DPoP proof: support the "ath" claim

4 files changed, 74 insertions, 12 deletions

diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm
index aea2b7e..30cbc75 100644
--- a/src/scm/webid-oidc/client.scm
+++ b/src/scm/webid-oidc/client.scm
@@ -455,7 +455,8 @@
                            (error "Unknown key type of ~S." key)))
                   #:htm method
                   #:htu uri
-                  #:iat current-time)))
+                  #:iat current-time
+                  #:access-token access-token)))
       (receive (response response-body)
           (apply http-request uri
                  #:method method
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))
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index d494c7d..beccc35 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -401,6 +401,18 @@
    &external-error
    '(value)))
 
+(define-exception-type
+  &incorrect-ath-field
+  &external-error
+  make-incorrect-ath-field
+  incorrect-ath-field?
+  (value incorrect-ath-field-value))
+
+(export &incorrect-ath-field
+        make-incorrect-ath-field
+        incorrect-ath-field?
+        incorrect-ath-field-value)
+
 (define-public (raise-incorrect-htu-field value)
   (raise-exception
    ((record-constructor &incorrect-htu-field) value)))
@@ -543,6 +555,20 @@
   (raise-exception
    ((record-constructor &dpop-unconfirmed-key) key expected cause)))
 
+(define-exception-type
+  &dpop-invalid-access-token-hash
+  &external-error
+  make-dpop-invalid-access-token-hash
+  dpop-invalid-access-token-hash?
+  (hash dpop-invalid-access-token-hash-hash)
+  (access-token dpop-invalid-access-token-hash-access-token))
+
+(export &dpop-invalid-access-token-hash
+        make-dpop-invalid-access-token-hash
+        dpop-invalid-access-token-hash?
+        dpop-invalid-access-token-hash-hash
+        dpop-invalid-access-token-hash-access-token)
+
 (define-public &jti-found
   (make-exception-type
    '&jti-found
@@ -1227,6 +1253,11 @@
              (if value
                  (format #f (G_ "the htu field is incorrect: ~s") value)
                  (format #f (G_ "the htu field is missing")))))
+          ((&incorrect-ath-field)
+           (let ((value (get 'value)))
+             (if value
+                 (format #f (G_ "the ath field is incorrect: ~s") value)
+                 (format #f (G_ "the ath field is missing")))))
           ((&not-an-access-token)
            (format #f (G_ "~s is not an access token (because ~a)")
                    (get 'value) (recurse (get 'cause))))
@@ -1288,6 +1319,14 @@
                (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)))))
+          ((&dpop-invalid-access-token-hash)
+           (let ((h (get 'hash))
+                 (at (get 'access-token)))
+             (if h
+                 (format #f (G_ "the DPoP proof is bound to an access token with hash ~s, not ~s")
+                         h at)
+                 (format #f (G_ "the DPoP proof should be bound to the access token ~s")
+                         at))))
           ((&jti-found)
            (format #f (G_ "the jti ~s has already been found (because ~a)")
                    (get 'jti) (recurse (get 'cause))))
diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm
index a8e88f5..2d1c798 100644
--- a/src/scm/webid-oidc/resource-server.scm
+++ b/src/scm/webid-oidc/resource-server.scm
@@ -94,15 +94,15 @@
                            (error->str error))
                    #f)
                (lambda ()
-                 (let* ((access-token
-                         (access-token-decode
-                          (symbol->string (cadr authz))
-                          #:http-get http-get))
+                 (let* ((lit-access-token (symbol->string (cadr authz)))
+                        (access-token
+                         (access-token-decode lit-access-token
+                                              #:http-get http-get))
                         (cnf/jkt (access-token-cnf/jkt access-token))
                         (dpop-proof
                          (dpop-proof-decode
                           current-time jti-list method full-uri
-                          dpop cnf/jkt)))
+                          dpop cnf/jkt #:access-token lit-access-token)))
                    (let ((subject (access-token-webid access-token))
                          (issuer (access-token-iss access-token)))
                      (confirm-provider subject issuer #:http-get http-get)