JWS: use GOOPS

11 files changed, 914 insertions, 1181 deletions

diff --git a/src/scm/webid-oidc/access-token.scm b/src/scm/webid-oidc/access-token.scm
index 7e67270..7c23126 100644
--- a/src/scm/webid-oidc/access-token.scm
+++ b/src/scm/webid-oidc/access-token.scm
@@ -29,7 +29,17 @@
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 receive)
+  #:use-module (oop goops)
   #:declarative? #t
+  #:re-export
+  (
+   alg iat exp iss
+   token->jwt
+   decode
+   encode
+   issue
+   )
   #:export
   (
 
@@ -37,21 +47,7 @@
    make-invalid-access-token
    invalid-access-token?
 
-   the-access-token
-   access-token?
-
-   access-token-alg
-
-   access-token-webid
-   access-token-iss
-   access-token-aud
-   access-token-iat
-   access-token-exp
-   access-token-client-id
-   access-token-cnf/jkt
-
-   access-token-decode
-   issue-access-token
+   <access-token> webid aud client-id cnf/jkt
    ))
 
 (define-exception-type
@@ -60,289 +56,109 @@
   make-invalid-access-token
   invalid-access-token?)
 
-;; The order is meaningful in this module, the-access-token reorders
-;; them.
-(define (the-access-token x)
-  (with-exception-handler
-      (lambda (error)
-        (let ((final-message
-               (cond
-                ((invalid-jws? error)
-                 (if (exception-with-message? error)
-                     (format #f (G_ "this is not an access token, because it is not even a JWS: ~a")
-                             (exception-message error))
-                     (format #f (G_ "this is not an access token, 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-access-token)
-            (make-exception-with-message final-message)
-            error))))
-    (lambda ()
-      (match (the-jws x)
-        ((header . payload)
-         (let examine-payload ((payload payload)
-                               (webid #f)
-                               (iss #f)
-                               (aud #f)
-                               (iat #f)
-                               (exp #f)
-                               (cnf #f)
-                               (client-id #f)
-                               (other-fields '()))
-           (match payload
-             (()
-              (unless (and webid iss aud iat exp cnf client-id)
-                ;; Missing some things
-                (fail (format #f (G_ "the payload is missing ~s")
-                              `(,@(if webid '() '("webid"))
-                                ,@(if iss '() '("iss"))
-                                ,@(if aud '() '("aud"))
-                                ,@(if iat '() '("iat"))
-                                ,@(if exp '() '("exp"))
-                                ,@(if cnf '() '("cnf"))
-                                ,@(if client-id '() '("client_id"))))))
-              `(,header
-                . ((webid . ,(uri->string webid))
-                   (iss . ,(uri->string iss))
-                   (aud . "solid")
-                   (iat . ,(time-second (date->time-utc iat)))
-                   (exp . ,(time-second (date->time-utc exp)))
-                   (client_id . ,(uri->string client-id))
-                   (cnf . ,cnf)
-                   ,@(reverse other-fields))))
-             ((('webid . (? string? (= string->uri (? uri? webid-given)))) payload ...)
-              (examine-payload payload
-                               (or webid webid-given)
-                               iss aud iat exp cnf client-id other-fields))
-             ((('webid . infringing) payload ...)
-              (fail (format #f (G_ "the \"webid\" field should be an URI, ~s is given")
-                            infringing)))
-             ((('iss . (? string? (= string->uri (? uri? iss-given)))) payload ...)
-              (examine-payload payload webid
-                               (or iss iss-given)
-                               aud iat exp cnf client-id other-fields))
-             ((('iss . infringing) payload ...)
-              (fail (format #f (G_ "the \"iss\" field should be an URI, ~s is given")
-                            infringing)))
-             ((('aud . "solid") payload ...)
-              (examine-payload payload webid iss #t iat exp cnf client-id other-fields))
-             ((('aud . infringing) payload ...)
-              (fail (format #f (G_ "the \"aud\" field should be set to \"solid\", ~s is given")
-                            infringing)))
-             ((('iat . (? (cute >= <> 0) (? integer? iat-given))) payload ...)
-              (examine-payload payload webid iss aud
-                               (or iat (time-utc->date (make-time time-utc 0 iat-given)))
-                               exp cnf client-id other-fields))
-             ((('iat . infringing) payload ...)
-              (fail (format #f (G_ "the \"iat\" field should be a timestamp, ~s is given")
-                            infringing)))
-             ((('exp . (? (cute >= <> 0) (? integer? exp-given))) payload ...)
-              (examine-payload payload webid iss aud iat
-                               (or exp (time-utc->date (make-time time-utc 0 exp-given)))
-                               cnf client-id other-fields))
-             ((('exp . infringing) payload ...)
-              (fail (format #f (G_ "the \"exp\" field should be a timestamp, ~s is given")
-                            infringing)))
-             ((('cnf . cnf) payload ...)
-              (let examine-cnf ((data cnf)
-                                (jkt #f)
-                                (other-cnf-fields '()))
-                (match data
-                  (()
-                   (unless jkt
-                     (fail (format #f (G_ "the \"cnf\" / \"jkt\" field is missing"))))
-                   (examine-payload payload webid iss aud iat exp
-                                    `((jkt . ,jkt)
-                                      ,@(reverse other-cnf-fields))
-                                    client-id other-fields))
-                  ((('jkt . (? string? jkt-given)) data ...)
-                   (examine-cnf data (or jkt jkt-given other-cnf-fields) other-cnf-fields))
-                  ((('jkt . infringing) _ ...)
-                   (fail (format #f (G_ "the \"cnf\" / \"jkt\" field should be a string, ~s is given")
-                                 infringing)))
-                  ((field data ...)
-                   (examine-cnf data jkt `(,field ,@other-cnf-fields)))
-                  (data
-                   (fail (format #f (G_ "the \"cnf\" field should be an object, ~s is given")
-                                 data))))))
-             ((('client_id . (? string? (= string->uri (? uri? client-id-given)))) payload ...)
-              (examine-payload payload webid iss aud iat exp cnf
-                               (or client-id client-id-given)
-                               other-fields))
-             ((('client_id . infringing) payload ...)
-              (fail (format #f (G_ "the \"client_id\" field should be an URI, ~s is given")
-                            infringing)))
-             ((field payload ...)
-              (examine-payload payload webid iss aud iat exp cnf client-id
-                               `(,field ,@other-fields))))))
-        (else
-         (scm-error 'wrong-type-arg "the-access-token"
-                    "expected a pair of lists"
-                    '()
-                    (list x)))))))
-
-(define (access-token? x)
-  (false-if-exception (the-access-token x)))
-
-(define (access-token-alg code)
-  (match (the-access-token code)
-    ((header . _)
-     (string->symbol (assq-ref header 'alg)))))
-
-(define (access-token-webid code)
-  (match (the-access-token code)
-    ((_ . payload)
-     (string->uri (assq-ref payload 'webid)))))
-
-(define (access-token-iss code)
-  (match (the-access-token code)
-    ((_ . payload)
-     (string->uri (assq-ref payload 'iss)))))
+(define-class <access-token> (<time-bound-token> <oidc-token>)
+  (webid #:init-keyword #:webid #:accessor webid)
+  (aud #:init-keyword #:aud #:accessor aud)
+  (client-id #:init-keyword #:client-id #:accessor client-id)
+  (cnf/jkt #:init-keyword #:cnf/jkt #:accessor cnf/jkt))
 
-(define (access-token-aud code)
-  (match (the-access-token code)
-    ((_ . payload)
-     (assq-ref payload 'aud))))
-
-(define (access-token-iat code)
-  (match (the-access-token code)
-    ((_ . payload)
-     (time-utc->date
-      (make-time time-utc 0 (assq-ref payload 'iat))))))
-
-(define (access-token-exp code)
-  (match (the-access-token code)
-    ((_ . payload)
-     (time-utc->date
-      (make-time time-utc 0 (assq-ref payload 'exp))))))
-
-(define (access-token-client-id code)
-  (match (the-access-token code)
-    ((_ . payload)
-     (string->uri (assq-ref payload 'client-id)))))
-
-(define (access-token-cnf/jkt code)
-  (match (the-access-token code)
-    ((_ . payload)
-     (assq-ref (assq-ref payload 'cnf) 'jkt))))
-
-(define* (access-token-decode str #:key (http-get http-get))
+(define-method (initialize (token <access-token>) initargs)
   (with-exception-handler
       (lambda (error)
-        (let ((final-message
-               (if (exception-with-message? error)
-                   (format #f (G_ "the access token is invalid: ~a")
-                           (exception-message error))
-                   (format #f (G_ "the access token is invalid")))))
-          (raise-exception
-           (make-exception
-            (make-invalid-access-token)
-            (make-exception-with-message final-message)
-            error))))
+        (raise-exception
+         (make-exception
+          (make-invalid-access-token)
+          (make-exception-with-message
+           (if (exception-with-message? error)
+               (format #f (G_ "invalid access token: ~a")
+                       (exception-message error))
+               (G_ "invalid access token")))
+          error)))
     (lambda ()
-      (jws-decode
-       str
-       (lambda (token)
-         (let* ((iss (access-token-iss token))
-                (cfg
-                 (with-exception-handler
-                     (lambda (error)
-                       (let ((final-message
-                              (if (exception-with-message? error)
-                                  (format #f (G_ "I cannot query the identity provider configuration: ~a")
-                                          (exception-message error))
-                                  (format #f (G_ "I cannot query the identity provider configuratioon")))))
-                         (raise-exception
-                          (make-exception
-                           (make-cannot-query-identity-provider iss)
-                           (make-exception-with-message final-message)
-                           error))))
-                   (lambda ()
-                     (get-oidc-configuration
-                      (uri-host iss)
-                      #:userinfo (uri-userinfo iss)
-                      #:port (uri-port iss)
-                      #:http-get http-get))))
-                (jwks
-                 (with-exception-handler
-                     (lambda (error)
-                       (let ((final-message
-                              (if (exception-with-message? error)
-                                  (format #f (G_ "I cannot query the identity provider public keys: ~a")
-                                          (exception-message error))
-                                  (format #f (G_ "I cannot query the identity provider public keys")))))
-                         (raise-exception
-                          (make-exception
-                           (make-cannot-query-identity-provider iss)
-                           (make-exception-with-message final-message)
-                           error))))
-                   (lambda ()
-                     (oidc-configuration-jwks cfg #:http-get http-get)))))
-           (let ((iat (access-token-iat token))
-                 (exp (access-token-exp token))
-                 (current-date ((p:current-date))))
-             (let ((iat-s (time-second (date->time-utc iat)))
-                   (exp-s (time-second (date->time-utc exp)))
-                   (current-s (time-second (date->time-utc current-date))))
-               (when (>= iat-s (+ current-s 5))
-                 (let ((final-message
-                        (format #f (G_ "the access token is signed in the future, ~a, relative to current ~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)))))
-               (when (>= current-s exp-s)
-                 (let ((final-message
-                        (format #f (G_ "the access token expired ~a, which is in the past (from ~a)")
-                                (date->string exp)
-                                (date->string current-date))))
-                   (raise-exception
-                    (make-exception
-                     (make-expired exp current-date)
-                     (make-exception-with-message final-message)))))))
-           jwks))))))
-
-(define (access-token-encode access-token key)
-  (with-exception-handler
-      (lambda (error)
-        (let ((final-message
-               (if (exception-with-message? error)
-                   (format #f (G_ "cannot encode the access token: ~a")
-                           (exception-message error))
-                   (format #f (G_ "cannot encode the access token")))))
-          (raise-exception
-           (make-exception-with-message final-message))))
-    (lambda ()
-      (jws-encode access-token key))))
-
-(define* (issue-access-token
-          issuer-key
-          #:key
-          (webid #f)
-          (iss #f)
-          (validity 3600)
-          (client-key #f)
-          (cnf/jkt #f)
-          (client-id #f))
-  (when client-key
-    (set! cnf/jkt (jkt client-key)))
-  (let* ((iat (time-second (date->time-utc ((p:current-date)))))
-         (exp (+ iat validity)))
-    (jws-encode
-     (the-access-token
-      `(((alg . ,(symbol->string (alg issuer-key))))
-        . ((webid . ,(uri->string webid))
-           (iss . ,(uri->string iss))
-           (aud . "solid")
-           (iat . ,iat)
-           (exp . ,exp)
-           (cnf . ((jkt . ,cnf/jkt)))
-           (client_id . ,(uri->string client-id)))))
-     issuer-key)))
+      (next-method)
+      (let-keywords
+       initargs #t
+       ((webid #f)
+        (aud "solid")
+        (client-id #f)
+        (cnf/jkt #f)
+        (client-key #f)
+        (jwt-header #f)
+        (jwt-payload #f))
+       (let do-initialize ((webid webid)
+                           (aud aud)
+                           (client-id client-id)
+                           (cnf/jkt cnf/jkt)
+                           (client-key client-key)
+                           (jwt-header jwt-header)
+                           (jwt-payload jwt-payload))
+         (cond
+          ((string? webid)
+           (do-initialize (string->uri webid)
+                          aud
+                          client-id
+                          cnf/jkt
+                          client-key
+                          jwt-header
+                          jwt-payload))
+          ((string? client-id)
+           (do-initialize webid
+                          aud
+                          (string->uri client-id)
+                          cnf/jkt
+                          client-key
+                          jwt-header
+                          jwt-payload))
+          ((and (not cnf/jkt) client-key)
+           (do-initialize webid aud client-id (jkt client-key) #f jwt-header jwt-payload))
+          ((and webid client-id cnf/jkt)
+           (unless (uri? webid)
+             (scm-error 'wrong-type-arg "make"
+                        (G_ "#:webid should be an URI")
+                        '()
+                        (list webid)))
+           (unless (uri? client-id)
+             (scm-error 'wrong-type-arg "make"
+                        (G_ "#:client-id should be an URI")
+                        '()
+                        (list client-id)))
+           (unless (string? cnf/jkt)
+             (scm-error 'wrong-type-arg "make"
+                        (G_ "#:cnf/jkt should be a string")
+                        '()
+                        (list cnf/jkt)))
+           (unless (equal? aud "solid")
+             (scm-error 'wrong-type-arg "make"
+                        (G_ "#:aud should be exactly \"solid\"")
+                        '()
+                        (list aud)))
+           (slot-set! token 'webid webid)
+           (slot-set! token 'aud aud)
+           (slot-set! token 'client-id client-id)
+           (slot-set! token 'cnf/jkt cnf/jkt))
+          ((and jwt-header jwt-payload)
+           (do-initialize (assq-ref jwt-payload 'webid)
+                          (assq-ref jwt-payload 'aud)
+                          (assq-ref jwt-payload 'client_id)
+                          (assq-ref (assq-ref jwt-payload 'cnf) 'jkt)
+                          #f #f #f))
+          (else
+           (raise-exception
+            (make-exception
+             (make-invalid-jws)
+             (make-exception-with-message
+              (G_ "when making an access token either its required fields (#:alg, #:webid, #:iss, #:aud, #:client-id, #:cnf/jkt, #:iat and #:exp) or (#:jwt-header and #:jwt-payload) should be passed")))))))))))
+
+(define-method (token->jwt (token <access-token>))
+  (receive (base-header base-payload)
+      (next-method)
+    (values
+     base-header
+     `((webid . ,(uri->string (webid token)))
+       (iss . ,(uri->string (iss token)))
+       (aud . ,(aud token))
+       (client_id . ,(uri->string (client-id token)))
+       (cnf . ((jkt . ,(cnf/jkt token))))
+       (iat . ,(time-second (date->time-utc (iat token))))
+       (exp . ,(time-second (date->time-utc (exp token))))
+       ,@base-payload))))
diff --git a/src/scm/webid-oidc/authorization-code.scm b/src/scm/webid-oidc/authorization-code.scm
index 1481b2c..13b7ac4 100644
--- a/src/scm/webid-oidc/authorization-code.scm
+++ b/src/scm/webid-oidc/authorization-code.scm
@@ -26,7 +26,18 @@
   #:use-module (webid-oidc web-i18n)
   #:use-module (ice-9 match)
   #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 optargs)
+  #:use-module (oop goops)
   #:declarative? #t
+  #:re-export
+  (
+   alg iat exp nonce
+   token->jwt
+   decode
+   encode
+   issue
+   )
   #:export
   (
 
@@ -34,18 +45,7 @@
    make-invalid-authorization-code
    invalid-authorization-code?
 
-   the-authorization-code
-   authorization-code?
-
-   authorization-code-alg
-
-   authorization-code-webid
-   authorization-code-client-id
-   authorization-code-jti
-   authorization-code-exp
-
-   authorization-code-decode
-   issue-authorization-code
+   <authorization-code> webid client-id
    ))
 
 (define-exception-type
@@ -54,171 +54,74 @@
   make-invalid-authorization-code
   invalid-authorization-code?)
 
-(define (the-authorization-code x)
-  (with-exception-handler
-      (lambda (error)
-        (let ((final-message
-               (cond
-                ((invalid-jws? error)
-                 (if (exception-with-message? error)
-                     (format #f (G_ "this is not an authorization code, because it is not even a JWS: ~a")
-                             (exception-message error))
-                     (format #f (G_ "this is not an authorization code, because it is not even a JWS"))))
-                (else
-                 (if (exception-with-message? error)
-                     (format #f (G_ "this is not an authorization code: ~a")
-                             (exception-message error))
-                     (format #f (G_ "this is not an authorization code")))))))
-          (raise-exception
-           (make-exception
-            (make-invalid-authorization-code)
-            (make-exception-with-message final-message)
-            error))))
-    (lambda ()
-      (match (the-jws x)
-        ((header . payload)
-         (let examine-payload ((payload payload)
-                               (webid #f)
-                               (client-id #f)
-                               (jti #f)
-                               (exp #f)
-                               (other-fields '()))
-           (match payload
-             (()
-              (unless (and webid client-id jti exp)
-                (fail (format #f (G_ "the payload is missing ~s")
-                              `(,@(if webid '() '("webid"))
-                                ,@(if client-id '() '("client_id"))
-                                ,@(if jti '() '("jti"))
-                                ,@(if exp '() '("exp"))))))
-              `(,header
-                . ((webid . ,(uri->string webid))
-                   (client_id . ,(uri->string client-id))
-                   (jti . ,jti)
-                   (exp . ,(time-second (date->time-utc exp)))
-                   ,@(reverse other-fields))))
-             ((('webid . (? string? (= string->uri (? uri? webid-given)))) payload ...)
-              (examine-payload payload
-                               (or webid webid-given)
-                               client-id jti exp other-fields))
-             ((('webid . infringing) payload ...)
-              (fail (format #f (G_ "the \"webid\" field should be an URI, ~s is given")
-                            infringing)))
-             ((('client_id . (? string? (= string->uri (? uri? client-id-given)))) payload ...)
-              (examine-payload payload webid
-                               (or client-id client-id-given)
-                               jti exp other-fields))
-             ((('client_id . infringing) payload ...)
-              (fail (format #f (G_ "the \"client_id\" field should be an URI, ~s is given")
-                            infringing)))
-             ((('jti . (? string? jti-given)) payload ...)
-              (examine-payload payload webid client-id
-                               (or jti jti-given)
-                               exp other-fields))
-             ((('jti . invalid) payload ...)
-              (fail (format #f (G_ "the \"jti\" field should be a string, ~s is given")
-                            invalid)))
-             ((('exp . (? (lambda (x) (and (integer? x) (>= x 0))) exp-given)) payload ...)
-              (examine-payload payload webid client-id jti
-                               (or exp (time-utc->date (make-time time-utc 0 exp-given)))
-                               other-fields))
-             ((('exp . infringing) payload ...)
-              (fail (format #f (G_ "the \"exp\" field should be a timestamp, ~s is given")
-                            infringing)))
-             ((field payload ...)
-              (examine-payload payload webid client-id jti exp `(,field ,@other-fields))))))
-        (else
-         (scm-error 'wrong-type-arg "the-authorization-code"
-                    "expected a pair of lists"
-                    '()
-                    (list x)))))))
-
-(define (authorization-code? x)
-  (false-if-exception (the-authorization-code x)))
+(define-class <authorization-code> (<single-use-token>)
+  (webid #:init-keyword #:webid #:accessor webid)
+  (client-id #:init-keyword #:client-id #:accessor client-id))
 
-(define (authorization-code-alg x)
-  (match (the-authorization-code x)
-    ((header . _)
-     (string->symbol (assq-ref header 'alg)))))
-
-(define (authorization-code-webid x)
-  (match (the-authorization-code x)
-    ((_ . payload)
-     (string->uri (assq-ref payload 'webid)))))
-
-(define (authorization-code-client-id x)
-  (match (the-authorization-code x)
-    ((_ . payload)
-     (string->uri (assq-ref payload 'client_id)))))
-
-(define (authorization-code-jti x)
-  (match (the-authorization-code x)
-    ((_ . payload)
-     (assq-ref payload 'jti))))
-
-(define (authorization-code-exp x)
-  (match (the-authorization-code x)
-    ((_ . payload)
-     (time-utc->date (make-time time-utc 0 (assq-ref payload 'exp))))))
-
-(define (authorization-code-decode str jwk)
-  (parameterize ((p:current-date
-                  (time-second (date->time-utc ((p:current-date))))))
-    (with-exception-handler
-        (lambda (error)
-          (let ((final-message
-                 (if (exception-with-message? error)
-                     (format #f (G_ "the authorization code is invalid: ~a")
-                             (exception-message error))
-                     (format #f (G_ "the authorization code is invalid")))))
-            (raise-exception
-             (make-exception
-              (make-invalid-authorization-code)
-              (make-exception-with-message final-message)
-              error))))
-      (lambda ()
-        (let ((code (the-authorization-code (jws-decode str (lambda (x) jwk)))))
-          (let ((exp (authorization-code-exp code))
-                (current-date ((p:current-date))))
-            (let ((exp-s (time-second (date->time-utc exp)))
-                  (current-s (time-second (date->time-utc current-date))))
-              (when (>= current-s exp-s)
-                (let ((final-message
-                       (format #f (G_ "the authorization expired ~a, which is in the past (from ~a)")
-                               (date->string exp)
-                               (date->string current-date))))
-                  (raise-exception
-                   (make-exception
-                    (make-expired exp current-date)
-                    (make-exception-with-message final-message)))))
-              (jti-check (authorization-code-jti code)
-                         (- exp-s current-s))
-              code)))))))
-
-(define (authorization-code-encode authorization-code key)
+(define-method (initialize (token <authorization-code>) initargs)
   (with-exception-handler
       (lambda (error)
-        (let ((final-message
-               (if (exception-with-message? error)
-                   (format #f (G_ "cannot encode the authorization code: ~a")
-                           (exception-message error))
-                   (format #f (G_ "cannot encode the authorization code")))))
-          (raise-exception
-           (make-exception-with-message final-message))))
+        (raise-exception
+         (make-exception
+          (make-invalid-authorization-code)
+          (make-exception-with-message
+           (if (exception-with-message? error)
+               (format #f (G_ "invalid authorization code: ~a")
+                       (exception-message error))
+               (G_ "invalid authorization code")))
+          error)))
     (lambda ()
-      (jws-encode authorization-code key))))
-
-(define* (issue-authorization-code issuer-key
-                                   #:key
-                                   (validity 120)
-                                   webid
-                                   client-id)
-  (let* ((iat (time-second (date->time-utc ((p:current-date)))))
-         (exp (+ iat validity)))
-    (authorization-code-encode
-     `(((alg . ,(symbol->string (alg issuer-key))))
-       . ((webid . ,(uri->string webid))
-          (client_id . ,(uri->string client-id))
-          (exp . ,exp)
-          (jti . ,(stubs:random 12))))
-     issuer-key)))
+      (next-method)
+      (let-keywords
+       initargs #t
+       ((webid #f)
+        (client-id #f)
+        (jwt-header #f)
+        (jwt-payload #f))
+       (let do-initialize ((webid webid)
+                           (client-id client-id)
+                           (jwt-header jwt-header)
+                           (jwt-payload jwt-payload))
+         (cond
+          ((string? webid)
+           (do-initialize (string->uri webid) client-id jwt-header jwt-payload))
+          ((string? client-id)
+           (do-initialize webid (string->uri client-id) jwt-header jwt-payload))
+          ((and webid client-id)
+           (unless (uri? webid)
+             (scm-error 'wrong-type-arg "make"
+                        (G_ "#:webid should be an URI")
+                        '()
+                        (list webid)))
+           (unless (uri? client-id)
+             (scm-error 'wrong-type-arg "make"
+                        (G_ "#:client-id should be a string")
+                        '()
+                        (list client-id)))
+           (slot-set! token 'webid webid)
+           (slot-set! token 'client-id client-id))
+          ((and jwt-header jwt-payload)
+           (do-initialize (assq-ref jwt-payload 'webid)
+                          (assq-ref jwt-payload 'client_id)
+                          #f #f))
+          (else
+           (raise-exception
+            (make-exception
+             (make-invalid-jws)
+             (make-exception-with-message
+              (G_ "when making an authorization code either its required fields (#:webid and #:client-id) or (#:jwt-header and #:jwt-payload) should be passed")))))))))))
+
+(define-method (token->jwt (token <authorization-code>))
+  (receive (base-header base-payload)
+      (next-method)
+    (values
+     base-header
+     `((webid . ,(uri->string (webid token)))
+       (client_id . ,(uri->string (client-id token)))
+       ,@base-payload))))
+
+(define-method (lookup-keys (token <authorization-code>) args)
+  (let-keywords
+   args #f
+   ((issuer-key #f))
+   issuer-key))
diff --git a/src/scm/webid-oidc/authorization-endpoint.scm b/src/scm/webid-oidc/authorization-endpoint.scm
index cf45a9c..4f171a2 100644
--- a/src/scm/webid-oidc/authorization-endpoint.scm
+++ b/src/scm/webid-oidc/authorization-endpoint.scm
@@ -106,7 +106,7 @@
               (lambda (error)
                 (error-application locale error))
             (lambda ()
-              (let ((code (issue-authorization-code
+              (let ((code (issue <authorization-code>
                            jwk
                            #:webid subject
                            #:client-id client-id))
diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm
index 5b6b0ef..006c86a 100644
--- a/src/scm/webid-oidc/client.scm
+++ b/src/scm/webid-oidc/client.scm
@@ -137,11 +137,12 @@
     (let* ((access-token (account:access-token account))
            (dpop-proof
             (let ((key-pair (account:key-pair account)))
-              (issue-dpop-proof
-               key-pair
-               #:htm method
-               #:htu uri
-               #:access-token access-token))))
+              (issue <dpop-proof>
+                     key-pair
+                     #:jwk (public-key key-pair)
+                     #:htm method
+                     #:htu uri
+                     #:access-token access-token))))
       (let ((all-headers
              `((dpop . ,dpop-proof)
                (authorization . (dpop . ,access-token))
diff --git a/src/scm/webid-oidc/client/accounts.scm b/src/scm/webid-oidc/client/accounts.scm
index ddb592a..3591b52 100644
--- a/src/scm/webid-oidc/client/accounts.scm
+++ b/src/scm/webid-oidc/client/accounts.scm
@@ -27,12 +27,13 @@
   #:use-module (srfi srfi-19)
   #:use-module (webid-oidc errors)
   #:use-module (webid-oidc web-i18n)
+  #:use-module (webid-oidc jws)
   #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module ((webid-oidc oidc-id-token) #:prefix id:)
   #:use-module ((webid-oidc oidc-configuration) #:prefix cfg:)
   #:use-module ((webid-oidc jwk) #:prefix jwk:)
-  #:use-module ((webid-oidc dpop-proof) #:prefix dpop:)
+  #:use-module (webid-oidc dpop-proof)
   #:use-module ((webid-oidc client client) #:prefix client:)
   #:use-module (web uri)
   #:use-module (web response)
@@ -87,6 +88,7 @@
   #:declarative? #t)
 
 (define <jwk:key-pair> jwk:<key-pair>)
+(define <id:id-token> id:<id-token>)
 
 ;; This exception is continuable! Continue with the authorization
 ;; code.
@@ -253,10 +255,11 @@
             (unless key-pair
               (set! key-pair (client:client-key-pair client)))
             (let ((dpop-proof
-                   (dpop:issue-dpop-proof
-                    key-pair
-                    #:htm 'POST
-                    #:htu token-endpoint)))
+                   (issue <dpop-proof>
+                          key-pair
+                          #:jwk (jwk:public-key key-pair)
+                          #:htm 'POST
+                          #:htu token-endpoint)))
               (receive (response response-body)
                   ((anonymous-http-request) token-endpoint
                    #:method 'POST
@@ -368,25 +371,24 @@
                             decoding-error))))
                     (lambda ()
                       (set! id-token
-                            (id:id-token-decode id-token
-                                                #:http-get
-                                                (http-request->http-get (anonymous-http-request))))))
+                            (decode <id:id-token> id-token
+                                    #:http-request (anonymous-http-request)))))
                   ;; We are not interested in the ID token
                   ;; signature anymore, because it won’t be
                   ;; transmitted to other parties and we know that
                   ;; it is valid.
                   (when (and subject
-                             (not (equal? subject (id:id-token-webid id-token))))
+                             (not (equal? subject (id:webid id-token))))
                     (let ((final-message
                            (format #f (G_ "the ID token delivered by the identity provider for ~s has ~s as webid")
                                    (uri->string subject)
-                                   (id:id-token-webid id-token))))
+                                   (id:webid id-token))))
                       (raise-exception
                        (make-exception
                         (make-token-request-failed response response-body)
                         (make-exception-with-message final-message)))))
-                  (set! subject (id:id-token-webid id-token))
-                  (when (not (equal? issuer (id:id-token-iss id-token)))
+                  (set! subject (id:webid id-token))
+                  (when (not (equal? issuer (iss id-token)))
                     (let ((final-message
                            (format #f (G_ "The ID token delivered by the identity provider ~s is for issuer ~s.")
                                    (uri->string issuer)
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))
diff --git a/src/scm/webid-oidc/example-app.scm b/src/scm/webid-oidc/example-app.scm
index c293d69..67d959f 100644
--- a/src/scm/webid-oidc/example-app.scm
+++ b/src/scm/webid-oidc/example-app.scm
@@ -18,7 +18,6 @@
   #:use-module ((webid-oidc client) #:prefix client:)
   #:use-module ((webid-oidc client accounts) #:prefix account:)
   #:use-module ((webid-oidc cache) #:prefix cache:)
-  #:use-module (webid-oidc dpop-proof)
   #:use-module (webid-oidc web-i18n)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module ((webid-oidc refresh-token) #:prefix refresh:)
diff --git a/src/scm/webid-oidc/jws.scm b/src/scm/webid-oidc/jws.scm
index 3e5e50b..af83c90 100644
--- a/src/scm/webid-oidc/jws.scm
+++ b/src/scm/webid-oidc/jws.scm
@@ -18,13 +18,30 @@
   #:use-module (webid-oidc jwk)
   #:use-module (webid-oidc errors)
   #:use-module (webid-oidc web-i18n)
+  #:use-module (webid-oidc jti)
+  #:use-module (webid-oidc oidc-configuration)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
+  #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-19)
   #:use-module (ice-9 receive)
   #:use-module (ice-9 exceptions)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 optargs)
+  #:use-module (web uri)
   #:use-module (oop goops)
   #:declarative? #t
+  #:re-export
+  (
+   (&jti-found . &nonce-found)
+   (make-jti-found . make-nonce-found)
+   (jti-found? . nonce-found?)
+   (jti-found-jti . nonce-found-nonce)
+   )
+  #:replace
+  (
+   exp ;; This is a function in guile
+   )
   #:export
   (
 
@@ -32,10 +49,16 @@
    make-invalid-jws
    invalid-jws?
 
-   the-jws
-   jws?
+   <token>
+
+   <time-bound-token> iat default-validity has-explicit-exp?
+   nonce-field-name ;; DPoP proofs use 'jti instead of 'nonce
+
+   <oidc-token> iss
 
-   jws-alg
+   <single-use-token> nonce
+   
+   token->jwt
 
    &cannot-query-identity-provider
    make-cannot-query-identity-provider
@@ -54,8 +77,11 @@
    error-expiration-date
    ;; error-current-date works for that one too
 
-   jws-decode
-   jws-encode
+   lookup-keys
+   verify
+   decode
+   encode
+   issue
 
    ))
 
@@ -65,70 +91,259 @@
   make-invalid-jws
   invalid-jws?)
 
-(define (the-jws x)
-  (with-exception-handler
-      (lambda (error)
-        (let ((final-message
-               (if (exception-with-message? error)
-                   (format #f (G_ "the JWS is invalid: ~a")
-                           (exception-message error))
-                   (format #f (G_ "the JWS is invalid")))))
+(define-class <token> ()
+  (alg #:init-keyword #:alg #:accessor alg))
+
+(define (key-alg key)
+  (alg key))
+
+(define-method (initialize (token <token>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((alg #f)
+    (signing-key #f)
+    (jwt-header #f)
+    (jwt-payload #f))
+   (let do-initialize ((alg alg)
+                       (signing-key signing-key)
+                       (jwt-header jwt-header)
+                       (jwt-payload jwt-payload))
+     (cond
+      ((string? alg)
+       (do-initialize (string->symbol alg) signing-key jwt-header jwt-payload))
+      (alg
+       (case alg
+         ((HS256 HS384 HS512
+                 RS256 RS384 RS512
+                 ES256 ES384 ES512
+                 PS256 PS384 PS512)
+          (slot-set! token 'alg alg))
+         (else
           (raise-exception
            (make-exception
             (make-invalid-jws)
-            (make-exception-with-message final-message)
-            error))))
-    (lambda ()
-      (match x
-        ((header . payload)
-         (let examine-header ((header header)
-                              (alg #f)
-                              (other-header-fields '()))
-           (match header
-             (()
-              (let examine-payload ((payload payload)
-                                    (other-payload-fields '()))
-                (match payload
-                  (()
-                   (unless alg
-                     (fail (format #f (G_ "the JWS header does not have an \"alg\" field"))))
-                   `(((alg . ,(symbol->string alg))
-                      ,@(reverse other-header-fields))
-                     . ,(reverse other-payload-fields)))
-                  ((((? symbol? key) . value) payload ...)
-                   (examine-payload payload
-                                    `((,key . ,value) ,@other-payload-fields)))
-                  (else
-                   (fail (format #f (G_ "invalid JSON object as payload")))))))
-             ((('alg . (? string? given-alg)) header ...)
-              (case (string->symbol given-alg)
-                ((HS256 HS384 HS512
-                        RS256 RS384 RS512
-                        ES256 ES384 ES512
-                        PS256 PS384 PS512)
-                 #t)
-                (else
-                 (fail (format #f (G_ "invalid signature algorithm: ~s") given-alg))))
-              (examine-header header (or alg (string->symbol given-alg))
-                              other-header-fields))
-             ((('alg . invalid) header ...)
-              (fail (format #f (G_ "invalid \"alg\" value: ~s") invalid)))
-             ((((? symbol? key) . value) header ...)
-              (examine-header header alg
-                              `((,key . ,value) ,@other-header-fields)))
-             (else
-              (fail (format #f (G_ "invalid JSON object as header")))))))
-        (else
-         (fail (format #f (G_ "this is not a pair"))))))))
-
-(define (jws? x)
-  (false-if-exception
-   (the-jws x)))
-
-(define (jws-alg jws)
-  (match (the-jws jws)
-    ((header . _)
-     (string->symbol (assq-ref header 'alg)))))
+            (make-exception-with-message
+             (format #f (G_ "unsupported JWS algorithm: ~s") alg)))))))
+      (signing-key
+       (do-initialize (key-alg signing-key) #f jwt-payload jwt-header))
+      ((and jwt-header jwt-payload)
+       (do-initialize (assq-ref jwt-header 'alg) #f #f #f))
+      (else
+       (raise-exception
+        (make-exception
+         (make-invalid-jws)
+         (make-exception-with-message
+          (G_ "when making a token either #:alg or (#:jwt-header and #:jwt-payload) should be passed")))))))))
+
+(define-class <generic-with-default> (<generic>)
+  ;; neutral is the list of values that are returned when there are no
+  ;; next methods.
+  (neutral #:init-keyword #:neutral))
+
+(define-method (no-next-method (generic <generic-with-default>) args)
+  (apply values (slot-ref generic 'neutral)))
+
+(define-method (no-applicable-method (generic <generic-with-default>) args)
+  (apply values (slot-ref generic 'neutral)))
+
+(define-class <time-bound-token> (<token>)
+  (iat #:init-keyword #:iat #:accessor iat)
+  (exp #:init-keyword #:exp #:accessor exp))
+
+(define default-validity
+  (make <generic-with-default>
+    #:name 'default-validity
+    #:neutral (list #f)))
+
+(define-method (has-explicit-exp? (token <time-bound-token>))
+  ;; Change it to #f when the token should not have an explicit
+  ;; expiration date, such as DPoP proofs
+  #t)
+
+(define-method (initialize (token <time-bound-token>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((iat ((p:current-date)))
+    (exp #f)
+    (validity (default-validity token))
+    (jwt-header #f)
+    (jwt-payload #f))
+   (let do-initialize ((iat iat)
+                       (exp exp)
+                       (validity validity)
+                       (jwt-header jwt-header)
+                       (jwt-payload jwt-payload))
+     (cond
+      ((integer? iat)
+       (do-initialize (make-time time-utc 0 iat) exp validity jwt-header jwt-payload))
+      ((time? iat)
+       (do-initialize (time-utc->date iat) exp validity jwt-header jwt-payload))
+      ((and (not exp) (date? iat) (integer? validity))
+       (do-initialize iat
+                      (+ (time-second (date->time-utc iat))
+                         validity)
+                      validity
+                      jwt-header
+                      jwt-payload))
+      ((integer? exp)
+       (do-initialize iat (make-time time-utc 0 exp) validity jwt-header jwt-payload))
+      ((time? exp)
+       (do-initialize iat (time-utc->date exp) validity jwt-header jwt-payload))
+      ((and jwt-header jwt-payload)
+       (do-initialize (assq-ref jwt-payload 'iat)
+                      (and (has-explicit-exp? token)
+                           (assq-ref jwt-payload 'exp))
+                      validity #f #f))
+      ((and iat exp)
+       (unless (date? iat)
+         (scm-error 'wrong-type-arg "make"
+                    (G_ "#:iat should be a date")
+                    '()
+                    (list iat)))
+       (unless (date? exp)
+         (scm-error 'wrong-type-arg "make"
+                    (G_ "#:exp should be a date")
+                    '()
+                    (list exp)))
+       (slot-set! token 'iat iat)
+       (slot-set! token 'exp exp))
+      (else
+       (raise-exception
+        (make-exception
+         (make-invalid-jws)
+         (make-exception-with-message
+          (G_ "when making a time-bound token, either its required fields (#:iat, and either #:exp or #:validity) or (#:jwt-header and #:jwt-payload) should be passed")))))))))
+
+(define-class <oidc-token> (<token>)
+  (iss #:init-keyword #:iss #:accessor iss))
+
+(define-method (default-validity (token <oidc-token>))
+  (let ((next (next-method))
+        (mine 3600))
+    (if (and next (< next mine))
+        next
+        mine)))
+
+(define-method (initialize (token <oidc-token>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((iss #f)
+    (jwt-header #f)
+    (jwt-payload #f))
+   (let do-initialize ((iss iss)
+                       (jwt-header jwt-header)
+                       (jwt-payload jwt-payload))
+     (cond
+      ((string? iss)
+       (do-initialize (string->uri iss) jwt-header jwt-payload))
+      (iss
+       (unless (uri? iss)
+         (scm-error 'wrong-type-arg "make"
+                    (G_ "#:iss should be an URI")
+                    '()
+                    (list iss)))
+       (slot-set! token 'iss iss))
+      ((and jwt-header jwt-payload)
+       (do-initialize (assq-ref jwt-payload 'iss) #f #f))
+      (else
+       (raise-exception
+        (make-exception
+         (make-invalid-jws)
+         (make-exception-with-message
+          (G_ "when making an OIDC token, either its required #:iss field or (#:jwt-header and #:jwt-payload) should be passed")))))))))
+
+(define-class <single-use-token> (<time-bound-token>)
+  (nonce #:init-keyword #:nonce #:accessor nonce))
+
+(define-method (default-validity (token <single-use-token>))
+  (let ((next (next-method))
+        (mine 120))
+    (if (and next (< next mine))
+        next
+        mine)))
+
+(define nonce-field-name
+  (make <generic-with-default>
+    #:name 'nonce-field-name
+    #:neutral (list 'nonce)))
+
+(define-method (nonce-field-name (token <top>))
+  ;; Without this method, this is an infinite loop.
+  (next-method))
+
+(define-method (initialize (token <single-use-token>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((nonce (stubs:random 12))
+    (jwt-header #f)
+    (jwt-payload #f))
+   ;; The maximum validity is 2 minutes
+   (let ((iat (time-second (date->time-utc (iat token))))
+         (exp (time-second (date->time-utc (exp token)))))
+     (let ((validity (- exp iat)))
+       (when (> validity 120)
+         (let ((true-exp (+ iat 120)))
+           (slot-set! token 'exp (time-utc->date (make-time time-utc 0 true-exp)))))))
+   (let do-initialize ((nonce nonce)
+                       (jwt-header jwt-header)
+                       (jwt-payload jwt-payload))
+     (cond
+      ((and jwt-header jwt-payload)
+       (do-initialize (assq-ref jwt-payload (nonce-field-name token)) #f #f))
+      (nonce
+       (unless (string? nonce)
+         (scm-error 'wrong-type-arg "make"
+                    (G_ "#:nonce should be a string")
+                    '()
+                    (list nonce)))
+       (slot-set! token 'nonce nonce))
+      (else
+       (raise-exception
+        (make-exception
+         (make-invalid-jws)
+         (make-exception-with-message
+          (G_ "when making a single-use token, either its required #:nonce field or (#:jwt-header and #:jwt-payload) should be passed")))))))))
+
+(define token->jwt
+  (make <generic-with-default>
+    #:name 'token->jwt
+    #:neutral (list '() '())))
+
+(define-method (token->jwt (token <token>))
+  (receive (base-header base-payload)
+      (next-method)
+    (values
+     `((alg . ,(symbol->string (alg token)))
+       ,@base-header)
+     base-payload)))
+
+(define-method (token->jwt (token <time-bound-token>))
+  (receive (base-header base-payload)
+      (next-method)
+    (values base-header
+            `((iat . ,(time-second (date->time-utc (iat token))))
+              ,@(if (has-explicit-exp? token)
+                    `((exp . ,(time-second (date->time-utc (exp token)))))
+                    '())
+              ,@base-payload))))
+
+(define-method (token->jwt (token <single-use-token>))
+  (receive (base-header base-payload)
+      (next-method)
+    (values base-header
+            `((,(nonce-field-name token) . ,(nonce token))
+              ,@base-payload))))
+
+(define-method (token->jwt (token <oidc-token>))
+  (receive (base-header base-payload)
+      (next-method)
+    (values base-header
+            `((iss . ,(uri->string (iss token)))
+              ,@base-payload))))
 
 (define (split-in-3-parts string separator)
   (match (string-split string separator)
@@ -193,14 +408,14 @@
      (error-current-date (apply make-exception sub-exceptions)))
     (else #f)))
 
-(define (parse str verify)
+(define (parse token-class str verify-signature)
   (receive (header payload signature)
       (split-in-3-parts str #\.)
     (let ((base (string-append header "." payload))
           (header (base64-decode-json header))
           (payload (base64-decode-json payload)))
-      (let ((ret `(,header . ,payload)))
-        (verify ret base signature)
+      (let ((ret (make token-class #:jwt-header header #:jwt-payload payload)))
+        (verify-signature ret base signature)
         ret))))
 
 (define (verify-any alg keys payload signature)
@@ -245,7 +460,102 @@
 (define-method (keys (keys <list>))
   (map public-key keys))
 
-(define (jws-decode str lookup-keys)
+(define lookup-keys
+  (make <generic-with-default>
+    #:name 'lookup-keys
+    #:neutral (list '())))
+
+(define-method (lookup-keys (token <oidc-token>) args)
+  (let-keywords
+   args #f
+   ((http-request http-request))
+   (let ((iss (iss token)))
+     (let ((cfg
+            (with-exception-handler
+                (lambda (error)
+                  (let ((final-message
+                         (if (exception-with-message? error)
+                             (format #f (G_ "I cannot query the identity provider configuration: ~a")
+                                     (exception-message error))
+                             (format #f (G_ "I cannot query the identity provider configuration")))))
+                    (raise-exception
+                     (make-exception
+                      (make-cannot-query-identity-provider iss)
+                      (make-exception-with-message final-message)
+                      error))))
+              (lambda ()
+                (get-oidc-configuration
+                 (uri-host iss)
+                 #:userinfo (uri-userinfo iss)
+                 #:port (uri-port iss)
+                 #:http-get
+                 (lambda* (uri . args)
+                   (apply http-request uri #:method 'GET args)))))))
+       (with-exception-handler
+           (lambda (error)
+             (raise-exception
+              (make-exception
+               (make-cannot-query-identity-provider iss)
+               (make-exception-with-message
+                (if (exception-with-message? error)
+                    (format #f (G_ "I cannot query the JWKS URI of the identity provider: ~a")
+                            (exception-message error))
+                    (format #f (G_ "I cannot query the JWKS URI of the identity provider")))))))
+         (lambda ()
+           (append
+               (keys (next-method))
+               (keys
+                (oidc-configuration-jwks
+                 cfg
+                 #:http-get 
+                 (lambda* (uri . args)
+                   (apply http-request uri #:method 'GET args)))))))))))
+
+(define verify
+  (make <generic-with-default>
+    #:name 'verify
+    #:neutral (list #t)))
+
+(define-method (verify (token <time-bound-token>) args)
+  (next-method)
+  (let-keywords
+   args #t
+   ((current-date ((p:current-date))))
+   (let ((iat (iat token))
+         (exp (exp token)))
+     (let ((iat-s (time-second (date->time-utc iat)))
+           (exp-s (time-second (date->time-utc exp)))
+           (current-s (time-second (date->time-utc current-date))))
+       (when (>= iat-s (+ current-s 5))
+         (let ((final-message
+                (format #f (G_ "the token is signed in the future, ~a, relative to current ~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)))))
+       (when (>= current-s exp-s)
+         (let ((final-message
+                (format #f (G_ "the token expired ~a, which is in the past (from ~a)")
+                        (date->string exp)
+                        (date->string current-date))))
+           (raise-exception
+            (make-exception
+             (make-expired exp current-date)
+             (make-exception-with-message final-message)))))))))
+
+(define-method (verify (token <single-use-token>) args)
+  (next-method)
+  (let-keywords
+   args #t
+   ((current-date ((p:current-date))))
+   (let ((exp (exp token)))
+     (let ((exp-s (time-second (date->time-utc exp)))
+           (current-s (time-second (date->time-utc current-date))))
+       (jti-check (nonce token) (- exp-s current-s))))))
+
+(define* (decode token-class str . args)
   (with-exception-handler
       (lambda (error)
         (let ((final-message
@@ -259,12 +569,13 @@
             (make-exception-with-message final-message)
             error))))
     (lambda ()
-      (parse str
-             (lambda (jws payload signature)
-               (let ((k (keys (lookup-keys jws))))
-                 (verify-any (jws-alg jws) k payload signature)))))))
+      (parse token-class str
+             (lambda (token payload signature)
+               (let ((k (keys (lookup-keys token args))))
+                 (verify-any (alg token) k payload signature))
+               (verify token args))))))
 
-(define (jws-encode jws key)
+(define (encode token key)
   (with-exception-handler
       (lambda (error)
         (let ((final-message
@@ -278,12 +589,14 @@
             (make-exception-with-message final-message)
             error))))
     (lambda ()
-      (match jws
-        ((header . payload)
-         (let ((header (stubs:scm->json-string header))
-               (payload (stubs:scm->json-string payload)))
-           (let ((header (stubs:base64-encode header))
-                 (payload (stubs:base64-encode payload)))
-             (let ((payload (string-append header "." payload)))
-               (let ((signature (stubs:sign (jws-alg jws) (key->jwk key) payload)))
-                 (string-append payload "." signature))))))))))
+      (receive (header payload) (token->jwt token)
+        (let ((header (stubs:scm->json-string header))
+              (payload (stubs:scm->json-string payload)))
+          (let ((header (stubs:base64-encode header))
+                (payload (stubs:base64-encode payload)))
+            (let ((payload (string-append header "." payload)))
+              (let ((signature (stubs:sign (alg token) (key->jwk key) payload)))
+                (string-append payload "." signature)))))))))
+
+(define* (issue token-class issuer-key . args)
+  (encode (apply make token-class #:signing-key issuer-key args) issuer-key))
diff --git a/src/scm/webid-oidc/oidc-id-token.scm b/src/scm/webid-oidc/oidc-id-token.scm
index abef88d..1d96a47 100644
--- a/src/scm/webid-oidc/oidc-id-token.scm
+++ b/src/scm/webid-oidc/oidc-id-token.scm
@@ -28,28 +28,26 @@
   #: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 (oop goops)
+  #:duplicates (merge-generics)
   #:declarative? #t
+  #:re-export
+  (
+   alg iat iss nonce
+   token->jwt
+   decode
+   encode
+   issue
+   )
   #:export
   (
    &invalid-id-token
    make-invalid-id-token
    invalid-id-token?
 
-   the-id-token
-   id-token?
-
-   id-token-alg
-   id-token-webid
-   id-token-iss
-   id-token-sub
-   id-token-aud
-   id-token-nonce
-   id-token-iat
-   id-token-exp
-
-   id-token-decode
-   issue-id-token
+   <id-token> webid sub aud
    ))
 
 (define-exception-type
@@ -58,268 +56,81 @@
   make-invalid-id-token
   invalid-id-token?)
 
-(define (the-id-token x)
-  (with-exception-handler
-      (lambda (error)
-        (let ((final-message
-               (cond
-                ((and (invalid-jws? error)
-                      (exception-with-message? error))
-                 (format #f (G_ "this is not an ID token, because it is not even a JWS: ~a")
-                         (exception-message error)))
-                ((invalid-jws? error)
-                 (format #f (G_ "this is not an ID token, because it is not even a JWS")))
-                ((exception-with-message? error)
-                 (format #f (G_ "this is not an ID token: ~a")
-                         (exception-message error)))
-                (else
-                 (format #f (G_ "this is not an ID token"))))))
-          (raise-exception
-           (make-exception
-            (make-invalid-id-token)
-            (make-exception-with-message final-message)
-            error))))
-    (lambda ()
-      (match (the-jws x)
-        ((header . payload)
-         (let examine-payload ((payload payload)
-                               (webid #f)
-                               (iss #f)
-                               (sub #f)
-                               (aud #f)
-                               (nonce #f)
-                               (iat #f)
-                               (exp #f)
-                               (other-fields '()))
-           (match payload
-             (()
-              (unless (and webid iss sub aud nonce iat exp)
-                (fail (format #f (G_ "the payload is missing ~s")
-                              `(,@(if webid '() '("webid"))
-                                ,@(if iss '() '("iss"))
-                                ,@(if sub '() '("sub"))
-                                ,@(if aud '() '("aud"))
-                                ,@(if nonce '() '("nonce"))
-                                ,@(if iat '() '("iat"))
-                                ,@(if exp '() '("exp"))))))
-              `(,header
-                . ((webid . ,(uri->string webid))
-                   (iss . ,(uri->string iss))
-                   (sub . ,sub)
-                   (aud . ,(uri->string aud))
-                   (nonce . ,nonce)
-                   (iat . ,(time-second (date->time-utc iat)))
-                   (exp . ,(time-second (date->time-utc exp))))))
-             ((('webid . (? string? (= string->uri (? uri? webid-given)))) payload ...)
-              (examine-payload payload
-                               (or webid webid-given)
-                               iss sub aud nonce iat exp other-fields))
-             ((('webid . invalid) payload ...)
-              (fail (format #f (G_ "the \"webid\" field should be an URI, ~s is given")
-                            invalid)))
-             ((('iss . (? string? (= string->uri (? uri? iss-given)))) payload ...)
-              (examine-payload payload webid
-                               (or iss iss-given)
-                               sub aud nonce iat exp other-fields))
-             ((('iss . invalid) payload ...)
-              (fail (format #f (G_ "the \"iss\" field should be an URI, ~s is given")
-                            invalid)))
-             ((('sub . (? string? sub-given)) payload ...)
-              (examine-payload payload webid iss
-                               (or sub sub-given)
-                               aud nonce iat exp other-fields))
-             ((('sub . invalid) payload ...)
-              (fail (format #f (G_ "the \"sub\" field should be a string, ~s is given")
-                            invalid)))
-             ((('aud . (? string? (= string->uri (? uri? aud-given)))) payload ...)
-              (examine-payload payload webid iss sub
-                               (or aud aud-given)
-                               nonce iat exp other-fields))
-             ((('aud . invalid) payload ...)
-              (fail (format #f (G_ "the \"aud\" field should be an URI, ~s is given")
-                            invalid)))
-             ((('nonce . (? string? nonce-given)) payload ...)
-              (examine-payload payload webid iss sub aud
-                               (or nonce nonce-given)
-                               iat exp other-fields))
-             ((('nonce . invalid) payload ...)
-              (fail (format #f (G_ "the \"nonce\" field should be a string, ~s is given")
-                            invalid)))
-             ((('iat . (? (lambda (x) (>= x 0)) (? integer? iat-given))) payload ...)
-              (examine-payload payload webid iss sub aud nonce
-                               (or iat (time-utc->date (make-time time-utc 0 iat-given)))
-                               exp other-fields))
-             ((('iat . invalid) payload ...)
-              (fail (format #f (G_ "the \"iat\" field should be a timestamp, ~s is given")
-                            invalid)))
-             ((('exp . (? (lambda (x) (>= x 0)) (? integer? exp-given))) payload ...)
-              (examine-payload payload webid iss sub aud nonce iat
-                               (or exp (time-utc->date (make-time time-utc 0 exp-given)))
-                               other-fields))
-             ((('exp . invalid) payload ...)
-              (fail (format #f (G_ "the \"exp\" field should be a timestamp, ~s is given")
-                            invalid)))
-             ((field payload ...)
-              (examine-payload payload webid iss sub aud nonce iat exp
-                               `(,field ,@other-fields)))
-             (else
-              (fail (format #f (G_ "the payload should be a JSON object")))))))))))
-
-(define (id-token? x)
-  (false-if-exception
-   (the-id-token x)))
-
-(define (id-token-alg code)
-  (match (the-id-token code)
-    ((header . _)
-     (string->symbol (assq-ref header 'alg)))))
-
-(define (id-token-webid code)
-  (match (the-id-token code)
-    ((_ . payload)
-     (string->uri (assq-ref payload 'webid)))))
-
-(define (id-token-iss code)
-  (match (the-id-token code)
-    ((_ . payload)
-     (string->uri (assq-ref payload 'iss)))))
+(define-class <id-token> (<single-use-token> <oidc-token>)
+  (webid #:init-keyword #:webid #:accessor webid)
+  (sub #:init-keyword #:sub #:accessor sub)
+  (aud #:init-keyword #:aud #:accessor aud))
 
-(define (id-token-sub code)
-  (match (the-id-token code)
-    ((_ . payload)
-     (assq-ref payload 'sub))))
-
-(define (id-token-aud code)
-  (match (the-id-token code)
-    ((_ . payload)
-     (string->uri (assq-ref payload 'aud)))))
-
-(define (id-token-nonce code)
-  (match (the-id-token code)
-    ((_ . payload)
-     (assq-ref payload 'nonce))))
-
-(define (id-token-iat code)
-  (match (the-id-token code)
-    ((_ . payload)
-     (time-utc->date
-      (make-time time-utc 0 (assq-ref payload 'iat))))))
-
-(define (id-token-exp code)
-  (match (the-id-token code)
-    ((_ . payload)
-     (time-utc->date
-      (make-time time-utc 0 (assq-ref payload 'exp))))))
-
-(define* (id-token-decode str #:key (http-get http-get))
+(define-method (initialize (token <id-token>) initargs)
   (with-exception-handler
       (lambda (error)
-        (let ((final-message
-               (if (exception-with-message? error)
-                   (format #f (G_ "the ID token is invalid: ~a")
-                           (exception-message error))
-                   (format #f (G_ "the ID token is invalid")))))
-          (raise-exception
-           (make-exception
-            (make-invalid-id-token)
-            (make-exception-with-message final-message)
-            error))))
+        (raise-exception
+         (make-exception
+          (make-invalid-id-token)
+          (make-exception-with-message
+           (if (exception-with-message? error)
+               (format #f (G_ "invalid OIDC ID token: ~a")
+                       (exception-message error))
+               (G_ "invalid OIDC id token")))
+          error)))
     (lambda ()
-      (jws-decode
-       str
-       (lambda (token)
-         (let ((iss (id-token-iss token)))
-           (let* ((cfg
-                   (with-exception-handler
-                       (lambda (error)
-                         (let ((final-message
-                                (if (exception-with-message? error)
-                                    (format #f (G_ "I cannot query the identity provider configuration: ~a")
-                                            (exception-message error))
-                                    (format #f (G_ "I cannot query the identity provider configuratioon")))))
-                           (raise-exception
-                            (make-exception
-                             (make-cannot-query-identity-provider iss)
-                             (make-exception-with-message final-message)
-                             error))))
-                     (lambda ()
-                       (get-oidc-configuration
-                        (uri-host iss)
-                        #:userinfo (uri-userinfo iss)
-                        #:port (uri-port iss)
-                        #:http-get http-get))))
-                  (jwks
-                   (with-exception-handler
-                       (lambda (error)
-                         (raise-exception
-                          (make-exception
-                           (make-cannot-query-identity-provider iss)
-                           (make-exception-with-message
-                            (if (exception-with-message? error)
-                                (format #f (G_ "I cannot query the JWKS URI of the identity provider: ~a")
-                                        (exception-message error))
-                                (format #f (G_ "I cannot query the JWKS URI of the identity provider")))))))
-                     (lambda ()
-                       (oidc-configuration-jwks cfg #:http-get http-get)))))
-             (let ((iat (id-token-iat token))
-                   (exp (id-token-exp token))
-                   (current-date ((p:current-date))))
-               (let ((iat-s (time-second (date->time-utc iat)))
-                     (exp-s (time-second (date->time-utc exp)))
-                     (current-s (time-second (date->time-utc current-date))))
-                 (when (>= iat-s (+ current-s 5))
-                   (let ((final-message
-                          (format #f (G_ "the ID token is signed in the future, ~a, relative to current ~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)))))
-                 (when (>= current-s exp-s)
-                   (let ((final-message
-                          (format #f (G_ "the ID token expired ~a, which is in the past (from ~a)")
-                                  (date->string exp)
-                                  (date->string current-date))))
-                     (raise-exception
-                      (make-exception
-                       (make-expired exp current-date)
-                       (make-exception-with-message final-message)))))))
-             jwks)))))))
-
-(define (id-token-encode id-token key)
-  (with-exception-handler
-      (lambda (error)
-        (let ((final-message
-               (if (exception-with-message? error)
-                   (format #f (G_ "cannot encode the ID token: ~a")
-                           (exception-message error))
-                   (format #f (G_ "cannot encode the ID token")))))
-          (raise-exception
-           (make-exception-with-message final-message))))
-    (lambda ()
-      (jws-encode id-token key))))
-
-(define* (issue-id-token
-          issuer-key
-          #:key
-          (webid #f)
-          (iss #f)
-          (sub #f)
-          (aud #f)
-          (validity 3600))
-  (unless sub
-    (set! sub (uri->string webid)))
-  (let* ((iat (time-second (date->time-utc ((p:current-date)))))
-         (exp (+ iat validity)))
-    (jws-encode
-     (the-id-token
-      `(((alg . ,(symbol->string (alg issuer-key))))
-        . ((webid . ,(uri->string webid))
-           (iss . ,(uri->string iss))
-           (sub . ,sub)
-           (aud . ,(uri->string aud))
-           (nonce . ,(stubs:random 12))
-           (iat . ,iat)
-           (exp . ,exp))))
-     issuer-key)))
+      (next-method)
+      (let-keywords
+       initargs #t
+       ((webid #f)
+        (sub #f)
+        (aud #f)
+        (jwt-header #f)
+        (jwt-payload #f))
+       (let do-initialize ((webid webid)
+                           (sub sub)
+                           (aud aud)
+                           (jwt-header jwt-header)
+                           (jwt-payload jwt-payload))
+         (cond
+          ((string? webid)
+           (do-initialize (string->uri webid) sub aud jwt-header jwt-payload))
+          ((and (not sub) (uri? webid))
+           (do-initialize webid (uri->string webid) aud jwt-header jwt-payload))
+          ((string? aud)
+           (do-initialize webid sub (string->uri aud) jwt-header jwt-payload))
+          ((and webid sub)
+           (unless (uri? webid)
+             (scm-error 'wrong-type-arg "make"
+                        (G_ "#:webid should be an URI")
+                        '()
+                        (list webid)))
+           (unless (string? sub)
+             (scm-error 'wrong-type-arg "make"
+                        (G_ "#:sub should be a string")
+                        '()
+                        (list sub)))
+           (unless (uri? aud)
+             (scm-error 'wrong-type-arg "make"
+                        (G_ "#:aud should be a string")
+                        '()
+                        (list aud)))
+           (slot-set! token 'webid webid)
+           (slot-set! token 'sub sub)
+           (slot-set! token 'aud aud))
+          ((and jwt-header jwt-payload)
+           (do-initialize (assq-ref jwt-payload 'webid)
+                          (assq-ref jwt-payload 'sub)
+                          (assq-ref jwt-payload 'aud)
+                          #f #f))
+          (else
+           (raise-exception
+            (make-exception
+             (make-invalid-jws)
+             (make-exception-with-message
+              (G_ "when making an ID token either its required fields (#:alg, #:webid, #:iss, #:sub, #:aud, #:iat and #:exp) or (#:jwt-header and #:jwt-payload) should be passed")))))))))))
+
+(define-method (token->jwt (token <id-token>))
+  (receive (base-header base-payload)
+      (next-method)
+    (values
+     base-header
+     `((webid . ,(uri->string (webid token)))
+       (sub . ,(sub token))
+       (aud . ,(uri->string (aud token)))
+       ,@base-payload))))
diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm
index 551b72d..99291b0 100644
--- a/src/scm/webid-oidc/resource-server.scm
+++ b/src/scm/webid-oidc/resource-server.scm
@@ -107,15 +107,27 @@
                              (('dpop . (? string? string-value))
                               string-value)))
                           (access-token
-                           (access-token-decode lit-access-token
-                                                #:http-get http-get))
-                          (cnf/jkt (access-token-cnf/jkt access-token))
+                           (decode <access-token> lit-access-token
+                                   #:http-request
+                                   (lambda* (uri . args)
+                                     (let without-method ((remaining-args args)
+                                                          (kept-args '()))
+                                       (match remaining-args
+                                         (() (apply http-get uri (reverse kept-args)))
+                                         ((#:method 'GET remaining-args ...)
+                                          (without-method remaining-args kept-args))
+                                         (((? keyword? key) value remaining-args ...)
+                                          (without-method remaining-args
+                                                          `(,value ,key ,@kept-args))))))))
+                          (cnf/jkt (cnf/jkt access-token))
                           (dpop-proof
-                           (dpop-proof-decode
-                            method full-uri
-                            dpop cnf/jkt #:access-token lit-access-token)))
-                     (let ((subject (access-token-webid access-token))
-                           (issuer (access-token-iss access-token)))
+                           (decode <dpop-proof> dpop
+                                   #:method method
+                                   #:uri full-uri
+                                   #:cnf/check cnf/jkt
+                                   #:access-token lit-access-token)))
+                     (let ((subject (webid access-token))
+                           (issuer (iss access-token)))
                        (confirm-provider subject issuer #:http-get http-get)
                        subject)))
                  #:unwind? #t)))))))
diff --git a/src/scm/webid-oidc/token-endpoint.scm b/src/scm/webid-oidc/token-endpoint.scm
index 81f8e48..292df4d 100644
--- a/src/scm/webid-oidc/token-endpoint.scm
+++ b/src/scm/webid-oidc/token-endpoint.scm
@@ -38,6 +38,8 @@
   #:use-module (rnrs bytevectors)
   #:use-module (sxml simple)
   #:use-module (sxml match)
+  #:use-module (oop goops)
+  #:duplicates (merge-generics)
   #:declarative? #t
   #:export
   (
@@ -177,7 +179,7 @@
                    port)))))))
        thunk))))
 
-(define (make-token-endpoint token-endpoint-uri iss jwk validity)
+(define (make-token-endpoint token-endpoint-uri iss issuer-key validity)
   (lambda (request request-body)
     (when (bytevector? request-body)
       (set! request-body (utf8->string request-body)))
@@ -213,10 +215,11 @@
                                #:path (uri-path (request-uri request))
                                #:query (uri-query (request-uri request)))))
            (let ((grant-type (assoc-ref form-args "grant_type"))
-                 (dpop (dpop-proof-decode
-                        method uri
-                        (assq-ref (request-headers request) 'dpop)
-                        (lambda (jkt) #t))))
+                 (dpop (decode <dpop-proof> (assq-ref (request-headers request) 'dpop)
+                               #:method method
+                               #:uri uri
+                               #:cnf/check
+                               (lambda (jkt) #t))))
              (unless (and grant-type (string? grant-type))
                (let ((final-message 
                       (format #f (G_ "missing grant type")))
@@ -248,9 +251,16 @@
                                    (make-no-authorization-code)
                                    (make-exception-with-message final-message)
                                    (make-message-for-the-user final-user-message)))))
-                             (authorization-code-decode str jwk))))
-                      (values (authorization-code-webid code)
-                              (authorization-code-client-id code))))
+                             (with-exception-handler
+                                 (lambda (error)
+                                   (raise-exception
+                                    (make-exception
+                                     (make-invalid-authorization-code)
+                                     error)))
+                               (lambda ()
+                                 (decode <authorization-code> str
+                                         #:issuer-key issuer-key))))))
+                      (values (webid code) (client-id code))))
                    ((refresh_token)
                     (let ((refresh-token (assoc-ref form-args "refresh_token")))
                       (unless refresh-token
@@ -268,7 +278,7 @@
                             (make-message-for-the-user final-user-message)))))
                       (refresh:with-refresh-token
                        refresh-token
-                       (dpop-proof-jwk dpop)
+                       (jwk dpop)
                        values)))
                    (else
                     (let ((final-message
@@ -288,26 +298,23 @@
                (let* ((iat (time-second (date->time-utc current-time)))
                       (exp (+ iat validity)))
                  (let ((id-token
-                        (issue-id-token
-                         jwk
+                        (issue <id-token>
+                         issuer-key
                          #:webid webid
-                         #:sub (uri->string webid)
                          #:iss iss
-                         #:aud client-id
-                         #:validity 3600))
+                         #:aud client-id))
                        (access-token
-                        (issue-access-token
-                         jwk
+                        (issue <access-token>
+                         issuer-key
                          #:webid webid
                          #:iss iss
-                         #:validity 3600
-                         #:client-key (dpop-proof-jwk dpop)
+                         #:client-key (jwk dpop)
                          #:client-id client-id))
                        (refresh-token
                         (if (equal? grant-type "refresh_token")
                             (assoc-ref form-args "refresh_token")
                             (refresh:issue-refresh-token webid client-id
-                                                         (jkt (dpop-proof-jwk dpop))))))
+                                                         (jkt (jwk dpop))))))
                    (values
                     (build-response #:headers '((content-type application/json)
                                                 (cache-control (no-cache no-store)))