diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/scm/webid-oidc/errors.scm | 17 | ||||
| -rw-r--r-- | src/scm/webid-oidc/server/Makefile.am | 6 | ||||
| -rw-r--r-- | src/scm/webid-oidc/server/read.scm | 207 |
3 files changed, 228 insertions, 2 deletions
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index 76ce8af..80a4f37 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -885,6 +885,20 @@ path-not-found-path) (define-exception-type + &auxiliary-resource-absent + &external-error + make-auxiliary-resource-absent + auxiliary-resource-absent? + (path auxiliary-resource-absent-path) + (kind auxiliary-resource-absent-kind)) + +(export &auxiliary-resource-absent + make-auxiliary-resource-absent + auxiliary-resource-absent? + auxiliary-resource-absent-path + auxiliary-resource-absent-kind) + +(define-exception-type &uri-slash-semantics-error &external-error make-uri-slash-semantics-error @@ -1336,6 +1350,9 @@ ((&path-not-found) (format #f (G_ "no resource has been found to serve URI path ~s") (get 'path))) + ((&auxiliary-resource-absent) + (format #f (G_ "the resource kind ~s is absent for the resource at ~s") + (get 'kind') (get 'path))) ((&uri-slash-semantics-error) (format #f (G_ "no resource has been found to serve URI path ~s, but ~s exists") (get 'path) (get 'expected-path))) diff --git a/src/scm/webid-oidc/server/Makefile.am b/src/scm/webid-oidc/server/Makefile.am index 12dad08..2f14df5 100644 --- a/src/scm/webid-oidc/server/Makefile.am +++ b/src/scm/webid-oidc/server/Makefile.am @@ -1,7 +1,9 @@ dist_serverwebidoidcmod_DATA += \ - %reldir%/create.scm + %reldir%/create.scm \ + %reldir%/read.scm serverwebidoidcgo_DATA += \ - %reldir%/create.go + %reldir%/create.go \ + %reldir%/read.go include %reldir%/resource/Makefile.am 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)))))))))) |