diff options
Diffstat (limited to 'src/scm/webid-oidc/server/create.scm')
| -rw-r--r-- | src/scm/webid-oidc/server/create.scm | 183 |
1 files changed, 183 insertions, 0 deletions
diff --git a/src/scm/webid-oidc/server/create.scm b/src/scm/webid-oidc/server/create.scm new file mode 100644 index 0000000..93f684c --- /dev/null +++ b/src/scm/webid-oidc/server/create.scm @@ -0,0 +1,183 @@ +(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 cache) + #:use-module (webid-oidc fetch) + #: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 (check-acl-can-append server-name container owner user http-get) + (let ((modes (wac-get-modes server-name container user #:http-get http-get))) + (define (check-modes modes) + (if (null? modes) + (raise-exception + (make-forbidden container user owner + (string->uri "http://www.w3.org/ns/auth/acl#Append"))) + (or + (equal? (car modes) (string->uri "http://www.w3.org/ns/auth/acl#Append")) + (equal? (car modes) (string->uri "http://www.w3.org/ns/auth/acl#Write")) + (check-modes (cdr modes))))) + (check-modes modes))) + +(define* (create server-name owner user container types slug content-type content + #:key + (http-get http-get)) + (unless (equal? owner user) + (check-acl-can-append server-name container owner user 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 (and slug + (or (string-suffix? ".acl" slug) + (string-suffix? ".meta" slug))) + (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))) + (catch 'already-exists + (lambda () + (with-session + (lambda (load-content-type load-contained load-static-content + do-create do-delete) + (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#> . + +<#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 root-uri))))))))) + load-content-type load-contained load-static-content + do-create do-delete))) + #t) + (lambda error + #f))) |