summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
authorVivien Kraus <vivien@planete-kraus.eu>2021-08-01 14:51:28 +0200
committerVivien Kraus <vivien@planete-kraus.eu>2021-08-01 18:08:56 +0200
commitbae1843f1a1d644fb3bd4f8c40b1dbb900aa3325 (patch)
tree00f590033af904a6a493e41bdebe9b3ddd73043b /tests
parentd8c2ca930673da858d63f2dea9526c259a2dd936 (diff)
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.
Diffstat (limited to 'tests')
-rw-r--r--tests/authorization-endpoint-get-form.scm20
-rw-r--r--tests/authorization-endpoint-no-args.scm16
-rw-r--r--tests/authorization-endpoint-submit-form.scm59
-rw-r--r--tests/cache-valid.scm56
-rw-r--r--tests/client-manifest-fraudulent.scm4
-rw-r--r--tests/client-manifest.scm5
-rw-r--r--tests/client-token.scm202
-rw-r--r--tests/dpop-proof-iat-in-future.scm25
-rw-r--r--tests/dpop-proof-iat-too-late.scm25
-rw-r--r--tests/dpop-proof-invalid-ath.scm48
-rw-r--r--tests/dpop-proof-no-ath.scm27
-rw-r--r--tests/dpop-proof-replay.scm25
-rw-r--r--tests/dpop-proof-valid-ath.scm48
-rw-r--r--tests/dpop-proof-valid.scm25
-rw-r--r--tests/dpop-proof-wrong-htm.scm25
-rw-r--r--tests/dpop-proof-wrong-htu.scm25
-rw-r--r--tests/dpop-proof-wrong-key.scm25
-rw-r--r--tests/jwks-get.scm4
-rw-r--r--tests/oidc-configuration.scm4
-rw-r--r--tests/resource-server.scm40
-rw-r--r--tests/token-endpoint-issue.scm72
-rw-r--r--tests/token-endpoint-refresh.scm56
22 files changed, 402 insertions, 434 deletions
diff --git a/tests/authorization-endpoint-get-form.scm b/tests/authorization-endpoint-get-form.scm
index d71d534..7dbf6ba 100644
--- a/tests/authorization-endpoint-get-form.scm
+++ b/tests/authorization-endpoint-get-form.scm
@@ -17,6 +17,7 @@
(use-modules (webid-oidc authorization-endpoint)
(webid-oidc jwk)
(webid-oidc testing)
+ ((webid-oidc parameters) #:prefix p:)
(web uri)
(web request)
(web response)
@@ -33,23 +34,20 @@
(define subject (string->uri "https://authorization-endpoint-get-form.scm/profile/card#me"))
(define password "p4ssw0rd")
(define validity 120)
- (define the-time 0)
- (define (current-time)
- (make-time time-utc 0 the-time))
(define* (http-get uri #:key (headers '()))
(exit 2))
(define endpoint
(make-authorization-endpoint
subject password alg key validity
- #:http-get http-get
- #:current-time current-time))
+ #:http-get http-get))
(receive (response response-body)
- (endpoint
- (build-request (string->uri
- (format #f "https://authorization-endpoint-get-form.scm/authorize?client_id=~a&redirect_uri=~a"
- (uri-encode "https://authorization-endpoint-get-form.scm/client/card#app")
- (uri-encode "https://authorization-endpoint-get-form.scm/client/redirect"))))
- "")
+ (parameterize ((p:current-date 0))
+ (endpoint
+ (build-request (string->uri
+ (format #f "https://authorization-endpoint-get-form.scm/authorize?client_id=~a&redirect_uri=~a"
+ (uri-encode "https://authorization-endpoint-get-form.scm/client/card#app")
+ (uri-encode "https://authorization-endpoint-get-form.scm/client/redirect"))))
+ ""))
(unless (eq? (response-code response) 200)
(exit 3))
(unless (response-content-type response)
diff --git a/tests/authorization-endpoint-no-args.scm b/tests/authorization-endpoint-no-args.scm
index bd24fa2..66579a2 100644
--- a/tests/authorization-endpoint-no-args.scm
+++ b/tests/authorization-endpoint-no-args.scm
@@ -17,6 +17,7 @@
(use-modules (webid-oidc authorization-endpoint)
(webid-oidc jwk)
(webid-oidc testing)
+ ((webid-oidc parameters) #:prefix p:)
(web uri)
(web request)
(web response)
@@ -33,20 +34,17 @@
(define subject (string->uri "https://authorization-endpoint-get-form.scm/profile/card#me"))
(define password "p4ssw0rd")
(define validity 120)
- (define the-time 0)
- (define (current-time)
- (make-time time-utc 0 the-time))
(define* (http-get uri #:key (headers '()))
(exit 2))
(define endpoint
(make-authorization-endpoint
subject password alg key validity
- #:http-get http-get
- #:current-time current-time))
+ #:http-get http-get))
(receive (response response-body)
- (endpoint
- (build-request (string->uri
- "https://authorization-endpoint-get-form.scm/authorize"))
- "")
+ (parameterize ((p:current-date 0))
+ (endpoint
+ (build-request (string->uri
+ "https://authorization-endpoint-get-form.scm/authorize"))
+ ""))
(unless (eq? (response-code response) 400)
(exit 3)))))
diff --git a/tests/authorization-endpoint-submit-form.scm b/tests/authorization-endpoint-submit-form.scm
index f379e38..ef84f40 100644
--- a/tests/authorization-endpoint-submit-form.scm
+++ b/tests/authorization-endpoint-submit-form.scm
@@ -21,6 +21,7 @@
(webid-oidc cache)
(webid-oidc jti)
(webid-oidc testing)
+ ((webid-oidc parameters) #:prefix p:)
(web uri)
(web request)
(web response)
@@ -40,9 +41,6 @@
(define password "p4ssw0rd")
(define encrypted-password (crypt password "$6$this.is.the.salt"))
(define validity 120)
- (define the-time 0)
- (define (current-time)
- (make-time time-utc 0 the-time))
(define what-uri-to-expect client)
(define served
(receive (response response-body)
@@ -57,37 +55,36 @@
(exit 2))
(values the-response the-response-body))
(define cached-http-get
- (with-cache #:http-get http-get
- #:current-time current-time))
- (define jti-list (make-jti-list))
+ (with-cache #:http-get http-get))
(define endpoint
(make-authorization-endpoint
subject encrypted-password alg key validity
- #:http-get cached-http-get
- #:current-time current-time))
+ #:http-get cached-http-get))
(receive (response response-body)
;; The password is fake!
- (endpoint
- (build-request (string->uri
- (format #f "https://authorization-endpoint-submit-form.scm/authorize?client_id=~a&redirect_uri=~a"
- (uri-encode (uri->string client))
- (uri-encode (uri->string redirect))))
- #:headers '((content-type application/x-www-form-urlencoded))
- #:method 'POST
- #:port #t)
- "password=fake")
+ (parameterize ((p:current-date 0))
+ (endpoint
+ (build-request (string->uri
+ (format #f "https://authorization-endpoint-submit-form.scm/authorize?client_id=~a&redirect_uri=~a"
+ (uri-encode (uri->string client))
+ (uri-encode (uri->string redirect))))
+ #:headers '((content-type application/x-www-form-urlencoded))
+ #:method 'POST
+ #:port #t)
+ "password=fake"))
(when (eq? (response-code response) 302)
(exit 3)))
(receive (response response-body)
- (endpoint
- (build-request (string->uri
- (format #f "https://authorization-endpoint-submit-form.scm/authorize?client_id=~a&redirect_uri=~a"
- (uri-encode (uri->string client))
- (uri-encode (uri->string redirect))))
- #:headers '((content-type application/x-www-form-urlencoded))
- #:method 'POST
- #:port #t)
- "password=p4ssw0rd")
+ (parameterize ((p:current-date 0))
+ (endpoint
+ (build-request (string->uri
+ (format #f "https://authorization-endpoint-submit-form.scm/authorize?client_id=~a&redirect_uri=~a"
+ (uri-encode (uri->string client))
+ (uri-encode (uri->string redirect))))
+ #:headers '((content-type application/x-www-form-urlencoded))
+ #:method 'POST
+ #:port #t)
+ "password=p4ssw0rd"))
(unless (eq? (response-code response) 302)
(exit 4))
(let ((loc (response-location response)))
@@ -109,10 +106,10 @@
kv)))
(unless (assoc-ref args "code")
(exit 9))
- (let ((parsed (authorization-code-decode
- 60
- jti-list
- (car (assoc-ref args "code"))
- key)))
+ (let ((parsed
+ (parameterize ((p:current-date 60))
+ (authorization-code-decode
+ (car (assoc-ref args "code"))
+ key))))
(unless parsed
(exit 10)))))))))
diff --git a/tests/cache-valid.scm b/tests/cache-valid.scm
index cf5c0f1..04e7c22 100644
--- a/tests/cache-valid.scm
+++ b/tests/cache-valid.scm
@@ -16,6 +16,7 @@
(use-modules (webid-oidc cache)
(webid-oidc testing)
+ ((webid-oidc parameters) #:prefix p:)
(web uri)
(web request)
(web response)
@@ -44,31 +45,42 @@
(last-modified . ,(time-utc->date (make-time time-utc 0 10)))
(date . ,(time-utc->date (make-time time-utc 0 30))))))
;; response-not-stored: never valid.
- (when (valid? response-not-stored #:current-time 0)
- (exit 1))
- (when (valid? response-not-stored #:current-time 100)
- (exit 2))
+ (parameterize ((p:current-date 0))
+ (when (valid? response-not-stored)
+ (exit 1)))
+ (parameterize ((p:current-date 100))
+ (when (valid? response-not-stored)
+ (exit 2)))
;; response-not-cached: never valid.
- (when (valid? response-not-cached #:current-time 0)
- (exit 3))
- (when (valid? response-not-cached #:current-time 100)
- (exit 4))
+ (parameterize ((p:current-date 0))
+ (when (valid? response-not-cached)
+ (exit 3)))
+ (parameterize ((p:current-date 100))
+ (when (valid? response-not-cached)
+ (exit 4)))
;; response-with-expires: valid at 110, invalid at 130.
- (unless (valid? response-with-expires #:current-time 110)
- (exit 5))
- (when (valid? response-with-expires #:current-time 130)
- (exit 6))
+ (parameterize ((p:current-date 110))
+ (unless (valid? response-with-expires)
+ (exit 5)))
+ (parameterize ((p:current-date 130))
+ (when (valid? response-with-expires)
+ (exit 6)))
;; response-with-overriden-expires: valid at 105, invalid at 115
- (unless (valid? response-with-overriden-expires #:current-time 105)
- (exit 7))
- (when (valid? response-with-overriden-expires #:current-time 115)
- (exit 8))
+ (parameterize ((p:current-date 105))
+ (unless (valid? response-with-overriden-expires)
+ (exit 7)))
+ (parameterize ((p:current-date 115))
+ (when (valid? response-with-overriden-expires)
+ (exit 8)))
;; response-without-max-age: not valid, cannot get a heuristic
- (when (valid? response-without-max-age #:current-time 10)
- (exit 9))
+ (parameterize ((p:current-date 10))
+ (when (valid? response-without-max-age)
+ (exit 9)))
;; response-with-heuristic-max-age: the heuristic max age is 2, so
;; it is valid at 31 but not at 33.
- (unless (valid? response-with-heuristic-max-age #:current-time 31)
- (exit 10))
- (when (valid? response-with-heuristic-max-age #:current-time 33)
- (exit 11))))
+ (parameterize ((p:current-date 31))
+ (unless (valid? response-with-heuristic-max-age)
+ (exit 10)))
+ (parameterize ((p:current-date 33))
+ (when (valid? response-with-heuristic-max-age)
+ (exit 11)))))
diff --git a/tests/client-manifest-fraudulent.scm b/tests/client-manifest-fraudulent.scm
index da77c27..b786140 100644
--- a/tests/client-manifest-fraudulent.scm
+++ b/tests/client-manifest-fraudulent.scm
@@ -30,9 +30,6 @@
(with-test-environment
"client-manifest-fraudulent"
(lambda ()
- (define the-current-time 0)
- (define (current-time)
- (make-time time-utc 0 the-current-time))
(define what-to-respond
(build-response #:headers '((content-type text/turtle))))
(define what-to-respond-body
@@ -63,7 +60,6 @@
(values what-to-respond what-to-respond-body))
(define cache-http-get
(with-cache
- #:current-time current-time
#:http-get respond))
(with-exception-handler
(lambda (error)
diff --git a/tests/client-manifest.scm b/tests/client-manifest.scm
index fb40901..2812ede 100644
--- a/tests/client-manifest.scm
+++ b/tests/client-manifest.scm
@@ -52,12 +52,8 @@
(string->uri "https://app.example.com/id#app"))
(exit 2))
(values what-to-respond what-to-respond-body))
- (define current-time 0)
(define cache-http-get
(with-cache
- #:current-time
- (lambda ()
- (make-time time-utc 0 current-time))
#:http-get respond))
(define mf
(get-client-manifest
@@ -85,7 +81,6 @@
(exit 6))
(set! what-to-respond response)
(set! what-to-respond-body response-body)
- (set! current-time 10)
(let ((re-parsed (get-client-manifest
(string->uri "https://app.example.com/id#app")
#:http-get cache-http-get)))
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.
+ ))))))
diff --git a/tests/dpop-proof-iat-in-future.scm b/tests/dpop-proof-iat-in-future.scm
index 4f167ca..b5dd3f8 100644
--- a/tests/dpop-proof-iat-in-future.scm
+++ b/tests/dpop-proof-iat-in-future.scm
@@ -19,6 +19,7 @@
(webid-oidc jwk)
(webid-oidc testing)
(webid-oidc errors)
+ ((webid-oidc parameters) #:prefix p:)
(web uri)
(srfi srfi-19)
(web response))
@@ -28,26 +29,24 @@
(lambda ()
(define jwk (generate-key #:n-size 2048))
(define cnf (jkt jwk))
- (define blacklist (make-jti-list))
(define proof
- (issue-dpop-proof
- jwk
- #:alg 'RS256
- #:htm 'GET
- #:htu (string->uri "https://example.com/res#frag")
- #:iat (time-utc->date (make-time time-utc 0 10))))
+ (parameterize ((p:current-date 10))
+ (issue-dpop-proof
+ jwk
+ #:alg 'RS256
+ #:htm 'GET
+ #:htu (string->uri "https://example.com/res#frag"))))
(with-exception-handler
(lambda (error)
(unless ((record-predicate &dpop-signed-in-future)
((record-accessor &cannot-decode-dpop-proof 'cause) error))
(raise-exception error)))
(lambda ()
- (dpop-proof-decode (time-utc->date (make-time time-utc 0 0))
- blacklist
- 'GET
- (string->uri "https://example.com/res?query")
- proof
- cnf)
+ (parameterize ((p:current-date 0))
+ (dpop-proof-decode 'GET
+ (string->uri "https://example.com/res?query")
+ proof
+ cnf))
(exit 2))
#:unwind? #t
#:unwind-for-type &cannot-decode-dpop-proof)))
diff --git a/tests/dpop-proof-iat-too-late.scm b/tests/dpop-proof-iat-too-late.scm
index e1b7a47..0e1f4ed 100644
--- a/tests/dpop-proof-iat-too-late.scm
+++ b/tests/dpop-proof-iat-too-late.scm
@@ -18,6 +18,7 @@
(webid-oidc jti)
(webid-oidc jwk)
(webid-oidc testing)
+ ((webid-oidc parameters) #:prefix p:)
(webid-oidc errors)
(web uri)
(srfi srfi-19)
@@ -28,26 +29,24 @@
(lambda ()
(define jwk (generate-key #:n-size 2048))
(define cnf (jkt jwk))
- (define blacklist (make-jti-list))
(define proof
- (issue-dpop-proof
- jwk
- #:alg 'RS256
- #:htm 'GET
- #:htu (string->uri "https://example.com/res#frag")
- #:iat (time-utc->date (make-time time-utc 0 0))))
+ (parameterize ((p:current-date 0))
+ (issue-dpop-proof
+ jwk
+ #:alg 'RS256
+ #:htm 'GET
+ #:htu (string->uri "https://example.com/res#frag"))))
(with-exception-handler
(lambda (error)
(unless ((record-predicate &dpop-too-old)
((record-accessor &cannot-decode-dpop-proof 'cause) error))
(raise-exception error)))
(lambda ()
- (dpop-proof-decode (time-utc->date (make-time time-utc 0 600))
- blacklist
- 'GET
- (string->uri "https://example.com/res?query")
- proof
- cnf)
+ (parameterize ((p:current-date 600))
+ (dpop-proof-decode 'GET
+ (string->uri "https://example.com/res?query")
+ proof
+ cnf))
(exit 2))
#:unwind? #t
#:unwind-for-type &cannot-decode-dpop-proof)))
diff --git a/tests/dpop-proof-invalid-ath.scm b/tests/dpop-proof-invalid-ath.scm
index e802ffe..90cd168 100644
--- a/tests/dpop-proof-invalid-ath.scm
+++ b/tests/dpop-proof-invalid-ath.scm
@@ -16,11 +16,11 @@
(use-modules (webid-oidc dpop-proof)
(webid-oidc access-token)
- (webid-oidc jti)
(webid-oidc jwk)
(webid-oidc testing)
(webid-oidc errors)
((webid-oidc stubs) #:prefix stubs:)
+ ((webid-oidc parameters) #:prefix p:)
(web uri)
(srfi srfi-19)
(web response))
@@ -31,25 +31,24 @@
(define jwk (generate-key #:n-size 2048))
(define idp-key (generate-key #:n-size 2048))
(define cnf (jkt jwk))
- (define blacklist (make-jti-list))
(define access-token
- (issue-access-token
- idp-key
- #:alg 'RS256
- #:webid "https://data.provider/subject"
- #:iss "https://identity.provider"
- #:iat 10
- #:exp 3610
- #:client-key jwk
- #:client-id "https://client"))
+ (parameterize ((p:current-date 10))
+ (issue-access-token
+ idp-key
+ #:alg 'RS256
+ #:webid "https://data.provider/subject"
+ #:iss "https://identity.provider"
+ #:validity 3600
+ #:client-key jwk
+ #:client-id "https://client")))
(define proof
- (issue-dpop-proof
- jwk
- #:alg 'RS256
- #:htm 'GET
- #:htu (string->uri "https://example.com/res?query")
- #:iat (time-utc->date (make-time time-utc 0 0))
- #:access-token "aaaaaaaaaaaaaaa"))
+ (parameterize ((p:current-date 0))
+ (issue-dpop-proof
+ jwk
+ #:alg 'RS256
+ #:htm 'GET
+ #:htu (string->uri "https://example.com/res?query")
+ #:access-token "aaaaaaaaaaaaaaa")))
(with-exception-handler
(lambda (error)
(let ((cause
@@ -61,13 +60,12 @@
(equal? (dpop-invalid-access-token-hash-access-token cause) access-token))
(exit 1))))
(lambda ()
- (dpop-proof-decode (time-utc->date (make-time time-utc 0 10))
- blacklist
- 'GET
- (string->uri "https://example.com/res?query")
- proof
- cnf
- #:access-token access-token)
+ (parameterize ((p:current-date 10))
+ (dpop-proof-decode 'GET
+ (string->uri "https://example.com/res?query")
+ proof
+ cnf
+ #:access-token access-token))
(exit 2))
#:unwind? #t
#:unwind-for-type &cannot-decode-dpop-proof)))
diff --git a/tests/dpop-proof-no-ath.scm b/tests/dpop-proof-no-ath.scm
index 67b8a70..35bff75 100644
--- a/tests/dpop-proof-no-ath.scm
+++ b/tests/dpop-proof-no-ath.scm
@@ -18,6 +18,7 @@
(webid-oidc jti)
(webid-oidc jwk)
(webid-oidc testing)
+ ((webid-oidc parameters) #:prefix p:)
(webid-oidc errors)
(web uri)
(srfi srfi-19)
@@ -28,14 +29,13 @@
(lambda ()
(define jwk (generate-key #:n-size 2048))
(define cnf (jkt jwk))
- (define blacklist (make-jti-list))
(define proof
- (issue-dpop-proof
- jwk
- #:alg 'RS256
- #:htm 'GET
- #:htu (string->uri "https://example.com/res?query")
- #:iat (time-utc->date (make-time time-utc 0 0))))
+ (parameterize ((p:current-date 0))
+ (issue-dpop-proof
+ jwk
+ #:alg 'RS256
+ #:htm 'GET
+ #:htu (string->uri "https://example.com/res?query"))))
(with-exception-handler
(lambda (error)
(let ((cause
@@ -47,13 +47,12 @@
;; claim
(exit 1))))
(lambda ()
- (dpop-proof-decode (time-utc->date (make-time time-utc 0 10))
- blacklist
- 'GET
- (string->uri "https://example.com/res?query")
- proof
- cnf
- #:access-token "aaa")
+ (parameterize ((p:current-date 10))
+ (dpop-proof-decode 'GET
+ (string->uri "https://example.com/res?query")
+ proof
+ cnf
+ #:access-token "aaa"))
(exit 2))
#:unwind? #t
#:unwind-for-type &cannot-decode-dpop-proof)))
diff --git a/tests/dpop-proof-replay.scm b/tests/dpop-proof-replay.scm
index 132a150..b8f4668 100644
--- a/tests/dpop-proof-replay.scm
+++ b/tests/dpop-proof-replay.scm
@@ -19,6 +19,7 @@
(webid-oidc jwk)
(webid-oidc testing)
(webid-oidc errors)
+ ((webid-oidc parameters) #:prefix p:)
(web uri)
(srfi srfi-19)
(web response))
@@ -28,21 +29,19 @@
(lambda ()
(define jwk (generate-key #:n-size 2048))
(define cnf (jkt jwk))
- (define blacklist (make-jti-list))
(define proof
- (issue-dpop-proof
- jwk
- #:alg 'RS256
- #:htm 'GET
- #:htu (string->uri "https://example.com/res#frag")
- #:iat (time-utc->date (make-time time-utc 0 0))))
+ (parameterize ((p:current-date 0))
+ (issue-dpop-proof
+ jwk
+ #:alg 'RS256
+ #:htm 'GET
+ #:htu (string->uri "https://example.com/res#frag"))))
(define (decode)
- (dpop-proof-decode (time-utc->date (make-time time-utc 0 10))
- blacklist
- 'GET
- (string->uri "https://example.com/res?query")
- proof
- cnf))
+ (parameterize ((p:current-date 10))
+ (dpop-proof-decode 'GET
+ (string->uri "https://example.com/res?query")
+ proof
+ cnf)))
(define decoded-once (decode))
(with-exception-handler
(lambda (error)
diff --git a/tests/dpop-proof-valid-ath.scm b/tests/dpop-proof-valid-ath.scm
index 259190f..1e15e17 100644
--- a/tests/dpop-proof-valid-ath.scm
+++ b/tests/dpop-proof-valid-ath.scm
@@ -16,9 +16,9 @@
(use-modules (webid-oidc dpop-proof)
(webid-oidc access-token)
- (webid-oidc jti)
(webid-oidc jwk)
(webid-oidc testing)
+ ((webid-oidc parameters) #:prefix p:)
(web uri)
(srfi srfi-19)
(web response))
@@ -29,32 +29,30 @@
(define jwk (generate-key #:n-size 2048))
(define idp-key (generate-key #:n-size 2048))
(define cnf (jkt jwk))
- (define blacklist (make-jti-list))
(define access-token
- (issue-access-token
- idp-key
- #:alg 'RS256
- #:webid "https://data.provider/subject"
- #:iss "https://identity.provider"
- #:iat 10
- #:exp 3610
- #:client-key jwk
- #:client-id "https://client"))
+ (parameterize ((p:current-date 10))
+ (issue-access-token
+ idp-key
+ #:alg 'RS256
+ #:webid "https://data.provider/subject"
+ #:iss "https://identity.provider"
+ #:validity 3600
+ #:client-key jwk
+ #:client-id "https://client")))
(define proof
- (issue-dpop-proof
- jwk
- #:alg 'RS256
- #:htm 'GET
- #:htu (string->uri "https://example.com/res#frag")
- #:iat (time-utc->date (make-time time-utc 0 0))
- #:access-token access-token))
+ (parameterize ((p:current-date 0))
+ (issue-dpop-proof
+ jwk
+ #:alg 'RS256
+ #:htm 'GET
+ #:htu (string->uri "https://example.com/res#frag")
+ #:access-token access-token)))
(define decoded
- (dpop-proof-decode (time-utc->date (make-time time-utc 0 10))
- blacklist
- 'GET
- (string->uri "https://example.com/res?query")
- proof
- cnf
- #:access-token access-token))
+ (parameterize ((p:current-date 10))
+ (dpop-proof-decode 'GET
+ (string->uri "https://example.com/res?query")
+ proof
+ cnf
+ #:access-token access-token)))
(unless decoded
(exit 1))))
diff --git a/tests/dpop-proof-valid.scm b/tests/dpop-proof-valid.scm
index 52da33b..ec6b32a 100644
--- a/tests/dpop-proof-valid.scm
+++ b/tests/dpop-proof-valid.scm
@@ -18,6 +18,7 @@
(webid-oidc jti)
(webid-oidc jwk)
(webid-oidc testing)
+ ((webid-oidc parameters) #:prefix p:)
(web uri)
(srfi srfi-19)
(web response))
@@ -27,20 +28,18 @@
(lambda ()
(define jwk (generate-key #:n-size 2048))
(define cnf (jkt jwk))
- (define blacklist (make-jti-list))
(define proof
- (issue-dpop-proof
- jwk
- #:alg 'RS256
- #:htm 'GET
- #:htu (string->uri "https://example.com/res#frag")
- #:iat (time-utc->date (make-time time-utc 0 0))))
+ (parameterize ((p:current-date 0))
+ (issue-dpop-proof
+ jwk
+ #:alg 'RS256
+ #:htm 'GET
+ #:htu (string->uri "https://example.com/res#frag"))))
(define decoded
- (dpop-proof-decode (time-utc->date (make-time time-utc 0 10))
- blacklist
- 'GET
- (string->uri "https://example.com/res?query")
- proof
- cnf))
+ (parameterize ((p:current-date 10))
+ (dpop-proof-decode 'GET
+ (string->uri "https://example.com/res?query")
+ proof
+ cnf)))
(unless decoded
(exit 1))))
diff --git a/tests/dpop-proof-wrong-htm.scm b/tests/dpop-proof-wrong-htm.scm
index eaedfe5..1b30161 100644
--- a/tests/dpop-proof-wrong-htm.scm
+++ b/tests/dpop-proof-wrong-htm.scm
@@ -19,6 +19,7 @@
(webid-oidc jwk)
(webid-oidc testing)
(webid-oidc errors)
+ ((webid-oidc parameters) #:prefix p:)
(web uri)
(srfi srfi-19)
(web response))
@@ -28,26 +29,24 @@
(lambda ()
(define jwk (generate-key #:n-size 2048))
(define cnf (jkt jwk))
- (define blacklist (make-jti-list))
(define proof
- (issue-dpop-proof
- jwk
- #:alg 'RS256
- #:htm 'POST
- #:htu (string->uri "https://example.com/res#frag")
- #:iat (time-utc->date (make-time time-utc 0 0))))
+ (parameterize ((p:current-date 0))
+ (issue-dpop-proof
+ jwk
+ #:alg 'RS256
+ #:htm 'POST
+ #:htu (string->uri "https://example.com/res#frag"))))
(with-exception-handler
(lambda (error)
(unless ((record-predicate &dpop-method-mismatch)
((record-accessor &cannot-decode-dpop-proof 'cause) error))
(raise-exception error)))
(lambda ()
- (dpop-proof-decode (time-utc->date (make-time time-utc 0 10))
- blacklist
- 'GET
- (string->uri "https://example.com/res?query")
- proof
- cnf)
+ (parameterize ((p:current-date 10))
+ (dpop-proof-decode 'GET
+ (string->uri "https://example.com/res?query")
+ proof
+ cnf))
(exit 2))
#:unwind? #t
#:unwind-for-type &cannot-decode-dpop-proof)))
diff --git a/tests/dpop-proof-wrong-htu.scm b/tests/dpop-proof-wrong-htu.scm
index c65d1fc..6f3ac0a 100644
--- a/tests/dpop-proof-wrong-htu.scm
+++ b/tests/dpop-proof-wrong-htu.scm
@@ -19,6 +19,7 @@
(webid-oidc jwk)
(webid-oidc testing)
(webid-oidc errors)
+ ((webid-oidc parameters) #:prefix p:)
(web uri)
(srfi srfi-19)
(web response))
@@ -28,26 +29,24 @@
(lambda ()
(define jwk (generate-key #:n-size 2048))
(define cnf (jkt jwk))
- (define blacklist (make-jti-list))
(define proof
- (issue-dpop-proof
- jwk
- #:alg 'RS256
- #:htm 'GET
- #:htu (string->uri "https://example.com/other-res#frag")
- #:iat (time-utc->date (make-time time-utc 0 0))))
+ (parameterize ((p:current-date 0))
+ (issue-dpop-proof
+ jwk
+ #:alg 'RS256
+ #:htm 'GET
+ #:htu (string->uri "https://example.com/other-res#frag"))))
(with-exception-handler
(lambda (error)
(unless ((record-predicate &dpop-uri-mismatch)
((record-accessor &cannot-decode-dpop-proof 'cause) error))
(raise-exception error)))
(lambda ()
- (dpop-proof-decode (time-utc->date (make-time time-utc 0 10))
- blacklist
- 'GET
- (string->uri "https://example.com/res?query")
- proof
- cnf)
+ (parameterize ((p:current-date 10))
+ (dpop-proof-decode 'GET
+ (string->uri "https://example.com/res?query")
+ proof
+ cnf))
(exit 2))
#:unwind? #t
#:unwind-for-type &cannot-decode-dpop-proof)))
diff --git a/tests/dpop-proof-wrong-key.scm b/tests/dpop-proof-wrong-key.scm
index ae6f177..497ae0e 100644
--- a/tests/dpop-proof-wrong-key.scm
+++ b/tests/dpop-proof-wrong-key.scm
@@ -19,6 +19,7 @@
(webid-oidc jwk)
(webid-oidc testing)
(webid-oidc errors)
+ ((webid-oidc parameters) #:prefix p:)
(web uri)
(srfi srfi-19)
(web response))
@@ -28,26 +29,24 @@
(lambda ()
(define jwk (generate-key #:n-size 2048))
(define cnf (jkt (generate-key #:n-size 2048)))
- (define blacklist (make-jti-list))
(define proof
- (issue-dpop-proof
- jwk
- #:alg 'RS256
- #:htm 'GET
- #:htu (string->uri "https://example.com/res#frag")
- #:iat (time-utc->date (make-time time-utc 0 0))))
+ (parameterize ((p:current-date 0))
+ (issue-dpop-proof
+ jwk
+ #:alg 'RS256
+ #:htm 'GET
+ #:htu (string->uri "https://example.com/res#frag"))))
(with-exception-handler
(lambda (error)
(unless ((record-predicate &dpop-unconfirmed-key)
((record-accessor &cannot-decode-dpop-proof 'cause) error))
(raise-exception error)))
(lambda ()
- (dpop-proof-decode (time-utc->date (make-time time-utc 0 10))
- blacklist
- 'GET
- (string->uri "https://example.com/res?query")
- proof
- cnf)
+ (parameterize ((p:current-date 10))
+ (dpop-proof-decode 'GET
+ (string->uri "https://example.com/res?query")
+ proof
+ cnf))
(exit 2))
#:unwind? #t
#:unwind-for-type &cannot-decode-dpop-proof)))
diff --git a/tests/jwks-get.scm b/tests/jwks-get.scm
index 66174a2..8e9169e 100644
--- a/tests/jwks-get.scm
+++ b/tests/jwks-get.scm
@@ -55,12 +55,8 @@
}
")
(exit 2)))
- (define current-time 0)
(define cache-http-get
(with-cache
- #:current-time
- (lambda ()
- (make-time time-utc 0 current-time))
#:http-get respond))
(define jwks (get-jwks "https://example.com/keys"
#:http-get cache-http-get))
diff --git a/tests/oidc-configuration.scm b/tests/oidc-configuration.scm
index 7f02941..f7b3bbc 100644
--- a/tests/oidc-configuration.scm
+++ b/tests/oidc-configuration.scm
@@ -115,12 +115,8 @@
]
}"))
(else (exit 2))))
- (define current-time 0)
(define cache-http-get
(with-cache
- #:current-time
- (lambda ()
- (make-time time-utc 0 current-time))
#:http-get respond))
(define cfg (get-oidc-configuration
"example.com"
diff --git a/tests/resource-server.scm b/tests/resource-server.scm
index ef5e0b7..aba4bb0 100644
--- a/tests/resource-server.scm
+++ b/tests/resource-server.scm
@@ -23,6 +23,7 @@
(webid-oidc dpop-proof)
(webid-oidc resource-server)
(webid-oidc testing)
+ ((webid-oidc parameters) #:prefix p:)
(web uri)
(web request)
(srfi srfi-19)
@@ -33,7 +34,6 @@
(with-test-environment
"resource-server"
(lambda ()
- (define jti (make-jti-list))
(define client-key (generate-key #:n-size 2048))
(define idp-key (generate-key #:n-size 2048))
(define jwks (make-jwks (list idp-key)))
@@ -55,26 +55,26 @@
(serve-jwks exp jwks))
(else (exit 1))))
(define access-token
- (issue-access-token
- idp-key
- #:alg 'RS256
- #:webid subject
- #:iss "https://identity.provider"
- #:iat 10
- #:exp 3610
- #:client-key client-key
- #:client-id "https://client"))
+ (parameterize ((p:current-date 10))
+ (issue-access-token
+ idp-key
+ #:alg 'RS256
+ #:webid subject
+ #:iss "https://identity.provider"
+ #:validity 3600
+ #:client-key client-key
+ #:client-id "https://client")))
(define uri (string->uri "https://resource.server/resource"))
(define server-uri (string->uri "https://resource.server/"))
(define method 'GET)
(define dpop-proof
- (issue-dpop-proof
- client-key
- #:alg 'RS256
- #:htm method
- #:htu uri
- #:iat (time-utc->date (make-time time-utc 0 15))
- #:access-token access-token))
+ (parameterize ((p:current-date 15))
+ (issue-dpop-proof
+ client-key
+ #:alg 'RS256
+ #:htm method
+ #:htu uri
+ #:access-token access-token)))
(define rq
(call-with-input-string
(format #f "GET /resource HTTP/1.1\r\n\
@@ -90,11 +90,11 @@ DPoP: ~a\r\n\r\n"
(define rq-body "")
(define authenticator
(make-authenticator
- jti
#:server-uri server-uri
- #:current-time (lambda () (make-time time-utc 0 20))
#:http-get http-get))
- (define parsed (authenticator rq rq-body))
+ (define parsed
+ (parameterize ((p:current-date 20))
+ (authenticator rq rq-body)))
(unless (uri? parsed)
(exit 2))
(unless (equal? parsed subject)
diff --git a/tests/token-endpoint-issue.scm b/tests/token-endpoint-issue.scm
index 6f7d4dc..9438dfe 100644
--- a/tests/token-endpoint-issue.scm
+++ b/tests/token-endpoint-issue.scm
@@ -22,6 +22,7 @@
(webid-oidc jti)
(webid-oidc testing)
((webid-oidc stubs) #:prefix stubs:)
+ ((webid-oidc parameters) #:prefix p:)
(web uri)
(web request)
(web response)
@@ -40,50 +41,27 @@
(define client (string->uri "https://token-endpoint-issue.scm/client/card#app"))
(define issuer (string->uri "https://issuer.token-endpoint-issue.scm"))
(define validity 3600)
- (define jti-list (make-jti-list))
- (define authz (issue-authorization-code
- alg key
- (time-utc->date (make-time time-utc 0 120))
- subject
- client))
- (define the-time 0)
- (define (current-time)
- (make-time time-utc 0 the-time))
- (define endpoint (make-token-endpoint
- (string->uri "https://token-endpoint-issue.scm/token")
- issuer alg key validity jti-list
- #:current-time current-time))
+ (define authz
+ (issue-authorization-code
+ alg key
+ (time-utc->date (make-time time-utc 0 120))
+ subject
+ client))
+ (define endpoint
+ (make-token-endpoint
+ (string->uri "https://token-endpoint-issue.scm/token")
+ issuer alg key validity))
(receive (response response-body user error)
;; The code is fake!
(let ((dpop
- (issue-dpop-proof
- client-key
- #:alg alg
- #:htm 'POST
- #:htu (string->uri
- "https://token-endpoint-issue.scm/token")
- #:iat (time-utc->date (make-time time-utc 0 0)))))
- (set! the-time 0)
- (endpoint
- (build-request (string->uri
- "http://localhost:8080/token")
- #:headers `((content-type application/x-www-form-urlencoded)
- (dpop . ,dpop))
- #:method 'POST
- #:port #t)
- "grant_type=authorization_code&code=fake"))
- (unless (eq? (response-code response) 400)
- (exit 3))
- (receive (response response-body user error)
- (let ((dpop
+ (parameterize ((p:current-date 0))
(issue-dpop-proof
client-key
#:alg alg
#:htm 'POST
#:htu (string->uri
- "https://token-endpoint-issue.scm/token")
- #:iat (time-utc->date (make-time time-utc 0 10)))))
- (set! the-time 10)
+ "https://token-endpoint-issue.scm/token")))))
+ (parameterize ((p:current-date 0))
(endpoint
(build-request (string->uri
"http://localhost:8080/token")
@@ -91,7 +69,27 @@
(dpop . ,dpop))
#:method 'POST
#:port #t)
- (string-append "grant_type=authorization_code&code=" authz)))
+ "grant_type=authorization_code&code=fake")))
+ (unless (eq? (response-code response) 400)
+ (exit 3))
+ (receive (response response-body user error)
+ (let ((dpop
+ (parameterize ((p:current-date 10))
+ (issue-dpop-proof
+ client-key
+ #:alg alg
+ #:htm 'POST
+ #:htu (string->uri
+ "https://token-endpoint-issue.scm/token")))))
+ (parameterize ((p:current-date 10))
+ (endpoint
+ (build-request (string->uri
+ "http://localhost:8080/token")
+ #:headers `((content-type application/x-www-form-urlencoded)
+ (dpop . ,dpop))
+ #:method 'POST
+ #:port #t)
+ (string-append "grant_type=authorization_code&code=" authz))))
(unless (eq? (response-code response) 200)
(write response)
(exit 4))
diff --git a/tests/token-endpoint-refresh.scm b/tests/token-endpoint-refresh.scm
index 2b5be1f..f3d9b52 100644
--- a/tests/token-endpoint-refresh.scm
+++ b/tests/token-endpoint-refresh.scm
@@ -23,6 +23,7 @@
(webid-oidc jti)
(webid-oidc testing)
((webid-oidc stubs) #:prefix stubs:)
+ ((webid-oidc parameters) #:prefix p:)
(web uri)
(web request)
(web response)
@@ -41,47 +42,22 @@
(define client (string->uri "https://token-endpoint-issue.scm/client/card#app"))
(define issuer (string->uri "https://issuer.token-endpoint-issue.scm"))
(define validity 3600)
- (define jti-list (make-jti-list))
(define refresh-code
(issue-refresh-token subject client (jkt client-key)))
- (define the-time 0)
- (define (current-time)
- (make-time time-utc 0 the-time))
(define endpoint (make-token-endpoint
(string->uri "https://token-endpoint-issue.scm/token")
- issuer alg key validity jti-list
- #:current-time current-time))
+ issuer alg key validity))
(receive (response response-body user error)
;; The refresh token is fake!
(let ((dpop
- (issue-dpop-proof
- client-key
- #:alg alg
- #:htm 'POST
- #:htu (string->uri
- "https://token-endpoint-issue.scm/token")
- #:iat (time-utc->date (make-time time-utc 0 0)))))
- (set! the-time 0)
- (endpoint
- (build-request (string->uri
- "http://localhost:8080/token")
- #:headers `((content-type application/x-www-form-urlencoded)
- (dpop . ,dpop))
- #:method 'POST
- #:port #t)
- "refresh_token=fake"))
- (unless (eq? (response-code response) 400)
- (exit 3))
- (receive (response response-body user error)
- (let ((dpop
+ (parameterize ((p:current-date 0))
(issue-dpop-proof
client-key
#:alg alg
#:htm 'POST
#:htu (string->uri
- "https://token-endpoint-issue.scm/token")
- #:iat (time-utc->date (make-time time-utc 0 10)))))
- (set! the-time 10)
+ "https://token-endpoint-issue.scm/token")))))
+ (parameterize ((p:current-date 0))
(endpoint
(build-request (string->uri
"http://localhost:8080/token")
@@ -89,7 +65,27 @@
(dpop . ,dpop))
#:method 'POST
#:port #t)
- (string-append "grant_type=refresh_token&refresh_token=" refresh-code)))
+ "refresh_token=fake")))
+ (unless (eq? (response-code response) 400)
+ (exit 3))
+ (receive (response response-body user error)
+ (let ((dpop
+ (parameterize ((p:current-date 10))
+ (issue-dpop-proof
+ client-key
+ #:alg alg
+ #:htm 'POST
+ #:htu (string->uri
+ "https://token-endpoint-issue.scm/token")))))
+ (parameterize ((p:current-date 10))
+ (endpoint
+ (build-request (string->uri
+ "http://localhost:8080/token")
+ #:headers `((content-type application/x-www-form-urlencoded)
+ (dpop . ,dpop))
+ #:method 'POST
+ #:port #t)
+ (string-append "grant_type=refresh_token&refresh_token=" refresh-code))))
(unless (eq? (response-code response) 200)
(exit 4))
(unless (eq? (car (response-content-type response)) 'application/json)