diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-01-09 11:57:23 +0100 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-01-10 14:33:51 +0100 |
commit | 59060419ba72773b11ada8aa56a063874b58f5d0 (patch) | |
tree | 02bd39d5ec527a3ddfbd289fed88367e5a63d2c4 |
Initial commit0.0.0
-rw-r--r-- | .gitignore | 65 | ||||
-rw-r--r-- | .guix-channel | 6 | ||||
-rw-r--r-- | AUTHORS | 3 | ||||
-rw-r--r-- | COPYING | 3 | ||||
-rw-r--r-- | ChangeLog | 1 | ||||
-rw-r--r-- | HACKING | 47 | ||||
-rw-r--r-- | Makefile.am | 90 | ||||
-rw-r--r-- | NEWS | 14 | ||||
l--------- | README | 1 | ||||
-rw-r--r-- | README.org | 4 | ||||
-rw-r--r-- | build-aux/test-driver.scm | 180 | ||||
-rw-r--r-- | configure.ac | 35 | ||||
-rw-r--r-- | doc/ldp.texi | 61 | ||||
-rw-r--r-- | guix.scm | 32 | ||||
-rw-r--r-- | guix/vkraus/packages/ldp.scm | 35 | ||||
-rw-r--r-- | hall.scm | 48 | ||||
-rw-r--r-- | ldp.scm | 64 | ||||
-rw-r--r-- | ldp/content.scm | 55 | ||||
-rw-r--r-- | ldp/etag.scm | 43 | ||||
-rw-r--r-- | ldp/http-link.scm | 71 | ||||
-rw-r--r-- | ldp/path.scm | 64 | ||||
-rw-r--r-- | ldp/precondition.scm | 55 | ||||
-rw-r--r-- | ldp/resource.scm | 112 | ||||
-rw-r--r-- | ldp/resource/load.scm | 57 | ||||
-rw-r--r-- | ldp/resource/sxml.scm | 51 | ||||
-rw-r--r-- | ldp/resource/unsafe/save.scm | 92 | ||||
-rw-r--r-- | ldp/resource/unsafe/update.scm | 95 | ||||
-rw-r--r-- | ldp/resource/update.scm | 101 | ||||
-rw-r--r-- | ldp/resource/xml.scm | 9 | ||||
-rw-r--r-- | ldp/response.scm | 102 | ||||
-rw-r--r-- | pre-inst-env.in | 14 | ||||
-rwxr-xr-x | release | 95 | ||||
-rw-r--r-- | tests/ldp-primer.scm | 55 |
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: @@ -0,0 +1,3 @@ +Contributers to Ldp SNAPSHOT: + + Vivien Kraus <INSERT EMAIL HERE> @@ -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 @@ + @@ -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) @@ -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 @@ -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) "[0;32m") ;green + ((xfail) "[1;32m") ;light green + ((skip) "[1;34m") ;blue + ((fail xpass) "[0;31m") ;red + ((error) "[0;35m")) ;magenta + result + "[m") ;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" ()))))) @@ -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 "$@" @@ -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") |