From 305d9fb0d15bf90430cc44772a016d60139cab45 Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Tue, 27 Apr 2021 14:07:10 +0200
Subject: Define the access token API

---
 src/scm/webid-oidc/Makefile.am      |   6 +-
 src/scm/webid-oidc/access-token.scm | 205 +++++++++++++++++++++++++++++++++++
 src/scm/webid-oidc/errors.scm       | 208 ++++++++++++++++++++++++++++++++++++
 3 files changed, 417 insertions(+), 2 deletions(-)
 create mode 100644 src/scm/webid-oidc/access-token.scm

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

diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index ebf6811..a63fa89 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -5,7 +5,8 @@ dist_webidoidcmod_DATA += \
   %reldir%/jwk.scm \
   %reldir%/jws.scm \
   %reldir%/cache.scm \
-  %reldir%/oidc-configuration.scm
+  %reldir%/oidc-configuration.scm \
+  %reldir%/access-token.scm
 webidoidcgo_DATA += \
   %reldir%/errors.go \
   %reldir%/stubs.go \
@@ -13,4 +14,5 @@ webidoidcgo_DATA += \
   %reldir%/jwk.go \
   %reldir%/jws.go \
   %reldir%/cache.go \
-  %reldir%/oidc-configuration.go
+  %reldir%/oidc-configuration.go \
+  %reldir%/access-token.go
diff --git a/src/scm/webid-oidc/access-token.scm b/src/scm/webid-oidc/access-token.scm
new file mode 100644
index 0000000..34afcdc
--- /dev/null
+++ b/src/scm/webid-oidc/access-token.scm
@@ -0,0 +1,205 @@
+(define-module (webid-oidc access-token)
+  #:use-module (webid-oidc jws)
+  #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc jwk)
+  #:use-module (webid-oidc oidc-configuration)
+  #:use-module ((webid-oidc stubs) #:prefix stubs:)
+  #:use-module (web uri)
+  #:use-module (web client)
+  #:use-module (ice-9 optargs)
+  #:use-module (srfi srfi-19))
+
+(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))))
+
+(define-public (access-token-header? x)
+  (false-if-exception
+   (and (the-access-token-header x) #t)))
+
+(define-public (the-access-token-payload x)
+  (with-exception-handler
+      (lambda (error)
+        (raise-not-an-access-token-payload x 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))
+  (with-exception-handler
+      (lambda (error)
+        (raise-cannot-decode-access-token str 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)
+  (with-exception-handler
+      (lambda (error)
+        (raise-cannot-encode-access-token access-token key error))
+    (lambda ()
+      (jws-encode access-token key))))
+
+(define*-public (issue-access-token
+                 issuer-key
+                 #:key
+                 (alg #f)
+                 (webid #f)
+                 (iss #f)
+                 (iat #f)
+                 (exp #f)
+                 (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)))
+    (make-access-token-payload
+     webid iss iat exp cnf/jkt client-id))
+   issuer-key))
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index beeaaea..50d526c 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -227,6 +227,146 @@
   (raise-exception
    ((record-constructor &not-an-oidc-configuration) value cause)))
 
+(define-public &incorrect-webid-field
+  (make-exception-type
+   '&incorrect-webid-field
+   &external-error
+   '(value)))
+
+(define-public (raise-incorrect-webid-field value)
+  (raise-exception
+   ((record-constructor &incorrect-webid-field) value)))
+
+(define-public &incorrect-iss-field
+  (make-exception-type
+   '&incorrect-iss-field
+   &external-error
+   '(value)))
+
+(define-public (raise-incorrect-iss-field value)
+  (raise-exception
+   ((record-constructor &incorrect-iss-field) value)))
+
+(define-public &incorrect-aud-field
+  (make-exception-type
+   '&incorrect-aud-field
+   &external-error
+   '(value)))
+
+(define-public (raise-incorrect-aud-field value)
+  (raise-exception
+   ((record-constructor &incorrect-aud-field) value)))
+
+(define-public &incorrect-iat-field
+  (make-exception-type
+   '&incorrect-iat-field
+   &external-error
+   '(value)))
+
+(define-public (raise-incorrect-iat-field value)
+  (raise-exception
+   ((record-constructor &incorrect-iat-field) value)))
+
+(define-public &incorrect-exp-field
+  (make-exception-type
+   '&incorrect-exp-field
+   &external-error
+   '(value)))
+
+(define-public (raise-incorrect-exp-field value)
+  (raise-exception
+   ((record-constructor &incorrect-exp-field) value)))
+
+(define-public &incorrect-cnf/jkt-field
+  (make-exception-type
+   '&incorrect-cnf/jkt-field
+   &external-error
+   '(value)))
+
+(define-public (raise-incorrect-cnf/jkt-field value)
+  (raise-exception
+   ((record-constructor &incorrect-cnf/jkt-field) value)))
+
+(define-public &incorrect-client-id-field
+  (make-exception-type
+   '&incorrect-client-id-field
+   &external-error
+   '(value)))
+
+(define-public (raise-incorrect-client-id-field value)
+  (raise-exception
+   ((record-constructor &incorrect-client-id-field) value)))
+
+(define-public &not-an-access-token
+  (make-exception-type
+   '&not-an-access-token
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-an-access-token value cause)
+  (raise-exception
+   ((record-constructor &not-an-access-token) value cause)))
+
+(define-public &not-an-access-token-header
+  (make-exception-type
+   '&not-an-access-token-header
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-an-access-token-header value cause)
+  (raise-exception
+   ((record-constructor &not-an-access-token-header) value cause)))
+
+(define-public &not-an-access-token-payload
+  (make-exception-type
+   '&not-an-access-token-payload
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-an-access-token-payload value cause)
+  (raise-exception
+   ((record-constructor &not-an-access-token-payload) value cause)))
+
+(define-public &cannot-fetch-issuer-configuration
+  (make-exception-type
+   '&cannot-fetch-issuer-configuration
+   &external-error
+   '(issuer cause)))
+
+(define-public (raise-cannot-fetch-issuer-configuration issuer cause)
+  (raise-exception
+   ((record-constructor &cannot-fetch-issuer-configuration) issuer cause)))
+
+(define-public &cannot-fetch-jwks
+  (make-exception-type
+   '&cannot-fetch-jwks
+   &external-error
+   '(issuer uri cause)))
+
+(define-public (raise-cannot-fetch-jwks issuer uri cause)
+  (raise-exception
+   ((record-constructor &cannot-fetch-jwks) issuer uri cause)))
+
+(define-public &cannot-decode-access-token
+  (make-exception-type
+   '&cannot-decode-access-token
+   &external-error
+   '(value cause)))
+
+(define-public (raise-cannot-decode-access-token value cause)
+  (raise-exception
+   ((record-constructor &cannot-decode-access-token) value cause)))
+
+(define-public &cannot-encode-access-token
+  (make-exception-type
+   '&cannot-encode-access-token
+   &external-error
+   '(access-token key cause)))
+
+(define-public (raise-cannot-encode-access-token access-token key cause)
+  (raise-exception
+   ((record-constructor &cannot-encode-access-token) access-token key cause)))
+
 (define*-public (error->str err #:key (max-depth #f))
   (if (record? err)
       (let* ((type (record-type-descriptor err))
@@ -322,6 +462,74 @@
           ((&not-an-oidc-configuration)
            (format #f (G_ "the value ~s is not an OIDC configuration (because ~a)")
                    (get 'value) (recurse (get 'cause))))
+          ((&incorrect-webid-field)
+           (let ((value (get 'value)))
+             (if value
+                 (format #f (G_ "the webid field is incorrect: ~s") value)
+                 (format #f (G_ "the webid field is missing")))))
+          ((&incorrect-iss-field)
+           (let ((value (get 'value)))
+             (if value
+                 (format #f (G_ "the iss field is incorrect: ~s") value)
+                 (format #f (G_ "the iss field is missing")))))
+          ((&incorrect-aud-field)
+           (let ((value (get 'value)))
+             (if value
+                 (format #f (G_ "the aud field is incorrect: ~s") value)
+                 (format #f (G_ "the aud field is missing")))))
+          ((&incorrect-iat-field)
+           (let ((value (get 'value)))
+             (if value
+                 (format #f (G_ "the iat field is incorrect: ~s") value)
+                 (format #f (G_ "the iat field is missing")))))
+          ((&incorrect-exp-field)
+           (let ((value (get 'value)))
+             (if value
+                 (format #f (G_ "the exp field is incorrect: ~s") value)
+                 (format #f (G_ "the exp field is missing")))))
+          ((&incorrect-cnf/jkt-field)
+           (let ((value (get 'value)))
+             (if value
+                 (format #f (G_ "the cnf/jkt field is incorrect: ~s") value)
+                 (format #f (G_ "the cnf/jkt field is missing")))))
+          ((&incorrect-client-id-field)
+           (let ((value (get 'value)))
+             (if value
+                 (format #f (G_ "the client-id field is incorrect: ~s") value)
+                 (format #f (G_ "the client-id field is missing")))))
+          ((&not-an-access-token)
+           (format #f (G_ "~s is not an access token (because ~a)"
+                          (get 'value) (recurse (get 'cause)))))
+          ((&not-an-access-token-header)
+           (format #f (G_ "~s is not an access token header (because ~a)"
+                          (get 'value) (recurse (get 'cause)))))
+          ((&not-an-access-token-payload)
+           (format #f (G_ "~s is not an access token payload (because ~a)"
+                          (get 'value) (recurse (get 'cause)))))
+          ((&cannot-fetch-issuer-configuration)
+           (format #f (G_ "I cannot fetch the issuer configuration of ~a (because ~a)"
+                          (let ((iss (get 'issuer)))
+                            (when (uri? iss)
+                              (set! iss (uri->string iss)))
+                            iss)
+                          (recurse (get 'cause)))))
+          ((&cannot-fetch-jwks)
+           (format #f (G_ "I cannot fetch the JWKS of ~a at ~a (because ~a)"
+                          (let ((iss (get 'issuer)))
+                            (when (uri? iss)
+                              (set! iss (uri->string iss)))
+                            iss)
+                          (let ((uri (get 'uri)))
+                            (when (uri? uri)
+                              (set! uri (uri->string uri)))
+                            uri)
+                          (recurse (get 'cause)))))
+          ((&cannot-decode-access-token)
+           (format #f (G_ "I cannot decode ~s as an access token (because ~a)"
+                          (get 'value) (recurse (get 'cause)))))
+          ((&cannot-encode-access-token)
+           (format #f (G_ "I cannot encode ~s as an access token with key ~s (because ~a)")
+                   (get 'access-token) (get 'key) (recurse (get 'cause))))
           ((&compound-exception)
            (let ((components (get 'components)))
              (if (null? components)
-- 
cgit v1.2.3