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

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