summaryrefslogtreecommitdiff
path: root/src/scm/webid-oidc/resource-server.scm
diff options
context:
space:
mode:
Diffstat (limited to 'src/scm/webid-oidc/resource-server.scm')
-rw-r--r--src/scm/webid-oidc/resource-server.scm139
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)))))