diff options
Diffstat (limited to 'src/scm/webid-oidc/token-endpoint.scm')
-rw-r--r-- | src/scm/webid-oidc/token-endpoint.scm | 94 |
1 files changed, 0 insertions, 94 deletions
diff --git a/src/scm/webid-oidc/token-endpoint.scm b/src/scm/webid-oidc/token-endpoint.scm deleted file mode 100644 index f96e768..0000000 --- a/src/scm/webid-oidc/token-endpoint.scm +++ /dev/null @@ -1,94 +0,0 @@ -;; disfluid, implementation of the Solid specification -;; Copyright (C) 2020, 2021 Vivien Kraus - -;; This program is free software: you can redistribute it and/or modify -;; it under the terms of the GNU Affero General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU Affero General Public License for more details. - -;; You should have received a copy of the GNU Affero General Public License -;; 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) - #: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 web-i18n) - #: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 request) - #:use-module (web response) - #:use-module (web uri) - #:use-module (ice-9 optargs) - #:use-module (ice-9 receive) - #: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) - #:use-module (oop goops) - #:duplicates (merge-generics) - #:declarative? #t - #:export - ( - make-token-endpoint - )) - -(define (try-handle-web-failure thunk) - (call/ec - (lambda (return) - (with-exception-handler - (lambda (error) - (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-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 ((web-locale request)) - (receive (response response-body response-meta) - (handle endpoint request request-body) - (values response response-body))))))) |