Implement the DPoP proof

4 files changed, 516 insertions, 26 deletions

diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index a63fa89..ecb3f0a 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -6,7 +6,9 @@ dist_webidoidcmod_DATA += \
   %reldir%/jws.scm \
   %reldir%/cache.scm \
   %reldir%/oidc-configuration.scm \
-  %reldir%/access-token.scm
+  %reldir%/access-token.scm \
+  %reldir%/jti.scm \
+  %reldir%/dpop-proof.scm
 webidoidcgo_DATA += \
   %reldir%/errors.go \
   %reldir%/stubs.go \
@@ -15,4 +17,6 @@ webidoidcgo_DATA += \
   %reldir%/jws.go \
   %reldir%/cache.go \
   %reldir%/oidc-configuration.go \
-  %reldir%/access-token.go
+  %reldir%/access-token.go \
+  %reldir%/jti.go \
+  %reldir%/dpop-proof.go
diff --git a/src/scm/webid-oidc/dpop-proof.scm b/src/scm/webid-oidc/dpop-proof.scm
new file mode 100644
index 0000000..89c78af
--- /dev/null
+++ b/src/scm/webid-oidc/dpop-proof.scm
@@ -0,0 +1,217 @@
+(define-module (webid-oidc dpop-proof)
+  #:use-module (webid-oidc jws)
+  #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc jwk)
+  #:use-module (webid-oidc jti)
+  #:use-module ((webid-oidc stubs) #:prefix stubs:)
+  #:use-module (web uri)
+  #:use-module (ice-9 optargs)
+  #:use-module (srfi srfi-19))
+
+(define-public (the-dpop-proof-header x)
+  (with-exception-handler
+      (lambda (error)
+        (raise-not-a-dpop-proof-header x error))
+    (lambda ()
+      (let ((x (the-jws-header x)))
+        (let ((alg (assq-ref x 'alg))
+              (typ (assq-ref x 'typ))
+              (jwk (assq-ref x 'jwk)))
+          (unless (and alg (string? alg))
+            (raise-unsupported-alg alg))
+          (case (string->symbol alg)
+            ((RS256 RS384 RS512 ES256 ES384 ES512 PS256 PS384 PS512)
+             #t)
+            (else
+             (raise-unsupported-alg alg)))
+          (unless (equal? typ "dpop+jwt")
+            (raise-incorrect-typ-field typ))
+          (with-exception-handler
+              (lambda (error)
+                (raise-incorrect-jwk-field jwk error))
+            (lambda ()
+              (the-public-jwk jwk)))
+          x)))))
+
+(define-public (dpop-proof-header? x)
+  (false-if-exception
+   (and (the-dpop-proof-header x) #t)))
+
+(define-public (the-dpop-proof-payload x)
+  (with-exception-handler
+      (lambda (error)
+        (raise-not-a-dpop-proof-payload x error))
+    (lambda ()
+      (let ((x (the-jws-payload x)))
+        (let ((jti (assq-ref x 'jti))
+              (htm (assq-ref x 'htm))
+              (htu (assq-ref x 'htu))
+              (iat (assq-ref x 'iat)))
+          (unless (and jti (string? jti))
+            (raise-incorrect-jti-field jti))
+          (unless (and htm (string? htm))
+            (raise-incorrect-htm-field htm))
+          (unless (and htu (string? htu) (string->uri htu))
+            (raise-incorrect-htu-field htu))
+          (unless (and iat (integer? iat))
+            (raise-incorrect-iat-field iat))
+          x)))))
+
+(define-public (dpop-proof-payload? x)
+  (false-if-exception
+   (and (the-dpop-proof-payload x) #t)))
+
+(define-public (the-dpop-proof x)
+  (with-exception-handler
+      (lambda (error)
+        (raise-not-a-dpop-proof x error))
+    (lambda ()
+      (cons (the-dpop-proof-header (car x))
+            (the-dpop-proof-payload (cdr x))))))
+
+(define-public (dpop-proof? x)
+  (false-if-exception
+   (and (the-dpop-proof x) #t)))
+
+(define-public (make-dpop-proof header payload)
+  (the-dpop-proof (cons header payload)))
+
+(define-public (make-dpop-proof-header alg jwk)
+  (when (symbol? alg)
+    (set! alg (symbol->string alg)))
+  (the-dpop-proof-header
+   `((alg . ,alg)
+     (typ . "dpop+jwt")
+     (jwk . ,(stubs:strip-key jwk)))))
+
+(define-public (make-dpop-proof-payload jti htm htu iat)
+  (when (symbol? htm)
+    (set! htm (symbol->string htm)))
+  (when (uri? htu)
+    (set! htu (uri->string htu)))
+  (when (date? iat)
+    (set! iat (date->time-utc iat)))
+  (when (time? iat)
+    (set! iat (time-second iat)))
+  (the-dpop-proof-payload
+   `((jti . ,jti)
+     (htm . ,htm)
+     (htu . ,htu)
+     (iat . ,iat))))
+
+(define-public (dpop-proof-header dpop)
+  (car (the-dpop-proof dpop)))
+
+(define-public (dpop-proof-payload dpop)
+  (cdr (the-dpop-proof dpop)))
+
+(define-public (dpop-proof-alg code)
+  (when (dpop-proof? code)
+    (set! code (dpop-proof-header code)))
+  (jws-alg (the-dpop-proof-header code)))
+
+(define-public (dpop-proof-jwk dpop)
+  (when (dpop-proof? dpop)
+    (set! dpop (dpop-proof-header dpop)))
+  (assq-ref (the-dpop-proof-header dpop) 'jwk))
+
+(define-public (dpop-proof-jti dpop)
+  (when (dpop-proof? dpop)
+    (set! dpop (dpop-proof-payload dpop)))
+  (assq-ref (the-dpop-proof-payload dpop) 'jti))
+
+(define-public (dpop-proof-htm dpop)
+  (when (dpop-proof? dpop)
+    (set! dpop (dpop-proof-payload dpop)))
+  (string->symbol
+   (assq-ref (the-dpop-proof-payload dpop)
+             'htm)))
+
+(define-public (dpop-proof-htu dpop)
+  (when (dpop-proof? dpop)
+    (set! dpop (dpop-proof-payload dpop)))
+  (string->uri
+   (assq-ref (the-dpop-proof-payload dpop)
+             'htu)))
+
+(define-public (dpop-proof-iat dpop)
+  (when (dpop-proof? dpop)
+    (set! dpop (dpop-proof-payload dpop)))
+  (time-utc->date
+   (make-time time-utc
+              0
+              (assq-ref (the-dpop-proof-payload dpop)
+                        'iat))))
+
+(define (uris-compatible a b)
+  ;; a is what is signed, b is the request
+  (unless
+      (and (eq? (uri-scheme a)
+                (uri-scheme b))
+           (equal? (uri-userinfo a)
+                   (uri-userinfo b))
+           (equal? (uri-port a)
+                   (uri-port b))
+           (equal? (split-and-decode-uri-path
+                    (uri-path a))
+                   (split-and-decode-uri-path
+                    (uri-path b))))
+    (raise-dpop-uri-mismatch a b)))
+
+(define-public (dpop-proof-decode current-time jti-list method uri str cnf/check)
+  (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-dpop-proof str error))
+    (lambda ()
+      (let ((decoded (the-dpop-proof (jws-decode str dpop-proof-jwk))))
+        (unless (eq? method (dpop-proof-htm decoded))
+          (raise-dpop-method-mismatch (dpop-proof-htm decoded) method))
+        (uris-compatible (dpop-proof-htu decoded)
+                         (if (string? uri)
+                             (string->uri uri)
+                             uri))
+        (let ((iat (time-second (date->time-utc (dpop-proof-iat decoded)))))
+          (unless (>= current-time (- iat 5))
+            (raise-dpop-signed-in-future iat current-time))
+          (unless (<= current-time (+ iat 120)) ;; Valid for 2 min
+            (raise-dpop-too-old iat current-time)))
+        (if (string? cnf/check)
+            (unless (equal? cnf/check (stubs:jkt (dpop-proof-jwk decoded)))
+              (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) cnf/check #f))
+            (with-exception-handler
+                (lambda (error)
+                  (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) #f error))
+              (lambda ()
+                (unless (cnf/check (stubs:jkt (dpop-proof-jwk decoded)))
+                  ;; deprecated; throw an error instead!
+                  (error "the cnf/check function returned #f")))))
+        (unless (jti-check current-time (dpop-proof-jti decoded) jti-list 120)
+          (with-exception-handler
+              (lambda (error)
+                (raise-jti-found (dpop-proof-jti decoded) error))
+            (lambda ()
+              (error "the jti-check function returned #f"))))
+        decoded))))
+
+(define-public (dpop-proof-encode dpop-proof key)
+  (with-exception-handler
+      (lambda (error)
+        (raise-cannot-encode-dpop-proof dpop-proof key error))
+    (lambda ()
+      (jws-encode dpop-proof key))))
+
+(define*-public (issue-dpop-proof
+                 client-key
+                 #:key
+                 (alg #f)
+                 (htm #f)
+                 (htu #f)
+                 (iat #f))
+  (dpop-proof-encode
+   (make-dpop-proof (make-dpop-proof-header alg client-key)
+                    (make-dpop-proof-payload (stubs:random 12) htm htu iat))
+   client-key))
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index 50d526c..959b04e 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -3,6 +3,8 @@
   #:use-module (ice-9 exceptions)
   #:use-module (ice-9 optargs)
   #:use-module (ice-9 i18n)
+  #:use-module (srfi srfi-19)
+  #:use-module (web uri)
   #:use-module (web response))
 
 (define (G_ text)
@@ -297,6 +299,56 @@
   (raise-exception
    ((record-constructor &incorrect-client-id-field) value)))
 
+(define-public &incorrect-typ-field
+  (make-exception-type
+   '&incorrect-typ-field
+   &external-error
+   '(value)))
+
+(define-public (raise-incorrect-typ-field value)
+  (raise-exception
+   ((record-constructor &incorrect-typ-field) value)))
+
+(define-public &incorrect-jwk-field
+  (make-exception-type
+   '&incorrect-jwk-field
+   &external-error
+   '(value cause)))
+
+(define-public (raise-incorrect-jwk-field value cause)
+  (raise-exception
+   ((record-constructor &incorrect-jwk-field) value cause)))
+
+(define-public &incorrect-jti-field
+  (make-exception-type
+   '&incorrect-jti-field
+   &external-error
+   '(value)))
+
+(define-public (raise-incorrect-jti-field value)
+  (raise-exception
+   ((record-constructor &incorrect-jti-field) value)))
+
+(define-public &incorrect-htm-field
+  (make-exception-type
+   '&incorrect-htm-field
+   &external-error
+   '(value)))
+
+(define-public (raise-incorrect-htm-field value)
+  (raise-exception
+   ((record-constructor &incorrect-htm-field) value)))
+
+(define-public &incorrect-htu-field
+  (make-exception-type
+   '&incorrect-htu-field
+   &external-error
+   '(value)))
+
+(define-public (raise-incorrect-htu-field value)
+  (raise-exception
+   ((record-constructor &incorrect-htu-field) value)))
+
 (define-public &not-an-access-token
   (make-exception-type
    '&not-an-access-token
@@ -327,6 +379,36 @@
   (raise-exception
    ((record-constructor &not-an-access-token-payload) value cause)))
 
+(define-public &not-a-dpop-proof
+  (make-exception-type
+   '&not-a-dpop-proof
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-a-dpop-proof value cause)
+  (raise-exception
+   ((record-constructor &not-a-dpop-proof) value cause)))
+
+(define-public &not-a-dpop-proof-header
+  (make-exception-type
+   '&not-a-dpop-proof-header
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-a-dpop-proof-header value cause)
+  (raise-exception
+   ((record-constructor &not-a-dpop-proof-header) value cause)))
+
+(define-public &not-a-dpop-proof-payload
+  (make-exception-type
+   '&not-a-dpop-proof-payload
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-a-dpop-proof-payload value cause)
+  (raise-exception
+   ((record-constructor &not-a-dpop-proof-payload) value cause)))
+
 (define-public &cannot-fetch-issuer-configuration
   (make-exception-type
    '&cannot-fetch-issuer-configuration
@@ -347,6 +429,66 @@
   (raise-exception
    ((record-constructor &cannot-fetch-jwks) issuer uri cause)))
 
+(define-public &dpop-method-mismatch
+  (make-exception-type
+   '&dpop-method-mismatch
+   &external-error
+   '(signed requested)))
+
+(define-public (raise-dpop-method-mismatch signed requested)
+  (raise-exception
+   ((record-constructor &dpop-method-mismatch) signed requested)))
+
+(define-public &dpop-uri-mismatch
+  (make-exception-type
+   '&dpop-uri-mismatch
+   &external-error
+   '(signed requested)))
+
+(define-public (raise-dpop-uri-mismatch signed requested)
+  (raise-exception
+   ((record-constructor &dpop-uri-mismatch) signed requested)))
+
+(define-public &dpop-signed-in-future
+  (make-exception-type
+   '&dpop-signed-in-future
+   &external-error
+   '(signed requested)))
+
+(define-public (raise-dpop-signed-in-future signed requested)
+  (raise-exception
+   ((record-constructor &dpop-signed-in-future) signed requested)))
+
+(define-public &dpop-too-old
+  (make-exception-type
+   '&dpop-too-old
+   &external-error
+   '(signed requested)))
+
+(define-public (raise-dpop-too-old signed requested)
+  (raise-exception
+   ((record-constructor &dpop-too-old) signed requested)))
+
+(define-public &dpop-unconfirmed-key
+  (make-exception-type
+   '&dpop-unconfirmed-key
+   &external-error
+   '(key expected cause)))
+
+(define-public (raise-dpop-unconfirmed-key key expected cause)
+  (raise-exception
+   ((record-constructor &dpop-unconfirmed-key) key expected cause)))
+
+(define-public &jti-found
+  (make-exception-type
+   '&jti-found
+   &external-error
+   '(jti cause)))
+
+(define-public (raise-jti-found jti cause)
+  (raise-exception
+   ((record-constructor &jti-found) jti cause)))
+
 (define-public &cannot-decode-access-token
   (make-exception-type
    '&cannot-decode-access-token
@@ -367,6 +509,26 @@
   (raise-exception
    ((record-constructor &cannot-encode-access-token) access-token key cause)))
 
+(define-public &cannot-decode-dpop-proof
+  (make-exception-type
+   '&cannot-decode-dpop-proof
+   &external-error
+   '(value cause)))
+
+(define-public (raise-cannot-decode-dpop-proof value cause)
+  (raise-exception
+   ((record-constructor &cannot-decode-dpop-proof) value cause)))
+
+(define-public &cannot-encode-dpop-proof
+  (make-exception-type
+   '&cannot-encode-dpop-proof
+   &external-error
+   '(dpop-proof key cause)))
+
+(define-public (raise-cannot-encode-dpop-proof dpop-proof key cause)
+  (raise-exception
+   ((record-constructor &cannot-encode-dpop-proof) dpop-proof key cause)))
+
 (define*-public (error->str err #:key (max-depth #f))
   (if (record? err)
       (let* ((type (record-type-descriptor err))
@@ -497,39 +659,108 @@
              (if value
                  (format #f (G_ "the client-id field is incorrect: ~s") value)
                  (format #f (G_ "the client-id field is missing")))))
+          ((&incorrect-typ-field)
+           (let ((value (get 'value)))
+             (if value
+                 (format #f (G_ "the typ field is incorrect: ~s") value)
+                 (format #f (G_ "the typ field is missing")))))
+          ((&incorrect-jwk-field)
+           (let ((value (get 'value)))
+             (if value
+                 (format #f (G_ "the jwk field is incorrect: ~s (because ~a)")
+                         value (recurse (get 'cause)))
+                 (format #f (G_ "the jwk field is missing")))))
+          ((&incorrect-jti-field)
+           (let ((value (get 'value)))
+             (if value
+                 (format #f (G_ "the jti field is incorrect: ~s") value)
+                 (format #f (G_ "the jti field is missing")))))
+          ((&incorrect-htm-field)
+           (let ((value (get 'value)))
+             (if value
+                 (format #f (G_ "the htm field is incorrect: ~s") value)
+                 (format #f (G_ "the htm field is missing")))))
+          ((&incorrect-htu-field)
+           (let ((value (get 'value)))
+             (if value
+                 (format #f (G_ "the htu field is incorrect: ~s") value)
+                 (format #f (G_ "the htu field is missing")))))
           ((&not-an-access-token)
-           (format #f (G_ "~s is not an access token (because ~a)"
-                          (get 'value) (recurse (get 'cause)))))
+           (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)))))
+           (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)))))
+           (format #f (G_ "~s is not an access token payload (because ~a)")
+                   (get 'value) (recurse (get 'cause))))
+          ((&not-a-dpop-proof)
+           (format #f (G_ "~s is not a DPoP proof (because ~a)")
+                   (get 'value) (recurse (get 'cause))))
+          ((&not-a-dpop-proof-header)
+           (format #f (G_ "~s is not a DPoP proof header (because ~a)")
+                   (get 'value) (recurse (get 'cause))))
+          ((&not-a-dpop-proof-payload)
+           (format #f (G_ "~s is not a DPoP proof 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)))))
+           (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)))))
+           (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))))
+          ((&dpop-method-mismatch)
+           (format #f (G_ "the HTTP method is signed for ~s, but ~s was requested")
+                   (get 'signed) (get 'requested)))
+          ((&dpop-uri-mismatch)
+           (format #f (G_ "the HTTP uri is signed for ~a, but ~a was requested")
+                   (uri->string (get 'signed)) (uri->string (get 'requested))))
+          ((&dpop-signed-in-future)
+           (format #f (G_ "the date is ~a, but the DPoP proof is signed in the future at ~a")
+                   (time-second (date->time-utc (get 'signed)))
+                   (time-second (date->time-utc (get 'requested)))))
+          ((&dpop-too-old)
+           (format #f (G_ "the date is ~a, but the DPoP proof was signed too long ago at ~a")
+                   (time-second (date->time-utc (get 'signed)))
+                   (time-second (date->time-utc (get 'requested)))))
+          ((&dpop-unconfirmed-key)
+           (let ((key (get 'key))
+                 (expected (get 'expected))
+                 (cause (get 'cause)))
+             (cond
+              (expected
+               (format #f (G_ "the key ~s does not hash to ~a") key expected))
+              (cause
+               (format #f (G_ "the key confirmation of ~s failed (because ~a)") key (recurse cause)))
+              (else
+               (format #f (G_ "the key confirmation of ~s failed") key)))))
+          ((&jti-found)
+           (format #f (G_ "the jti ~s has already been found (because ~a)")
+                   (get 'jti) (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)))))
+           (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))))
+          ((&cannot-decode-dpop-proof)
+           (format #f (G_ "I cannot decode ~s as a DPoP proof (because ~a)")
+                   (get 'value) (recurse (get 'cause))))
+          ((&cannot-encode-dpop-proof)
+           (format #f (G_ "I cannot encode ~s as a DPoP proof (because ~a)")
+                   (get 'value) (recurse (get 'cause))))
           ((&compound-exception)
            (let ((components (get 'components)))
              (if (null? components)
@@ -564,6 +795,10 @@
           ((&quit-exception)
            (format #f (G_ "the program quits with code ~a")
                    (get 'code)))
+          ((&non-continuable)
+           (format #f (G_ "the program cannot recover from this exception")))
+          ((&error)
+           (format #f (G_ "there is an error")))
           (else
            (error (format #f (G_ "Unhandled exception type ~a.")
                           (record-type-name type))))))
diff --git a/src/scm/webid-oidc/jti.scm b/src/scm/webid-oidc/jti.scm
new file mode 100644
index 0000000..423382a
--- /dev/null
+++ b/src/scm/webid-oidc/jti.scm
@@ -0,0 +1,34 @@
+(define-module (webid-oidc jti)
+  #:use-module (ice-9 atomic)
+  #:use-module (ice-9 threads)
+  #:use-module (srfi srfi-19))
+
+(define-public (make-jti-list)
+  (make-atomic-box '()))
+
+(define-public (lookup list jti)
+  (if (null? list)
+      #f
+      (or (string=? (assq-ref (car list) 'jti) jti)
+          (lookup (cdr list) jti))))
+
+(define-public (jti-check current-time jti list valid-time)
+  (when (date? current-time)
+    (set! current-time (date->time-utc current-time)))
+  (when (time? current-time)
+    (set! current-time (time-second current-time)))
+  (let* ((old (atomic-box-ref list))
+         (new-entry `((exp . ,(+ current-time valid-time))
+                      (jti . ,jti)))
+         (new (filter
+               (lambda (entry)
+                 (let ((exp (assq-ref entry 'exp)))
+                   (>= exp current-time)))
+               (cons new-entry old))))
+    (let ((present? (lookup old jti)))
+      (if present?
+          #f
+          (let ((discarded (atomic-box-compare-and-swap! list old new)))
+            (if (eq? discarded old)
+                #t
+                (jti-check current-time jti list valid-time)))))))