;; 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 . (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 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 (oop goops) #:duplicates (merge-generics) #:declarative? #t #:export ( make-authenticator make-resource-server )) (define-class ()) (define return (make-parameter #f)) (define-method (handle (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 )) (endpoint (make #: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 (handle-errors f g) (call/ec (lambda (do-return) (define (return . args) (apply do-return args)) (with-exception-handler (lambda (error) (g return error)) (lambda () (f return)) #:unwind? #t)))) (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 user)) (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)) (return (build-response #:code 412 #:reason-phrase (W_ "reason-phrase|Precondition Failed")) #f user)) (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 user)) (lambda () (when if-none-match (check-precondition path if-match if-none-match etag)) (respond-normal))))) (define* (make-resource-server #:key (server-uri #f) (owner #f) (authenticator #f)) (unless owner (fail (G_ "The owner is not defined."))) (declare-link-header!) (unless authenticator (set! authenticator (make-authenticator #:server-uri server-uri))) (lambda (request request-body) (parameterize ((p:current-date ((p:current-date))) ;; Fix the date (web-locale request)) (let ((user (authenticator request request-body))) (handle-errors (lambda (return) (let ((method (request-method request))) (case method ((GET HEAD OPTIONS) (receive (headers content) (ldp:read server-uri owner user (uri-path (request-uri request))) (let ((true-content-type (car (assq-ref headers 'content-type))) (other-headers (filter (lambda (h) (not (eq? (car h) 'content-type))) headers))) (receive (negociated-content-type negociated-content) (convert (request-accept request #f) server-uri (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 (car (assq-ref headers 'etag)) (cons `(content-type ,negociated-content-type) other-headers) user))))) ((PUT) (receive (content-type content) (nonrdf-or-turtle server-uri request request-body) (unless content (return (build-response #:code 400 #:reason-phrase (W_ "Bad Request")) "" user)) (let ((updated (ldp:update server-uri owner 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)))) "" user)))) ((POST) (receive (content-type content) (nonrdf-or-turtle server-uri request request-body) (unless content (return (build-response #:code 400 #:reason-phrase (W_ "Bad Request")) "" user)) (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-uri owner user (uri-path (request-uri request)) types (assq-ref (request-headers request) 'slug) content-type content)))) "" user)))) ((DELETE) (ldp:delete server-uri owner user (uri-path (request-uri request)) (request-if-match request) (request-if-none-match request)) (return (build-response) "" user))))) (lambda (return error) (if (wac:cannot-fetch-group? error) (if (exception-with-message? error) (format (current-error-port) (G_ "~a: ignoring a group that cannot be fetched: ~a\n") (date->string ((p:current-date))) (exception-message error)) (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? error) (return (build-response #:code 301 #:reason-phrase (W_ "reason-phrase|Found") #:headers `((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 error))))) #f user)) ((or (ldp:path-not-found? error) (ldp:auxiliary-resource-absent? error) (wac:forbidden? error)) (if user ;; That’s a forbidden (return (build-response #:code 403 #:reason-phrase (W_ "reason-phrase|Forbidden")) #f user) (return (build-response #:code 401 #:reason-phrase (W_ "reason-phrase|Unauthorized") #:headers `((www-authenticate . ((DPoP))))) #f user))) ((ldp:cannot-delete-root? error) (return (build-response #:code 405 #:reason-phrase (W_ "reason-phrase|Method Not Allowed")) #f user)) ((or (ldp:container-not-empty? error) (ldp:incorrect-containment-triples? error) (ldp:path-is-auxiliary? error)) (return (build-response #:code 409 #:reason-phrase (W_ "reason-phrase|Conflict")) #f user)) ((ldp:unsupported-media-type? error) (return (build-response #:code 415 #:reason-phrase (W_ "reason-phrase|Unsupported Media Type")) #f user)) ((precondition-failed? error) (return (build-response #:code 412 #:reason-phrase (W_ "reason-phrase|Precondition Failed")) #f user)) ((not-acceptable? error) (return (build-response #:code 406 #:reason-phrase (W_ "reason-phrase|Not Acceptable")) #f user)) (else (raise-exception error))))))))))