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