;; 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 server update)
  #:use-module (webid-oidc errors)
  #:use-module (webid-oidc server resource path)
  #:use-module (webid-oidc server resource content)
  #:use-module (webid-oidc server precondition)
  #:use-module (webid-oidc server create) ;; for &unsupported-media-type
  #:use-module (webid-oidc cache)
  #:use-module (webid-oidc fetch)
  #:use-module (webid-oidc server resource wac)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module (webid-oidc rdf-index)
  #:use-module ((webid-oidc refresh-token) #:prefix refresh:)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module (web uri)
  #:use-module (web response)
  #:use-module (rdf rdf)
  #:use-module (turtle tordf)
  #:use-module (turtle fromrdf)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 iconv)
  #:use-module (ice-9 textual-ports)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 hash-table)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (oop goops)
  #:declarative? #t
  #:export
  (

   update

   ))

(define (remove-containment-triples doc-uri content-type content)
  (case content-type
    ((text/turtle)
     #t)
    (else
     (raise-exception
      (make-exception
       (make-unsupported-media-type content-type)))))
  (let ((graph
         (parameterize
             ((p:anonymous-http-request
               (lambda (uri . args)
                 (values
                  (build-response #:headers `((content-type ,content-type)))
                  content))))
           (fetch doc-uri))))
    (with-index
     graph
     (lambda (rdf-match)
       (let ((containment-triples
              (rdf-match (uri->string doc-uri)
                         "http://www.w3.org/ns/auth/acl#contains"
                         #f)))
         (let ((blacklist
                (alist->hash-table
                 (map (lambda (t)
                        (cons t #t))
                      containment-triples))))
           (let ((not-blacklisted?
                  (lambda (t)
                    (not
                     (hash-ref blacklist t #f)))))
             (let ((final-graph
                    (filter not-blacklisted? graph)))
               (if (null? containment-triples)
                   content
                   (rdf->turtle final-graph))))))))))

(define* (update server-name owner user path if-match if-none-match
                 content-type content)
  (define updated #f)
  (parameterize ((current-content-cache (make <content-cache>)))
    (receive (base-path path-type)
        (base-path path)
      (update-path
       base-path
       (lambda (main auxiliary)
         (let ((relevant
                (if path-type
                    (assoc-ref auxiliary path-type)
                    main)))
           (if relevant
               ;; The resource exists, so we need write permission
               (check-acl-can-write server-name path owner user)
               ;; The resource does not exist yet, so we only need
               ;; append permission
               (check-acl-can-append server-name path owner user))
           (check-precondition path if-match if-none-match (and relevant (etag relevant)))
           (set! updated
                 (make <content>
                   #:content-type content-type
                   #:contained
                   (if relevant
                       (contained relevant)
                       (if (container-path? path)
                           '()
                           #f))
                   #:static-content
                   (if (container-path? path)
                       (remove-containment-triples
                        (build-uri (uri-scheme server-name)
                                   #:userinfo (uri-userinfo server-name)
                                   #:host (uri-host server-name)
                                   #:port (uri-port server-name)
                                   #:path path)
                        content-type content)
                       content)))
           (let ((new-main
                  (if path-type main updated))
                 (new-auxiliary
                  (if path-type
                      `((,path-type . ,updated)
                        ,@(filter
                           (match-lambda
                             ((type . content)
                              (let ((needs-description? (not (eq? content-type 'text/turtle)))
                                    (is-describedby?
                                     (equal?
                                      type
                                      (string->uri
                                       "https://www.w3.org/ns/iana/link-relations/relation#describedby")))
                                    (is-path-type?
                                     (equal? type path-type)))
                                (and (not is-path-type?)
                                     (or (not is-describedby?) needs-description?)))))
                           (or auxiliary '())))
                      (if (eq? content-type 'text/turtle)
                          (or auxiliary '())
                          `((,(string->uri
                               "https://www.w3.org/ns/iana/link-relations/relation#describedby")
                             . ,(make <content>
                                  #:content-type 'text/turtle
                                  #:static-content ""))
                            ,@(or auxiliary '()))))))
             (unless new-main
               ;; Trying to update an auxiliary resource for a
               ;; resource that does not exist
               (set! new-main
                     (make <content>
                       #:content-type 'text/turtle
                       #:contained (and (container-path? path) '())
                       #:statitc-content "")))
             (values new-main new-auxiliary))))
       #:create-intermediate-containers? #t)))
  updated)