diff options
Diffstat (limited to 'src/scm/webid-oidc/server/resource/path.scm')
| -rw-r--r-- | src/scm/webid-oidc/server/resource/path.scm | 129 |
1 files changed, 65 insertions, 64 deletions
diff --git a/src/scm/webid-oidc/server/resource/path.scm b/src/scm/webid-oidc/server/resource/path.scm index b8a9472..667dd2f 100644 --- a/src/scm/webid-oidc/server/resource/path.scm +++ b/src/scm/webid-oidc/server/resource/path.scm @@ -19,6 +19,7 @@ #: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) @@ -30,7 +31,9 @@ #: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 @@ -167,16 +170,16 @@ (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)))))))))) + (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 content-type contained static-content create delete +(define* (update-path path f #:key (create-intermediate-containers? #f)) (let ((h (hash-path path)) (lock (lock-file-name path)) @@ -202,7 +205,7 @@ h lock (lambda (port) - (receive (etag auxiliary) + (receive (main auxiliary) (with-exception-handler (lambda (error) (unless (path-not-found? error) @@ -213,25 +216,21 @@ (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)) + (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 etag auxiliary)) - (case-lambda - ((false) - (when false - (fail (G_ "You’re using the API wrong."))) - ;; Delete the resource - (unless (or (not etag) - (not (contained etag)) - (null? (contained etag))) + (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) @@ -246,62 +245,64 @@ (format #f (G_ "you cannot delete the root")))))) (set! has-been-deleted? #t) #f) - ((new-etag new-auxiliary) - (unless (and (string? new-etag) (list? new-auxiliary)) - (fail (G_ "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) + (((? (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)))))) + #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 (etag auxiliary) + (lambda (main auxiliary) ;; Add path as a child of the resource at etag (unless create-intermediate-containers? - (unless etag + (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 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 + (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 (etag auxiliary) - (unless etag + (lambda (main auxiliary) + (unless main (raise-exception (make-path-not-found parent-path))) - (let ((content-type (content-type etag)) - (all-children (contained etag)) - (static-content (static-content etag))) + (let ((content-type (content-type main)) + (all-children (contained main)) + (static-content (static-content main))) (values - (create content-type - (filter (lambda (x) - (not (equal? x path))) - all-children) - static-content) + (make <content> + #:content-type content-type + #:contained + (filter (lambda (x) (not (equal? x path))) all-children) + #:static-content 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)))) + delete-content + (hash-map->list (lambda (garbage _) garbage) garbage)))) (define (base-path path) (define (check-suffix suffix type) |