From 4b6e56ebb435f16374cebf38923393dc2f27f3ce Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Sat, 9 Jan 2021 11:57:23 +0100 Subject: Initial commit --- .guix-channel | 6 +++ AUTHORS | 3 ++ COPYING | 3 ++ ChangeLog | 1 + NEWS | 14 ++++++ README | 1 + README.org | 4 ++ bootstrap | 17 +++++++ doc/ldp.texi | 61 ++++++++++++++++++++++ guix/vkraus/packages/ldp.scm | 35 +++++++++++++ hall.scm | 48 ++++++++++++++++++ ldp.scm | 70 ++++++++++++++++++++++++++ ldp/content.scm | 55 ++++++++++++++++++++ ldp/etag.scm | 43 ++++++++++++++++ ldp/http-link.scm | 71 ++++++++++++++++++++++++++ ldp/path.scm | 64 +++++++++++++++++++++++ ldp/precondition.scm | 55 ++++++++++++++++++++ ldp/resource.scm | 112 +++++++++++++++++++++++++++++++++++++++++ ldp/resource/load.scm | 57 +++++++++++++++++++++ ldp/resource/sxml.scm | 51 +++++++++++++++++++ ldp/resource/unsafe/save.scm | 92 +++++++++++++++++++++++++++++++++ ldp/resource/unsafe/update.scm | 95 ++++++++++++++++++++++++++++++++++ ldp/resource/update.scm | 101 +++++++++++++++++++++++++++++++++++++ ldp/resource/xml.scm | 9 ++++ ldp/response.scm | 110 ++++++++++++++++++++++++++++++++++++++++ release | 84 +++++++++++++++++++++++++++++++ tests/ldp-primer.scm | 95 ++++++++++++++++++++++++++++++++++ 27 files changed, 1357 insertions(+) create mode 100644 .guix-channel create mode 100644 AUTHORS create mode 100644 COPYING create mode 100644 ChangeLog create mode 100644 NEWS create mode 120000 README create mode 100644 README.org create mode 100755 bootstrap create mode 100644 doc/ldp.texi create mode 100644 guix/vkraus/packages/ldp.scm create mode 100644 hall.scm create mode 100644 ldp.scm create mode 100644 ldp/content.scm create mode 100644 ldp/etag.scm create mode 100644 ldp/http-link.scm create mode 100644 ldp/path.scm create mode 100644 ldp/precondition.scm create mode 100644 ldp/resource.scm create mode 100644 ldp/resource/load.scm create mode 100644 ldp/resource/sxml.scm create mode 100644 ldp/resource/unsafe/save.scm create mode 100644 ldp/resource/unsafe/update.scm create mode 100644 ldp/resource/update.scm create mode 100644 ldp/resource/xml.scm create mode 100644 ldp/response.scm create mode 100755 release create mode 100644 tests/ldp-primer.scm diff --git a/.guix-channel b/.guix-channel new file mode 100644 index 0000000..8e7197b --- /dev/null +++ b/.guix-channel @@ -0,0 +1,6 @@ +(channel + (version 0) + (directory "guix")) +;; Local Variables: +;; mode: scheme +;; End: diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 0000000..4b01e25 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,3 @@ +Contributers to Ldp SNAPSHOT: + + Vivien Kraus diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..f658e91 --- /dev/null +++ b/COPYING @@ -0,0 +1,3 @@ +This project's license is GPL 3+. + +You can read the full license at https://www.gnu.org/licenses/gpl.html. diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..8b13789 --- /dev/null +++ b/ChangeLog @@ -0,0 +1 @@ + diff --git a/NEWS b/NEWS new file mode 100644 index 0000000..07771a4 --- /dev/null +++ b/NEWS @@ -0,0 +1,14 @@ +-*- mode: org; coding: utf-8; -*- + +#+TITLE: Ldp NEWS – history of user-visible changes +#+STARTUP: content hidestars + +Copyright © (2021) Vivien Kraus + + Copying and distribution of this file, with or without modification, + are permitted in any medium without royalty provided the copyright + notice and this notice are preserved. + +Please send Ldp bug reports to INSERT EMAIL HERE. + +* Publication at SNAPSHOT diff --git a/README b/README new file mode 120000 index 0000000..314e17d --- /dev/null +++ b/README @@ -0,0 +1 @@ +README.org \ No newline at end of file diff --git a/README.org b/README.org new file mode 100644 index 0000000..e22f775 --- /dev/null +++ b/README.org @@ -0,0 +1,4 @@ +-*- mode: org; coding: utf-8; -*- + +#+TITLE: README for Ldp + diff --git a/bootstrap b/bootstrap new file mode 100755 index 0000000..e3ed56e --- /dev/null +++ b/bootstrap @@ -0,0 +1,17 @@ +#!/bin/sh + +VERSION=$((cat .tarball-version \ + || git describe --tags \ + || echo "UNRELEASED") \ + | sed 's|/|_|g') + +export HOME="hall-home" + +hall dist -x \ + || exit 1 + +sed -i "s/SNAPSHOT/$VERSION/g" configure.ac || exit 1 + +autoreconf -vif || exit 1 + +rm -rf hall-home diff --git a/doc/ldp.texi b/doc/ldp.texi new file mode 100644 index 0000000..446d294 --- /dev/null +++ b/doc/ldp.texi @@ -0,0 +1,61 @@ + +\input texinfo +@c -*-texinfo-*- + +@c %**start of header +@setfilename ldp.info +@documentencoding UTF-8 +@settitle Ldp Reference Manual +@c %**end of header + +@include version.texi + +@copying +Copyright @copyright{} 2021 Vivien Kraus + +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.3 or +any later version published by the Free Software Foundation; with no +Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A +copy of the license is included in the section entitled ``GNU Free +Documentation License''. +@end copying + +@dircategory The Algorithmic Language Scheme +@direntry +* Ldp: (ldp). +@end direntry + +@titlepage +@title The Ldp Manual +@author Vivien Kraus + +@page +@vskip 0pt plus 1filll +Edition @value{EDITION} @* +@value{UPDATED} @* + +@insertcopying +@end titlepage + +@contents + +@c ********************************************************************* +@node Top +@top Ldp + +This document describes Ldp version @value{VERSION}. + +@menu +* Introduction:: Why Ldp? +@end menu + +@c ********************************************************************* +@node Introduction +@chapter Introduction + +INTRODUCTION HERE + +This documentation is a stub. + +@bye diff --git a/guix/vkraus/packages/ldp.scm b/guix/vkraus/packages/ldp.scm new file mode 100644 index 0000000..52dbe13 --- /dev/null +++ b/guix/vkraus/packages/ldp.scm @@ -0,0 +1,35 @@ +(define-module (vkraus packages ldp)) +(use-modules + (guix packages) + ((guix licenses) #:prefix license:) + (guix download) + (guix build-system gnu) + (gnu packages) + (gnu packages autotools) + (gnu packages guile) + (gnu packages guile-xyz) + (gnu packages pkg-config) + (gnu packages texinfo)) + +(define guile-ldp-local +(package + (name "ldp") + (version "SNAPSHOT") + (source "./ldp-SNAPSHOT.tar.gz") + (build-system gnu-build-system) + (arguments `()) + (native-inputs + `(("autoconf" ,autoconf) + ("automake" ,automake) + ("pkg-config" ,pkg-config) + ("texinfo" ,texinfo))) + (inputs `(("guile" ,guile-3.0))) + (propagated-inputs `(("guile-rdf" ,guile-rdf))) + (synopsis + "Implementation of the linked data platform specification") + (description + "Linked data platform is a standard for interoperable web architecture.") + (home-page "https://guile-ldp.planete-kraus.eu") + (license license:gpl3+))) + + diff --git a/hall.scm b/hall.scm new file mode 100644 index 0000000..3751013 --- /dev/null +++ b/hall.scm @@ -0,0 +1,48 @@ +(hall-description + (name "ldp") + (prefix "") + (version "SNAPSHOT") + (author "Vivien Kraus") + (copyright (2021)) + (synopsis + "Implementation of the linked data platform specification") + (description + "Linked data platform is a standard for interoperable web architecture.") + (home-page "https://guile-ldp.planete-kraus.eu") + (license gpl3+) + (dependencies + `(("guile-rdf" (rdf rdf) ,guile-rdf))) + (files (libraries + ((scheme-file "ldp") + (directory + "ldp" + ((directory + "resource" + ((directory + "unsafe" + ((scheme-file "save") (scheme-file "update"))) + (scheme-file "load") + (scheme-file "sxml") + (scheme-file "xml") + (scheme-file "update"))) + (scheme-file "path") + (scheme-file "response") + (scheme-file "resource") + (scheme-file "http-link") + (scheme-file "content") + (scheme-file "precondition") + (scheme-file "etag"))))) + (tests ((directory "tests" ((scheme-file "ldp-primer"))))) + (programs ()) + (documentation + ((org-file "README") + (symlink "README" "README.org") + (text-file "HACKING") + (text-file "COPYING") + (directory "doc" ((texi-file "ldp"))) + (text-file "NEWS") + (text-file "AUTHORS") + (text-file "ChangeLog"))) + (infrastructure + ((scheme-file "hall") + (directory "build-aux" ()))))) diff --git a/ldp.scm b/ldp.scm new file mode 100644 index 0000000..3c20c64 --- /dev/null +++ b/ldp.scm @@ -0,0 +1,70 @@ +(define-module (ldp) + #:use-module (ldp resource) + #:use-module (ldp path) + #:use-module (ldp resource load) + #:use-module (ldp resource update) + #:use-module (ldp response) + #:use-module (ldp content) + #:use-module (ldp precondition) + #:use-module (web request) + #:use-module (web response) + #:use-module (ldp precondition) + #:use-module (rnrs bytevectors)) + +(define-public (respond request request-body) + (when (string? request-body) + (set! request-body (string->utf8 request-body))) + (catch #t + (lambda () + (let ((method (request-method request)) + (path (uri->path (request-uri request))) + (has-precondition? (or (request-if-match request) + (request-if-none-match request))) + (precondition (request->precondition request))) + (cond ((or (eq? method 'POST) (eq? method 'PUT)) + (let ((slug (assoc-ref (request-headers request) 'slug)) + (link-header (assoc-ref (request-headers request) 'link)) + (content-type (request-content-type request))) + (unless slug + (set! slug "sub")) + (unless content-type + (throw 'bad-request)) + (set! content-type (car content-type)) + (cond ((eq? method 'POST) + (let ((resource (post path + slug + precondition + link-header + content-type + request-body))) + (respond-to-post resource))) + ((eq? method 'PUT) + (put path precondition link-header content-type request-body) + (respond-to-put))))) + ((or (eq? method 'GET) (eq? method 'HEAD) (eq? method 'OPTIONS)) + (call-with-values + (lambda () + (load (uri->path (request-uri request)))) + (lambda (resource port triples) + (let ((response-body + (and (eq? method 'GET) + (load-content + (make-content port triples) + (text-content-type? + (resource-content-type resource)))))) + (case method + ((GET) + (when (and has-precondition? + (precondition-valid? precondition + (resource-etag resource))) + (throw 'not-modified)) + (respond-to-get resource response-body)) + ((HEAD) (respond-to-head resource)) + ((OPTIONS) (respond-to-options resource))))))) + ((eq? method 'DELETE) + (delete path precondition) + (respond-to-delete)) + (else + (throw 'bad-request))))) + (lambda error + (apply respond-to-error error)))) diff --git a/ldp/content.scm b/ldp/content.scm new file mode 100644 index 0000000..57d4549 --- /dev/null +++ b/ldp/content.scm @@ -0,0 +1,55 @@ +(define-module (ldp content) + #:use-module (oop goops) + #:use-module (ice-9 binary-ports) + #:use-module (rnrs bytevectors) + #:use-module (rnrs)) + +(define-class () + (port #:init-keyword #:port #:getter content-port) + (additional #:init-keyword #:additional #:getter content-additional)) + +(define (the-boolean x) + (unless (boolean? x) + (scm-error 'wrong-type-arg + "the-boolean" + "Expected a boolean." + '() + (list x))) + x) + +(define (the-binary-port x) + (unless (binary-port? x) + (scm-error 'wrong-type-arg + "the-binary-port" + "Expected a binary port." + '() + (list x))) + x) + +(define (the-bytevector x) + (unless (bytevector? x) + (scm-error 'wrong-type-arg + "the-bytevector" + "Expected a bytevector." + '() + (list x))) + x) + +(define-public (make-content port additional) + (when (string? additional) + (set! additional (string->utf8 additional))) + (make + #:port (the-binary-port port) + #:additional additional)) + +(define-public (load-content content binary?) + (let ((left (get-bytevector-all (content-port content))) + (right (content-additional content))) + (let ((nl (bytevector-length left)) + (nr (bytevector-length right))) + (let ((total (make-bytevector (+ nl nr)))) + (bytevector-copy! left 0 total 0 nl) + (bytevector-copy! right 0 total nl nr) + (if binary? + total + (utf8->string total)))))) diff --git a/ldp/etag.scm b/ldp/etag.scm new file mode 100644 index 0000000..756766e --- /dev/null +++ b/ldp/etag.scm @@ -0,0 +1,43 @@ +(define-module (ldp etag)) + +(define alphabet + (string-join + '("abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "0123456789" + "-_") + "")) + +(define (generate-etag-letter) + (string-ref alphabet (random (string-length alphabet)))) + +(define (generate-etag-letters n) + (if (<= n 0) + '() + (cons (generate-etag-letter) + (generate-etag-letters (- n 1))))) + +(define-public (generate-etag) + (list->string (generate-etag-letters 16))) + +(define-public (etag? x) + (define (aux i) + (or (>= i (string-length x)) + (and (let ((c (string-ref x i))) + (or (and (char>=? c #\a) (char<=? c #\z)) + (and (char>=? c #\A) (char<=? c #\Z)) + (and (char>=? c #\0) (char<=? c #\9)) + (char=? c #\-) + (char=? c #\_))) + (aux (+ i 1))))) + (and (string? x) + (aux 0))) + +(define-public (the-etag x) + (unless (etag? x) + (scm-error 'wrong-type-arg + "the-etag" + "Expected a string satisfying etag? from (ldp etag)." + '() + (list x))) + x) diff --git a/ldp/http-link.scm b/ldp/http-link.scm new file mode 100644 index 0000000..b750df1 --- /dev/null +++ b/ldp/http-link.scm @@ -0,0 +1,71 @@ +(define-module (ldp http-link) + #:use-module (ice-9 peg) + #:use-module (web uri)) + +(define-peg-string-patterns + "links <-- (link (COMMA / ! link))* +link <-- OPENANGLE uri CLOSEANGLE properties +uri <-- (! CLOSEANGLE .)* +properties <-- (SEMICOLON property)* +property <-- key EQUAL QUOTE value QUOTE +key <-- ([a-zA-Z0-9_]/'-')* +value <-- (! QUOTE ((ESCAPE '\\') / (ESCAPE '\"') / (! ESCAPE .)))* +OPENANGLE < '<' +CLOSEANGLE < '>' +COMMA < ' '* ',' ' '* +SEMICOLON < ' '* ';' ' '* +EQUAL < ' '* '=' ' '* +QUOTE < '\"' +ESCAPE < '\\' +") + +(define (fix-key key) + (unless (and (list? key) + (eq? (car key) 'key)) + (throw 'bad-request)) + (cadr key)) + +(define (fix-value value) + (unless (and (list? value) + (eq? (car value) 'value)) + (throw 'bad-request)) + (cadr value)) + +(define (fix-property prop) + (unless (and (list? prop) + (eq? (car prop) 'property)) + (throw 'bad-request)) + (let ((key (fix-key (cadr prop))) + (value (fix-value (caddr prop)))) + `(,key . ,value))) + +(define (fix-properties props) + (if (eq? props 'properties) + '() + (map fix-property (cdr props)))) + +(define (fix-uri uri) + (unless (and (list? uri) + (eq? (car uri) 'uri) + (string? (cadr uri)) + (string->uri (cadr uri))) + (throw 'bad-request)) + (string->uri (cadr uri))) + +(define (fix-link link) + (unless (and (list? link) + (eq? (car link) 'link)) + (throw 'bad-request)) + (let ((uri (fix-uri (cadr link))) + (properties (fix-properties (caddr link)))) + `(,uri . ,properties))) + +(define (fix-links links) + (unless (and (list? links) + (eq? (car links) 'links)) + (throw 'bad-request)) + (map fix-link (cdr links))) + +(define-public (string->links str) + (let ((tree (peg:tree (match-pattern links str)))) + (fix-links tree))) diff --git a/ldp/path.scm b/ldp/path.scm new file mode 100644 index 0000000..fb25ba2 --- /dev/null +++ b/ldp/path.scm @@ -0,0 +1,64 @@ +(define-module (ldp path) + #:use-module (oop goops) + #:use-module (web uri)) + +(define-class () + (components-rev #:init-keyword #:components-rev #:getter path-components-rev)) + +(export ) + +(define-public (is-root? x) + (equal? (path-components-rev x) '())) + +(define-public (path->filename x) + (if (is-root? x) + "." + (string-append + "./" + (encode-and-join-uri-path + (map (lambda (x) + (string-append "r_" x)) + (reverse (path-components-rev x))))))) + +(define-public (path->uri x) + (let* ((components (reverse (path-components-rev x))) + (relative-to-root (encode-and-join-uri-path components)) + (path (string-append "/" relative-to-root))) + (build-uri-reference #:path path))) + +(define-public (path->string x) + (uri-path (path->uri x))) + +(define-public (uri->path x) + (make + #:components-rev + (reverse (split-and-decode-uri-path (uri-path x))))) + +(define-public (string->path x) + (uri->path (build-uri-reference #:path x))) + +(define-public (path? x) + (is-a? x )) + +(define-public (the-path x) + (unless (path? x) + (scm-error 'wrong-type-arg + "the-path" + "Expected a path from (ldp path)." + '() + (list x))) + x) + +(define-public (path-parent x) + (make #:components-rev (cdr (path-components-rev x)))) + +(define-public (path-cons container slug) + (make + #:components-rev + (cons slug (path-components-rev container)))) + +(define-public (path-slug x) + (car (path-components-rev x))) + +(define-public (path-equal? x y) + (equal? (path-components-rev x) (path-components-rev y))) diff --git a/ldp/precondition.scm b/ldp/precondition.scm new file mode 100644 index 0000000..990193a --- /dev/null +++ b/ldp/precondition.scm @@ -0,0 +1,55 @@ +(define-module (ldp precondition) + #:use-module (ldp etag) + #:use-module (web request) + #:use-module (oop goops)) + +(define-class () + (if-match #:init-keyword #:if-match #:getter precondition-if-match) + (if-none-match #:init-keyword #:if-match #:getter precondition-if-none-match)) + +(define (the-precondition x) + (unless (is-a? x ) + (scm-error 'wrong-type-arg + "the-precondition" + "Expected a precondition." + '() + (list x))) + x) + +(define (the-string x) + (unless (string? x) + (scm-error 'wrong-type-arg + "the-string" + "Expected a string." + '() + (list x))) + x) + +(define-public (make-precondition if-match if-none-match) + (unless if-match + (set! if-match '("*"))) + (unless if-none-match + (set! if-none-match '())) + (set! if-match (map the-string if-match)) + (set! if-none-match (map the-string if-none-match)) + (make + #:if-match if-match + #:if-none-match if-none-match)) + +(define-public (request->precondition request) + (make-precondition + (request-if-match request) + (request-if-none-match request))) + +(define-public (precondition-valid? x etag) + (define (check-matching list) + (and (not (null? list)) + (or (string=? etag (car list)) + (string=? (car list) "*") + (check-matching (cdr list))))) + (define (check-non-matching list) + (or (null? list) + (and (not (string=? etag (car list))) + (check-non-matching (cdr list))))) + (and (check-matching (precondition-if-match x)) + (check-non-matching (precondition-if-none-match x)))) diff --git a/ldp/resource.scm b/ldp/resource.scm new file mode 100644 index 0000000..6720499 --- /dev/null +++ b/ldp/resource.scm @@ -0,0 +1,112 @@ +(define-module (ldp resource) + #:use-module (ldp path) + #:use-module (ldp etag) + #:use-module (oop goops) + #:use-module (web uri)) + +;; If contained is #f, then this is not a container. Otherwise, this +;; is a container, possibly empty (null) +(define-class () + (path #:init-keyword #:path #:getter resource-path) + (etag #:init-keyword #:etag #:getter resource-etag) + (content-type #:init-keyword #:content-type #:getter resource-content-type) + (contained #:init-keyword #:contained #:getter resource-contained)) + +(export resource-path + resource-etag + resource-content-type + resource-contained) + +(define (the-symbol x) + (unless (symbol? x) + (scm-error 'wrong-type-arg + "the-symbol" + "Expected a symbol, got ~s." + (list x) + (list x))) + x) + +(define-public (make-resource path etag content-type contained) + (unless (or (not contained) + (eq? content-type 'text/turtle)) + (throw 'containers-should-be-rdf)) + (make + #:path (the-path path) + #:etag (the-etag etag) + #:content-type (the-symbol content-type) + #:contained (and contained + (map the-path contained)))) + +(define-public (resource? x) + (is-a? x )) + +(define-public (container? x) + (and (resource? x) + (resource-contained x))) + +(define-public (the-resource x) + (unless (resource? x) + (scm-error 'wrong-type-arg + "the-non-container" + "Expected a resource from (ldp resource)." + '() + (list x))) + x) + +(define-public (the-container x) + (unless (container? x) + (scm-error 'wrong-type-arg + "the-container" + "Expected a container from (ldp resource)." + '() + (list x))) + x) + +(define-method (has-child? (container ) (child )) + (define (check list) + (and (not (null? list)) + (or (path-equal? (car list) child) + (check (cdr list))))) + (check (resource-contained container))) + +(export has-child?) + +(define-public (add-child container child) + (set! container (the-container container)) + (set! child (the-path child)) + (if (has-child? container child) + (throw 'child-already-exists) + (make-resource (resource-path container) + (generate-etag) + (resource-content-type container) + (cons child (resource-contained container))))) + +(define-public (remove-child container child) + (set! container (the-container container)) + (set! child (the-path child)) + (define (check found kept list) + (if (null? list) + (if found + (reverse kept) + (throw 'child-does-not-exist)) + (if (path-equal? (car list) child) + (check #t kept (cdr list)) + (check found (cons (car list) kept) (cdr list))))) + (make-resource (resource-path container) + (generate-etag) + (resource-content-type container) + (check #f '() (resource-contained container)))) + +(define-public (update-children container added removed) + (set! container (the-container container)) + (set! added (map the-path added)) + (set! removed (map the-path removed)) + (cond + ((and (null? added) (null? removed)) + container) + ((null? added) + (update-children (remove-child container (car removed)) + '() (cdr removed))) + (else + (update-children (add-child container (car added)) + (cdr added) removed)))) diff --git a/ldp/resource/load.scm b/ldp/resource/load.scm new file mode 100644 index 0000000..2c37a53 --- /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 , + . +" + (path->string (resource-path resource))) + "")) + (containment-triples + (if (and (container? resource) + (not (null? (resource-contained resource)))) + (format #f " +<~a> a ~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)) diff --git a/ldp/response.scm b/ldp/response.scm new file mode 100644 index 0000000..339e44b --- /dev/null +++ b/ldp/response.scm @@ -0,0 +1,110 @@ +(define-module (ldp response) + #:use-module (ldp path) + #:use-module (ldp resource) + #:use-module (web response)) + +(define-public (respond-not-found) + (values (build-response + #:code 404 + #:reason-phrase "Not Found") + #f)) + +(define-public (respond-bad-request) + (values (build-response + #:code 400 + #:reason-phrase "Bad Request") + #f)) + +(define-public (respond-not-modified) + (values (build-response + #:code 304 + #:reason-phrase "Not Modified") + #f)) + +(define-public (respond-precondition-failed) + (values (build-response + #:code 412 + #:reason-phrase "Precondition Failed") + #f)) + +(define-public (respond-conflict) + (values (build-response + #:code 409 + #:reason-phrase "Conflict") + #f)) + +(define-public (respond-method-not-allowed) + (values (build-response + #:code 405 + #:reason-phrase "Method Not Allowed") + #f)) + +(define-public (respond-to-error key . args) + (case key + ((not-found) + (respond-not-found)) + ((bad-request) + (respond-bad-request)) + ((not-modified) + (respond-not-modified)) + ((precondition-failed) + (respond-precondition-failed)) + ((conflict cannot-delete-the-root) + (respond-conflict)) + ((method-not-allowed cannot-add-resources-in-non-container) + (respond-method-not-allowed)) + (else + (apply throw key args)))) + +(define (resource->http-link resource) + (if (container? resource) + "; rel=\"type\", ; rel=\"type\"" + "; rel=\"type\">")) + +(define-public (respond-to-post resource) + (values (build-response + #:code 201 + #:reason-phrase "Created" + #:headers `((location . ,(path->uri (resource-path resource))))) + #f)) + +(define-public (respond-to-put) + (values (build-response) + #f)) + +(define-public (respond-to-delete) + (values (build-response) + #f)) + +(define-public (respond-to-get resource data) + (values (build-response + #:headers `((content-type . (,(resource-content-type resource))) + (etag . (,(resource-etag resource) . #t)) + (link . ,(resource->http-link resource)) + (allow HEAD GET POST PUT DELETE OPTIONS))) + data)) + +(define-public (respond-to-head resource) + (values (build-response + #:headers `((content-type . (,(resource-content-type resource))) + (etag . (,(resource-etag resource) . #t)) + (link . ,(resource->http-link resource)) + (allow HEAD GET POST PUT DELETE OPTIONS))) + #f)) + +(define-public (respond-to-options resource) + (let ((allow + (cond ((is-root? (resource-path resource)) + '(HEAD GET POST PUT OPTIONS)) + ((container? resource) + '(HEAD GET POST PUT DELETE OPTIONS)) + (else + '(HEAD GET PUT DELETE OPTIONS))))) + (values (build-response + #:code 204 + #:reason-phrase "No Content" + #:headers `((content-type . (,(resource-content-type resource))) + (etag . (,(resource-etag resource) . #t)) + (link . ,(resource->http-link resource)) + (allow . ,allow))) + #f))) diff --git a/release b/release new file mode 100755 index 0000000..72dd29f --- /dev/null +++ b/release @@ -0,0 +1,84 @@ +#!/bin/sh + +VERSION=$(((guix environment --ad-hoc --container git -- \ + git describe --tags) \ + || echo "UNRELEASED") \ + | sed 's|/|_|g') + +>&2 echo "Version is: $VERSION" + +COMMIT=$(git rev-parse HEAD) + +>&2 echo "Commit is: $COMMIT" + +rm -rf pure + +guix environment --ad-hoc --container git -- \ + git checkout-index -a -f --prefix=pure/ \ + || exit 1 + +cd pure || exit 1 + +HASH=$(guix hash -r -x .) + +cd .. || exit 1 + +rm -rf pure || exit 1 + +guix environment --ad-hoc guile-hall -- \ + hall guix -x || exit 1 + +mkdir -p guix/vkraus/packages || exit 1 + +cat > release.scm <; rel=\"type\"\r\n\ +Slug: alice\r\n\r\n" + read-request)) + (request-body "@prefix dcterms: . +@prefix ldp: . + + a ldp:Container, ldp:BasicContainer; + dcterms:title 'Alice’s data storage on the Web' .")) + (call-with-values (lambda () (respond request request-body)) + (lambda (response response-body) + (test-equal "Slug is respected on empty container" + (string->uri-reference "/alice") + (response-location response))))) +(test-end "setup") + +(test-begin "example1-2") +(let ((request + (call-with-input-string "GET /alice/ HTTP/1.1\r\n\ +Host: example.org\r\n\ +Accept: text/turtle\r\n\r\n" + read-request)) + (request-body #f)) + (call-with-values (lambda () (respond request request-body)) + (lambda (response response-body) + (test-eq "Example 2: OK" + 200 + (response-code response)) + (test-eq "Example 2: content-type" + 'text/turtle + (car (response-content-type response))) + (test-equal "Example 2: links" + "; rel=\"type\", ; rel=\"type\"" + (assoc-ref (response-headers response) 'link)) + (test-equal "Example 2: allow" + '(HEAD GET POST PUT DELETE OPTIONS) + (response-allow response)) + (test-eq "Example 2: has ETag" + #t + (not (not (response-etag response)))) + (test-eq "Example 2: ETag is strong" + #t + (cdr (response-etag response))) + (test-equal "Example 2: content" + "@prefix dcterms: . +@prefix ldp: . + + a ldp:Container, ldp:BasicContainer; + dcterms:title 'Alice’s data storage on the Web' . + a , + . +" + (utf8->string response-body))))) +(test-end "example1-2") + +(test-begin "cleanup") +(let ((request + (call-with-input-string "DELETE /alice HTTP/1.1\r\n\ +Host: example.org\r\n\r\n" + read-request)) + (request-body #f)) + (call-with-values (lambda () (respond request request-body)) + (lambda (response response-body) + (test-eq "Cleaning OK" + 200 + (response-code response))))) +(test-end "cleanup") + +(delete-file "representation/manifest.xml") +(delete-file "representation/content") +(rmdir "representation") +(chdir "..") +(rmdir "primer") -- cgit v1.2.3