From 0dfaa2a0a9f9772557b06ca7542d4c1b915d7b0c Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Mon, 30 Nov 2020 21:39:32 +0100 Subject: Implement the DPoP proof --- src/scm/webid-oidc/Makefile.am | 8 +- src/scm/webid-oidc/dpop-proof.scm | 217 +++++++++++++++++++++++++++++ src/scm/webid-oidc/errors.scm | 283 ++++++++++++++++++++++++++++++++++---- src/scm/webid-oidc/jti.scm | 34 +++++ 4 files changed, 516 insertions(+), 26 deletions(-) create mode 100644 src/scm/webid-oidc/dpop-proof.scm create mode 100644 src/scm/webid-oidc/jti.scm (limited to 'src/scm/webid-oidc') diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index a63fa89..ecb3f0a 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -6,7 +6,9 @@ dist_webidoidcmod_DATA += \ %reldir%/jws.scm \ %reldir%/cache.scm \ %reldir%/oidc-configuration.scm \ - %reldir%/access-token.scm + %reldir%/access-token.scm \ + %reldir%/jti.scm \ + %reldir%/dpop-proof.scm webidoidcgo_DATA += \ %reldir%/errors.go \ %reldir%/stubs.go \ @@ -15,4 +17,6 @@ webidoidcgo_DATA += \ %reldir%/jws.go \ %reldir%/cache.go \ %reldir%/oidc-configuration.go \ - %reldir%/access-token.go + %reldir%/access-token.go \ + %reldir%/jti.go \ + %reldir%/dpop-proof.go diff --git a/src/scm/webid-oidc/dpop-proof.scm b/src/scm/webid-oidc/dpop-proof.scm new file mode 100644 index 0000000..89c78af --- /dev/null +++ b/src/scm/webid-oidc/dpop-proof.scm @@ -0,0 +1,217 @@ +(define-module (webid-oidc dpop-proof) + #:use-module (webid-oidc jws) + #:use-module (webid-oidc errors) + #:use-module (webid-oidc jwk) + #:use-module (webid-oidc jti) + #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module (web uri) + #:use-module (ice-9 optargs) + #:use-module (srfi srfi-19)) + +(define-public (the-dpop-proof-header x) + (with-exception-handler + (lambda (error) + (raise-not-a-dpop-proof-header x error)) + (lambda () + (let ((x (the-jws-header x))) + (let ((alg (assq-ref x 'alg)) + (typ (assq-ref x 'typ)) + (jwk (assq-ref x 'jwk))) + (unless (and alg (string? alg)) + (raise-unsupported-alg alg)) + (case (string->symbol alg) + ((RS256 RS384 RS512 ES256 ES384 ES512 PS256 PS384 PS512) + #t) + (else + (raise-unsupported-alg alg))) + (unless (equal? typ "dpop+jwt") + (raise-incorrect-typ-field typ)) + (with-exception-handler + (lambda (error) + (raise-incorrect-jwk-field jwk error)) + (lambda () + (the-public-jwk jwk))) + x))))) + +(define-public (dpop-proof-header? x) + (false-if-exception + (and (the-dpop-proof-header x) #t))) + +(define-public (the-dpop-proof-payload x) + (with-exception-handler + (lambda (error) + (raise-not-a-dpop-proof-payload x error)) + (lambda () + (let ((x (the-jws-payload x))) + (let ((jti (assq-ref x 'jti)) + (htm (assq-ref x 'htm)) + (htu (assq-ref x 'htu)) + (iat (assq-ref x 'iat))) + (unless (and jti (string? jti)) + (raise-incorrect-jti-field jti)) + (unless (and htm (string? htm)) + (raise-incorrect-htm-field htm)) + (unless (and htu (string? htu) (string->uri htu)) + (raise-incorrect-htu-field htu)) + (unless (and iat (integer? iat)) + (raise-incorrect-iat-field iat)) + x))))) + +(define-public (dpop-proof-payload? x) + (false-if-exception + (and (the-dpop-proof-payload x) #t))) + +(define-public (the-dpop-proof x) + (with-exception-handler + (lambda (error) + (raise-not-a-dpop-proof x error)) + (lambda () + (cons (the-dpop-proof-header (car x)) + (the-dpop-proof-payload (cdr x)))))) + +(define-public (dpop-proof? x) + (false-if-exception + (and (the-dpop-proof x) #t))) + +(define-public (make-dpop-proof header payload) + (the-dpop-proof (cons header payload))) + +(define-public (make-dpop-proof-header alg jwk) + (when (symbol? alg) + (set! alg (symbol->string alg))) + (the-dpop-proof-header + `((alg . ,alg) + (typ . "dpop+jwt") + (jwk . ,(stubs:strip-key jwk))))) + +(define-public (make-dpop-proof-payload jti htm htu iat) + (when (symbol? htm) + (set! htm (symbol->string htm))) + (when (uri? htu) + (set! htu (uri->string htu))) + (when (date? iat) + (set! iat (date->time-utc iat))) + (when (time? iat) + (set! iat (time-second iat))) + (the-dpop-proof-payload + `((jti . ,jti) + (htm . ,htm) + (htu . ,htu) + (iat . ,iat)))) + +(define-public (dpop-proof-header dpop) + (car (the-dpop-proof dpop))) + +(define-public (dpop-proof-payload dpop) + (cdr (the-dpop-proof dpop))) + +(define-public (dpop-proof-alg code) + (when (dpop-proof? code) + (set! code (dpop-proof-header code))) + (jws-alg (the-dpop-proof-header code))) + +(define-public (dpop-proof-jwk dpop) + (when (dpop-proof? dpop) + (set! dpop (dpop-proof-header dpop))) + (assq-ref (the-dpop-proof-header dpop) 'jwk)) + +(define-public (dpop-proof-jti dpop) + (when (dpop-proof? dpop) + (set! dpop (dpop-proof-payload dpop))) + (assq-ref (the-dpop-proof-payload dpop) 'jti)) + +(define-public (dpop-proof-htm dpop) + (when (dpop-proof? dpop) + (set! dpop (dpop-proof-payload dpop))) + (string->symbol + (assq-ref (the-dpop-proof-payload dpop) + 'htm))) + +(define-public (dpop-proof-htu dpop) + (when (dpop-proof? dpop) + (set! dpop (dpop-proof-payload dpop))) + (string->uri + (assq-ref (the-dpop-proof-payload dpop) + 'htu))) + +(define-public (dpop-proof-iat dpop) + (when (dpop-proof? dpop) + (set! dpop (dpop-proof-payload dpop))) + (time-utc->date + (make-time time-utc + 0 + (assq-ref (the-dpop-proof-payload dpop) + 'iat)))) + +(define (uris-compatible a b) + ;; a is what is signed, b is the request + (unless + (and (eq? (uri-scheme a) + (uri-scheme b)) + (equal? (uri-userinfo a) + (uri-userinfo b)) + (equal? (uri-port a) + (uri-port b)) + (equal? (split-and-decode-uri-path + (uri-path a)) + (split-and-decode-uri-path + (uri-path b)))) + (raise-dpop-uri-mismatch a b))) + +(define-public (dpop-proof-decode current-time jti-list method uri str cnf/check) + (when (date? current-time) + (set! current-time (date->time-utc current-time))) + (when (time? current-time) + (set! current-time (time-second current-time))) + (with-exception-handler + (lambda (error) + (raise-cannot-decode-dpop-proof str error)) + (lambda () + (let ((decoded (the-dpop-proof (jws-decode str dpop-proof-jwk)))) + (unless (eq? method (dpop-proof-htm decoded)) + (raise-dpop-method-mismatch (dpop-proof-htm decoded) method)) + (uris-compatible (dpop-proof-htu decoded) + (if (string? uri) + (string->uri uri) + uri)) + (let ((iat (time-second (date->time-utc (dpop-proof-iat decoded))))) + (unless (>= current-time (- iat 5)) + (raise-dpop-signed-in-future iat current-time)) + (unless (<= current-time (+ iat 120)) ;; Valid for 2 min + (raise-dpop-too-old iat current-time))) + (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)) + (with-exception-handler + (lambda (error) + (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) #f error)) + (lambda () + (unless (cnf/check (stubs:jkt (dpop-proof-jwk decoded))) + ;; deprecated; throw an error instead! + (error "the cnf/check function returned #f"))))) + (unless (jti-check current-time (dpop-proof-jti decoded) jti-list 120) + (with-exception-handler + (lambda (error) + (raise-jti-found (dpop-proof-jti decoded) error)) + (lambda () + (error "the jti-check function returned #f")))) + decoded)))) + +(define-public (dpop-proof-encode dpop-proof key) + (with-exception-handler + (lambda (error) + (raise-cannot-encode-dpop-proof dpop-proof key error)) + (lambda () + (jws-encode dpop-proof key)))) + +(define*-public (issue-dpop-proof + client-key + #:key + (alg #f) + (htm #f) + (htu #f) + (iat #f)) + (dpop-proof-encode + (make-dpop-proof (make-dpop-proof-header alg client-key) + (make-dpop-proof-payload (stubs:random 12) htm htu iat)) + client-key)) diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index 50d526c..959b04e 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -3,6 +3,8 @@ #:use-module (ice-9 exceptions) #:use-module (ice-9 optargs) #:use-module (ice-9 i18n) + #:use-module (srfi srfi-19) + #:use-module (web uri) #:use-module (web response)) (define (G_ text) @@ -297,6 +299,56 @@ (raise-exception ((record-constructor &incorrect-client-id-field) value))) +(define-public &incorrect-typ-field + (make-exception-type + '&incorrect-typ-field + &external-error + '(value))) + +(define-public (raise-incorrect-typ-field value) + (raise-exception + ((record-constructor &incorrect-typ-field) value))) + +(define-public &incorrect-jwk-field + (make-exception-type + '&incorrect-jwk-field + &external-error + '(value cause))) + +(define-public (raise-incorrect-jwk-field value cause) + (raise-exception + ((record-constructor &incorrect-jwk-field) value cause))) + +(define-public &incorrect-jti-field + (make-exception-type + '&incorrect-jti-field + &external-error + '(value))) + +(define-public (raise-incorrect-jti-field value) + (raise-exception + ((record-constructor &incorrect-jti-field) value))) + +(define-public &incorrect-htm-field + (make-exception-type + '&incorrect-htm-field + &external-error + '(value))) + +(define-public (raise-incorrect-htm-field value) + (raise-exception + ((record-constructor &incorrect-htm-field) value))) + +(define-public &incorrect-htu-field + (make-exception-type + '&incorrect-htu-field + &external-error + '(value))) + +(define-public (raise-incorrect-htu-field value) + (raise-exception + ((record-constructor &incorrect-htu-field) value))) + (define-public ¬-an-access-token (make-exception-type '¬-an-access-token @@ -327,6 +379,36 @@ (raise-exception ((record-constructor ¬-an-access-token-payload) value cause))) +(define-public ¬-a-dpop-proof + (make-exception-type + '¬-a-dpop-proof + &external-error + '(value cause))) + +(define-public (raise-not-a-dpop-proof value cause) + (raise-exception + ((record-constructor ¬-a-dpop-proof) value cause))) + +(define-public ¬-a-dpop-proof-header + (make-exception-type + '¬-a-dpop-proof-header + &external-error + '(value cause))) + +(define-public (raise-not-a-dpop-proof-header value cause) + (raise-exception + ((record-constructor ¬-a-dpop-proof-header) value cause))) + +(define-public ¬-a-dpop-proof-payload + (make-exception-type + '¬-a-dpop-proof-payload + &external-error + '(value cause))) + +(define-public (raise-not-a-dpop-proof-payload value cause) + (raise-exception + ((record-constructor ¬-a-dpop-proof-payload) value cause))) + (define-public &cannot-fetch-issuer-configuration (make-exception-type '&cannot-fetch-issuer-configuration @@ -347,6 +429,66 @@ (raise-exception ((record-constructor &cannot-fetch-jwks) issuer uri cause))) +(define-public &dpop-method-mismatch + (make-exception-type + '&dpop-method-mismatch + &external-error + '(signed requested))) + +(define-public (raise-dpop-method-mismatch signed requested) + (raise-exception + ((record-constructor &dpop-method-mismatch) signed requested))) + +(define-public &dpop-uri-mismatch + (make-exception-type + '&dpop-uri-mismatch + &external-error + '(signed requested))) + +(define-public (raise-dpop-uri-mismatch signed requested) + (raise-exception + ((record-constructor &dpop-uri-mismatch) signed requested))) + +(define-public &dpop-signed-in-future + (make-exception-type + '&dpop-signed-in-future + &external-error + '(signed requested))) + +(define-public (raise-dpop-signed-in-future signed requested) + (raise-exception + ((record-constructor &dpop-signed-in-future) signed requested))) + +(define-public &dpop-too-old + (make-exception-type + '&dpop-too-old + &external-error + '(signed requested))) + +(define-public (raise-dpop-too-old signed requested) + (raise-exception + ((record-constructor &dpop-too-old) signed requested))) + +(define-public &dpop-unconfirmed-key + (make-exception-type + '&dpop-unconfirmed-key + &external-error + '(key expected cause))) + +(define-public (raise-dpop-unconfirmed-key key expected cause) + (raise-exception + ((record-constructor &dpop-unconfirmed-key) key expected cause))) + +(define-public &jti-found + (make-exception-type + '&jti-found + &external-error + '(jti cause))) + +(define-public (raise-jti-found jti cause) + (raise-exception + ((record-constructor &jti-found) jti cause))) + (define-public &cannot-decode-access-token (make-exception-type '&cannot-decode-access-token @@ -367,6 +509,26 @@ (raise-exception ((record-constructor &cannot-encode-access-token) access-token key cause))) +(define-public &cannot-decode-dpop-proof + (make-exception-type + '&cannot-decode-dpop-proof + &external-error + '(value cause))) + +(define-public (raise-cannot-decode-dpop-proof value cause) + (raise-exception + ((record-constructor &cannot-decode-dpop-proof) value cause))) + +(define-public &cannot-encode-dpop-proof + (make-exception-type + '&cannot-encode-dpop-proof + &external-error + '(dpop-proof key cause))) + +(define-public (raise-cannot-encode-dpop-proof dpop-proof key cause) + (raise-exception + ((record-constructor &cannot-encode-dpop-proof) dpop-proof key cause))) + (define*-public (error->str err #:key (max-depth #f)) (if (record? err) (let* ((type (record-type-descriptor err)) @@ -497,39 +659,108 @@ (if value (format #f (G_ "the client-id field is incorrect: ~s") value) (format #f (G_ "the client-id field is missing"))))) + ((&incorrect-typ-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the typ field is incorrect: ~s") value) + (format #f (G_ "the typ field is missing"))))) + ((&incorrect-jwk-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the jwk field is incorrect: ~s (because ~a)") + value (recurse (get 'cause))) + (format #f (G_ "the jwk field is missing"))))) + ((&incorrect-jti-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the jti field is incorrect: ~s") value) + (format #f (G_ "the jti field is missing"))))) + ((&incorrect-htm-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the htm field is incorrect: ~s") value) + (format #f (G_ "the htm field is missing"))))) + ((&incorrect-htu-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the htu field is incorrect: ~s") value) + (format #f (G_ "the htu field is missing"))))) ((¬-an-access-token) - (format #f (G_ "~s is not an access token (because ~a)" - (get 'value) (recurse (get 'cause))))) + (format #f (G_ "~s is not an access token (because ~a)") + (get 'value) (recurse (get 'cause)))) ((¬-an-access-token-header) - (format #f (G_ "~s is not an access token header (because ~a)" - (get 'value) (recurse (get 'cause))))) + (format #f (G_ "~s is not an access token header (because ~a)") + (get 'value) (recurse (get 'cause)))) ((¬-an-access-token-payload) - (format #f (G_ "~s is not an access token payload (because ~a)" - (get 'value) (recurse (get 'cause))))) + (format #f (G_ "~s is not an access token payload (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-a-dpop-proof) + (format #f (G_ "~s is not a DPoP proof (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-a-dpop-proof-header) + (format #f (G_ "~s is not a DPoP proof header (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-a-dpop-proof-payload) + (format #f (G_ "~s is not a DPoP proof payload (because ~a)") + (get 'value) (recurse (get 'cause)))) ((&cannot-fetch-issuer-configuration) - (format #f (G_ "I cannot fetch the issuer configuration of ~a (because ~a)" - (let ((iss (get 'issuer))) - (when (uri? iss) - (set! iss (uri->string iss))) - iss) - (recurse (get 'cause))))) + (format #f (G_ "I cannot fetch the issuer configuration of ~a (because ~a)") + (let ((iss (get 'issuer))) + (when (uri? iss) + (set! iss (uri->string iss))) + iss) + (recurse (get 'cause)))) ((&cannot-fetch-jwks) - (format #f (G_ "I cannot fetch the JWKS of ~a at ~a (because ~a)" - (let ((iss (get 'issuer))) - (when (uri? iss) - (set! iss (uri->string iss))) - iss) - (let ((uri (get 'uri))) - (when (uri? uri) - (set! uri (uri->string uri))) - uri) - (recurse (get 'cause))))) + (format #f (G_ "I cannot fetch the JWKS of ~a at ~a (because ~a)") + (let ((iss (get 'issuer))) + (when (uri? iss) + (set! iss (uri->string iss))) + iss) + (let ((uri (get 'uri))) + (when (uri? uri) + (set! uri (uri->string uri))) + uri) + (recurse (get 'cause)))) + ((&dpop-method-mismatch) + (format #f (G_ "the HTTP method is signed for ~s, but ~s was requested") + (get 'signed) (get 'requested))) + ((&dpop-uri-mismatch) + (format #f (G_ "the HTTP uri is signed for ~a, but ~a was requested") + (uri->string (get 'signed)) (uri->string (get 'requested)))) + ((&dpop-signed-in-future) + (format #f (G_ "the date is ~a, but the DPoP proof is signed in the future at ~a") + (time-second (date->time-utc (get 'signed))) + (time-second (date->time-utc (get 'requested))))) + ((&dpop-too-old) + (format #f (G_ "the date is ~a, but the DPoP proof was signed too long ago at ~a") + (time-second (date->time-utc (get 'signed))) + (time-second (date->time-utc (get 'requested))))) + ((&dpop-unconfirmed-key) + (let ((key (get 'key)) + (expected (get 'expected)) + (cause (get 'cause))) + (cond + (expected + (format #f (G_ "the key ~s does not hash to ~a") key expected)) + (cause + (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))))) + ((&jti-found) + (format #f (G_ "the jti ~s has already been found (because ~a)") + (get 'jti) (recurse (get 'cause)))) ((&cannot-decode-access-token) - (format #f (G_ "I cannot decode ~s as an access token (because ~a)" - (get 'value) (recurse (get 'cause))))) + (format #f (G_ "I cannot decode ~s as an access token (because ~a)") + (get 'value) (recurse (get 'cause)))) ((&cannot-encode-access-token) (format #f (G_ "I cannot encode ~s as an access token with key ~s (because ~a)") (get 'access-token) (get 'key) (recurse (get 'cause)))) + ((&cannot-decode-dpop-proof) + (format #f (G_ "I cannot decode ~s as a DPoP proof (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((&cannot-encode-dpop-proof) + (format #f (G_ "I cannot encode ~s as a DPoP proof (because ~a)") + (get 'value) (recurse (get 'cause)))) ((&compound-exception) (let ((components (get 'components))) (if (null? components) @@ -564,6 +795,10 @@ ((&quit-exception) (format #f (G_ "the program quits with code ~a") (get 'code))) + ((&non-continuable) + (format #f (G_ "the program cannot recover from this exception"))) + ((&error) + (format #f (G_ "there is an error"))) (else (error (format #f (G_ "Unhandled exception type ~a.") (record-type-name type)))))) diff --git a/src/scm/webid-oidc/jti.scm b/src/scm/webid-oidc/jti.scm new file mode 100644 index 0000000..423382a --- /dev/null +++ b/src/scm/webid-oidc/jti.scm @@ -0,0 +1,34 @@ +(define-module (webid-oidc jti) + #:use-module (ice-9 atomic) + #:use-module (ice-9 threads) + #:use-module (srfi srfi-19)) + +(define-public (make-jti-list) + (make-atomic-box '())) + +(define-public (lookup list jti) + (if (null? list) + #f + (or (string=? (assq-ref (car list) 'jti) jti) + (lookup (cdr list) jti)))) + +(define-public (jti-check current-time jti list valid-time) + (when (date? current-time) + (set! current-time (date->time-utc current-time))) + (when (time? current-time) + (set! current-time (time-second current-time))) + (let* ((old (atomic-box-ref list)) + (new-entry `((exp . ,(+ current-time valid-time)) + (jti . ,jti))) + (new (filter + (lambda (entry) + (let ((exp (assq-ref entry 'exp))) + (>= exp current-time))) + (cons new-entry old)))) + (let ((present? (lookup old jti))) + (if present? + #f + (let ((discarded (atomic-box-compare-and-swap! list old new))) + (if (eq? discarded old) + #t + (jti-check current-time jti list valid-time))))))) -- cgit v1.2.3