Get a JWKS on the web

1 files changed, 53 insertions, 4 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)