(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))))))))))