;; 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 (tests crud)
  #:use-module (webid-oidc server create)
  #:use-module ((webid-oidc server read) #:prefix server:)
  #:use-module (webid-oidc server update)
  #:use-module ((webid-oidc server delete) #:prefix server:)
  #:use-module (webid-oidc server resource content)
  #:use-module (webid-oidc server resource path)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc testing)
  #:use-module (webid-oidc http-link)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module (webid-oidc fetch)
  #:use-module (webid-oidc rdf-index)
  #:use-module (web http)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web uri)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:duplicates (merge-generics)
  #:declarative? #t)

(with-test-environment
 "crud"
 (lambda ()
   (for-each
    (lambda (f)
      (false-if-exception
       (delete-file
        (string-append
         "tests/crud.home/disfluid/server/content/"
         f))))
    '("6/8OMG_V5x-KmI6TI"
      "X/hqM_2Avn5_egTzs"
      "5/n1KPgAd3ng4wSqn"
      "D/wxU0ogx5rzRrvu2"
      "F/BQKBGrtq6U_M0L7"
      "n/U46BXbknEaLWZpH"
      "A/fkGTJRCHc-jHk-V"
      "a/68pTwiImTWTpjQl"
      "H/y4S5p1BqTEJi-Jb"
      "b/k7RqZevpCHAumba"
      "y/29x0MEOMybxUqDU"
      "5/KVojpXDg0Aob3_v"
      "S/9kvZXAg1UQojIal"
      "B/JadnRZKhcTKHHZU"
      "_/VhVgLvE4J9JwpIP"
      "l/ljOph3RCCWJJW5K"
      "o/UmwpeCFbPoc9PCL"))
   (for-each
    (lambda (f)
      (false-if-exception
       (delete-file
        (string-append
         "tests/crud.home/disfluid/server/path/"
         f))))  
    '("L/uhr1159jdGYjIj_tpM6FDiW4rUZDQQKUnT35lhAR-s"
      "8/jgewChguz6YRPCTBOkx_9CW94iH_X88rP6Os4aM8jg"
      "n/PQ_3L8lXCsqpz1tkUhsJnVC9rcyqgDD41DnFPIDG1Q"
      "i/l7asoJjJEMhngUeSt4tHVu8Zxx4EFG_FDeJfL3-oPE"
      "4/Hkcb0hNCFXVdxfiSfpg9D2LPLelSWBw7rM1xyQkI_M"
      "1/8Jb3gOzbpL-A0o4MaBd4Iw41W1c0t3fgywwryZ8vBw"
      "P/6DoRBgELS5Hrr0E-sQgRsjN-apgr3GsKZpL9K-NMHs"))
   (let ((server-name (string->uri "https://example.com"))
         (owner (string->uri "https://alice.databox.me")))
     ;; CREATE
     (unless
         (create-root server-name owner)
       (exit 1))
     (let ((inbox (create server-name owner owner "/"
                          (list (string->uri "http://www.w3.org/ns/ldp#BasicContainer"))
                          "inbox"
                          'text/turtle
                          "")))
       (unless (equal? inbox (string->uri "https://example.com/inbox/"))
         (exit 2))
       (let ((inbox-2 (create server-name owner owner "/"
                              (list (string->uri "http://www.w3.org/ns/ldp#BasicContainer"))
                              "inbox"
                              'text/turtle
                              "")))
         (when (equal? inbox-2 (string->uri "https://example.com/inbox/"))
           (exit 3)))
       (let ((notif-1 (create server-name owner owner "/inbox"
                              '()
                              #f
                              'text/turtle
                              "")))
         (unless (equal? notif-1
                         (string->uri "https://example.com/inbox/NgnO8RAS9FpPiO5j"))
           (format (current-error-port) "Notif 1: ~s\n" notif-1)
           (exit 4))))
     (for-each
      (lambda (slug)
        (with-exception-handler
            (lambda (error)
              (unless (path-is-auxiliary? error)
                (raise-exception error)))
          (lambda ()
            (create server-name owner owner "/" '() slug 'text/turtle "")
            (exit 5))
          #:unwind? #t
          #:unwind-for-type &path-is-auxiliary))
      '(".acl" ".meta"))
     ;; READ
     (receive (headers-root root) (server:read server-name owner owner "/")
       ;; For root, we’re looking for the following headers:
       ;; - link: ldp:BasicContainer; rel = "type", </.acl>; rel = "acl", pim:Storage; rel = "type", owner; rel = "solid:owner"
       ;; - allow: GET, HEAD, OPTIONS, PUT, POST, but not DELETE
       ;; - accept-put: 'text/turtle 'application/n-quads 'application/ld+json
       ;; - content-type: 'text/turtle
       ;; - etag: weak
       ;; The content is a RDF graph, it should contain 1 triple: </> ldp:contains </inbox>.
       (when (bytevector? root)
         (set! root (utf8->string root)))
       (let ((links (assq-ref headers-root 'link))
             (allow (assq-ref headers-root 'allow))
             (accept-put (assq-ref headers-root 'accept-put))
             (content-type (assq-ref headers-root 'content-type))
             (etag (assq-ref headers-root 'etag)))
         (let search-links ((links links)
                            (container-type-found? #f)
                            (acl-found? #f)
                            (storage-type-found? #f)
                            (owner-found? #f))
           (match links
             ((link links ...)
              (cond
               ((and (equal? (target-iri link) (string->uri "http://www.w3.org/ns/ldp#BasicContainer"))
                     (equal? (relation-type link) "type"))
                (search-links links #t acl-found? storage-type-found? owner-found?))
               ((and (equal? (target-iri link) (string->uri "https://example.com/.acl"))
                     (equal? (relation-type link) "acl"))
                (search-links links container-type-found? #t storage-type-found? owner-found?))
               ((and (equal? (target-iri link) (string->uri "http://www.w3.org/ns/pim/space#Storage"))
                     (equal? (relation-type link) "type"))
                (search-links links container-type-found? acl-found? #t owner-found?))
               ((and (equal? (target-iri link) owner)
                     (equal? (relation-type link) "http://www.w3.org/ns/solid/terms#owner"))
                (search-links links container-type-found? acl-found? storage-type-found? #t))
               (else
                (format (current-error-port) "Ignoring link: ~s\n" link)
                (search-links links container-type-found? acl-found? storage-type-found? owner-found?))))
             (()
              (unless container-type-found?
                (exit 6))
              (unless acl-found?
                (exit 7))
              (unless storage-type-found?
                (exit 8))
              (unless owner-found?
                (exit 9)))))
         (unless (and (memq 'GET allow)
                      (memq 'HEAD allow)
                      (memq 'OPTIONS allow)
                      (memq 'PUT allow)
                      (memq 'POST allow))
           (exit 10))
         (when (memq 'DELETE allow)
           (exit 11))
         (unless (equal? accept-put "text/turtle; application/n-quads; application/ld+json")
           (exit 12))
         (unless (equal? content-type '(text/turtle))
           (exit 13))
         (unless (string? (car etag))
           (exit 14))
         (when (cdr etag)
           (exit 15))
         (with-index
          (parameterize ((p:anonymous-http-request
                          (lambda (uri . rest)
                            (values
                             (build-response #:headers `((content-type . ,content-type)))
                             root))))
            (fetch "https://example.com/"))
          (lambda (rdf-match)
            (when (null? (rdf-match "https://example.com/"
                                    "http://www.w3.org/ns/ldp#contains"
                                    "https://example.com/inbox/"))
              (exit 16))))))
     (receive (headers-/.acl /.acl) (server:read server-name owner owner "/.acl")
       ;; The ACL has the following headers:
       ;; - allow: GET, HEAD, OPTIONS, PUT, DELETE, but not POST
       ;; - accept-put: 'text/turtle
       ;; - content-type: 'text/turtle
       ;; - etag: weak
       ;; The content is a RDF graph containing at least one authorization.
       (when (bytevector? /.acl)
         (set! /.acl (utf8->string /.acl)))
       (let ((allow (assq-ref headers-/.acl 'allow))
             (accept-put (assq-ref headers-/.acl 'accept-put))
             (content-type (assq-ref headers-/.acl 'content-type))
             (etag (assq-ref headers-/.acl 'etag)))
         (unless (and (memq 'GET allow)
                      (memq 'HEAD allow)
                      (memq 'OPTIONS allow)
                      (memq 'PUT allow)
                      (memq 'DELETE allow))
           (exit 17))
         (when (memq 'POST allow)
           (exit 18))
         (unless (equal? accept-put "text/turtle; application/n-quads; application/ld+json")
           (exit 19))
         (unless (equal? content-type '(text/turtle))
           (exit 20))
         (unless (string? (car etag))
           (exit 21))
         (when (cdr etag)
           (exit 22))
         (with-index
          (parameterize ((p:anonymous-http-request
                          (lambda (uri . rest)
                            (values
                             (build-response #:headers `((content-type . ,content-type)))
                             /.acl))))
            (fetch "https://example.com/.acl"))
          (lambda (rdf-match)
            (when (null? (rdf-match #f
                                    "http://www.w3.org/1999/02/22-rdf-syntax-ns#type"
                                    "http://www.w3.org/ns/auth/acl#Authorization"))
              (exit 23))))))
     (update server-name owner owner "/inbox/.acl" #f '* 'text/turtle "@prefix acl: <http://www.w3.org/ns/auth/acl#> .
@prefix foaf: <http://xmlns.com/foaf/0.1/> .

<#default>
  a acl:Authorization;
  acl:accessTo <https://example.com/inbox/>;
  acl:agent <https://alice.databox.me/profile/card#me>;
  acl:mode acl:Read, acl:Write, acl:Control;
  acl:default <https://example.com/inbox/>.

<#public>
  a acl:Authorization;
  acl:accessTo <https://example.com/inbox/>;
  acl:default <https://example.com/inbox/>;
  acl:agentClass foaf:Agent;
  acl:mode acl:Append.
")
     (update server-name owner #f "/inbox/test-notifications/welcome" #f '* 'text/plain "Hello :)")
     (with-exception-handler
         (lambda (error)
           ;; The containment triples are not correct
           (unless (incorrect-containment-triples? error)
             (exit 24)))
       (lambda ()
         (update server-name owner owner "/inbox/" #f #f 'text/turtle "@prefix ldp: <http://www.w3.org/ns/ldp#> .
@prefix rdfs: <http://www.w3.org/2000/01/rdf-schema#> .

<> rdfs:comment \"Alice’s inbox, drop your notifications there and I’ll ignore them.\" .
"))
       #:unwind? #t
       #:unwind-for-type &incorrect-containment-triples)
     (let ((exact-content
            "@prefix ldp: <http://www.w3.org/ns/ldp#> .
@prefix rdfs: <http://www.w3.org/2000/01/rdf-schema#> .

# This is the exact content submitted to the server, however this
# comment will disappear because the server will re-write the turtle
# representation to change the containment triples.

<> rdfs:comment \"Alice’s inbox, drop your notifications there and I’ll ignore them.\" ;
   ldp:contains <test-notifications> .
"))
       (update server-name owner owner "/inbox/" #f #f 'text/turtle exact-content)
       (receive (headers content)
           (server:read server-name owner owner "/inbox/")
         (when (bytevector? content)
           (set! content (utf8->string content)))
         (when (equal? content exact-content)
           (exit 25))))
     (server:delete server-name owner owner "/inbox/test-notifications/welcome" #f #f)
     (server:delete server-name owner owner "/inbox/test-notifications" #f #f))))