DPoP proof: support the "ath" claim

1 files changed, 28 insertions, 6 deletions

diff --git a/src/scm/webid-oidc/dpop-proof.scm b/src/scm/webid-oidc/dpop-proof.scm
index c716c33..54b338b 100644
--- a/src/scm/webid-oidc/dpop-proof.scm
+++ b/src/scm/webid-oidc/dpop-proof.scm
@@ -62,7 +62,8 @@
         (let ((jti (assq-ref x 'jti))
               (htm (assq-ref x 'htm))
               (htu (assq-ref x 'htu))
-              (iat (assq-ref x 'iat)))
+              (iat (assq-ref x 'iat))
+              (ath (assq-ref x 'ath)))
           (unless (and jti (string? jti))
             (raise-incorrect-jti-field jti))
           (unless (and htm (string? htm))
@@ -71,6 +72,8 @@
             (raise-incorrect-htu-field htu))
           (unless (and iat (integer? iat))
             (raise-incorrect-iat-field iat))
+          (unless (or (not ath) (string? ath))
+            (raise-incorrect-ath-field ath))
           x)))))
 
 (define-public (dpop-proof-payload? x)
@@ -100,7 +103,7 @@
      (typ . "dpop+jwt")
      (jwk . ,(stubs:strip-key jwk)))))
 
-(define-public (make-dpop-proof-payload jti htm htu iat)
+(define-public (make-dpop-proof-payload jti htm htu iat ath)
   (when (symbol? htm)
     (set! htm (symbol->string htm)))
   (when (uri? htu)
@@ -113,7 +116,10 @@
    `((jti . ,jti)
      (htm . ,htm)
      (htu . ,htu)
-     (iat . ,iat))))
+     (iat . ,iat)
+     ,@(if ath
+           `((ath . ,ath))
+           '()))))
 
 (define-public (dpop-proof-header dpop)
   (car (the-dpop-proof dpop)))
@@ -159,6 +165,12 @@
               (assq-ref (the-dpop-proof-payload dpop)
                         'iat))))
 
+(define-public (dpop-proof-ath dpop)
+  (when (dpop-proof? dpop)
+    (set! dpop (dpop-proof-payload dpop)))
+  (assq-ref (the-dpop-proof-payload dpop)
+            'ath))
+
 (define (uris-compatible a b)
   ;; a is what is signed, b is the request
   (unless
@@ -174,7 +186,9 @@
                     (uri-path b))))
     (raise-dpop-uri-mismatch a b)))
 
-(define-public (dpop-proof-decode current-time jti-list method uri str cnf/check)
+(define*-public (dpop-proof-decode current-time jti-list method uri str cnf/check
+                                   #:key
+                                   (access-token #f))
   (when (date? current-time)
     (set! current-time (date->time-utc current-time)))
   (when (time? current-time)
@@ -195,6 +209,11 @@
             (raise-dpop-signed-in-future iat current-time))
           (unless (<= current-time (+ iat 120)) ;; Valid for 2 min
             (raise-dpop-too-old iat current-time)))
+        (when access-token
+          (let ((h (stubs:hash 'SHA-256 access-token)))
+            (unless (equal? (dpop-proof-ath decoded) h)
+              (raise-exception
+               (make-dpop-invalid-access-token-hash (dpop-proof-ath decoded) access-token)))))
         (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))
@@ -226,8 +245,11 @@
                  (alg #f)
                  (htm #f)
                  (htu #f)
-                 (iat #f))
+                 (iat #f)
+                 (access-token #f))
   (dpop-proof-encode
    (make-dpop-proof (make-dpop-proof-header alg client-key)
-                    (make-dpop-proof-payload (stubs:random 12) htm htu iat))
+                    (make-dpop-proof-payload (stubs:random 12) htm htu iat
+                                             (and access-token
+                                                  (stubs:hash 'SHA-256 access-token))))
    client-key))