Get a JWKS on the web

2 files changed, 89 insertions, 9 deletions

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)))))
           ((&not-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)))))
           ((&not-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)))))))