JWS: use GOOPS

1 files changed, 172 insertions, 303 deletions

diff --git a/src/scm/webid-oidc/dpop-proof.scm b/src/scm/webid-oidc/dpop-proof.scm
index 8c66f68..318ebb8 100644
--- a/src/scm/webid-oidc/dpop-proof.scm
+++ b/src/scm/webid-oidc/dpop-proof.scm
@@ -26,10 +26,19 @@
   #:use-module (ice-9 optargs)
   #:use-module (ice-9 exceptions)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 receive)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (oop goops)
   #:declarative? #t
+  #:re-export
+  (
+   alg iat exp nonce (nonce . jti)
+   token->jwt
+   decode
+   encode
+   issue
+   )
   #:export
   (
 
@@ -37,19 +46,6 @@
    make-invalid-dpop-proof
    invalid-dpop-proof?
 
-   the-dpop-proof
-   dpop-proof?
-
-   dpop-proof-alg
-   dpop-proof-typ
-   dpop-proof-jwk
-
-   dpop-proof-jti
-   dpop-proof-htm
-   dpop-proof-htu
-   dpop-proof-iat
-   dpop-proof-ath
-
    &dpop-method-mismatch
    make-dpop-method-mismatch
    dpop-method-mismatch?
@@ -72,8 +68,7 @@
    make-dpop-unconfirmed-key
    dpop-unconfirmed-key?
 
-   dpop-proof-decode
-   issue-dpop-proof
+   <dpop-proof> typ jwk htm htu ath
    ))
 
 (define-exception-type
@@ -82,172 +77,6 @@
   make-invalid-dpop-proof
   invalid-dpop-proof?)
 
