Switch to a more sensible error reporting system

1 files changed, 305 insertions, 179 deletions

diff --git a/src/scm/webid-oidc/access-token.scm b/src/scm/webid-oidc/access-token.scm
index acdc56f..6023108 100644
--- a/src/scm/webid-oidc/access-token.scm
+++ b/src/scm/webid-oidc/access-token.scm
@@ -1,5 +1,5 @@
-;; webid-oidc, implementation of the Solid specification
-;; Copyright (C) 2020, 2021  Vivien Kraus
+;; disfluid, implementation of the Solid specification
+;; Copyright (C) 2021  Vivien Kraus
 
 ;; This program is free software: you can redistribute it and/or modify
 ;; it under the terms of the GNU Affero General Public License as
@@ -19,204 +19,330 @@
   #:use-module (webid-oidc errors)
   #:use-module (webid-oidc jwk)
   #:use-module (webid-oidc oidc-configuration)
+  #: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 match)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 exceptions)
+  #:declarative? #t
+  #:export
+  (
 
-(define-public (the-access-token-header x)
-  (with-exception-handler
-      (lambda (error)
-        (raise-not-an-access-token-header x error))
-    (lambda ()
-      (the-jws-header x))))
+   &invalid-access-token
+   make-invalid-access-token
+   invalid-access-token?
+
+   the-access-token
+   access-token?
+
+   access-token-alg
 
-(define-public (access-token-header? x)
-  (false-if-exception
-   (and (the-access-token-header x) #t)))
+   access-token-webid
+   access-token-iss
+   access-token-aud
+   access-token-iat
+   access-token-exp
+   access-token-client-id
+   access-token-cnf/jkt
 
-(define-public (the-access-token-payload x)
+   access-token-decode
+   issue-access-token
+   ))
+
+(define-exception-type
+  &invalid-access-token
+  &external-error
+  make-invalid-access-token
+  invalid-access-token?)
+
+;; The order is meaningful in this module, the-access-token reorders
+;; them.
+(define (the-access-token x)
   (with-exception-handler
       (lambda (error)
-        (raise-not-an-access-token-payload x error))
+        (let ((final-message
+               (cond
+                ((invalid-jws? error)
+                 (if (exception-with-message? error)
+                     (format #f (G_ "this is not an access token, because it is not even a JWS: ~a")
+                             (exception-message error))
+                     (format #f (G_ "this is not an access token, 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-access-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))
-              (aud (assq-ref x 'aud))
-              (iat (assq-ref x 'iat))
-              (exp (assq-ref x 'exp))
-              (cnf (assq-ref x 'cnf))
-              (client-id (assq-ref x 'client_id)))
-          (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 (equal? aud "solid")
-            (raise-incorrect-aud-field aud))
-          (unless (integer? iat)
-            (raise-incorrect-iat-field iat))
-          (unless (and (integer? exp) (>= exp iat))
-            (raise-incorrect-exp-field exp))
-          (unless (and client-id (string? client-id) (string->uri client-id))
-            (raise-incorrect-client-id-field client-id))
-          (unless (and cnf (assq-ref cnf 'jkt) (string? (assq-ref cnf 'jkt)))
-            (raise-incorrect-cnf/jkt-field (and cnf (assq-ref cnf 'jkt))))
-          x)))))
-
-(define-public (access-token-payload? x)
-  (false-if-exception
-   (and (the-access-token-header x) #t)))
-
-(define-public (the-access-token x)
-  (with-exception-handler
-      (lambda (cause)
-        (raise-not-an-access-token x cause))
-    (lambda ()
-      (cons (the-access-token-header (car x))
-            (the-access-token-payload (cdr x))))))
-
-(define-public (access-token? x)
-  (false-if-exception
-   (and (the-access-token x) #t)))
-
-(define-public (make-access-token header payload)
-  (the-access-token
-   (cons header payload)))
-
-(define-public (make-access-token-payload webid iss iat exp cnf/jkt client-id)
-  (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? client-id)
-    (set! client-id (uri->string client-id)))
-  (the-access-token-payload
-   `((webid . ,webid)
-     (iss . ,iss)
-     (aud . "solid")
-     (iat . ,iat)
-     (exp . ,exp)
-     (cnf . ((jkt . ,cnf/jkt)))
-     (client_id . ,client-id))))
-
-(define-public (access-token-header code)
-  (car (the-access-token code)))
-
-(define-public (access-token-payload code)
-  (cdr (the-access-token code)))
-
-(define-public (access-token-alg code)
-  (when (access-token? code)
-    (set! code (access-token-header code)))
-  (jws-alg (the-access-token-header code)))
-
-(define-public (access-token-webid code)
-  (when (access-token? code)
-    (set! code (access-token-payload code)))
-  (string->uri
-   (assq-ref (the-access-token-payload code) 'webid)))
-
-(define-public (access-token-iss code)
-  (when (access-token? code)
-    (set! code (access-token-payload code)))
-  (string->uri
-   (assq-ref (the-access-token-payload code) 'iss)))
-
-(define-public (access-token-aud code)
-  (when (access-token? code)
-    (set! code (access-token-payload code)))
-  (assq-ref (the-access-token-payload code) 'aud))
-
-(define-public (access-token-exp code)
-  (when (access-token? code)
-    (set! code (access-token-payload code)))
-  (time-utc->date
-   (make-time time-utc 0 (assq-ref
-                          (the-access-token-payload code)
-                          'exp))))
-
-(define-public (access-token-iat code)
-  (when (access-token? code)
-    (set! code (access-token-payload code)))
-  (time-utc->date
-   (make-time time-utc 0 (assq-ref
-                          (the-access-token-payload code)
-                          'iat))))
-
-(define-public (access-token-cnf/jkt code)
-  (when (access-token? code)
-    (set! code (access-token-payload code)))
-  (assq-ref
-   (assq-ref (the-access-token-payload code) 'cnf)
-   'jkt))
-
-(define-public (access-token-client-id code)
-  (when (access-token? code)
-    (set! code (access-token-payload code)))
-  (string->uri
-   (assq-ref (the-access-token-payload code) 'client_id)))
-
-(define*-public (access-token-decode str #:key (http-get http-get))
+      (match (the-jws x)
+        ((header . payload)
+         (let examine-payload ((payload payload)
+                               (webid #f)
+                               (iss #f)
+                               (aud #f)
+                               (iat #f)
+                               (exp #f)
+                               (cnf #f)
+                               (client-id #f)
+                               (other-fields '()))
+           (match payload
+             (()
+              (unless (and webid iss aud iat exp cnf client-id)
+                ;; Missing some things
+                (fail (format #f (G_ "the payload is missing ~s")
+                              `(,@(if webid '() '("webid"))
+                                ,@(if iss '() '("iss"))
+                                ,@(if aud '() '("aud"))
+                                ,@(if iat '() '("iat"))
+                                ,@(if exp '() '("exp"))
+                                ,@(if cnf '() '("cnf"))
+                                ,@(if client-id '() '("client_id"))))))
+              `(,header
+                . ((webid . ,(uri->string webid))
+                   (iss . ,(uri->string iss))
+                   (aud . "solid")
+                   (iat . ,(time-second (date->time-utc iat)))
+                   (exp . ,(time-second (date->time-utc exp)))
+                   (client_id . ,(uri->string client-id))
+                   (cnf . ,cnf)
+                   ,@(reverse other-fields))))
+             ((('webid . (? string? (= string->uri (? uri? webid-given)))) payload ...)
+              (examine-payload payload
+                               (or webid webid-given)
+                               iss aud iat exp cnf client-id other-fields))
+             ((('webid . infringing) payload ...)
+              (fail (format #f (G_ "the \"webid\" field should be an URI, ~s is given")
+                            infringing)))
+             ((('iss . (? string? (= string->uri (? uri? iss-given)))) payload ...)
+              (examine-payload payload webid
+                               (or iss iss-given)
+                               aud iat exp cnf client-id other-fields))
+             ((('iss . infringing) payload ...)
+              (fail (format #f (G_ "the \"iss\" field should be an URI, ~s is given")
+                            infringing)))
+             ((('aud . "solid") payload ...)
+              (examine-payload payload webid iss #t iat exp cnf client-id other-fields))
+             ((('aud . infringing) payload ...)
+              (fail (format #f (G_ "the \"aud\" field should be set to \"solid\", ~s is given")
+                            infringing)))
+             ((('iat . (? (cute >= <> 0) (? integer? iat-given))) payload ...)
+              (examine-payload payload webid iss aud
+                               (or iat (time-utc->date (make-time time-utc 0 iat-given)))
+                               exp cnf client-id other-fields))
+             ((('iat . infringing) payload ...)
+              (fail (format #f (G_ "the \"iat\" field should be a timestamp, ~s is given")
+                            infringing)))
+             ((('exp . (? (cute >= <> 0) (? integer? exp-given))) payload ...)
+              (examine-payload payload webid iss aud iat
+                               (or exp (time-utc->date (make-time time-utc 0 exp-given)))
+                               cnf client-id other-fields))
+             ((('exp . infringing) payload ...)
+              (fail (format #f (G_ "the \"exp\" field should be a timestamp, ~s is given")
+                            infringing)))
+             ((('cnf . cnf) payload ...)
+              (let examine-cnf ((data cnf)
+                                (jkt #f)
+                                (other-cnf-fields '()))
+                (match data
+                  (()
+                   (unless jkt
+                     (fail (format #f (G_ "the \"cnf\" / \"jkt\" field is missing"))))
+                   (examine-payload payload webid iss aud iat exp
+                                    `((jkt . ,jkt)
+                                      ,@(reverse other-cnf-fields))
+                                    client-id other-fields))
+                  ((('jkt . (? string? jkt-given)) data ...)
+                   (examine-cnf data (or jkt jkt-given other-cnf-fields) other-cnf-fields))
+                  ((('jkt . infringing) _ ...)
+                   (fail (format #f (G_ "the \"cnf\" / \"jkt\" field should be a string, ~s is given")
+                                 infringing)))
+                  ((field data ...)
+                   (examine-cnf data jkt `(,field ,@other-cnf-fields)))
+                  (data
+                   (fail (format #f (G_ "the \"cnf\" field should be an object, ~s is given")
+                                 data))))))
+             ((('client_id . (? string? (= string->uri (? uri? client-id-given)))) payload ...)
+              (examine-payload payload webid iss aud iat exp cnf
+                               (or client-id client-id-given)
+                               other-fields))
+             ((('client_id . infringing) payload ...)
+              (fail (format #f (G_ "the \"client_id\" field should be an URI, ~s is given")
+                            infringing)))
+             ((field payload ...)
+              (examine-payload payload webid iss aud iat exp cnf client-id
+                               `(,field ,@other-fields))))))
+        (else
+         (scm-error 'wrong-type-arg "the-access-token"
+                    "expected a pair of lists"
+                    (list x)))))))
+
+(define (access-token? x)
+  (false-if-exception (the-access-token x)))
+
+(define (access-token-alg code)
+  (match (the-access-token code)
+    ((header . _)
+     (string->symbol (assq-ref header 'alg)))))
+
+(define (access-token-webid code)
+  (match (the-access-token code)
+    ((_ . payload)
+     (string->uri (assq-ref payload 'webid)))))
+
+(define (access-token-iss code)
+  (match (the-access-token code)
+    ((_ . payload)
+     (string->uri (assq-ref payload 'iss)))))
+
+(define (access-token-aud code)
+  (match (the-access-token code)
+    ((_ . payload)
+     (assq-ref payload 'aud))))
+
+(define (access-token-iat code)
+  (match (the-access-token code)
+    ((_ . payload)
+     (time-utc->date
+      (make-time time-utc 0 (assq-ref payload 'iat))))))
+
+(define (access-token-exp code)
+  (match (the-access-token code)
+    ((_ . payload)
+     (time-utc->date
+      (make-time time-utc 0 (assq-ref payload 'exp))))))
+
+(define (access-token-client-id code)
+  (match (the-access-token code)
+    ((_ . payload)
+     (string->uri (assq-ref payload 'client-id)))))
+
+(define (access-token-cnf/jkt code)
+  (match (the-access-token code)
+    ((_ . payload)
+     (assq-ref (assq-ref payload 'cnf) 'jkt))))
+
+(define* (access-token-decode str #:key (http-get http-get))
   (with-exception-handler
       (lambda (error)
-        (raise-cannot-decode-access-token str error))
+        (let ((final-message
+               (if (exception-with-message? error)
+                   (format #f (G_ "the access token is invalid: ~a")
+                           (exception-message error))
+                   (format #f (G_ "the access token is invalid")))))
+          (raise-exception
+           (make-exception
+            (make-invalid-access-token)
+            (make-exception-with-message final-message)
+            error))))
     (lambda ()
       (jws-decode
        str
        (lambda (token)
-         (let ((iss (access-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 (access-token-encode access-token key)
+         (let* ((iss (access-token-iss token))
+                (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)
+                       (let ((final-message
+                              (if (exception-with-message? error)
+                                  (format #f (G_ "I cannot query the identity provider public keys: ~a")
+                                          (exception-message error))
+                                  (format #f (G_ "I cannot query the identity provider public keys")))))
+                         (raise-exception
+                          (make-exception
+                           (make-cannot-query-identity-provider iss)
+                           (make-exception-with-message final-message)
+                           error))))
+                   (lambda ()
+                     (oidc-configuration-jwks cfg #:http-get http-get)))))
+           (let ((iat (access-token-iat token))
+                 (exp (access-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 access 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 access 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 (access-token-encode access-token key)
   (with-exception-handler
       (lambda (error)
-        (raise-cannot-encode-access-token access-token key error))
+        (let ((final-message
+               (if (exception-with-message? error)
+                   (format #f (G_ "cannot encode the access token: ~a")
+                           (exception-message error))
+                   (format #f (G_ "cannot encode the access token")))))
+          (raise-exception
+           (make-exception-with-message final-message))))
     (lambda ()
       (jws-encode access-token key))))
 
-(define*-public (issue-access-token
-                 issuer-key
-                 #:key
-                 (alg #f)
-                 (webid #f)
-                 (iss #f)
-                 (validity 3600)
-                 (client-key #f)
-                 (cnf/jkt #f)
-                 (client-id #f))
+(define* (issue-access-token
+          issuer-key
+          #:key
+          (alg #f)
+          (webid #f)
+          (iss #f)
+          (validity 3600)
+          (client-key #f)
+          (cnf/jkt #f)
+          (client-id #f))
   (when client-key
     (set! cnf/jkt (jkt client-key)))
-  (access-token-encode
-   (make-access-token
-    `((alg . ,(if (symbol? alg) (symbol->string alg) alg)))
-    (let ((iat (time-second (date->time-utc ((p:current-date))))))
-      (make-access-token-payload
-       webid iss iat (+ iat validity) cnf/jkt client-id)))
-   issuer-key))
+  (let* ((iat (time-second (date->time-utc ((p:current-date)))))
+         (exp (+ iat validity)))
+    (jws-encode
+     (the-access-token
+      `(((alg . ,(symbol->string alg)))
+        . ((webid . ,(uri->string webid))
+           (iss . ,(uri->string iss))
+           (aud . "solid")
+           (iat . ,iat)
+           (exp . ,exp)
+           (cnf . ((jkt . ,cnf/jkt)))
+           (client_id . ,(uri->string client-id)))))
+     issuer-key)))