Switch to a more sensible error reporting system

1 files changed, 218 insertions, 98 deletions

diff --git a/src/scm/webid-oidc/jws.scm b/src/scm/webid-oidc/jws.scm
index 43eb707..24a8bbc 100644
--- a/src/scm/webid-oidc/jws.scm
+++ b/src/scm/webid-oidc/jws.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,91 +17,180 @@
 (define-module (webid-oidc jws)
   #:use-module (webid-oidc jwk)
   #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc web-i18n)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module (rnrs bytevectors)
-  #:use-module (ice-9 receive))
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 match)
+  #:declarative? #t
+  #:export
+  (
 
-(define-public (the-jws-header x)
-  (with-exception-handler
-      (lambda (cause)
-        (raise-not-a-jws-header x cause))
-    (lambda ()
-      (let ((alg (assq-ref x 'alg)))
-        (unless alg
-          (raise-missing-alist-key x 'alg))
-        (unless (string? alg)
-          (raise-unsupported-alg alg))
-        (case (string->symbol alg)
-          ((HS256 HS384 HS512 RS256 RS384 RS512 ES256 ES384 ES512 PS256 PS384 PS512)
-           x)
-          (else
-           (raise-unsupported-alg (string->symbol alg))))))))
-
-(define-public (the-jws-payload x)
-  (with-exception-handler
-      (lambda (cause)
-        (raise-not-a-jws-payload x cause))
-    (lambda ()
-      (unless (list? x)
-        (scm-error 'wrong-type-arg "the-jws-payload" "expected a list" '() (list x)))
-      x)))
+   &invalid-jws
+   make-invalid-jws
+   invalid-jws?
 
-(define-public (the-jws x)
-  (with-exception-handler
-      (lambda (cause)
-        (raise-not-a-jws x cause))
-    (lambda ()
-      (unless (pair? x)
-        (scm-error 'wrong-type-arg "the-jws" "expected a pair" '() (list x)))
-      (cons (the-jws-header (car x))
-            (the-jws-payload (cdr x))))))
+   the-jws
+   jws?
 
-(define-public (jws-header? x)
-  (false-if-exception
-   (and (the-jws-header x) #t)))
+   jws-alg
 
-(define-public (jws-payload? x)
-  (false-if-exception
-   (and (the-jws-payload x) #t)))
+   &cannot-query-identity-provider
+   make-cannot-query-identity-provider
+   cannot-query-identity-provider?
+   cannot-query-identity-provider-value
 
-(define-public (jws? x)
-  (false-if-exception
-   (and (the-jws x) #t)))
+   &signed-in-future
+   make-signed-in-future
+   signed-in-future?
+   error-signature-date
+   error-current-date
 
-(define-public (make-jws header payload)
-  (the-jws (cons (the-jws-header header)
-                 (the-jws-payload payload))))
+   &expired
+   make-expired
+   expired?
+   error-expiration-date
+   ;; error-current-date works for that one too
 
-(define-public (jws-header jws)
-  (car (the-jws jws)))
+   jws-decode
+   jws-encode
 
-(define-public (jws-payload jws)
-  (cdr (the-jws jws)))
+   ))
 
-(define-public (jws-alg jws)
-  (if (jws? jws)
-      (jws-alg (jws-header jws))
-      (string->symbol (assq-ref (the-jws-header jws) 'alg))))
+(define-exception-type
+  &invalid-jws
+  &external-error
+  make-invalid-jws
+  invalid-jws?)
+
+(define (the-jws x)
+  (with-exception-handler
+      (lambda (error)
+        (let ((final-message
+               (if (exception-with-message? error)
+                   (format #f (G_ "the JWS is invalid: ~a")
+                           (exception-message error))
+                   (format #f (G_ "the JWS is invalid")))))
+          (raise-exception
+           (make-exception
+            (make-invalid-jws)
+            (make-exception-with-message final-message)
+            error))))
+    (lambda ()
+      (match x
+        ((header . payload)
+         (let examine-header ((header header)
+                              (alg #f)
+                              (other-header-fields '()))
+           (match header
+             (()
+              (let examine-payload ((payload payload)
+                                    (other-payload-fields '()))
+                (match payload
+                  (()
+                   (unless alg
+                     (fail (format #f (G_ "the JWS header does not have an \"alg\" field"))))
+                   `(((alg . ,(symbol->string alg))
+                      ,@(reverse other-header-fields))
+                     . ,(reverse other-payload-fields)))
+                  ((((? symbol? key) . value) payload ...)
+                   (examine-payload payload
+                                    `((,key . ,value) ,@other-payload-fields)))
+                  (else
+                   (fail (format #f (G_ "invalid JSON object as payload")))))))
+             ((('alg . (? string? given-alg)) header ...)
+              (case (string->symbol given-alg)
+                ((HS256 HS384 HS512
+                        RS256 RS384 RS512
+                        ES256 ES384 ES512
+                        PS256 PS384 PS512)
+                 #t)
+                (else
+                 (fail (format #f (G_ "invalid signature algorithm: ~s") given-alg))))
+              (examine-header header (or alg (string->symbol given-alg))
+                              other-header-fields))
+             ((('alg . invalid) header ...)
+              (fail (format #f (G_ "invalid \"alg\" value: ~s") invalid)))
+             ((((? symbol? key) . value) header ...)
+              (examine-header header alg
+                              `((,key . ,value) ,@other-header-fields)))
+             (else
+              (fail (format #f (G_ "invalid JSON object as header")))))))
+        (else
+         (fail (format #f (G_ "this is not a pair"))))))))
+
+(define (jws? x)
+  (false-if-exception
+   (the-jws x)))
+
+(define (jws-alg jws)
+  (match (the-jws jws)
+    ((header . _)
+     (string->symbol (assq-ref header 'alg)))))
 
 (define (split-in-3-parts string separator)
-  (let ((parts (list->vector (string-split string separator))))
-    (unless (eqv? (vector-length parts) 3)
-      (raise-not-in-3-parts string separator))
-    (values (vector-ref parts 0) (vector-ref parts 1) (vector-ref parts 2))))
+  (match (string-split string separator)
+    ((header payload signature)
+     (values header payload signature))
+    (else
+     (let ((final-message
+            (format #f (G_ "the encoded JWS is not in 3 parts"))))
+       (raise-exception
+        (make-exception
+         (make-invalid-jws)
+         (make-exception-with-message final-message)))))))
 
 (define (base64-decode-json str)
   (with-exception-handler
       (lambda (error)
-        (cond
-         (((record-predicate &not-base64) error)
-          (raise-exception error))
-         (((record-predicate &not-json) error)
-          (raise-exception error))
-         (else
-          ;; From utf8->string
-          (raise-not-base64 str error))))
+        (let ((final-message
+               (if (exception-with-message? error)
+                   (format #f (G_ "the encoded JWS header or payload is not a JSON object encoded in base64: ~a")
+                           (exception-message error))
+                   (format #f (G_ "the encoded JWS header or payload is not a JSON object encoded in base64")))))
+          (raise-exception
+           (make-exception
+            (make-invalid-jws)
+            (make-exception-with-message final-message)
+            error))))
     (lambda ()
-      (stubs:json-string->scm (utf8->string (stubs:base64-decode str))))))
+      (stubs:json-string->scm
+       (utf8->string (stubs:base64-decode str))))))
+
+(define-exception-type
+  &cannot-query-identity-provider
+  &external-error
+  make-cannot-query-identity-provider
+  cannot-query-identity-provider?
+  (identity-provider cannot-query-identity-provider-value))
+
+(define-exception-type
+  &signed-in-future
+  &external-error
+  make-signed-in-future
+  signed-in-future?
+  (signature-date error-signature-date)
+  (current-date error-current-date*))
+
+(define-exception-type
+  &expired
+  &external-error
+  make-expired
+  expired?
+  (expiration-date error-expiration-date)
+  (current-date error-current-date**))
+
+(define error-current-date
+  (match-lambda
+    ((or ($ &signed-in-future _ date)
+         ($ &expired _ date)
+         ($ &compound-exception (($ &signed-in-future _ date) _ ...))
+         ($ &compound-exception (($ &expired _ date) _ ...)))
+     date)
+    (($ &compound-exception (_ sub-exceptions ...))
+     (error-current-date (apply make-exception sub-exceptions)))
+    (else #f)))
 
 (define (parse str verify)
   (receive (header payload signature)
@@ -109,31 +198,53 @@
     (let ((base (string-append header "." payload))
           (header (base64-decode-json header))
           (payload (base64-decode-json payload)))
-      (let ((ret (make-jws header payload)))
+      (let ((ret `(,header . ,payload)))
         (verify ret base signature)
         ret))))
 
 (define (verify-any alg keys payload signature)
-  (define (aux candidates)
-    (if (null? keys)
-        (raise-no-matching-key keys alg payload signature)
-        (let ((next-ok
-               (with-exception-handler
-                   (lambda (error)
-                     #f)
-                 (lambda ()
-                   (stubs:verify alg (car candidates) payload signature)
-                   #t)
-                 #:unwind? #t
-                 #:unwind-for-type &invalid-signature)))
-          (or next-ok
-              (aux (cdr candidates))))))
-  (aux keys))
-
-(define-public (jws-decode str lookup-keys)
+  (let try-with-key ((keys keys))
+    (match keys
+      (()
+       (let ((final-message
+              (format #f (G_ "the JWS is not signed by any of the expected set of public keys"))))
+         (raise-exception
+          (make-exception
+           (make-invalid-jws)
+           (make-exception-with-message final-message)))))
+      ((next-key keys ...)
+       (with-exception-handler
+           (lambda (error)
+             (unless (stubs:invalid-signature? error)
+               (let ((final-message
+                      (if (exception-with-message? error)
+                          (format #f (G_ "while verifying the JWS signature: ~a")
+                                  (exception-message error))
+                          (format #f (G_ "an unexpected error happened while verifying a JWS")))))
+                 (raise-exception
+                  (make-exception
+                   (make-invalid-jws)
+                   (make-exception-with-message final-message)
+                   error))))
+             (try-with-key keys))
+         (lambda ()
+           (stubs:verify alg next-key payload signature))
+         #:unwind? #t
+         #:unwind-for-type stubs:&invalid-signature)))))
+
+(define (jws-decode str lookup-keys)
   (with-exception-handler
       (lambda (error)
-        (raise-cannot-decode-jws str error))
+        (let ((final-message
+               (if (exception-with-message? error)
+                   (format #f (G_ "cannot decode a JWS: ~a")
+                           (exception-message error))
+                   (format #f (G_ "cannot decode a JWS")))))
+          (raise-exception
+           (make-exception
+            (make-invalid-jws)
+            (make-exception-with-message final-message)
+            error))))
     (lambda ()
       (parse str
              (lambda (jws payload signature)
@@ -143,17 +254,26 @@
                                    (else keys))))
                    (verify-any (jws-alg jws) keys payload signature))))))))
 
-(define-public (jws-encode jws key)
+(define (jws-encode jws key)
   (with-exception-handler
       (lambda (error)
-        (raise-cannot-encode-jws jws key error))
+        (let ((final-message
+               (if (exception-with-message? error)
+                   (format #f (G_ "cannot encode a JWS: ~a")
+                           (exception-message error))
+                   (format #f (G_ "cannot encode a JWS")))))
+          (raise-exception
+           (make-exception
+            (make-invalid-jws)
+            (make-exception-with-message final-message)
+            error))))
     (lambda ()
-      (let ((header (jws-header jws))
-            (payload (jws-payload jws)))
-        (let ((header (stubs:scm->json-string header))
-              (payload (stubs:scm->json-string payload)))
-          (let ((header (stubs:base64-encode header))
-                (payload (stubs:base64-encode payload)))
-            (let ((payload (string-append header "." payload)))
-              (let ((signature (stubs:sign (jws-alg jws) key payload)))
-                (string-append payload "." signature)))))))))
+      (match jws
+        ((header . payload)
+         (let ((header (stubs:scm->json-string header))
+               (payload (stubs:scm->json-string payload)))
+           (let ((header (stubs:base64-encode header))
+                 (payload (stubs:base64-encode payload)))
+             (let ((payload (string-append header "." payload)))
+               (let ((signature (stubs:sign (jws-alg jws) key payload)))
+                 (string-append payload "." signature))))))))))