-(define (parse-jwk data)
-  (false-if-exception
-   (jwk->key data)))
-
-(define (the-dpop-proof x)
-  (with-exception-handler
-      (lambda (error)
-        (let ((final-message
-               (cond
-                ((invalid-jws? error)
-                 (if (exception-with-message? error)
-                     (format #f (G_ "this is not a DPoP proof, because it is not even a JWS: ~a")
-                             (exception-message error))
-                     (format #f (G_ "this is not a DPoP proof, because it is not even a JWS"))))
-                (else
-                 (if (exception-with-message? error)
-                     (format #f (G_ "this is not an access token: ~a")
-                             (exception-message error))
-                     (format #f (G_ "this is not an access token")))))))
-          (raise-exception
-           (make-exception
-            (make-invalid-dpop-proof)
-            (make-exception-with-message final-message)
-            error))))
-    (lambda ()
-      (match (the-jws x)
-        ((header . payload)
-         (let examine-header ((header header)
-                              (alg #f)
-                              (typ #f)
-                              (jwk #f)
-                              (other-header-fields '()))
-           (match header
-             (()
-              (let examine-payload ((payload payload)
-                                    (jti #f)
-                                    (htm #f)
-                                    (htu #f)
-                                    (iat #f)
-                                    (ath #f)
-                                    (other-payload-fields '()))
-                (match payload
-                  (()
-                   (unless (and alg typ jwk jti htm htu iat)
-                     (fail (format #f (G_ "the DPoP proof is missing ~s")
-                                   `(,@(if alg '() '("alg"))
-                                     ,@(if typ '() '("typ"))
-                                     ,@(if jwk '() '("jwk"))
-                                     ,@(if jti '() '("jti"))
-                                     ,@(if htm '() '("htm"))
-                                     ,@(if htu '() '("htu"))
-                                     ,@(if iat '() '("iat"))))))
-                   `(((alg . ,(symbol->string alg))
-                      (typ . "dpop+jwt")
-                      (jwk . ,(key->jwk (public-key jwk)))
-                      ,@other-header-fields)
-                     . ((jti . ,jti)
-                        (htm . ,(symbol->string htm))
-                        (htu . ,(uri->string htu))
-                        (iat . ,(time-second (date->time-utc iat)))
-                        ,@(if ath `((ath . ,ath)) '())
-                        ,@other-payload-fields)))
-                  ((('jti . (? string? given-jti)) payload ...)
-                   (examine-payload payload
-                                    (or jti given-jti) htm htu iat ath
-                                    other-payload-fields))
-                  ((('jti . incorrect) payload ...)
-                   (fail (format #f (G_ "the \"jti\" field should be a string, not ~s")
-                                 incorrect)))
-                  ((('htm . (? string? given-htm)) payload ...)
-                   (examine-payload payload jti
-                                    (or htm (string->symbol given-htm))
-                                    htu iat ath other-payload-fields))
-                  ((('htm . incorrect) payload ...)
-                   (fail (format #f (G_ "the \"htm\" field should be a string, not ~s")
-                                 incorrect)))
-                  ((('htu . (? string? (= string->uri (? uri? given-htu)))) payload ...)
-                   (examine-payload payload jti htm
-                                    (or htu given-htu)
-                                    iat ath other-payload-fields))
-                  ((('htu . incorrect) payload ...)
-                   (fail (format #f (G_ "the \"htu\" field should be an URI, not ~s")
-                                 incorrect)))
-                  ((('iat . (? (cute >= <> 0) (? integer? given-iat))) payload ...)
-                   (examine-payload payload jti htm htu
-                                    (or iat (time-utc->date (make-time time-utc 0 given-iat)))
-                                    ath other-payload-fields))
-                  ((('iat . incorrect) payload ...)
-                   (fail (format #f (G_ "the \"iat\" field should be a timestamp, not ~s")
-                                 incorrect)))
-                  ((('ath . (? string? given-ath)) payload ...)
-                   (examine-payload payload jti htm htu iat
-                                    (or ath given-ath)
-                                    other-payload-fields))
-                  ((('ath . incorrect) payload ...)
-                   (fail (format #f (G_ "the \"ath\" field should be an encoded JWT, not ~s")
-                                 incorrect)))
-                  ((field payload ...)
-                   (examine-payload payload jti htm htu iat ath
-                                    `(,field ,@other-payload-fields))))))
-             ((('alg . (? string? given-alg)) header ...)
-              (examine-header header (or alg (string->symbol given-alg))
-                              typ jwk other-header-fields))
-             ((('alg . incorrect) header ...)
-              (fail (format #f (G_ "the \"alg\" field should be a string, not ~s")
-                            incorrect)))
-             ((('typ . "dpop+jwt") header ...)
-              (examine-header header alg #t jwk other-header-fields))
-             ((('typ . incorrect) header ...)
-              (fail (format #f (G_ "the \"typ\" field should be \"dpop+jwt\", not ~s")
-                            incorrect)))
-             ((('jwk . (= parse-jwk (? (cute is-a? <> <public-key>) given-jwk))) header ...)
-              (examine-header header alg typ (or jwk given-jwk)
-                              other-header-fields))
-             ((('jwk . (= parse-jwk (? (cute is-a? <> <key-pair>) given-jwk))) header ...)
-              (fail (format #f (G_ "the \"jwk\" field should not contain the private key"))))
-             ((('jwk . incorrect) header ...)
-              (fail (format #f (G_ "the \"jwk\" field should be a valid public key, not ~s")
-                            incorrect)))
-             ((field header ...)
-              (examine-header header alg typ jwk `(,field ,@other-header-fields))))))))))
-
-(define (dpop-proof? x)
-  (false-if-exception (the-dpop-proof x)))
-
-(define (dpop-proof-alg proof)
-  (match (the-dpop-proof proof)
-    ((header . _)
-     (symbol->string (assq-ref header 'alg)))))
-
-(define (dpop-proof-typ proof)
-  (match (the-dpop-proof proof)
-    ((header . _)
-     (assq-ref header 'typ))))
-
-(define (dpop-proof-jwk proof)
-  (match (the-dpop-proof proof)
-    ((header . _)
-     (jwk->key (assq-ref header 'jwk)))))
-
-(define (dpop-proof-jti proof)
-  (match (the-dpop-proof proof)
-    ((_ . payload)
-     (assq-ref payload 'jti))))
-
-(define (dpop-proof-htm proof)
-  (match (the-dpop-proof proof)
-    ((_ . payload)
-     (string->symbol (assq-ref payload 'htm)))))
-
-(define (dpop-proof-htu proof)
-  (match (the-dpop-proof proof)
-    ((_ . payload)
-     (string->uri (assq-ref payload 'htu)))))
-
-(define (dpop-proof-iat proof)
-  (match (the-dpop-proof proof)
-    ((_ . payload)
-     (time-utc->date
-      (make-time time-utc 0 (assq-ref payload 'iat))))))
-
-(define (dpop-proof-ath proof)
-  (match (the-dpop-proof proof)
-    ((_ . payload)
-     (assq-ref payload 'ath))))
-
 (define-exception-type
   &dpop-method-mismatch
   &external-error
@@ -299,129 +128,169 @@
   make-dpop-unconfirmed-key
   dpop-unconfirmed-key?)
 
-(define* (dpop-proof-decode method uri str cnf/check
-                            #:key
-                            (access-token #f))
-  (let* ((current-date ((p:current-date)))
-         (current-time
-          (time-second (date->time-utc current-date))))
-    (with-exception-handler
-        (lambda (error)
-          (let ((final-message
-                 (if (exception-with-message? error)
-                     (format #f (G_ "the DPoP proof cannot be decoded: ~a")
-                             (exception-message error))
-                     (format #f (G_ "the DPoP proof cannot be decoded")))))
-            (raise-exception
-             (make-exception
-              (make-invalid-dpop-proof)
-              (make-exception-with-message final-message)
-              error))))
-      (lambda ()
-        (let ((decoded (the-dpop-proof (jws-decode str dpop-proof-jwk))))
-          (unless (eq? method (dpop-proof-htm decoded))
-            (let ((final-message
-                   (format #f (G_ "the DPoP proof is signed for access through ~s, but it is used with ~s")
-                           (dpop-proof-htm decoded) method)))
-              (raise-exception
-               (make-exception
-                (make-dpop-method-mismatch (dpop-proof-htm decoded) method)
-                (make-exception-with-message final-message)))))
-          (uris-compatible (dpop-proof-htu decoded)
-                           (if (string? uri)
-                               (string->uri uri)
-                               uri))
-          (let ((iat (dpop-proof-iat decoded)))
-            (let ((iat-s (time-second (date->time-utc iat))))
-              (unless (>= current-time (- iat-s 5))
-                (let ((final-message
-                       (format #f (G_ "the DPoP proof is signed in the future, ~a, relative to the current date, ~a")
-                               (date->string iat)
-                               (date->string current-date))))
-                  (raise-exception
-                   (make-exception
-                    (make-signed-in-future iat current-date)
-                    (make-exception-with-message final-message)))))
-              (unless (<= current-time (+ iat-s 120)) ;; valid for 2 minutes
-                (let ((final-message
-                       (format #f (G_ "the DPoP proof is too old, it was signed ~a and now it is ~a")
-                               (date->string iat)
-                               (date->string current-date))))
-                  (raise-exception
-                   (make-exception
-                    (make-expired (time-utc->date (make-time time-utc 0 (+ iat-s 120)))
-                                  current-date)
-                    (make-exception-with-message final-message)))))))
-          (when access-token
-            (let ((h (stubs:hash 'SHA-256 access-token)))
-              (unless (equal? (dpop-proof-ath decoded) h)
-                (let ((final-message
-                       (format #f (G_ "the DPoP proof should go along with an access token hashed to ~s, not ~s")
-                               (dpop-proof-ath decoded) access-token)))
-                  (raise-exception
-                   (make-exception
-                    (make-dpop-invalid-ath (dpop-proof-ath decoded) access-token)
-                    (make-exception-with-message final-message)))))))
-          (if (string? cnf/check)
-              (unless (equal? cnf/check (jkt (dpop-proof-jwk decoded)))
-                (let ((final-message
-                       (format #f (G_ "the DPoP proof is signed with the wrong key"))))
-                  (raise-exception
-                   (make-exception
-                    (make-dpop-unconfirmed-key)
-                    (make-exception-with-message final-message)))))
-              (with-exception-handler
-                  (lambda (error)
-                    (let ((final-message
-                           (if (exception-with-message? error)
-                               (format #f (G_ "the DPoP proof is signed with the wrong key: ~a")
-                                       (exception-message error))
-                               (format #f (G_ "the DPoP proof is signed with the wrong key")))))
-                      (raise-exception
-                       (make-exception
-                        (make-dpop-unconfirmed-key)
-                        (make-exception-with-message final-message)
-                        error))))
-                (lambda ()
-                  (unless (cnf/check (jkt (dpop-proof-jwk decoded)))
-                    ;; You should throw an error instead!
-                    (fail (G_ "the cnf/check function returned #f"))))))
-          (parameterize ((p:current-date current-date))
-            ;; jti-check should use the same date.
-            (jti-check (dpop-proof-jti decoded) 120))
-          decoded)))))
+(define-class <dpop-proof> (<single-use-token>)
+  (typ #:init-keyword #:typ #:accessor typ)
+  (jwk #:init-keyword #:jwk #:accessor jwk)
+  (htm #:init-keyword #:htm #:accessor htm)
+  (htu #:init-keyword #:htu #:accessor htu)
+  (ath #:init-keyword #:ath #:accessor ath))
+
+(define-method (default-validity (proof <dpop-proof>))
+  30)
+
+(define-method (has-explicit-exp? (proof <dpop-proof>))
+  #f)
 
-(define (dpop-proof-encode dpop-proof key)
+(define-method (nonce-field-name (proof <dpop-proof>))
+  'jti)
+
+(define-method (initialize (token <dpop-proof>) initargs)
   (with-exception-handler
       (lambda (error)
-        (let ((final-message
-               (if (exception-with-message? error)
-                   (format #f (G_ "cannot encode a DPoP proof: ~a")
-                           (exception-message error))
-                   (format #f (G_ "cannot encode a DPoP proof")))))
-          (raise-exception
-           (make-exception
-            (make-exception-with-message final-message)
-            error))))
+        (raise-exception
+         (make-exception
+          (make-invalid-dpop-proof)
+          (make-exception-with-message
+           (if (exception-with-message? error)
+               (format #f (G_ "invalid DPoP proof: ~a")
+                       (exception-message error))
+               (G_ "invalid DPoP proof token")))
+          error)))
     (lambda ()
-      (jws-encode dpop-proof key))))
-
-(define* (issue-dpop-proof
-          client-key
-          #:key
-          (htm #f)
-          (htu #f)
-          (access-token #f))
-  (dpop-proof-encode
-   (the-dpop-proof
-    `(((alg . ,(symbol->string (alg client-key)))
-       (typ . "dpop+jwt")
-       (jwk . ,(key->jwk (public-key client-key))))
-      . ((jti . ,(stubs:random 12))
-         (htm . ,(symbol->string htm))
-         (htu . ,(uri->string htu))
-         (iat . ,(time-second (date->time-utc ((p:current-date)))))
-         ,@(if access-token
-               `((ath . ,(stubs:hash 'SHA-256 access-token)))
-               '()))))
-   client-key))
+      (next-method)
+      (let-keywords
+       initargs #t
+       ((typ "dpop+jwt")
+        (jwk #f)
+        (htm #f)
+        (htu #f)
+        (ath #f)
+        (access-token #f)
+        (jwt-header #f)
+        (jwt-payload #f))
+       (let do-initialize ((typ typ)
+                           (jwk jwk)
+                           (htm htm)
+                           (htu htu)
+                           (ath ath)
+                           (access-token access-token)
+                           (jwt-header jwt-header)
+                           (jwt-payload jwt-payload))
+         (cond
+          ((string? htu)
+           (do-initialize typ jwk htm (string->uri htu) ath access-token jwt-header jwt-payload))
+          ((string? htm)
+           (do-initialize typ jwk (string->symbol htm) htu ath access-token jwt-header jwt-payload))
+          ((and (not ath) access-token)
+           (do-initialize typ jwk htm htu (stubs:hash 'SHA-256 access-token) #f jwt-header jwt-payload))
+          ((and typ jwk htm htu)
+           (unless (equal? typ "dpop+jwt")
+             (scm-error 'wrong-type-arg "make"
+                        (G_ "#:typ should be exactly \"dpop+jwt\"")
+                        '()
+                        (list typ)))
+           (unless (is-a? jwk <public-key>)
+             (scm-error 'wrong-type-arg "make"
+                        (G_ "#:jwk should be a public key")
+                        '()
+                        (list jwk)))
+           (unless (symbol? htm)
+             (scm-error 'wrong-type-arg "make"
+                        (G_ "#:htm should be a symbol")
+                        '()
+                        (list htm)))
+           (when ath
+             (unless (string? ath)
+               (scm-error 'wrong-type-arg "make"
+                          (G_ "when present, #:ath should be a string")
+                          '()
+                          (list ath))))
+           (slot-set! token 'typ typ)
+           (slot-set! token 'jwk jwk)
+           (slot-set! token 'htm htm)
+           (slot-set! token 'htu htu)
+           (slot-set! token 'ath ath))
+          ((and jwt-header jwt-payload)
+           (do-initialize
+            (assq-ref jwt-header 'typ)
+            (jwk->key (assq-ref jwt-header 'jwk))
+            (assq-ref jwt-payload 'htm)
+            (assq-ref jwt-payload 'htu)
+            (assq-ref jwt-payload 'ath)
+            #f #f #f))
+          (else
+           (raise-exception
+            (make-exception
+             (make-invalid-jws)
+             (make-exception-with-message
+              (G_ "when making a DPoP proof, either its required fields (#:typ, #:jwk, #:htm and #:htu) or (#:jwt-header and #:jwt-payload) should be passed")))))))))))
+
+(define-method (token->jwt (token <dpop-proof>))
+  ;; exp should be implicit, and nonce should be replaced by jti
+  (receive (base-header base-payload) (next-method)
+    (values
+     `((typ . ,(typ token))
+       (jwk . ,(key->jwk (jwk token)))
+       ,@base-header)
+     `((htm . ,(symbol->string (htm token)))
+       (htu . ,(uri->string (htu token)))
+       ,@(let ((ath (ath token)))
+           (if ath
+               `((ath . ,ath))
+               '()))
+       ,@base-payload))))
+
+(define-method (verify (token <dpop-proof>) args)
+  (next-method)
+  (let-keywords
+   args #t
+   ((access-token #f)
+    (method #f)
+    (uri #f)
+    (cnf/check #f))
+   (begin
+     (when (string? uri)
+       (set! uri (string->uri uri)))
+     (unless (eq? (htm token) method)
+       (raise-exception
+        (make-exception
+         (make-dpop-method-mismatch (htm token) method)
+         (make-exception-with-message
+          (format #f (G_ "the DPoP proof is signed for access through ~s, but it is used with ~s")
+                  (htm token) method)))))
+     (uris-compatible (htu token) uri)
+     (when access-token
+       (let ((h (stubs:hash 'SHA-256 access-token)))
+         (unless (equal? (ath token) h)
+           (raise-exception
+            (make-exception
+             (make-dpop-invalid-ath (ath token) access-token)
+             (make-exception-with-message
+              (format #f (G_ "the DPoP proof should go along with an access token hashed to ~s, not ~s")
+                      (ath token) access-token)))))))
+     (if (string? cnf/check)
+         (unless (equal? cnf/check (jkt (jwk token)))
+           (raise-exception
+            (make-exception
+             (make-dpop-unconfirmed-key)
+             (make-exception-with-message
+              (format #f (G_ "the DPoP proof is signed with the wrong key"))))))
+         (with-exception-handler
+             (lambda (error)
+               (let ((final-message
+                      (if (exception-with-message? error)
+                          (format #f (G_ "the DPoP proof is signed with the wrong key: ~a")
+                                  (exception-message error))
+                          (format #f (G_ "the DPoP proof is signed with the wrong key")))))
+                 (raise-exception
+                  (make-exception
+                   (make-dpop-unconfirmed-key)
+                   (make-exception-with-message final-message)
+                   error))))
+           (lambda ()
+             (unless (cnf/check (jkt (jwk token)))
+               ;; You should throw an error instead!
+               (fail (G_ "the cnf/check function returned #f")))))))))
+
+(define-method (lookup-keys (token <dpop-proof>) args)
+  (jwk token))