Switch to a more sensible error reporting system

1 files changed, 187 insertions, 130 deletions

diff --git a/src/scm/webid-oidc/authorization-code.scm b/src/scm/webid-oidc/authorization-code.scm
index 267d67a..95dcc4a 100644
--- a/src/scm/webid-oidc/authorization-code.scm
+++ b/src/scm/webid-oidc/authorization-code.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,146 +21,203 @@
   #:use-module (webid-oidc jti)
   #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module (web uri)
-  #:use-module (srfi srfi-19))
-
-(define-public (the-authorization-code-header x)
-  (with-exception-handler
-      (lambda (error)
-        (raise-not-an-authorization-code-header x error))
-    (lambda ()
-      (the-jws-header x))))
-
-(define-public (authorization-code-header? x)
-  (false-if-exception
-   (and (the-authorization-code-header x) #t)))
-
-(define-public (the-authorization-code-payload x)
-  (with-exception-handler
-      (lambda (error)
-        (raise-not-an-authorization-code-payload x error))
-    (lambda ()
-      (let ((x (the-jws-payload x)))
-        (let ((exp (assq-ref x 'exp))
-              (jti (assq-ref x 'jti))
-              (webid (assq-ref x 'webid))
-              (client-id (assq-ref x 'client_id)))
-          (unless (integer? exp)
-            (raise-incorrect-exp-field exp))
-          (unless (string? jti)
-            (raise-incorrect-jti-field jti))
-          (unless (and (string? webid) (string->uri webid))
-            (raise-incorrect-webid-field webid))
-          (unless (and (string? client-id) (string->uri client-id))
-            (raise-incorrect-client-id-field client-id))
-          x)))))
-
-(define-public (authorization-code-payload? x)
-  (false-if-exception
-   (and (the-authorization-code-payload x) #t)))
-
-(define-public (the-authorization-code x)
+  #:use-module (srfi srfi-19)
+  #:use-module (webid-oidc web-i18n)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 exceptions)
+  #:declarative? #t
+  #:export
+  (
+
+   &invalid-authorization-code
+   make-invalid-authorization-code
+   invalid-authorization-code?
+
+   the-authorization-code
+   authorization-code?
+
+   authorization-code-alg
+
+   authorization-code-webid
+   authorization-code-client-id
+   authorization-code-jti
+   authorization-code-exp
+
+   authorization-code-decode
+   issue-authorization-code
+   ))
+
+(define-exception-type
+  &invalid-authorization-code
+  &external-error
+  make-invalid-authorization-code
+  invalid-authorization-code?)
+
+(define (the-authorization-code x)
   (with-exception-handler
       (lambda (error)
-        (raise-not-an-authorization-code x error))
+        (let ((final-message
+               (cond
+                ((invalid-jws? error)
+                 (if (exception-with-message? error)
+                     (format #f (G_ "this is not an authorization code, because it is not even a JWS: ~a")
+                             (exception-message error))
+                     (format #f (G_ "this is not an authorization code, because it is not even a JWS"))))
+                (else
+                 (if (exception-with-message? error)
+                     (format #f (G_ "this is not an authorization code: ~a")
+                             (exception-message error))
+                     (format #f (G_ "this is not an authorization code")))))))
+          (raise-exception
+           (make-exception
+            (make-invalid-authorization-code)
+            (make-exception-with-message final-message)
+            error))))
     (lambda ()
-      (cons (the-authorization-code-header (car x))
-            (the-authorization-code-payload (cdr x))))))
-
-(define-public (authorization-code? x)
-  (false-if-exception
-   (and (the-authorization-code x) #t)))
-
-(define-public (make-authorization-code header payload)
-  (the-authorization-code (cons header payload)))
-
-(define-public (make-authorization-code-header alg)
-  (when (symbol? alg)
-    (set! alg (symbol->string alg)))
-  (the-authorization-code-header
-   `((alg . ,alg))))
-
-(define-public (make-authorization-code-payload exp jti sub aud)
-  (when (date? exp)
-    (set! exp (date->time-utc exp)))
-  (when (time? exp)
-    (set! exp (time-second exp)))
-  (when (uri? sub)
-    (set! sub (uri->string sub)))
-  (when (uri? aud)
-    (set! aud (uri->string aud)))
-  (the-authorization-code-payload
-   `((exp . ,exp)
-     (jti . ,jti)
-     (webid . ,sub)
-     (client_id . ,aud))))
-
-(define-public (authorization-code-header code)
-  (car (the-authorization-code code)))
-
-(define-public (authorization-code-payload code)
-  (cdr (the-authorization-code code)))
-
-(define-public (authorization-code-alg code)
-  (when (authorization-code? code)
-    (set! code (authorization-code-header code)))
-  (jws-alg (the-authorization-code-header code)))
-
-(define-public (authorization-code-exp code)
-  (when (authorization-code? code)
-    (set! code (authorization-code-payload code)))
-  (time-utc->date
-   (make-time time-utc 0 (assq-ref
-                          (the-authorization-code-payload code)
-                          'exp))))
-
-(define-public (authorization-code-jti code)
-  (when (authorization-code? code)
-    (set! code (authorization-code-payload code)))
-  (assq-ref (the-authorization-code-payload code) 'jti))
-
-(define-public (authorization-code-webid code)
-  (when (authorization-code? code)
-    (set! code (authorization-code-payload code)))
-  (string->uri
-   (assq-ref (the-authorization-code-payload code) 'webid)))
-
-(define-public (authorization-code-client-id code)
-  (when (authorization-code? code)
-    (set! code (authorization-code-payload code)))
-  (string->uri
-   (assq-ref (the-authorization-code-payload code) 'client_id)))
-
-(define-public (authorization-code-decode str jwk)
+      (match (the-jws x)
+        ((header . payload)
+         (let examine-payload ((payload payload)
+                               (webid #f)
+                               (client-id #f)
+                               (jti #f)
+                               (exp #f)
+                               (other-fields '()))
+           (match payload
+             (()
+              (unless (and webid client-id jti exp)
+                (fail (format #f (G_ "the payload is missing ~s")
+                              `(,@(if webid '() '("webid"))
+                                ,@(if client-id '() '("client_id"))
+                                ,@(if jti '() '("jti"))
+                                ,@(if exp '() '("exp"))))))
+              `(,header
+                . ((webid . ,(uri->string webid))
+                   (client_id . ,(uri->string client-id))
+                   (jti . ,jti)
+                   (exp . ,(time-second (date->time-utc exp)))
+                   ,@(reverse other-fields))))
+             ((('webid . (? string? (= string->uri (? uri? webid-given)))) payload ...)
+              (examine-payload payload
+                               (or webid webid-given)
+                               client-id jti exp other-fields))
+             ((('webid . infringing) payload ...)
+              (fail (format #f (G_ "the \"webid\" field should be an URI, ~s is given")
+                            infringing)))
+             ((('client_id . (? string? (= string->uri (? uri? client-id-given)))) payload ...)
+              (examine-payload payload webid
+                               (or client-id client-id-given)
+                               jti exp other-fields))
+             ((('client_id . infringing) payload ...)
+              (fail (format #f (G_ "the \"client_id\" field should be an URI, ~s is given")
+                            infringing)))
+             ((('jti . (? string? jti-given)) payload ...)
+              (examine-payload payload webid client-id
+                               (or jti jti-given)
+                               exp other-fields))
+             ((('jti . invalid) payload ...)
+              (fail (format #f (G_ "the \"jti\" field should be a string, ~s is given")
+                            invalid)))
+             ((('exp . (? (lambda (x) (and (integer? x) (>= x 0))) exp-given)) payload ...)
+              (examine-payload payload webid client-id jti
+                               (or exp (time-utc->date (make-time time-utc 0 exp-given)))
+                               other-fields))
+             ((('exp . infringing) payload ...)
+              (fail (format #f (G_ "the \"exp\" field should be a timestamp, ~s is given")
+                            infringing)))
+             ((field payload ...)
+              (examine-payload payload webid client-id jti exp `(,field ,@other-fields))))))
+        (else
+         (scm-error 'wrong-type-arg "the-authorization-code"
+                    "expected a pair of lists"
+                    (list x)))))))
+
+(define (authorization-code? x)
+  (false-if-exception (the-authorization-code x)))
+
+(define (authorization-code-alg x)
+  (match (the-authorization-code x)
+    ((header . _)
+     (string->symbol (assq-ref header 'alg)))))
+
+(define (authorization-code-webid x)
+  (match (the-authorization-code x)
+    ((_ . payload)
+     (string->uri (assq-ref payload 'webid)))))
+
+(define (authorization-code-client-id x)
+  (match (the-authorization-code x)
+    ((_ . payload)
+     (string->uri (assq-ref payload 'client_id)))))
+
+(define (authorization-code-jti x)
+  (match (the-authorization-code x)
+    ((_ . payload)
+     (assq-ref payload 'jti))))
+
+(define (authorization-code-exp x)
+  (match (the-authorization-code x)
+    ((_ . payload)
+     (time-utc->date (make-time time-utc 0 (assq-ref payload 'exp))))))
+
+(define (authorization-code-decode str jwk)
   (parameterize ((p:current-date
                   (time-second (date->time-utc ((p:current-date))))))
     (with-exception-handler
         (lambda (error)
-          (raise-cannot-decode-authorization-code str error))
+          (let ((final-message
+                 (if (exception-with-message? error)
+                     (format #f (G_ "the authorization code is invalid: ~a")
+                             (exception-message error))
+                     (format #f (G_ "the authorization code is invalid")))))
+            (raise-exception
+             (make-exception
+              (make-invalid-authorization-code)
+              (make-exception-with-message final-message)
+              error))))
       (lambda ()
         (let ((code (the-authorization-code (jws-decode str (lambda (x) jwk)))))
-          (let ((exp (time-second (date->time-utc (authorization-code-exp code))))
-                (current-time (time-second (date->time-utc ((p:current-date))))))
-            (unless (<= current-time exp)
-              (raise-authorization-code-expired exp current-time))
-            (unless (jti-check (authorization-code-jti code)
-                               (- exp current-time))
-              (with-exception-handler
-                  (lambda (error)
-                    (raise-jti-found (authorization-code-jti code) error))
-                (lambda ()
-                  (error "the jti-check function returned #f"))))
-            code))))))
-
-(define-public (authorization-code-encode authorization-code key)
+          (let ((exp (authorization-code-exp code))
+                (current-date ((p:current-date))))
+            (let ((exp-s (time-second (date->time-utc exp)))
+                  (current-s (time-second (date->time-utc current-date))))
+              (when (>= current-s exp-s)
+                (let ((final-message
+                       (format #f (G_ "the authorization 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)))))
+              (jti-check (authorization-code-jti code)
+                         (- exp-s current-s))
+              code)))))))
+
+(define (authorization-code-encode authorization-code key)
   (with-exception-handler
       (lambda (error)
-        (raise-cannot-encode-authorization-code authorization-code key error))
+        (let ((final-message
+               (if (exception-with-message? error)
+                   (format #f (G_ "cannot encode the authorization code: ~a")
+                           (exception-message error))
+                   (format #f (G_ "cannot encode the authorization code")))))
+          (raise-exception
+           (make-exception-with-message final-message))))
     (lambda ()
       (jws-encode authorization-code key))))
 
-(define-public (issue-authorization-code alg jwk exp sub aud)
-  (authorization-code-encode
-   (make-authorization-code
-    (make-authorization-code-header alg)
-    (make-authorization-code-payload exp (stubs:random 12) sub aud))
-   jwk))
+(define* (issue-authorization-code issuer-key
+                                   #:key
+                                   alg
+                                   (validity 120)
+                                   webid
+                                   client-id)
+  (let* ((iat (time-second (date->time-utc ((p:current-date)))))
+         (exp (+ iat validity)))
+    (authorization-code-encode
+     `(((alg . ,(symbol->string alg)))
+       . ((webid . ,(uri->string webid))
+          (client_id . ,(uri->string client-id))
+          (exp . ,exp)
+          (jti . ,(stubs:random 12))))
+     issuer-key)))