(use-modules (webid-oidc server create)
             (webid-oidc server read)
             (webid-oidc server resource content)
             (webid-oidc server resource path)
             (webid-oidc errors)
             (webid-oidc testing)
             (webid-oidc fetch)
             (webid-oidc rdf-index)
             (web http)
             (web request)
             (web response)
             (web uri)
             (ice-9 receive)
             (rnrs bytevectors))

(with-test-environment
 "crud"
 (lambda ()
   (for-each
    (lambda (f)
      (false-if-exception
       (delete-file
        (string-append
         "tests/crud.home/webid-oidc/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"))
   (for-each
    (lambda (f)
      (false-if-exception
       (delete-file
        (string-append
         "tests/crud.home/webid-oidc/server/path/"
         f))))  
    '("L/uhr1159jdGYjIj_tpM6FDiW4rUZDQQKUnT35lhAR-s"
      "8/jgewChguz6YRPCTBOkx_9CW94iH_X88rP6Os4aM8jg"
      "n/PQ_3L8lXCsqpz1tkUhsJnVC9rcyqgDD41DnFPIDG1Q"
      "i/l7asoJjJEMhngUeSt4tHVu8Zxx4EFG_FDeJfL3-oPE"))
   (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) (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
       ;; - 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)))
         (unless (equal? (assoc-ref links (string->uri "http://www.w3.org/ns/ldp#BasicContainer"))
                         '((rel . "type")))
           (exit 6))
         (unless (equal? (assoc-ref links (string->uri "https://example.com/.acl"))
                         '((rel . "acl")))
           (exit 7))
         (unless (equal? (assoc-ref links (string->uri "http://www.w3.org/ns/pim/space#Storage"))
                         '((rel . "type")))
           (exit 8))
         (unless (equal? (assoc-ref links owner)
                         '((rel . "http://www.w3.org/ns/solid/terms#owner")))
           (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")
           (exit 12))
         (unless (equal? content-type '(text/turtle))
           (exit 13))
         (unless (string? (car etag))
           (exit 14))
         (when (cdr etag)
           (exit 15))
         (with-index
          (fetch "https://example.com/"
                 #:http-get
                 (lambda (uri . rest)
                   (values
                    (build-response #:headers `((content-type . ,content-type)))
                    root)))
          (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) (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")
           (exit 19))
         (unless (equal? content-type '(text/turtle))
           (exit 20))
         (unless (string? (car etag))
           (exit 21))
         (when (cdr etag)
           (exit 22))
         (with-index
          (fetch "https://example.com/.acl"
                 #:http-get
                 (lambda (uri . rest)
                   (values
                    (build-response #:headers `((content-type . ,content-type)))
                    /.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)))))))))