;; disfluid, 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 create) #:use-module (webid-oidc errors) #:use-module (webid-oidc server resource path) #:use-module (webid-oidc server resource content) #:use-module (webid-oidc server read) #:use-module (webid-oidc cache) #:use-module (webid-oidc fetch) #:use-module (webid-oidc web-i18n) #:use-module (webid-oidc rdf-index) #: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 ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #: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) #:declarative? #t #:export ( &incorrect-containment-triples make-incorrect-containment-triples incorrect-containment-triples? incorrect-containment-triples-path &unsupported-media-type make-unsupported-media-type unsupported-media-type? unsupported-media-type-content-type create create-root )) (define-exception-type &incorrect-containment-triples &external-error make-incorrect-containment-triples incorrect-containment-triples? (path incorrect-containment-triples-path)) (define-exception-type &unsupported-media-type &external-error make-unsupported-media-type unsupported-media-type? (content-type unsupported-media-type-content-type)) (define (without-containment-triples doc-uri content-type content) (case content-type ((text/turtle) #t) (else (let ((final-message (format #f (G_ "only text/turtle is allowed for the target of a POST request, not ~s") content-type))) (raise-exception (make-exception (make-unsupported-media-type content-type) (make-exception-with-message final-message)))))) (let ((graph (parameterize ((p:anonymous-http-request (lambda* (uri . args) (values (build-response #:headers `((content-type ,content-type))) content)))) (fetch doc-uri)))) (with-index graph (lambda (rdf-match) (unless (null? (rdf-match (uri->string doc-uri) "http://www.w3.org/ns/auth/acl#contains" #f)) (let ((final-message (format #f (G_ "the created resource cannot have containment triples")))) (raise-exception (make-exception (make-incorrect-containment-triples (uri-path doc-uri)) (make-exception-with-message final-message))))))))) (define (types-indicate-container? types) (and (not (null? types)) (let ((next (car types))) (when (uri? next) (set! next (uri->string next))) (or (equal? next "http://www.w3.org/ns/ldp#BasicContainer") (types-indicate-container? (cdr types)))))) (define* (create server-name owner user container types slug content-type content) (parameterize ((current-content-cache (make ))) (check-acl-can-append server-name container owner user) (unless (and slug (not (equal? slug ""))) (set! slug (stubs:random 12))) (when (string-contains slug "/") (let ((i (string-contains slug "/"))) (set! slug (substring slug 0 i)))) (let ((container? (types-indicate-container? types))) (let ((doc-uri (build-uri (uri-scheme server-name) #:userinfo (uri-userinfo server-name) #:host (uri-host server-name) #:port (uri-port server-name) #:path (string-append "/" (encode-and-join-uri-path (append (split-and-decode-uri-path container) (list slug))) ;; There’s no risk to have // here, because slug is ;; non-empty. (if container? "/" ""))))) (when (auxiliary-path? (uri-path doc-uri)) (let ((final-message (format #f (G_ "cannot POST to an auxiliary resource path, ~s") (uri-path doc-uri)))) (raise-exception (make-exception (make-path-is-auxiliary (uri-path doc-uri)) (make-exception-with-message final-message))))) (when container? (without-containment-triples doc-uri content-type content)) (parameterize ((current-content-cache (make ))) (catch 'slug-already-exists (lambda () (update-path (uri-path doc-uri) (lambda (main auxiliary) (when main (throw 'slug-already-exists)) (values (make #:content-type content-type #:contained (and container? '()) #:static-content content) '()))) doc-uri) (lambda error (create server-name owner user container types (string-append slug "-" (stubs:random 12)) content-type content)))))))) (define (create-root server-name owner) (define (fix-angle-aux accu chars) (if (null? chars) (list->string (reverse accu)) (let ((next (car chars)) (rest (cdr chars))) (let ((next-accu (if (eqv? next #\>) (reverse (string->list "%3E")) (list next)))) (fix-angle-aux (append next-accu accu) rest))))) (define (fix-angle str) (fix-angle-aux '() (string->list str))) (parameterize ((current-content-cache (make ))) (catch 'already-exists (lambda () (update-path "/" (lambda (main auxiliary) (when main (throw 'already-exists)) (let ((root-uri (build-uri (uri-scheme server-name) #:userinfo (uri-userinfo server-name) #:host (uri-host server-name) #:port (uri-port server-name) #:path "/"))) (values (make #:content-type 'text/turtle #:contained '() #:static-content "") (list `(,(string->uri "http://www.w3.org/ns/auth/acl#accessControl") . ,(make #:content-type 'text/turtle #:static-content (format #f "@prefix acl: . <#default> a acl:Authorization; acl:accessTo <~a>; acl:agent <~a>; acl:mode acl:Read, acl:Write, acl:Control; acl:default <~a>. " (fix-angle (uri->string root-uri)) (fix-angle (uri->string owner)) (fix-angle (uri->string (build-uri (uri-scheme root-uri) #:userinfo (uri-userinfo root-uri) #:host (uri-host root-uri) #:port (uri-port root-uri) #:path "/"))))))))))) #t) (lambda error #f)) (when (and (equal? (uri-scheme server-name) (uri-scheme owner)) (equal? (uri-userinfo server-name) (uri-userinfo owner)) (equal? (uri-host server-name) (uri-host owner)) (equal? (uri-port server-name) (uri-port owner))) ;; We need to make sure that the profile exists (catch 'already-exists (lambda () (update-path (uri-path owner) (lambda (main auxiliary) (when main (throw 'already-exists)) (values (make #:content-type 'text/turtle #:static-content (format #f "@prefix foaf: . @prefix ldp: . <~a~a> a foaf:Person . " (if (uri-query owner) (string-append "?" (fix-angle (uri-encode (uri-query owner)))) "") (if (uri-fragment owner) (string-append "#" (fix-angle (uri-encode (uri-fragment owner)))) ""))) (list `(,(string->uri "http://www.w3.org/ns/auth/acl#accessControl") . ,(let ((doc-uri (build-uri (uri-scheme owner) #:userinfo (uri-userinfo owner) #:host (uri-host owner) #:port (uri-port owner) #:path (uri-path owner)))) (make #:content-type 'text/turtle #:static-content (format #f "@prefix acl: . @prefix foaf: . <#public> a acl:Authorization; acl:accessTo <~a>; acl:agentClass foaf:Agent; acl:mode acl:Read. <#default> a acl:Authorization; acl:accessTo <~a>; acl:agent <~a>; acl:mode acl:Read, acl:Write, acl:Control. " (fix-angle (uri->string doc-uri)) (fix-angle (uri->string doc-uri)) (fix-angle (uri->string owner))))))))) #:create-intermediate-containers? #t)) (lambda error #f)))))