diff options
Diffstat (limited to 'src/scm/webid-oidc/jwk.scm')
-rw-r--r-- | src/scm/webid-oidc/jwk.scm | 41 |
1 files changed, 36 insertions, 5 deletions
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))))))) |