diff options
Diffstat (limited to 'src/scm/webid-oidc/server/read.scm')
| -rw-r--r-- | src/scm/webid-oidc/server/read.scm | 207 |
1 files changed, 207 insertions, 0 deletions
diff --git a/src/scm/webid-oidc/server/read.scm b/src/scm/webid-oidc/server/read.scm new file mode 100644 index 0000000..bff241a --- /dev/null +++ b/src/scm/webid-oidc/server/read.scm @@ -0,0 +1,207 @@ +(define-module (webid-oidc server read) + #:use-module (webid-oidc errors) + #:use-module (webid-oidc server resource path) + #:use-module (webid-oidc server resource content) + #:use-module (webid-oidc cache) + #:use-module (webid-oidc fetch) + #:use-module (webid-oidc http-link) + #:use-module (webid-oidc server resource wac) + #: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 (web client) + #:use-module (web response) + #:use-module (rdf rdf) + #:use-module (turtle tordf) + #:use-module (turtle fromrdf) + #: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 + + )) + +(define (check-mode server-name path owner user http-get expected-mode) + (let ((modes (wac-get-modes server-name path user #:http-get http-get))) + (define (check-modes modes) + (if (null? modes) + (raise-exception + (make-forbidden path user owner expected-mode)) + (or + (equal? (car modes) expected-mode) + (check-modes (cdr modes))))) + (check-modes modes))) + +(define (check-acl-can-read server-name path owner user http-get) + (check-mode server-name path owner user http-get + (string->uri "http://www.w3.org/ns/auth/acl#Read"))) + +(define (check-acl-can-control server-name path owner user http-get) + (check-mode server-name path owner user http-get + (string->uri "http://www.w3.org/ns/auth/acl#Control"))) + +(define* (read server-name owner user path + #:key + (http-get http-get)) + (declare-link-header!) + (with-session + (lambda (load-content-type load-contained load-static-content + do-create do-delete) + (let ((acl? (string-suffix? ".acl" path)) + (description? (string-suffix? ".meta" path)) + (base-path + (cond + ((string-suffix? ".acl" path) + (substring path 0 (- (string-length path) (string-length ".acl")))) + ((string-suffix? ".meta" path) + (substring path 0 (- (string-length path) (string-length ".meta")))) + (else path))) + (container? (string-suffix? path "/")) + (root? (equal? path "/"))) + (unless (equal? user owner) + (if acl? + (check-acl-can-control server-name base-path owner user http-get) + (check-acl-can-read server-name path owner user http-get))) + (receive (main-etag auxiliary) + (read-path base-path) + (let ((relevant-etag + (cond + (acl? + (assoc-ref auxiliary + (string->uri "http://www.w3.org/ns/auth/acl#accessControl"))) + (description? + (assoc-ref auxiliary + (string->uri "https://www.w3.org/ns/iana/link-relations/relation#describedby"))) + (else + main-etag))) + (non-rdf? (not (eq? (load-content-type main-etag) 'text/turtle))) + (auxiliary? (or acl? description?)) + (allow (cond (root? '(GET HEAD OPTIONS POST PUT)) + (container? '(GET HEAD OPTIONS POST PUT DELETE)) + (else '(GET HEAD OPTIONS PUT DELETE))))) + (unless relevant-etag + (raise-exception + (make-auxiliary-resource-absent + base-path + (cond + (acl? + (assoc-ref auxiliary + (string->uri "http://www.w3.org/ns/auth/acl#accessControl"))) + (description? + (assoc-ref auxiliary + (string->uri "https://www.w3.org/ns/iana/link-relations/relation#describedby"))))))) + (let ((description (and non-rdf? (string-append path ".meta"))) + (accept-put (if (or container? auxiliary?) "text/turtle" "*/*"))) + (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 (not acl?) + (cons + (build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path (string-append path ".acl")) + '((rel . "acl"))))) + (describedby + (and non-rdf? + (cons + (build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path (string-append path ".acl")) + '((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 (string-append path ".acl")) + '((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 + (fetch + (build-uri + 'https + #:userinfo (uri-userinfo server-name) + #:host (uri-host server-name) + #:port (uri-port server-name) + #:path path) + #:http-get + (lambda (uri . args) + (values + (build-response + #:headers `((content-type ,(load-content-type relevant-etag)))) + (load-static-content relevant-etag)))))) + (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)))))))))) |