From 65d631ab2cdb65b8b5fcdab4c7ae500e9bdd612a Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Fri, 18 Jun 2021 15:39:58 +0200 Subject: Implement the POST method for the server --- src/scm/webid-oidc/errors.scm | 67 +++++++++++++ src/scm/webid-oidc/server/Makefile.am | 6 ++ src/scm/webid-oidc/server/create.scm | 183 ++++++++++++++++++++++++++++++++++ 3 files changed, 256 insertions(+) create mode 100644 src/scm/webid-oidc/server/create.scm (limited to 'src/scm/webid-oidc') diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index c6802d7..76ce8af 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -934,6 +934,60 @@ cannot-fetch-group-group-uri cannot-fetch-group-cause) +(define-exception-type + &incorrect-containment-triples + &external-error + make-incorrect-containment-triples + incorrect-containment-triples? + (path incorrect-containment-triples-path)) + +(export &incorrect-containment-triples + make-incorrect-containment-triples + incorrect-containment-triples? + 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)) + +(export &unsupported-media-type + make-unsupported-media-type + unsupported-media-type? + unsupported-media-type-content-type) + +(define-exception-type + &path-is-auxiliary + &external-error + make-path-is-auxiliary + path-is-auxiliary? + (path path-is-auxiliary-path)) + +(export &path-is-auxiliary + make-path-is-auxiliary + path-is-auxiliary? + path-is-auxiliary-path) + +(define-exception-type + &forbidden + &external-error + make-forbidden + forbidden? + (path forbidden-path) + (user forbidden-user) + (owner forbidden-owner) + (mode forbidden-mode)) + +(export &forbidden + make-forbidden + forbidden? + forbidden-path + forbidden-user + forbidden-owner + forbidden-mode) + (define*-public (error->str err #:key (max-depth #f)) (if (record? err) (let* ((type (record-type-descriptor err)) @@ -1294,6 +1348,19 @@ (format #f (G_ "the group ~s cannot be fetched (because ~a)" (uri->string (get 'group-uri)) (recurse (get 'cause))))) + ((&incorrect-containment-triples) + (format #f (G_ "the containment triples in the request to update ~s are not up to date") + (get 'path))) + ((&unsupported-media-type) + (format #f (G_ "the server cannot process resources with the ~s content-type") + (get 'content-type))) + ((&path-is-auxiliary) + (format #f (G_ "the client wants to create a resource at ~s, which is reserved for an auxiliary resource") + (get 'path))) + ((&forbidden) + (format #f (G_ "the operation on ~s by ~s is refused, because it’s not by ~s and the access control forbids the following mode of operation: ~s") + (get 'path) (uri->string (get 'user)) (uri->string (get 'owner)) + (uri->string (get 'mode)))) ((&compound-exception) (let ((components (get 'components))) (if (null? components) diff --git a/src/scm/webid-oidc/server/Makefile.am b/src/scm/webid-oidc/server/Makefile.am index e0ca8d6..12dad08 100644 --- a/src/scm/webid-oidc/server/Makefile.am +++ b/src/scm/webid-oidc/server/Makefile.am @@ -1 +1,7 @@ +dist_serverwebidoidcmod_DATA += \ + %reldir%/create.scm + +serverwebidoidcgo_DATA += \ + %reldir%/create.go + include %reldir%/resource/Makefile.am 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: . + +<#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))) -- cgit v1.2.3