From dcba5fbd11bbc3cdbc0f7476536cb2a0ee34f48f Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Sun, 29 Nov 2020 18:53:17 +0100 Subject: Get a JWKS on the web --- src/scm/webid-oidc/errors.scm | 57 ++++++++++++++++++++++++++++++++++++++++--- src/scm/webid-oidc/jwk.scm | 41 +++++++++++++++++++++++++++---- 2 files changed, 89 insertions(+), 9 deletions(-) (limited to 'src') diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index e6c7a3e..1476e86 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -2,7 +2,8 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (ice-9 exceptions) #:use-module (ice-9 optargs) - #:use-module (ice-9 i18n)) + #:use-module (ice-9 i18n) + #:use-module (web response)) (define (G_ text) (let ((out (gettext text))) @@ -184,6 +185,38 @@ (raise-exception ((record-constructor &cannot-encode-jws) jws key cause))) +(define-public &request-failed-unexpectedly + (make-exception-type + '&request-failed-unexpectedly + &external-error + '(response-code response-reason-phrase))) + +(define-public (raise-request-failed-unexpectedly + response-code response-reason-phrase) + (raise-exception + ((record-constructor &request-failed-unexpectedly) + response-code response-reason-phrase))) + +(define-public &unexpected-header-value + (make-exception-type + '&unexpected-header-value + &external-error + '(header value))) + +(define-public (raise-unexpected-header-value header value) + (raise-exception + ((record-constructor &unexpected-header-value) header value))) + +(define-public &unexpected-response + (make-exception-type + '&unexpected-response + &external-error + '(response cause))) + +(define-public (raise-unexpected-response response cause) + (raise-exception + ((record-constructor &unexpected-response) response cause))) + (define*-public (error->str err #:key (max-depth #f)) (if (record? err) (let* ((type (record-type-descriptor err)) @@ -209,14 +242,14 @@ (let ((cause (get 'cause))) (if cause (format #f (G_ "the value ~s does not identify a JWK (because ~a)") - (get 'value) cause) + (get 'value) (recurse cause)) (format #f (G_ "the value ~s does not identify a JWK") (get 'value))))) ((¬-a-public-jwk) (let ((cause (get 'cause))) (if cause (format #f (G_ "the value ~s does not identify a public JWK (because ~a)") - (get 'value) cause) + (get 'value) (recurse cause)) (format #f (G_ "the value ~s does not identify a public JWK") (get 'value))))) ((¬-a-private-jwk) @@ -230,7 +263,7 @@ (let ((cause (get 'cause))) (if cause (format #f (G_ "the value ~s does not identify a JWKS (because ~a)") - (get 'value) cause) + (get 'value) (recurse cause)) (format #f (G_ "the value ~s does not identify a JWKS") (get 'value))))) ((&unsupported-alg) @@ -260,6 +293,22 @@ ((&cannot-encode-jws) (format #f (G_ "I cannot encode JWS ~a (because ~a)") (get 'value) (recurse (get 'cause)))) + ((&response-failed-unexpectedly) + (format #f (G_ "the server request unexpectedly failed with code ~a and reason phrase ~s") + (get 'response-code) (get 'response-reason-phrase))) + ((&unexpected-header-value) + (let ((value (get 'value))) + (if value + (format #f (G_ "the header ~a should not have the value ~s") + (get 'header) value) + (format #f (G_ "the header ~a should be present") + (get 'header))))) + ((&unexpected-response) + (format #f (G_ "the server response wasn't expected: ~s (because ~a)") + (call-with-output-string + (lambda (port) + (write-response (get 'response) port))) + (recurse (get 'cause)))) ((&compound-exception) (let ((components (get 'components))) (if (null? components) diff --git a/src/scm/webid-oidc/jwk.scm b/src/scm/webid-oidc/jwk.scm index 1ad54ad..db7a41f 100644 --- a/src/scm/webid-oidc/jwk.scm +++ b/src/scm/webid-oidc/jwk.scm @@ -1,7 +1,12 @@ (define-module (webid-oidc jwk) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc errors) - #:use-module (json)) + #:use-module (ice-9 receive) + #:use-module (ice-9 optargs) + #:use-module (srfi srfi-19) + #:use-module (web response) + #:use-module (web client) + #:use-module (rnrs bytevectors)) (define-public (the-jwk x) (with-exception-handler @@ -36,13 +41,13 @@ (y . ,y))) (rsa-part `((n . ,n) (e . ,e)))) - (case (stubs:kty ec-part) + (case (stubs:kty key) ((EC) ec-part) ((RSA) rsa-part)))))))) (define-public (jwk-public? key) (false-if-exception - (and (the-public-jwk x) #t))) + (and (the-public-jwk key) #t))) (define-public (strip key) (with-exception-handler @@ -86,7 +91,7 @@ (define-public generate-key stubs:generate-key) (define (the-public-keys keys) - (map the-public-key keys)) + (map the-public-jwk keys)) (define-public (the-jwks jwks) (let ((keys (vector->list (assoc-ref jwks 'keys)))) @@ -109,4 +114,30 @@ (the-jwks `((keys . ,pubs)))))) (define-public (jwks-keys jwks) - (vector->list (assq-ref (the-jwks jwks) keys))) + (vector->list (assq-ref (the-jwks jwks) 'keys))) + +(define-public (serve-jwks expiration-date jwks) + (values (build-response + #:headers `((content-type . (application/json)) + (expires . ,expiration-date))) + (stubs:scm->json-string (the-jwks jwks)))) + +(define*-public (get-jwks uri #:key (http-get http-get)) + (receive (response response-body) (http-get uri) + (with-exception-handler + (lambda (cause) + (raise-unexpected-response response cause)) + (lambda () + (unless (eqv? (response-code response) 200) + (raise-request-failed-unexpectedly + (response-code response) + (response-reason-phrase response))) + (let ((content-type (response-content-type response))) + (unless (and (eq? (car content-type) 'application/json) + (or (equal? (assoc-ref (cdr content-type) 'charset) + "utf-8") + (not (assoc-ref (cdr content-type) 'charset)))) + (raise-unexpected-header-value 'content-type content-type)) + (unless (string? response-body) + (set! response-body (utf8->string response-body))) + (the-jwks (stubs:json-string->scm response-body))))))) -- cgit v1.2.3