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

;; 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 resource path)
  #:use-module (webid-oidc errors)
  #: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 (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 (rnrs bytevectors)
  #:use-module (oop goops)
  #:export
  (

   read-path
   update-path

   base-path

   derive-path

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

   ))

(define (default-dir)
  (string-append (refresh:default-dir) "/server"))

(define (hash-path/lock path)
  (let ((h (stubs:hash 'SHA-256 path))
        (dir (default-dir)))
    (let ((first-char (substring h 0 1))
          (rest (substring h 1)))
      (values
       (format #f "~a/path/~a/~a" dir first-char rest)
       (format #f "~a/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
                (raise-exception
                 (make-exception
                  (make-path-not-found path)
                  (make-uri-slash-semantics-error path with-slash))))
               (without-slash-exists
                (raise-exception
                 (make-exception
                  (make-path-not-found path)
                  (make-uri-slash-semantics-error path with-slash))))
               (else
                (raise-exception (make-path-not-found path)))))))
      (lambda ()
        (call-with-input-file h
          (lambda (port)
            (let ((main-etag (read port)))
              (let ((auxiliary (read port)))
                (values main-etag
                        (map (lambda (cell)
                               (let ((key (string->uri (car cell)))
                                     (value (cdr cell)))
                                 (cons key value)))
                             auxiliary))))))))))

(define* (update-path path f content-type contained static-content create delete
                      #: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 (etag 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 etag
           (hash-set! garbage etag #t))
         (when auxiliary
           (for-each
            (lambda (cell)
              (when (cdr cell)
                (hash-set! garbage (cdr cell) #t)))
            auxiliary))
         (call-with-values
             (lambda ()
               (f etag auxiliary))
           (case-lambda
             ((false)
              (when false
                (error "You’re using the API wrong."))
              ;; Delete the resource
              (unless (or (not etag)
                          (not (contained etag))
                          (null? (contained etag)))
                (raise-exception (make-container-not-empty path)))
              (when (equal? path "/")
                (raise-exception (make-cannot-delete-root)))
              (set! has-been-deleted? #t)
              #f)
             ((new-etag new-auxiliary)
              (unless (and (string? new-etag) (list? new-auxiliary))
                (error "You’re using the API wrong."))
              (hash-remove! garbage new-etag)
              (when new-auxiliary
                (for-each
                 (lambda (cell)
                   (hash-remove! garbage (cdr cell)))
                 new-auxiliary))
              (write new-etag port)
              (write (map (lambda (cell)
                            (cons (uri->string (car cell))
                                  (cdr cell)))
                          new-auxiliary)
                     port)
              #t))))))
    (when (and parent-path has-been-created? (not has-been-deleted?))
      (update-path
       parent-path
       (lambda (etag auxiliary)
         ;; Add path as a child of the resource at etag
         (unless create-intermediate-containers?
           (unless etag
             ;; Typically, POST to a non-existing path
             (raise-exception (make-path-not-found parent-path))))
         (unless auxiliary
           (set! auxiliary '()))
         (let ((content-type (if etag (content-type etag) 'text/turtle))
               (other-children (if etag (contained etag) '()))
               (static-content (if etag (static-content etag) (string->utf8 ""))))
           (let ((new-etag
                  (create content-type (cons path other-children) static-content)))
             (values new-etag auxiliary))))
       content-type contained static-content create delete
       #:create-intermediate-containers? create-intermediate-containers?))
    (when (and parent-path has-been-deleted? (not has-been-created?))
      (update-path
       parent-path
       (lambda (etag auxiliary)
         (unless etag
           (raise-exception (make-path-not-found parent-path)))
         (let ((content-type (content-type etag))
               (all-children (contained etag))
               (static-content (static-content etag)))
           (values
            (create content-type
                    (filter (lambda (x)
                              (not (equal? x path)))
                            all-children)
                    static-content)
            auxiliary)))
       content-type contained static-content create delete
       #:create-intermediate-containers? create-intermediate-containers?))
    (for-each
     delete
     (hash-map->list (lambda (garbage false) 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 "/"))