;; 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 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 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 (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 ( create create-root )) (define (without-containment-triples doc-uri content-type content) (case content-type ((text/turtle) #t) (else (raise-exception (make-unsupported-media-type content-type)))) (let ((graph (fetch doc-uri #:http-get (lambda (uri . args) (values (build-response #:headers `((content-type ,content-type))) content))))) (with-index graph (lambda (rdf-match) (unless (null? (rdf-match (uri->string doc-uri) "http://www.w3.org/ns/auth/acl#contains" #f)) (raise-exception (make-incorrect-containment-triples (uri-path doc-uri)))))))) (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 #:key (http-get http-get)) (check-acl-can-append server-name container owner user #:http-get http-get) (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)) (raise-exception (make-path-is-auxiliary (uri-path doc-uri)))) (when container? (without-containment-triples doc-uri content-type content)) (with-session (lambda (load-content-type load-contained load-static-content do-create do-delete) (catch 'slug-already-exists (lambda () (update-path (uri-path doc-uri) (lambda (etag auxiliary) (when etag (throw 'slug-already-exists)) (values (do-create content-type (and container? '()) content) '())) load-content-type load-contained load-static-content do-create do-delete) doc-uri) (lambda error (create server-name owner user container types (string-append slug "-" (stubs:random 12)) content-type content #:http-get http-get)))))))) (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))) (with-session (lambda (load-content-type load-contained load-static-content do-create do-delete) (catch 'already-exists (lambda () (update-path "/" (lambda (etag auxiliary) (when etag (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 (do-create 'text/turtle '() "") (list (cons (string->uri "http://www.w3.org/ns/auth/acl#accessControl") (do-create 'text/turtle #f (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 "/")))))))))) load-content-type load-contained load-static-content do-create do-delete) #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 (etag auxiliary) (when etag (throw 'already-exists)) (values (do-create 'text/turtle #f (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 (cons (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)))) (do-create 'text/turtle #f (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))))))))) load-content-type load-contained load-static-content do-create do-delete #:create-intermediate-containers? #t)) (lambda error #f))))))