diff options
Diffstat (limited to 'src/scm/webid-oidc/server/read.scm')
| -rw-r--r-- | src/scm/webid-oidc/server/read.scm | 301 |
1 files changed, 147 insertions, 154 deletions
diff --git a/src/scm/webid-oidc/server/read.scm b/src/scm/webid-oidc/server/read.scm index 0cd49fd..73d32e3 100644 --- a/src/scm/webid-oidc/server/read.scm +++ b/src/scm/webid-oidc/server/read.scm @@ -65,157 +65,150 @@ (define* (read server-name owner user path) (declare-link-header!) - (with-session - (lambda (load-content-type load-contained load-static-content - do-create do-delete) - (check-acl-can-read server-name path owner user) - (receive (base-path path-type) - (base-path path) - (let ((container? (container-path? path)) - (root? (root-path? path)) - (acl? - (equal? path-type - (string->uri - "http://www.w3.org/ns/auth/acl#accessControl"))) - (description? - (equal? - path-type - (string->uri - "https://www.w3.org/ns/iana/link-relations/relation#describedby")))) - (receive (main-etag auxiliary) - (read-path base-path) - (let ((relevant-etag - (if path-type - (assoc-ref auxiliary path-type) - main-etag)) - (needs-meta? - (case (load-content-type main-etag) - ((text/turtle) - #f) - (else #t))) - (needs-acl? - (not acl?)) - (allow (cond (root? '(GET HEAD OPTIONS POST PUT)) - (container? '(GET HEAD OPTIONS POST PUT DELETE)) - (else '(GET HEAD OPTIONS PUT DELETE))))) - (unless relevant-etag - (let ((final-message - (format #f (G_ "the auxiliary resource of type ~s at ~s is absent") - (uri->string path-type) - (uri->string base-path)))) - (raise-exception - (make-exception - (make-auxiliary-resource-absent base-path path-type) - (make-exception-with-message final-message))))) - (let ((accept-put (if (or container? path-type) - "text/turtle; application/n-quads; application/ld+json" - "*/*"))) - (values - ;; Headers - (let ((links - (let ((type - (cons - (if container? - (string->uri "http://www.w3.org/ns/ldp#BasicContainer") - (string->uri "http://www.w3.org/ns/ldp#Resource")) - '((rel . "type")))) - (acl - (and needs-acl? - (cons - (build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path (derive-path - base-path - (string->uri - "http://www.w3.org/ns/auth/acl#accessControl"))) - '((rel . "acl"))))) - (describedby - (and needs-meta? - (cons - (build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path (derive-path - base-path - (string->uri - "https://www.w3.org/ns/iana/link-relations/relation#describedby"))) - '((rel . "describedby"))))) - (describes - (and description? - (cons - (build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path base-path) - '((rel . "https://www.w3.org/ns/iana/link-relations/relation#describes"))))) - (storage - (and root? - (list - (list - (string->uri "http://www.w3.org/ns/pim/space#Storage") - '(rel . "type")) - (list - owner - '(rel . "http://www.w3.org/ns/solid/terms#owner")))))) - (append - (list type) - (if acl (list acl) '()) - (if describedby (list describedby) '()) - (if describes (list describes) '()) - (or storage '()))))) - `((link . ,links) - (allow . ,allow) - (accept-put . ,accept-put) - (content-type - . (,(if container? - 'text/turtle - (load-content-type relevant-etag)))) - (etag . (,relevant-etag . #f)))) - ;; Content - (if container? - (let ((static-graph - (parameterize - ((p:anonymous-http-request - (lambda (uri . args) - (values - (build-response - #:headers `((content-type ,(load-content-type relevant-etag)))) - (load-static-content relevant-etag))))) - (fetch - (build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path path))))) - (let ((final-graph - (reverse - (append - (map (lambda (contained-path) - (make-rdf-triple - (uri->string - (build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path path)) - "http://www.w3.org/ns/ldp#contains" - (uri->string - (build-uri - 'https - #:userinfo (uri-userinfo server-name) - #:host (uri-host server-name) - #:port (uri-port server-name) - #:path contained-path)))) - (load-contained relevant-etag)) - static-graph)))) - (rdf->turtle final-graph))) - (load-static-content relevant-etag))))))))))) + (parameterize ((current-content-cache (make <content-cache>))) + (check-acl-can-read server-name path owner user) + (receive (base-path path-type) + (base-path path) + (let ((container? (container-path? path)) + (root? (root-path? path)) + (acl? + (equal? path-type + (string->uri + "http://www.w3.org/ns/auth/acl#accessControl"))) + (description? + (equal? + path-type + (string->uri + "https://www.w3.org/ns/iana/link-relations/relation#describedby")))) + (receive (main auxiliary) + (read-path base-path) + (let ((relevant + (if path-type + (assoc-ref auxiliary path-type) + main)) + (needs-meta? + (case (content-type main) + ((text/turtle) + #f) + (else #t))) + (needs-acl? + (not acl?)) + (allow (cond (root? '(GET HEAD OPTIONS POST PUT)) + (container? '(GET HEAD OPTIONS POST PUT DELETE)) + (else '(GET HEAD OPTIONS PUT DELETE))))) + (unless relevant + (let ((final-message + (format #f (G_ "the auxiliary resource of type ~s at ~s is absent") + (uri->string path-type) + (uri->string base-path)))) + (raise-exception + (make-exception + (make-auxiliary-resource-absent base-path path-type) + (make-exception-with-message final-message))))) + (let ((accept-put (if (or container? path-type) + "text/turtle; application/n-quads; application/ld+json" + "*/*"))) + (values + ;; Headers + (let ((links + (let ((type + `(,(string->uri + (string-append "http://www.w3.org/ns/ldp#" + (if container? + "BasicContainer" + "Resource"))) + (rel . "type"))) + (acl + (and needs-acl? + `(,(build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path (derive-path + base-path + (string->uri + "http://www.w3.org/ns/auth/acl#accessControl"))) + (rel . "acl")))) + (describedby + (and needs-meta? + `(,(build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path (derive-path + base-path + (string->uri + "https://www.w3.org/ns/iana/link-relations/relation#describedby"))) + (rel . "describedby")))) + (describes + (and needs-meta? + `(,(build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path base-path) + (rel . "https://www.w3.org/ns/iana/link-relations/relation#describes")))) + (storage + (and root? + `((,(string->uri "http://www.w3.org/ns/pim/space#Storage") + (rel . "type")) + (,owner + (rel . "http://www.w3.org/ns/solid/terms#owner")))))) + (append + (list type) + (if acl (list acl) '()) + (if describedby (list describedby) '()) + (if describes (list describes) '()) + (or storage '()))))) + `((link . ,links) + (allow . ,allow) + (accept-put . ,accept-put) + (content-type + . (,(if container? + 'text/turtle + (content-type relevant)))) + (etag . (,(etag relevant) . #f)))) + ;; Content + (if container? + (let ((static-graph + (parameterize + ((p:anonymous-http-request + (lambda (uri . args) + (values + (build-response + #:headers `((content-type ,(content-type relevant)))) + (static-content relevant))))) + (fetch + (build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path path))))) + (let ((final-graph + (reverse + (append + (map (lambda (contained-path) + (make-rdf-triple + (uri->string + (build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path path)) + "http://www.w3.org/ns/ldp#contains" + (uri->string + (build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path contained-path)))) + (contained relevant)) + static-graph)))) + (rdf->turtle final-graph))) + (static-content relevant)))))))))) |