;; 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 .
(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 #:etag main-etag)
(map
(match-lambda
(((= string->uri key) . etag)
`(,key . ,(make #: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? <> ) 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-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-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 "/"))