;; 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 server-path)
  #:use-module (webid-oidc server resource content)
  #:use-module (webid-oidc server resource path)
  #:use-module (webid-oidc fetch)
  #:use-module (webid-oidc testing)
  #:use-module (webid-oidc errors)
  #:use-module (web uri)
  #:use-module (web response)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 receive)
  #:use-module (oop goops)
  #:declarative? #t
  #:duplicates (merge-generics))

(with-test-environment
 "server-path"
 (lambda ()
   (for-each
    (lambda (file)
      (false-if-exception (delete-file file)))
    '(
      "tests/server-path.home/disfluid/server/content/6/8OMG_V5x-KmI6TI"
      "tests/server-path.home/disfluid/server/content/X/hqM_2Avn5_egTzs"
      "tests/server-path.home/disfluid/server/content/a/68pTwiImTWTpjQl"
      "tests/server-path.home/disfluid/server/content/5/n1KPgAd3ng4wSqn"
      "tests/server-path.home/disfluid/server/content/D/wxU0ogx5rzRrvu2"
      "tests/server-path.home/disfluid/server/content/F/BQKBGrtq6U_M0L7"
      "tests/server-path.home/disfluid/server/content/N/gnO8RAS9FpPiO5j"
      "tests/server-path.home/disfluid/server/content/n/U46BXbknEaLWZpH"
      "tests/server-path.home/disfluid/server/content/y/29x0MEOMybxUqDU"
      "tests/server-path.home/disfluid/server/content/b/k7RqZevpCHAumba"
      "tests/server-path.home/disfluid/server/content/H/y4S5p1BqTEJi-Jb"
      "tests/server-path.home/disfluid/server/content/A/fkGTJRCHc-jHk-V"
      "tests/server-path.home/disfluid/server/path/b/FkceBVDI7O39t4bFK02Vu0E7OWtjnjDfAXDLKuREbE"
      "tests/server-path.home/disfluid/server/path/b/FkceBVDI7O39t4bFK02Vu0E7OWtjnjDfAXDLKuREbE.lock"
      "tests/server-path.home/disfluid/server/path/g/pBBL3msK7bpJ_LUp4xDyrB-EZD1EaJgD6xo9ysqy6Q"
      "tests/server-path.home/disfluid/server/path/g/pBBL3msK7bpJ_LUp4xDyrB-EZD1EaJgD6xo9ysqy6Q.lock"
      "tests/server-path.home/disfluid/server/path/i/l7asoJjJEMhngUeSt4tHVu8Zxx4EFG_FDeJfL3-oPE"
      "tests/server-path.home/disfluid/server/path/i/l7asoJjJEMhngUeSt4tHVu8Zxx4EFG_FDeJfL3-oPE.lock"
      "tests/server-path.home/disfluid/server/path/Q/hRrKeOf3iJxfvabWz2CBYAlF_ovDFXqHWcwhhuQhXg"
      "tests/server-path.home/disfluid/server/path/Q/hRrKeOf3iJxfvabWz2CBYAlF_ovDFXqHWcwhhuQhXg.lock"
      ))
   (parameterize ((current-content-cache (make <content-cache>)))
     (let ((new
            (lambda ()
              (make <content>
                #:content-type 'text/plain
                #:static-content "Hello :)")))
           (new-acl
            (lambda ()
              (make <content>
                #:content-type 'text/turtle
                #:contained '()
                #:static-content
                "@prefix acl: <http://www.w3.org/ns/auth/acl#>.

<#authorized> a acl:Authorization;
  acl:accessTo <https://example.com/a/b/c>;
  acl:mode acl:Read;
  acl:agent <https://friend.example.com/profile/card#me>.
"))))
       ;; Create with parents:
       (update-path
        "/a/b/c"
        (lambda (main auxiliary)
          (when (or main auxiliary)
            (exit 1))
          (values (new) `((,(string->uri "http://www.w3.org/ns/auth/acl#accessControl") . ,(new-acl)))))
        #:create-intermediate-containers? #t)
       ;; So now, there should be a chain of directories:
       (receive (root root-aux)
           (read-path "/")
         (let ((root-children (contained root)))
           (unless (equal? root-children '("/a/"))
             (exit 2)))
         (unless (null? root-aux)
           (exit 3)))
       (receive (/a/ /a/-aux)
           (read-path "/a/")
         (unless (equal? (contained /a/) '("/a/b/"))
           (exit 4))
         (unless (null? /a/-aux)
           (exit 5)))
       (receive (/a/b/ /a/b/-aux)
           (read-path "/a/b/")
         (unless (equal? (contained /a/b/) '("/a/b/c"))
           (exit 6))
         (unless (null? /a/b/-aux)
           (exit 7)))
       (receive (/a/b/c /a/b/c-aux)
           (read-path "/a/b/c")
         (unless (equal? (content-type /a/b/c) 'text/plain)
           (exit 8))
         (unless (equal? (static-content /a/b/c)
                         (string->utf8 "Hello :)"))
           (exit 9)))
       ;; We can delete /a/b/c
       (update-path "/a/b/c" (lambda (main aux) #f))
       ;; Now /a/b/c does not exist
       (with-exception-handler
           (lambda (error)
             (unless (path-not-found? error)
               (exit 10)))
         (lambda ()
           (read-path "/a/b/c")
           (exit 11))
         #:unwind? #t
         #:unwind-for-type &path-not-found)
       ;; We can’t delete /a/ because there's /a/b/ in it
       (with-exception-handler
           (lambda (error)
             (unless (container-not-empty? error)
               (exit 12))
             (unless (equal? (container-not-empty-path error) "/a/")
               (exit 13)))
         (lambda ()
           (update-path "/a/" (lambda (main aux) #f))
           (exit 14))
         #:unwind? #t
         #:unwind-for-type &container-not-empty)
       ;; However, we can recreate /a/b/c without creating intermediate containers
       (update-path "/a/b/c"
                    (lambda (main aux)
                      (values (new)
                              `((,(string->uri
                                   "http://www.w3.org/ns/auth/acl#accessControl")
                                 . ,(new-acl)))))
                    #:create-intermediate-containers? #f)
       ;; Delete /a/b/c again
       (update-path "/a/b/c" (lambda (main aux) #f))
       ;; Delete /a/b/
       (update-path "/a/b/" (lambda (main aux) #f))
       ;; Delete /a/
       (update-path "/a/" (lambda (main aux) #f))
       ;; Cannot delete the root
       (with-exception-handler
           (lambda (error)
             (unless (cannot-delete-root? error)
               (exit 15)))
         (lambda ()
           (update-path "/" (lambda (main aux) #f))
           (exit 16))
         #:unwind? #t
         #:unwind-for-type &cannot-delete-root)
       ;; However, the root should be empty
       (receive (root root-aux)
           (read-path "/")
         (unless (null? (contained root))
           (exit 17)))))))