diff options
Diffstat (limited to 'src/scm/webid-oidc/server/resource/path.scm')
| -rw-r--r-- | src/scm/webid-oidc/server/resource/path.scm | 185 |
1 files changed, 185 insertions, 0 deletions
diff --git a/src/scm/webid-oidc/server/resource/path.scm b/src/scm/webid-oidc/server/resource/path.scm new file mode 100644 index 0000000..a637d60 --- /dev/null +++ b/src/scm/webid-oidc/server/resource/path.scm @@ -0,0 +1,185 @@ +(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 + + )) + +(define (default-dir) + (string-append (refresh:default-dir) "/server")) + +(define (hash-path path) + (let ((h (stubs:hash 'SHA-256 path)) + (dir (default-dir))) + (let ((first-char (substring h 0 1)) + (rest (substring h 1))) + (format #f "~a/path/~a/~a" dir first-char rest)))) + +(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 (string->uri (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)) + (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 + (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 (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 "")))) + (unless (eq? content-type 'text/turtle) + (raise-exception (make-not-a-container parent-path content-type))) + (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)))) |