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, 100 insertions, 102 deletions

diff --git a/tests/client-token.scm b/tests/client-token.scm
index 9c55582..576019a 100644
--- a/tests/client-token.scm
+++ b/tests/client-token.scm
@@ -18,11 +18,11 @@
              (webid-oidc testing)
              (webid-oidc token-endpoint)
              (webid-oidc jwk)
-             (webid-oidc jti)
              (webid-oidc authorization-code)
              (webid-oidc oidc-configuration)
              (webid-oidc jws)
              (webid-oidc oidc-id-token)
+             ((webid-oidc parameters) #:prefix p:)
              (web uri)
              (web request)
              (web response)
@@ -35,105 +35,103 @@
  "client-token"
  (lambda ()
    (define the-current-time 0)
-   (define issuer-key (generate-key #:n-size 2048))
-   (define issuer-configuration
-     (make-oidc-configuration
-      "https://issuer.client-token.scm/keys"
-      "https://issuer.client-token.scm/authorize"
-      "https://issuer.client-token.scm/token"))
-   (define token-endpoint (make-token-endpoint
-                           (string->uri "https://issuer.client-token.scm/token")
-                           (string->uri "https://issuer.client-token.scm")
-                           'RS256
-                           issuer-key
-                           3600 ;; 1 hour
-                           (make-jti-list)
-                           #:current-time (lambda () the-current-time)))
-   (define client-key (generate-key #:n-size 2048))
-   (define authorization-code
-     (issue-authorization-code 'RS256  issuer-key 120
-                               (string->uri "https://client-token.scm/profile/card#me")
-                               (string->uri "https://app.client-token.scm/app#id")))
-   (define* (http-get uri #:key (headers '()))
-     (cond
-      ((equal? uri (string->uri "https://issuer.client-token.scm/.well-known/openid-configuration"))
-       (serve-oidc-configuration
-        (time-utc->date (make-time time-utc 0 (+ the-current-time 3600)))
-        issuer-configuration))
-      ((equal? uri (string->uri "https://issuer.client-token.scm/keys"))
-       (serve-jwks
-        (time-utc->date (make-time time-utc 0 (+ the-current-time 3600)))
-        (make-jwks (list issuer-key))))
-      (else
-       (format (current-error-port) "GET request to ~a: error.\n" (uri->string uri))
-       (exit 1))))
-   (define* (http-post uri #:key (body #f) (headers '()))
-     (unless (equal? uri (oidc-configuration-token-endpoint issuer-configuration))
-       (format (current-error-port)
-               "Wrong URI for token negociation: ~a (expected ~a).\n"
-               (uri->string uri)
-               (uri->string
-                (oidc-configuration-token-endpoint
-                 issuer-configuration)))
-       (exit 2))
-     (unless (equal? body (format #f "grant_type=authorization_code&code=~a"
-                                  authorization-code))
-       (format (current-error-port)
-               "Wrong body: ~s\n" body)
-       (exit 3))
-     (unless (equal?
-              (assoc-ref headers 'content-type)
-              '(application/x-www-form-urlencoded))
-       (format (current-error-port)
-               "Wrong content type: ~s\n" (assoc-ref headers 'content-type))
-       (exit 4))
-     (let ((request
-            (build-request uri
-                           #:method 'POST
-                           #:headers headers
-                           #:port (open-input-string body)))
-           (request-body body))
-       (receive (response response-body user error)
-           (token-endpoint request request-body)
-         (values response response-body))))
-   (let ((response
-          (token "https://issuer.client-token.scm"
-                 client-key
-                 #:authorization-code authorization-code
-                 #:http-get http-get
-                 #:http-post http-post
-                 #:current-time (lambda () the-current-time))))
-     (let ((id-token (assq-ref response 'id_token))
-           (access-token (assq-ref response 'access_token))
-           (token-type (assq-ref response 'token_type))
-           (token-expiration (assq-ref response 'expires_in))
-           (refresh-token (assq-ref response 'refresh_token)))
-       (let ((id-token-dec (id-token-decode id-token #:http-get http-get))
-             (access-token-dec (jws-decode access-token (lambda (jws) issuer-key))))
-         (unless id-token-dec
-           (format (current-error-port) "Could not decode the ID token from ~s (~s)"
-                   id-token response)
-           (exit 5))
-         (unless access-token-dec
-           (format (current-error-port) "Could not decode the access token from ~s (~s)"
-                   access-token response)
-           (exit 6))
-         (unless refresh-token
-           (format (current-error-port) "There does not seem to be a refresh token in ~s"
-                   response)
-           (exit 6))
-         (unless (equal? (id-token-webid id-token-dec)
-                         (string->uri "https://client-token.scm/profile/card#me"))
-           (exit 7))
-         (unless (equal? (id-token-iss id-token-dec)
-                         (string->uri "https://issuer.client-token.scm"))
-           (exit 8))
-         (unless (equal? (id-token-aud id-token-dec)
-                         (string->uri "https://app.client-token.scm/app#id"))
-           (exit 9))
-         ;; It’s not the job of the client to check that the access
-         ;; token is correct; TODO: add a check with a resource
-         ;; server.
+   (parameterize ((p:current-date (lambda () the-current-time)))
+     (define issuer-key (generate-key #:n-size 2048))
+     (define issuer-configuration
+       (make-oidc-configuration
+        "https://issuer.client-token.scm/keys"
+        "https://issuer.client-token.scm/authorize"
+        "https://issuer.client-token.scm/token"))
+     (define token-endpoint (make-token-endpoint
+                             (string->uri "https://issuer.client-token.scm/token")
+                             (string->uri "https://issuer.client-token.scm")
+                             'RS256
+                             issuer-key
+                             3600))
+     (define client-key (generate-key #:n-size 2048))
+     (define authorization-code
+       (issue-authorization-code 'RS256  issuer-key 120
+                                 (string->uri "https://client-token.scm/profile/card#me")
+                                 (string->uri "https://app.client-token.scm/app#id")))
+     (define* (http-get uri #:key (headers '()))
+       (cond
+        ((equal? uri (string->uri "https://issuer.client-token.scm/.well-known/openid-configuration"))
+         (serve-oidc-configuration
+          (time-utc->date (make-time time-utc 0 (+ the-current-time 3600)))
+          issuer-configuration))
+        ((equal? uri (string->uri "https://issuer.client-token.scm/keys"))
+         (serve-jwks
+          (time-utc->date (make-time time-utc 0 (+ the-current-time 3600)))
+          (make-jwks (list issuer-key))))
+        (else
+         (format (current-error-port) "GET request to ~a: error.\n" (uri->string uri))
+         (exit 1))))
+     (define* (http-post uri #:key (body #f) (headers '()))
+       (unless (equal? uri (oidc-configuration-token-endpoint issuer-configuration))
+         (format (current-error-port)
+                 "Wrong URI for token negociation: ~a (expected ~a).\n"
+                 (uri->string uri)
+                 (uri->string
+                  (oidc-configuration-token-endpoint
+                   issuer-configuration)))
+         (exit 2))
+       (unless (equal? body (format #f "grant_type=authorization_code&code=~a"
+                                    authorization-code))
+         (format (current-error-port)
+                 "Wrong body: ~s\n" body)
+         (exit 3))
+       (unless (equal?
+                (assoc-ref headers 'content-type)
+                '(application/x-www-form-urlencoded))
+         (format (current-error-port)
+                 "Wrong content type: ~s\n" (assoc-ref headers 'content-type))
+         (exit 4))
+       (let ((request
+              (build-request uri
+                             #:method 'POST
+                             #:headers headers
+                             #:port (open-input-string body)))
+             (request-body body))
+         (receive (response response-body user error)
+             (token-endpoint request request-body)
+           (values response response-body))))
+     (let ((response
+            (token "https://issuer.client-token.scm"
+                   client-key
+                   #:authorization-code authorization-code
+                   #:http-get http-get
+                   #:http-post http-post)))
+       (let ((id-token (assq-ref response 'id_token))
+             (access-token (assq-ref response 'access_token))
+             (token-type (assq-ref response 'token_type))
+             (token-expiration (assq-ref response 'expires_in))
+             (refresh-token (assq-ref response 'refresh_token)))
+         (let ((id-token-dec (id-token-decode id-token #:http-get http-get))
+               (access-token-dec (jws-decode access-token (lambda (jws) issuer-key))))
+           (unless id-token-dec
+             (format (current-error-port) "Could not decode the ID token from ~s (~s)"
+                     id-token response)
+             (exit 5))
+           (unless access-token-dec
+             (format (current-error-port) "Could not decode the access token from ~s (~s)"
+                     access-token response)
+             (exit 6))
+           (unless refresh-token
+             (format (current-error-port) "There does not seem to be a refresh token in ~s"
+                     response)
+             (exit 6))
+           (unless (equal? (id-token-webid id-token-dec)
+                           (string->uri "https://client-token.scm/profile/card#me"))
+             (exit 7))
+           (unless (equal? (id-token-iss id-token-dec)
+                           (string->uri "https://issuer.client-token.scm"))
+             (exit 8))
+           (unless (equal? (id-token-aud id-token-dec)
+                           (string->uri "https://app.client-token.scm/app#id"))
+             (exit 9))
+           ;; It’s not the job of the client to check that the access
+           ;; token is correct; TODO: add a check with a resource
+           ;; server.
 
-         ;; TODO: try to negociate a refresh token.
-         )))))
+           ;; TODO: try to negociate a refresh token.
+           ))))))