Switch to a more sensible error reporting system

1 files changed, 278 insertions, 172 deletions

diff --git a/src/scm/webid-oidc/oidc-id-token.scm b/src/scm/webid-oidc/oidc-id-token.scm
index e95efaf..2f84f64 100644
--- a/src/scm/webid-oidc/oidc-id-token.scm
+++ b/src/scm/webid-oidc/oidc-id-token.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
@@ -19,201 +19,307 @@
   #:use-module (webid-oidc errors)
   #:use-module (webid-oidc jws)
   #:use-module (webid-oidc jti)
+  #:use-module (webid-oidc web-i18n)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module (web uri)
   #:use-module (web client)
   #: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)
+  #:declarative? #t
+  #:export
+  (
+   &invalid-id-token
+   make-invalid-id-token
+   invalid-id-token?
 
-(define-public (the-id-token-header x)
-  (with-exception-handler
-      (lambda (error)
-        (raise-not-an-id-token-header x error))
-    (lambda ()
-      (the-jws-header x))))
+   the-id-token
+   id-token?
 
-(define-public (id-token-header? x)
-  (false-if-exception
-   (and (the-id-token-header x) #t)))
+   id-token-alg
+   id-token-webid
+   id-token-iss
+   id-token-sub
+   id-token-aud
+   id-token-nonce
+   id-token-iat
+   id-token-exp
+
+   id-token-decode
+   issue-id-token
+   ))
 
-(define-public (the-id-token-payload x)
+(define-exception-type
+  &invalid-id-token
+  &external-error
+  make-invalid-id-token
+  invalid-id-token?)
+
+(define (the-id-token x)
   (with-exception-handler
       (lambda (error)
-        (raise-not-an-id-token-payload x error))
+        (let ((final-message
+               (cond
+                ((and (invalid-jws? error)
+                      (exception-with-message? error))
+                 (format #f (G_ "this is not an ID token, because it is not even a JWS: ~a")
+                         (exception-message error)))
+                ((invalid-jws? error)
+                 (format #f (G_ "this is not an ID token, because it is not even a JWS")))
+                ((exception-with-message? error)
+                 (format #f (G_ "this is not an ID token: ~a")
+                         (exception-message error)))
+                (else
+                 (format #f (G_ "this is not an ID token"))))))
+          (raise-exception
+           (make-exception
+            (make-invalid-id-token)
+            (make-exception-with-message final-message)
+            error))))
     (lambda ()
-      (let ((x (the-jws-payload x)))
-        (let ((webid (assq-ref x 'webid))
-              (iss (assq-ref x 'iss))
-              (sub (assq-ref x 'sub))
-              (aud (assq-ref x 'aud))
-              (nonce (assq-ref x 'nonce))
-              (iat (assq-ref x 'iat))
-              (exp (assq-ref x 'exp)))
-          (unless (and webid (string? webid) (string->uri webid))
-            (raise-incorrect-webid-field webid))
-          (unless (and iss (string? iss) (string->uri iss))
-            (raise-incorrect-iss-field iss))
-          (unless (string? sub)
-            (raise-incorrect-sub-field sub))
-          (unless (and aud (string? aud) (string->uri aud))
-            (raise-incorrect-aud-field aud))
-          (unless (string? nonce)
-            (raise-incorrect-nonce-field nonce))
-          (unless (integer? iat)
-            (raise-incorrect-iat-field iat))
-          (unless (and (integer? exp) (>= exp iat))
-            (raise-incorrect-exp-field exp))
-          x)))))
-
-(define-public (id-token-payload? x)
+      (match (the-jws x)
+        ((header . payload)
+         (let examine-payload ((payload payload)
+                               (webid #f)
+                               (iss #f)
+                               (sub #f)
+                               (aud #f)
+                               (nonce #f)
+                               (iat #f)
+                               (exp #f)
+                               (other-fields '()))
+           (match payload
+             (()
+              (unless (and webid iss sub aud nonce iat exp)
+                (fail (format #f (G_ "the payload is missing ~s")
+                              `(,@(if webid '() '("webid"))
+                                ,@(if iss '() '("iss"))
+                                ,@(if sud '() '("sub"))
+                                ,@(if aud '() '("aud"))
+                                ,@(if nonce '() '("nonce"))
+                                ,@(if iat '() '("iat"))
+                                ,@(if exp '() '("exp"))))))
+              `(,header
+                . ((webid . ,(uri->string webid))
+                   (iss . ,(uri->string iss))
+                   (sub . ,sub)
+                   (aud . ,(uri->string aud))
+                   (nonce . ,nonce)
+                   (iat . ,(time-second (date->time-utc iat)))
+                   (exp . ,(time-second (date->time-utc exp))))))
+             ((('webid . (? string? (= string->uri (? uri? webid-given)))) payload ...)
+              (examine-payload payload
+                               (or webid webid-given)
+                               iss sub aud nonce iat exp other-fields))
+             ((('webid . invalid) payload ...)
+              (fail (format #f (G_ "the \"webid\" field should be an URI, ~s is given")
+                            invalid)))
+             ((('iss . (? string? (= string->uri (? uri? iss-given)))) payload ...)
+              (examine-payload payload webid
+                               (or iss iss-given)
+                               sub aud nonce iat exp other-fields))
+             ((('iss . invalid) payload ...)
+              (fail (format #f (G_ "the \"iss\" field should be an URI, ~s is given")
+                            invalid)))
+             ((('sub . (? string? sub-given)) payload ...)
+              (examine-payload payload webid iss
+                               (or sub sub-given)
+                               aud nonce iat exp other-fields))
+             ((('sub . invalid) payload ...)
+              (fail (format #f (G_ "the \"sub\" field should be a string, ~s is given")
+                            invalid)))
+             ((('aud . (? string? (= string->uri (? uri? aud-given)))) payload ...)
+              (examine-payload payload webid iss sub
+                               (or aud aud-given)
+                               nonce iat exp other-fields))
+             ((('aud . invalid) payload ...)
+              (fail (format #f (G_ "the \"aud\" field should be an URI, ~s is given")
+                            invalid)))
+             ((('nonce . (? string? nonce-given)) payload ...)
+              (examine-payload payload webid iss sub aud
+                               (or nonce nonce-given)
+                               iat exp other-fields))
+             ((('nonce . invalid) payload ...)
+              (fail (format #f (G_ "the \"nonce\" field should be a string, ~s is given")
+                            invalid)))
+             ((('iat . (? (lambda (x) (>= x 0)) (? integer? iat-given))) payload ...)
+              (examine-payload payload webid iss sub aud nonce
+                               (or iat (time-utc->date (make-time time-utc 0 iat-given)))
+                               exp other-fields))
+             ((('iat . invalid) payload ...)
+              (fail (format #f (G_ "the \"iat\" field should be a timestamp, ~s is given")
+                            invalid)))
+             ((('exp . (? (lambda (x) (>= x 0)) (? integer? exp-given))) payload ...)
+              (examine-payload payload webid iss sub aud nonce iat
+                               (or exp (time-utc->date (make-time time-utc 0 exp-given)))
+                               other-fields))
+             ((('exp . invalid) payload ...)
+              (fail (format #f (G_ "the \"exp\" field should be a timestamp, ~s is given")
+                            invalid)))
+             ((field payload ...)
+              (examine-payload payload webid iss sub aud nonce iat exp
+                               `(,field ,@other-fields)))
+             (else
+              (fail (format #f (G_ "the payload should be a JSON object")))))))))))
+
+(define (id-token? x)
   (false-if-exception
-   (and (the-id-token-header x) #t)))
+   (the-id-token x)))
 
-(define-public (the-id-token x)
-  (with-exception-handler
-      (lambda (cause)
-        (raise-not-an-id-token x cause))
-    (lambda ()
-      (cons (the-id-token-header (car x))
-            (the-id-token-payload (cdr x))))))
+(define (id-token-alg code)
+  (match (the-id-token code)
+    ((header . _)
+     (string->symbol (assq-ref header 'alg)))))
 
-(define-public (id-token? x)
-  (false-if-exception
-   (and (the-id-token x) #t)))
-
-(define-public (make-id-token header payload)
-  (the-id-token
-   (cons header payload)))
-
-(define-public (make-id-token-payload webid iss sub aud nonce exp iat)
-  (when (date? exp)
-    (set! exp (date->time-utc exp)))
-  (when (time? exp)
-    (set! exp (time-second exp)))
-  (when (date? iat)
-    (set! iat (date->time-utc iat)))
-  (when (time? iat)
-    (set! iat (time-second iat)))
-  (when (uri? webid)
-    (set! webid (uri->string webid)))
-  (when (uri? iss)
-    (set! iss (uri->string iss)))
-  (when (uri? aud)
-    (set! aud (uri->string aud)))
-  (the-id-token-payload
-   `((webid . ,webid)
-     (iss . ,iss)
-     (sub . ,sub)
-     (aud . ,aud)
-     (nonce . ,nonce)
-     (exp . ,exp)
-     (iat . ,iat))))
-
-(define-public (id-token-header code)
-  (car (the-id-token code)))
-
-(define-public (id-token-payload code)
-  (cdr (the-id-token code)))
-
-(define-public (id-token-alg code)
-  (when (id-token? code)
-    (set! code (id-token-header code)))
-  (jws-alg (the-id-token-header code)))
-
-(define-public (id-token-webid code)
-  (when (id-token? code)
-    (set! code (id-token-payload code)))
-  (string->uri
-   (assq-ref (the-id-token-payload code) 'webid)))
-
-(define-public (id-token-iss code)
-  (when (id-token? code)
-    (set! code (id-token-payload code)))
-  (string->uri
-   (assq-ref (the-id-token-payload code) 'iss)))
-
-(define-public (id-token-sub code)
-  (when (id-token? code)
-    (set! code (id-token-payload code)))
-  (assq-ref (the-id-token-payload code) 'sub))
-
-(define-public (id-token-aud code)
-  (when (id-token? code)
-    (set! code (id-token-payload code)))
-  (string->uri
-   (assq-ref (the-id-token-payload code) 'aud)))
-
-(define-public (id-token-nonce code)
-  (when (id-token? code)
-    (set! code (id-token-payload code)))
-  (assq-ref (the-id-token-payload code) 'nonce))
-
-(define-public (id-token-exp code)
-  (when (id-token? code)
-    (set! code (id-token-payload code)))
-  (time-utc->date
-   (make-time time-utc 0 (assq-ref
-                          (the-id-token-payload code)
-                          'exp))))
-
-(define-public (id-token-iat code)
-  (when (id-token? code)
-    (set! code (id-token-payload code)))
-  (time-utc->date
-   (make-time time-utc 0 (assq-ref
-                          (the-id-token-payload code)
-                          'iat))))
-
-(define*-public (id-token-decode str #:key (http-get http-get))
+(define (id-token-webid code)
+  (match (the-id-token code)
+    ((_ . payload)
+     (string->uri (assq-ref payload 'webid)))))
+
+(define (id-token-iss code)
+  (match (the-id-token code)
+    ((_ . payload)
+     (string->uri (assq-ref payload 'iss)))))
+
+(define (id-token-sub code)
+  (match (the-id-token code)
+    ((_ . payload)
+     (assq-ref payload 'sub))))
+
+(define (id-token-aud code)
+  (match (the-id-token code)
+    ((_ . payload)
+     (string->uri (assq-ref payload 'aud)))))
+
+(define (id-token-nonce code)
+  (match (the-id-token code)
+    ((_ . payload)
+     (assq-ref payload 'nonce))))
+
+(define (id-token-iat code)
+  (match (the-id-token code)
+    ((_ . payload)
+     (time-utc->date
+      (make-time time-utc 0 (assq-ref payload 'iat))))))
+
+(define (id-token-exp code)
+  (match (the-id-token code)
+    ((_ . payload)
+     (time-utc->date
+      (make-time time-utc 0 (assq-ref payload 'exp))))))
+
+(define* (id-token-decode str #:key (http-get http-get))
   (with-exception-handler
       (lambda (error)
-        (raise-cannot-decode-id-token str error))
+        (let ((final-message
+               (if (exception-with-message? error)
+                   (format #f (G_ "the ID token is invalid: ~a")
+                           (exception-message error))
+                   (format #f (G_ "the ID token is invalid")))))
+          (raise-exception
+           (make-exception
+            (make-invalid-id-token)
+            (make-exception-with-message final-message)
+            error))))
     (lambda ()
       (jws-decode
        str
        (lambda (token)
          (let ((iss (id-token-iss token)))
-           (let ((cfg
-                  (with-exception-handler
-                      (lambda (error)
-                        (raise-cannot-fetch-issuer-configuration iss error))
-                    (lambda ()
-                      (get-oidc-configuration
-                       (uri-host iss)
-                       #:userinfo (uri-userinfo iss)
-                       #:port (uri-port iss)
-                       #:http-get http-get)))))
-             (with-exception-handler
-                 (lambda (error)
-                   (raise-cannot-fetch-jwks iss
-                                            (oidc-configuration-jwks-uri cfg)
-                                            error))
-               (lambda ()
-                 (oidc-configuration-jwks cfg #:http-get http-get))))))))))
-
-(define-public (id-token-encode id-token key)
+           (let* ((cfg
+                   (with-exception-handler
+                       (lambda (error)
+                         (let ((final-message
+                                (if (exception-with-message? error)
+                                    (format #f (G_ "I cannot query the identity provider configuration: ~a")
+                                            (exception-message error))
+                                    (format #f (G_ "I cannot query the identity provider configuratioon")))))
+                           (raise-exception
+                            (make-exception
+                             (make-cannot-query-identity-provider iss)
+                             (make-exception-with-message final-message)
+                             error))))
+                     (lambda ()
+                       (get-oidc-configuration
+                        (uri-host iss)
+                        #:userinfo (uri-userinfo iss)
+                        #:port (uri-port iss)
+                        #:http-get http-get))))
+                  (jwks
+                   (with-exception-handler
+                       (lambda (error)
+                         (raise-exception
+                          (make-exception
+                           (make-cannot-query-identity-provider iss)
+                           (make-exception-with-message
+                            (if (exception-with-message? error)
+                                (format #f (G_ "I cannot query the JWKS URI of the identity provider: ~a")
+                                        (exception-message error))
+                                (format #f (G_ "I cannot query the JWKS URI of the identity provider")))))))
+                     (lambda ()
+                       (oidc-configuration-jwks cfg #:http-get http-get)))))
+             (let ((iat (id-token-iat token))
+                   (exp (id-token-exp token))
+                   (current-date ((p:current-date))))
+               (let ((iat-s (time-second (date->time-utc iat)))
+                     (exp-s (time-second (date->time-utc exp)))
+                     (current-s (time-second (date->time-utc current-date))))
+                 (when (>= iat-s (+ current-s 5))
+                   (let ((final-message
+                          (format #f (G_ "the ID token is signed in the future, ~a, relative to current ~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)))))
+                 (when (>= current-s exp-s)
+                   (let ((final-message
+                          (format #f (G_ "the ID token expired ~a, which is in the past (from ~a)")
+                                  (date->string exp)
+                                  (date->string current-date))))
+                     (raise-exception
+                      (make-exception
+                       (make-expired exp current-date)
+                       (make-exception-with-message final-message)))))))
+             jwks)))))))
+
+(define (id-token-encode id-token key)
   (with-exception-handler
       (lambda (error)
-        (raise-cannot-encode-id-token id-token key error))
+        (let ((final-message
+               (if (exception-with-message? error)
+                   (format #f (G_ "cannot encode the ID token: ~a")
+                           (exception-message error))
+                   (format #f (G_ "cannot encode the ID token")))))
+          (raise-exception
+           (make-exception-with-message final-message))))
     (lambda ()
       (jws-encode id-token key))))
 
-(define*-public (issue-id-token
-                 issuer-key
-                 #:key
-                 (alg #f)
-                 (webid #f)
-                 (iss #f)
-                 (sub #f)
-                 (aud #f)
-                 (validity 3600))
+(define* (issue-id-token
+          issuer-key
+          #:key
+          (alg #f)
+          (webid #f)
+          (iss #f)
+          (sub #f)
+          (aud #f)
+          (validity 3600))
   (unless sub
-    (set! sub webid))
-  (id-token-encode
-   (make-id-token
-    `((alg . ,(symbol->string alg)))
-    (let ((iat (time-second (date->time-utc ((p:current-date))))))
-      (make-id-token-payload webid iss sub aud (stubs:random 12)
-                             (+ iat validity) iat)))
-   issuer-key))
+    (set! sub (uri->string webid)))
+  (let* ((iat (time-second (date->time-utc ((p:current-date)))))
+         (exp (+ iat validity)))
+    (jws-encode
+     (the-id-token
+      `(((alg . ,(symbol->string alg)))
+        . ((webid . ,(uri->string webid))
+           (iss . ,(uri->string iss))
+           (sub . ,sub)
+           (aud . ,(uri->string aud))
+           (nonce . ,(stubs:random 12))
+           (iat . ,iat)
+           (exp . ,exp))))
+     issuer-key)))