Switch to a more sensible error reporting system

1 files changed, 350 insertions, 185 deletions

diff --git a/src/scm/webid-oidc/dpop-proof.scm b/src/scm/webid-oidc/dpop-proof.scm
index 2ccbddc..b1e07f9 100644
--- a/src/scm/webid-oidc/dpop-proof.scm
+++ b/src/scm/webid-oidc/dpop-proof.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
@@ -21,156 +21,241 @@
   #:use-module (webid-oidc jti)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module ((webid-oidc parameters) #:prefix p:)
+  #:use-module (webid-oidc web-i18n)
   #:use-module (web uri)
   #:use-module (ice-9 optargs)
-  #:use-module (srfi srfi-19))
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:declarative? #t
+  #:export
+  (
 
-(define-public (the-dpop-proof-header x)
-  (with-exception-handler
-      (lambda (error)
-        (raise-not-a-dpop-proof-header x error))
-    (lambda ()
-      (let ((x (the-jws-header x)))
-        (let ((alg (assq-ref x 'alg))
-              (typ (assq-ref x 'typ))
-              (jwk (assq-ref x 'jwk)))
-          (unless (and alg (string? alg))
-            (raise-unsupported-alg alg))
-          (case (string->symbol alg)
-            ((RS256 RS384 RS512 ES256 ES384 ES512 PS256 PS384 PS512)
-             #t)
-            (else
-             (raise-unsupported-alg alg)))
-          (unless (equal? typ "dpop+jwt")
-            (raise-incorrect-typ-field typ))
-          (with-exception-handler
-              (lambda (error)
-                (raise-incorrect-jwk-field jwk error))
-            (lambda ()
-              (the-public-jwk jwk)))
-          x)))))
-
-(define-public (dpop-proof-header? x)
-  (false-if-exception
-   (and (the-dpop-proof-header x) #t)))
-
-(define-public (the-dpop-proof-payload x)
-  (with-exception-handler
-      (lambda (error)
-        (raise-not-a-dpop-proof-payload x error))
-    (lambda ()
-      (let ((x (the-jws-payload x)))
-        (let ((jti (assq-ref x 'jti))
-              (htm (assq-ref x 'htm))
-              (htu (assq-ref x 'htu))
-              (iat (assq-ref x 'iat))
-              (ath (assq-ref x 'ath)))
-          (unless (and jti (string? jti))
-            (raise-incorrect-jti-field jti))
-          (unless (and htm (string? htm))
-            (raise-incorrect-htm-field htm))
-          (unless (and htu (string? htu) (string->uri htu))
-            (raise-incorrect-htu-field htu))
-          (unless (and iat (integer? iat))
-            (raise-incorrect-iat-field iat))
-          (unless (or (not ath) (string? ath))
-            (raise-incorrect-ath-field ath))
-          x)))))
-
-(define-public (dpop-proof-payload? x)
-  (false-if-exception
-   (and (the-dpop-proof-payload x) #t)))
-
-(define-public (the-dpop-proof x)
+   &invalid-dpop-proof
+   make-invalid-dpop-proof
+   invalid-dpop-proof?
+
+   the-dpop-proof
+   dpop-proof?
+
+   dpop-proof-alg
+   dpop-proof-typ
+   dpop-proof-jwk
+
+   dpop-proof-jti
+   dpop-proof-htm
+   dpop-proof-htu
+   dpop-proof-iat
+   dpop-proof-ath
+
+   &dpop-method-mismatch
+   make-dpop-method-mismatch
+   dpop-method-mismatch?
+   dpop-method-mismatch-advertised
+   dpop-method-mismatch-actual
+   
+   &dpop-uri-mismatch
+   make-dpop-uri-mismatch
+   dpop-uri-mismatch?
+   dpop-uri-mismatch-advertised
+   dpop-uri-mismatch-actual
+
+   &dpop-invalid-ath
+   make-dpop-invalid-ath
+   dpop-invalid-ath?
+   dpop-invalid-ath-hash
+   dpop-invalid-ath-access-token
+
+   &dpop-unconfirmed-key
+   make-dpop-unconfirmed-key
+   dpop-unconfirmed-key?
+
+   dpop-proof-decode
+   issue-dpop-proof
+   ))
+
+(define-exception-type
+  &invalid-dpop-proof
+  &external-error
+  make-invalid-dpop-proof
+  invalid-dpop-proof?)
+
+(define (the-dpop-proof x)
   (with-exception-handler
       (lambda (error)
-        (raise-not-a-dpop-proof x error))
+        (let ((final-message
+               (cond
+                ((invalid-jws? error)
+                 (if (exception-with-message? error)
+                     (format #f (G_ "this is not a DPoP proof, because it is not even a JWS: ~a")
+                             (exception-message error))
+                     (format #f (G_ "this is not a DPoP proof, because it is not even a JWS"))))
+                (else
+                 (if (exception-with-message? error)
+                     (format #f (G_ "this is not an access token: ~a")
+                             (exception-message error))
+                     (format #f (G_ "this is not an access token")))))))
+          (raise-exception
+           (make-exception
+            (make-invalid-dpop-proof)
+            (make-exception-with-message final-message)
+            error))))
     (lambda ()
-      (cons (the-dpop-proof-header (car x))
-            (the-dpop-proof-payload (cdr x))))))
-
-(define-public (dpop-proof? x)
-  (false-if-exception
-   (and (the-dpop-proof x) #t)))
-
-(define-public (make-dpop-proof header payload)
-  (the-dpop-proof (cons header payload)))
-
-(define-public (make-dpop-proof-header alg jwk)
-  (when (symbol? alg)
-    (set! alg (symbol->string alg)))
-  (the-dpop-proof-header
-   `((alg . ,alg)
-     (typ . "dpop+jwt")
-     (jwk . ,(stubs:strip-key jwk)))))
-
-(define-public (make-dpop-proof-payload jti htm htu iat ath)
-  (when (symbol? htm)
-    (set! htm (symbol->string htm)))
-  (when (uri? htu)
-    (set! htu (uri->string htu)))
-  (when (date? iat)
-    (set! iat (date->time-utc iat)))
-  (when (time? iat)
-    (set! iat (time-second iat)))
-  (the-dpop-proof-payload
-   `((jti . ,jti)
-     (htm . ,htm)
-     (htu . ,htu)
-     (iat . ,iat)
-     ,@(if ath
-           `((ath . ,ath))
-           '()))))
-
-(define-public (dpop-proof-header dpop)
-  (car (the-dpop-proof dpop)))
-
-(define-public (dpop-proof-payload dpop)
-  (cdr (the-dpop-proof dpop)))
-
-(define-public (dpop-proof-alg code)
-  (when (dpop-proof? code)
-    (set! code (dpop-proof-header code)))
-  (jws-alg (the-dpop-proof-header code)))
-
-(define-public (dpop-proof-jwk dpop)
-  (when (dpop-proof? dpop)
-    (set! dpop (dpop-proof-header dpop)))
-  (assq-ref (the-dpop-proof-header dpop) 'jwk))
-
-(define-public (dpop-proof-jti dpop)
-  (when (dpop-proof? dpop)
-    (set! dpop (dpop-proof-payload dpop)))
-  (assq-ref (the-dpop-proof-payload dpop) 'jti))
-
-(define-public (dpop-proof-htm dpop)
-  (when (dpop-proof? dpop)
-    (set! dpop (dpop-proof-payload dpop)))
-  (string->symbol
-   (assq-ref (the-dpop-proof-payload dpop)
-             'htm)))
-
-(define-public (dpop-proof-htu dpop)
-  (when (dpop-proof? dpop)
-    (set! dpop (dpop-proof-payload dpop)))
-  (string->uri
-   (assq-ref (the-dpop-proof-payload dpop)
-             'htu)))
-
-(define-public (dpop-proof-iat dpop)
-  (when (dpop-proof? dpop)
-    (set! dpop (dpop-proof-payload dpop)))
-  (time-utc->date
-   (make-time time-utc
-              0
-              (assq-ref (the-dpop-proof-payload dpop)
-                        'iat))))
-
-(define-public (dpop-proof-ath dpop)
-  (when (dpop-proof? dpop)
-    (set! dpop (dpop-proof-payload dpop)))
-  (assq-ref (the-dpop-proof-payload dpop)
-            'ath))
+      (match (the-jws x)
+        ((header . payload)
+         (let examine-header ((header header)
+                              (alg #f)
+                              (typ #f)
+                              (jwk #f)
+                              (other-header-fields '()))
+           (match header
+             (()
+              (let examine-payload ((payload payload)
+                                    (jti #f)
+                                    (htm #f)
+                                    (htu #f)
+                                    (iat #f)
+                                    (ath #f)
+                                    (other-payload-fields '()))
+                (match payload
+                  (()
+                   (unless (and alg typ jwk jti htm htu iat)
+                     (fail (format #f (G_ "the DPoP proof is missing ~s")
+                                   `(,@(if alg '() '("alg"))
+                                     ,@(if typ '() '("typ"))
+                                     ,@(if jwk '() '("jwk"))
+                                     ,@(if jti '() '("jti"))
+                                     ,@(if htm '() '("htm"))
+                                     ,@(if htu '() '("htu"))
+                                     ,@(if iat '() '("iat"))))))
+                   `(((alg . ,(symbol->string alg))
+                      (typ . "dpop+jwt")
+                      (jwk . ,(strip jwk))
+                      ,@other-header-fields)
+                     . ((jti . ,jti)
+                        (htm . ,(symbol->string htm))
+                        (htu . ,(uri->string htu))
+                        (iat . ,(time-second (date->time-utc iat)))
+                        ,@(if ath `((ath . ,ath)) '())
+                        ,@other-payload-fields)))
+                  ((('jti . (? string? given-jti)) payload ...)
+                   (examine-payload payload
+                                    (or jti given-jti) htm htu iat ath
+                                    other-payload-fields))
+                  ((('jti . incorrect) payload ...)
+                   (fail (format #f (G_ "the \"jti\" field should be a string, not ~s")
+                                 incorrect)))
+                  ((('htm . (? string? given-htm)) payload ...)
+                   (examine-payload payload jti
+                                    (or htm (string->symbol given-htm))
+                                    htu iat ath other-payload-fields))
+                  ((('htm . incorrect) payload ...)
+                   (fail (format #f (G_ "the \"htm\" field should be a string, not ~s")
+                                 incorrect)))
+                  ((('htu . (? string? (= string->uri (? uri? given-htu)))) payload ...)
+                   (examine-payload payload jti htm
+                                    (or htu given-htu)
+                                    iat ath other-payload-fields))
+                  ((('htu . incorrect) payload ...)
+                   (fail (format #f (G_ "the \"htu\" field should be an URI, not ~s")
+                                 incorrect)))
+                  ((('iat . (? (cute >= <> 0) (? integer? given-iat))) payload ...)
+                   (examine-payload payload jti htm htu
+                                    (or iat (time-utc->date (make-time time-utc 0 given-iat)))
+                                    ath other-payload-fields))
+                  ((('iat . incorrect) payload ...)
+                   (fail (format #f (G_ "the \"iat\" field should be a timestamp, not ~s")
+                                 incorrect)))
+                  ((('ath . (? string? given-ath)) payload ...)
+                   (examine-payload payload jti htm htu iat
+                                    (or ath given-ath)
+                                    other-payload-fields))
+                  ((('ath . incorrect) payload ...)
+                   (fail (format #f (G_ "the \"ath\" field should be an encoded JWT, not ~s")
+                                 incorrect)))
+                  ((field payload ...)
+                   (examine-payload payload jti htm htu iat ath
+                                    `(,field ,@other-payload-fields))))))
+             ((('alg . (? string? given-alg)) header ...)
+              (examine-header header (or alg (string->symbol given-alg))
+                              typ jwk other-header-fields))
+             ((('alg . incorrect) header ...)
+              (fail (format #f (G_ "the \"alg\" field should be a string, not ~s")
+                            incorrect)))
+             ((('typ . "dpop+jwt") header ...)
+              (examine-header header alg #t jwk other-header-fields))
+             ((('typ . incorrect) header ...)
+              (fail (format #f (G_ "the \"typ\" field should be \"dpop+jwt\", not ~s")
+                            incorrect)))
+             ((('jwk . (? jwk-public? given-jwk)) header ...)
+              (examine-header header alg typ (or jwk (the-public-jwk given-jwk))
+                              other-header-fields))
+             ((('jwk . incorrect) header ...)
+              (fail (format #f (G_ "the \"jwk\" field should be a valid public key, not ~s")
+                            incorrect)))
+             ((field header ...)
+              (examine-header header alg typ jwk `(,field ,@other-header-fields))))))))))
+
+(define (dpop-proof? x)
+  (false-if-exception (the-dpop-proof x)))
+
+(define (dpop-proof-alg proof)
+  (match (the-dpop-proof proof)
+    ((header . _)
+     (symbol->string (assq-ref header 'alg)))))
+
+(define (dpop-proof-typ proof)
+  (match (the-dpop-proof proof)
+    ((header . _)
+     (assq-ref header 'typ))))
+
+(define (dpop-proof-jwk proof)
+  (match (the-dpop-proof proof)
+    ((header . _)
+     (the-public-jwk (assq-ref header 'jwk)))))
+
+(define (dpop-proof-jti proof)
+  (match (the-dpop-proof proof)
+    ((_ . payload)
+     (assq-ref payload 'jti))))
+
+(define (dpop-proof-htm proof)
+  (match (the-dpop-proof proof)
+    ((_ . payload)
+     (string->symbol (assq-ref payload 'htm)))))
+
+(define (dpop-proof-htu proof)
+  (match (the-dpop-proof proof)
+    ((_ . payload)
+     (string->uri (assq-ref payload 'htu)))))
+
+(define (dpop-proof-iat proof)
+  (match (the-dpop-proof proof)
+    ((_ . payload)
+     (time-utc->date
+      (make-time time-utc 0 (assq-ref payload 'iat))))))
+
+(define (dpop-proof-ath proof)
+  (match (the-dpop-proof proof)
+    ((_ . payload)
+     (assq-ref payload 'ath))))
+
+(define-exception-type
+  &dpop-method-mismatch
+  &external-error
+  make-dpop-method-mismatch
+  dpop-method-mismatch?
+  (advertised dpop-method-mismatch-advertised)
+  (actual dpop-method-mismatch-actual))
+
+(define-exception-type
+  &dpop-uri-mismatch
+  &external-error
+  make-dpop-uri-mismatch
+  dpop-uri-mismatch?
+  (advertised dpop-uri-mismatch-advertised)
+  (actual dpop-uri-mismatch-actual))
 
 (define (uris-compatible a b)
   ;; a is what is signed, b is the request
@@ -185,71 +270,151 @@
                     (uri-path a))
                    (split-and-decode-uri-path
                     (uri-path b))))
-    (raise-dpop-uri-mismatch a b)))
+    (let ((final-message
+           (format #f (G_ "the DPoP proof is signed for ~s, but it is issued to ~s")
+                   (uri->string a) (uri->string b))))
+      (raise-exception
+       (make-exception
+        (make-dpop-uri-mismatch a b)
+        (make-exception-with-message final-message))))))
+
+(define-exception-type
+  &dpop-invalid-ath
+  &external-error
+  make-dpop-invalid-ath
+  dpop-invalid-ath?
+  (hash dpop-invalid-ath-hash)
+  (access-token dpop-invalid-ath-access-token))
+
+(define-exception-type
+  &dpop-unconfirmed-key
+  &external-error
+  make-dpop-unconfirmed-key
+  dpop-unconfirmed-key?)
 
-(define*-public (dpop-proof-decode method uri str cnf/check
-                                   #:key
-                                   (access-token #f))
-  (let ((current-time
-         (time-second (date->time-utc ((p:current-date))))))
+(define* (dpop-proof-decode method uri str cnf/check
+                            #:key
+                            (access-token #f))
+  (let* ((current-date ((p:current-date)))
+         (current-time
+          (time-second (date->time-utc current-date))))
     (with-exception-handler
         (lambda (error)
-          (raise-cannot-decode-dpop-proof str error))
+          (let ((final-message
+                 (if (exception-with-message? error)
+                     (format #f (G_ "the DPoP proof cannot be decoded: ~a")
+                             (exception-message error))
+                     (format #f (G_ "the DPoP proof cannot be decoded")))))
+            (raise-exception
+             (make-exception
+              (make-invalid-dpop-proof)
+              (make-exception-with-message final-message)
+              error))))
       (lambda ()
         (let ((decoded (the-dpop-proof (jws-decode str dpop-proof-jwk))))
           (unless (eq? method (dpop-proof-htm decoded))
-            (raise-dpop-method-mismatch (dpop-proof-htm decoded) method))
+            (let ((final-message
+                   (format #f (G_ "the DPoP proof is signed for access through ~s, but it is used with ~s")
+                           (dpop-proof-htm decoded) method)))
+              (raise-exception
+               (make-exception
+                (make-dpop-method-mismatch (dpop-proof-htm decoded) method)
+                (make-exception-with-message final-message)))))
           (uris-compatible (dpop-proof-htu decoded)
                            (if (string? uri)
                                (string->uri uri)
                                uri))
-          (let ((iat (time-second (date->time-utc (dpop-proof-iat decoded)))))
-            (unless (>= current-time (- iat 5))
-              (raise-dpop-signed-in-future iat current-time))
-            (unless (<= current-time (+ iat 120)) ;; Valid for 2 min
-              (raise-dpop-too-old iat current-time)))
+          (let ((iat (dpop-proof-iat decoded)))
+            (let ((iat-s (time-second (date->time-utc iat))))
+              (unless (>= current-time (- iat-s 5))
+                (let ((final-message
+                       (format #f (G_ "the DPoP proof is signed in the future, ~a, relative to the current date, ~a")
+                               (date->string iat)
+                               (date->string current-date))))
+                  (raise-exception
+                   (make-exception
+                    (make-signed-in-future iat current-date)
+                    (make-exception-with-message final-message)))))
+              (unless (<= current-time (+ iat-s 120)) ;; valid for 2 minutes
+                (let ((final-message
+                       (format #f (G_ "the DPoP proof is too old, it was signed ~a and now it is ~a")
+                               (date->string iat)
+                               (date->string current-date))))
+                  (raise-exception
+                   (make-exception
+                    (make-expired (time-utc->date (make-time time-utc 0 (+ iat-s 120)))
+                                  current-date)
+                    (make-exception-with-message final-message)))))))
           (when access-token
             (let ((h (stubs:hash 'SHA-256 access-token)))
               (unless (equal? (dpop-proof-ath decoded) h)
-                (raise-exception
-                 (make-dpop-invalid-access-token-hash (dpop-proof-ath decoded) access-token)))))
+                (let ((final-message
+                       (format #f (G_ "the DPoP proof should go along with an access token hashed to ~s, not ~s")
+                               (dpop-proof-ath decoded) access-token)))
+                  (raise-exception
+                   (make-exception
+                    (make-dpop-invalid-ath (dpop-proof-ath decoded) access-token)
+                    (make-exception-with-message final-message)))))))
           (if (string? cnf/check)
               (unless (equal? cnf/check (stubs:jkt (dpop-proof-jwk decoded)))
-                (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) cnf/check #f))
+                (let ((final-message
+                       (format #f (G_ "the DPoP proof is signed with the wrong key"))))
+                  (raise-exception
+                   (make-exception
+                    (make-dpop-unconfirmed-key)
+                    (make-exception-with-message final-message)))))
               (with-exception-handler
                   (lambda (error)
-                    (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) #f error))
+                    (let ((final-message
+                           (if (exception-with-message? error)
+                               (format #f (G_ "the DPoP proof is signed with the wrong key: ~a")
+                                       (exception-message error))
+                               (format #f (G_ "the DPoP proof is signed with the wrong key")))))
+                      (raise-exception
+                       (make-exception
+                        (make-dpop-unconfirmed-key)
+                        (make-exception-with-message final-message)
+                        error))))
                 (lambda ()
                   (unless (cnf/check (stubs:jkt (dpop-proof-jwk decoded)))
-                    ;; deprecated; throw an error instead!
-                    (error "the cnf/check function returned #f")))))
-          (parameterize ((p:current-date current-time))
+                    ;; You should throw an error instead!
+                    (fail (G_ "the cnf/check function returned #f"))))))
+          (parameterize ((p:current-date current-date))
             ;; jti-check should use the same date.
-            (unless (jti-check (dpop-proof-jti decoded) 120)
-              (with-exception-handler
-                  (lambda (error)
-                    (raise-jti-found (dpop-proof-jti decoded) error))
-                (lambda ()
-                  (error "the jti-check function returned #f"))))
-            decoded))))))
+            (jti-check (dpop-proof-jti decoded) 120))
+          decoded)))))
 
-(define-public (dpop-proof-encode dpop-proof key)
+(define (dpop-proof-encode dpop-proof key)
   (with-exception-handler
       (lambda (error)
-        (raise-cannot-encode-dpop-proof dpop-proof key error))
+        (let ((final-message
+               (if (exception-with-message? error)
+                   (format #f (G_ "cannot encode a DPoP proof: ~a")
+                           (exception-message error))
+                   (format #f (G_ "cannot encode a DPoP proof")))))
+          (raise-exception
+           (make-exception-with-message final-message)
+           error)))
     (lambda ()
       (jws-encode dpop-proof key))))
 
-(define*-public (issue-dpop-proof
-                 client-key
-                 #:key
-                 (alg #f)
-                 (htm #f)
-                 (htu #f)
-                 (access-token #f))
+(define* (issue-dpop-proof
+          client-key
+          #:key
+          (alg #f)
+          (htm #f)
+          (htu #f)
+          (access-token #f))
   (dpop-proof-encode
-   (make-dpop-proof (make-dpop-proof-header alg client-key)
-                    (make-dpop-proof-payload (stubs:random 12) htm htu ((p:current-date))
-                                             (and access-token
-                                                  (stubs:hash 'SHA-256 access-token))))
+   (the-dpop-proof
+    `(((alg . ,(symbol->string alg))
+       (typ . "dpop+jwt")
+       (jwk . ,client-key))
+      . ((jti . ,(stubs:random 12))
+         (htm . ,(symbol->string htm))
+         (htu . ,(uri->string htu))
+         (iat . ,(time-second (date->time-utc ((p:current-date)))))
+         ,@(if access-token
+               `((ath . ,(stubs:hash 'SHA-256 access-token)))
+               '()))))
    client-key))