diff options
Diffstat (limited to 'src/scm/webid-oidc/resource-server.scm')
-rw-r--r-- | src/scm/webid-oidc/resource-server.scm | 139 |
1 files changed, 0 insertions, 139 deletions
diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm deleted file mode 100644 index 95fa78a..0000000 --- a/src/scm/webid-oidc/resource-server.scm +++ /dev/null @@ -1,139 +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 resource-server) - #:use-module (webid-oidc errors) - #:use-module (webid-oidc provider-confirmation) - #:use-module (webid-oidc jwk) - #:use-module (webid-oidc dpop-proof) - #:use-module (webid-oidc serve) - #:use-module (webid-oidc server endpoint) - #:use-module (webid-oidc server endpoint authentication) - #:use-module (webid-oidc server endpoint resource-server) - #:use-module ((webid-oidc server create) #:prefix ldp:) - #:use-module ((webid-oidc server read) #:prefix ldp:) - #:use-module ((webid-oidc server update) #:prefix ldp:) - #:use-module ((webid-oidc server delete) #:prefix ldp:) - #:use-module ((webid-oidc server resource wac) #:prefix wac:) - #:use-module ((webid-oidc server resource path) #:prefix ldp:) - #:use-module ((webid-oidc server resource content) #:prefix ldp:) - #:use-module (webid-oidc server precondition) - #:use-module (webid-oidc server endpoint) - #:use-module (webid-oidc server endpoint authentication) - #:use-module (webid-oidc http-link) - #:use-module ((webid-oidc parameters) #:prefix p:) - #:use-module ((webid-oidc config) #:prefix cfg:) - #:use-module (webid-oidc jti) - #:use-module (webid-oidc access-token) - #:use-module (web request) - #:use-module (web response) - #:use-module (web uri) - #:use-module (web server) - #:use-module (ice-9 optargs) - #:use-module (ice-9 receive) - #:use-module (webid-oidc web-i18n) - #:use-module (ice-9 getopt-long) - #:use-module (ice-9 suspendable-ports) - #:use-module (ice-9 control) - #:use-module (ice-9 match) - #:use-module (ice-9 exceptions) - #:use-module (sxml simple) - #:use-module (srfi srfi-19) - #:use-module (srfi srfi-26) - #:use-module (oop goops) - #:duplicates (merge-generics) - #:declarative? #t - #:export - ( - make-authenticator - make-resource-server - )) - -(define-class <stub-endpoint> (<endpoint>)) - -(define return - (make-parameter #f)) - -(define-method (handle (endpoint <stub-endpoint>) request request-body) - ((return) (assq-ref (request-meta request) 'user))) - -(define* (make-authenticator #:key (server-uri #f)) - (unless (and server-uri (uri? server-uri)) - (fail (G_ "You need to pass #:server-uri URI where URI is the public URI of the server, as a (web uri)."))) - (let* ((backend (make <stub-endpoint>)) - (endpoint (make <authenticator> - #:backend backend - #:server-uri server-uri))) - (lambda (request request-body) - (parameterize ((web-locale request)) - (with-exception-handler - (lambda (error) - #f) - (lambda () - (let/ec ret - (parameterize ((return ret)) - (handle endpoint request request-body)))) - #:unwind? #t))))) - -(define* (make-resource-server - #:key - (server-uri #f) - (owner #f) - (authenticator #f)) - (unless owner - (fail (G_ "The owner is not defined."))) - (declare-link-header!) - (define resource-server - (make <resource-server> - #:server-name server-uri - #:owner owner)) - (define authenticator - (make <authenticator> - #:backend resource-server - #:server-uri server-uri)) - (lambda (request request-body) - (let/ec return - (parameterize ((web-locale request)) - (with-exception-handler - (lambda (exn) - (unless (web-exception? exn) - (raise-exception exn)) - (return - (build-response - #:code (web-exception-code exn) - #:reason-phrase (web-exception-reason-phrase exn) - #: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 resource server request failed</h1>")) - xml->sxml) - ,(if (user-message? exn) - (user-message-sxml exn) - (call-with-input-string - (format #f (W_ "<p>No more information.</p>")) - xml->sxml))))) - <>)))) - (lambda () - (receive (response response-body response-meta) - (handle authenticator request request-body) - (return response response-body))) - #:unwind? #t))))) |