1 files changed, 151 insertions, 0 deletions
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))