Parse and issue OIDC ID tokens

3 files changed, 300 insertions, 2 deletions

diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index d18d5fc..56b50ec 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -12,7 +12,8 @@ dist_webidoidcmod_DATA += \
   %reldir%/fetch.scm \
   %reldir%/client-manifest.scm \
   %reldir%/authorization-code.scm \
-  %reldir%/refresh-token.scm
+  %reldir%/refresh-token.scm \
+  %reldir%/oidc-id-token.scm
 webidoidcgo_DATA += \
   %reldir%/errors.go \
   %reldir%/stubs.go \
@@ -27,4 +28,5 @@ webidoidcgo_DATA += \
   %reldir%/fetch.go \
   %reldir%/client-manifest.go \
   %reldir%/authorization-code.go \
-  %reldir%/refresh-token.go
+  %reldir%/refresh-token.go \
+  %reldir%/oidc-id-token.go
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index e8ab5af..b0e9a19 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -249,6 +249,16 @@
   (raise-exception
    ((record-constructor &incorrect-webid-field) value)))
 
+(define-public &incorrect-sub-field
+  (make-exception-type
+   '&incorrect-sub-field
+   &external-error
+   '(value)))
+
+(define-public (raise-incorrect-sub-field value)
+  (raise-exception
+   ((record-constructor &incorrect-sub-field) value)))
+
 (define-public &incorrect-iss-field
   (make-exception-type
    '&incorrect-iss-field
@@ -349,6 +359,16 @@
   (raise-exception
    ((record-constructor &incorrect-jti-field) value)))
 
+(define-public &incorrect-nonce-field
+  (make-exception-type
+   '&incorrect-nonce-field
+   &external-error
+   '(value)))
+
+(define-public (raise-incorrect-nonce-field value)
+  (raise-exception
+   ((record-constructor &incorrect-nonce-field) value)))
+
 (define-public &incorrect-htm-field
   (make-exception-type
    '&incorrect-htm-field
@@ -707,6 +727,56 @@
   (raise-exception
    ((record-constructor &invalid-key-for-refresh-token) key jkt)))
 
+(define-public &not-an-id-token
+  (make-exception-type
+   '&not-an-id-token
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-an-id-token value cause)
+  (raise-exception
+   ((record-constructor &not-an-id-token) value cause)))
+
+(define-public &not-an-id-token-header
+  (make-exception-type
+   '&not-an-id-token-header
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-an-id-token-header value cause)
+  (raise-exception
+   ((record-constructor &not-an-id-token-header) value cause)))
+
+(define-public &not-an-id-token-payload
+  (make-exception-type
+   '&not-an-id-token-payload
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-an-id-token-payload value cause)
+  (raise-exception
+   ((record-constructor &not-an-id-token-payload) value cause)))
+
+(define-public &cannot-decode-id-token
+  (make-exception-type
+   '&cannot-decode-id-token
+   &external-error
+   '(value cause)))
+
+(define-public (raise-cannot-decode-id-token value cause)
+  (raise-exception
+   ((record-constructor &cannot-decode-id-token) value cause)))
+
+(define-public &cannot-encode-id-token
+  (make-exception-type
+   '&cannot-encode-id-token
+   &external-error
+   '(id-token key cause)))
+
+(define-public (raise-cannot-encode-id-token id-token key cause)
+  (raise-exception
+   ((record-constructor &cannot-encode-id-token) id-token key cause)))
+
 (define*-public (error->str err #:key (max-depth #f))
   (if (record? err)
       (let* ((type (record-type-descriptor err))
@@ -810,6 +880,11 @@
              (if value
                  (format #f (G_ "the webid field is incorrect: ~s") value)
                  (format #f (G_ "the webid field is missing")))))
+          ((&incorrect-sub-field)
+           (let ((value (get 'value)))
+             (if value
+                 (format #f (G_ "the sub field is incorrect: ~s") value)
+                 (format #f (G_ "the sub field is missing")))))
           ((&incorrect-iss-field)
            (let ((value (get 'value)))
              (if value
@@ -861,6 +936,11 @@
              (if value
                  (format #f (G_ "the jti field is incorrect: ~s") value)
                  (format #f (G_ "the jti field is missing")))))
+          ((&incorrect-nonce-field)
+           (let ((value (get 'value)))
+             (if value
+                 (format #f (G_ "the nonce field is incorrect: ~s") value)
+                 (format #f (G_ "the nonce field is missing")))))
           ((&incorrect-htm-field)
            (let ((value (get 'value)))
              (if value
@@ -992,6 +1072,21 @@
           ((&invalid-key-for-refresh-token)
            (format #f (G_ "the refresh token is bound to a key confirmed as ~s, but it is used with key ~s")
                    (get 'jkt) (get 'key)))
+          ((&cannot-decode-id-token)
+           (format #f (G_ "I cannot decode ~s as an ID token (because ~a)")
+                   (get 'value) (recurse (get 'cause))))
+          ((&cannot-encode-id-token)
+           (format #f (G_ "I cannot encode ~s as an ID token (because ~a)")
+                   (get 'value) (recurse (get 'cause))))
+          ((&not-an-id-token)
+           (format #f (G_ "~s is not an ID token (because ~a)")
+                   (get 'value) (recurse (get 'cause))))
+          ((&not-an-id-token-header)
+           (format #f (G_ "~s is not an ID token header (because ~a)")
+                   (get 'value) (recurse (get 'cause))))
+          ((&not-an-id-token-payload)
+           (format #f (G_ "~s is not an ID token payload (because ~a)")
+                   (get 'value) (recurse (get 'cause))))
           ((&compound-exception)
            (let ((components (get 'components)))
              (if (null? components)
diff --git a/src/scm/webid-oidc/oidc-id-token.scm b/src/scm/webid-oidc/oidc-id-token.scm
new file mode 100644
index 0000000..18ac124
--- /dev/null
+++ b/src/scm/webid-oidc/oidc-id-token.scm
@@ -0,0 +1,201 @@
+(define-module (webid-oidc oidc-id-token)
+  #:use-module (webid-oidc oidc-configuration)
+  #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc jws)
+  #:use-module (webid-oidc jti)
+  #: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-id-token-header x)
+  (with-exception-handler
+      (lambda (error)
+        (raise-not-an-id-token-header x error))
+    (lambda ()
+      (the-jws-header x))))
+
+(define-public (id-token-header? x)
+  (false-if-exception
+   (and (the-id-token-header x) #t)))
+
+(define-public (the-id-token-payload x)
+  (with-exception-handler
+      (lambda (error)
+        (raise-not-an-id-token-payload x error))
+    (lambda ()
+      (let ((x (the-jws-payload x)))
+        (let ((webid (assq-ref x 'webid))
+              (iss (assq-ref x 'iss))
+              (sub (assq-ref x 'sub))
+              (aud (assq-ref x 'aud))
+              (nonce (assq-ref x 'nonce))
+              (iat (assq-ref x 'iat))
+              (exp (assq-ref x 'exp)))
+          (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 (string? sub)
+            (raise-incorrect-sub-field sub))
+          (unless (and aud (string? aud) (string->uri aud))
+            (raise-incorrect-aud-field aud))
+          (unless (string? nonce)
+            (raise-incorrect-nonce-field nonce))
+          (unless (integer? iat)
+            (raise-incorrect-iat-field iat))
+          (unless (and (integer? exp) (>= exp iat))
+            (raise-incorrect-exp-field exp))
+          x)))))
+
+(define-public (id-token-payload? x)
+  (false-if-exception
+   (and (the-id-token-header x) #t)))
+
+(define-public (the-id-token x)
+  (with-exception-handler
+      (lambda (cause)
+        (raise-not-an-id-token x cause))
+    (lambda ()
+      (cons (the-id-token-header (car x))
+            (the-id-token-payload (cdr x))))))
+
+(define-public (id-token? x)
+  (false-if-exception
+   (and (the-id-token x) #t)))
+
+(define-public (make-id-token header payload)
+  (the-id-token
+   (cons header payload)))
+
+(define-public (make-id-token-payload webid iss sub aud nonce exp iat)
+  (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? aud)
+    (set! aud (uri->string aud)))
+  (the-id-token-payload
+   `((webid . ,webid)
+     (iss . ,iss)
+     (sub . ,sub)
+     (aud . ,aud)
+     (nonce . ,nonce)
+     (exp . ,exp)
+     (iat . ,iat))))
+
+(define-public (id-token-header code)
+  (car (the-id-token code)))
+
+(define-public (id-token-payload code)
+  (cdr (the-id-token code)))
+
+(define-public (id-token-alg code)
+  (when (id-token? code)
+    (set! code (id-token-header code)))
+  (jws-alg (the-id-token-header code)))
+
+(define-public (id-token-webid code)
+  (when (id-token? code)
+    (set! code (id-token-payload code)))
+  (string->uri
+   (assq-ref (the-id-token-payload code) 'webid)))
+
+(define-public (id-token-iss code)
+  (when (id-token? code)
+    (set! code (id-token-payload code)))
+  (string->uri
+   (assq-ref (the-id-token-payload code) 'iss)))
+
+(define-public (id-token-sub code)
+  (when (id-token? code)
+    (set! code (id-token-payload code)))
+  (assq-ref (the-id-token-payload code) 'sub))
+
+(define-public (id-token-aud code)
+  (when (id-token? code)
+    (set! code (id-token-payload code)))
+  (string->uri
+   (assq-ref (the-id-token-payload code) 'aud)))
+
+(define-public (id-token-nonce code)
+  (when (id-token? code)
+    (set! code (id-token-payload code)))
+  (assq-ref (the-id-token-payload code) 'nonce))
+
+(define-public (id-token-exp code)
+  (when (id-token? code)
+    (set! code (id-token-payload code)))
+  (time-utc->date
+   (make-time time-utc 0 (assq-ref
+                          (the-id-token-payload code)
+                          'exp))))
+
+(define-public (id-token-iat code)
+  (when (id-token? code)
+    (set! code (id-token-payload code)))
+  (time-utc->date
+   (make-time time-utc 0 (assq-ref
+                          (the-id-token-payload code)
+                          'iat))))
+
+(define*-public (id-token-decode str #:key (http-get http-get))
+  (with-exception-handler
+      (lambda (error)
+        (raise-cannot-decode-id-token str error))
+    (lambda ()
+      (jws-decode
+       str
+       (lambda (token)
+         (let ((iss (id-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 (id-token-encode id-token key)
+  (with-exception-handler
+      (lambda (error)
+        (raise-cannot-encode-id-token id-token key error))
+    (lambda ()
+      (jws-encode id-token key))))
+
+(define*-public (issue-id-token
+                 issuer-key
+                 #:key
+                 (alg #f)
+                 (webid #f)
+                 (iss #f)
+                 (sub #f)
+                 (aud #f)
+                 (exp #f)
+                 (iat #f))
+  (unless sub
+    (set! sub webid))
+  (id-token-encode
+   (make-id-token
+    `((alg . ,(symbol->string alg)))
+    (make-id-token-payload webid iss sub aud (stubs:random 12) exp iat))
+   issuer-key))