diff options
Diffstat (limited to 'src/scm/webid-oidc/token-endpoint.scm')
| -rw-r--r-- | src/scm/webid-oidc/token-endpoint.scm | 168 |
1 files changed, 168 insertions, 0 deletions
diff --git a/src/scm/webid-oidc/token-endpoint.scm b/src/scm/webid-oidc/token-endpoint.scm new file mode 100644 index 0000000..422bac6 --- /dev/null +++ b/src/scm/webid-oidc/token-endpoint.scm @@ -0,0 +1,168 @@ +(define-module (webid-oidc token-endpoint) + #:use-module (webid-oidc errors) + #:use-module (webid-oidc authorization-code) + #:use-module (webid-oidc dpop-proof) + #:use-module (webid-oidc jws) + #:use-module (webid-oidc jwk) + #:use-module (webid-oidc oidc-id-token) + #:use-module (webid-oidc access-token) + #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module ((webid-oidc refresh-token) #:prefix refresh:) + #:use-module (web client) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:use-module (ice-9 optargs) + #:use-module (ice-9 receive) + #:use-module (srfi srfi-19) + #:use-module (rnrs bytevectors)) + +(define (try-handle-web-failure thunk) + (define (error->str err) + (if (record? err) + (let* ((type (record-type-descriptor err)) + (get + (lambda (slot) + ((record-accessor type slot) err))) + (recurse + (lambda (err) + (error->str err)))) + (case (record-type-name type) + ((&cannot-decode-dpop-proof) + (format #f "the DPoP proof is invalid")) + ((&no-authorization-code) + (format #f "there is no authorization code in the request")) + ((&no-refresh-token) + (format #f "there is no refresh token in the request")) + ((&cannot-decode-authorization-code) + (format #f "the authorization code is invalid")) + ((&invalid-refresh-token) + (format #f "the refresh token is invalid")) + ((&invalid-key-for-refresh-token) + (format #f "the refresh token is bound to another key")) + ((&unsupported-grant-type) + (format #f "the grant type ~s is not supported" (get 'value))) + (else + (raise-exception err)))) + (throw err))) + (with-exception-handler + (lambda (error) + (values + (build-response + #:code 400 + #:reason-phrase (string-append "Bad Request: " (error->str error))) + (error->str error))) + 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)) + (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))))))))))))) |