diff options
Diffstat (limited to 'src/scm/webid-oidc/server/create.scm')
| -rw-r--r-- | src/scm/webid-oidc/server/create.scm | 279 |
1 files changed, 141 insertions, 138 deletions
diff --git a/src/scm/webid-oidc/server/create.scm b/src/scm/webid-oidc/server/create.scm index 0558ff3..6c2a619 100644 --- a/src/scm/webid-oidc/server/create.scm +++ b/src/scm/webid-oidc/server/create.scm @@ -119,58 +119,58 @@ (types-indicate-container? (cdr types)))))) (define* (create server-name owner user container types slug content-type content) - (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)) - (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)))))))) + (parameterize ((current-content-cache (make <content-cache>))) + (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 <content-cache>))) + (catch 'slug-already-exists + (lambda () + (update-path + (uri-path doc-uri) + (lambda (main auxiliary) + (when main + (throw 'slug-already-exists)) + (values + (make <content> + #: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) @@ -185,29 +185,32 @@ (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: <http://www.w3.org/ns/auth/acl#> . + (parameterize ((current-content-cache (make <content-cache>))) + (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> + #:content-type 'text/turtle + #:contained '() + #:static-content "") + (list + `(,(string->uri "http://www.w3.org/ns/auth/acl#accessControl") + . ,(make <content> + #:content-type 'text/turtle + #:static-content + (format #f "@prefix acl: <http://www.w3.org/ns/auth/acl#> . <#default> a acl:Authorization; @@ -216,66 +219,68 @@ 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: <http://xmlns.com/foaf/0.1/> . + (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> + #:content-type 'text/turtle + #:static-content + (format #f "@prefix foaf: <http://xmlns.com/foaf/0.1/> . @prefix ldp: <http://www.w3.org/ns/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: <http://www.w3.org/ns/auth/acl#> . + (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> + #:content-type 'text/turtle + #:static-content + (format #f "@prefix acl: <http://www.w3.org/ns/auth/acl#> . @prefix foaf: <http://xmlns.com/foaf/0.1/> . <#public> @@ -290,10 +295,8 @@ 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)))))) + (fix-angle (uri->string doc-uri)) + (fix-angle (uri->string doc-uri)) + (fix-angle (uri->string owner))))))))) + #:create-intermediate-containers? #t)) + (lambda error #f))))) |