diff options
132 files changed, 5803 insertions, 3128 deletions
@@ -1,4 +1,5 @@ *.x /html coverage +obj-* localization @@ -1,14 +1,21 @@ .PHONY: all clean test \ - static coverage + static \ + go_files -GUILE_SITE_DIR=$(shell guile -c "(display (%site-dir))") -GUILE_CCACHE_DIR=$(shell guile -c "(display (%site-ccache-dir))") +GUILE := guile +export GUILE + +GUILD := guild + +GUILE_VERSION=$(shell $(GUILE) -c '(display (version))') + +GUILE_SITE_DIR=$(shell $(GUILE) -c "(display (%site-dir))") +GUILE_CCACHE_DIR=$(shell $(GUILE) -c "(display (%site-ccache-dir))") SCM_FILES = $(shell find module/ -type f -name \*.scm) -GO_FILES = $(SCM_FILES:module/%.scm=obj/%.go) +GO_FILES = $(SCM_FILES:module/%.scm=obj-$(GUILE_VERSION)/%.go) GUILE_C_FLAGS = -Lmodule \ - -Wunused-toplevel \ -Wshadowed-toplevel -Wunbound-variable \ -Wmacro-use-before-definition -Warity-mismatch \ -Wduplicate-case-datum -Wbad-case-datum @@ -17,13 +24,22 @@ GUILE_C_FLAGS = -Lmodule \ PO_FILES = $(shell find po -type f -name \*.po -and -not -name new.po -and -not -name .\*) LOCALIZATIONS = $(PO_FILES:po/%.po=localization/%/LC_MESSAGES/calp.mo) -all: $(GO_FILES) README static $(LOCALIZATIONS) +all: go_files README static $(LOCALIZATIONS) + $(MAKE) -C doc/ref XGETTEXT_FLAGS = --from-code=UTF-8 --add-comments --indent -k_ static: $(MAKE) -C static +obj-$(GUILE_VERSION)/%.go: module/%.scm + @echo $(GUILD) $(GUILE_VERSION) compile $< + @$(GUILD) compile $(GUILE_C_FLAGS) -o $@ $< >/dev/null + +# Phony target used by test/run-tests.scm and main to +# automatically compile everything before they run. +go_files: $(GO_FILES) + po/%.po: $(SCM_FILES) xgettext $(XGETTEXT_FLAGS) --output $@ -L scheme $^ --join-existing --omit-header @@ -34,36 +50,33 @@ localization/%/LC_MESSAGES/calp.mo: po/%.po -@mkdir -p $(shell dirname $@) msgfmt --check -o $@ $< -obj/%.go: module/%.scm - @mkdir -p obj - @echo guild compile $< - @guild compile $(GUILE_C_FLAGS) -o $@ $< - clean: - $(MAKE) -C static clean - -rm -r obj + -$(MAKE) -C static clean + -rm -r obj-* install: all install -d $(DESTDIR)$(GUILE_SITE_DIR) $(DESTDIR)$(GUILE_CCACHE_DIR) rsync -a module/ $(DESTDIR)$(GUILE_SITE_DIR) - rsync -a obj/ $(DESTDIR)$(GUILE_CCACHE_DIR) + rsync -a obj-$(GUILE_VERSION)/ $(DESTDIR)$(GUILE_CCACHE_DIR) install -d $(DESTDIR)/usr/share/calp/www - rsync -a static $(DESTDIR)/usr/share/calp/www + $(MAKE) -C static install + $(MAKE) -C doc/ref install install -m 644 -D -t $(DESTDIR)/usr/share/doc/calp README install -m 755 -D -t $(DESTDIR)/usr/lib/calp/ scripts/tzget - install -D production-main $(DESTDIR)/usr/bin/calp + install -m755 -D production-main $(DESTDIR)/usr/bin/calp README: README.in ./main text < README.in | sed "s/<<today>>/`date -I`/" > README -test: - tests/run-tests.scm - $(MAKE) coverage - -coverage: - genhtml \ - --show-details \ - --output-directory coverage \ - --prefix $(shell pwd) \ - --no-function-coverage \ - lcov.info +lcov.info: $(GO_FILES) + env DEBUG=1 tests/run-tests.scm --coverage=$@ + +test: coverage + +GENHTML_FLAGS=--show-details \ + --prefix $(shell pwd)/module \ + --no-function-coverage \ + --quiet + +coverage: lcov.info + genhtml $(GENHTML_FLAGS) --output-directory $@ $< @@ -1,6 +1,9 @@ +make[1]: Entering directory '/home/hugo/code/calp' +make[1]: Nothing to be done for 'go_files'. +make[1]: Leaving directory '/home/hugo/code/calp' CALP Hugo Hörnquist - 2020-08-03 + 2022-03-04 Calp is primarily a program for loading calendar files (.ics's) from drendering them in different formats. The goal is however to also @@ -39,19 +42,22 @@ Standards and specifications - RFC 7265 (jCal) - Vdir Storage Format [VDIR] -Building --------- - ./configure - ./main -No explicit compilation is required for general usage, since Guile -compiles -files as they are needed. You do however have to run `./configure` -before the first startup to set up some local variables and download -the timezone db. +Building & Running +------------------ +Everything can be directly loaded due to Guile's auto-compilation. +However, two entry points are provided. +- `main', which sets up its own environment, and explicitly builds +all libraries before starting, and +- `production-main', which assumes that the environment already is +fine, and is the version which should be installed. -To actually compile the files, and render the documentation (at the -time of writing only the README), run - make all +The code can also be explicitly manually built, see the makefile. + +The environment/make variable GUILE can be set to another guile +binary, such as `guile3'. +Guild by defaults also uses this, but if a separate guild version is +explicitly required then the env/make var GUILD can be set (but this +shouldn't be needed). Techical Details ---------------- @@ -24,17 +24,20 @@ Standards and specifications ---------------------------- - RFC 5545 (iCalendar) - RFC 6321 (xCal) +- RFC 7265 (jCal) - Vdir Storage Format [VDIR] -Building --------- - ./configure - ./main -No explicit compilation is required for general usage, since Guile compiles -files as they are needed. You do however have to run `./configure` before the first startup to set up some local variables and download the timezone db. +Building & Running +------------------ +Everything can be directly loaded due to Guile's auto-compilation. +However, two entry points are provided. +- `main', which sets up its own environment, and explicitly builds all libraries before starting, and +- `production-main', which assumes that the environment already is fine, and is the version which should be installed. -To actually compile the files, and render the documentation (at the time of writing only the README), run - make all +The code can also be explicitly manually built, see the makefile. + +The environment/make variable GUILE can be set to another guile binary, such as `guile3'. +Guild by defaults also uses this, but if a separate guild version is explicitly required then the env/make var GUILD can be set (but this shouldn't be needed). Techical Details ---------------- @@ -4,16 +4,11 @@ (use-modules (ice-9 regex) (sxml simple) - - ;; TODO this module introduces description-filter. It should be - ;; possible to use set-config! before the declaration point is - ;; known. But I currently get a config error. - ;; (vcomponent datetime output) + (sxml xpath) ) (set-config! 'calendar-files (glob "~/.local/var/cal/*")) -;;; TODO possibly replace with propper lookup (define my-courses '((TSEA82 . "Datorteknik") (TFYA19 . "Kvantdatorer") @@ -32,20 +27,20 @@ 'pre (lambda (m) (aref my-courses (string->symbol (match:substring m)))) 'post))) -(define (a link) `(a (@ (href ,link)) ,link)) - (define (parse-html str) - ;; extra space to ensure that we don't get a self closing - ;; div tag in the final output - ;; TODO Fix a real sxml->html | The space - ;; method instead of pretending | - ;; that HTML is XML. v - (xml->sxml (string-append "<div> " str "</div>") - default-entity-handler: - (lambda (port name) - (case name - [(nbsp) " "] - [else (symbol->string name)]))) ) + (catch 'misc-error + ;; resolve-interface throws misc-error on missing module. + ;; TODO what does html->sxml throw? + (lambda () + (let* ((gumbo (resolve-interface '(sxml gumbo))) + (html->sxml (module-ref gumbo 'html->sxml))) + ;; html->sxml always gives us (html (head ...) (body <content>)) + ;; this strips it down to just <content> + (cdar ((sxpath '(// body)) (html->sxml str))))) + ;; Give up on parsing + (lambda _ str))) + +(define (a link) `(a (@ (href ,link)) ,link)) (define (parse-links str) (define regexp (make-regexp "https?://\\S+")) @@ -91,11 +86,8 @@ (set-config! 'description-filter (lambda (ev str) (cond [(member (prop (parent ev) 'NAME) - html-cals - ) - (parse-html (regexp-substitute/global - #f "<br>" str - 'pre "<br/>" 'post))] + html-cals) + (parse-html str)] [(prop ev 'X-MICROSOFT-SKYPETEAMSMEETINGURL) (parse-teams-description str)] [else (parse-links str)]))) diff --git a/doc/ref/Makefile b/doc/ref/Makefile index 2232a70e..79486a46 100644 --- a/doc/ref/Makefile +++ b/doc/ref/Makefile @@ -1,7 +1,12 @@ +.PHONY: all install + TEXI_FILES := $(shell find . -type f -name \*.texi) -INFOFLAGS := +INFOFLAGS := --no-split all: calp.info calp.info: $(TEXI_FILES) - makeinfo $(INFOFLAGS) calp.texi + makeinfo -o $@ $(INFOFLAGS) calp.texi + +install: all + install -m644 -D -t $(DESTDIR)/usr/share/info/ calp.info diff --git a/doc/ref/calp.texi b/doc/ref/calp.texi index 474ad3e2..92c30242 100644 --- a/doc/ref/calp.texi +++ b/doc/ref/calp.texi @@ -5,6 +5,11 @@ Copyright @copyright{} 2020 Hugo Hörnquist @end copying +@dircategory The Algorithmic Language Scheme +@direntry +* Calp: (calp). Parsing and displaying of icalendar files +@end direntry + @c Borrowed from guile.texi @c @nicode{S} is plain S in info, or @code{S} elsewhere. This can be used @c when the quotes that @code{} gives in info aren't wanted, but the diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index 67828b09..eb9e3bcc 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -1,10 +1,68 @@ @node Guile @chapter Guile +@include guile/datetime.texi +@include guile/srfi-41.texi @include guile/util.texi @include guile/util-path.texi +@include guile/util-config.texi @include guile/vcomponent.texi +@node Errors and Conditions +@section Errors and Conditions + +@subsection ``Special'' Errors + +@deftp{Error type} return +Thrown in some sub-mains to quickly return from the sub-function. +Should possibly be replaced by an explicit return-continuation. +@end deftp + +@deftp{Error type} warning fmt args +Thrown when @code{warnings-are-errors} is true. +@end deftp + +@deftp{Error type} max-page page-number +@end deftp + +@subsection ``Regular'' Errors +All below mentioned error types behave as expected, e.g., they are +produced through @code{scm-error}. + +@deftp{Error Type} configuration-error +Thrown by (calp util config), in some scenarios. +@TODO{Better documentation} +@end deftp + +@deftp{Error Type} c-parse-error +Errors thrown by our make-shift C parser. +@end deftp + +@deftp{Error Type} decoding-error +thrown by base64 in some cases +@end deftp + +@deftp{Error Type} parse-error +Thrown by some things related to parsing, but not all. +@TODO{normalize parsing errors further} +@end deftp + +@deftp{Error Type} graph-error +The first element of data is guaranteed to be the graph which caused +the error. +@end deftp + +@deftp{Error Type} missing-helper +A helper program we wanted was missing, could be resolved by somehow +downloading it into one of the searched locations. + +@example +data : (program-name : string) + , (searched-locations : (list string)) +@end example +@end deftp + + @node Other @section Other @@ -43,8 +101,8 @@ type = 'BINARY | 'BOOLEAN | 'CAL-ADDRES | 'DATE | 'DATE-TIME @subsubsection types @defun escape-chars str -Escape ``@verb{|,|}'', ``@verb{|;|}'' and ``@verb{|\|}'' with a -backslash, and encode newlines as ``@verb{|\n|}''. +Escape @code{,}, @code{;} and @code{\} with a +backslash, and encode newlines as @code{\n}. @end defun @defun get-writer type @@ -80,7 +138,7 @@ type = 'BINARY | 'BOOLEAN | 'CAL-ADDRES | 'DATE | 'DATE-TIME @defun ns-wrap @lisp (define (ns-wrap sxml) - `(icalendar (@ (xmlns "urn:ietf:params:xml:ns:icalendar-2.0")) + `(icalendar (@@ (xmlns "urn:ietf:params:xml:ns:icalendar-2.0")) ,sxml)) @end lisp Where @var{sxml} is expected to be the output of @var{vcomponent->sxcal}. @@ -121,3 +179,4 @@ Note that @var{body} is guarded through a dynamic-wind, meaning that even non-local exits will restore @var{component} to its initial state. @end defmac + diff --git a/doc/ref/guile/datetime.texi b/doc/ref/guile/datetime.texi new file mode 100644 index 00000000..d49c4ada --- /dev/null +++ b/doc/ref/guile/datetime.texi @@ -0,0 +1,680 @@ +@node Datetime +@section Datetime + +My datetime library, with focus on date manipulation in ways sensible +for humans. So that a date-time plus one day always keep the time of +day. +For example, 26 mars 2022 10:00 plus 1 day would give 27 mars 2022 +10:00, even though 25 hours have passed due to summer time starting +(in Sweden). + +Note that while some of these procedures mentions timezones, almost +nothing is actually done with it. + +@subsection Constants + +@defvar jan +@defvarx january +@defvarx feb +@defvarx february +@defvarx mar +@defvarx mars +@defvarx apr +@defvarx april +@defvarx may +@defvarx jun +@defvarx june +@defvarx jul +@defvarx july +@defvarx aug +@defvarx august +@defvarx sep +@defvarx september +@defvarx oct +@defvarx october +@defvarx nov +@defvarx november +@defvarx dec +@defvarx december +Numeric constants for all months. +@code{@var{jan} = 1}, @code{@var{dec} = 12}. +@end defvar + +@defvar sun +@defvarx sunday +@defvarx mon +@defvarx monday +@defvarx tue +@defvarx tuesday +@defvarx wed +@defvarx wednesday +@defvarx thu +@defvarx thursday +@defvarx fri +@defvarx friday +@defvarx sat +@defvarx saturday +@anchor{sunday} +Numeric constants for all weekdays. +@code{@var{sunday} = 0}, @code{@var{saturday} = 6}. +@end defvar + +@subsection Parameters and Configuration + +@deftp {parameter} week-start +@anchor{week-start} +Which weekday should be considered the first. Used for calculating +week numbers, the start dates of week, and is available for UI-code +and the like which wants it. +@end deftp + +@deftp {config} week-start +Configuration item, updates @xref{week-start}. +@end deftp + + +@subsection Datatypes + +@deftp {Immutable Record} <date> year month day +Object representing a date, without any timezone information. +Given the date 2040-03-23 (in ISO-8601 format), @var{year} = 2020, +@var{month} = 3 and @var{day} = 23. + +Values higher than those usually used are possible, but not recommended. + +@defun date? x +Is @var{x} a date object? +@end defun + +@defun date [#:year=0] [#:month=0] [#:day=0] +Create a new date object. +@end defun + +@defun year <date> +@defunx month <date> +@defunx day <date> +Fetch corresponding field from the date object. +@end defun +@end deftp + +@deftp {Immutable Record} <time> hour minute second +Object representing a timestamp in a given day, +without any timezone information. +Given the time 10:20:30, @var{hour} = 10, +@var{minute} = 20 and @var{second} = 30. + +Values larger than the ``regular'' are allowed, and useful since this +type is also used for time offsets. + +@defun time? x +Is @var{x} a time object? +@end defun + +@defun time [#:hour=0] [#:minute=0] [#:second=0] +Create a new time object. +@end defun + +@defun hour <time> +@defunx minute <time> +@defunx second <time> +Fetch corresponding field from the time object. +@end defun +@end deftp + + +@deftp {Immutable Record} <datetime> date time tz + +A collation of date and time, along with an optional timezone. +Set @code{tz = #f} if a timezone is not desired. + +@defun datetime? x +Is @var{x} a datetime object? +@end defun + +@defun datetime [#:date] [#:time] [#:tz] [#:year=0] [#:month=0] [#:day=0] [#:hour=0] [#:minute=0] [#:second=0] +Creates a new <datetime>. If @var{date} or @var{time} is given, those +are used. Otherwise, a date object is created from @var{year}, +@var{month} and @var{day}, and time is respectively created from +@var{hour}, @var{minute} and @var{second}. +@end defun + +@defun get-date +@defunx get-timezone +Note that @code{get-time} doesn't exists. +@end defun +@end deftp + + +@subsection Reader Extensions + +This module registers reader extensions on @code{#0}, @code{#1}, and +@code{#2}. These read either dates, times, or datetimes; using @code{string->date/-time}. + +@c @subsection CTIME + +@c These procedures are for interfacing with C's time procedures, see CTIME(3). + +@c The datetime<->tm procedures are internal, since they are slightly +@c unstable (see comments in code). +@c They are thereby not documented. +@c @defun datetime->tm datetime +@c Convert a @code{<datetime>} object to a @code{struct tm}, encoded in a +@c scheme vector. +@c @end defun +@c +@c @defun tm->datetime tm +@c Converts a @code{struct tm}, as returned from @code{datetime->tm} back +@c into a @code{<datetime>} object. +@c @end defun + +@subsection Procedures + +@defun datetime->unix-time datetime +Converts @var{datetime} to an integer representing its unix time. +@end defun + +@defun unix-time->datetime n +Converts a given unix timestamp to a datetime object. +Currently forces the timezone to be UTC. +@end defun + +@defun current-datetime +Return a datetime object of the current date and time. +Currently always returns it in UTC. +@end defun + +@defun current-date +Get the date component from a call to @code{current-datetime}. +@end defun + + +@defun get-datetime datetime +Takes a datetime in any timezone, and renormalize it to local time (as +defined by the environment variable TZ). This means that given UTC +10:00 new years day would return 11:00 new years day if ran in sweden. +@end defun + + +@defun as-date date/-time +@defunx as-time date/-time +Both procedures takes a <date>, <time>, or <datetime>, and return +respectively a <date> or <time> object. + +@code{as-date}, when given a time will return a zeroed date object. +Vice versa for @code{as-time}. +@end defun + +@defun as-datetime date/-time +Takes a <date>, <time>, or <datetime>, and returns a <datetime> object +with the same data, with the (possibly) missing date or time set to +all zeroes. +@end defun + + +@defun date-zero? date +@defunx time-zero? time +Checks if all components are zero. +@end defun + + +@defun leap-year? year +Given an integer @var{year}, return @code{#t} if it's a leap year, and +@code{#f} otherwise. +@end defun + +@defun days-in-month date +Returns how many days are in the month specified by the <date> @var{date}. +Note that the day component is ignored. +@end defun + +@defun days-in-year date +Returns how many days are in the year pointed to by @var{date}. +@end defun + +@defun start-of-month date +Returns a <date> object equal to date, but with the day component set +to 1. +@end defun + +@defun end-of-month date +Returns a <date> object equal to date, but with the day component set +to the last day of the month. + +@example +(end-of-month #2020-01-10) +⇒ #2020-01-31 +(end-of-month #2020-02-01) +⇒ #2020-02-29 +@end example +@end defun + + +@defun start-of-year date +Returns a <date> object equal to date, but with the day and month +component set to 1. +@end defun + +@defun date-stream date-increment start-day +Returns an @ref{(guile)SRFI-43} stream of <date> objects, starting at +@var{start-day} and stepping in increments of @var{date-increment}. +@end defun + +@defun day-stream start-day +Returns a stream of each day from @var{start-day}. +@end defun + +@defun month-stream start-day +Returns a stream of each months from @var{start-day}. +Day component stays the same. +@end defun + +@defun week-stream start-day +Returns a stream of each week from @var{start-day} +(increments of 7 days). +@end defun + +@defun time-min a b +@defunx time-max a b +@defunx date-min a b +@defunx date-max a b +@defunx datetime-min a b +@defunx datetime-max a b +Returns the smaller (or larger) of @var{a} or @var{b}. +@end defun + +@defun month+ date [change=1] +@defunx month- date [change=1] +Equivalent to @code{(date+ date (date month: change))}. +@end defun + +@defun week-day date +Returns an integer representing the week day of @var{date}. +@ref{sunday} +@end defun + + +@defun week-1-start date [week-start=(week-start)] +Returns the date which week 1 starts on, according to the (at least) +Swedish rule of week counting. +@ref{week-start} +@end defun + + +@defun week-number date [week-start=(week-start)] +Returns the week number of @var{date}, according to the (at least) +Swedish rule of week counting. +@ref{week-start} +@end defun + +@defun date-starting-week week-number date [week-start=(week-start)] +Returns the first day of week @var{week-number}, @var{date} is used +for year information. +@ref{week-start} +@end defun + + +@defun week-day-name week-day [truncate-to] [#:key locale] +Returns the locale dependent name for the given week day. + +@var{week-day} is a number per @ref{sunday}. +@var{truncate-to} may be a number, which limits to the first @var{n} +letters of the resulting string. +@end defun + + +@defun timespan-overlaps? s1-begin s1-end s2-begin s2-end +Check if the interval @var{s1-begin} to @var{s1-end} overlaps with the +interval @var{s2-begin} to @var{s2-end}. +@end defun + +@defun find-first-week-day week-day date +Returns the first instance of the given week-day after @var{date}. + +@example +(find-first-week-day mon #2020-04-01) +⇒ #2020-04-06 +(find-first-week-day mon #2020-04-10) +⇒ #2020-04-13 +(find-first-week-day mon #2020-04-30) +⇒ #2020-05-04 +@end example +@end defun + +@defun all-wday-in-month week-day month-date +Returns instances of the given week-day in month between +month-date and end of month. +@example +(all-wday-in-month mon #2020-06-01) +⇒ (#2020-06-01 #2020-06-08 #2020-06-15 #2020-06-22 #2020-06-29) +(all-wday-in-month mon #2020-06-10) +⇒ (#2020-06-15 #2020-06-22 #2020-06-29) +@end example +@end defun + +@defun all-wday-in-year week-day year-date +Returns a list of all instances of @var{week-day} in @var{year-date}. +@end defun + +@defun add-day date +@defunx remove-day date +@code{@var{date} ± (date day: 1)} +@end defun + +@defun in-date-range? start-date end-date → date → boolean +Returns a predicate procedure, which checks if a given date is between +@var{start-date} and @var{end-date}. +@end defun + +@defun weekday-list [week-start=(week-start)] +Returns a list of the seven week days, with @var{week-start} +as the beginning of the week. +@end defun + + +@defun start-of-week d [week-start=(week-start)] +@defunx end-of-week d [week-start=(week-start)] +Returns the date the week containing @var{d} started or ended. +@end defun + + +@defun month-days date [week-start=(week-start)] +Given a month and and which day the week starts on, +returns three lists, which are: +The days leading up to the current month, but share a week +The days in the current month +The days after the current month, but which shares a week. + +@example + mars 2020 +må ti on to fr lö sö + 1 + 2 3 4 5 6 7 8 + 9 10 11 12 13 14 15 +16 17 18 19 20 21 22 +23 24 25 26 27 28 29 +30 31 +@end example +@lisp +(month-days #2020-03-01 mon) +; ⇒ (2020-02-24 ... 2020-02-29) +; ⇒ (2020-03-01 ... 2020-03-31) +; ⇒ (2020-04-01 ... 2020-04-05) +@end lisp +Ignores day component of @var{date}. +@end defun + + +@defun days-in-interval start-date end-date +The amount of days in the given interval, including both endpoints. +@end defun + + +@defun year-day date +Day from start of the year, so 1 feb would be day 32. +Also known as Julian day. +@end defun + + +@defun time->decimal-hour time +Convert @var{time} to a decimal value, so 10:30 would become 10.5. +@end defun + +@defun datetime->decimal-hour dt [start-date] +Similar to @code{time->decimal-hour}, but also looks at the date component. + +@var{start-date} is required if either the month of year component of +@var{dt} is non-zero (since months and years have a variable number of hours). +@end defun + +@defun date-range start end [increment=(date day: 1)] +Returns a list of all dates from start to end. +Both inclusive +@end defun + +@defun locale-month +@defunx locale-month-short +These are direct re-exports from (ice-9 i18n) + +@xref{Accessing Locale Information,,,guile}. +@end defun + +@defun date= args ... +@defunx date=? args ... +@defunx date< args ... +@defunx date<? args ... +@defunx date> args ... +@defunx date>? args ... +@defunx date<= args ... +@defunx date<=? args ... +@defunx date>= args ... +@defunx date>=? args ... +Checks if all date arguments satisfy the predicate. +@end defun + +@defun time= args ... +@defunx time=? args ... +@defunx time< a b +@defunx time<? a b +@defunx time> a b +@defunx time>? a b +@defunx time<= a b +@defunx time<=? a b +@defunx time>= a b +@defunx time>=? a b +Checks if all time arguments satisfy the predicate. +@end defun + +@defun datetime= args ... +@defunx datetime=? args ... +@defunx datetime< a b +@defunx datetime<? a b +@defunx datetime> a b +@defunx datetime>? a b +@defunx datetime<= a b +@defunx datetime<=? a b +@defunx datetime>= a b +@defunx datetime>=? a b +Check if all datetime arguments satisfy the predicate. +The timezone field is ignored. +@end defun + +@defun date/-time< a b +@defunx date/-time<? a b +@defunx date/-time> a b +@defunx date/-time>? a b +@defunx date/-time<= a b +@defunx date/-time<=? a b +@defunx date/-time>= a b +@defunx date/-time>=? a b +Equivalent to the @code{datetime*} versions, but wraps its arguments +in @code{as-datetime}. +@end defun + +@subsection Arithmetic + +While only one date (and one time) type is available, it really should +be seen as two. Absolute dates, such as the fourth of november, +2022. The other type are intervals, such as 3 years, 4 months and 2 days. + +A ``type mismatch'' might therefore lead to some confounding results. +@example +(date- #2020-01-01 #2020-01-01) +⇒ #00-1-11-31 +(date-difference #2020-01-01 #2020-01-01) +⇒ #0000-00-00 +@end example + +@defun date+ base rest ... +@defunx date- base rest ... +Add or remove each difference from base. +@end defun + +@defun date-difference end start +Returns difference between the two dates, in years, months, and days. +In such a way that + +@lisp +(date= (date+ start (date-difference end start))) +@end lisp +@end defun + +@defun time+ base rest ... +@defunx time- base rest ... +Adds (or subtracts) each difference from the base, and returns two +values. The sum, and how many midnight's have passed. + +@lisp +(time+ #22:00:00 (time hour: 4)) +⇒ #02:00:00 +⇒ 1 +@end lisp +@end defun + +@defun datetime+ base change +@defunx datetime- base change +@end defun + +@defun datetime-difference end start +@end defun + +@subsection Parsing and Formatting + +@defun datetime->string datetime [fmt=''~Y-~m-~dT~H:~M:~S''] [#:allow-unknown?] + +Formats @var{datetime} into a string. +The function will throw an error when encountering an unknown format +specifier, unless @var{#:allow-unknown} is true. + +@table @samp +@item ~~ +A literal tilde (~). +@item ~H +Hour, left padded with zeroes to length 2. +@item ~k +Like @samp{~H}, but padded with spaces. +@item ~M +Minute, left padded with zeroes to length 2. +@item ~S +Seconds, left padded with zeroes to length 2. +@item ~Y +Year, left padded with zeroes to length 4; +@item ~m +Month number, left padded with zeroes to length 2. +@item ~d +Day in month, left padded with zeroes to length 2. +@item ~s +Epoch time, per UNIX. +@item ~e +Same as @samp{~d}, but padded with spaces. +@item ~1 +Shorthand for @samp{~Y-~m-~d}. +@item ~3 +Shorthand for @samp{~H:~M:~S}. +@item ~A +Locale week day name. +@item ~a +Locale week day name, truncated to 3 characters. +@item ~b +Locale month name, truncated. +@item ~B +Locale month name, in full. +@item ~Z +@samp{Z} if the timezone is @samp{UTC}. Nothing otherwise. +@end table +@end defun + +@defun date->string date [fmt=''~Y-~m-~d''] [#:allow-unknown?] +@defunx time->string date [fmt=''~H:~M:~S''] [#:allow-unknown?] +Simple wrappers around @code{datetime->string}, which works directly +on date or time objects. +@end defun + + +@defun string->datetime str [fmt=''~Y-~m-~dT~H:~M:~S~Z''] [locale=%global-locale] +Attempts to parse @var{str} as a datetime, according to the ruleset @var{fmt}. +An invalid or unparsable string will throw an error. + +Each token in @var{fmt} informs the parser what the next expected +token in @var{str} is. If a binding rule is parsed multiple times, +then the last one is used for the resulting object. For example, +@example +(string->datetime "10:20" "~H:~H") +⇒ (datetime hour: 20) +@end example + +spaces are literal, there is no way to match an arbitrary number of +whitespace characters + +@table @samp +@item ~~ +Next token is a literal tilde. + +@item ~Z +If next token is a literal @samp{Z} then the resulting timezone is set +to @samp{UTC}, otherwise does nothing. + +@item ~p +The next token is an AM/PM indicator, matched by the regex +@code{^([AaPp])[.]?[Mm][.]?}. A valid token will reinterpret the last +hour indicator as 12-hour time (instead of 24 hour time), regardless +if its before or after this token. + +@item ~b +@itemx ~B +@itemx ~h +Parses a month by name, just as @code{parse-month}. + +@item ~H +@itemx ~M +@itemx ~S +@itemx ~m +@itemx ~d +Parses up to two digits, but possibly less if a non-digit appears in +the string. Then stores the resulting value in either the hour, +minute, second, month, or day slot of the resulting object. + +This double function allows both dates without delimiters, such as +``0102'' to be correctly parsed, but also more free form formats, such +as ``1 jan''. + +@item ~Y +Equivalent to @samp{~H}, but reads up to 4 digits, and stores the +result in the year field. +@end table +@end defun + + +@defun parse-month str [locale=%global-locale] +Returns the first month whose name has @var{str} as its prefix. +The result will be on the interval [1, 12], or -1 if no month matched. +@end defun + + +@defun string->time str [fmt=''~H:~M:~S''] [locale=%global-locale] +@defunx string->date str [fmt=''~Y-~m-~d''] [locale=%global-locale] +Wrappers around @code{string->datetime}, but only returning the time +or date component. +@end defun + + +@defun string->date/-time string +Parses string as an ISO-8601 string. Checks for the existence of +@code{T}, @code{:}, or @code{-} to determine if it's a datetime, time +or date. +@end defun + +@defun parse-ics-date str +@defunx parse-ics-time str +@defunx parse-ics-datetime str [zone] +Parses dates per RFC5545. +@end defun + +@defun parse-iso-date str +@defunx parse-iso-time str +@defunx parse-iso-datetime str +Parses (the well known subset) of ISO-compatible dates. +@end defun + +@defun parse-freeform-date str +Currently an alias for parse-iso-datetime, but should preferably be extended. +@end defun diff --git a/doc/ref/guile/srfi-41.texi b/doc/ref/guile/srfi-41.texi new file mode 100644 index 00000000..8c65b6eb --- /dev/null +++ b/doc/ref/guile/srfi-41.texi @@ -0,0 +1,80 @@ +@node SRFI 41 Utilities +@section SRFI 41 Utilities + +Extra utilities for handling streams. Provided by @code{(srfi srfi-41 +util)}. + +@defun stream-car+cdr stream +Returns the car and cdr of stream. +@end defun + +@defun interleave-streams < streams +Merges a number of totally ordered streams into a single +totally ordered stream. + +((≺, stream)) → (≺, stream) +@end defun + +@defun stream-insert < item stream +Insert item in the totally ordered stream (≺, stream). +@end defun + + +@defun filter-sorted-stream pred stream +@end defun + + +@defun filter-sorted-stream* pred keep-remaining? stream +@end defun + +@defun get-stream-interval start-pred end-pred stream +Get the substream from stream from the first match of start-pred, to +the first match of end-pred after start-pred. +@end defun + + +@defun stream-find pred stream +Find the first element in stream satisfying the predicate, or #f none +was found. +@end defun + + +@defun stream-remave pred stream +Stream-filter, but with predicate negated. +@end defun + + +@defun stream->values stream +Equivalent to list->values. Returns as many objects as the stream is long. +@end defun + + +@defun repeating-naturals from repeats +Natural numbers from @var{from} and up, but each repeated @var{repeat} +times. +@example +(stream->list 15 (repeating-naturals 1 3)) +⇒ (1 1 1 2 2 2 3 3 3 4 4 4 5 5 5) +@end example +@end defun + + +@defun stream-partition pred stream +@end defun + +@defun stream-split idx stream +@end defun + +@defun stream-paginate stream [page-size=10] +@end defun + + +@defun eager-stream-cons a b +stream cons, but eval arguments beforehand. +@end defun + +@defun stream-timeslice-limit stream timeslice +Wrap a stream in time limits. Each element has at most @var{timeslice} +seconds to produce a value, otherwise the stream ends. Useful for finding the +``final'' element matching a predicate in an infinite stream. +@end defun diff --git a/doc/ref/guile/util-config.texi b/doc/ref/guile/util-config.texi new file mode 100644 index 00000000..2e197bcc --- /dev/null +++ b/doc/ref/guile/util-config.texi @@ -0,0 +1,93 @@ +@node Configuration + +@section Configuration + +Provided by the module @code{(calp util config)}. + +Configuration items are similar to regular defines, but global to the +entire program, and assignable before they are declared. +Their primary purpose is to allow a user supplied @file{config.scm}, +without needing all appropriate modules already loaded. + +@defmac define-config name default kw-parameters ... +Declares a new configuration variable named @var{named}, with the +default value @var{default}. @var{kw-parameters} are given on Guile's +standard @code{hash: value} form. @pxref{get-property} for available parameters. +@end defmac + +@defun get-property config-name property-key +@anchor{get-property} +Returns a metadata-slot value for the given configuration setting. + +Each declared configuration item has (at least) the following metadata +slots: + +@table @samp +@item description +Short human-readable description of this configuration item. + +@item source-module +Module in which this item was declared. Automatically filled in by @code{define-config}. + +@item pre +Procedure which can pre-process or validate set values. Think about it +as if @code{(set-config! key value)} expands to +@code{(true-set-config! key (pre value))}, +with the bonus that if @code{pre value} returns @code{#f} then the +assignment fail. + +@item post +Procedure to run after the value is set. For example for updating a +local parameter. +@example +(define-public week-start (make-parameter sun)) +(define-config week-start sun + description: "First day of week" + pre: (ensure (lambda (x) (<= sun x sat))) + post: week-start) +@end example +@end table + +@findex set-property! +Note that @code{set-property!} doesn't exist, since properties are read-only. +@end defun + +@defun set-config! name value +Sets the @var{value} of the configuration variable @var{name}. +@end defun + +@defun get-config key [default] +Retrieve the configured value for @var{key}. Throws an error if key +isn't set, and @var{default} isn't given (to differentiate it from +@code{#f} being set. +@end defun + +@defun {(ensure predicate)} value +Helper procedure for @code{pre} hooks. Curried function which checks +if @var{value} satisfies @var{predicate}, and if so returns @var{value}. + +@example +(define-public ((ensure predicate) value) + (if (predicate value) + value #f)) +@end example +@end defun + +@defun get-configuration-documentation +Collects all variables we know about (both defined and non-defined +(but set)), and builds a markup-tree with information about them. +@c TODO document markup format, link it here +@end defun + +@defun format-procedure procedure +Procedure mainly used by @code{get-configuration-documentation}. Gives +a simple string representation of the given procedure. + +@example +(format-procedure format-procedure) +⇒ "format-procedure(proc)" + +(format-procedure (lambda* (key: (a 1)) (+ a 3))) +⇒ "λkey: a" +@end example +@end defun diff --git a/doc/ref/guile/util.texi b/doc/ref/guile/util.texi index 71e3f93a..3f37491d 100644 --- a/doc/ref/guile/util.texi +++ b/doc/ref/guile/util.texi @@ -338,7 +338,20 @@ Similar to @var{let}, but sets environment variables for the code in body. Restores the old values once we leave. @end defmac +@defmac catch* thunk (symbol proc) ... +Macro allowing multiple exception types to be caught. Each (symbol +proc) pair expands to a regular @code{catch}, with the leftmost being +innermost. +@end defmac + +@subsection UUID generation + +Provided by module @code{(hnh util uuid)}. + +@defun uuid-v4 +Generates a UUID-v4 string. +@end defun -@defun uuidgen -Generates a UUID. +@defun uuid +Generates an implementation defined (but guaranteed valid) UUID. @end defun diff --git a/doc/ref/javascript.texi b/doc/ref/javascript.texi index 7510e4f5..bbe1cb25 100644 --- a/doc/ref/javascript.texi +++ b/doc/ref/javascript.texi @@ -10,6 +10,7 @@ The frontend code has its entry-point in @code{script.ts} All elements are initialized in elements.ts + @include javascript/clock.texi @include javascript/lib.texi @include javascript/eventCreator.texi @@ -17,6 +18,8 @@ All elements are initialized in elements.ts @include javascript/vevent.texi @include javascript/globals.texi @include javascript/server_connect.texi +@include javascript/formatters.texi +@include javascript/user-additions.texi @node General Components @section General Components @@ -34,3 +37,12 @@ All elements are initialized in elements.ts @include javascript/components/vevent_description.texi @include javascript/components/vevent_dl.texi @include javascript/components/vevent_edit.texi + +@section About our buildsystem +Currently (almost) everything is written in Typescript, and bundled +through browserify. Ideally we would, for debug builds, export the +single transplied Javascript files, but Chromium Chromium lacks +support for modules on XHTML documents +@url{https://bugs.chromium.org/p/chromium/issues/detail?id=717643}. +However, seeing as the issue still gets frequent updates as of 2021 I +believe that this might one day get resolved. diff --git a/doc/ref/javascript/components/tab_group_element.texi b/doc/ref/javascript/components/tab_group_element.texi index 7d9ca412..67f3a359 100644 --- a/doc/ref/javascript/components/tab_group_element.texi +++ b/doc/ref/javascript/components/tab_group_element.texi @@ -13,14 +13,14 @@ Each tab consists of two parts, a label which is used for selecting it, and a tab-element, which contains the actual content. These two should refer to each other as follows: -@verbatim +@example +---------------+ +----------------+ | TabLabel | | Tab | +---------------+ +----------------+ | id |<----| aria-labeledby | | aria-controls |---->| id | +---------------+ +----------------+ -@end verbatim +@end example Further information about tabs in HTML can be found here: @url{https://developer.mozilla.org/en-US/docs/Web/Accessibility/ARIA/Roles/Tab_Role} diff --git a/doc/ref/javascript/components/vevent_description.texi b/doc/ref/javascript/components/vevent_description.texi index 492c8dff..54dda7e3 100644 --- a/doc/ref/javascript/components/vevent_description.texi +++ b/doc/ref/javascript/components/vevent_description.texi @@ -7,4 +7,10 @@ A text representation of a VEvent. Used as the summary tab of our popup windows, and in the sidebar. + +When redrawn, it looks for an HTML-tag inside its template having the +attribute @code{data-property} matching the properties name. If one is +found, it looks in the @code{formatters} table +(@ref{formatters-proc}), for a field matching the property value, and +defaults to the key @code{default}. @end deftp diff --git a/doc/ref/javascript/formatters.texi b/doc/ref/javascript/formatters.texi new file mode 100644 index 00000000..16a988c4 --- /dev/null +++ b/doc/ref/javascript/formatters.texi @@ -0,0 +1,16 @@ +@node formatters +@subsection formatters + +Formatting procedures used by some components. +@c TODO can we have a backref of every node containing @ref{formatters-proc}? + +@deftypevar {Map<string, (e:HTMLElement, s:any) => void>} formatters +@anchor{formatters-proc} + +Each procedure takes two arguments. The HTML-element which contents +should be replaced, along with the target value, as returned by @ref{VEvent.getProperty}. +@end deftypevar + +@deftypevr {Window Value} {Map<string, (e:HTMLElement, s:string) => void>} formatters +Same object as @xref{formatters-proc}. Provided for @xref{user-additions.js}. +@end deftypevr diff --git a/doc/ref/javascript/lib.texi b/doc/ref/javascript/lib.texi index e5b13383..a3fb0697 100644 --- a/doc/ref/javascript/lib.texi +++ b/doc/ref/javascript/lib.texi @@ -116,22 +116,29 @@ This means that the @var{utc} field is @code{false}, and that Formats a Date object according to the format specification @var{str}. Keeping with Guile each format specifier starts with a ~. -@c table formatting borrowed from Gulie Reference (SRFI-19 Date to string) -@multitable {MMMM} {MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM} -@item @nicode{~~} @tab literal ~ +@table @samp +@item ~~ +literal ~ @c Almost all fields are left padded. How do I signify this @c with a single footnote? -@item @nicode{~Y} @tab year, left-padding with zeroes. -@item @nicode{~m} @tab month number, left padded with zeroes. -@item @nicode{~d} @tab day of month. -@item @nicode{~H} @tab hour -@item @nicode{~M} @tab minute -@item @nicode{~S} @tab second -@item @nicode{~Z} @tab 'Z' if Date is UTC, otherwise nothing - -@item @nicode{~L} @tab Converts the date to local time +@item ~Y +year, left-padding with zeroes. +@item ~m +month number, left padded with zeroes. +@item ~d +day of month. +@item ~H +hour +@item ~M +minute +@item ~S +second +@item ~Z +'Z' if Date is UTC, otherwise nothing +@item ~L +Converts the date to local time (@pxref{to_local}) (doesn't modify source object). Outputs nothing -@end multitable +@end table @end defmethod @defun format_date date str diff --git a/doc/ref/javascript/types.texi b/doc/ref/javascript/types.texi index b9e6dbbf..6f518f53 100644 --- a/doc/ref/javascript/types.texi +++ b/doc/ref/javascript/types.texi @@ -57,9 +57,8 @@ Alias of @code{'string'}. Alias for a record consisting of @itemize @bullet @item the name of the type, as a string -@item All parameters of the object, as a @code{Record<string, any}@ - @footnote{Which is simply a regular javascript object, mapping - strings to anything}. +@item All parameters of the object, as a @code{Record<string, any>} +@footnote{Which is simply a regular javascript object, mapping strings to anything}. @item An @code{ical_type} value, noting the type of the final field(s) @item And one or more values of the type specified by the third field. @end itemize diff --git a/doc/ref/javascript/user-additions.texi b/doc/ref/javascript/user-additions.texi new file mode 100644 index 00000000..706b1dd4 --- /dev/null +++ b/doc/ref/javascript/user-additions.texi @@ -0,0 +1,18 @@ +@node user-additions.js +@section user-additions.js + +Some things in the JavaScript code is built to be user-extendable. +The HTML-page attempts to load @code{/static/user/user-additions.js}. + + +Currently; this only entails @ref{formatters}, where you could, for +example, parse all HTTP-links in a description. + +@example +window.formatters.set('description', (el, d) => @{ + el.innerHTML = d.replaceAll(/https?:\/\/\S+/g, '<a href="$&">$&</a>'); +@}) +@end example + +Remember that the documents are X-HTML, so be @emph{extremely} careful +with innerHTML. diff --git a/doc/ref/javascript/vevent.texi b/doc/ref/javascript/vevent.texi index ae54cfd4..4ceaa380 100644 --- a/doc/ref/javascript/vevent.texi +++ b/doc/ref/javascript/vevent.texi @@ -31,6 +31,7 @@ through @code{calendar}). Almost all changes through these interfaces are logged, and can be viewed in @var{_changelog}. @deftypemethod VEvent {any?} getProperty {key: string} +@anchor{VEvent.getProperty} Returns the value of the given property if set, or undefined otherwise. For the keys @@ -1,15 +1,17 @@ # -*- mode: sh -*- -root=$(dirname $(realpath $BASH_SOURCE)) +_here=$(dirname "$(realpath "${BASH_SOURCE[0]}")") -GUILE_LOAD_PATH="$root/module:$GUILE_LOAD_PATH" -#GUILE_LOAD_COMPILED_PATH="$root/obj/module:$GUILE_LOAD_COMPILED_PATH" -#LD_LIBRARY_PATH="$root/lib:$LD_LIBRARY_PATH" +export GUILE=${GUILE:-guile} +guile_version=$($GUILE -c '(display (version))') -XDG_DATA_HOME=$root -LIBEXEC=$root/scripts/ +export GUILE_LOAD_COMPILED_PATH=${_here}/obj-${guile_version}:${GUILE_LOAD_COMPILED_PATH} +export GUILE_LOAD_PATH=${_here}/module:${GUILE_LOAD_PATH} +export GUILE_AUTO_COMPILE=0 + +# TODO why is this set? +export LIBEXEC=${_here}/scripts/ -export GUILE_LOAD_PATH GUILE_LOAD_COMPILED_PATH LD_LIBRARY_PATH XDG_DATA_HOME LIBEXEC #export GUILE_AUTO_COMPILE=0 # exec "$@" @@ -3,7 +3,6 @@ here=$(dirname $(realpath $0)) . $here/env -GUILE=${GUILE:-$(which guile)} -# GUILE_LOAD_PATH=$here/module +make GUILE="$GUILE" go_files exec $GUILE -c '((@ (calp main) main) (command-line))' "$@" diff --git a/module/base64.scm b/module/base64.scm index 594edf1f..c0080581 100644 --- a/module/base64.scm +++ b/module/base64.scm @@ -39,7 +39,10 @@ (+ 26 (- byte a))] [(<= zero byte nine) (+ 26 26 (- byte zero))] - [else (error "Invalid encoded value" byte (integer->char byte))])) + [else (scm-error 'decoding-error + "encoded->real" + "Invalid character in Base64 string: ~s" + (list byte) #f)])) (define ref (make-procedure-with-setter diff --git a/module/c/cpp.scm b/module/c/cpp.scm index c782e468..3f50fb87 100644 --- a/module/c/cpp.scm +++ b/module/c/cpp.scm @@ -5,7 +5,7 @@ :use-module (ice-9 match) :use-module (ice-9 regex) :use-module ((rnrs io ports) :select (call-with-port)) - :use-module (ice-9 pretty-print) ; used by one error handler + :use-module (ice-9 format) :use-module ((hnh util io) :select (read-lines)) :use-module (hnh util graph) :use-module (c lex) @@ -25,7 +25,10 @@ (aif (regexp-exec define-re header-line) (cons (match:substring it 1) (match:substring it 4)) - (error "Line dosen't match" header-line))) + (scm-error 'c-parse-error + "tokenize-define-line" + "Line dosen't match: ~s" + (list header-line) #f))) (define-public (do-funcall function arguments) @@ -99,7 +102,7 @@ (map (lambda (line) (catch #t (lambda () (parse-cpp-define line)) - (lambda (err caller fmt args . _) + (lambda (err caller fmt args data) (format #t "~a ~?~%" fmt args) #f))) lines)) diff --git a/module/c/parse.scm b/module/c/parse.scm index 3e3d8024..8030da77 100644 --- a/module/c/parse.scm +++ b/module/c/parse.scm @@ -34,7 +34,9 @@ [(LL) '(long-long)] [(L) '(long)] [(U) '(unsigned)]) - (error "Invalid integer suffix"))) + (scm-error 'c-parse-error "parse-integer-suffix" + "Invalid integer suffix ~s" + (list str) #f))) (define (parse-lexeme-tree tree) (match tree @@ -113,11 +115,11 @@ `(funcall ,(parse-lexeme-tree function) ,(parse-lexeme-tree arguments))] - [bare (throw 'parse-error - 'parse-lexeme-tree - "Naked literal in lex-tree. How did that get there?" - '() - bare)])) + [bare (scm-error 'c-parse-error + "parse-lexeme-tree" + "Naked literal in lex-tree: ~s" + (list bare) + #f)])) ;; https://en.wikipedia.org/wiki/Operators_in_C_and_C%2B%2B @@ -175,7 +177,11 @@ (parse-lexeme-tree op) (mark-other (parse-lexeme-tree right)))] - [other (error "Not an infix tree ~a" other)])) + [other (scm-error 'c-parse-error + "flatten-infix" + "Not an infix tree ~a" + (list other) + #f)])) diff --git a/module/calp/entry-points/convert.scm b/module/calp/entry-points/convert.scm index 5f298de4..d416b004 100644 --- a/module/calp/entry-points/convert.scm +++ b/module/calp/entry-points/convert.scm @@ -69,7 +69,7 @@ (@ (vcomponent formats xcal parse) sxcal->vcomponent) ;; TODO strip *TOP* xml->sxml)] - [else (error "")] + [else (scm-error 'misc-error "convert-main" "Unexpected parser type: ~a" (list from) #f)] )) (define writer @@ -86,7 +86,7 @@ (sxml->xml ((@ (vcomponent formats xcal output) vcomponent->sxcal) component) port))] - [else (error "")])) + [else (scm-error 'misc-error "convert-main" "Unexpected writer type: ~a" (list to) #f)])) (call-with-output-file outfile diff --git a/module/calp/entry-points/html.scm b/module/calp/entry-points/html.scm index 2a559794..8478aa6c 100644 --- a/module/calp/entry-points/html.scm +++ b/module/calp/entry-points/html.scm @@ -1,6 +1,7 @@ (define-module (calp entry-points html) :export (main) :use-module (hnh util) + :use-module ((hnh util exceptions) :select (warning)) :use-module ((hnh util path) :select (path-append)) :use-module (calp util time) :use-module (hnh util options) @@ -63,16 +64,31 @@ for embedding in a larger page. Currently only applies to the <i>small</i> style ;; file existing but is of wrong type, (define (create-files output-directory) - - (let* ((link (path-append output-directory "static"))) - - (unless (file-exists? output-directory) - (mkdir output-directory)) - - ;; TODO nicer way to resolve static - (let ((link (path-append output-directory "static"))) - (unless (file-exists? link) - (symlink (path-append (xdg-data-home) "calp" "www" "static") link))))) + (define link (path-append output-directory "static")) + ;; NOTE the target path is newer created + (define target (path-append (xdg-data-home) "calp" "www" "static")) + + (unless (file-exists? output-directory) + (mkdir output-directory)) + + (catch 'system-error + (lambda () (symlink target link)) + (lambda (err proc fmt fmt-args data) + (define errno (car data)) + (cond ((= errno EACCES) + (warning (format #f "~?" fmt fmt-args))) + ((= errno EEXIST) + (let ((st (lstat link))) + (cond ((not (eq? 'symlink (stat:type st))) + (warning "File ~s exists, but isn't a symlink" link)) + ((not (string=? target (readlink link))) + (warning "~s is a symlink, but points to ~s instead of expected ~s" + link (readlink link) target)))) + ;; else, file exists as a symlink, and points where we want, + ;; which is expected. Do nothing and be happy. + ) + ;; Rethrow + (else (scm-error err proc fmt fmt-args data)))))) (define (re-root-static tree) @@ -164,7 +180,7 @@ for embedding in a larger page. Currently only applies to the <i>small</i> style pre-start: (start-of-week start) post-end: (end-of-week (end-of-month start)))] [else - (error (_ "Unknown html style: ~a") style)]) + (scm-error 'misc-error "html-main" (_ "Unknown html style: ~a") (list style) #f)]) ((@ (calp util time) report-time!) (_ "all done")) ) diff --git a/module/calp/entry-points/import.scm b/module/calp/entry-points/import.scm index 28fb72a6..cb8b9485 100644 --- a/module/calp/entry-points/import.scm +++ b/module/calp/entry-points/import.scm @@ -4,6 +4,7 @@ :use-module (hnh util options) :use-module (ice-9 getopt-long) :use-module (ice-9 rdelim) + :use-module (ice-9 format) :use-module (srfi srfi-1) ;; TODO FIX ;; :use-module (output vdir) diff --git a/module/calp/entry-points/server.scm b/module/calp/entry-points/server.scm index d42a5d3a..1888a8a7 100644 --- a/module/calp/entry-points/server.scm +++ b/module/calp/entry-points/server.scm @@ -6,6 +6,7 @@ :use-module (srfi srfi-1) :use-module (ice-9 getopt-long) + :use-module (ice-9 format) :use-module (calp translation) :use-module (sxml simple) diff --git a/module/calp/html/components.scm b/module/calp/html/components.scm index 0d6fbf1c..6642b1fe 100644 --- a/module/calp/html/components.scm +++ b/module/calp/html/components.scm @@ -58,7 +58,10 @@ allow-other-keys: rest: args) (when (and onclick href) - (error (_ "Only give one of onclick, href and submit."))) + (scm-error 'wrong-type-arg "btn" + (_ "href and onclick are mutually exclusive. href = ~s, onclick = ~s.") + (list href onclick) + #f)) (let ((body #f)) `(,(cond [href 'a] diff --git a/module/calp/html/util.scm b/module/calp/html/util.scm index aa3d9233..affaf5d2 100644 --- a/module/calp/html/util.scm +++ b/module/calp/html/util.scm @@ -18,6 +18,7 @@ ;; Returns a color with good contrast to the given background color. ;; https://stackoverflow.com/questions/1855884/determine-font-color-based-on-background-color/1855903#1855903 (define-public (calculate-fg-color c) + ;; TODO what errors can actually appear here? (catch #t (lambda () (define (str->num c n) (string->number (substring/shared c n (+ n 2)) 16)) diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm index ffdd37e2..5c92e1e7 100644 --- a/module/calp/html/vcomponent.scm +++ b/module/calp/html/vcomponent.scm @@ -3,6 +3,7 @@ ;; TODO should we really use path-append here? Path append is ;; system-dependant, while URL-paths aren't. :use-module ((hnh util path) :select (path-append)) + :use-module ((hnh util exceptions) :select (warning)) :use-module (srfi srfi-1) :use-module (srfi srfi-41) :use-module ((rnrs io ports) :select (put-bytevector)) @@ -18,15 +19,37 @@ :use-module ((vcomponent recurrence) :select (repeating?)) :use-module ((vcomponent datetime output) :select (fmt-time-span - format-description - format-summary format-recurrence-rule )) - :use-module ((calp util config) :select (get-config)) + :use-module (calp util config) :use-module ((base64) :select (base64encode)) + :use-module (ice-9 format) :use-module (calp translation) ) +(define-config summary-filter (lambda (_ a) a) + pre: (ensure procedure?)) + +(define-config description-filter (lambda (_ a) a) + pre: (ensure procedure?)) + + +(define-public (format-summary ev str) + ((get-config 'summary-filter) ev str)) + +;; NOTE this should have information about context (html/term/...) +;; And then be moved somewhere else. +(define-public (format-description ev str) + (catch* (lambda () ((get-config 'description-filter) ev str)) + (configuration-error + (lambda (key subr msg args data) + (format (current-error-port) + "Error retrieving configuration, ~?~%" msg args))) + (#t ; for errors when running the filter + (lambda (err . args) + (warning "~a on formatting description, ~s" err args) + str)))) + ;; used by search view (define-public (compact-event-list list) @@ -222,11 +245,11 @@ (stream-map (lambda (ev) (fmt-single-event - ev `((id ,(html-id ev)) + ev `((id ,(html-id ev) "-side") (data-calendar ,(base64encode (or (prop (parent ev) 'NAME) "unknown")))) fmt-header: (lambda body - `(a (@ (href "#" ,(html-id ev) #; (date-link (as-date (prop ev 'DTSTART))) + `(a (@ (href "#" ,(html-id ev) "-block" #; (date-link (as-date (prop ev 'DTSTART))) ) (class "hidelink")) ,@body)))) @@ -259,11 +282,11 @@ ;; surrounding <a /> element which allows something to happen when an element ;; is clicked with JS turned off. Our JS disables this, and handles clicks itself. - `((a (@ (href "#" ,(html-id ev)) + `((a (@ (href "#" ,(html-id ev) "-side") (class "hidelink")) (vevent-block (@ ,@(assq-merge extra-attributes - `((id ,(html-id ev)) + `((id ,(html-id ev) "-block") (data-calendar ,(base64encode (or (prop (parent ev) 'NAME) "unknown"))) (data-uid ,(output-uid ev)) diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm index c7a5c8c2..d4ad2977 100644 --- a/module/calp/html/view/calendar.scm +++ b/module/calp/html/view/calendar.scm @@ -27,6 +27,8 @@ :use-module ((vcomponent util group) :select (group-stream get-groups-between)) :use-module ((base64) :select (base64encode)) + + :use-module (ice-9 format) :use-module (calp translation) ) @@ -73,10 +75,10 @@ ,display))) (unless next-start - (error 'html-generate (_ "Next-start needs to be a procedure"))) + (scm-error 'misc-error "html-generate" (_ "Next-start needs to be a procedure") #f #f)) (unless prev-start - (error 'html-generate (_ "Prev-start needs to be a procedure"))) + (scm-error 'misc-error "html-generate" (_ "Prev-start needs to be a procedure") #f #f)) (xhtml-doc (@ (lang sv)) @@ -118,11 +120,12 @@ window.default_calendar='~a';" ,(include-alt-css "/static/light.css" '(title "Light")) (script (@ (src "/static/script.out.js"))) + (script (@ (src "/static/user/user-additions.js"))) ,(calendar-styles calendars) ,@(when (debug) - '((style ".root { background-color: pink; }")))) + '((style ":root { --background-color: pink; }")))) (body (div (@ (class "root")) diff --git a/module/calp/html/view/calendar/shared.scm b/module/calp/html/view/calendar/shared.scm index 11f1a70c..e333dc4a 100644 --- a/module/calp/html/view/calendar/shared.scm +++ b/module/calp/html/view/calendar/shared.scm @@ -1,21 +1,19 @@ (define-module (calp html view calendar shared) :use-module (hnh util) - :use-module ((hnh util exceptions) :select (assert)) :use-module (srfi srfi-1) :use-module (vcomponent) :use-module ((vcomponent datetime) :select (event-length overlapping? event-length/clamped)) - :use-module ((vcomponent datetime output) - :select (format-summary)) :use-module (hnh util tree) :use-module (datetime) :use-module (calp html config) :use-module ((calp html components) :select (btn tabset)) :use-module ((calp html vcomponent) - :select (make-block) ) + :select (make-block format-summary)) + :use-module (ice-9 format) ) @@ -33,7 +31,10 @@ ;; only find events which also overlaps the ;; smaller event. - (assert event-length-key) + (unless event-length-key + (scm-error 'wrong-type-arg "fix-event-widths!" + "event-length-key is required" + #f #f)) ;; @var{x} is how for left in the container we are. (let inner ((x 0) diff --git a/module/calp/html/view/calendar/week.scm b/module/calp/html/view/calendar/week.scm index 921bdb83..16337102 100644 --- a/module/calp/html/view/calendar/week.scm +++ b/module/calp/html/view/calendar/week.scm @@ -20,6 +20,7 @@ :use-module (calp translation) :use-module ((vcomponent util group) :select (group-stream get-groups-between)) + :use-module (ice-9 format) ) diff --git a/module/calp/main.scm b/module/calp/main.scm index ebff00fd..e5388ae0 100644 --- a/module/calp/main.scm +++ b/module/calp/main.scm @@ -119,8 +119,11 @@ the same code as <b>ical</b>.</p>") (cond [altconfig (if (file-exists? altconfig) altconfig - (throw 'option-error - (_ "Configuration file ~a missing") altconfig))] + (scm-error 'misc-error + "wrapped-main" + (_ "Configuration file ~a missing") + (list altconfig) + #f))] ;; altconfig could be placed in the list below. But I want to raise an error ;; if an explicitly given config is missing. [(find file-exists? @@ -159,7 +162,7 @@ the same code as <b>ical</b>.</p>") (reverse done) (loop (cons form done)))))))) (make-sandbox-module - `(((guile) use-modules) + `(((guile) use-modules resolve-interface module-ref) ,@all-pure-and-impure-bindings )) )) @@ -215,7 +218,10 @@ the same code as <b>ical</b>.</p>") (when (option-ref opts 'update-zoneinfo #f) (let* ((locations (list "/usr/libexec/calp/tzget" (path-append (xdg-data-home) "tzget"))) (filename (or (find file-exists? locations) - (error (_ "tzget not installed, please put it in one of ~a") locations))) + (scm-error 'missing-helper "wrapped-main" + (_ "tzget not installed, please put it in one of ~a") + (list locations) + (list "tzget" locations)))) (pipe (open-input-pipe filename))) ;; (define path (read-line pipe)) @@ -237,6 +243,8 @@ the same code as <b>ical</b>.</p>") '("term")))) ((case (string->symbol (car ropt)) ((html) (@ (calp entry-points html) main)) + ;; TODO chnange term to be non-interactive term + ;; and then add interactive-term (or similar) ((term) (@ (calp entry-points terminal) main)) ((import) (@ (calp entry-points import) main)) ((text) (@ (calp entry-points text) main)) diff --git a/module/calp/repl.scm b/module/calp/repl.scm index 9b2df13f..6f2c7c0a 100644 --- a/module/calp/repl.scm +++ b/module/calp/repl.scm @@ -22,8 +22,9 @@ [else 'UNIX]) [(UNIX) (add-hook! shutdown-hook (lambda () (catch 'system-error (lambda () (delete-file address)) - (lambda (err proc fmt . args) - (warning (_ "Failed to unlink ~a") address args) + (lambda (err proc fmt args data) + (warning (string-append (format #f (_ "Failed to unlink ~a") address) + (format #f ": ~?" fmt args))) err)))) (make-unix-domain-server-socket path: address)] [(IPv4) (apply (case-lambda diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index 2f3544ee..d05451eb 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -1,14 +1,13 @@ (define-module (calp server routes) :use-module (hnh util) - :use-module ((hnh util path) :select (path-append)) - :use-module (hnh util options) + :use-module (hnh util path) :use-module (hnh util exceptions) :use-module (srfi srfi-1) :use-module ((ice-9 rdelim) :select (read-string)) :use-module ((ice-9 ftw) :select (scandir)) - :use-module (ice-9 regex) #| regex here due to bad macros |# + :use-module (ice-9 format) :use-module ((web response) :select (build-response)) :use-module ((web uri) :select (build-relative-ref)) @@ -32,6 +31,7 @@ :autoload (vcomponent util instance) (global-event-object) + :use-module (calp util config) :use-module (calp html view calendar) :use-module ((calp html view search) :select (search-result-page)) @@ -47,27 +47,50 @@ -(define (directory-table dir) - `(table - (thead - (tr (th "") (th ,(_ "Name")) - ;; File permissions, should be about as long as three digits - (th ,(_ "Perm")))) +;; @var{prefix} directory tree which should be exported +;; @var{dir} location in exported directory tree +;; Note that the exported url is currently hard-coded to +;; start with /static. +(define (directory-table prefix dir) + `(table (@ (class "directory-table")) + (thead + (tr (th "") + (th ,(_ "Name")) + ;; File permissions, should be about as long as three digits + (th ,(_ "Perm")) + ;; File size + (th ,(_ "Size")))) (tbody + (tr (td "↩️") (td (@ (colspan 3)) + (a (@ (href ,(-> (path-split dir) + (drop-right 1) + (xcons "/static") + path-join))) + "Return up"))) ,@(map (lambda (k) - (let* ((stat (lstat (path-append dir k)))) + (let* ((stat (lstat (path-append prefix dir k)))) `(tr (td ,(case (stat:type stat) [(directory) "📁"] [(regular) "📰"] + [(symlink) "🔗"] + [(block-special) "🖴"] + [(char-special) "🔌"] + ;; [(fifo)] + ;; [(socket)] [else "🙃"])) - (td (a (@ (href "/" ,dir "/" ,k)) ,k)) - (td ,(number->string (stat:perms stat) 8))))) - (cdr (or (scandir dir) - (scm-error - 'misc-error - "directory-table" - (_ "Scandir argument invalid or not directory: ~a") - (list dir) '()))))))) + (td (a (@ (href ,(path-append "/static" dir k))) + ,k)) + (td ,(number->string (stat:perms stat) 8)) + (td (@ (style "text-align:end")) + (data (@ (value ,(stat:size stat))) + ,(format #f "~:d" (stat:size stat))))))) + ;; cddr drops '.' and '..' + (cddr (or (scandir (path-append prefix dir)) + (scm-error + 'misc-error + "directory-table" + (_ "Scandir argument invalid or not directory: ~s") + (list dir) '()))))))) @@ -88,6 +111,14 @@ +(define static-dir (make-parameter "static")) + +(define-config static-dir "static" + description: "Where static files for the web server are located" + post: static-dir + ) + + ;; TODO ensure encoding on all fields which take user provided data. ;; Possibly a fallback which strips everything unknown, and treats @@ -234,70 +265,22 @@ ;; accidental overwriting. - (cond - [(get-event-by-uid global-event-object (prop event 'UID)) - => (lambda (old-event) - - ;; remove old instance of event from runtime - ((@ (vcomponent util instance methods) remove-event) - global-event-object old-event) - - ;; Add new event to runtime, - ;; MUST be done after since the two events SHOULD share UID. - (parameterize ((warnings-are-errors #t)) - (catch 'warning - (lambda () (add-event global-event-object calendar event)) - (lambda (err fmt args) - (return (build-response code: 400) - (format #f "~?~%" fmt args))))) - - (set! (prop event 'LAST-MODIFIED) - (current-datetime)) - - ;; NOTE Posibly defer save to a later point. - ;; That would allow better asyncronous preformance. - - ;; save-event sets -X-HNH-FILENAME from the UID. This is fine - ;; since the two events are guaranteed to have the same UID. - (unless ((@ (vcomponent formats vdir save-delete) save-event) event) - (return (build-response code: 500) - (_ "Saving event to disk failed."))) - - - (unless (eq? calendar (parent old-event)) - ;; change to a new calendar - (format (current-error-port) - ;; unlinks (removes) a single event, argument is a file name - (_ "Unlinking old event from ~a~%") - (prop old-event '-X-HNH-FILENAME)) - ;; NOTE that this may fail, leading to a duplicate event being - ;; created (since we save beforehand). This is just a minor problem - ;; which either a better atomic model, or a propper error - ;; recovery log would solve. - ((@ (vcomponent formats vdir save-delete) remove-event) old-event)) - - - (format (current-error-port) - (_ "Event updated ~a~%") (prop event 'UID)))] - - [else - (parameterize ((warnings-are-errors #t)) - (catch 'warning - (lambda () (add-event global-event-object calendar event)) - (lambda (err fmt args) - (return (build-response code: 400) - (format #f "~?~%" fmt args))))) - - (set! (prop event 'LAST-MODIFIED) (current-datetime)) - - ;; NOTE Posibly defer save to a later point. - ;; That would allow better asyncronous preformance. - (unless ((@ (vcomponent formats vdir save-delete) save-event) event) - (return (build-response code: 500) - (_ "Saving event to disk failed."))) - - (format (current-error-port) - (_ "Event inserted ~a~%") (prop event 'UID))]) + (parameterize ((warnings-are-errors #t)) + (catch* + (lambda () (add-and-save-event global-event-object + calendar event)) + (warning + (lambda (err fmt args) + (define str (format #f "~?" fmt args)) + (format (current-error-port) "400 ~a~%" str) + (return (build-response code: 400) + str))) + (#t + (lambda (err proc fmt args _) + (define str (format #f "~a in ~a: ~?~%" err proc fmt args)) + (format (current-error-port) "500 ~a~%" str) + (return (build-response code: 500) + str))))) (return '((content-type application/xml)) (with-output-to-string @@ -395,28 +378,27 @@ (define error #f) (define search-result - (catch #t - (lambda () - (catch 'max-page - ;; TODO Get-page only puts a time limiter per page, meaning that - ;; if a user requests page 1000 the server is stuck trying to - ;; find that page, which can take up to 1000 * timeslice = 500s = 8min+ - ;; A timeout here, and also an actual multithreaded server should - ;; solve this. - (lambda () (get-page paginator page)) - (lambda (err page-number) - (define location - (build-relative-ref - path: r:path ; host: r:host port: r:port - query: (encode-query-parameters - `((p . ,page-number) - (q . ,search-term))))) - (return (build-response - code: 307 - headers: `((location . ,location))))))) - (lambda (err callee fmt arg data) - (set! error - (format #f "~?~%" fmt arg))))) + ;; TODO Get-page only puts a time limiter per page, meaning that + ;; if a user requests page 1000 the server is stuck trying to + ;; find that page, which can take up to 1000 * timeslice = 500s = 8min+ + ;; A timeout here, and also an actual multithreaded server should + ;; solve this. + (catch* (lambda () (get-page paginator page)) + (max-page + (lambda (err page-number) + (define location + (build-relative-ref + path: r:path ; host: r:host port: r:port + query: (encode-query-parameters + `((p . ,page-number) + (q . ,search-term))))) + (return (build-response + code: 307 + headers: `((location . ,location)))))) + (#t + (lambda (err callee fmt arg data) + (set! error + (format #f "~?~%" fmt arg)))))) (return '((content-type application/xhtml+xml)) (with-output-to-string @@ -431,6 +413,7 @@ ;; is mostly for development, and something like nginx should be used in ;; production it isn't a huge problem. + (GET "/static/:*{.*}.:ext" (* ext) ;; Actually parsing /etc/mime.types would be better. @@ -439,16 +422,33 @@ [(js) "javascript"] [else ext])) - (return - `((content-type ,(string->symbol (string-append "text/" mime)))) - (call-with-input-file (string-append "static/" * "." ext) - read-string))) - - (GET "/static/:*{.*}" (*) - (return - '((content-type text/html)) - (sxml->html-string - (directory-table (path-append "static" *))))) + (catch 'system-error + (lambda () + (return + `((content-type ,(string->symbol (string-append "text/" mime)))) + (call-with-input-file (path-append (static-dir) (string-append * "." ext)) + read-string))) + (lambda (err proc fmt fmt-args data) + (warning (format #f "404|500: ~?" fmt fmt-args)) + (if (= ENOENT (car data)) + (return (build-response code: 404) + (format #f "~?" fmt fmt-args)) + (scm-error err proc fmt fmt-args data))))) + + ;; Note that `path' will most likely start with a slash + (GET "/static:path{.*}" (path) + (catch + 'misc-error + (lambda () (return + '((content-type text/html)) + (sxml->html-string + `(html + (head (title "Calp directory listing for " path) + ,((@ (calp html components) include-css) "/static/directory-listing.css")) + (body ,(directory-table (static-dir) path)))))) + (lambda (err proc fmt fmt-args data) + (return (build-response code: 404) + (format #f "~?" fmt fmt-args))))) ;; This is almost the same as /static/, but with the difference that ;; we produce these images during runtime diff --git a/module/calp/terminal.scm b/module/calp/terminal.scm index e982c468..d91dc584 100644 --- a/module/calp/terminal.scm +++ b/module/calp/terminal.scm @@ -32,6 +32,9 @@ #:export (main-loop)) + +;;; TODO change all hard coded escape sequences to proper markup + (define-values (height width) (get-terminal-size)) (define (open-in-editor fname) @@ -123,7 +126,8 @@ (cls) - (display (_ "== Day View ==\n")) + (display (_ "== Day View ==")) + (newline) (display-calendar-header! (current-page this)) diff --git a/module/calp/util/config.scm b/module/calp/util/config.scm index 2637cd85..3bc55d92 100644 --- a/module/calp/util/config.scm +++ b/module/calp/util/config.scm @@ -38,10 +38,13 @@ (define (define-config% name default-value kwargs) (for (key value) in (group kwargs 2) - (set! ((or (hashq-ref config-properties key) - (error (_ "Missing config protperty slot ") key)) - name) - value)) + (aif (hashq-ref config-properties key) + (set! (it name) value) + (scm-error 'configuration-error + "define-config" + (_ "No configuration slot named ~s, when defining ~s") + (list key name) + #f))) (set-config! name (get-config name default-value))) (define-syntax define-config @@ -54,7 +57,14 @@ (define-public (set-config! name value) (hashq-set! config-values name (aif (pre name) - (or (it value) (error (_ "Pre crashed for") name)) + (or (it value) + (scm-error 'configuration-error + "set-config!" + ;; first slot is property name, second is new + ;; property value. + (_ "Pre-property failed when setting ~s to ~s") + (list name value) + #f)) value)) (awhen (post name) (it value))) @@ -65,15 +75,18 @@ (if (eq? default %uniq) (let ((v (hashq-ref config-values key %uniq))) (when (eq? v %uniq) - (error (_ "Missing config") key)) + (scm-error 'configuration-error + "get-config" + (_ "No configuration item named ~s") + (list key) #f)) v) (hashq-ref config-values key default))) (define-public ((ensure predicate) value) - (if (not (predicate value)) - #f value)) + (if (predicate value) + value #f)) @@ -107,6 +120,8 @@ (export format-procedure) +;; TODO break this up into separate `get-all-configuration-items' and +;; `format-configuration-items' procedures (define-public (get-configuration-documentation) (define groups (group-by (compose source-module car) diff --git a/module/calp/util/time.scm b/module/calp/util/time.scm index 0a624d30..f3789eeb 100644 --- a/module/calp/util/time.scm +++ b/module/calp/util/time.scm @@ -1,5 +1,6 @@ (define-module (calp util time) :use-module (ice-9 match) + :use-module (ice-9 format) :export (report-time! profile!)) diff --git a/module/crypto.scm b/module/crypto.scm index 3e468018..477014e9 100644 --- a/module/crypto.scm +++ b/module/crypto.scm @@ -1,6 +1,7 @@ (define-module (crypto) :use-module (rnrs bytevectors) :use-module (system foreign) + :use-module (ice-9 format) :export (sha256 checksum->string)) (define-once libcrypto (dynamic-link "libcrypto")) @@ -21,17 +22,15 @@ (define bv (cond ((bytevector? msg) msg) ((string? msg) (string->utf8 msg)) - (else (throw 'value-error "Invalid type")))) + (else (scm-error 'wrong-type-arg "sha256" + "Wrong type argument. Expected string or bytevector, got ~s" + (list msg) (list msg))))) (SHA256 ((@ (system foreign) bytevector->pointer) bv) (bytevector-length bv) ((@ (system foreign) bytevector->pointer) md)) md) -(define (checksum->string md) - (string-concatenate - (map (lambda (byte) - (format #f "~x~x" - (logand #xF (ash byte -4)) - (logand #xF byte))) - (bytevector->u8-list md)))) +(define* (checksum->string md #:optional port) + ((@ (ice-9 format) format) port + "~{~2'0x~}" (bytevector->u8-list md))) diff --git a/module/datetime.scm b/module/datetime.scm index 3b03bf53..478fc479 100644 --- a/module/datetime.scm +++ b/module/datetime.scm @@ -10,12 +10,10 @@ :use-module (srfi srfi-9 gnu) :use-module ((hnh util) - :select (vector-last define*-public set! -> swap case* set + :select (vector-last define*-public set! -> ->> swap case* set span-upto let* set->)) :use-module (srfi srfi-41) - :use-module ((srfi srfi-41 util) - :select (with-streams)) :use-module (ice-9 i18n) :use-module (ice-9 format) :use-module (ice-9 regex) @@ -67,6 +65,11 @@ (year year) (month month) (day day)) (define*-public (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! @@ -74,7 +77,7 @@ (lambda (r p) (catch 'misc-error (lambda () (display (date->string r "#~Y-~m-~d") p)) - (lambda (err _ fmt args . rest) + (lambda (err proc fmt args data) (format p "#<<date> BAD year=~s month=~s day=~s>" (year r) (month r) (day r)))))) @@ -535,14 +538,15 @@ (iota (modulo (- (* 7 5) month-len month-start) 7) 1))))) +;; The amount of days in the given interval, both end pointts inclusive (define-public (days-in-interval start-date end-date) (let ((diff (date-difference (date+ end-date (date day: 1)) start-date))) - (with-streams - (fold + (day diff) - (map days-in-month - (take (+ (month diff) - (* 12 (year diff))) - (month-stream start-date))))))) + (->> (month-stream start-date) + (stream-take (+ (month diff) + (* 12 (year diff)))) + (stream-map days-in-month) + (stream-fold + (day diff))))) + ;; Day from start of the year, so 1 feb would be day 32. ;; Also known as Julian day. @@ -676,6 +680,11 @@ Returns -1 on failure" [else dt])) (cond [(null? str) + ;; TODO should this be considered an error? + ;; Should it be toggleable through a flag. + ;; It's sometimes useful to allow it, since it allows optional + ;; trailing fields, but sometimes useful to disallow it, since + ;; it gives a better check that the data is valid ;; ((@ (hnh util exceptions) warning) ;; "Premature end of string, still got fmt = ~s" ;; fmt) @@ -736,11 +745,15 @@ Returns -1 on failure" (let* ((head post (cond ((null? (cddr fmt)) (values str '())) ((eqv? #\~ (caddr fmt)) (cond ((null? (cdddr fmt)) - (error "Unexpected ~ at end of fmt")) + (scm-error 'misc-error "string->datetime" + "Unexpected ~ at end of fmt" + #f #f)) ((eqv? #\~ (cadddr fmt)) (span (lambda (c) (not (eqv? #\~ c))) str)) - (else (error "Can't have format specifier directly after month by name")))) + (else (scm-error 'misc-error "string->datetime" + "Can't have format specifier directly after month by name" + #f #f)))) (else (span (lambda (c) (not (eqv? c (caddr fmt)))) str))))) (loop post @@ -1125,7 +1138,7 @@ Returns -1 on failure" ;; overflow is number of days above ;; time x time → time x int -(define-public (time+% base change) +(define (time+% base change) ;; while (day base) > (days-in-month base) ;; month++; days -= (days-in-month base) diff --git a/module/datetime/timespec.scm b/module/datetime/timespec.scm index ea29a423..099634b6 100644 --- a/module/datetime/timespec.scm +++ b/module/datetime/timespec.scm @@ -65,15 +65,6 @@ specs)) -(define (parse-time string) - (apply (lambda* (hour optional: (minute "0") (second "0")) - (time hour: (string->number hour) - minute: (string->number minute) - ;; discard sub-seconds - second: (string->number (car (string-split second #\.))))) - (string-split string #\:))) - - (define*-public (parse-time-spec string optional: (suffixes '(#\s #\w #\u #\g #\z))) (let* ((type string @@ -82,11 +73,12 @@ (values (string-ref string idx) (substring string 0 idx)))] [else (values #\w string)]))) + ;; Note that string->time allows a longer format than the input (cond [(string=? "-" string) (make-timespec (time) '+ type)] [(string-prefix? "-" string) - (make-timespec (parse-time (string-drop string 1)) + (make-timespec (string->time (string-drop string 1) "~H:~M:~S") '- type)] [else - (make-timespec (parse-time string) + (make-timespec (string->time string "~H:~M:~S") '+ type)]))) diff --git a/module/datetime/zic.scm b/module/datetime/zic.scm index 0362ec99..e2600d4f 100644 --- a/module/datetime/zic.scm +++ b/module/datetime/zic.scm @@ -92,14 +92,14 @@ ;; @end example (define-public (get-zone zoneinfo name) (or (hash-ref (zoneinfo-zones zoneinfo) name) - (error "No zone ~a" name))) + (scm-error 'misc-error "get-zone" "No zone ~a" (list name) #f))) ;; @example ;; (get-rule zoneinfo 'EU) ;; @end example (define-public (get-rule zoneinfo name) (or (hashq-ref (zoneinfo-rules zoneinfo) name) - (error "No rule ~a" name))) + (scm-error 'misc-error "get-rule" "No rule ~a" (list name) #f))) @@ -119,7 +119,9 @@ [(string-prefix? name "October") 10] [(string-prefix? name "November") 11] [(string-prefix? name "December") 12] - [else (error "Unknown month" name)])) + [else (scm-error 'misc-error "month-name->number" + "Unknown month ~s" (list name) + #f)])) (define (string->weekday name) @@ -131,7 +133,9 @@ [(string-prefix? name "Friday") fri] [(string-prefix? name "Saturday") sat] [(string-prefix? name "Sunday") sun] - [else (error "Unknown week day" name)])) + [else (scm-error 'misc-error "string->weekday" + "Unknown week day ~s" + (list name) #f)])) (define (parse-from str) @@ -259,8 +263,10 @@ ;; NOTE an earlier version of the code the parsers for those. ;; They were removed since they were unused, uneeded, and was ;; technical dept. - (error (_ "Invalid key ~a. Note that leap seconds and -expries rules aren't yet implemented.") type)] + (scm-error 'misc-error "parse-zic-file" + (_ "Invalid key ~s. Note that leap seconds and expries rules aren't yet implemented.") + (list type) + #f)] ))])))))) @@ -357,7 +363,9 @@ expries rules aren't yet implemented.") type)] until: (let ((to (rule-to rule))) (case to ((maximum) #f) - ((minimum) (error (_ "Check your input"))) + ((minimum) (scm-error 'misc-error "rule->rrule" + (_ "Check your input") + #f #f)) ((only) (datetime date: (date year: (rule-from rule) month: 1 day: 1))) @@ -403,4 +411,12 @@ expries rules aren't yet implemented.") type)] (warning (_ "%z not yet implemented")) fmt-string] - [else (error (_ "Invalid format char"))]))) + [else (scm-error 'misc-error "zone-format" + ;; first slot is the errornous character, + ;; second is the whole string, third is the index + ;; of the faulty character. + (_ "Invalid format char ~s in ~s at position ~a") + (list (string-index fmt-string (1+ idx)) + fmt-string + (1+ idx)) + #f)]))) diff --git a/module/glob.scm b/module/glob.scm index a436b810..82489565 100644 --- a/module/glob.scm +++ b/module/glob.scm @@ -6,8 +6,10 @@ (define (glob-err epath eerrno) - (error "Glob errored on ~s with errno = ~a" - (pointer->string epath) eerrno)) + (scm-error 'misc-error "glob-err" + "Glob errored on ~s with errno = ~a" + (list (pointer->string epath) eerrno) + #f)) ;; NOTE there really should be an (c eval) module, to resolve symbols such as ;; @var{<<}. @@ -29,7 +31,10 @@ (procedure->pointer int glob-err (list '* int)) (bytevector->pointer bv)))) (unless (zero? globret) - (error "Globret errror ~a" globret)) + (scm-error 'misc-error "glob" + "Globret errror ~a" + (list globret) + #f)) (let* ((globstr (parse-c-struct (bytevector->pointer bv) (list size_t '* size_t))) (strvec (pointer->bytevector (cadr globstr) (car globstr) 0 (string->symbol (format #f "u~a" (* 8 (sizeof '*)))))) diff --git a/module/hnh/util.scm b/module/hnh/util.scm index 8cbc8c8d..3019b35b 100644 --- a/module/hnh/util.scm +++ b/module/hnh/util.scm @@ -13,6 +13,7 @@ and=>> label print-and-return begin1 + catch* ) #:replace (let* set! define-syntax when unless)) @@ -247,18 +248,20 @@ ;; and the other items in some order. ;; Ord b => (list a) [, (b, b -> bool), (a -> b)] -> a, (list a) (define*-public (find-extreme items optional: (< <) (access identity)) - (if (null? items) - (error "Can't find extreme in an empty list") - (fold-values - (lambda (c min other) - (if (< (access c) (access min)) - ;; Current stream head is smaller that previous min - (values c (cons min other)) - ;; Previous min is still smallest - (values min (cons c other)))) - (cdr items) - ;; seeds: - (car items) '()))) + (when (null? items) + (scm-error 'wrong-type-arg "find-extreme" + "Can't find extreme in an empty list" + #f #f)) + (fold-values + (lambda (c min other) + (if (< (access c) (access min)) + ;; Current stream head is smaller that previous min + (values c (cons min other)) + ;; Previous min is still smallest + (values min (cons c other)))) + (cdr items) + ;; seeds: + (car items) '())) (define*-public (find-min list optional: (access identity)) (find-extreme list < access)) @@ -576,8 +579,10 @@ (for-each (lambda (pair) (setenv (car pair) (caddr pair))) env-pairs))))])) - -(define-public (uuidgen) - ((@ (rnrs io ports) call-with-port) - ((@ (ice-9 popen) open-input-pipe) "uuidgen") - (@ (ice-9 rdelim) read-line))) +(define-syntax catch* + (syntax-rules () + ((_ thunk (key handler)) + (catch (quote key) thunk handler)) + ((_ thunk (key handler) rest ...) + (catch* (lambda () (catch (quote key) thunk handler)) + rest ...)))) diff --git a/module/hnh/util/exceptions.scm b/module/hnh/util/exceptions.scm index bcfd506d..eed310bb 100644 --- a/module/hnh/util/exceptions.scm +++ b/module/hnh/util/exceptions.scm @@ -6,7 +6,7 @@ #:use-module ((system vm frame) :select (frame-bindings binding-ref)) - #:export (assert)) + ) (define-public warning-handler @@ -31,20 +31,6 @@ (raise 2) ) -(define (prettify-tree tree) - (cond [(pair? tree) (cons (prettify-tree (car tree)) - (prettify-tree (cdr tree)))] - [(and (procedure? tree) (procedure-name tree)) - => identity] - [else tree])) - - -(define-macro (assert form) - `(unless ,form - (throw 'assertion-error "Assertion failed. ~a expected, ~a got" - (quote ,form) - ((@@ (calp util exceptions) prettify-tree) (list ,form))))) - (define-public (filter-stack pred? stk) (concatenate diff --git a/module/hnh/util/graph.scm b/module/hnh/util/graph.scm index 912f9612..03c2ae3c 100644 --- a/module/hnh/util/graph.scm +++ b/module/hnh/util/graph.scm @@ -73,8 +73,9 @@ (define-public (find-and-remove-node-without-dependencies graph) (let ((node (find-node-without-dependencies graph))) (unless node - (throw 'graph-error 'find-and-remove-node-without-dependencies - "No node without dependencies in graph" '() graph)) + (scm-error 'graph-error "find-and-remove-node-without-dependencies" + "No node without dependencies in graph" + #f (list graph))) (values node (remove-node graph node)))) ;; Assumes that the edges of the graph are dependencies. @@ -89,5 +90,5 @@ '() (let* ((node graph* (find-and-remove-node-without-dependencies graph))) (cons node (loop graph*)))))) - (lambda (err caller fmt args graph . data) - graph))) + (lambda (err caller fmt args data) + (car graph)))) diff --git a/module/hnh/util/io.scm b/module/hnh/util/io.scm index 161e09a0..3a595b67 100644 --- a/module/hnh/util/io.scm +++ b/module/hnh/util/io.scm @@ -1,4 +1,5 @@ (define-module (hnh util io) + :use-module ((hnh util) :select (begin1)) :use-module ((ice-9 rdelim) :select (read-line))) (define-public (open-input-port str) @@ -13,18 +14,18 @@ (define-public (read-lines port) - (with-input-from-port port - (lambda () - (let loop ((line (read-line))) - (if (eof-object? line) - '() (cons line (loop (read-line)))))))) + (let ((line (read-line port))) + (if (eof-object? line) + '() (cons line (read-lines port))))) ;; Same functionality as the regular @var{with-output-to-file}, but ;; with the difference that either everything is written, or nothing ;; is written, and if anything is written it's all written atomicaly at ;; once (the original file will never contain an intermidiate state). ;; Does NOT handle race conditions between threads. -;; Return #f on failure, something truthy otherwise +;; +;; propagates the return value of @var{thunk} upon successfully writing +;; the file, and @code{#f} otherwise. (define-public (with-atomic-output-to-file filename thunk) ;; copy to enusre writable string (define tmpfile (string-copy (string-append @@ -36,13 +37,14 @@ (dynamic-wind (lambda () (set! port (mkstemp! tmpfile))) (lambda () - (with-output-to-port port thunk) - ;; Closing a port forces a write, due to buffering - ;; some of the errors that logically would come - ;; from write calls are first raised here. But since - ;; crashing is acceptable here, that's fine. - (close-port port) - (rename-file tmpfile filename)) + (begin1 + (with-output-to-port port thunk) + ;; Closing a port forces a write, due to buffering + ;; some of the errors that logically would come + ;; from write calls are first raised here. But since + ;; crashing is acceptable here, that's fine. + (close-port port) + (rename-file tmpfile filename))) (lambda () (when (access? tmpfile F_OK) ;; I'm a bit unclear on how to trash our write buffer. diff --git a/module/hnh/util/path.scm b/module/hnh/util/path.scm index 7e40259a..28a026bc 100644 --- a/module/hnh/util/path.scm +++ b/module/hnh/util/path.scm @@ -2,31 +2,38 @@ :use-module (srfi srfi-1) :use-module (hnh util)) +(define // file-name-separator-string) +(define /? file-name-separator?) + (define-public (path-append . strings) (fold (lambda (s done) - (string-append - done - (if (string-null? s) - (string-append s file-name-separator-string) - (if (file-name-separator? (string-last done)) - (if (file-name-separator? (string-first s)) - (string-drop s 1) s) - (if (file-name-separator? (string-first s)) - s (string-append file-name-separator-string s)))))) + (string-append + done + (cond ((string-null? s) //) + ((and (/? (string-first s)) + (/? (string-last done))) + (string-drop s 1)) + ((or (/? (string-first s)) + (/? (string-last done))) + s) + (else (string-append // s))))) ;; If first component is empty, add a leading slash to make ;; the path absolute. This isn't exactly correct if we have ;; drive letters, but on those system the user should make ;; sure that the first component of the path is non-empty. (let ((s (car strings))) (if (string-null? s) - file-name-separator-string s)) - (cdr strings))) + // s)) + (cdr strings) + )) (define-public (path-join lst) (apply path-append lst)) ;; @example ;; (path-split "usr/lib/test") ;; ⇒ ("usr" "lib" "test") +;; (path-split "usr/lib/test/") +;; ⇒ ("usr" "lib" "test") ;; (path-split "/usr/lib/test") ;; ⇒ ("" "usr" "lib" "test") ;; (path-split "//usr////lib/test") @@ -38,7 +45,7 @@ (reverse (map reverse-list->string (fold (lambda (c done) - (if (file-name-separator? c) + (if (/? c) (cons '() done) (cons (cons c (car done)) (cdr done)))) '(()) diff --git a/module/hnh/util/uuid.scm b/module/hnh/util/uuid.scm new file mode 100644 index 00000000..68455243 --- /dev/null +++ b/module/hnh/util/uuid.scm @@ -0,0 +1,19 @@ +(define-module (hnh util uuid) + :use-module (ice-9 format) + :export (uuid uuid-v4)) + +(define %seed (random-state-from-platform)) + +(define (uuid-v4) + (define version 4) + (define variant #b10) + (format #f "~8'0x-~4'0x-~4'0x-~4'0x-~12'0x" + (random (ash 1 (* 4 8)) %seed) + (random (ash 1 (* 4 4)) %seed) + (logior (ash version (* 4 3)) + (random (1- (ash 1 (* 4 3))) %seed)) + (logior (ash variant (+ 2 (* 4 3))) + (random (ash 1 (+ 2 (* 4 3))) %seed)) + (random (ash 1 (* 4 12)) %seed))) + +(define uuid uuid-v4) diff --git a/module/srfi/srfi-41/util.scm b/module/srfi/srfi-41/util.scm index 7c062003..9a172e2d 100644 --- a/module/srfi/srfi-41/util.scm +++ b/module/srfi/srfi-41/util.scm @@ -3,7 +3,7 @@ #:use-module (srfi srfi-41) #:use-module ((ice-9 sandbox) :select (call-with-time-limit)) #:use-module (hnh util) ; let*, find-min - #:export (stream-car+cdr interleave-streams with-streams + #:export (stream-car+cdr interleave-streams stream-timeslice-limit)) (define (stream-car+cdr stream) @@ -132,39 +132,3 @@ (stream-timeslice-limit (stream-cdr strm) timeslice))) (lambda _ stream-null))) -;; Evaluates @var{body} in a context where most list fundamentals are -;; replaced by stream alternatives. -;; commented defifinitions are items which could be included, but for -;; one reason or another isn't. -;; TODO Possibly give access to list-primitives under a list- prefix. -;; TODO since this macro is inhygienic it requires that (srfi srfi-41) -;; is included at the point of use. -(define-macro (with-streams . body) - `(let-syntax - ((cons (identifier-syntax stream-cons)) - (null? (identifier-syntax stream-null?)) - (pair? (identifier-syntax stream-pair?)) - (car (identifier-syntax stream-car)) - (cdr (identifier-syntax stream-cdr)) - ;; stream-lambda - ;; define-stream - (append (identifier-syntax stream-append)) - (concat (identifier-syntax stream-concat)) - ;; (const stream-constant) - (drop (identifier-syntax stream-drop)) - (drop-while (identifier-syntax stream-drop-while)) - (filter (identifier-syntax stream-filter)) - (fold (identifier-syntax stream-fold)) - (for-each (identifier-syntax stream-for-each)) - (length (identifier-syntax stream-length)) - ;; stream-let - (map (identifier-syntax stream-map)) - ;; stream-match - ;; stream-range - ;; stream-ref - (reverse (identifier-syntax stream-reverse)) - ;; stream-scan - (take (identifier-syntax stream-take)) - (take-while (identifier-syntax stream-take-while)) - (zip (identifier-syntax stream-zip))) - ,@body)) diff --git a/module/srfi/srfi-64/test-error.scm b/module/srfi/srfi-64/test-error.scm new file mode 100644 index 00000000..33922c32 --- /dev/null +++ b/module/srfi/srfi-64/test-error.scm @@ -0,0 +1,85 @@ +;; Copyright © 2022 Hugo Hörnquist +;; Copyright for this file, however, majority of contents borrowed under the +;; below mentioned license agreement from srfi/srfi-64/testing.scm of Guile 2.2.7. + +;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner +;; Added "full" support for Chicken, Gauche, Guile and SISC. +;; Alex Shinn, Copyright (c) 2005. +;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012. +;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014. +;; +;; Permission is hereby granted, free of charge, to any person +;; obtaining a copy of this software and associated documentation +;; files (the "Software"), to deal in the Software without +;; restriction, including without limitation the rights to use, copy, +;; modify, merge, publish, distribute, sublicense, and/or sell copies +;; of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. +;;; Commentary: +;; The code is directly copied from Guile's source tree +;; (module/srfi/srfi-64/testing.scm), but @var{etype} +;; is passed to @code{catch}, causing it to actually +;; check the expected error. +;;; Code: + +(define-module (srfi srfi-64 test-error) + :use-module (srfi srfi-64) + :use-module (hnh util) + :replace (test-error)) + +(define %test-source-line2 (@@ (srfi srfi-64) %test-source-line2)) +(define %test-on-test-begin (@@ (srfi srfi-64) %test-on-test-begin)) +(define %test-on-test-end (@@ (srfi srfi-64) %test-on-test-end)) +(define %test-report-result (@@ (srfi srfi-64) %test-report-result)) + +(define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (cond ((%test-on-test-begin r) + (let ((et etype)) + (test-result-set! r 'expected-error et) + (%test-on-test-end r + (catch etype + (lambda () + (test-result-set! r 'actual-value expr) + #f) + (lambda (key . args) + ;; TODO: decide how to specify expected + ;; error types for Guile. + (test-result-set! r 'actual-error + (cons key args)) + #t))) + (%test-report-result))))))) + +(define-syntax test-error + (lambda (x) + (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () + (((mac tname etype expr) line) + (syntax + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r (cons (cons 'test-name tname) line)) + (%test-error r etype expr)))) + (((mac etype expr) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-error r etype expr)))) + (((mac expr) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-error r #t expr))))))) + diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 579382ae..18f31aaf 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -164,6 +164,7 @@ (define-public (copy-vcomponent component) (make-vcomponent% (type component) + ;; TODO deep copy? (children component) (parent component) ;; properties diff --git a/module/vcomponent/datetime/output.scm b/module/vcomponent/datetime/output.scm index 72ee8eb4..fe909ebb 100644 --- a/module/vcomponent/datetime/output.scm +++ b/module/vcomponent/datetime/output.scm @@ -1,7 +1,5 @@ (define-module (vcomponent datetime output) :use-module (hnh util) - :use-module (calp util config) - :use-module (hnh util exceptions) :use-module (datetime) :use-module (vcomponent base) :use-module (text util) @@ -9,12 +7,6 @@ :use-module ((vcomponent recurrence display) :select (format-recurrence-rule)) ) -(define-config summary-filter (lambda (_ a) a) - pre: (ensure procedure?)) - -(define-config description-filter (lambda (_ a) a) - pre: (ensure procedure?)) - ;; ev → sxml ;; TODO translation (define-public (format-recurrence-rule ev) diff --git a/module/vcomponent/duration.scm b/module/vcomponent/duration.scm index 786675b8..637d7db4 100644 --- a/module/vcomponent/duration.scm +++ b/module/vcomponent/duration.scm @@ -20,7 +20,9 @@ key: (sign '+) week day time) (when (and week (or day time)) - (error "Can't give week together with day or time")) + (scm-error 'misc-error "duration" + "Can't give week together with day or time" + #f #f)) (make-duration sign week day time)) @@ -64,7 +66,10 @@ (define (parse-duration str) (let ((m (match-pattern dur-pattern str))) (unless m - (throw 'parse-error "~a doesn't appar to be a duration" str)) + (scm-error 'parse-error "parse-duration" + "~s doesn't appar to be a duration" + (list str) + #f)) (unless (= (peg:end m) (string-length str)) (warning "Garbage at end of duration")) @@ -83,9 +88,12 @@ [(H) `(hour: ,n)] [(M) `(minute: ,n)] [(S) `(second: ,n)] - [else (error "Invalid key")]))] + [else (scm-error 'misc-error "parse-duration" + "Invalid key ~a" type #f)]))] [a - (error "~a not on form ((number <num>) type)" a)]) + (scm-error 'misc-error "parse-duration" + "~s not on expected form ((number <num>) type)" + (list a) #f)]) (context-flatten (lambda (x) (and (pair? (car x)) (eq? 'number (caar x)))) (cdr (member "P" tree))) diff --git a/module/vcomponent/formats/common/types.scm b/module/vcomponent/formats/common/types.scm index 9768cf70..9e18f1eb 100644 --- a/module/vcomponent/formats/common/types.scm +++ b/module/vcomponent/formats/common/types.scm @@ -137,4 +137,5 @@ (define-public (get-parser type) (or (hashq-ref type-parsers type #f) - (error (_ "No parser for type") type))) + (scm-error 'misc-error "get-parser" (_ "No parser for type ~a") + (list type) #f))) diff --git a/module/vcomponent/formats/ical/parse.scm b/module/vcomponent/formats/ical/parse.scm index 8b6cffeb..7f6c89cc 100644 --- a/module/vcomponent/formats/ical/parse.scm +++ b/module/vcomponent/formats/ical/parse.scm @@ -1,5 +1,6 @@ (define-module (vcomponent formats ical parse) :use-module ((ice-9 rdelim) :select (read-line)) + :use-module (ice-9 format) :use-module (hnh util exceptions) :use-module (hnh util) :use-module (datetime) @@ -121,7 +122,9 @@ (lambda (params value) (let ((vv (parser params value))) (when (list? vv) - (throw 'parse-error (_ "List in enum field"))) + (scm-error 'parse-error "enum-parser" + (_ "List in enum field") + #f #f)) (let ((v (string->symbol vv))) (unless (memv v enum) (warning "~a ∉ { ~{~a~^, ~} }" @@ -193,7 +196,9 @@ DRAFT FINAL CANCELED))] [(memv key '(REQUEST-STATUS)) - (throw 'parse-error (_ "TODO Implement REQUEST-STATUS"))] + (scm-error 'parse-error "build-vline" + (_ "TODO Implement REQUEST-STATUS") + #f #f)] [(memv key '(ACTION)) (enum-parser '(AUDIO DISPLAY EMAIL @@ -325,7 +330,7 @@ (set! (prop* (car stack) key) vline)))))) (loop (cdr lst) stack)]))) - (lambda (err fmt . args) + (lambda (err proc fmt fmt-args data) (let ((linedata (get-metadata head*))) (display (format #f @@ -339,7 +344,7 @@ line ~a ~a Defaulting to string~%") (get-string linedata) - fmt args + fmt fmt-args (get-line linedata) (get-file linedata)) (current-error-port)) diff --git a/module/vcomponent/formats/vdir/parse.scm b/module/vcomponent/formats/vdir/parse.scm index 4fc96e71..b21a5f2b 100644 --- a/module/vcomponent/formats/vdir/parse.scm +++ b/module/vcomponent/formats/vdir/parse.scm @@ -39,12 +39,16 @@ (reduce (lambda (item calendar) - (define-values (events other) (partition (lambda (e) (eq? 'VEVENT (type e))) - (children item))) + (define-values (events other) + (partition (lambda (e) (eq? 'VEVENT (type e))) + (children item))) - ;; (assert (eq? 'VCALENDAR (type calendar))) - (assert (eq? 'VCALENDAR (type 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)) (for child in (children item) (set! (prop child '-X-HNH-FILENAME) @@ -61,10 +65,7 @@ (case (length events) [(0) (warning (_ "No events in component~%~a") (prop item '-X-HNH-FILENAME))] - [(1) - (let ((child (car events))) - (assert (memv (type child) '(VTIMEZONE VEVENT))) - (add-child! calendar child))] + [(1) (add-child! calendar (car events))] ;; two or more [else diff --git a/module/vcomponent/formats/vdir/save-delete.scm b/module/vcomponent/formats/vdir/save-delete.scm index 6068e34c..01d34f9f 100644 --- a/module/vcomponent/formats/vdir/save-delete.scm +++ b/module/vcomponent/formats/vdir/save-delete.scm @@ -11,8 +11,8 @@ (define-module (vcomponent formats vdir save-delete) :use-module (hnh util) + :use-module (hnh util uuid) :use-module ((hnh util path) :select (path-append)) - :use-module ((hnh util exceptions) :select (assert)) :use-module (vcomponent formats ical output) :use-module (vcomponent) :use-module ((hnh util io) :select (with-atomic-output-to-file)) @@ -22,14 +22,25 @@ (define-public (save-event event) (define calendar (parent event)) - (assert (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE))) - - (let* ((uid (or (prop event 'UID) (uuidgen)))) - (set! (prop event 'UID) uid - ;; TODO use existing filename if present? - (prop event '-X-HNH-FILENAME) (path-append - (prop calendar '-X-HNH-DIRECTORY) - (string-append uid ".ics"))) + (unless calendar + (scm-error 'wrong-type-arg "save-event" + (_ "Can only save events belonging to calendars, event uid = ~s") + (list (prop event 'UID)) + #f)) + + (unless (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE)) + (scm-error 'wrong-type-arg "save-event" + (_ "Can only save events belonging to vdir calendars. Calendar is of type ~s") + (list (prop calendar '-X-HNH-SOURCETYPE)) + #f)) + + (let* ((uid (or (prop event 'UID) (uuid)))) + (set! (prop event 'UID) uid) + (unless (prop event 'X-HNH-FILENAME) + (set! (prop event '-X-HNH-FILENAME) + (path-append + (prop calendar '-X-HNH-DIRECTORY) + (string-append uid ".ics")))) (with-atomic-output-to-file (prop event '-X-HNH-FILENAME) (lambda () (print-components-with-fake-parent (list event)))) uid)) @@ -37,5 +48,9 @@ (define-public (remove-event event) (define calendar (parent event)) - (assert (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE))) + (unless (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE)) + (scm-error 'wrong-type-arg "remove-event" + (_ "Can only remove events belonging to vdir calendars. Calendar is of type ~s") + (list (prop calendar '-X-HNH-SOURCETYPE)) + #f)) (delete-file (prop event '-X-HNH-FILENAME))) diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm index 66bb8460..d9020858 100644 --- a/module/vcomponent/formats/xcal/parse.scm +++ b/module/vcomponent/formats/xcal/parse.scm @@ -82,10 +82,10 @@ bymonthday byyearday byweekno bymonth bysetpos) (string->number value)) - (else (throw - 'key-error + (else (scm-error 'key-error "handle-value" (_ "Invalid type ~a, with value ~a") - type value)))))) + (list type value) + #f)))))) ;; freq until count interval wkst @@ -109,9 +109,11 @@ byyearday byweekno bymonth bysetpos) (list (symbol->keyword key) (map (lambda (v) (parse-value-of-that-type key v)) - (map car values))) - ) - (else (throw 'error)))))))))] + (map car values)))) + (else (scm-error 'misc-error "handle-value" + "Invalid key ~s" + (list key) + #f)))))))))] [(time) (parse-iso-time (car value))] diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index b498e033..33f86e3d 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -217,7 +217,9 @@ [(BYHOUR) (to-dt (set (hour t) value))] [(BYMINUTE) (to-dt (set (minute t) value))] [(BYSECOND) (to-dt (set (second t) value))] - [else (error "Unrecognized by-extender" key)]))) + [else (scm-error 'wrong-type-arg "update" + "Unrecognized by-extender ~s" + key #f)]))) date-object extension-rule)) diff --git a/module/vcomponent/recurrence/internal.scm b/module/vcomponent/recurrence/internal.scm index b4f09d92..ae521d77 100644 --- a/module/vcomponent/recurrence/internal.scm +++ b/module/vcomponent/recurrence/internal.scm @@ -5,6 +5,7 @@ #:use-module ((vcomponent base) :select (prop)) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module (ice-9 format) #:use-module (hnh util) ) @@ -46,11 +47,14 @@ wkst) (export! count) +;; Interval and wkst have default values, since those are assumed +;; anyways, and having them set frees us from having to check them at +;; the use site. (define*-public (make-recur-rule key: - freq until count interval bysecond byminute byhour + freq until count (interval 1) bysecond byminute byhour byday bymonthday byyearday byweekno bymonth bysetpos - wkst) + (wkst monday)) ;; TODO possibly validate fields here ;; to prevent creation of invalid rules. ;; This was made apparent when wkst was (incorrectly) set to MO, diff --git a/module/vcomponent/recurrence/parse.scm b/module/vcomponent/recurrence/parse.scm index 3477f6d4..d45cedf9 100644 --- a/module/vcomponent/recurrence/parse.scm +++ b/module/vcomponent/recurrence/parse.scm @@ -51,7 +51,9 @@ (define-macro (quick-case key . cases) (let ((else-clause (or (assoc-ref cases 'else) - '(error "Guard failed")))) + '(scm-error 'misc-error "quick-case" + "Guard failed" + #f #f)))) `(case ,key ,@(map (match-lambda ((key guard '=> body ...) @@ -72,6 +74,12 @@ `(else ,@body))) cases)))) +(define* (string->number/throw string optional: (radix 10)) + (or (string->number string radix) + (scm-error 'wrong-type-arg + "string->number/throw" + "Can't parse ~s as number in base ~a" + (list string radix) (list string radix)))) ;; RFC 5545, Section 3.3.10. Recurrence Rule, states that the UNTIL value MUST have ;; the same type as the DTSTART of the event (date or datetime). I have seen events @@ -92,8 +100,8 @@ (parse-ics-datetime val))) (day (rfc->datetime-weekday (string->symbol val))) (days (map parse-day-spec (string-split val #\,))) - (num (string->number val)) - (nums (map string->number (string-split val #\,)))) + (num (string->number/throw val)) + (nums (map string->number/throw (string-split val #\,)))) ;; It's an error to give BYHOUR and smaller for pure dates. ;; 3.3.10. p 41 @@ -123,7 +131,7 @@ (else o))))) ;; obj - (make-recur-rule interval: 1 wkst: mon) + (make-recur-rule) ;; ((key val) ...) (map (cut string-split <> #\=) diff --git a/module/vcomponent/util/instance/methods.scm b/module/vcomponent/util/instance/methods.scm index e2e8a777..57d12f6b 100644 --- a/module/vcomponent/util/instance/methods.scm +++ b/module/vcomponent/util/instance/methods.scm @@ -1,5 +1,6 @@ (define-module (vcomponent util instance methods) :use-module (hnh util) + :use-module (hnh util uuid) :use-module (srfi srfi-1) :use-module (srfi srfi-41) :use-module (srfi srfi-41 util) @@ -19,8 +20,14 @@ get-event-by-uid fixed-events-in-range + get-calendar-by-name + get-event-set get-calendars get-fixed-events get-repeating-events + + add-and-save-event + + add-calendars )) (define-public (load-calendars calendar-files) @@ -28,12 +35,21 @@ (define-class <events> () - (calendar-files init-keyword: calendar-files:) - (calendars getter: get-calendars) + ;; Files which calendars where loaded from + (calendar-files init-keyword: calendar-files: + init-value: '()) + ;; calendar objects + (calendars getter: get-calendars + init-value: '()) + ;; events, which should all be children of the calendars (events getter: get-events) + ;; subset of events (repeating-events getter: get-repeating-events) + ;; subset of events (fixed-events getter: get-fixed-events) + ;; events again, but as stream with repeating events realised (event-set getter: get-event-set) + ;; hash-table from event UID:s, to the events uid-map ) @@ -42,6 +58,10 @@ (hash-ref (slot-ref this 'uid-map) uid)) +(define-method (get-calendar-by-name (this <events>) string) + (find (lambda (c) (string=? string (prop c 'NAME))) + (get-calendars this))) + (define-method (fixed-events-in-range (this <events>) start end) (filter-sorted (lambda (ev) ((in-date-range? start end) @@ -56,8 +76,12 @@ (for calendar in (slot-ref this 'calendar-files) (format (current-error-port) " - ~a~%" calendar)) - (slot-set! this 'calendars (load-calendars (slot-ref this 'calendar-files))) + (let ((calendars (load-calendars (slot-ref this 'calendar-files)))) + (apply add-calendars this calendars))) + +(define-method (add-calendars (this <events>) . calendars) + (slot-set! this 'calendars (append calendars (slot-ref this 'calendars))) (let* ((groups (group-by @@ -95,7 +119,7 @@ (add-child! calendar event) (unless (prop event 'UID) - (set! (prop event 'UID) (uuidgen))) + (set! (prop event 'UID) (uuid))) @@ -139,3 +163,57 @@ (hash-set! (slot-ref this 'uid-map) (prop event 'UID) #f)) + + +(define-method (add-and-save-event (this <events>) calendar event) + (cond + [(get-event-by-uid this (prop event 'UID)) + => (lambda (old-event) + + ;; remove old instance of event from runtime + (remove-event this old-event) + + ;; Add new event to runtime, + ;; MUST be done after since the two events SHOULD share UID. + ;; NOTE that this can emit warnings + (add-event this calendar event) + + (set! (prop event 'LAST-MODIFIED) + (current-datetime)) + + ;; NOTE Posibly defer save to a later point. + ;; That would allow better asyncronous preformance. + + ;; save-event sets -X-HNH-FILENAME from the UID. This is fine + ;; since the two events are guaranteed to have the same UID. + (unless ((@ (vcomponent formats vdir save-delete) save-event) event) + (throw 'misc-error (_ "Saving event to disk failed."))) + + + (unless (eq? calendar (parent old-event)) + ;; change to a new calendar + (format (current-error-port) + (_ "Unlinking old event from ~a~%") + (prop old-event '-X-HNH-FILENAME)) + ;; NOTE that this may fail, leading to a duplicate event being + ;; created (since we save beforehand). This is just a minor problem + ;; which either a better atomic model, or a propper error + ;; recovery log would solve. + ((@ (vcomponent formats vdir save-delete) remove-event) old-event)) + + + (format (current-error-port) + (_ "Event updated ~a~%") (prop event 'UID)))] + + [else + (add-event this calendar event) + + (set! (prop event 'LAST-MODIFIED) (current-datetime)) + + ;; NOTE Posibly defer save to a later point. + ;; That would allow better asyncronous preformance. + (unless ((@ (vcomponent formats vdir save-delete) save-event) event) + (throw 'misc-error (_ "Saving event to disk failed."))) + + (format (current-error-port) + (_ "Event inserted ~a~%") (prop event 'UID))])) diff --git a/module/vcomponent/util/parse-cal-path.scm b/module/vcomponent/util/parse-cal-path.scm index 7a5fea29..4baa647e 100644 --- a/module/vcomponent/util/parse-cal-path.scm +++ b/module/vcomponent/util/parse-cal-path.scm @@ -26,7 +26,10 @@ (prop comp '-X-HNH-DIRECTORY) path) comp)] [(block-special char-special fifo socket unknown symlink) - => (lambda (t) (error (_ "Can't parse file of type ") t))])) + => (lambda (t) (scm-error 'misc-error "parse-cal-path" + (_ "Can't parse file of type ~s") + (list t) + #f))])) (unless (prop cal "NAME") (set! (prop cal "NAME") diff --git a/module/vulgar.scm b/module/vulgar.scm index 5ddea738..20b93164 100644 --- a/module/vulgar.scm +++ b/module/vulgar.scm @@ -19,35 +19,39 @@ (1+ y) (1+ x))) -(define-syntax with-vulgar - (syntax-rules () - ((_ thunk) - (with-vulgar (bitwise-not (bitwise-ior ECHO ICANON)) - thunk)) - ((_ bits thunk) - (let* ((ifd (current-input-port)) - (ofd (current-output-port)) - (iattr (make-termios)) - (oattr (make-termios)) - iattr* oattr*) - (dynamic-wind - (lambda () - (tcgetattr! iattr ifd) - (tcgetattr! oattr ofd) - - ;; Store current settings to enable resetting the terminal later - (set! iattr* (copy-termios iattr) - oattr* (copy-termios oattr) - - (lflag iattr) (bitwise-and bits (lflag iattr)) - (lflag oattr) (bitwise-and bits (lflag oattr))) - - (tcsetattr! iattr ifd) - (tcsetattr! oattr ofd) - (system "tput civis")) - thunk - (lambda () - (tcsetattr! iattr* ifd) - (tcsetattr! oattr* ofd) - (system "tput cnorm") - )))))) +(define (with-vulgar . args) + (apply + (case-lambda + ((thunk) + (with-vulgar (bitwise-not (bitwise-ior ECHO ICANON)) + thunk)) + ((bits thunk) + (let* ((ifd (current-input-port)) + (ofd (current-output-port)) + (iattr (make-termios)) + (oattr (make-termios)) + iattr* oattr*) + (dynamic-wind + (lambda () + (tcgetattr! iattr ifd) + (tcgetattr! oattr ofd) + + ;; Store current settings to enable resetting the terminal later + (set! iattr* (copy-termios iattr) + oattr* (copy-termios oattr) + + (lflag iattr) (bitwise-and bits (lflag iattr)) + (lflag oattr) (bitwise-and bits (lflag oattr))) + + (tcsetattr! iattr ifd) + (tcsetattr! oattr ofd) + (format #t "\x1b[?1049h") + (system "tput civis")) + thunk + (lambda () + (tcsetattr! iattr* ifd) + (tcsetattr! oattr* ofd) + (format #t "\x1b[?1049l") + (system "tput cnorm") + ))))) + args)) diff --git a/module/web/http/make-routes.scm b/module/web/http/make-routes.scm index 7254fcb5..11f7dfb4 100644 --- a/module/web/http/make-routes.scm +++ b/module/web/http/make-routes.scm @@ -2,9 +2,9 @@ :export (make-routes) :use-module (hnh util) :use-module (ice-9 regex) + :use-module (ice-9 curried-definitions) :use-module (srfi srfi-1) - :use-module (web response) - :use-module (web uri)) + ) @@ -34,13 +34,13 @@ (cons (string->symbol (match:substring m 1)) tokens))))))) -(define (generate-case defn) + +(define ((generate-case regex-table) defn) (let* (((method uri param-list . body) defn) - (regex tokens (parse-endpoint-string uri)) + (_ tokens (parse-endpoint-string uri)) (diff intersect (lset-diff+intersection eq? param-list tokens))) `((and (eq? r:method (quote ,method)) - (regexp-exec (make-regexp ,(string-append "^" regex "/?$") regexp/icase) - r:path)) + (regexp-exec ,(car (assoc-ref regex-table uri)) r:path)) => (lambda (match-object) ;; (assert ;; (= (1- (match:count match-object)) @@ -54,60 +54,65 @@ ,@body)) ,@(unless (null? intersect) (map (lambda (i) - `(match:substring match-object ,i)) + `((@ (ice-9 regex) match:substring) match-object ,i)) (cdr (iota (1+ (length intersect))))))))))) (define-macro (make-routes . routes) + ;; Ensures that all regexes are only compiled once. + (define routes-regexes + (map (lambda (uri) + (define-values (regex _) (parse-endpoint-string uri)) + (list uri (gensym) `(make-regexp ,(string-append "^" regex "/?$") regexp/icase))) + (map cadr routes))) - `(lambda* (request body #:optional state) - ;; (format (current-error-port) "~a~%" request) - ;; ALl these bindings generate compile time warnings since the expansion - ;; of the macro might not use them. This isn't really a problem. - (let ((r:method ((@ (web request) request-method) request)) - (r:uri ((@ (web request) request-uri) request)) - (r:version ((@ (web request) request-version) request)) - (r:headers ((@ (web request) request-headers) request)) - (r:meta ((@ (web request) request-meta) request)) - (r:port ((@ (web request) request-port) request))) - (let ((r:scheme ((@ (web uri) uri-scheme) r:uri)) - (r:userinfo ((@ (web uri) uri-userinfo) r:uri)) - ;; TODO can sometimes be a pair of host and port - ;; '("localhost" . 8080). It shouldn't... - (r:host (or ((@ (web uri) uri-host) r:uri) - ((@ (web request) request-host) - request))) - (r:port (or ((@ (web uri) uri-port) r:uri) - ((@ (web request) request-port) - request))) - (r:path ((@ (web uri) uri-path) r:uri)) - (r:query ((@ (web uri) uri-query) r:uri)) - (r:fragment ((@ (web uri) uri-fragment) r:uri))) - ;; TODO propper logging - (display (format #f "[~a] ~a ~a/~a?~a~%" - (datetime->string (current-datetime)) - r:method r:host r:path (or r:query "")) - (current-error-port)) - (call-with-values - (lambda () - ((@ (ice-9 control) call/ec) - (lambda (return) - (apply - (cond ,@(map generate-case routes) - (else (lambda* _ (return (build-response #:code 404) - "404 Not Fonud")))) - (append - ((@ (web query) parse-query) r:query) + `(let ,(map cdr routes-regexes) + (lambda* (request body #:optional state) + ;; (format (current-error-port) "~a~%" request) + ;; All these bindings generate compile time warnings since the expansion + ;; of the macro might not use them. This isn't really a problem. + (let ((r:method ((@ (web request) request-method) request)) + (r:uri ((@ (web request) request-uri) request)) + (r:version ((@ (web request) request-version) request)) + (r:headers ((@ (web request) request-headers) request)) + (r:meta ((@ (web request) request-meta) request))) + (let ((r:scheme ((@ (web uri) uri-scheme) r:uri)) + (r:userinfo ((@ (web uri) uri-userinfo) r:uri)) + ;; uri-{host,port} is (probably) not set when we are a server, + ;; fetch them from the request instead + (r:host (or ((@ (web uri) uri-host) r:uri) + (and=> ((@ (web request) request-host) request) car))) + (r:port (or ((@ (web uri) uri-port) r:uri) + (and=> ((@ (web request) request-host) request) cdr))) + (r:path ((@ (web uri) uri-path) r:uri)) + (r:query ((@ (web uri) uri-query) r:uri)) + (r:fragment ((@ (web uri) uri-fragment) r:uri))) + ;; TODO propper logging + (display (format #f "[~a] ~a ~a:~a~a?~a~%" + (datetime->string (current-datetime)) + r:method r:host r:port r:path (or r:query "")) + (current-error-port)) + (call-with-values + (lambda () + ((@ (ice-9 control) call/ec) + (lambda (return) + (apply + (cond ,@(map (generate-case routes-regexes) routes) + (else (lambda* _ (return ((@ (web response) build-response) code: 404) + "404 Not Fonud")))) + (append + ((@ (web query) parse-query) r:query) - (let ((content-type (assoc-ref r:headers 'content-type))) - (when content-type - (let ((type (car content-type)) - (args (cdr content-type))) - (when (eq? type 'application/x-www-form-urlencoded) - (let ((encoding (or (assoc-ref args 'encoding) "UTF-8"))) - ((@ (web query) parse-query) - ((@ (ice-9 iconv) bytevector->string) - body encoding) - encoding))))))))))) - (case-lambda ((headers body new-state) (values headers body new-state)) - ((headers body) (values headers body state)) - ((headers) (values headers "" state)))))))) + (let ((content-type (assoc-ref r:headers 'content-type))) + ((@ (hnh util) when) content-type + (let ((type (car content-type)) + (args (cdr content-type))) + ((@ (hnh util) when) + (eq? type 'application/x-www-form-urlencoded) + (let ((encoding (or (assoc-ref args 'encoding) "UTF-8"))) + ((@ (web query) parse-query) + ((@ (ice-9 iconv) bytevector->string) + body encoding) + encoding))))))))))) + (case-lambda ((headers body new-state) (values headers body new-state)) + ((headers body) (values headers body state)) + ((headers) (values headers "" state))))))))) @@ -26,7 +26,9 @@ msgstr "Som standard är utskrifter avstängda, eftersom många fällt inehåll #: module/calp/entry-points/ical.scm:17 module/calp/entry-points/import.scm:24 #: module/calp/entry-points/terminal.scm:15 #: module/calp/entry-points/convert.scm:19 module/calp/entry-points/html.scm:60 -#: module/calp/entry-points/server.scm:30 +#: module/calp/entry-points/server.scm:30 module/calp/entry-points/html.scm:61 +#: module/calp/entry-points/import.scm:25 +#: module/calp/entry-points/server.scm:31 msgid "Print this help." msgstr "Visar den här hjälpen." @@ -39,21 +41,21 @@ msgstr "Indatafil" msgid "Output file" msgstr "Utdatafil" -#: module/calp/entry-points/html.scm:32 +#: module/calp/entry-points/html.scm:32 module/calp/entry-points/html.scm:33 msgid "Start date of output." msgstr "Startdatum för utdatan." -#: module/calp/entry-points/html.scm:99 +#: module/calp/entry-points/html.scm:99 module/calp/entry-points/html.scm:115 #, scheme-format msgid "Writing to [~a]~%" msgstr "Skriver till [~a]~%" -#: module/calp/entry-points/html.scm:167 +#: module/calp/entry-points/html.scm:167 module/calp/entry-points/html.scm:183 #, scheme-format msgid "Unknown html style: ~a" msgstr "Okänd html-stil: ~a" -#: module/calp/entry-points/html.scm:169 +#: module/calp/entry-points/html.scm:169 module/calp/entry-points/html.scm:185 msgid "all done" msgstr "Allt klart" @@ -62,50 +64,61 @@ msgid "Returns all elements between these two dates." msgstr "Returnerar alla element mellan de två datumen." #: module/calp/entry-points/import.scm:20 +#: module/calp/entry-points/import.scm:21 msgid "Name of calendar to import into" msgstr "Namn på kalendar att importera till" #: module/calp/entry-points/import.scm:22 +#: module/calp/entry-points/import.scm:23 msgid "ics file to import" msgstr "ics-fil att importera" #: module/calp/entry-points/import.scm:43 +#: module/calp/entry-points/import.scm:44 #, scheme-format msgid "No calendar named ~s~%" msgstr "Ingen kallender vid namn ~s~%" #: module/calp/entry-points/import.scm:48 +#: module/calp/entry-points/import.scm:49 #, scheme-format msgid "About to import the following ~a events into ~a~%" msgstr "På väg att importera ~a händelser till ~a~%" #: module/calp/entry-points/import.scm:54 +#: module/calp/entry-points/import.scm:55 msgid "Continue? [Y/n] " msgstr "Fortsätt? [J/n]" #. numbers as single-char doesn't work. #: module/calp/entry-points/server.scm:26 +#: module/calp/entry-points/server.scm:27 msgid "Use IPv6." msgstr "Använd IPv6." #: module/calp/entry-points/server.scm:27 +#: module/calp/entry-points/server.scm:28 msgid "Use IPv4." msgstr "Använd IPv4." #: module/calp/entry-points/server.scm:28 +#: module/calp/entry-points/server.scm:29 msgid "Reload events on SIGUSR1" msgstr "Ladda om händelser vid SIGUSR1 " #: module/calp/entry-points/server.scm:34 +#: module/calp/entry-points/server.scm:35 msgid "Port to which the web server should bind." msgstr "Port till vilken webservern ska binda." #: module/calp/entry-points/server.scm:63 +#: module/calp/entry-points/server.scm:64 #, scheme-format msgid "Listening for SIGUSR1~%" msgstr "Vakar för SIGUSR1~%" #: module/calp/entry-points/server.scm:68 +#: module/calp/entry-points/server.scm:69 #, scheme-format msgid "Received SIGUSR1, reloading calendars~%" msgstr "Mottog SIGUSR1, laddar om kallendar~%" @@ -116,6 +129,7 @@ msgstr "Mottog SIGUSR1, laddar om kallendar~%" #. PID of this process #. PWD of this process #: module/calp/entry-points/server.scm:78 +#: module/calp/entry-points/server.scm:79 #, scheme-format msgid "Starting server on ~a:~a~%I'm ~a, runing from ~a~%" msgstr "Startar server på ~a:~a~%Jag är ~a, körandes från ~a~%" @@ -162,81 +176,96 @@ msgstr "Grupper krävs i mallen" #. Week number prefix #: module/calp/html/view/calendar/week.scm:36 +#: module/calp/html/view/calendar/week.scm:37 msgid "v." msgstr "v." -#: module/calp/html/view/calendar.scm:76 +#: module/calp/html/view/calendar.scm:76 module/calp/html/view/calendar.scm:78 msgid "Next-start needs to be a procedure" msgstr "Next-start måste vara en procedur" -#: module/calp/html/view/calendar.scm:79 +#: module/calp/html/view/calendar.scm:79 module/calp/html/view/calendar.scm:81 msgid "Prev-start needs to be a procedure" msgstr "Prev-start måste vara en procedur" -#: module/calp/html/view/calendar.scm:90 +#: module/calp/html/view/calendar.scm:90 module/calp/html/view/calendar.scm:92 #, scheme-format msgid "Calendar for the dates between ~a and ~a" msgstr "Kallender för tidsintervallet ~a till ~a" #: module/calp/html/view/calendar.scm:154 +#: module/calp/html/view/calendar.scm:157 msgid "Page generated " msgstr "Sidan genererad " #: module/calp/html/view/calendar.scm:157 +#: module/calp/html/view/calendar.scm:160 msgid "Current time " msgstr "Nuvarande tid " #: module/calp/html/view/calendar.scm:159 +#: module/calp/html/view/calendar.scm:162 msgid "Source Code" msgstr "Källkod" #. Button to view week #: module/calp/html/view/calendar.scm:170 +#: module/calp/html/view/calendar.scm:173 msgid "Week" msgstr "Veckovy" #. button to view month #: module/calp/html/view/calendar.scm:174 +#: module/calp/html/view/calendar.scm:177 msgid "Month" msgstr "Månadsvy" #. Button to go to today #: module/calp/html/view/calendar.scm:184 +#: module/calp/html/view/calendar.scm:187 msgid "Today" msgstr "Idag" #: module/calp/html/view/calendar.scm:204 +#: module/calp/html/view/calendar.scm:207 msgid "Month overview" msgstr "Månaden i översikt" #. Header of small calendar #: module/calp/html/view/calendar.scm:208 +#: module/calp/html/view/calendar.scm:211 #, scheme-format msgid "~B ~Y" msgstr "~B ~Y" #. Search placeholder #: module/calp/html/view/calendar.scm:234 +#: module/calp/html/view/calendar.scm:237 msgid "Search" msgstr "Sök" #: module/calp/html/view/calendar.scm:240 +#: module/calp/html/view/calendar.scm:243 msgid "Option sliders" msgstr "Inställningsreglage" #: module/calp/html/view/calendar.scm:243 +#: module/calp/html/view/calendar.scm:246 msgid "Event blankspace" msgstr "Händelsetomrum" #: module/calp/html/view/calendar.scm:252 +#: module/calp/html/view/calendar.scm:255 msgid "Fontsize" msgstr "Typsnittsstorlek" #: module/calp/html/view/calendar.scm:263 +#: module/calp/html/view/calendar.scm:266 msgid "Calendar list" msgstr "Kallenderlista" #: module/calp/html/view/calendar.scm:289 +#: module/calp/html/view/calendar.scm:292 msgid "Earlier" msgstr "Tidigare" @@ -277,128 +306,131 @@ msgstr "Placerar den genererade mojängen i debug-läge" msgid "Makes the document editable" msgstr "Gör dokumentet redigerbart" -#: module/calp/html/util.scm:34 +#: module/calp/html/util.scm:34 module/calp/html/util.scm:35 #, scheme-format msgid "Error calculating foreground color?~%~s~%" msgstr "Misslyckades beräkna förgrundsfärg?~%~s~%" #. Compact event list date + time -#: module/calp/html/vcomponent.scm:50 +#: module/calp/html/vcomponent.scm:50 module/calp/html/vcomponent.scm:73 msgid "~Y-~m-~d ~H:~M" msgstr "~Y-~m-~d ~H:~M" #. Button for viewing calendar, accompanied by a calendar icon -#: module/calp/html/vcomponent.scm:55 +#: module/calp/html/vcomponent.scm:55 module/calp/html/vcomponent.scm:78 msgid "View" msgstr "Visa" -#: module/calp/html/vcomponent.scm:126 +#: module/calp/html/vcomponent.scm:126 module/calp/html/vcomponent.scm:149 msgid "Location: " msgstr "Plats: " -#: module/calp/html/vcomponent.scm:203 +#: module/calp/html/vcomponent.scm:203 module/calp/html/vcomponent.scm:226 msgid "Last modified" msgstr "Senast ändrad" #. Last modified datetime -#: module/calp/html/vcomponent.scm:206 +#: module/calp/html/vcomponent.scm:206 module/calp/html/vcomponent.scm:229 msgid "~1 ~H:~M" msgstr "~1 ~H:~M" #: module/calp/html/vcomponent.scm:303 module/calp/html/vcomponent.scm:520 +#: module/calp/html/vcomponent.scm:326 module/calp/html/vcomponent.scm:543 msgid "Recurrences" msgstr "Upprepningar" #. NOTE flytta "muffarna" utanför -#: module/calp/html/vcomponent.scm:375 +#: module/calp/html/vcomponent.scm:375 module/calp/html/vcomponent.scm:398 msgid "- Choose a Calendar -" msgstr "- Välj en kallender -" -#: module/calp/html/vcomponent.scm:385 +#: module/calp/html/vcomponent.scm:385 module/calp/html/vcomponent.scm:408 msgid "Summary" msgstr "Sammanfattning" -#: module/calp/html/vcomponent.scm:394 +#: module/calp/html/vcomponent.scm:394 module/calp/html/vcomponent.scm:417 msgid "Start time" msgstr "Starttid" -#: module/calp/html/vcomponent.scm:400 +#: module/calp/html/vcomponent.scm:400 module/calp/html/vcomponent.scm:423 msgid "End time" msgstr "Sluttid" -#: module/calp/html/vcomponent.scm:406 +#: module/calp/html/vcomponent.scm:406 module/calp/html/vcomponent.scm:429 msgid "Whole day?" msgstr "Heldag?" -#: module/calp/html/vcomponent.scm:411 +#: module/calp/html/vcomponent.scm:411 module/calp/html/vcomponent.scm:434 msgid "Recurring?" msgstr "Upprepande?" #: module/calp/html/vcomponent.scm:419 module/calp/html/vcomponent.scm:420 #: module/calp/terminal.scm:149 module/calp/terminal.scm:146 +#: module/calp/html/vcomponent.scm:442 module/calp/html/vcomponent.scm:443 msgid "Location" msgstr "Plats" #: module/calp/html/vcomponent.scm:428 module/calp/html/vcomponent.scm:429 +#: module/calp/html/vcomponent.scm:451 module/calp/html/vcomponent.scm:452 msgid "Description" msgstr "Beskrivning" -#: module/calp/html/vcomponent.scm:436 +#: module/calp/html/vcomponent.scm:436 module/calp/html/vcomponent.scm:459 msgid "Categories" msgstr "Kattegorier" -#: module/calp/html/vcomponent.scm:441 +#: module/calp/html/vcomponent.scm:441 module/calp/html/vcomponent.scm:464 msgid "Category" msgstr "Kattegori" -#: module/calp/html/vcomponent.scm:522 +#: module/calp/html/vcomponent.scm:522 module/calp/html/vcomponent.scm:545 msgid "Frequency" msgstr "Frekvens" -#: module/calp/html/vcomponent.scm:528 +#: module/calp/html/vcomponent.scm:528 module/calp/html/vcomponent.scm:551 msgid "Until" msgstr "Till och med" -#: module/calp/html/vcomponent.scm:531 +#: module/calp/html/vcomponent.scm:531 module/calp/html/vcomponent.scm:554 msgid "Conut" msgstr "Antal" -#: module/calp/html/vcomponent.scm:534 +#: module/calp/html/vcomponent.scm:534 module/calp/html/vcomponent.scm:557 msgid "Interval" msgstr "Intervall" -#: module/calp/html/vcomponent.scm:548 +#: module/calp/html/vcomponent.scm:548 module/calp/html/vcomponent.scm:571 msgid "By Second" msgstr "Per sekund" -#: module/calp/html/vcomponent.scm:549 +#: module/calp/html/vcomponent.scm:549 module/calp/html/vcomponent.scm:572 msgid "By Minute" msgstr "Per minut" -#: module/calp/html/vcomponent.scm:550 +#: module/calp/html/vcomponent.scm:550 module/calp/html/vcomponent.scm:573 msgid "By Hour" msgstr "Per timme" -#: module/calp/html/vcomponent.scm:551 +#: module/calp/html/vcomponent.scm:551 module/calp/html/vcomponent.scm:574 msgid "By Month Day" msgstr "Per månadsdag" #. except 0 -#: module/calp/html/vcomponent.scm:552 +#: module/calp/html/vcomponent.scm:552 module/calp/html/vcomponent.scm:575 msgid "By Year Day" msgstr "Per årsdag" #. except 0 -#: module/calp/html/vcomponent.scm:553 +#: module/calp/html/vcomponent.scm:553 module/calp/html/vcomponent.scm:576 msgid "By Week Number" msgstr "Per veckonummer" #. except 0 -#: module/calp/html/vcomponent.scm:554 +#: module/calp/html/vcomponent.scm:554 module/calp/html/vcomponent.scm:577 msgid "By Month" msgstr "Per månad" -#: module/calp/html/vcomponent.scm:555 +#: module/calp/html/vcomponent.scm:555 module/calp/html/vcomponent.scm:578 msgid "By Set Position" msgstr "Per fix-position" @@ -409,48 +441,48 @@ msgstr "Per fix-position" #. )) #. ,(week-day-select '()) #. )) -#: module/calp/html/vcomponent.scm:566 +#: module/calp/html/vcomponent.scm:566 module/calp/html/vcomponent.scm:589 msgid "Weekstart" msgstr "Veckobörjan" #. Close this popup -#: module/calp/html/vcomponent.scm:582 +#: module/calp/html/vcomponent.scm:582 module/calp/html/vcomponent.scm:605 msgid "Close" msgstr "Stäng" #. Make this popup occupy the entire screen -#: module/calp/html/vcomponent.scm:587 +#: module/calp/html/vcomponent.scm:587 module/calp/html/vcomponent.scm:610 msgid "Fullscreen" msgstr "Fullskärm" #. Remove/Trash the event this popup represent #. Think garbage can -#: module/calp/html/vcomponent.scm:594 +#: module/calp/html/vcomponent.scm:594 module/calp/html/vcomponent.scm:617 msgid "Remove" msgstr "Ta bort" -#: module/calp/html/vcomponent.scm:599 +#: module/calp/html/vcomponent.scm:599 module/calp/html/vcomponent.scm:622 msgid "Overview" msgstr "Översikt" -#: module/calp/html/vcomponent.scm:603 +#: module/calp/html/vcomponent.scm:603 module/calp/html/vcomponent.scm:626 msgid "Edit" msgstr "Redigera" -#: module/calp/html/vcomponent.scm:609 +#: module/calp/html/vcomponent.scm:609 module/calp/html/vcomponent.scm:632 msgid "Changelog" msgstr "Händelseförlopp" -#: module/calp/html/vcomponent.scm:613 +#: module/calp/html/vcomponent.scm:613 module/calp/html/vcomponent.scm:636 msgid "Debug" msgstr "Debug" -#: module/calp/server/routes.scm:53 +#: module/calp/server/routes.scm:53 module/calp/server/routes.scm:58 msgid "Name" msgstr "Namn" #. File permissions, should be about as long as three digits -#: module/calp/server/routes.scm:55 +#: module/calp/server/routes.scm:55 module/calp/server/routes.scm:60 msgid "Perm" msgstr "Mod" @@ -459,58 +491,64 @@ msgstr "Mod" msgid "Scandir argument invalid or not directory: ~a" msgstr "Scandir:s argument ogilgit eller inte katalog: ~a" -#: module/calp/server/routes.scm:103 +#: module/calp/server/routes.scm:103 module/calp/server/routes.scm:134 msgid "Go to Today" msgstr "Gå till idag" -#: module/calp/server/routes.scm:156 +#: module/calp/server/routes.scm:156 module/calp/server/routes.scm:187 msgid "uid required" msgstr "uid krävs" #: module/calp/server/routes.scm:168 module/calp/server/routes.scm:264 -#: module/calp/server/routes.scm:297 +#: module/calp/server/routes.scm:297 module/calp/server/routes.scm:199 +#: module/vcomponent/util/instance/methods.scm:190 +#: module/vcomponent/util/instance/methods.scm:216 msgid "Saving event to disk failed." msgstr "Misslyckades spara händelse till disk." -#: module/calp/server/routes.scm:171 +#: module/calp/server/routes.scm:171 module/calp/server/routes.scm:202 #, scheme-format msgid "No event with UID '~a'" msgstr "Ingen händelse med UID '~a'" -#: module/calp/server/routes.scm:179 +#: module/calp/server/routes.scm:179 module/calp/server/routes.scm:210 msgid "Both 'cal' and 'data' required" msgstr "Både 'cal' och 'data' obligatoriska" -#: module/calp/server/routes.scm:192 +#: module/calp/server/routes.scm:192 module/calp/server/routes.scm:223 #, scheme-format msgid "No calendar with name [~a]" msgstr "Ingen kallender heter [~a]" -#: module/calp/server/routes.scm:223 +#: module/calp/server/routes.scm:223 module/calp/server/routes.scm:254 msgid "XML parse error" msgstr "XML inläsningsfel" -#: module/calp/server/routes.scm:228 +#: module/calp/server/routes.scm:228 module/calp/server/routes.scm:259 msgid "Object not a VEVENT" msgstr "Objektet är inte ett VEVENT" #. unlinks (removes) a single event, argument is a file name #: module/calp/server/routes.scm:271 +#: module/vcomponent/util/instance/methods.scm:196 #, scheme-format msgid "Unlinking old event from ~a~%" msgstr "Tar bort den gamla händelsen från ~a~%" #: module/calp/server/routes.scm:281 +#: module/vcomponent/util/instance/methods.scm:206 #, scheme-format msgid "Event updated ~a~%" msgstr "Händelse uppdaterad ~a~%" #: module/calp/server/routes.scm:300 +#: module/vcomponent/util/instance/methods.scm:219 #, scheme-format msgid "Event inserted ~a~%" msgstr "Händelse infogad ~a~%" #: module/calp/server/routes.scm:352 module/calp/server/routes.scm:361 +#: module/calp/server/routes.scm:335 module/calp/server/routes.scm:344 #, scheme-format msgid "No component with UID=~a found." msgstr "Hittade ingen komponent med UID=~a." @@ -527,12 +565,12 @@ msgstr "Pre krashade för" msgid "Missing config" msgstr "Saknad konfiguration" -#: module/calp/util/config.scm:116 +#: module/calp/util/config.scm:116 module/calp/util/config.scm:131 msgid "Configuration variables" msgstr "Konfigurationsvariabler" #. Configuration variable value indicator -#: module/calp/util/config.scm:129 +#: module/calp/util/config.scm:129 module/calp/util/config.scm:144 msgid "V:" msgstr "V:" @@ -554,6 +592,8 @@ msgstr "Start" #. Event start date-time terminal view #. Event end date-time terminal view +#. Event start date-time terminal view +#. Event end date-time terminal view #: module/calp/terminal.scm:160 module/calp/terminal.scm:168 #: module/calp/terminal.scm:157 module/calp/terminal.scm:165 msgid "~Y-~m-~d ~H:~M:~S" @@ -585,12 +625,12 @@ msgstr "Startar REPL-server på ~a~%" msgid "Failed to unlink ~a" msgstr "Misslyckades med att avlänka ~a" -#: module/calp/repl.scm:30 +#: module/calp/repl.scm:30 module/calp/repl.scm:31 msgid "Empty address?" msgstr "Tom address?" #. currently impossible -#: module/calp/repl.scm:35 +#: module/calp/repl.scm:35 module/calp/repl.scm:36 msgid "How did you get here?" msgstr "Hur hamnade du här?" @@ -608,7 +648,7 @@ msgstr "Visar version, vilket är ~a helt apropå." msgid "Print this help" msgstr "Visar den här hjälpen." -#: module/calp/main.scm:123 +#: module/calp/main.scm:123 module/calp/main.scm:124 #, scheme-format msgid "Configuration file ~a missing" msgstr "Konfigurationsfilen ~a saknas" @@ -616,27 +656,27 @@ msgstr "Konfigurationsfilen ~a saknas" #. Two arguments: #. Configuration file path, #. thrown error arguments -#: module/calp/main.scm:171 +#: module/calp/main.scm:171 module/calp/main.scm:174 #, scheme-format msgid "Failed loading config file ~a~%~s~%" msgstr "Misslyckades med att ladda konfigurationsfilen ~a~%~s~%" -#: module/calp/main.scm:212 +#: module/calp/main.scm:212 module/calp/main.scm:215 #, scheme-format msgid "Calp version ~a~%" msgstr "Calp version ~a~%" -#: module/calp/main.scm:218 +#: module/calp/main.scm:218 module/calp/main.scm:222 #, scheme-format msgid "tzget not installed, please put it in one of ~a" msgstr "tzget är inte intstalleratt, vänligen placera programmet i en av ~a" -#: module/calp/main.scm:250 +#: module/calp/main.scm:250 module/calp/main.scm:258 #, scheme-format msgid "Unsupported mode of operation: ~a~%" msgstr "Orimligt subbkomando: ~a~%" -#: module/calp/main.scm:265 +#: module/calp/main.scm:265 module/calp/main.scm:273 msgid "Program start" msgstr "Programstart" @@ -646,6 +686,7 @@ msgid "Default zoneinfo only available when tz-dir and tz-list are " msgstr "Standardzoninfo endast tillgängligt när tz-dir och tz-list är satta" #: module/datetime/zic.scm:166 module/datetime/zic.scm:339 +#: module/datetime/zic.scm:170 module/datetime/zic.scm:345 msgid "what even is \"Standard time\"‽" msgstr "Vad är ens \"Standardtid\"‽" @@ -659,22 +700,22 @@ msgid "Invalid key ~a. Note that leap seconds and\n" msgstr "Ogiltig nyckel ~a. Notera att skottsekunder och utgångsreglerännu " "inte är implementerade." -#: module/datetime/zic.scm:299 +#: module/datetime/zic.scm:299 module/datetime/zic.scm:305 #, scheme-format msgid "Unresolved link, target missing ~a -> ~a" msgstr "Ohanterad länk, saknar mål ~a -> ~a" -#: module/datetime/zic.scm:360 +#: module/datetime/zic.scm:360 module/datetime/zic.scm:367 msgid "Check your input" msgstr "Kontrollera din input" -#: module/datetime/zic.scm:384 +#: module/datetime/zic.scm:384 module/datetime/zic.scm:392 msgid "Counting backward for RRULES unsupported" msgstr "Att räkna baklänges stdöjs inte för RRULES" #. NOTE No zones seem to currently use %z formatting. #. '%z' is NOT a format string, but information about another format string. -#: module/datetime/zic.scm:403 +#: module/datetime/zic.scm:403 module/datetime/zic.scm:411 msgid "%z not yet implemented" msgstr "%z ännu ej implementerat" @@ -691,6 +732,7 @@ msgstr "Lägger till tidsspecifikationer av olika typer" #. second is error arguments #: module/vcomponent/datetime/output.scm:51 #: module/vcomponent/datetime/output.scm:58 +#: module/vcomponent/datetime/output.scm:50 #, scheme-format msgid "~a on formatting description, ~s" msgstr "~a vid formattering av beskrivning, ~s" @@ -720,20 +762,24 @@ msgstr "Ingen inläsare för typ" #: module/vcomponent/formats/ical/output.scm:94 #: module/vcomponent/formats/ical/parse.scm:230 #: module/vcomponent/formats/xcal/output.scm:73 +#: module/vcomponent/formats/ical/parse.scm:235 #, scheme-format msgid "Unknown key ~a" msgstr "Okänd nyckel ~a" #: module/vcomponent/formats/ical/parse.scm:124 +#: module/vcomponent/formats/ical/parse.scm:126 msgid "List in enum field" msgstr "Lista in uppräkningsinstansfält" #: module/vcomponent/formats/ical/parse.scm:159 +#: module/vcomponent/formats/ical/parse.scm:162 #, scheme-format msgid "List in non-list field: ~s" msgstr "Lista i fält för icke-lista: ~s" #: module/vcomponent/formats/ical/parse.scm:196 +#: module/vcomponent/formats/ical/parse.scm:200 msgid "TODO Implement REQUEST-STATUS" msgstr "TODO implementera REQUEST-STATUS" @@ -743,6 +789,7 @@ msgstr "TODO implementera REQUEST-STATUS" #. source line #. source file #: module/vcomponent/formats/ical/parse.scm:283 +#: module/vcomponent/formats/ical/parse.scm:288 #, scheme-format msgid "WARNING parse error around ~a\n" " ~?\n" @@ -755,6 +802,7 @@ msgstr "VARNING inläsningsfel runt ~a ~? rad ~a ~a~%" #. source line #. source file #: module/vcomponent/formats/ical/parse.scm:337 +#: module/vcomponent/formats/ical/parse.scm:342 #, scheme-format msgid "ERROR parse error around ~a\n" " ~?\n" @@ -772,21 +820,25 @@ msgid "No writer for type" msgstr "Ingen formatterare för typ" #: module/vcomponent/formats/vdir/parse.scm:62 +#: module/vcomponent/formats/vdir/parse.scm:66 #, scheme-format msgid "No events in component~%~a" msgstr "Inga händelser i komponenten~%~a" #: module/vcomponent/formats/xcal/parse.scm:87 +#: module/vcomponent/formats/xcal/parse.scm:86 #, scheme-format msgid "Invalid type ~a, with value ~a" msgstr "Ogiltig typ ~a, med värde ~a" #. TODO #: module/vcomponent/formats/xcal/parse.scm:157 +#: module/vcomponent/formats/xcal/parse.scm:159 msgid "Request status not yet implemented" msgstr "Statusbegäran ännu ej implementerad" #: module/vcomponent/util/instance/methods.scm:55 +#: module/vcomponent/util/instance/methods.scm:75 #, scheme-format msgid "Building <events> from~%" msgstr "Bygger <events> från~%" @@ -808,7 +860,7 @@ msgstr "Kan inte läsa fil av typen " msgid "Can't give week together with day or time" msgstr "Kan inte ge vecka tillsamans med dag eller tid" -#: module/calp/html/vcomponent.scm:512 +#: module/calp/html/vcomponent.scm:512 module/calp/html/vcomponent.scm:535 msgid "Last Modified" msgstr "Senast ändrad" @@ -888,7 +940,7 @@ msgstr "<group>Inputformat (härleds annars från <i>infile</i>)</group>" msgid "<group>Output format (otherwise infered from <i>outfile</i>)</group>" msgstr "<group>Utadataformat (härleds annars från <i>outfile</i>)</group>" -#: module/calp/entry-points/html.scm:35 +#: module/calp/entry-points/html.scm:35 module/calp/entry-points/html.scm:36 msgid "<group>How many pages should be rendered.\n" "If --style=<b>week</b> and --from=<b>2020-04-27</b>;\n" "then --count=<b>4</b> would render the four pages\n" @@ -899,13 +951,13 @@ msgstr "<group>Antal sidor att rendera.Om --style=<b>week</b> och --" "sidorna2020-04-27, 2020-05-04, 2020-05-11, och 2020-05-25.Antar " "värdet 12 för att ge ett helt år då --style=<b>month</b></group>" -#: module/calp/entry-points/html.scm:42 +#: module/calp/entry-points/html.scm:42 module/calp/entry-points/html.scm:43 msgid "<group>Directory where html files should end up. Default to <b>./" "html</b></group>" msgstr "<group>Katalog där html-filer ska placeras. Har standardvärder <b>./" "html</b></group>" -#: module/calp/entry-points/html.scm:46 +#: module/calp/entry-points/html.scm:46 module/calp/entry-points/html.scm:47 msgid "<group>How the body of the HTML page should be layed out.\n" "<br/><b>week</b>\n" "gives a horizontally scrolling page with 7 elements, where each has " @@ -925,7 +977,7 @@ msgstr "<group>Hur HTML-sidans komponenter ska placeras.<br/><b>week</b> ger " "dock inte grafiskt skalade.<br/><b>wide</b> Motsvarande som week, " "men för en hel månad</group>" -#: module/calp/entry-points/html.scm:57 +#: module/calp/entry-points/html.scm:57 module/calp/entry-points/html.scm:58 msgid "<group>Creates a standalone document instead of an HTML fragment\n" "for embedding in a larger page. Currently only applies to the " "<i>small</i> style</group>" @@ -934,6 +986,7 @@ msgstr "<group>Skapar ett fristående dokument istället för ett HTML-fragment "<i>small</i></group>" #: module/calp/entry-points/server.scm:19 +#: module/calp/entry-points/server.scm:20 msgid "<group>Bind to TCP port, defaults to <i>8080</i>.\n" "<br/>Can also be set through the config variable\n" "<i>port</i>.</group>" @@ -941,6 +994,7 @@ msgstr "<group>Bind till en TCP-port, och blir <i>8080</i> om osatt.<br/>Kan " "även sättas genom konfigurationsfältet <i>port</i>.</group>" #: module/calp/entry-points/server.scm:23 +#: module/calp/entry-points/server.scm:24 msgid "<group>Address to use, defaults to <i>0.0.0.0</i> for IPv4,\n" "and <i>[::]</i> for IPv6</group>" msgstr "<group>Address att använda, utgår från <i>0.0.0.0</i> för IPv4, samt " @@ -1019,12 +1073,25 @@ msgstr "<p><b>benchmark</b> <i>modul</i><br/>Kör proceduren 'run-benchmark' " #. Generation data #. Compact event list date only #. Header for sidebar day +#. Week view header format +#. start date metainfo +#. end date metainfo +#. Generation data +#. Compact event list date only +#. Header for sidebar day +#. start = end, only return one value #: module/calp/html/view/calendar/week.scm:50 #: module/calp/html/view/calendar.scm:92 module/calp/html/view/calendar.scm:94 #: module/calp/html/view/calendar.scm:156 module/calp/html/vcomponent.scm:52 #: module/calp/html/vcomponent.scm:218 module/vcomponent/datetime/output.scm:69 #: module/vcomponent/datetime/output.scm:70 #: module/vcomponent/datetime/output.scm:71 +#: module/calp/html/view/calendar/week.scm:51 +#: module/calp/html/view/calendar.scm:96 module/calp/html/view/calendar.scm:159 +#: module/calp/html/vcomponent.scm:75 module/calp/html/vcomponent.scm:241 +#: module/vcomponent/datetime/output.scm:61 +#: module/vcomponent/datetime/output.scm:62 +#: module/vcomponent/datetime/output.scm:63 msgid "~Y-~m-~d" msgstr "~Y-~m-~d" @@ -1032,32 +1099,113 @@ msgstr "~Y-~m-~d" #. Part of the sentance "Repeated [every two weeks], except on ~a, ~a & ~a" #. See everything tagged [FRR] #: module/vcomponent/datetime/output.scm:24 +#: module/vcomponent/datetime/output.scm:16 msgid "Repeated " msgstr "Upprepas " #. See [FRR] #: module/vcomponent/datetime/output.scm:29 +#: module/vcomponent/datetime/output.scm:21 msgid ", except on " msgstr ", undantaget " #. [FRR] Exception date without time #: module/vcomponent/datetime/output.scm:35 #: module/vcomponent/datetime/output.scm:44 +#: module/vcomponent/datetime/output.scm:27 +#: module/vcomponent/datetime/output.scm:36 #, scheme-format msgid "~e ~b" msgstr "~e ~b" #. [FRR] Exception date with time #: module/vcomponent/datetime/output.scm:42 +#: module/vcomponent/datetime/output.scm:34 msgid "~e ~b ~k:~M" msgstr "~e ~b ~k:~M" #: module/vcomponent/datetime/output.scm:79 +#: module/vcomponent/datetime/output.scm:71 msgid "~H:~M" msgstr "~H:~M" #. Note the non-breaking space #: module/vcomponent/datetime/output.scm:81 #: module/vcomponent/datetime/output.scm:84 +#: module/vcomponent/datetime/output.scm:73 +#: module/vcomponent/datetime/output.scm:76 msgid "~Y-~m-~d ~H:~M" msgstr "~Y-~m-~d ~H:~M" + +#: module/calp/html/components.scm:62 +#, scheme-format +msgid "href and onclick are mutually exclusive. href = ~s, onclick = ~s." +msgstr "" + +#. File size +#: module/calp/server/routes.scm:62 +msgid "Size" +msgstr "" + +#: module/calp/server/routes.scm:92 +#, scheme-format +msgid "Scandir argument invalid or not directory: ~s" +msgstr "" + +#: module/calp/util/config.scm:45 +#, scheme-format +msgid "No configuration slot named ~s, when defining ~s" +msgstr "" + +#. first slot is property name, second is new +#. property value. +#: module/calp/util/config.scm:65 +#, scheme-format +msgid "Pre-property failed when setting ~s to ~s" +msgstr "" + +#: module/calp/util/config.scm:80 +#, scheme-format +msgid "No configuration item named ~s" +msgstr "" + +#: module/datetime/zic.scm:267 +#, scheme-format +msgid "Invalid key ~s. Note that leap seconds and expries rules aren't yet " + "implemented." +msgstr "" + +#. first slot is the errornous character, +#. second is the whole string, third is the index +#. of the faulty character. +#: module/datetime/zic.scm:418 +#, scheme-format +msgid "Invalid format char ~s in ~s at position ~a" +msgstr "" + +#: module/vcomponent/formats/common/types.scm:140 +#, scheme-format +msgid "No parser for type ~a" +msgstr "" + +#: module/vcomponent/formats/vdir/save-delete.scm:27 +#, scheme-format +msgid "Can only save events belonging to calendars, event uid = ~s" +msgstr "" + +#: module/vcomponent/formats/vdir/save-delete.scm:33 +#, scheme-format +msgid "Can only save events belonging to vdir calendars. Calendar is of " + "type ~s" +msgstr "" + +#: module/vcomponent/formats/vdir/save-delete.scm:53 +#, scheme-format +msgid "Can only remove events belonging to vdir calendars. Calendar is of " + "type ~s" +msgstr "" + +#: module/vcomponent/util/parse-cal-path.scm:30 +#, scheme-format +msgid "Can't parse file of type ~s" +msgstr "" diff --git a/production-main b/production-main index 44db76e5..69f1bc06 100644 --- a/production-main +++ b/production-main @@ -1,2 +1,3 @@ #!/bin/bash -exec $(which guile) -c '((@ (calp main) main) (command-line))' "$@" +GUILE=${GUILE:-guile} +exec "$GUILE" -c '((@ (calp main) main) (command-line))' "$@" diff --git a/scripts/all-modules.scm b/scripts/all-modules.scm new file mode 100644 index 00000000..41f35393 --- /dev/null +++ b/scripts/all-modules.scm @@ -0,0 +1,33 @@ +(define-module (all-modules) + :use-module (ice-9 regex) + :use-module (srfi srfi-1) + :use-module (ice-9 ftw) + :use-module (ice-9 match) + :export (all-modules-under-directory)) + +(define (all-modules-under-directory dir) + "Returns two values, all scm files in dir, and all top +level modules in those files" + + (define re (make-regexp "\\.scm$")) + + (define files '()) + + (ftw dir (lambda (filename statinfo flag) + (cond ((and (eq? flag 'regular) + (regexp-exec re filename)) + => (lambda (m) + (set! files (cons filename files)) + #t + )) + (else #t)))) + + + (values files + (filter identity + (map (lambda (file) + (match (call-with-input-file file read) + (('define-module (module ...) _ ...) + module) + (_ #f))) + files)))) diff --git a/scripts/fetch-liu-map-index.scm b/scripts/fetch-liu-map-index.scm new file mode 100755 index 00000000..eea2a63d --- /dev/null +++ b/scripts/fetch-liu-map-index.scm @@ -0,0 +1,53 @@ +#!/usr/bin/guile \ +-s +!# + +;;; Commentary: +;; Bulids an index of "all" locations at LiU, and prints it as a JSON +;; object on the form { "location name": "url-fragment", ... }. These +;; fragments should be appended to the base "https://old.liu.se/karta/". +;; +;; See static/user/user-additions.js for this script in action. +;;; Code: + +(use-modules (srfi srfi-1) + (web client) + (web response) + (ice-9 rdelim) + (ice-9 format) + (sxml gumbo) + (sxml match) + (json)) + +(define-values (response body) (http-get "https://old.liu.se/karta/list?l=sv")) + +(unless (= 200 (response-code response)) + (format #t "Fetching index failed with ~a ~a~%" + (response-code response) + (response-reason-phrase response)) + (format #t "~{~s~%~}" (response-headers response)) + (exit 1)) + +(define data (html->sxml body)) + +(define rx (make-regexp "^karta\\?")) + +(define links + (map (lambda (node) + (sxml-match node + [(a (@ (href ,href)) ,b0 ,body ...) + (cons href b0)])) + (((@ (sxml xpath) sxpath) '(// a)) data))) + +(define map-links (filter (lambda (pair) (regexp-exec rx (car pair))) + links)) + +(define link-table (make-hash-table)) +(for-each (lambda (pair) (hash-set! link-table (string-upcase (string-trim-both (cdr pair))) + (car pair))) + map-links) + +(scm->json (hash-map->list (lambda (name frag) + `(,name . ,frag)) + link-table)) +(newline) diff --git a/scripts/module-dependants.scm b/scripts/module-dependants.scm index 212a28c8..95e5bf53 100755 --- a/scripts/module-dependants.scm +++ b/scripts/module-dependants.scm @@ -49,7 +49,7 @@ (define (regular-file? filename) (eq? 'regular (stat:type (cstat filename)))) -(define (filename-extension ext) +(define (filename-extension? ext) (let ((re (make-regexp (string-append ((@ (texinfo string-utils) escape-special-chars) ext "^$[]()*." #\\) @@ -88,7 +88,7 @@ ))) ) (delete target-file - (filter (filename-extension ".scm") + (filter (filename-extension? ".scm") (filter regular-file? (find-all-files-under module-dir))))))) diff --git a/scripts/use2dot/gen-use.scm b/scripts/use2dot/gen-use.scm index 02785088..6c621fdd 100755 --- a/scripts/use2dot/gen-use.scm +++ b/scripts/use2dot/gen-use.scm @@ -2,43 +2,19 @@ !# (add-to-load-path (dirname (current-filename))) +(add-to-load-path (dirname (dirname (current-filename)))) (use-modules ((scripts frisk) :select (make-frisker edge-type edge-up edge-down)) (srfi srfi-1) - (ice-9 ftw) - (ice-9 regex) - (ice-9 match) ((graphviz) :prefix gv.) + (all-modules) ) (define scan (make-frisker `(default-module . (calp main)))) -(define re (make-regexp "\\.scm$")) - -(define lst '()) - -(ftw "module" (lambda (filename statinfo flag) - (cond ((and (eq? flag 'regular) - (regexp-exec re filename)) - => (lambda (m) - (set! lst (cons filename lst)) - #t - )) - (else #t)))) - - - -(define files lst) - -(define our-modules - (filter identity - (map (lambda (file) - (match (call-with-input-file file read) - (('define-module (module ...) _ ...) - module) - (_ #f))) - files))) +(define-values (files our-modules) + (all-modules-under-directory "module")) (define graph (gv.digraph "G")) (gv.setv graph "color" "blue") @@ -133,7 +109,7 @@ (for-each (lambda (edge) - (let ((gv-edge (gv.edge graph + (let ((gv-edge (gv.edge graph (format #f "~a" (edge-down edge)) (format #f "~a" (edge-up edge)) ))) @@ -144,7 +120,7 @@ (not (memv (car (edge-down edge)) '(vcomponent calp )))) (gv.setv gv-edge "color" "blue")) )) - (remove-edges '((srfi srfi-1) + (remove-edges '((srfi srfi-1) (srfi srfi-9) (srfi srfi-26) (srfi srfi-41) diff --git a/static/Makefile b/static/Makefile index b85422a3..1979575d 100644 --- a/static/Makefile +++ b/static/Makefile @@ -1,10 +1,11 @@ -.PHONY: all clean watch +.PHONY: all install clean watch -TARGETS := style.css smallcal.css script.out.js +TARGETS := style.css smallcal.css script.out.js directory-listing.css WATCH= # script explicitly named, since that is our entry point TS_FILES = script.ts $(shell find . -type f -name \*.ts -not -path */node_modules/*) +JS_FILES = $(TS_FILES:%.ts=%.js) export PATH := $(shell npm bin):$(PATH) @@ -20,15 +21,11 @@ script.out.js: $(TS_FILES) deps.svg: $(TS_FILES) madge --image $@ $^ -# Note that 'tsc --watch' doesn't provide the files we are using. It's -# just here for debug. watch: - tmux \ - new-session "scss --watch -I. style.scss:style.css" \; \ - split-window "tsc --watch" \; \ - rename-session "calp watch" \; \ - select-layout even-vertical + ./make-watch +install: all + install -m644 -t $(DESTDIR)/usr/share/calp/www/ $(TARGETS) clean: rm $(TARGETS) diff --git a/static/_global.scss b/static/_global.scss index 41f426f9..58e05155 100644 --- a/static/_global.scss +++ b/static/_global.scss @@ -13,4 +13,5 @@ $popup-style: "left"; /* Each popup can have a different amoutn of tabs. Override this as appropriate */ --tabcount: 4; + --background-color: white; } diff --git a/static/components/date-time-input.ts b/static/components/date-time-input.ts index a6d5df18..005e4190 100644 --- a/static/components/date-time-input.ts +++ b/static/components/date-time-input.ts @@ -67,7 +67,7 @@ class DateTimeInput extends /* HTMLInputElement */ HTMLElement { } set value(date: Date) { - let [d, t] = date.format("~L~Y-~m-~dT~H:~M:~S").split('T'); + let [d, t] = date.format("~L~Y-~m-~dT~H:~M").split('T'); // console.log(d, t); this.date.value = d; this.time.value = t; diff --git a/static/components/vevent-description.ts b/static/components/vevent-description.ts index 4d81d6b3..f0d224be 100644 --- a/static/components/vevent-description.ts +++ b/static/components/vevent-description.ts @@ -2,7 +2,7 @@ export { ComponentDescription } import { VEvent } from '../vevent' import { ComponentVEvent } from './vevent' -import { makeElement } from '../lib' +import { formatters } from '../formatters' /* <vevent-description /> @@ -24,26 +24,12 @@ class ComponentDescription extends ComponentVEvent { for (let el of body.querySelectorAll('[data-property]')) { if (!(el instanceof HTMLElement)) continue; let p = el.dataset.property!; - let d, fmt; + let d; if ((d = data.getProperty(p))) { - switch (p.toLowerCase()) { - case 'categories': - for (let item of d) { - let q = encodeURIComponent( - `(member "${item}" (or (prop event (quote CATEGORIES)) (quote ())))`) - el.appendChild(makeElement('a', { - textContent: item, - href: `/search/?q=${q}`, - })) - } - break; - default: - if ((fmt = el.dataset.fmt)) { - el.textContent = d.format(fmt); - } else { - el.textContent = d; - } - } + let key = p.toLowerCase(); + let f = formatters.get(key); + if (f) f(el, d); + else window.formatters.get('default')!(el, d); } } diff --git a/static/directory-listing.scss b/static/directory-listing.scss new file mode 100644 index 00000000..745b5bc3 --- /dev/null +++ b/static/directory-listing.scss @@ -0,0 +1,5 @@ +@import 'global'; + +.directory-table td:nth-child(3) { + text-align: end; +} diff --git a/static/formatters.ts b/static/formatters.ts new file mode 100644 index 00000000..828a0e8b --- /dev/null +++ b/static/formatters.ts @@ -0,0 +1,35 @@ +export { + formatters, +} + +import { makeElement } from './lib' + +declare global { + interface Window { + formatters : Map<string, (e : HTMLElement, s : any) => void>; + } +} + +let formatters : Map<string, (e : HTMLElement, s : any) => void>; +formatters = window.formatters = new Map(); + + +formatters.set('categories', (el, d) => { + for (let item of d) { + let q = encodeURIComponent( + `(member "${item}" (or (prop event (quote CATEGORIES)) (quote ())))`) + el.appendChild(makeElement('a', { + textContent: item, + href: `/search/?q=${q}`, + })) + } +}) + +formatters.set('default', (el, d) => { + let fmt; + if ((fmt = el.dataset.fmt)) { + el.textContent = d.format(fmt); + } else { + el.textContent = d; + } +}) diff --git a/static/globals.ts b/static/globals.ts index eb7488c0..2fc12933 100644 --- a/static/globals.ts +++ b/static/globals.ts @@ -30,6 +30,8 @@ window.addNewEvent = () => { let ev = new VEvent(); let uid = uuid() let now = new Date() + /* Round seconds to 0, since time inputs wants exact seconds */ + now.setUTCSeconds(0); ev.setProperties([ ['uid', uid], ['dtstart', now, 'date-time'], diff --git a/static/make-watch b/static/make-watch new file mode 100755 index 00000000..c985b37f --- /dev/null +++ b/static/make-watch @@ -0,0 +1,23 @@ +#!/bin/bash + +here=$(dirname "$(realpath "$0")") +cd "$here" || { + echo "Failed to cd to location of script ($here)" + exit 1 +} + +export PATH="$here/node_modules/.bin:$PATH" + +# Note that 'tsc --watch' doesn't provide the files we are using. It's +# just here for debug. +if [ -n "$TMUX" ]; then + tmux new-window "scss --watch -I. style.scss:style.css" + tmux new-window "tsc --watch" +else + tmux \ + new-session "scss --watch -I. style.scss:style.css" \; \ + split-window "tsc --watch" \; \ + rename-session "calp watch" \; \ + select-layout even-vertical + + fi diff --git a/static/style.scss b/static/style.scss index efe8291d..c5705e24 100644 --- a/static/style.scss +++ b/static/style.scss @@ -11,6 +11,8 @@ html, body { max-width: 100%; height: 100%; + background-color: var(--background-color); + grid-template-columns: auto auto 20em; grid-template-rows: auto; @@ -227,10 +229,16 @@ Each event within the eventlist padding-left: 2px; margin-top: 1em; - header h2 { - width: 100%; - text-align: center; - font-size: 14pt; + header { + position: sticky; + top: 0; + background-color: var(--background-color); + + h2 { + width: 100%; + text-align: center; + font-size: 14pt; + } } } diff --git a/static/user/.gitignore b/static/user/.gitignore new file mode 100644 index 00000000..6039f77d --- /dev/null +++ b/static/user/.gitignore @@ -0,0 +1,2 @@ +!*.js +salar.json diff --git a/static/user/user-additions.js b/static/user/user-additions.js new file mode 100644 index 00000000..c9ebe1a4 --- /dev/null +++ b/static/user/user-additions.js @@ -0,0 +1,62 @@ +window.formatters.set('description', (el, d) => { + if (/<br\/?>/.exec(d)) { + /* Assume that the text is HTML iff it contains a <br/> tag */ + let parser = new DOMParser(); + let doc = parser.parseFromString(d, 'text/html'); + el.replaceChildren(doc.body); + } else { + /* Otherwise it should be plain(er) text, parse "all" links */ + let rx = /https?:\/\/\S+/g + let idx = 0; + let children = [] + for (let match of d.matchAll(rx)) { + let anch = document.createElement('a') + anch.href = match[0] + anch.textContent = match[0] + + children.push(d.substring(idx, match.index)) + children.push(anch) + + idx = match.index + match[0].length + } + children.push(d.substring(idx)) + el.replaceChildren(...children); + } +}) + +/* This location formatter is generally not for general use. + It holds a small lookup table of "all" locations at Linköping University, + and makes location names from their calendar system clickable. + + To obtain salar.json, run scripts/fetch-liu-map-index.scm from calps source tree. +*/ + +window.salar = new Promise((resolve, reject) => + fetch('/static/user/salar.json') + .then(d => d.json()) + .then(d => resolve(d))) + + +window.formatters.set('location', async function(el, d) { + let rx = /Lokal: (.*)/ + let m = rx.exec(d) + if (! m) { + el.textContent = d; + return; + } + + let salar = await window.salar; + + let name = m[1] + let frag = salar[name]; + if (frag) { + let anch = document.createElement('a'); + anch.href = `https://old.liu.se/karta/${frag}` + anch.target = '_blank' + anch.textContent = name; + el.append('Lokal: '); + el.append(anch); + } else { + el.textContent = `Lokal: ${name}` + } +}) diff --git a/static/vevent.ts b/static/vevent.ts index cee26727..56c9019a 100644 --- a/static/vevent.ts +++ b/static/vevent.ts @@ -396,10 +396,13 @@ function xml_to_recurrence_rule(xml: Element): RecurrenceRule { break; case 'count': - case 'interval': rr.count = Number(t) break; + case 'interval': + rr.interval = Number(t) + break; + case 'bysecond': case 'byminute': case 'byhour': diff --git a/tests/annoying-events.scm b/tests/annoying-events.scm deleted file mode 100644 index 90e6a184..00000000 --- a/tests/annoying-events.scm +++ /dev/null @@ -1,59 +0,0 @@ -(((srfi srfi-41 util) filter-sorted-stream) - ((srfi srfi-41) stream stream->list stream-filter stream-take-while) - ((vcomponent base) extract prop make-vcomponent) - ((vcomponent datetime) event-overlaps?) - ((datetime) date date+ date<) - ((hnh util) set!)) - -(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 end (date+ start (date day: 8))) - -(define ev-set - (stream - (event ; should be part of the result - summary: "A" - dtstart: #2021-10-01 - dtend: #2021-12-01) - (event ; 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 - summary: "C" - dtstart: #2021-11-02 - dtend: #2021-11-03))) - -;; (if (and (date< (prop ev 'DTSTART) start-date) -;; (date<= (prop ev 'DTEND) end-date)) -;; ;; event will be picked, but next event might have -;; (and (date< start-date (prop ev 'DTSTART)) -;; (date< end-date (prop ev 'DTEND))) -;; ;; meaning that it wont be added, stopping filter-sorted-stream -;; ) - -;; The naïve way to get all events in an interval. Misses C due to B being "in the way" - -(test-equal "incorrect handling of non-contigious" - '("A" #; "C") - (map (extract 'SUMMARY) - (stream->list - (filter-sorted-stream - (lambda (ev) (event-overlaps? ev start (date+ start (date day: 8)))) - ev-set)))) - -;; A correct way - -(test-equal "correct handling of non-contigious" - '("A" "C") - (map (extract 'SUMMARY) - (stream->list - (stream-filter (lambda (ev) (event-overlaps? ev start end)) - (stream-take-while (lambda (ev) (date< (prop ev 'DTSTART) end)) - ev-set))))) diff --git a/tests/cpp.scm b/tests/cpp.scm deleted file mode 100644 index 84bd4b92..00000000 --- a/tests/cpp.scm +++ /dev/null @@ -1,43 +0,0 @@ -;;; Commentary: -;; Tests my parser for a subset of the C programming language. -;;; Code: - -(((c lex) lex) - ((c parse) parse-lexeme-tree)) - -(define run (compose parse-lexeme-tree lex)) - -(test-equal - '(+ (post-increment (dereference C)) 3) - (run "(*C)++ + 3")) - - -(test-equal - '(+ (post-increment (dereference C)) 3) - (run "*C++ + 3")) - -(test-equal - '(post-increment (dereference C)) - (run "*C++")) - -(test-equal - '(+ (post-increment C) (post-increment C)) - (run "C++ + C++")) - -(test-equal - '(+ (pre-increment C) (pre-increment C)) - (run "++C + ++C")) - - -(test-equal - '(+ 2 (* 2 2)) - (run "2 + 2 * 2")) - -(test-equal - '(+ (* 2 2) 2) - (run "2 * 2 + 2")) - -(test-equal - '(+ 2 2 2) - (run "2+2+2")) - diff --git a/tests/datetime-compare.scm b/tests/datetime-compare.scm deleted file mode 100644 index f2585f46..00000000 --- a/tests/datetime-compare.scm +++ /dev/null @@ -1,83 +0,0 @@ -;;; Commentary: -;; Tests that all ordering predicates for dates, -;; times, and datetimes hold. -;;; Code: - -(((datetime) - date - datetime time - date< date<= - date> date>= - date/-time< - time< - )) - -(test-assert "date< empty" - (date<)) - -(test-assert "date< single" - (date< #2020-01-10)) - -(test-assert "date< double" - (date< #2020-01-10 #2020-01-11)) - -(test-assert "date< tripple" - (date< #2020-01-10 #2020-01-11 #2020-01-12)) - -(test-assert "date< tripple negate" - (not (date< #2020-01-10 #2020-01-12 #2020-01-11))) - -(test-assert "date<= empty" - (date<=)) - -(test-assert "date<= single" - (date<= #2020-01-10)) - -(test-assert "date<= double" - (date<= #2020-01-10 #2020-01-11)) - -(test-assert "date<=" - (not (date<= #2020-01-01 #2018-05-15 #2020-01-31))) - -(test-assert "date<= equal" - (date<= #2018-05-15 #2018-05-15)) - -(test-assert "date<" - (not (date< #2020-01-01 #2018-05-15 #2020-01-31))) - -(test-assert "date>" - (not (date> #2020-01-31 #2018-05-15 #2020-01-01 ))) - -(test-assert "date>=" - (not (date>= #2020-01-31 #2018-05-15 #2020-01-01))) - -(test-assert "time< simple" - (time< #05:00:00 #10:00:00)) - -(test-assert "time<" - (time< (time) #10:00:00)) - -(test-assert "date/-time<" - (date/-time< #2020-01-01 #2020-01-02)) - -(test-assert "not date/-time<" - (not (date/-time< #2020-01-01 #2020-01-01))) - -(test-assert "date/-time< only other dt" - (date/-time< #2020-01-01 #2020-01-02T10:00:00)) - -(test-assert "date/-time< other dt, same date" - (date/-time< #2020-01-01 #2020-01-01T10:00:00)) - -;; In UTC+2 (CEST) the below datetime overflows into midnight the following -;; day. Earlier versions of this program only looked at the time component -(test-assert "date/-time< TZ overflow" - (date/-time< #2020-04-05 - (datetime date: #2020-04-05 time: #22:00:00 tz: "UTC"))) - -(test-assert "date/-time< time-only" - (date/-time< #00:00:00 #10:00:00)) - -(test-assert (not (date/-time< #2018-11-30T08:10:00 #2014-04-13T16:00:00))) - - diff --git a/tests/datetime-util.scm b/tests/datetime-util.scm deleted file mode 100644 index 28317676..00000000 --- a/tests/datetime-util.scm +++ /dev/null @@ -1,92 +0,0 @@ -;;; Commentary: -;; Tests timespan overlaps and month-streams. -;; Separate from tests/datetime.scm since -;; (datetime util) originally was its own module. -;;; Code: - -(((datetime) date time datetime - month-stream in-date-range? timespan-overlaps?) - ((srfi srfi-41) stream->list stream-take - )) - -(test-assert "jan->dec" - (stream->list (stream-take 11 (month-stream #2020-01-01)))) - -(test-assert "dec->jan" - (stream->list (stream-take 2 (month-stream #2020-12-01)))) - -(test-assert "dec->feb" - (stream->list (stream-take 3 (month-stream #2020-12-01)))) - -(test-assert "20 months" - (stream->list (stream-take 20 (month-stream #2020-01-01)))) - -(test-equal "Correct months" - (list #2020-02-01 #2020-03-01 #2020-04-01 #2020-05-01 #2020-06-01 #2020-07-01 #2020-08-01 #2020-09-01 #2020-10-01 #2020-11-01 #2020-12-01 #2021-01-01) - - (stream->list (stream-take 12 (month-stream #2020-02-01)))) - -(test-assert "in-date-range?" - (not ((in-date-range? #2020-01-01 #2020-02-29) - #2018-02-02))) - - - - -(test-assert "A" - (timespan-overlaps? #2020-01-01 #2020-01-10 - #2020-01-05 #2020-01-15)) - -(test-assert "A, shared start" - (timespan-overlaps? #2020-01-01 #2020-01-10 - #2020-01-01 #2020-01-15)) - -(test-assert "A, tangential" - (not (timespan-overlaps? #2020-01-01T00:00:00 #2020-01-10T00:00:00 - #2020-01-10T00:00:00 #2020-01-30T00:00:00))) - - - -(test-assert "s1 instant" - (timespan-overlaps? #2020-01-15T10:00:00 #2020-01-15T10:00:00 - #2020-01-10T00:00:00 #2020-01-30T00:00:00)) - -(test-assert "s2 instant" - (timespan-overlaps? #2020-01-10T00:00:00 #2020-01-30T00:00:00 - #2020-01-15T10:00:00 #2020-01-15T10:00:00)) - -(test-assert "s1 instant, shared start with s2" - (timespan-overlaps? #2020-01-15T10:00:00 #2020-01-15T10:00:00 - #2020-01-15T10:00:00 #2020-01-30T00:00:00)) - - -(test-assert "s1 instant, shared end with s2" - (not (timespan-overlaps? #2020-01-15T10:00:00 #2020-01-15T10:00:00 - #2020-01-10T00:00:00 #2020-01-15T10:00:00))) - -(test-assert "s2 instant, shared start with s1" - (timespan-overlaps? #2020-01-15T10:00:00 #2020-01-30T00:00:00 - #2020-01-15T10:00:00 #2020-01-15T10:00:00)) - - -(test-assert "s2 instant, shared end with s1" - (not (timespan-overlaps? #2020-01-10T00:00:00 #2020-01-15T10:00:00 - #2020-01-15T10:00:00 #2020-01-15T10:00:00))) - - -(test-assert "both instant" - (not (timespan-overlaps? #2020-01-15T10:00:00 #2020-01-15T10:00:00 - #2020-01-15T10:00:00 #2020-01-15T10:00:00))) - -(test-assert "tangential whole day" - (not (timespan-overlaps? #2020-01-01 #2020-01-02 - #2020-01-02 #2020-01-03))) - -(test-assert "B" - (timespan-overlaps? #2020-01-05 #2020-01-15 - #2020-01-01 #2020-01-10)) - - -(test-assert "E" - (timespan-overlaps? #2020-01-01 #2020-01-10 - #2020-01-01 #2020-01-10)) diff --git a/tests/datetime.scm b/tests/datetime.scm deleted file mode 100644 index eb9c02b6..00000000 --- a/tests/datetime.scm +++ /dev/null @@ -1,241 +0,0 @@ -;;; Commentary: -;; Tests date, time, and datetime creation, -;; (output) formatting, and arithmetic. -;;; Code: - -(((datetime) date+ date- - time+ time- - year month day - date time - datetime - datetime+ - datetime<=? - datetime-difference - datetime- - leap-year? - string->date string->time string->datetime - parse-month - ) - ((ice-9 format) format) - ((hnh util) let*) - ((ice-9 i18n) make-locale) - ((guile) LC_TIME) - ) - -(test-equal "empty time" - (time) #00:00:00) - -(test-assert "Synatx date" - #2020-01-01) - -(test-assert "Test year type" - (integer? (year (date year: 2020)))) - -(test-assert "Test mmnth type" - (integer? (month (date month: 1)))) - -(test-assert "Test day type" - (integer? (day (date day: 1)))) - -(test-equal "Manual print (any)" - "2020-10-10" - (let ((d (date year: 2020 month: 10 day: 10))) - (format #f "~a-~a-~a" - (year d) (month d) (day d)))) - -(test-equal "Manual print (number)" - "2020-10-10" - (let ((d (date year: 2020 month: 10 day: 10))) - (format #f "~d-~d-~d" - (year d) (month d) (day d)))) - -(test-equal "Date print" - "#2020-01-01" - (format #f "~a" (date year: 2020 month: 1 day: 1))) - -(test-equal "Syntax date=" - (date year: 2020 month: 1 day: 1) - #2020-01-01) - -(test-equal "Syntax time=" - (time hour: 13 minute: 37 second: 0) - #13:37:00) - -(test-equal "Syntax Datetime=" - (datetime year: 2020 month: 1 day: 1 hour: 13 minute: 37 second: 0) - #2020-01-01T13:37:00) - -(test-equal #2020-02-28 (date- #2020-03-05 (date day: 6))) -(test-equal #2020-02-29 (date- #2020-03-05 (date day: 5))) -(test-equal #2020-03-01 (date- #2020-03-05 (date day: 4))) - -(test-equal "date+ day" #2020-10-10 (date+ #2020-10-01 (date day: 9))) -(test-equal "date+ month" #2020-10-10 (date+ #2020-01-10 (date month: 9))) -(test-equal "date+ day/month" #2020-10-10 (date+ #2020-01-01 (date day: 9 month: 9))) -;; (test-equal "date+ year" #4040-10-10 (date+ #2020-10-10 (date year: 2020))) - -(test-assert "date+ first literal" (date+ #2020-01-01 (date day: 0))) -(test-assert "date+ second literal" (date+ (date year: 1 month: 1 day: 1) #0001-00-00)) -(test-assert "date+ both literal" (date+ #2020-01-01 #0000-00-00)) - -(test-equal "date+ year overflow" #2019-01-01 (date+ #2018-12-31 (date day: 1))) -(test-equal "date- year overflow" #2018-12-31 (date- #2019-01-01 (date day: 1))) - -;; (test-equal "date+ large" #4040-10-10 (date+ #2020-05-03 #2020-05-07)) - -(test-equal "date- large" #0001-01-01 (date- #2020-01-01 #2019-00-00)) - -;; Datum är spännande -(test-equal "date- equal" (date year: -1 month: 11 day: 31) - (date- #2020-01-01 #2020-01-01)) - -(test-equal #2020-01-01T10:00:00 (datetime date: #2020-01-01 - time: #10:00:00)) -(test-equal #2020-01-01T10:00:00 - (datetime+ (datetime date: #2020-01-01) - (datetime time: #10:00:00))) - -(test-equal - #2020-10-09T14:00:00 - (datetime- #2020-10-10T00:00:00 - (datetime time: #10:00:00))) - -(test-equal - #2020-09-24T14:00:00 - (datetime- #2020-10-10T00:00:00 - #0000-00-15T10:00:00)) - - -(test-equal #2020-03-10 - (date+ #2020-03-01 - (date day: 4) - (date day: 5))) - - -(let* ((diff overflow (time- #10:20:30 #10:20:30))) - (test-equal "time- self" #00:00:00 diff) - (test-equal "time- self overflow" 0 overflow)) - -(let* ((diff overflow (time- #10:00:00 #10:00:01))) - (test-equal "time- overflow 1s" #23:59:59 diff) - (test-equal "time- overflow 1s overflow" 1 overflow)) - - -(let* ((diff overflow (time- #10:00:00 (time hour: (+ 48 4))))) - (test-equal "time- overflow multiple" #06:00:00 diff) - (test-equal "time- overflow multiple overflow" 2 overflow)) - -(test-equal "datetime-difference self" - #0000-00-00T00:00:00 - (datetime-difference (datetime date: #2020-01-01) (datetime date: #2020-01-01))) - -;; (test-assert -;; (datetime- #2018-01-17T10:00:00 -;; #2018-01-17T08:00:00)) - - -;; (test-assert -;; (datetime<=? (datetime time: (time hour: 24)) -;; (datetime- #2018-01-17T10:00:00 -;; #2018-01-17T08:00:00))) - - -;; NOTE -;; at the time of writing this returns #2020-02-00 -;; The general question is, how is the last in a month handled? -(test-equal - #2020-01-31 - (date+ #2019-12-31 (date month: 1))) - -(test-assert (leap-year? 2020)) - -(test-equal "Add to Leap day" - #2020-02-29 (date+ #2020-02-28 (date day: 1))) - - -(test-equal "Parse ISO" - #2021-12-30T13:53:33 - (string->datetime "2021-12-30T13:53:33" "~Y-~m-~dT~H:~M:~S")) - -(test-equal "Parse ical date-time" - #2021-12-30T13:53:33 - (string->datetime "20211230T135333" "~Y~m~dT~H~M~S")) - - -(test-equal "Parse single hour (padded)" - (time hour: 5) - (string->time "05" "~H")) - -(test-equal "Parse single hour (non-padded)" - (time hour: 5) - (string->time "5" "~H")) - -(test-equal "Parse month (swedish)" - (date month: 5) - (string->date "Maj" "~b" (make-locale LC_TIME "sv_SE.UTF-8"))) - -(test-equal "Parse month (english)" - (date month: 5) - (string->date "May" "~b" (make-locale LC_TIME "en_US.UTF-8"))) - -(test-equal "AM/PM AM" - (time hour: 10) - (string->time "10 AM" "~H ~p")) - -(test-equal "AM/PM PM" - (time hour: 22) - (string->time "10 PM" "~H ~p")) - -(test-equal "AM/PM AM 12" - (time hour: 0) - (string->time "12 AM" "~H ~p")) - -(test-equal "AM/PM PM 12" - (time hour: 12) - (string->time "12 PM" "~H ~p")) - -(test-equal "AM/PM PM (prefix)" - (time hour: 22) - (string->time "PM 10" "~p ~H")) - -(test-equal "Parse complicated 1" - #2021-12-30T10:56:00 - (string->datetime "Dec. 30, 2021, 10:56" - "~b. ~d, ~Y, ~H:~M" - (make-locale LC_TIME "en_US.UTF-8"))) - -(test-equal "Parse complicated 2" - #2021-12-30T10:56:00 - (string->datetime "Dec. 30, 2021, 10:56 a.m." - "~b. ~d, ~Y, ~H:~M" - (make-locale LC_TIME "en_US.UTF-8"))) - -(test-equal "Parse complicated 3" - #2021-12-30T22:56:00 - (string->datetime "Dec. 30, 2021, 10:56 p.m." - "~b. ~d, ~Y, ~H:~M ~p" - (make-locale LC_TIME "en_US.UTF-8"))) - -(test-equal "Parse date single digit day" - (date day: 6) - (string->date "6" "~d")) - -(test-equal "Parse date single digit day, trailing comma" - (date day: 6) - (string->date "6," "~d,")) - -(test-equal "Parse date single digit day, trailing comma + space" - (date day: 6) - (string->date "6, " "~d, ")) - - -(define en_US (make-locale LC_TIME "en_US.UTF-8")) -(define sv_SE (make-locale LC_TIME "sv_SE.UTF-8")) - -(test-equal 1 (parse-month "jan" en_US)) -(test-equal 1 (parse-month "jan" sv_SE)) - -(test-equal 12 (parse-month "dec" en_US)) -(test-equal -1 (parse-month "inv" en_US)) - -(test-equal 5 (parse-month "mAJ" sv_SE)) diff --git a/tests/let-env.scm b/tests/let-env.scm deleted file mode 100644 index 17cfb817..00000000 --- a/tests/let-env.scm +++ /dev/null @@ -1,22 +0,0 @@ -(((guile) setenv getenv) - ((hnh util) let-env)) - -(setenv "CALP_TEST_ENV" "1") -(test-equal "Ensure we have set value beforehand" - "1" (getenv "CALP_TEST_ENV")) -(let-env ((CALP_TEST_ENV "2")) - (test-equal "Test our local override" - "2" (getenv "CALP_TEST_ENV"))) -(test-equal "Test that we have returned" - "1" (getenv "CALP_TEST_ENV")) - -(catch 'test-error - (lambda () - (let-env ((CALP_TEST_ENV "2")) - (test-equal "Test our local override again" - "2" (getenv "CALP_TEST_ENV")) - (throw 'test-error))) - list) - -(test-equal "Test restoration after non-local exit" - "1" (getenv "CALP_TEST_ENV")) diff --git a/tests/let.scm b/tests/let.scm deleted file mode 100644 index 3f1b52a7..00000000 --- a/tests/let.scm +++ /dev/null @@ -1,20 +0,0 @@ -;;; Commentary: -;; Tests my custom let*. -;;; Code: - -(((hnh util) let*) - ((guile) set!)) - -(test-assert (let* ((a #t)) a)) -(test-assert (let* (((a . b) (cons #t #f))) a)) -(test-assert (let* (((a . b) (cons* #f #t))) b)) -(test-assert (let* ((a b c (values #f #t #f))) b)) -(test-assert (let* (((a b c) (list #f #t #f))) b)) -(test-assert (let* (((a) '(#t))) a)) -(test-equal '(2) (let* (((a . b) '(1 2))) b)) -(test-equal '(3 4) (let* (((a b . c) '(1 2 3 4))) c)) -(test-equal 10 (let* (x) (set! x 10) x)) -(test-equal 30 (let* (x y) (set! x 10) (set! y 20) (+ x y))) -(test-assert (let* (x) (not x))) -(test-equal 6 (let* ((x 1) y z) (set! y 2) (set! z 3) (+ x y z))) - diff --git a/tests/param.scm b/tests/param.scm deleted file mode 100644 index cf8c9458..00000000 --- a/tests/param.scm +++ /dev/null @@ -1,39 +0,0 @@ -;;; Commentary: -;; Checks that parameters (1) are correctly parsed and stored. -;; (1): 'A', and 'B' in the line "KEY;A=1;B=2:Some text" -;;; Code: - -(((vcomponent base) param prop* parameters prop) - ((vcomponent formats ical parse) parse-calendar) - ((vcomponent) make-vcomponent) - ((hnh util) sort* set!)) - -(define v (call-with-input-string - "BEGIN:DUMMY -X-KEY;A=1;B=2:Some text -END:DUMMY" - parse-calendar)) - -(test-equal '("1") (param (prop* v 'X-KEY) 'A)) -(test-equal '("2") (param (prop* v 'X-KEY) 'B)) -(test-equal #f (param (prop* v 'X-KEY) 'C)) - -(test-equal '(A B) (sort* (map car (parameters (prop* v 'X-KEY))) - string<? - symbol->string)) - -;; TODO possibly move this. -;; Checks that a warning is properly raised for -;; unkonwn keys (without an X-prefix) -(test-error - 'warning - (call-with-input-string "BEGIN:DUMMY -KEY:Some Text -END:DUMMY")) - -;; Similar thing happens for sxcal, but during serialization instead -(let ((component (make-vcomponent 'DUMMY))) - (set! (prop component 'KEY) "Anything") - (test-error - 'warning - (vcomponent->sxcal component))) diff --git a/tests/recurrence-advanced.scm b/tests/recurrence-advanced.scm deleted file mode 100644 index 4f26f2c7..00000000 --- a/tests/recurrence-advanced.scm +++ /dev/null @@ -1,1163 +0,0 @@ -;;; Commentary: -;; Tests of recurrence rule generation with focus on correct instances -;; being generated. For tests of basic recurrence functionallity, see -;; recurrence-simple.scm. -;; -;; This file also tests format-recurrence-rule, which checks that human -;; readable representations of the RRULES work. -;; -;; Also contains the tests for EXDATE. -;; -;; Most examples copied from RFC5545, some home written. -;;; Code: - -;; The human readable tests are expected to fail with any change to the -;; text creator. Proof-read them manually, and update the test cases -;; to match. `x-summary' used for target string. Target strings should -;; be in swedish. - -(((vcomponent recurrence parse) parse-recurrence-rule) - ((vcomponent recurrence generate) generate-recurrence-set) - ((vcomponent recurrence display) format-recurrence-rule) - ((vcomponent recurrence internal) count until) - ((vcomponent base) make-vcomponent prop prop* extract) - ((datetime) parse-ics-datetime datetime time date - datetime->string) - ((hnh util) -> set!) - ((srfi srfi-41) stream->list) - ((srfi srfi-88) keyword->string)) - -(define (run-test comp) - - (test-equal (string-append "RSET: " (prop comp 'SUMMARY)) - (prop comp 'X-SET) - (let ((r (generate-recurrence-set comp))) - (map (extract 'DTSTART) - (if (or (until (prop comp 'RRULE)) - (count (prop comp 'RRULE))) - (stream->list r) - (stream->list 20 r))))) - - (test-equal (string-append "STR: " (prop comp 'SUMMARY)) - (prop comp 'X-SUMMARY) - (format-recurrence-rule (prop comp 'RRULE)))) - - -(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))) - (set! (prop v symb) - (case symb - [(DTSTART EXDATE) (parse-ics-datetime (cadr rem))] - [(RRULE) (parse-recurrence-rule (cadr rem))] - [else (cadr rem)])) - ;; hack for multi valued fields - (when (eq? symb 'EXDATE) - (set! (prop* v symb) = list))) - (loop (cddr rem)))) - - v) - -(map run-test - (list - (vevent - summary: "Daily for 10 occurrences" - dtstart: "19970902T090000" - rrule: "FREQ=DAILY;COUNT=10" - x-summary: "dagligen, totalt 10 gånger" - x-set: (list #1997-09-02T09:00:00 - #1997-09-03T09:00:00 - #1997-09-04T09:00:00 - #1997-09-05T09:00:00 - #1997-09-06T09:00:00 - #1997-09-07T09:00:00 - #1997-09-08T09:00:00 - #1997-09-09T09:00:00 - #1997-09-10T09:00:00 - #1997-09-11T09:00:00)) - - (vevent - summary: "Daily until December 24, 1997" - dtstart: "19970902T090000" - rrule: "FREQ=DAILY;UNTIL=19971224T000000Z" - x-summary: "dagligen, till och med den 24 december, 1997 kl. 0:00" - x-set: (list #1997-09-02T09:00:00 - #1997-09-03T09:00:00 - #1997-09-04T09:00:00 - #1997-09-05T09:00:00 - #1997-09-06T09:00:00 - #1997-09-07T09:00:00 - #1997-09-08T09:00:00 - #1997-09-09T09:00:00 - #1997-09-10T09:00:00 - #1997-09-11T09:00:00 - #1997-09-12T09:00:00 - #1997-09-13T09:00:00 - #1997-09-14T09:00:00 - #1997-09-15T09:00:00 - #1997-09-16T09:00:00 - #1997-09-17T09:00:00 - #1997-09-18T09:00:00 - #1997-09-19T09:00:00 - #1997-09-20T09:00:00 - #1997-09-21T09:00:00 - #1997-09-22T09:00:00 - #1997-09-23T09:00:00 - #1997-09-24T09:00:00 - #1997-09-25T09:00:00 - #1997-09-26T09:00:00 - #1997-09-27T09:00:00 - #1997-09-28T09:00:00 - #1997-09-29T09:00:00 - #1997-09-30T09:00:00 - #1997-10-01T09:00:00 - #1997-10-02T09:00:00 - #1997-10-03T09:00:00 - #1997-10-04T09:00:00 - #1997-10-05T09:00:00 - #1997-10-06T09:00:00 - #1997-10-07T09:00:00 - #1997-10-08T09:00:00 - #1997-10-09T09:00:00 - #1997-10-10T09:00:00 - #1997-10-11T09:00:00 - #1997-10-12T09:00:00 - #1997-10-13T09:00:00 - #1997-10-14T09:00:00 - #1997-10-15T09:00:00 - #1997-10-16T09:00:00 - #1997-10-17T09:00:00 - #1997-10-18T09:00:00 - #1997-10-19T09:00:00 - #1997-10-20T09:00:00 - #1997-10-21T09:00:00 - #1997-10-22T09:00:00 - #1997-10-23T09:00:00 - #1997-10-24T09:00:00 - #1997-10-25T09:00:00 - #1997-10-26T09:00:00 - #1997-10-27T09:00:00 - #1997-10-28T09:00:00 - #1997-10-29T09:00:00 - #1997-10-30T09:00:00 - #1997-10-31T09:00:00 - #1997-11-01T09:00:00 - #1997-11-02T09:00:00 - #1997-11-03T09:00:00 - #1997-11-04T09:00:00 - #1997-11-05T09:00:00 - #1997-11-06T09:00:00 - #1997-11-07T09:00:00 - #1997-11-08T09:00:00 - #1997-11-09T09:00:00 - #1997-11-10T09:00:00 - #1997-11-11T09:00:00 - #1997-11-12T09:00:00 - #1997-11-13T09:00:00 - #1997-11-14T09:00:00 - #1997-11-15T09:00:00 - #1997-11-16T09:00:00 - #1997-11-17T09:00:00 - #1997-11-18T09:00:00 - #1997-11-19T09:00:00 - #1997-11-20T09:00:00 - #1997-11-21T09:00:00 - #1997-11-22T09:00:00 - #1997-11-23T09:00:00 - #1997-11-24T09:00:00 - #1997-11-25T09:00:00 - #1997-11-26T09:00:00 - #1997-11-27T09:00:00 - #1997-11-28T09:00:00 - #1997-11-29T09:00:00 - #1997-11-30T09:00:00 - #1997-12-01T09:00:00 - #1997-12-02T09:00:00 - #1997-12-03T09:00:00 - #1997-12-04T09:00:00 - #1997-12-05T09:00:00 - #1997-12-06T09:00:00 - #1997-12-07T09:00:00 - #1997-12-08T09:00:00 - #1997-12-09T09:00:00 - #1997-12-10T09:00:00 - #1997-12-11T09:00:00 - #1997-12-12T09:00:00 - #1997-12-13T09:00:00 - #1997-12-14T09:00:00 - #1997-12-15T09:00:00 - #1997-12-16T09:00:00 - #1997-12-17T09:00:00 - #1997-12-18T09:00:00 - #1997-12-19T09:00:00 - #1997-12-20T09:00:00 - #1997-12-21T09:00:00 - #1997-12-22T09:00:00 - #1997-12-23T09:00:00 - ;; December 24 SHOULD be missing. - )) - - - (vevent - summary: "Every other day - forever" - dtstart: "19970902T090000" - rrule: "FREQ=DAILY;INTERVAL=2" - x-summary: "varannan dag" - x-set: (list #1997-09-02T09:00:00 - #1997-09-04T09:00:00 - #1997-09-06T09:00:00 - #1997-09-08T09:00:00 - #1997-09-10T09:00:00 - #1997-09-12T09:00:00 - #1997-09-14T09:00:00 - #1997-09-16T09:00:00 - #1997-09-18T09:00:00 - #1997-09-20T09:00:00 - #1997-09-22T09:00:00 - #1997-09-24T09:00:00 - #1997-09-26T09:00:00 - #1997-09-28T09:00:00 - #1997-09-30T09:00:00 - #1997-10-02T09:00:00 - #1997-10-04T09:00:00 - #1997-10-06T09:00:00 - #1997-10-08T09:00:00 - #1997-10-10T09:00:00)) - - (vevent - summary: "Every 10 days, 5 occurrences" - dtstart: "19970902T090000" - rrule: "FREQ=DAILY;INTERVAL=10;COUNT=5" - x-summary: "var tionde dag, totalt 5 gånger" - x-set: (list #1997-09-02T09:00:00 - #1997-09-12T09:00:00 - #1997-09-22T09:00:00 - #1997-10-02T09:00:00 - #1997-10-12T09:00:00)) - - (vevent - summary: "Every day in January, for 3 years (alt 1)" - dtstart: "19980101T090000" - rrule: "FREQ=YEARLY;UNTIL=20000131T140000Z;BYMONTH=1;BYDAY=SU,MO,TU,WE,TH,FR,SA" - 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: (list #1998-01-01T09:00:00 - #1998-01-02T09:00:00 - #1998-01-03T09:00:00 - #1998-01-04T09:00:00 - #1998-01-05T09:00:00 - #1998-01-06T09:00:00 - #1998-01-07T09:00:00 - #1998-01-08T09:00:00 - #1998-01-09T09:00:00 - #1998-01-10T09:00:00 - #1998-01-11T09:00:00 - #1998-01-12T09:00:00 - #1998-01-13T09:00:00 - #1998-01-14T09:00:00 - #1998-01-15T09:00:00 - #1998-01-16T09:00:00 - #1998-01-17T09:00:00 - #1998-01-18T09:00:00 - #1998-01-19T09:00:00 - #1998-01-20T09:00:00 - #1998-01-21T09:00:00 - #1998-01-22T09:00:00 - #1998-01-23T09:00:00 - #1998-01-24T09:00:00 - #1998-01-25T09:00:00 - #1998-01-26T09:00:00 - #1998-01-27T09:00:00 - #1998-01-28T09:00:00 - #1998-01-29T09:00:00 - #1998-01-30T09:00:00 - #1998-01-31T09:00:00 - #1999-01-01T09:00:00 - #1999-01-02T09:00:00 - #1999-01-03T09:00:00 - #1999-01-04T09:00:00 - #1999-01-05T09:00:00 - #1999-01-06T09:00:00 - #1999-01-07T09:00:00 - #1999-01-08T09:00:00 - #1999-01-09T09:00:00 - #1999-01-10T09:00:00 - #1999-01-11T09:00:00 - #1999-01-12T09:00:00 - #1999-01-13T09:00:00 - #1999-01-14T09:00:00 - #1999-01-15T09:00:00 - #1999-01-16T09:00:00 - #1999-01-17T09:00:00 - #1999-01-18T09:00:00 - #1999-01-19T09:00:00 - #1999-01-20T09:00:00 - #1999-01-21T09:00:00 - #1999-01-22T09:00:00 - #1999-01-23T09:00:00 - #1999-01-24T09:00:00 - #1999-01-25T09:00:00 - #1999-01-26T09:00:00 - #1999-01-27T09:00:00 - #1999-01-28T09:00:00 - #1999-01-29T09:00:00 - #1999-01-30T09:00:00 - #1999-01-31T09:00:00 - #2000-01-01T09:00:00 - #2000-01-02T09:00:00 - #2000-01-03T09:00:00 - #2000-01-04T09:00:00 - #2000-01-05T09:00:00 - #2000-01-06T09:00:00 - #2000-01-07T09:00:00 - #2000-01-08T09:00:00 - #2000-01-09T09:00:00 - #2000-01-10T09:00:00 - #2000-01-11T09:00:00 - #2000-01-12T09:00:00 - #2000-01-13T09:00:00 - #2000-01-14T09:00:00 - #2000-01-15T09:00:00 - #2000-01-16T09:00:00 - #2000-01-17T09:00:00 - #2000-01-18T09:00:00 - #2000-01-19T09:00:00 - #2000-01-20T09:00:00 - #2000-01-21T09:00:00 - #2000-01-22T09:00:00 - #2000-01-23T09:00:00 - #2000-01-24T09:00:00 - #2000-01-25T09:00:00 - #2000-01-26T09:00:00 - #2000-01-27T09:00:00 - #2000-01-28T09:00:00 - #2000-01-29T09:00:00 - #2000-01-30T09:00:00 - #2000-01-31T09:00:00)) - - (vevent - summary: "Every day in January, for 3 years (alt 2)" - dtstart: "19980101T090000" - rrule: "FREQ=DAILY;UNTIL=20000131T140000Z;BYMONTH=1" - x-summary: "dagligen, till och med den 31 januari, 2000 kl. 14:00" - x-set: (list #1998-01-01T09:00:00 - #1998-01-02T09:00:00 - #1998-01-03T09:00:00 - #1998-01-04T09:00:00 - #1998-01-05T09:00:00 - #1998-01-06T09:00:00 - #1998-01-07T09:00:00 - #1998-01-08T09:00:00 - #1998-01-09T09:00:00 - #1998-01-10T09:00:00 - #1998-01-11T09:00:00 - #1998-01-12T09:00:00 - #1998-01-13T09:00:00 - #1998-01-14T09:00:00 - #1998-01-15T09:00:00 - #1998-01-16T09:00:00 - #1998-01-17T09:00:00 - #1998-01-18T09:00:00 - #1998-01-19T09:00:00 - #1998-01-20T09:00:00 - #1998-01-21T09:00:00 - #1998-01-22T09:00:00 - #1998-01-23T09:00:00 - #1998-01-24T09:00:00 - #1998-01-25T09:00:00 - #1998-01-26T09:00:00 - #1998-01-27T09:00:00 - #1998-01-28T09:00:00 - #1998-01-29T09:00:00 - #1998-01-30T09:00:00 - #1998-01-31T09:00:00 - #1999-01-01T09:00:00 - #1999-01-02T09:00:00 - #1999-01-03T09:00:00 - #1999-01-04T09:00:00 - #1999-01-05T09:00:00 - #1999-01-06T09:00:00 - #1999-01-07T09:00:00 - #1999-01-08T09:00:00 - #1999-01-09T09:00:00 - #1999-01-10T09:00:00 - #1999-01-11T09:00:00 - #1999-01-12T09:00:00 - #1999-01-13T09:00:00 - #1999-01-14T09:00:00 - #1999-01-15T09:00:00 - #1999-01-16T09:00:00 - #1999-01-17T09:00:00 - #1999-01-18T09:00:00 - #1999-01-19T09:00:00 - #1999-01-20T09:00:00 - #1999-01-21T09:00:00 - #1999-01-22T09:00:00 - #1999-01-23T09:00:00 - #1999-01-24T09:00:00 - #1999-01-25T09:00:00 - #1999-01-26T09:00:00 - #1999-01-27T09:00:00 - #1999-01-28T09:00:00 - #1999-01-29T09:00:00 - #1999-01-30T09:00:00 - #1999-01-31T09:00:00 - #2000-01-01T09:00:00 - #2000-01-02T09:00:00 - #2000-01-03T09:00:00 - #2000-01-04T09:00:00 - #2000-01-05T09:00:00 - #2000-01-06T09:00:00 - #2000-01-07T09:00:00 - #2000-01-08T09:00:00 - #2000-01-09T09:00:00 - #2000-01-10T09:00:00 - #2000-01-11T09:00:00 - #2000-01-12T09:00:00 - #2000-01-13T09:00:00 - #2000-01-14T09:00:00 - #2000-01-15T09:00:00 - #2000-01-16T09:00:00 - #2000-01-17T09:00:00 - #2000-01-18T09:00:00 - #2000-01-19T09:00:00 - #2000-01-20T09:00:00 - #2000-01-21T09:00:00 - #2000-01-22T09:00:00 - #2000-01-23T09:00:00 - #2000-01-24T09:00:00 - #2000-01-25T09:00:00 - #2000-01-26T09:00:00 - #2000-01-27T09:00:00 - #2000-01-28T09:00:00 - #2000-01-29T09:00:00 - #2000-01-30T09:00:00 - #2000-01-31T09:00:00)) - - (vevent - summary: "Weekly for 10 occurrences" - dtstart: "19970902T090000" - rrule: "FREQ=WEEKLY;COUNT=10" - x-summary: "varje vecka, totalt 10 gånger" - x-set: (list #1997-09-02T09:00:00 - #1997-09-09T09:00:00 - #1997-09-16T09:00:00 - #1997-09-23T09:00:00 - #1997-09-30T09:00:00 - #1997-10-07T09:00:00 - #1997-10-14T09:00:00 - #1997-10-21T09:00:00 - #1997-10-28T09:00:00 - #1997-11-04T09:00:00)) - - (vevent - summary: "Weekly until December 24, 1997" - dtstart: "19970902T090000" - rrule: "FREQ=WEEKLY;UNTIL=19971224T000000Z" - x-summary: "varje vecka, till och med den 24 december, 1997 kl. 0:00" - x-set: (list #1997-09-02T09:00:00 - #1997-09-09T09:00:00 - #1997-09-16T09:00:00 - #1997-09-23T09:00:00 - #1997-09-30T09:00:00 - #1997-10-07T09:00:00 - #1997-10-14T09:00:00 - #1997-10-21T09:00:00 - #1997-10-28T09:00:00 - #1997-11-04T09:00:00 - #1997-11-11T09:00:00 - #1997-11-18T09:00:00 - #1997-11-25T09:00:00 - #1997-12-02T09:00:00 - #1997-12-09T09:00:00 - #1997-12-16T09:00:00 - #1997-12-23T09:00:00)) - - (vevent - summary: "Every other week - forever" - dtstart: "19970902T090000" - rrule: "FREQ=WEEKLY;INTERVAL=2;WKST=SU" - x-summary: "varannan vecka" - x-set: (list #1997-09-02T09:00:00 - #1997-09-16T09:00:00 - #1997-09-30T09:00:00 - #1997-10-14T09:00:00 - #1997-10-28T09:00:00 - #1997-11-11T09:00:00 - #1997-11-25T09:00:00 - #1997-12-09T09:00:00 - #1997-12-23T09:00:00 - #1998-01-06T09:00:00 - #1998-01-20T09:00:00 - #1998-02-03T09:00:00 - #1998-02-17T09:00:00 - #1998-03-03T09:00:00 - #1998-03-17T09:00:00 - #1998-03-31T09:00:00 - #1998-04-14T09:00:00 - #1998-04-28T09:00:00 - #1998-05-12T09:00:00 - #1998-05-26T09:00:00)) - - (vevent - summary: "Weekly on Tuesday and Thursday for five weeks (alt 1)" - dtstart: "19970902T090000" - rrule: "FREQ=WEEKLY;UNTIL=19971007T000000Z;WKST=SU;BYDAY=TU,TH" - x-summary: "varje tisdag & torsdag, till och med den 07 oktober, 1997 kl. 0:00" - x-set: (list #1997-09-02T09:00:00 - #1997-09-04T09:00:00 - #1997-09-09T09:00:00 - #1997-09-11T09:00:00 - #1997-09-16T09:00:00 - #1997-09-18T09:00:00 - #1997-09-23T09:00:00 - #1997-09-25T09:00:00 - #1997-09-30T09:00:00 - #1997-10-02T09:00:00)) - - (vevent - summary: "Weekly on Tuesday and Thursday for five weeks (alt 2)" - dtstart: "19970902T090000" - rrule: "FREQ=WEEKLY;COUNT=10;WKST=SU;BYDAY=TU,TH" - x-summary: "varje tisdag & torsdag, totalt 10 gånger" - x-set: (list #1997-09-02T09:00:00 - #1997-09-04T09:00:00 - #1997-09-09T09:00:00 - #1997-09-11T09:00:00 - #1997-09-16T09:00:00 - #1997-09-18T09:00:00 - #1997-09-23T09:00:00 - #1997-09-25T09:00:00 - #1997-09-30T09:00:00 - #1997-10-02T09:00:00)) - - (vevent - summary: "Every other week on Monday, Wednesday, and Friday until December 24, 1997, starting on Monday, September 1, 1997:" - dtstart: "19970901T090000" - rrule: "FREQ=WEEKLY;INTERVAL=2;UNTIL=19971224T000000Z;WKST=SU;BYDAY=MO,WE,FR" - x-summary: "varannan måndag, onsdag & fredag, till och med den 24 december, 1997 kl. 0:00" - x-set: (list #1997-09-01T09:00:00 - #1997-09-03T09:00:00 - #1997-09-05T09:00:00 - #1997-09-15T09:00:00 - #1997-09-17T09:00:00 - #1997-09-19T09:00:00 - #1997-09-29T09:00:00 - #1997-10-01T09:00:00 - #1997-10-03T09:00:00 - #1997-10-13T09:00:00 - #1997-10-15T09:00:00 - #1997-10-17T09:00:00 - #1997-10-27T09:00:00 - #1997-10-29T09:00:00 - #1997-10-31T09:00:00 - #1997-11-10T09:00:00 - #1997-11-12T09:00:00 - #1997-11-14T09:00:00 - #1997-11-24T09:00:00 - #1997-11-26T09:00:00 - #1997-11-28T09:00:00 - #1997-12-08T09:00:00 - #1997-12-10T09:00:00 - #1997-12-12T09:00:00 - #1997-12-22T09:00:00)) - - (vevent - summary: "Every other week on Tuesday and Thursday, for 8 occurrences" - dtstart: "19970902T090000" - rrule: "FREQ=WEEKLY;INTERVAL=2;COUNT=8;WKST=SU;BYDAY=TU,TH" - x-summary: "varannan tisdag & torsdag, totalt 8 gånger" - x-set: (list #1997-09-02T09:00:00 - #1997-09-04T09:00:00 - #1997-09-16T09:00:00 - #1997-09-18T09:00:00 - #1997-09-30T09:00:00 - #1997-10-02T09:00:00 - #1997-10-14T09:00:00 - #1997-10-16T09:00:00)) - - (vevent - summary: "Monthly on the first Friday for 10 occurrences" - dtstart: "19970905T090000" - rrule: "FREQ=MONTHLY;COUNT=10;BYDAY=1FR" - x-summary: "första fredagen varje månad, totalt 10 gånger" - x-set: (list #1997-09-05T09:00:00 - #1997-10-03T09:00:00 - #1997-11-07T09:00:00 - #1997-12-05T09:00:00 - #1998-01-02T09:00:00 - #1998-02-06T09:00:00 - #1998-03-06T09:00:00 - #1998-04-03T09:00:00 - #1998-05-01T09:00:00 - #1998-06-05T09:00:00)) - - (vevent - summary: "Monthly on the first Friday until December 24, 1997" - dtstart: "19970905T090000" - rrule: "FREQ=MONTHLY;UNTIL=19971224T000000Z;BYDAY=1FR" - x-summary: "första fredagen varje månad, till och med den 24 december, 1997 kl. 0:00" - x-set: (list #1997-09-05T09:00:00 - #1997-10-03T09:00:00 - #1997-11-07T09:00:00 - #1997-12-05T09:00:00)) - - (vevent - summary: "Every other month on the first and last Sunday of the month for 10 occurrences" - dtstart: "19970907T090000" - rrule: "FREQ=MONTHLY;INTERVAL=2;COUNT=10;BYDAY=1SU,-1SU" - x-summary: "första söndagen samt sista söndagen varannan månad, totalt 10 gånger" - x-set: (list #1997-09-07T09:00:00 - #1997-09-28T09:00:00 - #1997-11-02T09:00:00 - #1997-11-30T09:00:00 - #1998-01-04T09:00:00 - #1998-01-25T09:00:00 - #1998-03-01T09:00:00 - #1998-03-29T09:00:00 - #1998-05-03T09:00:00 - #1998-05-31T09:00:00)) - - (vevent - summary: "Monthly on the second-to-last Monday of the month for 6 months" - dtstart: "19970922T090000" - rrule: "FREQ=MONTHLY;COUNT=6;BYDAY=-2MO" - x-summary: "näst sista måndagen varje månad, totalt 6 gånger" - x-set: (list #1997-09-22T09:00:00 - #1997-10-20T09:00:00 - #1997-11-17T09:00:00 - #1997-12-22T09:00:00 - #1998-01-19T09:00:00 - #1998-02-16T09:00:00)) - - (vevent - summary: "Monthly on the third-to-the-last day of the month, forever" - dtstart: "19970928T090000" - rrule: "FREQ=MONTHLY;BYMONTHDAY=-3" - x-summary: "den tredje sista varje månad" - x-set: (list #1997-09-28T09:00:00 - #1997-10-29T09:00:00 - #1997-11-28T09:00:00 - #1997-12-29T09:00:00 - #1998-01-29T09:00:00 - #1998-02-26T09:00:00 - #1998-03-29T09:00:00 - #1998-04-28T09:00:00 - #1998-05-29T09:00:00 - #1998-06-28T09:00:00 - #1998-07-29T09:00:00 - #1998-08-29T09:00:00 - #1998-09-28T09:00:00 - #1998-10-29T09:00:00 - #1998-11-28T09:00:00 - #1998-12-29T09:00:00 - #1999-01-29T09:00:00 - #1999-02-26T09:00:00 - #1999-03-29T09:00:00 - #1999-04-28T09:00:00)) - - (vevent - summary: "Monthly on the 2nd and 15th of the month for 10 occurrences" - dtstart: "19970902T090000" - rrule: "FREQ=MONTHLY;COUNT=10;BYMONTHDAY=2,15" - x-summary: "den andre & femtonde varje månad, totalt 10 gånger" - x-set: (list #1997-09-02T09:00:00 - #1997-09-15T09:00:00 - #1997-10-02T09:00:00 - #1997-10-15T09:00:00 - #1997-11-02T09:00:00 - #1997-11-15T09:00:00 - #1997-12-02T09:00:00 - #1997-12-15T09:00:00 - #1998-01-02T09:00:00 - #1998-01-15T09:00:00)) - - (vevent - summary: "Monthly on the first and last day of the month for 10 occurrences" - dtstart: "19970930T090000" - rrule: "FREQ=MONTHLY;COUNT=10;BYMONTHDAY=1,-1" - x-summary: "den förste & sista varje månad, totalt 10 gånger" - x-set: (list #1997-09-30T09:00:00 - #1997-10-01T09:00:00 - #1997-10-31T09:00:00 - #1997-11-01T09:00:00 - #1997-11-30T09:00:00 - #1997-12-01T09:00:00 - #1997-12-31T09:00:00 - #1998-01-01T09:00:00 - #1998-01-31T09:00:00 - #1998-03-01T09:00:00)) - - (vevent - summary: "Every 18 months on the 10th thru 15th of the month for 10 occurrences" - dtstart: "19970910T090000" - rrule: "FREQ=MONTHLY;INTERVAL=18;COUNT=10;BYMONTHDAY=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: (list #1997-09-10T09:00:00 - #1997-09-11T09:00:00 - #1997-09-12T09:00:00 - #1997-09-13T09:00:00 - #1997-09-14T09:00:00 - #1997-09-15T09:00:00 - #1999-03-10T09:00:00 - #1999-03-11T09:00:00 - #1999-03-12T09:00:00 - #1999-03-13T09:00:00)) - - (vevent - summary: "Every Tuesday, every other month" - dtstart: "19970902T090000" - rrule: "FREQ=MONTHLY;INTERVAL=2;BYDAY=TU" - x-summary: "varje tisdag varannan månad" - x-set: (list #1997-09-02T09:00:00 - #1997-09-09T09:00:00 - #1997-09-16T09:00:00 - #1997-09-23T09:00:00 - #1997-09-30T09:00:00 - #1997-11-04T09:00:00 - #1997-11-11T09:00:00 - #1997-11-18T09:00:00 - #1997-11-25T09:00:00 - #1998-01-06T09:00:00 - #1998-01-13T09:00:00 - #1998-01-20T09:00:00 - #1998-01-27T09:00:00 - #1998-03-03T09:00:00 - #1998-03-10T09:00:00 - #1998-03-17T09:00:00 - #1998-03-24T09:00:00 - #1998-03-31T09:00:00 - #1998-05-05T09:00:00 - #1998-05-12T09:00:00)) - - (vevent - summary: "Yearly in June and July for 10 occurrences: -: Since none of the BYDAY, BYMONTHDAY, or BYYEARDAY -onents are specified, the day is gotten from \"DTSTART\"" - dtstart: "19970610T090000" - rrule: "FREQ=YEARLY;COUNT=10;BYMONTH=6,7" - x-summary: "juni & juli, årligen, totalt 10 gånger" - x-set: (list #1997-06-10T09:00:00 - #1997-07-10T09:00:00 - #1998-06-10T09:00:00 - #1998-07-10T09:00:00 - #1999-06-10T09:00:00 - #1999-07-10T09:00:00 - #2000-06-10T09:00:00 - #2000-07-10T09:00:00 - #2001-06-10T09:00:00 - #2001-07-10T09:00:00)) - - (vevent - summary: "Every other year on January, February, and March for 10 occurrences" - dtstart: "19970310T090000" - rrule: "FREQ=YEARLY;INTERVAL=2;COUNT=10;BYMONTH=1,2,3" - x-summary: "januari, februari & mars vartannat år, totalt 10 gånger" - x-set: (list #1997-03-10T09:00:00 - #1999-01-10T09:00:00 - #1999-02-10T09:00:00 - #1999-03-10T09:00:00 - #2001-01-10T09:00:00 - #2001-02-10T09:00:00 - #2001-03-10T09:00:00 - #2003-01-10T09:00:00 - #2003-02-10T09:00:00 - #2003-03-10T09:00:00)) - - (vevent - summary: "Every third year on the 1st, 100th, and 200th day for 10 occurrences" - dtstart: "19970101T090000" - rrule: "FREQ=YEARLY;INTERVAL=3;COUNT=10;BYYEARDAY=1,100,200" - x-summary: "dag 1, 100 & 200 vart tredje år, totalt 10 gånger" - x-set: (list #1997-01-01T09:00:00 - #1997-04-10T09:00:00 - #1997-07-19T09:00:00 - #2000-01-01T09:00:00 - #2000-04-09T09:00:00 - #2000-07-18T09:00:00 - #2003-01-01T09:00:00 - #2003-04-10T09:00:00 - #2003-07-19T09:00:00 - #2006-01-01T09:00:00)) - - (vevent - summary: "Every 20th Monday of the year, forever" - dtstart: "19970519T090000" - rrule: "FREQ=YEARLY;BYDAY=20MO" - x-summary: "tjugonde måndagen, årligen" - x-set: (list #1997-05-19T09:00:00 - #1998-05-18T09:00:00 - #1999-05-17T09:00:00 - #2000-05-15T09:00:00 - #2001-05-14T09:00:00 - #2002-05-20T09:00:00 - #2003-05-19T09:00:00 - #2004-05-17T09:00:00 - #2005-05-16T09:00:00 - #2006-05-15T09:00:00 - #2007-05-14T09:00:00 - #2008-05-19T09:00:00 - #2009-05-18T09:00:00 - #2010-05-17T09:00:00 - #2011-05-16T09:00:00 - #2012-05-14T09:00:00 - #2013-05-20T09:00:00 - #2014-05-19T09:00:00 - #2015-05-18T09:00:00 - #2016-05-16T09:00:00)) - - (vevent - summary: "Monday of week number 20 (where the default start of the week is Monday), forever" - dtstart: "19970512T090000" - rrule: "FREQ=YEARLY;BYWEEKNO=20;BYDAY=MO" - x-summary: "varje måndag v.20, årligen" - x-set: (list #1997-05-12T09:00:00 - #1998-05-11T09:00:00 - #1999-05-17T09:00:00 - #2000-05-15T09:00:00 - #2001-05-14T09:00:00 - #2002-05-13T09:00:00 - #2003-05-12T09:00:00 - #2004-05-10T09:00:00 - #2005-05-16T09:00:00 - #2006-05-15T09:00:00 - #2007-05-14T09:00:00 - #2008-05-12T09:00:00 - #2009-05-11T09:00:00 - #2010-05-17T09:00:00 - #2011-05-16T09:00:00 - #2012-05-14T09:00:00 - #2013-05-13T09:00:00 - #2014-05-12T09:00:00 - #2015-05-11T09:00:00 - #2016-05-16T09:00:00)) - - (vevent - summary: "Every Thursday in March, forever" - dtstart: "19970313T090000" - rrule: "FREQ=YEARLY;BYMONTH=3;BYDAY=TH" - x-summary: "varje torsdag i mars, årligen" - x-set: (list #1997-03-13T09:00:00 - #1997-03-20T09:00:00 - #1997-03-27T09:00:00 - #1998-03-05T09:00:00 - #1998-03-12T09:00:00 - #1998-03-19T09:00:00 - #1998-03-26T09:00:00 - #1999-03-04T09:00:00 - #1999-03-11T09:00:00 - #1999-03-18T09:00:00 - #1999-03-25T09:00:00 - #2000-03-02T09:00:00 - #2000-03-09T09:00:00 - #2000-03-16T09:00:00 - #2000-03-23T09:00:00 - #2000-03-30T09:00:00 - #2001-03-01T09:00:00 - #2001-03-08T09:00:00 - #2001-03-15T09:00:00 - #2001-03-22T09:00:00)) - - (vevent - summary: "Every Thursday, but only during June, July, and August, forever" - dtstart: "19970605T090000" - rrule: "FREQ=YEARLY;BYDAY=TH;BYMONTH=6,7,8" - x-summary: "varje torsdag i juni, juli & augusti, årligen" - x-set: (list #1997-06-05T09:00:00 - #1997-06-12T09:00:00 - #1997-06-19T09:00:00 - #1997-06-26T09:00:00 - #1997-07-03T09:00:00 - #1997-07-10T09:00:00 - #1997-07-17T09:00:00 - #1997-07-24T09:00:00 - #1997-07-31T09:00:00 - #1997-08-07T09:00:00 - #1997-08-14T09:00:00 - #1997-08-21T09:00:00 - #1997-08-28T09:00:00 - #1998-06-04T09:00:00 - #1998-06-11T09:00:00 - #1998-06-18T09:00:00 - #1998-06-25T09:00:00 - #1998-07-02T09:00:00 - #1998-07-09T09:00:00 - #1998-07-16T09:00:00)) - - (vevent - summary: "Every Friday the 13th, forever" - dtstart: "19970902T090000" - exdate: "19970902T090000" - rrule: "FREQ=MONTHLY;BYDAY=FR;BYMONTHDAY=13" - x-summary: "varje fredag den trettonde varje månad" - x-set: (list #1998-02-13T09:00:00 - #1998-03-13T09:00:00 - #1998-11-13T09:00:00 - #1999-08-13T09:00:00 - #2000-10-13T09:00:00 - #2001-04-13T09:00:00 - #2001-07-13T09:00:00 - #2002-09-13T09:00:00 - #2002-12-13T09:00:00 - #2003-06-13T09:00:00 - #2004-02-13T09:00:00 - #2004-08-13T09:00:00 - #2005-05-13T09:00:00 - #2006-01-13T09:00:00 - #2006-10-13T09:00:00 - #2007-04-13T09:00:00 - #2007-07-13T09:00:00 - #2008-06-13T09:00:00 - #2009-02-13T09:00:00 - #2009-03-13T09:00:00)) - - (vevent - summary: "The first Saturday that follows the first Sunday of the month, forever" - dtstart: "19970913T090000" - rrule: "FREQ=MONTHLY;BYDAY=SA;BYMONTHDAY=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: (list #1997-09-13T09:00:00 - #1997-10-11T09:00:00 - #1997-11-08T09:00:00 - #1997-12-13T09:00:00 - #1998-01-10T09:00:00 - #1998-02-07T09:00:00 - #1998-03-07T09:00:00 - #1998-04-11T09:00:00 - #1998-05-09T09:00:00 - #1998-06-13T09:00:00 - #1998-07-11T09:00:00 - #1998-08-08T09:00:00 - #1998-09-12T09:00:00 - #1998-10-10T09:00:00 - #1998-11-07T09:00:00 - #1998-12-12T09:00:00 - #1999-01-09T09:00:00 - #1999-02-13T09:00:00 - #1999-03-13T09:00:00 - #1999-04-10T09:00:00)) - - (vevent - summary: - "Every 4 years, the first Tuesday after a Monday in November, -ver (U.S. Presidential Election day)" - dtstart: "19961105T090000" - rrule: "FREQ=YEARLY;INTERVAL=4;BYMONTH=11;BYDAY=TU;BYMONTHDAY=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: (list #1996-11-05T09:00:00 - #2000-11-07T09:00:00 - #2004-11-02T09:00:00 - #2008-11-04T09:00:00 - #2012-11-06T09:00:00 - #2016-11-08T09:00:00 - #2020-11-03T09:00:00 - #2024-11-05T09:00:00 - #2028-11-07T09:00:00 - #2032-11-02T09:00:00 - #2036-11-04T09:00:00 - #2040-11-06T09:00:00 - #2044-11-08T09:00:00 - #2048-11-03T09:00:00 - #2052-11-05T09:00:00 - #2056-11-07T09:00:00 - #2060-11-02T09:00:00 - #2064-11-04T09:00:00 - #2068-11-06T09:00:00 - #2072-11-08T09:00:00)) - - (vevent - summary: "The third instance into the month of one of Tuesday, Wednesday, or -Thursday, for the next 3 months" - dtstart: "19970904T090000" - rrule: "FREQ=MONTHLY;COUNT=3;BYDAY=TU,WE,TH;BYSETPOS=3" - x-summary: "NOT YET IMPLEMENTED" - x-set: (list #1997-09-04T09:00:00 - #1997-10-07T09:00:00 - #1997-11-06T09:00:00)) - - (vevent - summary: "The second-to-last weekday of the month NOTE WILL FAIL DUE TO FEW EXAMPLES" - dtstart: "19970929T090000" - rrule: "FREQ=MONTHLY;BYDAY=MO,TU,WE,TH,FR;BYSETPOS=-2" - x-summary: "NOT YET IMPLEMENTED" - x-set: (list #1997-09-29T09:00:00 - #1997-10-30T09:00:00 - #1997-11-27T09:00:00 - #1997-12-30T09:00:00 - #1998-01-29T09:00:00)) - - (vevent - summary: "Every 3 hours from 9:00 AM to 5:00 PM on a specific day" - dtstart: "19970902T090000" - rrule: "FREQ=HOURLY;INTERVAL=3;UNTIL=19970902T170000Z" - x-summary: "var tredje timme, till och med den 02 september, 1997 kl. 17:00" - x-set: (list #1997-09-02T09:00:00 - #1997-09-02T12:00:00 - #1997-09-02T15:00:00)) - - (vevent - summary: "Every 15 minutes for 6 occurrences" - dtstart: "19970902T090000" - rrule: "FREQ=MINUTELY;INTERVAL=15;COUNT=6" - x-summary: "varje kvart, totalt 6 gånger" - x-set: (list #1997-09-02T09:00:00 - #1997-09-02T09:15:00 - #1997-09-02T09:30:00 - #1997-09-02T09:45:00 - #1997-09-02T10:00:00 - #1997-09-02T10:15:00)) - - (vevent - summary: "Every hour and a half for 4 occurrences" - dtstart: "19970902T090000" - rrule: "FREQ=MINUTELY;INTERVAL=90;COUNT=4" - x-summary: "var sjätte kvart, totalt 4 gånger" - x-set: (list #1997-09-02T09:00:00 - #1997-09-02T10:30:00 - #1997-09-02T12:00:00 - #1997-09-02T13:30:00)) - - (vevent - summary: "Every 20 minutes from 9:00 AM to 4:40 PM every day (alt 1)" - dtstart: "19970902T090000" - rrule: "FREQ=DAILY;BYHOUR=9,10,11,12,13,14,15,16;BYMINUTE=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: (list #1997-09-02T09:00:00 - #1997-09-02T09:20:00 - #1997-09-02T09:40:00 - #1997-09-02T10:00:00 - #1997-09-02T10:20:00 - #1997-09-02T10:40:00 - #1997-09-02T11:00:00 - #1997-09-02T11:20:00 - #1997-09-02T11:40:00 - #1997-09-02T12:00:00 - #1997-09-02T12:20:00 - #1997-09-02T12:40:00 - #1997-09-02T13:00:00 - #1997-09-02T13:20:00 - #1997-09-02T13:40:00 - #1997-09-02T14:00:00 - #1997-09-02T14:20:00 - #1997-09-02T14:40:00 - #1997-09-02T15:00:00 - #1997-09-02T15:20:00)) - - (vevent - summary: "Every 20 minutes from 9:00 AM to 4:40 PM every day (alt 2)" - dtstart: "19970902T090000" - rrule: "FREQ=MINUTELY;INTERVAL=20;BYHOUR=9,10,11,12,13,14,15,16" - x-summary: "var tjugonde minut kl. 9, 10, 11, 12, 13, 14, 15 & 16" - x-set: (list #1997-09-02T09:00:00 - #1997-09-02T09:20:00 - #1997-09-02T09:40:00 - #1997-09-02T10:00:00 - #1997-09-02T10:20:00 - #1997-09-02T10:40:00 - #1997-09-02T11:00:00 - #1997-09-02T11:20:00 - #1997-09-02T11:40:00 - #1997-09-02T12:00:00 - #1997-09-02T12:20:00 - #1997-09-02T12:40:00 - #1997-09-02T13:00:00 - #1997-09-02T13:20:00 - #1997-09-02T13:40:00 - #1997-09-02T14:00:00 - #1997-09-02T14:20:00 - #1997-09-02T14:40:00 - #1997-09-02T15:00:00 - #1997-09-02T15:20:00)) - - (vevent - summary: "An example where the days generated makes a difference because of WKST" - dtstart: "19970805T090000" - rrule: "FREQ=WEEKLY;INTERVAL=2;COUNT=4;BYDAY=TU,SU;WKST=MO" - x-summary: "varannan tisdag & söndag, totalt 4 gånger" - x-set: (list #1997-08-05T09:00:00 - #1997-08-10T09:00:00 - #1997-08-19T09:00:00 - #1997-08-24T09:00:00)) - - (vevent - summary: "changing only WKST from MO to SU, yields different results.." - dtstart: "19970805T090000" - rrule: "FREQ=WEEKLY;INTERVAL=2;COUNT=4;BYDAY=TU,SU;WKST=SU" - x-summary: "varannan tisdag & söndag, totalt 4 gånger" - x-set: (list #1997-08-05T09:00:00 - #1997-08-17T09:00:00 - #1997-08-19T09:00:00 - #1997-08-31T09:00:00)) - - (vevent - summary: "An example where an invalid date (i.e., February 30) is ignored" - dtstart: "20070115T090000" - rrule: "FREQ=MONTHLY;BYMONTHDAY=15,30;COUNT=5" - x-summary: "den femtonde & tretionde varje månad, totalt 5 gånger" - x-set: (list #2007-01-15T09:00:00 - #2007-01-30T09:00:00 - #2007-02-15T09:00:00 - #2007-03-15T09:00:00 - #2007-03-30T09:00:00)) - - - - ;; End of examples from RFC, start of own examples - - (vevent - summary: "Every Friday & Wednesday the 13th, forever" - dtstart: "19970902T090000" - exdate: "19970902T090000" - rrule: "FREQ=MONTHLY;BYDAY=FR,WE;BYMONTHDAY=13" - x-summary: "varje onsdag & fredag den trettonde varje månad" - x-set: (list #1998-02-13T09:00:00 - #1998-03-13T09:00:00 - #1998-05-13T09:00:00 - #1998-11-13T09:00:00 - #1999-01-13T09:00:00 - #1999-08-13T09:00:00 - #1999-10-13T09:00:00 - #2000-09-13T09:00:00 - #2000-10-13T09:00:00 - #2000-12-13T09:00:00 - #2001-04-13T09:00:00 - #2001-06-13T09:00:00 - #2001-07-13T09:00:00 - #2002-02-13T09:00:00 - #2002-03-13T09:00:00 - #2002-09-13T09:00:00 - #2002-11-13T09:00:00 - #2002-12-13T09:00:00 - #2003-06-13T09:00:00 - #2003-08-13T09:00:00)) - - (vevent - summary: "Monday & Wednesday of week number 20 (where the default start of the week is Monday), forever" - dtstart: "19970512T090000" - rrule: "FREQ=YEARLY;BYWEEKNO=20;BYDAY=MO,WE" - x-summary: "varje onsdag & måndag v.20, årligen" - x-set: (list #1997-05-12T09:00:00 - #1997-05-14T09:00:00 - #1998-05-11T09:00:00 - #1998-05-13T09:00:00 - #1999-05-17T09:00:00 - #1999-05-19T09:00:00 - #2000-05-15T09:00:00 - #2000-05-17T09:00:00 - #2001-05-14T09:00:00 - #2001-05-16T09:00:00 - #2002-05-13T09:00:00 - #2002-05-15T09:00:00 - #2003-05-12T09:00:00 - #2003-05-14T09:00:00 - #2004-05-10T09:00:00 - #2004-05-12T09:00:00 - #2005-05-16T09:00:00 - #2005-05-18T09:00:00 - #2006-05-15T09:00:00 - #2006-05-17T09:00:00)))) diff --git a/tests/rrule-serialization.scm b/tests/rrule-serialization.scm deleted file mode 100644 index 53365661..00000000 --- a/tests/rrule-serialization.scm +++ /dev/null @@ -1,76 +0,0 @@ -( - ;; Yes, this is ugly. But how else would I test a private procedure? - ((guile) @@) - - ((vcomponent recurrence internal) - recur-rule->rrule-string - recur-rule->rrule-sxml - byday - ) - - ((vcomponent recurrence parse) parse-recurrence-rule) - - ((ice-9 peg) - keyword-flatten - ) - ) - - -(test-equal - "Parse of week day" - '(#f . 3) - ((@@ (vcomponent recurrence parse) parse-day-spec) "WE")) - -(test-equal - "Parse of week day with positive offset" - '(1 . 3) - ((@@ (vcomponent recurrence parse) parse-day-spec) "1WE")) - -(test-equal - "Parse of week day with positive offset (and plus)" - '(2 . 3) - ((@@ (vcomponent recurrence parse) parse-day-spec) "+2WE")) - -(test-equal - "Parse of week day with negative offset" - '(-3 . 3) - ((@@ (vcomponent recurrence parse) parse-day-spec) "-3WE")) - - -;; numeric prefixes in the BYDAY list is only valid when -;; FREQ={MONTHLY,YEARLY}, but that should be handled in a -;; later stage since we are just testing the parser here. -;; (p. 41) - - -(define field->string - (@@ (vcomponent recurrence internal) field->string)) - - -(let ((rule (parse-recurrence-rule "BYDAY=MO,TU,WE"))) - (test-equal "Direct return of parsed value" - "MO,TU,WE" - (field->string 'byday (byday rule))) - - (test-equal "Direct return, but as SXML" - '((byday "MO") - (byday "TU") - (byday "WE")) - (filter (lambda (pair) - (eq? 'byday (car pair))) - (keyword-flatten '(interval byday wkst) - (recur-rule->rrule-sxml rule))))) - -(let ((rule (parse-recurrence-rule "BYDAY=+1MO,1TU,-2FR"))) - (test-equal "Direct return of parsed value" - "1MO,1TU,-2FR" - (field->string 'byday (byday rule))) - - (test-equal "Direct return, but as SXML" - '((byday "1MO") - (byday "1TU") - (byday "-2FR")) - (filter (lambda (pair) - (eq? 'byday (car pair))) - (keyword-flatten '(interval byday wkst) - (recur-rule->rrule-sxml rule))))) diff --git a/tests/run-tests.scm b/tests/run-tests.scm index 9271fc55..968100fd 100755 --- a/tests/run-tests.scm +++ b/tests/run-tests.scm @@ -1,143 +1,191 @@ -#!/usr/bin/guile \ ---debug -s +#!/usr/bin/bash +# -*- mode: scheme; geiser-scheme-implementation: guile -*- + +here=$(dirname $(realpath $0)) + +. "$(dirname "$here")/env" + +if [ "$DEBUG" = '' ]; then + exec $GUILE -s "$0" "$@" +else + exec $GUILE --debug -s "$0" "$@" +fi !# -;;; Commentary: -;; Not a test, but a script that runs tests. -;; Assumes that all other .scm files in this directory are test files, -;; and should thereby follow the test-file syntax. -;; Note that the --debug flag in the (extended) shebang is REQUIRED, -;; otherwise the coverage tests do nothing. -;; -;; Each test runs in its own sandbox. This is however only to protect -;; the modules from each other, and to prevent polution of the global -;; namespace. The system IS NOT protected from the modules. -;; -;; Each test file is required to start with an s-expression on the -;; form: -;; @lisp -;; ((library binding ...) ...) -;; @end lisp -;; Which details exactly which modules should be imported. The format -;; is the same as make-sandbox-module. For example: -;; @example -;; (((c lex) lex) -;; ((c parse) parse-lexeme-tree)) -;; @end example -;; pulls in the @code{lex} procedure from @code{(c lex)}, and -;; @code{parse-lexeme-tree} from @code{(c parse)}. -;; Remaining forms in the file can be any valid scheme expression. -;; @code{define}s are allowed, but only where they would be allowed -;; inside a let form in general code (so only at the start for Guile -;; 2.2, anywhere for Guile 3.0). -;;; Code: - -(eval-when (compile load) - (define here (dirname (current-filename)))) - -(format #t "current filename = ~a~%" here) - - -(add-to-load-path (format #f "~a/module" - (dirname here))) - -(use-modules (ice-9 ftw) - (ice-9 sandbox) +(format #t "current-filename = ~s~%" (current-filename)) + +(define here (dirname (current-filename))) + +(use-modules (srfi srfi-1) + (srfi srfi-64) + (srfi srfi-88) + (hnh util) + (hnh util path) + (ice-9 ftw) + (ice-9 format) (ice-9 getopt-long) - (srfi srfi-64) ; test suite - (srfi srfi-88) ; suffix keywords (system vm coverage) - ((hnh util) :select (for awhen)) - ;; datetime introduces the reader extensions for datetimes, - ;; which leaks into the sandboxes below. - (datetime)) - -(define files - (scandir here - (lambda (name) - (and (< 2 (string-length name)) - (not (string=? name (basename (current-filename)))) - (string=? "scm" (string-take-right name 3)))))) + ) + + + + +(define (µs x) + (* x #e1e6)) + +(define (transform-time-of-day tod) + (+ (* (µs 1) (car tod)) + (cdr tod))) + +(define verbose? (make-parameter #f)) + +(define (construct-test-runner) + (define runner (test-runner-null)) + ;; 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) + (case (test-result-kind runner) + ((pass) (display "\x1b[0;32mX\x1b[m")) + ((fail) (newline) (display "\x1b[0;31mE\x1b[m")) + ((xpass) (display "\x1b[0;33mX\x1b[m")) + ((xfail) (display "\x1b[0;33mE\x1b[m")) + ((skip) (display "\x1B[0;33m-\x1b[m"))) + (when (or (verbose?) (eq? 'fail (test-result-kind))) + (format #t " ~a~%" (test-runner-test-name runner))) + (when (eq? 'fail (test-result-kind)) + (cond ((test-result-ref runner 'actual-error) + => (lambda (err) (format #t "Error: ~s~%" err))) + (else + (format #t "Expected: ~s~%Received: ~s~%" + (test-result-ref runner 'expected-value "[UNKNOWN]") + (test-result-ref runner 'actual-value "[UNKNOWN]")))) + (format #t "Near ~a:~a~%~y" + (test-result-ref runner 'source-file) + (test-result-ref runner 'source-line) + (test-result-ref runner 'source-form))) + + (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) + (format #t "~a ~a ~a~%" + (make-string 10 #\=) + name + (make-string 10 #\=)))) + (test-runner-on-group-end! runner + (lambda (runner) (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) + + + +(define (rework-coverage data) + (define-values (module-files module-names) + ((@ (all-modules) all-modules-under-directory) + (path-append (dirname here) "module"))) + + (define to-drop + (1+ (length + (take-while (lambda (p) (not (string=? p "module"))) + (path-split (car module-files)))))) + + (define (drop-components path-list) + (drop path-list to-drop)) + + (define target-ht (make-hash-table)) + (define source-ht ((@@ (system vm coverage) data-file->line-counts) data)) + (for-each (lambda (path) + (cond ((hash-ref source-ht path #f) + => (lambda (value) (hash-set! target-ht path value))))) + (map (compose path-join drop-components path-split) module-files)) + + ((@@ (system vm coverage) %make-coverage-data) + ((@@ (system vm coverage) data-ip-counts) data) + ((@@ (system vm coverage) data-sources) data) + ((@@ (system vm coverage) data-file->procedures) data) + target-ht)) + + + + +(define option-spec + '((skip (value #t)) + (only (value #t)) + (verbose (single-char #\v)) + (coverage (value optional)))) +(define options (getopt-long (command-line) option-spec)) +(define coverage-dest (option-ref options 'coverage #f)) -;; Load tests +(when (option-ref options 'verbose #f) + (verbose? #t)) -(define (read-multiple) - (let loop ((done '())) - (let ((sexp (read))) - (if (eof-object? sexp) - (reverse done) - (loop (cons sexp done)))))) + +(define dir (path-append here "test")) -(define options - '((skip (value #t)) - (only (value #t)))) +(define (file-extension? ext) + (lambda (filename) + (and (<= (string-length ext) (string-length filename)) + (string=? (string-append "." ext) + (string-take-right + filename (1+ (string-length ext))))))) -(define opts (getopt-long (command-line) options)) -(define to-skip (call-with-input-string (option-ref opts 'skip "") - read)) -(define only (option-ref opts 'only #f)) +(define files (map (lambda (p) (path-append dir p)) + (scandir dir (lambda (fname) + (and ((file-extension? "scm") fname) + (not (char=? #\. (string-ref fname 0)))))))) -(when only (set! files (list only))) +;; (format #t "Running on:~%~y~%" files) -(when (list? to-skip) - (for skip in to-skip - (test-skip skip))) +(awhen (option-ref options 'only #f) + (set! files (list (path-append "test" it)))) -;; NOTE test-group fails if called before any test begin, since -;; (test-runner-current) needs to be a test-runner (dead or not), -;; but is initially bound to #f. -(test-begin "tests") +(awhen (option-ref options 'skip #f) + (set! files (delete it files))) -;; Forces all warnings to be explicitly handled by tests ((@ (hnh util exceptions) warnings-are-errors) #t) -(define (run-with-coverage) - (with-code-coverage - (lambda () - (for fname in files - (format (current-error-port) "Running test ~a~%" fname) - (test-group - fname - (with-throw-handler #t - (lambda () - (with-input-from-file (string-append here "/" fname) - (lambda () - (let ((modules (read)) - (forms (read-multiple))) - (eval-in-sandbox - `(begin ,@forms) - #:time-limit 60 ; larger than should be needed - #:allocation-limit #e10e8 - #:module (make-sandbox-module - (append modules - '(((srfi srfi-64) test-assert - test-equal test-error - test-eqv test-eq - test-approximate) - ((ice-9 ports) call-with-input-string) - ((guile) make-struct/no-tail) - ) - all-pure-bindings))) - (list fname modules forms))))) - (lambda (err . args) - (case err - ((misc-error) - (display-error #f (current-error-port) - (car args) - (cadr args) - (caddr args) - #f)) - (else - (format (current-error-port) - "Test unexpectedly crashed: ~a~%" args))) ))))))) - -(call-with-values run-with-coverage - (lambda (data _) - (call-with-output-file "lcov.info" - (lambda (port) (coverage-data->lcov data port))))) - -(test-end "tests") +(define finalizer + (if coverage-dest + (lambda (thunk) + (define-values (coverage _) (with-code-coverage thunk)) + (add-to-load-path (path-append (dirname here) "scripts")) + + (let ((limited-coverage (rework-coverage coverage))) + (call-with-output-file coverage-dest + (lambda (port) (coverage-data->lcov limited-coverage port)))) + + (format #t "Wrote coverage data to ~a~%" coverage-dest)) + (lambda (thunk) (thunk)) + )) + +(test-begin "suite") +(finalizer (lambda () (for-each (lambda (f) (test-group f (load f))) files))) +(test-end "suite") + +(newline) diff --git a/tests/termios.scm b/tests/termios.scm deleted file mode 100644 index e54ddc9c..00000000 --- a/tests/termios.scm +++ /dev/null @@ -1,37 +0,0 @@ -;;; Commentary: -;; Tests that my termios function works, at least somewhat. -;; Note that this actually modifies the terminal it's run on, and might fail -;; if the terminal doesn't support the wanted modes. See termios(3). -;; It might also leave the terminal in a broken state if exited prematurely. -;;; Code: - -(((hnh util) set!) - ((vulgar termios) - make-termios copy-termios - lflag - tcgetattr! tcsetattr! - ECHO ICANON) - ((srfi srfi-60) - (bitwise-ior . ||) - (bitwise-not . ~) - (bitwise-and . &)) - ((guile) open-input-file)) - -(define tty (open-input-file "/dev/tty")) - -(define-syntax-rule (&= lvalue val) - (set! lvalue = ((lambda (v) (& v val))))) - -(define t (make-termios)) - -(test-equal 0 (tcgetattr! t tty)) -(define ifl (lflag t)) - -(define copy (copy-termios t)) - -#!curly-infix { (lflag t) &= (~ (|| ECHO ICANON)) } - -(test-equal 0 (tcsetattr! t tty)) -(test-equal (& ifl (~ (|| ECHO ICANON))) - (lflag t)) -(test-equal 0 (tcsetattr! copy tty)) diff --git a/tests/test/add-and-save.scm b/tests/test/add-and-save.scm new file mode 100644 index 00000000..19e6c007 --- /dev/null +++ b/tests/test/add-and-save.scm @@ -0,0 +1,104 @@ +(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))) + +(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" + 2 (length (children calendar))) diff --git a/tests/test/annoying-events.scm b/tests/test/annoying-events.scm new file mode 100644 index 00000000..4570a5a6 --- /dev/null +++ b/tests/test/annoying-events.scm @@ -0,0 +1,75 @@ +(define-module (test annoying-events) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module ((srfi srfi-41 util) + :select (filter-sorted-stream)) + :use-module ((srfi srfi-41) + :select (stream + stream->list + stream-filter + stream-take-while)) + :use-module ((vcomponent base) + :select (extract prop make-vcomponent)) + :use-module ((vcomponent datetime) :select (event-overlaps?)) + :use-module ((datetime) :select (date date+ date<)) + :use-module ((hnh util) :select (set!))) + +(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 end (date+ start (date day: 8))) + +(define ev-set + (stream + (event ; should be part of the result + summary: "A" + dtstart: #2021-10-01 + dtend: #2021-12-01) + (event ; 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 + summary: "C" + dtstart: #2021-11-02 + dtend: #2021-11-03))) + +;; (if (and (date< (prop ev 'DTSTART) start-date) +;; (date<= (prop ev 'DTEND) end-date)) +;; ;; event will be picked, but next event might have +;; (and (date< start-date (prop ev 'DTSTART)) +;; (date< end-date (prop ev 'DTEND))) +;; ;; meaning that it wont be added, stopping filter-sorted-stream +;; ) + +;; The naïve way to get all events in an interval. Misses C due to B being "in the way" + +(test-equal "incorrect handling of non-contigious" + '("A" #; "C") + (map (extract 'SUMMARY) + (stream->list + (filter-sorted-stream + (lambda (ev) (event-overlaps? ev start (date+ start (date day: 8)))) + ev-set)))) + +(test-equal "correct handling of non-contigious" + '("A" "C") + (map (extract 'SUMMARY) + (stream->list + (stream-filter + (lambda (ev) (event-overlaps? ev start end)) + (stream-take-while + (lambda (ev) (date< (prop ev 'DTSTART) end)) + ev-set))))) + + diff --git a/tests/base64.scm b/tests/test/base64.scm index 59a8784c..788e7093 100644 --- a/tests/base64.scm +++ b/tests/test/base64.scm @@ -3,9 +3,13 @@ ;; Examples from RFC4648 ;;; Code: -(((base64) base64encode base64decode)) - +(define-module (test base64) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module (base64)) +;; Tests borrowed directly from RFC4648 (test-equal "" (base64encode "")) (test-equal "Zg==" (base64encode "f")) (test-equal "Zm8=" (base64encode "fo")) @@ -13,7 +17,6 @@ (test-equal "Zm9vYg==" (base64encode "foob")) (test-equal "Zm9vYmE=" (base64encode "fooba")) (test-equal "Zm9vYmFy" (base64encode "foobar")) - (test-equal "" (base64decode "")) (test-equal "f" (base64decode "Zg==")) (test-equal "fo" (base64decode "Zm8=")) @@ -21,3 +24,20 @@ (test-equal "foob" (base64decode "Zm9vYg==")) (test-equal "fooba" (base64decode "Zm9vYmE=")) (test-equal "foobar" (base64decode "Zm9vYmFy")) + + +;; Other tests + +;; TODO normalize base64 errors + +(test-error "Invalid base64" + 'decoding-error + (base64decode "@@@@")) + +(test-error "To short base64" + 'out-of-range + (base64decode "=")) + +(test-equal "AAECAw==" (bytevector->base64-string #vu8(0 1 2 3))) + +(test-equal #vu8(0 1 2 3) (base64-string->bytevector "AAECAw==")) diff --git a/tests/test/cpp.scm b/tests/test/cpp.scm new file mode 100644 index 00000000..9c720fde --- /dev/null +++ b/tests/test/cpp.scm @@ -0,0 +1,39 @@ +;;; Commentary: +;; Tests my parser for a subset of the C programming language. +;;; Code: + +(define-module (test cpp) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module ((c lex) :select (lex)) + :use-module ((c parse) :select (parse-lexeme-tree))) + +(define run (compose parse-lexeme-tree lex)) + +(test-equal + '(+ (post-increment (dereference C)) 3) + (run "(*C)++ + 3")) + +(test-equal + '(+ (post-increment (dereference C)) 3) + (run "*C++ + 3")) + +(test-equal + '(post-increment (dereference C)) + (run "*C++")) + +(test-equal + '(+ (post-increment C) (post-increment C)) + (run "C++ + C++")) + +(test-equal + '(+ (pre-increment C) (pre-increment C)) + (run "++C + ++C")) + +(test-equal '(+ 2 (* 2 2)) (run "2 + 2 * 2")) + +(test-equal '(+ (* 2 2) 2) (run "2 * 2 + 2")) + +(test-equal '(+ 2 2 2) (run "2+2+2")) + + diff --git a/tests/test/crypto.scm b/tests/test/crypto.scm new file mode 100644 index 00000000..71ecfc99 --- /dev/null +++ b/tests/test/crypto.scm @@ -0,0 +1,15 @@ +(use-modules ((crypto) :select (sha256 checksum->string))) + +(test-equal "sha256" + #vu8(24 95 141 179 34 113 254 37 245 97 166 252 147 139 46 38 67 6 236 48 78 218 81 128 7 209 118 72 38 56 25 105) + (sha256 "Hello")) + +(test-equal "sha256 string digest" + "185f8db32271fe25f561a6fc938b2e264306ec304eda518007d1764826381969" + (checksum->string (sha256 "Hello"))) + +(let ((port (open-output-string))) + (checksum->string (sha256 "Hello") port) + (test-equal "sha256 string digest to port" + "185f8db32271fe25f561a6fc938b2e264306ec304eda518007d1764826381969" + (get-output-string port))) diff --git a/tests/test/datetime-compare.scm b/tests/test/datetime-compare.scm new file mode 100644 index 00000000..0d07c52f --- /dev/null +++ b/tests/test/datetime-compare.scm @@ -0,0 +1,145 @@ +;;; Commentary: +;; Tests that all ordering predicates for dates, +;; times, and datetimes hold. +;;; Code: + +(define-module (test datetime-compare) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module ((datetime) + :select (date datetime + time + date< + date<= + date> + date>= + date/-time< + time<))) + +(test-assert "date< empty" (date<)) + +(test-assert + "date< single" + (date< #2020-01-10)) + +(test-assert + "date< double" + (date< #2020-01-10 + #2020-01-11)) + +(test-assert + "date< tripple" + (date< #2020-01-10 + #2020-01-11 + #2020-01-12)) + +(test-assert + "date< tripple negate" + (not (date< #2020-01-10 + #2020-01-12 + #2020-01-11))) + +(test-assert "date<= empty" (date<=)) + +(test-assert + "date<= single" + (date<= #2020-01-10)) + +(test-assert + "date<= double" + (date<= + #2020-01-10 + #2020-01-11)) + +(test-assert + "date<=" + (not (date<= + #2020-01-01 + #2018-05-15 + #2020-01-31))) + +(test-assert + "date<= equal" + (date<= + #2018-05-15 + #2018-05-15)) + +(test-assert + "date<" + (not (date< #2020-01-01 + #2018-05-15 + #2020-01-31))) + +(test-assert + "date>" + (not (date> #2020-01-31 + #2018-05-15 + #2020-01-01))) + +(test-assert + "date>=" + (not (date>= + #2020-01-31 + #2018-05-15 + #2020-01-01))) + +(test-assert + "time< simple" + (time< #05:00:00 + #10:00:00)) + +(test-assert + "time<" + (time< (time) + #10:00:00)) + +(test-assert + "date/-time<" + (date/-time< + #2020-01-01 + #2020-01-02)) + +(test-assert + "not date/-time<" + (not (date/-time< + #2020-01-01 + #2020-01-01))) + +(test-assert + "date/-time< only other dt" + (date/-time< + #2020-01-01 + #2020-01-02T10:00:00)) + +(test-assert + "date/-time< other dt, same date" + (date/-time< + #2020-01-01 + #2020-01-01T10:00:00)) + +;; In UTC+2 (CEST) the below datetime overflows into midnight the following +;; day. Earlier versions of this program only looked at the time component +(test-assert + "date/-time< TZ overflow" + (date/-time< + #2020-04-05 + (datetime + date: + #2020-04-05 + time: + #22:00:00 + tz: + "UTC"))) + +(test-assert + "date/-time< time-only" + (date/-time< + #00:00:00 + #10:00:00)) + +(test-assert + (not (date/-time< + #2018-11-30T08:10:00 + #2014-04-13T16:00:00))) + + diff --git a/tests/test/datetime-util.scm b/tests/test/datetime-util.scm new file mode 100644 index 00000000..ca8a9241 --- /dev/null +++ b/tests/test/datetime-util.scm @@ -0,0 +1,182 @@ +;;; Commentary: +;; Tests timespan overlaps and month-streams. +;; Separate from tests/datetime.scm since +;; (datetime util) originally was its own module. +;;; Code: + +(define-module (test datetime-util) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module ((datetime) + :select (date time + datetime + month-stream + in-date-range? + timespan-overlaps?)) + :use-module ((srfi srfi-41) + :select (stream->list stream-take))) + +(test-assert + "jan->dec" + (stream->list + (stream-take + 11 + (month-stream + #2020-01-01)))) + +(test-assert + "dec->jan" + (stream->list + (stream-take + 2 + (month-stream + #2020-12-01)))) + +(test-assert + "dec->feb" + (stream->list + (stream-take + 3 + (month-stream + #2020-12-01)))) + +(test-assert + "20 months" + (stream->list + (stream-take + 20 + (month-stream + #2020-01-01)))) + +(test-equal + "Correct months" + (list #2020-02-01 + #2020-03-01 + #2020-04-01 + #2020-05-01 + #2020-06-01 + #2020-07-01 + #2020-08-01 + #2020-09-01 + #2020-10-01 + #2020-11-01 + #2020-12-01 + #2021-01-01) + (stream->list + (stream-take + 12 + (month-stream + #2020-02-01)))) + +(test-assert + "in-date-range?" + (not ((in-date-range? + #2020-01-01 + #2020-02-29) + #2018-02-02))) + +(test-assert + "A" + (timespan-overlaps? + #2020-01-01 + #2020-01-10 + #2020-01-05 + #2020-01-15)) + +(test-assert + "A, shared start" + (timespan-overlaps? + #2020-01-01 + #2020-01-10 + #2020-01-01 + #2020-01-15)) + +(test-assert + "A, tangential" + (not (timespan-overlaps? + #2020-01-01T00:00:00 + #2020-01-10T00:00:00 + #2020-01-10T00:00:00 + #2020-01-30T00:00:00))) + +(test-assert + "s1 instant" + (timespan-overlaps? + #2020-01-15T10:00:00 + #2020-01-15T10:00:00 + #2020-01-10T00:00:00 + #2020-01-30T00:00:00)) + +(test-assert + "s2 instant" + (timespan-overlaps? + #2020-01-10T00:00:00 + #2020-01-30T00:00:00 + #2020-01-15T10:00:00 + #2020-01-15T10:00:00)) + +(test-assert + "s1 instant, shared start with s2" + (timespan-overlaps? + #2020-01-15T10:00:00 + #2020-01-15T10:00:00 + #2020-01-15T10:00:00 + #2020-01-30T00:00:00)) + +(test-assert + "s1 instant, shared end with s2" + (not (timespan-overlaps? + #2020-01-15T10:00:00 + #2020-01-15T10:00:00 + #2020-01-10T00:00:00 + #2020-01-15T10:00:00))) + +(test-assert + "s2 instant, shared start with s1" + (timespan-overlaps? + #2020-01-15T10:00:00 + #2020-01-30T00:00:00 + #2020-01-15T10:00:00 + #2020-01-15T10:00:00)) + +(test-assert + "s2 instant, shared end with s1" + (not (timespan-overlaps? + #2020-01-10T00:00:00 + #2020-01-15T10:00:00 + #2020-01-15T10:00:00 + #2020-01-15T10:00:00))) + +(test-assert + "both instant" + (not (timespan-overlaps? + #2020-01-15T10:00:00 + #2020-01-15T10:00:00 + #2020-01-15T10:00:00 + #2020-01-15T10:00:00))) + +(test-assert + "tangential whole day" + (not (timespan-overlaps? + #2020-01-01 + #2020-01-02 + #2020-01-02 + #2020-01-03))) + +(test-assert + "B" + (timespan-overlaps? + #2020-01-05 + #2020-01-15 + #2020-01-01 + #2020-01-10)) + +(test-assert + "E" + (timespan-overlaps? + #2020-01-01 + #2020-01-10 + #2020-01-01 + #2020-01-10)) + + diff --git a/tests/test/datetime.scm b/tests/test/datetime.scm new file mode 100644 index 00000000..1051e203 --- /dev/null +++ b/tests/test/datetime.scm @@ -0,0 +1,395 @@ +;;; Commentary: +;; Tests date, time, and datetime creation, +;; (output) formatting, and arithmetic. +;;; Code: + +(define-module (test datetime) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module ((datetime) + :select (date+ date- + time+ + time- + year + month + day + date + time + datetime + datetime+ + datetime<=? + datetime-difference + datetime- + leap-year? + string->date + string->time + string->datetime + parse-month + days-in-interval)) + :use-module ((ice-9 format) :select (format)) + :use-module ((hnh util) :select (let*)) + :use-module ((ice-9 i18n) :select (make-locale)) + :use-module ((guile) :select (LC_TIME))) + +(test-equal + "empty time" + (time) + #00:00:00) + +(test-assert + "Synatx date" + #2020-01-01) + +(test-assert + "Test year type" + (integer? (year (date year: 2020)))) + +(test-assert + "Test mmnth type" + (integer? (month (date month: 1)))) + +(test-assert + "Test day type" + (integer? (day (date day: 1)))) + +(test-equal + "Manual print (any)" + "2020-10-10" + (let ((d #2020-10-10)) + (format #f "~a-~a-~a" (year d) (month d) (day d)))) + +(test-equal + "Manual print (number)" + "2020-10-10" + (let ((d #2020-10-10)) + (format #f "~d-~d-~d" (year d) (month d) (day d)))) + +(test-equal + "Date print" + "#2020-01-01" + (format + #f + "~a" + #2020-01-01)) + +(test-equal + "Syntax date=" + (date year: 2020 month: 1 day: 1) + #2020-01-01) + +(test-equal + "Syntax time=" + (time hour: 13 minute: 37 second: 0) + #13:37:00) + +(test-equal + "Syntax Datetime=" + (datetime year: 2020 month: 1 day: 1 + hour: 13 minute: 37 second: 0) + #2020-01-01T13:37:00) + +(test-equal + #2020-02-28 + (date- #2020-03-05 + (date day: 6))) + +(test-equal + #2020-02-29 + (date- #2020-03-05 + (date day: 5))) + +(test-equal + #2020-03-01 + (date- #2020-03-05 + (date day: 4))) + +(test-equal + "date+ day" + #2020-10-10 + (date+ #2020-10-01 + (date day: 9))) + +(test-equal + "date+ month" + #2020-10-10 + (date+ #2020-01-10 + (date month: 9))) + +(test-equal + "date+ day/month" + #2020-10-10 + (date+ #2020-01-01 + (date day: 9 month: 9))) + +(test-assert + "date+ first literal" + (date+ #2020-01-01 + (date day: 0))) + +(test-assert + "date+ second literal" + (date+ #0001-01-01 + #0001-00-00)) + +(test-assert + "date+ both literal" + (date+ #2020-01-01 + #0000-00-00)) + +(test-equal + "date+ year overflow" + #2019-01-01 + (date+ #2018-12-31 + (date day: 1))) + +(test-equal + "date- year overflow" + #2018-12-31 + (date- #2019-01-01 + (date day: 1))) + +(test-equal + "date- large" + #0001-01-01 + (date- #2020-01-01 + #2019-00-00)) + +(test-equal + "date- equal" + (date year: -1 month: 11 day: 31) + (date- #2020-01-01 + #2020-01-01)) + +(test-equal + #2020-01-01T10:00:00 + (datetime + date: + #2020-01-01 + time: + #10:00:00)) + +(test-equal + #2020-01-01T10:00:00 + (datetime+ + (datetime + date: + #2020-01-01) + (datetime + time: + #10:00:00))) + +(test-equal + #2020-10-09T14:00:00 + (datetime- + #2020-10-10T00:00:00 + (datetime + time: + #10:00:00))) + +(test-equal + #2020-09-24T14:00:00 + (datetime- + #2020-10-10T00:00:00 + #0000-00-15T10:00:00)) + +(test-equal + #2020-03-10 + (date+ #2020-03-01 + (date day: 4) + (date day: 5))) + +(let* ((diff overflow + (time- #10:20:30 + #10:20:30))) + (test-equal + "time- self" + #00:00:00 + diff) + (test-equal "time- self overflow" 0 overflow)) + +(let* ((diff overflow + (time- #10:00:00 + #10:00:01))) + (test-equal + "time- overflow 1s" + #23:59:59 + diff) + (test-equal + "time- overflow 1s overflow" + 1 + overflow)) + +(let* ((diff overflow + (time- #10:00:00 + (time hour: (+ 48 4))))) + (test-equal + "time- overflow multiple" + #06:00:00 + diff) + (test-equal + "time- overflow multiple overflow" + 2 + overflow)) + +(test-equal + "datetime-difference self" + #0000-00-00T00:00:00 + (datetime-difference + (datetime + date: + #2020-01-01) + (datetime + date: + #2020-01-01))) + +;; NOTE +;; at the time of writing this returns #2020-02-00 +;; The general question is, how is the last in a month handled? +(test-equal + #2020-01-31 + (date+ #2019-12-31 + (date month: 1))) + +(test-assert (leap-year? 2020)) + +(test-equal + "Add to Leap day" + #2020-02-29 + (date+ #2020-02-28 + (date day: 1))) + +(test-equal + "Parse ISO" + #2021-12-30T13:53:33 + (string->datetime + "2021-12-30T13:53:33" + "~Y-~m-~dT~H:~M:~S")) + +(test-equal + "Parse ical date-time" + #2021-12-30T13:53:33 + (string->datetime + "20211230T135333" + "~Y~m~dT~H~M~S")) + +(test-equal + "Parse single hour (padded)" + (time hour: 5) + (string->time "05" "~H")) + +(test-equal + "Parse single hour (non-padded)" + (time hour: 5) + (string->time "5" "~H")) + +(test-equal + "Parse month (swedish)" + (date month: 5) + (string->date + "Maj" + "~b" + (make-locale LC_TIME "sv_SE.UTF-8"))) + +(test-equal + "Parse month (english)" + (date month: 5) + (string->date + "May" + "~b" + (make-locale LC_TIME "en_US.UTF-8"))) + +(test-equal + "AM/PM AM" + (time hour: 10) + (string->time "10 AM" "~H ~p")) + +(test-equal + "AM/PM PM" + (time hour: 22) + (string->time "10 PM" "~H ~p")) + +(test-equal + "AM/PM AM 12" + (time hour: 0) + (string->time "12 AM" "~H ~p")) + +(test-equal + "AM/PM PM 12" + (time hour: 12) + (string->time "12 PM" "~H ~p")) + +(test-equal + "AM/PM PM (prefix)" + (time hour: 22) + (string->time "PM 10" "~p ~H")) + +(test-equal + "Parse complicated 1" + #2021-12-30T10:56:00 + (string->datetime + "Dec. 30, 2021, 10:56" + "~b. ~d, ~Y, ~H:~M" + (make-locale LC_TIME "en_US.UTF-8"))) + +(test-equal + "Parse complicated 2" + #2021-12-30T10:56:00 + (string->datetime + "Dec. 30, 2021, 10:56 a.m." + "~b. ~d, ~Y, ~H:~M" + (make-locale LC_TIME "en_US.UTF-8"))) + +(test-equal + "Parse complicated 3" + #2021-12-30T22:56:00 + (string->datetime + "Dec. 30, 2021, 10:56 p.m." + "~b. ~d, ~Y, ~H:~M ~p" + (make-locale LC_TIME "en_US.UTF-8"))) + +(test-equal + "Parse date single digit day" + (date day: 6) + (string->date "6" "~d")) + +(test-equal + "Parse date single digit day, trailing comma" + (date day: 6) + (string->date "6," "~d,")) + +(test-equal + "Parse date single digit day, trailing comma + space" + (date day: 6) + (string->date "6, " "~d, ")) + +(define en_US + (make-locale LC_TIME "en_US.UTF-8")) + +(define sv_SE + (make-locale LC_TIME "sv_SE.UTF-8")) + +(test-equal 1 (parse-month "jan" en_US)) + +(test-equal 1 (parse-month "jan" sv_SE)) + +(test-equal 12 (parse-month "dec" en_US)) + +(test-equal -1 (parse-month "inv" en_US)) + +(test-equal 5 (parse-month "mAJ" sv_SE)) + +(test-equal + "Days in regular year" + 365 + (days-in-interval + #2021-01-01 + #2021-12-31)) + +(test-equal + "Days in leap year" + 366 + (days-in-interval + #2020-01-01 + #2020-12-31)) + + diff --git a/tests/test/let-env.scm b/tests/test/let-env.scm new file mode 100644 index 00000000..07b92d2d --- /dev/null +++ b/tests/test/let-env.scm @@ -0,0 +1,43 @@ +(define-module (test let-env) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module ((guile) :select (setenv getenv)) + :use-module ((hnh util) :select (let-env))) + +(setenv "CALP_TEST_ENV" "1") + +(test-equal + "Ensure we have set value beforehand" + "1" + (getenv "CALP_TEST_ENV")) + +(let-env + ((CALP_TEST_ENV "2")) + (test-equal + "Test our local override" + "2" + (getenv "CALP_TEST_ENV"))) + +(test-equal + "Test that we have returned" + "1" + (getenv "CALP_TEST_ENV")) + +(catch 'test-error + (lambda () + (let-env + ((CALP_TEST_ENV "2")) + (test-equal + "Test our local override again" + "2" + (getenv "CALP_TEST_ENV")) + (throw 'test-error))) + list) + +(test-equal + "Test restoration after non-local exit" + "1" + (getenv "CALP_TEST_ENV")) + + diff --git a/tests/test/let.scm b/tests/test/let.scm new file mode 100644 index 00000000..5312409e --- /dev/null +++ b/tests/test/let.scm @@ -0,0 +1,45 @@ +;;; Commentary: +;; Tests my custom let*. +;;; Code: + +(define-module (test let) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module ((hnh util) :select (let*))) + +(test-assert (let* ((a #t)) a)) + +(test-assert (let* (((a . b) (cons #t #f))) a)) + +(test-assert (let* (((a . b) (cons* #f #t))) b)) + +(test-assert + (let* ((a b c (values #f #t #f))) b)) + +(test-assert + (let* (((a b c) (list #f #t #f))) b)) + +(test-assert (let* (((a) '(#t))) a)) + +(test-equal '(2) (let* (((a . b) '(1 2))) b)) + +(test-equal + '(3 4) + (let* (((a b . c) '(1 2 3 4))) c)) + +(test-equal 10 (let* (x) (set! x 10) x)) + +(test-equal + 30 + (let* (x y) (set! x 10) (set! y 20) (+ x y))) + +(test-assert (let* (x) (not x))) + +(test-equal + 6 + (let* ((x 1) y z) + (set! y 2) + (set! z 3) + (+ x y z))) + + diff --git a/tests/test/param.scm b/tests/test/param.scm new file mode 100644 index 00000000..4c3cbcfb --- /dev/null +++ b/tests/test/param.scm @@ -0,0 +1,59 @@ +;;; Commentary: +;; Checks that parameters (1) are correctly parsed and stored. +;; (1): 'A', and 'B' in the line "KEY;A=1;B=2:Some text" +;;; Code: + +(define-module (test param) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module ((vcomponent base) + :select (param prop* parameters prop)) + :use-module ((vcomponent formats ical parse) + :select (parse-calendar)) + :use-module ((vcomponent) :select (make-vcomponent)) + :use-module ((hnh util) :select (sort* set!)) + :use-module ((ice-9 ports) :select (call-with-input-string)) + :use-module ((vcomponent formats xcal output) + :select (vcomponent->sxcal)) + ) + +(define v + (call-with-input-string + "BEGIN:DUMMY +X-KEY;A=1;B=2:Some text +END:DUMMY" + parse-calendar)) + +(test-equal '("1") (param (prop* v 'X-KEY) 'A)) + +(test-equal '("2") (param (prop* v 'X-KEY) 'B)) + +(test-equal #f (param (prop* v 'X-KEY) 'C)) + +(test-equal + '(A B) + (sort* (map car (parameters (prop* v 'X-KEY))) + string<? + symbol->string)) + + +;; TODO possibly move this. +;; Checks that a warning is properly raised for +;; unkonwn keys (without an X-prefix) +(test-error + 'warning + (call-with-input-string + "BEGIN:DUMMY +KEY:Some Text +END:DUMMY" + parse-calendar)) + +;; Similar thing happens for sxcal, but during serialization instead +(let ((component (make-vcomponent 'DUMMY))) + (set! (prop component 'KEY) "Anything") + (test-error + 'warning + (vcomponent->sxcal component))) + + diff --git a/tests/test/recurrence-advanced.scm b/tests/test/recurrence-advanced.scm new file mode 100644 index 00000000..9ea1e075 --- /dev/null +++ b/tests/test/recurrence-advanced.scm @@ -0,0 +1,1347 @@ +;;; Commentary: +;; Tests of recurrence rule generation with focus on correct instances +;; being generated. For tests of basic recurrence functionallity, see +;; recurrence-simple.scm. +;; +;; This file also tests format-recurrence-rule, which checks that human +;; readable representations of the RRULES work. +;; +;; Also contains the tests for EXDATE. +;; +;; Most examples copied from RFC5545, some home written. +;;; Code: + +(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 generate) + :select (generate-recurrence-set)) + :use-module ((vcomponent recurrence display) + :select (format-recurrence-rule)) + :use-module ((vcomponent recurrence internal) + :select (count until)) + :use-module ((vcomponent base) + :select (make-vcomponent prop prop* extract)) + :use-module ((datetime) + :select (parse-ics-datetime + datetime + time + date + datetime->string)) + :use-module ((hnh util) :select (-> set!)) + :use-module ((srfi srfi-41) :select (stream->list)) + :use-module ((srfi srfi-88) :select (keyword->string))) + +(test-expect-fail "RSET: The third instance into the month of one of Tuesday, Wednesday, or Thursday, for the next 3 months") + +(test-expect-fail "STR: The third instance into the month of one of Tuesday, Wednesday, or Thursday, for the next 3 months") + +(test-expect-fail "RSET: The second-to-last weekday of the month") + +(test-expect-fail "STR: The second-to-last weekday of the month") + +;; TODO this test is really slow, figure out why (takes approx. 25s to run) +(test-skip "RSET: Every day in January, for 3 years (alt 2)") + +(define (run-test comp) + (test-equal + (string-append "RSET: " (prop comp 'SUMMARY)) + (prop comp 'X-SET) + (let ((r (generate-recurrence-set comp))) + (map (extract 'DTSTART) + (if (or (until (prop comp 'RRULE)) + (count (prop comp 'RRULE))) + (stream->list r) + (stream->list 20 r))))) + (test-equal + (string-append "STR: " (prop comp 'SUMMARY)) + (prop comp 'X-SUMMARY) + (format-recurrence-rule (prop comp 'RRULE)))) + +(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))) + (set! (prop v symb) + (case symb + ((DTSTART EXDATE) + (parse-ics-datetime (cadr rem))) + ((RRULE) (parse-recurrence-rule (cadr rem))) + (else (cadr rem)))) + (when (eq? symb 'EXDATE) + (set! (prop* v symb) = list))) + (loop (cddr rem)))) + v) + +(map run-test + (list (vevent + summary: + "Daily for 10 occurrences" + dtstart: + "19970902T090000" + rrule: + "FREQ=DAILY;COUNT=10" + x-summary: + "dagligen, totalt 10 gånger" + x-set: + (list #1997-09-02T09:00:00 + #1997-09-03T09:00:00 + #1997-09-04T09:00:00 + #1997-09-05T09:00:00 + #1997-09-06T09:00:00 + #1997-09-07T09:00:00 + #1997-09-08T09:00:00 + #1997-09-09T09:00:00 + #1997-09-10T09:00:00 + #1997-09-11T09:00:00)) + (vevent + summary: + "Daily until December 24, 1997" + dtstart: + "19970902T090000" + rrule: + "FREQ=DAILY;UNTIL=19971224T000000Z" + x-summary: + "dagligen, till och med den 24 december, 1997 kl. 0:00" + x-set: + (list #1997-09-02T09:00:00 + #1997-09-03T09:00:00 + #1997-09-04T09:00:00 + #1997-09-05T09:00:00 + #1997-09-06T09:00:00 + #1997-09-07T09:00:00 + #1997-09-08T09:00:00 + #1997-09-09T09:00:00 + #1997-09-10T09:00:00 + #1997-09-11T09:00:00 + #1997-09-12T09:00:00 + #1997-09-13T09:00:00 + #1997-09-14T09:00:00 + #1997-09-15T09:00:00 + #1997-09-16T09:00:00 + #1997-09-17T09:00:00 + #1997-09-18T09:00:00 + #1997-09-19T09:00:00 + #1997-09-20T09:00:00 + #1997-09-21T09:00:00 + #1997-09-22T09:00:00 + #1997-09-23T09:00:00 + #1997-09-24T09:00:00 + #1997-09-25T09:00:00 + #1997-09-26T09:00:00 + #1997-09-27T09:00:00 + #1997-09-28T09:00:00 + #1997-09-29T09:00:00 + #1997-09-30T09:00:00 + #1997-10-01T09:00:00 + #1997-10-02T09:00:00 + #1997-10-03T09:00:00 + #1997-10-04T09:00:00 + #1997-10-05T09:00:00 + #1997-10-06T09:00:00 + #1997-10-07T09:00:00 + #1997-10-08T09:00:00 + #1997-10-09T09:00:00 + #1997-10-10T09:00:00 + #1997-10-11T09:00:00 + #1997-10-12T09:00:00 + #1997-10-13T09:00:00 + #1997-10-14T09:00:00 + #1997-10-15T09:00:00 + #1997-10-16T09:00:00 + #1997-10-17T09:00:00 + #1997-10-18T09:00:00 + #1997-10-19T09:00:00 + #1997-10-20T09:00:00 + #1997-10-21T09:00:00 + #1997-10-22T09:00:00 + #1997-10-23T09:00:00 + #1997-10-24T09:00:00 + #1997-10-25T09:00:00 + #1997-10-26T09:00:00 + #1997-10-27T09:00:00 + #1997-10-28T09:00:00 + #1997-10-29T09:00:00 + #1997-10-30T09:00:00 + #1997-10-31T09:00:00 + #1997-11-01T09:00:00 + #1997-11-02T09:00:00 + #1997-11-03T09:00:00 + #1997-11-04T09:00:00 + #1997-11-05T09:00:00 + #1997-11-06T09:00:00 + #1997-11-07T09:00:00 + #1997-11-08T09:00:00 + #1997-11-09T09:00:00 + #1997-11-10T09:00:00 + #1997-11-11T09:00:00 + #1997-11-12T09:00:00 + #1997-11-13T09:00:00 + #1997-11-14T09:00:00 + #1997-11-15T09:00:00 + #1997-11-16T09:00:00 + #1997-11-17T09:00:00 + #1997-11-18T09:00:00 + #1997-11-19T09:00:00 + #1997-11-20T09:00:00 + #1997-11-21T09:00:00 + #1997-11-22T09:00:00 + #1997-11-23T09:00:00 + #1997-11-24T09:00:00 + #1997-11-25T09:00:00 + #1997-11-26T09:00:00 + #1997-11-27T09:00:00 + #1997-11-28T09:00:00 + #1997-11-29T09:00:00 + #1997-11-30T09:00:00 + #1997-12-01T09:00:00 + #1997-12-02T09:00:00 + #1997-12-03T09:00:00 + #1997-12-04T09:00:00 + #1997-12-05T09:00:00 + #1997-12-06T09:00:00 + #1997-12-07T09:00:00 + #1997-12-08T09:00:00 + #1997-12-09T09:00:00 + #1997-12-10T09:00:00 + #1997-12-11T09:00:00 + #1997-12-12T09:00:00 + #1997-12-13T09:00:00 + #1997-12-14T09:00:00 + #1997-12-15T09:00:00 + #1997-12-16T09:00:00 + #1997-12-17T09:00:00 + #1997-12-18T09:00:00 + #1997-12-19T09:00:00 + #1997-12-20T09:00:00 + #1997-12-21T09:00:00 + #1997-12-22T09:00:00 + #1997-12-23T09:00:00)) + (vevent + summary: + "Every other day - forever" + dtstart: + "19970902T090000" + rrule: + "FREQ=DAILY;INTERVAL=2" + x-summary: + "varannan dag" + x-set: + (list #1997-09-02T09:00:00 + #1997-09-04T09:00:00 + #1997-09-06T09:00:00 + #1997-09-08T09:00:00 + #1997-09-10T09:00:00 + #1997-09-12T09:00:00 + #1997-09-14T09:00:00 + #1997-09-16T09:00:00 + #1997-09-18T09:00:00 + #1997-09-20T09:00:00 + #1997-09-22T09:00:00 + #1997-09-24T09:00:00 + #1997-09-26T09:00:00 + #1997-09-28T09:00:00 + #1997-09-30T09:00:00 + #1997-10-02T09:00:00 + #1997-10-04T09:00:00 + #1997-10-06T09:00:00 + #1997-10-08T09:00:00 + #1997-10-10T09:00:00)) + (vevent + summary: + "Every 10 days, 5 occurrences" + dtstart: + "19970902T090000" + rrule: + "FREQ=DAILY;INTERVAL=10;COUNT=5" + x-summary: + "var tionde dag, totalt 5 gånger" + x-set: + (list #1997-09-02T09:00:00 + #1997-09-12T09:00:00 + #1997-09-22T09:00:00 + #1997-10-02T09:00:00 + #1997-10-12T09:00:00)) + (vevent + summary: + "Every day in January, for 3 years (alt 1)" + dtstart: + "19980101T090000" + rrule: + "FREQ=YEARLY;UNTIL=20000131T140000Z;BYMONTH=1;BYDAY=SU,MO,TU,WE,TH,FR,SA" + 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: + (list #1998-01-01T09:00:00 + #1998-01-02T09:00:00 + #1998-01-03T09:00:00 + #1998-01-04T09:00:00 + #1998-01-05T09:00:00 + #1998-01-06T09:00:00 + #1998-01-07T09:00:00 + #1998-01-08T09:00:00 + #1998-01-09T09:00:00 + #1998-01-10T09:00:00 + #1998-01-11T09:00:00 + #1998-01-12T09:00:00 + #1998-01-13T09:00:00 + #1998-01-14T09:00:00 + #1998-01-15T09:00:00 + #1998-01-16T09:00:00 + #1998-01-17T09:00:00 + #1998-01-18T09:00:00 + #1998-01-19T09:00:00 + #1998-01-20T09:00:00 + #1998-01-21T09:00:00 + #1998-01-22T09:00:00 + #1998-01-23T09:00:00 + #1998-01-24T09:00:00 + #1998-01-25T09:00:00 + #1998-01-26T09:00:00 + #1998-01-27T09:00:00 + #1998-01-28T09:00:00 + #1998-01-29T09:00:00 + #1998-01-30T09:00:00 + #1998-01-31T09:00:00 + #1999-01-01T09:00:00 + #1999-01-02T09:00:00 + #1999-01-03T09:00:00 + #1999-01-04T09:00:00 + #1999-01-05T09:00:00 + #1999-01-06T09:00:00 + #1999-01-07T09:00:00 + #1999-01-08T09:00:00 + #1999-01-09T09:00:00 + #1999-01-10T09:00:00 + #1999-01-11T09:00:00 + #1999-01-12T09:00:00 + #1999-01-13T09:00:00 + #1999-01-14T09:00:00 + #1999-01-15T09:00:00 + #1999-01-16T09:00:00 + #1999-01-17T09:00:00 + #1999-01-18T09:00:00 + #1999-01-19T09:00:00 + #1999-01-20T09:00:00 + #1999-01-21T09:00:00 + #1999-01-22T09:00:00 + #1999-01-23T09:00:00 + #1999-01-24T09:00:00 + #1999-01-25T09:00:00 + #1999-01-26T09:00:00 + #1999-01-27T09:00:00 + #1999-01-28T09:00:00 + #1999-01-29T09:00:00 + #1999-01-30T09:00:00 + #1999-01-31T09:00:00 + #2000-01-01T09:00:00 + #2000-01-02T09:00:00 + #2000-01-03T09:00:00 + #2000-01-04T09:00:00 + #2000-01-05T09:00:00 + #2000-01-06T09:00:00 + #2000-01-07T09:00:00 + #2000-01-08T09:00:00 + #2000-01-09T09:00:00 + #2000-01-10T09:00:00 + #2000-01-11T09:00:00 + #2000-01-12T09:00:00 + #2000-01-13T09:00:00 + #2000-01-14T09:00:00 + #2000-01-15T09:00:00 + #2000-01-16T09:00:00 + #2000-01-17T09:00:00 + #2000-01-18T09:00:00 + #2000-01-19T09:00:00 + #2000-01-20T09:00:00 + #2000-01-21T09:00:00 + #2000-01-22T09:00:00 + #2000-01-23T09:00:00 + #2000-01-24T09:00:00 + #2000-01-25T09:00:00 + #2000-01-26T09:00:00 + #2000-01-27T09:00:00 + #2000-01-28T09:00:00 + #2000-01-29T09:00:00 + #2000-01-30T09:00:00 + #2000-01-31T09:00:00)) + (vevent + summary: + "Every day in January, for 3 years (alt 2)" + dtstart: + "19980101T090000" + rrule: + "FREQ=DAILY;UNTIL=20000131T140000Z;BYMONTH=1" + x-summary: + "dagligen, till och med den 31 januari, 2000 kl. 14:00" + x-set: + (list #1998-01-01T09:00:00 + #1998-01-02T09:00:00 + #1998-01-03T09:00:00 + #1998-01-04T09:00:00 + #1998-01-05T09:00:00 + #1998-01-06T09:00:00 + #1998-01-07T09:00:00 + #1998-01-08T09:00:00 + #1998-01-09T09:00:00 + #1998-01-10T09:00:00 + #1998-01-11T09:00:00 + #1998-01-12T09:00:00 + #1998-01-13T09:00:00 + #1998-01-14T09:00:00 + #1998-01-15T09:00:00 + #1998-01-16T09:00:00 + #1998-01-17T09:00:00 + #1998-01-18T09:00:00 + #1998-01-19T09:00:00 + #1998-01-20T09:00:00 + #1998-01-21T09:00:00 + #1998-01-22T09:00:00 + #1998-01-23T09:00:00 + #1998-01-24T09:00:00 + #1998-01-25T09:00:00 + #1998-01-26T09:00:00 + #1998-01-27T09:00:00 + #1998-01-28T09:00:00 + #1998-01-29T09:00:00 + #1998-01-30T09:00:00 + #1998-01-31T09:00:00 + #1999-01-01T09:00:00 + #1999-01-02T09:00:00 + #1999-01-03T09:00:00 + #1999-01-04T09:00:00 + #1999-01-05T09:00:00 + #1999-01-06T09:00:00 + #1999-01-07T09:00:00 + #1999-01-08T09:00:00 + #1999-01-09T09:00:00 + #1999-01-10T09:00:00 + #1999-01-11T09:00:00 + #1999-01-12T09:00:00 + #1999-01-13T09:00:00 + #1999-01-14T09:00:00 + #1999-01-15T09:00:00 + #1999-01-16T09:00:00 + #1999-01-17T09:00:00 + #1999-01-18T09:00:00 + #1999-01-19T09:00:00 + #1999-01-20T09:00:00 + #1999-01-21T09:00:00 + #1999-01-22T09:00:00 + #1999-01-23T09:00:00 + #1999-01-24T09:00:00 + #1999-01-25T09:00:00 + #1999-01-26T09:00:00 + #1999-01-27T09:00:00 + #1999-01-28T09:00:00 + #1999-01-29T09:00:00 + #1999-01-30T09:00:00 + #1999-01-31T09:00:00 + #2000-01-01T09:00:00 + #2000-01-02T09:00:00 + #2000-01-03T09:00:00 + #2000-01-04T09:00:00 + #2000-01-05T09:00:00 + #2000-01-06T09:00:00 + #2000-01-07T09:00:00 + #2000-01-08T09:00:00 + #2000-01-09T09:00:00 + #2000-01-10T09:00:00 + #2000-01-11T09:00:00 + #2000-01-12T09:00:00 + #2000-01-13T09:00:00 + #2000-01-14T09:00:00 + #2000-01-15T09:00:00 + #2000-01-16T09:00:00 + #2000-01-17T09:00:00 + #2000-01-18T09:00:00 + #2000-01-19T09:00:00 + #2000-01-20T09:00:00 + #2000-01-21T09:00:00 + #2000-01-22T09:00:00 + #2000-01-23T09:00:00 + #2000-01-24T09:00:00 + #2000-01-25T09:00:00 + #2000-01-26T09:00:00 + #2000-01-27T09:00:00 + #2000-01-28T09:00:00 + #2000-01-29T09:00:00 + #2000-01-30T09:00:00 + #2000-01-31T09:00:00)) + (vevent + summary: + "Weekly for 10 occurrences" + dtstart: + "19970902T090000" + rrule: + "FREQ=WEEKLY;COUNT=10" + x-summary: + "varje vecka, totalt 10 gånger" + x-set: + (list #1997-09-02T09:00:00 + #1997-09-09T09:00:00 + #1997-09-16T09:00:00 + #1997-09-23T09:00:00 + #1997-09-30T09:00:00 + #1997-10-07T09:00:00 + #1997-10-14T09:00:00 + #1997-10-21T09:00:00 + #1997-10-28T09:00:00 + #1997-11-04T09:00:00)) + (vevent + summary: + "Weekly until December 24, 1997" + dtstart: + "19970902T090000" + rrule: + "FREQ=WEEKLY;UNTIL=19971224T000000Z" + x-summary: + "varje vecka, till och med den 24 december, 1997 kl. 0:00" + x-set: + (list #1997-09-02T09:00:00 + #1997-09-09T09:00:00 + #1997-09-16T09:00:00 + #1997-09-23T09:00:00 + #1997-09-30T09:00:00 + #1997-10-07T09:00:00 + #1997-10-14T09:00:00 + #1997-10-21T09:00:00 + #1997-10-28T09:00:00 + #1997-11-04T09:00:00 + #1997-11-11T09:00:00 + #1997-11-18T09:00:00 + #1997-11-25T09:00:00 + #1997-12-02T09:00:00 + #1997-12-09T09:00:00 + #1997-12-16T09:00:00 + #1997-12-23T09:00:00)) + (vevent + summary: + "Every other week - forever" + dtstart: + "19970902T090000" + rrule: + "FREQ=WEEKLY;INTERVAL=2;WKST=SU" + x-summary: + "varannan vecka" + x-set: + (list #1997-09-02T09:00:00 + #1997-09-16T09:00:00 + #1997-09-30T09:00:00 + #1997-10-14T09:00:00 + #1997-10-28T09:00:00 + #1997-11-11T09:00:00 + #1997-11-25T09:00:00 + #1997-12-09T09:00:00 + #1997-12-23T09:00:00 + #1998-01-06T09:00:00 + #1998-01-20T09:00:00 + #1998-02-03T09:00:00 + #1998-02-17T09:00:00 + #1998-03-03T09:00:00 + #1998-03-17T09:00:00 + #1998-03-31T09:00:00 + #1998-04-14T09:00:00 + #1998-04-28T09:00:00 + #1998-05-12T09:00:00 + #1998-05-26T09:00:00)) + (vevent + summary: + "Weekly on Tuesday and Thursday for five weeks (alt 1)" + dtstart: + "19970902T090000" + rrule: + "FREQ=WEEKLY;UNTIL=19971007T000000Z;WKST=SU;BYDAY=TU,TH" + x-summary: + "varje tisdag & torsdag, till och med den 07 oktober, 1997 kl. 0:00" + x-set: + (list #1997-09-02T09:00:00 + #1997-09-04T09:00:00 + #1997-09-09T09:00:00 + #1997-09-11T09:00:00 + #1997-09-16T09:00:00 + #1997-09-18T09:00:00 + #1997-09-23T09:00:00 + #1997-09-25T09:00:00 + #1997-09-30T09:00:00 + #1997-10-02T09:00:00)) + (vevent + summary: + "Weekly on Tuesday and Thursday for five weeks (alt 2)" + dtstart: + "19970902T090000" + rrule: + "FREQ=WEEKLY;COUNT=10;WKST=SU;BYDAY=TU,TH" + x-summary: + "varje tisdag & torsdag, totalt 10 gånger" + x-set: + (list #1997-09-02T09:00:00 + #1997-09-04T09:00:00 + #1997-09-09T09:00:00 + #1997-09-11T09:00:00 + #1997-09-16T09:00:00 + #1997-09-18T09:00:00 + #1997-09-23T09:00:00 + #1997-09-25T09:00:00 + #1997-09-30T09:00:00 + #1997-10-02T09:00:00)) + (vevent + summary: + "Every other week on Monday, Wednesday, and Friday until December 24, 1997, starting on Monday, September 1, 1997:" + dtstart: + "19970901T090000" + rrule: + "FREQ=WEEKLY;INTERVAL=2;UNTIL=19971224T000000Z;WKST=SU;BYDAY=MO,WE,FR" + x-summary: + "varannan måndag, onsdag & fredag, till och med den 24 december, 1997 kl. 0:00" + x-set: + (list #1997-09-01T09:00:00 + #1997-09-03T09:00:00 + #1997-09-05T09:00:00 + #1997-09-15T09:00:00 + #1997-09-17T09:00:00 + #1997-09-19T09:00:00 + #1997-09-29T09:00:00 + #1997-10-01T09:00:00 + #1997-10-03T09:00:00 + #1997-10-13T09:00:00 + #1997-10-15T09:00:00 + #1997-10-17T09:00:00 + #1997-10-27T09:00:00 + #1997-10-29T09:00:00 + #1997-10-31T09:00:00 + #1997-11-10T09:00:00 + #1997-11-12T09:00:00 + #1997-11-14T09:00:00 + #1997-11-24T09:00:00 + #1997-11-26T09:00:00 + #1997-11-28T09:00:00 + #1997-12-08T09:00:00 + #1997-12-10T09:00:00 + #1997-12-12T09:00:00 + #1997-12-22T09:00:00)) + (vevent + summary: + "Every other week on Tuesday and Thursday, for 8 occurrences" + dtstart: + "19970902T090000" + rrule: + "FREQ=WEEKLY;INTERVAL=2;COUNT=8;WKST=SU;BYDAY=TU,TH" + x-summary: + "varannan tisdag & torsdag, totalt 8 gånger" + x-set: + (list #1997-09-02T09:00:00 + #1997-09-04T09:00:00 + #1997-09-16T09:00:00 + #1997-09-18T09:00:00 + #1997-09-30T09:00:00 + #1997-10-02T09:00:00 + #1997-10-14T09:00:00 + #1997-10-16T09:00:00)) + (vevent + summary: + "Monthly on the first Friday for 10 occurrences" + dtstart: + "19970905T090000" + rrule: + "FREQ=MONTHLY;COUNT=10;BYDAY=1FR" + x-summary: + "första fredagen varje månad, totalt 10 gånger" + x-set: + (list #1997-09-05T09:00:00 + #1997-10-03T09:00:00 + #1997-11-07T09:00:00 + #1997-12-05T09:00:00 + #1998-01-02T09:00:00 + #1998-02-06T09:00:00 + #1998-03-06T09:00:00 + #1998-04-03T09:00:00 + #1998-05-01T09:00:00 + #1998-06-05T09:00:00)) + (vevent + summary: + "Monthly on the first Friday until December 24, 1997" + dtstart: + "19970905T090000" + rrule: + "FREQ=MONTHLY;UNTIL=19971224T000000Z;BYDAY=1FR" + x-summary: + "första fredagen varje månad, till och med den 24 december, 1997 kl. 0:00" + x-set: + (list #1997-09-05T09:00:00 + #1997-10-03T09:00:00 + #1997-11-07T09:00:00 + #1997-12-05T09:00:00)) + (vevent + summary: + "Every other month on the first and last Sunday of the month for 10 occurrences" + dtstart: + "19970907T090000" + rrule: + "FREQ=MONTHLY;INTERVAL=2;COUNT=10;BYDAY=1SU,-1SU" + x-summary: + "första söndagen samt sista söndagen varannan månad, totalt 10 gånger" + x-set: + (list #1997-09-07T09:00:00 + #1997-09-28T09:00:00 + #1997-11-02T09:00:00 + #1997-11-30T09:00:00 + #1998-01-04T09:00:00 + #1998-01-25T09:00:00 + #1998-03-01T09:00:00 + #1998-03-29T09:00:00 + #1998-05-03T09:00:00 + #1998-05-31T09:00:00)) + (vevent + summary: + "Monthly on the second-to-last Monday of the month for 6 months" + dtstart: + "19970922T090000" + rrule: + "FREQ=MONTHLY;COUNT=6;BYDAY=-2MO" + x-summary: + "näst sista måndagen varje månad, totalt 6 gånger" + x-set: + (list #1997-09-22T09:00:00 + #1997-10-20T09:00:00 + #1997-11-17T09:00:00 + #1997-12-22T09:00:00 + #1998-01-19T09:00:00 + #1998-02-16T09:00:00)) + (vevent + summary: + "Monthly on the third-to-the-last day of the month, forever" + dtstart: + "19970928T090000" + rrule: + "FREQ=MONTHLY;BYMONTHDAY=-3" + x-summary: + "den tredje sista varje månad" + x-set: + (list #1997-09-28T09:00:00 + #1997-10-29T09:00:00 + #1997-11-28T09:00:00 + #1997-12-29T09:00:00 + #1998-01-29T09:00:00 + #1998-02-26T09:00:00 + #1998-03-29T09:00:00 + #1998-04-28T09:00:00 + #1998-05-29T09:00:00 + #1998-06-28T09:00:00 + #1998-07-29T09:00:00 + #1998-08-29T09:00:00 + #1998-09-28T09:00:00 + #1998-10-29T09:00:00 + #1998-11-28T09:00:00 + #1998-12-29T09:00:00 + #1999-01-29T09:00:00 + #1999-02-26T09:00:00 + #1999-03-29T09:00:00 + #1999-04-28T09:00:00)) + (vevent + summary: + "Monthly on the 2nd and 15th of the month for 10 occurrences" + dtstart: + "19970902T090000" + rrule: + "FREQ=MONTHLY;COUNT=10;BYMONTHDAY=2,15" + x-summary: + "den andre & femtonde varje månad, totalt 10 gånger" + x-set: + (list #1997-09-02T09:00:00 + #1997-09-15T09:00:00 + #1997-10-02T09:00:00 + #1997-10-15T09:00:00 + #1997-11-02T09:00:00 + #1997-11-15T09:00:00 + #1997-12-02T09:00:00 + #1997-12-15T09:00:00 + #1998-01-02T09:00:00 + #1998-01-15T09:00:00)) + (vevent + summary: + "Monthly on the first and last day of the month for 10 occurrences" + dtstart: + "19970930T090000" + rrule: + "FREQ=MONTHLY;COUNT=10;BYMONTHDAY=1,-1" + x-summary: + "den förste & sista varje månad, totalt 10 gånger" + x-set: + (list #1997-09-30T09:00:00 + #1997-10-01T09:00:00 + #1997-10-31T09:00:00 + #1997-11-01T09:00:00 + #1997-11-30T09:00:00 + #1997-12-01T09:00:00 + #1997-12-31T09:00:00 + #1998-01-01T09:00:00 + #1998-01-31T09:00:00 + #1998-03-01T09:00:00)) + (vevent + summary: + "Every 18 months on the 10th thru 15th of the month for 10 occurrences" + dtstart: + "19970910T090000" + rrule: + "FREQ=MONTHLY;INTERVAL=18;COUNT=10;BYMONTHDAY=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: + (list #1997-09-10T09:00:00 + #1997-09-11T09:00:00 + #1997-09-12T09:00:00 + #1997-09-13T09:00:00 + #1997-09-14T09:00:00 + #1997-09-15T09:00:00 + #1999-03-10T09:00:00 + #1999-03-11T09:00:00 + #1999-03-12T09:00:00 + #1999-03-13T09:00:00)) + (vevent + summary: + "Every Tuesday, every other month" + dtstart: + "19970902T090000" + rrule: + "FREQ=MONTHLY;INTERVAL=2;BYDAY=TU" + x-summary: + "varje tisdag varannan månad" + x-set: + (list #1997-09-02T09:00:00 + #1997-09-09T09:00:00 + #1997-09-16T09:00:00 + #1997-09-23T09:00:00 + #1997-09-30T09:00:00 + #1997-11-04T09:00:00 + #1997-11-11T09:00:00 + #1997-11-18T09:00:00 + #1997-11-25T09:00:00 + #1998-01-06T09:00:00 + #1998-01-13T09:00:00 + #1998-01-20T09:00:00 + #1998-01-27T09:00:00 + #1998-03-03T09:00:00 + #1998-03-10T09:00:00 + #1998-03-17T09:00:00 + #1998-03-24T09:00:00 + #1998-03-31T09:00:00 + #1998-05-05T09:00:00 + #1998-05-12T09:00:00)) + (vevent + 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" + rrule: + "FREQ=YEARLY;COUNT=10;BYMONTH=6,7" + x-summary: + "juni & juli, årligen, totalt 10 gånger" + x-set: + (list #1997-06-10T09:00:00 + #1997-07-10T09:00:00 + #1998-06-10T09:00:00 + #1998-07-10T09:00:00 + #1999-06-10T09:00:00 + #1999-07-10T09:00:00 + #2000-06-10T09:00:00 + #2000-07-10T09:00:00 + #2001-06-10T09:00:00 + #2001-07-10T09:00:00)) + (vevent + summary: + "Every other year on January, February, and March for 10 occurrences" + dtstart: + "19970310T090000" + rrule: + "FREQ=YEARLY;INTERVAL=2;COUNT=10;BYMONTH=1,2,3" + x-summary: + "januari, februari & mars vartannat år, totalt 10 gånger" + x-set: + (list #1997-03-10T09:00:00 + #1999-01-10T09:00:00 + #1999-02-10T09:00:00 + #1999-03-10T09:00:00 + #2001-01-10T09:00:00 + #2001-02-10T09:00:00 + #2001-03-10T09:00:00 + #2003-01-10T09:00:00 + #2003-02-10T09:00:00 + #2003-03-10T09:00:00)) + (vevent + summary: + "Every third year on the 1st, 100th, and 200th day for 10 occurrences" + dtstart: + "19970101T090000" + rrule: + "FREQ=YEARLY;INTERVAL=3;COUNT=10;BYYEARDAY=1,100,200" + x-summary: + "dag 1, 100 & 200 vart tredje år, totalt 10 gånger" + x-set: + (list #1997-01-01T09:00:00 + #1997-04-10T09:00:00 + #1997-07-19T09:00:00 + #2000-01-01T09:00:00 + #2000-04-09T09:00:00 + #2000-07-18T09:00:00 + #2003-01-01T09:00:00 + #2003-04-10T09:00:00 + #2003-07-19T09:00:00 + #2006-01-01T09:00:00)) + (vevent + summary: + "Every 20th Monday of the year, forever" + dtstart: + "19970519T090000" + rrule: + "FREQ=YEARLY;BYDAY=20MO" + x-summary: + "tjugonde måndagen, årligen" + x-set: + (list #1997-05-19T09:00:00 + #1998-05-18T09:00:00 + #1999-05-17T09:00:00 + #2000-05-15T09:00:00 + #2001-05-14T09:00:00 + #2002-05-20T09:00:00 + #2003-05-19T09:00:00 + #2004-05-17T09:00:00 + #2005-05-16T09:00:00 + #2006-05-15T09:00:00 + #2007-05-14T09:00:00 + #2008-05-19T09:00:00 + #2009-05-18T09:00:00 + #2010-05-17T09:00:00 + #2011-05-16T09:00:00 + #2012-05-14T09:00:00 + #2013-05-20T09:00:00 + #2014-05-19T09:00:00 + #2015-05-18T09:00:00 + #2016-05-16T09:00:00)) + (vevent + summary: + "Monday of week number 20 (where the default start of the week is Monday), forever" + dtstart: + "19970512T090000" + rrule: + "FREQ=YEARLY;BYWEEKNO=20;BYDAY=MO" + x-summary: + "varje måndag v.20, årligen" + x-set: + (list #1997-05-12T09:00:00 + #1998-05-11T09:00:00 + #1999-05-17T09:00:00 + #2000-05-15T09:00:00 + #2001-05-14T09:00:00 + #2002-05-13T09:00:00 + #2003-05-12T09:00:00 + #2004-05-10T09:00:00 + #2005-05-16T09:00:00 + #2006-05-15T09:00:00 + #2007-05-14T09:00:00 + #2008-05-12T09:00:00 + #2009-05-11T09:00:00 + #2010-05-17T09:00:00 + #2011-05-16T09:00:00 + #2012-05-14T09:00:00 + #2013-05-13T09:00:00 + #2014-05-12T09:00:00 + #2015-05-11T09:00:00 + #2016-05-16T09:00:00)) + (vevent + summary: + "Every Thursday in March, forever" + dtstart: + "19970313T090000" + rrule: + "FREQ=YEARLY;BYMONTH=3;BYDAY=TH" + x-summary: + "varje torsdag i mars, årligen" + x-set: + (list #1997-03-13T09:00:00 + #1997-03-20T09:00:00 + #1997-03-27T09:00:00 + #1998-03-05T09:00:00 + #1998-03-12T09:00:00 + #1998-03-19T09:00:00 + #1998-03-26T09:00:00 + #1999-03-04T09:00:00 + #1999-03-11T09:00:00 + #1999-03-18T09:00:00 + #1999-03-25T09:00:00 + #2000-03-02T09:00:00 + #2000-03-09T09:00:00 + #2000-03-16T09:00:00 + #2000-03-23T09:00:00 + #2000-03-30T09:00:00 + #2001-03-01T09:00:00 + #2001-03-08T09:00:00 + #2001-03-15T09:00:00 + #2001-03-22T09:00:00)) + (vevent + summary: + "Every Thursday, but only during June, July, and August, forever" + dtstart: + "19970605T090000" + rrule: + "FREQ=YEARLY;BYDAY=TH;BYMONTH=6,7,8" + x-summary: + "varje torsdag i juni, juli & augusti, årligen" + x-set: + (list #1997-06-05T09:00:00 + #1997-06-12T09:00:00 + #1997-06-19T09:00:00 + #1997-06-26T09:00:00 + #1997-07-03T09:00:00 + #1997-07-10T09:00:00 + #1997-07-17T09:00:00 + #1997-07-24T09:00:00 + #1997-07-31T09:00:00 + #1997-08-07T09:00:00 + #1997-08-14T09:00:00 + #1997-08-21T09:00:00 + #1997-08-28T09:00:00 + #1998-06-04T09:00:00 + #1998-06-11T09:00:00 + #1998-06-18T09:00:00 + #1998-06-25T09:00:00 + #1998-07-02T09:00:00 + #1998-07-09T09:00:00 + #1998-07-16T09:00:00)) + (vevent + summary: + "Every Friday the 13th, forever" + dtstart: + "19970902T090000" + exdate: + "19970902T090000" + rrule: + "FREQ=MONTHLY;BYDAY=FR;BYMONTHDAY=13" + x-summary: + "varje fredag den trettonde varje månad" + x-set: + (list #1998-02-13T09:00:00 + #1998-03-13T09:00:00 + #1998-11-13T09:00:00 + #1999-08-13T09:00:00 + #2000-10-13T09:00:00 + #2001-04-13T09:00:00 + #2001-07-13T09:00:00 + #2002-09-13T09:00:00 + #2002-12-13T09:00:00 + #2003-06-13T09:00:00 + #2004-02-13T09:00:00 + #2004-08-13T09:00:00 + #2005-05-13T09:00:00 + #2006-01-13T09:00:00 + #2006-10-13T09:00:00 + #2007-04-13T09:00:00 + #2007-07-13T09:00:00 + #2008-06-13T09:00:00 + #2009-02-13T09:00:00 + #2009-03-13T09:00:00)) + (vevent + summary: + "The first Saturday that follows the first Sunday of the month, forever" + dtstart: + "19970913T090000" + rrule: + "FREQ=MONTHLY;BYDAY=SA;BYMONTHDAY=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: + (list #1997-09-13T09:00:00 + #1997-10-11T09:00:00 + #1997-11-08T09:00:00 + #1997-12-13T09:00:00 + #1998-01-10T09:00:00 + #1998-02-07T09:00:00 + #1998-03-07T09:00:00 + #1998-04-11T09:00:00 + #1998-05-09T09:00:00 + #1998-06-13T09:00:00 + #1998-07-11T09:00:00 + #1998-08-08T09:00:00 + #1998-09-12T09:00:00 + #1998-10-10T09:00:00 + #1998-11-07T09:00:00 + #1998-12-12T09:00:00 + #1999-01-09T09:00:00 + #1999-02-13T09:00:00 + #1999-03-13T09:00:00 + #1999-04-10T09:00:00)) + (vevent + summary: + "Every 4 years, the first Tuesday after a Monday in November,\nver (U.S. Presidential Election day)" + dtstart: + "19961105T090000" + rrule: + "FREQ=YEARLY;INTERVAL=4;BYMONTH=11;BYDAY=TU;BYMONTHDAY=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: + (list #1996-11-05T09:00:00 + #2000-11-07T09:00:00 + #2004-11-02T09:00:00 + #2008-11-04T09:00:00 + #2012-11-06T09:00:00 + #2016-11-08T09:00:00 + #2020-11-03T09:00:00 + #2024-11-05T09:00:00 + #2028-11-07T09:00:00 + #2032-11-02T09:00:00 + #2036-11-04T09:00:00 + #2040-11-06T09:00:00 + #2044-11-08T09:00:00 + #2048-11-03T09:00:00 + #2052-11-05T09:00:00 + #2056-11-07T09:00:00 + #2060-11-02T09:00:00 + #2064-11-04T09:00:00 + #2068-11-06T09:00:00 + #2072-11-08T09:00:00)) + (vevent + summary: + "The third instance into the month of one of Tuesday, Wednesday, or Thursday, for the next 3 months" + dtstart: + "19970904T090000" + rrule: + "FREQ=MONTHLY;COUNT=3;BYDAY=TU,WE,TH;BYSETPOS=3" + x-summary: + "NOT YET IMPLEMENTED" + x-set: + (list #1997-09-04T09:00:00 + #1997-10-07T09:00:00 + #1997-11-06T09:00:00)) + (vevent + summary: + "The second-to-last weekday of the month" + dtstart: + "19970929T090000" + rrule: + "FREQ=MONTHLY;BYDAY=MO,TU,WE,TH,FR;BYSETPOS=-2" + x-summary: + "NOT YET IMPLEMENTED" + x-set: + (list #1997-09-29T09:00:00 + #1997-10-30T09:00:00 + #1997-11-27T09:00:00 + #1997-12-30T09:00:00 + #1998-01-29T09:00:00)) + (vevent + summary: + "Every 3 hours from 9:00 AM to 5:00 PM on a specific day" + dtstart: + "19970902T090000" + rrule: + "FREQ=HOURLY;INTERVAL=3;UNTIL=19970902T170000Z" + x-summary: + "var tredje timme, till och med den 02 september, 1997 kl. 17:00" + x-set: + (list #1997-09-02T09:00:00 + #1997-09-02T12:00:00 + #1997-09-02T15:00:00)) + (vevent + summary: + "Every 15 minutes for 6 occurrences" + dtstart: + "19970902T090000" + rrule: + "FREQ=MINUTELY;INTERVAL=15;COUNT=6" + x-summary: + "varje kvart, totalt 6 gånger" + x-set: + (list #1997-09-02T09:00:00 + #1997-09-02T09:15:00 + #1997-09-02T09:30:00 + #1997-09-02T09:45:00 + #1997-09-02T10:00:00 + #1997-09-02T10:15:00)) + (vevent + summary: + "Every hour and a half for 4 occurrences" + dtstart: + "19970902T090000" + rrule: + "FREQ=MINUTELY;INTERVAL=90;COUNT=4" + x-summary: + "var sjätte kvart, totalt 4 gånger" + x-set: + (list #1997-09-02T09:00:00 + #1997-09-02T10:30:00 + #1997-09-02T12:00:00 + #1997-09-02T13:30:00)) + (vevent + summary: + "Every 20 minutes from 9:00 AM to 4:40 PM every day (alt 1)" + dtstart: + "19970902T090000" + rrule: + "FREQ=DAILY;BYHOUR=9,10,11,12,13,14,15,16;BYMINUTE=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: + (list #1997-09-02T09:00:00 + #1997-09-02T09:20:00 + #1997-09-02T09:40:00 + #1997-09-02T10:00:00 + #1997-09-02T10:20:00 + #1997-09-02T10:40:00 + #1997-09-02T11:00:00 + #1997-09-02T11:20:00 + #1997-09-02T11:40:00 + #1997-09-02T12:00:00 + #1997-09-02T12:20:00 + #1997-09-02T12:40:00 + #1997-09-02T13:00:00 + #1997-09-02T13:20:00 + #1997-09-02T13:40:00 + #1997-09-02T14:00:00 + #1997-09-02T14:20:00 + #1997-09-02T14:40:00 + #1997-09-02T15:00:00 + #1997-09-02T15:20:00)) + (vevent + summary: + "Every 20 minutes from 9:00 AM to 4:40 PM every day (alt 2)" + dtstart: + "19970902T090000" + rrule: + "FREQ=MINUTELY;INTERVAL=20;BYHOUR=9,10,11,12,13,14,15,16" + x-summary: + "var tjugonde minut kl. 9, 10, 11, 12, 13, 14, 15 & 16" + x-set: + (list #1997-09-02T09:00:00 + #1997-09-02T09:20:00 + #1997-09-02T09:40:00 + #1997-09-02T10:00:00 + #1997-09-02T10:20:00 + #1997-09-02T10:40:00 + #1997-09-02T11:00:00 + #1997-09-02T11:20:00 + #1997-09-02T11:40:00 + #1997-09-02T12:00:00 + #1997-09-02T12:20:00 + #1997-09-02T12:40:00 + #1997-09-02T13:00:00 + #1997-09-02T13:20:00 + #1997-09-02T13:40:00 + #1997-09-02T14:00:00 + #1997-09-02T14:20:00 + #1997-09-02T14:40:00 + #1997-09-02T15:00:00 + #1997-09-02T15:20:00)) + (vevent + summary: + "An example where the days generated makes a difference because of WKST" + dtstart: + "19970805T090000" + rrule: + "FREQ=WEEKLY;INTERVAL=2;COUNT=4;BYDAY=TU,SU;WKST=MO" + x-summary: + "varannan tisdag & söndag, totalt 4 gånger" + x-set: + (list #1997-08-05T09:00:00 + #1997-08-10T09:00:00 + #1997-08-19T09:00:00 + #1997-08-24T09:00:00)) + (vevent + summary: + "changing only WKST from MO to SU, yields different results.." + dtstart: + "19970805T090000" + rrule: + "FREQ=WEEKLY;INTERVAL=2;COUNT=4;BYDAY=TU,SU;WKST=SU" + x-summary: + "varannan tisdag & söndag, totalt 4 gånger" + x-set: + (list #1997-08-05T09:00:00 + #1997-08-17T09:00:00 + #1997-08-19T09:00:00 + #1997-08-31T09:00:00)) + (vevent + summary: + "An example where an invalid date (i.e., February 30) is ignored" + dtstart: + "20070115T090000" + rrule: + "FREQ=MONTHLY;BYMONTHDAY=15,30;COUNT=5" + x-summary: + "den femtonde & tretionde varje månad, totalt 5 gånger" + x-set: + (list #2007-01-15T09:00:00 + #2007-01-30T09:00:00 + #2007-02-15T09:00:00 + #2007-03-15T09:00:00 + #2007-03-30T09:00:00)) + (vevent + summary: + "Every Friday & Wednesday the 13th, forever" + dtstart: + "19970902T090000" + exdate: + "19970902T090000" + rrule: + "FREQ=MONTHLY;BYDAY=FR,WE;BYMONTHDAY=13" + x-summary: + "varje onsdag & fredag den trettonde varje månad" + x-set: + (list #1998-02-13T09:00:00 + #1998-03-13T09:00:00 + #1998-05-13T09:00:00 + #1998-11-13T09:00:00 + #1999-01-13T09:00:00 + #1999-08-13T09:00:00 + #1999-10-13T09:00:00 + #2000-09-13T09:00:00 + #2000-10-13T09:00:00 + #2000-12-13T09:00:00 + #2001-04-13T09:00:00 + #2001-06-13T09:00:00 + #2001-07-13T09:00:00 + #2002-02-13T09:00:00 + #2002-03-13T09:00:00 + #2002-09-13T09:00:00 + #2002-11-13T09:00:00 + #2002-12-13T09:00:00 + #2003-06-13T09:00:00 + #2003-08-13T09:00:00)) + (vevent + summary: + "Monday & Wednesday of week number 20 (where the default start of the week is Monday), forever" + dtstart: + "19970512T090000" + rrule: + "FREQ=YEARLY;BYWEEKNO=20;BYDAY=MO,WE" + x-summary: + "varje onsdag & måndag v.20, årligen" + x-set: + (list #1997-05-12T09:00:00 + #1997-05-14T09:00:00 + #1998-05-11T09:00:00 + #1998-05-13T09:00:00 + #1999-05-17T09:00:00 + #1999-05-19T09:00:00 + #2000-05-15T09:00:00 + #2000-05-17T09:00:00 + #2001-05-14T09:00:00 + #2001-05-16T09:00:00 + #2002-05-13T09:00:00 + #2002-05-15T09:00:00 + #2003-05-12T09:00:00 + #2003-05-14T09:00:00 + #2004-05-10T09:00:00 + #2004-05-12T09:00:00 + #2005-05-16T09:00:00 + #2005-05-18T09:00:00 + #2006-05-15T09:00:00 + #2006-05-17T09:00:00)))) + + diff --git a/tests/recurrence-simple.scm b/tests/test/recurrence-simple.scm index d5a35802..3ddcb5ad 100644 --- a/tests/recurrence-simple.scm +++ b/tests/test/recurrence-simple.scm @@ -4,19 +4,24 @@ ;; most are instead in recurrence-advanced.scm. ;;; Code: -(((srfi srfi-41) stream-take stream-map stream->list stream-car) - ((datetime) day-stream mon) - ((vcomponent base) extract prop) - - ((hnh util exceptions) warnings-are-errors warning-handler) - ((guile) format @@) - - ((vcomponent formats ical parse) parse-calendar) - ((vcomponent formats xcal parse) sxcal->vcomponent) - ((vcomponent recurrence) - parse-recurrence-rule - make-recur-rule - generate-recurrence-set)) +(define-module (test recurrence-simple) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module ((srfi srfi-41) + :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 ((hnh util exceptions) + :select (warnings-are-errors warning-handler)) + :use-module ((vcomponent formats ical parse) + :select (parse-calendar)) + :use-module ((vcomponent formats xcal parse) + :select (sxcal->vcomponent)) + :use-module ((vcomponent recurrence) + :select (parse-recurrence-rule + make-recur-rule + generate-recurrence-set))) ;;; Test that basic parsing or recurrence rules work. @@ -24,28 +29,28 @@ (parse-recurrence-rule "FREQ=HOURLY")) (test-equal (make-recur-rule freq: 'HOURLY count: 3 interval: 1 wkst: mon) - (parse-recurrence-rule "FREQ=HOURLY;COUNT=3")) + (parse-recurrence-rule "FREQ=HOURLY;COUNT=3")) ;;; Test that recurrence rule parsing fails where appropriate (parameterize ((warnings-are-errors #t) - (warning-handler identity)) ; silence warnings - (test-error "Invalid FREQ" 'warning - (parse-recurrence-rule "FREQ=ERR;COUNT=3")) - - (test-error "Negative COUNT" 'warning - (parse-recurrence-rule "FREQ=HOURLY;COUNT=-1")) - + (warning-handler (lambda _ ""))) + (test-error "Invalid FREQ" + 'warning + (parse-recurrence-rule "FREQ=ERR;COUNT=3")) + (test-error "Negative COUNT" + 'warning + (parse-recurrence-rule "FREQ=HOURLY;COUNT=-1")) (test-error "Invalid COUNT" - 'wrong-type-argument - (parse-recurrence-rule "FREQ=HOURLY;COUNT=err")) ) + 'wrong-type-arg + (parse-recurrence-rule "FREQ=HOURLY;COUNT=err"))) ;;; Test that basic recurrence works ;;; also see the neighbour test file recurrence.scm for more tests. (define ev (call-with-input-string - "BEGIN:VEVENT + "BEGIN:VEVENT DTSTART;VALUE=DATE:20190302 RRULE:FREQ=DAILY END:VEVENT" @@ -55,44 +60,44 @@ END:VEVENT" (stream-car (generate-recurrence-set ev))) (test-assert "Generate some" - (stream->list (stream-take 5 (generate-recurrence-set ev)))) + (stream->list + (stream-take 5 (generate-recurrence-set ev)))) (test-equal "Generate First" (stream->list - 5 (stream-map (extract 'DTSTART) - (generate-recurrence-set ev))) - (stream->list - 5 (day-stream - (prop ev 'DTSTART)))) + 5 + (stream-map + (extract 'DTSTART) + (generate-recurrence-set ev))) + (stream->list 5 (day-stream (prop ev 'DTSTART)))) ;; We run the exact same thing a secound time, since I had an error with ;; that during development. (test-equal "Generate Again" (stream->list - (stream-take - 5 (stream-map (extract 'DTSTART) - (generate-recurrence-set ev)))) + (stream-take + 5 + (stream-map + (extract 'DTSTART) + (generate-recurrence-set ev)))) (stream->list - (stream-take - 5 (day-stream - (prop ev 'DTSTART))))) - + (stream-take 5 (day-stream (prop ev 'DTSTART))))) (define ev (call-with-input-string - "BEGIN:VEVENT + "BEGIN:VEVENT DTSTART:20190302T100000 RRULE:FREQ=DAILY END:VEVENT" - parse-calendar) ) + parse-calendar)) (test-assert "daily 10:00" (stream-car (generate-recurrence-set ev))) (define ev (call-with-input-string - "BEGIN:VEVENT + "BEGIN:VEVENT DTSTART:20190302T100000 DTEND:20190302T120000 RRULE:FREQ=DAILY @@ -104,7 +109,7 @@ END:VEVENT" (define ev (call-with-input-string - "BEGIN:VEVENT + "BEGIN:VEVENT DTSTART:20190302T100000 DTEND:20190302T120000 RRULE:FREQ=WEEKLY @@ -116,7 +121,7 @@ END:VEVENT" (define ev (call-with-input-string - "BEGIN:VEVENT + "BEGIN:VEVENT DTSTART;TZID=Europe/Stockholm:20190302T100000 DTEND;TZID=Europe/Stockholm:20190302T120000 RRULE:FREQ=WEEKLY @@ -128,7 +133,7 @@ END:VEVENT" (define ev (call-with-input-string - "BEGIN:VEVENT + "BEGIN:VEVENT DTSTART;TZID=Europe/Stockholm:20190302T100000 DTEND;TZID=Europe/Stockholm:20190302T120000 RRULE:FREQ=WEEKLY @@ -141,7 +146,7 @@ END:VEVENT" (define ev (call-with-input-string - "BEGIN:VEVENT + "BEGIN:VEVENT DTSTART;TZID=Europe/Stockholm:20190302T100000 RRULE:FREQ=WEEKLY DTEND;TZID=Europe/Stockholm:20190302T120000 @@ -155,46 +160,45 @@ END:VEVENT" (define ev (call-with-input-string - "BEGIN:VEVENT + "BEGIN:VEVENT DTSTART:20180117T170000 RRULE:FREQ=WEEKLY LOCATION:~ END:VEVENT" - parse-calendar)) + parse-calendar)) (test-assert "Just location" (stream-car (generate-recurrence-set ev))) - (define ev - (call-with-input-string - "BEGIN:VEVENT + (call-with-input-string + "BEGIN:VEVENT DTSTART;TZID=Europe/Stockholm:20180117T170000 DTEND;TZID=Europe/Stockholm:20180117T200000 RRULE:FREQ=WEEKLY END:VEVENT" - parse-calendar)) + parse-calendar)) (test-assert "Same times" (stream-car (generate-recurrence-set ev))) (define ev - (call-with-input-string - "BEGIN:VEVENT + (call-with-input-string + "BEGIN:VEVENT DTSTART;TZID=Europe/Stockholm:20180117T170000 RRULE:FREQ=WEEKLY DTEND;TZID=Europe/Stockholm:20180117T200000 SEQUENCE:1 LOCATION:~ END:VEVENT" - parse-calendar)) + parse-calendar)) ;; errer in dtend ? (test-assert "Full test" (stream-car (generate-recurrence-set ev))) -;;; Tests that exceptions (in the recurrence-id meaning) +;;; Tests that exceptions (in the recurrence-id meaning) ;;; in recurrence sets are handled correctly. ;;; TODO Is however far from done. @@ -205,21 +209,27 @@ END:VEVENT" (children (vevent (properties - (summary (text "Changing type on Recurrence-id.")) + (summary + (text "Changing type on Recurrence-id.")) (uid (text ,uid)) (dtstart (date "20090127")))) (vevent (properties - (summary (text "Changing type on Recurrence-id.")) + (summary + (text "Changing type on Recurrence-id.")) (uid (text ,uid)) - (dtstart (params (TZID "Europe/Stockholm")) - (date-time "20100127T120000")) + (dtstart + (params (TZID "Europe/Stockholm")) + (date-time "20100127T120000")) (recurrence-id (date "20100127")) - (summary "This instance only has a time component"))))) + (summary + "This instance only has a time component"))))) (define ev - (call-with-input-string - (format #f "BEGIN:VCALENDAR + (call-with-input-string + (format + #f + "BEGIN:VCALENDAR BEGIN:VEVENT SUMMARY:Changing type on Recurrence-id. UID:~a @@ -233,9 +243,9 @@ RECURRENCE-ID;VALUE=DATE:20100127 SUMMARY:This instance only has a time component END:VEVENT END:VCALENDAR" - uid uid) - parse-calendar)) - + uid + uid) + parse-calendar)) (test-assert "Changing type on Recurrence id." (stream->list 10 (generate-recurrence-set ev))) @@ -243,31 +253,31 @@ END:VCALENDAR" ;;; Earlier I failed to actually parse the recurrence parts, in short, 1 ≠ "1". (test-assert "Test that xcal recur rules are parseable" - ((@@ (vcomponent formats xcal parse) handle-value) - 'recur 'props-are-unused-for-recur - '((freq "WEEKLY") - (interval "1") - (wkst "MO")))) + ((@@ (vcomponent formats xcal parse) handle-value) + 'recur + 'props-are-unused-for-recur + '((freq "WEEKLY") (interval "1") (wkst "MO")))) (define ev (sxcal->vcomponent - '(vevent - (properties - (summary (text "reptest")) - (dtend (date-time "2021-01-13T02:00:00")) - (dtstart (date-time "2021-01-13T01:00:00")) - (uid (text "RNW198S6QANQPV1C4FDNFH6ER1VZX6KXEYNB")) - (rrule (recur (freq "WEEKLY") - (interval "1") - (wkst "MO"))) - (dtstamp (date-time "2021-01-13T01:42:20Z")) - (sequence (integer "0"))) - (components)))) + '(vevent + (properties + (summary (text "reptest")) + (dtend (date-time "2021-01-13T02:00:00")) + (dtstart (date-time "2021-01-13T01:00:00")) + (uid (text "RNW198S6QANQPV1C4FDNFH6ER1VZX6KXEYNB")) + (rrule (recur (freq "WEEKLY") + (interval "1") + (wkst "MO"))) + (dtstamp (date-time "2021-01-13T01:42:20Z")) + (sequence (integer "0"))) + (components)))) (test-assert - "Check that recurrence rule commint from xcal also works" + "Check that recurrence rule commint from xcal also works" (generate-recurrence-set ev)) + ;;; TODO test here, for byday parsing, and multiple byday instances in one recur element ;;; TODO which should also test serializing and deserializing to xcal. ;;; For example, the following rules specify every workday diff --git a/tests/test/rrule-serialization.scm b/tests/test/rrule-serialization.scm new file mode 100644 index 00000000..e616c5a2 --- /dev/null +++ b/tests/test/rrule-serialization.scm @@ -0,0 +1,75 @@ +(define-module (test rrule-serialization) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module ((vcomponent recurrence internal) + :select (recur-rule->rrule-string + recur-rule->rrule-sxml + byday)) + :use-module ((vcomponent recurrence parse) + :select (parse-recurrence-rule)) + :use-module ((ice-9 peg) :select (keyword-flatten))) + +(test-equal + "Parse of week day" + '(#f . 3) + ((@@ (vcomponent recurrence parse) parse-day-spec) + "WE")) + +(test-equal + "Parse of week day with positive offset" + '(1 . 3) + ((@@ (vcomponent recurrence parse) parse-day-spec) + "1WE")) + +(test-equal + "Parse of week day with positive offset (and plus)" + '(2 . 3) + ((@@ (vcomponent recurrence parse) parse-day-spec) + "+2WE")) + +(test-equal + "Parse of week day with negative offset" + '(-3 . 3) + ((@@ (vcomponent recurrence parse) parse-day-spec) + "-3WE")) + + +;; numeric prefixes in the BYDAY list is only valid when +;; FREQ={MONTHLY,YEARLY}, but that should be handled in a +;; later stage since we are just testing the parser here. +;; (p. 41) + + +(define field->string + (@@ (vcomponent recurrence internal) + field->string)) + +(let ((rule (parse-recurrence-rule "BYDAY=MO,TU,WE"))) + (test-equal + "Direct return of parsed value" + "MO,TU,WE" + (field->string 'byday (byday rule))) + (test-equal + "Direct return, but as SXML" + '((byday "MO") (byday "TU") (byday "WE")) + (filter + (lambda (pair) (eq? 'byday (car pair))) + (keyword-flatten + '(interval byday wkst) + (recur-rule->rrule-sxml rule))))) + +(let ((rule (parse-recurrence-rule "BYDAY=+1MO,1TU,-2FR"))) + (test-equal + "Direct return of parsed value" + "1MO,1TU,-2FR" + (field->string 'byday (byday rule))) + (test-equal + "Direct return, but as SXML" + '((byday "1MO") (byday "1TU") (byday "-2FR")) + (filter + (lambda (pair) (eq? 'byday (car pair))) + (keyword-flatten + '(interval byday wkst) + (recur-rule->rrule-sxml rule))))) + + diff --git a/tests/server.scm b/tests/test/server.scm index a2b3ea9d..1b5d4775 100644 --- a/tests/server.scm +++ b/tests/test/server.scm @@ -2,8 +2,12 @@ ;; Tests parse-endpoint-string, used for defining server routes. ;;; Code: -(((web http make-routes) parse-endpoint-string) - ((hnh util) let*)) +(define-module (test server) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module ((web http make-routes) + :select (parse-endpoint-string)) + :use-module ((hnh util) :select (let*))) (test-assert "Check that parsing doesn't crash" (parse-endpoint-string "/static/:dir/:file")) @@ -13,7 +17,6 @@ (test-equal "/static/([^/.]+)/([^/.]+)" path) (test-equal '(dir file) args)) - ;; Checks that parsing with custom regex works ;; along with literal periods. (let* ((path args (parse-endpoint-string "/static/:filename{.*}.:ext"))) diff --git a/tests/srfi-41-util.scm b/tests/test/srfi-41-util.scm index 3c2c3f0f..176fb38e 100644 --- a/tests/srfi-41-util.scm +++ b/tests/test/srfi-41-util.scm @@ -3,27 +3,29 @@ ;; Currently only tests stream-paginate. ;;; Code: -(((srfi srfi-41 util) stream-paginate) - ((srfi srfi-41) stream->list stream-ref stream-from - stream-filter stream-car stream) - ((ice-9 sandbox) call-with-time-limit) - ) +(define-module (test srfi-41-util) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module ((srfi srfi-41 util) :select (stream-paginate)) + :use-module ((srfi srfi-41) + :select (stream->list + stream-ref + stream-from + stream-filter + stream-car + stream)) + :use-module ((ice-9 sandbox) :select (call-with-time-limit))) (test-equal "Finite stream" '((0 1 2) (3 4 5) (6 7 8) (9)) - (let ((strm - (stream-paginate (stream 0 1 2 3 4 5 6 7 8 9) - 3))) + (let ((strm (stream-paginate (stream 0 1 2 3 4 5 6 7 8 9) 3))) (map stream->list (stream->list strm)))) - (test-equal "slice of infinite" - '(1000 1001 1002 1003 1004 1005 1006 1007 1008 1009) + '(1000 1001 1002 1003 1004 1005 1006 1007 1008 1009) (let ((strm (stream-paginate (stream-from 0)))) (stream->list (stream-ref strm 100)))) - - (define unique-symbol (gensym)) (test-equal "time out on infinite 'empty' stream" @@ -38,3 +40,5 @@ 0.1 (lambda () (stream-car strm)) (lambda _ unique-symbol)))) + + diff --git a/tests/test/termios.scm b/tests/test/termios.scm new file mode 100644 index 00000000..7f607cc4 --- /dev/null +++ b/tests/test/termios.scm @@ -0,0 +1,48 @@ +;;; Commentary: +;; Tests that my termios function works, at least somewhat. +;; Note that this actually modifies the terminal it's run on, and might fail +;; if the terminal doesn't support the wanted modes. See termios(3). +;; It might also leave the terminal in a broken state if exited prematurely. +;;; Code: + +(define-module (test termios) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module ((hnh util) :select (set!)) + :use-module ((vulgar termios) + :select (make-termios + copy-termios + lflag + tcgetattr! + tcsetattr! + ECHO + ICANON)) + :use-module ((srfi srfi-60) + :select ((bitwise-ior . ||) + (bitwise-not . ~) + (bitwise-and . &)))) + +(define tty (open-input-file "/dev/tty")) + +(define-syntax-rule (&= lvalue val) + (set! lvalue = ((lambda (v) (& v val))))) + +(define t (make-termios)) + +(test-equal 0 (tcgetattr! t tty)) + +(define ifl (lflag t)) + +(define copy (copy-termios t)) + +#!curly-infix {(lflag t) &= (~ (|| ECHO ICANON))} + +(test-equal 0 (tcsetattr! t tty)) + +(test-equal + (& ifl (~ (|| ECHO ICANON))) + (lflag t)) + +(test-equal 0 (tcsetattr! copy tty)) + + diff --git a/tests/test/tz.scm b/tests/test/tz.scm new file mode 100644 index 00000000..245258d0 --- /dev/null +++ b/tests/test/tz.scm @@ -0,0 +1,87 @@ +;;; Commentary: +;; Tests that datetime->unix-time correctly converts between Olssen +;; timezone definitions (e.g. Europe/Stockholm), into correct times +;; and offsets (in unix time). +;; Also indirectly tests the Zone Info Compiler (datetime zic), since +;; the zoneinfo comes from there. +;;; Code: + +(define-module (test tz) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module ((datetime) + :select (parse-ics-datetime + datetime + date + time + datetime->unix-time + unix-time->datetime + get-datetime)) + :use-module ((hnh util) :select (let-env))) + +;; London alternates between +0000 and +0100 +(let-env + ((TZ "Europe/London")) + (test-equal + "London winter" + #2020-01-12T13:30:00 + (get-datetime + (parse-ics-datetime "20200112T133000Z"))) + (test-equal + "London summer" + #2020-06-12T14:30:00 + (get-datetime + (parse-ics-datetime "20200612T133000Z")))) + +;; Stockholm alternates between +0100 and +0200 +(let-env + ((TZ "Europe/Stockholm")) + (test-equal + "Stockholm winter" + #2020-01-12T14:30:00 + (get-datetime + (parse-ics-datetime "20200112T133000Z"))) + (test-equal + "Stockholm summer" + #2020-06-12T15:30:00 + (get-datetime + (parse-ics-datetime "20200612T133000Z")))) + +(test-equal + -10800 + (datetime->unix-time + (parse-ics-datetime + "19700101T000000" + "Europe/Tallinn"))) + +(test-equal + -3600 + (datetime->unix-time + (parse-ics-datetime + "19700101T000000" + "Europe/Stockholm"))) + +(test-equal + 0 + (datetime->unix-time + (parse-ics-datetime "19700101T000000Z"))) + +;; yes, really +(test-equal + -3600 + (datetime->unix-time + (parse-ics-datetime + "19700101T000000" + "Europe/London"))) + +(test-equal + (datetime + date: + #1970-01-01 + time: + #00:00:00 + tz: + "UTC") + (unix-time->datetime 0)) + + diff --git a/tests/test/util.scm b/tests/test/util.scm new file mode 100644 index 00000000..325ca992 --- /dev/null +++ b/tests/test/util.scm @@ -0,0 +1,152 @@ +;;; Commentary: +;; Checks some prodecuders from (hnh util) +;;; Code: + +(define-module (test util) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module ((hnh util) + :select (filter-sorted + set/r! + find-min + find-max + find-extreme + span-upto + iterate + ->string + ->quoted-string + begin1)) + :use-module ((hnh util path) + :select (path-append path-split))) + +(test-equal + "Filter sorted" + '(3 4 5) + (filter-sorted (lambda (x) (<= 3 x 5)) (iota 10))) + +(test-equal + "set/r! = single" + #f + (let ((x #t)) (set/r! x = not))) + +(test-error + 'syntax-error + (test-read-eval-string "(set/r! x err not)")) + +(call-with-values + (lambda () (find-min (iota 10))) + (lambda (extreme rest) + (test-equal "Found correct minimum" 0 extreme) + (test-equal + "Removed \"something\" from the set" + 9 + (length rest)))) + +(call-with-values + (lambda () + (find-max + '("Hello" "Test" "Something long") + string-length)) + (lambda (extreme rest) + (test-equal + "Found the longest string" + "Something long" + extreme) + (test-equal "Removed the string" 2 (length rest)) + (test-assert + "Other members left 1" + (member "Hello" rest)) + (test-assert + "Other members left 2" + (member "Test" rest)))) + +(test-error 'wrong-type-arg (find-extreme '())) + +(call-with-values + (lambda () + (span-upto + 2 + char-numeric? + (string->list "123456"))) + (lambda (head tail) + (test-equal '(#\1 #\2) head) + (test-equal '(#\3 #\4 #\5 #\6) tail))) + +(call-with-values + (lambda () + (span-upto + 2 + char-numeric? + (string->list "H123456"))) + (lambda (head tail) + (test-equal '() head) + (test-equal '(#\H #\1 #\2 #\3 #\4 #\5 #\6) tail))) + +(let ((value #f)) + (test-equal + "begin1 return value" + "Hello" + (begin1 "Hello" (set! value "World"))) + (test-equal "begin1 side effects" "World" value)) + +(let ((x 1)) + (test-eqv "begin1 set! after return" + 1 (begin1 x (set! x 10))) + (test-eqv "Updates value" + 10 x)) + +(test-equal 0 (iterate 1- zero? 10)) + +(test-equal "5" (->string 5)) + +(test-equal "5" (->string "5")) + +(test-equal "5" (->quoted-string 5)) + +(test-equal "\"5\"" (->quoted-string "5")) + +(test-equal + "no slashes" + "home/user" + (path-append "home" "user")) + +(test-equal + "no slashes, absolute" + "/home/user" + (path-append "" "home" "user")) + +(test-equal + "slashes in one component, absolute" + "/home/user" + (path-append "" "/home/" "user")) + +(test-equal + "slashes in one component, absolute due to first" + "/home/user" + (path-append "/home/" "user")) + +(test-equal + "Slashes in both" + "home/user" + (path-append "home/" "/user")) + +(test-equal "root" "/" (path-append "")) + +(test-equal + '("usr" "lib" "test") + (path-split "usr/lib/test")) + +(test-equal + '("usr" "lib" "test") + (path-split "usr/lib/test/")) + +(test-equal + '("" "usr" "lib" "test") + (path-split "/usr/lib/test")) + +(test-equal + '("" "usr" "lib" "test") + (path-split "//usr////lib/test")) + + diff --git a/tests/test/vcomponent-control.scm b/tests/test/vcomponent-control.scm new file mode 100644 index 00000000..f408c8b4 --- /dev/null +++ b/tests/test/vcomponent-control.scm @@ -0,0 +1,36 @@ +;;; Commentary: +;; Tests that with-replaced-properties work. +;;; Code: + +(define-module (test vcomponent-control) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :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)) + +;; 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))) + +(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)))) + + diff --git a/tests/test/vcomponent-datetime.scm b/tests/test/vcomponent-datetime.scm new file mode 100644 index 00000000..073a70ae --- /dev/null +++ b/tests/test/vcomponent-datetime.scm @@ -0,0 +1,49 @@ +;;; Commentary: +;; Tests that event-clamping (checking how long part of an event +;; overlaps another time span) works. +;;; Code: + +(define-module (test vcomponent-datetime) + :use-module (srfi srfi-64) + :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))) + +(define ev + (call-with-input-string + "BEGIN:VEVENT +DTSTART:20200329T170000 +DTEND:20200401T100000 +END:VEVENT" + parse-calendar)) + + +;; |-----------------| test interval +;; |----------| event interval + +(test-equal + "Correct clamping" + (datetime time: (time hour: 7)) ; 2020-03-29T17:00 - 2020-03-30T00:00 + (event-length/clamped + #2020-03-23 ; a time way before the start of the event + #2020-03-29 ; a time slightly after the end of the event + ev)) + +(define utc-ev + (call-with-input-string + "BEGIN:VEVENT +DTSTART:20200329T150000Z +DTEND:20200401T080000Z +END:VEVENT" + parse-calendar)) + +(test-equal + "Correct clamping UTC" + (datetime time: (time hour: 7)) + (event-length/clamped + #2020-03-23 + #2020-03-29 + ev)) + + diff --git a/tests/vcomponent-formats-common-types.scm b/tests/test/vcomponent-formats-common-types.scm index d9c80ff9..4c442461 100644 --- a/tests/vcomponent-formats-common-types.scm +++ b/tests/test/vcomponent-formats-common-types.scm @@ -1,6 +1,10 @@ -(((vcomponent formats common types) - get-parser) - ((datetime) date time datetime)) +(define-module (test vcomponent-formats-common-types) + :use-module (srfi srfi-64) + :use-module (srfi srfi-64 test-error) + :use-module (srfi srfi-88) + :use-module ((vcomponent formats common types) + :select (get-parser)) + :use-module ((datetime) :select (date time datetime))) @@ -18,23 +22,28 @@ -(define parse-cal-address (get-parser 'CAL-ADDRESS)) +(define parse-cal-address + (get-parser 'CAL-ADDRESS)) -(test-equal "Test uri is passthrough" 74 (parse-cal-address #f 74)) +(test-equal "Test uri is passthrough" + 74 (parse-cal-address #f 74)) (define parse-date (get-parser 'DATE)) -(test-equal #2021-12-02 (parse-date #f "20211202")) +(test-equal + #2021-12-02 + (parse-date #f "20211202")) ;; TODO negative test here - - (define parse-datetime (get-parser 'DATE-TIME)) -(test-equal #2021-12-02T10:20:30 - (parse-datetime (make-hash-table) "20211202T102030")) +(test-equal + #2021-12-02T10:20:30 + (parse-datetime + (make-hash-table) + "20211202T102030")) ;; TODO tests with timezones here ;; TODO test -X-HNH-ORIGINAL here @@ -63,19 +72,30 @@ (define parse-integer (get-parser 'INTEGER)) -(test-equal "parse integer" 123456 (parse-integer #f "123456")) -(test-equal "parse bigint" 123451234512345123456666123456 - (parse-integer #f "123451234512345123456666123456")) +(test-equal + "parse integer" + 123456 + (parse-integer #f "123456")) + +(test-equal + "parse bigint" + 123451234512345123456666123456 + (parse-integer + #f + "123451234512345123456666123456")) ;; TODO is this expected behaivour? (test-error 'warning (parse-integer #f "failure")) (test-error - "Non-integers aren't integers" - 'warning (parse-integer #f "1.1")) + "Non-integers aren't integers" + 'warning + (parse-integer #f "1.1")) -(test-equal "But exact floats are" - 1.0 (parse-integer #f "1.0")) +(test-equal + "But exact floats are" + 1.0 + (parse-integer #f "1.0")) @@ -99,7 +119,9 @@ (define parse-time (get-parser 'TIME)) -(test-equal #10:20:30 (parse-time #f "102030")) +(test-equal + #10:20:30 + (parse-time #f "102030")) ;; TODO negative test here @@ -110,6 +132,7 @@ -(define parse-utc-offset (get-parser 'UTC-OFFSET)) +(define parse-utc-offset + (get-parser 'UTC-OFFSET)) ;; TODO diff --git a/tests/test/vcomponent.scm b/tests/test/vcomponent.scm new file mode 100644 index 00000000..d3ee37dc --- /dev/null +++ b/tests/test/vcomponent.scm @@ -0,0 +1,23 @@ +;;; Commentary: +;; Test that vcomponent parsing works at all. +;;; Code: + +(define-module (test vcomponent) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module ((vcomponent base) :select (prop)) + :use-module ((vcomponent formats ical parse) + :select (parse-calendar))) + +(define ev + (call-with-input-string + "BEGIN:DUMMY\nX-KEY:value\nEND:DUMMY" + parse-calendar)) + +(test-assert (eq? #f (prop ev 'MISSING))) + +(test-assert (prop ev 'X-KEY)) + +(test-equal "value" (prop ev 'X-KEY)) + + diff --git a/tests/test/web-server.scm b/tests/test/web-server.scm new file mode 100644 index 00000000..e5a796b6 --- /dev/null +++ b/tests/test/web-server.scm @@ -0,0 +1,116 @@ +;;; Commentary: +;; Checks that HTTP server can start correctly, and that at least some +;; endpoints return correct information. +;; +;; NOTE This test, when ran in as `tests/run-tests --only web-server.scm' +;; segfaults on Guile 2.2.7, but not on Guile 3.0.8. This doesn't happen +;; when it's run as one of all tests. +;;; Code: + +(define-module (test web-server) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module ((calp server routes) :select (make-make-routes)) + :use-module ((web server) :select (run-server)) + :use-module ((ice-9 threads) + :select (call-with-new-thread cancel-thread)) + :use-module ((web client) :select (http-get)) + :use-module ((hnh util) :select (let*)) + :use-module ((web response) :select (response-code response-location)) + :use-module ((web uri) :select (build-uri uri-path)) + :use-module ((guile) + :select (socket + inet-pton + bind + make-socket-address + setsockopt + AF_INET + PF_INET + SOL_SOCKET + SO_REUSEADDR + SOCK_STREAM + current-error-port)) + :use-module ((ice-9 format) :select (format)) + :use-module ((web response) :select (build-response))) + +(define host "127.8.9.5") + +(define sock (socket PF_INET SOCK_STREAM 0)) + +(setsockopt sock SOL_SOCKET SO_REUSEADDR 1) + +(define-values + (port sock) + (let ((addr (inet-pton AF_INET host))) + (let loop ((port 8090)) + (catch 'system-error + (lambda () + (bind sock + (make-socket-address AF_INET addr port)) + (values port sock)) + (lambda (err proc fmt args data) + (if (and (not (null? data)) + ;; errno address already in use + (= 98 (car data))) + (loop (1+ port)) + ;; rethrow + (throw err fmt args data))))))) + +(define server-thread + (call-with-new-thread + (lambda () + (catch #t + (lambda () + (run-server + (make-make-routes) + 'http + `(socket: ,sock))) + (lambda args + (format #f "~s~%" args) + (test-assert "Server Crashed" #f))) + ;; This test should always fail, but should never be run + (test-assert "Server returned unexpectedly" #f)))) + +(let* ((response + _ + (catch 'system-error + (lambda () + (http-get + (build-uri 'http host: host port: port))) + (lambda (err proc fmt args data) + (format + (current-error-port) + "~a (in ~a) ~?~%" + err + proc + fmt + args) + (values (build-response code: 500) #f))))) + (test-eqv + "Basic connect" + 200 + (response-code response))) + +(let* ((response + body + (http-get + (build-uri + 'http + host: + host + port: + port + path: + "/today" + query: + "view=week&date=2020-01-04")))) + (test-eqv + "Redirect" + 302 + (response-code response)) + (test-equal + "Fully specified redirect position" + "/week/2020-01-04.html" + (uri-path (response-location response)))) + +(cancel-thread server-thread) diff --git a/tests/xcal.scm b/tests/test/xcal.scm index 6e80405b..48d43c59 100644 --- a/tests/xcal.scm +++ b/tests/test/xcal.scm @@ -3,18 +3,24 @@ ;; Currently only checks that events survive a round trip. ;;; Code: -(((vcomponent formats xcal parse) sxcal->vcomponent) - ((vcomponent formats xcal output) vcomponent->sxcal) - ((vcomponent formats ical parse) parse-calendar) - ((hnh util) ->) - ((vcomponent base) - parameters prop* children) - ) +(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 + (call-with-input-string + "BEGIN:VCALENDAR VERSION:2.0 PRODID:-//calparse-test BEGIN:VEVENT @@ -34,17 +40,19 @@ END:VCALENDAR" parse-calendar)) (define twice-converted - (-> ev - vcomponent->sxcal - sxcal->vcomponent)) + (-> 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" +(test-equal + "c->x & c->x->c->x" (vcomponent->sxcal ev) (vcomponent->sxcal twice-converted)) -(test-equal "xcal parameters" +(test-equal + "xcal parameters" '((X-TEST-PARAM "10")) - (parameters (prop* (car (children twice-converted)) - 'STATUS))) + (parameters + (prop* (car (children twice-converted)) 'STATUS))) + + diff --git a/tests/test/xml-namespace.scm b/tests/test/xml-namespace.scm new file mode 100644 index 00000000..09402ceb --- /dev/null +++ b/tests/test/xml-namespace.scm @@ -0,0 +1,36 @@ +(define-module (test xml-namespace) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module ((sxml namespace) :select (move-to-namespace))) + +(test-equal + "Move unnamespaced to namespace" + '(NEW:test) + (move-to-namespace '(test) '((#f . NEW)))) + +(test-equal + "Swap namespaces" + '(b:a (a:b)) + (move-to-namespace + '(a:a (b:b)) + '((a . b) (b . a)))) + +(test-equal + "Remove all namespaces" + '(a (b)) + (move-to-namespace '(a:a (b:b)) #f)) + +(test-equal + "Move everything to one namespace" + '(c:a (c:b)) + (move-to-namespace '(a:a (b:b)) 'c)) + +(test-equal + "Partial namespace change" + '(c:a (b:b)) + (move-to-namespace '(a:a (b:b)) '((a . c)))) + +(test-equal + "Remove specific namespace" + '(a:a (b)) + (move-to-namespace '(a:a (b:b)) '((b . #f)))) diff --git a/tests/tz.scm b/tests/tz.scm deleted file mode 100644 index 1cbb1842..00000000 --- a/tests/tz.scm +++ /dev/null @@ -1,57 +0,0 @@ -;;; Commentary: -;; Tests that datetime->unix-time correctly converts between Olssen -;; timezone definitions (e.g. Europe/Stockholm), into correct times -;; and offsets (in unix time). -;; Also indirectly tests the Zone Info Compiler (datetime zic), since -;; the zoneinfo comes from there. -;;; Code: - -(((datetime) - parse-ics-datetime - datetime date time - datetime->unix-time - unix-time->datetime - get-datetime) - ((hnh util) let-env)) - -;; London alternates between +0000 and +0100 -(let-env ((TZ "Europe/London")) - (test-equal "London winter" - #2020-01-12T13:30:00 - (get-datetime (parse-ics-datetime "20200112T133000Z"))) - (test-equal "London summer" - #2020-06-12T14:30:00 - (get-datetime (parse-ics-datetime "20200612T133000Z")))) - -;; Stockholm alternates between +0100 and +0200 -(let-env ((TZ "Europe/Stockholm")) - (test-equal "Stockholm winter" - #2020-01-12T14:30:00 - (get-datetime (parse-ics-datetime "20200112T133000Z"))) - (test-equal "Stockholm summer" - #2020-06-12T15:30:00 - (get-datetime (parse-ics-datetime "20200612T133000Z"))) ) - -(test-equal - -10800 - (datetime->unix-time - (parse-ics-datetime "19700101T000000" "Europe/Tallinn"))) - -(test-equal - -3600 - (datetime->unix-time - (parse-ics-datetime "19700101T000000" "Europe/Stockholm"))) - -(test-equal - 0 - (datetime->unix-time (parse-ics-datetime "19700101T000000Z"))) - -;; yes, really -(test-equal - -3600 - (datetime->unix-time - (parse-ics-datetime "19700101T000000" "Europe/London"))) - -(test-equal - #1970-01-01T00:00:00Z - (unix-time->datetime 0)) diff --git a/tests/util.scm b/tests/util.scm deleted file mode 100644 index 721b7e1b..00000000 --- a/tests/util.scm +++ /dev/null @@ -1,81 +0,0 @@ -;;; Commentary: -;; Checks some prodecuders from (hnh util) -;;; Code: - -(((hnh util) filter-sorted set/r! - find-min find-max span-upto - iterate ->string ->quoted-string - begin1) - ((hnh util path) path-append) - ((ice-9 ports) with-output-to-string) - ) - -(test-equal "Filter sorted" - '(3 4 5) - (filter-sorted (lambda (x) (<= 3 x 5)) (iota 10))) - -(test-equal "set/r! = single" - #f - (let ((x #t)) - (set/r! x = not))) - -(test-error - 'syntax-error - (test-read-eval-string "(set/r! x err not)")) - - -(call-with-values (lambda () (find-min (iota 10))) - (lambda (extreme rest) - (test-equal "Found correct minimum" - 0 extreme) - (test-equal "Removed \"something\" from the set" - 9 (length rest)))) - - -(call-with-values (lambda () (find-max '("Hello" "Test" "Something long") string-length)) - (lambda (extreme rest) - (test-equal "Found the longest string" "Something long" extreme) - (test-equal "Removed the string" 2 (length rest)) - (test-assert "Other members left 1" (member "Hello" rest)) - (test-assert "Other members left 2" (member "Test" rest)))) - - -(test-error 'misc-error (find-extreme '())) - -(call-with-values (lambda () (span-upto 2 char-numeric? (string->list "123456"))) - (lambda (head tail) - (test-equal '(#\1 #\2) head) - (test-equal '(#\3 #\4 #\5 #\6) tail))) - -(call-with-values (lambda () (span-upto 2 char-numeric? (string->list "H123456"))) - (lambda (head tail) - (test-equal '() head) - (test-equal '(#\H #\1 #\2 #\3 #\4 #\5 #\6) tail))) - - -(test-equal "begin1 side effects" "World" - (with-output-to-string - (lambda () - (test-equal "begin1 return value" "Hello" - (begin1 - "Hello" - (display "World")))))) - - -(test-equal 0 (iterate 1- zero? 10)) - - - -(test-equal "5" (->string 5)) -(test-equal "5" (->string "5")) - -(test-equal "5" (->quoted-string 5)) -(test-equal "\"5\"" (->quoted-string "5")) - - -(test-equal "/home/hugo/" - (path-append "/home" "hugo/")) - -(test-equal "/home/hugo/" (path-append "/" "/home/" "/hugo/")) - -(test-equal "/" (path-append "")) diff --git a/tests/vcomponent-control.scm b/tests/vcomponent-control.scm deleted file mode 100644 index 1f4d6801..00000000 --- a/tests/vcomponent-control.scm +++ /dev/null @@ -1,29 +0,0 @@ -;;; Commentary: -;; Tests that with-replaced-properties work. -;;; Code: - -(((vcomponent util control) with-replaced-properties) - ((vcomponent formats ical parse) parse-calendar) - ((vcomponent base) prop)) - - - -(define ev (call-with-input-string - "BEGIN:DUMMY -X-KEY:value -END:DUMMY" - parse-calendar)) - -;; 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))) -(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)))) diff --git a/tests/vcomponent-datetime.scm b/tests/vcomponent-datetime.scm deleted file mode 100644 index 0f410979..00000000 --- a/tests/vcomponent-datetime.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; Commentary: -;; Tests that event-clamping (checking how long part of an event -;; overlaps another time span) works. -;;; Code: - -(((datetime) - date time - datetime) - ((vcomponent datetime) - event-length/clamped) - ((vcomponent formats ical parse) parse-calendar) - ) - -(define ev (call-with-input-string - "BEGIN:VEVENT -DTSTART:20200329T170000 -DTEND:20200401T100000 -END:VEVENT" - parse-calendar)) - -;; |-----------------| test interval -;; |----------| event interval - -(test-equal "Correct clamping" - (datetime time: (time hour: 7)) ; 2020-03-29T17:00 - 2020-03-30T00:00 - (event-length/clamped - #2020-03-23 ; a time way before the start of the event - #2020-03-29 ; a time slightly after the end of the event - ev)) - -(define utc-ev (call-with-input-string - "BEGIN:VEVENT -DTSTART:20200329T150000Z -DTEND:20200401T080000Z -END:VEVENT" - parse-calendar)) - -(test-equal "Correct clamping UTC" - (datetime time: (time hour: 7)) - (event-length/clamped #2020-03-23 #2020-03-29 ev)) diff --git a/tests/vcomponent.scm b/tests/vcomponent.scm deleted file mode 100644 index acdb970b..00000000 --- a/tests/vcomponent.scm +++ /dev/null @@ -1,16 +0,0 @@ -;;; Commentary: -;; Test that vcomponent parsing works at all. -;;; Code: - -(((vcomponent base) prop) - ((vcomponent formats ical parse) parse-calendar)) - -(define ev (call-with-input-string - "BEGIN:DUMMY -X-KEY:value -END:DUMMY" - parse-calendar)) - -(test-assert (eq? #f (prop ev 'MISSING))) -(test-assert (prop ev 'X-KEY)) -(test-equal "value" (prop ev 'X-KEY)) diff --git a/tests/web-server.scm b/tests/web-server.scm deleted file mode 100644 index 73d34317..00000000 --- a/tests/web-server.scm +++ /dev/null @@ -1,43 +0,0 @@ -;;; Commentary: -;; Checks that HTTP server can start correctly, and that at least some -;; endpoints return correct information. -;;; Code: - -(((calp server routes) make-make-routes) - ((web server) run-server) - ((ice-9 threads) call-with-new-thread cancel-thread) - ((web client) http-get) - ((hnh util) let*) - ((web response) response-code response-location) - ((web uri) build-uri uri-path) - ((guile) AF_INET)) - -;; TODO find some free address. -(define port 8090) -(define host "127.8.9.5") - -(define server-thread - (call-with-new-thread - (lambda () - (run-server (make-make-routes) - 'http - `(family: ,AF_INET - host: ,host - port: ,port - )) - ;; This test should always fail, but should never be run - (test-assert "Server returned unexpectedly" #f) - ))) - -(let* ((response body (http-get (build-uri 'http host: host port: port)))) - (test-eqv "Basic connect" 200 (response-code response))) - -(let* ((response body (http-get (build-uri 'http host: host port: port - path: "/today" - query: "view=week&date=2020-01-04")))) - (test-eqv "Redirect" - 302 (response-code response)) - (test-equal "Fully specified redirect position" - "/week/2020-01-04.html" (uri-path (response-location response)))) - -(cancel-thread server-thread) diff --git a/tests/xml-namespace.scm b/tests/xml-namespace.scm deleted file mode 100644 index 74053fd8..00000000 --- a/tests/xml-namespace.scm +++ /dev/null @@ -1,30 +0,0 @@ -(((sxml namespace) - move-to-namespace - )) - - -(test-equal "Move unnamespaced to namespace" - '(NEW:test) - (move-to-namespace '(test) '((#f . NEW)))) - -(test-equal "Swap namespaces" - '(b:a (a:b)) - (move-to-namespace '(a:a (b:b)) '((a . b) (b . a)))) - -(test-equal "Remove all namespaces" - '(a (b)) - (move-to-namespace '(a:a (b:b)) #f)) - -(test-equal "Move everything to one namespace" - '(c:a (c:b)) - (move-to-namespace '(a:a (b:b)) 'c)) - -(test-equal "Partial namespace change" - '(c:a (b:b)) - (move-to-namespace '(a:a (b:b)) - '((a . c)))) - -(test-equal "Remove specific namespace" - '(a:a (b)) - (move-to-namespace '(a:a (b:b)) - '((b . #f)))) |