diff options
Diffstat (limited to 'tests/client-token.scm')
| -rw-r--r-- | tests/client-token.scm | 202 |
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. + )))))) |