path: root/src/scm/webid-oidc/server/endpoint/resource-server.scm

;; 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))))