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