From 4d9a10165a6c7bf8df6f86f032bf7b3412e83ae6 Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Thu, 22 Jul 2021 11:00:12 +0200 Subject: DPoP proof: support the "ath" claim --- src/scm/webid-oidc/client.scm | 3 ++- src/scm/webid-oidc/dpop-proof.scm | 34 +++++++++++++++++++++++------ src/scm/webid-oidc/errors.scm | 39 ++++++++++++++++++++++++++++++++++ src/scm/webid-oidc/resource-server.scm | 10 ++++----- 4 files changed, 74 insertions(+), 12 deletions(-) (limited to 'src') diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm index aea2b7e..30cbc75 100644 --- a/src/scm/webid-oidc/client.scm +++ b/src/scm/webid-oidc/client.scm @@ -455,7 +455,8 @@ (error "Unknown key type of ~S." key))) #:htm method #:htu uri - #:iat current-time))) + #:iat current-time + #:access-token access-token))) (receive (response response-body) (apply http-request uri #:method method diff --git a/src/scm/webid-oidc/dpop-proof.scm b/src/scm/webid-oidc/dpop-proof.scm index c716c33..54b338b 100644 --- a/src/scm/webid-oidc/dpop-proof.scm +++ b/src/scm/webid-oidc/dpop-proof.scm @@ -62,7 +62,8 @@ (let ((jti (assq-ref x 'jti)) (htm (assq-ref x 'htm)) (htu (assq-ref x 'htu)) - (iat (assq-ref x 'iat))) + (iat (assq-ref x 'iat)) + (ath (assq-ref x 'ath))) (unless (and jti (string? jti)) (raise-incorrect-jti-field jti)) (unless (and htm (string? htm)) @@ -71,6 +72,8 @@ (raise-incorrect-htu-field htu)) (unless (and iat (integer? iat)) (raise-incorrect-iat-field iat)) + (unless (or (not ath) (string? ath)) + (raise-incorrect-ath-field ath)) x))))) (define-public (dpop-proof-payload? x) @@ -100,7 +103,7 @@ (typ . "dpop+jwt") (jwk . ,(stubs:strip-key jwk))))) -(define-public (make-dpop-proof-payload jti htm htu iat) +(define-public (make-dpop-proof-payload jti htm htu iat ath) (when (symbol? htm) (set! htm (symbol->string htm))) (when (uri? htu) @@ -113,7 +116,10 @@ `((jti . ,jti) (htm . ,htm) (htu . ,htu) - (iat . ,iat)))) + (iat . ,iat) + ,@(if ath + `((ath . ,ath)) + '())))) (define-public (dpop-proof-header dpop) (car (the-dpop-proof dpop))) @@ -159,6 +165,12 @@ (assq-ref (the-dpop-proof-payload dpop) 'iat)))) +(define-public (dpop-proof-ath dpop) + (when (dpop-proof? dpop) + (set! dpop (dpop-proof-payload dpop))) + (assq-ref (the-dpop-proof-payload dpop) + 'ath)) + (define (uris-compatible a b) ;; a is what is signed, b is the request (unless @@ -174,7 +186,9 @@ (uri-path b)))) (raise-dpop-uri-mismatch a b))) -(define-public (dpop-proof-decode current-time jti-list method uri str cnf/check) +(define*-public (dpop-proof-decode current-time jti-list method uri str cnf/check + #:key + (access-token #f)) (when (date? current-time) (set! current-time (date->time-utc current-time))) (when (time? current-time) @@ -195,6 +209,11 @@ (raise-dpop-signed-in-future iat current-time)) (unless (<= current-time (+ iat 120)) ;; Valid for 2 min (raise-dpop-too-old iat current-time))) + (when access-token + (let ((h (stubs:hash 'SHA-256 access-token))) + (unless (equal? (dpop-proof-ath decoded) h) + (raise-exception + (make-dpop-invalid-access-token-hash (dpop-proof-ath decoded) access-token))))) (if (string? cnf/check) (unless (equal? cnf/check (stubs:jkt (dpop-proof-jwk decoded))) (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) cnf/check #f)) @@ -226,8 +245,11 @@ (alg #f) (htm #f) (htu #f) - (iat #f)) + (iat #f) + (access-token #f)) (dpop-proof-encode (make-dpop-proof (make-dpop-proof-header alg client-key) - (make-dpop-proof-payload (stubs:random 12) htm htu iat)) + (make-dpop-proof-payload (stubs:random 12) htm htu iat + (and access-token + (stubs:hash 'SHA-256 access-token)))) client-key)) diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index d494c7d..beccc35 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -401,6 +401,18 @@ &external-error '(value))) +(define-exception-type + &incorrect-ath-field + &external-error + make-incorrect-ath-field + incorrect-ath-field? + (value incorrect-ath-field-value)) + +(export &incorrect-ath-field + make-incorrect-ath-field + incorrect-ath-field? + incorrect-ath-field-value) + (define-public (raise-incorrect-htu-field value) (raise-exception ((record-constructor &incorrect-htu-field) value))) @@ -543,6 +555,20 @@ (raise-exception ((record-constructor &dpop-unconfirmed-key) key expected cause))) +(define-exception-type + &dpop-invalid-access-token-hash + &external-error + make-dpop-invalid-access-token-hash + dpop-invalid-access-token-hash? + (hash dpop-invalid-access-token-hash-hash) + (access-token dpop-invalid-access-token-hash-access-token)) + +(export &dpop-invalid-access-token-hash + make-dpop-invalid-access-token-hash + dpop-invalid-access-token-hash? + dpop-invalid-access-token-hash-hash + dpop-invalid-access-token-hash-access-token) + (define-public &jti-found (make-exception-type '&jti-found @@ -1227,6 +1253,11 @@ (if value (format #f (G_ "the htu field is incorrect: ~s") value) (format #f (G_ "the htu field is missing"))))) + ((&incorrect-ath-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the ath field is incorrect: ~s") value) + (format #f (G_ "the ath field is missing"))))) ((¬-an-access-token) (format #f (G_ "~s is not an access token (because ~a)") (get 'value) (recurse (get 'cause)))) @@ -1288,6 +1319,14 @@ (format #f (G_ "the key confirmation of ~s failed (because ~a)") key (recurse cause))) (else (format #f (G_ "the key confirmation of ~s failed") key))))) + ((&dpop-invalid-access-token-hash) + (let ((h (get 'hash)) + (at (get 'access-token))) + (if h + (format #f (G_ "the DPoP proof is bound to an access token with hash ~s, not ~s") + h at) + (format #f (G_ "the DPoP proof should be bound to the access token ~s") + at)))) ((&jti-found) (format #f (G_ "the jti ~s has already been found (because ~a)") (get 'jti) (recurse (get 'cause)))) diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm index a8e88f5..2d1c798 100644 --- a/src/scm/webid-oidc/resource-server.scm +++ b/src/scm/webid-oidc/resource-server.scm @@ -94,15 +94,15 @@ (error->str error)) #f) (lambda () - (let* ((access-token - (access-token-decode - (symbol->string (cadr authz)) - #:http-get http-get)) + (let* ((lit-access-token (symbol->string (cadr authz))) + (access-token + (access-token-decode lit-access-token + #:http-get http-get)) (cnf/jkt (access-token-cnf/jkt access-token)) (dpop-proof (dpop-proof-decode current-time jti-list method full-uri - dpop cnf/jkt))) + dpop cnf/jkt #:access-token lit-access-token))) (let ((subject (access-token-webid access-token)) (issuer (access-token-iss access-token))) (confirm-provider subject issuer #:http-get http-get) -- cgit v1.2.3