diff options
Diffstat (limited to 'ldp/resource')
| -rw-r--r-- | ldp/resource/load.scm | 57 | ||||
| -rw-r--r-- | ldp/resource/sxml.scm | 51 | ||||
| -rw-r--r-- | ldp/resource/unsafe/save.scm | 92 | ||||
| -rw-r--r-- | ldp/resource/unsafe/update.scm | 95 | ||||
| -rw-r--r-- | ldp/resource/update.scm | 101 | ||||
| -rw-r--r-- | ldp/resource/xml.scm | 9 |
6 files changed, 405 insertions, 0 deletions
diff --git a/ldp/resource/load.scm b/ldp/resource/load.scm new file mode 100644 index 0000000..9ae9134 --- /dev/null +++ b/ldp/resource/load.scm @@ -0,0 +1,57 @@ +(define-module (ldp resource load) + #:use-module (ldp resource) + #:use-module (ldp path) + #:use-module (ldp resource xml) + #:use-module (rnrs bytevectors) + #:use-module (web uri)) + +(define-public (load uri) + (cond + ((string? uri) + (load (string->path uri))) + ((uri? uri) + (load (uri->path uri))) + ((or (resource? uri) (container? uri)) + (load (resource-path uri))) + (else + (let* ((dirname (path->filename uri)) + (filename (string-append dirname + "/representation/manifest.xml")) + (port + (catch #t + (lambda () + (open-input-file filename)) + (lambda error + (throw 'not-found)))) + (resource (xml->resource port)) + (container-def + (if (container? resource) + (format #f " +</~a> a <http://www.w3.org/ns/ldp#Container>, + <http://www.w3.org/ns/ldp#BasicContainer> . +" + (path->string (resource-path resource))) + "")) + (containment-triples + (if (and (container? resource) + (not (null? (resource-contained resource)))) + (format #f " +</~a> a <http://www.w3.org/ns/ldp#contains> ~a . +" + (path->string (resource-path resource)) + (string-join + (map (lambda (p) + (format #f "</~a>" + (path->string p))) + (resource-contained resource)) + ", ")) + "")) + (content-filename + (string-append dirname + "/representation/content"))) + (values + resource + (open-input-file content-filename #:binary #t) + (and (container? resource) + (string->utf8 + (string-append container-def containment-triples)))))))) diff --git a/ldp/resource/sxml.scm b/ldp/resource/sxml.scm new file mode 100644 index 0000000..d1e4420 --- /dev/null +++ b/ldp/resource/sxml.scm @@ -0,0 +1,51 @@ +(define-module (ldp resource sxml) + #:use-module (ldp resource) + #:use-module (ldp path) + #:use-module (sxml match)) + +(define-public (sxml->resource res) + (sxml-match + res + ((*TOP* (*PI* . ,whatever) . ,rest) + (sxml->resource `(*TOP* ,@rest))) + ((*TOP* ,rest) + (sxml->resource rest)) + ((https://linked-data-platform.planete-kraus.eu/ns:resource + (@ (container "no") + (uri-path ,uri-path) + (etag ,etag) + (content-type ,content-type))) + (make-resource (string->path uri-path) + etag + (string->symbol content-type) + #f)) + ((https://linked-data-platform.planete-kraus.eu/ns:resource + (@ (container "yes") + (uri-path ,uri-path) + (etag ,etag) + (content-type ,content-type)) + (https://linked-data-platform.planete-kraus.eu/ns:contains + (@ (path ,contents))) + ...) + (make-resource (string->path uri-path) + etag + (string->symbol content-type) + (map string->path contents))) + (,otherwise + (scm-error 'wrong-type-arg + "sxml->resource" + "Expected a SXML fragment with the correct schema, not ~s." + (list res) + (list res))))) + +(define-public (resource->sxml x) + `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (resource + (@ (xmlns "https://linked-data-platform.planete-kraus.eu/ns") + (container ,(if (container? x) "yes" "no")) + (uri-path ,(path->string (resource-path x))) + (etag ,(resource-etag x)) + (content-type ,(symbol->string (resource-content-type x)))) + ,@(map (lambda (p) + `(contains (@ (path ,(path->string p))))) + (or (resource-contained x) '()))))) diff --git a/ldp/resource/unsafe/save.scm b/ldp/resource/unsafe/save.scm new file mode 100644 index 0000000..7510f82 --- /dev/null +++ b/ldp/resource/unsafe/save.scm @@ -0,0 +1,92 @@ +(define-module (ldp resource unsafe save) + #:use-module (ldp resource) + #:use-module (ldp path) + #:use-module (ldp resource xml) + #:use-module (ice-9 ftw) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) + #:use-module (web uri)) + +(define (clean-directories path kept) + ;; Remove everything in path except kept + (define (enter-aux? x list) + (cond ((null? list) + #t) + ((string=? x (car list)) + #f) + (else (enter-aux? x (cdr list))))) + (define (enter? name stat result) + (enter-aux? name kept)) + (define (leaf name stat result) + (delete-file name) + result) + (define (down name stat result) + result) + (define (up name stat result) + (unless (string=? name path) + (rmdir name)) + result) + (define (skip name stat result) #f) + (define (error name stat errno result) + (unless (string=? name path) + (catch #t + (lambda () + (delete-file name)) + (lambda err #t)) + (catch #t + (lambda () + (rmdir name)) + (lambda err #t))) + result) + (file-system-fold enter? leaf down up skip error #t path)) + +(define (fix-directories resource) + (let ((dirname (path->filename (resource-path resource)))) + (map + (lambda (path) + (catch #t + (lambda () + ;; It may already exist, of course + (mkdir (path->filename path))) + (lambda err #t))) + (or (resource-contained resource) '())) + (clean-directories + dirname + (cons (string-append dirname "/representation") + (map path->filename + (or (resource-contained resource) '())))))) + +(define-public (save-manifest resource) + (let* ((dirname (path->filename (resource-path resource))) + (filename (string-append dirname "/representation/manifest.xml")) + (temp-filename (string-append filename "~"))) + (catch #t + (lambda () + (mkdir (string-append dirname "/representation"))) + (lambda err #t)) + (call-with-output-file temp-filename + (lambda (port) + (resource->xml resource port))) + (rename-file temp-filename filename) + (fix-directories resource))) + +(define-public (save resource content) + (let* ((dirname (path->filename (resource-path resource))) + (reprname (string-append dirname "/representation")) + (temp-reprname (string-append dirname "/representation~"))) + (catch #t + (lambda () + (mkdir temp-reprname)) + (lambda err #t)) + (call-with-output-file (string-append temp-reprname "/manifest.xml") + (lambda (port) + (resource->xml resource port))) + (call-with-output-file (string-append temp-reprname "/content") + (lambda (port) + (put-bytevector port + (if (string? content) + (string->utf8 content) + content))) + #:binary #t) + (rename-file temp-reprname reprname) + (fix-directories resource))) diff --git a/ldp/resource/unsafe/update.scm b/ldp/resource/unsafe/update.scm new file mode 100644 index 0000000..b563fda --- /dev/null +++ b/ldp/resource/unsafe/update.scm @@ -0,0 +1,95 @@ +(define-module (ldp resource unsafe update) + #:use-module (ldp resource) + #:use-module (ldp resource unsafe save) + #:use-module (ldp resource load) + #:use-module (ldp etag) + #:use-module (ldp path) + #:use-module (ldp precondition) + #:use-module (turtle tordf) + #:use-module (rdf rdf) + #:use-module (rnrs bytevectors) + #:use-module (web uri)) + +(define (check-triple triple) + (not (equal? (rdf-triple-predicate triple) + "http://www.w3.org/ns/ldp#contains"))) + +(define (check-graph graph) + (or (null? graph) + (and (check-triple (car graph)) + (check-graph (cdr graph))))) + +(define (check-container-content path content) + (when (bytevector? content) + (set! content (utf8->string content))) + (let ((graph (turtle->rdf (string-append "# This is not a file name." + content) + (uri->string (path->uri path))))) + (unless (check-graph graph) + (throw 'conflict)))) + +(define-public (initialize-root) + (catch 'not-found + (lambda () + (load "") + #t) + (lambda error + (save (make-resource (string->path "") + (generate-etag) + 'text/turtle + '()) + "") + (initialize-root)))) + +(define-public (change-contained path precondition added removed) + (call-with-values (lambda () (load path)) + (lambda (resource _port _triples) + (unless (container? resource) + (throw 'cannot-add-resources-in-non-container)) + (unless (precondition-valid? precondition (resource-etag resource)) + (throw 'precondition-failed)) + (let ((updated (update-children resource added removed))) + (save-manifest updated))))) + +(define-public (change-representation path precondition content-type content) + (call-with-values (lambda () (load path)) + (lambda (resource _port _triples) + (unless (precondition-valid? precondition (resource-etag resource)) + (throw 'precondition-failed)) + (let ((updated (make-resource path + (generate-etag) + content-type + (resource-contained resource)))) + (when (container? updated) + (check-container-content path content)) + (save updated content))))) + +(define-public (delete path precondition) + (call-with-values (lambda () (load path)) + (lambda (resource _port _triples) + (unless (precondition-valid? precondition (resource-etag resource)) + (throw 'precondition-failed)) + (unless (or (not (resource-contained resource)) + (null? (resource-contained resource))) + (throw 'non-empty-container)) + (unless (not (is-root? path)) + (throw 'cannot-delete-the-root)) + (change-contained (path-parent path) + (make-precondition #f #f) + '() + (list path))))) + +(define-public (mkcont-recursive path) + (catch 'not-found + (lambda () + (call-with-values (lambda () (load path)) + (lambda (_resource _port _triples) + #t))) + (lambda error + (unless (is-root? path) + (mkcont-recursive (path-parent path))) + (save (make-resource path + (generate-etag) + 'text/turtle + '()) + "")))) diff --git a/ldp/resource/update.scm b/ldp/resource/update.scm new file mode 100644 index 0000000..23f8867 --- /dev/null +++ b/ldp/resource/update.scm @@ -0,0 +1,101 @@ +(define-module (ldp resource update) + #:use-module (ldp etag) + #:use-module (ldp path) + #:use-module (ldp resource) + #:use-module (ldp http-link) + #:use-module (ldp precondition) + #:use-module (ldp resource unsafe save) + #:use-module (ice-9 threads) + #:use-module (web uri) + #:use-module ((ldp resource unsafe update) #:prefix unsafe:)) + +;; FIXME: use a bag of locks, so that we can have concurrent updates +;; of different resources. +(define lock (make-mutex)) + +(define-public (initialize-root) + (with-mutex lock + (unsafe:initialize-root))) + +(define-public (delete path precondition) + (with-mutex lock + (unsafe:delete path precondition))) + +(define (links-hint-for-a-container link-header) + (define (has-rel-type properties) + (if (null? properties) + #f + (let* ((prop (car properties)) + (key (car prop)) + (value (cdr prop))) + (if (and (string=? key "rel") + (or (string=? value "type") + (string=? value "http://www.w3.org/1999/02/22-rdf-syntax-ns#type"))) + #t + (has-rel-type (cdr properties)))))) + (and link-header + (let ((links (string->links link-header))) + (let ((for-basic-container + (or + (assoc-ref links + (string->uri + "http://www.w3.org/ns/ldp/BasicContainer")) + '())) + (for-container + (or + (assoc-ref links + (string->uri + "http://www.w3.org/ns/ldp/Container")) + '()))) + (has-rel-type (append for-basic-container for-container)))))) + +(define-public (post path slug precondition + http-link-header content-type content) + (catch 'child-already-exists + (lambda () + (let ((child-path (path-cons path slug))) + (let ((new-resource + (make-resource + child-path + (generate-etag) + content-type + (and (links-hint-for-a-container http-link-header) + '())))) + (with-mutex lock + (unsafe:mkcont-recursive path) + (unsafe:change-contained path precondition + (list child-path) + '()) + (save new-resource content) + new-resource)))) + (lambda err + (post path (string-append slug "-" (generate-etag)) + precondition + http-link-header content-type content)))) + +(define-public (put path precondition + http-link-header content-type content) + (let ((new-resource + (make-resource + path + (generate-etag) + content-type + (and (links-hint-for-a-container http-link-header) + '())))) + (with-mutex lock + (if (is-root? path) + (unsafe:initialize-root) + (unsafe:mkcont-recursive (path-parent path))) + (catch 'not-found + (lambda () + (unsafe:change-representation path precondition + content-type content)) + (lambda error + ;; path is not the root, because it exists from the + ;; beginning of the locked section + (unsafe:change-contained (path-parent path) + (make-precondition #f #f) + (list path) + '()) + (save new-resource content) + new-resource))))) diff --git a/ldp/resource/xml.scm b/ldp/resource/xml.scm new file mode 100644 index 0000000..d6a63c4 --- /dev/null +++ b/ldp/resource/xml.scm @@ -0,0 +1,9 @@ +(define-module (ldp resource xml) + #:use-module (ldp resource sxml) + #:use-module (sxml simple)) + +(define-public (xml->resource string-or-port) + (sxml->resource (xml->sxml string-or-port))) + +(define-public (resource->xml resource . args) + (apply sxml->xml (resource->sxml resource) args)) |