summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorVivien Kraus <vivien@planete-kraus.eu>2021-01-09 11:57:23 +0100
committerVivien Kraus <vivien@planete-kraus.eu>2021-01-10 14:33:51 +0100
commit59060419ba72773b11ada8aa56a063874b58f5d0 (patch)
tree02bd39d5ec527a3ddfbd289fed88367e5a63d2c4
Initial commit0.0.0
-rw-r--r--.gitignore65
-rw-r--r--.guix-channel6
-rw-r--r--AUTHORS3
-rw-r--r--COPYING3
-rw-r--r--ChangeLog1
-rw-r--r--HACKING47
-rw-r--r--Makefile.am90
-rw-r--r--NEWS14
l---------README1
-rw-r--r--README.org4
-rw-r--r--build-aux/test-driver.scm180
-rw-r--r--configure.ac35
-rw-r--r--doc/ldp.texi61
-rw-r--r--guix.scm32
-rw-r--r--guix/vkraus/packages/ldp.scm35
-rw-r--r--hall.scm48
-rw-r--r--ldp.scm64
-rw-r--r--ldp/content.scm55
-rw-r--r--ldp/etag.scm43
-rw-r--r--ldp/http-link.scm71
-rw-r--r--ldp/path.scm64
-rw-r--r--ldp/precondition.scm55
-rw-r--r--ldp/resource.scm112
-rw-r--r--ldp/resource/load.scm57
-rw-r--r--ldp/resource/sxml.scm51
-rw-r--r--ldp/resource/unsafe/save.scm92
-rw-r--r--ldp/resource/unsafe/update.scm95
-rw-r--r--ldp/resource/update.scm101
-rw-r--r--ldp/resource/xml.scm9
-rw-r--r--ldp/response.scm102
-rw-r--r--pre-inst-env.in14
-rwxr-xr-xrelease95
-rw-r--r--tests/ldp-primer.scm55
33 files changed, 1760 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..0a123e7
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,65 @@
+*.eps
+*.go
+*.log
+*.pdf
+*.png
+*.tar.xz
+*.tar.gz
+*.tmp
+*~
+.#*
+\#*\#
+,*
+/ABOUT-NLS
+/INSTALL
+/aclocal.m4
+/autom4te.cache
+/build-aux/ar-lib
+/build-aux/compile
+/build-aux/config.guess
+/build-aux/config.rpath
+/build-aux/config.sub
+/build-aux/depcomp
+/build-aux/install-sh
+/build-aux/mdate-sh
+/build-aux/missing
+/build-aux/test-driver
+/build-aux/texinfo.tex
+/config.status
+/configure
+/doc/*.1
+/doc/.dirstamp
+/doc/contributing.*.texi
+/doc/*.aux
+/doc/*.cp
+/doc/*.cps
+/doc/*.fn
+/doc/*.fns
+/doc/*.html
+/doc/*.info
+/doc/*.info-[0-9]
+/doc/*.ky
+/doc/*.pg
+/doc/*.toc
+/doc/*.t2p
+/doc/*.tp
+/doc/*.vr
+/doc/*.vrs
+/doc/stamp-vti
+/doc/version.texi
+/doc/version-*.texi
+/m4/*
+/pre-inst-env
+/test-env
+/test-tmp
+/tests/*.trs
+GPATH
+GRTAGS
+GTAGS
+Makefile
+Makefile.in
+config.cache
+stamp-h[0-9]
+tmp
+/.version
+/doc/stamp-[0-9]
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/HACKING b/HACKING
new file mode 100644
index 0000000..0248a8d
--- /dev/null
+++ b/HACKING
@@ -0,0 +1,47 @@
+-*- mode: org; coding: utf-8; -*-
+
+#+TITLE: Hacking ldp
+
+* Contributing
+
+By far the easiest way to hack on ldp is to develop using Guix:
+
+#+BEGIN_SRC bash
+ # Obtain the source code
+ cd /path/to/source-code
+ guix environment -l guix.scm
+ # In the new shell, run:
+ hall dist --execute && autoreconf -vif && ./configure && make check
+#+END_SRC
+
+You can now hack this project's files to your heart's content, whilst
+testing them from your `guix environment' shell.
+
+To try out any scripts in the project you can now use
+
+#+BEGIN_SRC bash
+ ./pre-inst-env scripts/${script-name}
+#+END_SRC
+
+If you'd like to tidy the project again, but retain the ability to test the
+project from the commandline, simply run:
+
+#+BEGIN_SRC bash
+ ./hall clean --skip "scripts/${script-name},pre-inst-env" --execute
+#+END_SRC
+
+** Manual Installation
+
+If you do not yet use Guix, you will have to install this project's
+dependencies manually:
+ - autoconf
+ - automake
+ - pkg-config
+ - texinfo
+ - guile-hall
+
+Once those dependencies are installed you can run:
+
+#+BEGIN_SRC bash
+ hall dist -x && autoreconf -vif && ./configure && make check
+#+END_SRC
diff --git a/Makefile.am b/Makefile.am
new file mode 100644
index 0000000..e500385
--- /dev/null
+++ b/Makefile.am
@@ -0,0 +1,90 @@
+
+
+bin_SCRIPTS =
+
+# Handle substitution of fully-expanded Autoconf variables.
+do_subst = $(SED) \
+ -e 's,[@]GUILE[@],$(GUILE),g' \
+ -e 's,[@]guilemoduledir[@],$(guilemoduledir),g' \
+ -e 's,[@]guileobjectdir[@],$(guileobjectdir),g' \
+ -e 's,[@]localedir[@],$(localedir),g'
+
+nodist_noinst_SCRIPTS = pre-inst-env
+
+GOBJECTS = $(SOURCES:%.scm=%.go)
+
+moddir=$(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION)
+godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache
+ccachedir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache
+
+nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES)
+nobase_go_DATA = $(GOBJECTS)
+
+# Make sure source files are installed first, so that the mtime of
+# installed compiled files is greater than that of installed source
+# files. See
+# <http://lists.gnu.org/archive/html/guile-devel/2010-07/msg00125.html>
+# for details.
+guile_install_go_files = install-nobase_goDATA
+$(guile_install_go_files): install-nobase_modDATA
+
+EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES)
+GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat
+SUFFIXES = .scm .go
+.scm.go:
+ $(AM_V_GEN)$(top_builddir)/pre-inst-env $(GUILE_TOOLS) compile $(GUILE_WARNINGS) -o "$@" "$<"
+
+SOURCES = ldp.scm \
+ ldp/resource/unsafe/save.scm \
+ ldp/resource/unsafe/update.scm \
+ ldp/resource/load.scm \
+ ldp/resource/sxml.scm \
+ ldp/resource/xml.scm \
+ ldp/resource/update.scm \
+ ldp/path.scm \
+ ldp/response.scm \
+ ldp/resource.scm \
+ ldp/http-link.scm \
+ ldp/content.scm \
+ ldp/precondition.scm \
+ ldp/etag.scm
+
+TESTS = tests/ldp-primer.scm
+
+TEST_EXTENSIONS = .scm
+SCM_LOG_DRIVER = \
+ $(top_builddir)/pre-inst-env \
+ $(GUILE) --no-auto-compile -e main \
+ $(top_srcdir)/build-aux/test-driver.scm
+
+# Tell 'build-aux/test-driver.scm' to display only source file names,
+# not indivdual test names.
+AM_SCM_LOG_DRIVER_FLAGS = --brief=yes
+
+AM_SCM_LOG_FLAGS = --no-auto-compile -L "$(top_srcdir)"
+
+AM_TESTS_ENVIRONMENT = abs_top_srcdir="$(abs_top_srcdir)"
+
+info_TEXINFOS = doc/ldp.texi
+dvi: # Don't build dvi docs
+
+EXTRA_DIST += README.org \
+ README \
+ HACKING \
+ COPYING \
+ NEWS \
+ AUTHORS \
+ ChangeLog \
+ hall.scm \
+ build-aux/test-driver.scm \
+ $(TESTS)
+
+ACLOCAL_AMFLAGS = -I m4
+
+clean-go:
+ -$(RM) $(GOBJECTS)
+.PHONY: clean-go
+
+CLEANFILES = \
+ $(GOBJECTS) \
+ $(TESTS:tests/%.scm=%.log)
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/build-aux/test-driver.scm b/build-aux/test-driver.scm
new file mode 100644
index 0000000..a818968
--- /dev/null
+++ b/build-aux/test-driver.scm
@@ -0,0 +1,180 @@
+
+;;;; test-driver.scm - Guile test driver for Automake testsuite harness
+
+(define script-version "2019-01-15.13") ;UTC
+
+;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2019 Alex Sassmannshausen <alex@pompo.co>
+;;;
+;;; This program is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;;; Commentary:
+;;;
+;;; This script provides a Guile test driver using the SRFI-64 Scheme API for
+;;; test suites. SRFI-64 is distributed with Guile since version 2.0.9.
+;;;
+;;; This script is a lightly modified version of the orignal written by
+;;; Matthieu Lirzin. The changes make it suitable for use as part of the
+;;; guile-hall infrastructure.
+;;;
+;;;; Code:
+
+(use-modules (ice-9 getopt-long)
+ (ice-9 pretty-print)
+ (srfi srfi-26)
+ (srfi srfi-64))
+
+(define (show-help)
+ (display "Usage:
+ test-driver --test-name=NAME --log-file=PATH --trs-file=PATH
+ [--expect-failure={yes|no}] [--color-tests={yes|no}]
+ [--enable-hard-errors={yes|no}] [--brief={yes|no}}] [--]
+ TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS]
+The '--test-name', '--log-file' and '--trs-file' options are mandatory.
+"))
+
+(define %options
+ '((test-name (value #t))
+ (log-file (value #t))
+ (trs-file (value #t))
+ (color-tests (value #t))
+ (expect-failure (value #t)) ;XXX: not implemented yet
+ (enable-hard-errors (value #t)) ;not implemented in SRFI-64
+ (brief (value #t))
+ (help (single-char #\h) (value #f))
+ (version (single-char #\V) (value #f))))
+
+(define (option->boolean options key)
+ "Return #t if the value associated with KEY in OPTIONS is 'yes'."
+ (and=> (option-ref options key #f) (cut string=? <> "yes")))
+
+(define* (test-display field value #:optional (port (current-output-port))
+ #:key pretty?)
+ "Display 'FIELD: VALUE\n' on PORT."
+ (if pretty?
+ (begin
+ (format port "~A:~%" field)
+ (pretty-print value port #:per-line-prefix "+ "))
+ (format port "~A: ~S~%" field value)))
+
+(define* (result->string symbol #:key colorize?)
+ "Return SYMBOL as an upper case string. Use colors when COLORIZE is #t."
+ (let ((result (string-upcase (symbol->string symbol))))
+ (if colorize?
+ (string-append (case symbol
+ ((pass) "") ;green
+ ((xfail) "") ;light green
+ ((skip) "") ;blue
+ ((fail xpass) "") ;red
+ ((error) "")) ;magenta
+ result
+ "") ;no color
+ result)))
+
+(define* (test-runner-gnu test-name #:key color? brief? out-port trs-port)
+ "Return an custom SRFI-64 test runner. TEST-NAME is a string specifying the
+file name of the current the test. COLOR? specifies whether to use colors,
+and BRIEF?, well, you know. OUT-PORT and TRS-PORT must be output ports. The
+current output port is supposed to be redirected to a '.log' file."
+
+ (define (test-on-test-begin-gnu runner)
+ ;; Procedure called at the start of an individual test case, before the
+ ;; test expression (and expected value) are evaluated.
+ (let ((result (cute assq-ref (test-result-alist runner) <>)))
+ (format #t "test-name: ~A~%" (result 'test-name))
+ (format #t "location: ~A~%"
+ (string-append (result 'source-file) ":"
+ (number->string (result 'source-line))))
+ (test-display "source" (result 'source-form) #:pretty? #t)))
+
+ (define (test-on-test-end-gnu runner)
+ ;; Procedure called at the end of an individual test case, when the result
+ ;; of the test is available.
+ (let* ((results (test-result-alist runner))
+ (result? (cut assq <> results))
+ (result (cut assq-ref results <>)))
+ (unless brief?
+ ;; Display the result of each test case on the console.
+ (format out-port "~A: ~A - ~A~%"
+ (result->string (test-result-kind runner) #:colorize? color?)
+ test-name (test-runner-test-name runner)))
+ (when (result? 'expected-value)
+ (test-display "expected-value" (result 'expected-value)))
+ (when (result? 'expected-error)
+ (test-display "expected-error" (result 'expected-error) #:pretty? #t))
+ (when (result? 'actual-value)
+ (test-display "actual-value" (result 'actual-value)))
+ (when (result? 'actual-error)
+ (test-display "actual-error" (result 'actual-error) #:pretty? #t))
+ (format #t "result: ~a~%" (result->string (result 'result-kind)))
+ (newline)
+ (format trs-port ":test-result: ~A ~A~%"
+ (result->string (test-result-kind runner))
+ (test-runner-test-name runner))))
+
+ (define (test-on-group-end-gnu runner)
+ ;; Procedure called by a 'test-end', including at the end of a test-group.
+ (let ((fail (or (positive? (test-runner-fail-count runner))
+ (positive? (test-runner-xpass-count runner))))
+ (skip (or (positive? (test-runner-skip-count runner))
+ (positive? (test-runner-xfail-count runner)))))
+ ;; XXX: The global results need some refinements for XPASS.
+ (format trs-port ":global-test-result: ~A~%"
+ (if fail "FAIL" (if skip "SKIP" "PASS")))
+ (format trs-port ":recheck: ~A~%"
+ (if fail "yes" "no"))
+ (format trs-port ":copy-in-global-log: ~A~%"
+ (if (or fail skip) "yes" "no"))
+ (when brief?
+ ;; Display the global test group result on the console.
+ (format out-port "~A: ~A~%"
+ (result->string (if fail 'fail (if skip 'skip 'pass))
+ #:colorize? color?)
+ test-name))
+ #f))
+
+ (let ((runner (test-runner-null)))
+ (test-runner-on-test-begin! runner test-on-test-begin-gnu)
+ (test-runner-on-test-end! runner test-on-test-end-gnu)
+ (test-runner-on-group-end! runner test-on-group-end-gnu)
+ (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
+ runner))
+
+;;;
+;;; Entry point.
+;;;
+
+(define (main . args)
+ (let* ((opts (getopt-long (command-line) %options))
+ (option (cut option-ref opts <> <>)))
+ (cond
+ ((option 'help #f) (show-help))
+ ((option 'version #f) (format #t "test-driver.scm ~A" script-version))
+ (else
+ (let ((log (open-file (option 'log-file "") "w0"))
+ (trs (open-file (option 'trs-file "") "wl"))
+ (out (duplicate-port (current-output-port) "wl")))
+ (redirect-port log (current-output-port))
+ (redirect-port log (current-warning-port))
+ (redirect-port log (current-error-port))
+ (test-with-runner
+ (test-runner-gnu (option 'test-name #f)
+ #:color? (option->boolean opts 'color-tests)
+ #:brief? (option->boolean opts 'brief)
+ #:out-port out #:trs-port trs)
+ (load-from-path (option 'test-name #f)))
+ (close-port log)
+ (close-port trs)
+ (close-port out))))
+ (exit 0)))
diff --git a/configure.ac b/configure.ac
new file mode 100644
index 0000000..1f51d55
--- /dev/null
+++ b/configure.ac
@@ -0,0 +1,35 @@
+
+dnl -*- Autoconf -*-
+
+AC_INIT(ldp, UNRELEASED)
+AC_SUBST(HVERSION, "\"UNRELEASED\"")
+AC_SUBST(AUTHOR, "\"Vivien Kraus\"")
+AC_SUBST(COPYRIGHT, "'(2021)")
+AC_SUBST(LICENSE, gpl3+)
+AC_CONFIG_SRCDIR(ldp.scm)
+AC_CONFIG_AUX_DIR([build-aux])
+AM_INIT_AUTOMAKE([1.12 gnu silent-rules subdir-objects color-tests parallel-tests -Woverride -Wno-portability])
+AM_SILENT_RULES([yes])
+
+AC_CONFIG_FILES([Makefile])
+AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env])
+
+dnl Search for 'guile' and 'guild'. This macro defines
+dnl 'GUILE_EFFECTIVE_VERSION'.
+GUILE_PKG([3.0 2.2 2.0])
+GUILE_PROGS
+GUILE_SITE_DIR
+if test "x$GUILD" = "x"; then
+ AC_MSG_ERROR(['guild' binary not found; please check your guile-2.x installation.])
+fi
+
+dnl Hall auto-generated guile-module dependencies
+GUILE_MODULE_REQUIRED([rdf rdf])
+
+dnl Installation directories for .scm and .go files.
+guilemoduledir="${datarootdir}/guile/site/$GUILE_EFFECTIVE_VERSION"
+guileobjectdir="${libdir}/guile/$GUILE_EFFECTIVE_VERSION/site-ccache"
+AC_SUBST([guilemoduledir])
+AC_SUBST([guileobjectdir])
+
+AC_OUTPUT
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.scm b/guix.scm
new file mode 100644
index 0000000..1ef070d
--- /dev/null
+++ b/guix.scm
@@ -0,0 +1,32 @@
+(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))
+
+(package
+ (name "ldp")
+ (version "UNRELEASED")
+ (source "./ldp-UNRELEASED.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/guix/vkraus/packages/ldp.scm b/guix/vkraus/packages/ldp.scm
new file mode 100644
index 0000000..20d3353
--- /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 "UNRELEASED")
+ (source "./ldp-UNRELEASED.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..00615dc
--- /dev/null
+++ b/ldp.scm
@@ -0,0 +1,64 @@
+(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)))
+ (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 (load (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 (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..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))
diff --git a/ldp/response.scm b/ldp/response.scm
new file mode 100644
index 0000000..a822979
--- /dev/null
+++ b/ldp/response.scm
@@ -0,0 +1,102 @@
+(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-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))
+ (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))
+ (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))
+ (allow . ,allow)))
+ #f)))
diff --git a/pre-inst-env.in b/pre-inst-env.in
new file mode 100644
index 0000000..1556fcd
--- /dev/null
+++ b/pre-inst-env.in
@@ -0,0 +1,14 @@
+
+#!/bin/sh
+
+abs_top_srcdir="`cd "@abs_top_srcdir@" > /dev/null; pwd`"
+abs_top_builddir="`cd "@abs_top_builddir@" > /dev/null; pwd`"
+
+GUILE_LOAD_COMPILED_PATH="$abs_top_builddir${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH"
+GUILE_LOAD_PATH="$abs_top_builddir:$abs_top_srcdir${GUILE_LOAD_PATH:+:}:$GUILE_LOAD_PATH"
+export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH
+
+PATH="$abs_top_builddir/scripts:$PATH"
+export PATH
+
+exec "$@"
diff --git a/release b/release
new file mode 100755
index 0000000..9dcd7ee
--- /dev/null
+++ b/release
@@ -0,0 +1,95 @@
+#!/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 .)
+
+rm -rf guix.scm configure.ac Makefile.am pre-inst-env.in build-aux/test-driver.scm
+
+sed -i "s/SNAPSHOT/$VERSION/g" hall.scm || exit 1
+
+hall scan -x || exit 1
+
+hall dist -x || exit 1
+
+hall guix -x || exit 1
+
+sed -i "s/$VERSION/SNAPSHOT/g" hall.scm || exit 1
+
+cp hall.scm guix.scm configure.ac Makefile.am pre-inst-env.in ../ || exit 1
+
+mkdir -p ../build-aux || exit 1
+
+cp build-aux/test-driver.scm ../build-aux || exit 1
+
+cd .. || exit 1
+
+mkdir -p guix/vkraus/packages || exit 1
+
+cat > release.scm <<EOF
+(define-public guile-ldp
+ (package
+ (inherit guile-ldp-local)
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "http://labo.planete-kraus.eu/ldp.git")
+ (commit "$COMMIT")))
+ (sha256
+ (base32
+ "$HASH"))))))
+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
+
+guix environment --ad-hoc --container git -- \
+ git add hall.scm guix.scm \
+ configure.ac Makefile.am pre-inst-env.in \
+ build-aux/test-driver.scm \
+ guix/vkraus/packages/ldp.scm \
+ || exit 1
+
+guix environment --container -l guix.scm -- autoreconf -vif \
+ || exit 1
+
+guix environment --container -l guix.scm -- ./configure \
+ || exit 1
+
+guix environment --container -l guix.scm -- make -j \
+ || exit 1
+
+guix environment --container -l guix.scm -- make -j check \
+ || exit 1
+
+rm -rf pure
diff --git a/tests/ldp-primer.scm b/tests/ldp-primer.scm
new file mode 100644
index 0000000..6f3d5c5
--- /dev/null
+++ b/tests/ldp-primer.scm
@@ -0,0 +1,55 @@
+(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))
+
+(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 "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")