summaryrefslogtreecommitdiff
path: root/src/scm/webid-oidc/token-endpoint.scm
diff options
context:
space:
mode:
Diffstat (limited to 'src/scm/webid-oidc/token-endpoint.scm')
-rw-r--r--src/scm/webid-oidc/token-endpoint.scm301
1 files changed, 34 insertions, 267 deletions
diff --git a/src/scm/webid-oidc/token-endpoint.scm b/src/scm/webid-oidc/token-endpoint.scm
index 53ff1cc..f96e768 100644
--- a/src/scm/webid-oidc/token-endpoint.scm
+++ b/src/scm/webid-oidc/token-endpoint.scm
@@ -15,6 +15,7 @@
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
(define-module (webid-oidc token-endpoint)
+ #:use-module (webid-oidc server endpoint identity-provider)
#:use-module (webid-oidc errors)
#:use-module (webid-oidc server endpoint)
#:use-module (webid-oidc authorization-code)
@@ -35,6 +36,7 @@
#:use-module (ice-9 control)
#:use-module (ice-9 exceptions)
#:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
#:use-module (rnrs bytevectors)
#:use-module (sxml simple)
#:use-module (sxml match)
@@ -43,285 +45,50 @@
#:declarative? #t
#:export
(
- &unsupported-grant-type
- make-unsupported-grant-type
- unsupported-grant-type?
- unsupported-grant-type-grant-type
-
- &no-authorization-code
- make-no-authorization-code
- no-authorization-code?
-
- &no-refresh-token
- make-no-refresh-token
- no-refresh-token?
-
make-token-endpoint
))
-(define-exception-type
- &unsupported-grant-type
- &external-error
- make-unsupported-grant-type
- unsupported-grant-type?
- (grant-type unsupported-grant-type-grant-type))
-
-(define-exception-type
- &no-authorization-code
- &external-error
- make-no-authorization-code
- no-authorization-code?)
-
-(define-exception-type
- &no-refresh-token
- &external-error
- make-no-refresh-token
- no-refresh-token?)
-
(define (try-handle-web-failure thunk)
(call/ec
(lambda (return)
(with-exception-handler
(lambda (error)
- (unless (or (unsupported-grant-type? error)
- (no-authorization-code? error)
- (no-refresh-token? error)
- (refresh:invalid-refresh-token? error)
- (invalid-authorization-code? error))
- (let ((final-message
- (if (exception-with-message? error)
- (format #f (G_ "while handling web failure for the token endpoint: ~a")
- (exception-message error))
- (format #f (G_ "an error happened during the token endpoint failure handling")))))
- (raise-exception
- (make-exception
- (make-exception-with-message final-message)
- error))))
- (cond
- ((refresh:invalid-refresh-token? error)
- (return
- (build-response
- #:code 403
- #:reason-phrase (G_ "reason-phrase|Forbidden")
- #:headers '((content-type application/xhtml-xml)))
- (call-with-output-string
- (lambda (port)
- (sxml->xml
- `(*TOP*
- (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
- (html (@ (xmlns "http://www.w3.org/1999/xhtml")
- (xml:lang ,(W_ "xml-lang|en")))
- (body
- ,(sxml-match
- (xml->sxml
- (W_ (format #f "<h1>Invalid refresh token</h1>")))
- ((*TOP* ,title) title))
- ,(sxml-match
- (xml->sxml
- (W_ (format #f "<p>The refresh token you sent is invalid, or it is already bound to another key.</p>")))
- ((*TOP* ,p) p))
- ,@(if (user-message? error)
- (list (user-message-sxml error))
- '()))))
- port)))))
- ((invalid-authorization-code? error)
- (return
- (build-response
- #:code 400
- #:reason-phrase (G_ "reason-phrase|Bad Request")
- #:headers '((content-type application/xhtml-xml)))
- (call-with-output-string
- (lambda (port)
- (sxml->xml
- `(*TOP*
- (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
- (html (@ (xmlns "http://www.w3.org/1999/xhtml")
- (xml:lang ,(W_ "xml-lang|en")))
- (body
- ,(sxml-match
- (xml->sxml
- (W_ (format #f "<h1>Invalid authorization code</h1>")))
- ((*TOP* ,title) title))
- ,(sxml-match
- (xml->sxml
- (W_ (format #f "<p>The authorization code is forged, or expired.</p>")))
- ((*TOP* ,p) p))
- ,@(if (user-message? error)
- (list (user-message-sxml error))
- '()))))
- port)))))
- ;; Other bad request
- (else
- (return
- (build-response
- #:code 400
- #:reason-phrase (G_ "reason-phrase|Bad Request")
- #:headers '((content-type application/xhtml+xml)))
- (call-with-output-string
- (lambda (port)
- (sxml->xml
- `(*TOP*
- (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
- (html (@ (xmlns "http://www.w3.org/1999/xhtml")
- (xml:lang ,(W_ "xml-lang|en")))
- (body
- ,(sxml-match
- (xml->sxml
- (W_ (format #f "<h1>Bad token request</h1>")))
- ((*TOP* ,title) title))
- ,(sxml-match
- (xml->sxml
- (W_ (format #f "<p>The token request failed.</p>")))
- ((*TOP* ,p) p))
- ,@(if (user-message? error)
- (list (user-message-sxml error))
- '()))))
- port)))))))
+ (unless (web-exception? error)
+ (raise-exception error))
+ (return
+ (build-response
+ #:code (web-exception-code error)
+ #:reason-phrase (web-exception-reason-phrase error)
+ #:headers `((content-type application/xhtml+xml)))
+ (call-with-output-string
+ (cute sxml->xml
+ `(*TOP*
+ (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+ (html (@ (xmlns "http://www.w3.org/1999/xhtml")
+ (xml:lang ,(W_ "xml-lang|en")))
+ (body
+ ,(call-with-input-string
+ (format #f (W_ "<h1>The token request failed</h1>"))
+ xml->sxml)
+ ,(if (user-message? error)
+ (user-message-sxml error)
+ (call-with-input-string
+ (format #f (W_ "<p>No more information.</p>"))
+ xml->sxml)))))
+ <>))))
thunk))))
-(define (make-token-endpoint token-endpoint-uri iss issuer-key)
+(define (make-token-endpoint token-endpoint-uri iss issuer-key-file)
+ (define endpoint
+ (make <token-endpoint>
+ #:issuer iss
+ #:key-file issuer-key-file))
(lambda (request request-body)
(when (bytevector? request-body)
(set! request-body (utf8->string request-body)))
(try-handle-web-failure
(lambda ()
- (parameterize ((p:current-date ((p:current-date)))
- (web-locale request))
- (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 (decode <dpop-proof> (assq-ref (request-headers request) 'dpop)
- #:method method
- #:uri uri
- #:cnf/check
- (lambda (jkt) #t))))
- (unless (and grant-type (string? grant-type))
- (let ((final-message
- (format #f (G_ "missing grant type")))
- (final-user-message
- (sxml-match
- (xml->sxml
- (format #f (W_ "<p>You did not specify a grant_type for this request.</p>")))
- ((*TOP* ,p) p))))
- (raise-exception
- (make-exception
- (make-unsupported-grant-type #f)
- (make-exception-with-message final-message)
- (make-user-message final-user-message)))))
- (receive (webid client-id)
- (case (string->symbol grant-type)
- ((authorization_code)
- (let ((code
- (let ((str (assoc-ref form-args "code")))
- (unless str
- (let ((final-message
- (format #f (G_ "missing authorization code")))
- (final-user-message
- (sxml-match
- (xml->sxml
- (format #f (W_ "<p>You want to grant an authorization code, but you did not set one.</p>")))
- ((*TOP* ,p) p))))
- (raise-exception
- (make-exception
- (make-no-authorization-code)
- (make-exception-with-message final-message)
- (make-user-message final-user-message)))))
- (with-exception-handler
- (lambda (error)
- (raise-exception
- (make-exception
- (make-invalid-authorization-code)
- error)))
- (lambda ()
- (decode <authorization-code> str
- #:issuer-key issuer-key))))))
- (values (webid code) (client-id code))))
- ((refresh_token)
- (let ((refresh-token (assoc-ref form-args "refresh_token")))
- (unless refresh-token
- (let ((final-message
- (format #f (G_ "missing refresh token")))
- (final-user-message
- (sxml-match
- (xml->sxml
- (format #f (W_ "<p>You want to grant a refresh token, but you did not set one.</p>")))
- ((*TOP* ,p) p))))
- (raise-exception
- (make-exception
- (make-no-refresh-token)
- (make-exception-with-message final-message)
- (make-user-message final-user-message)))))
- (refresh:with-refresh-token
- refresh-token
- (jwk dpop)
- values)))
- (else
- (let ((final-message
- (format #f (G_ "unsupported grant type: ~s")
- grant-type))
- (final-user-message
- (sxml-match
- (xml->sxml
- (format #f (W_ "<p>You want to use <pre>~s</pre> as a grant type, but this is not supported.</p>")
- grant-type))
- ((*TOP* ,p) p))))
- (raise-exception
- (make-exception
- (make-unsupported-grant-type grant-type)
- (make-exception-with-message final-message)
- (make-user-message final-user-message))))))
- (let ((id-token
- (issue <id-token>
- issuer-key
- #:webid webid
- #:iss iss
- #:aud client-id))
- (access-token
- (issue <access-token>
- issuer-key
- #:webid webid
- #:iss iss
- #:client-key (jwk dpop)
- #:client-id client-id))
- (refresh-token
- (if (equal? grant-type "refresh_token")
- (assoc-ref form-args "refresh_token")
- (refresh:issue-refresh-token webid client-id
- (jkt (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 . ,(p:oidc-token-default-validity))
- (refresh_token . ,refresh-token)))
- client-id
- #f))))))))))
+ (parameterize ((web-locale request))
+ (receive (response response-body response-meta)
+ (handle endpoint request request-body)
+ (values response response-body)))))))
generated by cgit v1.2.3 (git 2.44.0) at 2024-05-18 13:19:18 +0000