From fa486f2e136a898d1b1548ec90757a78c65a0b70 Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Thu, 16 Sep 2021 23:03:12 +0200 Subject: JWK: document it, and use GOOPS --- src/scm/webid-oidc/client/accounts.scm | 14 +- src/scm/webid-oidc/client/client.scm | 8 +- src/scm/webid-oidc/dpop-proof.scm | 21 +- src/scm/webid-oidc/example-app.scm | 1 - src/scm/webid-oidc/identity-provider.scm | 10 +- src/scm/webid-oidc/jwk.scm | 468 ++++++++++++++++++++---------- src/scm/webid-oidc/jws.scm | 24 +- src/scm/webid-oidc/oidc-configuration.scm | 8 +- 8 files changed, 372 insertions(+), 182 deletions(-) (limited to 'src/scm/webid-oidc') diff --git a/src/scm/webid-oidc/client/accounts.scm b/src/scm/webid-oidc/client/accounts.scm index 626cc6a..54c6e07 100644 --- a/src/scm/webid-oidc/client/accounts.scm +++ b/src/scm/webid-oidc/client/accounts.scm @@ -26,6 +26,7 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-19) #:use-module (webid-oidc errors) + #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc oidc-id-token) #:prefix id:) @@ -85,12 +86,7 @@ ) #:declarative? #t) -(define (G_ text) - (let ((out (gettext text))) - (if (string=? out text) - ;; No translation, disambiguate - (car (reverse (string-split text #\|))) - out))) +(define jwk:) ;; This exception is continuable! Continue with the authorization ;; code. @@ -159,7 +155,7 @@ (define-method (->sexp (account )) `(begin - (use-modules (oop goops) (webid-oidc client accounts)) + (use-modules (oop goops) (webid-oidc client accounts) (webid-oidc jwk)) (make #:subject ,(uri->string (subject account)) #:issuer ,(uri->string (issuer account)) @@ -175,7 +171,7 @@ (if refresh-token `(#:refresh-token ,refresh-token) '())) - #:key-pair (quote ,(key-pair account))))) + #:key-pair (jwk->key (quote ,(key->jwk (key-pair account))))))) (define-method (write (account ) port) (let ((code (->sexp account))) @@ -496,7 +492,7 @@ (slot-set! ret 'refresh-token refresh-token) ret)) -(define-method (set-key-pair (a ) key-pair) +(define-method (set-key-pair (a ) (key-pair )) (let ((ret (shallow-clone a))) (slot-set! ret 'key-pair key-pair) ret)) diff --git a/src/scm/webid-oidc/client/client.scm b/src/scm/webid-oidc/client/client.scm index 1bf1c7c..5da701b 100644 --- a/src/scm/webid-oidc/client/client.scm +++ b/src/scm/webid-oidc/client/client.scm @@ -58,6 +58,8 @@ ) #:declarative? #t) +(define jwk:) + (define-class () (client-id #:init-keyword #:client-id #:getter client-id) (key-pair #:init-keyword #:key-pair #:getter client-key-pair) @@ -65,10 +67,10 @@ (define-method (->sexp (client )) `(begin - (use-modules (oop goops) (webid-oidc client)) + (use-modules (oop goops) (webid-oidc client) (webid-oidc jwk)) (make #:client-id ,(uri->string (client-id client)) - #:key-pair (quote ,(client-key-pair client)) + #:key-pair (jwk->key (quote ,(key->jwk (client-key-pair client)))) #:redirect-uri ,(uri->string (client-redirect-uri client))))) (define-method (write (client ) port) @@ -92,7 +94,7 @@ (match `(,client-id ,key-pair ,redirect-uri) (((or (? string? (= string->uri (? uri? client-id))) (? uri? client-id)) - (? jwk:jwk? client-key) + (? (cute is-a? <> ) client-key) (or (? string? (= string->uri (? uri? redirect-uri))) (? uri? redirect-uri))) (begin diff --git a/src/scm/webid-oidc/dpop-proof.scm b/src/scm/webid-oidc/dpop-proof.scm index cc756d3..5e01235 100644 --- a/src/scm/webid-oidc/dpop-proof.scm +++ b/src/scm/webid-oidc/dpop-proof.scm @@ -28,6 +28,7 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) + #:use-module (oop goops) #:declarative? #t #:export ( @@ -81,6 +82,10 @@ make-invalid-dpop-proof invalid-dpop-proof?) +(define (parse-jwk data) + (false-if-exception + (jwk->key data))) + (define (the-dpop-proof x) (with-exception-handler (lambda (error) @@ -131,7 +136,7 @@ ,@(if iat '() '("iat")))))) `(((alg . ,(symbol->string alg)) (typ . "dpop+jwt") - (jwk . ,(strip jwk)) + (jwk . ,(key->jwk (public-key jwk))) ,@other-header-fields) . ((jti . ,jti) (htm . ,(symbol->string htm)) @@ -188,9 +193,11 @@ ((('typ . incorrect) header ...) (fail (format #f (G_ "the \"typ\" field should be \"dpop+jwt\", not ~s") incorrect))) - ((('jwk . (? jwk-public? given-jwk)) header ...) - (examine-header header alg typ (or jwk (the-public-jwk given-jwk)) + ((('jwk . (= parse-jwk (? (cute is-a? <> ) given-jwk))) header ...) + (examine-header header alg typ (or jwk given-jwk) other-header-fields)) + ((('jwk . (= parse-jwk (? (cute is-a? <> ) given-jwk))) header ...) + (fail (format #f (G_ "the \"jwk\" field should not contain the private key")))) ((('jwk . incorrect) header ...) (fail (format #f (G_ "the \"jwk\" field should be a valid public key, not ~s") incorrect))) @@ -213,7 +220,7 @@ (define (dpop-proof-jwk proof) (match (the-dpop-proof proof) ((header . _) - (the-public-jwk (assq-ref header 'jwk))))) + (jwk->key (assq-ref header 'jwk))))) (define (dpop-proof-jti proof) (match (the-dpop-proof proof) @@ -356,7 +363,7 @@ (make-dpop-invalid-ath (dpop-proof-ath decoded) access-token) (make-exception-with-message final-message))))))) (if (string? cnf/check) - (unless (equal? cnf/check (stubs:jkt (dpop-proof-jwk decoded))) + (unless (equal? cnf/check (jkt (dpop-proof-jwk decoded))) (let ((final-message (format #f (G_ "the DPoP proof is signed with the wrong key")))) (raise-exception @@ -376,7 +383,7 @@ (make-exception-with-message final-message) error)))) (lambda () - (unless (cnf/check (stubs:jkt (dpop-proof-jwk decoded))) + (unless (cnf/check (jkt (dpop-proof-jwk decoded))) ;; You should throw an error instead! (fail (G_ "the cnf/check function returned #f")))))) (parameterize ((p:current-date current-date)) @@ -410,7 +417,7 @@ (the-dpop-proof `(((alg . ,(symbol->string alg)) (typ . "dpop+jwt") - (jwk . ,client-key)) + (jwk . ,(key->jwk (public-key client-key)))) . ((jti . ,(stubs:random 12)) (htm . ,(symbol->string htm)) (htu . ,(uri->string htu)) diff --git a/src/scm/webid-oidc/example-app.scm b/src/scm/webid-oidc/example-app.scm index 9bf99c1..c293d69 100644 --- a/src/scm/webid-oidc/example-app.scm +++ b/src/scm/webid-oidc/example-app.scm @@ -23,7 +23,6 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) #:use-module ((webid-oidc config) #:prefix cfg:) - #:use-module ((webid-oidc jwk) #:prefix jwk:) #:use-module (web uri) #:use-module (web client) #:use-module (web request) diff --git a/src/scm/webid-oidc/identity-provider.scm b/src/scm/webid-oidc/identity-provider.scm index 7f1fb48..cf06b62 100644 --- a/src/scm/webid-oidc/identity-provider.scm +++ b/src/scm/webid-oidc/identity-provider.scm @@ -41,6 +41,7 @@ #:use-module (sxml match) #:use-module (srfi srfi-19) #:use-module (rnrs bytevectors) + #:use-module (oop goops) #:declarative? #t #:export ( @@ -66,7 +67,10 @@ (let ((key (catch #t (lambda () - (call-with-input-file key-file stubs:json->scm)) + (call-with-input-file key-file + (lambda (port) + (jwk->key + (stubs:json->scm port))))) (lambda error (format (current-error-port) (G_ "Warning: generating a new key pair.")) @@ -74,7 +78,7 @@ (stubs:call-with-output-file* key-file (lambda (port) - (stubs:scm->json k port #:pretty #t))) + (stubs:scm->json (key->jwk k) port #:pretty #t))) k))))) (let ((alg (if (eq? (kty key) 'RSA) @@ -109,7 +113,7 @@ (exp-sec (+ current-sec 3600)) (exp (time-utc->date (make-time time-utc 0 exp-sec)))) - (serve-jwks exp (make-jwks (list key))))) + (serve (make #:keys (list key)) exp))) ((same-uri? uri authorization-endpoint-uri #:skip-query #t) (authorization-endpoint request request-body)) ((same-uri? uri token-endpoint-uri) diff --git a/src/scm/webid-oidc/jwk.scm b/src/scm/webid-oidc/jwk.scm index e4f2119..7675d04 100644 --- a/src/scm/webid-oidc/jwk.scm +++ b/src/scm/webid-oidc/jwk.scm @@ -25,26 +25,28 @@ #:use-module (web response) #:use-module (web client) #:use-module (rnrs bytevectors) + #:use-module (oop goops) #:declarative? #t #:export ( - the-jwk - jwk? + + + public-key private-key + + + rsa-d rsa-p rsa-q rsa-dp rsa-dq rsa-qi + rsa-n rsa-e + ec-crv ec-x ec-y + ec-z + keys + + check-key + key->jwk + jwk->key kty - the-public-jwk - jwk-public? - strip jkt - make-rsa-public-key - make-rsa-private-key - make-ec-point - make-ec-scalar generate-key - the-jwks - jwks? - make-jwks - jwks-keys - serve-jwks + serve get-jwks ¬-a-jwk @@ -68,7 +70,165 @@ make-not-a-jwks not-a-jwks?) -(define (the-jwk x) +(define-class ()) + +(define-class ()) + +(define-class () + (public-key #:init-keyword #:public-key #:accessor public-key) + (private-key #:init-keyword #:private-key #:accessor private-key)) + +(define-class ()) + +(define-class () + (crv #:init-keyword #:crv #:accessor ec-crv)) + +(define-class () + (d #:init-keyword #:d #:accessor rsa-d) + (p #:init-keyword #:p #:accessor rsa-p) + (q #:init-keyword #:q #:accessor rsa-q) + (dp #:init-keyword #:dp #:accessor rsa-dp) + (dq #:init-keyword #:dq #:accessor rsa-dq) + (qi #:init-keyword #:qi #:accessor rsa-qi)) + +(define-class () + (n #:init-keyword #:n #:accessor rsa-n) + (e #:init-keyword #:e #:accessor rsa-e)) + +(define-class () + (crv #:init-keyword #:crv #:accessor ec-crv) + (z #:init-keyword #:z #:accessor ec-z)) + +(define-class () + (crv #:init-keyword #:crv #:accessor ec-crv) + (x #:init-keyword #:x #:accessor ec-x) + (y #:init-keyword #:y #:accessor ec-y)) + +(define-method (initialize-key-pair (key ) (public ) (private )) + (set! (public-key key) public) + (set! (private-key key) private)) + +(define-method (initialize-key-pair (key ) (public ) (private )) + (set! (public-key key) public) + (set! (private-key key) private)) + +(define-method (initialize (key ) initargs) + (next-method) + (let-keywords + initargs #t + ((public-key #f) + (private-key #f)) + (initialize-key-pair key public-key private-key)) + (check-key key)) + +(define-method (initialize-rsa-key-pair (key ) (public ) (private )) + #t) + +(define-method (initialize (key ) initargs) + (next-method) + (let-keywords + initargs #t + ((public-key #f) + (private-key #f)) + (initialize-rsa-key-pair key public-key private-key)) + (check-key key)) + +(define-method (initialize-ec-key-pair (key ) (public ) (private )) + (unless (eq? (ec-crv public) (ec-crv private)) + (raise-exception + (make-exception + (make-not-a-jwk) + (make-exception-with-message (G_ "the point and scalar are not on the same curve"))))) + (set! (ec-crv key) (ec-crv public))) + +(define-method (initialize (key ) initargs) + (next-method) + (let-keywords + initargs #t + ((public-key #f) + (private-key #f)) + (initialize-ec-key-pair key public-key private-key) + (check-key key))) + +(define-method (initialize (key ) initargs) + (next-method) + (check-key key)) + +(define-method (initialize (key ) initargs) + (next-method) + (check-key key)) + +(define-method (initialize (key ) initargs) + (next-method) + (check-key key)) + +(define-method (initialize (key ) initargs) + (next-method) + (check-key key)) + +(define-method (rsa-d (key )) + (rsa-d (private-key key))) + +(define-method (rsa-p (key )) + (rsa-p (private-key key))) + +(define-method (rsa-q (key )) + (rsa-q (private-key key))) + +(define-method (rsa-dp (key )) + (rsa-dp (private-key key))) + +(define-method (rsa-dq (key )) + (rsa-dq (private-key key))) + +(define-method (rsa-qi (key )) + (rsa-qi (private-key key))) + +(define-method (rsa-n (key )) + (rsa-n (public-key key))) + +(define-method (rsa-e (key )) + (rsa-e (public-key key))) + +(define-method (ec-x (key )) + (ec-x (public-key key))) + +(define-method (ec-y (key )) + (ec-y (public-key key))) + +(define-method (ec-z (key )) + (ec-z (private-key key))) + +(define-method (equal? (x ) (y )) + (and (equal? (public-key x) (public-key y)) + (equal? (private-key x) (private-key y)))) + +(define-method (equal? (x ) (y )) + #f) + +(define-method (equal? (x ) (y )) + #f) + +(define-method (equal? (x ) (y )) + (and (equal? (rsa-n x) (rsa-n y)) + (equal? (rsa-e x) (rsa-e y)))) + +(define-method (equal? (x ) (y )) + (and (equal? (rsa-d x) (rsa-d y)) + (equal? (rsa-p x) (rsa-p y)) + (equal? (rsa-q x) (rsa-q y)) + (equal? (rsa-dp x) (rsa-dp y)) + (equal? (rsa-dq x) (rsa-dq y)) + (equal? (rsa-qi x) (rsa-qi y)))) + +(define-method (equal? (x ) (y )) + (and (equal? (ec-x x) (ec-x y)) + (equal? (ec-y x) (ec-y y)))) + +(define-method (equal? (x ) (y )) + (equal? (ec-z x) (ec-z y))) + +(define (check-and-kty key) (with-exception-handler (lambda (error) (let ((final-message @@ -82,150 +242,156 @@ (make-exception-with-message final-message) error)))) (lambda () - (let ((kty (stubs:kty x))) - (unless (or (eq? kty 'EC) (eq? kty 'RSA)) - (fail (format #f (G_ "unknown key type ~s") - kty))) - x)))) + (let ((kty (stubs:kty (key->jwk key)))) + (unless kty + (fail (G_ "cannot compute the key type"))) + kty)))) -(define (jwk? x) - (false-if-exception - (and (the-jwk x) #t))) +(define-method (key->jwk (key )) + (append (key->jwk (public-key key)) + (key->jwk (private-key key)))) -(define (kty x) - (stubs:kty (the-jwk x))) +(define-method (key->jwk (key )) + `((d . ,(rsa-d key)) + (p . ,(rsa-p key)) + (q . ,(rsa-q key)) + (dp . ,(rsa-dp key)) + (dq . ,(rsa-dq key)) + (qi . ,(rsa-qi key)))) -(define (the-public-jwk x) - (with-exception-handler - (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "the public JWK is invalid: ~a") - (exception-message error)) - (format #f (G_ "the public JWK is invalid"))))) - (raise-exception - (make-exception - (make-not-a-jwk) - (make-exception-with-message final-message) - error)))) - (lambda () - (let ((key (the-jwk x))) - (let ((crv (assq-ref key 'crv)) - (x (assq-ref key 'x)) - (y (assq-ref key 'y)) - (n (assq-ref key 'n)) - (e (assq-ref key 'e))) - (let ((ec-part `((crv . ,crv) - (x . ,x) - (y . ,y))) - (rsa-part `((n . ,n) - (e . ,e)))) - (case (stubs:kty key) - ((EC) ec-part) - ((RSA) rsa-part)))))))) - -(define (jwk-public? key) - (false-if-exception - (and (the-public-jwk key) #t))) - -(define (strip key) - (with-exception-handler - (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "cannot extract the public part of the key: ~a") - (exception-message error)) - (format #f (G_ "cannot extract the public part of the key"))))) - (raise-exception - (make-exception - (make-not-a-jwk) - (make-exception-with-message final-message) - error)))) - (lambda () - (stubs:strip-key key)))) +(define-method (key->jwk (key )) + `((n . ,(rsa-n key)) + (e . ,(rsa-e key)))) + +(define-method (key->jwk (key )) + `((crv . ,(symbol->string (ec-crv key))) + (x . ,(ec-x key)) + (y . ,(ec-y key)))) + +(define-method (key->jwk (key )) + `((crv . ,(symbol->string (ec-crv key))) + (z . ,(ec-z key)))) + +(define-method (check-key key) + (check-and-kty (key->jwk key))) + +(define (check-rsa-key key) + (unless (eq? (check-and-kty key) 'RSA) + (raise-exception + (make-exception + (make-not-a-jwk) + (make-exception-with-message + (format #f (G_ "it is built as an RSA key or key pair, but it is not"))))))) + +(define (check-ec-key key) + (unless (eq? (check-and-kty key) 'EC) + (raise-exception + (make-exception + (make-not-a-jwk) + (make-exception-with-message + (format #f (G_ "it is built as an elliptic curve key or key pair, but it is not"))))))) + +(define-method (check-key (key )) + (check-rsa-key key)) + +(define-method (check-key (key )) + (check-rsa-key key)) + +(define-method (check-key (key )) + (check-rsa-key key)) + +(define-method (check-key (key )) + (check-ec-key key)) + +(define-method (check-key (key )) + (check-ec-key key)) + +(define-method (check-key (key )) + (check-ec-key key)) + +(define-method (kty (key )) 'RSA) +(define-method (kty (key )) 'RSA) +(define-method (kty (key )) 'RSA) + +(define-method (kty (key )) 'EC) +(define-method (kty (key )) 'EC) +(define-method (kty (key )) 'EC) + +(define-method (public-key (key )) + key) + +(define-method (private-key (key )) + key) + +(define (jwk->key fields) + (let ((kty (stubs:kty fields))) + (case kty + ((RSA) + (let ((d (assq-ref fields 'd)) + (p (assq-ref fields 'p)) + (q (assq-ref fields 'q)) + (dp (assq-ref fields 'dp)) + (dq (assq-ref fields 'dq)) + (qi (assq-ref fields 'qi)) + (n (assq-ref fields 'n)) + (e (assq-ref fields 'e))) + (let ((public + (and n e + (make #:n n #:e e))) + (private + (and d p q dp dq qi + (make #:d d #:p p #:q q #:dp dp #:dq dq #:qi qi)))) + (if (and public private) + (make #:public-key public #:private-key private) + (or public private))))) + ((EC) + (let ((crv (string->symbol (assq-ref fields 'crv))) + (x (assq-ref fields 'x)) + (y (assq-ref fields 'y)) + (z (assq-ref fields 'z))) + (let ((public + (and x y + (make #:crv crv #:x x #:y y))) + (private + (and z + (make #:crv crv #:z z)))) + (if (and public private) + (make #:public-key public #:private-key private) + (or public private))))) + (else + (raise-exception + (make-exception + (make-not-a-jwk) + (make-exception-with-message (G_ "this is neither a RSA key nor an elliptic curve key")))))))) (define (jkt x) - (stubs:jkt (the-public-jwk x))) - -(define (make-rsa-public-key n e) - (the-public-jwk - `((n . ,n) - (e . ,e)))) - -(define (make-rsa-private-key d p q dp dq qi) - (the-jwk - `((d . ,d) - (p . ,p) - (q . ,q) - (dp . ,dp) - (dq . ,dq) - (qi . ,qi)))) - -(define (make-ec-point crv x y) - (if (symbol? crv) - (make-ec-point (symbol->string crv) x y) - (the-public-jwk - `((crv . ,crv) - (x . ,x) - (y . ,y))))) - -(define (make-ec-scalar crv d) - (if (symbol? crv) - (make-ec-scalar (symbol->string crv) d) - (the-jwk - `((crv . ,crv) - (d . ,d))))) - -(define generate-key stubs:generate-key) - -(define (the-public-keys keys) - (map the-public-jwk keys)) - -(define (the-jwks jwks) - (let ((keys (vector->list (assoc-ref jwks 'keys)))) - (unless keys - (let ((final-message - (format #f (G_ "the JWKS is invalid, because it does not have keys")))) - (raise-exception - (make-exception - (make-not-a-jwks) - (make-exception-with-message final-message))))) - (with-exception-handler - (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "the JWKS is invalid: ~a") - (exception-message error)) - (format #f (G_ "the JWKS is invalid"))))) - (raise-exception - (make-exception - (make-not-a-jwks) - (make-exception-with-message final-message) - error)))) - (lambda () - `((keys . ,(list->vector (the-public-keys keys)))))))) + (stubs:jkt (key->jwk x))) -(define (jwks? jwks) - (false-if-exception - (and (the-jwks jwks) #t))) +(define (generate-key . args) + (jwk->key (apply stubs:generate-key args))) -(define (make-jwks keys) - (if (vector? keys) - (make-jwks (vector->list keys)) - (let ((pubs (list->vector (map strip keys)))) - (the-jwks `((keys . ,pubs)))))) +(define-class () + (keys #:init-keyword #:keys #:accessor keys)) -(define (jwks-keys jwks) - (vector->list (assq-ref (the-jwks jwks) 'keys))) +(define-method (initialize (jwks ) initargs) + (next-method) + (let-keywords + initargs #t + ((keys '())) + (slot-set! jwks 'keys (map public-key keys)))) -(define (serve-jwks expiration-date jwks) - (values (build-response - #:headers `((content-type . (application/json)) - (expires . ,expiration-date))) - (stubs:scm->json-string (the-jwks jwks)))) +(define-method (serve (jwks ) expiration-date) + (values + (build-response + #:headers `((content-type . (application/json)) + (expires . ,expiration-date))) + (stubs:scm->json-string + `((keys + . ,(list->vector + (map key->jwk (keys jwks)))))))) -(define* (get-jwks uri #:key (http-get http-get)) - (receive (response response-body) (http-get uri) +(define* (get-jwks uri #:key (http-request http-request)) + (receive (response response-body) (http-request uri) (with-exception-handler (lambda (error) (raise-exception @@ -252,4 +418,6 @@ (fail (format #f (G_ "invalid content-type: ~s") content-type))) (unless (string? response-body) (set! response-body (utf8->string response-body))) - (the-jwks (stubs:json-string->scm response-body))))))) + (let ((data (stubs:json-string->scm response-body))) + (let ((keys (vector->list (assq-ref data 'keys)))) + (make #:keys (map jwk->key keys))))))))) diff --git a/src/scm/webid-oidc/jws.scm b/src/scm/webid-oidc/jws.scm index 24a8bbc..3e5e50b 100644 --- a/src/scm/webid-oidc/jws.scm +++ b/src/scm/webid-oidc/jws.scm @@ -23,6 +23,7 @@ #:use-module (ice-9 receive) #:use-module (ice-9 exceptions) #:use-module (ice-9 match) + #:use-module (oop goops) #:declarative? #t #:export ( @@ -228,10 +229,22 @@ error)))) (try-with-key keys)) (lambda () - (stubs:verify alg next-key payload signature)) + (stubs:verify alg (key->jwk next-key) payload signature)) #:unwind? #t #:unwind-for-type stubs:&invalid-signature))))) +;; For verification, we can supply a JWKS, or a public key, or a list +;; of public keys. The JWKS case is handled in (webid-oidc jwk). + +(define-method (keys (key )) + (list key)) + +(define-method (keys (key )) + (list (public-key key))) + +(define-method (keys (keys )) + (map public-key keys)) + (define (jws-decode str lookup-keys) (with-exception-handler (lambda (error) @@ -248,11 +261,8 @@ (lambda () (parse str (lambda (jws payload signature) - (let ((keys (lookup-keys jws))) - (let ((keys (cond ((jwk? keys) (list keys)) - ((jwks? keys) (jwks-keys keys)) - (else keys)))) - (verify-any (jws-alg jws) keys payload signature)))))))) + (let ((k (keys (lookup-keys jws)))) + (verify-any (jws-alg jws) k payload signature))))))) (define (jws-encode jws key) (with-exception-handler @@ -275,5 +285,5 @@ (let ((header (stubs:base64-encode header)) (payload (stubs:base64-encode payload))) (let ((payload (string-append header "." payload))) - (let ((signature (stubs:sign (jws-alg jws) key payload))) + (let ((signature (stubs:sign (jws-alg jws) (key->jwk key) payload))) (string-append payload "." signature)))))))))) diff --git a/src/scm/webid-oidc/oidc-configuration.scm b/src/scm/webid-oidc/oidc-configuration.scm index d9aab84..2233d95 100644 --- a/src/scm/webid-oidc/oidc-configuration.scm +++ b/src/scm/webid-oidc/oidc-configuration.scm @@ -141,8 +141,12 @@ (define oidc-configuration-token-endpoint (uri-field 'token_endpoint)) -(define (oidc-configuration-jwks cfg . args) - (apply get-jwks (oidc-configuration-jwks-uri cfg) args)) +(define* (oidc-configuration-jwks cfg #:key (http-get http-get)) + (let ((http-request-for-get-jwks + (lambda* (uri #:key (method 'GET)) + (http-get uri)))) + (get-jwks (oidc-configuration-jwks-uri cfg) + #:http-request http-request-for-get-jwks))) (define (serve-oidc-configuration expiration-date cfg) (values (build-response #:headers `((content-type . (application/json)) -- cgit v1.2.3