Use guile parameters

With parameters, the API does not need to care about the directory
where to load files and how to get the time.

1 files changed, 94 insertions, 108 deletions

diff --git a/src/scm/webid-oidc/token-endpoint.scm b/src/scm/webid-oidc/token-endpoint.scm
index 5a05945..7c4d41c 100644
--- a/src/scm/webid-oidc/token-endpoint.scm
+++ b/src/scm/webid-oidc/token-endpoint.scm
@@ -22,6 +22,7 @@
   #:use-module (webid-oidc jwk)
   #:use-module (webid-oidc oidc-id-token)
   #:use-module (webid-oidc access-token)
+  #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module ((webid-oidc refresh-token) #:prefix refresh:)
   #:use-module (web client)
@@ -76,116 +77,101 @@
        thunk
        #:unwind? #t))))
 
-(define*-public (make-token-endpoint token-endpoint-uri iss alg jwk validity jti-list
-                                     #:key
-                                     (refresh-token-dir refresh:default-dir)
-                                     (current-time current-time))
+(define*-public (make-token-endpoint token-endpoint-uri iss alg jwk validity)
   (lambda* (request request-body)
     (try-handle-web-failure
      (lambda ()
        (when (bytevector? request-body)
          (set! request-body (utf8->string request-body)))
-       (let ((current-time
-              (let ((t current-time))
-                (when (thunk? t)
-                  (set! t (t)))
-                (when (integer? t)
-                  (set! t (make-time time-utc 0 t)))
-                (when (time? t)
-                  (set! t (time-utc->date t)))
-                t))
-             (form-args
-              (if (and (request-content-type request)
-                       (eq? (car (request-content-type request))
-                            'application/x-www-form-urlencoded))
-                  (filter
-                   (lambda (x) x)
-                   (map (lambda (kv)
-                          (let ((parsed
-                                 (list->vector
-                                  (map (lambda (x)
-                                         (uri-decode x #:decode-plus-to-space? #t))
-                                       (string-split kv #\=)))))
-                            (if (eq? (vector-length parsed) 2)
-                                `(,(vector-ref parsed 0) . ,(vector-ref parsed 1))
-                                #f)))
-                        (string-split request-body #\&)))
-                  '()))
-             (method (request-method request))
-             ;; Maybe we’re behind a reverse proxy, so the authority of
-             ;; (request-uri request) is meaningless.
-             (uri (build-uri (uri-scheme token-endpoint-uri)
-                             #:userinfo (uri-userinfo token-endpoint-uri)
-                             #:host (uri-host token-endpoint-uri)
-                             #:port (uri-port token-endpoint-uri)
-                             #: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
-                      current-time jti-list method uri
-                      (assq-ref (request-headers request) 'dpop)
-                      (lambda (jkt) #t))))
-           (unless (and grant-type (string? grant-type))
-             (raise-unsupported-grant-type #f))
-           (receive (webid client-id)
-               (case (string->symbol grant-type)
-                 ((authorization_code)
-                  (let ((code
-                         (let ((str (assoc-ref form-args "code")))
-                           (unless str
-                             (raise-no-authorization-code))
-                           (authorization-code-decode
-                            current-time jti-list str jwk))))
-                    (values (authorization-code-webid code)
-                            (authorization-code-client-id code))))
-                 ((refresh_token)
-                  (let ((refresh-token (assoc-ref form-args "refresh_token")))
-                    (unless refresh-token
-                      (raise-no-refresh-token))
-                    (refresh:with-refresh-token
-                     refresh-token
-                     (dpop-proof-jwk dpop)
-                     values
-                     #:dir refresh-token-dir)))
-                 (else
-                  (raise-unsupported-grant-type grant-type)))
-             (let* ((iat (time-second (date->time-utc current-time)))
-                    (exp (+ iat validity)))
-               (let ((id-token
-                      (issue-id-token
-                       jwk
-                       #:alg alg
-                       #:webid (uri->string webid)
-                       #:sub (uri->string webid)
-                       #:iss (uri->string iss)
-                       #:aud (uri->string client-id)
-                       #:exp exp
-                       #:iat iat))
-                     (access-token
-                      (issue-access-token
-                       jwk
-                       #:alg alg
-                       #:webid (uri->string webid)
-                       #:iss (uri->string iss)
-                       #:exp exp
-                       #:iat iat
-                       #:client-key (dpop-proof-jwk dpop)
-                       #:client-id (uri->string 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))
-                                                       #:dir refresh-token-dir))))
-                 (values
-                  (build-response #:headers '((content-type application/json)
-                                              (cache-control (no-cache no-store)))
-                                  #:port #f)
-                  (stubs:scm->json-string
-                   `((id_token . ,id-token)
-                     (access_token . ,access-token)
-                     (token_type . "DPoP")
-                     (expires_in . ,validity)
-                     (refresh_token . ,refresh-token)))
-                  client-id
-                  #f))))))))))
+       (parameterize ((p:current-date ((p:current-date))))
+         (let ((current-time ((p:current-date))) ;; thunk parameter
+               (form-args
+                (if (and (request-content-type request)
+                         (eq? (car (request-content-type request))
+                              'application/x-www-form-urlencoded))
+                    (filter
+                     (lambda (x) x)
+                     (map (lambda (kv)
+                            (let ((parsed
+                                   (list->vector
+                                    (map (lambda (x)
+                                           (uri-decode x #:decode-plus-to-space? #t))
+                                         (string-split kv #\=)))))
+                              (if (eq? (vector-length parsed) 2)
+                                  `(,(vector-ref parsed 0) . ,(vector-ref parsed 1))
+                                  #f)))
+                          (string-split request-body #\&)))
+                    '()))
+               (method (request-method request))
+               ;; Maybe we’re behind a reverse proxy, so the authority of
+               ;; (request-uri request) is meaningless.
+               (uri (build-uri (uri-scheme token-endpoint-uri)
+                               #:userinfo (uri-userinfo token-endpoint-uri)
+                               #:host (uri-host token-endpoint-uri)
+                               #:port (uri-port token-endpoint-uri)
+                               #: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))))
+             (unless (and grant-type (string? grant-type))
+               (raise-unsupported-grant-type #f))
+             (receive (webid client-id)
+                 (case (string->symbol grant-type)
+                   ((authorization_code)
+                    (let ((code
+                           (let ((str (assoc-ref form-args "code")))
+                             (unless str
+                               (raise-no-authorization-code))
+                             (authorization-code-decode str jwk))))
+                      (values (authorization-code-webid code)
+                              (authorization-code-client-id code))))
+                   ((refresh_token)
+                    (let ((refresh-token (assoc-ref form-args "refresh_token")))
+                      (unless refresh-token
+                        (raise-no-refresh-token))
+                      (refresh:with-refresh-token
+                       refresh-token
+                       (dpop-proof-jwk dpop)
+                       values)))
+                   (else
+                    (raise-unsupported-grant-type grant-type)))
+               (let* ((iat (time-second (date->time-utc current-time)))
+                      (exp (+ iat validity)))
+                 (let ((id-token
+                        (issue-id-token
+                         jwk
+                         #:alg alg
+                         #:webid (uri->string webid)
+                         #:sub (uri->string webid)
+                         #:iss (uri->string iss)
+                         #:aud (uri->string client-id)
+                         #:validity 3600))
+                       (access-token
+                        (issue-access-token
+                         jwk
+                         #:alg alg
+                         #:webid (uri->string webid)
+                         #:iss (uri->string iss)
+                         #:validity 3600
+                         #:client-key (dpop-proof-jwk dpop)
+                         #:client-id (uri->string 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))))))
+                   (values
+                    (build-response #:headers '((content-type application/json)
+                                                (cache-control (no-cache no-store)))
+                                    #:port #f)
+                    (stubs:scm->json-string
+                     `((id_token . ,id-token)
+                       (access_token . ,access-token)
+                       (token_type . "DPoP")
+                       (expires_in . ,validity)
+                       (refresh_token . ,refresh-token)))
+                    client-id
+                    #f)))))))))))