Initial commit

27 files changed, 1357 insertions, 0 deletions

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 <INSERT EMAIL HERE>
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 <INSERT EMAIL HERE>
+
+  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 <content> ()
+  (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 <content>
+    #: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 <path> ()
+  (components-rev #:init-keyword #:components-rev #:getter path-components-rev))
+
+(export <path>)
+
+(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 <path>
+    #: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 <path>))
+
+(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 <path> #:components-rev (cdr (path-components-rev x))))
+
+(define-public (path-cons container slug)
+  (make <path>
+    #: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 <precondition> ()
+  (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 <precondition>)
+    (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 <precondition>
+    #: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 <resource> ()
+  (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 <resource>
+    #: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 <resource>))
+
+(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 <resource>) (child <path>))
+  (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 <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))
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)
+      "<http://www.w3.org/ns/ldp#BasicContainer>; rel=\"type\", <http://www.w3.org/ns/ldp#Resource>; rel=\"type\""
+      "<http://www.w3.org/ns/ldp#Resource>; 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 <<EOF
+(use-modules (guix git-download))
+(define-public guile-ldp
+  (package
+    (inherit guile-ldp-local)
+    (version "$VERSION")
+    (source
+      (origin
+        (method git-fetch)
+        (uri (git-reference
+	  (url "http://labo.planete-kraus.eu/ldp.git")
+          (commit "$COMMIT")))
+        (sha256
+          (base32
+            "$HASH"))
+	(snippet
+	 (quasiquote
+           (begin
+	    (with-output-to-file ".tarball-version"
+	      (lambda _ (format #t "~a~%" ,version)))
+	    #t)))))
+    (native-inputs
+     (cons*
+      (quasiquote ("guile-hall" ,guile-hall))
+      (package-native-inputs guile-ldp-local)))))
+EOF
+
+rm -f guix/vkraus/packages/ldp.scm || exit 1
+
+guix environment --ad-hoc --container emacs -- \
+     emacs --batch --file guix/vkraus/packages/ldp.scm \
+     --eval '(insert "(define-module (vkraus packages ldp))\n")' \
+     --eval '(insert-file "../../../guix.scm")' \
+     -f end-of-buffer \
+     -f backward-sexp \
+     --eval '(insert "(define guile-ldp-local\n")' \
+     -f forward-sexp \
+     --eval '(insert ")\n\n")' \
+     --eval '(insert-file "../../../release.scm")' \
+     -f save-buffer \
+    || exit 1
+
+rm -rf guix.scm release.scm || exit 1
+
+guix environment --ad-hoc --container git -- \
+     git add guix/vkraus/packages/ldp.scm \
+    || exit 1
+
+guix build -L guix --rounds=2 --with-git-url=ldp=file://$PWD ldp \
+     || exit 1
+
+rm -rf pure
diff --git a/tests/ldp-primer.scm b/tests/ldp-primer.scm
new file mode 100644
index 0000000..cc27e4b
--- /dev/null
+++ b/tests/ldp-primer.scm
@@ -0,0 +1,95 @@
+(define-module (ldp-primer)
+  #:use-module (srfi srfi-64)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (ldp)
+  #:use-module (ldp precondition)
+  #:use-module (ldp resource update)
+  #:use-module (rnrs bytevectors))
+
+(system* "rm" "-rf" "primer")
+
+(catch #t
+  (lambda ()
+    (mkdir "primer"))
+  (lambda err #t))
+(chdir "primer")
+
+(test-begin "setup")
+(let ((request
+       (call-with-input-string "POST / HTTP/1.1\r\n\
+Host: example.org\r\n\
+Content-Type: text/turtle\r\n\
+Link: <http://www.w3.org/ns/ldp/BasicContainer>; rel=\"type\"\r\n\
+Slug: alice\r\n\r\n"
+	 read-request))
+      (request-body "@prefix dcterms: <http://purl.org/dc/terms/>.
+@prefix ldp: <http://www.w3.org/ns/ldp#>.
+
+<http://example.org/alice/> 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"
+	"<http://www.w3.org/ns/ldp#BasicContainer>; rel=\"type\", <http://www.w3.org/ns/ldp#Resource>; 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: <http://purl.org/dc/terms/>.
+@prefix ldp: <http://www.w3.org/ns/ldp#>.
+
+<http://example.org/alice/> a ldp:Container, ldp:BasicContainer;
+  dcterms:title 'Alice’s data storage on the Web' .
+</alice> a <http://www.w3.org/ns/ldp#Container>,
+    <http://www.w3.org/ns/ldp#BasicContainer> .
+"
+	(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")