From b074df926f069081bdf6c75ced47d7409abdc7b6 Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Tue, 1 Dec 2020 19:46:24 +0100
Subject: Add an authorization code data structure

---
 src/scm/webid-oidc/errors.scm | 87 +++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 87 insertions(+)

(limited to 'src/scm/webid-oidc/errors.scm')

diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index d6f685a..879b23c 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -619,6 +619,74 @@
   (raise-exception
    ((record-constructor &cannot-fetch-client-manifest) id cause)))
 
+(define-public &not-an-authorization-code
+  (make-exception-type
+   '&not-an-authorization-code
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-an-authorization-code value cause)
+  (raise-exception
+   ((record-constructor &not-an-authorization-code) value cause)))
+
+(define-public &not-an-authorization-code-header
+  (make-exception-type
+   '&not-an-authorization-code-header
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-an-authorization-code-header value cause)
+  (raise-exception
+   ((record-constructor &not-an-authorization-code-header) value cause)))
+
+(define-public &not-an-authorization-code-payload
+  (make-exception-type
+   '&not-an-authorization-code-payload
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-an-authorization-code-payload value cause)
+  (raise-exception
+   ((record-constructor &not-an-authorization-code-payload) value cause)))
+
+(define-public &authorization-code-expired
+  (make-exception-type
+   '&authorization-code-expired
+   &external-error
+   '(exp current-time)))
+
+(define-public (raise-authorization-code-expired exp current-time)
+  (when (integer? exp)
+    (set! exp (make-time time-utc 0 exp)))
+  (when (time? exp)
+    (set! exp (time-utc->date exp)))
+  (when (integer? current-time)
+    (set! current-time (make-time time-utc 0 current-time)))
+  (when (time? current-time)
+    (set! current-time (time-utc->date current-time)))
+  (raise-exception
+   ((record-constructor &authorization-code-expired) exp current-time)))
+
+(define-public &cannot-decode-authorization-code
+  (make-exception-type
+   '&cannot-decode-authorization-code
+   &external-error
+   '(value cause)))
+
+(define-public (raise-cannot-decode-authorization-code value cause)
+  (raise-exception
+   ((record-constructor &cannot-decode-authorization-code) value cause)))
+
+(define-public &cannot-encode-authorization-code
+  (make-exception-type
+   '&cannot-encode-authorization-code
+   &external-error
+   '(authorization-code key cause)))
+
+(define-public (raise-cannot-encode-authorization-code authorization-code key cause)
+  (raise-exception
+   ((record-constructor &cannot-encode-authorization-code) authorization-code key cause)))
+
 (define*-public (error->str err #:key (max-depth #f))
   (if (record? err)
       (let* ((type (record-type-descriptor err))
@@ -879,6 +947,25 @@
           ((&cannot-fetch-client-manifest)
            (format #f (G_ "I could not fetch the client manifest of ~a (because ~a)")
                    (uri->string (get 'id)) (recurse (get 'cause))))
+          ((&not-an-authorization-code)
+           (format #f (G_ "~s is not an authorization code (because ~a)")
+                   (get 'value) (recurse (get 'cause))))
+          ((&not-an-authorization-code-header)
+           (format #f (G_ "~s is not an authorization code header (because ~a)")
+                   (get 'value) (recurse (get 'cause))))
+          ((&not-an-authorization-code-payload)
+           (format #f (G_ "~s is not an authorization code payload (because ~a)")
+                   (get 'value) (recurse (get 'cause))))
+	  ((&authorization-code-expired)
+	   (format #f (G_ "the current time is ~a, and the authorization code expired at ~a")
+		   (time-second (date->time-utc (get 'current-time)))
+		   (time-second (date->time-utc (get 'exp)))))
+          ((&cannot-decode-authorization-code)
+           (format #f (G_ "I cannot decode ~s as an authorization code (because ~a)")
+                   (get 'value) (recurse (get 'cause))))
+          ((&cannot-encode-authorization-code)
+           (format #f (G_ "I cannot encode ~s as an authorization code (because ~a)")
+                   (get 'value) (recurse (get 'cause))))
           ((&compound-exception)
            (let ((components (get 'components)))
              (if (null? components)
-- 
cgit v1.2.3