Add an authorization code data structure

3 files changed, 242 insertions, 2 deletions

diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index 709eb1b..6736595 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -10,7 +10,8 @@ dist_webidoidcmod_DATA += \
   %reldir%/jti.scm \
   %reldir%/dpop-proof.scm \
   %reldir%/fetch.scm \
-  %reldir%/client-manifest.scm
+  %reldir%/client-manifest.scm \
+  %reldir%/authorization-code.scm
 webidoidcgo_DATA += \
   %reldir%/errors.go \
   %reldir%/stubs.go \
@@ -23,4 +24,5 @@ webidoidcgo_DATA += \
   %reldir%/jti.go \
   %reldir%/dpop-proof.go \
   %reldir%/fetch.go \
-  %reldir%/client-manifest.go
+  %reldir%/client-manifest.go \
+  %reldir%/authorization-code.go
diff --git a/src/scm/webid-oidc/authorization-code.scm b/src/scm/webid-oidc/authorization-code.scm
new file mode 100644
index 0000000..ebe97c4
--- /dev/null
+++ b/src/scm/webid-oidc/authorization-code.scm
@@ -0,0 +1,151 @@
+(define-module (webid-oidc authorization-code)
+  #:use-module (webid-oidc errors)
+  #:use-module ((webid-oidc stubs) #:prefix stubs:)
+  #:use-module (webid-oidc jws)
+  #:use-module (webid-oidc jti)
+  #: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)
+  (with-exception-handler
+      (lambda (error)
+        (raise-not-an-authorization-code x 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 current-time jti-list str jwk)
+  (when (date? current-time)
+    (set! current-time (date->time-utc current-time)))
+  (when (time? current-time)
+    (set! current-time (time-second current-time)))
+  (with-exception-handler
+      (lambda (error)
+        (raise-cannot-decode-authorization-code str error))
+    (lambda ()
+      (let ((code (the-authorization-code (jws-decode str (lambda (x) jwk)))))
+        (let ((exp (time-second (date->time-utc (authorization-code-exp code)))))
+          (unless (<= current-time exp)
+            (raise-authorization-code-expired exp current-time))
+          (unless (jti-check current-time (authorization-code-jti code)
+                             jti-list
+                             (- 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)
+  (with-exception-handler
+      (lambda (error)
+        (raise-cannot-encode-authorization-code authorization-code key error))
+    (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))
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)