;; webid-oidc, 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 cache)
  #:use-module (webid-oidc fetch)
  #:use-module (webid-oidc http-link)
  #: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 (web uri)
  #:use-module (web client)
  #: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 (rnrs bytevectors)
  #:use-module (oop goops)
  #:export
  (

   update

   ))

(define (remove-containment-triples doc-uri content-type content)
  (case content-type
    ((text/turtle)
     #t)
    (else
     (raise-exception (make-unsupported-media-type content-type))))
  (let ((graph (fetch
                doc-uri
                #:http-get
                (lambda (uri . args)
                  (values
                   (build-response #:headers `((content-type ,content-type)))
                   content)))))
    (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
                 #:key
                 (http-get http-get))
  (define updated-etag #f)
  (with-session
   (lambda (load-content-type load-contained load-static-content
                              do-create do-delete)
     (receive (base-path path-type)
         (base-path path)
       (update-path
        base-path
        (lambda (main-etag auxiliary)
          (let ((relevant-etag
                 (if path-type
                     (assoc-ref auxiliary path-type)
                     main-etag)))
            (if relevant-etag
                ;; 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 relevant-etag)
            (set! updated-etag
                  (do-create content-type
                             (if relevant-etag
                                 (load-contained relevant-etag)
                                 (if (container-path? path)
                                     '()
                                     #f))
                             (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-etag
                   (if path-type
                       main-etag
                       updated-etag))
                  (new-auxiliary
                   (if path-type
                       (cons
                        `(,path-type . ,updated-etag)
                        (filter
                         (lambda (auxiliary)
                           (let ((needs-description? (not (eq? content-type 'text/turtle)))
                                 (is-describedby?
                                  (equal?
                                   (car auxiliary)
                                   (string->uri
                                    "https://www.w3.org/ns/iana/link-relations/relation#describedby")))
                                 (is-path-type?
                                  (equal? (car auxiliary) path-type)))
                             (and (not is-path-type?)
                                  (or (not is-describedby?) needs-description?))))
                         (or auxiliary '())))
                       (if (eq? content-type 'text/turtle)
                           (or auxiliary '())
                           (cons
                            `(,(string->uri
                                "https://www.w3.org/ns/iana/link-relations/relation#describedby")
                              . ,(do-create 'text/turtle #f ""))
                            (or auxiliary '()))))))
              (unless new-main-etag
                ;; Trying to update an auxiliary resource for a
                ;; resource that does not exist
                (set! new-main-etag
                      (do-create 'text/turtle
                                 (if (container-path? path)
                                     '()
                                     #f)
                                 "")))
              (values new-main-etag new-auxiliary))))
        load-content-type load-contained load-static-content do-create do-delete
        #:create-intermediate-containers? #t))))
  updated-etag)