Switch to a more sensible error reporting system

1 files changed, 117 insertions, 31 deletions

diff --git a/src/scm/webid-oidc/jwk.scm b/src/scm/webid-oidc/jwk.scm
index 57da31d..5b17f29 100644
--- a/src/scm/webid-oidc/jwk.scm
+++ b/src/scm/webid-oidc/jwk.scm
@@ -1,4 +1,4 @@
-;; webid-oidc, implementation of the Solid specification
+;; disfluid, implementation of the Solid specification
 ;; Copyright (C) 2020, 2021  Vivien Kraus
 
 ;; This program is free software: you can redistribute it and/or modify
@@ -17,34 +17,97 @@
 (define-module (webid-oidc jwk)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc web-i18n)
   #:use-module (ice-9 receive)
   #:use-module (ice-9 optargs)
+  #:use-module (ice-9 exceptions)
   #:use-module (srfi srfi-19)
   #:use-module (web response)
   #:use-module (web client)
-  #:use-module (rnrs bytevectors))
-
-(define-public (the-jwk x)
+  #:use-module (rnrs bytevectors)
+  #:declarative? #t
+  #:export
+  (
+   the-jwk
+   jwk?
+   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
+   get-jwks
+
+   &not-a-jwk
+   make-not-a-jwk
+   not-a-jwk?
+
+   &not-a-jwks
+   make-not-a-jwks
+   not-a-jwks?
+   ))
+
+(define-exception-type
+  &not-a-jwk
+  &external-error
+  make-not-a-jwk
+  not-a-jwk?)
+
+(define-exception-type
+  &not-a-jwks
+  &external-error
+  make-not-a-jwks
+  not-a-jwks?)
+
+(define (the-jwk x)
   (with-exception-handler
-      (lambda (cause)
-        (raise-not-a-jwk x cause))
+      (lambda (error)
+        (let ((final-message
+               (if (exception-with-message? error)
+                   (format #f (G_ "the JWK is invalid: ~a")
+                           (exception-message error))
+                   (format #f (G_ "the JWK is invalid")))))
+          (raise-exception
+           (make-exception
+            (make-not-a-jwk)
+            (make-exception-with-message final-message)
+            error))))
     (lambda ()
       (let ((kty (stubs:kty x)))
         (unless (or (eq? kty 'EC) (eq? kty 'RSA))
-          (throw 'really-not-a-jwk))
+          (fail (format #f (G_ "unknown key type ~s")
+                        kty)))
         x))))
 
-(define-public (jwk? x)
+(define (jwk? x)
   (false-if-exception
    (and (the-jwk x) #t)))
 
-(define-public (kty x)
+(define (kty x)
   (stubs:kty (the-jwk x)))
 
-(define-public (the-public-jwk x)
+(define (the-public-jwk x)
   (with-exception-handler
-      (lambda (cause)
-        (raise-not-a-public-jwk x cause))
+      (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))
@@ -61,26 +124,35 @@
               ((EC) ec-part)
               ((RSA) rsa-part))))))))
 
-(define-public (jwk-public? key)
+(define (jwk-public? key)
   (false-if-exception
    (and (the-public-jwk key) #t)))
 
-(define-public (strip key)
+(define (strip key)
   (with-exception-handler
-      (lambda (cause)
-        (raise-not-a-public-jwk key cause))
+      (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-public (jkt x)
+(define (jkt x)
   (stubs:jkt (the-public-jwk x)))
 
-(define-public (make-rsa-public-key n e)
+(define (make-rsa-public-key n e)
   (the-public-jwk
    `((n . ,n)
      (e . ,e))))
 
-(define-public (make-rsa-private-key d p q dp dq qi)
+(define (make-rsa-private-key d p q dp dq qi)
   (the-jwk
    `((d . ,d)
      (p . ,p)
@@ -89,7 +161,7 @@
      (dq . ,dq)
      (qi . ,qi))))
 
-(define-public (make-ec-point crv x y)
+(define (make-ec-point crv x y)
   (if (symbol? crv)
       (make-ec-point (symbol->string crv) x y)
       (the-public-jwk
@@ -97,48 +169,62 @@
          (x . ,x)
          (y . ,y)))))
 
-(define-public (make-ec-scalar crv d)
+(define (make-ec-scalar crv d)
   (if (symbol? crv)
       (make-ec-scalar (symbol->string crv) d)
       (the-jwk
        `((crv . ,crv)
          (d . ,d)))))
 
-(define-public generate-key stubs:generate-key)
+(define generate-key stubs:generate-key)
 
 (define (the-public-keys keys)
   (map the-public-jwk keys))
 
-(define-public (the-jwks jwks)
+(define (the-jwks jwks)
   (let ((keys (vector->list (assoc-ref jwks 'keys))))
     (unless keys
-      (raise-not-a-jwks jwks #f))
+      (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 (cause)
-          (raise-not-a-jwks jwks cause))
+        (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))))))))
 
-(define-public (jwks? jwks)
+(define (jwks? jwks)
   (false-if-exception
    (and (the-jwks jwks) #t)))
 
-(define-public (make-jwks keys)
+(define (make-jwks keys)
   (if (vector? keys)
       (make-jwks (vector->list keys))
       (let ((pubs (list->vector (map strip keys))))
         (the-jwks `((keys . ,pubs))))))
 
-(define-public (jwks-keys jwks)
+(define (jwks-keys jwks)
   (vector->list (assq-ref (the-jwks jwks) 'keys)))
 
-(define-public (serve-jwks expiration-date jwks)
+(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*-public (get-jwks uri #:key (http-get http-get))
+(define* (get-jwks uri #:key (http-get http-get))
   (receive (response response-body) (http-get uri)
     (with-exception-handler
         (lambda (cause)