path: root/src/scm/webid-oidc/server/resource/path.scm

;; 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 resource path)
  #:use-module (webid-oidc errors)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #:use-module (webid-oidc rdf-index)
  #:use-module (webid-oidc web-i18n)
  #:use-module (webid-oidc server resource content)
  #:use-module ((webid-oidc refresh-token) #:prefix refresh:)
  #:use-module ((webid-oidc parameters) #:prefix p:)
  #:use-module (web uri)
  #: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 match)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-26)
  #:use-module (oop goops)
  #:declarative? #t
  #:export
  (

   &path-not-found
   make-path-not-found
   path-not-found?
   path-not-found-path

   &uri-slash-semantics-error
   make-uri-slash-semantics-error
   uri-slash-semantics-error?
   uri-slash-semantics-error-requested
   uri-slash-semantics-error-existing

   &container-not-empty
   make-container-not-empty
   container-not-empty?
   container-not-empty-path

   &cannot-delete-root
   make-cannot-delete-root
   cannot-delete-root?

   &path-is-auxiliary
   make-path-is-auxiliary
   path-is-auxiliary?
   path-is-auxiliary-path

   read-path
   update-path

   base-path

   derive-path

   auxiliary-path?
   acl-path?
   container-path?
   root-path?

   ))

(define-exception-type
  &path-not-found
  &external-error
  make-path-not-found
  path-not-found?
  (path path-not-found-path))

(define-exception-type
  &uri-slash-semantics-error
  &external-error
  make-uri-slash-semantics-error
  uri-slash-semantics-error?
  (requested uri-slash-semantics-error-requested)
  (existing uri-slash-semantics-error-existing))

(define-exception-type
  &container-not-empty
  &external-error
  make-container-not-empty
  container-not-empty?
  (path container-not-empty-path))

(define-exception-type
  &cannot-delete-root
  &external-error
  make-cannot-delete-root
  cannot-delete-root?)

(define-exception-type
  &path-is-auxiliary
  &external-error
  make-path-is-auxiliary
  path-is-auxiliary?
  (path path-is-auxiliary-path))

