From 59060419ba72773b11ada8aa56a063874b58f5d0 Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Sat, 9 Jan 2021 11:57:23 +0100 Subject: Initial commit --- .gitignore | 65 +++++++++++++++ .guix-channel | 6 ++ AUTHORS | 3 + COPYING | 3 + ChangeLog | 1 + HACKING | 47 +++++++++++ Makefile.am | 90 +++++++++++++++++++++ NEWS | 14 ++++ README | 1 + README.org | 4 + build-aux/test-driver.scm | 180 +++++++++++++++++++++++++++++++++++++++++ configure.ac | 35 ++++++++ doc/ldp.texi | 61 ++++++++++++++ guix.scm | 32 ++++++++ guix/vkraus/packages/ldp.scm | 35 ++++++++ hall.scm | 48 +++++++++++ ldp.scm | 64 +++++++++++++++ ldp/content.scm | 55 +++++++++++++ ldp/etag.scm | 43 ++++++++++ ldp/http-link.scm | 71 ++++++++++++++++ ldp/path.scm | 64 +++++++++++++++ ldp/precondition.scm | 55 +++++++++++++ ldp/resource.scm | 112 +++++++++++++++++++++++++ ldp/resource/load.scm | 57 +++++++++++++ ldp/resource/sxml.scm | 51 ++++++++++++ ldp/resource/unsafe/save.scm | 92 +++++++++++++++++++++ ldp/resource/unsafe/update.scm | 95 ++++++++++++++++++++++ ldp/resource/update.scm | 101 +++++++++++++++++++++++ ldp/resource/xml.scm | 9 +++ ldp/response.scm | 102 +++++++++++++++++++++++ pre-inst-env.in | 14 ++++ release | 95 ++++++++++++++++++++++ tests/ldp-primer.scm | 55 +++++++++++++ 33 files changed, 1760 insertions(+) create mode 100644 .gitignore create mode 100644 .guix-channel create mode 100644 AUTHORS create mode 100644 COPYING create mode 100644 ChangeLog create mode 100644 HACKING create mode 100644 Makefile.am create mode 100644 NEWS create mode 120000 README create mode 100644 README.org create mode 100644 build-aux/test-driver.scm create mode 100644 configure.ac create mode 100644 doc/ldp.texi create mode 100644 guix.scm create mode 100644 guix/vkraus/packages/ldp.scm create mode 100644 hall.scm create mode 100644 ldp.scm create mode 100644 ldp/content.scm create mode 100644 ldp/etag.scm create mode 100644 ldp/http-link.scm create mode 100644 ldp/path.scm create mode 100644 ldp/precondition.scm create mode 100644 ldp/resource.scm create mode 100644 ldp/resource/load.scm create mode 100644 ldp/resource/sxml.scm create mode 100644 ldp/resource/unsafe/save.scm create mode 100644 ldp/resource/unsafe/update.scm create mode 100644 ldp/resource/update.scm create mode 100644 ldp/resource/xml.scm create mode 100644 ldp/response.scm create mode 100644 pre-inst-env.in create mode 100755 release create mode 100644 tests/ldp-primer.scm 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 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 +# +# 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 + + 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 +;;; Copyright © 2019 Alex Sassmannshausen +;;; +;;; 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 . + +;;;; 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 () + (port #:init-keyword #:port #:getter content-port) + (additional #:init-keyword #:additional #:getter content-additional)) + +(define (the-boolean x) + (unless (boolean? x) + (scm-error 'wrong-type-arg + "the-boolean" + "Expected a boolean." + '() + (list x))) + x) + +(define (the-binary-port x) + (unless (binary-port? x) + (scm-error 'wrong-type-arg + "the-binary-port" + "Expected a binary port." + '() + (list x))) + x) + +(define (the-bytevector x) + (unless (bytevector? x) + (scm-error 'wrong-type-arg + "the-bytevector" + "Expected a bytevector." + '() + (list x))) + x) + +(define-public (make-content port additional) + (when (string? additional) + (set! additional (string->utf8 additional))) + (make + #:port (the-binary-port port) + #:additional additional)) + +(define-public (load-content content binary?) + (let ((left (get-bytevector-all (content-port content))) + (right (content-additional content))) + (let ((nl (bytevector-length left)) + (nr (bytevector-length right))) + (let ((total (make-bytevector (+ nl nr)))) + (bytevector-copy! left 0 total 0 nl) + (bytevector-copy! right 0 total nl nr) + (if binary? + total + (utf8->string total)))))) diff --git a/ldp/etag.scm b/ldp/etag.scm new file mode 100644 index 0000000..756766e --- /dev/null +++ b/ldp/etag.scm @@ -0,0 +1,43 @@ +(define-module (ldp etag)) + +(define alphabet + (string-join + '("abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "0123456789" + "-_") + "")) + +(define (generate-etag-letter) + (string-ref alphabet (random (string-length alphabet)))) + +(define (generate-etag-letters n) + (if (<= n 0) + '() + (cons (generate-etag-letter) + (generate-etag-letters (- n 1))))) + +(define-public (generate-etag) + (list->string (generate-etag-letters 16))) + +(define-public (etag? x) + (define (aux i) + (or (>= i (string-length x)) + (and (let ((c (string-ref x i))) + (or (and (char>=? c #\a) (char<=? c #\z)) + (and (char>=? c #\A) (char<=? c #\Z)) + (and (char>=? c #\0) (char<=? c #\9)) + (char=? c #\-) + (char=? c #\_))) + (aux (+ i 1))))) + (and (string? x) + (aux 0))) + +(define-public (the-etag x) + (unless (etag? x) + (scm-error 'wrong-type-arg + "the-etag" + "Expected a string satisfying etag? from (ldp etag)." + '() + (list x))) + x) diff --git a/ldp/http-link.scm b/ldp/http-link.scm new file mode 100644 index 0000000..b750df1 --- /dev/null +++ b/ldp/http-link.scm @@ -0,0 +1,71 @@ +(define-module (ldp http-link) + #:use-module (ice-9 peg) + #:use-module (web uri)) + +(define-peg-string-patterns + "links <-- (link (COMMA / ! link))* +link <-- OPENANGLE uri CLOSEANGLE properties +uri <-- (! CLOSEANGLE .)* +properties <-- (SEMICOLON property)* +property <-- key EQUAL QUOTE value QUOTE +key <-- ([a-zA-Z0-9_]/'-')* +value <-- (! QUOTE ((ESCAPE '\\') / (ESCAPE '\"') / (! ESCAPE .)))* +OPENANGLE < '<' +CLOSEANGLE < '>' +COMMA < ' '* ',' ' '* +SEMICOLON < ' '* ';' ' '* +EQUAL < ' '* '=' ' '* +QUOTE < '\"' +ESCAPE < '\\' +") + +(define (fix-key key) + (unless (and (list? key) + (eq? (car key) 'key)) + (throw 'bad-request)) + (cadr key)) + +(define (fix-value value) + (unless (and (list? value) + (eq? (car value) 'value)) + (throw 'bad-request)) + (cadr value)) + +(define (fix-property prop) + (unless (and (list? prop) + (eq? (car prop) 'property)) + (throw 'bad-request)) + (let ((key (fix-key (cadr prop))) + (value (fix-value (caddr prop)))) + `(,key . ,value))) + +(define (fix-properties props) + (if (eq? props 'properties) + '() + (map fix-property (cdr props)))) + +(define (fix-uri uri) + (unless (and (list? uri) + (eq? (car uri) 'uri) + (string? (cadr uri)) + (string->uri (cadr uri))) + (throw 'bad-request)) + (string->uri (cadr uri))) + +(define (fix-link link) + (unless (and (list? link) + (eq? (car link) 'link)) + (throw 'bad-request)) + (let ((uri (fix-uri (cadr link))) + (properties (fix-properties (caddr link)))) + `(,uri . ,properties))) + +(define (fix-links links) + (unless (and (list? links) + (eq? (car links) 'links)) + (throw 'bad-request)) + (map fix-link (cdr links))) + +(define-public (string->links str) + (let ((tree (peg:tree (match-pattern links str)))) + (fix-links tree))) diff --git a/ldp/path.scm b/ldp/path.scm new file mode 100644 index 0000000..fb25ba2 --- /dev/null +++ b/ldp/path.scm @@ -0,0 +1,64 @@ +(define-module (ldp path) + #:use-module (oop goops) + #:use-module (web uri)) + +(define-class () + (components-rev #:init-keyword #:components-rev #:getter path-components-rev)) + +(export ) + +(define-public (is-root? x) + (equal? (path-components-rev x) '())) + +(define-public (path->filename x) + (if (is-root? x) + "." + (string-append + "./" + (encode-and-join-uri-path + (map (lambda (x) + (string-append "r_" x)) + (reverse (path-components-rev x))))))) + +(define-public (path->uri x) + (let* ((components (reverse (path-components-rev x))) + (relative-to-root (encode-and-join-uri-path components)) + (path (string-append "/" relative-to-root))) + (build-uri-reference #:path path))) + +(define-public (path->string x) + (uri-path (path->uri x))) + +(define-public (uri->path x) + (make + #:components-rev + (reverse (split-and-decode-uri-path (uri-path x))))) + +(define-public (string->path x) + (uri->path (build-uri-reference #:path x))) + +(define-public (path? x) + (is-a? x )) + +(define-public (the-path x) + (unless (path? x) + (scm-error 'wrong-type-arg + "the-path" + "Expected a path from (ldp path)." + '() + (list x))) + x) + +(define-public (path-parent x) + (make #:components-rev (cdr (path-components-rev x)))) + +(define-public (path-cons container slug) + (make + #:components-rev + (cons slug (path-components-rev container)))) + +(define-public (path-slug x) + (car (path-components-rev x))) + +(define-public (path-equal? x y) + (equal? (path-components-rev x) (path-components-rev y))) diff --git a/ldp/precondition.scm b/ldp/precondition.scm new file mode 100644 index 0000000..990193a --- /dev/null +++ b/ldp/precondition.scm @@ -0,0 +1,55 @@ +(define-module (ldp precondition) + #:use-module (ldp etag) + #:use-module (web request) + #:use-module (oop goops)) + +(define-class () + (if-match #:init-keyword #:if-match #:getter precondition-if-match) + (if-none-match #:init-keyword #:if-match #:getter precondition-if-none-match)) + +(define (the-precondition x) + (unless (is-a? x ) + (scm-error 'wrong-type-arg + "the-precondition" + "Expected a precondition." + '() + (list x))) + x) + +(define (the-string x) + (unless (string? x) + (scm-error 'wrong-type-arg + "the-string" + "Expected a string." + '() + (list x))) + x) + +(define-public (make-precondition if-match if-none-match) + (unless if-match + (set! if-match '("*"))) + (unless if-none-match + (set! if-none-match '())) + (set! if-match (map the-string if-match)) + (set! if-none-match (map the-string if-none-match)) + (make + #:if-match if-match + #:if-none-match if-none-match)) + +(define-public (request->precondition request) + (make-precondition + (request-if-match request) + (request-if-none-match request))) + +(define-public (precondition-valid? x etag) + (define (check-matching list) + (and (not (null? list)) + (or (string=? etag (car list)) + (string=? (car list) "*") + (check-matching (cdr list))))) + (define (check-non-matching list) + (or (null? list) + (and (not (string=? etag (car list))) + (check-non-matching (cdr list))))) + (and (check-matching (precondition-if-match x)) + (check-non-matching (precondition-if-none-match x)))) diff --git a/ldp/resource.scm b/ldp/resource.scm new file mode 100644 index 0000000..6720499 --- /dev/null +++ b/ldp/resource.scm @@ -0,0 +1,112 @@ +(define-module (ldp resource) + #:use-module (ldp path) + #:use-module (ldp etag) + #:use-module (oop goops) + #:use-module (web uri)) + +;; If contained is #f, then this is not a container. Otherwise, this +;; is a container, possibly empty (null) +(define-class () + (path #:init-keyword #:path #:getter resource-path) + (etag #:init-keyword #:etag #:getter resource-etag) + (content-type #:init-keyword #:content-type #:getter resource-content-type) + (contained #:init-keyword #:contained #:getter resource-contained)) + +(export resource-path + resource-etag + resource-content-type + resource-contained) + +(define (the-symbol x) + (unless (symbol? x) + (scm-error 'wrong-type-arg + "the-symbol" + "Expected a symbol, got ~s." + (list x) + (list x))) + x) + +(define-public (make-resource path etag content-type contained) + (unless (or (not contained) + (eq? content-type 'text/turtle)) + (throw 'containers-should-be-rdf)) + (make + #:path (the-path path) + #:etag (the-etag etag) + #:content-type (the-symbol content-type) + #:contained (and contained + (map the-path contained)))) + +(define-public (resource? x) + (is-a? x )) + +(define-public (container? x) + (and (resource? x) + (resource-contained x))) + +(define-public (the-resource x) + (unless (resource? x) + (scm-error 'wrong-type-arg + "the-non-container" + "Expected a resource from (ldp resource)." + '() + (list x))) + x) + +(define-public (the-container x) + (unless (container? x) + (scm-error 'wrong-type-arg + "the-container" + "Expected a container from (ldp resource)." + '() + (list x))) + x) + +(define-method (has-child? (container ) (child )) + (define (check list) + (and (not (null? list)) + (or (path-equal? (car list) child) + (check (cdr list))))) + (check (resource-contained container))) + +(export has-child?) + +(define-public (add-child container child) + (set! container (the-container container)) + (set! child (the-path child)) + (if (has-child? container child) + (throw 'child-already-exists) + (make-resource (resource-path container) + (generate-etag) + (resource-content-type container) + (cons child (resource-contained container))))) + +(define-public (remove-child container child) + (set! container (the-container container)) + (set! child (the-path child)) + (define (check found kept list) + (if (null? list) + (if found + (reverse kept) + (throw 'child-does-not-exist)) + (if (path-equal? (car list) child) + (check #t kept (cdr list)) + (check found (cons (car list) kept) (cdr list))))) + (make-resource (resource-path container) + (generate-etag) + (resource-content-type container) + (check #f '() (resource-contained container)))) + +(define-public (update-children container added removed) + (set! container (the-container container)) + (set! added (map the-path added)) + (set! removed (map the-path removed)) + (cond + ((and (null? added) (null? removed)) + container) + ((null? added) + (update-children (remove-child container (car removed)) + '() (cdr removed))) + (else + (update-children (add-child container (car added)) + (cdr added) removed)))) diff --git a/ldp/resource/load.scm b/ldp/resource/load.scm new file mode 100644 index 0000000..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 , + . +" + (path->string (resource-path resource))) + "")) + (containment-triples + (if (and (container? resource) + (not (null? (resource-contained resource)))) + (format #f " + a ~a . +" + (path->string (resource-path resource)) + (string-join + (map (lambda (p) + (format #f "" + (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 <; rel=\"type\"\r\n\ +Slug: alice\r\n\r\n" + read-request)) + (request-body "@prefix dcterms: . +@prefix ldp: . + + a ldp:Container, ldp:BasicContainer; + dcterms:title 'Alice’s data storage on the Web' .")) + (call-with-values (lambda () (respond request request-body)) + (lambda (response response-body) + (test-equal "Slug is respected on empty container" + (string->uri-reference "/alice") + (response-location response))))) +(test-end "setup") + +(test-begin "cleanup") +(let ((request + (call-with-input-string "DELETE /alice HTTP/1.1\r\n\ +Host: example.org\r\n\r\n" + read-request)) + (request-body #f)) + (call-with-values (lambda () (respond request request-body)) + (lambda (response response-body) + (test-eq "Cleaning OK" + 200 + (response-code response))))) +(test-end "cleanup") + +(delete-file "representation/manifest.xml") +(delete-file "representation/content") +(rmdir "representation") +(chdir "..") +(rmdir "primer") -- cgit v1.2.3