diff options
147 files changed, 12412 insertions, 1431 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 \ @@ -103,3 +105,6 @@ coverage: lcov.info check: tests/run-tests.scm $(if $(VERBOSE),--verbose) $(SKIP) $(LIMIT_FILES) + +litmus: + tests/litmus.scm $(path) diff --git a/doc/ref/general.texi b/doc/ref/general.texi index d33975ed..b97dece0 100644 --- a/doc/ref/general.texi +++ b/doc/ref/general.texi @@ -21,3 +21,11 @@ of these should be generally useful in any project. @include general/crypto.texi @include general/graph.texi @include general/options.texi + + +@include general/util-type.texi +@include general/util-object.texi +@include general/lens.texi +@include general/data-formats.texi +@include general/data-stores.texi +@include general/webdav.texi diff --git a/doc/ref/general/data-formats.texi b/doc/ref/general/data-formats.texi new file mode 100644 index 00000000..037d3ae7 --- /dev/null +++ b/doc/ref/general/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/general/data-stores.texi b/doc/ref/general/data-stores.texi new file mode 100644 index 00000000..ec3962da --- /dev/null +++ b/doc/ref/general/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/general/lens.texi b/doc/ref/general/lens.texi new file mode 100644 index 00000000..eeddd6ca --- /dev/null +++ b/doc/ref/general/lens.texi @@ -0,0 +1,47 @@ +@node Lenses +@section Lenses + +Provided by the module @code{(hnh util lens)} + +@defun modify object lens f args ... +@end defun + +@defmac modify* object lens +@defmacx modify* object lens rest ... +@end defmac + +@defmac set object lenses ... value +@end defmac + +@defmac get object lenses ... +@end defmac + + +@defun make-lens getter setter +@end defun + +@defmac build-lens getter setter +Where any of getter or setter can either be a single symbol, or a list. +@end defmac + +@deftp {Scheme Lens} identity-lens +@end deftp + +@defun compose-lenses lenses ... +@defunx lens-compose lenses ... +Lenses composes left to right, so earlier lenses in @var{lenses} are +applied earlier. +@end defun + +@deftp {Scheme Lens} ref idx +Focuses the element at index @var{idx} in a list. +@end deftp + +@deftp {Scheme Lens} car* +@deftp {Scheme Lens} cdr* +Focuses the first or second element of a pair. +@end deftp + +@defun each object lens proc +@end defun + diff --git a/doc/ref/general/sxml.texi b/doc/ref/general/sxml.texi new file mode 100644 index 00000000..dd635b4c --- /dev/null +++ b/doc/ref/general/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/general/util-object.texi b/doc/ref/general/util-object.texi new file mode 100644 index 00000000..ceac2f2a --- /dev/null +++ b/doc/ref/general/util-object.texi @@ -0,0 +1,86 @@ +@node define-type +@section Yet Another Object System + +@defmac define-type (name type-parameters ...) fields ... +Introduce a new type. + +Each field is either a symbol, or a list where the first element is a +symbol, and the remaining elements are alternating keywords and +values, as per @ref{Field Parameters}. All fields are optional by +default, but can be made non-optional through its type parameter. + +The example below creates a new type called @var{type}, with a custom +printer which always displays the string ``TYPE''. It has two fields, +@var{x}, which must be an integer, and @var{y}, which can have any +type, but gets the value ``Hello'' in none is given. +@example +(define-type (type #:printer (lambda (r p) (display "TYPE" p))) + (x #:type integer?) + (y #:default "Hello")) +@end example +@end defmac + +@subsection Type Parameters + +@deffn {Type Parameter} constructor (λ (primitive-constructor type-validator)) +Use a custom constructor for the type. The given procedure is called +with two values: +@itemize +@item the types primitive (and usually hidden) constructor, +which takes as many arguments as there are fields, in the order given +in define-type, and +@item the type validator procedure, which also takes all arguments, +but instead either returns an undefined value if everything is fine, +or throws @code{'wrong-type-arg} otherwise. +@end itemize +The procedure should then return a new procedure, which will be bound +as the constructor for the type. Note that default values are current +disregarded with custom constructors. + +A custom constructor for the type above might look like +@example +(lambda (primitive-constructor type-check) + (lambda* (#:key x y) + (type-check x y) + (primitive-constructor x y))) +@end example +@end deffn + +@deffn {Type Parameter} printer (λ (record port)) +Use a custom printer for the type. +@end deffn + +@subsection Field Parameters +@anchor{Field Parameters} + +@deffn {Field Parameter} default value +Value the field should get if not given. +@end deffn + +@deffn {Field Parameter} type type-clause +A type predicate that the field must obey. See @ref{type-clause} for details. +@end deffn + +@subsection Introduced Bindings + +Define type introduces a number procedures. (@var{<name>} should be +replaced with whatever was given as @var{name} to define-type. + +@defun @var{<name>} [kv-args ...] +Type constructor. Takes key-value arguments. Where the keys are the +names of the fields. +@end defun + +@defun @var{<name>}? x +Type predicate. +@end defun + +And for each field @var{<field>}: + +@defun @var{<field>} object [value] +Accessor for the given filed. +Returns the current value if called with only an object, and returns a +new object with @var{field} set to @var{value} if called with two values. + +The updating version checks the type if #:type was given on creation. +@end defun diff --git a/doc/ref/general/util-path.texi b/doc/ref/general/util-path.texi index 9c1da19b..ba78a828 100644 --- a/doc/ref/general/util-path.texi +++ b/doc/ref/general/util-path.texi @@ -41,7 +41,13 @@ 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 diff --git a/doc/ref/general/util-type.texi b/doc/ref/general/util-type.texi new file mode 100644 index 00000000..104b00b3 --- /dev/null +++ b/doc/ref/general/util-type.texi @@ -0,0 +1,62 @@ +@node Type utilities +@section Type utilities + +Provided by the module @code{(hnh util type)} + +@subsection Type Clauses +@anchor{type-clause} +@cindex type-clause + +Type clauses are an effective way of writing compound predicates +without explicitly mentioning the variable at all steps. + +The simplest type predicate is a single symbol, which is directly +called on the object: +@example +predicate? ⇒ (predicate? x) +@end example + +Otherwise, if the predicate is a list then the variable is spliced +into the argument list in the first position: +@example +(proc args ...) ⇒ (proc x args ...) +@end example + +The two primitives @code{and} and @code{or} are also available, which +both take an arbitrary number of predicates, and calls them in order, +with Scheme's usual short-circuiting rules. +@footnote{@code{and} and @code{or} doesn't have to be primitives, but +we would otherwise have one hell of a namespace conflict} + +@defmac list-of variable type-clause +Checks if @var{variable} is a list, and that every element satisfies type-clause. +@end defmac + +@defmac pair-of variable car-type-clause cdr-type-clause +Check if @var{variable} is a cons-pair, and that the car satisfies +@var{car-type-clause}, and that the cdr satisfies @var{cdr-type-clause}. +@end defmac + +@subsection Deffinitions + +@defmac build-validator-body variable type-clause +``Entry point'' of type clauses. Inserts variable into the +type-clause, returning something ready to be passed along the eval (or +rather, spliced into another macro). + +Also used if new ``primitives'' are to be added, such as list-of. +@end defmac + +@defmac typecheck variable type-clause [procedure-name=(current-procedure-name)] +Checks @var{variable} against @var{type-clause}, and raises +@code{'wrong-type-argument} if it fails. @var{procedure-name} is used +as the calling procedure for @code{scm-error}. + +Useful at the start of procedures. +@end defmac + + +@defmac current-procedure-name +Returns the current procedure name as a symbol, or @code{#f} if not found. +@end defmac + diff --git a/doc/ref/general/util.texi b/doc/ref/general/util.texi index a85ff661..1d6a4e7a 100644 --- a/doc/ref/general/util.texi +++ b/doc/ref/general/util.texi @@ -127,6 +127,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). @@ -235,7 +240,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 @@ -243,7 +250,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 @@ -334,6 +341,11 @@ A variable can also be removed from the environment, by setting its value to @code{#f}. @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 diff --git a/doc/ref/general/webdav.texi b/doc/ref/general/webdav.texi new file mode 100644 index 00000000..a495c945 --- /dev/null +++ b/doc/ref/general/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/vcomponent.texi b/doc/ref/vcomponent.texi index dac47348..d0e032b3 100644 --- a/doc/ref/vcomponent.texi +++ b/doc/ref/vcomponent.texi @@ -113,6 +113,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 @@ -122,3 +124,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/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/html/view/calendar.scm b/module/calp/html/view/calendar.scm index a240d00c..070d1c3f 100644 --- a/module/calp/html/view/calendar.scm +++ b/module/calp/html/view/calendar.scm @@ -171,7 +171,7 @@ window.default_calendar='~a';" ;; Button to view week (G_ "Week")) - ,(btn href: (date->string (set (day start-date) 1) "/month/~1.html") + ,(btn href: (date->string (day start-date 1) "/month/~1.html") ;; button to view month (G_ "Month")) @@ -381,13 +381,11 @@ window.default_calendar='~a';" (repeating% regular (partition repeating? flat-events)) (repeating (for ev in repeating% - (define instance (copy-vcomponent ev)) - - (set! (prop instance 'UID) (output-uid instance)) - (delete-parameter! (prop* instance 'DTSTART) '-X-HNH-ORIGINAL) - (delete-parameter! (prop* instance 'DTEND) '-X-HNH-ORIGINAL) - - instance))) + ;; TODO + (-> (set-properties ev 'UID (output-uid ev)) + ;; (focus (prop* instance 'DTSTART) (lambda (vline) (remove-parameter vline key))) + ;; (focus (prop* instance 'DTEND) (lambda (vline) (remove-parameter vline key))) + )))) `( ;; Mapping showing which events belongs to which calendar, diff --git a/module/calp/html/view/search.scm b/module/calp/html/view/search.scm index 7b991104..e400c1ba 100644 --- a/module/calp/html/view/search.scm +++ b/module/calp/html/view/search.scm @@ -31,6 +31,8 @@ (body (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%")) 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/server/routes.scm b/module/calp/server/routes.scm index b4901900..3383f7a6 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -294,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 @@ -332,16 +332,16 @@ (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 (G_ "No component with UID=~a found.") uid)))) @@ -414,13 +414,13 @@ (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)))))) + (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 diff --git a/module/calp/server/server.scm b/module/calp/server/server.scm index f2d58337..4c5a0886 100644 --- a/module/calp/server/server.scm +++ b/module/calp/server/server.scm @@ -4,28 +4,13 @@ :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)) +;;; TODO Do I really want this hardcoded here? (define handler (make-make-routes)) -;; 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 (start-server open-params) (run-server handler 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..781a85d9 --- /dev/null +++ b/module/calp/server/webdav.scm @@ -0,0 +1,768 @@ +(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) +(declare-method! "MKCALENDAR" '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 04effd68..316421eb 100644 --- a/module/calp/terminal.scm +++ b/module/calp/terminal.scm @@ -162,11 +162,11 @@ (date->string start)))) (format #t "\x1b[1m~a:\x1b[m ~a~%~%" (G_ "End") - (let ((start (prop ev 'DTSTART))) - (if (datetime? start) - (datetime->string (prop ev 'DTSTART) + (let ((end (prop ev 'DTEND))) + (if (datetime? end) + (datetime->string (prop ev 'DTEND) (G_ "~Y-~m-~d ~H:~M:~S")) - (date->string start)))) + (date->string end)))) (format #t "~a~%" (unlines (take-to (flow-text (or (prop ev 'DESCRIPTION) "") width: (min 70 width)) @@ -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))) 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..e1bf73fd --- /dev/null +++ b/module/calp/webdav/resource/calendar/collection.scm @@ -0,0 +1,295 @@ +(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 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:)) + + +(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) + (vcomponent type: '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.scm b/module/datetime.scm index 8bba6e89..d54ba403 100644 --- a/module/datetime.scm +++ b/module/datetime.scm @@ -3,8 +3,6 @@ :replace (second) :use-module (srfi srfi-1) - :use-module (srfi srfi-9) - :use-module (srfi srfi-9 gnu) :use-module (srfi srfi-41) :use-module (srfi srfi-71) :use-module (srfi srfi-88) @@ -15,12 +13,13 @@ -> ->> swap - set label span-upto - set-> )) + :use-module (hnh util object) + :use-module (hnh util lens) + :use-module (ice-9 i18n) :use-module (ice-9 format) :use-module (ice-9 regex) @@ -37,8 +36,11 @@ datetime datetime? - get-date - get-timezone + ;; get-date + ;; get-timezone + datetime-date + datetime-time + tz date-zero? time-zero? @@ -171,45 +173,40 @@ pre: (ensure (lambda (x) (<= sun x sat)))) -;;; RECORD TYPES - -;;; DATE - -(define-immutable-record-type <date> - (make-date year month day) - date? - (year year) (month month) (day day)) - -(define* (date key: (year 0) (month 0) (day 0)) - (unless (and (integer? year) (integer? month) (integer? day)) - (scm-error 'wrong-type-arg "date" - "Year, month, and day must all be integers. ~s, ~s, ~s" - (list year month day) - #f)) - (make-date year month day)) -(set-record-type-printer! - <date> (lambda (r p) (display (date->string r "#~1") p))) - - -;;; TIME - -(define-immutable-record-type <time> - (make-time hour minute second) - time? - (hour hour) (minute minute) (second second)) - -(define* (time key: (hour 0) (minute 0) (second 0)) - (unless (and (integer? hour) (integer? minute) (integer? second)) - (scm-error 'wrong-type-arg "time" - "Hour, minute, and second must all be integers. ~s, ~s, ~s" - (list hour minute second) - #f)) - (make-time hour minute second)) +;;; RECORD TYPES -(set-record-type-printer! - <time> - (lambda (r p) (display (time->string r "#~3") p))) +(define-type (date printer: (lambda (r p) (display (date->string r "#~1") p))) + (year default: 0 type: integer?) + (month default: 0 type: integer?) + (day default: 0 type: integer?)) + +(define-type (time printer: (lambda (r p) (display (time->string r "#~3") p))) + (hour default: 0 type: integer?) + (minute default: 0 type: integer?) + (second default: 0 type: integer?)) + +(define (datetime-constructor-constructor constructor validator) + (let ((date% date) + (time% time)) + (lambda* (key: date time tz + (year 0) (month 0) (day 0) + (hour 0) (minute 0) (second 0)) + (let ((date (or date (date% year: year month: month day: day))) + (time (or time (time% hour: hour minute: minute second: second)))) + (validator date time tz) + (constructor date time tz))))) + +(define-type (datetime + constructor: datetime-constructor-constructor + printer: (lambda (r p) + (if (and (tz r) (not (string=? "UTC" (tz r)))) + (write (datetime->sexp r) p) + (display (datetime->string r "#~1T~3~Z") p)))) + + (datetime-date type: date?) + (datetime-time type: time?) + tz) (define (date-zero? date) @@ -218,53 +215,14 @@ (define (time-zero? time) (= 0 (hour time) (minute time) (second time))) -;;; DATETIME - -(define-immutable-record-type <datetime> - (make-datetime date time tz) - datetime? - (date get-date) - (time get-time%) - (tz tz) ; #f for localtime, "UTC", "Europe/Stockholm", ... - ) - -(define (get-timezone datetime) - (tz datetime)) - - -(define* (datetime - key: date time - (year 0) (month 0) (day 0) - (hour 0) (minute 0) (second 0) - tz) - (let ((date (or date (make-date year month day))) - (time (or time (make-time hour minute second)))) - (unless (date? date) - (scm-error 'wrong-type-arg "datetime" - "Date must be a date object, got ~s" - (list date) (list date))) - (unless (time? time) - (scm-error 'wrong-type-arg "datetime" - "Time must be a time object, got ~s" - (list time) (list time))) - (make-datetime date time tz))) - -(set-record-type-printer! - <datetime> - (lambda (r p) - (if (and (tz r) (not (string=? "UTC" (tz r)))) - (write (datetime->sexp r) p) - (display (datetime->string r "#~1T~3~Z") p)))) - - ;; NOTE there isn't any stable way to craft the tm objects. ;; I could call mktime on some date, and replace the fields ;; with the set-tm:*, but that is worse that breaking the API. (define (datetime->tm datetime) - (let ((t (get-time% datetime)) - (d (get-date datetime))) + (let ((t (datetime-time datetime)) + (d (datetime-date datetime))) (vector (second t) (minute t) (hour t) @@ -296,8 +254,8 @@ (define (unix-time->datetime n) ;; tm->datetime returns GMT here (as hinted by the ;; name @var{gmtime}). Blindly change it to UTC. - (set (tz (tm->datetime (gmtime n))) - "UTC")) + (-> (tm->datetime (gmtime n)) + (tz "UTC"))) ;; this returns UTC time, with a TZ component set to "UTC" @@ -305,7 +263,7 @@ (unix-time->datetime ((@ (guile) current-time)))) (define (current-date) - (get-date (current-datetime))) + (datetime-date (current-datetime))) @@ -324,10 +282,11 @@ [(string=? "local" (tz dt)) (mktime v)] [else (mktime v (tz dt))]))))) ;; strip tz-name, to conform with my local time. - (set (tz (tm->datetime tm)) #f)))) + (-> (tm->datetime tm) + (tz #f))))) (define (as-date date/-time) - (cond [(datetime? date/-time) (get-date date/-time)] + (cond [date/-time datetime? => datetime-date] [(date? date/-time) date/-time] [(time? date/-time) (date)] [else (scm-error 'wrong-type-arg @@ -337,7 +296,7 @@ #f)])) (define (as-time date/-time) - (cond [(datetime? date/-time) (get-time% date/-time)] + (cond [date/-time datetime? => datetime-time] [(date? date/-time) (time)] [(time? date/-time) date/-time] [else (scm-error 'wrong-type-arg "as-time" @@ -379,15 +338,15 @@ 366 365)) (define (start-of-month date) - (set (day date) 1)) + (-> date (day 1))) (define (end-of-month date) - (set (day date) (days-in-month date))) + (-> date (day (days-in-month date)))) (define (start-of-year date) - (set-> date - (day 1) - (month 1))) + (-> date + (day 1) + (month 1))) (define (date-stream date-increment start-day) (stream-iterate (lambda (d) (date+ d date-increment)) @@ -624,10 +583,10 @@ (prev-month-len (days-in-month (date- date* (date month: 1)))) (month-start (modulo (- (week-day date*) week-start) 7))) (values - (map (lambda (d) (set (day (date- date* (date month: 1))) d)) + (map (lambda (d) (-> date* (date- (date month: 1)) (day d))) (iota month-start (1+ (- prev-month-len month-start)))) - (map (lambda (d) (set (day date*) d)) (iota month-len 1)) - (map (lambda (d) (set (day (date+ date* (date month: 1))) d)) + (map (lambda (d) (day date* d)) (iota month-len 1)) + (map (lambda (d) (-> date* (date+ (date month: 1)) (day d))) (iota (modulo (- (* 7 5) month-len month-start) 7) 1))))) @@ -664,17 +623,17 @@ (let ((date-diff (cond [start-date - (let ((end-date (date+ start-date (get-date dt)))) - (1- (days-in-interval start-date end-date))) ] - [(or (not (zero? (month (get-date dt)))) - (not (zero? (year (get-date dt))))) + (let ((end-date (date+ start-date (datetime-date dt)))) + (1- (days-in-interval start-date end-date)))] + [(or (not (zero? (month (datetime-date dt)))) + (not (zero? (year (datetime-date dt))))) (scm-error 'misc-error "datetime->decimal-hour" "Multi-month intervals only supported when start-date is given (~a)" (list dt) #f)] - [else (day (get-date dt))]))) - (+ (time->decimal-hour (get-time% dt)) - (* date-diff 24)))) + [else (-> dt datetime-date day)]))) + (-> dt datetime-time time->decimal-hour + (+ (* date-diff 24))))) ;; Returns a list of all dates from start to end. ;; both inclusive @@ -693,8 +652,8 @@ (fmt "~1T~3") (locale %global-locale) key: allow-unknown?) - (define date (get-date datetime)) - (define time (get-time% datetime)) + (define date (datetime-date datetime)) + (define time (datetime-time datetime)) (with-output-to-string (lambda () (fold (lambda (token state) @@ -718,7 +677,7 @@ ((#\a) (display (week-day-name (week-day date) 3 locale: locale))) ((#\B) (display (locale-month (month date) locale))) ((#\b) (display (locale-month-short (month date) locale))) - ((#\Z) (when (equal? "UTC" (get-timezone datetime)) (display "Z"))) + ((#\Z) (when (equal? "UTC" (tz datetime)) (display "Z"))) (else (unless allow-unknown? (scm-error 'misc-error "datetime->string" "Invalid format token ~a" @@ -777,14 +736,6 @@ Returns -1 on failure" (define* (loop str fmt dt optional: (ampm ampm)) (loop* str fmt dt ampm)) - (define time (get-time% dt)) - (define date (get-date dt)) - (define zone (get-timezone dt)) - (define (as-dt dt) - (cond [(date? dt) (datetime date: dt time: time tz: zone)] - [(time? dt) (datetime date: date time: dt tz: zone)] - [else dt])) - (cond [(and (null? str) (null? fmt)) (ampm dt)] [(null? str) @@ -811,7 +762,7 @@ Returns -1 on failure" (if (eq? #\Z (car str)) (loop (cdr str) (cddr fmt) - (set (tz dt) "UTC")) + (tz dt "UTC")) (loop str (cddr fmt) dt))] @@ -825,17 +776,13 @@ Returns -1 on failure" (case (string-ref (match:substring m 1) 0) ((#\a #\A) (lambda (dt) - (datetime date: (get-date dt) - time: (if (= 12 (hour (get-time% dt))) - (set (hour (get-time% dt)) 0) - (get-time% dt))))) + (modify* dt datetime-time hour + (lambda (x) (if (= x 12) 0 x))))) ((#\p #\P) (lambda (dt) - (datetime date: (get-date dt) - time: (if (= 12 (hour (get-time% dt))) - (get-time% dt) - (set (hour (get-time% dt)) - (+ 12 (hour (get-time% dt)))))))))) + (modify* dt datetime-time hour + (lambda (x) (if (= x 12) + x (+ x 12)))))))) )) ;; fail here? (else (loop str (cddr fmt) dt))) @@ -853,8 +800,8 @@ Returns -1 on failure" ((next-char rest ...) (span (lambda (c) (not (eqv? c next-char))) str))))) (loop post (cddr fmt) - (as-dt (set (month date) - (parse-month (list->string head) locale)))))] + (set dt datetime-date month + (parse-month (list->string head) locale))))] [(#\H #\M #\S #\m #\d) ;; This captures both the possibility of a date with a single digit, ;; e.g. 7 may, but also compact, digits only, form without delimiters, @@ -864,13 +811,14 @@ Returns -1 on failure" (loop post (cddr fmt) - (as-dt - (case (cadr fmt) - [(#\H) (set (hour time) num)] - [(#\M) (set (minute time) num)] - [(#\S) (set (second time) num)] - [(#\m) (set (month date) num)] - [(#\d) (set (day date) num)]))))] + (let ((lens + (case (cadr fmt) + [(#\H) (lens-compose datetime-time hour)] + [(#\M) (lens-compose datetime-time minute)] + [(#\S) (lens-compose datetime-time second)] + [(#\m) (lens-compose datetime-date month)] + [(#\d) (lens-compose datetime-date day)]))) + (set dt lens num))))] [(#\Y) (let* ((pre post (span-upto 4 char-numeric? str)) @@ -878,7 +826,7 @@ Returns -1 on failure" (loop post (cddr fmt) - (as-dt (set (year date) num))))] + (set dt datetime-date year num)))] [else (err "Unimplemented or incorrect parse token ~S" str)])] [else @@ -894,11 +842,11 @@ Returns -1 on failure" (define* (string->time str optional: (fmt "~H:~M:~S") (locale %global-locale) key: return-trailing) - (get-time% (string->datetime str fmt locale return-trailing: return-trailing))) + (datetime-time (string->datetime str fmt locale return-trailing: return-trailing))) (define* (string->date str optional: (fmt "~Y-~m-~d") (locale %global-locale) key: return-trailing) - (get-date (string->datetime str fmt locale return-trailing: return-trailing))) + (datetime-date (string->datetime str fmt locale return-trailing: return-trailing))) ;; Parse @var{string} as either a date, time, or date-time. ;; String MUST be on iso-8601 format. @@ -924,7 +872,7 @@ Returns -1 on failure" (let ((dt (string->datetime str "~Y~m~dT~H~M~S~Z"))) (if (tz dt) dt - (set (tz dt) zone)))) + (tz dt zone)))) (define (parse-iso-date str) (string->date str)) @@ -949,8 +897,8 @@ Returns -1 on failure" second: ,(second t))) (define* (datetime->sexp dt optional: verbose) - `(datetime date: ,(if verbose (date->sexp (get-date dt)) (get-date dt)) - time: ,(if verbose (time->sexp (get-time% dt)) (get-time% dt)) + `(datetime date: ,(if verbose (date->sexp (datetime-date dt)) (datetime-date dt)) + time: ,(if verbose (time->sexp (datetime-time dt)) (datetime-time dt)) tz: ,(tz dt))) @@ -992,8 +940,8 @@ Returns -1 on failure" (define (datetime= . args) (reduce (lambda (a b) - (and (date= (get-date a) (get-date b)) - (time= (get-time% a) (get-time% b)) + (and (date= (datetime-date a) (datetime-date b)) + (time= (datetime-time a) (datetime-time b)) a)) #t args)) @@ -1053,16 +1001,16 @@ Returns -1 on failure" (define datetime< (fold-comparator (lambda (a b) - (if (date= (get-date a) (get-date b)) - (time< (get-time% a) (get-time% b)) - (date< (get-date a) (get-date b)))))) + (if (date= (datetime-date a) (datetime-date b)) + (time< (datetime-time a) (datetime-time b)) + (date< (datetime-date a) (datetime-date b)))))) (define datetime<= (fold-comparator (lambda (a b) - (if (date= (get-date a) (get-date b)) - (time<= (get-time% a) (get-time% b)) - (date<= (get-date a) (get-date b)))))) + (if (date= (datetime-date a) (datetime-date b)) + (time<= (datetime-time a) (datetime-time b)) + (date<= (datetime-date a) (datetime-date b)))))) (define date/-time< (fold-comparator @@ -1126,19 +1074,20 @@ Returns -1 on failure" (let loop ((target base) (change change)) (if (>= (days-in-month target) (+ (day change) (day target))) ;; No date overflow, just add the change - (values (set-> target (day = (+ (day change)))) - (set-> change (day 0))) + (values (-> target (day (+ (day target) + (day change)))) + (day change 0)) ;; Date (and possibly year) overflow (loop (if (= 12 (month target)) - (set-> target - (year = (+ 1)) - (month 1) - (day 1)) - (set-> target - (month = (+ 1)) - (day 1))) - (set-> change - (day = (- (1+ (- (days-in-month target) (day target)))))))))) + (-> (modify target year 1+) + (month 1) + (day 1)) + (-> (modify target month 1+) + (day 1))) + (modify change day - + (- (day target)) + (days-in-month target) + 1))))) (define-values (month-fixed change**) (if (date-zero? change*) @@ -1146,20 +1095,19 @@ Returns -1 on failure" (let loop ((target days-fixed) (change change*)) (if (< 12 (+ (month change) (month target))) ;; if we overflow into the next year - (loop (set-> target - (year = (+ 1)) - (month 1)) - (set (month change) = (- (- 13 (month target))))) - + (loop (-> (modify target year 1+) + (month 1)) + (modify change month + + (month target) -13)) ;; if we don't overflow our date - (values (set (month target) = (+ (month change))) - (set (month change) 0)) + (values (modify target month + (month change)) + (month change 0)) )))) ;; change** should here should have both month and date = 0 - (set (year month-fixed) = (+ (year change**)))) + (year month-fixed (+ (year month-fixed) (year change**)))) (define (date+% change base) @@ -1188,33 +1136,30 @@ Returns -1 on failure" (define-values (days-fixed change*) (let loop ((target base) (change change)) (if (>= (day change) (day target)) - (let ((new-change (set (day change) = (- (day target))))) + (let ((new-change (modify change day - (day target)))) (loop (if (= 1 (month target)) - (set-> target - (year = (- 1)) - (month 12) - (day 31) ; days in december - ) - (set-> target - (month = (- 1)) - (day (days-in-month (set (month target) = (- 1)))))) + (-> (modify target year 1-) + (month 12) + (day 31) ; days in december + ) + (let ((nm (modify target month 1-))) + (day nm (days-in-month nm)))) new-change)) - (values (set (day target) = (- (day change))) - (set (day change) 0))))) + (values (modify target day - (day change)) + (day change 0))))) (define-values (month-fixed change**) (let loop ((target days-fixed) (change change*)) (if (>= (month change) (month target)) - (loop (set-> target - (year = (- 1)) - (month 12)) - (set (month change) = (- (month target)))) - (values (set (month target) = (- (month change))) - (set (month change) 0))))) + (loop (-> (modify target year 1-) + (month 12)) + (modify change month - (month target))) + (values (modify target month - (month change)) + (month change 0))))) ;; change** should here should have both month and date = 0 - (set (year month-fixed) = (- (year change**)))) + (modify month-fixed year - (year change**))) (define (date-% change base) @@ -1248,28 +1193,28 @@ Returns -1 on failure" ;; while (day base) > (days-in-month base) ;; month++; days -= (days-in-month base) (define second-fixed - (let loop ((target (set (second base) = (+ (second change))))) + (let loop ((target (modify base second + (second change)))) (if (>= (second target) 60) - (loop (set-> target - (minute = (+ 1)) - (second = (- 60)))) + (loop (-> target + (modify minute 1+) + (modify second - 60))) target))) ;; while (month base) > 12 ;; year++; month -= 12 (define minute-fixed - (let loop ((target (set (minute second-fixed) = (+ (minute change))))) + (let loop ((target (modify second-fixed minute + (minute change)))) (if (>= (minute target) 60) - (loop (set-> target - (hour = (+ 1)) - (minute = (- 60)))) + (loop (-> target + (modify hour 1+) + (modify minute - 60))) target))) - (define hour-almost-fixed (set (hour minute-fixed) = (+ (hour change)))) + (define hour-almost-fixed (modify minute-fixed hour + (hour change))) (if (<= 24 (hour hour-almost-fixed)) (let ((div remainder (floor/ (hour hour-almost-fixed) 24))) - (values (set (hour hour-almost-fixed) remainder) div)) + (values (hour hour-almost-fixed remainder) div)) (values hour-almost-fixed 0))) ;;; PLUS @@ -1289,28 +1234,26 @@ Returns -1 on failure" (define-values (second-fixed change*) (let loop ((target base) (change change)) (if (> (second change) (second target)) - (loop (set-> target - (minute = (- 1)) - (second 60)) - (set (second change) = (- (second target)))) - (values (set (second target) = (- (second change))) - (set (second change) 0))))) + (loop (-> (modify target minute 1-) + (second 60)) + (modify change second - (second target))) + (values (modify target second - (second change)) + (second change 0))))) (define-values (minute-fixed change**) (let loop ((target second-fixed) (change change*)) (if (> (minute change) (minute target)) - (loop (set-> target - (hour = (- 1)) - (minute 60)) - (set (minute change) = (- (minute target)))) - (values (set (minute target) = (- (minute change))) - (set (minute change) 0))))) + (loop (-> (modify target hour 1-) + (minute 60)) + (modify change minute - (minute target))) + (values (modify target minute - (minute change)) + (minute change 0))))) (if (>= (hour minute-fixed) (hour change**)) - (values (set (hour minute-fixed) = (- (hour change**))) 0) + (values (modify minute-fixed hour - (hour change**)) 0) (let ((diff (- (hour minute-fixed) (hour change**)))) - (values (set (hour minute-fixed) (modulo diff 24)) + (values (hour minute-fixed (modulo diff 24)) (abs (floor (/ diff 24))))))) ;; Goes backwards from base, returning the two values: @@ -1331,21 +1274,20 @@ Returns -1 on failure" (define (datetime+ base change) - (let ((time overflow (time+ (get-time% base) (get-time% change)))) - (datetime date: (date+ (get-date base) - (get-date change) - (date day: overflow)) - time: time - tz: (get-timezone base) - ))) + (let ((time* overflow (time+ (datetime-time base) (datetime-time change)))) + (-> base + (modify datetime-date date+ + (datetime-date change) + (date day: overflow)) + (datetime-time time*)))) (define (datetime- base change) - (let ((time underflow (time- (get-time% base) (get-time% change)))) - (datetime date: (date- (get-date base) - (get-date change) - (date day: underflow)) - time: time - tz: (tz base)))) + (let ((time* underflow (time- (datetime-time base) (datetime-time change)))) + (-> base + (modify datetime-date date- + (datetime-date change) + (date day: underflow)) + (datetime-time time*)))) ;;; the *-difference procedures takes two actual datetimes. ;;; date- instead takes a date and a delta (but NOT an actual date). @@ -1357,20 +1299,18 @@ Returns -1 on failure" (define-values (b* a*) (let loop ((b b) (a a)) (if (> (day a) (day b)) - (let ((new-a (set (day a) = (- (1+ (day b)))))) + (let ((new-a (day a (- (day a) (day b) 1)))) (loop (if (= 0 (month b)) - (set-> b - (year = (- 1)) - (month 11) - (day 30) ; Last day in december - ) - (set-> b - (month = (- 1)) - (day (1- (days-in-month b))))) ; last in prev month + (-> (modify b year 1-) + (month 11) + (day 30) ; Last day in december + ) + (-> (modify b month 1-) + (day (1- (days-in-month b))))) ; last in prev month new-a)) ;; elif (> (day b) (day a)) - (values (set (day b) = (- (day a))) - (set (day a) 0))))) + (values (day b (- (day b) (day a))) + (day a 0))))) ;; (day a*) should be 0 here. @@ -1378,17 +1318,16 @@ Returns -1 on failure" (define-values (b** a**) (let loop ((b b*) (a a*)) (if (> (month a) (month b)) - (loop (set-> b - (year = (- 1)) - (month 11)) - (set (month a) = (- (1+ (month b))))) + (loop (-> (modify b year 1-) + (month 11)) + (modify a month - 1 (month b))) ;; elif (> (month b) (month a)) - (values (set (month b) = (- (month a))) - (set (month a) 0))))) + (values (modify b month - (month a)) + (month a 0))))) ;; a** should here should have both month and date = 0 - (set (year b**) = (- (year a**)))) + (year b** (- (year b**) (year a**)))) @@ -1407,20 +1346,21 @@ Returns -1 on failure" (list earlier-date later-date) #f)) - (date-difference% (set-> later-date - (month = (- 1)) - (day = (- 1))) - (set-> earlier-date - (month = (- 1)) - (day = (- 1))))) + (let ((proc (lambda (d) (-> d + (modify month 1-) + (modify day 1-))))) + (date-difference% (proc later-date) + (proc earlier-date)))) ;; NOTE, this is only properly defined when end is greater than start. (define (datetime-difference end start) ;; NOTE Makes both start and end datetimes in the current local time. - (let ((fixed-time overflow (time- (get-time% end) - (get-time% start)))) - (datetime date: (date-difference (date- (get-date end) + (let ((fixed-time overflow (time- (datetime-time end) + (datetime-time start)))) + (datetime date: (date-difference (date- (datetime-date end) (date day: overflow)) - (get-date start)) - time: fixed-time))) + (datetime-date start)) + time: fixed-time + ;; TODO TZ + ))) diff --git a/module/datetime/zic.scm b/module/datetime/zic.scm index 470f6c07..acfb17a8 100644 --- a/module/datetime/zic.scm +++ b/module/datetime/zic.scm @@ -342,17 +342,17 @@ (datetime date: (match (rule-on rule) - ((? number? on) (set (day d) on)) + ((? number? on) (day d on)) (('last n) (iterate (lambda (d) (date- d (date day: 1))) (lambda (d) (eqv? n (week-day d))) - (set (day d) (days-in-month d)))) + (day d (days-in-month d)))) (((? (lambda (x) (memv x '(< >))) <>) wday base-day) (iterate (lambda (d) ((if (eq? '< <>) date- date+) d (date day: 1))) (lambda (d) (eqv? wday (week-day d))) - (set (day d) base-day)))) + (day d base-day)))) tz: (case (timespec-type (rule-at rule)) ((#\w) #f) ((#\s) (warning (G_ "what even is \"Standard time\"‽")) #f) diff --git a/module/hnh/module-introspection/module-uses.scm b/module/hnh/module-introspection/module-uses.scm index b82aa6d0..3bed2a5e 100644 --- a/module/hnh/module-introspection/module-uses.scm +++ b/module/hnh/module-introspection/module-uses.scm @@ -82,6 +82,8 @@ (_ '()))) ;; 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 ...) 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 91c081e2..9f71c1ec 100644 --- a/module/hnh/util.scm +++ b/module/hnh/util.scm @@ -18,6 +18,7 @@ find-extreme find-min find-max filter-sorted != + init+last take-to string-take-to string-first @@ -70,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 ...) @@ -179,9 +184,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} @@ -282,6 +290,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)) @@ -425,7 +439,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))] diff --git a/module/hnh/util/assert.scm b/module/hnh/util/assert.scm new file mode 100644 index 00000000..74715654 --- /dev/null +++ b/module/hnh/util/assert.scm @@ -0,0 +1,9 @@ +(define-module (hnh util assert) + :use-module (rnrs base) + :export (assert*) + ) + +(define-syntax assert* + (syntax-rules () + ((_ assertion) + (assert assertion)))) diff --git a/module/hnh/util/env.scm b/module/hnh/util/env.scm index bb42d966..f5992245 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 () @@ -37,3 +39,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 d73a1de8..09900f8d 100644 --- a/module/hnh/util/io.scm +++ b/module/hnh/util/io.scm @@ -5,7 +5,8 @@ open-output-port read-lines with-atomic-output-to-file - call-with-tmpfile)) + call-with-tmpfile + ->port)) (define (open-input-port str) (if (string=? "-" str) @@ -72,3 +73,10 @@ (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/lens.scm b/module/hnh/util/lens.scm new file mode 100644 index 00000000..26c75be7 --- /dev/null +++ b/module/hnh/util/lens.scm @@ -0,0 +1,105 @@ +(define-module (hnh util lens) + :use-module (srfi srfi-1) + :export (modify + modify* + set + get + + identity-lens + compose-lenses + lens-compose + + ref car* cdr* + + each)) + + +(define (modify object lens f . args) + (lens object (apply f (lens object) args))) + +(define-syntax modify* + (syntax-rules () + ((_ object f) (f object)) + ((_ object lens rest ...) + (modify object lens + (lambda (object*) (modify* object* rest ...)))))) + +;; The simple case of getting and setting when you already have the lens is trivial +;; (lens object) +;; (lens object new-value) + +(define-syntax set + (syntax-rules () + ((_ object lenses ... value) + (modify* object lenses ... (const value))))) + +(define-syntax get + (syntax-rules () + ((_ object) object) + ((_ object f lenses ...) + (get (f object) lenses ...)))) + + + + +(define (make-lens getter setter) + (case-lambda ((datum) (getter datum)) + ((datum new-value) (setter datum new-value)))) + +(define-syntax build-lens + (syntax-rules () + ((_ (getter gargs ...) + (setter sargs ...)) + ;; (make-lens (lambda (datum) (getter datum gargs ...)) + ;; (lambda (datum new-value) (setter datum sargs ... new-value))) + (case-lambda ((datum) + (getter datum gargs ...)) + ((datum new-value) + (setter datum sargs ... new-value)))) + ((_ (getter args ...) setter) + (build-accesor (getter args ...) (setter))) + ((_ getter (setter args ...)) + (build-lens (getter) (setter args ...))) + ((_ getter setter) + (build-lens (getter) (setter))))) + + + + +(define identity-lens + (case-lambda ((a) a) + ((_ a) a))) + +(define (compose-lenses% f g) + (build-lens (get f g) (set f g))) + +(define (compose-lenses . fs) + (reduce-right compose-lenses% identity-lens fs)) + +(define lens-compose compose-lenses) + + + +(define (list-change list index value) + (cond ((zero? index) + (cons value (cdr list))) + ((null? list) + (scm-error 'out-of-range "list-change" "" #f #f)) + (else + (cons (car list) + (list-change (cdr list) + (1- index) + value))))) + + + +(define (ref idx) + (build-lens (list-ref idx) (list-change idx))) + + +(define car* (make-lens car (lambda (pair value) (cons value (cdr pair))))) +(define cdr* (make-lens cdr (lambda (pair value) (cons (car pair) value)))) + +(define (each obj lens proc) + (modify obj lens + (lambda (lst) (map proc lst)))) diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm new file mode 100644 index 00000000..4477b462 --- /dev/null +++ b/module/hnh/util/object.scm @@ -0,0 +1,169 @@ +(define-module (hnh util object) + :use-module (srfi srfi-9 gnu) + :use-module (ice-9 curried-definitions) + :use-module (hnh util) + :use-module (hnh util type) + :export (define-type)) + + + +;; If given a syntax list extract the first lexeme, if given a "symbol", return that. +(define (syntax-first stx) + (syntax-case stx () + ((a rest ...) #'a) + (a #'a))) + +(define (construct-syntax stx base transform) + (->> base + syntax->datum + (format #f transform) + string->symbol + (datum->syntax stx))) + +;; stx should be a syntax object of a key-value list on the form +;; (key: value key2: value2) +;; and target-key the datum which the target key unwraps to. +;; returns the corresponding values syntax +;; or #f if none is found +(define (kv-ref stx target-key) + (syntax-case stx () + ((key value rest ...) + (if (eqv? target-key (syntax->datum #'key)) + #'value + (kv-ref #'(rest ...) target-key))) + (_ #f))) + + + +;; Given (x type: predicate?), expand to a single `unless' form (otherwise #f) +(define-syntax (validator stx) + (syntax-case stx () + ((_ (name kvs ...)) + (cond ((kv-ref #'(kvs ...) type:) + => (lambda (type-stx) + (with-syntax ((type type-stx)) + #'(unless (build-validator-body name type) + (scm-error 'wrong-type-arg "validator" + "Invalid value for `~s'. Expected ~s, got ~s" + (list (quote name) (quote type) name) #f))))) + (else #f))) + ((_ name) #f))) + + + + +;; Get syntax for getter-procedure's symbol +(define-syntax (field-get stx) + (syntax-case stx () + ;; ((_ (name kv ...)) #'(field-get name)) + ((_ type-name name) + (->> + (format #f "~a-~a-get" + (syntax->datum #'type-name) + (syntax->datum #'name)) + string->symbol + (datum->syntax stx))))) + +;; get syntax for setter-procedure's symbol +(define-syntax (field-set stx) + (syntax-case stx () + ;; ((_ (name kv ...)) #'(field-set name)) + ((_ type-name name) + (->> + (format #f "~a-~a-set" + (syntax->datum #'type-name) + (syntax->datum #'name)) + string->symbol + (datum->syntax stx))))) + +;; Construct a field line for define-immutable-record-type +(define ((field-declaration type) stx) + (syntax-case stx () + (name + (with-syntax ((name-get (->> (format #f "~a-~a-get" + (syntax->datum type) + (syntax->datum #'name)) + string->symbol + (datum->syntax stx))) + (name-set (->> (format #f "~a-~a-set" + (syntax->datum type) + (syntax->datum #'name)) + string->symbol + (datum->syntax stx)))) + #'(name name-get name-set))))) + +;; Accessors are procedures for getting and setting fields in records +(define-syntax (build-accessor stx) + (syntax-case stx () + ((_ type-name (name kvs ...)) + #'(define name + (case-lambda ((datum) + ((field-get type-name name) datum)) + ((datum new-value) + ;; validator uses the first field (in the list) as both + ;; the name of the field, and a reference to the value of + ;; the field. This ensures those two are the same for validator, + ;; while keeping name bound to the accessor in the outer scope. + (let ((name new-value)) + (validator (name kvs ...))) + ((field-set type-name name) datum new-value))))) + ((_ type-name name) #'(build-accessor type-name (name))))) + + +;; Go from my concept of field deffinitions, to what lambda* wants as arguments +(define (lambda*-stx field) + (syntax-case field () + ((name kvs ...) + (cond ((kv-ref #'(kvs ...) default:) + => (lambda (dflt) #`(name #,dflt))) + (else #'name))) + (name #'name))) + + + +(define-syntax (define-type stx) + (syntax-case stx () + ((_ (name attribute ...) field ...) + ;; These names SHOULD leak + (with-syntax ((<type>? (construct-syntax stx #'name "~a?"))) + ;; These names are manually constructed, since generated identifiers are + ;; only dependant on the source from which they orginate, which leads to + ;; multiple instances of <type> being equal for similar types... + ;; See the manual 6.10.10 Hygiene and the Top-Level + (with-syntax ((<type> (construct-syntax stx #'name "<~a>")) + (make-<type> (construct-syntax stx #'name "make-~a%"))) + #`(begin + (define-immutable-record-type <type> + (make-<type> #,@(map syntax-first #'(field ...))) + <type>? + #,@(map (field-declaration #'name) + (map syntax-first #'(field ...)))) + + ;; User-facing constructor + (define name + #,(cond ((kv-ref #'(attribute ...) constructor:) + => (lambda (constructor-builder) + #`(#,constructor-builder + ;; primitive constructor + make-<type> + ;; Type validator + (lambda #,(map syntax-first #'(field ...)) + (validator field) ...)))) + (else #`(lambda* (key: #,@(map lambda*-stx #'(field ...))) + ;; Type validators + (validator field) ... + (make-<type> #,@(map syntax-first #'(field ...))))))) + + ;; Field accessors + (build-accessor name field) ... + + ;; if printer in attribute + #,@(cond ((kv-ref #'(attribute ...) printer:) + => (lambda (printer) + (list #`(set-record-type-printer! <type> #,printer)))) + (else '())))))) + + ;; else, type name without extra attributes + #; + ((_ name field ...) + #'(define-type (name) field ...)))) diff --git a/module/hnh/util/set.scm b/module/hnh/util/set.scm new file mode 100644 index 00000000..2839a231 --- /dev/null +++ b/module/hnh/util/set.scm @@ -0,0 +1,46 @@ +(define-module (hnh util set) + :use-module (hnh util object) + :use-module (hnh util table)) + +(define-type (set) + (set-data default: (make-table))) + +(define (set-null) (set)) + +(define (set-adjoin value set) + (modify set set-data tree-put value #t)) + +(define (set-disjoin value set) + (modify set set-data tree-put value #f)) + +(define (in-set? set value) + (catch 'out-of-range + (lambda () (tree-get (set-data set) value)) + (lambda () #f))) + +(define (set-fold f done set) + (tree-fold (lambda (k v lst) + (if v + (f k done) + done)) + done set)) + +(define (set->list set) + (set-fold cons '() set)) + +(define (set-union set1 set2) + (set-fold set-adjoin set1 set2)) + +(define (set-intersection set1 set2) + (set-fold (lambda (v set) + (if (in-set? v set1) + set1 + (set-disjoin v set1))) + set1 set2)) + +(define (set-difference set1 set2) + (set-fold set-disjoin set1 set2)) + +;; (define (set-xor set1 set2)) + + 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/table.scm b/module/hnh/util/table.scm new file mode 100644 index 00000000..a57e6591 --- /dev/null +++ b/module/hnh/util/table.scm @@ -0,0 +1,108 @@ +(define-module (hnh util table) + :use-module (srfi srfi-1) + :use-module (srfi srfi-88) + :use-module (srfi srfi-9) + :use-module (srfi srfi-9 gnu) + :use-module (hnh util lens) + :use-module (hnh util object) + :export ((make-tree . table) + (tree-get . table-get) + (tree-put . table-put) + (tree-remove . table-remove) + (tree->list . table->list) + (tree? . table?) + (alist->tree . alist->table))) + +(define (symbol<? . args) + (apply string<? (map symbol->string args))) + +(define-syntax-rule (symbol< args ...) + (string< (symbol->string args) ...)) + +(define-type (tree-node) + (key type: symbol?) + value + (left type: tree? default: (tree-terminal)) + (right type: tree? default: (tree-terminal))) + +;; Type tagged null +(define-type (tree-terminal)) + +;; Wrapped for better error messages +(define (make-tree) (tree-terminal)) + +(define (tree? x) + (or (tree-node? x) + (tree-terminal? x))) + +(define (tree-put tree k v) + (cond ((tree-terminal? tree) (tree-node key: k value: v)) + ((eq? k (key tree)) (value tree v)) + (else + (modify tree (if (symbol<? k (key tree)) left right) + tree-put k v)))) + +(define (tree-get tree k) + (cond ((tree-terminal? tree) #f ; (throw 'out-of-range) + ) + ((eq? k (key tree)) (value tree)) + ((symbol<? k (key tree)) + (tree-get (left tree) k)) + (else + (tree-get (right tree) k)))) + +(define (tree-remove tree k) + (cond ((tree-terminal? tree) tree) + ((eq? k (key tree)) + (merge-trees (left tree) (right tree))) + ((symbol<? k (key tree)) + (modify tree left (lambda (t) (tree-remove t k)))) + (else + (modify tree right (lambda (t) (tree-remove t k)))))) + +(define (merge-trees a b) + ;; TODO write a better version of this + (fold (lambda (item tree) + (apply tree-put tree item)) + a + b)) + +;; in-order traversal +(define (tree->list tree) + (if (tree-terminal? tree) + '() + (append (tree->list (left tree)) + (list (cons (key tree) (value tree))) + (tree->list (right tree))))) + +;; undefined order, probably pre-order +(define (tree-map f tree) + (if (tree-terminal? tree) + '() + (tree-node key: (key tree) + value: (f (key tree) (value tree)) + left: (tree-map f (left tree)) + right: (tree-map f (right tree))))) + +;; pre-order +(define (tree-fold f init tree) + (if (tree-terminal? tree) + init + (let ((a (f (key tree) (value tree) init))) + (let ((b (tree-fold f a (left tree)))) + (tree-fold f b (right tree)))))) + +(define (alist->tree alist) + (fold (lambda (kv tree) (tree-put tree (car kv) (cdr kv))) + (tree-terminal) + alist)) + + + +(define (make-indent depth) (make-string (* 2 depth) #\space)) + +(define* (print-tree tree optional: (depth 0)) + (unless (tree-terminal? tree) + (format #t "~a- ~s: ~s~%" (make-indent depth) (key tree) (value tree)) + (print-tree (left tree) (1+ depth)) + (print-tree (right tree) (1+ depth)))) diff --git a/module/hnh/util/type.scm b/module/hnh/util/type.scm new file mode 100644 index 00000000..800834e5 --- /dev/null +++ b/module/hnh/util/type.scm @@ -0,0 +1,46 @@ +(define-module (hnh util type) + :use-module ((srfi srfi-1) :select (every)) + :export (build-validator-body + list-of pair-of + typecheck + current-procedure-name)) + +(define-syntax list-of + (syntax-rules () + ((_ variable (rule ...)) + (and (list? variable) + (every (lambda (x) (build-validator-body x (rule ...))) variable))) + ((_ variable rule) + (and (list? variable) + (every rule variable))))) + +(define-syntax-rule (pair-of variable a b) + (and (pair? variable) + (build-validator-body (car variable) a) + (build-validator-body (cdr variable) b))) + +;; DSL for specifying type predicates +;; Basically a procedure body, but the variable to test is implicit. +(define-syntax build-validator-body + (syntax-rules (and or list-of) + ((_ variable (and clauses ...)) (and (build-validator-body variable clauses) ...)) + ((_ variable (or clauses ...)) (or (build-validator-body variable clauses) ...)) + ((_ variable (proc args ...)) (proc variable args ...)) + ((_ variable proc) (proc variable)))) + +(define-syntax-rule (current-procedure-name) + ;; 1 since make-stack is at top of stack + (frame-procedure-name (stack-ref (make-stack #t) 1))) + +(define-syntax typecheck + (syntax-rules () + ((_ variable type-clause) + (let ((procedure-name (current-procedure-name))) + (typecheck variable type-clause procedure-name))) + ((_ variable type-clause procedure-name) + (unless (build-validator-body variable type-clause) + (scm-error 'wrong-type-arg procedure-name + "Invalid value for ~s. Expected ~s, got ~s" + (list (quote variable) (quote type-clause) variable) + #f))))) + 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.scm b/module/vcomponent.scm index 0f000ba5..7930bf92 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -2,12 +2,21 @@ :use-module (hnh util) :use-module (vcomponent base) :use-module (vcomponent config) - ;; :use-module ((vcomponent util instance methods) - ;; :select (make-vcomponent)) :use-module ((vcomponent util parse-cal-path) :select (parse-cal-path)) - :re-export (make-vcomponent + :re-export ( + vcomponent + set-properties + properties + children + type + prop + prop* parse-cal-path + param + ;; value + vline? + vline-parameters ;; configuration items calendar-files default-calendar)) diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index df452f62..ff2382bf 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -1,38 +1,39 @@ (define-module (vcomponent base) :use-module (hnh util) :use-module (srfi srfi-1) - :use-module (srfi srfi-9) - :use-module (srfi srfi-9 gnu) :use-module (srfi srfi-17) :use-module (srfi srfi-88) - :use-module (ice-9 hash-table) - :export (make-vline + :use-module (hnh util object) + :use-module (hnh util lens) + :use-module (hnh util table) + :use-module (hnh util uuid) + :export (vline vline? - vline-key + vline-value + key + vline-parameters vline-source - make-vcomponent + vcomponent vcomponent? children type parent + add-child - add-child! remove-child! - - delete-property! + remove-property prop* prop extract extract* - delete-parameter! - value + set-properties + + remove-parameter + ;; value param parameters properties - copy-vcomponent x-property? internal-field? - - ) ) @@ -50,163 +51,95 @@ ;;; </vcomponent> ;;; -(define-record-type <vline> - (make-vline% key value parameters) - vline? - (key vline-key) - (value get-vline-value set-vline-value!) - (parameters get-vline-parameters) - (source get-source set-source!) - ) - -(set-record-type-printer! - <vline> - (lambda (v p) - (format p "#<<vline> key: ~s value: ~s parameters: ~s>" - (vline-key v) - (get-vline-value v) - (hash-map->list list (get-vline-parameters v))))) - -(define vline-source - (make-procedure-with-setter - get-source set-source!)) - -(define* (make-vline key value optional: (ht (make-hash-table))) - (make-vline% key value ht)) - -(define-record-type <vcomponent> - (make-vcomponent% type children parent 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>" - (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* (make-vcomponent optional: (type 'VIRTUAL)) - (make-vcomponent% type '() #f (make-hash-table))) - -(define (add-child! parent child) - (set-component-children! parent (cons child (children parent))) - (set-component-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)) - (set-component-children! parent-component (delq1! child (children parent-component))) - (set-component-parent! child #f)) - -;;; TODO key=DTSTART, (date? value) => #t -;;; KRÄVER att (props vline 'VALUE) <- "DATE" -(define (set-property! component key value) - (let ((ht (get-component-properties component))) - (cond [(hashq-ref ht key #f) - => (lambda (vline) (set-vline-value! vline value))] - [else (hashq-set! ht key (make-vline key value))]))) +(define (print-vline v p) + (format p "#<<vline> key: ~s value: ~s parameters: ~s>" + (key v) + (vline-value v) + #f + ;; (hash-map->list list (get-vline-parameters v)) + )) +(define-type (vline printer: print-vline) + (key type: symbol?) + (vline-value) + (vline-parameters default: (table) type: table?) + (vline-source default: "" type: string?)) - +(define (print-vcomponent c p) + (format p "#<<vcomponent> ~a>" + (type c))) -;; vline → value -(define value - (make-procedure-with-setter - get-vline-value set-vline-value!)) -;; vcomponent x (or str symb) → vline -(define (get-prop* component prop) - (hashq-ref (get-component-properties component) - (as-symb prop))) +(define false? not) -(define (set-prop*! component key value) - (hashq-set! (get-component-properties component) - (as-symb key) value)) +(define-type (vcomponent printer: print-vcomponent) + (type type: symbol?) + (vcomponent-children + default: (table) type: table?) + (component-properties + default: (table) type: table?) + (parent default: #f type: (or false? vcomponent?))) (define prop* - (make-procedure-with-setter - get-prop* - set-prop*!)) - -(define (delete-property! component key) - (hashq-remove! (get-component-properties component) - (as-symb key))) + (case-lambda + ((object key) + (table-get (component-properties object) key)) + ((object key value) + (component-properties object + (table-put (component-properties object) key value))))) + +(define (children c) + (map cdr (table->list (vcomponent-children c)))) + +(define (add-child parent* child) + (modify parent* vcomponent-children + (lambda (table) + (let ((child + (if (prop child 'UID) + child + (prop child 'UID (uuid))))) + (table-put table + (as-symb (prop child 'UID)) + (parent child parent*)))))) + -;; vcomponent x (or str symb) → value -(define (get-prop component key) - (let ((props (get-prop* component key))) - (cond [(not props) #f] - [(list? props) (map value props)] - [else (value props)]))) - -;; TODO do something sensible here -(define (set-prop! component key value) - (set-property! component (as-symb key) value)) - +;; (define prop (compose-lens vline-value prop*)) (define prop - (make-procedure-with-setter - get-prop - set-prop!)) - + (case-lambda + ((comp key) (and=> (prop* comp key) vline-value)) + ((comp k v) + (cond ((prop* comp k) + => (lambda (vline) + (prop* comp k (vline-value vline v)))) + (else + (prop* comp k (vline key: k vline-value: v))))))) + +(define (remove-property component key) + (component-properties component + (table-remove (component-properties component) key))) (define param - (make-procedure-with-setter - (lambda (vline parameter-key) - ;; TODO `list' is a hack since a bit to much code depends - ;; on prop always returning a list of values. - (and=> (hashq-ref (get-vline-parameters vline) - (as-symb parameter-key)) - list)) - (lambda (vline parameter-key val) - (hashq-set! (get-vline-parameters vline) - (as-symb parameter-key) val)))) + ;; TODO list? + (case-lambda ((vline key) (and=> (table-get (vline-parameters vline) key) list)) + ((vline k v) (vline-parameters + vline + (table-put (vline-parameters vline) k v))))) - -(define (delete-parameter! vline parameter-key) - (hashq-remove! (get-vline-parameters vline) - (as-symb parameter-key))) +(define (remove-parameter vline key) + (vline-parameters vline + (table-remove (vline-parameters vline) key))) ;; Returns the parameters of a property as an assoc list. ;; @code{(map car <>)} leads to available parameters. (define (parameters vline) - (hash-map->list list (get-vline-parameters vline))) + (map (compose list car+cdr) + (table->list (vline-parameters vline)))) (define (properties component) - (hash-map->list cons (get-component-properties component))) - -(define (copy-vline vline) - (make-vline (vline-key vline) - (get-vline-value vline) - ;; TODO deep-copy on parameters? - (get-vline-parameters vline))) - -(define (copy-vcomponent component) - (make-vcomponent% - (type component) - ;; TODO deep copy? - (children component) - (parent component) - ;; properties - (alist->hashq-table - (hash-map->list (lambda (key value) - (cons key (if (list? value) - (map copy-vline value) - (copy-vline value)))) - (get-component-properties component))))) + (map (compose list car+cdr) + (table->list (component-properties component)))) (define (extract field) (lambda (e) (prop e field))) @@ -221,3 +154,10 @@ (string=? prefix (string-take-to (symbol->string symbol) (string-length prefix)))) + + +(define (set-properties component . pairs) + ;; (format (current-error-port) "component: ~s, pairs: ~s~%" component pairs) + (fold (lambda (pair component) (prop component (car pair) (cdr pair))) + component + pairs)) diff --git a/module/vcomponent/create.scm b/module/vcomponent/create.scm new file mode 100644 index 00000000..5704b0f1 --- /dev/null +++ b/module/vcomponent/create.scm @@ -0,0 +1,104 @@ +(define-module (vcomponent create) + :use-module ((vcomponent base) :prefix vcs-) + :use-module ((vcomponent base) + :select (vline key add-child prop* vline?)) + :use-module ((srfi srfi-1) :select (fold 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 ((hnh util table) :select (alist->table)) + :use-module ((hnh util) :select (swap init+last 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 (with-parameters . args) + (define-values (parameters value) + (init+last args)) + (vline + key: 'PLACEHOLDER + vline-value: value + vline-parameters: + (-> parameters + kvlist->assq + upcase-keys + alist->table))) + + + +(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-values (attrs children) + (cond ((null? attrs*) (values '() '())) + ((even? (length attrs*)) (values attrs* '())) + (else (init+last attrs*)))) + ;; TODO add-child requires a UID on the child + ;; Possibly just genenerate one here if missing + (fold (swap add-child) + (fold (lambda (pair component) + (let ((k value (car+cdr pair))) + (prop* component k + (cond ((vline? value) + (key value k)) + ((list-value? value) + (map (lambda (value) (vline key: k vline-value: value)) + (list-value-value value))) + (else (vline key: k vline-value: value)))))) + (vcs-vcomponent + type: type) + (upcase-keys (kvlist->assq attrs))) + children)) + +(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..5d487028 --- /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 (vcomponent type: '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..9320c44e --- /dev/null +++ b/module/vcomponent/data-stores/vdir.scm @@ -0,0 +1,89 @@ +(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)) + :use-module (ice-9 rdelim) + :use-module (srfi srfi-1) + :use-module (vcomponent base) + :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 + (fold (swap add-child) + (set-properties (vcomponent type: 'VCALENDAR) + (cons 'NAME (get-attribute (path this) "displayname")) + (cons 'COLOR (get-attribute (path this) "color" "#FFFFFF"))) + (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))) + (each cal children + (lambda (child) + (prop child '-X-HNH-FILENAME file)))) + 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) + (fold (swap add-child) + (set-properties (vcomponent type: 'VCALENDAR) + (cons 'VERSION "2.0") + (cons 'PRODID (prodid)) + (cons 'CALSCALE "GREGORIAN")) + vcomponents)) + +(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/data-stores/virtual.scm b/module/vcomponent/data-stores/virtual.scm new file mode 100644 index 00000000..03c115f5 --- /dev/null +++ b/module/vcomponent/data-stores/virtual.scm @@ -0,0 +1,22 @@ +(define-module (vcomponent data-stores virtual) + :use-module (oop goops) + :use-module ((srfi srfi-88) :select ()) + :use-module (vcomponent data-stores common) + :export (make-file-store)) + +(define-class <virtual-data-store> (<calendar-data-store>) + ) + +(define-method (get-all (this <virtual-data-store>)) + #f) + +(define-method (get-by-uid (this <virtual-data-store>) + (uid <string>)) + #f) + + +(define-method (color (this <virtual-data-store>)) + "") + +(define-method (displayname (this <virtual-data-store>)) + "Virtual Calendar") diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm index 440ec5fd..5aa6f4ab 100644 --- a/module/vcomponent/datetime.scm +++ b/module/vcomponent/datetime.scm @@ -227,75 +227,89 @@ Event must have the DTSTART and DTEND protperty set." ;; event is for limiter (define (zoneinfo->vtimezone zoneinfo zone-name event) - (define vtimezone (make-vcomponent 'VTIMEZONE)) (define last-until (datetime date: (date month: 1 day: 1))) (define last-offset (timespec-zero)) - (set! (prop vtimezone 'TZID) zone-name) - - (for zone-entry in (filter (relevant-zone-entry? event) (get-zone zoneinfo zone-name)) - (cond [(zone-entry-rule zone-entry) timespec? - => (lambda (inline-rule) - (let ((component (make-vcomponent 'DAYLIGHT)) - (new-timespec (timespec-add - (zone-entry-stdoff zone-entry) - inline-rule))) - (set! (prop component 'DTSTART) last-until - (prop component 'TZOFFSETFROM) last-offset - (prop component 'TZOFFSETTO) new-timespec - (prop component 'TZNAME) (zone-entry-format zone-entry) - last-until (zone-entry-until zone-entry) - last-offset new-timespec) - (add-child! vtimezone component)))] - - [(zone-entry-rule zone-entry) - => (lambda (rule-name) - (map (lambda (rule) - (let ((component (make-vcomponent - ;; NOTE the zoneinfo database doesn't - ;; come with information if a given - ;; rule is in standard or daylight time, - ;; since that's mostly nonsencical - ;; (e.g. war- and peacetime). - ;; But the ical standard requires that, - ;; so this is a fair compromize. - (if (string-null? (rule-letters rule)) - 'STANDARD 'DAYLIGHT))) - (new-timespec (timespec-add - (zone-entry-stdoff zone-entry) - (rule-save rule)))) - - (set! (prop component 'DTSTART) (rule->dtstart rule) - (prop component 'TZOFFSETFROM) last-offset - (prop component 'TZOFFSETTO) new-timespec - (prop component 'TZNAME) (zone-format - (zone-entry-format zone-entry) - (rule-letters rule)) - ;; NOTE this can both be a number or the - ;; symbol 'maximum - last-until (zone-entry-until zone-entry) - last-offset new-timespec) - - (awhen (rule->rrule rule) - (set! (prop component 'RRULE) it)) - - (add-child! 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. - ;; - ;; Both these are filtered here. - (filter - (relevant-zone-rule? event) - (get-rule zoneinfo rule-name))))] - - [else ; no rule - (let ((component (make-vcomponent 'STANDARD))) - ;; DTSTART MUST be a datetime in local time - (set! (prop component 'DTSTART) last-until - (prop component 'TZOFFSETFROM) last-offset - (prop component 'TZOFFSETTO) (zone-entry-stdoff zone-entry) - (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))])) - vtimezone) + + (fold (lambda (zone-entry vtimezone) + (cond [(zone-entry-rule zone-entry) timespec? + => (lambda (inline-rule) + (let ((component (vcomponent type: 'DAYLIGHT)) + (new-timespec (timespec-add + (zone-entry-stdoff zone-entry) + inline-rule))) + (let ((component + (set-properties + component + (cons 'DTSTART last-until) + (cons 'TZOFFSETFROM last-offset) + (cons 'TZOFFSETTO new-timespec) + (cons 'TZNAME (zone-entry-format zone-entry))))) + (set! last-until (zone-entry-until zone-entry) + last-offset new-timespec) + (add-child vtimezone component))))] + + [(zone-entry-rule zone-entry) + => (lambda (rule-name) + (fold (lambda (rule vtimezone) + (let ((component (vcomponent + type: + ;; NOTE the zoneinfo database doesn't + ;; come with information if a given + ;; rule is in standard or daylight time, + ;; since that's mostly nonsencical + ;; (e.g. war- and peacetime). + ;; But the ical standard requires that, + ;; so this is a fair compromize. + (if (string-null? (rule-letters rule)) + 'STANDARD 'DAYLIGHT))) + (new-timespec (timespec-add + (zone-entry-stdoff zone-entry) + (rule-save rule)))) + + (let ((component + (set-properties + component + (cons 'DTSTART (rule->dtstart rule)) + (cons 'TZOFFSETFROM last-offset) + (cons 'TZOFFSETTO new-timespec) + (cons 'TZNAME (zone-format + (zone-entry-format zone-entry) + (rule-letters rule)))))) + + (set! ;; NOTE this can both be a number or the + ;; symbol 'maximum + last-until (zone-entry-until zone-entry) + last-offset new-timespec) + + (add-child + vtimezone + (cond ((rule->rrule rule) + => (lambda (it) (prop component 'RRULE it))) + (else component)))))) + vtimezone + ;; 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. + ;; + ;; Both these are filtered here. + (filter + (relevant-zone-rule? event) + (get-rule zoneinfo rule-name))))] + + [else ; no rule + ;; DTSTART MUST be a datetime in local time + (let ((component + (set-properties + (vcomponent type: 'STANDARD) + (cons 'DTSTART last-until) + (cons 'TZOFFSETFROM last-offset) + (cons 'TZOFFSETTO (zone-entry-stdoff zone-entry)) + (cons 'TZNAME (zone-entry-format zone-entry))))) + (set! last-until (zone-entry-until zone-entry) + last-offset (zone-entry-stdoff zone-entry)) + (add-child vtimezone component)) + ]) + ) + (prop (vcomponent type: 'VTIMEZONE) 'TZID zone-name) + (filter (relevant-zone-entry? event) (get-zone zoneinfo zone-name)) + )) diff --git a/module/vcomponent/datetime/output.scm b/module/vcomponent/datetime/output.scm index 736db0a4..1226fc44 100644 --- a/module/vcomponent/datetime/output.scm +++ b/module/vcomponent/datetime/output.scm @@ -73,7 +73,7 @@ (let ((s (prop ev 'DTSTART)) (e (prop ev 'DTEND))) (if e - (let ((fmt-str (if (date= (get-date s) (get-date e)) + (let ((fmt-str (if (date= (datetime-date s) (datetime-date e)) (G_ "~H:~M") ;; Note the non-breaking space (G_ "~Y-~m-~d ~H:~M")))) 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 4d37dff6..5fa004bb 100644 --- a/module/vcomponent/formats/ical/output.scm +++ b/module/vcomponent/formats/ical/output.scm @@ -14,8 +14,10 @@ :use-module (vcomponent) :use-module (vcomponent datetime) :use-module (vcomponent geo) - :use-module (vcomponent formats ical types) + :use-module ((vcomponent formats ical types) + :select (escape-chars get-writer)) :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 +26,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. @@ -101,11 +99,12 @@ (catch #t #; 'wrong-type-arg (lambda () - (writer ((@@ (vcomponent base) get-vline-parameters) vline) - (value vline))) + (writer + (vline-parameters vline) + (vline-value vline))) (lambda (err caller fmt args call-args) (define fallback-string - (with-output-to-string (lambda () (display value)))) + (with-output-to-string (lambda () (display (vline-value vline))))) (warning "key = ~a, caller = ~s, call-args = ~s~%~k~%Falling back to ~s" key caller call-args fmt args fallback-string) @@ -129,11 +128,10 @@ (define (vline->string vline) - (define key (vline-key vline)) (ical-line-fold ;; Expected output: key;p1=v;p3=10:value (string-append - (symbol->string key) + (symbol->string (key vline)) (string-concatenate (map (match-lambda [(? (compose internal-field? car)) ""] @@ -143,7 +141,7 @@ (string-join (map (compose escape-chars ->string) values) "," 'infix))]) (parameters vline))) - ":" (value-format key vline)))) + ":" (value-format (key vline) vline)))) (define (component->ical-string component) (format #t "BEGIN:~a\r\n" (type component)) diff --git a/module/vcomponent/formats/ical/parse.scm b/module/vcomponent/formats/ical/parse.scm index 252a155e..38257fba 100644 --- a/module/vcomponent/formats/ical/parse.scm +++ b/module/vcomponent/formats/ical/parse.scm @@ -1,6 +1,7 @@ (define-module (vcomponent formats ical parse) :use-module ((ice-9 rdelim) :select (read-line)) :use-module (ice-9 format) + :use-module (ice-9 curried-definitions) :use-module (hnh util exceptions) :use-module (hnh util) :use-module (datetime) @@ -12,6 +13,8 @@ :use-module (vcomponent geo) :use-module (vcomponent formats common types) :use-module (calp translation) + :use-module (hnh util lens) + :use-module (hnh util table) :export (parse-calendar)) ;;; TODO a few translated strings here contain explicit newlines. Check if that @@ -139,7 +142,7 @@ (define (build-vline key value params) (let ((parser (cond - [(and=> (hashq-ref params 'VALUE) string->symbol) => get-parser] + [(and=> (table-get params 'VALUE) string->symbol) => get-parser] [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID RDATE CREATED DTSTAMP LAST-MODIFIED @@ -246,9 +249,9 @@ (let ((parsed (parser params value))) (if (list? parsed) (apply values - (map (lambda (p) (make-vline key p params)) + (map (lambda (p) (vline key: key vline-value: p vline-parameters: params)) parsed)) - (make-vline key parsed params))))) + (vline key: key vline-value: parsed vline-parameters: params))))) ;; (parse-itemline '("DTEND" "20200407T130000")) ;; => DTEND @@ -256,17 +259,45 @@ ;; => #<hash-table 7f76b5f82a60 0/31> (define (parse-itemline itemline) (define key (string->symbol (car itemline))) - (define parameters (make-hash-table)) - (let loop ((rem (cdr itemline))) - (if (null? (cdr rem)) - (values key (car rem) parameters ) - (let* ((kv (car rem)) - (idx (string-index kv #\=))) - ;; TODO lists in parameters - (hashq-set! parameters (string->symbol (substring kv 0 idx)) - (substring kv (1+ idx))) - (loop (cdr rem)))))) - + ;; (define parameters (make-hash-table)) + (define-values (parameters value) (init+last (cdr itemline))) + (values + key value + (fold (lambda (parameter table) + (let ((idx (string-index parameter #\=))) + ;; TODO lists in parameters + (table-put table (string->symbol (substring parameter 0 idx)) + (substring parameter (1+ idx))))) + (table) + parameters))) + +(define ((warning-handler-proc token) fmt . args) + (let ((linedata (get-metadata token))) + (format + #f + ;; arguments: + ;; linedata + ;; ~? + ;; source line + ;; source file + (G_ "WARNING parse error around ~a + ~? + line ~a ~a~%") + (get-string linedata) + fmt args + (get-line linedata) + (get-file linedata) + ))) + +;;; Property keys which are allowed multiple times +(define repeating-properties + '(ATTACH ATTENDEE CATEGORIES + COMMENT CONTACT EXDATE + REQUEST-STATUS RELATED-TO + RESOURCES RDATE + ;; x-prop + ;; iana-prop + )) ;; (list <tokens>) → <vcomponent> (define (parse lst) @@ -274,69 +305,53 @@ (stack '())) (if (null? lst) stack - (let* ((head* (car lst)) - (head (get-data head*))) + (let* ((token (car lst)) + (head (get-data token))) (catch 'parse-error (lambda () - (parameterize - ((warning-handler - (lambda (fmt . args) - (let ((linedata (get-metadata head*))) - (format - #f - ;; arguments: - ;; linedata - ;; ~? - ;; source line - ;; source file - (G_ "WARNING parse error around ~a - ~? - line ~a ~a~%") - (get-string linedata) - fmt args - (get-line linedata) - (get-file linedata) - ))))) - (cond [(string=? "BEGIN" (car head)) - (loop (cdr lst) - (cons (make-vcomponent (string->symbol (cadr head))) - stack))] - [(string=? "END" (car head)) - (loop (cdr lst) - (if (null? (cdr stack)) - ;; return - (car stack) - (begin (add-child! (cadr stack) (car stack)) - (cdr stack))))] - [else - (let ((key value params (parse-itemline head))) - (call-with-values (lambda () (build-vline key value params)) - (lambda vlines - (for vline in vlines - (define key (vline-key vline)) - - (set! (vline-source vline) - (get-metadata head*)) + (parameterize ((warning-handler (warning-handler-proc token))) + (cond [(string=? "BEGIN" (car head)) + (format (current-error-port) "BEGIN ~s~%" (cadr head)) + (loop (cdr lst) + (cons (vcomponent type: (string->symbol (cadr head))) + stack))] + [(string=? "END" (car head)) + (format (current-error-port) "END ~s~%" (cadr head)) + (loop (cdr lst) + (if (null? (cdr stack)) + ;; return + stack + (cons (add-child (cadr stack) (car stack)) + (cddr stack))))] + [else + (let ((k value params (parse-itemline head))) + (loop (cdr lst) + (let (((values . vlines) (build-vline k value params))) + ;; TODO + ;; (set! (vline-source vline) + ;; (get-metadata token)) ;; See RFC 5545 p.53 for list of all repeating types ;; (for vcomponent) - ;; TODO templetize this, and allow users to set which types are list types, but also validate this upon creation (elsewhere) - (if (memv key '(ATTACH ATTENDEE CATEGORIES - COMMENT CONTACT EXDATE - REQUEST-STATUS RELATED-TO - RESOURCES RDATE - ;; x-prop - ;; iana-prop - )) - (aif (prop* (car stack) key) - (set! (prop* (car stack) key) (cons vline it)) - (set! (prop* (car stack) key) (list vline))) - ;; else - (set! (prop* (car stack) key) vline)))))) - - (loop (cdr lst) stack)]))) + ;; TODO templetize this, and allow users to + ;; set which types are list types, but also + ;; validate this upon creation (elsewhere). + (fold (lambda (vline stack) + (modify stack car* + (lambda (comp) + (format (current-error-port) + " stack=~s, comp=~s~%" + stack comp) + (if (memv (key vline) repeating-properties) + (aif (prop* comp (key vline)) + (prop* comp (key vline) (cons vline it)) + (prop* comp (key vline) (list vline))) + ;; else + (prop* comp (key vline) vline))))) + stack vlines))))]))) + (lambda (err proc fmt fmt-args data) - (let ((linedata (get-metadata head*))) + (let ((linedata (get-metadata token))) (display (format #f ;; arguments @@ -353,7 +368,10 @@ (get-line linedata) (get-file linedata)) (current-error-port)) - (let ((key value params (parse-itemline head))) - (set! (prop* (car stack) key) - (make-vline key value params)) - (loop (cdr lst) stack))))))))) + (let ((k value params (parse-itemline head))) + (loop (cdr lst) + (modify stack car* + (lambda (c) (prop* c key + (vline key: k + vline-value: value + vline-parameters: params))))))))))))) diff --git a/module/vcomponent/formats/ical/types.scm b/module/vcomponent/formats/ical/types.scm index 768f5098..c5259f0d 100644 --- a/module/vcomponent/formats/ical/types.scm +++ b/module/vcomponent/formats/ical/types.scm @@ -2,6 +2,7 @@ (define-module (vcomponent formats ical types) :use-module (hnh util) :use-module (hnh util exceptions) + :use-module (hnh util table) :use-module (base64) :use-module (datetime) :use-module (datetime timespec) @@ -23,7 +24,8 @@ ;; NOTE We really should output TZID from param here, but ;; we first need to change so these writers can output ;; parameters. - (datetime->string (hashq-ref param '-X-HNH-ORIGINAL value) + (datetime->string (or (table-get param '-X-HNH-ORIGINAL) + value) "~Y~m~dT~H~M~S~Z")) (define (write-duration _ value) 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 4e21d4d0..7f1439ae 100644 --- a/module/vcomponent/formats/vdir/parse.scm +++ b/module/vcomponent/formats/vdir/parse.scm @@ -44,13 +44,14 @@ (partition (lambda (e) (eq? 'VEVENT (type e))) (children item))) - (unless (eq? 'VCALENDAR (type item)) (scm-error 'misc-error "parse-vdir" "Unexepected top level component. Expected VCALENDAR, got ~a. In file ~s" (list (type item) (prop item '-X-HNH-FILENAME)) #f)) + ;; TODO + #; (for child in (children item) (set! (prop child '-X-HNH-FILENAME) (prop (parent child) '-X-HNH-FILENAME))) @@ -65,8 +66,9 @@ ;; the standard. Section 3.8.4.4. (case (length events) [(0) (warning (G_ "No events in component~%~a") - (prop item '-X-HNH-FILENAME))] - [(1) (add-child! calendar (car events))] + (prop item '-X-HNH-FILENAME)) + calendar] + [(1) (add-child calendar (car events))] ;; two or more [else @@ -93,35 +95,36 @@ (car events))) (rest (delete head events eq?))) - (set! (prop head '-X-HNH-ALTERNATIVES) - (alist->hash-table - (map cons - ;; head is added back to the collection to simplify - ;; generation of recurrences. The recurrence - ;; generation assumes that the base event either - ;; contains an RRULE property, OR is in the - ;; -X-HNH-ALTERNATIVES set. This might produce - ;; duplicates, since the base event might also - ;; get included through an RRULE. This however - ;; is almost a non-problem, since RDATES and RRULES - ;; can already produce duplicates, meaning that - ;; we need to filter duplicates either way. - (map (extract 'RECURRENCE-ID) (cons head rest)) - (cons head rest)))) - (add-child! calendar head))]) + (add-child + calendar + ;; TODO this is really ugly + (prop head '-X-HNH-ALTERNATIVES + (alist->hash-table + (map cons + ;; head is added back to the collection to simplify + ;; generation of recurrences. The recurrence + ;; generation assumes that the base event either + ;; contains an RRULE property, OR is in the + ;; -X-HNH-ALTERNATIVES set. This might produce + ;; duplicates, since the base event might also + ;; get included through an RRULE. This however + ;; is almost a non-problem, since RDATES and RRULES + ;; can already produce duplicates, meaning that + ;; we need to filter duplicates either way. + (map (extract 'RECURRENCE-ID) (cons head rest)) + (cons head rest))))))]) ;; return calendar) - (make-vcomponent) + (vcomponent type: 'VIRTUAL) (map #; (@ (ice-9 threads) par-map) (lambda (fname) (let ((fullname (path-append path fname))) - (let ((cal (call-with-input-file fullname - parse-calendar))) - (set! (prop cal 'COLOR) color - (prop cal 'NAME) name - (prop cal '-X-HNH-FILENAME) fullname) - cal))) + (set-properties (call-with-input-file fullname + parse-calendar) + (cons 'COLOR color) + (cons 'NAME name) + (cons '-X-HNH-FILENAME fullname)))) (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) (string= "ics" (string-take-right s 3))))))))) diff --git a/module/vcomponent/formats/vdir/save-delete.scm b/module/vcomponent/formats/vdir/save-delete.scm index ab1985b6..d096405e 100644 --- a/module/vcomponent/formats/vdir/save-delete.scm +++ b/module/vcomponent/formats/vdir/save-delete.scm @@ -61,4 +61,4 @@ (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 8e92b280..7cf8c591 100644 --- a/module/vcomponent/formats/xcal/output.scm +++ b/module/vcomponent/formats/xcal/output.scm @@ -8,28 +8,31 @@ :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)) (define (vline->value-tag vline) - (define key (vline-key vline)) + (define k (key vline)) (define writer (cond [(and=> (param vline 'VALUE) (compose string->symbol car)) => get-writer] - [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID + [(memv k '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID CREATED DTSTAMP LAST-MODIFIED ACKNOWLEDGED EXDATE)) (get-writer 'DATE-TIME)] - [(memv key '(TRIGGER DURATION)) + [(memv k '(TRIGGER DURATION)) (get-writer 'DURATION)] - [(memv key '(FREEBUSY)) + [(memv k '(FREEBUSY)) (get-writer 'PERIOD)] - [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION + [(memv k '(CALSCALE METHOD PRODID COMMENT DESCRIPTION LOCATION SUMMARY TZID TZNAME CONTACT RELATED-TO UID @@ -38,69 +41,69 @@ VERSION)) (get-writer 'TEXT)] - [(memv key '(TRANSP + [(memv k '(TRANSP CLASS PARTSTAT STATUS ACTION)) (lambda (p v) ((get-writer 'TEXT) p (symbol->string v)))] - [(memv key '(TZOFFSETFROM TZOFFSETTO)) + [(memv k '(TZOFFSETFROM TZOFFSETTO)) (get-writer 'UTC-OFFSET)] - [(memv key '(ATTACH TZURL URL)) + [(memv k '(ATTACH TZURL URL)) (get-writer 'URI)] - [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) + [(memv k '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) (get-writer 'INTEGER)] - [(memv key '(GEO)) + [(memv k '(GEO)) (lambda (_ v) - `(geo + `(,(xml xcal 'geo) (latitude ,(geo-latitude v)) (longitude ,(geo-longitude v))))] - [(memv key '(RRULE)) + [(memv k '(RRULE)) (get-writer 'RECUR)] - [(memv key '(ORGANIZER ATTENDEE)) + [(memv k '(ORGANIZER ATTENDEE)) (get-writer 'CAL-ADDRESS)] - [(x-property? key) + [(x-property? k) (get-writer 'TEXT)] [else - (warning (G_ "Unknown key ~a") key) + (warning (G_ "Unknown key ~a") k) (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 , ... ) (define (parameters-tag parameters) (define outparams (filter-map - (lambda (x) (apply property->value-tag x)) + (lambda (x) (property->value-tag x)) 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 @@ -108,27 +111,33 @@ [(? (compose internal-field? car)) #f] [(key vlines ...) + (format (current-error-port) "vlines: ~s~%" vlines) (remove null? - `(,(downcase-symbol key) + `(,(xml xcal (downcase-symbol key)) ,(parameters-tag (reduce assq-merge - '() (map parameters vlines))) + '() + (map parameters vlines))) ,@(for vline in vlines (vline->value-tag vline))))] [(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 0e638d36..5ae1b928 100644 --- a/module/vcomponent/formats/xcal/parse.scm +++ b/module/vcomponent/formats/xcal/parse.scm @@ -3,18 +3,24 @@ :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) + :use-module (hnh util table) :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 +31,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))] @@ -96,35 +102,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,16 +144,20 @@ (define (handle-parameters parameters) - (define ht (make-hash-table)) + ;; (assert (element-matches? (xml xcal 'parameters) + ;; parameters)) - (for param in parameters - (match param - [(ptag (ptype pvalue ...) ...) - ;; TODO parameter type (rfc6321 3.5.) + (fold (lambda (param table) + (define ptag (xml-element-tagname (car param))) + ;; (define-values (ptype pvalue) (car+cdr cdr)) ;; TODO multi-valued parameters!!! - (hashq-set! ht (symbol-upcase ptag) - (car (concatenate pvalue)))])) - ht) + (define-values (pytpe pvalue) (car+cdr (cadr param))) + ;; TODO parameter type (rfc6321 3.5.) + ;; TODO namespaces + (table-put table (symbol-upcase ptag) + (concatenate pvalue))) + (table) + (cdr parameters))) (define* (parse-enum str enum optional: (allow-other #t)) (let ((symb (string->symbol str))) @@ -153,7 +167,8 @@ ;; 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 @@ -174,6 +189,51 @@ 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))) + + (fold (lambda (typetag component) + (define type (xml-element-tagname (car typetag))) + ;; TODO multi valued data + (define raw-value (cdr typetag)) + (define vline* + (vline type: tag* + value: (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: parameters)) + (if (memv tag* '(ATTACH ATTENDEE CATEGORIES + COMMENT CONTACT EXDATE + REQUEST-STATUS RELATED-TO + RESOURCES RDATE + ;; x-prop + ;; iana-prop + )) + (aif (prop* component tag*) + (prop* component tag* (cons vline* it)) + (prop* component tag* (list vline*))) + (prop* component tag* vline*))) + component data)) + ;; Note ;; This doesn't verify the inter-field validity of the object, ;; meaning that value(DTSTART) == DATE and value(DTEND) == DATE-TIME @@ -181,83 +241,30 @@ ;; TODO ;; since we are feeding user input into this it really should be fixed. (define (sxcal->vcomponent sxcal) - (define type (symbol-upcase (car sxcal))) - (define component (make-vcomponent type)) - - (awhen (assoc-ref sxcal 'properties) - ;; 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)) - )))]))) - - ;; children - (awhen (assoc-ref sxcal 'components) - (for child in (map sxcal->vcomponent it) - (add-child! component child))) - - component) + + ;; 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))) + + (let ((component + (aif (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 + (fold swap handle-single-property + (vcomponent type: type) (cdr it)) + (vcomponent type: type)))) + + ;; children + (aif (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). + (fold (swap add-child) + component + (map sxcal->vcomponent + (reverse (cdr it)))) + component))) diff --git a/module/vcomponent/formats/xcal/types.scm b/module/vcomponent/formats/xcal/types.scm index 024ca61a..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) diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index 07305647..936c2631 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -119,7 +119,7 @@ (branching-fold (lambda (rule dt) (let* ((key value (car+cdr rule)) - (d (if (date? dt) dt (get-date dt))) + (d (if (date? dt) dt (datetime-date dt))) ;; NOTE It's proably an error to give BYHOUR, BYMINUTE, and BYSECOND ;; rules for a date object. This doesn't warn if those are given, but ;; instead silently discards them. @@ -128,8 +128,8 @@ (if (date? dt) (if (date? o) o d) (if (date? o) - (datetime date: o time: t tz: (get-timezone dt)) - (datetime date: d time: o tz: (get-timezone dt))))))) + (datetime date: o time: t tz: (tz dt)) + (datetime date: d time: o tz: (tz dt))))))) (case key [(BYMONTH) (if (and (eq? 'YEARLY (freq rrule)) @@ -141,11 +141,11 @@ (concatenate (map (lambda (wday) (all-wday-in-month - wday (start-of-month (set (month d) value)))) + wday (start-of-month (month d value)))) (map cdr (byday rrule))))) ;; else - (to-dt (set (month d) value)))] + (to-dt (month d value)))] [(BYDAY) (let* ((offset value (car+cdr value))) @@ -201,12 +201,12 @@ [(BYYEARDAY) (to-dt (date+ (start-of-year d) (date day: (1- value))))] [(BYMONTHDAY) - (to-dt (set (day d) + (to-dt (day d (if (positive? value) value (+ 1 value (days-in-month d)))))] - [(BYHOUR) (to-dt (set (hour t) value))] - [(BYMINUTE) (to-dt (set (minute t) value))] - [(BYSECOND) (to-dt (set (second t) value))] + [(BYHOUR) (to-dt (hour t value))] + [(BYMINUTE) (to-dt (minute t value))] + [(BYSECOND) (to-dt (second t value))] [else (scm-error 'wrong-type-arg "update" "Unrecognized by-extender ~s" key #f)]))) @@ -254,7 +254,7 @@ (extend-recurrence-set rrule (if (date? base-date) - (date+ base-date (get-date (make-date-increment rrule))) + (date+ base-date (datetime-date (make-date-increment rrule))) (datetime+ base-date (make-date-increment rrule)))))) (define ((month-mod d) value) @@ -273,7 +273,7 @@ #t (let ((key values (car+cdr (car remaining))) (t (as-time dt)) - (d (if (date? dt) dt (get-date dt)))) + (d (if (date? dt) dt (datetime-date dt)))) (and (case key [(BYMONTH) (memv (month d) values)] [(BYMONTHDAY) (memv (day d) (map (month-mod d) values))] @@ -339,10 +339,10 @@ (rrule-instances-raw rrule (prop event 'DTSTART)))) (else stream-null))) (rdates - (cond ((prop* event 'RDATE) => (lambda (v) (map value v))) + (cond ((prop* event 'RDATE) => (lambda (v) (map vline-value v))) (else '()))) (exdates - (cond ((prop* event 'EXDATE) => (lambda (v) (map value v))) + (cond ((prop* event 'EXDATE) => (lambda (v) (map vline-value v))) (else #f)))) (let ((items (interleave-streams @@ -418,21 +418,19 @@ => (lambda (ht) (aif (hash-ref ht dt) it ; RECURRENCE-ID objects come with their own DTEND - (let ((ev (copy-vcomponent base-event))) - (set! (prop ev 'DTSTART) dt) - (when duration ; (and (not (prop ev 'DTEND)) duration) - ;; p. 123 (3.8.5.3 Recurrence Rule) - ;; specifies that the DTEND should be updated to match how the - ;; initial dtend related to the initial DTSTART. It also notes - ;; that an event of 1 day in length might be longer or shorter - ;; than 24h depending on timezone shifts. - (set! (prop ev 'DTEND) (get-endtime dt duration))) - ev)))) + (let ((ev (prop base-event 'DTSTART dt))) + (if duration ; (and (not (prop ev 'DTEND)) duration) + ;; p. 123 (3.8.5.3 Recurrence Rule) + ;; specifies that the DTEND should be updated to match how the + ;; initial dtend related to the initial DTSTART. It also notes + ;; that an event of 1 day in length might be longer or shorter + ;; than 24h depending on timezone shifts. + (prop ev 'DTEND (get-endtime dt duration)) + ev))))) (else - (let ((ev (copy-vcomponent base-event))) - (set! (prop ev 'DTSTART) dt) - (when duration - (set! (prop ev 'DTEND) (get-endtime dt duration))) - ev)))) + (let ((ev (prop base-event 'DTSTART dt))) + (if duration + (prop ev 'DTEND (get-endtime dt duration)) + ev))))) rrule-stream)) diff --git a/module/vcomponent/util/instance/methods.scm b/module/vcomponent/util/instance/methods.scm index 5651b265..fef83958 100644 --- a/module/vcomponent/util/instance/methods.scm +++ b/module/vcomponent/util/instance/methods.scm @@ -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))) @@ -184,7 +184,7 @@ ;; remove old instance of event from runtime (remove-event this old-event) - (remove-child! old-calendar old-event) + (abandon! old-calendar old-event) ;; Add new event to runtime, ;; MUST be done after since the two events SHOULD share UID. diff --git a/module/vcomponent/util/parse-cal-path.scm b/module/vcomponent/util/parse-cal-path.scm index 24eee04e..33dbd0cc 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!)) @@ -17,24 +19,21 @@ (define cal (case (stat:type st) [(regular) - (let ((comp (call-with-input-file path parse-calendar))) - (set! (prop comp '-X-HNH-SOURCETYPE) 'file) - comp) ] + (prop (call-with-input-file path parse-calendar) + '-X-HNH-SOURCETYPE 'file)] [(directory) (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)] + (set-properties (parse-vdir path) + (cons '-X-HNH-SOURCETYPE 'vdir) + (cons '-X-HNH-DIRECTORY path))] [(block-special char-special fifo socket unknown symlink) => (lambda (t) (scm-error 'misc-error "parse-cal-path" (G_ "Can't parse file of type ~s") (list t) #f))])) - (unless (prop cal "NAME") - (set! (prop cal "NAME") - (or (prop cal "X-WR-CALNAME") - (string-append "[" (basename path) "]")))) - - cal) + (if (prop cal 'NAME) + cal + (prop cal 'NAME + (or (prop cal 'X-WR-CALNAME) + (string-append "[" (basename path) "]"))))) 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 feba3f19..a36efaef 100644 --- a/module/web/http/make-routes.scm +++ b/module/web/http/make-routes.scm @@ -145,6 +145,8 @@ ;; 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)) @@ -164,13 +166,14 @@ ;; When content-type is application/x-www-form-urlencoded, ;; decode them, and add it to the argument list - (let ((content-type (assoc-ref r:headers 'content-type))) - (when content-type - (let ((type args (car+cdr content-type))) - (when (eq? type 'application/x-www-form-urlencoded) - (let ((encoding (or (assoc-ref args 'encoding) "UTF-8"))) - (parse-query (bytevector->string body encoding) - encoding))))))))))) + (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))))))))))))) (case-lambda ((headers body new-state) (values headers body new-state)) ((headers body) (values headers body 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)))) 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/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/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..dfa04f22 --- /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-group "Deserialize" + (let ((object (call-with-input-string component-str deserialize))) + (test-assert "Deserialize worked" (vcomponent? object)) + + (test-equal "Deserialized object serializes back into source" + (sanitize-string component-str) + (sanitize-string + (call-with-output-string + (lambda (p) (serialize object 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 4bb34ce8..4b6d2773 100755 --- a/tests/run-tests.scm +++ b/tests/run-tests.scm @@ -23,11 +23,8 @@ fi (use-modules (srfi srfi-1) (srfi srfi-64) (srfi srfi-88) - (hnh util) ((hnh util io) :select (call-with-tmpfile)) - (ice-9 ftw) (ice-9 format) - (ice-9 pretty-print) (ice-9 getopt-long) (ice-9 match) (ice-9 regex) @@ -37,162 +34,12 @@ fi ((ice-9 rdelim) :select (read-string)) (system vm coverage) ((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 (string-replace-head s1 s2) - (string-replace s1 s2 - 0 (string-length s2))) - -(define (diff s1 s2) - (let ((filename1 (call-with-tmpfile (lambda (p f) (display s1 p) f))) - (filename2 (call-with-tmpfile (lambda (p f) (display s2 p) f)))) - (let ((pipe (open-pipe* - OPEN_READ - ;; "git" "diff" "--no-index" - "diff" - filename1 filename2))) - (begin1 (begin - (read-string pipe)) - (close-pipe pipe))))) - -(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 - 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) - (test-runner-factory construct-test-runner) @@ -230,7 +77,8 @@ fi '((skip (value #t)) (only (value #t)) (verbose (single-char #\v)) - (coverage (value optional)))) + (coverage (value optional)) + (catch))) (define options (getopt-long (command-line) option-spec)) @@ -268,17 +116,22 @@ fi ;;; Catch/print-trace should intercept thrown exceptions, print them prettily with a stack trace, and then continue -#; -(define (catch/print-trace proc) - (catch #t proc - (case-lambda - ((err from msg args data) - (test-assert (format #f "~a in ~a: ~?" err from msg args) - #f)) - (args - (test-assert (format #f "~a (~s)" f args) - #f))))) + +(define catch/print-trace + (if (option-ref options 'catch #f) + (lambda (proc) + (catch #t proc + (case-lambda + ((err from msg args data) + (test-assert (format #f "~a in ~a: ~?" err from msg args) + #f)) + (args + (test-assert (format #f "~a (~s)" f args) + #f))))) + (lambda (proc) (proc)))) + +#; (define (catch/print-trace proc) (proc)) @@ -293,9 +146,9 @@ fi (%loop args onlies))) (if (null? args) onlies - (cond ((string-match "^--skip(=.*)?$" (car args)) + (cond ((string-match "^--skip(=(.*))?$" (car args)) => (lambda (m) - (cond ((match:substring m 1) + (cond ((match:substring m 2) => (lambda (s) (format #t "Skipping ~s~%" s) (test-skip s) @@ -303,9 +156,9 @@ fi (else (format #t "Skipping ~s~%" (cadr args)) (test-skip (cadr args)) (loop (cddr args)))))) - ((string-match "^--only(=.*)?$" (car args)) + ((string-match "^--only(=(.*))?$" (car args)) => (lambda (m) - (cond ((match:substring m 1) + (cond ((match:substring m 2) => (lambda (s) (loop (cdr args) only: s))) (else (loop (cddr args) only: (cadr args)))))) diff --git a/tests/test/add-and-save.scm b/tests/test/add-and-save.scm deleted file mode 100644 index 1ab6f660..00000000 --- a/tests/test/add-and-save.scm +++ /dev/null @@ -1,120 +0,0 @@ -(define-module (test add-and-save) - :use-module (srfi srfi-64) - :use-module (srfi srfi-88) - :use-module (hnh util) - :use-module (datetime) - ;; :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 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)))))))) ) - -(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")))))) - -(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)) - -(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) - -(add-calendars event-object calendar) - -;; Try adding and saving a new regular event -(add-and-save-event event-object calendar ev) - -;; Try changing and saving an existing regular event -(set! (prop ev 'SUMMARY) "Changed summary") -(add-and-save-event event-object calendar ev) - -;; Try adding and saving a new repeating event -(add-and-save-event event-object calendar rep-ev) - -;; Try changing and saving an existing repeating event -;; TODO setting start time to later than end time leads to nonsense -;; errors when trying to generate the recurrence set. -(set! (prop rep-ev 'DTSTART) (datetime+ (prop rep-ev 'DTSTART) - (datetime time: (time hour: 1)))) -(add-and-save-event event-object calendar rep-ev) - -;; Try adding and saving a new event with multiple instances -;; Try changing and saving an existing event with multiple instances - -;; (add-and-save-event event-object calendar event) - - -(test-equal "Correct amount of children in calendar" - 2 (length (children calendar))) - - -(define get-events (@@ (vcomponent util instance methods) get-events)) -(test-equal "Event object contains correct number of events (single calendar)" - 2 (length (get-events event-object))) - -(remove-event event-object (car (get-events event-object))) - -(test-equal "Correct number of events after removing first element" - 1 (length (get-events event-object))) diff --git a/tests/test/annoying-events.scm b/tests/test/annoying-events.scm index 4e5aa07d..a6f5e946 100644 --- a/tests/test/annoying-events.scm +++ b/tests/test/annoying-events.scm @@ -9,35 +9,29 @@ stream-filter stream-take-while)) :use-module ((vcomponent base) - :select (extract prop make-vcomponent)) + :select (extract prop)) :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..7cc00419 --- /dev/null +++ b/tests/test/create.scm @@ -0,0 +1,66 @@ +(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) + :select (vcomponent + with-parameters + as-list)) + :use-module ((vcomponent) + :select (children properties type prop prop* param vline?))) + +;; 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/datetime.scm b/tests/test/datetime.scm index 2a5ac141..f73a0ad2 100644 --- a/tests/test/datetime.scm +++ b/tests/test/datetime.scm @@ -70,45 +70,44 @@ (test-error "Invalid second" 'wrong-type-arg (time second: #f)))) (test-group "Datetime" - (let ((get-time% (@@ (datetime) get-time%))) + (let () (test-group "Empty datetime" (let ((dt (datetime))) - ;; TODO figure out propper export of get-time% - (test-assert "Datetime date is date" (date? (get-date dt))) - (test-assert "Datetime date is zero" (date-zero? (get-date dt))) - (test-assert "Datetime time is time" (time? (get-time% dt))) - (test-assert "Datetime time is zero" (time-zero? (get-time% dt))) - (test-eqv "Defalut timezone is #f" #f (get-timezone dt)))) + (test-assert "Datetime date is date" (date? (datetime-date dt))) + (test-assert "Datetime date is zero" (date-zero? (datetime-date dt))) + (test-assert "Datetime time is time" (time? (datetime-time dt))) + (test-assert "Datetime time is zero" (time-zero? (datetime-time dt))) + (test-eqv "Defalut timezone is #f" #f (tz dt)))) (test-group "Datetime with keys" (let ((dt (datetime date: (date day: 10) time: (time minute: 20)))) (test-equal "Given date is stored" - 10 (day (get-date dt))) + 10 (day (datetime-date dt))) (test-equal "Given time is stored" - 20 (minute (get-time% dt)))) + 20 (minute (datetime-time dt)))) (test-error "Date must be a date" 'wrong-type-arg (datetime date: 1)) (test-error "Date must be a date" 'wrong-type-arg (datetime date: (time))) - (test-assert "Date: #f gives still constructs a date" (date? (get-date (datetime date: #f)))) + (test-assert "Date: #f gives still constructs a date" (date? (datetime-date (datetime date: #f)))) (test-error "Time must be a time" 'wrong-type-arg (datetime time: 1)) (test-error "Time must be a time" 'wrong-type-arg (datetime time: (date))) - (test-assert "Time: #f gives still constructs a time" (time? (get-time% (datetime time: #f)))) + (test-assert "Time: #f gives still constructs a time" (time? (datetime-time (datetime time: #f)))) (let ((dt (datetime hour: 20 day: 30))) - (test-equal "Time objects can be implicitly created" 20 (hour (get-time% dt))) - (test-equal "Date objects can be implicitly created" 30 (day (get-date dt)))) + (test-equal "Time objects can be implicitly created" 20 (hour (datetime-time dt))) + (test-equal "Date objects can be implicitly created" 30 (day (datetime-date dt)))) (let ((dt (datetime day: 30 time: (time hour: 20)))) (test-equal "\"Upper\" and \"lower\" keys can be mixed" - 20 (hour (get-time% dt))) + 20 (hour (datetime-time dt))) (test-equal "\"Upper\" and \"lower\" keys can be mixed" - 30 (day (get-date dt)))) + 30 (day (datetime-date dt)))) (let ((dt (datetime hour: 30 time: (time hour: 20)))) (test-equal "time: has priority over hour: (and the like)" - 20 (hour (get-time% dt))))) + 20 (hour (datetime-time dt))))) (let ((dt (datetime day: 30 date: (date day: 20)))) (test-equal "date: has priority over day: (and the like)" - 20 (day (get-date dt))))))) + 20 (day (datetime-date dt))))))) ;; Before the general parser, since it's a dependency string->datetime. (test-group "Parse Month" @@ -384,7 +383,7 @@ (test-assert "Current datetime returns a datetime" (datetime? (current-datetime))) (test-equal "Current datetime returns with tz: UTC" - "UTC" (get-timezone (current-datetime))) + "UTC" (tz (current-datetime))) (test-assert "Current-date returns a date" (date? (current-date))) @@ -707,6 +706,11 @@ date-range (not (datetime< (datetime day: 1) (datetime day: 2) (datetime day: 1))))))) ;; TODO +date<= +time<= +datetime<= + +;; TODO date/-time< date/-time<? date/-time<= date/-time<=? date/-time> date/-time>? date/-time>= date/-time>=? 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-lens.scm b/tests/test/hnh-util-lens.scm new file mode 100644 index 00000000..0508553a --- /dev/null +++ b/tests/test/hnh-util-lens.scm @@ -0,0 +1,59 @@ +(define-module (test hnh-util-lens) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module (hnh util lens)) + + +(define first (ref 0)) + +(test-equal '((1)) (first '(((1))))) +(test-equal '((2)) (set '(((1))) (compose-lenses first first) 2)) +(test-equal '(((2))) (set '(((1))) (compose-lenses first first first) 2)) + + +;; (list-change (iota 10) 5 'Hello) +;; => (0 1 2 3 4 Hello 6 7 8 9) + +(test-equal '(1 (10) 3) (set '(1 (2) 3) (compose-lenses (ref 1) (ref 0)) 10)) +(test-equal '(1 (10) 3) (set '(1 (2) 3) (ref 1) (ref 0) 10)) + +;; (set (list (iota 10)) first first 11) + +(define cadr* (compose-lenses cdr* car*)) + +(test-group "Primitive lenses get and set" + (define lst '(1 2 3 4 5)) + (test-equal 1 (car* lst)) + (test-equal '(2 3 4 5) (cdr* lst)) + + (test-equal '(10 2 3 4 5) + (car* lst 10))) + +(test-group "Primitive lens composition" + (define lst '(1 2 3 4 5)) + (test-equal 2 (cadr* lst)) + (test-equal '(1 10 3 4 5) (cadr* lst 10))) + +(test-group "Modify" + (define lst '(1 2 3 4 5)) + (test-equal '(10 2 3 4 5) (modify lst car* * 10)) + (test-equal '(1 20 3 4 5) (modify lst cadr* * 10)) + ) + +(test-group "Modify*" + (define lst '(1 2 3 4 5)) + (test-equal '(1 2 4 4 5) (modify* lst cdr* cdr* car* 1+))) + +;; modify +;; modify* +;; set +;; get + +;; identity-lens +;; compose-lenses +;; lens-compose + +;; ref car* cdr* + +;; each 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/object.scm b/tests/test/object.scm new file mode 100644 index 00000000..701c45c0 --- /dev/null +++ b/tests/test/object.scm @@ -0,0 +1,80 @@ +(define-module (test object) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module (hnh util object) + :use-module ((hnh util) :select (->))) + +(define-type (f) x) + +(test-group "Created procedures" + (test-assert "Constructor" (procedure? f)) + (test-assert "Predicate" (procedure? f?)) + (test-assert "Field access" (procedure? x))) + +;; (f) +;; (f x: 10) +;; (f? (f)) + +(test-equal "Accessors are getters" + 10 (x (f x: 10))) +(test-assert "Accessors update, returning a object of the original type" + (f? (x (f x: 10) 20))) +(test-equal "A get after an update returns the new value" + 20 (-> (f x: 10) + (x 20) + x)) + + +(define-type (g) x) + +(test-assert "Second type can be created" + (g x: 10)) + +(test-assert "Second type isn't first type" + (not (f? (g x: 10)))) + +(test-assert "First type isn't second type" + (not (g? (f x: 10)))) + +;; Tests that the old x gets shadowed +;; (test-equal 10 (x (f x: 10))) +;; (test-equal 10 (x (g x: 10))) + +;; field-level arguments +;; - init: +(define-type (f2) (f2-x default: 0 type: integer?)) +(test-equal 0 (f2-x (f2))) + +;; - type: + +(test-error "Giving an invalid type to the constructor throws an error" + 'wrong-type-arg (f2 f2-x: 'hello)) +(test-error "Giving an invalid type to a setter throws an error" + 'wrong-type-arg (f2-x (f2) 'hello)) +(test-equal "The error includes the name of the field, the expected type, and the given value" + '(f2-x integer? hello) + (catch 'wrong-type-arg (lambda () (f2-x (f2) 'hello)) + (lambda (err proc fmt args data) args))) + +(test-equal "Typed setter updates the value" + (f2 f2-x: 10) (f2-x (f2) 10)) + +;; type-level arguments +;; - constructor: +(define-type (f3 constructor: (lambda (make check) + (lambda* (#:key f3-x f3-y) + (check f3-x f3-y) + (make f3-x f3-y)))) + (f3-x type: integer?) + (f3-y type: string?)) + +(test-assert "Custom constructors create objcets" + (f3? (f3 f3-x: 10 f3-y: "Hello"))) + +(test-error "Bad arguments to custom constructor" + 'wrong-type-arg (f3 f3-x: 'hello f3-y: 'world)) + +;; - printer: +(define-type (f4 printer: (lambda (r p) (display "something" p)))) +(test-equal "something" (with-output-to-string (lambda () (write (f4))))) diff --git a/tests/test/param.scm b/tests/test/param.scm index 34f7b826..431a8f46 100644 --- a/tests/test/param.scm +++ b/tests/test/param.scm @@ -8,10 +8,10 @@ :use-module (srfi srfi-64 test-error) :use-module (srfi srfi-88) :use-module ((vcomponent base) - :select (param prop* parameters prop)) + :select (param prop* parameters prop vline?)) :use-module ((vcomponent formats ical parse) :select (parse-calendar)) - :use-module ((vcomponent) :select (make-vcomponent)) + :use-module ((vcomponent) :select (vcomponent properties set-properties)) :use-module ((hnh util) :select (sort* set!)) :use-module ((ice-9 ports) :select (call-with-input-string)) :use-module ((vcomponent formats xcal output) @@ -23,11 +23,12 @@ ;; TODO possibly change parsing (define v - (call-with-input-string - "BEGIN:DUMMY + (car + (call-with-input-string + "BEGIN:DUMMY X-KEY;A=1;B=2:Some text END:DUMMY" - parse-calendar)) + parse-calendar))) (test-equal '("1") (param (prop* v 'X-KEY) 'A)) @@ -35,17 +36,20 @@ END:DUMMY" (test-equal #f (param (prop* v 'X-KEY) 'C)) -(test-equal - '(A B) - (sort* (map car (parameters (prop* v 'X-KEY))) - string<? - symbol->string)) + +(test-group "Properties" + (let ((p (properties v))) + (test-assert (list? p)) + (test-eqv 1 (length p)) + (test-eq 'X-KEY (caar p)) + (test-assert (vline? (cadar p))))) + ;; TODO possibly move this. ;; Checks that a warning is properly raised for ;; unkonwn keys (without an X-prefix) -(test-error +(test-error "Ensure parse-calendar warns on unknown keys" 'warning (call-with-input-string "BEGIN:DUMMY @@ -54,10 +58,9 @@ END:DUMMY" parse-calendar)) ;; Similar thing happens for sxcal, but during serialization instead -(let ((component (make-vcomponent 'DUMMY))) - (set! (prop component 'KEY) "Anything") +(let ((component (set-properties (vcomponent type: 'DUMMY) + (cons 'KEY "Anything")))) + (test-error 'warning (vcomponent->sxcal component))) - - diff --git a/tests/test/recurrence-advanced.scm b/tests/test/recurrence-advanced.scm index a291cc17..c2d71e61 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) @@ -23,12 +23,16 @@ :use-module ((vcomponent recurrence internal) :select (count until)) :use-module ((vcomponent base) - :select (make-vcomponent prop prop* extract make-vline)) + :select (prop prop* extract)) + :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)) @@ -63,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: @@ -110,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: @@ -233,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: @@ -263,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: @@ -278,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: @@ -381,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: @@ -484,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: @@ -504,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: @@ -531,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: @@ -561,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: @@ -581,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: @@ -601,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: @@ -636,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: @@ -654,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: @@ -674,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: @@ -688,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: @@ -708,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: @@ -724,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: @@ -754,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: @@ -774,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: @@ -794,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: @@ -814,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: @@ -844,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: @@ -864,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: @@ -884,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: @@ -904,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: @@ -934,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: @@ -964,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: @@ -994,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: @@ -1024,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: @@ -1056,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: @@ -1086,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: @@ -1116,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: @@ -1129,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: @@ -1144,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: @@ -1157,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: @@ -1173,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: @@ -1187,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: @@ -1217,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: @@ -1247,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: @@ -1261,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: @@ -1275,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: @@ -1290,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: @@ -1322,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: @@ -1350,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 @@ -1377,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 @@ -1389,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 @@ -1403,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/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..bdaefa95 100644 --- a/tests/test/vcomponent.scm +++ b/tests/test/vcomponent.scm @@ -1,30 +1,103 @@ ;;; Commentary: -;; Test that vcomponent parsing works at all. +;; Test base functionallity of vcomponent structures. ;;; 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))) + :use-module (hnh util table) + :use-module (datetime) + :use-module (vcomponent base)) + + + (define ev - (call-with-input-string - "BEGIN:DUMMY\nX-KEY:value\nEND:DUMMY" - parse-calendar)) + (prop (vcomponent type: 'DUMMY) + 'X-KEY "value")) -(test-assert (eq? #f (prop ev 'MISSING))) +(test-eqv "Non-existant properties return #f" + #f (prop ev 'MISSING)) -(test-assert (prop ev 'X-KEY)) +(test-assert "Existing property is non-false" + (prop ev 'X-KEY)) -(test-equal "value" (prop ev 'X-KEY)) +(test-equal "Getting value of existing property" + "value" (prop ev 'X-KEY)) -(define calendar (make-vcomponent 'VCALENDAR)) +(define calendar (add-child (vcomponent type: 'VCALENDAR) + ev)) -(add-child! calendar ev) (test-equal 1 (length (children calendar))) -(remove-child! calendar ev) -(test-equal 0 (length (children calendar))) + +;;; TODO remove child +;; (abandon! calendar ev) +;; (test-equal 0 (length (children calendar))) + + + +(define vline* + (vline + key: 'DTSTART + vline-value: #2020-01-02 + vline-parameters: (alist->table + '((VALUE . "DATE"))) + vline-source: "DTSTART;VALUE=DATE:2020-01-02")) + +(test-group "vline" + (test-assert "Type check works as expected" + (vline? vline*))) + +(define vcomponent* + (vcomponent type: 'VEVENT)) + +(test-assert "Type check works as expected" + (vcomponent? vcomponent*)) + +(define child + (vcomponent type: 'CHILD)) + + +(test-eqv + "An added component extends length" + 1 (length (children (add-child vcomponent* child)))) + +(test-eqv + "But the source isn't modified" + 0 (length (children vcomponent*))) + +(test-equal "Setting property" + (list (list 'KEY (vline key: 'KEY vline-value: "Value"))) + (properties + (prop vcomponent* 'KEY "Value"))) + +(let ((vl (vline key: 'KEY vline-value: "Value"))) + (test-equal "Setting property vline" + (list (list 'KEY vl)) + (properties + (prop* vcomponent* 'KEY vl)))) + +(test-equal "Set properties test" + '(K1 K2) + (map car + (properties + (apply set-properties + vcomponent* + `((K1 . "V1") + (K2 . "V2")))))) + +;; remove-property + +;; extract extract* + + +;; remove-parameter +;; value +;; param + +;; parameters +;; properties + +;; x-property? +;; internal-field? 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))) - - |