;; webid-oidc, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU Affero General Public License as ;; published by the Free Software Foundation, either version 3 of the ;; License, or (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU Affero General Public License for more details. ;; You should have received a copy of the GNU Affero General Public License ;; along with this program. If not, see . (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* (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) (check-acl-can-read server-name path owner user #:http-get http-get) (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 (raise-exception (make-auxiliary-resource-absent base-path path-type))) (let ((accept-put (if (or container? path-type) "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 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 (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)))))))))))