diff options
Diffstat (limited to 'src/scm/webid-oidc/server/endpoint/resource-server.scm')
| -rw-r--r-- | src/scm/webid-oidc/server/endpoint/resource-server.scm | 373 |
1 files changed, 373 insertions, 0 deletions
diff --git a/src/scm/webid-oidc/server/endpoint/resource-server.scm b/src/scm/webid-oidc/server/endpoint/resource-server.scm new file mode 100644 index 0000000..9e7a0b7 --- /dev/null +++ b/src/scm/webid-oidc/server/endpoint/resource-server.scm @@ -0,0 +1,373 @@ +;; disfluid, implementation of the Solid specification +;; Copyright (C) 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 server endpoint resource-server) + #:use-module (webid-oidc server endpoint) + #:use-module (webid-oidc errors) + #:use-module (webid-oidc provider-confirmation) + #:use-module (webid-oidc client-manifest) + #:use-module (webid-oidc http-link) + #:use-module (webid-oidc serve) + #:use-module ((webid-oidc parameters) #:prefix p:) + #:use-module ((webid-oidc config) #:prefix cfg:) + #:use-module ((webid-oidc server resource wac) #:prefix wac:) + #:use-module ((webid-oidc server resource path) #:prefix ldp:) + #:use-module ((webid-oidc server read) #:prefix ldp:) + #:use-module ((webid-oidc server create) #:prefix ldp:) + #:use-module (webid-oidc server precondition) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:use-module (web server) + #:use-module (web client) + #: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 + ( + <resource-server> + server-name + owner + data-home + )) + +(define-class <resource-server> (<endpoint>) + (server-name #:init-keyword #:server-name #:getter server-name) + (owner #:init-keyword #:owner #:getter owner) + (data-home #:init-keyword #:data-home #:getter get-data-home #:init-value p:data-home)) + +(define-method (data-home (s <resource-server>)) + ;; Actually, it’s stored as a thunk + ((get-data-home s))) + +(define-method (initialize (s <resource-server>) initargs) + (next-method) + (match (server-name s) + ((? string? (= string->uri (? uri? uri))) + (slot-set! s 'server-name uri)) + ((? uri?) + #t) + (else + (scm-error 'wrong-type-arg "make <resource-server>" + (G_ "#:server-name must be an URI or a string encoding an URI") + '() + (list (server-name s))))) + (match (owner s) + ((? string? (= string->uri (? uri? uri))) + (slot-set! s 'owner uri)) + ((? uri?) + #t) + (else + (scm-error 'wrong-type-arg "make <resource-server>" + (G_ "#:owner must be an URI or a string encoding an URI") + '() + (list (owner s))))) + (let ((given-data-home (get-data-home s))) + (when (string? given-data-home) + (slot-set! s 'data-home (lambda () given-data-home)))) + (unless (thunk? (get-data-home s)) + (scm-error 'wrong-type-arg "make <resource-server>" + (G_ "#:data-home must be a string, or a thunk (returning a string)") + '() + (list (get-data-home s)))) + (parameterize ((p:data-home (data-home s))) + (ldp:create-root (server-name s) (owner s)))) + +(define (nonrdf-or-turtle server-uri request request-body) + ;; If the request is an exotic RDF serialization + ;; format, we want to convert it to Turtle, + ;; otherwise we will consider it non-rdf. + (convert '(text/turtle */*) + server-uri + (uri-path (request-uri request)) + (match (request-content-type request) + ((or (? symbol? content-type) + ((? symbol? content-type) _ ...)) + content-type)) + request-body)) + +(define (serve-get return path if-match if-none-match content-type content etag headers user) + (define (respond-normal) + (return + (build-response #:headers headers) + content + '())) + (if if-match + ;; If the precondition failed, then we should respond with 412 + (with-exception-handler + (lambda (error) + (unless (precondition-failed? error) + (raise-exception error)) + (raise-exception + (make-exception + (make-web-exception 412 (W_ "reason-phrase|Precondition Failed")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>The resource has been updated.</p>")) + xml->sxml)) + error))) + (lambda () + (check-precondition path if-match if-none-match etag) + (respond-normal))) + ;; If the precondition succeeds (if-none-match is effectively + ;; invalid), we return 200 + (with-exception-handler + (lambda (error) + (unless (precondition-failed? error) + (raise-exception error)) + (return + (build-response + #:code 304 + #:reason-phrase (W_ "reason-phrase|Not Modified") + #:headers + (filter + (lambda (h) + (case (car h) + ((cache-control content-location date etag expires vary) + #t) + (else #f))) + headers)) + #f + '())) + (lambda () + (when if-none-match + (check-precondition path if-match if-none-match etag)) + (respond-normal))))) + +(define-method (handle (endpoint <resource-server>) request request-body) + (parameterize ((p:data-home (data-home endpoint))) + (declare-link-header!) + (let/ec return + (with-exception-handler + (lambda (exn) + (if (wac:cannot-fetch-group? exn) + (if (exception-with-message? exn) + (format (current-error-port) + (G_ "~a: ignoring a group that cannot be fetched: ~a\n") + (date->string ((p:current-date))) + (exception-message exn)) + (format (current-error-port) + (G_ "~a: ignoring a group that cannot be fetched\n") + (date->string ((p:current-date))))) + (cond + ((ldp:uri-slash-semantics-error? exn) + (return + (build-response + #:code 301 + #:reason-phrase (W_ "reason-phrase|Found") + #:headers + (let ((server-uri (server-name endpoint))) + `((location + . ,(build-uri + (uri-scheme server-uri) + #:userinfo (uri-userinfo server-uri) + #:host (uri-host server-uri) + #:port (uri-port server-uri) + #:path (ldp:uri-slash-semantics-error-existing exn)))))) + #f + '())) + ((or (ldp:path-not-found? exn) + (ldp:auxiliary-resource-absent? exn) + (wac:forbidden? exn)) + (let ((user (assq-ref (request-meta request) 'user))) + (if user + ;; That’s a forbidden + (raise-exception + (make-exception + (make-web-exception 403 (W_ "reason-phrase|Forbidden")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>You are authentified, but you are not authorized to access this resource.</p>")) + xml->sxml)) + exn)) + (return + (build-response #:code 401 #:reason-phrase (W_ "reason-phrase|Unauthorized") + #:headers `((www-authenticate . ((DPoP))))) + #f + '())))) + ((ldp:cannot-delete-root? exn) + (raise-exception + (make-exception + (make-web-exception 405 (W_ "reason-phrase|Method Not Allowed")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>The storage root cannot be deleted.</p>")) + xml->sxml)) + exn))) + ((or (ldp:container-not-empty? exn) + (ldp:incorrect-containment-triples? exn) + (ldp:path-is-auxiliary? exn)) + (raise-exception + (make-exception + (make-web-exception 409 (W_ "reason-phrase|Conflict")) + (make-user-message + (call-with-input-string + (cond + ((ldp:container-not-empty? exn) + (format #f (W_ "<p>You need to empty the container first before deleting it.</p>"))) + ((ldp:incorrect-containment-triples? exn) + (format #f (W_ "<p>To change which resources are contained within this container, please use HTTP POST, PUT or DELETE.</p>"))) + ((ldp:path-is-auxiliary? exn) + (format #f (W_ "<p>The target resource is an auxiliary resource.</p>")))) + xml->sxml)) + exn))) + ((ldp:unsupported-media-type? exn) + (raise-exception + (make-exception + (make-web-exception 415 (W_ "reason-phrase|Unsupported Media Type")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>You cannot use this content type.</p>")) + xml->sxml)) + exn))) + ((precondition-failed? exn) + (raise-exception + (make-exception + (make-web-exception 412 (W_ "reason-phrase|Precondition Failed")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>The resource is not in the state you expected.</p>")) + xml->sxml)) + exn))) + ((not-acceptable? exn) + (raise-exception + (make-exception + (make-web-exception 406 (W_ "reason-phrase|Not Acceptable")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>I cannot serve the resource with a content-type you want.</p>")) + xml->sxml)) + exn))) + (else + (raise-exception exn))))) + (lambda () + (case (request-method request) + ((GET HEAD OPTIONS) + (receive (headers content) + (ldp:read (server-name endpoint) (owner endpoint) + (assq-ref (request-meta request) 'user) + (uri-path (request-uri request))) + (let ((true-content-type + (match (assq-ref headers 'content-type) + ((or (? symbol? ct) + ((? symbol? ct) _ ...)) + ct))) + (other-headers + (filter + (match-lambda + (('content-type . _) #f) + (else #t)) + headers))) + (receive (negociated-content-type + negociated-content) + (convert (request-accept request #f) + (server-name endpoint) + (uri-path (request-uri request)) + true-content-type + content) + (serve-get + return + (uri-path (request-uri request)) + (request-if-match request) + (request-if-none-match request) + negociated-content-type + negociated-content + (match (assq-ref headers 'etag) + (((? string? etag) . #f) + etag)) + `((content-type ,negociated-content-type) + ,@other-headers) + (assq-ref (request-meta request) 'user)))))) + ((PUT) + (receive (content-type content) + (nonrdf-or-turtle (server-name endpoint) request request-body) + (unless content + (raise-exception + (make-exception + (make-web-exception 400 (W_ "reason-phrase|Bad Request")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>Please include a request body.</p>")) + xml->sxml))))) + (let ((updated + (ldp:update (server-name endpoint) + (owner endpoint) + (assq-ref (request-meta request) 'user) + (uri-path (request-uri request)) + (request-if-match request) + (request-if-none-match request) + content-type + content))) + (return + (build-response + #:headers + `((etag . (,(ldp:etag updated) . #f)))) + "" + '())))) + ((POST) + (receive (content-type content) + (nonrdf-or-turtle (server-name endpoint) request request-body) + (unless content + (raise-exception + (make-exception + (make-web-exception 400 (W_ "reason-phrase|Bad Request")) + (make-user-message + (call-with-input-string + (format #f (W_ "<p>Please include a request body.</p>")) + xml->sxml))))) + (let ((types + (map target-iri + (filter + (lambda (link) + (equal? (relation-type link) "type")) + (request-links request))))) + (return + (build-response + #:code 201 #:reason-phrase (W_ "reason-phrase|Created") + #:headers + `((location . ,(ldp:create (server-name endpoint) + (owner endpoint) + (assq-ref (request-meta request) 'user) + (uri-path (request-uri request)) + types + (assq-ref (request-headers request) 'slug) + content-type + content)))) + "" + '())))) + ((DELETE) + (ldp:delete (server-name endpoint) + (owner endpoint) + (assq-ref (request-meta request) 'user) + (uri-path (request-uri request)) + (request-if-match request) + (request-if-none-match request)) + (return + (build-response) + "" + '())))) + #:unwind? #t)))) |