(define (hash-path/lock path)
  (let ((h (stubs:hash 'SHA-256 path))
        (dir (p:data-home)))
    (let ((first-char (substring h 0 1))
          (rest (substring h 1)))
      (values
       (format #f "~a/server/path/~a/~a" dir first-char rest)
       (format #f "~a/server/path/~a/.lock" dir first-char)))))

(define (hash-path path)
  (receive (h lock) (hash-path/lock path)
    h))

(define (lock-file-name path)
  (receive (h lock) (hash-path/lock path)
    lock))

(define (read-path path)
  (let ((h (hash-path path)))
    (with-exception-handler
        (lambda (error)
          (let ((with-slash (string-append path "/"))
                (without-slash
                 (if (string-suffix? "/" path)
                     (substring path 0 (- (string-length path) (string-length "/")))
                     path)))
            (let ((with-slash-exists (file-exists? (hash-path with-slash)))
                  (without-slash-exists (file-exists? (hash-path without-slash))))
              (cond
               (with-slash-exists
                (let ((final-message
                       (format #f (G_ "incorrect slash semantics: path ~s should have a slash")
                               path)))
                  (raise-exception
                   (make-exception
                    (make-path-not-found path)
                    (make-uri-slash-semantics-error path with-slash)
                    (make-exception-with-message final-message)))))
               (without-slash-exists
                (let ((final-message
                       (format #f (G_ "incorrect slash semantics: path ~s should not have a slash")
                               path)))
                  (raise-exception
                   (make-exception
                    (make-path-not-found path)
                    (make-uri-slash-semantics-error path without-slash)
                    (make-exception-with-message final-message)))))
               (else
                (let ((final-message
                       (format #f (G_ "path ~s does not exist") path)))
                  (raise-exception
                   (make-exception
                    (make-path-not-found path)
                    (make-exception-with-message final-message)))))))))
      (lambda ()
        (call-with-input-file h
          (lambda (port)
            (let* ((main-etag (read port))
                   (auxiliary (read port)))
              (values (make <content> #:etag main-etag)
                      (map
                       (match-lambda
                         (((= string->uri key) . etag)
                          `(,key . ,(make <content> #:etag etag))))
                       auxiliary)))))))))

(define* (update-path path f
                      #:key (create-intermediate-containers? #f))
  (let ((h (hash-path path))
        (lock (lock-file-name path))
        (garbage (make-hash-table))
        (has-been-created? #f)
        (has-been-deleted? #f)
        (parent-path
         (let ((components (split-and-decode-uri-path path)))
           (cond
            ((null? components)
             #f)
            ((null? (cdr components))
             "/")
            (else
             (string-append
              "/"
              (encode-and-join-uri-path
               (reverse
                (cdr
                 (reverse components))))
              "/"))))))
    (stubs:atomically-update-file
     h
     lock
     (lambda (port)
       (receive (main auxiliary)
           (with-exception-handler
               (lambda (error)
                 (unless (path-not-found? error)
                   (raise-exception error))
                 (set! has-been-created? #t)
                 (values #f #f))
             (lambda ()
               (read-path path))
             #:unwind? #t
             #:unwind-for-type &path-not-found)
         (when main
           (hash-set! garbage (etag main) #t))
         (for-each
          (match-lambda
            ((_ . content)
             (hash-set! garbage (etag content) #t)))
          (or auxiliary '()))
         (call-with-values
             (lambda ()
               (f main auxiliary))
           (match-lambda*
             ((#f)
              (unless (or (not main)
                          (not (contained main))
                          (null? (contained main)))
                (raise-exception
                 (make-exception
                  (make-container-not-empty path)
                  (make-exception-with-message
                   (format #f (G_ "the path ~s exists, it has contained paths, and it is not empty")
                           path)))))
              (when (equal? path "/")
                (raise-exception
                 (make-exception
                  (make-cannot-delete-root)
                  (make-exception-with-message
                   (format #f (G_ "you cannot delete the root"))))))
              (set! has-been-deleted? #t)
              #f)
             (((? (cute is-a? <> <content>) new-main)
               new-auxiliary)
              (hash-remove! garbage (etag new-main))
              (for-each
               (match-lambda
                 ((_ . content)
                  (hash-remove! garbage (etag content))))
               (or new-auxiliary '()))
              (write (etag new-main) port)
              (write (map (match-lambda
                            (((= uri->string key) . (= etag etag))
                             `(,key . ,etag)))
                          (or new-auxiliary '()))
                     port)
              #t)
             (else
              (fail (G_ "you must return either #f to delete the path, or a new main content and alist from URI types to auxiliary content"))))))))
    (when (and parent-path has-been-created? (not has-been-deleted?))
      (update-path
       parent-path
       (lambda (main auxiliary)
         ;; Add path as a child of the resource at etag
         (unless create-intermediate-containers?
           (unless main
             ;; Typically, POST to a non-existing path
             (raise-exception (make-path-not-found parent-path))))
         (unless auxiliary
           (set! auxiliary '()))
         (let ((content-type (if main (content-type main) 'text/turtle))
               (other-children (if main (contained main) '()))
               (static-content (if main (static-content main) (string->utf8 ""))))
           (let ((new-content
                  (make <content>
                    #:content-type content-type
                    #:contained (cons path other-children)
                    #:static-content static-content)))
             (values new-content auxiliary))))
       #:create-intermediate-containers? create-intermediate-containers?))
    (when (and parent-path has-been-deleted? (not has-been-created?))
      (update-path
       parent-path
       (lambda (main auxiliary)
         (unless main
           (raise-exception (make-path-not-found parent-path)))
         (let ((content-type (content-type main))
               (all-children (contained main))
               (static-content (static-content main)))
           (values
            (make <content>
              #:content-type content-type
              #:contained
              (filter (lambda (x) (not (equal? x path))) all-children)
              #:static-content static-content)
            auxiliary)))
       #:create-intermediate-containers? create-intermediate-containers?))
    (for-each
     delete-content
     (hash-map->list (lambda (garbage _) garbage) garbage))))

(define (base-path path)
  (define (check-suffix suffix type)
    (let ((total-length (string-length path))
          (suffix-length (string-length suffix)))
      (if (string-suffix? suffix path)
          (values
           (substring path 0 (- total-length suffix-length))
           type)
          (values #f #f))))
  (define (all-checks candidates)
    (if (null? candidates)
        (values path #f)
        (receive (base type)
            (check-suffix (caar candidates) (cdar candidates))
          (if base
              (values base type)
              (all-checks (cdr candidates))))))
  (all-checks
   `((".acl"
      . ,(string->uri "http://www.w3.org/ns/auth/acl#accessControl"))
     (".meta"
      . ,(string->uri "https://www.w3.org/ns/iana/link-relations/relation#describedby")))))

(define (derive-path path type)
  (receive (base base-type)
      (base-path path)
    (cond
     ((equal? type (string->uri "http://www.w3.org/ns/auth/acl#accessControl"))
      (string-append base ".acl"))
     ((equal? type (string->uri "https://www.w3.org/ns/iana/link-relations/relation#describedby"))
      (string-append base ".meta")))))

(define (auxiliary-path? path)
  (receive (base type)
      (base-path path)
    (values type base)))

(define (acl-path? path)
  (receive (base type)
      (base-path path)
    (and type
         (equal? type (string->uri "http://www.w3.org/ns/auth/acl#accessControl")))))

(define (container-path? path)
  (string-suffix? "/" path))

(define (root-path? path)
  (equal? path "/"))