diff options
214 files changed, 12578 insertions, 2004 deletions
@@ -1,5 +1,6 @@ .PHONY: all clean test \ check \ + litmus \ static \ go_files \ lcov.info @@ -18,7 +19,8 @@ SCM_FILES = $(shell find module/ -type f -name \*.scm) GO_FILES = $(SCM_FILES:module/%.scm=obj-$(GUILE_VERSION)/%.go) GUILE_ENV = GUILE_LOAD_PATH=$(PWD)/module \ - GUILE_LOAD_COMPILED_PATH=$(PWD)/obj-$(GUILE_VERSION) + GUILE_LOAD_COMPILED_PATH=$(PWD)/obj-$(GUILE_VERSION) \ + GUILE_AUTO_COMPILE=0 GUILE_C_FLAGS = -Lmodule \ -Wshadowed-toplevel -Wunbound-variable \ @@ -34,10 +36,10 @@ LIMIT_FILES=$(LIMIT:%=--only %) # Skip these files when testing SKIP=--skip $(PWD)/tests/test/web-server.scm -all: go_files README static $(LOCALIZATIONS) +all: go_files static $(LOCALIZATIONS) $(MAKE) -C doc/ref -XGETTEXT_FLAGS = --from-code=UTF-8 --add-comments --indent -k_ +XGETTEXT_FLAGS = --from-code=UTF-8 --add-comments --indent -kG_ static: $(MAKE) -C static @@ -68,17 +70,13 @@ install: all install -d $(DESTDIR)$(GUILE_SITE_DIR) $(DESTDIR)$(GUILE_CCACHE_DIR) rsync -a module/ $(DESTDIR)$(GUILE_SITE_DIR) rsync -a obj-$(GUILE_VERSION)/ $(DESTDIR)$(GUILE_CCACHE_DIR) - install -d $(DESTDIR)/usr/share/calp/www $(MAKE) -C static install $(MAKE) -C system install $(MAKE) -C doc/ref install - install -m 644 -D -t $(DESTDIR)/usr/share/doc/calp README + install -m 644 -D -t $(DESTDIR)/usr/share/doc/calp README.md install -m 755 -D -t $(DESTDIR)/usr/lib/calp/ scripts/tzget install -m755 -D production-main $(DESTDIR)/usr/bin/calp -README: README.in - ./main text < README.in | sed "s/<<today>>/`date -I`/" > README - lcov.info: $(GO_FILES) env DEBUG=0 tests/run-tests.scm --coverage=$@ $(if $(VERBOSE),--verbose) $(SKIP) $(LIMIT_FILES) @@ -94,3 +92,6 @@ coverage: lcov.info check: tests/run-tests.scm $(if $(VERBOSE),--verbose) $(SKIP) $(LIMIT_FILES) + +litmus: + tests/litmus.scm $(path) diff --git a/README b/README deleted file mode 100644 index 23643d42..00000000 --- a/README +++ /dev/null @@ -1,81 +0,0 @@ -make[1]: Entering directory '/home/hugo/code/calp' -make[1]: Nothing to be done for 'go_files'. -make[1]: Leaving directory '/home/hugo/code/calp' - CALP - Hugo Hörnquist - 2022-03-04 - -Calp is primarily a program for loading calendar files (.ics's) from -drendering them in different formats. The goal is however to also -support fancy filtering, an edit server, and more. The currently -working frontends is the HTML-frontend, which have the two main -modes of a month-by-month in "week" view, or a table of a single -month, and the terminal frontend. The terminatend is mostly for -debugging purposes, but it's quite usable still. - -Configuration is set in ~/.config/calp/config.scm. Set at least -calendar-files with something like: - (set-config! 'calendar-files (glob "~/calendars/*")). -Both single calendar files, and vdir's are supported, see vdirsyncer -and ikhal. Then run - ./main --help -to see how to start the different modes. - -Contributing ------------- -Easiest is to open issues at https://github.com/HugoNikanor/calp. -But patches and the like can also be mailed to <hugo@lysator.liu.se> - -Requirements & Dependencies ---------------------------- -For basic functionallity guile-2.2 or greater should be enough -(tested to work with guile-3.0). You do however need to supply your -own calendar files. I recommend vdirsyncer for fetching local copies -from all over the internet. - -The zoneinfo data [TZ] is in the public domain [TZLIC]. - -Standards and specifications ----------------------------- -- RFC 5545 (iCalendar) -- RFC 6321 (xCal) -- RFC 7265 (jCal) -- Vdir Storage Format [VDIR] - -Building & Running ------------------- -Everything can be directly loaded due to Guile's auto-compilation. -However, two entry points are provided. -- `main', which sets up its own environment, and explicitly builds -all libraries before starting, and -- `production-main', which assumes that the environment already is -fine, and is the version which should be installed. - -The code can also be explicitly manually built, see the makefile. - -The environment/make variable GUILE can be set to another guile -binary, such as `guile3'. -Guild by defaults also uses this, but if a separate guild version is -explicitly required then the env/make var GUILD can be set (but this -shouldn't be needed). - -Techical Details ----------------- -- Internally all weeks start on sunday, which is repsenented as `0'. - -== The configuration system == -For all user provided variables a purpose built configuration system -is used. Thee module `(util config)` exposes the bindings -`define-config` along with `set-config` and `get-config`. The idea -behind this, instead of direct variables, is to make it clearer what -is part of the configurable environment, it allows a set! before the -point of definition, and it makes values constraints easier to -manage. - -References ----------- - -[TZ] https://github.com/eggert/tz -[TZLIC] https://github.com/eggert/tz/blob/master/LICENSE -[VDIR] http://vdirsyncer.pimutils.org/en/latest/vdir.html - diff --git a/README.in b/README.in deleted file mode 100644 index d0abb27e..00000000 --- a/README.in +++ /dev/null @@ -1,54 +0,0 @@ - CALP - Hugo Hörnquist - <<today>> - -Calp is primarily a program for loading calendar files (.ics's) from drendering them in different formats. The goal is however to also support fancy filtering, an edit server, and more. The currently working frontends is the HTML-frontend, which have the two main modes of a month-by-month in "week" view, or a table of a single month, and the terminal frontend. The terminatend is mostly for debugging purposes, but it's quite usable still. - -Configuration is set in ~/.config/calp/config.scm. Set at least calendar-files with something like: - (set-config! 'calendar-files (glob "~/calendars/*")). -Both single calendar files, and vdir's are supported, see vdirsyncer and ikhal. Then run - ./main --help -to see how to start the different modes. - -Contributing ------------- -Easiest is to open issues at https://github.com/HugoNikanor/calp. But patches and the like can also be mailed to <hugo@lysator.liu.se> - -Requirements & Dependencies ---------------------------- -For basic functionallity guile-2.2 or greater should be enough (tested to work with guile-3.0). You do however need to supply your own calendar files. I recommend vdirsyncer for fetching local copies from all over the internet. - -The zoneinfo data [TZ] is in the public domain [TZLIC]. - -Standards and specifications ----------------------------- -- RFC 5545 (iCalendar) -- RFC 6321 (xCal) -- RFC 7265 (jCal) -- Vdir Storage Format [VDIR] - -Building & Running ------------------- -Everything can be directly loaded due to Guile's auto-compilation. -However, two entry points are provided. -- `main', which sets up its own environment, and explicitly builds all libraries before starting, and -- `production-main', which assumes that the environment already is fine, and is the version which should be installed. - -The code can also be explicitly manually built, see the makefile. - -The environment/make variable GUILE can be set to another guile binary, such as `guile3'. -Guild by defaults also uses this, but if a separate guild version is explicitly required then the env/make var GUILD can be set (but this shouldn't be needed). - -Techical Details ----------------- -- Internally all weeks start on sunday, which is repsenented as `0'. - -== The configuration system == -For all user provided variables a purpose built configuration system is used. Thee module `(util config)` exposes the bindings `define-config` along with `set-config` and `get-config`. The idea behind this, instead of direct variables, is to make it clearer what is part of the configurable environment, it allows a set! before the point of definition, and it makes values constraints easier to manage. - -References ----------- - -[TZ] https://github.com/eggert/tz -[TZLIC] https://github.com/eggert/tz/blob/master/LICENSE -[VDIR] http://vdirsyncer.pimutils.org/en/latest/vdir.html diff --git a/README.md b/README.md new file mode 100644 index 00000000..8257f728 --- /dev/null +++ b/README.md @@ -0,0 +1,74 @@ +CALP +==== + +Calp is primarily a program for loading calendar files (.ics's) from +drendering them in different formats. The goal is however to also +support fancy filtering, an edit server, and more. The currently +working frontends is the HTML-frontend, which have the two main modes +of a month-by-month in "week" view, or a table of a single month, and +the terminal frontend. The terminatend is mostly for debugging +purposes, but it's quite usable still. + +Configuration is set in `~/.config/calp/config.scm`. Set at least +calendar-files with something like: + + (set-config! 'calendar-files (glob "~/calendars/*")). +Both single calendar files, and vdir's are supported, see vdirsyncer +and ikhal. Then run + + ./main --help +to see how to start the different modes. + +Contributing +------------ +Easiest is to open issues at https://github.com/HugoNikanor/calp. But +patches and the like can also be mailed to <hugo@lysator.liu.se> + +Requirements & Dependencies +--------------------------- +For basic functionallity guile-2.2 or greater should be enough (tested +to work with guile-3.0). You do however need to supply your own +calendar files. I recommend vdirsyncer for fetching local copies from +all over the internet. + +The [zoneinfo data][TZ] is in [the public domain][TZLIC]. + +Standards and specifications +---------------------------- +- RFC 5545 (iCalendar) +- RFC 6321 (xCal) +- RFC 7265 (jCal) +- [Vdir Storage Format][VDIR] + +Building & Running +------------------ +Everything can be directly loaded due to Guile's auto-compilation. +However, two entry points are provided. + +- `main`, which sets up its own environment, and explicitly builds all + libraries before starting, and +- `production-main`, which assumes that the environment already is + fine, and is the version which should be installed. + +The code can also be explicitly manually built, see the makefile. + +The environment/make variable `GUILE` can be set to another guile +binary, such as `guile3`. Guild by defaults also uses this, but if a +separate guild version is explicitly required then the env/make var +`GUILD` can be set (but this shouldn't be needed). + +Techical Details +---------------- +- Internally all weeks start on sunday, which is repsenented as `0`. + +### The configuration system +For all user provided variables a purpose built configuration system +is used. Thee module `(util config)` exposes the bindings +`define-config` along with `set-config` and `get-config`. The idea +behind this, instead of direct variables, is to make it clearer what +is part of the configurable environment, it allows a set! before the +point of definition, and it makes values constraints easier to manage. + +[TZ]: https://github.com/eggert/tz +[TZLIC]: https://github.com/eggert/tz/blob/master/LICENSE +[VDIR]: http://vdirsyncer.pimutils.org/en/latest/vdir.html @@ -6,9 +6,20 @@ XDG_CONFIG_HOME Liknande för cache, genererade filer, med mera Både när programmet körs som användare och som systemtjänst. +Byt lagringsplats för kalenderfiler +----------------------------------- +~/.local/var/cal +borde vara ~/.local/share/cal +kanske... + +Kalenderfilerna "tillhör" inte det här programmet... + HTML ==== +Vallidering att DTEND > DTSTART +------------------------------- + Mycket små events ----------------- @@ -47,6 +58,22 @@ Antingen: - generera nya from tzdb. +quoted-string i params +---------------------- + LOCATION;ALTREP="https://old.liu.se/karta/?l=sv&px_type=2&px_id=399":Ada Lovelace +Bör tolkas som + key: LOCATION + params: + ALTREP: https://old.liu.se/karta/?l=sv&px_type=2&px_id=399 + value: Ada Lovelace +Men tolkas för nuvarande som + key: LOCATION + params: + ALTREP: HTTPS + value: //old.liu.se/karta/?l=sv&px_type=2&px_id=399":Ada Lovelace + + + Text ==== Bibehåll ledande whitespace vid radbrott. diff --git a/doc/ref/Makefile b/doc/ref/Makefile index 79486a46..64b3dda3 100644 --- a/doc/ref/Makefile +++ b/doc/ref/Makefile @@ -6,7 +6,7 @@ INFOFLAGS := --no-split all: calp.info calp.info: $(TEXI_FILES) - makeinfo -o $@ $(INFOFLAGS) calp.texi + $(MAKEINFO) -o $@ $(INFOFLAGS) calp.texi install: all install -m644 -D -t $(DESTDIR)/usr/share/info/ calp.info diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index 58c162e1..78fe2293 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -1,6 +1,8 @@ @node Guile @chapter Guile +@include guile/data-formats.texi +@include guile/data-stores.texi @include guile/datetime.texi @include guile/zic.texi @include guile/srfi-41.texi @@ -12,6 +14,8 @@ @include guile/base64.texi @include guile/web.texi @include guile/vcomponent.texi +@include guile/sxml.texi +@include guile/webdav.texi @node Errors and Conditions @section Errors and Conditions diff --git a/doc/ref/guile/data-formats.texi b/doc/ref/guile/data-formats.texi new file mode 100644 index 00000000..037d3ae7 --- /dev/null +++ b/doc/ref/guile/data-formats.texi @@ -0,0 +1,25 @@ +@node Data Formats +@section Data Formats +A data format is some way that an individual event may get serialized +to disk. The default is iCalendar (TODO reference RFC 5545), but +others might be available (TODO footnote and reference xcal). + +Each available format should be included as +@code{(vcomponent formats @var{format-name})}. +Which module corresponds to what file type is currently defined out of band. + +Each module should expose the following procedures. + +@defun serialize component port +Write a serialized representation of @var{component} to @var{port}. +@end defun + +@defun deserialize port +Read a serialized representation of a component from @var{port}, and +return the deserialized instance of this object. +@end defun + +@subsection iCalendar +RFC 5545 + +@subsection xCal diff --git a/doc/ref/guile/data-stores.texi b/doc/ref/guile/data-stores.texi new file mode 100644 index 00000000..ec3962da --- /dev/null +++ b/doc/ref/guile/data-stores.texi @@ -0,0 +1,36 @@ +@node Data Stores +@section Data Stores +Data stores are persistant stores for events, such as databases or the +file system. Each data store can support any number of data formats, +but which is an implementation detail of that format and shouldn't be +needed information from the high level view. +@footnote{It is however important for interoperability with other programs}. + +@c (make <calendar-store> #:path ``hello'') + +@defun path store +@end defun + +@deftp {GOOPS method} get-calendar this +Returns a vcomponent object of type @code{VCALENDAR}. Should contain +all @code{VEVENT} components of this calendar. +@end deftp + +@deftp {GOOPS method} get-by-uid this uid +Return the event object with UID equal to the string @var{uid}. +@end deftp + +@deftp {GOOPS method} queue-save this event +Queue a save event of @var{event} to the store. +@end deftp + +@deftp {GOOPS method} flush this +Force write of all queued actions. +@end deftp + +@subsection VDir +[VDIR]: http://vdirsyncer.pimutils.org/en/latest/vdir.html + +@subsection File + +@subsection SQLite diff --git a/doc/ref/guile/sxml.texi b/doc/ref/guile/sxml.texi new file mode 100644 index 00000000..dd635b4c --- /dev/null +++ b/doc/ref/guile/sxml.texi @@ -0,0 +1,100 @@ +@node sxml namespaced +@section Namespaced SXML + +Namespaces is a variant to ``regular'' SXML. Difference being that +instead of representing XML-tags as symbols, they are instead actual +objects. + +For example +@example +`(a (b "Content")) +@end example + +Would be represented as +@example +`(,(xml 'a) + (,(xml 'b) + "Content")) +@end example + +@defun namespaced-sxml->sxml tree [namespace-prefixes='()] +Takes a tree of namespaced-sxml, and optionally an assoc list from +namespace symbols, to prefered prefix. + +Returns a sxml tree, with xmlns:<prefix>=namespace attributes +@end defun + +@defun namespaced-sxml->xml tree [namespaces='()] [port='(current-output-port)] +Serializes the namespaced sxml tree to port. @var{namespaces} should +be an association list from namespace symbols, to prefered prefixes. +@end defun + +@defun namespaced-sxml->sxml/namespaces tree [namespace-prefixes='()] +Returns two values: +@itemize +@item An SXML tree (which doesn't have namespace attributes) +@item an association list from namespace symbols, to used prefixes. +@end itemize +@end defun + +@c xml->namespcaed-sxml and sxml->namespaced-sxml don't share +@c implementation, despite doing almost the same thing. This is since +@c xml->namespaced-sxml directly uses the ssax parser, giving us great +@c controll, while sxml->namespaced-sxml attempt to look at symbols. + +@defun xml->namespaced-sxml port-or-string +Reads xml from port, and return a namespaced SXML tree. +@end defun + +@defun sxml->namespaced-sxml tree namespaces +Converts a ``regular'' SXML tree into a namespaced sxml tree. +@var{namespaces} must be an association list which maps each prefix +used in @var{tree} onto a full XML namespace. + +The key @code{#f} can be used to map non-namespaced elements into a +namespace. +@end defun + +@defun xml tag +@defunx xml ns tag [attrs] +@anchor{xml-tag} + A single XML element, suitable to go as the car of a list to + create a full object. + + @var{xml} is a shorthand to @code{make-xml-element}, which + either takes just a tag (for non-namespaced elements), or a + namespace, a tag, and a list of attributes. + + @itemize + @item @var{tag} should be a symbol. + @item @var{ns} should be a symbol. + @item @var{attrs} should be a hash table. + @end itemize + + @defun make-xml-element tagname namespace attributes + @end defun + + @defun xml-element? x + @end defun + + @defun xml-element-tagname el + @end defun + + @defun xml-element-namespace el + @end defun + + @defun xml-element-attributes el + @end defun +@end defun + + +@defun make-pi-element tag body + @defun pi-element? x + @end defun + + @defun pi-tag pi + @end defun + + @defun pi-body pi + @end defun +@end defun diff --git a/doc/ref/guile/util-path.texi b/doc/ref/guile/util-path.texi index 322c50ec..9cf41b40 100644 --- a/doc/ref/guile/util-path.texi +++ b/doc/ref/guile/util-path.texi @@ -3,7 +3,10 @@ Provided by the module @code{(hnh util path)}. -See also @code{absolute-file-name?} from Guile. + +@defun path-absolute? string +Alias of @code{absolute-file-name?} from Guile. +@end defun @defun path-append strings ... Joins all strings into a path, squeezing duplicated delimiters, but @@ -33,10 +36,33 @@ The first component will be @code{""} if path is absolute. @defun filename-extension filename -Returns the extension of the filename, or the empty string if none exists. +Returns the extension of the filename without a leading period, or the +empty string if none exists. + +@example +(filename-extension "file.tar.gz") +⇒ "gz" +@end example @end defun @defun realpath path Equivalent of realpath(3). Absolute file names are returned as is, while relative filenames gets expanded to absolute filenames. @end defun + +@defun relative-to base path +Returns @var{path} as a relative path relative to @var{base}. + +base must be non-empty +@example +(relative-to "/some" "/some/path") +;; ⇒ "path" + +(relative-to "/some" "/other/path/") +;; ⇒ "../path" + +(relative-to "/a/b/c" "/a/b") +;; ⇒ "/a/b" +@end example + +@end defun diff --git a/doc/ref/guile/util.texi b/doc/ref/guile/util.texi index 32df5fce..1d35e0bf 100644 --- a/doc/ref/guile/util.texi +++ b/doc/ref/guile/util.texi @@ -113,6 +113,11 @@ See @var{find-extreme} @end lisp @end defun +@defun init+last list +Returns two values: everything except the last element of @var{list}, +and the last element of @var{list}. +@end defun + @defun take-to lst n Equivalent to @var{take}, but return everything (instead of crash) if n > (length lst). @@ -175,8 +180,8 @@ pairs of symbols and values. @lisp (kvlist->assq '(#:a 1 #:b "Hello")) -⇒ ((a 1) - (b "Hello")) +⇒ ((a . 1) + (b . "Hello")) @end lisp @end defun @@ -188,6 +193,8 @@ pairs of symbols and values. Calls @var{proc} on each element in @var{lst}, and return a association list which @code{(proc e)} as its keys, and all elements which mapped to that value. + +The values returned by @var{proc} are compared as per @code{equal?}. @end defun @defun split-by lst element @@ -219,7 +226,9 @@ list, whose indices matches the order of the inputs @end defun @defun string-flatten tree -@c TODO document me +Given an arbitary tree, do a pre-order traversal, appending all strings. + +Non-strings are converted to strings, and also appended. @end defun @defun intersperse item list @@ -227,7 +236,7 @@ Inserts @var{item} between each element in @var{list}. @end defun -@defun insert-ordered item collection [<=<] +@defun insert-ordered item collection [<] Inserts @var{item} into @var{collection}, such that collection remainins sorted if it was sorted beforehand. @end defun @@ -315,10 +324,18 @@ Similar to @var{let}, but sets environment variables for the code in body. Restores the old values once we leave. @end defmac +@defmac with-locale1 category locale thunk +Run @var{thunk} with the locale @var{category} temporarily set to +@var{locale}. +@end defmac + @defmac catch* thunk (symbol proc) ... Macro allowing multiple exception types to be caught. Each (symbol proc) pair expands to a regular @code{catch}, with the leftmost being innermost. + +@var{Symbol} can also be on the form @code{(pre-unwind @var{symbol})}, +then @code{with-throw-handler} is used instead of @code{catch}. @end defmac @subsection UUID generation @@ -332,3 +349,40 @@ Generates a UUID-v4 string. @defun uuid Generates an implementation defined (but guaranteed valid) UUID. @end defun + +@subsection IO + +Provided by module @code{(hnh util io)}. + +@defun open-input-port path +@defunx open-output-port path +Like @code{open-*-file}, but ``-'' gives @code{standard-@{input,output@}}. +@end defun + +@defun read-lines port +Return a list of all lines read from port. +@end defun + +@defun with-atomic-output-to-file filename thunk +Same functionality as the regular @var{with-output-to-file}, but +with the difference that either everything is written, or nothing +is written, and if anything is written it's all written atomicaly at +once (the original file will never contain an intermidiate state). +Does NOT handle race conditions between threads. + +propagates the return value of @var{thunk} upon successfully writing +the file, and @code{#f} otherwise. +@end defun + +@defun call-with-tmpfile proc [#:tmpl ``/tmp/file-XXXXXXX''] +@end defun + +@defun ->port port-or-strings +If @var{port-or-string} is a port, return it directly. If it's a +string, instead return an input string containing the strings content. +@end defun + +@c Is this even a procedure? +@defun read-file path +Open file at path, and return its content as a string. +@end defun diff --git a/doc/ref/guile/vcomponent.texi b/doc/ref/guile/vcomponent.texi index 299ae1da..2560bdde 100644 --- a/doc/ref/guile/vcomponent.texi +++ b/doc/ref/guile/vcomponent.texi @@ -106,6 +106,8 @@ Curried version of @var{prop}. @end deftp @defun copy-vcomponent vcomponent +Creates a shallow copy of @var{vcomponent}. If the source object has a +parent, then than parent adopts the new event also. @end defun @@ -115,3 +117,42 @@ Does symbol start with ``X-''? @defun internal-field? symb [prefix="-"] @end defun + +@node VComponent Create +@section (vcomponent create) + +Procedures for declarativly creating components (instead of the +primitive procedural API). + +@defun vcomponent type [key: prop] ... children +Creates a new vcomponent of @var{type}. Each kv-pair should contain a +keyword @var{key}, and a value which is either a direct value, or the +return value of @code{with-parameters} or +@code{as-list}. @var{children} should be a list of other vcomponent's. +@end defun + +@defun vcalendar +@defunx vevent +@defunx vtimezone +@defunx standard +@defunx daylight +Calls @code{vcomponent}, with type set to the procedure name (but +up-cased). +@end defun + +@defun with-parameters [key: param] ... value +Allows setting parameters for a property as created by @code{vcomponent}. + +@var{value} follows the same rules as in @code{vcomponent}. Multiple +@var{key}, @var{value} pairs can be given, where each key must be a keyword. +@end defun + +@defun as-list lst +Allows setting list values when using @code{vcomponent}. + +Without this a list value would be stored as a single value, while +with this a list of values is instead stored (as, for example, in EXDATE). + +A list of list types could be hard-coded, but even then this procedure +is needed since custom types might need it. +@end defun diff --git a/doc/ref/guile/webdav.texi b/doc/ref/guile/webdav.texi new file mode 100644 index 00000000..a495c945 --- /dev/null +++ b/doc/ref/guile/webdav.texi @@ -0,0 +1,301 @@ +@node WebDAV +@section WebDAV + +For a complete view of WebDAV, please see @cite{RFC4918 (HTTP +Extensions for Web Distributed Authoring and Versioning (WebDAV))}, +but in short, and specifc for this implementation. + +A DAV tree consists of resources, which are analogous to files and +directories. A resource is referenced by its href. + +Each resources is either a collection and have children, or have +content. Parts of this implementation allows a collection to also have +contents, while other does not. The standard doesn't seem to mind +either way. + +Each resource also has a set of properties, modelling metadata and +extra data about the resource. + +@emph{href}'s are internally represented as lists of strings, where the +root element ``/'' is an empty list, and all other cases are mapped +like: +@example +"/a/b" ⇒ '("a" "b") +@end example + +@emph{resources} are GOOPS objects, which the base class +@code{<resource>}. + +The user (of the library) is assumed to designate one resource +instance as the root of the resource tree. All other resources are +then added as (grand-)children to that resource. Each resource has a +field @var{name}, which is the normative name used when searching by +name in the tree@footnote{This means that one resource can't easily +exist at multiple points in the tree}. + +@emph{properties} are split into live and dead properties, where live +properties have extra handling by the server, while dead properties +are simply carried along after the end-user put them on a resource. + +Live properties are handled through GOOPS methods. + +Dead properties are (by default) stored directly inside each resource. + +@node WebDAV Properties +@subsection Properties + +@itemize +@item @code{(calp webdav property)} +@item @code{(calp webdav propfind)} +@end itemize + +@subsubsection Default Live Properties + +@deftp {GOOPS method} creationdate +@end deftp + +@deftp {GOOPS method} displayname +@end deftp + +@deftp {GOOPS method} getcontentlanguage +@end deftp + +@deftp {GOOPS method} getcontentlength +@end deftp + +@deftp {GOOPS method} getcontenttype +@end deftp + +@deftp {GOOPS method} getetag +@end deftp + +@deftp {GOOPS method} getlastmodified +@end deftp + +@deftp {GOOPS method} lockdiscovery +@end deftp + +@deftp {GOOPS method} resourcetype +@end deftp + +@deftp {GOOPS method} supportedlock +@end deftp + + +@node WebDAV Resources +@subsection Resources + +@deftp {GOOPS class} <resource> +Base type for all WebDAV resources. + +The base class shouldn't be directly instanciated. + + @defun resource? x + Is the given object a <resource>, or decendant? + @end defun +@end deftp + +@deftp {GOOPS method} name resource +The name of a resource is the local part of a href. +@end deftp + +@deftp {GOOPS method} children resource +All direct children of a resource, as a list. +@end deftp + +@defun add-child! parent child [#:overwrite?] [#:collection?=(is-collection? child)] +Adds a resource as a child of another resource. + +Before adding the resource to the parents child set, +@code{(setup-new-resource! child parent)} is called. If +@var{collection?} is true, then +@code{(setup-new-collection! child parent)} is also called. + +If @var{overwrite?} is present, then the parent will be checked for a +child which already has that name, and take action accordingly. +It will return one of: @code{'replaced} if a resource already existed +with that name, but it has been replaced, @code{'collision}, if the +old one was kept, and @code{'created} if the new resource was added +without collisions. + +If @var{overwrite?} is absent then the method always returns @var{'created}. +@end defun + +@defun add-resource! resource name content +Creates a new resource with the given name, and make it a child of +@var{self}. Setting its initial content to @var{content}. + +Calls @code{add-resource!}, so the same book-keeping procedures are called. +@c TODO Document throw +@c TODO Document return +@end defun + +@defun add-collection! resource name +Similar to @code{add-resource!} but the created resource is instead a collection. +@end defun + +@deftp {GOOPS method} setup-new-resource! (self <resource>) (parent <resource>) +Book-keeping procedure called by @code{add-resource!} on @emph{all} +added resources. + +Base implementation in a no-op. +@end deftp + +@deftp {GOOPS method} setup-new-collection! (self <resource>) (parent <resource>) +Book-keeping procedure called by @code{add-resource!} if +@var{collection?} is true. + +Base implementation is a no-op. +@end deftp + +@deftp {GOOPS method} is-collection? resource +Is the given resource a collection. + +The base implementation simply checks if the resource has any children. +@end deftp + +@deftp {GOOPS method} content resource +@deftpx {GOOPS method} set-content! resource content +Get and set the content of a given resource. @var{content}s type can +be anything that the given resource type accepts. Overrides of this +procedure should preferably save its contents properly. +@end deftp + +@c + +@defun get-property resource xml-tag +@defunx get-live-property resource xml-tag +@defunx get-dead-property resource xml-tag +@end defun + + +@defun set-property resource xml-el +@defunx set-property! resource xml-el +@defunx set-dead-property resource xml-el +@defunx set-dead-property! resource xml-el +@defunx set-live-property resource xml-el +@defunx set-live-property! resource xml-el +@end defun + + +@defun remove-property resource xml-tag +@defunx remove-property! resource xml-tag +@defunx remove-dead-property resource xml-tag +@defunx remove-dead-property! resource xml-tag +@defunx remove-live-property resource xml-tag +@defunx remove-live-property! resource xml-tag +@end defun + +@c + +@deftp {GOOPS method} copy-resource (resource <resource>) include-children? [name] +Create a new resource which looks as similar as possible to the given +resource. The new resource will have the same (GOOPS) class as the +source, displayname, contentlanguage and all dead properties are +transfered, other live properties are currently not explicitly +transfered (but probably still transfered implicitly). + +The new resources name is @var{name} if given, and the name of the +original resource otherwise. + +If @var{include-children?} is true then a deep copy is performed, +otherwise no children are copied, and the resulting resource will be a +leaf node. + +Content is copied verbatim. + +@b{NOTE} currently no helper method is called, which means that extra +resources held by the resource object can't be copied. +For example, FILE can't create a copy (but it also shouldn't do that +here, but rathen when the element is ``mounted'' into the tree). +@end deftp + +@c + +@defun lookup-resource root-resource path +@end defun + + +@defun all-resources-under resource [prefix='()] +Returns the given resource, and all its children in a flat list. + +Currently depth first, but that might change. +The root resource is however guaranteed to be first. +@end defun + +@c + +@c TODO + make-live-property + live-property? + property-getter + + property-setter-generator + property-remover-generator + + prepare-update-properties + + live-properties + dead-properties + + webdav-properties + + +@node WebDAV Resource Types +@subsection Resource Types + +@subsubsection @code{(calp webdav resource base)} + +Implementation of @code{(calp webdav resource)}. Exists to possibly +avoid dependency loops. + +@subsubsection @code{(calp webdav resource calendar)} +@subsubsection @code{(calp webdav resource file)} + +Resources backed by the file system. + +@defun file-resource? x +@end defun + +@deftp {GOOPS method} children <file-resource> +@end deftp + +@deftp {GOOPS method} is-collection? <file-resource> +@end deftp + +@deftp {GOOPS method} creationdate <file-resource> +Retrived directly from the file through @command{stat -c %W $@{filename@}}. +@end deftp + +@deftp {GOOPS method} content <file-resource> +@deftpx {GOOPS method} set-content! <file-resource> data +Directly interfaced with the file. + +Data can't be retrieved for collections, and will always be +returned as a bytevector for non-collections. + +Data can be set either as a string or a bytevector. When a string is +used Guile's current encoding will be used. +@end deftp + +@subsubsection @code{(calp webdav resource virtual)} + +@node WebDAV Utilities +@subsection Utilities +@defun xml-element-hash-key xml-tag +Given an xml tag object @ref{xml-tag}, return a suitable key for +@code{hash-ref} and family. + +These key objects should preferably not be carried around for +long. Prefer to keep the @emph{real} xml-tag object, and only call +this while directly referencing the hash table. +@end defun + +@defun href->string href +HREF's are represented as lists of strings. The root resource (``/'') +is the empty list. +@end defun + +@defun string->href string +Return a href list back into a string. A leading slash will always be added. +@end defun diff --git a/doc/ref/javascript/formatters.texi b/doc/ref/javascript/formatters.texi index 71394b39..a3086aa9 100644 --- a/doc/ref/javascript/formatters.texi +++ b/doc/ref/javascript/formatters.texi @@ -4,6 +4,12 @@ Formatting procedures used by some components. @c TODO can we have a backref of every node containing @ref{formatters-proc}? +@deftypefun void format(targetElement:HTMLElement, data:VEvent, key:string) +Checks if a specific formatter exists for the given key, and executes +it. +Defaults to 'default', and also runs that if the regular formatter throws. +@end deftypefun + @deftypevar {Map<string, (e:HTMLElement, d:VEvent, s:any) => void>} formatters @anchor{formatters-proc} diff --git a/module/c/lex.scm b/module/c/lex.scm index 34e52d88..977f497f 100644 --- a/module/c/lex.scm +++ b/module/c/lex.scm @@ -65,16 +65,16 @@ (define-peg-pattern char all (and (ignore "'") (or escaped-char peg-any) (ignore "'"))) +;; whitespace +(define-peg-pattern ws none + (or " " " " "\n")) + (define-peg-pattern* operator all `(or ,@(map symbol->string symbol-binary-operators) ,@(map (lambda (op) `(and ,(symbol->string op) ws)) wordy-binary-operators))) -;; whitespace -(define-peg-pattern ws none - (or " " " " "\n")) - ;; space (for when whitespace is optional) (define-peg-pattern sp none (* ws)) diff --git a/module/calp.scm b/module/calp.scm index 81268cbb..b1952547 100644 --- a/module/calp.scm +++ b/module/calp.scm @@ -1,4 +1,9 @@ -(define-module (calp)) +(define-module (calp) + :export (version prodid)) ;; Update me on new release -(define-public version "0.6.1") +(define version "0.6.1") + +(define (prodid) + (format #f "-//hugo//calp ~a//EN" + (@ (calp) version))) diff --git a/module/calp/entry-points/benchmark.scm b/module/calp/entry-points/benchmark.scm index 31ea958a..709d2bea 100644 --- a/module/calp/entry-points/benchmark.scm +++ b/module/calp/entry-points/benchmark.scm @@ -17,9 +17,9 @@ (define opt-spec `((enable-output (single-char #\o) (description - ,(_ "Output is by default supressed, since many fields contain way to much data to read. This turns it on again.") + ,(G_ "Output is by default supressed, since many fields contain way to much data to read. This turns it on again.") )) - (help (single-char #\h) (description ,(_ "Print this help."))))) + (help (single-char #\h) (description ,(G_ "Print this help."))))) (define (main args) diff --git a/module/calp/entry-points/convert.scm b/module/calp/entry-points/convert.scm index 707414e5..0835b3d6 100644 --- a/module/calp/entry-points/convert.scm +++ b/module/calp/entry-points/convert.scm @@ -12,12 +12,12 @@ (define opt-spec `((from (single-char #\f) (value (options "xcal" "ical")) - (description ,(xml->sxml (_ "<group>Input format (otherwise infered from <i>infile</i>)</group>")))) + (description ,(xml->sxml (G_ "<group>Input format (otherwise infered from <i>infile</i>)</group>")))) (to (single-char #\t) (value (options "xcal" "ical")) - (description ,(xml->sxml (_ "<group>Output format (otherwise infered from <i>outfile</i>)</group>")))) - (infile (value #t) (single-char #\i) (description ,(_ "Input file"))) - (outfile (value #t) (single-char #\o) (description ,(_ "Output file"))) - (help (single-char #\h) (description ,(_ "Print this help."))))) + (description ,(xml->sxml (G_ "<group>Output format (otherwise infered from <i>outfile</i>)</group>")))) + (infile (value #t) (single-char #\i) (description ,(G_ "Input file"))) + (outfile (value #t) (single-char #\o) (description ,(G_ "Output file"))) + (help (single-char #\h) (description ,(G_ "Print this help."))))) (define (filename-to-type filename) @@ -71,7 +71,7 @@ ;; TODO strip *TOP* xml->sxml)] [else (scm-error 'misc-error "convert-main" - (_ "Unexpected parser type: ~a") + (G_ "Unexpected parser type: ~a") (list from) #f)] )) @@ -90,7 +90,7 @@ component) port))] [else (scm-error 'misc-error "convert-main" - (_ "Unexpected writer type: ~a") + (G_ "Unexpected writer type: ~a") (list to) #f)])) diff --git a/module/calp/entry-points/html.scm b/module/calp/entry-points/html.scm index 2aa7e0e2..de229533 100644 --- a/module/calp/entry-points/html.scm +++ b/module/calp/entry-points/html.scm @@ -31,21 +31,21 @@ (define opt-spec `((from (value #t) (single-char #\F) - (description ,(_ "Start date of output.")) + (description ,(G_ "Start date of output.")) ) (count (value #t) - (description ,(xml->sxml (_ "<group>How many pages should be rendered. + (description ,(xml->sxml (G_ "<group>How many pages should be rendered. If --style=<b>week</b> and --from=<b>2020-04-27</b>; then --count=<b>4</b> would render the four pages 2020-04-27, 2020-05-04, 2020-05-11, and 2020-05-25. Defaults to 12 to give a whole year when --style=<b>month</b></group>")))) (target (single-char #\t) (value #t) - (description ,(xml->sxml (_ "<group>Directory where html files should end up. Default to <b>./html</b></group>")))) + (description ,(xml->sxml (G_ "<group>Directory where html files should end up. Default to <b>./html</b></group>")))) (style (value #t) (predicate ,(lambda (v) (memv (string->symbol v) '(small wide week table)))) - (description ,(xml->sxml (_ "<group>How the body of the HTML page should be layed out. + (description ,(xml->sxml (G_ "<group>How the body of the HTML page should be layed out. <br/><b>week</b> gives a horizontally scrolling page with 7 elements, where each has events graphically laid out hour by hour. @@ -56,10 +56,10 @@ given day, in order of start time. They are however not graphically sized. is the same as week, but gives a full month.</group>")))) (standalone - (description ,(xml->sxml (_ "<group>Creates a standalone document instead of an HTML fragment + (description ,(xml->sxml (G_ "<group>Creates a standalone document instead of an HTML fragment for embedding in a larger page. Currently only applies to the <i>small</i> style</group>")))) - (help (single-char #\h) (description ,(_ "Print this help."))))) + (help (single-char #\h) (description ,(G_ "Print this help."))))) @@ -81,9 +81,9 @@ for embedding in a larger page. Currently only applies to the <i>small</i> style ((= errno EEXIST) (let ((st (lstat link))) (cond ((not (eq? 'symlink (stat:type st))) - (warning (_ "File ~s exists, but isn't a symlink") link)) + (warning (G_ "File ~s exists, but isn't a symlink") link)) ((not (string=? target (readlink link))) - (warning (_ "~s is a symlink, but points to ~s instead of expected ~s") + (warning (G_ "~s is a symlink, but points to ~s instead of expected ~s") link (readlink link) target)))) ;; else, file exists as a symlink, and points where we want, ;; which is expected. Do nothing and be happy. @@ -113,7 +113,7 @@ for embedding in a larger page. Currently only applies to the <i>small</i> style (stream-for-each (lambda (start-date) (define fname (path-append target-directory (date->string start-date "~1.xml"))) - (format (current-error-port) (_ "Writing to [~a]~%") fname) + (format (current-error-port) (G_ "Writing to [~a]~%") fname) (with-output-to-file fname (lambda () (sxml->xml (re-root-static (apply html-generate @@ -178,7 +178,7 @@ for embedding in a larger page. Currently only applies to the <i>small</i> style pre-start: (start-of-week start) post-end: (end-of-week (end-of-month start)))] [else - (scm-error 'misc-error "html-main" (_ "Unknown html style: ~a") (list style) #f)]) + (scm-error 'misc-error "html-main" (G_ "Unknown html style: ~a") (list style) #f)]) - ((@ (calp util time) report-time!) (_ "all done")) + ((@ (calp util time) report-time!) (G_ "all done")) ) diff --git a/module/calp/entry-points/ical.scm b/module/calp/entry-points/ical.scm index e164c340..3720d8db 100644 --- a/module/calp/entry-points/ical.scm +++ b/module/calp/entry-points/ical.scm @@ -12,9 +12,9 @@ (define opt-spec `((from (value #t) (single-char #\F)) (to (value #t) (single-char #\T) - (description ,(_ "Returns all elements between these two dates."))) + (description ,(G_ "Returns all elements between these two dates."))) (help (single-char #\h) - (description ,(_ "Print this help."))))) + (description ,(G_ "Print this help."))))) (define (main args) (define opts (getopt-long args (getopt-opt opt-spec))) diff --git a/module/calp/entry-points/import.scm b/module/calp/entry-points/import.scm index 00edc0d8..ecf8b939 100644 --- a/module/calp/entry-points/import.scm +++ b/module/calp/entry-points/import.scm @@ -16,11 +16,11 @@ (define options `((calendar (value #t) (single-char #\c) - (description ,(_ "Name of calendar to import into"))) + (description ,(G_ "Name of calendar to import into"))) (file (value #t) (single-char #\f) - (description ,(_ "ics file to import"))) + (description ,(G_ "ics file to import"))) (help (single-char #\h) - (description ,(_ "Print this help."))))) + (description ,(G_ "Print this help."))))) (define (main args) (define opts (getopt-long args (getopt-opt options))) @@ -39,18 +39,18 @@ (get-calendars global-event-object))))) (unless calendar - (format (current-error-port) (_ "No calendar named ~s~%") cal-name) + (format (current-error-port) (G_ "No calendar named ~s~%") cal-name) (throw 'return)) (let ((new-events (parse-cal-path fname))) - (format #t (_ "About to import the following ~a events into ~a~%") + (format #t (G_ "About to import the following ~a events into ~a~%") (length (children new-events)) (prop calendar 'NAME)) (format #t "~{~a~^~%~}~%" (map (extract 'SUMMARY) (children new-events))) - (format #t (_ "Continue? [Y/n] ")) + (format #t (G_ "Continue? [Y/n] ")) (let loop ((line (read-line))) (case (if (string-null? line) 'yes (yes-no-check line)) diff --git a/module/calp/entry-points/server.scm b/module/calp/entry-points/server.scm index 903d085d..08c9d43a 100644 --- a/module/calp/entry-points/server.scm +++ b/module/calp/entry-points/server.scm @@ -17,22 +17,22 @@ (define options `((port (value #t) (single-char #\p) - (description ,(xml->sxml (_ "<group>Bind to TCP port, defaults to <i>8080</i>. + (description ,(xml->sxml (G_ "<group>Bind to TCP port, defaults to <i>8080</i>. <br/>Can also be set through the config variable <i>port</i>.</group>")))) (addr (value #t) - (description ,(xml->sxml (_ "<group>Address to use, defaults to <i>0.0.0.0</i> for IPv4, + (description ,(xml->sxml (G_ "<group>Address to use, defaults to <i>0.0.0.0</i> for IPv4, and <i>[::]</i> for IPv6</group>")))) ;; numbers as single-char doesn't work. - (six (description ,(_ "Use IPv6."))) - (four (description ,(_ "Use IPv4."))) - (sigusr (description ,(_ "Reload events on SIGUSR1"))) + (six (description ,(G_ "Use IPv6."))) + (four (description ,(G_ "Use IPv4."))) + (sigusr (description ,(G_ "Reload events on SIGUSR1"))) (help (single-char #\h) - (description ,(_ "Print this help."))))) + (description ,(G_ "Print this help."))))) (define-config port 8080 - description: (_ "Port to which the web server should bind.")) + description: (G_ "Port to which the web server should bind.")) (define (main args) @@ -59,12 +59,12 @@ and <i>[::]</i> for IPv6</group>")))) "::" "0.0.0.0"))) (when (option-ref opts 'sigusr #f) - (format (current-error-port) (_ "Listening for SIGUSR1~%")) + (format (current-error-port) (G_ "Listening for SIGUSR1~%")) ;; NOTE this uses the main thread, and does therefore block HTTP requests ;; while reloading. However, it appears to not cause any race conditions. (sigaction SIGUSR1 (lambda _ - (format (current-error-port) (_ "Received SIGUSR1, reloading calendars~%")) + (format (current-error-port) (G_ "Received SIGUSR1, reloading calendars~%")) ((@ (vcomponent util instance) reload))))) @@ -74,7 +74,7 @@ and <i>[::]</i> for IPv6</group>")))) ;; Port which we listen to ;; PID of this process ;; PWD of this process - (format #t (_ "Starting server on ~a:~a~%I'm ~a, runing from ~a~%") + (format #t (G_ "Starting server on ~a:~a~%I'm ~a, runing from ~a~%") addr port% (getpid) (getcwd)) diff --git a/module/calp/entry-points/terminal.scm b/module/calp/entry-points/terminal.scm index dd35b8f3..9a1b8b00 100644 --- a/module/calp/entry-points/terminal.scm +++ b/module/calp/entry-points/terminal.scm @@ -11,8 +11,8 @@ (define options `((date (value #t) (single-char #\d) - (description ,(_ "Which date to start on."))) - (help (single-char #\t) (description ,(_ "Print this help."))) + (description ,(G_ "Which date to start on."))) + (help (single-char #\t) (description ,(G_ "Print this help."))) )) (define (main args) diff --git a/module/calp/entry-points/text.scm b/module/calp/entry-points/text.scm index 775245eb..127798ce 100644 --- a/module/calp/entry-points/text.scm +++ b/module/calp/entry-points/text.scm @@ -12,11 +12,11 @@ (define options `((width (value #t) (single-char #\w) - (description ,(_ "Width of written text, defaults to 70 chars."))) + (description ,(G_ "Width of written text, defaults to 70 chars."))) (file (value #t) (single-char #\f) - (description ,(xml->sxml (_ "<group>Read from <i>file</i> instead of standard input.</group>")))) + (description ,(xml->sxml (G_ "<group>Read from <i>file</i> instead of standard input.</group>")))) (help (single-char #\h) - (description ,(_ "Prints this help."))))) + (description ,(G_ "Prints this help."))))) (define (main args) (define opts (getopt-long args (getopt-opt options))) diff --git a/module/calp/entry-points/tidsrapport.scm b/module/calp/entry-points/tidsrapport.scm index a50f0659..a258cd73 100644 --- a/module/calp/entry-points/tidsrapport.scm +++ b/module/calp/entry-points/tidsrapport.scm @@ -93,7 +93,7 @@ (as-time (datetime-difference (prop e 'DTEND) (prop e 'DTSTART))))) - (cadr group)))))) + (cdr group)))))) instances) @@ -165,19 +165,19 @@ trailer (define opt-spec `((pdf (value #t) - (description ,(_ "Input pdf file"))) + (description ,(G_ "Input pdf file"))) (output (single-char #\o) (value optional) - (description ,(_ "Output file"))) + (description ,(G_ "Output file"))) (data (value optional) - (description ,(_ "Static data to fill fields with")) + (description ,(G_ "Static data to fill fields with")) ) (template (value optional) - (description ,(xml->sxml (_ "<group>Map between real field names and human readable names.<br/> + (description ,(xml->sxml (G_ "<group>Map between real field names and human readable names.<br/> If data is given, but not trans, then data is assumed to be in a correct format</group>")))) (search (value #t) (description - ,(_ "Search term for dynamic filling. Supports basic globbing"))))) + ,(G_ "Search term for dynamic filling. Supports basic globbing"))))) (define (parse-search str) (cond [(string-match "\\{(.*)\\}" str) @@ -203,7 +203,7 @@ If data is given, but not trans, then data is assumed to be in a correct format< (define template (call-with-input-file (or (option-ref opts 'template #f) - (error (_ "Template required"))) + (error (G_ "Template required"))) read)) (define prepared-data @@ -231,9 +231,9 @@ If data is given, but not trans, then data is assumed to be in a correct format< (define days (let ((days (assoc-ref group 'days))) (cond ((not (list? days)) - (error (_ "Needs list, not pair"))) + (error (G_ "Needs list, not pair"))) ((null? days) - (error (_ "Need more days"))) + (error (G_ "Need more days"))) ((and (list? (car days)) (eqv? '- (caar days))) (map (lambda (s) (string-append prefix (->string s))) (iota (1+ (- (list-ref (car days) 2) @@ -249,7 +249,7 @@ If data is given, but not trans, then data is assumed to be in a correct format< ,@(build-alist work-hours days) (,sum ,(apply + work-hours)))) (or (assoc-ref template 'groups) - (error (_ "Groups required in template"))) + (error (G_ "Groups required in template"))) search))) (define report diff --git a/module/calp/entry-points/update-zoneinfo.scm b/module/calp/entry-points/update-zoneinfo.scm index b565faeb..c6be1af3 100644 --- a/module/calp/entry-points/update-zoneinfo.scm +++ b/module/calp/entry-points/update-zoneinfo.scm @@ -14,7 +14,7 @@ :use-module (calp translation)) (define opt-spec - `((help (single-char #\h) (description ,(_ "Print this help."))))) + `((help (single-char #\h) (description ,(G_ "Print this help."))))) (define (main args) (define opts (getopt-long args (getopt-opt opt-spec))) @@ -27,7 +27,7 @@ (path-append (xdg-data-home) "tzget"))) (filename (or (find file-exists? locations) (scm-error 'missing-helper "update-zoneinfo" - (_ "tzget not installed, please put it in one of ~a") + (G_ "tzget not installed, please put it in one of ~a") (list locations) (list "tzget" locations)))) diff --git a/module/calp/html/caltable.scm b/module/calp/html/caltable.scm index 2c027c35..bdbcf55f 100644 --- a/module/calp/html/caltable.scm +++ b/module/calp/html/caltable.scm @@ -58,7 +58,7 @@ ;; Cell 0, 0. The letter v. for week number (div (@ (class "column-head row-head")) - ,(_ "v.")) + ,(G_ "v.")) ;; top row, names of week days ,@(map (lambda (d) `(div (@ (class "column-head")) diff --git a/module/calp/html/components.scm b/module/calp/html/components.scm index df30b6bc..463bae38 100644 --- a/module/calp/html/components.scm +++ b/module/calp/html/components.scm @@ -54,7 +54,7 @@ rest: args) (when (and onclick href) (scm-error 'wrong-type-arg "btn" - (_ "href and onclick are mutually exclusive. href = ~s, onclick = ~s.") + (G_ "href and onclick are mutually exclusive. href = ~s, onclick = ~s.") (list href onclick) #f)) (let ((classes (string-join (cons "btn" class) " ")) diff --git a/module/calp/html/util.scm b/module/calp/html/util.scm index 948cadb7..0a5b44ae 100644 --- a/module/calp/html/util.scm +++ b/module/calp/html/util.scm @@ -33,6 +33,6 @@ #xFF)) "#000000" "#FFFFFF"))) (lambda args - (format (current-error-port) (_ "Error calculating foreground color?~%~s~%") args) + (format (current-error-port) (G_ "Error calculating foreground color?~%~s~%") args) "#FF0000" ))) diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm index 287c62e1..0516b9d4 100644 --- a/module/calp/html/vcomponent.scm +++ b/module/calp/html/vcomponent.scm @@ -56,10 +56,10 @@ (configuration-error (lambda (key subr msg args data) (format (current-error-port) - (_ "Error retrieving configuration, ~?~%") msg args))) + (G_ "Error retrieving configuration, ~?~%") msg args))) (#t ; for errors when running the filter (lambda (err . args) - (warning (_ "~a on formatting description, ~s") err args) + (warning (G_ "~a on formatting description, ~s") err args) str)))) ;; TODO replace with propper mimetype parser @@ -91,14 +91,14 @@ "unknown"))))) (time ,(let ((dt (prop event 'DTSTART))) (if (datetime? dt) - (datetime->string dt (_ "~Y-~m-~d ~H:~M")) - (date->string dt (_ "~Y-~m-~d") )))) + (datetime->string dt (G_ "~Y-~m-~d ~H:~M")) + (date->string dt (G_ "~Y-~m-~d") )))) (a (@ (href ,(date->string (as-date (prop event 'DTSTART)) "/week/~Y-~m-~d.html"))) ;; Button for viewing calendar, accompanied by a calendar icon - ,(_ "View") " 📅") + ,(G_ "View") " 📅") (span ,(prop event 'SUMMARY))))) (cons - (calendar-styles calendars) + `(style ,(lambda () (calendar-styles calendars #t))) (for event in list `(details ,(summary event) @@ -166,7 +166,7 @@ (div (@ (class "fields")) ,(when (and=> (prop ev 'LOCATION) (negate string-null?)) - `(div (b ,(_ "Location: ")) + `(div (b ,(G_ "Location: ")) (div (@ (class "location") (data-property "location")) ,(string-map (lambda (c) (if (char=? c #\,) #\newline c)) (prop ev 'LOCATION))))) @@ -244,10 +244,10 @@ ,@(format-recurrence-rule ev))) ,(when (prop ev 'LAST-MODIFIED) - `(div (@ (class "last-modified")) ,(_ "Last modified") " " + `(div (@ (class "last-modified")) ,(G_ "Last modified") " " ,(datetime->string (prop ev 'LAST-MODIFIED) ;; Last modified datetime - (_ "~1 ~H:~M"))))) + (G_ "~1 ~H:~M"))))) )))) @@ -258,7 +258,7 @@ (let ((date (car day)) (events (cdr day))) `(section (@ (class "text-day")) - (header (h2 ,(let ((s (date->string date (_ "~Y-~m-~d")))) + (header (h2 ,(let ((s (date->string date (G_ "~Y-~m-~d")))) `(a (@ (href "#" ,s) (class "hidelink")) ,s)))) ,@(stream->list @@ -340,7 +340,7 @@ ;; TODO possibly unused? (define (repeat-info event) `(div (@ (class "eventtext")) - (h2 ,(_ "Recurrences")) + (h2 ,(G_ "Recurrences")) (table (@ (class "recur-components")) ,@((@@ (vcomponent recurrence internal) map-fields) (lambda (key value) @@ -412,7 +412,7 @@ (form (@ (class "edit-form")) (select (@ (class "calendar-selection")) ;; NOTE flytta "muffarna" utanför - (option ,(_ "- Choose a Calendar -")) + (option ,(G_ "- Choose a Calendar -")) ,@(let ((dflt ((@ (vcomponent) default-calendar)))) (map (lambda (calendar) (define name (prop calendar 'NAME)) @@ -422,7 +422,7 @@ ,name)) calendars))) (input (@ (type "text") - (placeholder ,(_ "Summary")) + (placeholder ,(G_ "Summary")) (name "summary") (required) (data-property "summary") ; (value ,(prop ev 'SUMMARY)) @@ -440,25 +440,25 @@ (div (@ (class "checkboxes")) (input (@ (type "checkbox") (name "wholeday") - (data-label ,(_ "Whole day?")) + (data-label ,(G_ "Whole day?")) )) (input (@ (type "checkbox") (name "has_repeats") - (data-label ,(_ "Recurring?")) + (data-label ,(G_ "Recurring?")) ))) ) - (input (@ (placeholder ,(_ "Location")) - (data-label ,(_ "Location")) + (input (@ (placeholder ,(G_ "Location")) + (data-label ,(G_ "Location")) (name "location") (type "text") (data-property "location") ; (value ,(or (prop ev 'LOCATION) "")) )) - (textarea (@ (placeholder ,(_ "Description")) - (data-label ,(_ "Description")) + (textarea (@ (placeholder ,(G_ "Description")) + (data-label ,(G_ "Description")) (data-property "description") (name "description")) ; ,(prop ev 'DESCRIPTION) @@ -467,9 +467,9 @@ (input-list (@ (name "categories") (data-property "categories") - (data-label ,(_ "Categories"))) + (data-label ,(G_ "Categories"))) (input (@ (type "text") - (placeholder ,(_ "Category"))))) + (placeholder ,(G_ "Category"))))) ;; TODO This should be a "list" where any field can be edited ;; directly. Major thing holding us back currently is that @@ -518,7 +518,7 @@ ; "20:56" )) (div (@ (class "fields")) - (div (b ,(_ "Location: ")) + (div (b ,(G_ "Location: ")) (div (@ (class "location") (data-property "location")) ; "Alsättersgatan 13" @@ -540,7 +540,7 @@ ;; "varje vecka" ;; ".") (div (@ (class "last-modified")) - ,(_ "Last Modified") " -" + ,(G_ "Last Modified") " -" ; "2021-09-29 19:56" )))))) @@ -548,21 +548,21 @@ `(template (@ (id "vevent-edit-rrule")) (div (@ (class "eventtext")) - (h2 ,(_ "Recurrences")) + (h2 ,(G_ "Recurrences")) (dl - (dt ,(_ "Frequency")) + (dt ,(G_ "Frequency")) (dd (select (@ (name "freq")) (option "-") ,@(map (lambda (x) `(option (@ (value ,x)) ,(string-titlecase (symbol->string x)))) '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY)))) - (dt ,(_ "Until")) + (dt ,(G_ "Until")) (dd (date-time-input (@ (name "until")))) - (dt ,(_ "Conut")) + (dt ,(G_ "Conut")) (dd (input (@ (type "number") (name "count") (min 0)))) - (dt ,(_ "Interval")) + (dt ,(G_ "Interval")) (dd (input (@ (type "number") (name "interval") ; min and max depend on FREQ ))) @@ -576,14 +576,14 @@ (dd (input-list (@ (name ,name)) (input (@ (type "number") (min ,min) (max ,max))))))) - `((bysecond ,(_ "By Second") 0 60) - (byminute ,(_ "By Minute") 0 59) - (byhour ,(_ "By Hour") 0 23) - (bymonthday ,(_ "By Month Day") -31 31) ; except 0 - (byyearday ,(_ "By Year Day") -366 366) ; except 0 - (byweekno ,(_ "By Week Number") -53 53) ; except 0 - (bymonth ,(_ "By Month") 1 12) - (bysetpos ,(_ "By Set Position") -366 366) ; except 0 + `((bysecond ,(G_ "By Second") 0 60) + (byminute ,(G_ "By Minute") 0 59) + (byhour ,(G_ "By Hour") 0 23) + (bymonthday ,(G_ "By Month Day") -31 31) ; except 0 + (byyearday ,(G_ "By Year Day") -366 366) ; except 0 + (byweekno ,(G_ "By Week Number") -53 53) ; except 0 + (bymonth ,(G_ "By Month") 1 12) + (bysetpos ,(G_ "By Set Position") -366 366) ; except 0 ))) ;; (dt "By Week Day") @@ -594,7 +594,7 @@ ;; ,(week-day-select '()) ;; )) - (dt ,(_ "Weekstart")) + (dt ,(G_ "Weekstart")) (dd ,(week-day-select '((name "wkst"))))))) ) @@ -610,29 +610,29 @@ (nav (@ (class "popup-control")) (button (@ (class "close-button") ;; Close this popup - (title ,(_ "Close")) + (title ,(G_ "Close")) (aria-label "Close")) "×") (button (@ (class "maximize-button") ;; Make this popup occupy the entire screen - (title ,(_ "Fullscreen")) + (title ,(G_ "Fullscreen")) ;; (aria-label "") ) ,(xml-entities "🗖")) (button (@ (class "remove-button") ;; Remove/Trash the event this popup represent ;; Think garbage can - (title ,(_ "Remove"))) + (title ,(G_ "Remove"))) ,(xml-entities "🗑"))) (tab-group (@ (class "window-body")) (vevent-description - (@ (data-label ,(xml-entities "📅")) (data-title ,(_ "Overview")) + (@ (data-label ,(xml-entities "📅")) (data-title ,(G_ "Overview")) (class "vevent"))) (vevent-edit (@ (data-label ,(xml-entities "🖊")) - (data-title ,(_ "Edit")) + (data-title ,(G_ "Edit")) ;; Used by JavaScript to target this tab (data-originaltitle "Edit"))) @@ -641,9 +641,9 @@ (vevent-changelog (@ (data-label ,(xml-entities "📒")) - (data-title ,(_ "Changelog")))) + (data-title ,(G_ "Changelog")))) ,@(when (debug) `((vevent-dl (@ (data-label ,(xml-entities "🐸")) - (data-title ,(_ "Debug")))))))))) + (data-title ,(G_ "Debug")))))))))) diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm index 3d70fb1b..3c7e2546 100644 --- a/module/calp/html/view/calendar.scm +++ b/module/calp/html/view/calendar.scm @@ -78,10 +78,10 @@ ,display))) (unless next-start - (scm-error 'misc-error "html-generate" (_ "Next-start needs to be a procedure") #f #f)) + (scm-error 'misc-error "html-generate" (G_ "Next-start needs to be a procedure") #f #f)) (unless prev-start - (scm-error 'misc-error "html-generate" (_ "Prev-start needs to be a procedure") #f #f)) + (scm-error 'misc-error "html-generate" (G_ "Prev-start needs to be a procedure") #f #f)) (xhtml-doc (@ (lang sv)) @@ -92,9 +92,9 @@ (meta (@ (name viewport) (content "width=device-width, initial-scale=0.5"))) (meta (@ (name description) - (content ,(format #f (_ "Calendar for the dates between ~a and ~a") - (date->string start-date (_ "~Y-~m-~d")) - (date->string end-date (_ "~Y-~m-~d")))))) + (content ,(format #f (G_ "Calendar for the dates between ~a and ~a") + (date->string start-date (G_ "~Y-~m-~d")) + (date->string end-date (G_ "~Y-~m-~d")))))) ;; NOTE this is only for the time actually part of this calendar. ;; overflowing times from pre-start and post-end is currently ignored here. (meta (@ (name start-time) @@ -119,7 +119,7 @@ window.default_calendar='~a';" ,(include-alt-css "/static/dark.css" '(title "Dark")) ,(include-alt-css "/static/light.css" '(title "Light")) - (script (@ (src "/static/script.out.js"))) + (script (@ (src "/static/script.js"))) (script (@ (src "/static/user/user-additions.js"))) (style ,(lambda () (calendar-styles calendars #t))) @@ -154,11 +154,11 @@ window.default_calendar='~a';" ;; Page footer (footer (@ (style "grid-area: footer")) - (span ,(_ "Page generated ") - ,(date->string (current-date) (_ "~Y-~m-~d"))) - (span ,(_ "Current time ") (current-time (@ (interval 1)))) + (span ,(G_ "Page generated ") + ,(date->string (current-date) (G_ "~Y-~m-~d"))) + (span ,(G_ "Current time ") (current-time (@ (interval 1)))) (span (a (@ (href ,(repo-url))) - ,(_ "Source Code")))) + ,(G_ "Source Code")))) ;; Small calendar and navigation (nav (@ (class "calnav") (style "grid-area: nav")) @@ -169,11 +169,11 @@ window.default_calendar='~a';" start-date) "/week/~1.html") ;; Button to view week - (_ "Week")) + (G_ "Week")) ,(btn href: (date->string (day start-date 1) "/month/~1.html") ;; button to view month - (_ "Month")) + (G_ "Month")) (today-button (a (@ (class "btn") @@ -183,7 +183,7 @@ window.default_calendar='~a';" [(week) "view=week"] [else ""])))) ;; Button to go to today - ,(_ "Today")))) + ,(G_ "Today")))) (date-jump ;; Firefox's accessability complain about each date @@ -203,11 +203,11 @@ window.default_calendar='~a';" ,(btn "➔")))) (details (@ (open) (style "grid-area: cal")) - (summary ,(_ "Month overview")) + (summary ,(G_ "Month overview")) (div (@ (class "smallcall-head")) ,(string-titlecase (date->string start-date ;; Header of small calendar - (_ "~B ~Y")))) + (G_ "~B ~Y")))) ;; NOTE it might be a good idea to put the navigation buttons ;; earlier in the DOM-tree/tag order. At least Vimium's ;; @key{[[} keybind sometimes finds parts of events instead. @@ -233,16 +233,16 @@ window.default_calendar='~a';" (input (@ (type "text") (name "q") ;; Search placeholder - (placeholder ,(_ "Search")))) + (placeholder ,(G_ "Search")))) (input (@ (type "submit") (value ">")))) ,(when (or (debug) (edit-mode)) `(details (@ (class "sliders")) - (summary ,(_ "Option sliders")) + (summary ,(G_ "Option sliders")) ,@(when (edit-mode) - `((label ,(_ "Event blankspace")) + `((label ,(G_ "Event blankspace")) ,(slider-input variable: "editmode" min: 0 @@ -251,7 +251,7 @@ window.default_calendar='~a';" value: 1))) ,@(when (debug) - `((label ,(_ "Fontsize")) + `((label ,(G_ "Fontsize")) ,(slider-input unit: "pt" min: 1 @@ -262,7 +262,7 @@ window.default_calendar='~a';" ;; List of calendars (details (@ (class "calendarlist")) - (summary ,(_ "Calendar list")) + (summary ,(G_ "Calendar list")) (ul ,@(map (lambda (calendar) `(li (@ (data-calendar ,(base64encode (prop calendar 'NAME)))) @@ -288,7 +288,7 @@ window.default_calendar='~a';" ;; Events which started before our start point, ;; but "spill" into our time span. (section (@ (class "text-day")) - (header (h2 ,(_ "Earlier"))) + (header (h2 ,(G_ "Earlier"))) ;; TODO this group gets styles applied incorrectly. ;; Figure out way to merge it with the below call. ,@(stream->list diff --git a/module/calp/html/view/calendar/shared.scm b/module/calp/html/view/calendar/shared.scm index 4779d11b..413bb5f5 100644 --- a/module/calp/html/view/calendar/shared.scm +++ b/module/calp/html/view/calendar/shared.scm @@ -36,7 +36,7 @@ (unless event-length-key (scm-error 'wrong-type-arg "fix-event-widths!" - (_ "event-length-key is required") + (G_ "event-length-key is required") #f #f)) ;; @var{x} is how for left in the container we are. diff --git a/module/calp/html/view/calendar/week.scm b/module/calp/html/view/calendar/week.scm index caad8912..44898b0d 100644 --- a/module/calp/html/view/calendar/week.scm +++ b/module/calp/html/view/calendar/week.scm @@ -36,7 +36,7 @@ ;; Top left area (div (@ (class "week-indicator")) (span (@ (style "font-size: 50%")) - ,(_ "v.")) + ,(G_ "v.")) ,@(->> (week-number start-date) number->string string->list (map (lambda (c) `(span ,(string c)))))) @@ -49,7 +49,7 @@ ,@(map (lambda (day-date) `(div (@ (class "meta")) (span (@ (class "daydate")) - ,(date->string day-date (_ "~Y-~m-~d"))) + ,(date->string day-date (G_ "~Y-~m-~d"))) (span (@ (class "dayname")) ;; TODO translation here? ,(string-titlecase (date->string day-date "~a"))))) diff --git a/module/calp/html/view/search.scm b/module/calp/html/view/search.scm index 114541ed..e400c1ba 100644 --- a/module/calp/html/view/search.scm +++ b/module/calp/html/view/search.scm @@ -26,25 +26,27 @@ errors has-query? search-term search-result page paginator) (xhtml-doc (@ (lang sv)) - (head (title ,(_ "Search results")) + (head (title ,(G_ "Search results")) ,(include-css "/static/style.css")) (body - (a (@ (href ("/today"))) ,(_ "Show today")) - (h2 ,(_ "Search term")) + (a (@ (href ("/today"))) ,(G_ "Show today")) + (h2 ,(G_ "Search term")) + ;; TODO add blurb documenting available variables here, + ;; and link to full documentation page (form (pre (textarea (@ (name "q") (rows 5) (spellcheck false) (style "width:100%")) ,(when has-query? (with-output-to-string (lambda () (pretty-print search-term)))))) - (label (@ (for "onlyfuture")) ,(_ "limit to future occurences")) + (label (@ (for "onlyfuture")) ,(G_ "limit to future occurences")) (input (@ (name "onlyfuture") (id "onlyfuture") (type checkbox))) (input (@ (type submit)))) ,@(if errors - `((h2 ,(_ "Error searching")) + `((h2 ,(G_ "Error searching")) (div (@ (class "error")) (pre ,errors))) - `((h2 ,(format #f (_ "Result (page ~a)") page)) + `((h2 ,(format #f (G_ "Result (page ~a)") page)) (ul ,@(compact-event-list search-result)) (div (@ (class "paginator")) ,@(paginator->list diff --git a/module/calp/load-config.scm b/module/calp/load-config.scm new file mode 100644 index 00000000..5844c1b6 --- /dev/null +++ b/module/calp/load-config.scm @@ -0,0 +1,50 @@ +(cond-expand + (guile-3 + (define-module (calp load-config) + :declarative? #f)) + (else + (define-module (calp load-config) + ))) + +(use-modules (srfi srfi-1) + (calp translation) + (hnh util path) + ((xdg basedir) :prefix xdg-)) + +(export load-config find-config-file) + +(define (load-config config-file) + ;; Load config + ;; Sandbox and "stuff" not for security from the user. The config script is + ;; assumed to be "safe". Instead it's so we can control the environment in + ;; which it is executed. + (catch #t + (lambda () (load config-file)) + (lambda args + (format (current-error-port) + ;; Two arguments: + ;; Configuration file path, + ;; thrown error arguments + (G_ "Failed loading config file ~a~%~s~%") + config-file + args + )))) + + +(define (find-config-file altconfig) + (cond [altconfig + (if (file-exists? altconfig) + altconfig + (scm-error 'misc-error + "wrapped-main" + (G_ "Configuration file ~a missing") + (list altconfig) + #f))] + ;; altconfig could be placed in the list below. But I want to raise an error + ;; if an explicitly given config is missing. + [(find file-exists? + (list + (path-append (xdg-config-home) "calp" "config.scm") + (path-append (xdg-sysconfdir) "calp" "config.scm"))) + => identity]) + ) diff --git a/module/calp/main.scm b/module/calp/main.scm index 827dbf4e..90e7e115 100644 --- a/module/calp/main.scm +++ b/module/calp/main.scm @@ -1,10 +1,10 @@ ;; -*- geiser-scheme-implementation: guile -*- (define-module (calp main) - :use-module (hnh util) + :use-module ((hnh util) :select (awhen)) :use-module ((hnh util path) :select (path-append)) :use-module (srfi srfi-1) - :use-module (srfi srfi-88) ; keyword syntax + :use-module ((srfi srfi-88) :select ()) ; keyword syntax :use-module (hnh util options) :use-module ((calp util hooks) :select (shutdown-hook)) @@ -16,10 +16,6 @@ :use-module ((calp util exceptions) :select ()) :use-module (ice-9 getopt-long) - :use-module (ice-9 regex) - :use-module ((ice-9 popen) :select (open-input-pipe)) - :use-module ((ice-9 sandbox) :select - (make-sandbox-module all-pure-and-impure-bindings)) :use-module (statprof) :use-module (calp repl) @@ -28,18 +24,22 @@ :use-module ((xdg basedir) :prefix xdg-) :use-module (calp translation) + :use-module ((calp load-config) :select (load-config find-config-file)) :export (main) ) + + + (define options `((statprof (value display-style) - (description ,(xml->sxml (_ "<group>Run the program within Guile's built in statical + (description ,(xml->sxml (G_ "<group>Run the program within Guile's built in statical profiler. Display style is one of <b>flat</b> or <b>tree</b>.</group>")))) (repl (value address) (description - ,(xml->sxml (_ "<group>Start a Guile repl which can be connected to, defaults to the + ,(xml->sxml (G_ "<group>Start a Guile repl which can be connected to, defaults to the unix socket <i>/run/user/${UID}/calp-${PID}</i>, but it can be bound to any unix or TCP socket. ((@ (vcomponent util instance) global-event-object)) should contain all events. @@ -48,22 +48,22 @@ contain all events. (config (value #t) (description - ,(_ "Path to alterantive configuration file to load instead of the default one."))) + ,(G_ "Path to alterantive configuration file to load instead of the default one."))) (debug (single-char #\d) (description - ,(_ "Turns on debug mode for HTML output"))) + ,(G_ "Turns on debug mode for HTML output"))) (edit-mode (description - ,(_ "Makes generated HTML user editable (through JS)"))) + ,(G_ "Makes generated HTML user editable (through JS)"))) (version (single-char #\v) - (description ,(format #f (_ "Display version, which is ~a btw.") + (description ,(format #f (G_ "Display version, which is ~a btw.") (@ (calp) version)))) (help (single-char #\h) - (description ,(_ "Print this help"))) + (description ,(G_ "Print this help"))) )) @@ -73,30 +73,30 @@ contain all events. "<group><br/> <center><b>" "Calp" "</b></center> <br/><br/> -" (_ "Usage: <b>calp</b> [ <i>flags</i> ] <i>mode</i> [ <i>mode flags</i> ]") "<br/> +" (G_ "Usage: <b>calp</b> [ <i>flags</i> ] <i>mode</i> [ <i>mode flags</i> ]") "<br/> <hr/>" ;; Header for following list of modes of operation - "<center><b>" (_ "Modes") "</b></center> + "<center><b>" (G_ "Modes") "</b></center> <br/><br/>" - (_ "<p><b>html</b> reads calendar files from disk, and writes them to static HTML files.</p>") - (_ "<p><b>terminal</b> loads the calendars, and starts an interactive terminal interface.</p>") - (_ "[UNTESTED]<br/><p><b>import</b>s a calendar object into the database.</p>") - (_ "<p><b>text</b> formats and justifies what it's given on standard input, + (G_ "<p><b>html</b> reads calendar files from disk, and writes them to static HTML files.</p>") + (G_ "<p><b>terminal</b> loads the calendars, and starts an interactive terminal interface.</p>") + (G_ "[UNTESTED]<br/><p><b>import</b>s a calendar object into the database.</p>") + (G_ "<p><b>text</b> formats and justifies what it's given on standard input, and writes it to standard output. Similar to this text.</p>") - (_ "<p><b>ical</b> loads the calendar database, and immediately + (G_ "<p><b>ical</b> loads the calendar database, and immediately re-serializes it back into iCAL format. Useful for merging calendars.</p>") - (_ "<p><b>benchmark</b> <i>module</i><br/>Runs the procedure 'run-benchmark' + (G_ "<p><b>benchmark</b> <i>module</i><br/>Runs the procedure 'run-benchmark' from the module (calp benchmark <i>module</i>).</p>") - (_ "<p><b>server</b> starts an HTTP server which dynamically loads and + (G_ "<p><b>server</b> starts an HTTP server which dynamically loads and displays events. The <i>/month/{date}.html</i> & <i>/week/{date}.html</i> runs the same output code as <b>html</b>. While the <i>/calendar/{uid}.ics</i> uses the same code as <b>ical</b>.</p>") - (_ "<p><b>update-zoneinfo</b> in theory downloads and updates our local + (G_ "<p><b>update-zoneinfo</b> in theory downloads and updates our local zoneinfo database, but is currently broken.</p>") "<hr/><br/>" ;; Header for list of available flags. ;; Actual list is auto generated elsewhere. - "<center><b>" (_ "Flags") "</b></center> + "<center><b>" (G_ "Flags") "</b></center> <br/></group>"))) (define (ornull a b) @@ -109,42 +109,11 @@ zoneinfo database, but is currently broken.</p>") (define repl (option-ref opts 'repl #f)) (define altconfig (option-ref opts 'config #f)) - (define config-file - (cond [altconfig - (if (file-exists? altconfig) - altconfig - (scm-error 'misc-error - "wrapped-main" - (_ "Configuration file ~a missing") - (list altconfig) - #f))] - ;; altconfig could be placed in the list below. But I want to raise an error - ;; if an explicitly given config is missing. - [(find file-exists? - (list - (path-append (xdg-config-home) "calp" "config.scm") - (path-append (xdg-sysconfdir) "calp" "config.scm"))) - => identity])) + (define config-file (find-config-file altconfig)) (when stprof (statprof-start)) - - - ;; Load config - ;; Sandbox and "stuff" not for security from the user. The config script is - ;; assumed to be "safe". Instead it's so we can control the environment in - ;; which it is executed. - (catch #t - (lambda () (load config-file)) - (lambda args - (format (current-error-port) - ;; Two arguments: - ;; Configuration file path, - ;; thrown error arguments - (_ "Failed loading config file ~a~%~s~%") - config-file - args - ))) + (load-config config-file) (awhen (option-ref opts 'edit-mode #f) ((@ (calp html config) edit-mode) #t)) @@ -162,7 +131,7 @@ zoneinfo database, but is currently broken.</p>") (throw 'return)) (when (option-ref opts 'version #f) - (format #t (_ "Calp version ~a~%") (@ (calp) version)) + (format #t (G_ "Calp version ~a~%") (@ (calp) version)) (throw 'return)) ;; always load zoneinfo if available. @@ -194,7 +163,7 @@ zoneinfo database, but is currently broken.</p>") ((update-zoneinfo) (@ (calp entry-points update-zoneinfo) main)) (else => (lambda (s) (format (current-error-port) - (_ "Unsupported mode of operation: ~a~%") + (G_ "Unsupported mode of operation: ~a~%") s) (exit 1)))) ropt)) @@ -209,7 +178,7 @@ zoneinfo database, but is currently broken.</p>") (define (main args) - ((@ (calp util time) report-time!) (_ "Program start")) + ((@ (calp util time) report-time!) (G_ "Program start")) (with-throw-handler #t (lambda () (dynamic-wind (lambda () 'noop) diff --git a/module/calp/namespaces.scm b/module/calp/namespaces.scm new file mode 100644 index 00000000..09a642da --- /dev/null +++ b/module/calp/namespaces.scm @@ -0,0 +1,14 @@ +(define-module (calp namespaces)) + +;;; Commentary: +;;; (XML) Namespaces used by different parts of the program. +;;; Code: + +(define-public webdav (string->symbol "DAV:")) +(define-public caldav (string->symbol "urn:ietf:params:xml:ns:caldav")) +(define-public xcal (string->symbol "urn:ietf:params:xml:ns:icalendar-2.0")) + +(define-public namespaces + `((d . ,webdav) + (c . ,caldav) + (x . ,xcal))) diff --git a/module/calp/repl.scm b/module/calp/repl.scm index 7beee560..327ee206 100644 --- a/module/calp/repl.scm +++ b/module/calp/repl.scm @@ -4,7 +4,10 @@ (define-module (calp repl) :use-module (system repl server) + :use-module ((system repl common) :select (repl-default-option-set!)) + :use-module ((ice-9 pretty-print) :select (truncated-print)) :use-module (ice-9 regex) + :use-module (ice-9 format) :use-module ((calp util hooks) :select (shutdown-hook)) :use-module ((hnh util exceptions) :select (warning)) :use-module (calp translation) @@ -14,7 +17,7 @@ (define (repl-start address) (define lst (string->list address)) (format (current-error-port) - (_ "Starting REPL server at ~a~%") address) + (G_ "Starting REPL server at ~a~%") address) (spawn-server (case (cond [(memv (car lst) '(#\. #\/)) 'UNIX] [(string-match "(\\d{1,3}\\.){3}\\d{1,3}(:\\d+)?" address) 'IPv4] @@ -24,19 +27,24 @@ [(UNIX) (add-hook! shutdown-hook (lambda () (catch 'system-error (lambda () (delete-file address)) (lambda (err proc fmt args data) - (warning (string-append (format #f (_ "Failed to unlink ~a") address) + (warning (string-append (format #f (G_ "Failed to unlink ~a") address) (format #f ": ~?" fmt args))) err)))) (make-unix-domain-server-socket path: address)] [(IPv4) (apply (case-lambda - [() (error (_ "Empty address?"))] + [() (error (G_ "Empty address?"))] [(address) (make-tcp-server-socket host: address)] [(address port) (make-tcp-server-socket host: address port: port)]) (string-split address #\:))] ;; currently impossible - [(IPv6) (error (_ "How did you get here?"))])) + [(IPv6) (error (G_ "How did you get here?"))])) - ;; TODO setup repl environment here + (repl-default-option-set! + 'print + (lambda (repl obj) + (truncated-print obj) + (newline))) + ;; TODO setup repl environment here ) diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index 44fac7e8..3383f7a6 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -61,18 +61,18 @@ `(table (@ (class "directory-table")) (thead (tr (th "") - (th ,(_ "Name")) + (th ,(G_ "Name")) ;; File permissions, should be about as long as three digits - (th ,(_ "Perm")) + (th ,(G_ "Perm")) ;; File size - (th ,(_ "Size")))) + (th ,(G_ "Size")))) (tbody (tr (td "↩️") (td (@ (colspan 3)) (a (@ (href ,(-> (path-split dir) (drop-right 1) (xcons "/static") path-join))) - ,(_ "Return up")))) + ,(G_ "Return up")))) ,@(map (lambda (k) (let ((stat (lstat (path-append prefix dir k)))) `(tr (td ,(case (stat:type stat) @@ -95,7 +95,7 @@ (scm-error 'misc-error "directory-table" - (_ "Scandir argument invalid or not directory: ~s") + (G_ "Scandir argument invalid or not directory: ~s") (list dir) '()))))))) @@ -118,13 +118,12 @@ (define-config static-dir "static" - description: (_ "Where static files for the web server are located")) + description: (G_ "Where static files for the web server are located")) (define ical-namespace '(IC . "urn:ietf:params:xml:ns:icalendar-2.0")) -(define root-script "window.onload = () => document.getElementsByTagName('a')[0].click()") ;; TODO ensure encoding on all fields which take user provided data. ;; Possibly a fallback which strips everything unknown, and treats @@ -132,22 +131,28 @@ (define (make-make-routes) (make-routes - ;; Manual redirect to not reserve root. - ;; Also reason for really ugly frontend redirect. (GET "/" (html) - (return `((content-type ,(content-type html))) - (with-output-to-string - (lambda () - ((sxml->output html) - (xhtml-doc - (body (a (@ (href "/today")) ,(_ "Go to Today")) - (script ,(lambda () (display root-script)))))))))) + (return (build-response code: 307 + headers: `((Location . "/today/") + (content-type tex/plain))) + (G_ "Redirecting to today, might take some time if server was just restarted."))) (GET "/favicon.ico" () (return `((content-type image/svg+xml)) (call-with-input-file "static/calendar.svg" read-string))) + (GET "/everything.ics" (start end) + (let ((start (or start (date- (current-date) (date day: 14)))) + (end (or end (date+ (current-date) (date year: 1))))) + (let ((events (append + (fixed-events-in-range global-event-object start end) + (get-repeating-events global-event-object)))) + (format (current-error-port) "Collected ~a events~%" (length events)) + (return '((content-type text/calendar)) + (with-output-to-string + (lambda () (print-components-with-fake-parent events))))))) + ;; TODO any exception in this causes the whole page to fail ;; It would be much better if most of the page could still make it. (GET "/week/:start-date.html" (start-date html) @@ -163,8 +168,7 @@ next-start: (lambda (d) (date+ d (date day: 7))) prev-start: (lambda (d) (date- d (date day: 7))) render-calendar: (@ (calp html view calendar week) render-calendar) - intervaltype: 'week - ))))))) + intervaltype: 'week))))))) (GET "/month/:start-date.html" (start-date html) (let ((start-date (start-of-month (parse-iso-date start-date)))) @@ -189,7 +193,7 @@ (POST "/remove" (uid) (unless uid (return (build-response code: 400) - (_ "uid required"))) + (G_ "uid required"))) (aif (get-event-by-uid global-event-object uid) (begin @@ -201,10 +205,10 @@ (set! (param (prop* it 'X-HNH-REMOVED) 'VALUE) "BOOLEAN") (unless ((@ (vcomponent formats vdir save-delete) save-event) it) (return (build-response code: 500) - (_ "Saving event to disk failed."))) + (G_ "Saving event to disk failed."))) (return (build-response code: 204))) (return (build-response code: 400) - (format #f (_ "No event with UID '~a'") uid)))) + (format #f (G_ "No event with UID '~a'") uid)))) ;; TODO this fails when dtstart is <date>. ;; @var{cal} should be the name of the calendar encoded in base64. @@ -212,7 +216,7 @@ (unless (and cal data) (return (build-response code: 400) - (string-append (_ "Both 'cal' and 'data' required") "\r\n"))) + (string-append (G_ "Both 'cal' and 'data' required") "\r\n"))) ;; NOTE that this leaks which calendar exists, ;; but you can only query for existance. @@ -223,7 +227,7 @@ (unless calendar (return (build-response code: 400) - (format #f "~@?\r\n" (_ "No calendar with name [~a]") + (format #f "~@?\r\n" (G_ "No calendar with name [~a]") calendar-name))) ;; Expected form of data (but in XML) is: @@ -254,12 +258,12 @@ (lambda (err port . args) (return (build-response code: 400) (format #f "~a ~{~a~}\r\n" - (_ "XML parse error") + (G_ "XML parse error") args))))))) (unless (eq? 'VEVENT (type event)) (return (build-response code: 400) - (string-append (_ "Object not a VEVENT") "\r\n"))) + (string-append (G_ "Object not a VEVENT") "\r\n"))) ;; NOTE add-event uses the given UID if one is given, ;; but generates its own if not. It might be a good idea @@ -272,6 +276,10 @@ (catch* (lambda () (add-and-save-event global-event-object calendar event)) + ((pre-unwind #t) + (lambda _ + (let ((stack (make-stack #t))) + (display-backtrace stack (current-error-port))))) (warning (lambda (err fmt args) (define str (format #f "~?" fmt args)) @@ -286,11 +294,11 @@ str))))) (return '((content-type application/xml)) - (with-output-to-string - (lambda () - (sxml->xml - `(properties - (uid (text ,(prop event 'UID))))))))))) + (lambda (port) + (sxml->xml + `(properties + (uid (text ,(prop event 'UID)))) + port)))))) ;; Get specific page by query string instead of by path. ;; Useful for <form>'s, since they always submit in this form, but also @@ -324,18 +332,18 @@ (GET "/calendar/:uid{.*}.xcs" (uid) (aif (get-event-by-uid global-event-object uid) (return '((content-type application/calendar+xml)) - ;; TODO sxml->xml takes a port, would be better - ;; to give it the return port imidiately. - (with-output-to-string - ;; TODO this is just the vevent part. - ;; A surounding vcalendar is required, as well as - ;; a doctype. - ;; Look into changing how events carry around their - ;; parent information, possibly splitting "source parent" - ;; and "program parent" into different fields. - (lambda () (sxml->xml ((@ (vcomponent formats xcal output) vcomponent->sxcal) it))))) + ;; TODO this is just the vevent part. + ;; A surounding vcalendar is required, as well as + ;; a doctype. + ;; Look into changing how events carry around their + ;; parent information, possibly splitting "source parent" + ;; and "program parent" into different fields. + (lambda (port) + (sxml->xml + ((@ (vcomponent formats xcal output) vcomponent->sxcal) it) + port))) (return (build-response code: 404) - (format #f (_ "No component with UID=~a found.") uid)))) + (format #f (G_ "No component with UID=~a found.") uid)))) (GET "/calendar/:uid{.*}.ics" (uid) (aif (get-event-by-uid global-event-object uid) @@ -344,7 +352,8 @@ (lambda () (print-components-with-fake-parent (list it))))) (return (build-response code: 404) - (format #f (_ "No component with UID=~a found.") uid)))) + (format #f (G_ "No component with UID=~a found.") uid)))) + (GET "/search/text" (q) (return (build-response @@ -404,14 +413,14 @@ (set! error (format #f "~?~%" fmt arg)))))) - (return `((content-type (content-type html))) - (with-output-to-string - (lambda () - ((sxml->output html) - (search-result-page - error - (and=> q (negate string-null?)) - search-term search-result page paginator)))))) + (return `((content-type ,(content-type html))) + (lambda (port) + ((sxml->output html) + (search-result-page + error + (and=> q (negate string-null?)) + search-term search-result page paginator) + port)))) ;; NOTE this only handles files with extensions. Limited, but since this ;; is mostly for development, and something like nginx should be used in @@ -449,7 +458,7 @@ (lambda () ((sxml->output html) (xhtml-doc - (head (title ,(_ "Calp directory listing for ") path) + (head (title ,(G_ "Calp directory listing for ") path) ,(include-css "/static/directory-listing.css")) (body ,(directory-table (static-dir) path)))))))) diff --git a/module/calp/server/server.scm b/module/calp/server/server.scm index 814aaed7..4c5a0886 100644 --- a/module/calp/server/server.scm +++ b/module/calp/server/server.scm @@ -3,28 +3,21 @@ :use-module (web server) :use-module ((calp server routes) :select (make-make-routes)) :use-module (ice-9 threads) + :use-module (srfi srfi-88) + :use-module (calp server socket) :export (start-server)) -;; NOTE The default make-default-socket is broken for IPv6. -;; A patch has been submitted to the mailing list. 2020-03-31 -(module-set! - (resolve-module '(web server http)) - 'make-default-socket - (lambda (family addr port) - (let ((sock (socket family SOCK_STREAM 0))) - (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) - (bind sock family addr port) - sock))) - +;;; TODO Do I really want this hardcoded here? (define handler (make-make-routes)) -;; (define impl (lookup-server-impl 'http)) -;; (define server (open-server impl open-params)) - (define (start-server open-params) - (run-server handler 'http open-params 1) + (run-server handler + 'http + (append open-params + `(socket: ,(apply setup-socket open-params))) + 1) ;; NOTE at first this seems to work, but it quickly deteriorates. ;; (for i in (iota 16) ;; (begin-thread diff --git a/module/calp/server/socket.scm b/module/calp/server/socket.scm new file mode 100644 index 00000000..990adfa6 --- /dev/null +++ b/module/calp/server/socket.scm @@ -0,0 +1,48 @@ +(define-module (calp server socket) + :use-module (srfi srfi-88) + :use-module (web server) + :export (setup-socket + run-at-any-port) + ) + +;; NOTE The default make-default-socket is broken for IPv6. +;; A patch has been submitted to the mailing list. 2020-03-31 +;; +;; This sets up the socket manually, and sends that to @code{http-open}. +(define* (make-default-socket/fixed family addr port) + (let ((sock (socket family SOCK_STREAM 0))) + (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) + (bind sock family addr port) + sock)) + +(define* (setup-socket key: + (host #f) + (family AF_INET) + (addr (if host (inet-pton family host) + INADDR_LOOPBACK)) + (port 8080)) + (make-default-socket/fixed family addr port)) + + +(define* (run-at-any-port handler key: + (min-port 8081) + msg-port) + (unless msg-port + (scm-error 'misc-error "run-at-any-port" + "msg-port required" + '() #f)) + (let loop ((port min-port)) + (catch 'system-error + (lambda () + (let ((socket (setup-socket port: port))) + (let ((addr (format #f "http://localhost:~a~%" port))) + (display addr msg-port) + (force-output msg-port) + (format #t "Server started at ~s~%" addr) + (run-server handler 'http + `(socket: ,socket)) + (format #t "Server closed~%")))) + (lambda (err proc fmt args data) + (if (= EADDRINUSE (car data)) + (loop (1+ port)) + (apply throw err proc fmt args data)))))) diff --git a/module/calp/server/webdav.scm b/module/calp/server/webdav.scm new file mode 100644 index 00000000..f26b97f6 --- /dev/null +++ b/module/calp/server/webdav.scm @@ -0,0 +1,767 @@ +(define-module (calp server webdav) + :use-module ((hnh util) :select (for group -> ->> init+last catch*)) + :use-module (ice-9 match) + :use-module (ice-9 regex) + :use-module (ice-9 format) + :use-module (ice-9 control) + :use-module (web request) + :use-module (web response) + :use-module (web uri) + :use-module (web server) + :use-module ((web http) :select (declare-method! + declare-header!)) + :use-module (web http status-codes) + :use-module (datetime) + :use-module (sxml match) + :use-module (sxml namespaced) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (rnrs bytevectors) + :use-module (rnrs io ports) + :use-module (calp namespaces) + :use-module (calp webdav resource) + :use-module (calp webdav resource virtual) + :use-module (calp webdav resource file) + :use-module (calp webdav property) + :use-module (calp webdav propfind) + :use-module (calp webdav proppatch) + :use-module (oop goops) + :export (; run-run + run-propfind + run-proppatch + run-options + run-get + run-put + run-delete + run-mkcol + run-copy + run-move + run-report + + root-resource + webdav-handler + )) + +;; (define* (my-build-response . kvs) +;; (define dt (datetime->string (current-datetime) "~a, ~d ~b ~Y ~H:~M:~S GMT")) +;; (define server (format #f "calp/~a" (@ (calp) version))) +;; (let ((as (kvlist->assq kvs))) +;; (append kvs +;; (list +;; reason-phrase: (http-status-phrase (assq-ref as code:)) +;; headers: (append (or (assq-ref kvs headers:) '()) +;; (list +;; server: server +;; date: dt +;; connection: 'keep-alive)))))) + +(define (swap p) + (xcons (car p) (cdr p))) + + +(define output-namespaces + (map (lambda (pair) (call-with-values (lambda () (car+cdr pair)) + xcons)) + namespaces)) + +;; (define (run-filter context filter-spec) +;; (sxml-match filter-spec +;; [(c:comp-filter (@ (name ,name)) . ,rest) +;; ;; TODO +;; (filter (lambda (child) (string=? name (type child))) +;; (children context))] +;; [(c:prop-filter (@ (name ,name))) +;; (prop context name) +;; ] +;; [(c:prop-filter (@ (name ,name)) . ,rest) +;; ] +;; [(c:param-filter (@ (name ,name)) . ,rest)] +;; [(c:is-not-defined)] +;; [(c:text-match (@ . ,attrs) . ,data)] +;; [(c:time-range (@ . ,attrs))])) + + + +;; Requests can content-type be both both application/xml and text/xml, server MUST accept both (RFC 4918 8.2) + +;; ;; RFC 4918 8.2 +;; (catch 'parser-error +;; (lambda () (xml->sxml body)) +;; (lambda (err input-port . msg) +;; (define err-msg +;; (with-output-to-string +;; (lambda () (for-each display msg)))) +;; (return (build-response code: 400 +;; headers: ((content-type . (text/plain)))) +;; err-msg))) + +;; ;; If a body is sent by the client when not expected, the server MUST repspond +;; ;; with 415 (RFC 4918 8.4) + +;; PROPPATCH +;; SHOULD support setting of arbitrary dead properties (RFC4918 9.2) +;; Fruux supports this +;; NOTE this means that user quotas must include dead properties + + +;; A caldav server MUST support +;; - RFC4918 (WebDAV) Class 1 +;; - RFC3744 WebDAV ACL including additional privilege defined in 6.1 +;; - HTTPS +;; - ETags from RFC2616 (http) + +;; MKCALENDAR NOT required + + + + +;; getcontentlanguage, "dead" property + +(declare-method! "PROPFIND" 'PROPFIND) +(declare-method! "PROPPATCH" 'PROPPATCH) +(declare-method! "MKCOL" 'MKCOL) +(declare-method! "COPY" 'COPY) +(declare-method! "MOVE" 'MOVE) +(declare-method! "LOCK" 'LOCK) +(declare-method! "UNLOCK" 'UNLOCK) +(declare-method! "REPORT" 'REPORT) + + + +(define (root-element sxml) + (sxml-match sxml + [(*TOP* (*PI* . ,args) ,root) root] + [(*TOP* ,root) root] + [,root root])) + +(define (root-element/namespaced sxml) + (cond ((not (list? sxml)) (scm-error 'misc-error "root-element/namespaced" + "Argument is invalid sxml: ~s" + (list sxml) #f)) + ((null? (car sxml)) (scm-error 'misc-error "root-element/namespaced" + "No root in an empty list" + '() #f)) + ((eq? '*TOP* (car sxml)) + (let ((children (cdr sxml))) + (cond ((null? children) #f) + ((pi-element? (car children)) + (cadr children)) + (else (car children))))) + (else sxml))) + + +(define root-resource (make-parameter #f)) + + + +(define (parse-dav-line str) + (map (lambda (item) + (cond ((string-match "^[0-9]+$" item) + => (lambda (m) (number->string (match:substring m)))) + ((string-match "^<(.*)>$" item) + => (lambda (m) (string->uri (match:substring m 1)))) + (else (string->symbol item)))) + (map string-trim-both (string-split str #\,)))) + +(define (validate-dav-line lst) + (every (lambda (item) + (or (and (number? item) (<= 1 item 3)) + (uri? item) + ;; Possibly check against list of valid tokens + (symbol? item))) + lst)) + +(define (write-dav-line lst port) + (display + (string-join (map (lambda (item) + (cond ((number? item) (number->string item)) + ((uri? item) (string-append "<" (uri->string item) ">")) + (else (symbol->string item)))) + lst) + ", " 'infix) + port)) + +(declare-header! "DAV" + parse-dav-line + validate-dav-line + write-dav-line) + +(declare-header! "Depth" + (lambda (str) + (if (string-ci=? str "Infinity") + 'infinity + (string->number str))) + (lambda (value) + (memv value '(0 1 infinity))) + (lambda (value port) + (display value port))) + +(declare-header! "Destination" + string->uri + uri? + (lambda (uri port) + (display (uri->string uri) port))) + +;;; TODO +;; (declare-header! "If") + +;;; TODO +;; (declare-header! "Lock-Token") + +(declare-header! "Overwrite" + (lambda (str) + ;; TODO assert isn't a thing + ;; (assert (= 1 (string-length str))) + (case (string-ref str 0) + ((#\F) #f) + ((#\T) #t) + (else (throw 'error)))) + boolean? + (lambda (b port) + (display (if b "T" "F") + port))) + +;;; TODO +;; (declare-header! "Timeout") + + + +(define (run-propfind href request body) + (define headers (request-headers request)) + (cond ((lookup-resource (root-resource) href) + => (lambda (resource) + (define requested-resources + (case (or (assoc-ref headers 'depth) 'infinity) + ((0) (list (cons href resource))) + ((1) (cons (cons href resource) + (map (lambda (child) + (cons (append href (list (name child))) + child)) + (children resource)))) + ((infinity) (all-resources-under resource href)))) + + ;; Body, if it exists, MUST have be a DAV::propfind object + (define property-request + (cond ((string? body) + (xml->namespaced-sxml body)) + ((bytevector? body) + (-> body + (bytevector->string + (make-transcoder (utf-8-codec))) + xml->namespaced-sxml)) + (else `(,(xml webdav 'propfind) + (,(xml webdav 'allprop)))))) + + + (catch 'bad-request + (lambda () + (values (build-response + code: 207 + reason-phrase: (http-status-phrase 207) + headers: '((content-type . (application/xml)))) + (lambda (port) + (namespaced-sxml->xml + `(,(xml webdav 'multistatus) + ,@(for (href . resource) in requested-resources + `(,(xml webdav 'response) + (,(xml webdav 'href) ,(href->string href)) + ,@(map propstat->namespaced-sxml + (parse-propfind (root-element/namespaced property-request) + resource))))) + namespaces: output-namespaces + port: port) + (newline port)))) + (lambda (err proc fmt args data) + (values (build-response + code: 400 + headers: '((content-type . (text/plain)))) + (lambda (port) + (apply format port fmt args))))))) + (else (values (build-response code: 404) "")))) + + + +(define (run-proppatch href request body) + (cond ((lookup-resource (root-resource) href) + => (lambda (resource) + ;; Body MUST exist, and be a DAV::propertyupdate element + (catch 'bad-request + (lambda () + (values (build-response + code: 207 + reason-phrase: (http-status-phrase 207) + headers: '((content-type . (application/xml)))) + (lambda (port) + (define-values (request namespaces*) + (cond ((string? body) + (-> body + xml->namespaced-sxml + (namespaced-sxml->sxml/namespaces + (map swap namespaces)))) + ((bytevector? body) + (-> body + (bytevector->string (make-transcoder (utf-8-codec))) + xml->namespaced-sxml + (namespaced-sxml->sxml/namespaces + (map swap namespaces)))) + (else (throw 'body-required)))) + + (namespaced-sxml->xml + `(,(xml webdav 'multistatus) + (,(xml webdav 'response) + (,(xml webdav 'href) ,(href->string href)) + ,@(map propstat->namespaced-sxml + (parse-propertyupdate + (root-element request) + (map swap namespaces*) + resource)))) + port: port)))) + (lambda (err proc fmt args data) + (values (build-response + code: 400 + headers: '((content-type . (text/plain)))) + (lambda (port) + (apply format port fmt args))))))) + (else (values (build-response code: 404) "")))) + + +(define (run-options href request) + (values + (build-response code: 200 + headers: `((dav . (1)) + ;; (DAV . "calendar-access") + ;; TODO collecting this set dynamically would be fancy! + (allow . (GET HEAD PUT + MKCOL PROPFIND OPTIONS + DELETE + COPY + MOVE + ;; LOCK + ;; UNLOCK + ;; REPORT + )))) + "")) + +(define (run-get href request mode) + (cond ((lookup-resource (root-resource) href) + => (lambda (resource) + ;; "/calendar/:user/:calendar/:filename" + ;; headers: `((content-type ,content-type)) + (values (build-response code: 200) + (case mode + ((HEAD) "") + ((GET) (content resource)) + (else (scm-error 'misc-error "run-get" + "Unknown mode: ~s" + (list mode) #f)))))) + (else (values (build-response code: 404) "")))) + +(define (run-put href request request-body) + (cond ((null? href) + (values (build-response code: 405 headers: '((content-type . (text/plain)))) + "Can't PUT on root resource")) + ((lookup-resource (root-resource) (drop-right href 1)) + => (lambda (parent) + (cond ((lookup-resource parent (list (last href))) + => (lambda (child) + (if (is-collection? child) + (values (build-response code: 405) "") + (begin + (set-content! child request-body) + (values (build-response code: 204) ""))))) + (else + (add-resource! parent (last href) + request-body) + (values (build-response code: 201) ""))))) + ;; No parent collection, fail per [WEBDAV] 9.7.1. + (else (values (build-response code: 409))))) + +(define (run-mkcol href request _) + ;; TODO href="/" + (if (assoc-ref (request-headers request) 'content-type) + (values (build-response code: 415) + "") + (let ((path name (init+last href))) + (cond ((lookup-resource (root-resource) path) + => (lambda (parent) + (catch 'resource-exists + (lambda () + (add-collection! parent name) + (values (build-response code: 201) "")) + (lambda _ (values (build-response code: 405) ""))))) + (else + (values (build-response code: 409) "")))))) + + + +;;; TODO completely rewrite error handling here +;;; TODO what happens on copy between sub-trees of different types? +;;; Like from a <calendar-resource> tree to a <file-tree>. +(define (run-copy source-href request) + (define headers (request-headers request)) + (call/ec + (lambda (return) + (let* ((depth (or (assoc-ref headers 'depth) 'infinity)) + (destination-uri (assoc-ref headers 'destination)) + (dest-href (-> headers (assoc-ref 'destination) + uri-path string->href)) + (overwrite? + (cond ((assoc 'overwrite headers) => cdr) + (else #t)))) + + ;; (assert (memv depth '(0 infinity))) + ;; (unless (string=? (listen-uri) (uri-host destination-uri)) + ;; (throw 'cross-domain-copy-not-supported)) + + (let ((dest-path dest-name (init+last dest-href))) + (let ((source-resource + (cond ((lookup-resource (root-resource) source-href) => identity) + (else (return (build-response code: 404) "")))) + (destination-parent-resource + (cond ((lookup-resource (root-resource) dest-path) => identity) + (else (return (build-response + code: 409 + reason-phrase: (http-status-phrase 409) + headers: '((content-type . (text/plain)))) + "One or more parent components of destination are missing"))))) + + (case (copy-to-location! source-resource destination-parent-resource + new-name: dest-name + include-children?: (case depth + ((0) #f) + ((infinity) #t) + (else (throw 'invalid-requeqst))) + overwrite?: overwrite?) + ((created) + (values (build-response code: 201) "")) + ((replaced) + (values (build-response code: 204) "")) + ((collision) + (values (build-response code: 412) ""))))))))) + + +(define (run-delete href request) + ;; TODO href="/" + (let ((path name (init+last href))) + (cond ((lookup-resource (root-resource) path) + => (lambda (parent) + (cond ((lookup-resource parent (list name)) + => (lambda (child) + (delete-child! parent child) + (values (build-response code: 202) + ""))) + (else + (values (build-response code: 404) ""))))) + (else + (values (build-response code: 404) ""))))) + + +(define (run-move href request) + ;; TODO href="/" + (define headers (request-headers request)) + (call/ec + (lambda (return) + (define-values (path name) (init+last href)) + (define parent (or (lookup-resource (root-resource) path) + (return (build-response code: 404) + "Source Parent not found"))) + (define child (or (lookup-resource parent (list name)) + (return (build-response code: 404) + "Source not found"))) + (define-values (dest-path dest-name) + (-> headers (assoc-ref 'destination) + uri-path string->href init+last)) + (define dest-parent (or (lookup-resource (root-resource) dest-path) + (return (build-response code: 404) + "Dest Parent not found"))) + (define overwrite? (cond ((assoc 'overwrite headers) => cdr) + (else #t))) + (define status (move-to-location! parent child + dest-parent + new-name: dest-name + overwrite?: overwrite?)) + + (case status + ((created) + (values (build-response code: 201) "")) + ((replaced) + (values (build-response code: 204) "")) + ((collision) + (values (build-response code: 412) "")))))) + + + +;; (define (run-report href request request-body)) + + + +(define log-table (make-parameter #f)) +(define (init-log-table!) (log-table '())) +(define (log-table-add! . args) + (for (key value) in (group args 2) + (log-table (acons key value (log-table))))) +(define* (log-table-get key optional: dflt) + (or (assoc-ref (log-table) key) + dflt)) + +(define (log-table-format . args) + (for-each (lambda (arg) + (cond ((string? arg) (display arg)) + ((symbol? arg) (cond ((log-table-get arg) + => display))) + ((pair? arg) (cond ((log-table-get (car arg)) + => (compose display (cdr arg))))) + (else #f))) + args)) + +(define (emit-log!) + ;; (write (log-table) (current-error-port)) + ;; (newline (current-error-port)) + (display + (with-output-to-string + (lambda () + (log-table-format (cons 'now (lambda (n) (datetime->string n "~H:~M:~S"))) + " " 'method " " + (cons 'uri uri->string) + " ") + (case (request-method (log-table-get 'request)) + ((COPY MOVE) (log-table-format + (cons 'headers (lambda (h) (and=> (assoc-ref h 'destination) uri->string))) + " ")) + (else "")) + ;; Nginx uses + ;; <ip> - - [<date>] "<request-line>" <request-status> <content-length> "<referer-url>" "<user-agent>" + (log-table-format 'response-code " " + 'response-phrase + " " + (cons 'headers (lambda (h) (assoc-ref h 'x-litmus))) + "\n") + + (cond ((log-table-get 'msg) + => (lambda (it) + (display it) + (newline)))))) + + (current-error-port)) + ) + + + + +;; For all headers: +;; `((server ,(format #f "calp/~a" (@ (calp) version))) +;; (date ,(datetime->string (current-datetime) +;; "~a, ~d ~b ~Y ~H:~M:~S GMT")) +;; (connection keep-alive)) + +;; Already fixed by server +;; (content-length ,(format #f (bytevector->length data))) + + +(define (webdav-handler request request-body) + (define href (-> request request-uri uri-path string->href)) + (init-log-table!) + (log-table-add! 'now (current-datetime) + 'method (request-method request) + 'uri (request-uri request) + 'headers (request-headers request) + 'request request) + + (catch* + (lambda () + ;; TODO also log result of execution + (call-with-values + (lambda () + (case (request-method request) + ((OPTIONS) (run-options href request)) + + ((PROPFIND) (run-propfind href request request-body)) + ((PROPPATCH) (run-proppatch href request request-body)) + + ((GET HEAD) (run-get href request (request-method request))) + + ((PUT) (run-put href request request-body)) + + ((DELETE) (run-delete href request)) + + ((MKCOL) (run-mkcol href request request-body)) + + ((COPY) (run-copy href request)) + ((MOVE) (run-move href request)) + + ;; ((REPORT)) + + (else (values (build-response code: 400) "")))) + (lambda (head body) + (log-table-add! + 'response head + 'response-code (response-code head) + 'response-phrase (response-reason-phrase head)) + (emit-log!) + (values head body)))) + + (parser-error + (lambda (err port msg . args) + (define head (build-response code: 400 + headers: '((content-type . (text/plain))))) + (define errmsg + (with-output-to-string + (lambda () + (display msg) + (for-each display args)))) + (log-table-add! 'response head + 'response-code 400 + 'msg errmsg) + (emit-log!) + (values head errmsg))) + + (#t + (case-lambda ((err proc fmt args data) + (let ((head (build-response + code: 500 + headers: '((content-type . (text/plain))))) + (errmsg (if proc + (format #f "Error in ~a: ~?~%" proc fmt args) + (format #f "~?~%" fmt args)))) + (log-table-add! 'response head + 'response-code 500 + 'msg errmsg) + (emit-log!) + (values head errmsg))) + (err + (let ((errmsg (format #f "General error: ~s~%" err))) + (log-table-add! 'response-code 500 + 'msg errmsg) + (emit-log!) + (values (build-response code: 500) + errmsg))))))) + + + +;;; TODO shouldn't this default to #f +(root-resource + (let () + (define root-resource (make <virtual-resource> name: "*root*")) + + (define virtual-resource (make <virtual-resource> + name: "virtual" + content: (string->bytevector "Hello, World\n" (native-transcoder)))) + + (define file-tree (make <file-resource> + root: "/home/hugo/tmp" + name: "files")) + + (mount-resource! root-resource file-tree) + (mount-resource! root-resource virtual-resource) + root-resource)) + + +(define (run-run) + (unless (root-resource) + (throw 'misc-error "run-run" + "root-resource parameter must be set before running" + (list) #f)) + (run-server webdav-handler + 'http + `(#:port 8102))) + +;; "/principals/uid/:uid" + +#; + +(define (make-make-routes) + (make-routes + + + ;; A file extension could be added, but + ;; text/calendar ⇒ .ics + ;; application/calendar+xml ⇒ .xcs + ;; application/calendar+json ⇒ UNKNOWN + (GET "/caldav/:user/:calendar/:filename" (user calendar filename) + (define requested-types + (cond ((assoc-ref r:headers 'accept) + => (lambda (accept) + (sort* accept < + (lambda (type) + (or (assoc-ref (cdr type) 'q) + 1000))))) + (else '(text/calendar)))) + (define available-types + '(text/calendar application/calendar+xml)) + + (define content-type (find (lambda (type) (memv type available-types)) requested-types)) + (define serializer + (case content-type + ((text/calendar) ical:serialize) + ((application/calendar+xml) xcal:serialize) + ((application/calendar+sexp) sxcal:serialize) + (else (return (build-response code: 415) + "Bad content type")))) + + (define event + (copy-as-orphan + (get-by-uid (get-store-by-name calendar) filename))) + + ;; TODO where is the event split into multiple VEVENT objects in the + ;; serialized form? Should be in the serializer, right? + + (define component + (vcalendar prodid: ((@ (calp) prodid)) + version: "2.0" + (list event))) + + (values `((content-type ,content-type)) + (call-with-output-string + (lambda (p) (serializer component p))))) + + (PUT "/caldav/:user/:calendar/:filename" (user calendar filename) + ;; Request Headers: + ;; If-None-Match + ;; Content-Type: text/calendar + ;; application/calendar+xml + + ;; TODO change -X-HNH to X-HNH-PRIVATE, see RFC4791 5.3.3 + + (define component + (let ((type args (car+cdr (assoc-ref r:headers 'content-type)))) + ;; Valid args: charset component optinfo + ;; Invalid args: method (see RFC4791 4.1) + ;; Component is for redundancy? + ;; optinfo is implementation dependant? + ;; Charset already handled by HTTP server + (case type + ((text/calendar) (ical:deserialize body)) + ((application/calendar+xml) (xcal:deserialize body)) + (else (return (build-response code: 415) + "Can't handle that content type"))))) + + (unless (eq? 'VCALENDAR (type component)) + ;; Top level object must be a VCALENDAR + ) + + ;; Must all children be VEVENT? + (children component) + + ;; All VEVENT component must be the the same event, so they should be merged into a single event + (define event (handle-events component)) + + ;; RFC4791 5.3.2: + ;; > The URL for each calendar object resource is entirely arbitrary and + ;; > does not need to bear a specific relationship to the calendar object + ;; > resource's iCalendar properties or other metadata. New calendar + ;; But requiring that UID and filename match makes things easier for us, at least for now + (unless (string=? filename (prop component 'UID)) + (return (build-response code: 400) + "UID and filename must match")) + + (let ((cal (get-calendar-by-name global-event-object calendar))) + ;; (add-and-save-event global-event-object cal component) + + (reparent! cal event) + (queue-write (get-store-for-calendar cal) event) + + ) + + ) + )) diff --git a/module/calp/terminal.scm b/module/calp/terminal.scm index ee3b7bc4..316421eb 100644 --- a/module/calp/terminal.scm +++ b/module/calp/terminal.scm @@ -76,7 +76,7 @@ " │ " (if (prop ev 'LOCATION) "" "\x1b[1;30m") (trim-to-width - (or (prop ev 'LOCATION) (_ "NO LOCATION")) location-width) + (or (prop ev 'LOCATION) (G_ "NO LOCATION")) location-width) STR-RESET "\n"))) events @@ -127,7 +127,7 @@ (cls) - (display (_ "== Day View ==")) + (display (G_ "== Day View ==")) (newline) (display-calendar-header! (current-page this)) @@ -148,25 +148,25 @@ (awhen (prop ev 'LOCATION) (format #t "\x1b[1m~a:\x1b[m ~a~%" - (_ "Location") + (G_ "Location") it)) ;; NOTE RFC 5545 says that DTSTART and DTEND MUST ;; have the same type. However we believe that is ;; another story. (format #t "\x1b[1m~a:\x1b[m ~a " - (_ "Start") + (G_ "Start") (let ((start (prop ev 'DTSTART))) (if (datetime? start) (datetime->string (prop ev 'DTSTART) - (_ "~Y-~m-~d ~H:~M:~S")) + (G_ "~Y-~m-~d ~H:~M:~S")) (date->string start)))) (format #t "\x1b[1m~a:\x1b[m ~a~%~%" - (_ "End") - (let ((start (prop ev 'DTSTART))) - (if (datetime? start) - (datetime->string (prop ev 'DTSTART) - (_ "~Y-~m-~d ~H:~M:~S")) - (date->string start)))) + (G_ "End") + (let ((end (prop ev 'DTEND))) + (if (datetime? end) + (datetime->string (prop ev 'DTEND) + (G_ "~Y-~m-~d ~H:~M:~S")) + (date->string end)))) (format #t "~a~%" (unlines (take-to (flow-text (or (prop ev 'DESCRIPTION) "") width: (min 70 width)) @@ -208,14 +208,14 @@ (active-element this) 0)) ((#\/) (set-cursor-pos 0 (1- height)) - (let ((search-term (get-line (_ "quick search: ")))) + (let ((search-term (get-line (G_ "quick search: ")))) `(push ,(search-view (format #f "(regexp-exec (make-regexp \"~a\" regexp/icase) (prop event 'SUMMARY))" search-term) (get-event-set this))))) ((#\() (set-cursor-pos 0 (1- height)) - (let ((search-term (get-line (_ "search: ")))) + (let ((search-term (get-line (G_ "search: ")))) `(push ,(search-view search-term (get-event-set this))))) (else (next-method)))) @@ -261,7 +261,7 @@ (cls) - (display (_ "== Search View ==\n")) + (display (G_ "== Search View ==\n")) ;; display search term (format #t "~y" (search-term this)) @@ -290,6 +290,7 @@ ">"))) (newline)) +;;; TODO what is this view? (define-method (input (this <view>) char) (case char ((#\j #\J down) (unless (= (active-element this) (1- (page-length this))) @@ -300,6 +301,9 @@ ((#\g) (set! (active-element this) 0)) ((#\G) (set! (active-element this) (1- (page-length this)))) + ;; TODO Launch edit mode! + ;; TODO should edit mode be here? + ((#\e) 'NOOP) ((#\q) '(pop))) @@ -317,7 +321,7 @@ 'DTSTART))))) ((#\h left) (set! (current-page this) = ((lambda (old) (max 0 (1- old)))))) ((#\l right) - (format #t "~% ~a~%" (_ "loading...")) + (format #t "~% ~a~%" (G_ "loading...")) (set! (current-page this) (next-page (slot-ref this 'search-result) (current-page this)))) diff --git a/module/calp/translation.scm b/module/calp/translation.scm index 67189e7a..e99062db 100644 --- a/module/calp/translation.scm +++ b/module/calp/translation.scm @@ -3,7 +3,7 @@ :use-module (ice-9 regex) :use-module (ice-9 match) :use-module (srfi srfi-88) - :export (_ translate yes-no-check)) + :export (G_ translate yes-no-check)) (bindtextdomain "calp" "/home/hugo/code/calp/localization/") @@ -18,7 +18,7 @@ (gettext string "calp"))) ;; Mark string for translation, and also make it discoverable for gettext -(define (_ . msg) +(define (G_ . msg) (translate (string-join msg))) (define* (yes-no-check string optional: (locale %global-locale)) diff --git a/module/calp/util/config.scm b/module/calp/util/config.scm index aba2cd2c..d2bff5ac 100644 --- a/module/calp/util/config.scm +++ b/module/calp/util/config.scm @@ -19,7 +19,7 @@ args)) (define %configuration-error - (_ "Pre-property failed when setting ~s to ~s")) + (G_ "Pre-property failed when setting ~s to ~s")) (define-syntax-rule (define-once-public symbol binding) (begin (define-once symbol binding) @@ -27,7 +27,7 @@ (define-syntax (define-config stx) (syntax-case stx () - ((_ name default kw ...) + ((G_ name default kw ...) (let ((pre (cond ((memv pre: (fix-keywords #'(kw ...))) => cadr) (else #f))) (post (cond ((memv post: (fix-keywords #'(kw ...))) => cadr) (else #f)))) #`(define-once-public name diff --git a/module/calp/util/exceptions.scm b/module/calp/util/exceptions.scm index 5d6a71e8..6bfc2415 100644 --- a/module/calp/util/exceptions.scm +++ b/module/calp/util/exceptions.scm @@ -4,6 +4,6 @@ :use-module (hnh util exceptions)) (define-config warnings-are-errors #f - description: (_ "Crash on warnings.") + description: (G_ "Crash on warnings.") post: (@ (hnh util exceptions) warnings-are-errors) ) diff --git a/module/calp/webdav/property.scm b/module/calp/webdav/property.scm new file mode 100644 index 00000000..092d270a --- /dev/null +++ b/module/calp/webdav/property.scm @@ -0,0 +1,91 @@ +(define-module (calp webdav property) + :use-module (sxml namespaced) + :use-module (web http status-codes) + :use-module ((srfi srfi-1) :select (concatenate find)) + :use-module (srfi srfi-9) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (hnh util) + :use-module (calp namespaces) + :export (make-propstat + propstat? + propstat-status-code + propstat-property + propstat-error + propstat-response-description + + propstat + + merge-propstats + propstat-200? + ;; propstat->sxml + propstat->namespaced-sxml + )) + +;;; Commentary: +;;; Code: + + +;; Maps directly to [WEBDAV]'s propstat objects. This is just a simpler interface in the code. + +(define-record-type <propstat> + (make-propstat status prop error responsedescription) + propstat? + ;; An http status code indicating if this property is present + (status propstat-status-code) + ;; A list of namespaced sxml elements, such that they could all be + ;; directly inserted as the children of <DAV::prop/> + ;; @example + ;; `((,(xml ns tag) "Content")) + ;; @end example + (prop propstat-property) + + ;; See [WEBCAL] propstat XML element + (error propstat-error) + (responsedescription propstat-response-description)) + +(define* (propstat code prop key: error responsedescription) + (make-propstat code prop error responsedescription)) + +;; Query a given dead property from the given resource +;; property should be a xml-element item +;; (define (propfind-selected-property resource property) +;; (cond ((get-dead-property resource property) +;; => (lambda (it) (propstat 200 (list it)))) +;; (else (propstat 404 (list (list property)))))) +;; Takes a list of <propstat> items, finds all where status, error, and +;; responsedescription are all equal, and merges the prop tags of all those. +;; Returns a new list of <propstat> items +(define (merge-propstats propstats) + (map (lambda (group) + (define-values (code error desc) (unlist (car group))) + (make-propstat code + (concatenate + (map propstat-property (cdr group))) + error desc)) + (group-by (lambda (propstat) + (list (propstat-status-code propstat) + (propstat-error propstat ) + (propstat-response-description propstat))) + propstats))) + +(define (propstat-200? prop) + (= 200 (propstat-status-code prop))) + + +;; (define (propstat->sxml propstat) +;; `(d:propstat (d:prop ,(propstat-property propstat)) +;; (d:status ,(http-status-line (propstat-status-code propstat))) +;; ,@(awhen (propstat-error propstat) +;; `((d:error ,it))) +;; ,@(awhen (propstat-response-description propstat) +;; `((d:responsedescription ,it))))) + +(define (propstat->namespaced-sxml propstat) + `(,(xml webdav 'propstat) + (,(xml webdav 'prop) ,@(propstat-property propstat)) + (,(xml webdav 'status) ,(http-status-line (propstat-status-code propstat))) + ,@(awhen (propstat-error propstat) + `((,(xml webdav 'error) ,it))) + ,@(awhen (propstat-response-description propstat) + `((,(xml webdav 'responsedescription) ,it))))) diff --git a/module/calp/webdav/propfind.scm b/module/calp/webdav/propfind.scm new file mode 100644 index 00000000..83725825 --- /dev/null +++ b/module/calp/webdav/propfind.scm @@ -0,0 +1,99 @@ +(define-module (calp webdav propfind) + :use-module (calp webdav property) + :use-module (calp webdav resource) + :use-module (calp namespaces) + :use-module (srfi srfi-1) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) + :export (propfind-selected-properties + propfind-all-live-properties + propfind-most-live-properties + propfind-all-dead-properties + + parse-propfind + )) + +;;; Commentary: +;;; Procedures for the WebDav PROPFIND method +;;; Code: + +;; Properties should be a list of xml-tag-elements +;; return a list of propstat elements +;; work for both dead and alive objects +(define (propfind-selected-properties resource properties) + (map (lambda (el) (get-property resource el)) + properties)) + + +;; (define-method (supported-properties (self <resource>)) +;; (map (lambda (v) (cons webdav v)) +;; `())) + +;; Returns a list of <propstat> objects. +(define (propfind-all-live-properties resource) + (map (lambda (p) ((cdr p) resource)) + (live-properties resource))) + +;; Returns a list of <propstat> objects. +;; The list being the live properties defined by [WEBDAV] +(define (propfind-most-live-properties resource) + (map (lambda (p) ((property-getter (cdr p)) resource)) + webdav-properties)) + +;; Returns a list of <propstat> objects. +;; All "dead" properties on resource. +(define (propfind-all-dead-properties resource) + (map (lambda (v) (propstat 200 (list v))) + (dead-properties resource))) + + + + + +(define (find-element target list) + (define target* (xml-element-hash-key target)) + (find (lambda (x) (and (list? x) + (not (null? x)) + (xml-element? (car x)) + (equal? target* (xml-element-hash-key (car x))))) + list)) + +;; Takes a propfind xml element (tree), and a webdav resource object. +;; Returns a list of <propstat> objects. +(define (parse-propfind sxml resource) + ;; (assert (list? sxml)) + ;; (assert (not (null? sxml))) + ;; (assert eq? 'd:propfid (car sxml)) + (let ((propname (find-element (xml webdav 'propname) (cdr sxml))) + (allprop (find-element (xml webdav 'allprop) (cdr sxml))) + (include (find-element (xml webdav 'include) (cdr sxml))) + (prop (find-element (xml webdav 'prop) (cdr sxml)))) + (merge-propstats + (cond ((and allprop include) + ;; Return "all" properties + those noted by <include/> + (append (propfind-most-live-properties resource) + (propfind-all-dead-properties resource) + (propfind-selected-properties + resource + (map car (cdr include))))) + (allprop + ;; Return "all" properties + (append (propfind-most-live-properties resource) + (propfind-all-dead-properties resource))) + (propname + ;; Return the list of available properties + (list (propstat + 200 + ;; car to get tagname, list to construct a valid xml element + (map (compose list car) + (append + (dead-properties resource) + (live-properties resource)))))) + (prop + ;; Return the properties listed + (propfind-selected-properties + resource + (map car (cdr prop)))) + (else + (scm-error 'bad-request "parse-propfind" + "Invalid search query ~s" (list sxml) (list sxml))))))) diff --git a/module/calp/webdav/proppatch.scm b/module/calp/webdav/proppatch.scm new file mode 100644 index 00000000..db7f5f95 --- /dev/null +++ b/module/calp/webdav/proppatch.scm @@ -0,0 +1,67 @@ +(define-module (calp webdav proppatch) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (calp webdav property) + :use-module (calp webdav resource) + :use-module (sxml match) + :use-module (sxml namespaced) + :use-module ((hnh util) :select (for)) + :export (parse-propertyupdate) + ) + + +(define (parse-propertyupdate body namespaces resource) + (merge-propstats + (sxml-match body + [(d:propertyupdate . ,changes) + (define continuations + (concatenate + (for change in changes + (sxml-match change + [(d:remove (d:prop . ,properties)) + (map (lambda (prop) (cons prop + (remove-property + resource + (car + (sxml->namespaced-sxml prop namespaces))))) + properties)] + + ;; TODO handle xmllang correctly + [(d:set (d:prop . ,properties)) + (map (lambda (prop) (cons prop + (set-property resource + (sxml->namespaced-sxml prop namespaces)))) + properties)] + + [,else (scm-error 'bad-request "" + "Invalid propertyupdate: ~s" + (list body) + (list body))])))) + + ;; (format (current-error-port) "~s~%" continuations) + (let loop ((continuations continuations)) + (if (null? continuations) + '() + (let ((tag proc (car+cdr (car continuations)))) + (set! tag (sxml->namespaced-sxml tag namespaces)) + ;; (format (current-error-port) "tag: ~s~%" tag) + (catch #t (lambda () + ;; This is expected to throw quite often + (proc) + (cons (propstat 200 (list tag)) + (loop (cdr continuations)))) + (lambda err + (cons (propstat 409 (list tag)) + (mark-remaining-as-failed-dependency (cdr continuations))))))))] + + [,else (scm-error 'bad-request "" + "Invalid root element: ~s" + (list else) + (list else))]))) + + +(define (mark-remaining-as-failed-dependency pairs) + (map (lambda (item) + (propstat 424 (list (car item)))) + pairs)) diff --git a/module/calp/webdav/resource.scm b/module/calp/webdav/resource.scm new file mode 100644 index 00000000..47c5aded --- /dev/null +++ b/module/calp/webdav/resource.scm @@ -0,0 +1,15 @@ +(define-module (calp webdav resource) + :use-module (srfi srfi-88) + :use-module (oop goops) + :use-module (calp webdav resource base) + :export (mount-resource!)) + +(define cm (module-public-interface (current-module))) +(module-use! cm (resolve-interface '(calp webdav resource base))) + +;;; TODO mount-resource! vs add-child! +;;; Would a good idea be that add-resource! adds directly, and should +;;; be considered internal, while mount-resource! also runs post-add +;;; hooks, and could thereby be exported +(define-method (mount-resource! (this <resource>) (child <resource>)) + (add-child! this child)) diff --git a/module/calp/webdav/resource/base.scm b/module/calp/webdav/resource/base.scm new file mode 100644 index 00000000..500aef90 --- /dev/null +++ b/module/calp/webdav/resource/base.scm @@ -0,0 +1,598 @@ +(define-module (calp webdav resource base) + :use-module ((srfi srfi-1) :select (find remove last append-map drop-while)) + :use-module (srfi srfi-9) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (oop goops) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) + :use-module (calp webdav property) + :use-module (calp namespaces) + :use-module ((hnh util) :select (unless)) + :use-module (rnrs bytevectors) + :use-module (hnh util) + :use-module (hnh util env) + :use-module (datetime) + :export (<resource> + ;; href + href->string + string->href + href-relative + ;; local-path + name + dead-properties + ;; resource-children + resource? + children + + + + get-live-property + get-dead-property + get-property + + set-dead-property + set-dead-property! + set-live-property + set-live-property! + set-property + set-property! + + remove-dead-property + remove-dead-property! + remove-live-property + remove-live-property! + remove-property + remove-property! + + + setup-new-resource! + setup-new-collection! + + + + live-properties + add-child! + add-resource! + add-collection! + is-collection? + + content + set-content! + + copy-resource + copy-to-location! + move-to-location! + cleanup-resource + delete-child! + setup-new-resource! + ;; prepare-for-add! + + creationdate + displayname + getcontentlanguage + getcontentlength + getcontenttype + getetag + getlastmodified + lockdiscovery + resourcetype + supportedlock + + webdav-properties + + ;; absolute-path + ;; find-resource + lookup-resource + all-resources-under + + ;; dereference + + make-live-property + live-property? + property-getter + property-setter-generator + property-remover-generator + + prepare-update-properties + + )) + + +(define-record-type <live-property> + (make-live-property% getter setter-generator remover-generator) + live-property? + (getter property-getter) + (setter-generator property-setter-generator) + (remover-generator property-remover-generator)) + +(define* (make-live-property getter setter-generator optional: remover-generator) + (make-live-property% getter setter-generator remover-generator)) + + + +;; Collections are also resources, this is non-collection resources +(define-class <resource> () + ;; (href init-keyword: href: getter: href init-value: #f) + ;; (local-path init-keyword: local-path: getter: local-path) + + ;; name is a part of its search path. + ;; For example: the component located at /a/b + ;; would have name="a", its parent name="b", and the root element + ;; would have an unspecified name (probably the empty string, or "*root*") + (name init-keyword: name: getter: name) + + (dead-properties + ;; Map from (namespace . tagname) pairs to namespaced xml element + init-form: (make-hash-table) + getter: dead-properties%) + + ;; Attributes on data + (displayname accessor: displayname* init-value: #f) + (contentlanguage accessor: contentlanguage init-value: #f) + + ;; Direct children, used by @code{children} if not overwritten by child + (resource-children init-value: '() + accessor: resource-children) + + ;; Table containing href -> resource mappings, saves us from recursivly searching children each time. + (resource-cache init-value: (make-hash-table 0) + getter: resource-cache)) + +(define (resource? x) + (is-a? x <resource>)) + + +(define (href->string href) + (if (null? href) + "/" (string-join href "/" 'prefix))) + +(define (string->href s) + (remove string-null? + (string-split s #\/))) + +;; parent must be the head of child, elements in child after that is "free range" +(define (href-relative parent child) + (cond ((null? parent) child) + ((null? child) (scm-error 'misc-error "href-relative" "Not a sub-href" '() #f)) + ((equal? (car parent) (car child)) + (href-relative (cdr parent) (cdr child))) + (else (scm-error 'misc-error "href-relative" "Not a sub-href" '() #f)))) + +(define-method (children (self <resource>)) + (resource-children self)) + +;;; TODO merge content and set-content! into an accessor? +(define-method (content (self <resource>)) + (throw 'misc-error "content<resource>" + "Base <resource> doesn't implement (getting) content, please override this method" + '() #f)) + +(define-method (set-content! (self <resource>) content) + (throw 'msic-error "set-content!<resource>" + "Base <resource> doesn't implement (setting) content, please override this method" + '() #f)) + +(define-method (content-length (self <resource>)) + (if (is-collection? self) + 0 + (let ((c (content self))) + (cond ((bytevector? c) (bytevector-length c)) + ((string? c) (string-length c)) + (else -1))))) + +(define-method (write (self <resource>) port) + (catch #t + (lambda () + (display ; Make output atomic + (call-with-output-string + (lambda (port) + (format port "#<~a name=~s" + (class-name (class-of self)) + (name self)) + (cond ((displayname self) + propstat-200? + (lambda (name) (format port ", displayname=~s" name)))) + (format port ">"))) + port)) + (lambda _ + (format port "#<~a>" (class-name (class-of self)))))) + + +(define (add-resource! self new-name content) + (if (lookup-resource self (list new-name)) + (throw 'resource-exists) + (let ((resource (make (class-of self) name: new-name))) + (add-child! self resource collection?: #f) + (set-content! resource content) + resource))) + +(define (add-collection! self new-name) + (if (lookup-resource self (list new-name)) + (throw 'resource-exists) + (let ((resource (make (class-of self) name: new-name))) + (add-child! self resource collection?: #t) + resource))) + +(define (initialize-copied-resource! source copy) + (for-each (lambda (tag) (set-dead-property! copy tag)) + (dead-properties source)) + (set! (displayname* copy) (displayname* source) + (contentlanguage copy) (contentlanguage source)) + ;; (format (current-error-port) "Setting content! ~s (~s)~%" copy source) + (when (content source) + (set-content! copy (content source))) + ;; resource-cache should never be copied + ) + +(define-method (copy-resource (self <resource>) include-children?) + (copy-resource self include-children? #f)) + +(define-method (copy-resource (self <resource>) include-children? new-name) + (let ((resource (make (class-of self) name: (or new-name (name self))))) + (initialize-copied-resource! self resource) + (when include-children? + (for-each (lambda (c) (add-child! resource c)) + (map (lambda (c) (copy-resource c #t)) + (children self)))) + resource)) + +;; source and target-parent should be resource instances +;; new-name a string +;; include-children? and overwrite? booleans +(define* (copy-to-location! source target-parent + key: + (new-name (name source)) + include-children? + overwrite? + ) + (let ((copy (make (class-of source) name: new-name)) + ;; Take copy if child list. If we run `cp -r / /c` then; + ;; (at least when /c already exists) our child list gets + ;; updated, leading to an infinite loop if we use + ;; `(children source)` directly below. + (children-before (children source))) + (let ((status (add-child! target-parent copy + ;; (is-collection? copy) doesn't work for + ;; all types, since it's not quite yet + ;; added (for example: <file-resoure> + ;; checks if the target resource is a + ;; directory on the file system). + collection?: (is-collection? source) + overwrite?: overwrite?))) + (case status + ((created replaced) + (initialize-copied-resource! source copy) + (when include-children? + (for-each (lambda (c) (copy-to-location! + c copy + include-children?: #t)) + children-before)) + status) + ((collision) 'collision))))) + +(define* (move-to-location! source-parent source target-parent + key: + (new-name (name source)) + overwrite?) + (let ((status (copy-to-location! source target-parent + new-name: new-name + include-children?: #t + overwrite?: overwrite?))) + (case status + ((created replaced) + (delete-child! source-parent source) + status) + ((collision) 'collision)))) + + +;; Only tagname and namespaces are checked on the <xml-element> for the {get,set}-property + + +;;; All get-*-property methods return propstat elements + +(define (lookup-live-property resource xml-el) + (assoc-ref (live-properties resource) (xml-element-hash-key xml-el))) + +;;; TODO should {get,set}{,-{dead,live}}-property really be methods? +;;; - Live properties are defined by lookup-live-property, which isn't a +;;; method, which in turn calls live-properties, which MUST be a method. +;;; - Dead properties may have a reason. For example, file resources might +;;; want to store them directly in xattrs, ignoring its built in hash-table. +;;; - The combined should always just dispatch to either one + +(define-method (get-live-property (resource <resource>) xml-el) + (cond ((lookup-live-property resource xml-el) + => (lambda (pair) ((property-getter pair) resource))) + (else (propstat 404 (list (list xml-el)))))) + +(define-method (get-dead-property (resource <resource>) xml-el) + (cond ((hash-ref (dead-properties% resource) + (xml-element-hash-key xml-el)) + => (lambda (it) (propstat 200 (list it)))) + (else (propstat 404 (list (list xml-el)))))) + +;;; Return a list xml tags (including containing list) +(define-method (dead-properties (resource <resource>)) + (hash-map->list (lambda (_ v) v) + (dead-properties% resource))) + +;; Value should be a list with an <xml-element> in it's car +(define-method (set-dead-property (resource <resource>) value) + (unless (and (list? value) + (xml-element? (car value))) + (scm-error 'misc-error "set-dead-property" + "Invalid value, expected namespaced sxml" + '() #f)) + (lambda () + (hash-set! (dead-properties% resource) + (xml-element-hash-key (car value)) + value))) + +(define-method (set-live-property (resource <resource>) value) + (unless (and (list? value) + (xml-element? (car value))) + (scm-error 'misc-error "set-live-property" + "Invalid value, expected namespaced sxml" + '() #f)) + (cond ((lookup-live-property resource (car value)) + => (lambda (prop) (apply (property-setter-generator prop) + resource (cdr value)))) + (else #f))) + +(define (set-dead-property! resource value) + ((set-dead-property resource value))) + +(define (set-live-property! resource value) + ((set-live-property resource value))) + +(define (set-property resource value) + (or (set-live-property resource value) + (set-dead-property resource value))) + +(define (set-property! resource value) + ((set-property resource value))) + +;;; The remove-* procedures still take "correct" namespaced sxml (so an +;;; xml-element object inside a list). These extra lists are a bit of a waste, +;;; But allows remove-* to have the same signature as set-* + +(define-method (remove-dead-property (resource <resource>) xml-tag) + (unless (xml-element? xml-tag) + (scm-error 'misc-error "remove-dead-property" + "Bad property element" + '() #f)) + (lambda () + (hash-remove! (dead-properties% resource) + (xml-element-hash-key xml-tag)))) + +(define-method (remove-live-property (resource <resource>) xml-tag) + (unless (xml-element? xml-tag) + (scm-error 'misc-error "remove-live-property" + "Bad property element" + '() #f)) + + (cond ((lookup-live-property resource xml-tag) + => (lambda (prop) + (cond ((property-remover-generator prop) + => (lambda (f) (f resource))) + (else (throw 'irremovable-live-property))))) + (else #f))) + +(define (remove-dead-property! resource xml-tag) + ((remove-dead-property resource xml-tag))) + +(define (remove-live-property! resource xml-tag) + ((remove-live-property resource xml-tag))) + +(define-method (remove-property (resource <resource>) xml-tag) + (or (remove-live-property resource xml-tag) + (remove-dead-property resource xml-tag))) + +(define (remove-property! resource xml-tag) + ((remove-property resource xml-tag))) + + + +;; xml-tag should be just the tag element, without a surounding list +(define-method (get-property (resource <resource>) xml-tag) + (cond ((get-dead-property resource xml-tag) + propstat-200? => identity) + (else (get-live-property resource xml-tag)))) + +;; Return an alist from xml-element tags (but not full elements with surrounding list) +;; to generic procedures returning that value. +;; SHOULD be extended by children, which append their result to this result +;; @example +;; (define-method (live-properties (self <specific-resource>) +;; (append (next-method) +;; specific-resource-properties)) +;; @end example +(define-method (live-properties (self <resource>)) + (map (lambda (pair) (cons (xml-element-hash-key (xml webdav (car pair))) (cdr pair))) + webdav-properties)) + +(define-method (setup-new-resource! (this <resource>) (parent <resource>)) + 'noop) + +(define-method (setup-new-collection! (this <resource>) (parent <resource>)) + 'noop) + +(define (add-child* this child collection?) + (setup-new-resource! child this) + (when collection? + (setup-new-collection! child this)) + (set! (resource-children this) + (cons child (resource-children this)))) + +(define* (add-child! this child + key: + overwrite? + (collection? (is-collection? child))) + (let ((existing (lookup-resource this (list (name child))))) + (cond ((and overwrite? existing) + (delete-child! this existing) + (add-child* this child collection?) + 'replaced) + (existing 'collision) + (else + (add-child* this child collection?) + 'created)))) + + +;; Free any aditional system resources held by this object. +;; For example, file resources will remove the underlying file here. +(define-method (cleanup-resource (this <resource>)) + 'noop) + +(define-method (delete-child! (this <resource>) (child <resource>)) + (set! (resource-children this) + (delq1! child (children this))) + (for-each (lambda (grandchild) + (delete-child! child grandchild)) + (children child)) + (cleanup-resource child)) + + + +;;; TODO rename to simply @code{collection?} +(define-method (is-collection? (self <resource>)) + (not (null? (resource-children self)))) + + + + +(define-method (creationdate (self <resource>)) + (propstat 501 `((,(xml webdav 'creationdate))))) + +(define-method (set-creationdate! (self <resource>) _) + (throw 'protected-resource "creationdate")) + +(define-method (displayname (self <resource>)) + (cond ((displayname* self) + => (lambda (name) + (propstat 200 `((,(xml webdav 'displayname) + ,name))))) + (else + (propstat 404 `((,(xml webdav 'displayname))))))) + +(define-method (set-displayname! (self <resource>) value) + (lambda () (set! (displayname* self) value))) + +(define-method (getcontentlanguage (self <resource>)) + (cond ((contentlanguage self) + => (lambda (lang) (propstat 200 `((,(xml webdav 'getcontentlanguage) ,lang))))) + (else (propstat 404 `((,(xml webdav 'getcontentlanguage))))))) + +(define-method (set-getcontentlanguage! (self <resource>) value) + (lambda () (set! (contentlanguage self) value))) + +(define-method (getcontentlength (self <resource>)) + (propstat 501 `((,(xml webdav 'getcontentlength))))) + +(define-method (getcontentlength (self <resource>)) + (propstat 200 + (list + (list (xml webdav 'getcontentlength) + (content-length self))))) + +(define-method (set-getcontentlength! (self <resource>) _) + (throw 'protected-resource "getcontentlength")) + +(define-method (getcontenttype (self <resource>)) + (propstat 501 `((,(xml webdav 'getcontenttype))))) + +(define-method (set-getcontenttype! (self <resource>) _) + (throw 'protected-resource "getcontenttype")) + +(define-method (getetag (self <resource>)) + ;; TODO + (propstat 501 `((,(xml webdav 'getetag))))) + +(define-method (set-getetag! (self <resource>) _) + (throw 'protected-resource "getetag")) + +(define-method (getlastmodified (self <resource>)) + (propstat 200 `((,(xml webdav 'getlastmodified) + ,(with-locale1 + LC_TIME "C" + (lambda () + (datetime->string (unix-time->datetime 0) "~a, ~d ~b ~Y ~H:~M:~S GMT"))))))) + +(define-method (set-getlastmodified! (self <resource>) _) + (throw 'protected-resource "getlastmodified")) + +(define-method (lockdiscovery (self <resource>)) + (propstat 200 `((,(xml webdav 'lockdiscovery) + ())))) + +(define-method (set-lockdiscovery! (self <resource>) _) + (throw 'protected-resource "lockdiscovery")) + +(define-method (resourcetype (self <resource>)) + (propstat 200 `((,(xml webdav 'resourcetype) + ,@(when (is-collection? self) + `((,(xml webdav 'collection)))))))) + +(define-method (set-resourcetype! (self <resource>) _) + (throw 'protected-resource "resourcetype")) + +(define-method (supportedlock (self <resource>)) + (propstat 200 `((,(xml webdav 'supportedlock) ())))) + +(define-method (set-supportedlock! (self <resource>) _) + (throw 'protected-resource "supportedlock")) + +(define webdav-properties + `((creationdate . ,(make-live-property creationdate set-creationdate!)) + (displayname . ,(make-live-property displayname set-displayname!)) + (getcontentlanguage . ,(make-live-property getcontentlanguage set-getcontentlanguage!)) + (getcontentlength . ,(make-live-property getcontentlength set-getcontentlength!)) + (getcontenttype . ,(make-live-property getcontenttype set-getcontenttype!)) + (getetag . ,(make-live-property getetag set-getetag!)) + (getlastmodified . ,(make-live-property getlastmodified set-getlastmodified!)) + (lockdiscovery . ,(make-live-property lockdiscovery set-lockdiscovery!)) + (resourcetype . ,(make-live-property resourcetype set-resourcetype!)) + (supportedlock . ,(make-live-property supportedlock set-supportedlock!)))) + + + +;;; TODO remove! This is a remnant of the old mount system +;; (define-method (dereference (self <resource>)) +;; self) + +(define (find-resource resource path) + ;; Resource should be a <resource> (or something descended from it) + ;; path should be a list of strings + (cond ((null? path) resource) + ((string-null? (car path)) + ;; resource + (find-resource resource (cdr path))) + ((find (lambda (r) (string=? (car path) (name r))) + (children resource)) + => (lambda (r) (find-resource r (cdr path)))) + (else #f))) + +;; Lookup up a given resource first in the cache, +;; Then in the tree +;; and finaly fails and returns #f +(define (lookup-resource root-resource path) + (find-resource root-resource path) + #; + (or (hash-ref (resource-cache root-resource) path) + (and=> (find-resource root-resource path) + (lambda (resource) + (hash-set! (resource-cache root-resource) path resource) + resource)))) + +(define* (all-resources-under* resource optional: (prefix '())) + (define s (append prefix (list (name resource)))) + (cons (cons s resource) + (append-map (lambda (c) (all-resources-under* c s)) + (children resource)))) + +;; Returns a flat list of this resource, and all its decendants +(define* (all-resources-under resource optional: (prefix '())) + (cons (cons prefix resource) + (append-map (lambda (c) (all-resources-under* c prefix)) + (children resource)))) diff --git a/module/calp/webdav/resource/calendar.scm b/module/calp/webdav/resource/calendar.scm new file mode 100644 index 00000000..314d66aa --- /dev/null +++ b/module/calp/webdav/resource/calendar.scm @@ -0,0 +1,27 @@ +(define-module (calp webdav resource calendar) + ;; :use-module (hnh util) + ;; :use-module (datetime) + ;; :use-module (sxml namespaced util) + ;; :use-module (calp webdav property) + ;; :use-module (ice-9 hash-table) + :use-module (calp webdav resource calendar collection) + :use-module (calp webdav resource calendar object) + :export ( + calendar-resource? +) + ) + +(define cm (module-public-interface (current-module))) +(module-use! cm (resolve-interface '(calp webdav resource calendar collection))) +(module-use! cm (resolve-interface '(calp webdav resource calendar object))) + +(define (calendar-resource? x) + (or (calendar-collection-resource? x) + (calendar-object-resource? x))) + + + + + + + diff --git a/module/calp/webdav/resource/calendar/collection.scm b/module/calp/webdav/resource/calendar/collection.scm new file mode 100644 index 00000000..9acb6701 --- /dev/null +++ b/module/calp/webdav/resource/calendar/collection.scm @@ -0,0 +1,298 @@ +(define-module (calp webdav resource calendar collection) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (oop goops) + :use-module (calp webdav resource) + :use-module (calp webdav property) + :use-module (calp webdav propfind) + :use-module ((vcomponent formats ical) :prefix #{ics:}#) + :use-module ((vcomponent) :prefix vcs-) + :use-module ((vcomponent base) + :select (type prop make-vcomponent)) + + :use-module (web request) + :use-module (web uri) + + :use-module ((calp namespaces) :select (webdav caldav)) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) + :use-module (ice-9 hash-table) + + :use-module (hnh util) + + :use-module (calp webdav resource calendar object) + ;; propfind-most-live-properties propfind-all-dead-properties propname uri-path request-uri type + :export (<calendar-collection-resource> + caldav-properties + calendar-collection-resource?) + ) + +;;; Resoruces containing calendar components +(define-class <calendar-collection-resource> (<resource>) + (description init-value: #f + accessor: description) + (data-store getter: data-store + init-keyword: store:) + #; + (content% init-value: (make-vcomponent 'VIRTUAL) + accessor: content%)) + + +(define-method (is-collection? (_ <calendar-collection-resource>)) + #t) + + + +(define-method (children (this <calendar-collection-resource>)) + (map (lambda (ev) + (make <calendar-object-resource> + name: (prop ev 'UID) + component: ev)) + (vcs-children this))) + +(define (calendar-collection-resource? x) + (is-a? x <calendar-collection-resource>)) + + +(define-method (base-timezone <calendar-collection-resource>) + ;; (zoneinfo->vtimezone '() "Europe/Stockholm" 'ev) + (make-vcomponent 'VTIMEZONE) + ) + + + +(define-method (live-properties (self <calendar-collection-resource>)) + (append (next-method) + (map (lambda (pair) (cons (xml caldav (car pair)) (cdr pair))) + caldav-properties))) + + + + +(define-method (displayname (self <calendar-collection-resource>)) + (propstat 200 + `((,(xml webdav 'displayname) + ,(prop (content self) 'displayname))))) + + +(define-method (resourcetype (self <calendar-collection-resource>)) + (propstat 200 + `((,(xml webdav 'resourcetype) + (,(xml caldav 'calendar)))))) + +;;; CALDAV Properties + +(define-method (calendar-description (self <calendar-collection-resource>)) + (cond ((description self) + => (lambda (it) + (propstat 200 + (list (list (xml caldav 'calendar-description (alist->hashq-table '((xml:lang . "en")))) + it))))) + (else + (propstat 404 (list (list (xml caldav 'calendar-description))))))) + +(define-method (calendar-timezone (self <calendar-collection-resource>)) + (propstat 200 + (list + (list (xml caldav 'calendar-description) + (call-with-output-string + (lambda (port) + (ics:serialize (base-timezone self) port))))))) + +(define-method (supported-calendar-component-set (self <calendar-collection-resource>)) + (propstat 200 + `((,(xml caldav 'supported-calendar-component-set) + (,(xml caldav 'comp + (alist->hashq-table '((name . "VEVENT"))))))))) + +(define-method (supported-calendar-data (self <calendar-collection-resource>)) + (propstat 200 + (list + (list + (xml caldav 'supported-calendar-data) + (map (lambda (content-type) + (list (xml caldav 'calendar-data + (alist->hashq-table + '((content-type . ,content-type) + (version . "2.0")))))) + '("text/calendar" + "application/calendar+xml")))))) + + + +;; (define-method (max-resource-size (self <calendar-collection-resource>)) +;; ) + +;; (define-method (min-date-time )) +;; (define-method (max-date-time )) +;; (define-method (max-instances )) +;; (define-method (max-attendees-per-instance )) + +(define-method (supported-collation-set (self <calendar-collection-resource>)) + (propstat 200 + (list `(,(xml caldav 'supported-collation-set) + ,@(map (lambda (cs) `(,(xml caldav 'supported-collation) ,cs)) + `(;; Required by CalDAV + "i;ascii-casemap" + "i;octet" + ;; Added (RFC 5051)) + "i;unicode-casemap")))))) + + + +(define caldav-properties + `((calendar-description . ,calendar-description) + (calendar-timezone . ,calendar-timezone) + (supported-calendar-component-set . ,supported-calendar-component-set) + (supported-calendar-data . ,supported-calendar-data) + (supported-collation-set . ,supported-collation-set) + ;; (max-resource-size . ,max-resource-size) + ;; (min-date-time . ,min-date-time) + ;; (max-date-time . ,max-date-time) + ;; (max-instances . ,max-instances) + ;; (max-attendees-per-instance . ,max-attendees-per-instance) + )) + +;;; Reports + +(define-method (supported-reports* (this <calendar-collection-resource>)) + (append (next-method) + (list + ;; Required for ACL, but not for CalDAV + ;; (xml webdav 'version-tree) + ;; Optional for ACL, but REQUIRED for CalDAV + (cons (xml webdav 'expand-property) expand-property) + ;; REQUIRED by CalDAV + (cons (xml caldav 'calendar-query) calendar-query) + (cons (xml caldav 'calendar-multiget) calendar-multiget) + (cons (xml caldav 'free-busy-report) free-busy-report) + ))) + + +(define-method (calendar-query (this <calendar-collection-resource>) headers body) + ;; Request body MUST be a caldav:calendar-query + ;; Request MAY include a depth header, default = 0 + ;; Respnose-body MUST be a dav:multistatus + ;; Responseb body MUST contain DAV:respons element for each iCalendar object that matched the search filter + + (let ((allprop (find-element (xml webdav 'allprop) (cdr body))) + (propname (find-element (xml webdav 'propname) (cdr body))) + (prop (find-element (xml webdav 'prop) (cdr body))) + (filter (find-element (xml caldav 'filter) (cdr body))) + (timezone (find-element (xml caldav 'timezone) (cdr body)))) + (when (< 1 (count identity (list allprop propname prop))) + (throw 'bad-request 400 "allprop, propname, and prop are mutually exclusive")) + + (unless filter + (throw 'bad-request 400 "filter required")) + + + #; + (when timezone + (case (assoc-ref (attributes timezone) 'content-type) + ((application/calendar+xml) + (xcs:serialize default-timezone)) + ;; ((application/calendar+json)) + (else ; includes text/calendar + (ics:serialieze default-timezone) + ))) + + (let ((resources (select-components-by-comp-filter this comp-filter))) + `(,(xml webdav 'multistatus) + ,@(for (href . resource) in resources + `(,(xml webdav 'response) + (,(xml webdav 'href) ,(href->string href)) + ,@(map propstat->namespaced-sxml + (merge-propstats + (cond (allprop + (append (propfind-most-live-properties resource) + (propfind-all-dead-properties resource))) + (propname + (list (propstat + 200 + (map (compose list car) + (append (dead-properties resource) + (live-properties resource)))))) + (prop + (map (lambda (prop) (get-property resource prop)) + prop))))))))))) + + + + +(define-method (expand-property (this <calendar-collection-resource>) request body)) + +(define-method (free-busy-report (this <calendar-collection-resource>) request body)) + +(define-method (calendar-multiget (this <calendar-collection-resource>) request body) + (define base-href (-> request request-uri uri-path href->string)) + (let ((allprop (find-element (xml webdav 'allprop) (cdr body))) + (propname (find-element (xml webdav 'propname) (cdr body))) + (prop (find-element (xml webdav 'prop) (cdr body))) + (hrefs (find-elements (xml webdav 'href) (cdr body)))) + (when (< 1 (count identity (list allprop propname prop))) + (throw 'bad-request 400 "allprop, propname, and prop are mutually exclusive")) + (when (null? hrefs) + (throw 'bad-request 400 "At least one href is required")) + + ;; (assert (memv href hrefs)) + + (let ((resources + (for href in hrefs + (cons href + (lookup-resource + this + (href-relative base-href href)))))) + `(,(xml webdav 'multistatus) + (for (href . resource) in resources + `(,(xml webdav 'response) + (,(xml webdav 'href) ,(href->string href)) + ,@(cond (resource + (cond (allprop + (append (propfind-most-live-properties resource) + (propfind-all-dead-properties resource))) + (propname + (list (propstat + 200 + ;; car to get tagname, list to construct a valid xml element + (map (compose list car) + (append + (dead-properties resource) + (live-properties resource)))))) + (prop + (propfind-selected-properties + resource + (map car (cdr prop)))))) + (else + `(,(xml webdav 'status) + ,(http-status-line 404)))))))))) + + + + +(define-method (select-components-by-comp-filter (this <calendar-collection-resource>) comp-filter) + ) + + +;;; TODO +(define (overlaps? a b) + #t) + +(define (comp-filter scope filter) + ;; CaldDAV 9.7.1 + (or (and (null? (children filter)) + (eq? (attribute filter 'name) + (type scope))) + (and (find-element (xml caldav 'is-not-defined) + (children filter)) + (not + (find (lambda (el) (eq? (type el) (attribute filter 'name))) + (children scope)))) + (and (cond ((find-element (xml caldav 'time-range) + (children filter)) + => (lambda (range) + (overlaps? scope range))) + (else #f)) + (every (lambda (filt) (comp-filter scope filt)) (children filter))) + (every (lambda (filt) (comp-filter scope filt)) (children filter)))) diff --git a/module/calp/webdav/resource/calendar/object.scm b/module/calp/webdav/resource/calendar/object.scm new file mode 100644 index 00000000..82a8c18e --- /dev/null +++ b/module/calp/webdav/resource/calendar/object.scm @@ -0,0 +1,76 @@ +(define-module (calp webdav resource calendar object) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (oop goops) + :use-module (calp webdav resource) + :use-module ((vcomponent formats ical) :prefix #{ics:}#) + :use-module ((vcomponent formats xcal) :prefix #{xcs:}#) + :use-module ((vcomponent) :prefix vcs-) + :use-module ((calp namespaces) :select (webdav)) + :use-module (calp webdav property) + :use-module (sxml namespaced) + + :export (<calendar-object-resource> + calendar-object-resource? + component) + ) + +;;; content% + +(define-class <calendar-object-resource> (<resource>) + (component getter: component + init-keyword: component:)) + + + +(define-method (is-collection? (_ <calendar-object-resource>)) + #f) + + + +(define-method (children (_ <calendar-object-resource>)) + '()) + +(define (calendar-object-resource? x) + (is-a? x <calendar-object-resource>)) + +(define-method (content (self <calendar-object-resource>) content-type) + (case content-type + ((text/calendar) + (call-with-output-string (lambda (port) (ics:serialize (content% self) port)))) + ((application/calendar+xml) + (call-with-output-string (lambda (port) (xcs:serialize (content% self) port)))) + ;; ((text/html)) + ;; ((application/xhtml+xml)) + ;; ((application/calendar+json)) + (else (content self 'text/calendar)) + ) + ) + +(define-method (creationdate (self <calendar-object-resource>)) + (propstat 200 + `((,(xml webdav 'creationdate) + (-> (content self) + (prop 'CREATED) + ;; TODO timezone + (datetime->string "~Y-~m-~dT~H:~M:~SZ")))))) + + +(define-method (getcontentlength (self <calendar-object-resource>)) + ;; TODO which representation should be choosen to calculate length? + (propstat 501 `((,(xml webdav 'getcontentlength))))) + + + +(define-method (getcontenttyype (self <calendar-object-resource>)) + ;; TODO different representations + (propstat 200 `((,(xml webdav 'getcontentlength) + "text/calendar")))) + + +(define-method (getlastmodified (self <calendar-object-resource>)) + (propstat 200 + `((,(xml webdav 'getlastmodified) + (string->datetime (prop (content self) 'LAST-MODIFIED) + "~Y~m~dT~H~M~S"))))) diff --git a/module/calp/webdav/resource/file.scm b/module/calp/webdav/resource/file.scm new file mode 100644 index 00000000..e2fec9a5 --- /dev/null +++ b/module/calp/webdav/resource/file.scm @@ -0,0 +1,192 @@ +(define-module (calp webdav resource file) + :use-module (srfi srfi-1) + :use-module (oop goops) + :use-module (hnh util) + :use-module (hnh util env) + :use-module (hnh util path) + :use-module (datetime) + :use-module (ice-9 popen) + :use-module (ice-9 rdelim) + :use-module (ice-9 ftw) + :use-module (sxml namespaced) + :use-module (calp webdav resource) + :use-module (calp webdav property) + :use-module (calp namespaces) + :use-module (rnrs io ports) + :use-module (rnrs bytevectors) + :export (<file-resource> file-resource? root ; path + )) + +;;; Resources backed by the filesystem +(define-class <file-resource> (<resource>) + ;; Directory to act as root for this file tree. + ;; Should be inherited by all children + + ;; DO NOT export the setters. These fields needs to be carefully managed to + ;; ensure that they stay consistant with the @var{name} trail. + (root getter: root setter: set-root! init-value: "/" init-keyword: root:) + (path getter: path setter: set-path! init-value: "/" init-keyword: path:)) + +(define-method (write (self <file-resource>) port) + (display + (format #f "#<<file-resource> name=~s, root=~s, path=~s>" + (name self) + (root self) + (path self)) + port)) + +(define (file-resource? x) + (is-a? x <file-resource>)) + +;; TODO this is global, so most certanly leaks info between different +;; <file-resource> trees. +(define *realized-resource* (make-hash-table)) + +(define (file-resource-for-path root path) + (or (hash-ref *realized-resource* path) + (let ((resource (make <file-resource> + ;; href: + root: root + ; local-path: path + name: (basename path) + path: path + ))) + (hash-set! *realized-resource* path resource) + resource))) + +(define (filepath self) + (path-append (root self) + (path self))) + +(define-method (children (self <file-resource>)) + ;; (format (current-error-port) "root=~s, path=~s~%" + ;; (root self) + ;; (local-path self)) + (when (is-collection? self) + (map (lambda (p) (file-resource-for-path (root self) + (path-append (path self) + p))) + (remove (lambda (p) (member p '("." ".."))) + (scandir (filepath self)))))) + +(define-method (is-collection? (self <file-resource>)) + (eq? 'directory (stat:type (stat (filepath self))))) + +(define (file-creation-date path) + (let ((pipe (open-pipe* OPEN_READ "stat" "-c" "%W" path))) + (begin1 (unix-time->datetime (read pipe)) + (close-pipe pipe)))) + +(define (mimetype path) + (let ((pipe (open-pipe* OPEN_READ "file" "--brief" "--mime-type" + path))) + (begin1 (read-line pipe) + (close-pipe pipe)))) + +(define-method (creationdate (self <file-resource>)) + (propstat 200 + `((,(xml webdav 'creationdate) + ,(with-locale1 + LC_TIME "C" + (lambda () + (-> (file-creation-date (filepath self)) + (datetime->string "~Y-~m-~dT~H:~M:~S~Z")))))))) + +(define-method (content (self <file-resource>)) + (if (is-collection? self) + #f + (call-with-input-file (filepath self) + get-bytevector-all binary: #t))) + +(define-method (set-content! (self <file-resource>) data) + (cond ((bytevector? data) + (call-with-output-file (filepath self) + (lambda (port) (put-bytevector port data)))) + ((string? data) + (call-with-output-file (filepath self) + (lambda (port) (put-string port data)))) + (else (scm-error 'misc-error "set-content!<file-resource>" + "Content must be bytevector or string: ~s" + (list data) #f)))) + + +(define-method (setup-new-resource! (self <file-resource>) + (parent <file-resource>)) + (next-method) + (set-root! self (root parent)) + (set-path! self (path-append (path parent) (name self)))) + +(define-method (setup-new-collection! (self <file-resource>) + (parent <file-resource>)) + (next-method) + (mkdir (filepath self))) + +(define-method (cleanup-resource (self <file-resource>)) + ((if (is-collection? self) + rmdir + delete-file) + (filepath self))) + +(define-method (content-length (self <file-resource>)) + (-> (filepath self) stat stat:size)) + + +(define-method (getcontenttype (self <file-resource>)) + ;; TODO 404 if collection + ;; Or just omit it? + (propstat 200 `((,(xml webdav 'getcontenttype) + ,(mimetype (filepath self)))))) + +(define-method (getlastmodified (self <file-resource>)) + (propstat 200 + `((,(xml webdav 'getlastmodified) + ,(with-locale1 + LC_TIME "C" + (lambda () + (-> (filepath self) + stat + stat:mtime + unix-time->datetime + (datetime->string "~a, ~d ~b ~Y ~H:~M:~S GMT")))))))) + +;; (define (xattr-key xml-el) +;; (format #f "caldav.~a" +;; (base64-encode +;; (format #f "~a:~a" +;; (xml-element-namespace xml-el) +;; (xml-element-tagname xml-el))))) + + +;; (define-method (set-dead-property (self <file-resource>) value) +;; (unless (and (list? value) +;; (xml-element? (car value))) +;; (scm-error 'misc-error "set-dead-property" +;; "Invalid value, expected namespaced sxml" +;; '() #f)) +;; (catch #t +;; (lambda () +;; (lambda () +;; (xattr-set! +;; (filename self) +;; (xattr-key (car value)) +;; (with-output-to-string +;; (lambda () (namespaced-sxml->xml value)))))) +;; (lambda _ (next-method)))) + + +;; (define-method (get-dead-property (self <file-resource>) +;; xml-el) +;; (catch #t +;; (lambda () +;; (propstat 200 +;; (list +;; (xattr-ref (filepath self) +;; (xattr-key el))))) +;; (lambda _ (next-method)))) + + +;; (define-method (remove-dead-property (self <file-resource>) +;; xml-el) +;; (catch #t +;; (lambda () (xattr-remove! (filepath self) xml-el)) +;; (lambda _ (next-method)))) diff --git a/module/calp/webdav/resource/virtual.scm b/module/calp/webdav/resource/virtual.scm new file mode 100644 index 00000000..1d2d5d31 --- /dev/null +++ b/module/calp/webdav/resource/virtual.scm @@ -0,0 +1,71 @@ +(define-module (calp webdav resource virtual) + :use-module (oop goops) + :use-module (datetime) + :use-module (rnrs bytevectors) + :use-module (hnh util) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) + :use-module (calp webdav resource) + :use-module (calp webdav property) + :use-module (calp namespaces) + :export (<virtual-resource> + virtual-resource? + virtual-ns + ;; content + isvirtual + ) + ) + +(define virtual-ns (string->symbol "http://example.com/virtual")) + +(define-class <virtual-resource> (<resource>) + (content* init-value: #vu8() + init-keyword: content: + accessor: content*) + (creation-time init-form: (current-datetime) + init-keyword: creation-time: + getter: creation-time)) + +(define (virtual-resource? x) + (is-a? x <virtual-resource>)) + +(define-method (write (self <virtual-resource>) port) + (format port "#<<virtual-resource> name=~s, creation-time=~s, content=~s>" + (name self) + (creation-time self) + (content self))) + +(define-method (live-properties (self <virtual-resource>)) + (append + (next-method) + (list (cons (xml-element-hash-key (xml virtual-ns 'isvirtual)) (make-live-property isvirtual set-isvirtual!))))) + +(define-method (content (self <virtual-resource>)) + (content* self)) + +(define-method (set-content! (self <virtual-resource>) data) + (set! (content* self) data)) + +(define-method (creationdate (self <virtual-resource>)) + (propstat 200 + (list + (list (xml webdav 'creationdate) + (-> (creation-time self) + (datetime->string "~Y-~m-~dT~H:~M:~SZ")))))) + + +(define-method (getcontenttype (self <resource>)) + (propstat 200 + (list + (list (xml webdav 'getcontenttype) + "application/binary")))) + +(define-method (isvirtual (self <virtual-resource>)) + (propstat 200 + (list + (list (xml virtual-ns 'isvirtual) + "true")))) + + +(define-method (set-isvirtual! (self <virtual-resource>) _) + (throw 'protected-resource "isvirtual")) diff --git a/module/datetime/instance.scm b/module/datetime/instance.scm index d9a304b2..d6c84348 100644 --- a/module/datetime/instance.scm +++ b/module/datetime/instance.scm @@ -9,7 +9,7 @@ :export (zoneinfo)) (define-config tz-list '() - description: (_ "List of default zoneinfo files to be parsed")) + description: (G_ "List of default zoneinfo files to be parsed")) ;; TODO see (vcomponent uil instance), this has a similar problem with early load ;; Takes a list of zoneinfo files relative @@ -25,7 +25,7 @@ (() (define tz-list (tz-list)) (if (null? tz-list) - (warning (_ "Default zoneinfo only available when tz-dir and tz-list are configured")) + (warning (G_ "Default zoneinfo only available when tz-dir and tz-list are configured")) (self tz-list))) ((file-list) (provide 'zoneinfo) diff --git a/module/datetime/timespec.scm b/module/datetime/timespec.scm index 46f93a61..53eba014 100644 --- a/module/datetime/timespec.scm +++ b/module/datetime/timespec.scm @@ -42,7 +42,7 @@ (define (timespec-add . specs) (unless (apply eqv? (map timespec-type specs)) - (warning (_ "Adding timespecs of differing types"))) + (warning (G_ "Adding timespecs of differing types"))) (reduce (lambda (spec done) (cond diff --git a/module/datetime/zic.scm b/module/datetime/zic.scm index 1c9b34ee..acfb17a8 100644 --- a/module/datetime/zic.scm +++ b/module/datetime/zic.scm @@ -186,7 +186,7 @@ day: (string->number day)) time: (timespec-time timespec) tz: (case (timespec-type timespec) - [(#\s) (warning (_ "what even is \"Standard time\"‽")) ""] + [(#\s) (warning (G_ "what even is \"Standard time\"‽")) ""] [(#\w) #f] ;; Since we might represent times before UTC existed ;; this is a bit of a lie. But it should work. @@ -274,8 +274,8 @@ ;; They were removed since they were unused, uneeded, and was ;; technical dept. (scm-error 'misc-error "parse-zic-file" - (_ "Invalid key ~s. Note that leap seconds and expries rules aren't yet implemented.") - (list type) + (G_ "Invalid key ~s. Note that leap seconds and expries rules aren't yet implemented.") + (list (car tokens)) #f)))])))))) @@ -298,16 +298,16 @@ (for-each (lambda (group) (hashq-set! rules (car group) - (sort* (cadr group) + (sort* (cdr group) (lambda (a b) (if (eq? 'minimum) #t (< a b))) rule-from))) - (group-by rule-name (car it)))) + (group-by rule-name it))) ;; put zones in map (awhen (assoc-ref groups 'zone) (for-each (lambda (zone) (hash-set! zones (zone-name zone) (zone-entries zone))) - (car it))) + it)) ;; resolve links to extra entries in the zone map (awhen (assoc-ref groups 'link) @@ -316,9 +316,9 @@ (target (link-target link)) (target-item (hash-ref zones target #f))) (if (not target-item) - (warning (_ "Unresolved link, target missing ~a -> ~a") name target) + (warning (G_ "Unresolved link, target missing ~a -> ~a") name target) (hash-set! zones name target-item)))) - (car it))) + it)) (make-zoneinfo rules zones))) @@ -355,7 +355,7 @@ (day d base-day)))) tz: (case (timespec-type (rule-at rule)) ((#\w) #f) - ((#\s) (warning (_ "what even is \"Standard time\"‽")) #f) + ((#\s) (warning (G_ "what even is \"Standard time\"‽")) #f) ((#\u #\g #\z) "UTC")))) (let ((timespec (rule-at rule))) @@ -377,7 +377,7 @@ (case to ((maximum) #f) ((minimum) (scm-error 'misc-error "rule->rrule" - (_ "Check your input") + (G_ "Check your input") #f #f)) (else ;; NOTE I possibly need to check the start of @@ -390,7 +390,7 @@ (match (rule-on rule) ((? number? d) (set (bymonthday base) (list d))) (('last d) (set (byday base) (list (cons -1 d)))) - (('< wday base-day) (scm-error 'misc-error "rule->rrule" (_ "Counting backward for RRULES unsupported") #f #f)) + (('< wday base-day) (scm-error 'misc-error "rule->rrule" (G_ "Counting backward for RRULES unsupported") #f #f)) (('> wday base-day) ;; Sun<=25 ;; Sun>=8 @@ -412,14 +412,14 @@ [(#\z) ;; NOTE No zones seem to currently use %z formatting. ;; '%z' is NOT a format string, but information about another format string. - (warning (_ "%z not yet implemented")) + (warning (G_ "%z not yet implemented")) fmt-string] [else (scm-error 'misc-error "zone-format" ;; first slot is the errornous character, ;; second is the whole string, third is the index ;; of the faulty character. - (_ "Invalid format char ~s in ~s at position ~a") + (G_ "Invalid format char ~s in ~s at position ~a") (list (string-ref fmt-string (1+ idx)) fmt-string (1+ idx)) diff --git a/scripts/use2dot/graphviz.scm b/module/graphviz.scm index 9355d723..c2e3fa04 100644 --- a/scripts/use2dot/graphviz.scm +++ b/module/graphviz.scm @@ -79,6 +79,10 @@ renderdata write)) -;; (load-extension "libgv_guile.so" "SWIG_init") +(define lib "graphviz/guile/libgv_guile") -(load-extension "/usr/lib/graphviz/guile/libgv_guile.so" "SWIG_init") +(load-extension + (format #f "~a/~a.so" + "/usr/lib" ; LIBRARY PATH + lib) + "SWIG_init") diff --git a/module/hnh/module-introspection.scm b/module/hnh/module-introspection.scm new file mode 100644 index 00000000..83e561f1 --- /dev/null +++ b/module/hnh/module-introspection.scm @@ -0,0 +1,22 @@ +(define-module (hnh module-introspection) + :use-module (srfi srfi-1) + :use-module (hnh util) + :export (unique-symbols + find-module-declaration + module-declaration? + )) + + +(define (unique-symbols tree) + (uniq + (sort* (filter symbol? (flatten tree)) + string<? symbol->string))) + +(define (module-declaration? form) + (cond ((null? form) #f) + ((not (pair? form)) #f) + (else (eq? 'define-module (car form))))) + +(define (find-module-declaration forms) + (and=> (find module-declaration? forms) + cadr)) diff --git a/scripts/all-modules.scm b/module/hnh/module-introspection/all-modules.scm index b83644e5..1bf39e1e 100644 --- a/scripts/all-modules.scm +++ b/module/hnh/module-introspection/all-modules.scm @@ -1,13 +1,16 @@ -(define-module (all-modules) +(define-module (hnh module-introspection all-modules) :use-module (ice-9 regex) :use-module (srfi srfi-1) :use-module (ice-9 ftw) :use-module (ice-9 match) :use-module (hnh util path) - :use-module (module-introspection) + :use-module (hnh module-introspection) + :use-module ((hnh module-introspection static-util) :select (get-forms)) :export (all-files-and-modules-under-directory all-modules-under-directory - fs-find-base fs-find)) + fs-find-base fs-find + module-file-mapping + )) (define (fs-find dir) (define files '()) @@ -42,3 +45,11 @@ level modules in those files" (values (map car pairs) (filter identity (map cadr pairs)))) + +;; Returns an association list from module names the modules +;; containing filename +(define (module-file-mapping dir) + (filter + car + (map (lambda (pair) (cons (cadr pair) (car pair))) + (all-files-and-modules-under-directory dir)))) diff --git a/module/hnh/module-introspection/module-uses.scm b/module/hnh/module-introspection/module-uses.scm new file mode 100644 index 00000000..3bed2a5e --- /dev/null +++ b/module/hnh/module-introspection/module-uses.scm @@ -0,0 +1,116 @@ +(define-module (hnh module-introspection module-uses) + :use-module (ice-9 match) + :use-module (hnh util) + :use-module ((srfi srfi-1) :select (concatenate)) + :use-module ((srfi srfi-88) :select (string->keyword)) + :use-module (rnrs records syntactic) + :export (module-uses*)) + +;;; Commentary: +;;; Static analyze version of guile's built in module-uses. +;;; Will give a less accurate result, but in turn doesn't +;;; require that the target module compiles. +;;; Code: + +(define-record-type (module make-module% module?) + (fields name select hide prefix renamer version)) + +(define* (make-module name key: + (select #f) + (hide '()) + (prefix #f) + (renamer #f) + (version #f)) + (make-module% name select hide prefix renamer version)) + +(define (module->list module) + (append + (list (module-name module)) + (awhen (module-select module) `(#:select ,it)) + (awhen (module-hide module) `(#:hide ,it)) + (awhen (module-prefix module) `(#:prefix ,it)) + (awhen (module-renamer module) `(#:renamer ,it)) + (awhen (module-version module) `(#:version ,it)))) + +;; Normalizes keywords (#:key) and pseudo keywords (:key) used by define-module syntax. +(define (normalize-keyword kw-or-symb) + (cond ((symbol? kw-or-symb) + (-> (symbol->string kw-or-symb) + (string-drop 1) + string->keyword)) + ((keyword? kw-or-symb) + kw-or-symb) + (else (error "Bad keyword like" kw-or-symb)))) + +;; Takes one argument as taken by @code{use-modules}, or following #:use-module +;; in @code{define-module}. +;; returns a list on the form +;; (module-name (key value) ...) +;; where module name is something like (srfi srfi-1) +(define (parse-interface-specification interface-specification) + (match interface-specification + ;; matches `((srfi srfi-1) :select (something)) + (((parts ...) args ...) + (apply make-module + `(,parts ,@(concatenate + (map (lambda (pair) + (cons (normalize-keyword (car pair)) + (cdr pair))) + (group args 2)))))) + ;; matches `(srfi srfi-1) + ((parts ...) + (make-module parts)) + (_ (error "Bad module declaration")))) + +;; Finds all define-module forms, and returns what they +;; pull in (including autoloads) +(define (module-declaration-uses forms) + (match forms + (('define-module module-name directives ...) + (let loop ((directives directives)) + (cond ((null? directives) '()) + ((memv (car directives) '(#:use-module #{:use-module}#)) + (cons (parse-interface-specification (cadr directives)) + (loop (cddr directives)))) + ((memv (car directives) '(#:autoload #{:autoload}#)) + (cons (cadr directives) + (loop (cdddr directives)))) + (else (loop (cdr directives)))))) + ((form forms ...) + (append (module-declaration-uses form) + (module-declaration-uses forms))) + (_ '()))) + +;; find all use-modules forms, and return what they pull in +;; NOTE this will pull in all forms looking like a (use-modules ...) +;; form, even if they are quoted, or in a cond-expand +(define (module-use-module-uses forms) + (match forms + (('use-modules modules ...) + (map parse-interface-specification modules)) + ((form forms ...) + (append (module-use-module-uses form) + (module-use-module-uses forms))) + (_ '()))) + +;; find all explicit module references (e.g. +;; (@ (module) var) and (@@ (module) private-var)), +;; and return those modules +(define (module-refer-uses forms) + (match forms + (((or '@ '@@) module symb) + (list (make-module module select: (list symb)))) + ((form forms ...) + (append (module-refer-uses form) + (module-refer-uses forms))) + (_ '()))) + +;; List of all modules pulled in in any of forms +;; Returns a list where each element suitable to have +;; resolve-interface applied to it. +(define (module-uses* forms) + (map module->list + (append + (module-declaration-uses forms) + (module-use-module-uses forms) + (module-refer-uses forms)))) diff --git a/module/hnh/module-introspection/static-util.scm b/module/hnh/module-introspection/static-util.scm new file mode 100644 index 00000000..7593ce3c --- /dev/null +++ b/module/hnh/module-introspection/static-util.scm @@ -0,0 +1,9 @@ +(define-module (hnh module-introspection static-util) + :export (get-forms)) + +(define (get-forms port) + (let loop ((done '())) + (let ((form (read port))) + (if (eof-object? form) + done + (loop (cons form done)))))) diff --git a/module/hnh/test/testrunner.scm b/module/hnh/test/testrunner.scm new file mode 100644 index 00000000..384afd4b --- /dev/null +++ b/module/hnh/test/testrunner.scm @@ -0,0 +1,126 @@ +(define-module (hnh test testrunner) + :use-module (srfi srfi-64) + :use-module (hnh test util) + :use-module (ice-9 pretty-print) + :use-module (ice-9 format) + :export (verbose? construct-test-runner) + ) + +(define verbose? (make-parameter #f)) + +(define (pp form indent prefix-1) + (let ((prefix (make-string (+ (string-length indent) + (string-length prefix-1)) + #\space))) + (string-replace-head + (with-output-to-string + (lambda () (pretty-print + form + display?: #t + per-line-prefix: prefix + width: (- 79 (string-length indent))))) + (string-append indent prefix-1)))) + + +(define (construct-test-runner) + (define runner (test-runner-null)) + (define depth 0) + ;; end of individual test case + (test-runner-on-test-begin! runner + (lambda (runner) + (test-runner-aux-value! runner (transform-time-of-day (gettimeofday))))) + (test-runner-on-test-end! runner + (lambda (runner) + (when (verbose?) (display (make-indent depth))) + (case (test-result-kind runner) + ((pass) (display (green "X"))) + ((fail) (display (red "E"))) + ((xpass) (display (yellow "X"))) + ((xfail) (display (yellow "E"))) + ((skip) (display (yellow "-")))) + (when (or (verbose?) (eq? 'fail (test-result-kind))) + (format #t " ~a~%" + (cond ((test-runner-test-name runner) + (negate string-null?) => identity) + ((test-result-ref runner 'expected-value) + => (lambda (p) (with-output-to-string + (lambda () + (display (bold "[SOURCE]: ")) + (truncated-print p width: 60)))))))) + (when (eq? 'fail (test-result-kind)) + (cond ((test-result-ref runner 'actual-error) + => (lambda (err) + (if (and (list? err) + (= 5 (length err))) + (let ((err (list-ref err 0)) + (proc (list-ref err 1)) + (fmt (list-ref err 2)) + (args (list-ref err 3))) + (format #t "~a~a in ~a: ~?~%" + (make-indent (1+ depth)) + err proc fmt args)) + (format #t "~aError: ~s~%" (make-indent (1+ depth)) err)))) + (else + (let ((unknown-expected (gensym)) + (unknown-actual (gensym))) + (let ((expected (test-result-ref runner 'expected-value unknown-expected)) + (actual (test-result-ref runner 'actual-value unknown-actual))) + (let ((indent (make-indent (1+ depth)))) + (if (eq? expected unknown-expected) + (format #t "~aAssertion failed~%" indent) + (begin + (display (pp expected indent "Expected: ")) + (display (pp actual indent "Received: ")) + (let ((d (diff (pp expected "" "") + (pp actual "" "")))) + (display + (string-join + (map (lambda (line) (string-append indent "|" line)) + (string-split d #\newline)) + "\n" 'suffix)))))))))) + (format #t "~aNear ~a:~a~%" + (make-indent (1+ depth)) + (test-result-ref runner 'source-file) + (test-result-ref runner 'source-line)) + (pretty-print (test-result-ref runner 'source-form) + (current-output-port) + per-line-prefix: (string-append (make-indent (1+ depth)) "> ") + )) + + (let ((start (test-runner-aux-value runner)) + (end (transform-time-of-day (gettimeofday)))) + (when (< (µs 1) (- end start)) + (format #t "~%Slow test: ~s, took ~a~%" + (test-runner-test-name runner) + (exact->inexact (/ (- end start) (µs 1))) + ))))) + + ;; on start of group + (test-runner-on-group-begin! runner + ;; count is number of #f + (lambda (runner name count) + (if (<= depth 1) + (format #t "~a ~a ~a~%" + (make-string 10 #\=) + name + (make-string 10 #\=)) + (when (verbose?) + (format #t "~a~a~%" (make-string (* depth 2) #\space) name))) + (set! depth (1+ depth)))) + (test-runner-on-group-end! runner + (lambda (runner) + (set! depth (1- depth)) + (when (<= depth 1) + (newline)))) + ;; after everything else is done + (test-runner-on-final! runner + (lambda (runner) + (format #t "Guile version ~a~%~%" (version)) + (format #t "pass: ~a~%" (test-runner-pass-count runner)) + (format #t "fail: ~a~%" (test-runner-fail-count runner)) + (format #t "xpass: ~a~%" (test-runner-xpass-count runner)) + (format #t "xfail: ~a~%" (test-runner-xfail-count runner)) + )) + + runner) + diff --git a/module/hnh/test/util.scm b/module/hnh/test/util.scm new file mode 100644 index 00000000..3d51e162 --- /dev/null +++ b/module/hnh/test/util.scm @@ -0,0 +1,57 @@ +(define-module (hnh test util) + :use-module ((hnh util) :select (begin1)) + :use-module ((hnh util io) :select (call-with-tmpfile)) + :use-module (ice-9 pretty-print) + :use-module ((ice-9 rdelim) :select (read-string)) + :use-module ((ice-9 popen) + :select (open-pipe* + close-pipe)) + :export (µs + transform-time-of-day + green + red + yellow + bold + make-indent + string-replace-head + diff + )) + +(define (µs x) + (* x #e1e6)) + +(define (transform-time-of-day tod) + (+ (* (µs 1) (car tod)) + (cdr tod))) + +(define (escaped sequence string) + (format #f "\x1b[~am~a\x1b[m" sequence string)) + +;; Terminal output formatting. Doesn NOT compose +(define (green s) (escaped 32 s)) +(define (red s) (escaped 31 s)) +(define (yellow s) (escaped 33 s)) +(define (bold s) (escaped 1 s)) + +(define (make-indent depth) + (make-string (* 2 depth) #\space)) + +(define (string-replace-head s1 s2) + (string-replace s1 s2 + 0 (string-length s2))) + + +(define diff-cmd + ;; '("diff") + '("git" "diff" "--no-index" "--color-moved=default" "--color=always"; "--word-diff=color" + ) + ) + +(define (diff s1 s2) + (let ((filename1 (call-with-tmpfile (lambda (p f) (pretty-print s1 p display?: #t) f))) + (filename2 (call-with-tmpfile (lambda (p f) (pretty-print s2 p display?: #t) f)))) + (let ((pipe (apply open-pipe* + OPEN_READ + (append diff-cmd (list filename1 filename2))))) + (begin1 (read-string pipe) + (close-pipe pipe))))) diff --git a/module/hnh/test/xmllint.scm b/module/hnh/test/xmllint.scm new file mode 100644 index 00000000..95362607 --- /dev/null +++ b/module/hnh/test/xmllint.scm @@ -0,0 +1,27 @@ +(define-module (hnh test xmllint) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module ((rnrs io ports) :select (get-string-all)) + :use-module ((hnh util) :select (begin1)) + :export (xmllint) + ) + + +(define (xmllint str) + (let ((in* out (car+cdr (pipe))) + (in out* (car+cdr (pipe))) + (cmdline (string-split "xmllint --format -" #\space))) + (define pid + (spawn (car cmdline) cmdline + input: in* + output: out*)) + (close-port in*) + (close-port out*) + + (display str out) + (force-output out) + (close-port out) + + (begin1 (get-string-all in) + (close-port in)))) diff --git a/module/hnh/util.scm b/module/hnh/util.scm index d2c0dd5f..c88a029e 100644 --- a/module/hnh/util.scm +++ b/module/hnh/util.scm @@ -17,6 +17,7 @@ find-extreme find-min find-max filter-sorted != + init+last take-to string-take-to string-first @@ -55,6 +56,12 @@ assq-ref-all assv-ref-all + uniqx + uniq + univ + uniqv + unique + vector-last ->string @@ -64,6 +71,10 @@ :replace (set! define-syntax when unless)) +(cond-expand + (guile-3 (use-modules ((ice-9 copy-tree) :select (copy-tree)))) + (else)) + ((@ (guile) define-syntax) define-syntax (syntax-rules () ((_ (name args ...) body ...) @@ -112,6 +123,9 @@ ((for (<var> <vars> ...) in <collection> b1 body ...) (map ((@ (ice-9 match) match-lambda) [(<var> <vars> ...) b1 body ...]) <collection>)) + ((for (<var> <vars> ... . <tail>) in <collection> b1 body ...) + (map ((@ (ice-9 match) match-lambda) [(<var> <vars> ... . <tail>) b1 body ...]) + <collection>)) ((for <var> in <collection> b1 body ...) (map (lambda (<var>) b1 body ...) <collection>)))) @@ -137,9 +151,12 @@ +;; TODO this is called flip in Haskell land (define (swap f) (lambda args (apply f (reverse args)))) - +;; Swap would be +;; (define (swap p) +;; (xcons (car p) (cdr p))) ;; Allow set to work on multiple values at once, ;; similar to Common Lisp's @var{setf} @@ -240,6 +257,12 @@ ;; (define (!= a b) (not (= a b))) (define != (negate =)) + +(define (init+last l) + (let ((last rest (car+cdr (reverse l)))) + (values (reverse rest) last))) + + (define (take-to lst i) "Like @var{take}, but might lists shorter than length." (if (> i (length lst)) @@ -307,7 +330,8 @@ (define (kvlist->assq kvlist) (map (lambda (pair) - (cons (keyword->symbol (car pair)) (cdr pair))) + (cons (keyword->symbol (car pair)) + (cadr pair))) (group kvlist 2))) (define* (assq-limit alist optional: (number 1)) @@ -320,8 +344,7 @@ (for value in lst (let ((key (proc value))) (hash-set! h key (cons value (hash-ref h key '()))))) - ;; NOTE changing this list to cons allows the output to work with assq-merge. - (hash-map->list list h))) + (hash-map->list cons h))) ;; (split-by '(0 1 2 3 4 2 5 6) 2) ;; ⇒ ((0 1) (3 4) (5 6)) @@ -383,7 +406,7 @@ (reverse (cons (map list last) rest )))))) ;; Given an arbitary tree, do a pre-order traversal, appending all strings. -;; non-strings allso allowed, converted to strings and also appended. +;; non-strings also allowed, converted to strings and also appended. (define (string-flatten tree) (cond [(string? tree) tree] [(list? tree) (string-concatenate (map string-flatten tree))] @@ -506,6 +529,19 @@ (define (assv-ref-all alist key) (ass%-ref-all alist key eqv?)) +(define (uniqx = lst) + (cond ((null? lst) lst) + ((null? (cdr lst)) lst) + ((and (pair? lst) + (= (car lst) (cadr lst))) + (uniqx = (cons (car lst) (cddr lst)))) + (else (cons (car lst) + (uniqx = (cdr lst)))))) + +(define (uniq lst) (uniqx eq? lst)) +(define (univ lst) (uniqx eqv? lst)) +(define (unique lst) (uniqx equal? lst)) + (define (vector-last v) @@ -517,9 +553,12 @@ (define-syntax catch* - (syntax-rules () + (syntax-rules (pre-unwind) + ((_ thunk ((pre-unwind key) handler)) + (with-throw-handler (quote key) thunk handler)) ((_ thunk (key handler)) (catch (quote key) thunk handler)) - ((_ thunk (key handler) rest ...) - (catch* (lambda () (catch (quote key) thunk handler)) + + ((_ thunk pair rest ...) + (catch* (lambda () (catch* thunk pair)) rest ...)))) diff --git a/module/hnh/util/env.scm b/module/hnh/util/env.scm index 18ec0543..32ea1cc1 100644 --- a/module/hnh/util/env.scm +++ b/module/hnh/util/env.scm @@ -1,5 +1,7 @@ (define-module (hnh util env) - :export (let-env with-working-directory)) + :export (let-env + with-working-directory + with-locale1)) (define-syntax let-env (syntax-rules () @@ -33,3 +35,12 @@ thunk (lambda () (chdir old-cwd))))) + +(define-syntax-rule (with-locale1 category locale thunk) + (let ((old #f)) + (dynamic-wind + (lambda () + (set! old (setlocale category)) + (setlocale category locale)) + thunk + (lambda () (setlocale category old))))) diff --git a/module/hnh/util/io.scm b/module/hnh/util/io.scm index d638ebb4..09900f8d 100644 --- a/module/hnh/util/io.scm +++ b/module/hnh/util/io.scm @@ -4,7 +4,9 @@ :export (open-input-port open-output-port read-lines - with-atomic-output-to-file)) + with-atomic-output-to-file + call-with-tmpfile + ->port)) (define (open-input-port str) (if (string=? "-" str) @@ -62,3 +64,19 @@ ;; counted on, since anything with an unspecified return ;; value might as well return #f) #f)))) + +(define* (call-with-tmpfile proc key: (tmpl "/tmp/file-XXXXXXX")) + (let* ((filename (string-copy tmpl)) + (port (mkstemp! filename))) + (with-continuation-barrier + (lambda () + (begin1 + (proc port filename) + (close-port port)))))) + +(define (->port port-or-string) + (cond ((port? port-or-string) port-or-string) + ((string? port-or-string) (open-input-string port-or-string)) + (else (scm-error 'misc-error "->port" + "Not a port or string" + (list port-or-string) #f)))) diff --git a/module/hnh/util/path.scm b/module/hnh/util/path.scm index ea081e85..b0991073 100644 --- a/module/hnh/util/path.scm +++ b/module/hnh/util/path.scm @@ -3,15 +3,20 @@ :use-module (srfi srfi-71) :use-module (hnh util) :export (path-append + path-absolute? path-join path-split file-hidden? filename-extension - realpath)) + realpath + relative-to)) (define // file-name-separator-string) (define /? file-name-separator?) +(define path-absolute? absolute-file-name?) + +;; TODO remove intermidiate period components (define (path-append . strings) (fold (lambda (s done) (string-append @@ -87,3 +92,31 @@ (if (absolute-file-name? filename) filename (path-append (getcwd) filename))) + + +(define (relative-to base path) + ;; (typecheck base string?) + ;; (typecheck path string?) + + (when (string-null? base) + (error "Base can't be empty" )) + + (let ((base (if (absolute-file-name? base) + base + (path-append (getcwd) base)))) + + (cond ((equal? '("") base) path) + ((not (absolute-file-name? path)) + (path-append base path)) + (else + (let loop ((a (path-split base)) + (b (path-split path))) + (cond + ((null? a) (path-join b)) + ((null? b) path) + ((string=? (car a) (car b)) (loop (cdr a) (cdr b))) + (else + (path-join + (append + (make-list (length a) "..") + (drop b (length a))))))))))) diff --git a/module/hnh/util/state-monad.scm b/module/hnh/util/state-monad.scm new file mode 100644 index 00000000..91201583 --- /dev/null +++ b/module/hnh/util/state-monad.scm @@ -0,0 +1,120 @@ +;;; Commentary: +;;; A state monad similar to (and directly influenced by) the one found in in +;;; Haskell +;;; Each procedure can either explicitly take the state as a curried last +;;; argument, or use the `do' notation, which handles that implicitly. +;;; Each procedure MUST return two values, where the second value is the state +;;; value which will be chained. +;;; +;;; Code borrowed from guile-dns +;;; Code: + +(define-module (hnh util state-monad) + :use-module (ice-9 curried-definitions) + :replace (do mod) + :export (with-temp-state + <$> return get get* put put* sequence lift + eval-state exec-state)) + +(define-syntax do + (syntax-rules (<- let =) + ((_ (a ...) <- b rest ...) + (lambda state-args + (call-with-values (lambda () (apply b state-args)) + (lambda (a* . next-state) + (apply (lambda (a ...) + (apply (do rest ...) + next-state)) + a*))))) + ((_ a <- b rest ...) + (lambda state-args + (call-with-values (lambda () (apply b state-args)) + (lambda (a . next-state) + (apply (do rest ...) + next-state))))) + + ((_ a = b rest ...) + (let ((a b)) + (do rest ...))) + + ((_ a) + (lambda state (apply a state))) + ((_ a rest ...) + (lambda state + (call-with-values (lambda () (apply a state)) + (lambda (_ . next-state) + (apply (do rest ...) + next-state))))))) + + +(define (with-temp-state state* op) + (do old <- (get*) + (apply put* state*) + ret-value <- op + (apply put* old) + (return ret-value))) + + +(define (<$> f y) + (do tmp <- y + (return (f tmp)))) + +(define ((return x) . y) + (apply values x y)) + +(define ((get*) . state) + "Like @code{get}, but always returns a list" + (values state state)) + +(define ((get) fst . state) + "If state contains a single variable return that, otherwise, return a list of all variables in state" + (if (null? state) + (values fst fst) + (apply values (cons fst state) fst state))) + +(define ((put . new-state) fst . old-state) + (if (null? old-state) + (apply values fst new-state) + (apply values (cons fst old-state) new-state))) + +;; Like put, but doesn't return anything (useful) +(define ((put* . new-state) . _) + (apply values #f new-state)) + +(define (mod proc) + (do + a <- (get) + (put (proc a)))) + +;; ms must be a list of continuations +(define (sequence ms) + (if (null? ms) + (return '()) + (do + fst <- (car ms) + rest <- (sequence (cdr ms)) + (return (cons fst rest))))) + + +(define (lift proc . arguments) + (do xs <- (sequence arguments) + (return (apply proc xs)))) + + +;; Run state, returning value +(define (eval-state st init) + (call-with-values + (lambda () + (if (procedure? init) + (call-with-values init st) + (st init))) + (lambda (r . _) r))) + +;; Run state, returning state +(define (exec-state st init) + (call-with-values + (lambda () + (if (procedure? init) + (call-with-values init st) + (st init))) + (lambda (_ . v) (apply values v)))) diff --git a/module/hnh/util/uuid.scm b/module/hnh/util/uuid.scm index 68455243..8e0434e3 100644 --- a/module/hnh/util/uuid.scm +++ b/module/hnh/util/uuid.scm @@ -1,19 +1,19 @@ (define-module (hnh util uuid) :use-module (ice-9 format) - :export (uuid uuid-v4)) + :export (seed uuid uuid-v4)) -(define %seed (random-state-from-platform)) +(define seed (make-parameter (random-state-from-platform))) (define (uuid-v4) (define version 4) (define variant #b10) (format #f "~8'0x-~4'0x-~4'0x-~4'0x-~12'0x" - (random (ash 1 (* 4 8)) %seed) - (random (ash 1 (* 4 4)) %seed) + (random (ash 1 (* 4 8)) (seed)) + (random (ash 1 (* 4 4)) (seed)) (logior (ash version (* 4 3)) - (random (1- (ash 1 (* 4 3))) %seed)) + (random (1- (ash 1 (* 4 3))) (seed))) (logior (ash variant (+ 2 (* 4 3))) - (random (ash 1 (+ 2 (* 4 3))) %seed)) - (random (ash 1 (* 4 12)) %seed))) + (random (ash 1 (+ 2 (* 4 3))) (seed))) + (random (ash 1 (* 4 12)) (seed)))) (define uuid uuid-v4) diff --git a/module/scripts/README.md b/module/scripts/README.md new file mode 100644 index 00000000..37bee989 --- /dev/null +++ b/module/scripts/README.md @@ -0,0 +1,18 @@ +Guile Script Format +=================== + +### `%summary` +String containing a summary of what the module does. +Should be a single line. + +### `%include-in-guild-list` +Boolean, indicating if the script should be listed when running `guild help` or `guild list`. + +### `%help` +Longer help for module. If this variable isn't set the procedure `module-commentary` is run + +### `%synopsis` +Short help showing how to invoke the script. Should *not* include the guild command. + +### `main` +Procedure which is primary entry point. Gets remaining command line as its arguments (meaning it takes multiple arguments). diff --git a/scripts/module-dependants.scm b/module/scripts/module-dependants.scm index 87c1f40b..6bda1917 100755..100644 --- a/scripts/module-dependants.scm +++ b/module/scripts/module-dependants.scm @@ -1,9 +1,3 @@ -#!/usr/bin/env bash -GUILE=${GUILE:-guile} -set -x -exec $GUILE -e main -s "$0" "$@" -!# - ;;; Commentary: ;;; ;;; For a given module in the project, finds all other modules who uses that @@ -11,25 +5,24 @@ exec $GUILE -e main -s "$0" "$@" ;;; ;;; Code: -(define module-dir (string-append - (dirname (dirname (current-filename))) - "/module")) - -(add-to-load-path module-dir) -(add-to-load-path (dirname (current-filename))) - - -(use-modules (hnh util) - (hnh util path) - (srfi srfi-1) - (srfi srfi-71) - (ice-9 ftw) - (texinfo string-utils) - (module-introspection)) +(define-module (scripts module-dependants) + :use-module (hnh util) + :use-module (hnh util path) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (ice-9 ftw) + :use-module (ice-9 curried-definitions) + :use-module (ice-9 format) + :use-module (texinfo string-utils) + :use-module (hnh module-introspection) + :use-module ((hnh module-introspection static-util) :select (get-forms)) + :export (main)) + +(define %summary "Print all modules which depend on module specified in target file.") +(define %synopsis "module-dependants TARGET-FILE") (define cstat (make-object-property)) - (define (find-all-files-under directory) (file-system-fold ;; enter? @@ -53,16 +46,13 @@ exec $GUILE -e main -s "$0" "$@" (define (regular-file? filename) (eq? 'regular (stat:type (cstat filename)))) -(define (filename-extension? ext) - (let ((re (make-regexp (string-append ((@ (texinfo string-utils) - escape-special-chars) - ext "^$[]()*." #\\) - "$") regexp/icase))) - (lambda (filename) (regexp-exec re filename)))) +;; Does @var{filename} have the extension @var{ext}? +(define ((filename-extension? ext) filename) + (string=? ext (filename-extension filename))) -(define (main args) - (define target-file (realpath (cadr args))) +(define (main . args) + (define target-file (realpath (car args))) (define target-forms (reverse (call-with-input-file target-file get-forms))) (define target-module @@ -73,26 +63,36 @@ exec $GUILE -e main -s "$0" "$@" (define edges (concatenate (map (lambda (file) - (define forms (call-with-input-file file get-forms)) - (define module (and=> (-> forms find-module-declaration) resolve-module)) - (define source-symbols (unique-symbols forms)) - - (when module - (awhen (find (lambda (module) - (equal? target-module - (module-name module))) - (module-uses module)) - (let ((module-symbols (module-map (lambda (key value) key) it))) - ;; (display " ") - (map (lambda (symb) - (cons file symb)) - (lset-intersection eq? source-symbols module-symbols)) - ))) - ) + (catch #t + (lambda () + (define forms (call-with-input-file file get-forms)) + (define module (and=> (-> forms find-module-declaration) resolve-module)) + (define source-symbols (unique-symbols forms)) + + (when module + (awhen (find (lambda (module) + (equal? target-module + (module-name module))) + (module-uses module)) + (let ((module-symbols (module-map (lambda (key value) key) it))) + ;; (display " ") + (map (lambda (symb) + (cons file symb)) + (lset-intersection eq? source-symbols module-symbols)) + )))) + ;; TODO many of these errors are due to the 'prefix and 'postfix + ;; read options being set for modules which expect them to be off. + (lambda (err proc fmt args data) + (format (current-error-port) + "ERROR when reading ~a: ~a in ~a: ~?~%" file err proc fmt args) + '()))) + (delete target-file - (filter (filename-extension? ".scm") + (filter (filename-extension? "scm") (filter regular-file? - (find-all-files-under module-dir))))))) + (append-map (lambda (module-dir) + (find-all-files-under module-dir)) + %load-path))))))) (define file-uses (make-hash-table)) diff --git a/module/scripts/module-imports.scm b/module/scripts/module-imports.scm new file mode 100644 index 00000000..8f9ab1b8 --- /dev/null +++ b/module/scripts/module-imports.scm @@ -0,0 +1,80 @@ +;;; Commentary: +;;; +;;; Scripts which finds unused imports in each file. +;;; Uses Guile's module system reflection to find what is imported, +;;; but simple looks at all unique symbols in the source file for what +;;; is used, which might lead to some discrepancies. +;;; +;;; Code: + +(define-module (scripts module-imports) + :use-module ((srfi srfi-1) :select (lset-difference)) + :use-module ((rnrs lists) :select (remp filter partition)) + :use-module ((hnh module-introspection) :select (module-declaration? unique-symbols)) + :use-module ((hnh module-introspection static-util) :select (get-forms)) + :use-module ((hnh module-introspection module-uses) :select (module-uses*)) + :export (main) + ) + +(define %summary "List imports, and how many are used.") +(define %synopsis "module-imports filename") + +;;; Module use high scores +;;; $ grep -Ho '#\?:use-module' -R module | uniq -c | sort -n + +(define (main . args) + (define filename (car args)) + ;; TODO Module declaration can reside inside a cond-expand block + (define-values (module-declaration-list forms) + (partition module-declaration? + (reverse (call-with-input-file filename get-forms)))) + + ;; All symbols in source file, which are not in module declaration. + ;; Otherwise all explicitly imported symbols would be marked as + ;; used. + (define symbs (unique-symbols forms)) + ;; (format #t "~y" (find-module-declaration forms)) + ;; (format #t "~a~%" symbs) + + ;; TODO parameterize this to a command line argument + (define skip-list '((guile) + (guile-user) + (srfi srfi-1) + )) + + (define modules + ;; If we didn't find the module declaration + (if (null? module-declaration-list) + ;; Find symbols by best effort + (begin + (format #t "Using our make-shift module introspection~%") + (map (lambda (mod) (apply resolve-interface mod)) + (remp (lambda (mod) (member (car mod) skip-list)) + (module-uses* forms)))) + ;; If we did find the declaration, use the actual symbol in + (begin + (format #t "Using guile's true module introspection~%") + (remp (lambda (mod) (member (module-name mod) skip-list)) + (module-uses (resolve-module + (cadr (car module-declaration-list)))))))) + + (format #t "=== ~a ===~%" filename) + (for-each (lambda (mod) + + ;; all symbols imported from module + (define all-symbols (module-map (lambda (key value) key) mod)) + + ;; Thes subset of all imported symbols from module which are used + (define used-symbols + (filter (lambda (symb) (memv symb symbs)) + all-symbols)) + + (define used-count (length used-symbols)) + (define total-count (length (module-map list mod))) + + (format #t "~a/~a ~a~% used ~s~% unused ~s~%" + used-count total-count (module-name mod) + used-symbols + (lset-difference eq? all-symbols used-symbols))) + modules) + (newline)) diff --git a/module/scripts/peg-to-graph.scm b/module/scripts/peg-to-graph.scm new file mode 100644 index 00000000..afd7a4c3 --- /dev/null +++ b/module/scripts/peg-to-graph.scm @@ -0,0 +1,63 @@ +(define-module (scripts peg-to-graph) + :use-module ((graphviz) :prefix #{gv:}#) + :use-module ((hnh module-introspection) :select (unique-symbols)) + :use-module ((hnh module-introspection static-util) :select (get-forms)) + :use-module (srfi srfi-1) + :use-module (ice-9 match) + :use-module (hnh util options) + :use-module (ice-9 getopt-long) + :export (main)) + +(define option-spec + `((engine (value #t) + (description "Graphviz rendering engine to use. Defaults to DOT")) + (output (single-char #\o) + (value #t) + (description "Name of output pdf")))) + +(define %summary "Output peg-pattern relations as a graphviz graph.") +(define %synopsis "peg-to-graph [options] <filename>") +(define %help (format-arg-help option-spec)) + +(define peg-primitives + '(and or * + ? followed-by not-followed-by peg-any range + ignore capture peg)) + +(define (handle-peg-form! graph form) + (match form + (`(define-peg-pattern ,name ,capture ,body) + (let ((node (gv:node graph (format #f "~a" name)))) + (gv:setv node "style" + (case capture + ((all) "solid") + ((body) "dashed") + ((none) "dotted")))) + (for-each (lambda (symbol) + (gv:edge graph + (format #f "~a" name) + (format #f "~a" symbol))) + (remove (lambda (x) (memv x peg-primitives)) + (unique-symbols (list body))))))) + +(define (main . args) + (define options (getopt-long (cons "peg-to-graph" args) + (getopt-opt option-spec))) + (define engine (option-ref options 'engine "dot")) + (define output-file (option-ref options 'output "lex2.pdf")) + (define input-file (let ((filenames (option-ref options '() '()))) + (when (null? filenames) + (format #t "Usage: ~a~%" %summary) + (exit 1)) + (car filenames))) + + + (let ((graph (gv:digraph "G"))) + (for-each (lambda (form) handle-peg-form! graph form) + (filter (lambda (x) + (and (list? x) + (not (null? x)) + (eq? 'define-peg-pattern (car x)))) + (call-with-input-file input-file get-forms))) + + (gv:layout graph engine) + (gv:render graph "pdf" output-file))) diff --git a/module/scripts/use2dot-all.scm b/module/scripts/use2dot-all.scm new file mode 100644 index 00000000..18639619 --- /dev/null +++ b/module/scripts/use2dot-all.scm @@ -0,0 +1,191 @@ +(define-module (scripts use2dot-all) + :use-module ((scripts frisk) :select (make-frisker edge-type edge-up + edge-down)) + :use-module (srfi srfi-1) + :use-module (srfi srfi-88) + :use-module ((graphviz) :prefix gv.) + :use-module (hnh module-introspection all-modules) + :use-module (hnh util options) + :use-module (ice-9 getopt-long) + :export (main)) + +(define default-remove + '((srfi srfi-1) + (srfi srfi-9) + (srfi srfi-26) + (srfi srfi-41) + + (ice-9 match) + (ice-9 format))) + +(define option-spec + `((engine (value #t) + (description "Graphviz rendering engine to use. Defaults to FDP")) + (default-module + (single-char #\m) + (value #t) + (description "Set MOD as the default module, see guild help use2dot for more information. Defaults to (guile-user)")) + (output + (single-char #\o) + (value #t) + (description "Name of output PDF")) + (remove + (value #t) + (description "Modules to remove from check, usually since to many other modules depend on them.")) + (ignore-default-remove + (description "Don't ignore the modules which are ignored by default, which are:" (br) + ,@(append-map (lambda (item) (list (with-output-to-string (lambda () (display item))) '(br))) + default-remove))))) + +(define %synopsis "use2dot-all [options] <directory>") +(define %summary "Like use2dot, but for multiple modules") +(define %help (format-arg-help option-spec)) + +(define (remove-edges blacklist edges) + (remove (lambda (edge) + (or (member (edge-up edge) blacklist) + (member (edge-down edge) blacklist))) + edges)) + +(define (main . args) + (define options (getopt-long (cons "use2dot-all" args) + (getopt-opt option-spec) + stop-at-first-non-option: #t)) + (define default-module + (cond ((option-ref options 'default-module #f) + => (lambda (s) (let ((mod (with-input-from-string s read))) + (unless (list? mod) + (format (current-error-port) + "Module must be a list: ~s~%" mod) + (exit 1))))) + (else '(guile-user)))) + (define engine (option-ref options 'engine "fdp")) + (define output-file (option-ref options 'output "graph.pdf")) + (define custom-remove (cond ((option-ref options 'remove #f) + => (lambda (s) (let ((lst (with-input-from-string s read))) + (unless (and (list? lst) (every list? lst)) + (format (current-error-port) + "custom-remove must get a list of lists: ~s~%" lst) + (exit 1)) + lst))) + (else '()))) + (define to-remove (if (option-ref options 'default-remove #f) + custom-remove + (append custom-remove default-remove))) + (define target-directory + (let ((remaining (option-ref options '() '()))) + (cond ((null? remaining) + (format (current-error-port) "Target directory required~%") + (exit 1)) + (else (car remaining))))) + + ;; End of command line parsing + + (define scan (make-frisker `(default-module . ,default-module))) + + (define-values (files our-modules) + (all-modules-under-directory target-directory)) + + (define graph + (let ((graph (gv.digraph "G"))) + (gv.setv graph "color" "blue") + (gv.setv graph "compound" "true") + (gv.setv graph "overlap" "prism") + ;; (gv.setv graph "bgcolor" "blue") + graph)) + + (define count 0) + + (define colors + '("red" "green" "blue")) + + (define rem our-modules) + + ;; (for-each (lambda (key) + ;; + ;; (define subgraph (gv.graph graph (format #f "cluster_~a" count))) + ;; + ;; (define-values (use rem*) (partition (lambda (mod) (eq? key (car mod))) rem)) + ;; (set! rem rem*) + ;; + ;; ;; (gv.setv subgraph "rankdir" "TB") + ;; (gv.setv subgraph "color" (list-ref colors count)) + ;; + ;; (for-each (lambda (name) + ;; (gv.node subgraph (format #f "~a" name))) + ;; use) + ;; + ;; (set! count (1+ count)) + ;; ) + ;; '(calp vcomponent)) + + ;; (define subgraph (gv.graph graph (format #f "cluster_~a" count))) + ;; + ;; ;; (gv.setv subgraph "rankdir" "TB") + ;; (gv.setv subgraph "color" (list-ref colors count)) + ;; + ;; (for-each (lambda (name) + ;; (gv.node subgraph (format #f "~a" name))) + ;; rem) + + (define subgraph + (let ((subgraph (gv.graph graph (format #f "cluster_~a" 0)))) + ;; (gv.setv subgraph "rankdir" "TB") + (gv.setv subgraph "color" "Red") + subgraph)) + + + (define subgraphs + (let ((subgraphs (make-hash-table))) + (for-each (lambda (name) + (let ((g (hashq-ref subgraphs (car name) + (gv.graph graph (format #f "cluster_~a" (car name)))))) + (hashq-set! subgraphs (car name) g) + + (let ((node (gv.node g (format #f "~a" name)))) + (gv.setv node "fillcolor" "green") + (gv.setv node "style" "filled") + )) + ) + (remove (lambda (x) (eq? 'calp (car x))) + our-modules)))) + + (define calp-base (gv.graph graph "cluster_1")) + (define calpgraphs + (let ((calpgraphs (make-hash-table))) + (for-each (lambda (name) + (let ((g (hashq-ref calpgraphs (cadr name) + (gv.graph + ;; calp-base + graph + (format #f "cluster_~a" (cadr name)))))) + (hashq-set! calpgraphs (car name) g) + + (let ((node (gv.node g (format #f "~a" name)))) + (gv.setv node "fillcolor" "green") + (gv.setv node "style" "filled") + )) + ) + (remove (compose null? cdr) + (filter (lambda (x) (eq? 'calp (car x))) + our-modules))) + calpgraphs)) + + + (for-each (lambda (edge) + (let ((gv-edge (gv.edge graph + (format #f "~a" (edge-down edge)) + (format #f "~a" (edge-up edge)) + ))) + (when (and (eq? 'calp (car (edge-up edge))) + (not (eq? 'calp (car (edge-down edge))))) + (gv.setv gv-edge "color" "red")) + (when (and (memv (car (edge-up edge)) '(vcomponent calp)) + (not (memv (car (edge-down edge)) '(vcomponent calp )))) + (gv.setv gv-edge "color" "blue")) + )) + (remove-edges to-remove + ((scan files) 'edges))) + + (gv.layout graph engine) + (gv.render graph "pdf" output-file)) diff --git a/module/srfi/srfi-64/util.scm b/module/srfi/srfi-64/util.scm new file mode 100644 index 00000000..a371227f --- /dev/null +++ b/module/srfi/srfi-64/util.scm @@ -0,0 +1,11 @@ +(define-module (srfi srfi-64 util) + :use-module (ice-9 curried-definitions) + :use-module ((srfi srfi-1) :select (every)) + :use-module (srfi srfi-64) + :export (test-match-group)) + +;; Specifier for name of group +(define ((test-match-group name . names) runner) + (every string=? + (reverse (cons name names)) + (test-runner-group-stack runner))) diff --git a/module/sxml/namespaced.scm b/module/sxml/namespaced.scm new file mode 100644 index 00000000..e5a334da --- /dev/null +++ b/module/sxml/namespaced.scm @@ -0,0 +1,266 @@ +(define-module (sxml namespaced) + :use-module (sxml ssax) + :use-module (sxml util) + :use-module (ice-9 match) + :use-module (srfi srfi-1) + :use-module (srfi srfi-9) + :use-module (srfi srfi-9 gnu) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (hnh util state-monad) + :use-module ((hnh util io) :select (->port)) + :export (xml->namespaced-sxml + namespaced-sxml->xml + namespaced-sxml->sxml + namespaced-sxml->sxml/namespaces + sxml->namespaced-sxml + xml + attribute + + make-xml-element + xml-element? + xml-element-tagname + xml-element-namespace + xml-element-attributes + + make-pi-element + pi-element? + pi-tag + pi-body + )) + +;; XML processing instruction elements (and other things with identical syntax) +;; For example: <?xml version="1.0" encoding="utf-8"?> would be encoded as +;; (make-pi-element 'xml "version=\"1.0\" encoding=\"utf-8\"") +;; tag should always be a symbol +;; body should always be a string +(define-record-type <pi-element> + (make-pi-element tag body) + pi-element? + (tag pi-tag) + (body pi-body)) + + +(define-record-type <xml-element> + (make-xml-element tagname namespace attributes) + xml-element? + (tagname xml-element-tagname) + (namespace xml-element-namespace) + (attributes xml-element-attributes)) + + +(define xml + (case-lambda + ((tag) (make-xml-element tag #f '())) + ((ns tag) (make-xml-element tag ns '())) + ((ns tag attrs) (make-xml-element tag ns attrs)))) + +(define (attribute xml attr) + (assoc-ref (xml-element-attributes xml) attr)) + + +(define* (parser key: trim-whitespace?) + (ssax:make-parser + + ;; DOCTYPE + ;; (lambda (port docname systemid internal-subset? seed) + ;; (format (current-error-port) + ;; "doctype: port=~s, docname=~s, systemid=~s, internal-subset?=~s, seed=~s~%" + ;; port docname systemid internal-subset? seed) + ;; (values #f '() '() seed)) + + ;; UNDECL-ROOT + ;; (lambda (elem-gi seed) + ;; (format (current-error-port) "Undecl-root: ~s~%" elem-gi) + ;; (values #f '() '() seed)) + + ;; DECL-ROOT + ;; (lambda (elem-gi seed) + ;; (format (current-error-port) "Decl-root: ~s~%" elem-gi) + ;; seed) + + NEW-LEVEL-SEED + (lambda (elem-gi attributes namespaces expected-content seed) + (cons + (list + (match elem-gi + ((ns . tag) (make-xml-element tag ns attributes)) + (tag (make-xml-element tag #f attributes)))) + seed)) + + FINISH-ELEMENT + (lambda (elem-gi attributes namespaces parent-seed seed) + (match seed + (((self . self-children) (parent . children) . rest) + `((,parent (,self ,@(reverse self-children)) ,@children) + ,@rest)))) + + CHAR-DATA-HANDLER + (lambda (str1 str2 seed) + (define s + (if trim-whitespace? + (string-trim-both (string-append str1 str2)) + (string-append str1 str2))) + (cond ((string-null? s) seed) + (else + (match seed + (((parent . children) . rest) + `((,parent ,(string-append str1 str2) + ,@children) + ,@rest)))))) + + PI + ((*DEFAULT* . (lambda (port pi-tag seed) + (let ((body (ssax:read-pi-body-as-string port))) + (match seed + (((parent . children) . rest) + `((,parent ,(make-pi-element pi-tag body) ,@children) + ,@rest))))))) + )) + + +(define* (xml->namespaced-sxml port-or-string key: (trim-whitespace? #t)) + (match (with-ssax-error-to-port + (current-error-port) + (lambda () ((parser trim-whitespace?: trim-whitespace?) + (->port port-or-string) + '((*TOP*))))) + ((('*TOP* . items)) + `(*TOP* ,@(reverse items))))) + +(define (pi-element->sxml pi) + `(*PI* ,(pi-tag pi) ,(pi-body pi))) + + + +(define (ns-pair->attribute pair) + (let ((fqdn short (car+cdr pair))) + (list (string->symbol (format #f "xmlns:~a" short)) + (symbol->string fqdn)))) + +;; Takes an association list from full namespace names (as symbols), to their +;; short forms, and returns a list containing xmlns:x-attributes suitable for +;; splicing into scheme's "regular" sxml. +(define (ns-alist->attributes ns) + (map ns-pair->attribute ns)) + + + +(define (get-prefix ns) + (do namespaces <- (get) + (cond ((assq-ref namespaces ns) => return) + (else (do prefix = (gensym "ns") + (put (acons ns prefix namespaces)) + (return prefix)))))) + + +(define (xml-element->sxml el) + (do tag <- (cond ((xml-element-namespace el) + => (lambda (ns) + (do pre <- (get-prefix ns) + (return + (string->symbol + (format #f "~a:~a" pre (xml-element-tagname el))))))) + (else (return (xml-element-tagname el)))) + (return + (lambda (children) + (cond ((null? (xml-element-attributes el)) + `(,tag ,@children)) + (else + `(,tag (@ ,@(map (lambda (p) + (call-with-values (lambda () (car+cdr p)) list)) + (xml-element-attributes el))) + ,@children))))))) + +(define (sxml->xml-element el namespaces) + (lambda (children) + (let ((tag-symb attrs + (match el + ((tag ('@ attrs ...)) + (values tag (map (lambda (p) (apply cons p)) attrs))) + ((tag) (values tag '()))))) + (let ((parts (string-split (symbol->string tag-symb) #\:))) + (cons (case (length parts) + ((1) (xml (assoc-ref namespaces #f) + (string->symbol (car parts)) attrs)) + ((2) + (cond ((assoc-ref namespaces (string->symbol (car parts))) + => (lambda (ns) (xml ns (string->symbol (cadr parts)) attrs))) + (else (scm-error 'missing-namespace "sxml->xml-element" + "Unknown namespace prefix encountered: ~s (on tag ~s)" + (list (car parts) (cadr parts)) + #f)))) + (else (scm-error 'misc-error "sxml->xml-element" + "Invalid QName: more than one colon ~s" + (list tag-symb) #f))) + children))))) + + +(define (namespaced-sxml->sxml* tree) + (cond ((null? tree) (return tree)) + ((string? tree) (return tree)) + ((pi-element? tree) (return (pi-element->sxml tree))) + ((not (pair? tree)) (return tree)) + ((car tree) symbol? + => (lambda (symb) + (case symb + ((*TOP*) (do children <- (sequence (map namespaced-sxml->sxml* + (cdr tree))) + + (return (cons '*TOP* children)))) + (else (return tree))))) + ((xml-element? (car tree)) + (do proc <- (xml-element->sxml (car tree)) + children <- (sequence (map namespaced-sxml->sxml* (cdr tree))) + (return (proc children)))) + + ;; list of xml-element? + (else (scm-error 'misc-error "namespaced-sxml->sxml*" + "Unexpected token in tree: ~s" + (list tree) + #f)))) + + +;; Takes a tree of namespaced-sxml, and optionally an assoc list from namespace symbols, to prefered prefix. +;; Returns a sxml tree, with xmlns:<prefix>=namespace attributes +(define* (namespaced-sxml->sxml tree optional: (namespace-prefixes '())) + (let ((tree ns ((namespaced-sxml->sxml* tree) namespace-prefixes))) + ((get-root-element tree) + (lambda (root) + (add-attributes root (ns-alist->attributes ns)))))) + +(define* (namespaced-sxml->xml tree key: + (namespaces '()) + (port (current-output-port))) + ((@ (sxml simple) sxml->xml) + (namespaced-sxml->sxml tree namespaces) port)) + +;; Takes a tree of namespaced-sxml, and optionally an assoc list from namespace symbols, to prefered prefix. +;; Returns two values: a sxml tree without declared namespaces +;; and a association list from namespace symbols, to used prefixes +(define* (namespaced-sxml->sxml/namespaces tree optional: (namespace-prefixes '())) + ((namespaced-sxml->sxml* tree) namespace-prefixes)) + +;; Takes an sxml tree, and an association list from prefixes to namespaces +;; Returns a namespaced sxml tree +(define (sxml->namespaced-sxml tree namespaces) + (match tree + (('*PI* tag body) (make-pi-element tag body)) + (('*TOP* rest ...) + `(*TOP* ,@(map (lambda (r) (sxml->namespaced-sxml r namespaces)) + rest))) + ((el ('@ attrs ...) rest ...) + ((sxml->xml-element `(,el (@ ,@attrs)) namespaces) + (map (lambda (el) (sxml->namespaced-sxml el namespaces)) + rest))) + ((el rest ...) + ((sxml->xml-element `(,el) namespaces) + (map (lambda (el) (sxml->namespaced-sxml el namespaces)) + rest))) + (atom atom))) + +;;; TODO read intro-comment in SSAX file +;;; TODO Figure out how to still use (sxml match) and (sxml xpath) with these +;;; new trees (probably rewriting to a "regular" sxml tree, and keeping +;;; a strict mapping of namespaces) + diff --git a/module/sxml/namespaced/util.scm b/module/sxml/namespaced/util.scm new file mode 100644 index 00000000..6f93e362 --- /dev/null +++ b/module/sxml/namespaced/util.scm @@ -0,0 +1,45 @@ +(define-module (sxml namespaced util) + :use-module (sxml namespaced) + :use-module (srfi srfi-1) + :use-module ((ice-9 control) :select (call/ec)) + :export (xml-element-hash-key + find-element + element-matches? + on-root-element + root-element + )) + +(define (xml-element-hash-key tag) + "Returns a value suitable as a key to hash-ref (and family)" + (cons (xml-element-namespace tag) + (xml-element-tagname tag))) + +(define (find-element target list) + (define target* (xml-element-hash-key target)) + (find (lambda (x) (and (list? x) + (not (null? x)) + (xml-element? (car x)) + (equal? target* (xml-element-hash-key (car x))))) + list)) + + +(define (element-matches? target-el tree) + (and (not (null? tree)) + (equal? + (xml-element-hash-key target-el) + (xml-element-hash-key (car tree))))) + + +(define (on-root-element proc tree) + (cond ((and (eq? '*TOP* (car tree)) + (pi-element? (cadr tree))) + (cons* (car tree) (cadr tree) + (proc (caddr tree)))) + ((eq? '*TOP* (car tree)) + (cons (car tree) + (proc (cadr tree)))) + (else (proc (car tree))))) + +(define (root-element tree) + (call/ec (lambda (return) + (on-root-element return tree)))) diff --git a/module/sxml/util.scm b/module/sxml/util.scm new file mode 100644 index 00000000..532141b2 --- /dev/null +++ b/module/sxml/util.scm @@ -0,0 +1,22 @@ +(define-module (sxml util) + :use-module (ice-9 match) + :export (get-root-element add-attributes)) + +(define (get-root-element tree) + (match tree + (('*TOP* ('*PI* 'xml body) (root . children)) + (lambda (modifier) `(*TOP* (*PI* xml ,body) + ,(modifier `(,root ,@children))))) + (('*TOP* (root . children)) + (lambda (modifier) `(*TOP* ,(modifier `(,root ,@children))))) + ((root . children) + (lambda (modifier) `(*TOP* ,(modifier `(,root ,@children))))))) + +(define (add-attributes element added-attributes) + (match element + ((el ('@ . attributes) . children) + `(,el (@ ,@attributes ,@added-attributes) + ,@children)) + ((el . children) + `(,el (@ ,@added-attributes) + ,@children)))) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index b62d45c2..472c5074 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -15,7 +15,9 @@ vcomponent? children type parent - add-child! remove-child! + reparent! + abandon! + orphan! delete-property! prop* prop @@ -28,6 +30,7 @@ parameters properties + copy-as-orphan copy-vcomponent x-property? internal-field? @@ -75,40 +78,42 @@ (make-vline% key value ht)) (define-record-type <vcomponent> - (make-vcomponent% type children parent properties) + (make-vcomponent% type children properties) vcomponent? (type type) (children children set-component-children!) - (parent get-component-parent set-component-parent!) (properties get-component-properties)) ((@ (srfi srfi-9 gnu) set-record-type-printer!) <vcomponent> (lambda (c p) - (format p "#<<vcomponent> ~a, len(child)=~a, parent=~a>~%" + (format p "#<<vcomponent> ~a, len(child)=~a>" (type c) (length (children c)) - (and=> (get-component-parent c) type)))) + ))) -;; TODO should this also update the parent -(define parent - (make-procedure-with-setter - get-component-parent set-component-parent!)) + +(define parent% (make-object-property)) +(define (parent x) (parent% x)) (define* (make-vcomponent optional: (type 'VIRTUAL)) - (make-vcomponent% type '() #f (make-hash-table))) + (make-vcomponent% type '() (make-hash-table))) -(define (add-child! parent child) +;; TODO should this be renamed to `adopt!'? Adopting a child better implies +;; that the old parent should no longer be considered its parent. +(define (reparent! parent child) (set-component-children! parent (cons child (children parent))) - (set-component-parent! child parent)) + (set! (parent% child) parent)) -(define (remove-child! parent-component child) - (unless (eq? parent-component (parent child)) - (scm-error - 'wrong-type-arg "remove-child!" "Child doesn't belong to parent" - (list parent-component child) #f)) +(define (abandon! parent-component child) (set-component-children! parent-component (delq1! child (children parent-component))) - (set-component-parent! child #f)) + (when (eq? parent-component (parent% child)) + (orphan! child))) + +;; TODO should this exist? It's really weird to remove our reference to our +;; parent, without the parent removing their reference to us. +(define (orphan! child) + (set! (parent% child) #f)) ;;; TODO key=DTSTART, (date? value) => #t ;;; KRÄVER att (props vline 'VALUE) <- "DATE" @@ -194,12 +199,10 @@ ;; TODO deep-copy on parameters? (get-vline-parameters vline))) -(define (copy-vcomponent component) +(define (copy-as-orphan component) (make-vcomponent% (type component) - ;; TODO deep copy? (children component) - (parent component) ;; properties (alist->hashq-table (hash-map->list (lambda (key value) @@ -208,6 +211,13 @@ (copy-vline value)))) (get-component-properties component))))) + +(define (copy-vcomponent component) + (let ((ev (copy-as-orphan component))) + (when (parent component) + (reparent! (parent component) ev)) + ev)) + (define (extract field) (lambda (e) (prop e field))) diff --git a/module/vcomponent/config.scm b/module/vcomponent/config.scm index b2598207..3bc51557 100644 --- a/module/vcomponent/config.scm +++ b/module/vcomponent/config.scm @@ -4,13 +4,13 @@ :use-module (calp util config)) (define-config calendar-files '() - description: (_ "Which files to parse. Takes a list of paths or a single string which will be globbed.") + description: (G_ "Which files to parse. Takes a list of paths or a single string which will be globbed.") pre: (lambda (v) (cond [(list? v) v] [(string? v) ((@ (glob) glob) v)] [else #f]))) (define-config default-calendar "" - description: (_ "Default calendar to use for operations. Set to empty string to unset") + description: (G_ "Default calendar to use for operations. Set to empty string to unset") pre: (ensure string?)) diff --git a/module/vcomponent/control.scm b/module/vcomponent/control.scm index 0869543d..19a6fa18 100644 --- a/module/vcomponent/control.scm +++ b/module/vcomponent/control.scm @@ -26,7 +26,7 @@ ;; TODO what is this even used for? (define-syntax with-replaced-properties (syntax-rules () - [(_ (component (key val) ...) + [(G_ (component (key val) ...) body ...) (let ((htable (make-hash-table 10))) diff --git a/module/vcomponent/create.scm b/module/vcomponent/create.scm new file mode 100644 index 00000000..374da8b4 --- /dev/null +++ b/module/vcomponent/create.scm @@ -0,0 +1,121 @@ +(define-module (vcomponent create) + :use-module (vcomponent base) + :use-module ((srfi srfi-1) :select (last drop-right car+cdr)) + :use-module (srfi srfi-9) + :use-module (srfi srfi-9 gnu) + :use-module (srfi srfi-17) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module ((ice-9 hash-table) :select (alist->hashq-table)) + :use-module ((hnh util) :select (kvlist->assq ->)) + :export (with-parameters + as-list + vcomponent + vcalendar vevent + vtimezone standard daylight + )) + +;; TODO allow parameters and list values at same time + + + +;; Convert a scheme keyword to a symbol suitable for us +(define (keyword->key keyword) + (-> keyword + keyword->string + string-upcase + string->symbol)) + +(define (symbol-upcase symbol) + (-> symbol + symbol->string + string-upcase + string->symbol)) + +;; Upcase the keys in an association list. Keys must be symbols. +(define (upcase-keys alist) + (map (lambda (pair) (cons (symbol-upcase (car pair)) + (cdr pair))) + alist)) + + + +(define-immutable-record-type <almost-vline> + (make-almost-vline parameters value) + almost-vline? + (parameters almost-vline-parameters) + (value almost-vline-value)) + +(define (almost-vline->vline key almost-vline) + (make-vline key + (almost-vline-value almost-vline) + (almost-vline-parameters almost-vline))) + +(define (with-parameters . args*) + (define parameters (drop-right args* 1)) + (define value (last args*)) + (make-almost-vline + (-> parameters + kvlist->assq + upcase-keys + alist->hashq-table) + value)) + + + +(define-immutable-record-type <list-value> + (make-list-value value) + list-value? + (value list-value-value)) + +(define (as-list arg) + (make-list-value arg)) + + + +(define (vcomponent type . attrs*) + (define component (make-vcomponent type)) + (define attrs*-len (length attrs*)) + (unless (zero? attrs*-len) + (let ((attrs children + (if (and (list? (list-ref attrs* (- attrs*-len 1))) + (or (= 1 attrs*-len) + (not (keyword? (list-ref attrs* (- attrs*-len 2)))))) + (values (drop-right attrs* 1) + (last attrs*)) + (values attrs* '())))) + (for-each (lambda (pair) + (let ((key value (car+cdr pair))) + (cond + ((almost-vline? value) + (set! (prop* component key) + (almost-vline->vline key value))) + ((list-value? value) + (set! (prop* component key) + (map (lambda (value) + (make-vline key value (make-hash-table))) + (list-value-value value)))) + (else + (set! (prop component key) value))))) + (upcase-keys (kvlist->assq attrs))) + + ;; Attach children + (for-each (lambda (child) (reparent! component child)) + children))) + + component) + +(define (vcalendar . attrs) + (apply vcomponent 'VCALENDAR attrs)) + +(define (vevent . attrs) + (apply vcomponent 'VEVENT attrs)) + +(define (vtimezone . attrs) + (apply vcomponent 'VTIMEZONE attrs)) + +(define (standard . attrs) + (apply vcomponent 'STANDARD attrs)) + +(define (daylight . attrs) + (apply vcomponent 'DAYLIGHT attrs)) diff --git a/module/vcomponent/data-stores/caldav.scm b/module/vcomponent/data-stores/caldav.scm new file mode 100644 index 00000000..f9ba61c1 --- /dev/null +++ b/module/vcomponent/data-stores/caldav.scm @@ -0,0 +1,270 @@ +(define-module (vcomponent data-stores caldav) + ) + +(use-modules (srfi srfi-71) + (srfi srfi-88) + (rnrs bytevectors) + (rnrs io ports) + ((ice-9 binary-ports) :select (call-with-output-bytevector)) + (web request) + (web response) + (web client) + (web uri) + ;; (web http) ; + (sxml simple) + (oop goops) + (vcomponent data-stores common) + ((hnh util) :select (->)) + (web http dav) + ) + + + +(define-class <caldav-data-store> (<calendar-data-store>) + (host init-keyword: host: + getter: host) + (user init-keyword: user: + getter: user) + (calendar-path init-keyword: calendar-path: + accessor: calendar-path) + (password init-keyword: password: + getter: store-password)) + + +(define local-uri + (case-lambda ((this path) + (build-uri 'https + host: (host this) + path: path)) + ((this) + (build-uri 'https + host: (host this) + path: (calendar-path this))))) + + +(define* (make-caldav-store key: host user path password) + (define store + (make <caldav-data-store> + host: host + user: user + password: (string->symbol password) + calendar-path: path)) + + + (let* ((principal-path + (get-principal (local-uri store "/") + password: (store-password store))) + (calendar-home-set + (get-calendar-home-set (local-uri store principal-path) + password: (store-password store))) + (calendar-paths + (get-calendar-paths (local-uri store calendar-home-set) + password: (store-password store)))) + (set! (calendar-path store) + (car calendar-paths))) + + store) + +(define-method (write (this <caldav-data-store>) port) + (write `(make-caldav-store host: ,(host this) + user: ,(user this) + calendar-path: ,(calendar-path this) + password: ,(store-password this)) + port)) + +(define store + (make-caldav-store host: "dav.fruux.com" + user: "a3298201184" + password: "YjMyOTc0NjUwMDk6YXRhc3llanY2MGtu")) + +#; +(define-method (calendar-base (this <caldav-data-store>)) + (build-uri 'https + host: (host this) + path: (calendar-path this))) + + +;; (define-method (get-all (this <caldav-data-store>)) +;; ) + +(define-method (get-by-uid (this <caldav-data-store>) + (uid <string>)) + (let ((uids + (dav (local-uri this) + method: 'REPORT + authorization: `(Basic ,(store-password this)) + depth: 1 + body: + `(c:calendar-query + (@ (xmlns:c ,caldav)) + (d:prop (@ (xmlns:d "DAV:")) + (d:getetag) + #; (c:calendar-data) + ) + (c:filter + (c:comp-filter + (@ (name "VCALENDAR")) + (c:comp-filter + (@ (name "VEVENT")) + (c:prop-filter + (@ (name "UID")) + (c:text-match (@ (collation "i;octet")) + ,uid))))))))) + uids)) + + +(define-method (search (this <caldav-data-store>) + (filter <pair>)) + (let ((uids + (dav (local-uri this) + method: 'REPORT + authorization: `(Basic ,(store-password this)) + depth: 1 + body: + `(c:calendar-query + (@ (xmlns:c ,caldav)) + (d:prop (@ (xmlns:d "DAV:")) + (d:getetag) + (c:calendar-data + (c:comp (@ (name "VCALENDAR")) + (c:prop (@ (name "PRODID"))))) + #; (c:calendar-data) + ) + ,filter)))) + uids)) + +(define-method (search (this <caldav-data-store>) + (filter <string>) + (field <string>)) + (search store + `(c:filter + (c:comp-filter + (@ (name "VCALENDAR")) + (c:comp-filter + (@ (name "VEVENT")) + (c:prop-filter + (@ (name ,field)) + (c:text-match (@ (collation "i;octet")) + ,filter))))))) + + + +(define-method (list-calendars (this <caldav-data-store>)) + ) + + + + +(get-principal) ; => "/principals/uid/a3298201184/" + +(get-calendar-home-set "/principals/uid/a3298201184/") +;; => "/calendars/a3298201184/" + +(get-calendar-paths "/calendars/a3298201184/") +;; => ("/calendars/a3298201184/b85ba2e9-18aa-4451-91bb-b52da930e977/") + + + +(define user "a3298201184") +(define calendar "b85ba2e9-18aa-4451-91bb-b52da930e977") +(define password (string->symbol "YjMyOTc0NjUwMDk6YXRhc3llanY2MGtu")) +(define auth `(Basic ,password)) + + + + + + +(define uri + (build-uri 'https + host: "dav.fruux.com" + path: "/calendars/a3298201184/b85ba2e9-18aa-4451-91bb-b52da930e977/ff95c36c-6ae9-4aa0-b08f-c52d84bf4f26.ics")) + +(define-values (response body) + (dav uri + method: 'GET + authorization: auth)) + + + + +(define-values (response body) + (dav uri + method: 'PROPFIND + authorization: auth + body: + `(C:supported-collation-set (@ (xmlns:C ,caldav))))) + +(define-values (response body) + (dav uri + method: 'REPORT + authorization: auth + body: + `(C:calendar-query + (@ (xmlns:C ,caldav)) + (D:prop (@ (xmlns:D "DAV:")) + (D:getetac) + (C:calendar-data)) + (C:filter + (C:comp-filter (@ (name "VCALENDAR")) + (C:comp-filter (@ (name "VEVENT")) + (C:prop-filter (@ (name "UID")) + (C:text-match (@ (collation "i;utf-8")) + "Admittansen")))))))) + + + + + + +(define (add) + ;; add new event + (http-request 'PUT + path: "/path-on-server/<filename>.ics" + headers: + ((if-none-match "*") + (content-type "text/calendar")) + body: (ics:serialize event-with-wrapping-calendar) + )) + + +(define (get-by-time-range) + (http-request 'REPORT + path: "/calendar/<calendar-name>" + body: + ;; See RFC 4791 7.8.1 + `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (C:calendar-query + (@ (xmlns:D "DAV:") + (xmlns:C "urn:ietf:params:xml:ns:caldav")) + (D:prop + (D:getetag) + (C:calendar-data + (C:comp + (@ (name "VCALENDAR")) + (C:prop (@ (name "VERSION"))) + (C:prop (@ name "VEVENT") + (C:prop (@ (name "SUMMARY"))) + ...)))) + (C:filter + (C:comp-filter + (@ (name "VCALENDAR")) + (C:comp-filter + (@ (name "VEVENT")) + (C:time-range + (@ (start ,(datetime->string + start + "~Y~m~dT~H~M~S~Z")) + (end ,(datetime->string + end + "~Y~m~dT~H~M~S~Z"))))))))))) + + + + + +;; (use-modules (curl)) +;; (define c (curl-easy-init)) +;; (curl-easy-setopt c 'url "https://hornquist.se") + +;; (curl-easy-perform handle) diff --git a/module/vcomponent/data-stores/common.scm b/module/vcomponent/data-stores/common.scm new file mode 100644 index 00000000..2fb4422a --- /dev/null +++ b/module/vcomponent/data-stores/common.scm @@ -0,0 +1,43 @@ +(define-module (vcomponent data-stores common) + :use-module ((srfi srfi-88) :select ()) + :use-module (oop goops) + :export (<calendar-data-store> + ;; path + get-all + get-by-uid)) + + +(define-class <calendar-data-store> () + ;; (path init-keyword: path: + ;; getter: path) + ) + + +;;; In (calp server routes) + + + + +;;; Load - Load store into memero +;;; Dump - Save store into "disk" + + +(define-method (get-all (this <calendar-data-store>)) + (scm-error 'not-implemented "get-all" + "Get-all is not implemented for ~s" + (class-of this) + #f)) + +(define-method (get-by-uid (this <calendar-data-store>) (uid <string>)) + (scm-error 'not-implemented "get-by-uid" + "Get-by-uid is not implemented for ~s" + (class-of this) + #f)) + + +(define-method (color (this <calendar-data-store>)) + "") + + +(define-method (displayname (this <calendar-data-store>)) + "") diff --git a/module/vcomponent/data-stores/file.scm b/module/vcomponent/data-stores/file.scm new file mode 100644 index 00000000..54676224 --- /dev/null +++ b/module/vcomponent/data-stores/file.scm @@ -0,0 +1,32 @@ +(define-module (vcomponent data-stores file) + :use-module (oop goops) + :use-module ((srfi srfi-88) :select ()) + :use-module ((calp) :select (prodid)) + :use-module (vcomponent data-stores common) + :use-module ((vcomponent formats ical) :select (serialize deserialize)) + ) + +(define-class <file-data-store> (<calendar-data-store>) + (path getter: path + init-keyword: path:)) + +(define (make-file-store path) + (make <file-store> path: path)) + +(define-method (get-all (this <file-data-store>)) + ;; X-WR-CALNAME ⇒ NAME + ;; X-WR-CALDESC + (call-with-input-file (path this) + deserialize)) + +(define-method (get-by-uid (this <file-data-store>) (uid <string>)) + #f + ) + +(define-method (queue-write (this <file-data-store>) vcomponent) + ) + +(define-method (flush (this <file-data-store>)) + (with-atomic-output-to-file (path this) + (lambda () (serialize (data this) (current-output-port)))) + ) diff --git a/module/vcomponent/data-stores/meta.scm b/module/vcomponent/data-stores/meta.scm new file mode 100644 index 00000000..8ec5f7fd --- /dev/null +++ b/module/vcomponent/data-stores/meta.scm @@ -0,0 +1,29 @@ +;;; Commentary: +;;; A virtual data store which uses other data stores for its storage. +;;; Used to merge stores into larger stores +;;; Code: + +(define-module (vcomponent data-stores meta) + :use-module (oop goops) + :use-module (vcomponent data-stores common) + :use-module (srfi srfi-41) + :use-module ((srfi srfi-88) :select ()) + :export () + ) + +(define-class <meta-data-store> (<calendar-data-store>) + (stores accessor: stores + init-value: '() + init-keyword: stores:)) + + + +(define-method (get-all (this <meta-data-store>)) + (map get-all (stores this))) + +(define-method (get-by-uid (this <meta-data-store>) (uid <string>)) + (stream-car + (stream-append + (steam-map (lambda (store) (get-by-uid store uid)) + (list->stream (stores this))) + (stream #f)))) diff --git a/module/vcomponent/data-stores/sqlite.scm b/module/vcomponent/data-stores/sqlite.scm new file mode 100644 index 00000000..b5b566a8 --- /dev/null +++ b/module/vcomponent/data-stores/sqlite.scm @@ -0,0 +1,186 @@ +(define-module (vcomponent data-stores sqlite) + :use-module (oop goops) + :use-module (vcomponent data-stores common) + :use-module (srfi srfi-71) + :use-module ((srfi srfi-88) :select ()) + :use-module (vcomponent) + :use-module ((vcomponent formats ical) :prefix #{ical:}#) + :use-module ((hnh util) :select (aif)) + ) + + +(catch 'misc-error + (lambda () + (use-modules (sqlite3)) + (provide 'data-store-sqlite)) + (lambda args 'no-op)) + +;; (define (sqlite-exec db str) +;; (display str) +;; ((@ (sqlite3) sqlite-exec) db str)) + +(define-class <sqlite-data-store> (<calendar-data-store>) + (database accessor: database) + (name init-keyword: name: getter: calendar-name) + ) + +(define (initialize-database db) + ;;; Setup Content type + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS content_type +( id INTEGER PRIMARY KEY AUTOINCREMENT +, name TEXT NOT NULL +)") + + (let ((stmt (sqlite-prepare db " +INSERT OR IGNORE INTO content_type +( name ) VALUES ( ? )"))) + (for-each (lambda (content-type) + (sqlite-reset stmt) + (sqlite-bind-arguments stmt ) + (sqlite-step stmt)) + '("ical" + "xcal" + "jcal"))) + + ;;; Setup calendar + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS calendar +( id INTEGER PRIMARY KEY AUTOINCREMENT +, name TEXT NOT NULL +)") + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS calendar_properties +( id INTEGER PRIMARY KEY AUTOINCREMENT +, calendar INTEGER NOT NULL +, key TEXT NOT NULL +, value TEXT NOT NULL +, FOREIGN KEY (calendar) REFERENCES calendar(id) +)") + + ;; INSERT INTO calendar_properties (id, key, value) + ;; VALUES ( (SELECT id FROM calendar WHERE name = 'Calendar') + ;; , 'color' + ;; , '#1E90FF') + + ;;; Setup event + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS event +( uid TEXT PRIMARY KEY +, content_type INTEGER NOT NULL +, content TEXT NOT NULL +, calendar INTEGER NOT NULL +, FOREIGN KEY (content_type) REFERENCES content_type(id) +, FOREIGN KEY (calendar) REFERENCES calendar(id) +)") + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS event_instances +( id INTEGER PRIMARY KEY AUTOINCREMENT +, event TEXT NOT NULL +, start DATETIME NOT NULL +, end DATETIME +, FOREIGN KEY (event) REFERENCES event(uid) +)") + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS event_instances_valid_range +( start DATETIME NOT NULL +, end DATETIME NOT NULL +)") + ) + +(define-method (initialize (this <sqlite-data-store>) args) + (next-method) + (if (calendar-name this) + (set! (database this) (sqlite-open (path this))) + (let ((path db-name + (aif (string-rindex (path this) #\#) + (values (substring (path this) 0 it) + (substring (path this) (1+ it))) + (scm-error 'misc-error "(initialize <sqlite-data-store>)" + "Target calendar name not specified" + '() #f)))) + (set! (database this) (sqlite-open path)) + (slot-set! this 'name db-name))) + + (initialize-database (database this))) + + +(define-method (get-calendar (this <sqlite-data-store>)) + (let ((db (database this)) + (calendar (make-vcomponent 'VCALENDAR))) + (let ((stmt (sqlite-prepare db " +SELECT key, value FROM calendar_properties cp +LEFT JOIN calendar c ON cp.calendar = c.id +WHERE c.name = ? +"))) + (sqlite-bind-arguments stmt (calendar-name this)) + (sqlite-fold (lambda (row calendar) + (let ((key (vector-ref row 0)) + (value (vector-ref row 1))) + (set-property! calendar + (string->symbol key) + value)) + calendar) + calendar + stmt)) + + (let ((stmt (sqlite-prepare db " +SELECT content_type.name, content +FROM event +LEFT JOIN calendar ON event.calendar = calendar.id +LEFT JOIN content_type ON event.content_type = content_type.id +WHERE calendar.name = ? +"))) + (sqlite-bind-arguments stmt (calendar-name this)) + (sqlite-fold (lambda (row calendar) + (case (string->symbol (vector-ref row 0)) + ((ical) + (add-child! calendar + (call-with-input-string (vector-ref row 1) + ics:deserialize)) + calendar) + (else + (scm-error 'misc-error "(get-calendar <sqlite-data-store>)" + "Only iCal data supported, got ~a" + (list (vector-ref row 0)) #f) + )) + ) + calendar + stmt)) + + calendar)) + + +#; +(define-method (get-by-uid (this <sqlite-data-store>) (uid <string>)) + (let ((stmt (sqlite-prepare db " +SELECT name, content +FROM event +LEFT JOIN content_type ON event.content_type = content_type.id +WHERE event.uid = ?"))) + (sqlite-bind-arguments stmt uid) + (cond ((sqlite-step stmt) + => (lambda (record) + (case (string->symbol (vector-ref content 0)) + ((ics) + ;; TODO dispatch to higher instance + ) + (else + (scm-error 'value-error "get-by-uid" + "Can only deserialize ics (uid=~s)" + (list uid) #f))) + + )) + (else + ;; TODO possibly throw no-such-value + #f + )) + + ) + ) diff --git a/module/vcomponent/data-stores/vdir.scm b/module/vcomponent/data-stores/vdir.scm new file mode 100644 index 00000000..f0ed0fdc --- /dev/null +++ b/module/vcomponent/data-stores/vdir.scm @@ -0,0 +1,87 @@ +(define-module (vcomponent data-stores vdir) + :use-module (hnh util) + :use-module (oop goops) + :use-module (vcomponent data-stores common) + :use-module (srfi srfi-71) + :use-module ((srfi srfi-88) :select ()) + :use-module (hnh util path) + :use-module ((vcomponent formats ical) :select (serialize deserialize)) + :use-module ((ice-9 ftw) :select (scandir)) + :export ()) + +(define-class <vdir-data-store> (<calendar-data-store>) + (path getter: path + init-keyword: path:) + (loaded-calendar accessor: loaded-calendar + init-value: #f) + (uid-map accessor: uid-map + init-value: #f) + ) + +(define (make-vdir-store path) + (make <vdir-data-store> path: path)) + +(define* (get-attribute path key key: dflt) + (catch 'system-error + (lambda () (call-with-input-file (path-append path key) read-line)) + (const dflt))) + + +(define-method (get-all (this <vdir-data-store>)) + (let ((files (scandir (path this) (lambda (item) (string-ci=? "ics" (filename-extension item))))) + (calendar (make-vcomponent 'VCALENDAR))) + (set! (prop calendar 'NAME) (get-attribute (path this) "displayname") + (prop calendar 'COLOR) (get-attribute (path this) "color" "#FFFFFF")) + (for-each (lambda (item) (reparent! calendar item)) + (append-map (lambda (file) + (define cal + (call-with-input-file (path-append (path this) file) + deserialize)) + (unless (eq? 'VCALENDAR (type cal)) + (scm-error 'misc-error "get-all<vdir-data-store>" + "Unexpected top level component. Expected VCALENDAR, got ~a. In file ~s" + (list (type cal) file))) + (for-each (lambda (child) + (set! (prop child '-X-HNH-FILENAME) file)) + (children cal)) + ) + files)) + (set! (loaded-calendar this) calendar) + calendar)) + + +(define-method (get-by-uid (this <vdir-data-store>) (uid <string>)) + (unless (uid-map this) + (let ((cal + (or (loaded-calendar this) + (get-all this)))) + (define ht (make-hash-table)) + (for-each (lambda (ev) (hash-set! ht (uid ev) ev)) + (children cal)) + (set! (uid-map this) ht))) + (hash-ref m uid #f)) + + +(define (wrap-for-output . vcomponents) + (let ((calendar (make-vcomponent 'VCALENDAR))) + (set! (prop calendar 'VERSION) "2.0" + (prop calendar 'PRODID) (prodid) + (prop calendar 'CALSCALE) "GREGORIAN") + (for-each (lambda (vcomponent) (reparent! calendar vcomponent)) + vcomponents) + calendar)) + +(define-method (queue-write (this <vdir-data-store>) vcomponent) + ;; TODO Multiple components + (let ((filename + (cond ((prop vcomponent '-X-HNH-FILENAME) + => identity) + (else + (format #f "~a.ics" (prop vcomponent 'UID)))))) + (with-atomic-output-to-file (path-append (path this) filename) + (lambda () (serialize (wrap-for-output vcomponent) (current-output-port)))))) + +(define-method (flush (this <vdir-data-store>)) + (sync)) + +;; (define (get-in-date-interval )) diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm index 440ec5fd..a66ba38a 100644 --- a/module/vcomponent/datetime.scm +++ b/module/vcomponent/datetime.scm @@ -245,7 +245,7 @@ Event must have the DTSTART and DTEND protperty set." (prop component 'TZNAME) (zone-entry-format zone-entry) last-until (zone-entry-until zone-entry) last-offset new-timespec) - (add-child! vtimezone component)))] + (reparent! vtimezone component)))] [(zone-entry-rule zone-entry) => (lambda (rule-name) @@ -278,7 +278,7 @@ Event must have the DTSTART and DTEND protperty set." (awhen (rule->rrule rule) (set! (prop component 'RRULE) it)) - (add-child! vtimezone component))) + (reparent! vtimezone component))) ;; some of the rules might not apply to us since we only ;; started using that rule set later. It's also possible ;; that we stopped using a ruleset which continues existing. @@ -297,5 +297,5 @@ Event must have the DTSTART and DTEND protperty set." (prop component 'TZNAME) (zone-entry-format zone-entry) last-until (zone-entry-until zone-entry) last-offset (zone-entry-stdoff zone-entry)) - (add-child! vtimezone component))])) + (reparent! vtimezone component))])) vtimezone) diff --git a/module/vcomponent/datetime/output.scm b/module/vcomponent/datetime/output.scm index fb3d0478..1226fc44 100644 --- a/module/vcomponent/datetime/output.scm +++ b/module/vcomponent/datetime/output.scm @@ -17,27 +17,27 @@ ;; [FRR] ;; Part of the sentance "Repeated [every two weeks], except on ~a, ~a & ~a" ;; See everything tagged [FRR] - `(,(_ "Repeated ") + `(,(G_ "Repeated ") ,((@ (vcomponent recurrence display) format-recurrence-rule) (prop ev 'RRULE)) ,@(awhen (prop* ev 'EXDATE) (list ;; See [FRR] - (_ ", except on ") + (G_ ", except on ") (add-enumeration-punctuation (map (lambda (d) ;; TODO show year if different from current year (if (date? d) ;; [FRR] Exception date without time - (date->string d (_ "~e ~b")) + (date->string d (G_ "~e ~b")) ;; NOTE only show time when it's different than the start time? ;; or possibly only when FREQ is hourly or lower. (if (memv ((@ (vcomponent recurrence internal) freq) (prop ev 'RRULE)) '(HOURLY MINUTELY SECONDLY)) ;; [FRR] Exception date with time - (datetime->string d (_ "~e ~b ~k:~M")) + (datetime->string d (G_ "~e ~b ~k:~M")) ;; [FRR] Exception date without time - (datetime->string d (_ "~e ~b"))))) + (datetime->string d (G_ "~e ~b"))))) (map value it))))) ".")) @@ -52,7 +52,7 @@ ;; Warning message for failure to format description. ;; First argument is name of warning/error, ;; second is error arguments - (warning (_ "~a on formatting description, ~s") err args) + (warning (G_ "~a on formatting description, ~s") err args) str))) ;; Takes an event, and returns a pretty string for the time interval @@ -64,9 +64,9 @@ => (lambda (e) ;; start = end, only return one value (if (date= e (date+ s (date day: 1))) - (_ "~Y-~m-~d") - (values (_ "~Y-~m-~d") - (_ "~Y-~m-~d"))))] + (G_ "~Y-~m-~d") + (values (G_ "~Y-~m-~d") + (G_ "~Y-~m-~d"))))] ;; no end value, just return start [else (date->string s)]))] [else ; guaranteed datetime @@ -74,10 +74,10 @@ (e (prop ev 'DTEND))) (if e (let ((fmt-str (if (date= (datetime-date s) (datetime-date e)) - (_ "~H:~M") + (G_ "~H:~M") ;; Note the non-breaking space - (_ "~Y-~m-~d ~H:~M")))) + (G_ "~Y-~m-~d ~H:~M")))) (values fmt-str fmt-str)) ;; Note the non-breaking space - (_ "~Y-~m-~d ~H:~M")))])) + (G_ "~Y-~m-~d ~H:~M")))])) diff --git a/module/vcomponent/formats/common/types.scm b/module/vcomponent/formats/common/types.scm index a8a923da..fcb2b7b6 100644 --- a/module/vcomponent/formats/common/types.scm +++ b/module/vcomponent/formats/common/types.scm @@ -13,7 +13,7 @@ (define (parse-binary props value) ;; p 30 (unless (string=? "BASE64" (hashq-ref props 'ENCODING)) - (warning (_ "Binary field not marked ENCODING=BASE64"))) + (warning (G_ "Binary field not marked ENCODING=BASE64"))) ;; For icalendar no extra whitespace is allowed in a ;; binary field (except for line wrapping). This differs @@ -25,7 +25,7 @@ (cond [(string=? "TRUE" value) #t] [(string=? "FALSE" value) #f] - [else (warning (_ "~a invalid boolean") value)])) + [else (warning (G_ "~a invalid boolean") value)])) ;; CAL-ADDRESS ⇒ uri @@ -58,7 +58,7 @@ (define (parse-integer props value) (let ((n (string->number value))) (unless (integer? n) - (warning (_ "Non integer as integer"))) + (warning (G_ "Non integer as integer"))) n)) ;; PERIOD @@ -89,7 +89,7 @@ (case (cadr rem) [(#\n #\N) (loop (cddr rem) (cons #\newline str) done)] [(#\; #\, #\\) => (lambda (c) (loop (cddr rem) (cons c str) done))] - [else => (lambda (c) (warning (_ "Non-escapable character: ~a") c) + [else => (lambda (c) (warning (G_ "Non-escapable character: ~a") c) (loop (cddr rem) str done))])] [(#\,) (loop (cdr rem) '() (cons (reverse-list->string str) done))] @@ -138,5 +138,5 @@ (define (get-parser type) (or (hashq-ref type-parsers type #f) - (scm-error 'misc-error "get-parser" (_ "No parser for type ~a") + (scm-error 'misc-error "get-parser" (G_ "No parser for type ~a") (list type) #f))) diff --git a/module/vcomponent/formats/ical.scm b/module/vcomponent/formats/ical.scm new file mode 100644 index 00000000..dddca946 --- /dev/null +++ b/module/vcomponent/formats/ical.scm @@ -0,0 +1,17 @@ +(define-module (vcomponent formats ical) + :use-module ((vcomponent formats ical output) + :select (component->ical-string)) + :use-module ((vcomponent formats ical parse) + :select (parse-calendar)) + :export (serialize + deserialize + ) + ) + + +(define (serialize component port) + (with-output-to-port port + (lambda () (component->ical-string component)))) + +(define (deserialize port) + (parse-calendar port)) diff --git a/module/vcomponent/formats/ical/output.scm b/module/vcomponent/formats/ical/output.scm index da891fa6..57860d2a 100644 --- a/module/vcomponent/formats/ical/output.scm +++ b/module/vcomponent/formats/ical/output.scm @@ -16,6 +16,7 @@ :use-module (vcomponent geo) :use-module (vcomponent formats ical types) :use-module (vcomponent recurrence) + :use-module ((calp) :select (prodid)) :use-module (calp translation) :autoload (vcomponent util instance) (global-event-object) :export (component->ical-string @@ -24,10 +25,6 @@ print-events-in-interval )) -(define (prodid) - (format #f "-//hugo//calp ~a//EN" - (@ (calp) version))) - ;; Format value depending on key type. ;; Should NOT emit the key. @@ -96,7 +93,7 @@ (get-writer 'TEXT)] [else - (warning (_ "Unknown key ~a") key) + (warning (G_ "Unknown key ~a") key) (get-writer 'TEXT)])) (catch #t #; 'wrong-type-arg @@ -168,7 +165,9 @@ ;; If we have alternatives, splice them in here. (cond [(prop component '-X-HNH-ALTERNATIVES) - => (lambda (alts) (hash-map->list (lambda (_ comp) (component->ical-string comp)) + => (lambda (alts) (hash-map->list (lambda (_ comp) + (unless (eq? component comp) + (component->ical-string comp))) alts))])) diff --git a/module/vcomponent/formats/ical/parse.scm b/module/vcomponent/formats/ical/parse.scm index 49f8f101..f0a19ba5 100644 --- a/module/vcomponent/formats/ical/parse.scm +++ b/module/vcomponent/formats/ical/parse.scm @@ -14,6 +14,9 @@ :use-module (calp translation) :export (parse-calendar)) +;;; TODO a few translated strings here contain explicit newlines. Check if that +;;; is preserved through the translation. + (define string->symbol (let ((ht (make-hash-table 1000))) (lambda (str) @@ -124,7 +127,7 @@ (let ((vv (parser params value))) (when (list? vv) (scm-error 'parse-error "enum-parser" - (_ "List in enum field") + (G_ "List in enum field") #f #f)) (let ((v (string->symbol vv))) (unless (memv v enum) @@ -160,7 +163,7 @@ (lambda (params value) (let ((v ((get-parser 'TEXT) params value))) (unless (= 1 (length v)) - (warning (_ "List in non-list field: ~s") v)) + (warning (G_ "List in non-list field: ~s") v)) (string-join v ",")))] ;; TEXT, but allow a list @@ -198,7 +201,7 @@ [(memv key '(REQUEST-STATUS)) (scm-error 'parse-error "build-vline" - (_ "TODO Implement REQUEST-STATUS") + (G_ "TODO Implement REQUEST-STATUS") #f #f)] [(memv key '(ACTION)) @@ -233,7 +236,7 @@ (compose car (get-parser 'TEXT))] [else - (warning (_ "Unknown key ~a") key) + (warning (G_ "Unknown key ~a") key) (compose car (get-parser 'TEXT))]))) ;; If we produced a list create multiple VLINES from it. @@ -286,7 +289,7 @@ ;; ~? ;; source line ;; source file - (_ "WARNING parse error around ~a + (G_ "WARNING parse error around ~a ~? line ~a ~a~%") (get-string linedata) @@ -303,7 +306,7 @@ (if (null? (cdr stack)) ;; return (car stack) - (begin (add-child! (cadr stack) (car stack)) + (begin (reparent! (cadr stack) (car stack)) (cdr stack))))] [else (let ((key value params (parse-itemline head))) @@ -341,7 +344,7 @@ ;; ~? ;; source line ;; source file - (_ "ERROR parse error around ~a + (G_ "ERROR parse error around ~a ~? line ~a ~a Defaulting to string~%") diff --git a/module/vcomponent/formats/ical/types.scm b/module/vcomponent/formats/ical/types.scm index 7b6aad2e..768f5098 100644 --- a/module/vcomponent/formats/ical/types.scm +++ b/module/vcomponent/formats/ical/types.scm @@ -37,7 +37,7 @@ ;; TODO (define (write-period _ value) - (warning (_ "PERIOD writer not yet implemented")) + (warning (G_ "PERIOD writer not yet implemented")) (with-output-to-string (lambda () (write value)))) @@ -94,4 +94,4 @@ (define (get-writer type) (or (hashq-ref type-writers type #f) - (error (_ "No writer for type") type))) + (error (G_ "No writer for type") type))) diff --git a/module/vcomponent/formats/sxcal.scm b/module/vcomponent/formats/sxcal.scm new file mode 100644 index 00000000..c02dbada --- /dev/null +++ b/module/vcomponent/formats/sxcal.scm @@ -0,0 +1,16 @@ +(define-module (vcomponent formats sxcal) + :use-module ((vcomponent formats xcal parse) + :select (sxcal->vcomponent)) + :export (serialize deserialize) + ) + + +(define (serialize component port) + (write (serialize/object component) port)) + +(define (serialize/object component) + ;; TODO where is this defined? + (vcomponent->sxcal component)) + +(define (deserialize port) + (sxcal->vcomponent port)) diff --git a/module/vcomponent/formats/vdir/parse.scm b/module/vcomponent/formats/vdir/parse.scm index 46626402..8fe69fc6 100644 --- a/module/vcomponent/formats/vdir/parse.scm +++ b/module/vcomponent/formats/vdir/parse.scm @@ -64,9 +64,9 @@ ;; by RECURRENCE-ID. As far as I can tell this goes against ;; the standard. Section 3.8.4.4. (case (length events) - [(0) (warning (_ "No events in component~%~a") + [(0) (warning (G_ "No events in component~%~a") (prop item '-X-HNH-FILENAME))] - [(1) (add-child! calendar (car events))] + [(1) (reparent! calendar (car events))] ;; two or more [else @@ -108,7 +108,7 @@ ;; we need to filter duplicates either way. (map (extract 'RECURRENCE-ID) (cons head rest)) (cons head rest)))) - (add-child! calendar head))]) + (reparent! calendar head))]) ;; return calendar) diff --git a/module/vcomponent/formats/vdir/save-delete.scm b/module/vcomponent/formats/vdir/save-delete.scm index ac520463..d096405e 100644 --- a/module/vcomponent/formats/vdir/save-delete.scm +++ b/module/vcomponent/formats/vdir/save-delete.scm @@ -26,16 +26,16 @@ (unless calendar (scm-error 'wrong-type-arg "save-event" - (_ "Can only save events belonging to calendars, event uid = ~s") + (G_ "Can only save events belonging to calendars, event uid = ~s") (list (prop event 'UID)) #f)) (unless (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE)) (scm-error 'wrong-type-arg "save-event" (string-append - (_ "Can only save events belonging to vdir calendars.") + (G_ "Can only save events belonging to vdir calendars.") " " - (_ "Calendar is of type ~s")) + (G_ "Calendar is of type ~s")) (list (prop calendar '-X-HNH-SOURCETYPE)) #f)) @@ -55,10 +55,10 @@ (define calendar (parent event)) (unless (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE)) (scm-error 'wrong-type-arg "remove-event" - (string-append (_ "Can only remove events belonging to vdir calendars.") + (string-append (G_ "Can only remove events belonging to vdir calendars.") " " - (_ "Calendar is of type ~s")) + (G_ "Calendar is of type ~s")) (list (prop calendar '-X-HNH-SOURCETYPE)) #f)) (delete-file (prop event '-X-HNH-FILENAME)) - (remove-child! parent event)) + (abandon! parent event)) diff --git a/module/vcomponent/formats/xcal.scm b/module/vcomponent/formats/xcal.scm new file mode 100644 index 00000000..29a1d92f --- /dev/null +++ b/module/vcomponent/formats/xcal.scm @@ -0,0 +1,27 @@ +(define-module (vcomponent formats xcal) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) + :use-module ((vcomponent formats xcal output) + :select (vcomponent->sxcal ns-wrap)) + :use-module ((vcomponent formats xcal parse) + :select (sxcal->vcomponent)) + :use-module ((hnh util) :select (->)) + :export (serialize deserialize)) + + +(define* (serialize component port key: (namespaces '())) + (-> (vcomponent->sxcal component) + ns-wrap + (namespaced-sxml->xml port: port + namespaces: namespaces))) + +(define (serialize/object component) + (call-with-output-string (lambda (p) (serialize component p)))) + + +(define* (deserialize port) + (-> port + xml->namespaced-sxml + root-element ; Strip potential *TOP* + cadr ; Remove containing icalendar + sxcal->vcomponent)) diff --git a/module/vcomponent/formats/xcal/output.scm b/module/vcomponent/formats/xcal/output.scm index 87ebd32b..e4a84efb 100644 --- a/module/vcomponent/formats/xcal/output.scm +++ b/module/vcomponent/formats/xcal/output.scm @@ -8,6 +8,9 @@ :use-module (datetime) :use-module (srfi srfi-1) :use-module (calp translation) + :use-module (calp namespaces) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) :export (vcomponent->sxcal ns-wrap)) @@ -56,7 +59,7 @@ [(memv key '(GEO)) (lambda (_ v) - `(geo + `(,(xml xcal 'geo) (latitude ,(geo-latitude v)) (longitude ,(geo-longitude v))))] @@ -70,19 +73,20 @@ (get-writer 'TEXT)] [else - (warning (_ "Unknown key ~a") key) + (warning (G_ "Unknown key ~a") key) (get-writer 'TEXT)])) - (writer ((@@ (vcomponent base) get-vline-parameters) vline) (value vline))) + (writer ((@@ (vcomponent base) get-vline-parameters) vline) + (value vline))) (define (property->value-tag tag . values) (if (or (eq? tag 'VALUE) (internal-field? tag)) #f - `(,(downcase-symbol tag) + `(,(xml xcal (downcase-symbol tag)) ,@(map (lambda (v) ;; TODO parameter types!!!! (rfc6321 3.5.) - `(text ,(->string v))) + `(,(xml xcal 'text) ,(->string v))) values)))) ;; ((key value ...) ...) -> `(parameters , ... ) @@ -92,15 +96,14 @@ parameters)) (unless (null? outparams) - `(parameters ,@outparams))) + `(,(xml xcal 'parameters) ,@outparams))) (define (vcomponent->sxcal component) (define tagsymb (downcase-symbol (type component))) - (remove null? - `(,tagsymb + `(,(xml xcal tagsymb) ;; only have <properties> when it's non-empty. ,(let ((props (filter-map @@ -109,7 +112,7 @@ [(key vlines ...) (remove null? - `(,(downcase-symbol key) + `(,(xml xcal (downcase-symbol key)) ,(parameters-tag (reduce assq-merge '() (map parameters vlines))) ,@(for vline in vlines @@ -117,18 +120,22 @@ [(key . vline) (remove null? - `(,(downcase-symbol key) + `(,(xml xcal (downcase-symbol key)) ,(parameters-tag (parameters vline)) ,(vline->value-tag vline)))]) - (properties component)))) + ;; NOTE this sort is unnecesasary, but here so tests can work + ;; Possibly add it as a flag instead + (sort* (properties component) + string< (compose symbol->string car))))) (unless (null? props) - `(properties + `(,(xml xcal 'properties) ;; NOTE ;; (x-hnh-calendar-name (text ,(prop (parent component) 'NAME))) ,@props))) ,(unless (null? (children component)) - `(components ,@(map vcomponent->sxcal (children component))))))) + `(,(xml xcal 'components) + ,@(map vcomponent->sxcal (children component))))))) (define (ns-wrap sxml) - `(icalendar (@ (xmlns "urn:ietf:params:xml:ns:icalendar-2.0")) - ,sxml)) + `(,(xml xcal 'icalendar) + ,sxml)) diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm index 8537956a..7ed8c637 100644 --- a/module/vcomponent/formats/xcal/parse.scm +++ b/module/vcomponent/formats/xcal/parse.scm @@ -3,18 +3,23 @@ :use-module (hnh util exceptions) :use-module (base64) :use-module (ice-9 match) + :use-module (calp namespaces) + :use-module (sxml namespaced) + :use-module (sxml namespaced util) :use-module (sxml match) :use-module (vcomponent) :use-module (vcomponent geo) :use-module (vcomponent formats common types) :use-module (datetime) :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) :use-module (calp translation) :export (sxcal->vcomponent) ) ;; symbol, ht, (list a) -> non-list -(define (handle-value type props value) +(define (handle-value type parameters value) (case type [(binary) @@ -25,17 +30,17 @@ [(boolean) (string=? "true" (car value))] ;; TODO possibly trim whitespace on text fields - [(cal-address uri text unknown) (car value)] + [(cal-address uri text unknown) (string-concatenate value)] [(date) ;; TODO this is correct, but ensure remaining types - (hashq-set! props 'VALUE "DATE") + (hashq-set! parameters 'VALUE "DATE") (parse-iso-date (car value))] [(date-time) (parse-iso-datetime (car value))] [(duration) - ((get-parser 'DURATION) props value)] + ((get-parser 'DURATION) parameters value)] [(float integer) ; (3.0) (string->number (car value))] @@ -84,7 +89,7 @@ bymonth bysetpos) (string->number value)) (else (scm-error 'key-error "handle-value" - (_ "Invalid type ~a, with value ~a") + (G_ "Invalid type ~a, with value ~a") (list type value) #f)))))) @@ -96,35 +101,39 @@ (for key in '(bysecond byminute byhour byday bymonthday byyearday byweekno bymonth bysetpos freq until count interval wkst) - (define values (assoc-ref-all value key)) - (if (null? values) - #f - (case key - ;; These fields all have zero or one value - ((freq until count interval wkst) - (list (symbol->keyword key) - (parse-value-of-that-type - key (car (map car values))))) - ;; these fields take lists - ((bysecond byminute byhour byday bymonthday - byyearday byweekno bymonth bysetpos) - (list (symbol->keyword key) - (map (lambda (v) (parse-value-of-that-type key v)) - (map car values)))) - (else (scm-error 'misc-error "handle-value" - "Invalid key ~s" - (list key) - #f)))))))))] + (cond ((find-element (xml xcal key) value) + => (lambda (v) + (case key + ;; These fields all have zero or one value + ((freq until count interval wkst) + (list (symbol->keyword key) + (parse-value-of-that-type + key (cadr v)))) + ;; these fields take lists + ((bysecond byminute byhour byday bymonthday + byyearday byweekno bymonth bysetpos) + (list (symbol->keyword key) + (map (lambda (v) (parse-value-of-that-type key v)) + (cadr v)))) + (else (scm-error 'misc-error "handle-value" + "Invalid key ~s" + (list key) + #f))))) + (else #f)))))))] [(time) (parse-iso-time (car value))] - [(utc-offset) ((get-parser 'UTC-OFFSET) props (car value))] + [(utc-offset) ((get-parser 'UTC-OFFSET) parameters (car value))] [(geo) ; ((long 1) (lat 2)) (sxml-match (cons 'geo value) [(geo (latitude ,x) (longitude ,y)) - ((@ (vcomponent geo) make-geo) x y)])])) + ((@ (vcomponent geo) make-geo) x y)])] + + [else (scm-error 'misc-error "handle-value" + "Unknown value type: ~s" + (list type) #f)])) (define (symbol-upcase symb) (-> symb @@ -134,15 +143,20 @@ (define (handle-parameters parameters) + ;; (assert (element-matches? (xml xcal 'parameters) + ;; parameters)) + (define ht (make-hash-table)) - (for param in parameters - (match param - [(ptag (ptype pvalue ...) ...) - ;; TODO parameter type (rfc6321 3.5.) - ;; TODO multi-valued parameters!!! - (hashq-set! ht (symbol-upcase ptag) - (car (concatenate pvalue)))])) + (for param in (cdr parameters) + (define ptag (xml-element-tagname (car param))) + ;; (define-values (ptype pvalue) (car+cdr cdr)) + ;; TODO multi-valued parameters!!! + (define-values (pytpe pvalue) (car+cdr (cadr param))) + ;; TODO parameter type (rfc6321 3.5.) + ;; TODO namespaces + (hashq-set! ht (symbol-upcase ptag) + (concatenate pvalue))) ht) (define* (parse-enum str enum optional: (allow-other #t)) @@ -153,11 +167,12 @@ ;; symbol non-list -> non-list -(define (handle-tag tag-name data) +(define (handle-tag xml-tag data) + (define tag-name (xml-element-tagname xml-tag)) (case tag-name [(request-status) ;; TODO - (warning (_ "Request status not yet implemented")) + (warning (G_ "Request status not yet implemented")) #f] ((transp) (parse-enum @@ -174,6 +189,49 @@ data '(AUDIO DISPLAY EMAIL NONE))) [else data])) +(define (handle-single-property! component tree) + (define xml-tag (car tree)) + (define tag (xml-element-tagname xml-tag)) + (define tag* (symbol-upcase tag)) + + (define body (cdr tree)) + + ;; TODO request-status + (define-values (parameters data) + (if (element-matches? (xml xcal 'parameters) + (car body)) + (values (handle-parameters (car body)) + (cdr body)) + (values (make-hash-table) + body))) + + (for typetag in data + (define type (xml-element-tagname (car typetag))) + ;; TODO multi valued data + (define raw-value (cdr typetag)) + (define vline + (make-vline tag* (handle-tag + xml-tag + (let ((v (handle-value type parameters raw-value))) + ;; TODO possibly more list fields + ;; (if (eq? tag 'categories) + ;; (string-split v #\,) + ;; v) + + v)) + parameters)) + (if (memv tag* '(ATTACH ATTENDEE CATEGORIES + COMMENT CONTACT EXDATE + REQUEST-STATUS RELATED-TO + RESOURCES RDATE + ;; x-prop + ;; iana-prop + )) + (aif (prop* component tag*) + (set! (prop* component tag*) (cons vline it)) + (set! (prop* component tag*) (list vline))) + (set! (prop* component tag*) vline)))) + ;; Note ;; This doesn't verify the inter-field validity of the object, ;; meaning that value(DTSTART) == DATE and value(DTEND) == DATE-TIME @@ -181,83 +239,29 @@ ;; TODO ;; since we are feeding user input into this it really should be fixed. (define (sxcal->vcomponent sxcal) - (define type (symbol-upcase (car sxcal))) + + ;; TODO the surrounding icalendar element needs to be removed BEFORE this procedue is called + + (define xml-tag (car sxcal)) + (define type (symbol-upcase (xml-element-tagname xml-tag))) (define component (make-vcomponent type)) - (awhen (assoc-ref sxcal 'properties) + (awhen (find-element (xml xcal 'properties) (cdr sxcal)) ;; Loop over multi valued fields, creating one vline ;; for every value. So ;; KEY;p=1:a,b ;; would be expanded into ;; KEY;p=1:a ;; KEY;p=1:b - (for property in it - (match property - ;; TODO request-status - - [(tag ('parameters parameters ...) - (type value ...) ...) - (let ((params (handle-parameters parameters)) - (tag* (symbol-upcase tag))) - (for (type value) in (zip type value) - ;; ignore empty fields - ;; mostly for <text/> - (unless (null? value) - (let () - (define vline - (make-vline tag* - (handle-tag - tag (handle-value type params value)) - params)) - (if (memv tag* '(ATTACH ATTENDEE CATEGORIES - COMMENT CONTACT EXDATE - REQUEST-STATUS RELATED-TO - RESOURCES RDATE - ;; x-prop - ;; iana-prop - )) - (aif (prop* component tag*) - (set! (prop* component tag*) (cons vline it)) - (set! (prop* component tag*) (list vline))) - ;; else - (set! (prop* component tag*) vline)) - ))))] - - [(tag (type value ...) ...) - (for (type value) in (zip type value) - ;; ignore empty fields - ;; mostly for <text/> - (unless (null? value) - (let ((params (make-hash-table)) - (tag* (symbol-upcase tag))) - (define vline - (make-vline tag* - (handle-tag - tag (let ((v (handle-value type params value))) - ;; TODO possibly more list fields - (if (eq? tag 'categories) - (string-split v #\,) - v))) - params)) - ;; - - (if (memv tag* '(ATTACH ATTENDEE CATEGORIES - COMMENT CONTACT EXDATE - REQUEST-STATUS RELATED-TO - RESOURCES RDATE - ;; x-prop - ;; iana-prop - )) - (aif (prop* component tag*) - (set! (prop* component tag*) (cons vline it)) - (set! (prop* component tag*) (list vline))) - ;; else - (set! (prop* component tag*) vline)) - )))]))) + (map (lambda (x) (handle-single-property! component x)) + (cdr it))) ;; children - (awhen (assoc-ref sxcal 'components) - (for child in (map sxcal->vcomponent it) - (add-child! component child))) + (awhen (find-element (xml xcal 'components) (cdr sxcal)) + ;; NOTE Order of children is insignificant, but this allows + ;; diffs to be stable (which is used by the format tests). + (for child in (map sxcal->vcomponent + (reverse (cdr it))) + (reparent! component child))) component) diff --git a/module/vcomponent/formats/xcal/types.scm b/module/vcomponent/formats/xcal/types.scm index a88b6b04..82121d5e 100644 --- a/module/vcomponent/formats/xcal/types.scm +++ b/module/vcomponent/formats/xcal/types.scm @@ -3,16 +3,18 @@ :use-module (vcomponent formats ical types) :use-module (datetime) :use-module (calp translation) + :use-module ((calp namespaces) :select (xcal)) + :use-module ((sxml namespaced) :select (xml)) :export (get-writer)) (define (write-boolean _ v) - `(boolean ,(if v "true" "false"))) + `(,(xml xcal 'boolean) ,(if v "true" "false"))) (define (write-date _ v) - `(date ,(date->string v "~Y-~m-~d"))) + `(,(xml xcal 'date) ,(date->string v "~Y-~m-~d"))) (define (write-datetime p v) - `(date-time + `(,(xml xcal 'date-time) ,(datetime->string (hashq-ref p '-X-HNH-ORIGINAL v) ;; 'Z' should be included for UTC, @@ -21,17 +23,17 @@ "~Y-~m-~dT~H:~M:~S~Z"))) (define (write-time _ v) - `(time ,(time->string v "~H:~M:S"))) + `(,(xml xcal 'time) ,(time->string v "~H:~M:S"))) (define (write-recur _ v) - `(recur ,@((@@ (vcomponent recurrence internal) recur-rule->rrule-sxml) v))) + `(,(xml xcal 'recur) ,@((@@ (vcomponent recurrence internal) recur-rule->rrule-sxml) v))) ;; sepparate since this text shouldn't be escaped (define (write-text _ v) ;; TODO out type should be xsd:string. ;; Look into what that means, and escape ;; from there - `(text ,v)) + `(,(xml xcal 'text) ,v)) @@ -40,7 +42,7 @@ #| TODO PERIOD |# URI UTC-OFFSET) (hashq-set! sxml-writers simple-type (lambda (p v) - `(,(downcase-symbol simple-type) + `(,(xml xcal (downcase-symbol simple-type)) ,(((@ (vcomponent formats ical types) get-writer) simple-type) p v))))) (hashq-set! sxml-writers 'BOOLEAN write-boolean) @@ -52,4 +54,4 @@ (define (get-writer type) (or (hashq-ref sxml-writers type #f) - (error (_ "No writer for type") type))) + (error (G_ "No writer for type") type))) diff --git a/module/vcomponent/recurrence/display/en.scm b/module/vcomponent/recurrence/display/en.scm index c711a75c..18d11dba 100644 --- a/module/vcomponent/recurrence/display/en.scm +++ b/module/vcomponent/recurrence/display/en.scm @@ -26,13 +26,13 @@ (list "every " (add-enumeration-punctuation (map (lambda (d) (list (week-day-name (cdr d)))) - (cadr group) + (cdr group) )))] [else (list (number->string-ordinal (car group)) " " (add-enumeration-punctuation (map (lambda (d) (list (week-day-name (cdr d)) "en")) - (cadr group))))]) + (cdr group))))]) ) groups)))) diff --git a/module/vcomponent/recurrence/display/sv.scm b/module/vcomponent/recurrence/display/sv.scm index 2bd70657..ee8fc3fd 100644 --- a/module/vcomponent/recurrence/display/sv.scm +++ b/module/vcomponent/recurrence/display/sv.scm @@ -31,7 +31,7 @@ (list "varje " (add-enumeration-punctuation (map (lambda (d) (list (week-day-name (cdr d)))) - (cadr group) + (cdr group) )))] [else (list (number->string-ordinal @@ -40,7 +40,7 @@ " " (add-enumeration-punctuation (map (lambda (d) (list (week-day-name (cdr d)) "en")) - (cadr group))))]) + (cdr group))))]) ) groups)))) diff --git a/module/vcomponent/recurrence/internal.scm b/module/vcomponent/recurrence/internal.scm index 94c4cccf..9bf425ac 100644 --- a/module/vcomponent/recurrence/internal.scm +++ b/module/vcomponent/recurrence/internal.scm @@ -79,9 +79,18 @@ ;; to prevent creation of invalid rules. ;; This was made apparent when wkst was (incorrectly) set to MO, ;; which later crashed generate-recurrence-set. - (make-recur-rule% freq until count interval bysecond byminute byhour - byday bymonthday byyearday byweekno bymonth bysetpos - wkst)) + + ;; Allow `(cons #f day)' to be written as just `day'. + (let ((byday* (if byday + (map (lambda (day) + (if (number? day) + (cons #f day) + day)) + byday) + #f))) + (make-recur-rule% freq until count interval bysecond byminute byhour + byday* bymonthday byyearday byweekno bymonth bysetpos + wkst))) ;; only print fields with actual values. (set-record-type-printer! diff --git a/module/vcomponent/util/instance.scm b/module/vcomponent/util/instance.scm index a18085eb..2310c5bc 100644 --- a/module/vcomponent/util/instance.scm +++ b/module/vcomponent/util/instance.scm @@ -1,4 +1,5 @@ (define-module (vcomponent util instance) + :use-module (srfi srfi-88) :use-module (hnh util) :use-module (calp translation) :use-module ((vcomponent util instance methods) :select (make-instance)) @@ -14,6 +15,6 @@ (define-once global-event-object (make-instance ((@ (vcomponent config) calendar-files)))) -(define (reload) - (begin (set! global-event-object (make-instance ((@ (vcomponent config) calendar-files)))) - (format (current-error-port) (_ "Reload done~%")))) +(define* (reload optional: (files ((@ (vcomponent config) calendar-files)))) + (begin (set! global-event-object (make-instance files)) + (format (current-error-port) (G_ "Reload done~%")))) diff --git a/module/vcomponent/util/instance/methods.scm b/module/vcomponent/util/instance/methods.scm index 193a0304..fef83958 100644 --- a/module/vcomponent/util/instance/methods.scm +++ b/module/vcomponent/util/instance/methods.scm @@ -80,7 +80,7 @@ (define-method (initialize (this <events>) args) (next-method) - (format (current-error-port) (_ "Building <events> from~%")) + (format (current-error-port) (G_ "Building <events> from~%")) (for calendar in (slot-ref this 'calendar-files) (format (current-error-port) " - ~a~%" calendar)) @@ -96,7 +96,7 @@ type (concatenate (map children (slot-ref this 'calendars))))) (events (awhen (assoc-ref groups 'VEVENT) - (car it))) + it)) (removed remaining (partition (extract 'X-HNH-REMOVED) events))) ;; TODO figure out what to do with removed events @@ -125,7 +125,7 @@ ;;; with the same UID, which is BAD. (define-method (add-event (this <events>) calendar event) - (add-child! calendar event) + (reparent! calendar event) (unless (prop event 'UID) (set! (prop event 'UID) (uuid))) @@ -174,13 +174,17 @@ (define-method (add-and-save-event (this <events>) calendar event) + + ((@ (vcomponent validate) validate-event) event) + (cond [(get-event-by-uid this (prop event 'UID)) => (lambda (old-event) + (define old-calendar (parent old-event)) ;; remove old instance of event from runtime (remove-event this old-event) - (remove-child! (parent old-event) old-event) + (abandon! old-calendar old-event) ;; Add new event to runtime, ;; MUST be done after since the two events SHOULD share UID. @@ -196,13 +200,13 @@ ;; save-event sets -X-HNH-FILENAME from the UID. This is fine ;; since the two events are guaranteed to have the same UID. (unless ((@ (vcomponent formats vdir save-delete) save-event) event) - (throw 'misc-error (_ "Saving event to disk failed."))) - + (throw 'misc-error (G_ "Saving event to disk failed."))) - (unless (eq? calendar (parent old-event)) + #; + (unless (eq? calendar old-calendar) ;; change to a new calendar (format (current-error-port) - (_ "Unlinking old event from ~a~%") + (G_ "Unlinking old event from ~a~%") (prop old-event '-X-HNH-FILENAME)) ;; NOTE that this may fail, leading to a duplicate event being ;; created (since we save beforehand). This is just a minor problem @@ -212,7 +216,9 @@ (format (current-error-port) - (_ "Event updated ~a~%") (prop event 'UID)))] + (G_ "Event ~a updated in ~a~%") + (prop event 'UID) + (prop calendar 'NAME)))] [else (add-event this calendar event) @@ -222,7 +228,9 @@ ;; NOTE Posibly defer save to a later point. ;; That would allow better asyncronous preformance. (unless ((@ (vcomponent formats vdir save-delete) save-event) event) - (throw 'misc-error (_ "Saving event to disk failed."))) + (throw 'misc-error (G_ "Saving event to disk failed."))) (format (current-error-port) - (_ "Event inserted ~a~%") (prop event 'UID))])) + (G_ "Event ~a added to ~a~%") + (prop event 'UID) + (prop calendar 'NAME))])) diff --git a/module/vcomponent/util/parse-cal-path.scm b/module/vcomponent/util/parse-cal-path.scm index cf03db88..fe3a6b7d 100644 --- a/module/vcomponent/util/parse-cal-path.scm +++ b/module/vcomponent/util/parse-cal-path.scm @@ -1,3 +1,5 @@ +;;; TODO remove this module, it should be part of the vdir interface + (define-module (vcomponent util parse-cal-path) :use-module (hnh util) :use-module ((calp util time) :select (report-time!)) @@ -21,14 +23,14 @@ (set! (prop comp '-X-HNH-SOURCETYPE) 'file) comp) ] [(directory) - (report-time! (_ "Parsing ~a") path) + (report-time! (G_ "Parsing ~a") path) (let ((comp (parse-vdir path))) (set! (prop comp '-X-HNH-SOURCETYPE) 'vdir (prop comp '-X-HNH-DIRECTORY) path) comp)] [(block-special char-special fifo socket unknown symlink) => (lambda (t) (scm-error 'misc-error "parse-cal-path" - (_ "Can't parse file of type ~s") + (G_ "Can't parse file of type ~s") (list t) #f))])) diff --git a/module/vcomponent/validate.scm b/module/vcomponent/validate.scm new file mode 100644 index 00000000..8881c95f --- /dev/null +++ b/module/vcomponent/validate.scm @@ -0,0 +1,16 @@ +(define-module (vcomponent validate) + :use-module (vcomponent) + :use-module (datetime) + :use-module ((hnh util exceptions) + :select (warning)) + :use-module (calp translation) + :export (validate-event)) + +(define (validate-event component) + (unless (date/-time<= + (prop component 'DTSTART) + (prop component 'DTEND)) + (warning (G_ "end (~a) must be equal to or greater than start (~a)") + (prop component 'DTEND) + (prop component 'DTSTART))) + ) diff --git a/module/web/http.scm b/module/web/http.scm new file mode 100644 index 00000000..62a462d3 --- /dev/null +++ b/module/web/http.scm @@ -0,0 +1,2081 @@ +;;; HTTP messages + +;; Copyright (C) 2010-2017 Free Software Foundation, Inc. + +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library 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 +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;; Copyright (C) 2023 Hugo Hörnquist. + +;;; Commentary: +;;; +;;; This module has a number of routines to parse textual +;;; representations of HTTP data into native Scheme data structures. +;;; +;;; It tries to follow RFCs fairly strictly---the road to perdition +;;; being paved with compatibility hacks---though some allowances are +;;; made for not-too-divergent texts (like a quality of .2 which should +;;; be 0.2, etc). +;;; +;;; Code: + +(define-module (web http) + #:use-module ((srfi srfi-1) #:select (append-map! map! find)) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-19) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 match) + #:use-module (ice-9 q) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 textual-ports) + #:use-module (ice-9 exceptions) + #:use-module (rnrs bytevectors) + #:use-module (web uri) + #:export (string->header + header->string + + declare-header! + declare-opaque-header! + known-header? + header-parser + header-validator + header-writer + + read-header + parse-header + valid-header? + write-header + + read-headers + write-headers + + declare-method! + parse-http-method + parse-http-version + parse-request-uri + + read-request-line + write-request-line + read-response-line + write-response-line + + &chunked-input-error-prematurely + chunked-input-ended-prematurely-error? + make-chunked-input-port + make-chunked-output-port + + http-proxy-port? + set-http-proxy-port?!)) + + +(define (put-symbol port sym) + (put-string port (symbol->string sym))) + +(define (put-non-negative-integer port i) + (put-string port (number->string i))) + +(define (string->header name) + "Parse NAME to a symbolic header name." + (string->symbol (string-downcase name))) + +(define-record-type <header-decl> + (make-header-decl name parser validator writer multiple?) + header-decl? + (name header-decl-name) + (parser header-decl-parser) + (validator header-decl-validator) + (writer header-decl-writer) + (multiple? header-decl-multiple?)) + +;; sym -> header +(define *declared-headers* (make-hash-table)) + +(define (lookup-header-decl sym) + (hashq-ref *declared-headers* sym)) + +(define* (declare-header! name + parser + validator + writer + #:key multiple?) + "Declare a parser, validator, and writer for a given header." + (unless (and (string? name) parser validator writer) + (error "bad header decl" name parser validator writer multiple?)) + (let ((decl (make-header-decl name parser validator writer multiple?))) + (hashq-set! *declared-headers* (string->header name) decl) + decl)) + +(define (header->string sym) + "Return the string form for the header named SYM." + (let ((decl (lookup-header-decl sym))) + (if decl + (header-decl-name decl) + (string-titlecase (symbol->string sym))))) + +(define (known-header? sym) + "Return ‘#t’ iff SYM is a known header, with associated +parsers and serialization procedures." + (and (lookup-header-decl sym) #t)) + +(define (header-parser sym) + "Return the value parser for headers named SYM. The result is a +procedure that takes one argument, a string, and returns the parsed +value. If the header isn't known to Guile, a default parser is returned +that passes through the string unchanged." + (let ((decl (lookup-header-decl sym))) + (if decl + (header-decl-parser decl) + (lambda (x) x)))) + +(define (header-validator sym) + "Return a predicate which returns ‘#t’ if the given value is valid +for headers named SYM. The default validator for unknown headers +is ‘string?’." + (let ((decl (lookup-header-decl sym))) + (if decl + (header-decl-validator decl) + string?))) + +(define (header-writer sym) + "Return a procedure that writes values for headers named SYM to a +port. The resulting procedure takes two arguments: a value and a port. +The default writer will call ‘put-string’." + (let ((decl (lookup-header-decl sym))) + (if decl + (header-decl-writer decl) + (lambda (val port) + (put-string port val))))) + +(define (read-header-line port) + "Read an HTTP header line and return it without its final CRLF or LF. +Raise a 'bad-header' exception if the line does not end in CRLF or LF, +or if EOF is reached." + (match (%read-line port) + (((? string? line) . #\newline) + ;; '%read-line' does not consider #\return a delimiter; so if it's + ;; there, remove it. We are more tolerant than the RFC in that we + ;; tolerate LF-only endings. + (if (string-suffix? "\r" line) + (string-drop-right line 1) + line)) + ((line . _) ;EOF or missing delimiter + (bad-header 'read-header-line line)))) + +(define (read-continuation-line port val) + (match (peek-char port) + ((or #\space #\tab) + (read-continuation-line port + (string-append val (read-header-line port)))) + (_ val))) + +(define *eof* (call-with-input-string "" read)) + +(define (read-header port) + "Read one HTTP header from PORT. Return two values: the header +name and the parsed Scheme value. May raise an exception if the header +was known but the value was invalid. + +Returns the end-of-file object for both values if the end of the message +body was reached (i.e., a blank line)." + (let ((line (read-header-line port))) + (if (or (string-null? line) + (string=? line "\r")) + (values *eof* *eof*) + (let* ((delim (or (string-index line #\:) + (bad-header '%read line))) + (sym (string->header (substring line 0 delim)))) + (values + sym + (parse-header + sym + (read-continuation-line + port + (string-trim-both line char-set:whitespace (1+ delim))))))))) + +(define (parse-header sym val) + "Parse VAL, a string, with the parser registered for the header +named SYM. Returns the parsed value." + ((header-parser sym) val)) + +(define (valid-header? sym val) + "Returns a true value iff VAL is a valid Scheme value for the +header with name SYM." + (unless (symbol? sym) + (error "header name not a symbol" sym)) + ((header-validator sym) val)) + +(define (write-header sym val port) + "Write the given header name and value to PORT, using the writer +from ‘header-writer’." + (put-string port (header->string sym)) + (put-string port ": ") + ((header-writer sym) val port) + (put-string port "\r\n")) + +(define (read-headers port) + "Read the headers of an HTTP message from PORT, returning them +as an ordered alist." + (let lp ((headers '())) + (call-with-values (lambda () (read-header port)) + (lambda (k v) + (if (eof-object? k) + (reverse! headers) + (lp (acons k v headers))))))) + +(define (write-headers headers port) + "Write the given header alist to PORT. Doesn't write the final +‘\\r\\n’, as the user might want to add another header." + (let lp ((headers headers)) + (match headers + (((k . v) . headers) + (write-header k v port) + (lp headers)) + (() + (values))))) + + + + +;;; +;;; Utilities +;;; + +(define (bad-header sym val) + (throw 'bad-header sym val)) +(define (bad-header-component sym val) + (throw 'bad-header-component sym val)) + +(define (bad-header-printer port key args default-printer) + (apply (case-lambda + ((sym val) + (format port "Bad ~a header: ~a\n" (header->string sym) val)) + (_ (default-printer))) + args)) +(define (bad-header-component-printer port key args default-printer) + (apply (case-lambda + ((sym val) + (format port "Bad ~a header component: ~a\n" sym val)) + (_ (default-printer))) + args)) +(set-exception-printer! 'bad-header bad-header-printer) +(set-exception-printer! 'bad-header-component bad-header-component-printer) + +(define (parse-opaque-string str) + str) +(define (validate-opaque-string val) + (string? val)) +(define (write-opaque-string val port) + (put-string port val)) + +(define separators-without-slash + (string->char-set "[^][()<>@,;:\\\"?= \t]")) +(define (validate-media-type str) + (let ((idx (string-index str #\/))) + (and idx (= idx (string-rindex str #\/)) + (not (string-index str separators-without-slash))))) +(define (parse-media-type str) + (unless (validate-media-type str) + (bad-header-component 'media-type str)) + (string->symbol str)) + +(define* (skip-whitespace str #:optional (start 0) (end (string-length str))) + (let lp ((i start)) + (if (and (< i end) (char-whitespace? (string-ref str i))) + (lp (1+ i)) + i))) + +(define* (trim-whitespace str #:optional (start 0) (end (string-length str))) + (let lp ((i end)) + (if (and (< start i) (char-whitespace? (string-ref str (1- i)))) + (lp (1- i)) + i))) + +(define* (split-and-trim str #:optional (delim #\,) + (start 0) (end (string-length str))) + (let lp ((i start)) + (if (< i end) + (let* ((idx (string-index str delim i end)) + (tok (string-trim-both str char-set:whitespace i (or idx end)))) + (cons tok (split-and-trim str delim (if idx (1+ idx) end) end))) + '()))) + +(define (list-of-strings? val) + (list-of? val string?)) + +(define (write-list-of-strings val port) + (put-list port val put-string ", ")) + +(define (split-header-names str) + (map string->header (split-and-trim str))) + +(define (list-of-header-names? val) + (list-of? val symbol?)) + +(define (write-header-list val port) + (put-list port val + (lambda (port x) + (put-string port (header->string x))) + ", ")) + +(define (collect-escaped-string from start len escapes) + (let ((to (make-string len))) + (let lp ((start start) (i 0) (escapes escapes)) + (match escapes + (() + (substring-move! from start (+ start (- len i)) to i) + to) + ((e . escapes) + (let ((next-start (+ start (- e i) 2))) + (substring-move! from start (- next-start 2) to i) + (string-set! to e (string-ref from (- next-start 1))) + (lp next-start (1+ e) escapes))))))) + +;; in incremental mode, returns two values: the string, and the index at +;; which the string ended +(define* (parse-qstring str #:optional + (start 0) (end (trim-whitespace str start)) + #:key incremental?) + (unless (and (< start end) (eqv? (string-ref str start) #\")) + (bad-header-component 'qstring str)) + (let lp ((i (1+ start)) (qi 0) (escapes '())) + (if (< i end) + (case (string-ref str i) + ((#\\) + (lp (+ i 2) (1+ qi) (cons qi escapes))) + ((#\") + (let ((out (collect-escaped-string str (1+ start) qi escapes))) + (cond + (incremental? (values out (1+ i))) + ((= (1+ i) end) out) + (else (bad-header-component 'qstring str))))) + (else + (lp (1+ i) (1+ qi) escapes))) + (bad-header-component 'qstring str)))) + +(define (put-list port items put-item delim) + (match items + (() (values)) + ((item . items) + (put-item port item) + (let lp ((items items)) + (match items + (() (values)) + ((item . items) + (put-string port delim) + (put-item port item) + (lp items))))))) + +(define (write-qstring str port) + (put-char port #\") + (if (string-index str #\") + ;; optimize me + (put-list port (string-split str #\") put-string "\\\"") + (put-string port str)) + (put-char port #\")) + +(define* (parse-quality str #:optional (start 0) (end (string-length str))) + (define (char->decimal c) + (let ((i (- (char->integer c) (char->integer #\0)))) + (unless (and (<= 0 i) (< i 10)) + (bad-header-component 'quality str)) + i)) + (cond + ((not (< start end)) + (bad-header-component 'quality str)) + ((eqv? (string-ref str start) #\1) + (unless (or (string= str "1" start end) + (string= str "1." start end) + (string= str "1.0" start end) + (string= str "1.00" start end) + (string= str "1.000" start end)) + (bad-header-component 'quality str)) + 1000) + ((eqv? (string-ref str start) #\0) + (if (or (string= str "0" start end) + (string= str "0." start end)) + 0 + (if (< 2 (- end start) 6) + (let lp ((place 1) (i (+ start 4)) (q 0)) + (if (= i (1+ start)) + (if (eqv? (string-ref str (1+ start)) #\.) + q + (bad-header-component 'quality str)) + (lp (* 10 place) (1- i) + (if (< i end) + (+ q (* place (char->decimal (string-ref str i)))) + q)))) + (bad-header-component 'quality str)))) + ;; Allow the nonstandard .2 instead of 0.2. + ((and (eqv? (string-ref str start) #\.) + (< 1 (- end start) 5)) + (let lp ((place 1) (i (+ start 3)) (q 0)) + (if (= i start) + q + (lp (* 10 place) (1- i) + (if (< i end) + (+ q (* place (char->decimal (string-ref str i)))) + q))))) + (else + (bad-header-component 'quality str)))) + +(define (valid-quality? q) + (and (non-negative-integer? q) (<= q 1000))) + +(define (write-quality q port) + (define (digit->char d) + (integer->char (+ (char->integer #\0) d))) + (put-char port (digit->char (modulo (quotient q 1000) 10))) + (put-char port #\.) + (put-char port (digit->char (modulo (quotient q 100) 10))) + (put-char port (digit->char (modulo (quotient q 10) 10))) + (put-char port (digit->char (modulo q 10)))) + +(define (list-of? val pred) + (match val + (((? pred) ...) #t) + (_ #f))) + +(define* (parse-quality-list str) + (map (lambda (part) + (cond + ((string-rindex part #\;) + => (lambda (idx) + (let ((qpart (string-trim-both part char-set:whitespace (1+ idx)))) + (unless (string-prefix? "q=" qpart) + (bad-header-component 'quality qpart)) + (cons (parse-quality qpart 2) + (string-trim-both part char-set:whitespace 0 idx))))) + (else + (cons 1000 (string-trim-both part char-set:whitespace))))) + (string-split str #\,))) + +(define (validate-quality-list l) + (match l + ((((? valid-quality?) . (? string?)) ...) #t) + (_ #f))) + +(define (write-quality-list l port) + (put-list port l + (lambda (port x) + (let ((q (car x)) + (str (cdr x))) + (put-string port str) + (when (< q 1000) + (put-string port ";q=") + (write-quality q port)))) + ",")) + +(define* (parse-non-negative-integer val #:optional (start 0) + (end (string-length val))) + (define (char->decimal c) + (let ((i (- (char->integer c) (char->integer #\0)))) + (unless (and (<= 0 i) (< i 10)) + (bad-header-component 'non-negative-integer val)) + i)) + (unless (< start end) + (bad-header-component 'non-negative-integer val)) + (let lp ((i start) (out 0)) + (if (< i end) + (lp (1+ i) + (+ (* out 10) (char->decimal (string-ref val i)))) + out))) + +(define (non-negative-integer? code) + (and (number? code) (>= code 0) (exact? code) (integer? code))) + +(define (default-val-parser k val) + val) + +(define (default-val-validator k val) + (or (not val) (string? val))) + +(define (default-val-writer k val port) + (if (or (string-index val #\;) + (string-index val #\,) + (string-index val #\")) + (write-qstring val port) + (put-string port val))) + +(define* (parse-key-value-list str #:optional + (val-parser default-val-parser) + (start 0) (end (string-length str))) + (let lp ((i start)) + (if (not (< i end)) + '() + (let* ((i (skip-whitespace str i end)) + (eq (string-index str #\= i end)) + (comma (string-index str #\, i end)) + (delim (min (or eq end) (or comma end))) + (k (string->symbol + (substring str i (trim-whitespace str i delim))))) + (call-with-values + (lambda () + (if (and eq (or (not comma) (< eq comma))) + (let ((i (skip-whitespace str (1+ eq) end))) + (if (and (< i end) (eqv? (string-ref str i) #\")) + (parse-qstring str i end #:incremental? #t) + (values (substring str i + (trim-whitespace str i + (or comma end))) + (or comma end)))) + (values #f delim))) + (lambda (v-str next-i) + (let ((v (val-parser k v-str)) + (i (skip-whitespace str next-i end))) + (unless (or (= i end) (eqv? (string-ref str i) #\,)) + (bad-header-component 'key-value-list + (substring str start end))) + (cons (if v (cons k v) k) + (lp (1+ i)))))))))) + +(define* (key-value-list? list #:optional + (valid? default-val-validator)) + (list-of? list + (lambda (elt) + (match elt + (((? symbol? k) . v) (valid? k v)) + ((? symbol? k) (valid? k #f)) + (_ #f))))) + +(define* (write-key-value-list list port #:optional + (val-writer default-val-writer) (delim ", ")) + (put-list + port list + (lambda (port x) + (match x + ((k . #f) + (put-symbol port k)) + ((k . v) + (put-symbol port k) + (put-char port #\=) + (val-writer k v port)) + (k + (put-symbol port k)))) + delim)) + +;; param-component = token [ "=" (token | quoted-string) ] \ +;; *(";" token [ "=" (token | quoted-string) ]) +;; +(define param-delimiters (char-set #\, #\; #\=)) +(define param-value-delimiters (char-set-adjoin char-set:whitespace #\, #\;)) +(define* (parse-param-component str #:optional + (val-parser default-val-parser) + (start 0) (end (string-length str))) + (let lp ((i start) (out '())) + (if (not (< i end)) + (values (reverse! out) end) + (let ((delim (string-index str param-delimiters i))) + (let ((k (string->symbol + (substring str i (trim-whitespace str i (or delim end))))) + (delimc (and delim (string-ref str delim)))) + (case delimc + ((#\=) + (call-with-values + (lambda () + (let ((i (skip-whitespace str (1+ delim) end))) + (if (and (< i end) (eqv? (string-ref str i) #\")) + (parse-qstring str i end #:incremental? #t) + (let ((delim + (or (string-index str param-value-delimiters + i end) + end))) + (values (substring str i delim) + delim))))) + (lambda (v-str next-i) + (let* ((v (val-parser k v-str)) + (x (if v (cons k v) k)) + (i (skip-whitespace str next-i end))) + (case (and (< i end) (string-ref str i)) + ((#f) + (values (reverse! (cons x out)) end)) + ((#\;) + (lp (skip-whitespace str (1+ i) end) + (cons x out))) + (else ; including #\, + (values (reverse! (cons x out)) i))))))) + ((#\;) + (let ((v (val-parser k #f))) + (lp (skip-whitespace str (1+ delim) end) + (cons (if v (cons k v) k) out)))) + + (else ;; either the end of the string or a #\, + (let ((v (val-parser k #f))) + (values (reverse! (cons (if v (cons k v) k) out)) + (or delim end)))))))))) + +(define* (parse-param-list str #:optional + (val-parser default-val-parser) + (start 0) (end (string-length str))) + (let lp ((i start) (out '())) + (call-with-values + (lambda () (parse-param-component str val-parser i end)) + (lambda (item i) + (if (< i end) + (if (eqv? (string-ref str i) #\,) + (lp (skip-whitespace str (1+ i) end) + (cons item out)) + (bad-header-component 'param-list str)) + (reverse! (cons item out))))))) + +(define* (validate-param-list list #:optional + (valid? default-val-validator)) + (list-of? list + (lambda (elt) + (key-value-list? elt valid?)))) + +(define* (write-param-list list port #:optional + (val-writer default-val-writer)) + (put-list + port list + (lambda (port item) + (write-key-value-list item port val-writer ";")) + ",")) + +(define-syntax string-match? + (lambda (x) + (syntax-case x () + ((_ str pat) (string? (syntax->datum #'pat)) + (let ((p (syntax->datum #'pat))) + #`(let ((s str)) + (and + (= (string-length s) #,(string-length p)) + #,@(let lp ((i 0) (tests '())) + (if (< i (string-length p)) + (let ((c (string-ref p i))) + (lp (1+ i) + (case c + ((#\.) ; Whatever. + tests) + ((#\d) ; Digit. + (cons #`(char-numeric? (string-ref s #,i)) + tests)) + ((#\a) ; Alphabetic. + (cons #`(char-alphabetic? (string-ref s #,i)) + tests)) + (else ; Literal. + (cons #`(eqv? (string-ref s #,i) #,c) + tests))))) + tests))))))))) + +;; "Jan" | "Feb" | "Mar" | "Apr" | "May" | "Jun" +;; "Jul" | "Aug" | "Sep" | "Oct" | "Nov" | "Dec" + +(define (parse-month str start end) + (define (bad) + (bad-header-component 'month (substring str start end))) + (if (not (= (- end start) 3)) + (bad) + (let ((a (string-ref str (+ start 0))) + (b (string-ref str (+ start 1))) + (c (string-ref str (+ start 2)))) + (case a + ((#\J) + (case b + ((#\a) (case c ((#\n) 1) (else (bad)))) + ((#\u) (case c ((#\n) 6) ((#\l) 7) (else (bad)))) + (else (bad)))) + ((#\F) + (case b + ((#\e) (case c ((#\b) 2) (else (bad)))) + (else (bad)))) + ((#\M) + (case b + ((#\a) (case c ((#\r) 3) ((#\y) 5) (else (bad)))) + (else (bad)))) + ((#\A) + (case b + ((#\p) (case c ((#\r) 4) (else (bad)))) + ((#\u) (case c ((#\g) 8) (else (bad)))) + (else (bad)))) + ((#\S) + (case b + ((#\e) (case c ((#\p) 9) (else (bad)))) + (else (bad)))) + ((#\O) + (case b + ((#\c) (case c ((#\t) 10) (else (bad)))) + (else (bad)))) + ((#\N) + (case b + ((#\o) (case c ((#\v) 11) (else (bad)))) + (else (bad)))) + ((#\D) + (case b + ((#\e) (case c ((#\c) 12) (else (bad)))) + (else (bad)))) + (else (bad)))))) + +;; "GMT" | "+" 4DIGIT | "-" 4DIGIT +;; +;; RFC 2616 requires date values to use "GMT", but recommends accepting +;; the others as they are commonly generated by e.g. RFC 822 sources. +(define (parse-zone-offset str start) + (let ((s (substring str start))) + (define (bad) + (bad-header-component 'zone-offset s)) + (cond + ((string=? s "GMT") + 0) + ((string=? s "UTC") + 0) + ((string-match? s ".dddd") + (let ((sign (case (string-ref s 0) + ((#\+) +1) + ((#\-) -1) + (else (bad)))) + (hours (parse-non-negative-integer s 1 3)) + (minutes (parse-non-negative-integer s 3 5))) + (* sign 60 (+ (* 60 hours) minutes)))) ; seconds east of Greenwich + (else (bad))))) + +;; RFC 822, updated by RFC 1123 +;; +;; Sun, 06 Nov 1994 08:49:37 GMT +;; 01234567890123456789012345678 +;; 0 1 2 +(define (parse-rfc-822-date str space zone-offset) + ;; We could verify the day of the week but we don't. + (cond ((string-match? (substring str 0 space) "aaa, dd aaa dddd dd:dd:dd") + (let ((date (parse-non-negative-integer str 5 7)) + (month (parse-month str 8 11)) + (year (parse-non-negative-integer str 12 16)) + (hour (parse-non-negative-integer str 17 19)) + (minute (parse-non-negative-integer str 20 22)) + (second (parse-non-negative-integer str 23 25))) + (make-date 0 second minute hour date month year zone-offset))) + ((string-match? (substring str 0 space) "aaa, d aaa dddd dd:dd:dd") + (let ((date (parse-non-negative-integer str 5 6)) + (month (parse-month str 7 10)) + (year (parse-non-negative-integer str 11 15)) + (hour (parse-non-negative-integer str 16 18)) + (minute (parse-non-negative-integer str 19 21)) + (second (parse-non-negative-integer str 22 24))) + (make-date 0 second minute hour date month year zone-offset))) + + ;; The next two clauses match dates that have a space instead of + ;; a leading zero for hours, like " 8:49:37". + ((string-match? (substring str 0 space) "aaa, dd aaa dddd d:dd:dd") + (let ((date (parse-non-negative-integer str 5 7)) + (month (parse-month str 8 11)) + (year (parse-non-negative-integer str 12 16)) + (hour (parse-non-negative-integer str 18 19)) + (minute (parse-non-negative-integer str 20 22)) + (second (parse-non-negative-integer str 23 25))) + (make-date 0 second minute hour date month year zone-offset))) + ((string-match? (substring str 0 space) "aaa, d aaa dddd d:dd:dd") + (let ((date (parse-non-negative-integer str 5 6)) + (month (parse-month str 7 10)) + (year (parse-non-negative-integer str 11 15)) + (hour (parse-non-negative-integer str 17 18)) + (minute (parse-non-negative-integer str 19 21)) + (second (parse-non-negative-integer str 22 24))) + (make-date 0 second minute hour date month year zone-offset))) + + (else + (bad-header 'date str) ; prevent tail call + #f))) + +;; RFC 850, updated by RFC 1036 +;; Sunday, 06-Nov-94 08:49:37 GMT +;; 0123456789012345678901 +;; 0 1 2 +(define (parse-rfc-850-date str comma space zone-offset) + ;; We could verify the day of the week but we don't. + (let ((tail (substring str (1+ comma) space))) + (unless (string-match? tail " dd-aaa-dd dd:dd:dd") + (bad-header 'date str)) + (let ((date (parse-non-negative-integer tail 1 3)) + (month (parse-month tail 4 7)) + (year (parse-non-negative-integer tail 8 10)) + (hour (parse-non-negative-integer tail 11 13)) + (minute (parse-non-negative-integer tail 14 16)) + (second (parse-non-negative-integer tail 17 19))) + (make-date 0 second minute hour date month + (let* ((now (date-year (current-date))) + (then (+ now year (- (modulo now 100))))) + (cond ((< (+ then 50) now) (+ then 100)) + ((< (+ now 50) then) (- then 100)) + (else then))) + zone-offset)))) + +;; ANSI C's asctime() format +;; Sun Nov 6 08:49:37 1994 +;; 012345678901234567890123 +;; 0 1 2 +(define (parse-asctime-date str) + (unless (string-match? str "aaa aaa .d dd:dd:dd dddd") + (bad-header 'date str)) + (let ((date (parse-non-negative-integer + str + (if (eqv? (string-ref str 8) #\space) 9 8) + 10)) + (month (parse-month str 4 7)) + (year (parse-non-negative-integer str 20 24)) + (hour (parse-non-negative-integer str 11 13)) + (minute (parse-non-negative-integer str 14 16)) + (second (parse-non-negative-integer str 17 19))) + (make-date 0 second minute hour date month year 0))) + +;; Convert all date values to GMT time zone, as per RFC 2616 appendix C. +(define (normalize-date date) + (if (zero? (date-zone-offset date)) + date + (time-utc->date (date->time-utc date) 0))) + +(define (parse-date str) + (let* ((space (string-rindex str #\space)) + (zone-offset (and space (false-if-exception + (parse-zone-offset str (1+ space)))))) + (normalize-date + (if zone-offset + (let ((comma (string-index str #\,))) + (cond ((not comma) (bad-header 'date str)) + ((= comma 3) (parse-rfc-822-date str space zone-offset)) + (else (parse-rfc-850-date str comma space zone-offset)))) + (parse-asctime-date str))))) + +(define (write-date date port) + (define (put-digits port n digits) + (define zero (char->integer #\0)) + (let lp ((tens (expt 10 (1- digits)))) + (when (> tens 0) + (put-char port + (integer->char (+ zero (modulo (truncate/ n tens) 10)))) + (lp (floor/ tens 10))))) + (let ((date (if (zero? (date-zone-offset date)) + date + (time-tai->date (date->time-tai date) 0)))) + (put-string port + (case (date-week-day date) + ((0) "Sun, ") ((1) "Mon, ") ((2) "Tue, ") + ((3) "Wed, ") ((4) "Thu, ") ((5) "Fri, ") + ((6) "Sat, ") (else (error "bad date" date)))) + (put-digits port (date-day date) 2) + (put-string port + (case (date-month date) + ((1) " Jan ") ((2) " Feb ") ((3) " Mar ") + ((4) " Apr ") ((5) " May ") ((6) " Jun ") + ((7) " Jul ") ((8) " Aug ") ((9) " Sep ") + ((10) " Oct ") ((11) " Nov ") ((12) " Dec ") + (else (error "bad date" date)))) + (put-digits port (date-year date) 4) + (put-char port #\space) + (put-digits port (date-hour date) 2) + (put-char port #\:) + (put-digits port (date-minute date) 2) + (put-char port #\:) + (put-digits port (date-second date) 2) + (put-string port " GMT"))) + +;; Following https://tools.ietf.org/html/rfc7232#section-2.3, an entity +;; tag should really be a qstring. However there are a number of +;; servers that emit etags as unquoted strings. Assume that if the +;; value doesn't start with a quote, it's an unquoted strong etag. +(define* (parse-entity-tag val #:optional (start 0) (end (string-length val)) + #:key sloppy-delimiters) + (define (parse-proper-etag-at start strong?) + (cond + (sloppy-delimiters + (call-with-values (lambda () + (parse-qstring val start end #:incremental? #t)) + (lambda (tag next) + (values (cons tag strong?) next)))) + (else + (values (cons (parse-qstring val start end) strong?) end)))) + (cond + ((string-prefix? "W/" val 0 2 start end) + (parse-proper-etag-at (+ start 2) #f)) + ((string-prefix? "\"" val 0 1 start end) + (parse-proper-etag-at start #t)) + (else + (let ((delim (or (and sloppy-delimiters + (string-index val sloppy-delimiters start end)) + end))) + (values (cons (substring val start delim) #t) delim))))) + +(define (entity-tag? val) + (match val + (((? string?) . _) #t) + (_ #f))) + +(define (put-entity-tag port val) + (match val + ((tag . strong?) + (unless strong? (put-string port "W/")) + (write-qstring tag port)))) + +(define* (parse-entity-tag-list val #:optional + (start 0) (end (string-length val))) + (call-with-values (lambda () + (parse-entity-tag val start end #:sloppy-delimiters #\,)) + (lambda (etag next) + (cons etag + (let ((next (skip-whitespace val next end))) + (if (< next end) + (if (eqv? (string-ref val next) #\,) + (parse-entity-tag-list + val + (skip-whitespace val (1+ next) end) + end) + (bad-header-component 'entity-tag-list val)) + '())))))) + +(define (entity-tag-list? val) + (list-of? val entity-tag?)) + +(define (put-entity-tag-list port val) + (put-list port val put-entity-tag ", ")) + +;; credentials = auth-scheme #auth-param +;; auth-scheme = token +;; auth-param = token "=" ( token | quoted-string ) +;; +;; That's what the spec says. In reality the Basic scheme doesn't have +;; k-v pairs, just one auth token, so we give that token as a string. +;; +(define* (parse-credentials str #:optional (val-parser default-val-parser) + (start 0) (end (string-length str))) + (let* ((start (skip-whitespace str start end)) + (delim (or (string-index str char-set:whitespace start end) end))) + (when (= start end) + (bad-header-component 'authorization str)) + (let ((scheme (string->symbol + (string-downcase (substring str start (or delim end)))))) + (case scheme + ((basic) + (let* ((start (skip-whitespace str delim end))) + (unless (< start end) + (bad-header-component 'credentials str)) + (cons scheme (substring str start end)))) + (else + (cons scheme (parse-key-value-list str default-val-parser delim end))))))) + +(define (validate-credentials val) + (match val + (('basic . (? string?)) #t) + (((? symbol?) . (? key-value-list?)) #t) + (_ #f))) + +;; While according to RFC 7617 Schemes are case-insensitive: +;; +;; 'Note that both scheme and parameter names are matched +;; case-insensitive' +;; +;; some software (*) incorrectly assumes title case for scheme +;; names, so use the more titlecase. +;; +;; (*): See, e.g., +;; https://community.spotify.com/t5/Spotify-for-Developers/API-Authorization-header-doesn-t-follow-HTTP-spec/m-p/5397381#M4917 +(define (write-credentials val port) + (match val + (('basic . cred) + (put-string port "Basic ") + (put-string port cred)) + ((scheme . params) + (put-string port (string-titlecase (symbol->string scheme))) + (put-char port #\space) + (write-key-value-list params port)))) + +;; challenges = 1#challenge +;; challenge = auth-scheme 1*SP 1#auth-param +;; +;; A pain to parse, as both challenges and auth params are delimited by +;; commas, and qstrings can contain anything. We rely on auth params +;; necessarily having "=" in them. +;; +(define* (parse-challenge str #:optional + (start 0) (end (string-length str))) + (let* ((start (skip-whitespace str start end)) + (sp (string-index str #\space start end)) + (scheme (if sp + (string->symbol (string-downcase (substring str start sp))) + (bad-header-component 'challenge str)))) + (let lp ((i sp) (out (list scheme))) + (if (not (< i end)) + (values (reverse! out) end) + (let* ((i (skip-whitespace str i end)) + (eq (string-index str #\= i end)) + (comma (string-index str #\, i end)) + (delim (min (or eq end) (or comma end))) + (token-end (trim-whitespace str i delim))) + (if (string-index str #\space i token-end) + (values (reverse! out) i) + (let ((k (string->symbol (substring str i token-end)))) + (call-with-values + (lambda () + (if (and eq (or (not comma) (< eq comma))) + (let ((i (skip-whitespace str (1+ eq) end))) + (if (and (< i end) (eqv? (string-ref str i) #\")) + (parse-qstring str i end #:incremental? #t) + (values (substring + str i + (trim-whitespace str i + (or comma end))) + (or comma end)))) + (values #f delim))) + (lambda (v next-i) + (let ((i (skip-whitespace str next-i end))) + (unless (or (= i end) (eqv? (string-ref str i) #\,)) + (bad-header-component 'challenge + (substring str start end))) + (lp (1+ i) (cons (if v (cons k v) k) out)))))))))))) + +(define* (parse-challenges str #:optional (val-parser default-val-parser) + (start 0) (end (string-length str))) + (let lp ((i start)) + (let ((i (skip-whitespace str i end))) + (if (< i end) + (call-with-values (lambda () (parse-challenge str i end)) + (lambda (challenge i) + (cons challenge (lp i)))) + '())))) + +(define (validate-challenges val) + (match val + ((((? symbol?) . (? key-value-list?)) ...) #t) + (_ #f))) + +(define (put-challenge port val) + (match val + ((scheme . params) + (put-symbol port scheme) + (put-char port #\space) + (write-key-value-list params port)))) + +(define (write-challenges val port) + (put-list port val put-challenge ", ")) + + + + +;;; +;;; Request-Line and Response-Line +;;; + +;; Hmm. +(define (bad-request message . args) + (throw 'bad-request message args)) +(define (bad-response message . args) + (throw 'bad-response message args)) + +(define *known-versions* '()) + +(define* (parse-http-version str #:optional (start 0) (end (string-length str))) + "Parse an HTTP version from STR, returning it as a major–minor +pair. For example, ‘HTTP/1.1’ parses as the pair of integers, +‘(1 . 1)’." + (let lp ((known *known-versions*)) + (match known + (((version-str . version-val) . known) + (if (string= str version-str start end) + version-val + (lp known))) + (() + (let ((dot-idx (string-index str #\. start end))) + (unless (and (string-prefix? "HTTP/" str 0 5 start end) + dot-idx + (= dot-idx (string-rindex str #\. start end))) + + (bad-header-component 'http-version (substring str start end))) + (cons (parse-non-negative-integer str (+ start 5) dot-idx) + (parse-non-negative-integer str (1+ dot-idx) end))))))) + +(define (write-http-version val port) + "Write the given major-minor version pair to PORT." + (put-string port "HTTP/") + (put-non-negative-integer port (car val)) + (put-char port #\.) + (put-non-negative-integer port (cdr val))) + +(for-each + (lambda (v) + (set! *known-versions* + (acons v (parse-http-version v 0 (string-length v)) + *known-versions*))) + '("HTTP/1.0" "HTTP/1.1")) + + +(define *declared-methods* '()) + +(define (declare-method! str symb) + (set! *declared-methods* (acons str symb *declared-methods*))) + +;; Request-URI = "*" | absoluteURI | abs_path | authority +;; +;; The `authority' form is only permissible for the CONNECT method, so +;; because we don't expect people to implement CONNECT, we save +;; ourselves the trouble of that case, and disallow the CONNECT method. +;; +(define* (parse-http-method str #:optional (start 0) (end (string-length str))) + "Parse an HTTP method from STR. The result is an upper-case +symbol, like ‘GET’." + (cdr + (or (find (lambda (pair) (string= str (car pair) start end)) + *declared-methods*) + (bad-request "Invalid method: ~a" (substring str start end))))) + +(declare-method! "GET" 'GET) +(declare-method! "HEAD" 'HEAD) +(declare-method! "POST" 'POST) +(declare-method! "PUT" 'PUT) +(declare-method! "DELETE" 'DELETE) +(declare-method! "OPTIONS" 'OPTIONS) +(declare-method! "TRACE" 'TRACE) +(declare-method! "CONNECT" 'CONNECT) +(declare-method! "PATCH" 'PATCH) + +(define* (parse-request-uri str #:optional (start 0) (end (string-length str))) + "Parse a URI from an HTTP request line. Note that URIs in requests do +not have to have a scheme or host name. The result is a URI-reference +object." + (cond + ((= start end) + (bad-request "Missing Request-URI")) + ((string= str "*" start end) + #f) + ((eqv? (string-ref str start) #\/) + (let* ((q (string-index str #\? start end)) + (f (string-index str #\# start end)) + (q (and q (or (not f) (< q f)) q))) + (build-uri-reference + #:path (substring str start (or q f end)) + #:query (and q (substring str (1+ q) (or f end))) + #:fragment (and f (substring str (1+ f) end))))) + (else + (or (string->uri (substring str start end)) + (bad-request "Invalid URI: ~a" (substring str start end)))))) + +(define (read-request-line port) + "Read the first line of an HTTP request from PORT, returning +three values: the method, the URI, and the version." + (let* ((line (read-header-line port)) + (d0 (string-index line char-set:whitespace)) ; "delimiter zero" + (d1 (string-rindex line char-set:whitespace))) + (unless (and d0 d1 (< d0 d1)) + (bad-request "Bad Request-Line: ~s" line)) + (values (parse-http-method line 0 d0) + (parse-request-uri line (skip-whitespace line (1+ d0) d1) d1) + (parse-http-version line (1+ d1) (string-length line))))) + +(define (write-uri uri port) + (put-string port (uri->string uri #:include-fragment? #f))) + +(define (write-request-line method uri version port) + "Write the first line of an HTTP request to PORT." + (put-symbol port method) + (put-char port #\space) + (when (http-proxy-port? port) + (let ((scheme (uri-scheme uri)) + (host (uri-host uri)) + (host-port (uri-port uri))) + (when (and scheme host) + (put-symbol port scheme) + (put-string port "://") + (cond + ((string-index host #\:) + (put-char port #\[) + (put-string port host) + (put-char port #\])) + (else + (put-string port host))) + (unless ((@@ (web uri) default-port?) scheme host-port) + (put-char port #\:) + (put-non-negative-integer port host-port))))) + (let ((path (uri-path uri)) + (query (uri-query uri))) + (if (string-null? path) + (put-string port "/") + (put-string port path)) + (when query + (put-string port "?") + (put-string port query))) + (put-char port #\space) + (write-http-version version port) + (put-string port "\r\n")) + +(define (read-response-line port) + "Read the first line of an HTTP response from PORT, returning three +values: the HTTP version, the response code, and the (possibly empty) +\"reason phrase\"." + (let* ((line (read-header-line port)) + (d0 (string-index line char-set:whitespace)) ; "delimiter zero" + (d1 (and d0 (string-index line char-set:whitespace + (skip-whitespace line d0))))) + (unless (and d0 d1) + (bad-response "Bad Response-Line: ~s" line)) + (values (parse-http-version line 0 d0) + (parse-non-negative-integer line (skip-whitespace line d0 d1) + d1) + (string-trim-both line char-set:whitespace d1)))) + +(define (write-response-line version code reason-phrase port) + "Write the first line of an HTTP response to PORT." + (write-http-version version port) + (put-char port #\space) + (put-non-negative-integer port code) + (put-char port #\space) + (put-string port reason-phrase) + (put-string port "\r\n")) + + + + +;;; +;;; Helpers for declaring headers +;;; + +;; emacs: (put 'declare-header! 'scheme-indent-function 1) +;; emacs: (put 'declare-opaque!-header 'scheme-indent-function 1) +(define (declare-opaque-header! name) + "Declares a given header as \"opaque\", meaning that its value is not +treated specially, and is just returned as a plain string." + (declare-header! name + parse-opaque-string validate-opaque-string write-opaque-string)) + +;; emacs: (put 'declare-date-header! 'scheme-indent-function 1) +(define (declare-date-header! name) + (declare-header! name + parse-date date? write-date)) + +;; emacs: (put 'declare-string-list-header! 'scheme-indent-function 1) +(define (declare-string-list-header! name) + (declare-header! name + split-and-trim list-of-strings? write-list-of-strings)) + +;; emacs: (put 'declare-symbol-list-header! 'scheme-indent-function 1) +(define (declare-symbol-list-header! name) + (declare-header! name + (lambda (str) + (map string->symbol (split-and-trim str))) + (lambda (v) + (list-of? v symbol?)) + (lambda (v port) + (put-list port v put-symbol ", ")))) + +;; emacs: (put 'declare-header-list-header! 'scheme-indent-function 1) +(define (declare-header-list-header! name) + (declare-header! name + split-header-names list-of-header-names? write-header-list)) + +;; emacs: (put 'declare-integer-header! 'scheme-indent-function 1) +(define (declare-integer-header! name) + (declare-header! name + parse-non-negative-integer non-negative-integer? + (lambda (val port) (put-non-negative-integer port val)))) + +;; emacs: (put 'declare-uri-reference-header! 'scheme-indent-function 1) +(define (declare-uri-reference-header! name) + (declare-header! name + (lambda (str) + (or (string->uri-reference str) + (bad-header-component 'uri-reference str))) + uri-reference? + write-uri)) + +;; emacs: (put 'declare-quality-list-header! 'scheme-indent-function 1) +(define (declare-quality-list-header! name) + (declare-header! name + parse-quality-list validate-quality-list write-quality-list)) + +;; emacs: (put 'declare-param-list-header! 'scheme-indent-function 1) +(define* (declare-param-list-header! name #:optional + (val-parser default-val-parser) + (val-validator default-val-validator) + (val-writer default-val-writer)) + (declare-header! name + (lambda (str) (parse-param-list str val-parser)) + (lambda (val) (validate-param-list val val-validator)) + (lambda (val port) (write-param-list val port val-writer)))) + +;; emacs: (put 'declare-key-value-list-header! 'scheme-indent-function 1) +(define* (declare-key-value-list-header! name #:optional + (val-parser default-val-parser) + (val-validator default-val-validator) + (val-writer default-val-writer)) + (declare-header! name + (lambda (str) (parse-key-value-list str val-parser)) + (lambda (val) (key-value-list? val val-validator)) + (lambda (val port) (write-key-value-list val port val-writer)))) + +;; emacs: (put 'declare-entity-tag-list-header! 'scheme-indent-function 1) +(define (declare-entity-tag-list-header! name) + (declare-header! name + (lambda (str) (if (string=? str "*") '* (parse-entity-tag-list str))) + (lambda (val) (or (eq? val '*) (entity-tag-list? val))) + (lambda (val port) + (if (eq? val '*) + (put-string port "*") + (put-entity-tag-list port val))))) + +;; emacs: (put 'declare-credentials-header! 'scheme-indent-function 1) +(define (declare-credentials-header! name) + (declare-header! name + parse-credentials validate-credentials write-credentials)) + +;; emacs: (put 'declare-challenge-list-header! 'scheme-indent-function 1) +(define (declare-challenge-list-header! name) + (declare-header! name + parse-challenges validate-challenges write-challenges)) + + + + +;;; +;;; General headers +;;; + +;; Cache-Control = 1#(cache-directive) +;; cache-directive = cache-request-directive | cache-response-directive +;; cache-request-directive = +;; "no-cache" ; Section 14.9.1 +;; | "no-store" ; Section 14.9.2 +;; | "max-age" "=" delta-seconds ; Section 14.9.3, 14.9.4 +;; | "max-stale" [ "=" delta-seconds ] ; Section 14.9.3 +;; | "min-fresh" "=" delta-seconds ; Section 14.9.3 +;; | "no-transform" ; Section 14.9.5 +;; | "only-if-cached" ; Section 14.9.4 +;; | cache-extension ; Section 14.9.6 +;; cache-response-directive = +;; "public" ; Section 14.9.1 +;; | "private" [ "=" <"> 1#field-name <"> ] ; Section 14.9.1 +;; | "no-cache" [ "=" <"> 1#field-name <"> ]; Section 14.9.1 +;; | "no-store" ; Section 14.9.2 +;; | "no-transform" ; Section 14.9.5 +;; | "must-revalidate" ; Section 14.9.4 +;; | "proxy-revalidate" ; Section 14.9.4 +;; | "max-age" "=" delta-seconds ; Section 14.9.3 +;; | "s-maxage" "=" delta-seconds ; Section 14.9.3 +;; | cache-extension ; Section 14.9.6 +;; cache-extension = token [ "=" ( token | quoted-string ) ] +;; +(declare-key-value-list-header! "Cache-Control" + (lambda (k v-str) + (case k + ((max-age min-fresh s-maxage) + (parse-non-negative-integer v-str)) + ((max-stale) + (and v-str (parse-non-negative-integer v-str))) + ((private no-cache) + (and v-str (split-header-names v-str))) + (else v-str))) + (lambda (k v) + (case k + ((max-age min-fresh s-maxage) + (non-negative-integer? v)) + ((max-stale) + (or (not v) (non-negative-integer? v))) + ((private no-cache) + (or (not v) (list-of-header-names? v))) + ((no-store no-transform only-if-cache must-revalidate proxy-revalidate) + (not v)) + (else + (or (not v) (string? v))))) + (lambda (k v port) + (cond + ((string? v) (default-val-writer k v port)) + ((pair? v) + (put-char port #\") + (write-header-list v port) + (put-char port #\")) + ((integer? v) + (put-non-negative-integer port v)) + (else + (bad-header-component 'cache-control v))))) + +;; Connection = "Connection" ":" 1#(connection-token) +;; connection-token = token +;; e.g. +;; Connection: close, Foo-Header +;; +(declare-header! "Connection" + split-header-names + list-of-header-names? + (lambda (val port) + (put-list port val + (lambda (port x) + (put-string port + (if (eq? x 'close) + "close" + (header->string x)))) + ", "))) + +;; Date = "Date" ":" HTTP-date +;; e.g. +;; Date: Tue, 15 Nov 1994 08:12:31 GMT +;; +(declare-date-header! "Date") + +;; Pragma = "Pragma" ":" 1#pragma-directive +;; pragma-directive = "no-cache" | extension-pragma +;; extension-pragma = token [ "=" ( token | quoted-string ) ] +;; +(declare-key-value-list-header! "Pragma") + +;; Trailer = "Trailer" ":" 1#field-name +;; +(declare-header-list-header! "Trailer") + +;; Transfer-Encoding = "Transfer-Encoding" ":" 1#transfer-coding +;; +(declare-param-list-header! "Transfer-Encoding") + +;; Upgrade = "Upgrade" ":" 1#product +;; +(declare-string-list-header! "Upgrade") + +;; Via = "Via" ":" 1#( received-protocol received-by [ comment ] ) +;; received-protocol = [ protocol-name "/" ] protocol-version +;; protocol-name = token +;; protocol-version = token +;; received-by = ( host [ ":" port ] ) | pseudonym +;; pseudonym = token +;; +(declare-header! "Via" + split-and-trim + list-of-strings? + write-list-of-strings + #:multiple? #t) + +;; Warning = "Warning" ":" 1#warning-value +;; +;; warning-value = warn-code SP warn-agent SP warn-text +;; [SP warn-date] +;; +;; warn-code = 3DIGIT +;; warn-agent = ( host [ ":" port ] ) | pseudonym +;; ; the name or pseudonym of the server adding +;; ; the Warning header, for use in debugging +;; warn-text = quoted-string +;; warn-date = <"> HTTP-date <"> +(declare-header! "Warning" + (lambda (str) + (let ((len (string-length str))) + (let lp ((i (skip-whitespace str 0))) + (let* ((idx1 (string-index str #\space i)) + (idx2 (string-index str #\space (1+ idx1)))) + (when (and idx1 idx2) + (let ((code (parse-non-negative-integer str i idx1)) + (agent (substring str (1+ idx1) idx2))) + (call-with-values + (lambda () (parse-qstring str (1+ idx2) #:incremental? #t)) + (lambda (text i) + (call-with-values + (lambda () + (let ((c (and (< i len) (string-ref str i)))) + (case c + ((#\space) + ;; we have a date. + (call-with-values + (lambda () (parse-qstring str (1+ i) + #:incremental? #t)) + (lambda (date i) + (values text (parse-date date) i)))) + (else + (values text #f i))))) + (lambda (text date i) + (let ((w (list code agent text date)) + (c (and (< i len) (string-ref str i)))) + (case c + ((#f) (list w)) + ((#\,) (cons w (lp (skip-whitespace str (1+ i))))) + (else (bad-header 'warning str)))))))))))))) + (lambda (val) + (list-of? val + (lambda (elt) + (match elt + ((code host text date) + (and (non-negative-integer? code) (< code 1000) + (string? host) + (string? text) + (or (not date) (date? date)))) + (_ #f))))) + (lambda (val port) + (put-list + port val + (lambda (port w) + (match w + ((code host text date) + (put-non-negative-integer port code) + (put-char port #\space) + (put-string port host) + (put-char port #\space) + (write-qstring text port) + (when date + (put-char port #\space) + (put-char port #\") + (write-date date port) + (put-char port #\"))))) + ", ")) + #:multiple? #t) + + + + +;;; +;;; Entity headers +;;; + +;; Allow = #Method +;; +(declare-symbol-list-header! "Allow") + +;; Content-Disposition = disposition-type *( ";" disposition-parm ) +;; disposition-type = "attachment" | disp-extension-token +;; disposition-parm = filename-parm | disp-extension-parm +;; filename-parm = "filename" "=" quoted-string +;; disp-extension-token = token +;; disp-extension-parm = token "=" ( token | quoted-string ) +;; +(declare-header! "Content-Disposition" + (lambda (str) + ;; Lazily reuse the param list parser. + (match (parse-param-list str default-val-parser) + ((disposition) disposition) + (_ (bad-header-component 'content-disposition str)))) + (lambda (val) + (match val + (((? symbol?) ((? symbol?) . (? string?)) ...) #t) + (_ #f))) + (lambda (val port) + (write-param-list (list val) port))) + +;; Content-Encoding = 1#content-coding +;; +(declare-symbol-list-header! "Content-Encoding") + +;; Content-Language = 1#language-tag +;; +(declare-string-list-header! "Content-Language") + +;; Content-Length = 1*DIGIT +;; +(declare-integer-header! "Content-Length") + +;; Content-Location = URI-reference +;; +(declare-uri-reference-header! "Content-Location") + +;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864> +;; +(declare-opaque-header! "Content-MD5") + +;; Content-Range = content-range-spec +;; content-range-spec = byte-content-range-spec +;; byte-content-range-spec = bytes-unit SP +;; byte-range-resp-spec "/" +;; ( instance-length | "*" ) +;; byte-range-resp-spec = (first-byte-pos "-" last-byte-pos) +;; | "*" +;; instance-length = 1*DIGIT +;; +(declare-header! "Content-Range" + (lambda (str) + (let ((dash (string-index str #\-)) + (slash (string-index str #\/))) + (unless (and (string-prefix? "bytes " str) slash) + (bad-header 'content-range str)) + (list 'bytes + (cond + (dash + (cons + (parse-non-negative-integer str 6 dash) + (parse-non-negative-integer str (1+ dash) slash))) + ((string= str "*" 6 slash) + '*) + (else + (bad-header 'content-range str))) + (if (string= str "*" (1+ slash)) + '* + (parse-non-negative-integer str (1+ slash)))))) + (lambda (val) + (match val + (((? symbol?) + (or '* ((? non-negative-integer?) . (? non-negative-integer?))) + (or '* (? non-negative-integer?))) + #t) + (_ #f))) + (lambda (val port) + (match val + ((unit range instance-length) + (put-symbol port unit) + (put-char port #\space) + (match range + ('* + (put-char port #\*)) + ((start . end) + (put-non-negative-integer port start) + (put-char port #\-) + (put-non-negative-integer port end))) + (put-char port #\/) + (match instance-length + ('* (put-char port #\*)) + (len (put-non-negative-integer port len))))))) + +;; Content-Type = media-type +;; +(declare-header! "Content-Type" + (lambda (str) + (let ((parts (string-split str #\;))) + (cons (parse-media-type (car parts)) + (map (lambda (x) + (let ((eq (string-index x #\=))) + (unless (and eq (= eq (string-rindex x #\=))) + (bad-header 'content-type str)) + (cons + (string->symbol + (string-trim x char-set:whitespace 0 eq)) + (string-trim-right x char-set:whitespace (1+ eq))))) + (cdr parts))))) + (lambda (val) + (match val + (((? symbol?) ((? symbol?) . (? string?)) ...) #t) + (_ #f))) + (lambda (val port) + (match val + ((type . args) + (put-symbol port type) + (match args + (() (values)) + (args + (put-string port ";") + (put-list + port args + (lambda (port pair) + (match pair + ((k . v) + (put-symbol port k) + (put-char port #\=) + (put-string port v)))) + ";"))))))) + +;; Expires = HTTP-date +;; +(define *date-in-the-past* (parse-date "Thu, 01 Jan 1970 00:00:00 GMT")) + +(declare-header! "Expires" + (lambda (str) + (if (member str '("0" "-1")) + *date-in-the-past* + (parse-date str))) + date? + write-date) + +;; Last-Modified = HTTP-date +;; +(declare-date-header! "Last-Modified") + + + + +;;; +;;; Request headers +;;; + +;; Accept = #( media-range [ accept-params ] ) +;; media-range = ( "*/*" | ( type "/" "*" ) | ( type "/" subtype ) ) +;; *( ";" parameter ) +;; accept-params = ";" "q" "=" qvalue *( accept-extension ) +;; accept-extension = ";" token [ "=" ( token | quoted-string ) ] +;; +(declare-param-list-header! "Accept" + ;; -> (type/subtype (sym-prop . str-val) ...) ...) + ;; + ;; with the exception of prop `q', in which case the val will be a + ;; valid quality value + ;; + (lambda (k v) + (if (eq? k 'q) + (parse-quality v) + v)) + (lambda (k v) + (if (eq? k 'q) + (valid-quality? v) + (or (not v) (string? v)))) + (lambda (k v port) + (if (eq? k 'q) + (write-quality v port) + (default-val-writer k v port)))) + +;; Accept-Charset = 1#( ( charset | "*" )[ ";" "q" "=" qvalue ] ) +;; +(declare-quality-list-header! "Accept-Charset") + +;; Accept-Encoding = 1#( codings [ ";" "q" "=" qvalue ] ) +;; codings = ( content-coding | "*" ) +;; +(declare-quality-list-header! "Accept-Encoding") + +;; Accept-Language = 1#( language-range [ ";" "q" "=" qvalue ] ) +;; language-range = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" ) +;; +(declare-quality-list-header! "Accept-Language") + +;; Authorization = credentials +;; credentials = auth-scheme #auth-param +;; auth-scheme = token +;; auth-param = token "=" ( token | quoted-string ) +;; +(declare-credentials-header! "Authorization") + +;; Expect = 1#expectation +;; expectation = "100-continue" | expectation-extension +;; expectation-extension = token [ "=" ( token | quoted-string ) +;; *expect-params ] +;; expect-params = ";" token [ "=" ( token | quoted-string ) ] +;; +(declare-param-list-header! "Expect") + +;; From = mailbox +;; +;; Should be an email address; we just pass on the string as-is. +;; +(declare-opaque-header! "From") + +;; Host = host [ ":" port ] +;; +(declare-header! "Host" + (lambda (str) + (let* ((rbracket (string-index str #\])) + (colon (string-index str #\: (or rbracket 0))) + (host (cond + (rbracket + (unless (eqv? (string-ref str 0) #\[) + (bad-header 'host str)) + (substring str 1 rbracket)) + (colon + (substring str 0 colon)) + (else + str))) + (port (and colon + (parse-non-negative-integer str (1+ colon))))) + (cons host port))) + (lambda (val) + (match val + (((? string?) . (or #f (? non-negative-integer?))) #t) + (_ #f))) + (lambda (val port) + (match val + ((host-name . host-port) + (cond + ((string-index host-name #\:) + (put-char port #\[) + (put-string port host-name) + (put-char port #\])) + (else + (put-string port host-name))) + (when host-port + (put-char port #\:) + (put-non-negative-integer port host-port)))))) + +;; If-Match = ( "*" | 1#entity-tag ) +;; +(declare-entity-tag-list-header! "If-Match") + +;; If-Modified-Since = HTTP-date +;; +(declare-date-header! "If-Modified-Since") + +;; If-None-Match = ( "*" | 1#entity-tag ) +;; +(declare-entity-tag-list-header! "If-None-Match") + +;; If-Range = ( entity-tag | HTTP-date ) +;; +(declare-header! "If-Range" + (lambda (str) + (if (or (string-prefix? "\"" str) + (string-prefix? "W/" str)) + (parse-entity-tag str) + (parse-date str))) + (lambda (val) + (or (date? val) (entity-tag? val))) + (lambda (val port) + (if (date? val) + (write-date val port) + (put-entity-tag port val)))) + +;; If-Unmodified-Since = HTTP-date +;; +(declare-date-header! "If-Unmodified-Since") + +;; Max-Forwards = 1*DIGIT +;; +(declare-integer-header! "Max-Forwards") + +;; Proxy-Authorization = credentials +;; +(declare-credentials-header! "Proxy-Authorization") + +;; Range = "Range" ":" ranges-specifier +;; ranges-specifier = byte-ranges-specifier +;; byte-ranges-specifier = bytes-unit "=" byte-range-set +;; byte-range-set = 1#( byte-range-spec | suffix-byte-range-spec ) +;; byte-range-spec = first-byte-pos "-" [last-byte-pos] +;; first-byte-pos = 1*DIGIT +;; last-byte-pos = 1*DIGIT +;; suffix-byte-range-spec = "-" suffix-length +;; suffix-length = 1*DIGIT +;; +(declare-header! "Range" + (lambda (str) + (unless (string-prefix? "bytes=" str) + (bad-header 'range str)) + (cons + 'bytes + (map (lambda (x) + (let ((dash (string-index x #\-))) + (cond + ((not dash) + (bad-header 'range str)) + ((zero? dash) + (cons #f (parse-non-negative-integer x 1))) + ((= dash (1- (string-length x))) + (cons (parse-non-negative-integer x 0 dash) #f)) + (else + (cons (parse-non-negative-integer x 0 dash) + (parse-non-negative-integer x (1+ dash))))))) + (string-split (substring str 6) #\,)))) + (lambda (val) + (match val + (((? symbol?) + (or (#f . (? non-negative-integer?)) + ((? non-negative-integer?) . (? non-negative-integer?)) + ((? non-negative-integer?) . #f)) + ...) #t) + (_ #f))) + (lambda (val port) + (match val + ((unit . ranges) + (put-symbol port unit) + (put-char port #\=) + (put-list + port ranges + (lambda (port range) + (match range + ((start . end) + (when start (put-non-negative-integer port start)) + (put-char port #\-) + (when end (put-non-negative-integer port end))))) + ","))))) + +;; Referer = URI-reference +;; +(declare-uri-reference-header! "Referer") + +;; TE = #( t-codings ) +;; t-codings = "trailers" | ( transfer-extension [ accept-params ] ) +;; +(declare-param-list-header! "TE") + +;; User-Agent = 1*( product | comment ) +;; +(declare-opaque-header! "User-Agent") + + + + +;;; +;;; Reponse headers +;;; + +;; Accept-Ranges = acceptable-ranges +;; acceptable-ranges = 1#range-unit | "none" +;; +(declare-symbol-list-header! "Accept-Ranges") + +;; Age = age-value +;; age-value = delta-seconds +;; +(declare-integer-header! "Age") + +;; ETag = entity-tag +;; +(declare-header! "ETag" + parse-entity-tag + entity-tag? + (lambda (val port) + (put-entity-tag port val))) + +;; Location = URI-reference +;; +;; In RFC 2616, Location was specified as being an absolute URI. This +;; was changed in RFC 7231 to permit URI references generally, which +;; matches web reality. +;; +(declare-uri-reference-header! "Location") + +;; Proxy-Authenticate = 1#challenge +;; +(declare-challenge-list-header! "Proxy-Authenticate") + +;; Retry-After = ( HTTP-date | delta-seconds ) +;; +(declare-header! "Retry-After" + (lambda (str) + (if (and (not (string-null? str)) + (char-numeric? (string-ref str 0))) + (parse-non-negative-integer str) + (parse-date str))) + (lambda (val) + (or (date? val) (non-negative-integer? val))) + (lambda (val port) + (if (date? val) + (write-date val port) + (put-non-negative-integer port val)))) + +;; Server = 1*( product | comment ) +;; +(declare-opaque-header! "Server") + +;; Vary = ( "*" | 1#field-name ) +;; +(declare-header! "Vary" + (lambda (str) + (if (equal? str "*") + '* + (split-header-names str))) + (lambda (val) + (or (eq? val '*) (list-of-header-names? val))) + (lambda (val port) + (if (eq? val '*) + (put-string port "*") + (write-header-list val port)))) + +;; WWW-Authenticate = 1#challenge +;; +(declare-challenge-list-header! "WWW-Authenticate") + + +;; Chunked Responses +(define &chunked-input-ended-prematurely + (make-exception-type '&chunked-input-error-prematurely + &external-error + '())) + +(define make-chunked-input-ended-prematurely-error + (record-constructor &chunked-input-ended-prematurely)) + +(define chunked-input-ended-prematurely-error? + (record-predicate &chunked-input-ended-prematurely)) + +(define (read-chunk-header port) + "Read a chunk header from PORT and return the size in bytes of the +upcoming chunk." + (match (read-line port) + ((? eof-object?) + ;; Connection closed prematurely: there's nothing left to read. + 0) + (str + (let ((extension-start (string-index str + (lambda (c) + (or (char=? c #\;) + (char=? c #\return)))))) + (string->number (if extension-start ; unnecessary? + (substring str 0 extension-start) + str) + 16))))) + +(define* (make-chunked-input-port port #:key (keep-alive? #f)) + "Returns a new port which translates HTTP chunked transfer encoded +data from PORT into a non-encoded format. Returns eof when it has +read the final chunk from PORT. This does not necessarily mean +that there is no more data on PORT. When the returned port is +closed it will also close PORT, unless the KEEP-ALIVE? is true." + (define (close) + (unless keep-alive? + (close-port port))) + + (define chunk-size 0) ;size of the current chunk + (define remaining 0) ;number of bytes left from the current chunk + (define finished? #f) ;did we get all the chunks? + + (define (read! bv idx to-read) + (define (loop to-read num-read) + (cond ((or finished? (zero? to-read)) + num-read) + ((zero? remaining) ;get a new chunk + (let ((size (read-chunk-header port))) + (set! chunk-size size) + (set! remaining size) + (cond + ((zero? size) + (set! finished? #t) + (get-bytevector-n port 2) ; \r\n follows the last chunk + num-read) + (else + (loop to-read num-read))))) + (else ;read from the current chunk + (let* ((ask-for (min to-read remaining)) + (read (get-bytevector-n! port bv (+ idx num-read) + ask-for))) + (cond + ((eof-object? read) ;premature termination + (raise-exception + (make-chunked-input-ended-prematurely-error))) + (else + (let ((left (- remaining read))) + (set! remaining left) + (when (zero? left) + ;; We're done with this chunk; read CR and LF. + (get-u8 port) (get-u8 port)) + (loop (- to-read read) + (+ num-read read))))))))) + (loop to-read 0)) + + (make-custom-binary-input-port "chunked input port" read! #f #f close)) + +(define* (make-chunked-output-port port #:key (keep-alive? #f) + (buffering 1200)) + "Returns a new port which translates non-encoded data into a HTTP +chunked transfer encoded data and writes this to PORT. Data written to +this port is buffered until the port is flushed, at which point it is +all sent as one chunk. The port will otherwise be flushed every +BUFFERING bytes, which defaults to 1200. Take care to close the port +when done, as it will output the remaining data, and encode the final +zero chunk. When the port is closed it will also close PORT, unless +KEEP-ALIVE? is true." + (define (q-for-each f q) + (while (not (q-empty? q)) + (f (deq! q)))) + (define queue (make-q)) + (define (%put-char c) + (enq! queue c)) + (define (%put-string s) + (string-for-each (lambda (c) (enq! queue c)) + s)) + (define (flush) + ;; It is important that we do _not_ write a chunk if the queue is + ;; empty, since it will be treated as the final chunk. + (unless (q-empty? queue) + (let ((len (q-length queue))) + (put-string port (number->string len 16)) + (put-string port "\r\n") + (q-for-each (lambda (elem) (put-char port elem)) + queue) + (put-string port "\r\n")))) + (define (close) + (flush) + (put-string port "0\r\n\r\n") + (force-output port) + (unless keep-alive? + (close-port port))) + (let ((ret (make-soft-port (vector %put-char %put-string flush #f close) "w"))) + (setvbuf ret 'block buffering) + ret)) + +(define %http-proxy-port? (make-object-property)) +(define (http-proxy-port? port) (%http-proxy-port? port)) +(define (set-http-proxy-port?! port flag) + (set! (%http-proxy-port? port) flag)) diff --git a/module/web/http/dav.scm b/module/web/http/dav.scm new file mode 100644 index 00000000..9adc8b87 --- /dev/null +++ b/module/web/http/dav.scm @@ -0,0 +1,144 @@ +(define-module (web http dav) + :use-module (srfi srfi-9) + :use-module (srfi srfi-88) + :use-module (rnrs bytevectors) + :use-module (rnrs io ports) + :use-module ((ice-9 binary-ports) :select (call-with-output-bytevector)) + :use-module (web request) + :use-module (web response) + :use-module (web client) + :use-module (web uri) + :use-module (sxml simple) + :use-module (sxml xpath) + :use-module ((hnh util) :select (->)) + :export (caldav + user-agent dav + propfind + get-principal + get-calendar-home-set + get-calendar-paths + get-calendar-name + ) + ) + +(define caldav "urn:ietf:params:xml:ns:caldav") +(define user-agent (make-parameter "")) +(user-agent "calp/0.1") + +(define-record-type <info> + (make-info uri-creator password) + info? + (uri-creator uri-creator) + (password info-password) + ) + +(define (with-output-to-bytevector thunk) + (call-with-output-bytevector + (lambda (port) + (with-output-to-port port thunk)))) + +;; Make a webdav HTTP request, body should be a sxml tree without the *TOP* or +;; *PI* element. +(define* (dav uri key: method authorization body (depth 1)) + (define request-body + (if body + (with-output-to-bytevector + (lambda () + (sxml->xml + `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + ,body)))) + #f)) + + (define headers + `((user-agent . ,(user-agent)) + (depth . ,(cond (depth number? => number->string) + (else depth))) + ;; (accept . ((*/*))) + (authorization . ,authorization) + ,@(if body + `((content-type . (application/xml (charset . "UTF-8"))) + (content-length . ,(bytevector-length request-body))) + '()))) + + (http-request uri + method: method + body: request-body + headers: headers + keep-alive?: #t + decode-body?: #f + streaming?: #t)) + +(define* (propfind uri resource key: (depth 1) password) + (define authorization + (if password + `(Basic ,password) + #f)) + (define-values (response port) + (dav uri + method: 'PROPFIND + authorization: authorization + depth: depth + body: `(propfind (@ (xmlns "DAV:") + (xmlns:d "DAV:") + (xmlns:c ,caldav)) + (prop (,resource))))) + (unless (= 207 (response-code response)) + (scm-error 'dav-error "propfind" + "HTTP error ~a: ~a" + (list + (response-code response) + (response-reason-phrase response)) + (list response))) + (xml->sxml port + declare-namespaces?: #t + trim-whitespace?: #t + namespaces: `((d . "DAV:") + (c . ,caldav)))) + + +;; (define (get-collections) +;; (-> (propfind "/" 'resourcetype) +;; ((sxpath '(// (d:response (// d:resourcetype d:collection)) +;; d:href *text*))))) + +;; => ((d:resourcetype (d:collection))) + +(define* (get-principal uri key: password) + (-> (propfind uri 'current-user-principal + depth: 0 + password: password) + ((sxpath '(// (d:response (d:href (equal? "/"))) + // + d:prop d:current-user-principal + d:href *text*))) + car)) + +(define* (get-calendar-home-set principal-uri key: password) + (-> (propfind principal-uri + 'c:calendar-home-set + password: password) + ((sxpath `(// (d:response (d:href + (equal? ,(uri-path principal-uri)))) + // d:prop c:calendar-home-set + d:href *text* + ))) + car)) + +(define* (get-calendar-paths calendar-home-set-uri key: password) + (-> (propfind calendar-home-set-uri + 'resourcetype + depth: "infinity" + password: password) + ((sxpath '(// (d:response (// d:resourcetype c:calendar)) + d:href *text*))))) + +;; => ("Calendar") +(define* (get-calendar-name calendar-path + key: password) + (-> (propfind calendar-path 'displayname + depth: 0 + password: password) + ((sxpath '(// d:response // d:prop d:displayname *text*))) + car)) + + diff --git a/module/web/http/make-routes.scm b/module/web/http/make-routes.scm index aa3be1ed..a36efaef 100644 --- a/module/web/http/make-routes.scm +++ b/module/web/http/make-routes.scm @@ -3,15 +3,28 @@ :use-module (ice-9 regex) :use-module (ice-9 match) :use-module (ice-9 curried-definitions) + :use-module (ice-9 control) :use-module (srfi srfi-1) :use-module (srfi srfi-71) :use-module (srfi srfi-88) + :use-module ((web query) :select (parse-query)) + :use-module ((web response) :select (build-response)) + :use-module ((ice-9 iconv) :select (bytevector->string)) :export (parse-endpoint-string make-routes) ) +;; Parses an endpoint description, and returns two values: +;; - a regex string which matches the rule +;; - the list of symbols embedded int the string +;; An endpoint string looks like +;; /calendar/:uid{.*}.ics +;; Where "/calendar/" matches literally +;; followed by something matching ".*" +;; followed by something literally matching ".ics" +;; and '(uid) would be the second return (define (parse-endpoint-string str) (let ((rx (make-regexp ":([^/.]+)(\\{([^}]+)\\})?([.])?"))) (let loop ((str str) @@ -38,87 +51,130 @@ (cons (string->symbol (match:substring m 1)) tokens))))))) - -(define ((generate-case regex-table) defn) - (match defn +(define ((generate-case regexes r:method r:path) stx) + (syntax-case stx () ((method uri param-list body ...) - (let* ((_ tokens (parse-endpoint-string uri)) - (diff intersect (lset-diff+intersection eq? param-list tokens))) - `((and (eq? r:method (quote ,method)) - (regexp-exec ,(car (assoc-ref regex-table uri)) r:path)) - => (lambda (match-object) - ;; (assert - ;; (= (1- (match:count match-object)) - ;; (length intersect))) + (let* ((regex tokens (parse-endpoint-string (syntax->datum #'uri))) + (diff intersect (lset-diff+intersection eq? (syntax->datum #'param-list) + tokens)) + (argument-list (if (null? diff) + #'() #`(key: #,@(map (lambda (x) (datum->syntax stx x)) diff) + allow-other-keys: rest: rest))) + (intersect-list (map (lambda (x) (datum->syntax stx x)) intersect)) + (rx-var (list-ref (assoc regex regexes) 1))) + #`((and (eq? #,r:method (quote method)) + (regexp-exec #,rx-var #,r:path)) + => (lambda (match-object) + ;; Those parameters which were present in the template uri + ((lambda #,intersect-list + ;; Those that only are in the query string + (lambda* #,argument-list body ...)) + #,@(unless (null? intersect) + (map (lambda (i) #`(match:substring match-object #,i)) + (cdr (iota (1+ (length intersect))))))))))))) + + + +(define-syntax (make-routes stx) + (syntax-case stx () + ((_ options-and-routes ...) + (with-syntax ((r:method (datum->syntax stx 'r:method)) + (r:uri (datum->syntax stx 'r:uri)) + (r:version (datum->syntax stx 'r:version)) + (r:headers (datum->syntax stx 'r:headers)) + (r:meta (datum->syntax stx 'r:meta)) + (r:scheme (datum->syntax stx 'r:scheme)) + (r:userinfo (datum->syntax stx 'r:userinfo)) + (r:host (datum->syntax stx 'r:host)) + (r:port (datum->syntax stx 'r:port)) + (r:path (datum->syntax stx 'r:path)) + (r:query (datum->syntax stx 'r:query)) + (r:fragment (datum->syntax stx 'r:fragment)) + + (return (datum->syntax stx 'return)) + (request (datum->syntax stx 'request)) + (body (datum->syntax stx 'body)) + (state (datum->syntax stx 'state)) + ) + + (define-values (options routes) + (let loop ((options '()) (items #'(options-and-routes ...))) + (when (null? items) + (scm-error 'misc-error "make-routes" + "Needs at least one route" '() #f)) + ;; (format #t "options: ~s, items: ~s~%" options items) + (let ((kv (syntax->datum (car items)))) + (if (keyword? kv) + (loop (cons (cons kv (cadr items)) + options) + (cddr items)) + (values (reverse options) items))))) + + ;; Ensures that all regexes are only compiled once. + ;; Given (GET "/today/" (view date) body ...) + ;; returns ("/today/" #'*random-symbol* #'(make-regexp "^/today//?$" regexp/icase)) + (define routes-regexes + (map (lambda (stx-1) + (syntax-case stx-1 () + ((%fst uri %rest ...) + (let ((regex _ (parse-endpoint-string (syntax->datum #'uri)))) + (list regex (datum->syntax stx (gensym "rx-")) + #`(make-regexp #,(string-append "^" regex "/?$") regexp/icase)))))) + routes)) + + #`(let #,(map cdr routes-regexes) + (lambda* (request body optional: state) + ;; All these bindings generate compile time warnings since the expansion + ;; of the macro might not use them. This isn't really a problem. + (let ((r:method ((@ (web request) request-method) request)) + (r:uri ((@ (web request) request-uri) request)) + (r:version ((@ (web request) request-version) request)) + (r:headers ((@ (web request) request-headers) request)) + (r:meta ((@ (web request) request-meta) request))) + (let ((r:scheme ((@ (web uri) uri-scheme) r:uri)) + (r:userinfo ((@ (web uri) uri-userinfo) r:uri)) + ;; uri-{host,port} is (probably) not set when we are a server, + ;; fetch them from the request instead + (r:host (or ((@ (web uri) uri-host) r:uri) + (and=> ((@ (web request) request-host) request) car))) + (r:port (or ((@ (web uri) uri-port) r:uri) + (and=> ((@ (web request) request-host) request) cdr))) + (r:path ((@ (web uri) uri-path) r:uri)) + (r:query ((@ (web uri) uri-query) r:uri)) + (r:fragment ((@ (web uri) uri-fragment) r:uri))) - ;; Those parameters which were present in the template uri - ((lambda ,intersect - ;; Those that only are in the query string - (lambda* (,@(unless (null? diff) `(key: ,@diff allow-other-keys:)) - rest: rest) - ,@body)) - ,@(unless (null? intersect) - (map (lambda (i) - `((@ (ice-9 regex) match:substring) match-object ,i)) - (cdr (iota (1+ (length intersect))))))))))))) + ;; TODO propper logging + (display (format #f "[~a] ~a ~a:~a~a?~a~%" + ;; TODO does this even work? Maybe it works due to datetime + ;; being included at all expansion points. + (datetime->string (current-datetime)) + r:method r:host r:port r:path (or r:query "")) + (current-error-port)) -(define-macro (make-routes . routes) - ;; Ensures that all regexes are only compiled once. - (define routes-regexes - (map (lambda (uri) - (define-values (regex _) (parse-endpoint-string uri)) - (list uri (gensym) `(make-regexp ,(string-append "^" regex "/?$") regexp/icase))) - (map cadr routes))) + (call-with-values + (lambda () + (call/ec (lambda (return) + (apply + (with-throw-handler #t + (lambda () + (cond #,@(map (generate-case routes-regexes #'r:method #'r:path) routes) + (else (lambda* _ (return (build-response code: 404) + "404 Not Fonud"))))) + #,(assoc-ref options with-throw-handler:)) + (append + (parse-query r:query) - `(let ,(map cdr routes-regexes) - (lambda* (request body optional: state) - ;; (format (current-error-port) "~a~%" request) - ;; All these bindings generate compile time warnings since the expansion - ;; of the macro might not use them. This isn't really a problem. - (let ((r:method ((@ (web request) request-method) request)) - (r:uri ((@ (web request) request-uri) request)) - (r:version ((@ (web request) request-version) request)) - (r:headers ((@ (web request) request-headers) request)) - (r:meta ((@ (web request) request-meta) request))) - (let ((r:scheme ((@ (web uri) uri-scheme) r:uri)) - (r:userinfo ((@ (web uri) uri-userinfo) r:uri)) - ;; uri-{host,port} is (probably) not set when we are a server, - ;; fetch them from the request instead - (r:host (or ((@ (web uri) uri-host) r:uri) - (and=> ((@ (web request) request-host) request) car))) - (r:port (or ((@ (web uri) uri-port) r:uri) - (and=> ((@ (web request) request-host) request) cdr))) - (r:path ((@ (web uri) uri-path) r:uri)) - (r:query ((@ (web uri) uri-query) r:uri)) - (r:fragment ((@ (web uri) uri-fragment) r:uri))) - ;; TODO propper logging - (display (format #f "[~a] ~a ~a:~a~a?~a~%" - (datetime->string (current-datetime)) - r:method r:host r:port r:path (or r:query "")) - (current-error-port)) - (call-with-values - (lambda () - ((@ (ice-9 control) call/ec) - (lambda (return) - (apply - (cond ,@(map (generate-case routes-regexes) routes) - (else (lambda* _ (return ((@ (web response) build-response) code: 404) - "404 Not Fonud")))) - (append - ((@ (web query) parse-query) r:query) + ;; When content-type is application/x-www-form-urlencoded, + ;; decode them, and add it to the argument list + (cond ((assoc-ref r:headers 'content-type) + => (lambda (content-type) + (let ((type args (car+cdr content-type))) + (case type + ((application/x-www-form-urlencoded) + (let ((encoding (or (assoc-ref args 'encoding) "UTF-8"))) + (parse-query (bytevector->string body encoding) + encoding))))))))))))) - ;; TODO what's happening here? - (let ((content-type (assoc-ref r:headers 'content-type))) - ((@ (hnh util) when) content-type - (let ((type (car content-type)) - (args (cdr content-type))) - ((@ (hnh util) when) - (eq? type 'application/x-www-form-urlencoded) - (let ((encoding (or (assoc-ref args 'encoding) "UTF-8"))) - ((@ (web query) parse-query) - ((@ (ice-9 iconv) bytevector->string) - body encoding) - encoding))))))))))) - (case-lambda ((headers body new-state) (values headers body new-state)) - ((headers body) (values headers body state)) - ((headers) (values headers "" state))))))))) + (case-lambda ((headers body new-state) (values headers body new-state)) + ((headers body) (values headers body state)) + ((headers) (values headers "" state)))))))))))) diff --git a/module/web/http/status-codes.scm b/module/web/http/status-codes.scm new file mode 100644 index 00000000..86be694f --- /dev/null +++ b/module/web/http/status-codes.scm @@ -0,0 +1,87 @@ +(define-module (web http status-codes) + :use-module (srfi srfi-88) + :export (http-status-codes + http-status-phrase + http-status-line)) + +;;; https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml +;;; DAV: RFC4918 + +(define http-status-codes + '((100 . "Continue") + (101 . "Switching Protocols") + (102 . "Processing") ;RFC2518 + (103 . "Early Hints") ;RFC8297 + + (200 . "OK") + (201 . "Created") + (202 . "Accepted") + (203 . "Non-Authoritative Information") + (204 . "No Content") + (205 . "Reset Content") + (206 . "Partial Content") + (207 . "Multi-Status") ;DAV + (208 . "Already Reported") ;RFC5842 + (226 . "IM Used") ;RFC3229 + + (300 . "Multiple Choices") + (301 . "Moved Permanently") + (302 . "Found") + (303 . "See Other") + (304 . "Not Modified") + (305 . "Use Proxy") + (306 . "(Unused)") + (307 . "Temporary Redirect") + (308 . "Permanent Redirect") + + (400 . "Bad Request") + (401 . "Unauthorized") + (402 . "Payment Required") + (403 . "Forbidden") + (404 . "Not Found") + (405 . "Method Not Allowed") + (406 . "Not Acceptable") + (407 . "Proxy Authentication Required") + (408 . "Request Timeout") + (409 . "Conflict") + (410 . "Gone") + (411 . "Length Required") + (412 . "Precondition Failed") ;Extended by DAV + (413 . "Request Entity Too Large") + (414 . "Request-URI Too Long") ;Extended by DAV + (415 . "Unsupported Media Type") + (416 . "Requested Range Not Satisfiable") + (417 . "Expectation Failed") + (418 . "I'm a teapot") ;RFC7168 + (421 . "Misdirection Request") + (422 . "Unprocessable Content") + (423 . "Locked") ;DAV + (424 . "Failed Dependency") ;DAV + (425 . "Too Early") ;RFC8470 + (426 . "Upgrade Required") + (428 . "Precondition Failed") ;RFC6585 + (429 . "Too Many Requests") ;RFC6585 + (431 . "Request Header Fields Too Large") ;RFC6585 + (451 . "Unavailable For Legal Reasons") ;RFC7225 + + (500 . "Internal Server Error") + (501 . "Not Implemented") + (502 . "Bad Gateway") + (503 . "Service Unavailable") + (504 . "Gateway Timeout") + (505 . "HTTP Version Not Supported") + (506 . "Variant Also Negotiates") ;RFC2295 + (507 . "Insufficient Storage") ;DAV + (508 . "Loop Detected") ;RFC5842 + (510 . "Not Extended") ;RFC2774 (OBSOLETED) + (511 . "Network Authentication Required") ;RFC6585 + )) + + +(define (http-status-phrase code) + (or (assoc-ref http-status-codes code) + "")) + +(define* (http-status-line code optional: msg) + (format #f "HTTP/1.1 ~a ~a" code + (or msg (http-status-phrase code)))) @@ -940,3 +940,19 @@ msgstr "<p><b>update-zoneinfo</b> laddar i teori ner och uppdaterar vår " msgid "Return up" msgstr "Återvänd uppåt" + +#, scheme-format +msgid "Event ~a updated in ~a~%" +msgstr "Händelse ~a uppdaterad i ~a~%" + +#, scheme-format +msgid "Event ~a added to ~a~%" +msgstr "Händelse ~a tillagd till ~a~%" + +#, scheme-format +msgid "end (~a) must be equal to or greater than start (~a)" +msgstr "slut (~a) måste vara större en eller lika med start (~a)" + +msgid "Redirecting to today, might take some time if server was just " + "restarted." +msgstr "Omdirigerar till idag, kan ta viss tid om servern just startated om." diff --git a/scripts/fetch-liu-map-index.scm b/scripts/fetch-liu-map-index.scm index 31db3844..2ac300e1 100755 --- a/scripts/fetch-liu-map-index.scm +++ b/scripts/fetch-liu-map-index.scm @@ -19,35 +19,54 @@ (ice-9 getopt-long) (sxml gumbo) (sxml match) - ((hnh util) :select (->)) + ((sxml xpath) :select (sxpath)) + ((hnh util) :select (-> ->>)) (json)) +;; Fallback to ensure we have HTTPS +(define http-get + (catch 'gnutls-not-available + (lambda () + ((@@ (web client) ensure-gnutls)) + (@ (web client) http-get)) + (lambda _ + (use-modules (ice-9 popen) + (web http)) + + (lambda (url . _) + (let ((pipe (open-pipe* OPEN_READ "curl" "--include" "--http1.1" url))) + (let ((intro (string-split (read-line pipe) #\space)) ; HTTP/1.1 200 OK\r + (headers (read-headers pipe))) + (let ((response + (build-response + version: (parse-http-version (list-ref intro 0)) + code: (string->number (list-ref intro 1)) + reason-phrase: (string-trim-right + (string-join (drop intro 2) " " 'infix) + char-whitespace?) + headers: headers + port: pipe + validate-headers?: #t))) + (values response pipe)))))))) ;; Parse string as HTML, find all links which are "map links", ;; and return them as an association list from name to url-fragments. -(define (get-data string) - (define data (html->sxml string)) - +(define (extract-data string) (define rx (make-regexp "^karta\\?")) - (define links - (map (lambda (node) - (sxml-match node - [(a (@ (href ,href)) ,b0 ,body ...) - (cons href b0)])) - (((@ (sxml xpath) sxpath) '(// a)) data))) - - (define map-links (filter (lambda (pair) (regexp-exec rx (car pair))) - links)) - - (define link-table (make-hash-table)) - (for-each (lambda (pair) (hash-set! link-table (string-upcase (string-trim-both (cdr pair))) - (car pair))) - map-links) + ;; for (let el of document.querySelectorAll('a[href*="karta?"]')) { + ;; ret[el.textContent.trim().toUpperCase()] = el.href + ;; } - (hash-map->list (lambda (name frag) - `(,name . ,frag)) - link-table)) + (->> (html->sxml string) + ((sxpath '(// a))) + (map (lambda (node) + (sxml-match node + [(a (@ (href ,href)) ,b0 ,body ...) + (cons href b0)]))) + (filter (lambda (pair) (regexp-exec rx (car pair)))) + (map (lambda (pair) (cons (string-upcase (string-trim-both (cdr pair))) + (car pair)))))) ;; Open a HTTP request to the given URL, and return the ;; response body as a port. @@ -85,9 +104,9 @@ (let ((port (cond ((option-ref options 'url #f) => open-input-url) - ((and=> (option-ref options 'file #f) (lambda (s) (string=? s "-"))) + ((string=? "-" (option-ref options 'file "")) (current-input-port)) ((option-ref options 'file #f) => open-input-file) (else (open-input-url "https://old.liu.se/karta/list?l=sv"))))) - (-> port read-string get-data scm->json) + (-> port read-string extract-data scm->json) (newline))) diff --git a/scripts/generate-test-data.scm b/scripts/generate-test-data.scm index 076558e4..b80c4994 100755 --- a/scripts/generate-test-data.scm +++ b/scripts/generate-test-data.scm @@ -63,8 +63,8 @@ (prop cal 'PRODID) "-//hugo//calp TEST//EN" (prop cal 'VERSION) "2.0") -(add-child! cal zoneinfo) -(add-child! cal ev) +(reparent! cal zoneinfo) +(reparent! cal ev) (define sxcal `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"") diff --git a/scripts/get-config.scm b/scripts/get-config.scm index 7d6abfcd..99204941 100755 --- a/scripts/get-config.scm +++ b/scripts/get-config.scm @@ -8,8 +8,7 @@ ;;; Code: -(add-to-load-path "module") -(add-to-load-path "scripts") +(add-to-load-path (string-append (dirname (dirname (current-filename))) "/module")) (use-modules (hnh util) @@ -18,8 +17,10 @@ (srfi srfi-1) (srfi srfi-88) - (all-modules) - (module-introspection) + (hnh module-introspection all-modules) + (hnh module-introspection module-introspection) + ((hnh module-introspection static-util) + :select (get-forms)) ((calp translation) :select (translate)) diff --git a/scripts/input.scm b/scripts/input.scm index 3589a45a..626f5346 100755 --- a/scripts/input.scm +++ b/scripts/input.scm @@ -6,7 +6,7 @@ ;;; `c' to clear screen, `q' to quit. ;;; Code: -(add-to-load-path "module") +(add-to-load-path (string-append (dirname (dirname (current-filename))) "/module")) (use-modules (vulgar)) (define chrlist '()) diff --git a/scripts/module-imports.scm b/scripts/module-imports.scm deleted file mode 100755 index 6a0a5beb..00000000 --- a/scripts/module-imports.scm +++ /dev/null @@ -1,65 +0,0 @@ -#!/usr/bin/guile \ --e main -s -!# - -;;; Commentary: -;;; -;;; Scripts which finds unused imports in each file. -;;; Uses Guile's module system reflection to find what is imported, -;;; but simple looks at all unique symbols in the source file for what -;;; is used, which might lead to some discrepancies. -;;; -;;; Code: - -(add-to-load-path (string-append (dirname (dirname (current-filename))) "/module")) -(add-to-load-path (dirname (current-filename))) - -(use-modules (hnh util) - ((srfi srfi-1) :select (lset-difference)) - (rnrs lists) - (module-introspection)) - - -;;; Module use high scores -;;; $ grop -Ho '#\?:use-module' -R module | uniq -c | sort -n - -(define (main args) - (define filename (cadr args)) - (define-values (module-declaration-lst forms) - (partition module-declaration? - (reverse (call-with-input-file filename get-forms)))) - ;; All symbols in source file, which are not in module declaration. - ;; Otherwise all explicitly imported symbols would be marked as - ;; used. - (define symbs (unique-symbols forms)) - ;; (format #t "~y" (find-module-declaration forms)) - ;; (format #t "~a~%" symbs) - - (format #t "=== ~a ===~%" filename) - (for-each (lambda (mod) - - ;; all symbols imported from module - (define all-symbols (module-map (lambda (key value) key) mod)) - - ;; Thes subset of all imported symbols from module which are used - (define used-symbols - (filter (lambda (symb) (memv symb symbs)) - all-symbols)) - - (define used-count (length used-symbols)) - (define total-count (length (module-map list mod))) - - (format #t "~a/~a ~a~% used ~s~% unused ~s~%" - used-count total-count (module-name mod) - used-symbols - (lset-difference eq? all-symbols used-symbols))) - - (remp (lambda (mod) - (member (module-name mod) - '((guile) - (guile-user) - (srfi srfi-1) - ))) - (module-uses (resolve-module - (cadr (car module-declaration-lst)))))) - (newline)) diff --git a/scripts/module-introspection.scm b/scripts/module-introspection.scm deleted file mode 100644 index dc430d8a..00000000 --- a/scripts/module-introspection.scm +++ /dev/null @@ -1,43 +0,0 @@ -(define-module (module-introspection) - :use-module (srfi srfi-1) - :use-module (hnh util) - :export (get-forms - uniq - unique-symbols - find-module-declaration - module-declaration? - )) - - -(define (get-forms port) - (let loop ((done '())) - (let ((form (read port))) - (if (eof-object? form) - done - (loop (cons form done)))))) - - -(define (uniq lst) - (cond ((null? lst) lst) - ((null? (cdr lst)) lst) - ((and (pair? lst) - (eqv? (car lst) (cadr lst))) - (uniq (cons (car lst) (cddr lst)))) - (else (cons (car lst) - (uniq (cdr lst)))))) - - -(define (unique-symbols tree) - (uniq - (sort* (filter symbol? (flatten tree)) - string<? symbol->string))) - - -(define (module-declaration? form) - (cond ((null? form) #f) - ((not (pair? form)) #f) - (else (eq? 'define-module (car form))))) - -(define (find-module-declaration forms) - (and=> (find module-declaration? forms) - cadr)) diff --git a/scripts/set-version b/scripts/set-version index 6f9d694c..fef13e90 100755 --- a/scripts/set-version +++ b/scripts/set-version @@ -6,4 +6,4 @@ fi VERSION=$1 sed -i "s/^pkgver=.*/pkgver=$VERSION/" system/PKGBUILD -sed -i "s/^(define-public version.*/(define-public version \"$VERSION\")/" module/calp.scm +sed -i "s/^(define version.*/(define version \"$VERSION\")/" module/calp.scm diff --git a/scripts/use2dot-all.sh b/scripts/use2dot-all.sh new file mode 100755 index 00000000..80703d33 --- /dev/null +++ b/scripts/use2dot-all.sh @@ -0,0 +1,8 @@ +#!/bin/sh + +guild use2dot-all \ + --engine fdp \ + --output graph.pdf \ + --default-module '(calp main)' \ + --remove '((datetime) (vcomponent) (hnh util))' \ + module diff --git a/scripts/use2dot/gen-use.scm b/scripts/use2dot/gen-use.scm deleted file mode 100755 index 6c621fdd..00000000 --- a/scripts/use2dot/gen-use.scm +++ /dev/null @@ -1,141 +0,0 @@ -#!/usr/bin/guile -s -!# - -(add-to-load-path (dirname (current-filename))) -(add-to-load-path (dirname (dirname (current-filename)))) - -(use-modules ((scripts frisk) :select (make-frisker edge-type edge-up - edge-down)) - (srfi srfi-1) - ((graphviz) :prefix gv.) - (all-modules) - ) - -(define scan (make-frisker `(default-module . (calp main)))) - -(define-values (files our-modules) - (all-modules-under-directory "module")) - -(define graph (gv.digraph "G")) -(gv.setv graph "color" "blue") -(gv.setv graph "compound" "true") -(gv.setv graph "overlap" "prism") -;; (gv.setv graph "bgcolor" "blue") - -(define count 0) - -(define colors - '("red" "green" "blue")) - -(define rem our-modules) - -;; (for-each (lambda (key) -;; -;; (define subgraph (gv.graph graph (format #f "cluster_~a" count))) -;; -;; (define-values (use rem*) (partition (lambda (mod) (eq? key (car mod))) rem)) -;; (set! rem rem*) -;; -;; ;; (gv.setv subgraph "rankdir" "TB") -;; (gv.setv subgraph "color" (list-ref colors count)) -;; -;; (for-each (lambda (name) -;; (gv.node subgraph (format #f "~a" name))) -;; use) -;; -;; (set! count (1+ count)) -;; ) -;; '(calp vcomponent)) - -;; (define subgraph (gv.graph graph (format #f "cluster_~a" count))) -;; -;; ;; (gv.setv subgraph "rankdir" "TB") -;; (gv.setv subgraph "color" (list-ref colors count)) -;; -;; (for-each (lambda (name) -;; (gv.node subgraph (format #f "~a" name))) -;; rem) - -(define subgraph (gv.graph graph (format #f "cluster_~a" 0))) - -;; (gv.setv subgraph "rankdir" "TB") -(gv.setv subgraph "color" "Red") - -(define subgraphs (make-hash-table)) - -(for-each (lambda (name) - (let ((g (hashq-ref subgraphs (car name) - (gv.graph graph (format #f "cluster_~a" (car name)))))) - (hashq-set! subgraphs (car name) g) - - (let ((node (gv.node g (format #f "~a" name)))) - (gv.setv node "fillcolor" "green") - (gv.setv node "style" "filled") - )) - ) - (remove (lambda (x) (eq? 'calp (car x))) - our-modules)) - - -(define calp-base (gv.graph graph "cluster_1")) -(define calpgraphs (make-hash-table)) - -(for-each (lambda (name) - (let ((g (hashq-ref calpgraphs (cadr name) - (gv.graph - ;; calp-base - graph - (format #f "cluster_~a" (cadr name)))))) - (hashq-set! calpgraphs (car name) g) - - (let ((node (gv.node g (format #f "~a" name)))) - (gv.setv node "fillcolor" "green") - (gv.setv node "style" "filled") - )) - ) - (remove (compose null? cdr) - (filter (lambda (x) (eq? 'calp (car x))) - our-modules))) - - -(define (remove-edges blacklist edges) - (remove (lambda (edge) - (or (member (edge-up edge) blacklist) - (member (edge-down edge) blacklist))) - edges)) - - - - - -(for-each (lambda (edge) - (let ((gv-edge (gv.edge graph - (format #f "~a" (edge-down edge)) - (format #f "~a" (edge-up edge)) - ))) - (when (and (eq? 'calp (car (edge-up edge))) - (not (eq? 'calp (car (edge-down edge))))) - (gv.setv gv-edge "color" "red")) - (when (and (memv (car (edge-up edge)) '(vcomponent calp)) - (not (memv (car (edge-down edge)) '(vcomponent calp )))) - (gv.setv gv-edge "color" "blue")) - )) - (remove-edges '((srfi srfi-1) - (srfi srfi-9) - (srfi srfi-26) - (srfi srfi-41) - - (ice-9 match) - (ice-9 format) - - (datetime) - (vcomponent) - (hnh util) - ) - ((scan files) 'edges))) - -(gv.layout graph "fdp") -(gv.render graph "pdf" "graph.pdf") - - -(display "done\n") diff --git a/static/Makefile b/static/Makefile index 9292ed8a..2f715f7e 100644 --- a/static/Makefile +++ b/static/Makefile @@ -1,22 +1,29 @@ -.PHONY: all install clean watch +.PHONY: all install clean watch watch-esbuild -TARGETS := style.css smallcal.css script.out.js directory-listing.css +TARGETS := style.css smallcal.css script.js directory-listing.css WATCH= TS_FILES = $(shell find . -type f -name \*.ts -not -path */node_modules/*) JS_FILES = $(TS_FILES:%.ts=%.js) +ESBUILD_LOGLEVEL=warning +# Variable for adding extra flags +ESBUILD_FLAGS = +# Used flags +__ESBUILD_FLAGS = --log-level=$(ESBUILD_LOGLEVEL) \ + --sourcemap --bundle --outdir=$(CURDIR) \ + $(ESBUILD_FLAGS) + export PATH := $(shell npm bin):$(PATH) all: $(TARGETS) -%.map.json: %.out.js - tail -n1 $< | tail -c+65 | base64 --decode | jq '.' > $@ - -# r!browserify --list script.ts -p tsify | xargs -L1 basename | tac # script explicitly named, since that is our entry point -script.out.js: script.ts $(TS_FILES) - browserify $< -p tsify --noImplicitAny --debug -o $@ +script.js: script.ts $(TS_FILES) + esbuild $< $(__ESBUILD_FLAGS) + +watch-esbuild: + $(MAKE) ESBUILD_FLAGS+='--watch' ESBUILD_LOGLEVEL=info -B script.js deps.svg: $(TS_FILES) madge --image $@ $^ @@ -25,10 +32,11 @@ watch: ./make-watch install: all + install -d $(DESTDIR)/usr/share/calp/www install -m644 -t $(DESTDIR)/usr/share/calp/www/ $(TARGETS) clean: - rm $(TARGETS) + -rm $(TARGETS) %.css: %.scss - scss $(WATCH) -I. $< $@ + scss -E UTF-8 $(WATCH) -I. $< $@ diff --git a/static/elements.ts b/static/components.ts index e5fabba6..e5fabba6 100644 --- a/static/elements.ts +++ b/static/components.ts diff --git a/static/components/date-time-input.ts b/static/components/date-time-input.ts index 005e4190..20e9a505 100644 --- a/static/components/date-time-input.ts +++ b/static/components/date-time-input.ts @@ -68,7 +68,6 @@ class DateTimeInput extends /* HTMLInputElement */ HTMLElement { set value(date: Date) { let [d, t] = date.format("~L~Y-~m-~dT~H:~M").split('T'); - // console.log(d, t); this.date.value = d; this.time.value = t; @@ -98,7 +97,6 @@ class DateTimeInput extends /* HTMLInputElement */ HTMLElement { } set stringValue(new_value: Date | string) { - // console.log('Setting date'); let date, time, dateonly = false; if (new_value instanceof Date) { date = new_value.format("~L~Y-~m-~d"); diff --git a/static/components/input-list.ts b/static/components/input-list.ts index 34696e3e..0afd4999 100644 --- a/static/components/input-list.ts +++ b/static/components/input-list.ts @@ -1,7 +1,5 @@ export { InputList } -/* This file replaces input_list.js */ - /* TODO allow each item to be a larger unit, possibly containing multiple input fields. diff --git a/static/components/popup-element.ts b/static/components/popup-element.ts index 3300f885..458f543c 100644 --- a/static/components/popup-element.ts +++ b/static/components/popup-element.ts @@ -71,10 +71,12 @@ class PopupElement extends ComponentVEvent { return ['visible']; } - attributeChangedCallback(name: string, oldValue?: string, newValue?: string) { + attributeChangedCallback(name: string, _?: string, newValue?: string) { switch (name) { case 'visible': - this.onVisibilityChange() + if (newValue !== null) + /* Only run resize code when showing the popup */ + this.onVisibilityChange() break; } } @@ -92,6 +94,7 @@ class PopupElement extends ComponentVEvent { } private onVisibilityChange() { + console.log('here'); /* TODO better way to find root */ let root; diff --git a/static/components/slider.ts b/static/components/slider.ts index a48d5a40..48abc91b 100644 --- a/static/components/slider.ts +++ b/static/components/slider.ts @@ -24,14 +24,14 @@ class SliderInput extends HTMLElement { constructor(min?: number, max?: number, step?: number, value?: number) { super(); - this.min = min || parseFloat(this.getAttribute('min') || ""+dflt['min']); - this.max = max || parseFloat(this.getAttribute('max') || ""+dflt['max']); - this.step = step || parseFloat(this.getAttribute('step') || ""+dflt['step']); + this.min = min || parseFloat(this.getAttribute('min') || "" + dflt['min']); + this.max = max || parseFloat(this.getAttribute('max') || "" + dflt['max']); + this.step = step || parseFloat(this.getAttribute('step') || "" + dflt['step']); // https://developer.mozilla.org/en-US/docs/Web/HTML/Element/input/range#value const defaultValue = (this.max < this.min) - ? this.min - : this.min + (this.max - this.min)/2; + ? this.min + : this.min + (this.max - this.min) / 2; this.slider = makeElement('input', { type: 'range', @@ -48,8 +48,8 @@ class SliderInput extends HTMLElement { value: this.value, }) as HTMLInputElement - this.slider.addEventListener('input', (e) => this.propagate(e)); - this.textIn.addEventListener('input', (e) => this.propagate(e)); + this.slider.addEventListener('input', e => this.propagate(e)); + this.textIn.addEventListener('input', e => this.propagate(e)); /* MUST be after sub components are bound */ this.value = "" + (value || this.getAttribute('value') || defaultValue); @@ -64,7 +64,7 @@ class SliderInput extends HTMLElement { return ['min', 'max', 'step'] } - attributeChangedCallback(name: Attribute, _: string|null, to: string|null): void { + attributeChangedCallback(name: Attribute, _?: string, to?: string): void { if (to) { this.slider.setAttribute(name, to); this.textIn.setAttribute(name, to); @@ -72,7 +72,7 @@ class SliderInput extends HTMLElement { this.slider.removeAttribute(name); this.textIn.removeAttribute(name); } - this[name] = parseFloat(to || ""+dflt[name]) + this[name] = parseFloat(to || "" + dflt[name]) } propagate(e: Event) { diff --git a/static/components/vevent-block.ts b/static/components/vevent-block.ts index 8cf61d30..9bbb8e7e 100644 --- a/static/components/vevent-block.ts +++ b/static/components/vevent-block.ts @@ -91,7 +91,7 @@ class ComponentBlock extends ComponentVEvent { if (data.getProperty('rrule') !== undefined) { let rep = this.getElementsByClassName('repeating') - if (rep && rep.length !== 0) { + if (rep.length !== 0) { (rep[0] as HTMLElement).innerText = '↺' } } diff --git a/static/components/vevent-description.ts b/static/components/vevent-description.ts index 463725f1..b44185e7 100644 --- a/static/components/vevent-description.ts +++ b/static/components/vevent-description.ts @@ -2,7 +2,7 @@ export { ComponentDescription } import { VEvent } from '../vevent' import { ComponentVEvent } from './vevent' -import { formatters } from '../formatters' +import { format } from '../formatters' /* <vevent-description /> @@ -23,14 +23,7 @@ class ComponentDescription extends ComponentVEvent { for (let el of body.querySelectorAll('[data-property]')) { if (!(el instanceof HTMLElement)) continue; - let p = el.dataset.property!; - let d; - if ((d = data.getProperty(p))) { - let key = p.toLowerCase(); - let f = formatters.get(key); - if (f) f(el, data, d); - else window.formatters.get('default')!(el, data, d); - } + format(el, data, el.dataset.property!); } let repeating = body.getElementsByClassName('repeating')[0] as HTMLElement diff --git a/static/components/vevent-edit.ts b/static/components/vevent-edit.ts index bf72678c..e3b5d105 100644 --- a/static/components/vevent-edit.ts +++ b/static/components/vevent-edit.ts @@ -25,31 +25,22 @@ class ComponentEdit extends ComponentVEvent { let body = frag.firstElementChild! this.replaceChildren(body); + let data = vcal_objects.get(this.uid) + if (!data) { + throw `Data missing for uid ${this.dataset.uid}.` + } + for (let el of this.querySelectorAll('[data-label]')) { let label = document.createElement('label'); let id = el.id || gensym('input'); el.id = id; label.htmlFor = id; label.textContent = (el as HTMLElement).dataset.label!; + el.parentElement!.insertBefore(label, el); } - } - - connectedCallback() { - - /* Edit tab is rendered here. It's left blank server-side, since - it only makes sense to have something here if we have javascript */ - - let data = vcal_objects.get(this.uid) - - if (!data) { - throw `Data missing for uid ${this.dataset.uid}.` - } - - - // return; /* Handle calendar dropdown */ - for (let el of this.getElementsByClassName('calendar-selection')) { + for (let el of this.querySelectorAll('select.calendar-selection')) { for (let opt of el.getElementsByTagName('option')) { opt.selected = false; } @@ -57,21 +48,19 @@ class ComponentEdit extends ComponentVEvent { (el as HTMLSelectElement).value = data.calendar; } - el.addEventListener('change', (e) => { + el.addEventListener('change', e => { let v = (e.target as HTMLSelectElement).selectedOptions[0].value let obj = vcal_objects.get(this.uid)! obj.calendar = v; }); } - this.redraw(data); // for (let el of this.getElementsByClassName("interactive")) { for (let el of this.querySelectorAll("[data-property]")) { // console.log(el); - el.addEventListener('input', (e) => { + el.addEventListener('input', () => { let obj = vcal_objects.get(this.uid) - // console.log(el, e); if (obj === undefined) { throw 'No object with uid ' + this.uid } @@ -83,7 +72,6 @@ class ComponentEdit extends ComponentVEvent { console.log(el, 'not an HTMLInputElement'); return; } - // console.log(`obj[${el.dataset.property!}] = `, el.value); obj.setProperty( el.dataset.property!, el.value) @@ -135,6 +123,22 @@ class ComponentEdit extends ComponentVEvent { }); } + connectedCallback() { + + /* Edit tab is rendered here. It's left blank server-side, since + it only makes sense to have something here if we have javascript */ + + let data = vcal_objects.get(this.uid) + + if (!data) { + throw `Data missing for uid ${this.dataset.uid}.` + } + + this.redraw(data); + + // return; + } + redraw(data: VEvent) { /* We only update our fields, instead of reinstansiating ourselves from the template, in hope that it's faster */ diff --git a/static/components/vevent.ts b/static/components/vevent.ts index 5852a2ff..7487cbb6 100644 --- a/static/components/vevent.ts +++ b/static/components/vevent.ts @@ -10,12 +10,12 @@ Lacks an accompaning tag, and shouldn't be directly instanciated. */ abstract class ComponentVEvent extends HTMLElement { - template: HTMLTemplateElement | null + template?: HTMLTemplateElement uid: string constructor(uid?: string) { super(); - this.template = document.getElementById(this.tagName.toLowerCase()) as HTMLTemplateElement | null + this.template = document.getElementById(this.tagName.toLowerCase()) as HTMLTemplateElement | undefined let real_uid; diff --git a/static/event-creator.ts b/static/event-creator.ts index 0f2c42b4..5e55e64e 100644 --- a/static/event-creator.ts +++ b/static/event-creator.ts @@ -9,11 +9,11 @@ import { ical_type } from './types' class EventCreator { /* Event which we are trying to create */ - ev: VEvent | null = null; + ev?: VEvent /* Graphical block for event. Only here so we can find its siblings, and update pointer events accordingly */ - event: Element | null = null; + event?: Element event_start: { x: number, y: number } = { x: NaN, y: NaN } down_on_event: boolean = false @@ -160,7 +160,7 @@ class EventCreator { create_event_finisher(callback: ((ev: VEvent) => void)) { let that = this; - return function create_event_up(e: MouseEvent) { + return function create_event_up(_: MouseEvent) { if (!that.ev) return; /* Restore pointer events for all existing events. @@ -171,8 +171,8 @@ class EventCreator { } let localevent = that.ev; - that.ev = null - that.event = null; + that.ev = undefined + that.event = undefined; callback(localevent); diff --git a/static/formatters.ts b/static/formatters.ts index 5605e051..e0018278 100644 --- a/static/formatters.ts +++ b/static/formatters.ts @@ -1,11 +1,11 @@ export { - formatters, + format } import { makeElement } from './lib' import { VEvent } from './vevent' -type formatter = (e: HTMLElement, d: VEvent, s: any) => void +type formatter = (e: HTMLElement, d: VEvent, s: any) => Promise<void> declare global { interface Window { @@ -16,8 +16,24 @@ declare global { let formatters: Map<string, formatter>; formatters = window.formatters = new Map(); +async function format(targetElement: HTMLElement, data: VEvent, key: string): Promise<void> { + let d = data.getProperty(key); + if (!d) return + let formatter = formatters.get(key.toLowerCase()); + if (formatter) { + try { + await formatter(targetElement, data, d); + } catch (error) { + console.warn('Formatter failed') + console.warn(error); + formatters.get('default')!(targetElement, data, d); + } + } else { + formatters.get('default')!(targetElement, data, d); + } +} -formatters.set('categories', (el, _, d) => { +formatters.set('categories', async (el, _, d) => { for (let item of d) { let q = encodeURIComponent( `(member "${item}" (or (prop event (quote CATEGORIES)) (quote ())))`) @@ -28,7 +44,7 @@ formatters.set('categories', (el, _, d) => { } }) -function format_time_tag(el: HTMLElement, ev: VEvent, d: any): void { +async function format_time_tag(el: HTMLElement, ev: VEvent, d: any): Promise<void> { if (el instanceof HTMLTimeElement) { if (d instanceof Date) { let fmt = ''; @@ -49,7 +65,7 @@ function format_time_tag(el: HTMLElement, ev: VEvent, d: any): void { formatters.set('dtstart', format_time_tag) formatters.set('dtend', format_time_tag) -formatters.set('default', (el, _, d) => { +formatters.set('default', async (el, _, d) => { let fmt; if ((fmt = el.dataset.fmt)) { el.textContent = d.format(fmt); diff --git a/static/globals.ts b/static/globals.ts index d90a3681..243e15e4 100644 --- a/static/globals.ts +++ b/static/globals.ts @@ -20,7 +20,7 @@ declare global { EDIT_MODE: boolean; default_calendar: string; - addNewEvent: ((e: any) => void); + addNewEvent(): void; } } window.vcal_objects = vcal_objects; diff --git a/static/make-watch b/static/make-watch index c985b37f..b328038a 100755 --- a/static/make-watch +++ b/static/make-watch @@ -8,15 +8,14 @@ cd "$here" || { export PATH="$here/node_modules/.bin:$PATH" -# Note that 'tsc --watch' doesn't provide the files we are using. It's -# just here for debug. if [ -n "$TMUX" ]; then tmux new-window "scss --watch -I. style.scss:style.css" tmux new-window "tsc --watch" else tmux \ new-session "scss --watch -I. style.scss:style.css" \; \ - split-window "tsc --watch" \; \ + split-window "tsc --watch --noEmit" \; \ + split-window "make watch-esbuild" \; \ rename-session "calp watch" \; \ select-layout even-vertical diff --git a/static/package.json b/static/package.json index 27ea218a..81db3a61 100644 --- a/static/package.json +++ b/static/package.json @@ -1,13 +1,11 @@ { - "dependencies": { - "browserify": "^17.0.0", - "tsify": "^5.0.4" - }, "devDependencies": { - "@types/uuid": "^8.3.1", - "uuid": "^8.3.2" + "@types/uuid": "^8.3.1" }, "optionalDependencies": { "madge": "^5.0.1" + }, + "dependencies": { + "uuid": "^8.3.2" } } diff --git a/static/script.ts b/static/script.ts index ec771773..9238d834 100644 --- a/static/script.ts +++ b/static/script.ts @@ -6,7 +6,7 @@ import { import { vcal_objects, event_calendar_mapping } from './globals' import { EventCreator } from './event-creator' import { PopupElement, setup_popup_element } from './components/popup-element' -import { initialize_components } from './elements' +import { initialize_components } from './components' /* calp specific stuff diff --git a/static/server_connect.ts b/static/server_connect.ts index d1a544eb..29f5bab2 100644 --- a/static/server_connect.ts +++ b/static/server_connect.ts @@ -64,7 +64,7 @@ async function create_event(event: VEvent) { return; } - console.log('calendar=', calendar/*, xml*/); + console.log('calendar =', atob(calendar)/*, xml*/); let data = new URLSearchParams(); data.append("cal", calendar); diff --git a/static/style.scss b/static/style.scss index 578288b4..d5920f79 100644 --- a/static/style.scss +++ b/static/style.scss @@ -819,7 +819,7 @@ popup-element { /* some form of sensible minimi and default size for the popup (s main area). */ min-width: 150px; width: 350px; - height: 250px; + height: 300px; } } diff --git a/static/user/user-additions.js b/static/user/user-additions.js index 7291f232..3a2951e0 100644 --- a/static/user/user-additions.js +++ b/static/user/user-additions.js @@ -1,4 +1,4 @@ -window.formatters.set('description', (el, ev, d) => { +window.formatters.set('description', async (el, ev, d) => { if (ev.getProperty('X-MICROSOFT-SKYPETEAMSMEETINGURL')) { /* parse Microsoft Teams meeting entries */ /* Replace lines with propper <hr> tags */ @@ -32,7 +32,7 @@ window.formatters.set('description', (el, ev, d) => { idx = match.index + match[0].length } children.push(d.substring(idx)); - el.replaceChildren(...children); + el.replaceChildren(...children); } else if (/<\/?\w+( +\w+(=["']?\w+["']?)?)* *\/?>/.exec(d)) { /* Assume that the text is HTML if it contains something which looks like an HTML tag */ @@ -68,37 +68,41 @@ window.formatters.set('description', (el, ev, d) => { window.salar = new Promise((resolve, reject) => fetch('/static/user/salar.json') - .then(resp => { if (! resp.ok) reject("404"); else resp.json() }) + .then(resp => ! resp.ok ? reject("404") : resp.json()) .then(d => resolve(d)) .catch(err => reject(err)) ) - window.formatters.set('location', async function(el, _, d) { - let rx = /Lokal: (.*)/ - let m = rx.exec(d) - if (! m) { - el.textContent = d; - return; - } + let salar; try { - let salar = await window.salar; + salar = await window.salar; } catch (e) { console.warn("Location formatter failed", e); return; } - let name = m[1] - let frag = salar[name]; - if (frag) { - let anch = document.createElement('a'); - anch.href = `https://old.liu.se/karta/${frag}` - anch.target = '_blank' - anch.textContent = name; - el.append('Lokal: '); - el.append(anch); - } else { - el.textContent = `Lokal: ${name}` + let rx = /Lokal: ([A-Za-z0-9]*)?/g + + let idx = 0; + let children = [] + for (let match of d.matchAll(rx)) { + children.push(d.substring(idx, match.index)) + let name = match[1] + let frag = salar[name.toUpperCase()]; + if (frag) { + let anch = document.createElement('a'); + anch.href = `https://old.liu.se/karta/${frag}` + anch.target = '_blank' + anch.textContent = name; + children.push('Lokal: '); + children.push(anch); + } else { + children.push(`Lokal: ${name}`) + } + idx = match.index + match[0].length } + children.push(d.substring(idx)); + el.replaceChildren(...children) }) diff --git a/static/vevent.ts b/static/vevent.ts index 6a2c6f0f..f3606f70 100644 --- a/static/vevent.ts +++ b/static/vevent.ts @@ -9,7 +9,7 @@ export { /* Something which can be redrawn */ interface Redrawable extends HTMLElement { - redraw: ((data: VEvent) => void) + redraw(data: VEvent): void } function isRedrawable(x: HTMLElement): x is Redrawable { @@ -26,7 +26,7 @@ class VEventValue { value: any parameters: Map<string, any> - constructor(type: ical_type, value: any, parameters = new Map()) { + constructor(type: ical_type, value: any, parameters = new Map) { this.type = type; this.value = value; this.parameters = parameters; @@ -37,7 +37,7 @@ class VEventValue { let v = this.value; switch (this.type) { case 'binary': - /* TOOD */ + /* TODO */ value = 'BINARY DATA GOES HERE'; break; case 'date-time': @@ -76,7 +76,7 @@ class VEventValue { } } -/* maybe ... */ +/* TODO maybe ... */ class VEventDuration extends VEventValue { } @@ -514,7 +514,7 @@ function xml_to_vcal(xml: Element): VEvent { let property_map: Map<string, VEventValue | VEventValue[]> = new Map; if (properties) { - property_loop: + /* property_loop: */ for (var i = 0; i < properties.childElementCount; i++) { let tag = properties.childNodes[i]; if (!(tag instanceof Element)) continue; diff --git a/tests/formats/README.md b/tests/formats/README.md new file mode 100644 index 00000000..b17bd866 --- /dev/null +++ b/tests/formats/README.md @@ -0,0 +1,9 @@ +Serialization and deserialization formats +========================================= + +`test.scm` runs every other test. + +xcal +---- + +The program handles xml trees with a default namespace fine, but diff does not. diff --git a/tests/formats/event.ics b/tests/formats/event.ics new file mode 100644 index 00000000..5b578627 --- /dev/null +++ b/tests/formats/event.ics @@ -0,0 +1,27 @@ +BEGIN:VCALENDAR
+PRODID:-//PIMUTILS.ORG//NONSGML khal / icalendar //EN
+VERSION:2.0
+BEGIN:VTIMEZONE
+TZID:Europe/Stockholm
+BEGIN:DAYLIGHT
+DTSTART;VALUE=DATE-TIME:20180325T030000
+TZNAME:CEST
+TZOFFSETFROM:+0100
+TZOFFSETTO:+0200
+END:DAYLIGHT
+BEGIN:STANDARD
+DTSTART;VALUE=DATE-TIME:20181028T020000
+TZNAME:CET
+TZOFFSETFROM:+0200
+TZOFFSETTO:+0100
+END:STANDARD
+END:VTIMEZONE
+BEGIN:VEVENT
+DTEND;TZID=Europe/Stockholm;VALUE=DATE-TIME:20180907T180000
+DTSTAMP;VALUE=DATE-TIME:20180907T154223Z
+DTSTART;TZID=Europe/Stockholm;VALUE=DATE-TIME:20180907T170000
+SEQUENCE:0
+SUMMARY:Backhäfv
+UID:ZSGUP6BTM52UV42SEWBICHSS63V8DYQX5TSZ
+END:VEVENT
+END:VCALENDAR
diff --git a/tests/formats/event.xcs b/tests/formats/event.xcs new file mode 100644 index 00000000..c3fd817f --- /dev/null +++ b/tests/formats/event.xcs @@ -0,0 +1,50 @@ +<?xml version="1.0"?> +<c:icalendar xmlns:c="urn:ietf:params:xml:ns:icalendar-2.0"> + <c:vcalendar> + <c:properties> + <c:prodid> + <c:text>-//PIMUTILS.ORG//NONSGML khal / icalendar //EN</c:text> + </c:prodid> + <c:version> + <c:text>2.0</c:text> + </c:version> + </c:properties> + <c:components> + <c:vtimezone> + <c:properties> + <c:tzid> + <c:text>Europe/Stockholm</c:text> + </c:tzid> + </c:properties> + <c:components> + <c:daylight> + <c:properties> + <c:dtstart><c:date-time>2018-03-25T03:00:00</c:date-time></c:dtstart> + <c:tzname><c:text>CEST</c:text></c:tzname> + <c:tzoffsetfrom><c:utc-offset>+0100</c:utc-offset></c:tzoffsetfrom> + <c:tzoffsetto><c:utc-offset>+0200</c:utc-offset></c:tzoffsetto> + </c:properties> + </c:daylight> + <c:standard> + <c:properties> + <c:dtstart><c:date-time>2018-10-28T02:00:00</c:date-time></c:dtstart> + <c:tzname><c:text>CET</c:text></c:tzname> + <c:tzoffsetfrom><c:utc-offset>+0200</c:utc-offset></c:tzoffsetfrom> + <c:tzoffsetto><c:utc-offset>+0100</c:utc-offset></c:tzoffsetto> + </c:properties> + </c:standard> + </c:components> + </c:vtimezone> + <c:vevent> + <c:properties> + <c:dtend><c:parameters><c:tzid><c:text>Europe/Stockholm</c:text></c:tzid></c:parameters><c:date-time>2018-09-07T18:00:00</c:date-time></c:dtend> + <c:dtstamp><c:date-time>2018-09-07T15:42:23Z</c:date-time></c:dtstamp> + <c:dtstart><c:parameters><c:tzid><c:text>Europe/Stockholm</c:text></c:tzid></c:parameters><c:date-time>2018-09-07T17:00:00</c:date-time></c:dtstart> + <c:sequence><c:integer>0</c:integer></c:sequence> + <c:summary><c:text>Backhäfv</c:text></c:summary> + <c:uid><c:text>ZSGUP6BTM52UV42SEWBICHSS63V8DYQX5TSZ</c:text></c:uid> + </c:properties> + </c:vevent> + </c:components> + </c:vcalendar> +</c:icalendar> diff --git a/tests/formats/ical.scm b/tests/formats/ical.scm new file mode 100644 index 00000000..5747e2ea --- /dev/null +++ b/tests/formats/ical.scm @@ -0,0 +1,24 @@ +(define-module (ical) + :use-module (srfi srfi-88) + :use-module ((hnh util) :select (sort*)) + :use-module (hnh util path) + :use-module ((rnrs io ports) :select (get-string-all)) + :use-module ((vcomponent formats ical) :prefix #{ics:}#) + :export (sanitize-string + serialize + deserialize + component-str)) + +;; Technically not back into source, since order of children isn't +;; stable. That's also why we just check that all lines are present, +;; regardless of order. +(define (sanitize-string str) + (sort* (string-split str #\newline) + string<)) + +(define serialize ics:serialize) +(define deserialize ics:deserialize) + +(define component-str + (call-with-input-file (path-append (getenv "here") "event.ics") + get-string-all)) diff --git a/tests/formats/test.scm b/tests/formats/test.scm new file mode 100755 index 00000000..b4a00a73 --- /dev/null +++ b/tests/formats/test.scm @@ -0,0 +1,101 @@ +#!/usr/bin/env bash +# -*- mode: scheme; geiser-scheme-implementation: guile -*- + +here=$(dirname $(realpath $0)) +export here +. "$(dirname $(dirname "$here"))/env" + +exec $GUILE -s "$0" "$@" +!# + +(use-modules (srfi srfi-64) + (srfi srfi-88) + (vcomponent) + (vcomponent create) + (datetime) + (datetime timespec) + ((hnh util) :select (for print-and-return)) + (hnh test testrunner)) + + +(verbose? #t) +(test-runner-factory construct-test-runner) + +(define component + (vcomponent + 'VCALENDAR + version: "2.0" + prodid: "-//PIMUTILS.ORG//NONSGML khal / icalendar //EN" + (list + (vcomponent + 'VEVENT + summary: "Backhäfv" + dtstart: (with-parameters tzid: "Europe/Stockholm" + value: "DATE-TIME" + #2018-09-07T17:00:00) + dtend: (with-parameters tzid: "Europe/Stockholm" + value: "DATE-TIME" + #2018-09-07T18:00:00) + dtstamp: (with-parameters value: "DATE-TIME" + #2018-09-07T15:42:23Z) + uid: "ZSGUP6BTM52UV42SEWBICHSS63V8DYQX5TSZ" + sequence: 0) + (vcomponent + 'VTIMEZONE + tzid: "Europe/Stockholm" + (list (vcomponent + 'STANDARD + dtstart: (with-parameters value: "DATE-TIME" + #2018-10-28T02:00:00) + tzname: "CET" + tzoffsetfrom: (make-timespec #02:00 '+ #\z) + tzoffsetto: (make-timespec #01:00 '+ #\z)) + (vcomponent + 'DAYLIGHT + dtstart: (with-parameters value: "DATE-TIME" + #2018-03-25T03:00:00) + tzname: "CEST" + tzoffsetfrom: (make-timespec #01:00 '+ #\z) + tzoffsetto: (make-timespec #02:00 '+ #\z)))) + ))) + +(add-to-load-path (getenv "here")) + +(test-begin "Serialization Formats") + + + +(for test in '(ical xcal) + (test-group (format #f "Format: ~a" test) + (let ((interface (resolve-interface (list test)))) + (let ((component-str (module-ref interface 'component-str)) + (serialize (module-ref interface 'serialize)) + (deserialize (module-ref interface 'deserialize)) + (sanitize-string (module-ref interface 'sanitize-string))) + + (test-equal "Serialize" + (sanitize-string component-str) + (sanitize-string + (call-with-output-string + (lambda (p) (serialize component p))))) + + (test-equal "Deserialized object serializes back into source" + (sanitize-string component-str) + (sanitize-string + (call-with-output-string + (lambda (p) + (serialize + (call-with-input-string + component-str deserialize) + p))))) + + + (test-assert "Serialized string can still be read back in" + (vcomponent? + (let* ((obj1 (call-with-input-string component-str deserialize)) + (str2 (call-with-output-string (lambda (p) (serialize obj1 p)))) + (obj2 (call-with-input-string str2 deserialize))) + obj2))))))) + + +(test-end) diff --git a/tests/formats/xcal.scm b/tests/formats/xcal.scm new file mode 100644 index 00000000..4c27931a --- /dev/null +++ b/tests/formats/xcal.scm @@ -0,0 +1,26 @@ +(define-module (xcal) + :use-module (srfi srfi-88) + :use-module (hnh test xmllint) + :use-module (hnh util path) + :use-module ((rnrs io ports) :select (get-string-all)) + :use-module ((vcomponent formats xcal) :prefix #{xcs:}#) + :use-module ((calp namespaces) :select (xcal)) + :export (sanitize-string + serialize + deserialize + component-str)) + +(define (sanitize-string str) + (xmllint str)) + +(define serialize + (lambda (component port) + (xcs:serialize + component port namespaces: `((,xcal . c)) + ))) + +(define deserialize xcs:deserialize) + +(define component-str + (call-with-input-file (path-append (getenv "here") "event.xcs") + get-string-all)) diff --git a/tests/litmus.scm b/tests/litmus.scm new file mode 100755 index 00000000..477c5946 --- /dev/null +++ b/tests/litmus.scm @@ -0,0 +1,47 @@ +#!/usr/bin/env bash +# -*- mode: scheme; geiser-scheme-implementation: guile -*- + +here=$(dirname $(realpath $0)) +. "$(dirname "$here")/env" + +exec $GUILE -e main -s "$0" "$@" +!# + +(use-modules (calp server webdav) + (calp server socket) + (ice-9 threads) + (ice-9 rdelim) + (srfi srfi-1) + (srfi srfi-88)) + +;;; Commentary: +;;; Runs the external WebDAV test framework litmus [1], pointing it +;;; to a new instance of our webdav server. +;;; +;;; [1]: http://webdav.org/neon/litmus/ +;;; +;;; Code: + + + +(define (start-server out) + (begin-thread + (with-error-to-file "webdav.log" + (lambda () + (run-at-any-port + webdav-handler + min-port: 8102 + msg-port: out))))) + + +(define (main args) + (define-values (in out) (car+cdr (pipe))) + (define scm (start-server out)) + (define uri-base (read-line in)) + (define suffix + (if (null? (cdr args)) + "" + (string-append "/" (cadr args)))) + (system* "litmus" (string-append uri-base suffix)) + + (cancel-thread scm)) diff --git a/tests/rfc4791/5.3.1.2/request b/tests/rfc4791/5.3.1.2/request new file mode 100644 index 00000000..8b72a380 --- /dev/null +++ b/tests/rfc4791/5.3.1.2/request @@ -0,0 +1,42 @@ +MKCALENDAR /home/lisa/calendars/events/ HTTP/1.1 +Host: cal.example.com +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:mkcalendar xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:set> + <D:prop> + <D:displayname>Lisa's Events</D:displayname> + <C:calendar-description xml:lang="en" +>Calendar restricted to events.</C:calendar-description> + <C:supported-calendar-component-set> + <C:comp name="VEVENT"/> + </C:supported-calendar-component-set> + <C:calendar-timezone><![CDATA[BEGIN:VCALENDAR +PRODID:-//Example Corp.//CalDAV Client//EN +VERSION:2.0 +BEGIN:VTIMEZONE +TZID:US-Eastern +LAST-MODIFIED:19870101T000000Z +BEGIN:STANDARD +DTSTART:19671029T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +TZNAME:Eastern Standard Time (US & Canada) +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:19870405T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:Eastern Daylight Time (US & Canada) +END:DAYLIGHT +END:VTIMEZONE +END:VCALENDAR +]]></C:calendar-timezone> + </D:prop> + </D:set> +</C:mkcalendar> diff --git a/tests/rfc4791/5.3.1.2/response b/tests/rfc4791/5.3.1.2/response new file mode 100644 index 00000000..f92d755a --- /dev/null +++ b/tests/rfc4791/5.3.1.2/response @@ -0,0 +1,5 @@ +HTTP/1.1 201 Created +Cache-Control: no-cache +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Length: 0 + diff --git a/tests/rfc4791/5.3.2/request b/tests/rfc4791/5.3.2/request new file mode 100644 index 00000000..7efaceb3 --- /dev/null +++ b/tests/rfc4791/5.3.2/request @@ -0,0 +1,17 @@ +PUT /home/lisa/calendars/events/qwue23489.ics HTTP/1.1 +If-None-Match: * +Host: cal.example.com +Content-Type: text/calendar +Content-Length: 0 + +BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VEVENT +UID:20010712T182145Z-123401@example.com +DTSTAMP:20060712T182145Z +DTSTART:20060714T170000Z +DTEND:20060715T040000Z +SUMMARY:Bastille Day Party +END:VEVENT +END:VCALENDAR diff --git a/tests/rfc4791/5.3.2/response b/tests/rfc4791/5.3.2/response new file mode 100644 index 00000000..1c3c18e8 --- /dev/null +++ b/tests/rfc4791/5.3.2/response @@ -0,0 +1,5 @@ +HTTP/1.1 201 Created +Content-Length: 0 +Date: Sat, 11 Nov 2006 09:32:12 GMT +ETag: "123456789-000-111" + diff --git a/tests/rfc4791/7.10.1/request b/tests/rfc4791/7.10.1/request new file mode 100644 index 00000000..977f934b --- /dev/null +++ b/tests/rfc4791/7.10.1/request @@ -0,0 +1,11 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:free-busy-query xmlns:C="urn:ietf:params:xml:ns:caldav"> + <C:time-range start="20060104T140000Z" + end="20060105T220000Z"/> +</C:free-busy-query> diff --git a/tests/rfc4791/7.10.1/response b/tests/rfc4791/7.10.1/response new file mode 100644 index 00000000..eaf31712 --- /dev/null +++ b/tests/rfc4791/7.10.1/response @@ -0,0 +1,16 @@ +HTTP/1.1 200 OK +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: text/calendar +Content-Length: 0 + +BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Server//EN +BEGIN:VFREEBUSY +DTSTAMP:20050125T090000Z +DTSTART:20060104T140000Z +DTEND:20060105T220000Z +FREEBUSY;FBTYPE=BUSY-TENTATIVE:20060104T150000Z/PT1H +FREEBUSY:20060104T190000Z/PT1H +END:VFREEBUSY +END:VCALENDAR diff --git a/tests/rfc4791/7.8.1/request b/tests/rfc4791/7.8.1/request new file mode 100644 index 00000000..94a711a2 --- /dev/null +++ b/tests/rfc4791/7.8.1/request @@ -0,0 +1,39 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop> + <D:getetag/> + <C:calendar-data> + <C:comp name="VCALENDAR"> + <C:prop name="VERSION"/> + <C:comp name="VEVENT"> + <C:prop name="SUMMARY"/> + <C:prop name="UID"/> + <C:prop name="DTSTART"/> + <C:prop name="DTEND"/> + <C:prop name="DURATION"/> + <C:prop name="RRULE"/> + <C:prop name="RDATE"/> + <C:prop name="EXRULE"/> + <C:prop name="EXDATE"/> + <C:prop name="RECURRENCE-ID"/> + </C:comp> + <C:comp name="VTIMEZONE"/> + </C:comp> + </C:calendar-data> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VEVENT"> + <C:time-range start="20060104T000000Z" + end="20060105T000000Z"/> + </C:comp-filter> + </C:comp-filter> + </C:filter> +</C:calendar-query> diff --git a/tests/rfc4791/7.8.1/response b/tests/rfc4791/7.8.1/response new file mode 100644 index 00000000..b618b58f --- /dev/null +++ b/tests/rfc4791/7.8.1/response @@ -0,0 +1,99 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd2.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd2"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTART;TZID=US/Eastern:20060102T120000 +DURATION:PT1H +RRULE:FREQ=DAILY;COUNT=5 +SUMMARY:Event #2 +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +BEGIN:VEVENT +DTSTART;TZID=US/Eastern:20060104T140000 +DURATION:PT1H +RECURRENCE-ID;TZID=US/Eastern:20060104T120000 +SUMMARY:Event #2 bis +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +BEGIN:VEVENT +DTSTART;TZID=US/Eastern:20060106T140000 +DURATION:PT1H +RECURRENCE-ID;TZID=US/Eastern:20060106T120000 +SUMMARY:Event #2 bis bis +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd3.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd3"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTART;TZID=US/Eastern:20060104T100000 +DURATION:PT1H +SUMMARY:Event #3 +UID:DC6C50A017428C5216A2F1CD@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus>
\ No newline at end of file diff --git a/tests/rfc4791/7.8.10/request b/tests/rfc4791/7.8.10/request new file mode 100644 index 00000000..df483796 --- /dev/null +++ b/tests/rfc4791/7.8.10/request @@ -0,0 +1,22 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop xmlns:D="DAV:"> + <D:getetag/> + <C:calendar-data/> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VEVENT"> + <C:prop-filter name="X-ABC-GUID"> + <C:text-match>ABC</C:text-match> + </C:prop-filter> + </C:comp-filter> + </C:comp-filter> + </C:filter> +</C:calendar-query>
\ No newline at end of file diff --git a/tests/rfc4791/7.8.10/response b/tests/rfc4791/7.8.10/response new file mode 100644 index 00000000..6a13fb53 --- /dev/null +++ b/tests/rfc4791/7.8.10/response @@ -0,0 +1,11 @@ +HTTP/1.1 403 Forbidden +Date: Sat, 11 Nov 2005 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:error> + <C:supported-filter> + <C:prop-filter name="X-ABC-GUID"/> + </C:supported-filter> +</D:error> diff --git a/tests/rfc4791/7.8.2/request b/tests/rfc4791/7.8.2/request new file mode 100644 index 00000000..83e31d90 --- /dev/null +++ b/tests/rfc4791/7.8.2/request @@ -0,0 +1,24 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop> + <C:calendar-data> + <C:limit-recurrence-set start="20060103T000000Z" + end="20060105T000000Z"/> + </C:calendar-data> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VEVENT"> + <C:time-range start="20060103T000000Z" + end="20060105T000000Z"/> + </C:comp-filter> + </C:comp-filter> + </C:filter> +</C:calendar-query> diff --git a/tests/rfc4791/7.8.2/response b/tests/rfc4791/7.8.2/response new file mode 100644 index 00000000..71dced2c --- /dev/null +++ b/tests/rfc4791/7.8.2/response @@ -0,0 +1,103 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd2.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd2"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20060206T001121Z +DTSTART;TZID=US/Eastern:20060102T120000 +DURATION:PT1H +RRULE:FREQ=DAILY;COUNT=5 +SUMMARY:Event #2 +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +BEGIN:VEVENT +DTSTAMP:20060206T001121Z +DTSTART;TZID=US/Eastern:20060104T140000 +DURATION:PT1H +RECURRENCE-ID;TZID=US/Eastern:20060104T120000 +SUMMARY:Event #2 bis +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd3.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd3"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +ATTENDEE;PARTSTAT=ACCEPTED;ROLE=CHAIR:mailto:cyrus@example.com +ATTENDEE;PARTSTAT=NEEDS-ACTION:mailto:lisa@example.com +DTSTAMP:20060206T001220Z +DTSTART;TZID=US/Eastern:20060104T100000 +DURATION:PT1H +LAST-MODIFIED:20060206T001330Z +ORGANIZER:mailto:cyrus@example.com +SEQUENCE:1 +STATUS:TENTATIVE +SUMMARY:Event #3 +UID:DC6C50A017428C5216A2F1CD@example.com +X-ABC-GUID:E1CX5Dr-0007ym-Hz@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus> diff --git a/tests/rfc4791/7.8.3/request b/tests/rfc4791/7.8.3/request new file mode 100644 index 00000000..35f9ca07 --- /dev/null +++ b/tests/rfc4791/7.8.3/request @@ -0,0 +1,24 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop> + <C:calendar-data> + <C:expand start="20060103T000000Z" + end="20060105T000000Z"/> + </C:calendar-data> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VEVENT"> + <C:time-range start="20060103T000000Z" + end="20060105T000000Z"/> + </C:comp-filter> + </C:comp-filter> + </C:filter> +</C:calendar-query> diff --git a/tests/rfc4791/7.8.3/response b/tests/rfc4791/7.8.3/response new file mode 100644 index 00000000..68f3b1a1 --- /dev/null +++ b/tests/rfc4791/7.8.3/response @@ -0,0 +1,67 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd2.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd2"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VEVENT +DTSTAMP:20060206T001121Z +DTSTART:20060103T170000 +DURATION:PT1H +RECURRENCE-ID:20060103T170000 +SUMMARY:Event #2 +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +BEGIN:VEVENT +DTSTAMP:20060206T001121Z +DTSTART:20060104T190000 +DURATION:PT1H +RECURRENCE-ID:20060104T170000 +SUMMARY:Event #2 bis +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd3.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd3"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VEVENT +ATTENDEE;PARTSTAT=ACCEPTED;ROLE=CHAIR:mailto:cyrus@example.com +ATTENDEE;PARTSTAT=NEEDS-ACTION:mailto:lisa@example.com +DTSTAMP:20060206T001220Z +DTSTART:20060104T150000 +DURATION:PT1H +LAST-MODIFIED:20060206T001330Z +ORGANIZER:mailto:cyrus@example.com +SEQUENCE:1 +STATUS:TENTATIVE +SUMMARY:Event #3 +UID:DC6C50A017428C5216A2F1CD@example.com +X-ABC-GUID:E1CX5Dr-0007ym-Hz@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus>
\ No newline at end of file diff --git a/tests/rfc4791/7.8.4/request b/tests/rfc4791/7.8.4/request new file mode 100644 index 00000000..c70acc61 --- /dev/null +++ b/tests/rfc4791/7.8.4/request @@ -0,0 +1,24 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop> + <C:calendar-data> + <C:limit-freebusy-set start="20060102T000000Z" + end="20060103T000000Z"/> + </C:calendar-data> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VFREEBUSY"> + <C:time-range start="20060102T000000Z" + end="20060103T000000Z"/> + </C:comp-filter> + </C:comp-filter> + </C:filter> +</C:calendar-query> diff --git a/tests/rfc4791/7.8.4/response b/tests/rfc4791/7.8.4/response new file mode 100644 index 00000000..67959c58 --- /dev/null +++ b/tests/rfc4791/7.8.4/response @@ -0,0 +1,31 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd8.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd8"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VFREEBUSY +ORGANIZER;CN="Bernard Desruisseaux":mailto:bernard@example.com +UID:76ef34-54a3d2@example.com +DTSTAMP:20050530T123421Z +DTSTART:20060101T100000Z +DTEND:20060108T100000Z +FREEBUSY;FBTYPE=BUSY-TENTATIVE:20060102T100000Z/20060102T120000Z +END:VFREEBUSY +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus> diff --git a/tests/rfc4791/7.8.5/request b/tests/rfc4791/7.8.5/request new file mode 100644 index 00000000..d3639f40 --- /dev/null +++ b/tests/rfc4791/7.8.5/request @@ -0,0 +1,23 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop xmlns:D="DAV:"> + <D:getetag/> + <C:calendar-data/> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VTODO"> + <C:comp-filter name="VALARM"> + <C:time-range start="20060106T100000Z" + end="20060107T100000Z"/> + </C:comp-filter> + </C:comp-filter> + </C:comp-filter> + </C:filter> +</C:calendar-query> diff --git a/tests/rfc4791/7.8.5/response b/tests/rfc4791/7.8.5/response new file mode 100644 index 00000000..4b5a8d8a --- /dev/null +++ b/tests/rfc4791/7.8.5/response @@ -0,0 +1,36 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd4.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd4"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTODO +DTSTAMP:20060205T235300Z +DUE;TZID=US/Eastern:20060106T120000 +LAST-MODIFIED:20060205T235308Z +SEQUENCE:1 +STATUS:NEEDS-ACTION +SUMMARY:Task #2 +UID:E10BA47467C5C69BB74E8720@example.com +BEGIN:VALARM +ACTION:AUDIO +TRIGGER;RELATED=START:-PT10M +END:VALARM +END:VTODO +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus> diff --git a/tests/rfc4791/7.8.6/request b/tests/rfc4791/7.8.6/request new file mode 100644 index 00000000..ca6d4b37 --- /dev/null +++ b/tests/rfc4791/7.8.6/request @@ -0,0 +1,23 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop xmlns:D="DAV:"> + <D:getetag/> + <C:calendar-data/> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VEVENT"> + <C:prop-filter name="UID"> + <C:text-match collation="i;octet" + >DC6C50A017428C5216A2F1CD@example.com</C:text-match> + </C:prop-filter> + </C:comp-filter> + </C:comp-filter> + </C:filter> +</C:calendar-query> diff --git a/tests/rfc4791/7.8.6/response b/tests/rfc4791/7.8.6/response new file mode 100644 index 00000000..cd257a10 --- /dev/null +++ b/tests/rfc4791/7.8.6/response @@ -0,0 +1,55 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd3.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd3"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +ATTENDEE;PARTSTAT=ACCEPTED;ROLE=CHAIR:mailto:cyrus@example.com +ATTENDEE;PARTSTAT=NEEDS-ACTION:mailto:lisa@example.com +DTSTAMP:20060206T001220Z +DTSTART;TZID=US/Eastern:20060104T100000 +DURATION:PT1H +LAST-MODIFIED:20060206T001330Z +ORGANIZER:mailto:cyrus@example.com +SEQUENCE:1 +STATUS:TENTATIVE +SUMMARY:Event #3 +UID:DC6C50A017428C5216A2F1CD@example.com +X-ABC-GUID:E1CX5Dr-0007ym-Hz@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus> diff --git a/tests/rfc4791/7.8.7/request b/tests/rfc4791/7.8.7/request new file mode 100644 index 00000000..cb030130 --- /dev/null +++ b/tests/rfc4791/7.8.7/request @@ -0,0 +1,27 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop xmlns:D="DAV:"> + <D:getetag/> + <C:calendar-data/> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VEVENT"> + <C:prop-filter name="ATTENDEE"> + <C:text-match collation="i;ascii-casemap" + >mailto:lisa@example.com</C:text-match> + <C:param-filter name="PARTSTAT"> + <C:text-match collation="i;ascii-casemap" + >NEEDS-ACTION</C:text-match> + </C:param-filter> + </C:prop-filter> + </C:comp-filter> + </C:comp-filter> + </C:filter> +</C:calendar-query> diff --git a/tests/rfc4791/7.8.7/response b/tests/rfc4791/7.8.7/response new file mode 100644 index 00000000..cd257a10 --- /dev/null +++ b/tests/rfc4791/7.8.7/response @@ -0,0 +1,55 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd3.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd3"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +ATTENDEE;PARTSTAT=ACCEPTED;ROLE=CHAIR:mailto:cyrus@example.com +ATTENDEE;PARTSTAT=NEEDS-ACTION:mailto:lisa@example.com +DTSTAMP:20060206T001220Z +DTSTART;TZID=US/Eastern:20060104T100000 +DURATION:PT1H +LAST-MODIFIED:20060206T001330Z +ORGANIZER:mailto:cyrus@example.com +SEQUENCE:1 +STATUS:TENTATIVE +SUMMARY:Event #3 +UID:DC6C50A017428C5216A2F1CD@example.com +X-ABC-GUID:E1CX5Dr-0007ym-Hz@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus> diff --git a/tests/rfc4791/7.8.8/request b/tests/rfc4791/7.8.8/request new file mode 100644 index 00000000..1ddb3287 --- /dev/null +++ b/tests/rfc4791/7.8.8/request @@ -0,0 +1,18 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop xmlns:D="DAV:"> + <D:getetag/> + <C:calendar-data/> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VEVENT"/> + </C:comp-filter> + </C:filter> +</C:calendar-query> diff --git a/tests/rfc4791/7.8.8/response b/tests/rfc4791/7.8.8/response new file mode 100644 index 00000000..63895076 --- /dev/null +++ b/tests/rfc4791/7.8.8/response @@ -0,0 +1,151 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd1.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd1"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20060206T001102Z +DTSTART;TZID=US/Eastern:20060102T100000 +DURATION:PT1H +SUMMARY:Event #1 +Description:Go Steelers! +UID:74855313FA803DA593CD579A@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd2.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd2"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20060206T001121Z +DTSTART;TZID=US/Eastern:20060102T120000 +DURATION:PT1H +RRULE:FREQ=DAILY;COUNT=5 +SUMMARY:Event #2 +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +BEGIN:VEVENT +DTSTAMP:20060206T001121Z +DTSTART;TZID=US/Eastern:20060104T140000 +DURATION:PT1H +RECURRENCE-ID;TZID=US/Eastern:20060104T120000 +SUMMARY:Event #2 bis +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +BEGIN:VEVENT +DTSTAMP:20060206T001121Z +DTSTART;TZID=US/Eastern:20060106T140000 +DURATION:PT1H +RECURRENCE-ID;TZID=US/Eastern:20060106T120000 +SUMMARY:Event #2 bis bis +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd3.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd3"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +ATTENDEE;PARTSTAT=ACCEPTED;ROLE=CHAIR:mailto:cyrus@example.com +ATTENDEE;PARTSTAT=NEEDS-ACTION:mailto:lisa@example.com +DTSTAMP:20060206T001220Z +DTSTART;TZID=US/Eastern:20060104T100000 +DURATION:PT1H +LAST-MODIFIED:20060206T001330Z +ORGANIZER:mailto:cyrus@example.com +SEQUENCE:1 +STATUS:TENTATIVE +SUMMARY:Event #3 +UID:DC6C50A017428C5216A2F1CD@example.com +X-ABC-GUID:E1CX5Dr-0007ym-Hz@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus> diff --git a/tests/rfc4791/7.8.9/request b/tests/rfc4791/7.8.9/request new file mode 100644 index 00000000..24484ffb --- /dev/null +++ b/tests/rfc4791/7.8.9/request @@ -0,0 +1,26 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop xmlns:D="DAV:"> + <D:getetag/> + <C:calendar-data/> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"> + <C:comp-filter name="VTODO"> + <C:prop-filter name="COMPLETED"> + <C:is-not-defined/> + </C:prop-filter> + <C:prop-filter name="STATUS"> + <C:text-match + negate-condition="yes">CANCELLED</C:text-match> + </C:prop-filter> + </C:comp-filter> + </C:comp-filter> + </C:filter> +</C:calendar-query> diff --git a/tests/rfc4791/7.8.9/response b/tests/rfc4791/7.8.9/response new file mode 100644 index 00000000..9e37db61 --- /dev/null +++ b/tests/rfc4791/7.8.9/response @@ -0,0 +1,62 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd4.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd4"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTODO +DTSTAMP:20060205T235335Z +DUE;VALUE=DATE:20060104 +STATUS:NEEDS-ACTION +SUMMARY:Task #1 +UID:DDDEEB7915FA61233B861457@example.com +BEGIN:VALARM +ACTION:AUDIO +TRIGGER;RELATED=START:-PT10M +END:VALARM +END:VTODO +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd5.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd5"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTODO +DTSTAMP:20060205T235300Z +DUE;VALUE=DATE:20060106 +LAST-MODIFIED:20060205T235308Z +SEQUENCE:1 +STATUS:NEEDS-ACTION +SUMMARY:Task #2 +UID:E10BA47467C5C69BB74E8720@example.com +BEGIN:VALARM +ACTION:AUDIO +TRIGGER;RELATED=START:-PT10M +END:VALARM +END:VTODO +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus> diff --git a/tests/rfc4791/7.9.1/request b/tests/rfc4791/7.9.1/request new file mode 100644 index 00000000..caccc135 --- /dev/null +++ b/tests/rfc4791/7.9.1/request @@ -0,0 +1,15 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-multiget xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop> + <D:getetag/> + <C:calendar-data/> + </D:prop> + <D:href>/bernard/work/abcd1.ics</D:href> + <D:href>/bernard/work/mtg1.ics</D:href> +</C:calendar-multiget> diff --git a/tests/rfc4791/7.9.1/response b/tests/rfc4791/7.9.1/response new file mode 100644 index 00000000..fbc5e966 --- /dev/null +++ b/tests/rfc4791/7.9.1/response @@ -0,0 +1,53 @@ +HTTP/1.1 207 Multi-Status +Date: Sat, 11 Nov 2006 09:32:12 GMT +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd1.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd1"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20060206T001102Z +DTSTART;TZID=US/Eastern:20060102T100000 +DURATION:PT1H +SUMMARY:Event #1 +Description:Go Steelers! +UID:74855313FA803DA593CD579A@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + <D:response> + <D:href>http://cal.example.com/bernard/work/mtg1.ics</D:href> + <D:status>HTTP/1.1 404 Not Found</D:status> + </D:response> +</D:multistatus> diff --git a/tests/rfc4791/appendix-b/request b/tests/rfc4791/appendix-b/request new file mode 100644 index 00000000..6e077508 --- /dev/null +++ b/tests/rfc4791/appendix-b/request @@ -0,0 +1,17 @@ +REPORT /bernard/work/ HTTP/1.1 +Host: cal.example.com +Depth: 1 +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<C:calendar-query xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + <D:prop> + <D:getetag/> + <C:calendar-data/> + </D:prop> + <C:filter> + <C:comp-filter name="VCALENDAR"/> + </C:filter> +</C:calendar-query>
\ No newline at end of file diff --git a/tests/rfc4791/appendix-b/response b/tests/rfc4791/appendix-b/response new file mode 100644 index 00000000..5e6878ef --- /dev/null +++ b/tests/rfc4791/appendix-b/response @@ -0,0 +1,275 @@ +HTTP/1.1 207 Multi-Status +Content-Type: application/xml; charset="utf-8" +Content-Length: 0 + +<?xml version="1.0" encoding="utf-8" ?> +<D:multistatus xmlns:D="DAV:" + xmlns:C="urn:ietf:params:xml:ns:caldav"> + + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd1.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd1"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20060206T001102Z +DTSTART;TZID=US/Eastern:20060102T100000 +DURATION:PT1H +SUMMARY:Event #1 +Description:Go Steelers! +UID:74855313FA803DA593CD579A@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd2.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd2"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20060206T001121Z +DTSTART;TZID=US/Eastern:20060102T120000 +DURATION:PT1H +RRULE:FREQ=DAILY;COUNT=5 +SUMMARY:Event #2 +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +BEGIN:VEVENT +DTSTAMP:20060206T001121Z +DTSTART;TZID=US/Eastern:20060104T140000 +DURATION:PT1H +RECURRENCE-ID;TZID=US/Eastern:20060104T120000 +SUMMARY:Event #2 bis +UID:00959BC664CA650E933C892C@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd3.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd3"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTIMEZONE +LAST-MODIFIED:20040110T032845Z +TZID:US/Eastern +BEGIN:DAYLIGHT +DTSTART:20000404T020000 +RRULE:FREQ=YEARLY;BYDAY=1SU;BYMONTH=4 +TZNAME:EDT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +END:DAYLIGHT +BEGIN:STANDARD +DTSTART:20001026T020000 +RRULE:FREQ=YEARLY;BYDAY=-1SU;BYMONTH=10 +TZNAME:EST +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +ATTENDEE;PARTSTAT=ACCEPTED;ROLE=CHAIR:mailto:cyrus@example.com +ATTENDEE;PARTSTAT=NEEDS-ACTION:mailto:lisa@example.com +DTSTAMP:20060206T001220Z +DTSTART;TZID=US/Eastern:20060104T100000 +DURATION:PT1H +LAST-MODIFIED:20060206T001330Z +ORGANIZER:mailto:cyrus@example.com +SEQUENCE:1 +STATUS:TENTATIVE +SUMMARY:Event #3 +UID:DC6C50A017428C5216A2F1CD@example.com +END:VEVENT +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd4.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd4"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTODO +DTSTAMP:20060205T235335Z +DUE;VALUE=DATE:20060104 +STATUS:NEEDS-ACTION +SUMMARY:Task #1 +UID:DDDEEB7915FA61233B861457@example.com +BEGIN:VALARM +ACTION:AUDIO +TRIGGER;RELATED=START:-PT10M +END:VALARM +END:VTODO +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd5.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd5"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTODO +DTSTAMP:20060205T235300Z +DUE;VALUE=DATE:20060106 +LAST-MODIFIED:20060205T235308Z +SEQUENCE:1 +STATUS:NEEDS-ACTION +SUMMARY:Task #2 +UID:E10BA47467C5C69BB74E8720@example.com +BEGIN:VALARM +ACTION:AUDIO +TRIGGER;RELATED=START:-PT10M +END:VALARM +END:VTODO +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd6.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd6"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTODO +COMPLETED:20051223T122322Z +DTSTAMP:20060205T235400Z +DUE;VALUE=DATE:20051225 +LAST-MODIFIED:20060205T235308Z +SEQUENCE:1 +STATUS:COMPLETED +SUMMARY:Task #3 +UID:E10BA47467C5C69BB74E8722@example.com +END:VTODO +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd7.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd7"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VTODO +DTSTAMP:20060205T235600Z +DUE;VALUE=DATE:20060101 +LAST-MODIFIED:20060205T235308Z +SEQUENCE:1 +STATUS:CANCELLED +SUMMARY:Task #4 +UID:E10BA47467C5C69BB74E8725@example.com +END:VTODO +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> + + <D:response> + <D:href>http://cal.example.com/bernard/work/abcd8.ics</D:href> + <D:propstat> + <D:prop> + <D:getetag>"fffff-abcd8"</D:getetag> + <C:calendar-data>BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Example Corp.//CalDAV Client//EN +BEGIN:VFREEBUSY +ORGANIZER;CN="Bernard Desruisseaux":mailto:bernard@example.com +UID:76ef34-54a3d2@example.com +DTSTAMP:20050530T123421Z +DTSTART:20060101T000000Z +DTEND:20060108T000000Z +FREEBUSY:20050531T230000Z/20050601T010000Z +FREEBUSY;FBTYPE=BUSY-TENTATIVE:20060102T100000Z/20060102T120000Z +FREEBUSY:20060103T100000Z/20060103T120000Z +FREEBUSY:20060104T100000Z/20060104T120000Z +FREEBUSY;FBTYPE=BUSY-UNAVAILABLE:20060105T100000Z/20060105T120000Z +FREEBUSY:20060106T100000Z/20060106T120000Z +END:VFREEBUSY +END:VCALENDAR +</C:calendar-data> + </D:prop> + <D:status>HTTP/1.1 200 OK</D:status> + </D:propstat> + </D:response> +</D:multistatus> diff --git a/tests/run-tests.scm b/tests/run-tests.scm index 5270636e..d3ba53f8 100755 --- a/tests/run-tests.scm +++ b/tests/run-tests.scm @@ -16,136 +16,27 @@ fi (define here (dirname (current-filename))) (use-modules (hnh util path)) -(add-to-load-path (path-append (dirname here) "scripts")) (use-modules (srfi srfi-1) (srfi srfi-64) (srfi srfi-88) - (hnh util) - (ice-9 ftw) + ((hnh util io) :select (call-with-tmpfile)) (ice-9 format) - (ice-9 pretty-print) (ice-9 getopt-long) (ice-9 match) + (ice-9 regex) + ((ice-9 popen) + :select (open-pipe* + close-pipe)) + ((ice-9 rdelim) :select (read-string)) (system vm coverage) - ((all-modules) :select (fs-find)) + ((hnh module-introspection all-modules) :select (fs-find)) + + (hnh test testrunner) ) - -(define (µs x) - (* x #e1e6)) - -(define (transform-time-of-day tod) - (+ (* (µs 1) (car tod)) - (cdr tod))) - -(define verbose? (make-parameter #f)) - -(define (escaped sequence string) - (format #f "\x1b[~am~a\x1b[m" sequence string)) - -(define (green s) (escaped 32 s)) -(define (red s) (escaped 31 s)) -(define (yellow s) (escaped 33 s)) -(define (bold s) (escaped 1 s)) - -(define (make-indent depth) - (make-string (* 2 depth) #\space)) - -(define (construct-test-runner) - (define runner (test-runner-null)) - (define depth 0) - ;; end of individual test case - (test-runner-on-test-begin! runner - (lambda (runner) - (test-runner-aux-value! runner (transform-time-of-day (gettimeofday))))) - (test-runner-on-test-end! runner - (lambda (runner) - (when (verbose?) (display (make-indent depth))) - (case (test-result-kind runner) - ((pass) (display (green "X"))) - ((fail) (display (red "E"))) - ((xpass) (display (yellow "X"))) - ((xfail) (display (yellow "E"))) - ((skip) (display (yellow "-")))) - (when (or (verbose?) (eq? 'fail (test-result-kind))) - (format #t " ~a~%" - (cond ((test-runner-test-name runner) - (negate string-null?) => identity) - ((test-result-ref runner 'expected-value) - => (lambda (p) (with-output-to-string (lambda () (display (bold "[SOURCE]: ")) (truncated-print p width: 60)))))))) - (when (eq? 'fail (test-result-kind)) - (cond ((test-result-ref runner 'actual-error) - => (lambda (err) - (if (and (list? err) - (= 5 (length err))) - (let ((err (list-ref err 0)) - (proc (list-ref err 1)) - (fmt (list-ref err 2)) - (args (list-ref err 3))) - (format #t "~a~a in ~a: ~?~%" - (make-indent (1+ depth)) - err proc fmt args)) - (format #t "~aError: ~s~%" (make-indent (1+ depth)) err)))) - (else - (let ((unknown-expected (gensym)) - (unknown-actual (gensym))) - (let ((expected (test-result-ref runner 'expected-value unknown-expected)) - (actual (test-result-ref runner 'actual-value unknown-actual))) - (if (eq? expected unknown-expected) - (format #t "~aAssertion failed, received ~s~%" - (make-indent (1+ depth)) actual) - (format #t "~aExpected: ~s~%~aReceived: ~s~%" - (make-indent (1+ depth)) expected - (make-indent (1+ depth)) actual)))))) - (format #t "~aNear ~a:~a~%" - (make-indent (1+ depth)) - (test-result-ref runner 'source-file) - (test-result-ref runner 'source-line)) - (pretty-print (test-result-ref runner 'source-form) - (current-output-port) - per-line-prefix: (string-append (make-indent (1+ depth)) "> ") - )) - - (let ((start (test-runner-aux-value runner)) - (end (transform-time-of-day (gettimeofday)))) - (when (< (µs 1) (- end start)) - (format #t "~%Slow test: ~s, took ~a~%" - (test-runner-test-name runner) - (exact->inexact (/ (- end start) (µs 1))) - ))))) - - ;; on start of group - (test-runner-on-group-begin! runner - ;; count is number of #f - (lambda (runner name count) - (if (<= depth 1) - (format #t "~a ~a ~a~%" - (make-string 10 #\=) - name - (make-string 10 #\=)) - (when (verbose?) - (format #t "~a~a~%" (make-string (* depth 2) #\space) name))) - (set! depth (1+ depth)))) - (test-runner-on-group-end! runner - (lambda (runner) - (set! depth (1- depth)) - (when (<= depth 1) - (newline)))) - ;; after everything else is done - (test-runner-on-final! runner - (lambda (runner) - (format #t "Guile version ~a~%~%" (version)) - (format #t "pass: ~a~%" (test-runner-pass-count runner)) - (format #t "fail: ~a~%" (test-runner-fail-count runner)) - (format #t "xpass: ~a~%" (test-runner-xpass-count runner)) - (format #t "xfail: ~a~%" (test-runner-xfail-count runner)) - )) - - runner) - (test-runner-factory construct-test-runner) @@ -203,9 +94,6 @@ fi ;; (format #t "Running on:~%~y~%" files) -(awhen (option-ref options 'only #f) - (set! files (list (path-append "test" it)))) - ((@ (hnh util exceptions) warnings-are-errors) #t) @@ -240,9 +128,38 @@ fi (test-begin "suite") -(awhen (option-ref options 'skip #f) - (format #t "Skipping ~s~%" it) - (test-skip it)) + +(define onlies + (let %loop ((args (command-line)) (onlies '())) + (define* (loop args key: only) + (if only + (%loop args (cons only onlies)) + (%loop args onlies))) + (if (null? args) + onlies + (cond ((string-match "^--skip(=(.*))?$" (car args)) + => (lambda (m) + (cond ((match:substring m 2) + => (lambda (s) + (format #t "Skipping ~s~%" s) + (test-skip s) + (loop (cdr args)))) + (else (format #t "Skipping ~s~%" (cadr args)) + (test-skip (cadr args)) + (loop (cddr args)))))) + ((string-match "^--only(=(.*))?$" (car args)) + => (lambda (m) + (cond ((match:substring m 2) + => (lambda (s) + (loop (cdr args) only: s))) + (else (loop (cddr args) only: (cadr args)))))) + (else (loop (cdr args))))))) + +(unless (null? onlies) + (set! files + (map (lambda (x) (path-append "test" x)) + ;; reverse only until I have built a dependency graph for tests + (reverse onlies)))) (finalizer (lambda () (for-each (lambda (f) (catch/print-trace (lambda () (test-group f (load f))))) files))) diff --git a/tests/test/add-and-save.scm b/tests/test/add-and-save.scm index 1ab6f660..efbfe09e 100644 --- a/tests/test/add-and-save.scm +++ b/tests/test/add-and-save.scm @@ -3,83 +3,86 @@ :use-module (srfi srfi-88) :use-module (hnh util) :use-module (datetime) + :use-module (datetime timespec) ;; :use-module ((vcomponent) :select (prop)) :use-module ((vcomponent base) :select (prop type children make-vcomponent)) :use-module ((srfi srfi-1) :select (find)) :use-module ((vcomponent formats vdir save-delete) :select (save-event)) - :use-module ((vcomponent formats xcal parse) :select (sxcal->vcomponent)) + :use-module ((vcomponent create) + :select (with-parameters + vcalendar vevent + vtimezone standard daylight)) + :use-module (vcomponent recurrence) :use-module ((vcomponent util instance methods) :select (add-calendars add-and-save-event remove-event ))) -;; TODO is this how I want to format direct components? - (define timezone - '(vtimezone - (properties (tzid (text "Europe/Stockholm"))) - (components - (standard - (properties - (tzoffsetto (utc-offset "+0100")) - (dtstart (date-time "1996-10-27T01:00:00")) - (tzname (text "CET")) - (tzoffsetfrom (utc-offset "+0200")) - (rrule (recur (freq "YEARLY") - (interval "1") - ((byday "-1SU")) - ((bymonth 10)))))) - (daylight - (properties - (tzoffsetto (utc-offset "+0200")) - (dtstart (date-time "1981-03-29T01:00:00")) - (tzname (text "CEST")) - (tzoffsetfrom (utc-offset "+0000")) - (rrule (recur (freq "YEARLY") - (interval "1") - ((byday "-1SU")) - ((bymonth 3)))))))) ) + (vtimezone + tzid: "Europe/Stockholm" + (list + (standard + tzoffsetto: (parse-time-spec "01:00") + dtstart: #1996-10-27T01:00:00 + tzname: "CET" + tzoffsetfrom: (parse-time-spec "02:00") + rrule: (make-recur-rule + freq: 'YEARLY + interval: 1 + byday: (list (cons -1 sun)) + bymonth: (list 10) + )) + (daylight + tzoffsetto: (parse-time-spec "02:00") + dtstart: #1981-03-29T01:00:00 + tzname: "CEST" + tzoffsetfrom: (parse-time-spec "00:00") + rrule: (make-recur-rule + freq: 'YEARLY + interval: 1 + byday: (list (cons -1 sun)) + bymonth: (list 3)))))) (define ev - (sxcal->vcomponent - '(vevent - (properties - (uid (text "3da506ad-8d27-4810-94b3-6ab341baa1f2")) - (summary (text "Test Event #1")) - (dtstart - (parameters (tzid (text "Europe/Stockholm"))) - (date-time "2021-12-21T10:30:00")) - (dtstamp (date-time "2021-12-21T14:10:56Z")) - (dtend (parameters (tzid (text "Europe/Stockholm"))) - (date-time "2021-12-21T11:45:00")))))) + (vevent + uid: "3da506ad-8d27-4810-94b3-6ab341baa1f2" + summary: "Test Event #1" + dtstart: (with-parameters + tzid: "Europe/Stockholm" + #2021-12-21T10:30:00) + dtstamp: #2021-12-21T14:10:56Z + dtend: (with-parameters + tzid: "Europe/Stockholm" + #2021-12-21T11:45:00))) (define rep-ev - (sxcal->vcomponent - '(vevent - (properties - (uid (text "4ebd6632-d192-4bf4-a33a-7a8388185914")) - (summary (text "Repeating Test Event #1")) - (rrule (recur (freq "DAILY"))) - (dtstart - (parameters (tzid (text "Europe/Stockholm"))) - (date-time "2021-12-21T10:30:00")) - (dtstamp (date-time "2021-12-21T14:10:56Z")) - (dtend (parameters (tzid (text "Europe/Stockholm"))) - (date-time "2021-12-21T11:45:00")))))) - -(define directory (tmpnam)) + (vevent + uid: "4ebd6632-d192-4bf4-a33a-7a8388185914" + summary: "Repeating Test Event #1" + rrule: (make-recur-rule freq: 'DAILY) + dtstart: (with-parameters + tzid: "Europe/Stockholm" + #2021-12-21T10:30:00) + dtstamp: #2021-12-21T14:10:56Z + dtend: (with-parameters + tzid: "Europe/Stockholm" + #2021-12-21T11:45:00) + )) + +(define directory (mkdtemp (string-copy"/tmp/guile-test-XXXXXX"))) +(format #t "Using ~a~%" directory) (define event-object ((@ (oop goops) make) (@@ (vcomponent util instance methods) <events>))) -(mkdir directory) -(format #t "Using ~a~%" directory) - -(define calendar (make-vcomponent 'VCALENDAR)) -(set! (prop calendar '-X-HNH-SOURCETYPE) 'vdir - (prop calendar '-X-HNH-DIRECTORY) directory) +(define calendar + (vcalendar + #:-X-HNH-SOURCETYPE 'vdir + #:-X-HNH-DIRECTORY directory + )) (add-calendars event-object calendar) @@ -107,7 +110,7 @@ (test-equal "Correct amount of children in calendar" - 2 (length (children calendar))) + 5 (length (children calendar))) (define get-events (@@ (vcomponent util instance methods) get-events)) diff --git a/tests/test/annoying-events.scm b/tests/test/annoying-events.scm index 673a4b49..d41ee450 100644 --- a/tests/test/annoying-events.scm +++ b/tests/test/annoying-events.scm @@ -12,35 +12,26 @@ :select (extract prop make-vcomponent)) :use-module ((vcomponent datetime) :select (event-overlaps?)) :use-module ((datetime) :select (date date+ date<)) - :use-module ((hnh util) :select (set!))) + :use-module ((hnh util) :select (set!)) + :use-module (vcomponent create) + :use-module (vcomponent base)) -;; TODO remove this -(define* (event key: summary dtstart dtend) - (define ev (make-vcomponent 'VEVENT)) - (set! (prop ev 'SUMMARY) - summary - (prop ev 'DTSTART) - dtstart - (prop ev 'DTEND) - dtend) - ev) -(define start - #2021-11-01) +(define start #2021-11-01) (define end (date+ start (date day: 8))) (define ev-set (stream - (event ; should be part of the result + (vevent ; should be part of the result summary: "A" dtstart: #2021-10-01 dtend: #2021-12-01) - (event ; should NOT be part of the result + (vevent ; should NOT be part of the result summary: "B" dtstart: #2021-10-10 dtend: #2021-10-11) - (event ; should also be part of the result + (vevent ; should also be part of the result summary: "C" dtstart: #2021-11-02 dtend: #2021-11-03))) diff --git a/tests/test/create.scm b/tests/test/create.scm new file mode 100644 index 00000000..ca055df1 --- /dev/null +++ b/tests/test/create.scm @@ -0,0 +1,60 @@ +(define-module (test create) + :use-module ((srfi srfi-1) :select (every)) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module (vcomponent create) + :use-module (vcomponent)) + +;; vevent, vcalendar, vtimezone, standard, and daylight all trivial +;; and therefore not tested + +(test-group "Empty component" + (let ((ev (vcomponent 'TEST))) + (test-equal 'TEST (type ev)) + (test-equal '() (children ev)) + (test-equal '() (properties ev)))) + +(test-group "Component with properties, but no children" + (let ((ev (vcomponent 'TEST + prop: "value"))) + (test-equal '(PROP) (map car (properties ev))) + (test-equal "value" (prop ev 'PROP)))) + +(test-group "Component with children, but no properties" + (let* ((child (vcomponent 'CHILD)) + (ev (vcomponent 'TEST + (list child)))) + (test-equal '() (properties ev)) + (test-equal 1 (length (children ev))) + (test-eq child (car (children ev))))) + +(test-group "Component with both children and properties" + (let* ((child (vcomponent 'CHILD)) + (ev (vcomponent 'TEST + prop: "VALUE" + (list child)))) + (test-equal '(PROP) (map car (properties ev))) + (test-equal "VALUE" (prop ev 'PROP)) + (test-equal 1 (length (children ev))) + (test-eq child (car (children ev))))) + +(test-group "Component with no children, where last elements value is a list" + (let ((ev (vcomponent 'TEST prop: (list 1 2 3)))) + (test-equal '() (children ev)) + (test-equal '(PROP) (map car (properties ev))) + (test-equal '(1 2 3) (prop ev 'PROP)))) + +(test-group "With parameters" + (let ((ev (vcomponent 'TEST + prop: (with-parameters param: 1 2)))) + (test-equal 2 (prop ev 'PROP)) + (test-equal '(1) (param (prop* ev 'PROP) 'PARAM)))) + +(test-group "As list" + (let ((ev (vcomponent 'TEST + prop: (as-list (list 1 2 3))))) + (test-equal '(1 2 3) (prop ev 'PROP)) + (test-equal 3 (length (prop* ev 'PROP))) + (test-assert (every vline? (prop* ev 'PROP))))) + +;; (test-group "Parameters and lists" ) diff --git a/tests/test/data-stores/file.scm b/tests/test/data-stores/file.scm new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/tests/test/data-stores/file.scm diff --git a/tests/test/data-stores/sqlite.scm b/tests/test/data-stores/sqlite.scm new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/tests/test/data-stores/sqlite.scm diff --git a/tests/test/data-stores/vdir.scm b/tests/test/data-stores/vdir.scm new file mode 100644 index 00000000..e69de29b --- /dev/null +++ b/tests/test/data-stores/vdir.scm diff --git a/tests/test/hnh-util-env.scm b/tests/test/hnh-util-env.scm new file mode 100644 index 00000000..f38a3a3b --- /dev/null +++ b/tests/test/hnh-util-env.scm @@ -0,0 +1,49 @@ +(define-module (test hnh-util-env) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module ((guile) :select (setenv getenv)) + :use-module ((hnh util env) :select (let-env))) + + +(test-group "let-env" + (setenv "CALP_TEST_ENV" "1") + + (test-equal + "Ensure we have set value beforehand" + "1" + (getenv "CALP_TEST_ENV")) + + (let-env + ((CALP_TEST_ENV "2")) + (test-equal + "Test our local override" + "2" + (getenv "CALP_TEST_ENV"))) + + (test-equal + "Test that we have returned" + "1" + (getenv "CALP_TEST_ENV")) + + (catch 'test-error + (lambda () + (let-env + ((CALP_TEST_ENV "2")) + (test-equal + "Test our local override again" + "2" + (getenv "CALP_TEST_ENV")) + (throw 'test-error))) + list) + + (test-equal + "Test restoration after non-local exit" + "1" + (getenv "CALP_TEST_ENV"))) + +(test-group "with-working-directory" + 'TODO) + +(test-group "with-locale" + 'TODO) diff --git a/tests/test/hnh-util-path.scm b/tests/test/hnh-util-path.scm new file mode 100644 index 00000000..de4bf8e3 --- /dev/null +++ b/tests/test/hnh-util-path.scm @@ -0,0 +1,124 @@ +(define-module (test hnh-util-path) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module ((hnh util env) :select (with-working-directory)) + :use-module (hnh util path)) + +(test-equal + "no slashes" + "home/user" + (path-append "home" "user")) + +(test-equal + "no slashes, absolute" + "/home/user" + (path-append "" "home" "user")) + +(test-equal + "slashes in one component, absolute" + "/home/user" + (path-append "" "/home/" "user")) + +(test-equal + "slashes in one component, absolute due to first" + "/home/user" + (path-append "/home/" "user")) + +(test-equal + "Slashes in both" + "home/user" + (path-append "home/" "/user")) + +(test-equal "root" "/" (path-append "")) + +(test-equal + '("usr" "lib" "test") + (path-split "usr/lib/test")) + +(test-equal + '("usr" "lib" "test") + (path-split "usr/lib/test/")) + +(test-equal + '("" "usr" "lib" "test") + (path-split "/usr/lib/test")) + +(test-equal + '("" "usr" "lib" "test") + (path-split "//usr////lib/test")) + +(test-assert (file-hidden? ".just-filename")) +(test-assert (file-hidden? "/path/to/.hidden")) +(test-assert (not (file-hidden? "/visible/.in/hidden"))) +(test-assert (not (file-hidden? ""))) + +;; TODO test realpath with .. and similar + +(test-equal "Realpath for path fragment" + "/home/hugo" + (with-working-directory + "/home" + (lambda () (realpath "hugo")))) + +(test-equal "Realpath for already absolute path" + "/home/hugo" + (with-working-directory + "/tmp" + (lambda () (realpath "/home/hugo")))) + +(test-equal "Realpath for already absolute path" + "/home/hugo" + (with-working-directory + "/tmp" + (lambda () (realpath "/home/hugo")))) + + +(test-group "Relative to" + + (test-group "With relative child" + (test-equal "/some/path" (relative-to "/some" "path"))) + + ;; Relative parent just adds (getcwd) to start of parent, + ;; but this is "hard" to test. + ;; (test-group "With relative parent") + + (test-group "With absolute child" + (test-error 'misc-error (relative-to "" "/some/path")) + (test-equal "some/path" (relative-to "/" "/some/path")) + (test-group "Without trailing slashes" + (test-equal "path" (relative-to "/some" "/some/path")) + (test-equal "../path" (relative-to "/some" "/other/path"))) + (test-group "With trailing slashes" + (test-equal "path" (relative-to "/some" "/some/path/")) + (test-equal "../path" (relative-to "/some" "/other/path/")))) + + (test-equal "/a/b" (relative-to "/a/b/c" "/a/b")) + + ) + + +(test-equal "Extension of simple file" + "txt" (filename-extension "file.txt")) + +(test-equal "Extension of file with directory" + "txt" (filename-extension "/direcotry/file.txt")) + +(test-equal "Extension of file with multiple" + "gz" (filename-extension "filename.tar.gz")) + +(test-equal "Filename extension when none is present" + "" (filename-extension "filename")) + +(test-equal "Filename extension when none is present, but directory has" + "" (filename-extension "config.d/filename")) + +(test-equal "Filename extension of directory" + "d" (filename-extension "config.d/")) + + +(test-equal "Extension of hidden file" + "sh" (filename-extension ".bashrc.sh")) + +(test-equal "Extension of hidden file without extension" + "bashrc" (filename-extension ".bashrc")) diff --git a/tests/test/hnh-util-state-monad.scm b/tests/test/hnh-util-state-monad.scm new file mode 100644 index 00000000..353c47e9 --- /dev/null +++ b/tests/test/hnh-util-state-monad.scm @@ -0,0 +1,120 @@ +(define-module (test hnh-util-state-monad) + :use-module (srfi srfi-64) + :use-module (hnh util state-monad)) + + +(call-with-values (lambda () ((return 1) 2)) + (lambda (value state) + (test-equal "Return returns the value unmodified" 1 value) + (test-equal "Return also returns the state as a second value" 2 state))) + +(test-equal "Get returns the current state as primary value, while kepping the state" + '(state state) + (call-with-values (lambda () ((get) 'state)) list)) + +;; Return value of put untested, since it's undefined +(test-equal "Put replaces the old state with a new one, and return old one" + '(old-state new-state) + (call-with-values (lambda () ((put 'new-state) 'old-state)) + list)) + +(test-equal "A simple do is effectively a `values' call" + '(value initial-state) + (call-with-values (lambda () ((do (return 'value)) 'initial-state)) + list)) + +(test-equal "Let statement in do" + '(10 state) + (call-with-values (lambda () ((do x = 10 + (return x)) + 'state)) + list)) + +;; TODO let statement with multiple binds +;; (do let (a b) = (values 10 20) ...) + +(test-equal "Set and get through do, along with <- in do." + '(5 1) + (call-with-values (lambda () ((do old <- (get) + (put (1+ old)) + (return 5)) + 0)) + list)) + + + +(test-equal "<$> Updates stuff before being removed from the monad context" + '(11 10) + (call-with-values (lambda () + ((do x <- (<$> 1+ (get)) + (return x)) + 10)) + list)) + +(test-equal "Sequence should update the state accordingly" + 3 + (call-with-values + (lambda () + ((sequence + (list (mod 1+) + (mod 1+) + (mod 1+))) + 0)) + (lambda (_ st) st))) + +(test-equal "Sequence should also act as map on the primary value" + '((0 1 2) 3) + (call-with-values + (lambda () + ((sequence + (list (mod 1+) + (mod 1+) + (mod 1+))) + 0)) + list)) + +(test-equal "Get returns a single value when only a single value is in the state" + '(1 1) (call-with-values (lambda () ((get) 1)) + list)) + +(test-equal "Get returns a list of values when multiple items are in the state" + '((1 2 3) 1 2 3) + (call-with-values (lambda () ((get) 1 2 3)) + list)) + +(test-equal "Get with multiple values" + '((1 2) 1 2) + (call-with-values (lambda () ((get) 1 2)) + list)) + +(test-equal "Get with multiple values in do" + '((1 2) 1 2) + (call-with-values (lambda () + ((do (a b) <- (get) + (return (list a b))) + 1 2)) + list)) + +((do (put 0) + (with-temp-state + (list 10) + (do a <- (get) + (return (test-equal "Temporary state is set" + 10 a)) + (put 20))) + a <- (get) + (return (test-equal "Pre-temp state is restored" 0 a))) + 'init) + + +;; TODO test for do where the number of implicit arguments changes + +(test-equal "Something" 30 + ((do (with-temp-state + '(10 20) + ;; todo (lift +) + (do (a b) <- (get) + (return (+ a b))))) + 0 1)) + + diff --git a/tests/test/hnh-util.scm b/tests/test/hnh-util.scm new file mode 100644 index 00000000..4e50ac1b --- /dev/null +++ b/tests/test/hnh-util.scm @@ -0,0 +1,428 @@ +;;; Commentary: +;; Checks some prodecuders from (hnh util) +;;; Code: + +(define-module (test hnh-util) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module (srfi srfi-1) + :use-module (hnh util) + :use-module (hnh util env) + ) + +(define (unreachable) + (throw 'unreachable)) + + +;;; Changed core bindings + +(test-group "set!" + (let ((x 10)) + (set! x 20) + (test-eqv "Regular set! still works" 20 x)) + + (test-group "Multiple set! at once works" + (let ((x 10) (y 20)) + (set! x 20 + y 30) + (test-eqv x 20) + (test-eqv y 30))) + + (test-group "Set! is ordered" + (let ((x 10)) + (set! x 20 + x (* x 2)) + (test-eqv x 40))) + + ;; TODO + ;; (test-group "set! =" + ;; ) + + ) + +;;; Nonscensical to test +;; (test-group "define-syntax" +;; ) + +(test-group "when" + (test-equal "when" + 1 (when #t 1)) + + (test-equal "'() when #f" + '() (when #f 1))) + +(test-group "unless" + (test-equal "unless" + 1 (unless #f 1)) + + (test-equal "'() unless #t" + '() (unless #t 1))) + + + +;;; New bindings + +(test-group "aif" + (aif (+ 1 2) + (test-eqv 3 it) + (unreachable)) + + (aif #f + (unreachable) + (test-assert #t))) + +(test-group "awhen" + (test-equal "awhen it" + '(3 4 5) + (awhen (memv 2 '(1 2 3 4 5)) + (cdr it))) + + (test-equal "awhen not" + '() + (awhen (memv 0 '(1 2 3 4 5)) + (cdr it)))) + +(test-group "for" + (test-equal "for simple" + (iota 10) + (for x in (iota 10) + x)) + + (test-equal "for matching" + (iota 12) + (for (x c) in (zip (iota 12) (string->list "Hello, World")) + x)) + + (test-equal "for with improper list elements" + `(3 7) + (for (a . b) in '((1 . 2) (3 . 4)) + (+ a b))) + + (test-equal "for with longer improper list elements" + '(1 2 4) + (for (a b . c) in '((1 -1 . 1) (2 -2 . 2) (4 -4 . 4)) + (* c (+ 1 a b))))) + +(test-group "begin1" + (let ((value #f)) + (test-equal + "begin1 return value" + "Hello" + (begin1 "Hello" (set! value "World"))) + (test-equal "begin1 side effects" "World" value)) + + (let ((x 1)) + (test-eqv "begin1 set! after return" + 1 (begin1 x (set! x 10))) + (test-eqv "Updates value" + 10 x))) + +(test-group "print-and-return" + (let ((p (open-output-string))) + (let ((v (with-error-to-port p + (lambda () (print-and-return (+ 1 2)))))) + (test-equal "Printed value" + "3 [(+ 1 2)]\n" (get-output-string p)) + (test-eqv "Returned value" + 3 v)))) + +(test-group "swap" + (test-equal + '(3 2 1) + ((swap list) 1 2 3))) + +(test-group "set/r!" + (test-equal + "set/r! = single" + #f + (let ((x #t)) (set/r! x = not))) + + (test-error + 'syntax-error + (test-read-eval-string "(set/r! x err not)"))) + +(test-group "label" + (test-equal "procedure label" + 120 + ((label factorial (lambda (n) + (if (zero? n) + 1 (* n (factorial (1- n)))))) + 5))) + +(test-group "sort*" + ;; we can't test if sort*! destroys the list, since its only /allowed/ to do it, + ;; not required. + (test-equal "sort*!" + '("a" "Hello" "Assparagus") + (sort*! '("Hello" "a" "Assparagus") + < string-length))) + + +(test-group "find-extreme" + (test-error 'wrong-type-arg (find-extreme '())) + + (test-group "find-min" + (call-with-values + (lambda () (find-min (iota 10))) + (lambda (extreme rest) + (test-equal "Found correct minimum" 0 extreme) + (test-equal + "Removed \"something\" from the set" + 9 + (length rest))))) + + (test-group "find-max" + (call-with-values + (lambda () + (find-max + '("Hello" "Test" "Something long") + string-length)) + (lambda (extreme rest) + (test-equal + "Found the longest string" + "Something long" + extreme) + (test-equal "Removed the string" 2 (length rest)) + (test-assert + "Other members left 1" + (member "Hello" rest)) + (test-assert + "Other members left 2" + (member "Test" rest)))))) + +(test-group "filter-sorted" + (test-equal + "Filter sorted" + '(3 4 5) + (filter-sorted (lambda (x) (<= 3 x 5)) (iota 10)))) + + +(test-group "!=" + (test-assert "not equal" + (!= 1 2))) + +(test-group "init+last" + 'TODO) + +(test-group "take-to" + (test-equal "Take to" + '() (take-to '() 5))) + +(test-group "string-take-to" + (test-equal "Hello" + (string-take-to "Hello, World!" 5))) + +(test-group "string-first" + (test-eqv #\H (string-first "Hello, World!"))) + +(test-group "string-last" + (test-eqv #\! (string-last "Hello, World!"))) + +(test-group "as-symb" + (test-eq "From string" 'hello (as-symb "hello")) + (test-eq "From symbol" 'hello (as-symb 'hello)) + (test-eq "NOTE that others pass right through" + '() (as-symb '()))) + + +(test-group "enumerate" + (test-equal "Enumerate" + '((0 #\H) (1 #\e) (2 #\l) (3 #\l) (4 #\o) (5 #\,) (6 #\space) (7 #\W) (8 #\o) (9 #\r) (10 #\l) (11 #\d) (12 #\!)) + (enumerate (string->list "Hello, World!")))) + + +(test-group "unval" + (test-equal "unval first" + 1 + ((unval (lambda () (values 1 2 3))))) + + (test-equal "unval other" + 2 + ((unval car+cdr 1) + (cons 1 2)))) + + +(test-group "flatten" + (test-equal "flatten already flat" + (iota 10) + (flatten (iota 10))) + + (test-equal "flatten really deep" + '(1) + (flatten '(((((((((((((((1))))))))))))))))) + + (test-equal "flatten mixed" + '(1 2 3 4 5) + (flatten '((((((1(((((2((((3))))))4))))))))5)))) + +(test-group "let-lazy" + 'TODO) + +(test-group "map/dotted" + (test-equal "map/dotted without dot" + '(1 2 3 4) + (map/dotted 1+ '(0 1 2 3))) + + (test-equal "map/dotted with dot" + '(1 2 3 . 4) + (map/dotted 1+ '(0 1 2 . 3))) + + (test-equal "map/dotted direct value" + 1 (map/dotted 1+ 0))) + +(test-group "assq-merge" + (test-equal "assq merge" + '((k 2 1) (v 2)) + (assq-merge '((k 1) (v 2)) '((k 2))))) + + +(test-group "kvlist->assq" + (test-equal "kvlist->assq" + '((a . 1) (b . 2)) + (kvlist->assq '(a: 1 b: 2))) + + (test-equal "kvlist->assq repeated key" + '((a . 1) (b . 2) (a . 3)) + (kvlist->assq '(a: 1 b: 2 a: 3)))) + +(test-group "assq-limit" + 'TODO) + + +(test-group "group-by" + ;; Extra roundabout tests since groups-by doesn't guarantee order of the keys + (test-group "Two simple groups" + (let ((groups (group-by even? (iota 10)))) + (test-assert (lset= eq? '(#f #t) (map car groups))) + (test-assert (lset= = '(0 2 4 6 8) (assq-ref groups #t))) + (test-assert (lset= = '(1 3 5 7 9) (assq-ref groups #f))))) + + (test-group "Identity groups" + (let ((groups (group-by identity (iota 5)))) + (test-assert "Correct keys" + (lset= = (iota 5) (map car groups))) + (test-group "Correct amount in each group" + (for-each (lambda (g) (test-equal 1 (length (cdr g)))) groups)))) + + (test-equal "Null case" + '() + (group-by (lambda _ (unreachable)) '()))) + +(test-group "split-by" + 'TODO) + + +(test-group "span-upto" + (test-group "Case 1" + (call-with-values + (lambda () + (span-upto + 2 + char-numeric? + (string->list "123456"))) + (lambda (head tail) + (test-equal '(#\1 #\2) head) + (test-equal '(#\3 #\4 #\5 #\6) tail)))) + + (test-group "Case 2" + (call-with-values + (lambda () + (span-upto + 2 + char-numeric? + (string->list "H123456"))) + (lambda (head tail) + (test-equal '() head) + (test-equal '(#\H #\1 #\2 #\3 #\4 #\5 #\6) tail))))) + +(test-group "cross-product" + (test-equal "Basic case" + '((1 4) + (1 5) + (1 6) + (2 4) + (2 5) + (2 6) + (3 4) + (3 5) + (3 6)) + (cross-product + '(1 2 3) + '(4 5 6))) + + (test-equal "Single input list" + '((1) (2) (3)) + (cross-product '(1 2 3))) + + (test-equal "More than two" + '((1 3 5) (1 3 6) + (1 4 5) (1 4 6) + (2 3 5) (2 3 6) + (2 4 5) (2 4 6)) + (cross-product + '(1 2) + '(3 4) + '(5 6)))) + +(test-group "string-flatten" + 'TODO) + +(test-group "intersperse" + 'TODO) + +(test-group "insert-ordered" + 'TODO) + +(test-group "-> (arrows)" + (test-equal "->" 9 (-> 1 (+ 2) (* 3))) + (test-equal "-> order dependant" -1 (-> 1 (- 2))) + (test-equal "->> order dependant" 1 (->> 1 (- 2)))) + +(test-group "set" + 'TODO) + +(test-group "set->" + 'TODO) + +(test-group "and=>" + 'TODO) + +(test-group "downcase-symbol" + 'TODO) + + +(test-group "group" + ;; TODO test failure when grouping isn't possible? + (test-equal "Group" + '((0 1) (2 3) (4 5) (6 7) (8 9)) + (group (iota 10) 2))) + +(test-group "iterate" + (test-equal 0 (iterate 1- zero? 10))) + +(test-group "valued-map" + 'TODO) + +(test-group "assoc-ref-all" + (test-equal "assoc-ref-all" + '(1 3) (assoc-ref-all '((a . 1) (b . 2) (a . 3)) 'a)) + (test-equal "assq-ref-all" + '(1 3) (assq-ref-all '((a . 1) (b . 2) (a . 3)) 'a)) + (test-equal "assv-ref-all" + '(1 3) (assv-ref-all '((a . 1) (b . 2) (a . 3)) 'a))) + +(test-group "unique" + 'TODO) + +(test-group "vector-last" + (test-equal "vector-last" + 1 (vector-last #(0 2 3 1)))) + +(test-group "->string" + (test-equal "5" (->string 5)) + (test-equal "5" (->string "5"))) + +(test-group "catch*" + 'TODO) + diff --git a/tests/test/html/caltable.scm b/tests/test/html/caltable.scm index f64f8775..fec1ace4 100644 --- a/tests/test/html/caltable.scm +++ b/tests/test/html/caltable.scm @@ -11,7 +11,7 @@ ;; Not the most robust test, but at least it shows us when we break something (test-equal "Whole fucking caltable" `(div (@ (class "small-calendar")) - (div (@ (class "column-head row-head")) ,(_ "v.")) + (div (@ (class "column-head row-head")) ,(G_ "v.")) (div (@ (class "column-head")) "Må") (div (@ (class "column-head")) "Ti") (div (@ (class "column-head")) "On") diff --git a/tests/test/let-env.scm b/tests/test/let-env.scm deleted file mode 100644 index e3dc5927..00000000 --- a/tests/test/let-env.scm +++ /dev/null @@ -1,43 +0,0 @@ -(define-module (test let-env) - :use-module (srfi srfi-64) - :use-module (srfi srfi-64 test-error) - :use-module (srfi srfi-88) - :use-module ((guile) :select (setenv getenv)) - :use-module ((hnh util env) :select (let-env))) - -(setenv "CALP_TEST_ENV" "1") - -(test-equal - "Ensure we have set value beforehand" - "1" - (getenv "CALP_TEST_ENV")) - -(let-env - ((CALP_TEST_ENV "2")) - (test-equal - "Test our local override" - "2" - (getenv "CALP_TEST_ENV"))) - -(test-equal - "Test that we have returned" - "1" - (getenv "CALP_TEST_ENV")) - -(catch 'test-error - (lambda () - (let-env - ((CALP_TEST_ENV "2")) - (test-equal - "Test our local override again" - "2" - (getenv "CALP_TEST_ENV")) - (throw 'test-error))) - list) - -(test-equal - "Test restoration after non-local exit" - "1" - (getenv "CALP_TEST_ENV")) - - diff --git a/tests/test/recurrence-advanced.scm b/tests/test/recurrence-advanced.scm index 56f4cda6..c4684ba7 100644 --- a/tests/test/recurrence-advanced.scm +++ b/tests/test/recurrence-advanced.scm @@ -14,8 +14,8 @@ (define-module (test recurrence-advanced) :use-module (srfi srfi-64) :use-module (srfi srfi-88) - :use-module ((vcomponent recurrence parse) - :select (parse-recurrence-rule)) + :use-module ((vcomponent recurrence) + :select (make-recur-rule)) :use-module ((vcomponent recurrence generate) :select (generate-recurrence-set)) :use-module ((vcomponent recurrence display) @@ -24,12 +24,15 @@ :select (count until)) :use-module ((vcomponent base) :select (make-vcomponent prop prop* extract make-vline)) + :use-module (vcomponent create) :use-module ((datetime) :select (parse-ics-datetime datetime datetime-date time date + jan feb mar apr may jun jul aug sep oct nov dec + mon tue wed thu fri sat sun datetime->string)) :use-module ((hnh util) :select (-> set!)) :use-module ((srfi srfi-41) :select (stream->list)) @@ -64,36 +67,16 @@ ;; TODO possibly test with other languages (format-recurrence-rule (prop comp 'RRULE) 'sv))) -;; TODO remove this makeshift parser (and all others), and replace them with a -;; properly specified syntax for easily creating objects. -(define (vevent . rest) - (define v (make-vcomponent 'VEVENT)) - (let loop ((rem rest)) - (unless - (null? rem) - (let ((symb (-> (car rem) - keyword->string - string-upcase - string->symbol))) - ;; TODO extend to allow dates (without time) - (case symb - ((EXDATE RDATE) (set! (prop* v symb) - (map (lambda (dt) (make-vline symb dt (make-hash-table))) - (map parse-ics-datetime (cadr rem))))) - ((DTSTART) (set! (prop v symb) (parse-ics-datetime (cadr rem)))) - ((RRULE) (set! (prop v symb) (parse-recurrence-rule (cadr rem)))) - (else (set! (prop v symb) (cadr rem))))) - (loop (cddr rem)))) - v) - (map run-test (list (vevent summary: "Daily for 10 occurrences" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=DAILY;COUNT=10" + (make-recur-rule + freq: 'DAILY + count: 10) x-summary: "dagligen, totalt 10 gånger" x-set: @@ -111,9 +94,11 @@ summary: "Daily until December 24, 1997" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=DAILY;UNTIL=19971224T000000Z" + (make-recur-rule + freq: 'DAILY + until: #1997-12-24T00:00:00Z) x-summary: "dagligen, till och med den 24 december, 1997 kl. 0:00" x-set: @@ -234,9 +219,11 @@ summary: "Every other day - forever" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=DAILY;INTERVAL=2" + (make-recur-rule + freq: 'DAILY + interval: 2) x-summary: "varannan dag" x-set: @@ -264,9 +251,12 @@ summary: "Every 10 days, 5 occurrences" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=DAILY;INTERVAL=10;COUNT=5" + (make-recur-rule + freq: 'DAILY + interval: 10 + count: 5) x-summary: "var tionde dag, totalt 5 gånger" x-set: @@ -279,9 +269,13 @@ summary: "Every day in January, for 3 years (alt 1)" dtstart: - "19980101T090000" + #1998-01-01T09:00:00 rrule: - "FREQ=YEARLY;UNTIL=20000131T140000Z;BYMONTH=1;BYDAY=SU,MO,TU,WE,TH,FR,SA" + (make-recur-rule + freq: 'YEARLY + until: #2000-01-31T14:00:00Z + bymonth: (list jan) + byday: (list sun mon tue wed thu fri sat)) x-summary: "varje lördag, fredag, torsdag, onsdag, tisdag, måndag & söndag i januari, årligen, till och med den 31 januari, 2000 kl. 14:00" x-set: @@ -382,9 +376,12 @@ summary: "Every day in January, for 3 years (alt 2)" dtstart: - "19980101T090000" + #1998-01-01T09:00:00 rrule: - "FREQ=DAILY;UNTIL=20000131T140000Z;BYMONTH=1" + (make-recur-rule + freq: 'DAILY + until: #2000-01-31T14:00:00Z + bymonth: 1) x-summary: "dagligen, till och med den 31 januari, 2000 kl. 14:00" x-set: @@ -485,9 +482,11 @@ summary: "Weekly for 10 occurrences" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=WEEKLY;COUNT=10" + (make-recur-rule + freq: 'WEEKLY + count: 10) x-summary: "varje vecka, totalt 10 gånger" x-set: @@ -505,9 +504,11 @@ summary: "Weekly until December 24, 1997" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=WEEKLY;UNTIL=19971224T000000Z" + (make-recur-rule + freq: 'WEEKLY + until: #1997-12-24T00:00:00Z) x-summary: "varje vecka, till och med den 24 december, 1997 kl. 0:00" x-set: @@ -532,9 +533,12 @@ summary: "Every other week - forever" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=WEEKLY;INTERVAL=2;WKST=SU" + (make-recur-rule + freq: 'WEEKLY + interval: 2 + wkst: sun) x-summary: "varannan vecka" x-set: @@ -562,9 +566,13 @@ summary: "Weekly on Tuesday and Thursday for five weeks (alt 1)" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=WEEKLY;UNTIL=19971007T000000Z;WKST=SU;BYDAY=TU,TH" + (make-recur-rule + freq: 'WEEKLY + until: #1997-10-07T00:00:00Z + wkst: sun + byday: (list tue thu)) x-summary: "varje tisdag & torsdag, till och med den 07 oktober, 1997 kl. 0:00" x-set: @@ -582,9 +590,13 @@ summary: "Weekly on Tuesday and Thursday for five weeks (alt 2)" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=WEEKLY;COUNT=10;WKST=SU;BYDAY=TU,TH" + (make-recur-rule + freq: 'WEEKLY + count: 10 + wkst: sun + byday: (list tue thu)) x-summary: "varje tisdag & torsdag, totalt 10 gånger" x-set: @@ -602,9 +614,14 @@ summary: "Every other week on Monday, Wednesday, and Friday until December 24, 1997, starting on Monday, September 1, 1997:" dtstart: - "19970901T090000" + #1997-09-01T09:00:00 rrule: - "FREQ=WEEKLY;INTERVAL=2;UNTIL=19971224T000000Z;WKST=SU;BYDAY=MO,WE,FR" + (make-recur-rule + freq: 'WEEKLY + interval: 2 + until: #1997-12-24T00:00:00Z + wkst: sun + byday: (list mon wed fri)) x-summary: "varannan måndag, onsdag & fredag, till och med den 24 december, 1997 kl. 0:00" x-set: @@ -637,9 +654,14 @@ summary: "Every other week on Tuesday and Thursday, for 8 occurrences" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=WEEKLY;INTERVAL=2;COUNT=8;WKST=SU;BYDAY=TU,TH" + (make-recur-rule + freq: 'WEEKLY + interval: 2 + count: 8 + wkst: sun + byday: (list tue thu)) x-summary: "varannan tisdag & torsdag, totalt 8 gånger" x-set: @@ -655,9 +677,12 @@ summary: "Monthly on the first Friday for 10 occurrences" dtstart: - "19970905T090000" + #1997-09-05T09:00:00 rrule: - "FREQ=MONTHLY;COUNT=10;BYDAY=1FR" + (make-recur-rule + freq: 'MONTHLY + count: 10 + byday: (list (cons 1 fri))) x-summary: "första fredagen varje månad, totalt 10 gånger" x-set: @@ -675,9 +700,12 @@ summary: "Monthly on the first Friday until December 24, 1997" dtstart: - "19970905T090000" + #1997-09-05T09:00:00 rrule: - "FREQ=MONTHLY;UNTIL=19971224T000000Z;BYDAY=1FR" + (make-recur-rule + freq: 'MONTHLY + until: #1997-12-24T00:00:00Z + byday: (list (cons 1 fri))) x-summary: "första fredagen varje månad, till och med den 24 december, 1997 kl. 0:00" x-set: @@ -689,9 +717,14 @@ summary: "Every other month on the first and last Sunday of the month for 10 occurrences" dtstart: - "19970907T090000" + #1997-09-07T09:00:00 rrule: - "FREQ=MONTHLY;INTERVAL=2;COUNT=10;BYDAY=1SU,-1SU" + (make-recur-rule + freq: 'MONTHLY + interval: 2 + count: 10 + byday: (list (cons 1 sun) + (cons -1 sun))) x-summary: "första söndagen samt sista söndagen varannan månad, totalt 10 gånger" x-set: @@ -709,9 +742,12 @@ summary: "Monthly on the second-to-last Monday of the month for 6 months" dtstart: - "19970922T090000" + #1997-09-22T09:00:00 rrule: - "FREQ=MONTHLY;COUNT=6;BYDAY=-2MO" + (make-recur-rule + freq: 'MONTHLY + count: 6 + byday: (list (cons -2 mon))) x-summary: "näst sista måndagen varje månad, totalt 6 gånger" x-set: @@ -725,9 +761,11 @@ summary: "Monthly on the third-to-the-last day of the month, forever" dtstart: - "19970928T090000" + #1997-09-28T09:00:00 rrule: - "FREQ=MONTHLY;BYMONTHDAY=-3" + (make-recur-rule + freq: 'MONTHLY + bymonthday: (list -3)) x-summary: "den tredje sista varje månad" x-set: @@ -755,9 +793,12 @@ summary: "Monthly on the 2nd and 15th of the month for 10 occurrences" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=MONTHLY;COUNT=10;BYMONTHDAY=2,15" + (make-recur-rule + freq: 'MONTHLY + count: 10 + bymonthday: (list 2 15)) x-summary: "den andre & femtonde varje månad, totalt 10 gånger" x-set: @@ -775,9 +816,12 @@ summary: "Monthly on the first and last day of the month for 10 occurrences" dtstart: - "19970930T090000" + #1997-09-30T09:00:00 rrule: - "FREQ=MONTHLY;COUNT=10;BYMONTHDAY=1,-1" + (make-recur-rule + freq: 'MONTHLY + count: 10 + bymonthday: (list 1 -1)) x-summary: "den förste & sista varje månad, totalt 10 gånger" x-set: @@ -795,9 +839,13 @@ summary: "Every 18 months on the 10th thru 15th of the month for 10 occurrences" dtstart: - "19970910T090000" + #1997-09-10T09:00:00 rrule: - "FREQ=MONTHLY;INTERVAL=18;COUNT=10;BYMONTHDAY=10,11,12,13,14,15" + (make-recur-rule + freq: 'MONTHLY + interval: 18 + count: 10 + bymonthday: (list 10 11 12 13 14 15)) x-summary: "den tionde, elfte, tolfte, trettonde, fjortonde & femtonde var artonde månad, totalt 10 gånger" x-set: @@ -815,9 +863,12 @@ summary: "Every Tuesday, every other month" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=MONTHLY;INTERVAL=2;BYDAY=TU" + (make-recur-rule + freq: 'MONTHLY + interval: 2 + byday: (list tue)) x-summary: "varje tisdag varannan månad" x-set: @@ -845,9 +896,12 @@ summary: "Yearly in June and July for 10 occurrences:\n: Since none of the BYDAY, BYMONTHDAY, or BYYEARDAY\nonents are specified, the day is gotten from \"DTSTART\"" dtstart: - "19970610T090000" + #1997-06-10T09:00:00 rrule: - "FREQ=YEARLY;COUNT=10;BYMONTH=6,7" + (make-recur-rule + freq: 'YEARLY + count: 10 + bymonth: (list 6 7)) x-summary: "juni & juli, årligen, totalt 10 gånger" x-set: @@ -865,9 +919,13 @@ summary: "Every other year on January, February, and March for 10 occurrences" dtstart: - "19970310T090000" + #1997-03-10T09:00:00 rrule: - "FREQ=YEARLY;INTERVAL=2;COUNT=10;BYMONTH=1,2,3" + (make-recur-rule + freq: 'YEARLY + interval: 2 + count: 10 + bymonth: (list jan feb mar)) x-summary: "januari, februari & mars vartannat år, totalt 10 gånger" x-set: @@ -885,9 +943,13 @@ summary: "Every third year on the 1st, 100th, and 200th day for 10 occurrences" dtstart: - "19970101T090000" + #1997-01-01T09:00:00 rrule: - "FREQ=YEARLY;INTERVAL=3;COUNT=10;BYYEARDAY=1,100,200" + (make-recur-rule + freq: 'YEARLY + interval: 3 + count: 10 + byyearday: (list 1 100 200)) x-summary: "dag 1, 100 & 200 vart tredje år, totalt 10 gånger" x-set: @@ -905,9 +967,11 @@ summary: "Every 20th Monday of the year, forever" dtstart: - "19970519T090000" + #1997-05-19T09:00:00 rrule: - "FREQ=YEARLY;BYDAY=20MO" + (make-recur-rule + freq: 'YEARLY + byday: (list (cons 20 mon))) x-summary: "tjugonde måndagen, årligen" x-set: @@ -935,9 +999,12 @@ summary: "Monday of week number 20 (where the default start of the week is Monday), forever" dtstart: - "19970512T090000" + #1997-05-12T09:00:00 rrule: - "FREQ=YEARLY;BYWEEKNO=20;BYDAY=MO" + (make-recur-rule + freq: 'YEARLY + byweekno: (list 20) + byday: (list mon)) x-summary: "varje måndag v.20, årligen" x-set: @@ -965,9 +1032,12 @@ summary: "Every Thursday in March, forever" dtstart: - "19970313T090000" + #1997-03-13T09:00:00 rrule: - "FREQ=YEARLY;BYMONTH=3;BYDAY=TH" + (make-recur-rule + freq: 'YEARLY + bymonth: (list mar) + byday: (list thu)) x-summary: "varje torsdag i mars, årligen" x-set: @@ -995,9 +1065,12 @@ summary: "Every Thursday, but only during June, July, and August, forever" dtstart: - "19970605T090000" + #1997-06-05T09:00:00 rrule: - "FREQ=YEARLY;BYDAY=TH;BYMONTH=6,7,8" + (make-recur-rule + freq: 'YEARLY + byday: (list thu) + bymonth: (list 6 7 8)) x-summary: "varje torsdag i juni, juli & augusti, årligen" x-set: @@ -1025,11 +1098,15 @@ summary: "Every Friday the 13th, forever" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 exdate: - (list "19970902T090000") + (as-list + (list #1997-09-02T09:00:00)) rrule: - "FREQ=MONTHLY;BYDAY=FR;BYMONTHDAY=13" + (make-recur-rule + freq: 'MONTHLY + byday: (list fri) + bymonthday: (list 13)) x-summary: "varje fredag den trettonde varje månad" x-set: @@ -1057,9 +1134,12 @@ summary: "The first Saturday that follows the first Sunday of the month, forever" dtstart: - "19970913T090000" + #1997-09-13T09:00:00 rrule: - "FREQ=MONTHLY;BYDAY=SA;BYMONTHDAY=7,8,9,10,11,12,13" + (make-recur-rule + freq: 'MONTHLY + byday: (list sat) + bymonthday: (list 7 8 9 10 11 12 13)) x-summary: "varje lördag den sjunde, åttonde, nionde, tionde, elfte, tolfte & trettonde varje månad" x-set: @@ -1087,9 +1167,14 @@ summary: "Every 4 years, the first Tuesday after a Monday in November,\nver (U.S. Presidential Election day)" dtstart: - "19961105T090000" + #1996-11-05T09:00:00 rrule: - "FREQ=YEARLY;INTERVAL=4;BYMONTH=11;BYDAY=TU;BYMONTHDAY=2,3,4,5,6,7,8" + (make-recur-rule + freq: 'YEARLY + interval: 4 + bymonth: (list nov) + byday: (list tue) + bymonthday: (list 2 3 4 5 6 7 8)) x-summary: "varje tisdag den andre, tredje, fjärde, femte, sjätte, sjunde eller åttonde i november vart fjärde år" x-set: @@ -1117,9 +1202,13 @@ summary: "The third instance into the month of one of Tuesday, Wednesday, or Thursday, for the next 3 months" dtstart: - "19970904T090000" + #1997-09-04T09:00:00 rrule: - "FREQ=MONTHLY;COUNT=3;BYDAY=TU,WE,TH;BYSETPOS=3" + (make-recur-rule + freq: 'MONTHLY + count: 3 + byday: (list tue wed thu) + bysetpos: (list 3)) x-summary: "NOT YET IMPLEMENTED" x-set: @@ -1130,9 +1219,12 @@ summary: "The second-to-last weekday of the month" dtstart: - "19970929T090000" + #1997-09-29T09:00:00 rrule: - "FREQ=MONTHLY;BYDAY=MO,TU,WE,TH,FR;BYSETPOS=-2" + (make-recur-rule + freq: 'MONTHLY + byday: (list mon tue wed thu fri) + bysetpos: (list -2)) x-summary: "NOT YET IMPLEMENTED" x-set: @@ -1145,9 +1237,12 @@ summary: "Every 3 hours from 9:00 AM to 5:00 PM on a specific day" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=HOURLY;INTERVAL=3;UNTIL=19970902T170000Z" + (make-recur-rule + freq: 'HOURLY + interval: 3 + until: #1997-09-02T17:00:00Z) x-summary: "var tredje timme, till och med den 02 september, 1997 kl. 17:00" x-set: @@ -1158,9 +1253,12 @@ summary: "Every 15 minutes for 6 occurrences" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=MINUTELY;INTERVAL=15;COUNT=6" + (make-recur-rule + freq: 'MINUTELY + interval: 15 + count: 6) x-summary: "varje kvart, totalt 6 gånger" x-set: @@ -1174,9 +1272,12 @@ summary: "Every hour and a half for 4 occurrences" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=MINUTELY;INTERVAL=90;COUNT=4" + (make-recur-rule + freq: 'MINUTELY + interval: 90 + count: 4) x-summary: "var sjätte kvart, totalt 4 gånger" x-set: @@ -1188,9 +1289,12 @@ summary: "Every 20 minutes from 9:00 AM to 4:40 PM every day (alt 1)" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=DAILY;BYHOUR=9,10,11,12,13,14,15,16;BYMINUTE=0,20,40" + (make-recur-rule + freq: 'DAILY + byhour: (list 9 10 11 12 13 14 15 16) + byminute: (list 0 20 40)) x-summary: "dagligen kl. 09:00, 09:20, 09:40, 10:00, 10:20, 10:40, 11:00, 11:20, 11:40, 12:00, 12:20, 12:40, 13:00, 13:20, 13:40, 14:00, 14:20, 14:40, 15:00, 15:20, 15:40, 16:00, 16:20 & 16:40" x-set: @@ -1218,9 +1322,12 @@ summary: "Every 20 minutes from 9:00 AM to 4:40 PM every day (alt 2)" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 rrule: - "FREQ=MINUTELY;INTERVAL=20;BYHOUR=9,10,11,12,13,14,15,16" + (make-recur-rule + freq: 'MINUTELY + interval: 20 + byhour: (list 9 10 11 12 13 14 15 16)) x-summary: "var tjugonde minut kl. 9, 10, 11, 12, 13, 14, 15 & 16" x-set: @@ -1248,9 +1355,14 @@ summary: "An example where the days generated makes a difference because of WKST" dtstart: - "19970805T090000" + #1997-08-05T09:00:00 rrule: - "FREQ=WEEKLY;INTERVAL=2;COUNT=4;BYDAY=TU,SU;WKST=MO" + (make-recur-rule + freq: 'WEEKLY + interval: 2 + count: 4 + byday: (list tue sun) + wkst: mon) x-summary: "varannan tisdag & söndag, totalt 4 gånger" x-set: @@ -1262,9 +1374,14 @@ summary: "changing only WKST from MO to SU, yields different results.." dtstart: - "19970805T090000" + #1997-08-05T09:00:00 rrule: - "FREQ=WEEKLY;INTERVAL=2;COUNT=4;BYDAY=TU,SU;WKST=SU" + (make-recur-rule + freq: 'WEEKLY + interval: 2 + count: 4 + byday: (list tue sun) + wkst: sun) x-summary: "varannan tisdag & söndag, totalt 4 gånger" x-set: @@ -1276,9 +1393,12 @@ summary: "An example where an invalid date (i.e., February 30) is ignored" dtstart: - "20070115T090000" + #2007-01-15T09:00:00 rrule: - "FREQ=MONTHLY;BYMONTHDAY=15,30;COUNT=5" + (make-recur-rule + freq: 'MONTHLY + bymonthday: (list 15 30) + count: 5) x-summary: "den femtonde & tretionde varje månad, totalt 5 gånger" x-set: @@ -1291,11 +1411,15 @@ summary: "Every Friday & Wednesday the 13th, forever" dtstart: - "19970902T090000" + #1997-09-02T09:00:00 exdate: - (list "19970902T090000") + (as-list + (list #1997-09-02T09:00:00)) rrule: - "FREQ=MONTHLY;BYDAY=FR,WE;BYMONTHDAY=13" + (make-recur-rule + freq: 'MONTHLY + byday: (list fri wed) + bymonthday: (list 13)) x-summary: "varje onsdag & fredag den trettonde varje månad" x-set: @@ -1323,9 +1447,12 @@ summary: "Monday & Wednesday of week number 20 (where the default start of the week is Monday), forever" dtstart: - "19970512T090000" + #1997-05-12T09:00:00 rrule: - "FREQ=YEARLY;BYWEEKNO=20;BYDAY=MO,WE" + (make-recur-rule + freq: 'YEARLY + byweekno: (list 20) + byday: (list mon wed)) x-summary: "varje onsdag & måndag v.20, årligen" x-set: @@ -1351,8 +1478,8 @@ #2006-05-17T09:00:00)) (vevent summary: "Each second, for ever" - dtstart: "20201010T100000" - rrule: "FREQ=SECONDLY" + dtstart: #2020-10-10T10:00:00 + rrule: (make-recur-rule freq: 'SECONDLY) x-summary: "varje sekund" x-set: (list #2020-10-10T10:00:00 #2020-10-10T10:00:01 @@ -1378,9 +1505,9 @@ ;; instances may be present. (vevent summary: "Exdates are applied AFTER rrule's" - dtstart: "20220610T100000" - rrule: "FREQ=DAILY;COUNT=5" - exdate: (list "20220612T100000") + dtstart: #2022-06-10T10:00:00 + rrule: (make-recur-rule freq: 'DAILY count: 5) + exdate: (as-list (list #2022-06-12T10:00:00)) x-summary: "dagligen, totalt 5 gånger" x-set: (list #2022-06-10T10:00:00 #2022-06-11T10:00:00 @@ -1390,9 +1517,9 @@ )) (vevent summary: "RDATE:s add to the recurrence rule" - dtstart: "20220610T100000" - rrule: "FREQ=DAILY;COUNT=5" - rdate: (list "20220620T100000") + dtstart: #2022-06-10T10:00:00 + rrule: (make-recur-rule freq: 'DAILY count: 5) + rdate: (as-list (list #2022-06-20T10:00:00)) x-summary: "dagligen, totalt 5 gånger" x-set: (list #2022-06-10T10:00:00 #2022-06-11T10:00:00 @@ -1404,10 +1531,10 @@ ) (vevent summary: "RDATE:s add to the recurrence rule" - dtstart: "20220610T100000" - rrule: "FREQ=DAILY;COUNT=5" - exdate: (list "20220620T100000") - rdate: (list "20220620T100000") + dtstart: #2022-06-10T10:00:00 + rrule: (make-recur-rule freq: 'DAILY count: 5) + exdate: (as-list (list #2022-06-20T10:00:00)) + rdate: (as-list (list #2022-06-20T10:00:00)) x-summary: "dagligen, totalt 5 gånger" x-set: (list #2022-06-10T10:00:00 #2022-06-11T10:00:00 diff --git a/tests/test/recurrence-simple.scm b/tests/test/recurrence-simple.scm index bf154fea..33900ceb 100644 --- a/tests/test/recurrence-simple.scm +++ b/tests/test/recurrence-simple.scm @@ -12,6 +12,9 @@ :select (stream-take stream-map stream->list stream-car)) :use-module ((datetime) :select (day-stream mon)) :use-module ((vcomponent base) :select (extract prop)) + :use-module ((sxml namespaced) :select (sxml->namespaced-sxml)) + :use-module ((calp namespaces) :select (xcal)) + :use-module ((hnh util) :select (->)) :use-module ((hnh util exceptions) :select (warnings-are-errors warning-handler)) :use-module ((vcomponent formats ical parse) @@ -261,9 +264,8 @@ END:VCALENDAR" '((freq "WEEKLY") (interval "1") (wkst "MO")))) (define ev - (sxcal->vcomponent - '(vevent - (properties + (-> '(vevent + (properties (summary (text "reptest")) (dtend (date-time "2021-01-13T02:00:00")) (dtstart (date-time "2021-01-13T01:00:00")) @@ -273,7 +275,9 @@ END:VCALENDAR" (wkst "MO"))) (dtstamp (date-time "2021-01-13T01:42:20Z")) (sequence (integer "0"))) - (components)))) + (components)) + (sxml->namespaced-sxml `((#f . ,xcal))) + sxcal->vcomponent)) (test-assert "Check that recurrence rule commint from xcal also works" diff --git a/tests/test/state-monad.scm b/tests/test/state-monad.scm new file mode 100644 index 00000000..a4e28b78 --- /dev/null +++ b/tests/test/state-monad.scm @@ -0,0 +1,121 @@ +;;; Borrowed from guile-dns + +(define-module (test state-monad) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module (hnh util state-monad) + ) + +(call-with-values (lambda () ((return 1) 2)) + (lambda (value state) + (test-equal "Return returns the value unmodified" 1 value) + (test-equal "Return also returns the state as a second value" 2 state))) + +(test-equal "Get returns the current state as primary value, while kepping the state" + '(state state) + (call-with-values (lambda () ((get) 'state)) list)) + +;; Return value of put untested, since it's undefined +(test-equal "Put replaces the old state with a new one, and return old one" + '(old-state new-state) + (call-with-values (lambda () ((put 'new-state) 'old-state)) + list)) + +(test-equal "A simple do is effectively a `values' call" + '(value initial-state) + (call-with-values (lambda () ((do (return 'value)) 'initial-state)) + list)) + +(test-equal "Let statement in do" + '(10 state) + (call-with-values (lambda () ((do x = 10 + (return x)) + 'state)) + list)) + +;; TODO let statement with multiple binds +;; (do let (a b) = (values 10 20) ...) + +(test-equal "Set and get through do, along with <- in do." + '(5 1) + (call-with-values (lambda () ((do old <- (get) + (put (1+ old)) + (return 5)) + 0)) + list)) + + + +(test-equal "<$> Updates stuff before being removed from the monad context" + '(11 10) + (call-with-values (lambda () + ((do x <- (<$> 1+ (get)) + (return x)) + 10)) + list)) + +(test-equal "Sequence should update the state accordingly" + 3 + (call-with-values + (lambda () + ((sequence + (list (mod 1+) + (mod 1+) + (mod 1+))) + 0)) + (lambda (_ st) st))) + +(test-equal "Sequence should also act as map on the primary value" + '((0 1 2) 3) + (call-with-values + (lambda () + ((sequence + (list (mod 1+) + (mod 1+) + (mod 1+))) + 0)) + list)) + +(test-equal "Get returns a single value when only a single value is in the state" + '(1 1) (call-with-values (lambda () ((get) 1)) + list)) + +(test-equal "Get returns a list of values when multiple items are in the state" + '((1 2 3) 1 2 3) + (call-with-values (lambda () ((get) 1 2 3)) + list)) + +(test-equal "Get with multiple values" + '((1 2) 1 2) + (call-with-values (lambda () ((get) 1 2)) + list)) + +(test-equal "Get with multiple values in do" + '((1 2) 1 2) + (call-with-values (lambda () + ((do (a b) <- (get) + (return (list a b))) + 1 2)) + list)) + +((do (put 0) + (with-temp-state + (list 10) + (do a <- (get) + (return (test-equal "Temporary state is set" + 10 a)) + (put 20))) + a <- (get) + (return (test-equal "Pre-temp state is restored" 0 a))) + 'init) + + +;; TODO test for do where the number of implicit arguments changes + +(test-equal "Something" 30 + ((do (with-temp-state + '(10 20) + ;; todo (lift +) + (do (a b) <- (get) + (return (+ a b))))) + 0 1)) diff --git a/tests/test/sxml-namespaced.scm b/tests/test/sxml-namespaced.scm new file mode 100644 index 00000000..55d52798 --- /dev/null +++ b/tests/test/sxml-namespaced.scm @@ -0,0 +1,170 @@ +(define-module (test sxml-namespaced) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module (ice-9 match) + :use-module (sxml namespaced) + :use-module (hnh util state-monad) + ) + +;;; TODO tests with attributes + +(define (ns x) + (string->symbol (format #f "http://example.com/~a" x))) + +(define (namespaced-symbol ns symb) + (string->symbol (format #f "~a:~a" ns symb))) + + + +(test-group "XML constructor utility procedure" + (test-equal "3 args" + (make-xml-element 'tagname 'namespace 'attributes) + (xml 'namespace 'tagname 'attributes)) + + (test-equal "2 args" + (make-xml-element 'tagname 'namespace '()) + (xml 'namespace 'tagname)) + + (test-equal "1 args" + (make-xml-element 'tagname #f '()) + (xml 'tagname))) + + + +(test-group "xml->namespaced-sxml" + + (test-equal + `(*TOP* (,(xml 'tag))) + (xml->namespaced-sxml "<tag/>")) + + (test-equal + `(*TOP* (,(xml 'ns1 'tag))) + (xml->namespaced-sxml "<tag xmlns='ns1'/>")) + + (test-equal + `(*TOP* (,(xml 'ns2 'tag))) + (xml->namespaced-sxml "<x:tag xmlns='ns1' xmlns:x='ns2'/>")) + + (test-equal + `(*TOP* (,(xml 'ns2 'tag) + (,(xml 'ns1 'tag)))) + (xml->namespaced-sxml "<x:tag xmlns='ns1' xmlns:x='ns2'><tag/></x:tag>")) + + (test-equal "PI are passed directly" + `(*TOP* ,(make-pi-element 'xml "encoding=\"utf-8\" version=\"1.0\"") + (,(xml 'tag))) + (xml->namespaced-sxml "<?xml encoding=\"utf-8\" version=\"1.0\"?><tag/>")) + + (test-equal "Document with whitespace in it" + `(*TOP* ,(make-pi-element 'xml "") + (,(xml 'root) + " " + (,(xml 'a)) + )) + (xml->namespaced-sxml "<?xml?><root> <a/></root>" + trim-whitespace?: #f)) + + ;; TODO is this expected? xml->sxml discards it. + (test-equal "Whitespace before root is kept" + `(*TOP* ,(make-pi-element 'xml "") + (,(xml 'root))) + (xml->namespaced-sxml "<?xml?> <root/>"))) + + + +;;; NOTE that sxml->namespaced-sxml currently ignores any existing xmlns +;;; attributes, since xml->sxml doesn't have those. +(test-group "sxml->namespaced-sxml" + (test-equal "Simplest" + `(,(xml 'a)) (sxml->namespaced-sxml '(a) '())) + (test-equal "With *TOP*" + `(*TOP* (,(xml 'a))) (sxml->namespaced-sxml '(*TOP* (a)) '())) + (test-equal "Simplest with namespace" + `(,(xml (ns 1) 'a)) + (sxml->namespaced-sxml '(x:a) + `((x . ,(ns 1))))) + (test-equal "With pi" + `(*TOP* ,(make-pi-element 'xml "test") + (,(xml 'a))) + (sxml->namespaced-sxml + `(*TOP* + (*PI* xml "test") + (a)) + '())) + (test-error "With unknown namespace" + 'missing-namespace + (sxml->namespaced-sxml '(x:a) '()))) + + + +(test-group "namespaced-sxml->*" + + ;; /namespaces is the most "primitive" one + (test-group "/namespaces" + (test-group "Without namespaces" + (call-with-values + (lambda () + (namespaced-sxml->sxml/namespaces + `(*TOP* + (,(xml 'a))))) + (lambda (tree namespaces) + (test-equal `(*TOP* (a)) tree) + (test-equal '() namespaces)))) + + (test-group "With namespaces" + (call-with-values + (lambda () + (namespaced-sxml->sxml/namespaces + `(*TOP* + (,(xml (ns 1) 'a) + (,(xml (ns 2) 'a)) + (,(xml 'a)))))) + (lambda (tree nss) + (test-eqv 2 (length nss)) + (test-equal + `(*TOP* + (,(namespaced-symbol (assoc-ref nss (ns 1)) 'a) + (,(namespaced-symbol (assoc-ref nss (ns 2)) 'a)) + (a))) + tree)))) + + (test-group "*PI*" + (call-with-values + (lambda () + (namespaced-sxml->sxml/namespaces + `(*TOP* + ,(make-pi-element 'xml "test") + (,(xml 'a))))) + (lambda (tree namespaces) + (test-equal '() namespaces) + (test-equal `(*TOP* (*PI* xml "test") + (a)) + tree))))) + + (test-group "namespaced-sxml->sxml" + (test-equal "Without namespaces" + '(*TOP* (a (@))) + (namespaced-sxml->sxml `(*TOP* (,(xml 'a))))) + + (test-group "With namespaces" + (match (namespaced-sxml->sxml `(*TOP* (,(xml (ns 1) 'a)))) + ;; (ns 1) hard coded to work with match + (`(*TOP* (,el (@ (,key "http://example.com/1")))) + (let ((el-pair (string-split (symbol->string el) #\:)) + (key-pair (string-split (symbol->string key) #\:))) + (test-equal "a" (cadr el-pair)) + (test-equal "xmlns" (car key-pair)) + (test-equal (car el-pair) (cadr key-pair)))) + (any + (test-assert (format #f "Match failed: ~s" any) #f)))))) + +;; (namespaced-sxml->xml) +;; Literal strings + + +(test-error "Namespaces x is missing, note error" + 'parser-error + (xml->namespaced-sxml "<x:a xmlns:y=\"http://example.com/1\"><x:b/></x:a>" + ; `((x . ,(ns 1))) + )) diff --git a/tests/test/util.scm b/tests/test/util.scm deleted file mode 100644 index 1de96a37..00000000 --- a/tests/test/util.scm +++ /dev/null @@ -1,321 +0,0 @@ -;;; Commentary: -;; Checks some prodecuders from (hnh util) -;;; Code: - -(define-module (test util) - :use-module (srfi srfi-64) - :use-module (srfi srfi-64 test-error) - :use-module (srfi srfi-88) - :use-module (srfi srfi-1) - :use-module (hnh util) - :use-module (hnh util env) - :use-module ((hnh util path) - :select (path-append - path-split - file-hidden? - realpath - filename-extension))) - -(test-equal "when" - 1 (when #t 1)) - -(test-equal "'() when #f" - '() (when #f 1)) - -(test-equal "unless" - 1 (unless #f 1)) - -(test-equal "'() unless #t" - '() (unless #t 1)) - -(test-equal "awhen it" - '(3 4 5) - (awhen (memv 2 '(1 2 3 4 5)) - (cdr it))) - -(test-equal "awhen not" - '() - (awhen (memv 0 '(1 2 3 4 5)) - (cdr it))) - -(test-equal "for simple" - (iota 10) - (for x in (iota 10) - x)) - -(test-equal "for matching" - (iota 12) - (for (x c) in (zip (iota 12) (string->list "Hello, World")) - x)) - -(test-equal "procedure label" - 120 - ((label factorial (lambda (n) - (if (zero? n) - 1 (* n (factorial (1- n)))))) - 5)) - -;; we can't test if sort*! destroys the list, since its only /allowed/ to do it, -;; not required. -(test-equal "sort*!" - '("a" "Hello" "Assparagus") - (sort*! '("Hello" "a" "Assparagus") - < string-length)) - -(test-assert "not equal" - (!= 1 2)) - -(test-equal "Take to" - '() (take-to '() 5)) - -(test-equal "Enumerate" - '((0 #\H) (1 #\e) (2 #\l) (3 #\l) (4 #\o) (5 #\,) (6 #\space) (7 #\W) (8 #\o) (9 #\r) (10 #\l) (11 #\d) (12 #\!)) - (enumerate (string->list "Hello, World!"))) - -(test-equal "unval first" - 1 - ((unval (lambda () (values 1 2 3))))) - -(test-equal "unval other" - 2 - ((unval car+cdr 1) - (cons 1 2))) - -(test-equal "flatten already flat" - (iota 10) - (flatten (iota 10))) - -(test-equal "flatten really deep" - '(1) - (flatten '(((((((((((((((1))))))))))))))))) - -(test-equal "flatten mixed" - '(1 2 3 4 5) - (flatten '((((((1(((((2((((3))))))4))))))))5))) - -;; TODO test let-lazy - -(test-equal "map/dotted without dot" - '(1 2 3 4) - (map/dotted 1+ '(0 1 2 3))) - -(test-equal "map/dotted with dot" - '(1 2 3 . 4) - (map/dotted 1+ '(0 1 2 . 3))) - -(test-equal "map/dotted direct value" - 1 (map/dotted 1+ 0)) - -(test-equal "assq merge" - '((k 2 1) (v 2)) - (assq-merge '((k 1) (v 2)) '((k 2)))) - -(test-equal "kvlist->assq" - '((a 1) (b 2)) - (kvlist->assq '(a: 1 b: 2))) - - -(test-equal "kvlist->assq repeated key" - '((a 1) (b 2) (a 3)) - (kvlist->assq '(a: 1 b: 2 a: 3))) - -;; TODO assq-limit ? - -(test-equal "->" 9 (-> 1 (+ 2) (* 3))) -(test-equal "-> order dependant" -1 (-> 1 (- 2))) -(test-equal "->> order dependant" 1 (->> 1 (- 2))) - -;; TODO set and set-> - -;; TODO and=>> - -(test-equal "Group" - '((0 1) (2 3) (4 5) (6 7) (8 9)) - (group (iota 10) 2)) - -;; TODO test failure when grouping isn't possible? - -(test-equal "assoc-ref-all" '(1 3) (assoc-ref-all '((a . 1) (b . 2) (a . 3)) 'a)) -(test-equal "assq-ref-all" '(1 3) (assq-ref-all '((a . 1) (b . 2) (a . 3)) 'a)) -(test-equal "assv-ref-all "'(1 3) (assv-ref-all '((a . 1) (b . 2) (a . 3)) 'a)) - -(test-equal "vector-last" - 1 (vector-last #(0 2 3 1))) - -;; TODO test catch* - -(test-equal - "Filter sorted" - '(3 4 5) - (filter-sorted (lambda (x) (<= 3 x 5)) (iota 10))) - -(test-equal - "set/r! = single" - #f - (let ((x #t)) (set/r! x = not))) - -(test-error - 'syntax-error - (test-read-eval-string "(set/r! x err not)")) - -(call-with-values - (lambda () (find-min (iota 10))) - (lambda (extreme rest) - (test-equal "Found correct minimum" 0 extreme) - (test-equal - "Removed \"something\" from the set" - 9 - (length rest)))) - -(call-with-values - (lambda () - (find-max - '("Hello" "Test" "Something long") - string-length)) - (lambda (extreme rest) - (test-equal - "Found the longest string" - "Something long" - extreme) - (test-equal "Removed the string" 2 (length rest)) - (test-assert - "Other members left 1" - (member "Hello" rest)) - (test-assert - "Other members left 2" - (member "Test" rest)))) - -(test-error 'wrong-type-arg (find-extreme '())) - -(call-with-values - (lambda () - (span-upto - 2 - char-numeric? - (string->list "123456"))) - (lambda (head tail) - (test-equal '(#\1 #\2) head) - (test-equal '(#\3 #\4 #\5 #\6) tail))) - -(call-with-values - (lambda () - (span-upto - 2 - char-numeric? - (string->list "H123456"))) - (lambda (head tail) - (test-equal '() head) - (test-equal '(#\H #\1 #\2 #\3 #\4 #\5 #\6) tail))) - -(let ((value #f)) - (test-equal - "begin1 return value" - "Hello" - (begin1 "Hello" (set! value "World"))) - (test-equal "begin1 side effects" "World" value)) - -(let ((x 1)) - (test-eqv "begin1 set! after return" - 1 (begin1 x (set! x 10))) - (test-eqv "Updates value" - 10 x)) - -(test-equal 0 (iterate 1- zero? 10)) - -(test-equal "5" (->string 5)) - -(test-equal "5" (->string "5")) - -(test-equal - "no slashes" - "home/user" - (path-append "home" "user")) - -(test-equal - "no slashes, absolute" - "/home/user" - (path-append "" "home" "user")) - -(test-equal - "slashes in one component, absolute" - "/home/user" - (path-append "" "/home/" "user")) - -(test-equal - "slashes in one component, absolute due to first" - "/home/user" - (path-append "/home/" "user")) - -(test-equal - "Slashes in both" - "home/user" - (path-append "home/" "/user")) - -(test-equal "root" "/" (path-append "")) - -(test-equal - '("usr" "lib" "test") - (path-split "usr/lib/test")) - -(test-equal - '("usr" "lib" "test") - (path-split "usr/lib/test/")) - -(test-equal - '("" "usr" "lib" "test") - (path-split "/usr/lib/test")) - -(test-equal - '("" "usr" "lib" "test") - (path-split "//usr////lib/test")) - -(test-assert (file-hidden? ".just-filename")) -(test-assert (file-hidden? "/path/to/.hidden")) -(test-assert (not (file-hidden? "/visible/.in/hidden"))) -(test-assert (not (file-hidden? ""))) - -;; TODO test realpath with .. and similar - -(test-equal "Realpath for path fragment" - "/home/hugo" - (with-working-directory - "/home" - (lambda () (realpath "hugo")))) - -(test-equal "Realpath for already absolute path" - "/home/hugo" - (with-working-directory - "/tmp" - (lambda () (realpath "/home/hugo")))) - -(test-equal "Realpath for already absolute path" - "/home/hugo" - (with-working-directory - "/tmp" - (lambda () (realpath "/home/hugo")))) - - -(test-equal "Extension of simple file" - "txt" (filename-extension "file.txt")) - -(test-equal "Extension of file with directory" - "txt" (filename-extension "/direcotry/file.txt")) - -(test-equal "Extension of file with multiple" - "gz" (filename-extension "filename.tar.gz")) - -(test-equal "Filename extension when none is present" - "" (filename-extension "filename")) - -(test-equal "Filename extension when none is present, but directory has" - "" (filename-extension "config.d/filename")) - -(test-equal "Filename extension of directory" - "d" (filename-extension "config.d/")) - - -(test-equal "Extension of hidden file" - "sh" (filename-extension ".bashrc.sh")) - -(test-equal "Extension of hidden file without extension" - "bashrc" (filename-extension ".bashrc")) diff --git a/tests/test/uuid.scm b/tests/test/uuid.scm index 6a2bd92a..b73db5f4 100644 --- a/tests/test/uuid.scm +++ b/tests/test/uuid.scm @@ -4,9 +4,15 @@ :use-module (srfi srfi-88) :use-module (hnh util uuid)) -(set! (@@ (hnh util uuid) %seed) - (seed->random-state 0)) (test-equal "UUIDv4 fixed seed" - "d19c9347-9a85-4432-a876-5fb9c0d24d2b" - (uuid-v4)) + (let ((version (version))) + (cond ((string=? version "2.2.7") + "d19c9347-9a85-4432-a876-5fb9c0d24d2b") + ((string=? version "3.0.9") + "d19c9347-9a85-4432-a876-5fb9c0d24d2b") + (else + "Randomness isn't stable between guile versions"))) + (begin + (parameterize ((seed (seed->random-state 0))) + (uuid-v4)))) diff --git a/tests/test/vcomponent-control.scm b/tests/test/vcomponent-control.scm index f408c8b4..6ab38996 100644 --- a/tests/test/vcomponent-control.scm +++ b/tests/test/vcomponent-control.scm @@ -5,32 +5,32 @@ (define-module (test vcomponent-control) :use-module (srfi srfi-64) :use-module (srfi srfi-88) + :use-module ((vcomponent create)) :use-module ((vcomponent util control) :select (with-replaced-properties)) :use-module ((vcomponent formats ical parse) :select (parse-calendar)) :use-module ((vcomponent base) :select (prop))) -(define ev - (call-with-input-string - "BEGIN:DUMMY\nX-KEY:value\nEND:DUMMY" - parse-calendar)) +(define ev (vcomponent 'DUMMY x-key: "value")) -;; Test that temoraries are set and restored -(test-equal "value" (prop ev 'X-KEY)) +(test-group "With replaced properties" + ;; Test that temoraries are set and restored + (test-equal "value" (prop ev 'X-KEY)) -(with-replaced-properties - (ev (X-KEY "other")) - (test-equal "other" (prop ev 'X-KEY))) + (with-replaced-properties + (ev (X-KEY "other")) + (test-equal "other" (prop ev 'X-KEY))) -(test-equal "value" (prop ev 'X-KEY)) + (test-equal "value" (prop ev 'X-KEY))) ;; Test that they are restored on non-local exit -(catch #t - (lambda () - (with-replaced-properties - (ev (X-KEY "other")) - (throw 'any))) - (lambda _ (test-equal "value" (prop ev 'X-KEY)))) +(test-group "With replaced properties when throwing" + (catch #t + (lambda () + (with-replaced-properties + (ev (X-KEY "other")) + (throw 'any))) + (lambda _ (test-equal "value" (prop ev 'X-KEY))))) diff --git a/tests/test/vcomponent-datetime.scm b/tests/test/vcomponent-datetime.scm index 073a70ae..49d1711f 100644 --- a/tests/test/vcomponent-datetime.scm +++ b/tests/test/vcomponent-datetime.scm @@ -8,15 +8,12 @@ :use-module (srfi srfi-88) :use-module ((datetime) :select (date time datetime)) :use-module ((vcomponent datetime) :select (event-length/clamped)) - :use-module ((vcomponent formats ical parse) :select (parse-calendar))) + :use-module ((vcomponent create) :select (vevent))) (define ev - (call-with-input-string - "BEGIN:VEVENT -DTSTART:20200329T170000 -DTEND:20200401T100000 -END:VEVENT" - parse-calendar)) + (vevent + dtstart: #2020-03-29T17:00:00 + dtend: #2020-04-01T10:00:00)) ;; |-----------------| test interval @@ -31,12 +28,9 @@ END:VEVENT" ev)) (define utc-ev - (call-with-input-string - "BEGIN:VEVENT -DTSTART:20200329T150000Z -DTEND:20200401T080000Z -END:VEVENT" - parse-calendar)) + (vevent + dtstart: #2020-03-29T15:00:00Z + dtend: #2020-04-01T08:00:00Z)) (test-equal "Correct clamping UTC" diff --git a/tests/test/vcomponent.scm b/tests/test/vcomponent.scm index 68715462..a6989776 100644 --- a/tests/test/vcomponent.scm +++ b/tests/test/vcomponent.scm @@ -3,18 +3,18 @@ ;;; Code: (define-module (test vcomponent) + :use-module (srfi srfi-17) :use-module (srfi srfi-64) :use-module (srfi srfi-88) :use-module ((vcomponent base) - :select (prop make-vcomponent add-child! remove-child! - children)) - :use-module ((vcomponent formats ical parse) - :select (parse-calendar))) + :select (prop make-vcomponent reparent! abandon! + copy-vcomponent + type parent children))) (define ev - (call-with-input-string - "BEGIN:DUMMY\nX-KEY:value\nEND:DUMMY" - parse-calendar)) + (let ((ev (make-vcomponent 'DUMMY))) + (set! (prop ev 'X-KEY) "value") + ev)) (test-assert (eq? #f (prop ev 'MISSING))) @@ -24,7 +24,29 @@ (define calendar (make-vcomponent 'VCALENDAR)) -(add-child! calendar ev) +(reparent! calendar ev) (test-equal 1 (length (children calendar))) -(remove-child! calendar ev) +(abandon! calendar ev) (test-equal 0 (length (children calendar))) + + +(test-group "Copy VComponent" + (let ((ev1 (make-vcomponent 'A)) + (ev2 (make-vcomponent 'B)) + (ev3 (make-vcomponent 'C))) + (set! (prop ev3 'TEST) (list 1 2 3)) + (reparent! ev1 ev2) + (reparent! ev2 ev3) + (let* ((ev2* (copy-vcomponent ev2)) + (ev3* (car (children ev2*)))) + ;; NOTE replace this with `vcomponent=?' if that gets written + (test-group "New object is equivalent to old one" + (test-equal (type ev2) (type ev2*)) + (test-equal (length (children ev2)) (length (children ev2*)))) + (test-eq ev1 (parent ev2)) + + (set! (car (prop ev3* 'TEST)) 10) + (test-equal "Property values aren't deep copied" + '(10 2 3) (prop ev3 'TEST)) + (test-equal '(10 2 3) (prop ev3* 'TEST)) + ))) diff --git a/tests/test/webdav-file.scm b/tests/test/webdav-file.scm new file mode 100644 index 00000000..4096016b --- /dev/null +++ b/tests/test/webdav-file.scm @@ -0,0 +1,53 @@ +(define-module (test webdav-file) + :use-module (srfi srfi-64) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (hnh util) + :use-module (hnh util path) + :use-module (ice-9 ftw) + :use-module (ice-9 rdelim) + :use-module (oop goops) + :use-module (calp webdav resource) + :use-module (calp webdav resource file) + ) + +;;; Commentary: +;;; Tests the specifics of the file backed webdav resource objects. +;;; Code: + + +;;; TODO general helper procedure for this +(define test-root (mkdtemp (string-copy "/tmp/calp-test-XXXXXX"))) + +(define root-resource (make <file-resource> + root: test-root)) + + +(test-group "File resource collection" + (add-collection! root-resource "subdir") + (test-eqv "Collection correctly added" + 'directory (-> (path-append test-root "subdir") + stat stat:type) )) + + + +;;; TODO this fails, sice <file-resource> doesn't override add-resource! +;;; <file-resources>'s add resource must at least update root path path of the +;;; child resource, and possibly also touch the file (so ctime gets set). +(test-group "File resource with content" + (let ((fname "file.txt") + (s "Hello, World!\n")) + (add-resource! root-resource fname s) + (let ((p (path-append test-root fname))) + (test-eqv "File correctly added" + 'regular (-> p stat stat:type)) + (test-equal "Expected content was written" + s + (with-input-from-file p + (lambda () (read-delimited ""))) + )))) + + + +(test-group "Copy file" + 'TODO) diff --git a/tests/test/webdav-server.scm b/tests/test/webdav-server.scm new file mode 100644 index 00000000..67747de7 --- /dev/null +++ b/tests/test/webdav-server.scm @@ -0,0 +1,351 @@ +(define-module (test webdav-server) + ;; :use-module (srfi srfi-1) + ;; :use-module (ice-9 threads) + + :use-module (srfi srfi-64) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (calp server webdav) + :use-module (calp webdav resource) + :use-module ((calp webdav property) :select (propstat)) + :use-module (calp webdav resource virtual) + :use-module (calp namespaces) + :use-module (oop goops) + :use-module (web request) + :use-module (web response) + :use-module (web uri) + :use-module (sxml simple) + :use-module (sxml xpath) + :use-module (sxml namespaced) + :use-module (hnh util) + ) + +;;; Commentary: +;;; Tests that handlers for all HTTP Methods works correctly. +;;; Note that these tests don't have as goal to check that resources and +;;; properties work correctly. See (test webdav) and (test webdav-tree) for that. +;;; +;;; The namespaces http://ns.example.com/properties is intentionally given +;;; different prefixes everywhere, to ensure that namespaces are handled correctly. +;;; Code: + +(define prop-ns (string->symbol "http://ns.example.com/properties")) + +(root-resource (make <virtual-resource> name: "*root*")) +(add-resource! (root-resource) "a" "Contents of A") +(add-resource! (root-resource) "b" "Contents of B") + +;;; Connect output of one procedure to input of another +;;; Both producer and consumer should take exactly one port as argument +(define (connect producer consumer) + ;; (let ((in out (car+cdr (pipe)))) + ;; (let ((thread (begin-thread (consumer in)))) + ;; (producer out) + ;; (join-thread thread))) + + (call-with-input-string + (call-with-output-string producer) + consumer)) + +(define (xml->sxml* port) + (xml->sxml port namespaces: `((d . ,(symbol->string webdav)) + (y . ,(symbol->string prop-ns))))) + + + +(test-group "run-propfind" + (test-group "Working, depth 0" + (let* ((request (build-request + (string->uri "http://localhost/") + method: 'PROPFIND + headers: '((depth . 0)) + validate-headers?: #f)) + (head body (run-propfind '() request #f))) + (test-equal 207 (response-code head)) + (test-equal '(application/xml) + (response-content-type head)) + (test-assert (procedure? body)) + (let ((body* (connect body xml->sxml*))) + ;; Arbitrarily chosen resource + (test-equal "Resource gets returned as expected" + '((d:resourcetype (d:collection))) + ((sxpath '(// d:response + (d:propstat (// d:status (equal? "HTTP/1.1 200 OK"))) + // d:resourcetype)) + body*))))) + + (test-group "Depth: infinity" + (let* ((request (build-request + (string->uri "http://localhost/") + method: 'PROPFIND + headers: '((depth . infinity)) + validate-headers?: #f)) + (head body (run-propfind '() request #f))) + (test-equal 207 (response-code head)) + (test-equal '(application/xml) (response-content-type head)) + (test-assert (procedure? body)) + (let ((body* (connect body xml->sxml*))) + (test-equal + '("/" "/a" "/b") + (sort* ((sxpath '(// d:href *text*)) body*) + string<))))) + + (test-group "With body" + (let ((request (build-request (string->uri "http://localhost/") + method: 'PROPFIND + headers: '((depth . 0)) + validate-headers?: #f)) + (request-body "<?xml version=\"1.0\" encoding=\"utf-8\"?> +<propfind xmlns=\"DAV:\"> + <prop><resourcetype/></prop> +</propfind>")) + (let ((head body (run-propfind '() request request-body))) + (test-equal 207 (response-code head)) + (test-equal '(application/xml) (response-content-type head)) + (test-assert (procedure? body)) + (let ((body* (connect body xml->sxml*))) + (test-equal "We only get what we ask for" + '((d:prop (d:resourcetype (d:collection)))) + ((sxpath '(// d:response + (d:propstat (// d:status (equal? "HTTP/1.1 200 OK"))) + // d:prop)) + body*))))))) + + + +(test-group "run-proppatch" + (let ((request (build-request (string->uri "http://localhost/a") + method: 'PROPPATCH)) + (request-body (format #f "<?xml version=\"1.0\" encoding=\"utf-8\"?> +<propertyupdate xmlns=\"DAV:\" xmlns:x=\"~a\"> + <set> + <prop> + <displayname>New Displayname</displayname> + <x:test><x:content/></x:test> + </prop> + </set> + <!-- TODO test remove? --> +</propertyupdate>" prop-ns))) + (let ((response body (run-proppatch '("a") request request-body))) + (test-equal 207 (response-code response)) + (test-equal '(application/xml) (response-content-type response)) + (test-assert (procedure? body)) + ;; Commit the changes + (call-with-output-string body) + )) + + (let ((response body (run-propfind + '("a") + (build-request (string->uri "http://localhost/a") + method: 'PROPFIND + headers: '((depth . 0)) + validate-headers?: #f) + (format #f "<?xml version=\"1.0\" encoding=\"utf-8\"?> +<propfind xmlns=\"DAV:\" xmlns:z=\"~a\"> + <prop> + <displayname/> + <z:test/> + </prop> +</propfind>" prop-ns)))) + (test-equal 207 (response-code response)) + (test-equal '(application/xml) (response-content-type response)) + (test-assert (procedure? body)) + + ;; (format (current-error-port) "Here~%") + ;; ;; The crash is after here + ;; (body (current-error-port)) + + (let* ((body* (connect body xml->sxml*)) + (properties ((sxpath '(// d:response + (d:propstat (// d:status (equal? "HTTP/1.1 200 OK"))))) + body*))) + ;; ((@ (ice-9 format) format) (current-error-port) "Properties: ~y~%" properties) + (test-equal "Native active property is properly updated" + '("New Displayname") + ((sxpath '(// d:displayname *text*)) properties)) + (test-equal "Custom property is correctly stored and preserved" + '((y:test (y:content))) + ((sxpath '(// y:test)) properties)))) + + ;; TODO test proppatch atomicity + ) + + + +(test-group "run-options" + (let ((head body (run-options #f #f))) + (test-equal "options head" + (build-response + code: 200 + headers: `((dav . (1)) + (allow . (GET HEAD PUT MKCOL PROPFIND OPTIONS DELETE COPY MOVE)))) + head) + (test-equal "options body" + "" body))) + + + +(test-group "run-get" + (let ((head body (run-get '("a") + (build-request + (string->uri "http://localhost/a") + method: 'GET) + 'GET))) + (test-equal "Contents of A" body))) + + + +(test-group "run-put" + (test-group "Update existing resource" + (run-put '("a") + (build-request (string->uri "http://localhost/a") + method: 'PUT + port: (open-output-string)) + "New Contents of A") + + (let ((head body (run-get '("a") + (build-request + (string->uri "http://localhost/a") + method: 'GET) + 'GET))) + (test-equal "Put updates subsequent gets" + "New Contents of A" body))) + + (test-group "Create new resource" + (run-put '("c") + (build-request (string->uri "http://localhost/c") + method: 'PUT + port: (open-output-string)) + "Created Resource C") + (let ((head body (run-get '("c") + (build-request + (string->uri "http://localhost/c") + method: 'GET) + 'GET))) + (test-equal "Put creates new resources" + "Created Resource C" body)))) + + + +;;; Run DELETE +(test-group "run-delete" + 'TODO) + + + + +(test-group "run-mkcol" + (run-mkcol '("a" "b") + (build-request (string->uri "http://localhost/a/b") + method: 'MKCOL) + "") + (let* ((request (build-request + (string->uri "http://localhost/") + method: 'PROPFIND + headers: '((depth . infinity)) + validate-headers?: #f)) + (head body (run-propfind '() request #f))) + (test-equal 207 (response-code head)) + (test-equal '(application/xml) (response-content-type head)) + (test-assert (procedure? body)) + (let ((body* (connect body xml->sxml*))) + (test-equal "Check that all created resources now exists" + '("/" "/a" "/a/b" "/b" "/c") + (sort* ((sxpath '(// d:href *text*)) body*) + string<))))) + + +;;; TODO test MKCOL indempotence + + + +;;; Run COPY +(test-group "run-copy" + (parameterize ((root-resource (make <virtual-resource> name: "*root*"))) + (add-resource! (root-resource) "a" "Content of A") + (let ((a (lookup-resource (root-resource) '("a")))) + (set-property! a `(,(xml prop-ns 'test) "prop-value")) + ;; Extra child added to ensure deep copy works + (add-resource! a "d" "Content of d")) + + (test-group "cp /a /c" + (let ((response _ + (run-copy '("a") + (build-request + (string->uri "http://example.com/a") + headers: `((destination + . ,(string->uri "http://example.com/c"))))))) + ;; Created + (test-eqv "Resource was reported created" + 201 (response-code response))) + + (let ((c (lookup-resource (root-resource) '("c")))) + (test-assert "New resource present in tree" c) + (test-equal "Content was correctly copied" + "Content of A" (content c)) + (test-equal "Property was correctly copied" + (propstat 200 + (list `(,(xml prop-ns 'test) + "prop-value"))) + (get-property c (xml prop-ns 'test))))) + + (test-group "cp --no-clobber /c /a" + (let ((response _ + (run-copy '("c") + (build-request + (string->uri "http://example.com/c") + headers: `((destination + . ,(string->uri "http://example.com/a")) + (overwrite . #f)))))) + ;; collision + (test-eqv "Resource collision was reported" + 412 (response-code response)))) + + ;; Copy recursive collection, and onto child of self. + (test-group "cp -r / /c" + (let ((response _ + (run-copy '() + (build-request + (string->uri "http://example.com/") + headers: `((destination . ,(string->uri "http://example.com/c"))))))) + (test-eqv "Check that reported replaced" + 204 (response-code response)) + (test-equal "Check that recursive resources where created" + '("/" "/a" "/a/d" "/c" + ;; New resources. Note that /c/c doesn't create an infinite loop + "/c/a" "/c/a/d" "/c/c") + (map car + (sort* (map (lambda (p) (cons (href->string (car p)) (cdr p))) + (all-resources-under (root-resource) '())) + string< car))) + + ;; TODO we should also check that /c is a copy of the root resource, + ;; instead of the old /c resource. + ;; Do this by setting some properties + )))) + + + +;;; Run MOVE +(test-group "run-move" + (parameterize ((root-resource (make <virtual-resource> name: "*root*"))) + (add-resource! (root-resource) "a" "Content of A") + (let ((a (lookup-resource (root-resource) '("a")))) + (set-property! a `(,(xml prop-ns 'test) "prop-value"))) + + (test-group "mv /a /c" + (let ((response _ + (run-move '("a") + (build-request + (string->uri "http://example.com/a") + headers: `((destination + . ,(string->uri "http://example.com/c"))))))) + ;; Created + (test-eqv "Resource was reported created" + 201 (response-code response)) + ;; TODO check that old resource is gone + )))) + + + +;;; Run REPORT diff --git a/tests/test/webdav-tree.scm b/tests/test/webdav-tree.scm new file mode 100644 index 00000000..5c2a6a9b --- /dev/null +++ b/tests/test/webdav-tree.scm @@ -0,0 +1,89 @@ +(define-module (test webdav-tree) + :use-module (srfi srfi-64) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (calp webdav resource) + :use-module (calp webdav resource virtual) + :use-module (calp webdav resource file) + :use-module (oop goops) + :use-module (rnrs bytevectors) + :use-module (rnrs io ports) + :use-module ((hnh util) :select (sort*)) + :use-module (hnh util path) + ) + +(define* (pretty-print-tree tree + optional: (formatter (lambda (el) (write el) (newline))) + key: (depth 0)) + (cond ((null? tree) 'noop) + ((pair? tree) + (display (make-string (* depth 2) #\space)) (formatter (car tree)) + (for-each (lambda (el) (pretty-print-tree el formatter depth: (+ depth 1))) + (cdr tree))) + (else (formatter tree)))) + +(define-method (resource-tree (self <resource>)) + (cons self + (map resource-tree (children self)))) + + + +(define dir (mkdtemp (string-copy "/tmp/webdav-tree-XXXXXX"))) +(with-output-to-file (path-append dir "greeting") + (lambda () (display "Hello, World!\n"))) + +(define root-resource (make <virtual-resource> + name: "*root*")) + +(define virtual-resource (make <virtual-resource> + name: "virtual" + content: (string->bytevector "I'm Virtual!" (native-transcoder)))) + +(define file-tree (make <file-resource> + root: dir + name: "files")) + +(mount-resource! root-resource file-tree) +(mount-resource! root-resource virtual-resource) + +(test-equal "All resources in tree, along with href items" + (list (cons '() root-resource) + (cons '("files") file-tree) + (cons '("files" "greeting") (car (children file-tree))) + (cons '("virtual") virtual-resource)) + (sort* (all-resources-under root-resource) string< (compose string-concatenate car))) + + + +;; (pretty-print-tree (resource-tree root-resource)) + + + +;; (test-equal '("") (href root-resource) ) ; / +;; ;; (test-equal '("" "virtual") (href virtual-resource)) ; /virtual & /virtual/ +;; (test-equal '("virtual") (href virtual-resource)) ; /virtual & /virtual/ +;; ;; (test-equal '("" "files") (href file-tree)) ; /files & /files/ +;; (test-equal '("files") (href file-tree)) ; /files & /files/ + +(test-eqv "Correct amount of children are mounted" + 2 (length (children root-resource))) + +(test-eq "Lookup root" + root-resource (lookup-resource root-resource '())) + +(test-eq "Lookup of mount works (virtual)" + virtual-resource (lookup-resource root-resource '("virtual"))) +(test-eq "Lookup of mount works (files)" + file-tree (lookup-resource root-resource '("files"))) + +;; (test-equal "File resource works as expected" +;; "/home/hugo/tmp" +;; (path file-tree)) + +(let ((resource (lookup-resource root-resource (string->href "/files/greeting")))) + (test-assert (resource? resource)) + (test-assert (file-resource? resource)) + ;; (test-equal "/files/greeting" (href->string (href resource))) + (test-equal "Hello, World!\n" (bytevector->string (content resource) (native-transcoder))) + ) + diff --git a/tests/test/webdav-util.scm b/tests/test/webdav-util.scm new file mode 100644 index 00000000..5c89cf6c --- /dev/null +++ b/tests/test/webdav-util.scm @@ -0,0 +1,29 @@ +(define-module (test webdav-util) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (calp webdav resource base)) + +(test-group "string->href" + (test-equal "Root path becomes null" + '() (string->href "/")) + (test-equal "Trailing slashes are ignored" + '("a" "b") (string->href "/a/b/"))) + +(test-group "href->string" + (test-equal "Null case becomes root path" + "/" (href->string '())) + (test-equal "Trailing slashes are not added" + "/a/b" (href->string '("a" "b")))) + +(test-group "href-relative" + (test-equal '("a" "b") (href-relative '() '("a" "b"))) + (test-equal '("b") (href-relative '("a") '("a" "b"))) + (test-equal '() (href-relative '("a" "b") '("a" "b"))) + + (test-error 'misc-error + (href-relative '("c") '("a" "b"))) + + (test-error 'misc-error + (href-relative '("c") '()))) diff --git a/tests/test/webdav.scm b/tests/test/webdav.scm new file mode 100644 index 00000000..0962a89e --- /dev/null +++ b/tests/test/webdav.scm @@ -0,0 +1,353 @@ +(define-module (test webdav) + :use-module (srfi srfi-64) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (srfi srfi-1) + :use-module (sxml namespaced) + :use-module (oop goops) + :use-module (calp namespaces) + :use-module ((hnh util) :select (sort*)) + :use-module (datetime) + + :use-module (calp webdav property) + :use-module (calp webdav propfind) + :use-module (calp webdav resource) + :use-module (calp webdav resource virtual) + ) + +;;; NOTE these tests don't check that XML namespaces work correctly, but only as +;;; far as not checking that the correct namespace is choosen. They should fail if +;;; namespacing gets completely broken. + +;;; TODO tests for a missing resource? + +(define (swap p) (xcons (car p) (cdr p))) + +(define dt #2010-11-12T13:14:15) + +(define resource (make <virtual-resource> + ;; local-path: '("") + name: "*root" + content: #vu8(1 2 3 4) + creation-time: dt)) + +(define (sort-propstats propstats) + (map + (lambda (propstat) + (make-propstat (propstat-status-code propstat) + (sort* (propstat-property propstat) + string< (compose symbol->string xml-element-tagname car)) + (propstat-error propstat) + (propstat-response-description propstat))) + (sort* propstats < propstat-status-code)) + ) + +;; (test-equal "/" (href->string (href resource))) +(test-equal "Basic propstat" + (propstat 200 (list (list (xml webdav 'getcontentlength) 4))) + (getcontentlength resource)) + + +(define (sort-symbols symbs) + (sort* symbs string<=? symbol->string)) + + + +;;; NOTE propstat's return order isn't stable, making this test possibly fail +(let ((ps (list (propstat 200 (list `(,(xml webdav 'displayname) "Displayname"))) + (propstat 200 (list `(,(xml webdav 'getcontenttype) "text/plain")))))) + (test-equal "Propstat merger" + (list (propstat 200 + (list (list (xml webdav 'getcontenttype) "text/plain") + (list (xml webdav 'displayname) "Displayname")))) + (merge-propstats ps))) + + + +(test-group "All live properties" + (let ((props (live-properties resource))) + (test-assert (list? props)) + (for-each (lambda (pair) + ;; (test-assert (xml-element? (car pair))) + (test-assert (live-property? (cdr pair))) + (test-assert (procedure? (property-getter (cdr pair)))) + (test-assert (procedure? (property-setter-generator (cdr pair))))) + props))) + +(test-group "\"All\" live properties" + (let ((most (propfind-most-live-properties resource))) + (test-equal "Correct amount of keys" 10 (length most)) + (for-each (lambda (propstat) + (test-assert "Propstat is propstat" (propstat? propstat)) + (test-equal (format #f "Propstat well formed: ~a" (propstat-property propstat)) + 1 (length (propstat-property propstat))) + (test-assert "Propstat child is xml" + (xml-element? (caar (propstat-property propstat))))) + most) + + (test-equal "Correct keys" + '(creationdate displayname getcontentlanguage getcontentlength + getcontenttype getetag getlastmodified + lockdiscovery resourcetype supportedlock) + (sort-symbols (map (compose xml-element-tagname caar propstat-property) most))))) + + + +(define ns1 (string->symbol "http://example.com/namespace")) + +(set-dead-property! resource `(,(xml ns1 'test) "Content")) + +(test-equal "Get dead property" + (propstat 200 (list (list (xml ns1 'test) "Content"))) + (get-dead-property resource (xml ns1 'test))) + +(test-equal "Get live property" + (propstat 404 (list (list (xml ns1 'test)))) + (get-live-property resource (xml ns1 'test))) + +(test-group "Dead properties" + (test-equal "Existing property" + (propstat 200 (list (list (xml ns1 'test) "Content"))) + (get-property resource (xml ns1 'test))) + + (test-equal "Missing property" + (propstat 404 (list (list (xml ns1 'test2)))) + (get-property resource (xml ns1 'test2))) + + (test-equal "All dead properties" + (list (propstat 200 (list (list (xml ns1 'test) "Content")))) + (propfind-all-dead-properties resource))) + +(test-group "Live Properties" + + ;; TODO these tests were written when displayname always returned 200, but have since changed to test for 404. + ;; Change to another property which return 200 + (test-equal "Existing live property (through get-live-property)" + (propstat 404 `((,(xml webdav 'displayname)))) + (get-live-property resource (xml webdav 'displayname))) + + (test-equal "Existing live property (thrtough get-property)" + (propstat 404 `((,(xml webdav 'displayname)))) + (get-property resource (xml webdav 'displayname))) + ) + +(test-equal "propfind-selected-properties" + (list (propstat 404 `((,(xml webdav 'displayname))))) + (propfind-selected-properties resource (list (xml webdav 'displayname)))) + +(test-group "parse-propfind" + (test-group "propname" + (let ((props (parse-propfind `(,(xml webdav 'propfind) + (,(xml webdav 'propname))) + resource))) + + + (test-group "Propfind should NEVER fail for an existing resource" + (test-equal 1 (length props)) + (test-equal 200 (propstat-status-code (car props)))) + + (test-assert "Propstat objects are returned" (propstat? (car props))) + (for-each (lambda (el) + (test-assert "Base is list" (list? el)) + (test-eqv "List only contains head el" 1 (length el)) + #; + (test-assert (format #f "Head is an xml tag: ~a" el) + (xml-element? (car el)))) + (propstat-property (car props))) + + #; + (test-equal "Correct property keys" + (sort-symbols (cons* 'test 'is-virtual webdav-keys)) + (sort-symbols (map (compose xml-element-tagname car) + (propstat-property (car props))))) + + (test-group "No property should contain any data" + (for-each (lambda (el) + (test-eqv (format #f "Propname property: ~s" el) + 1 (length el))) + (propstat-property (car props)))))) + + + (test-group "direct property list" + (let ((props (parse-propfind `((xml webdav 'propfind) + (,(xml webdav 'prop) + (,(xml webdav 'displayname)))) + resource))) + (test-equal "Simple lookup" + (list (propstat 404 (list (list (xml webdav 'displayname) + )))) + props))) + + ;; TODO test that calendar properties are reported by propname + ;; TODO test that non-native caldav propreties aren't reported by allprop + + (test-group "allprop" + (let ((props (parse-propfind `(,(xml webdav 'propfind) + (,(xml webdav 'allprop))) + resource))) + + + (test-equal "Propfind result" + (list + (propstat 200 + (list (list (xml webdav 'creationdate) + (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) + (list (xml webdav 'getcontentlength) + 4) + (list (xml webdav 'getcontenttype) + "application/binary") + (list (xml webdav 'getlastmodified) + "Thu, 01 Jan 1970 00:00:00 GMT") + (list (xml webdav 'lockdiscovery) '()) + (list (xml webdav 'resourcetype) + ; (list (xml webdav 'collection)) + ) + (list (xml webdav 'supportedlock) '()) + (list (xml ns1 'test) "Content") + )) + (propstat 404 (list (list (xml webdav 'displayname)) + (list (xml webdav 'getcontentlanguage)))) + (propstat 501 + (list (list (xml webdav 'getetag)) + ))) + (sort-propstats props)))) + + + (test-group "allprop with include" + (let ((props (parse-propfind `((xml webdav 'propfind) + (,(xml webdav 'allprop)) + (,(xml webdav 'include))) + resource))) + + + (test-equal "Include NOTHING" + (list + (propstat 200 + (list (list (xml webdav 'creationdate) + (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) + (list (xml webdav 'getcontentlength) + 4) + (list (xml webdav 'getcontenttype) + "application/binary") + (list (xml webdav 'getlastmodified) + "Thu, 01 Jan 1970 00:00:00 GMT") + (list (xml webdav 'lockdiscovery) '()) + (list (xml webdav 'resourcetype) + ; (list (xml webdav 'collection)) + ) + (list (xml webdav 'supportedlock) '()) + (list (xml ns1 'test) "Content") + )) + (propstat 404 (list (list (xml webdav 'displayname)) + (list (xml webdav 'getcontentlanguage)))) + (propstat 501 + (list (list (xml webdav 'getetag)) + ))) + (sort-propstats props))) + + + (let ((props (parse-propfind `(,(xml webdav 'propfind) + (,(xml webdav 'allprop)) + (,(xml webdav 'include) + (,(xml virtual-ns 'isvirtual)))) + resource))) + + (test-equal "Include isvirtual" + (list + (propstat 200 + (list (list (xml webdav 'creationdate) (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) + (list (xml webdav 'getcontentlength) 4) + (list (xml webdav 'getcontenttype) "application/binary") + (list (xml webdav 'getlastmodified) "Thu, 01 Jan 1970 00:00:00 GMT") + (list (xml virtual-ns 'isvirtual) "true") + (list (xml webdav 'lockdiscovery) '()) + (list (xml webdav 'resourcetype)) + (list (xml webdav 'supportedlock) '()) + (list (xml ns1 'test) "Content") + )) + (propstat 404 (list (list (xml webdav 'displayname)) + (list (xml webdav 'getcontentlanguage)))) + (propstat 501 + (list (list (xml webdav 'getetag)) + ))) + (sort-propstats props))))) + + + + +;;; Setting properties + +;;; We already use set-dead-property! above, but for testing get we need set, +;;; and for testing set we need get, and get is more independent, so we start there. + + + +(test-group "Propstat -> namespaced sxml" + (test-equal "Simple" + `(,(xml webdav 'propstat) + (,(xml webdav 'prop) (,(xml webdav 'displayname) "test")) + (,(xml webdav 'status) "HTTP/1.1 200 OK")) + (propstat->namespaced-sxml (propstat 200 `((,(xml webdav 'displayname) "test")) ))) + + ;; TODO populated error field + + (test-equal "With response description" + `(,(xml webdav 'propstat) + (,(xml webdav 'prop) (,(xml webdav 'displayname) "test")) + (,(xml webdav 'status) "HTTP/1.1 403 Forbidden") + (,(xml webdav 'responsedescription) "Try logging in")) + (propstat->namespaced-sxml (propstat 403 `((,(xml webdav 'displayname) "test")) + responsedescription: "Try logging in")))) + + + + +;;; TODO what am I doing here? + +(test-equal + (list (propstat 200 + `((,(xml webdav 'getcontentlength) 4) + (,(xml webdav 'getlastmodified) "Thu, 01 Jan 1970 00:00:00 GMT") + (,(xml webdav 'resourcetype)))) + (propstat 404 + `((,(xml webdav 'checked-in)) + (,(xml webdav 'checked-out)) + (,(xml (string->symbol "http://apache.org/dav/props/") 'executable))))) + (let ((request (xml->namespaced-sxml + "<?xml version=\"1.0\" encoding=\"utf-8\"?> +<propfind xmlns=\"DAV:\"> + <prop> + <getcontentlength/> + <getlastmodified/> + <executable xmlns=\"http://apache.org/dav/props/\"/> + <resourcetype/> + <checked-in/> + <checked-out/> + </prop> +</propfind>"))) + + (sort-propstats (parse-propfind (caddr request) resource)))) + + + +(test-group "lookup-resource" + (let* ((root (make <virtual-resource> name: "*root*")) + (a (add-collection! root "a")) + (b (add-collection! a "b")) + (c (add-resource! b "c" "~~Nothing~~"))) + (test-eq "Lookup root" + root (lookup-resource root '())) + (test-eq "Lookup direct child" + a (lookup-resource root '("a"))) + (test-eq "Lookup deep child" + c (lookup-resource root '("a" "b" "c"))) + (test-assert "Lookup missing" + (not (lookup-resource root '("a" "d" "c")))))) + + + + +(test-group "mkcol" + (let ((root (make <virtual-resource> name: "*root*"))) + (add-collection! root "child") + (test-eqv "Child got added" 1 (length (children root))))) diff --git a/tests/test/xcal.scm b/tests/test/xcal.scm deleted file mode 100644 index 48d43c59..00000000 --- a/tests/test/xcal.scm +++ /dev/null @@ -1,58 +0,0 @@ -;;; Commentary: -;; Basic tests of xcal convertion. -;; Currently only checks that events survive a round trip. -;;; Code: - -(define-module (test xcal) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module ((vcomponent formats xcal parse) - :select (sxcal->vcomponent)) - :use-module ((vcomponent formats xcal output) - :select (vcomponent->sxcal)) - :use-module ((vcomponent formats ical parse) - :select (parse-calendar)) - :use-module ((hnh util) :select (->)) - :use-module ((vcomponent base) - :select (parameters prop* children))) - -;;; Some different types, same parameters - -(define ev - (call-with-input-string - "BEGIN:VCALENDAR -VERSION:2.0 -PRODID:-//calparse-test -BEGIN:VEVENT -SUMMARY:Test event -DTSTART;TZID=Europe/Stockholm:20200625T133000 -DTEND:20200625T143000Z -DTSTAMP:20200609T131418Z -UID:1 -SEQUENCE:0 -CREATED:20200609T081725Z -DESCRIPTION:Short description -LAST-MODIFIED:20200609T081725Z -STATUS;X-TEST-PARAM=10:CONFIRMED -TRANSP:OPAQUE -END:VEVENT -END:VCALENDAR" - parse-calendar)) - -(define twice-converted - (-> ev vcomponent->sxcal sxcal->vcomponent)) - -;;; NOTE both these tests may fail since neither properties nor parameters are ordered sorted. - -(test-equal - "c->x & c->x->c->x" - (vcomponent->sxcal ev) - (vcomponent->sxcal twice-converted)) - -(test-equal - "xcal parameters" - '((X-TEST-PARAM "10")) - (parameters - (prop* (car (children twice-converted)) 'STATUS))) - - diff --git a/tests/validate-html/run-validator.scm b/tests/validate-html/run-validator.scm index bd96c32d..0c4ee0bc 100755 --- a/tests/validate-html/run-validator.scm +++ b/tests/validate-html/run-validator.scm @@ -80,6 +80,6 @@ exec $GUILE -e main -s "$0" -- "$@" (begin (for-each (lambda (group) (format #t "~a~%" (-> group car (assoc-ref 'url) car)) - (for-each display-entry (cadr group))) + (for-each display-entry (cdr group))) (group-by-file filtered-data)) (exit 1))))) |