diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-08-01 14:51:28 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-08-01 18:08:56 +0200 |
commit | bae1843f1a1d644fb3bd4f8c40b1dbb900aa3325 (patch) | |
tree | 00f590033af904a6a493e41bdebe9b3ddd73043b /tests | |
parent | d8c2ca930673da858d63f2dea9526c259a2dd936 (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.scm | 20 | ||||
-rw-r--r-- | tests/authorization-endpoint-no-args.scm | 16 | ||||
-rw-r--r-- | tests/authorization-endpoint-submit-form.scm | 59 | ||||
-rw-r--r-- | tests/cache-valid.scm | 56 | ||||
-rw-r--r-- | tests/client-manifest-fraudulent.scm | 4 | ||||
-rw-r--r-- | tests/client-manifest.scm | 5 | ||||
-rw-r--r-- | tests/client-token.scm | 202 | ||||
-rw-r--r-- | tests/dpop-proof-iat-in-future.scm | 25 | ||||
-rw-r--r-- | tests/dpop-proof-iat-too-late.scm | 25 | ||||
-rw-r--r-- | tests/dpop-proof-invalid-ath.scm | 48 | ||||
-rw-r--r-- | tests/dpop-proof-no-ath.scm | 27 | ||||
-rw-r--r-- | tests/dpop-proof-replay.scm | 25 | ||||
-rw-r--r-- | tests/dpop-proof-valid-ath.scm | 48 | ||||
-rw-r--r-- | tests/dpop-proof-valid.scm | 25 | ||||
-rw-r--r-- | tests/dpop-proof-wrong-htm.scm | 25 | ||||
-rw-r--r-- | tests/dpop-proof-wrong-htu.scm | 25 | ||||
-rw-r--r-- | tests/dpop-proof-wrong-key.scm | 25 | ||||
-rw-r--r-- | tests/jwks-get.scm | 4 | ||||
-rw-r--r-- | tests/oidc-configuration.scm | 4 | ||||
-rw-r--r-- | tests/resource-server.scm | 40 | ||||
-rw-r--r-- | tests/token-endpoint-issue.scm | 72 | ||||
-rw-r--r-- | tests/token-endpoint-refresh.scm | 56 |
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) |