From d00fea566004e67161ee45246b239fff5d416b0e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 21 Dec 2021 16:17:28 +0100 Subject: Cleanup modules. Primarly this moves all vcompenent input and output code to clearly labeled modules, instead of being spread out. At the same time it also removes a handfull of unused procedures. --- Makefile | 13 +- doc/ref/guile.texi | 103 ++++++++ doc/ref/guile/vcomponent.texi | 117 +++++++++ module/calp/benchmark/parse.scm | 6 +- module/calp/entry-points/benchmark.scm | 4 +- module/calp/entry-points/convert.scm | 8 +- module/calp/entry-points/html.scm | 4 +- module/calp/entry-points/ical.scm | 2 +- module/calp/entry-points/import.scm | 6 +- module/calp/entry-points/server.scm | 3 +- module/calp/entry-points/tidsrapport.scm | 6 +- module/calp/html/components.scm | 1 - module/calp/html/vcomponent.scm | 8 +- module/calp/html/view/calendar.scm | 8 +- module/calp/html/view/calendar/month.scm | 2 +- module/calp/html/view/calendar/week.scm | 2 +- module/calp/html/view/search.scm | 2 +- module/calp/main.scm | 4 +- module/calp/repl.scm | 2 +- module/calp/server/routes.scm | 20 +- module/calp/terminal.scm | 9 +- module/calp/util.scm | 9 + module/calp/util/exceptions.scm | 50 +--- module/datetime/instance.scm | 8 +- module/vcomponent.scm | 11 +- module/vcomponent/base.scm | 10 - module/vcomponent/build.scm | 38 --- module/vcomponent/control.scm | 2 +- module/vcomponent/describe.scm | 44 ---- module/vcomponent/formats/common/types.scm | 139 ++++++++++ module/vcomponent/formats/ical/output.scm | 234 +++++++++++++++++ module/vcomponent/formats/ical/parse.scm | 336 +++++++++++++++++++++++++ module/vcomponent/formats/ical/types.scm | 95 +++++++ module/vcomponent/formats/vdir/parse.scm | 123 +++++++++ module/vcomponent/formats/vdir/save-delete.scm | 40 +++ module/vcomponent/formats/xcal/output.scm | 133 ++++++++++ module/vcomponent/formats/xcal/parse.scm | 259 +++++++++++++++++++ module/vcomponent/formats/xcal/types.scm | 54 ++++ module/vcomponent/group.scm | 71 ------ module/vcomponent/ical/output.scm | 260 ------------------- module/vcomponent/ical/parse.scm | 336 ------------------------- module/vcomponent/ical/types.scm | 95 ------- module/vcomponent/instance.scm | 22 -- module/vcomponent/instance/methods.scm | 138 ---------- module/vcomponent/parse.scm | 35 --- module/vcomponent/parse/types.scm | 140 ----------- module/vcomponent/search.scm | 175 ------------- module/vcomponent/util/control.scm | 36 +++ module/vcomponent/util/describe.scm | 44 ++++ module/vcomponent/util/group.scm | 71 ++++++ module/vcomponent/util/instance.scm | 22 ++ module/vcomponent/util/instance/methods.scm | 139 ++++++++++ module/vcomponent/util/parse-cal-path.scm | 35 +++ module/vcomponent/util/search.scm | 175 +++++++++++++ module/vcomponent/vdir/parse.scm | 123 --------- module/vcomponent/vdir/save-delete.scm | 40 --- module/vcomponent/xcal/output.scm | 133 ---------- module/vcomponent/xcal/parse.scm | 259 ------------------- module/vcomponent/xcal/types.scm | 54 ---- tests/datetime.scm | 2 + tests/param.scm | 2 +- tests/recurrence-simple.scm | 6 +- tests/run-tests.scm | 3 +- tests/vcomponent-control.scm | 4 +- tests/vcomponent-datetime.scm | 2 +- tests/vcomponent-formats-common-types.scm | 115 +++++++++ tests/vcomponent.scm | 2 +- tests/xcal.scm | 6 +- 68 files changed, 2365 insertions(+), 2095 deletions(-) create mode 100644 doc/ref/guile/vcomponent.texi delete mode 100644 module/vcomponent/build.scm delete mode 100644 module/vcomponent/describe.scm create mode 100644 module/vcomponent/formats/common/types.scm create mode 100644 module/vcomponent/formats/ical/output.scm create mode 100644 module/vcomponent/formats/ical/parse.scm create mode 100644 module/vcomponent/formats/ical/types.scm create mode 100644 module/vcomponent/formats/vdir/parse.scm create mode 100644 module/vcomponent/formats/vdir/save-delete.scm create mode 100644 module/vcomponent/formats/xcal/output.scm create mode 100644 module/vcomponent/formats/xcal/parse.scm create mode 100644 module/vcomponent/formats/xcal/types.scm delete mode 100644 module/vcomponent/group.scm delete mode 100644 module/vcomponent/ical/output.scm delete mode 100644 module/vcomponent/ical/parse.scm delete mode 100644 module/vcomponent/ical/types.scm delete mode 100644 module/vcomponent/instance.scm delete mode 100644 module/vcomponent/instance/methods.scm delete mode 100644 module/vcomponent/parse.scm delete mode 100644 module/vcomponent/parse/types.scm delete mode 100644 module/vcomponent/search.scm create mode 100644 module/vcomponent/util/control.scm create mode 100644 module/vcomponent/util/describe.scm create mode 100644 module/vcomponent/util/group.scm create mode 100644 module/vcomponent/util/instance.scm create mode 100644 module/vcomponent/util/instance/methods.scm create mode 100644 module/vcomponent/util/parse-cal-path.scm create mode 100644 module/vcomponent/util/search.scm delete mode 100644 module/vcomponent/vdir/parse.scm delete mode 100644 module/vcomponent/vdir/save-delete.scm delete mode 100644 module/vcomponent/xcal/output.scm delete mode 100644 module/vcomponent/xcal/parse.scm delete mode 100644 module/vcomponent/xcal/types.scm create mode 100644 tests/vcomponent-formats-common-types.scm diff --git a/Makefile b/Makefile index 152ff19e..978ecc85 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ .PHONY: all clean test \ - static + static coverage GUILE_SITE_DIR=$(shell guile -c "(display (%site-dir))") GUILE_CCACHE_DIR=$(shell guile -c "(display (%site-ccache-dir))") @@ -42,5 +42,12 @@ README: README.in test: tests/run-tests.scm - genhtml -o coverage lcov.info - + $(MAKE) coverage + +coverage: + genhtml \ + --show-details \ + --output-directory coverage \ + --prefix $(shell pwd) \ + --no-function-coverage \ + lcov.info diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index b21850bd..f7373767 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -2,6 +2,109 @@ @chapter Guile @include guile/util.texi +@include guile/vcomponent.texi + + +@node Other +@section Other + +@defun get-parser type +@example +get-parser ∷ type-name → hash-table x string → any +type = 'BINARY | 'BOOLEAN | 'CAL-ADDRES | 'DATE | 'DATE-TIME + | 'DURATION | 'FLOAT | 'INTEGER | 'PERIOD | 'RECUR + | 'TEXT | 'TIME | 'URI | 'UTC-OFFSET +@end example + +@ref{ical-get-writer} +@end defun + +@subsection formats ical +@subsubsection output + +@defun component->ical-string component +@end defun + +@defun print-components-with-fake-parent events +@end defun + +@defun print-all-events +@end defun + +@defun print-events-in-interval start end +@end defun + +@subsubsection parse + +@defun parse-calendar port +@end defun + +@subsubsection types + +@defun escape-chars str +Escape ``@verb{|,|}'', ``@verb{|;|}'' and ``@verb{|\|}'' with a +backslash, and encode newlines as ``@verb{|\n|}''. +@end defun + +@defun get-writer type +@anchor{ical-get-writer} +@example +get-writer ∷ type-name → hash-table x value → string +type = 'BINARY | 'BOOLEAN | 'CAL-ADDRES | 'DATE | 'DATE-TIME + | 'DURATION | 'FLOAT | 'INTEGER | 'PERIOD | 'RECUR + | 'TEXT | 'TIME | 'URI | 'UTC-OFFSET +@end example +@end defun + +@subsection formats vdir +@subsubsection parse + +@defun parse-vdir path +@end defun + +@subsubsection save-delete + +@defun save-event event +@end defun + +@defun remove-event event +@end defun + +@subsection formats xcal +@subsubsection output + +@defun vcomponent->sxcal component +@end defun + +@defun ns-wrap +@lisp +(define (ns-wrap sxml) + `(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}. +@end defun + +@subsubsection parse +@defun sxcal->vcomponent sxcal +Parses a vcomponent in sxcal format. Requires that the vcomponent is +the root of the document (fragment), so wrapping icalendar-tags or +similar @emph{must} be removed. + +@example +(vcalendar + (properties ...) + (components ...)) +@end example +@end defun + +@subsubsection types +@defun get-writer type +@ref{ical-get-writer} +@end defun + + +@c -------------------------------------------------- @c TODO This chapter will probably in the future be replaced by a proper diff --git a/doc/ref/guile/vcomponent.texi b/doc/ref/guile/vcomponent.texi new file mode 100644 index 00000000..299ae1da --- /dev/null +++ b/doc/ref/guile/vcomponent.texi @@ -0,0 +1,117 @@ +@node VComponent +@section (vcomponent) + +@defvr {Configuration Variable} calendar-files +List of filepaths +@end defvr + +@defvr {Configuration Variable} default-calendar +@end defvr + +@c ===== Concepts ===== + +@c - internal fields +@c DATA layout +@c how does multiple value work? + +@c ===== BASE ===== + +@deftp {Record Type} + +@c - key +@c - value +@c - parameters +@c - source + +@defun make-vline key value [ht=(make-hash-table)] +@var{ht} is the hash table storing the parameters, can be explicitly +given if need for optimizations arrises. +@end defun + +@defun vline? x +@end defun + +@defun vline-key vline +@end defun + +@deffn {Slot} vline-source vline +@end deffn + +@deffn {Slot} value vline +@end deffn + +@deffn {Slot} param vline key +@end deffn + +@defun delete-parameter! vline key +@end defun + +@defun parameters vline +Key a list of all parameters +@example +((key value) ...) +@end example +@end defun + +@end deftp + + +@deftp {Record Type} + +@defun vcomponent? x +@end defun + +@defun make-vcomponent [type='VIRTUAL] +@end defun + +@defun children vcomponent +Returns all direct children of vcomponent, as a list of vcomponents. +@end defun + +@deffn {Slot} parent vcomonent +@end deffn + +@defun type vcomponent +Returns the type of this vcomponent, as a symbol. Probably one of +@code{VCALENDAR}, @code{VEVENT}, ... +@end defun + +@defun add-child! parent child +Adds child to the parents child list, but also updates the child to +have parent in its parent slot +@end defun + +@deffn {Prop} prop* vcomponent key +@deffnx {Prop} prop vcomponent key +@var{prop*} return the vline object, while @var{prop} is equivalent to +@lisp +(value (prop* vcomponent key)) +@end lisp +@end deffn + +@deffn (extract field) vcomponent +@deffnx (extract* field) vcomponent +Curried version of @var{prop}. +@end deffn + +@defun delete-property! component key +@end defun + +@defun properties comopnent +@example +((key . value) ...) +@end example +@end defun + +@end deftp + +@defun copy-vcomponent vcomponent +@end defun + + +@defun x-property? symb +Does symbol start with ``X-''? +@end defun + +@defun internal-field? symb [prefix="-"] +@end defun diff --git a/module/calp/benchmark/parse.scm b/module/calp/benchmark/parse.scm index f1be66f5..2d7c7b18 100644 --- a/module/calp/benchmark/parse.scm +++ b/module/calp/benchmark/parse.scm @@ -27,7 +27,7 @@ (display "All read\n") (map (lambda ( fullname) (let ((cal (call-with-input-file fullname - (@@ (vcomponent ical parse) read-file)))) + (@@ (vcomponent formats ical parse) read-file)))) cal)) all-calendar-files)))) @@ -36,7 +36,7 @@ (lambda () (display "Tokenized\n") (map (lambda (one-read) - (map (@@ (vcomponent ical parse) tokenize) + (map (@@ (vcomponent formats ical parse) tokenize) one-read)) all-read)))) @@ -44,7 +44,7 @@ (statprof (lambda () (display "Parsed\n") - (map (@@ (vcomponent ical parse) parse) tokenized)))) + (map (@@ (vcomponent formats ical parse) parse) tokenized)))) (format #t "~a files processed~%" (length parsed)) diff --git a/module/calp/entry-points/benchmark.scm b/module/calp/entry-points/benchmark.scm index 851edc59..152a398c 100644 --- a/module/calp/entry-points/benchmark.scm +++ b/module/calp/entry-points/benchmark.scm @@ -5,8 +5,8 @@ :use-module (calp util options) :use-module ((srfi srfi-41) :select (stream->list)) - :use-module ((vcomponent instance methods) :select (get-event-set)) - :autoload (vcomponent instance) (global-event-object) + :use-module ((vcomponent util instance methods) :select (get-event-set)) + :autoload (vcomponent util instance) (global-event-object) :export (main) ) diff --git a/module/calp/entry-points/convert.scm b/module/calp/entry-points/convert.scm index 52ee6b2d..f05b1e7b 100644 --- a/module/calp/entry-points/convert.scm +++ b/module/calp/entry-points/convert.scm @@ -61,11 +61,11 @@ (case (string->symbol from) [(ical) ;; read ical - (@ (vcomponent ical parse) parse-calendar)] + (@ (vcomponent formats ical parse) parse-calendar)] [(xcal) ;; read xcal (compose - (@ (vcomponent xcal parse) sxcal->vcomponent) + (@ (vcomponent formats xcal parse) sxcal->vcomponent) ;; TODO strip *TOP* xml->sxml)] [else (error "")] @@ -76,13 +76,13 @@ [(ical) ;; write ical (lambda (component port) - (display ((@ (vcomponent ical output) component->ical-string) + (display ((@ (vcomponent formats ical output) component->ical-string) component) port))] [(xcal) ;; write xcal (lambda (component port) - (sxml->xml ((@ (vcomponent xcal output) vcomponent->sxcal) + (sxml->xml ((@ (vcomponent formats xcal output) vcomponent->sxcal) component) port))] [else (error "")])) diff --git a/module/calp/entry-points/html.scm b/module/calp/entry-points/html.scm index 39f00979..45e71947 100644 --- a/module/calp/entry-points/html.scm +++ b/module/calp/entry-points/html.scm @@ -14,14 +14,14 @@ :renamer (lambda _ 'render-calendar-wide)) :use-module ((calp html view calendar month) :select (render-calendar-table)) - :use-module ((vcomponent instance methods) + :use-module ((vcomponent util instance methods) :select (get-calendars get-event-set)) :use-module ((sxml simple) :select (sxml->xml)) :use-module ((sxml transformations) :select (href-transformer)) :use-module ((xdg basedir) :prefix xdg-) - :autoload (vcomponent instance) (global-event-object) + :autoload (vcomponent util instance) (global-event-object) ) diff --git a/module/calp/entry-points/ical.scm b/module/calp/entry-points/ical.scm index 15e677b5..0ac01b17 100644 --- a/module/calp/entry-points/ical.scm +++ b/module/calp/entry-points/ical.scm @@ -2,7 +2,7 @@ :export (main) :use-module (calp util) :use-module (calp util options) - :use-module (vcomponent ical output) + :use-module (vcomponent formats ical output) :use-module (ice-9 getopt-long) :use-module (datetime) ) diff --git a/module/calp/entry-points/import.scm b/module/calp/entry-points/import.scm index f25e642f..69c5b687 100644 --- a/module/calp/entry-points/import.scm +++ b/module/calp/entry-points/import.scm @@ -7,9 +7,11 @@ :use-module (srfi srfi-1) ;; TODO FIX ;; :use-module (output vdir) - :use-module ((vcomponent vdir save-delete) :select (save-event)) + :use-module ((vcomponent formats vdir save-delete) :select (save-event)) :use-module (vcomponent) - :autoload (vcomponent instance) (global-event-object) + ;; :use-module ((vcomponent formats ical parse) :select (parse-cal-path)) + :use-module ((vcomponent util parse-cal-path) :select (parse-cal-path)) + :autoload (vcomponent util instance) (global-event-object) ) (define options diff --git a/module/calp/entry-points/server.scm b/module/calp/entry-points/server.scm index a456c292..a7be4afd 100644 --- a/module/calp/entry-points/server.scm +++ b/module/calp/entry-points/server.scm @@ -1,7 +1,6 @@ (define-module (calp entry-points server) :use-module (calp util) :use-module (calp util options) - :use-module (calp util exceptions) :use-module (calp util config) :use-module (srfi srfi-1) @@ -68,7 +67,7 @@ (lambda _ (display "Received SIGUSR1, reloading calendars\n" (current-error-port)) - ((@ (vcomponent instance) reload))))) + ((@ (vcomponent util instance) reload))))) diff --git a/module/calp/entry-points/tidsrapport.scm b/module/calp/entry-points/tidsrapport.scm index 4716ceeb..abdd7aa2 100644 --- a/module/calp/entry-points/tidsrapport.scm +++ b/module/calp/entry-points/tidsrapport.scm @@ -50,8 +50,8 @@ (srfi srfi-1) (vcomponent) (datetime) - (vcomponent instance) - (vcomponent instance methods) + (vcomponent util instance) + (vcomponent util instance methods) (calp util) (ice-9 regex) (ice-9 popen) @@ -66,7 +66,7 @@ (define instances (group-by (compose day as-date (extract 'DTSTART)) (stream->list - ((@ (vcomponent search) execute-query) + ((@ (vcomponent util search) execute-query) (lambda (e) (define d (as-datetime (prop e 'DTSTART))) (define s (date year: year month: month day: 1)) diff --git a/module/calp/html/components.scm b/module/calp/html/components.scm index 1d677c0d..36ec5166 100644 --- a/module/calp/html/components.scm +++ b/module/calp/html/components.scm @@ -1,6 +1,5 @@ (define-module (calp html components) :use-module (calp util) - :use-module (calp util exceptions) :use-module (ice-9 curried-definitions) :use-module (ice-9 match) :export (xhtml-doc) diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm index 3e7cc4dc..2abf370d 100644 --- a/module/calp/html/vcomponent.scm +++ b/module/calp/html/vcomponent.scm @@ -1,11 +1,9 @@ (define-module (calp html vcomponent) :use-module (calp util) - :use-module ((calp util exceptions) :select (warning)) - :use-module (vcomponent) :use-module (srfi srfi-1) - :use-module (srfi srfi-26) :use-module (srfi srfi-41) :use-module ((rnrs io ports) :select (put-bytevector)) + :use-module (vcomponent) :use-module (datetime) :use-module ((text util) :select (add-enumeration-punctuation)) :use-module ((web uri-query) :select (encode-query-parameters)) @@ -16,7 +14,6 @@ :use-module ((crypto) :select (sha256 checksum->string)) :use-module ((xdg basedir) :prefix xdg-) :use-module ((vcomponent recurrence) :select (repeating?)) - :use-module ((vcomponent recurrence internal) :prefix #{rrule:}#) :use-module ((vcomponent datetime output) :select (fmt-time-span format-description @@ -169,7 +166,7 @@ (src ,link)))))))) ;; URI (cond ((and=> (param attach 'FMTTYPE) - (compose (cut string= <> "image" 0 5) car)) + (lambda (p) (string=? (car p) "image" 0 5))) `(img (@ (class "attach") (src ,(value attach))))) (else `(a (@ (class "attach") @@ -289,6 +286,7 @@ "🗎"))))))) +;; TODO possibly unused? (define (repeat-info event) `(div (@ (class "eventtext")) (h2 "Upprepningar") diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm index aa311fcb..64fafb3d 100644 --- a/module/calp/html/view/calendar.scm +++ b/module/calp/html/view/calendar.scm @@ -3,8 +3,6 @@ :use-module (vcomponent) :use-module ((vcomponent datetime) :select (events-between)) - :use-module ((vcomponent build) - :select (vcalendar vevent)) :use-module (datetime) :use-module (calp html components) :use-module ((calp html vcomponent) @@ -26,7 +24,7 @@ :use-module (srfi srfi-41 util) :use-module ((vcomponent recurrence) :select (repeating? generate-recurrence-set)) - :use-module ((vcomponent group) + :use-module ((vcomponent util group) :select (group-stream get-groups-between)) :use-module ((base64) :select (base64encode)) ) @@ -406,6 +404,6 @@ window.default_calendar='~a';" ;; rendered as xcal. (div (@ (style "display:none !important;") (id "xcal-data")) - ,((@ (vcomponent xcal output) ns-wrap) - (map (@ (vcomponent xcal output) vcomponent->sxcal) + ,((@ (vcomponent formats xcal output) ns-wrap) + (map (@ (vcomponent formats xcal output) vcomponent->sxcal) (append regular repeating))))))))) diff --git a/module/calp/html/view/calendar/month.scm b/module/calp/html/view/calendar/month.scm index 02689fd5..6506b0ea 100644 --- a/module/calp/html/view/calendar/month.scm +++ b/module/calp/html/view/calendar/month.scm @@ -12,7 +12,7 @@ events-between)) :use-module ((calp html vcomponent) :select (make-block output-uid)) - :use-module ((vcomponent group) + :use-module ((vcomponent util group) :select (group-stream get-groups-between)) ) diff --git a/module/calp/html/view/calendar/week.scm b/module/calp/html/view/calendar/week.scm index 499de1d6..1714c6c4 100644 --- a/module/calp/html/view/calendar/week.scm +++ b/module/calp/html/view/calendar/week.scm @@ -17,7 +17,7 @@ :select (make-block output-uid) ) ;; :use-module ((calp html components) ;; :select ()) - :use-module ((vcomponent group) + :use-module ((vcomponent util group) :select (group-stream get-groups-between)) ) diff --git a/module/calp/html/view/search.scm b/module/calp/html/view/search.scm index c356baec..b939e7a2 100644 --- a/module/calp/html/view/search.scm +++ b/module/calp/html/view/search.scm @@ -1,7 +1,7 @@ (define-module (calp html view search) :use-module (calp util) :use-module (vcomponent) - :use-module (vcomponent search) + :use-module (vcomponent util search) :use-module ((ice-9 pretty-print) :select (pretty-print)) :use-module ((web uri-query) :select (encode-query-parameters)) :use-module ((calp html components) diff --git a/module/calp/main.scm b/module/calp/main.scm index 1af2861a..a27e4c38 100644 --- a/module/calp/main.scm +++ b/module/calp/main.scm @@ -35,7 +35,7 @@ (description "Start a Guile repl which can be connected to, defaults to the unix socket " (i "/run/user/${UID}/calp-${PID}") ", but it can be bound to any unix or " - "TCP socket. ((@ (vcomponent instance) global-event-object)) " + "TCP socket. ((@ (vcomponent util instance) global-event-object)) " "should contain all events." (br) (b "Should NOT be used in production."))) @@ -260,5 +260,5 @@ ;; and prints them. (map (lambda (it) (with-output-to-port (current-error-port) - (lambda () ((@ (vcomponent describe) describe) it)))) + (lambda () ((@ (vcomponent util describe) describe) it)))) (filter-stack (@ (vcomponent) vcomponent?) (make-stack #t)))))) diff --git a/module/calp/repl.scm b/module/calp/repl.scm index e6fbfe3d..0765b65c 100644 --- a/module/calp/repl.scm +++ b/module/calp/repl.scm @@ -6,7 +6,7 @@ :use-module (system repl server) :use-module (ice-9 regex) :use-module ((calp util hooks) :select (shutdown-hook)) - :use-module (calp util exceptions) + :use-module ((calp util exceptions) :select (warning)) ) (define-public (repl-start address) diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index 08e48714..a435bbc0 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -25,11 +25,11 @@ :use-module (web http make-routes) :use-module (vcomponent) - :use-module (vcomponent search) + :use-module (vcomponent util search) :use-module (datetime) - :use-module (vcomponent ical output) + :use-module (vcomponent formats ical output) - :autoload (vcomponent instance) (global-event-object) + :autoload (vcomponent util instance) (global-event-object) :use-module (calp html view calendar) :use-module ((calp html view search) :select (search-result-page)) @@ -159,7 +159,7 @@ (remove-event global-event-object it) (set! (prop it 'X-HNH-REMOVED) #t) (set! (param (prop* it 'X-HNH-REMOVED) 'VALUE) "BOOLEAN") - (unless ((@ (vcomponent vdir save-delete) save-event) it) + (unless ((@ (vcomponent formats vdir save-delete) save-event) it) (return (build-response code: 500) "Saving event to disk failed.")) (return (build-response code: 204))) @@ -203,7 +203,7 @@ ;; *TOP* node is a required part of the sxml. (let ((event - ((@ (vcomponent xcal parse) sxcal->vcomponent) + ((@ (vcomponent formats xcal parse) sxcal->vcomponent) (catch 'parser-error (lambda () (move-to-namespace @@ -232,7 +232,7 @@ => (lambda (old-event) ;; remove old instance of event from runtime - ((@ (vcomponent instance methods) remove-event) + ((@ (vcomponent util instance methods) remove-event) global-event-object old-event) ;; Add new event to runtime, @@ -252,7 +252,7 @@ ;; 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 vdir save-delete) save-event) event) + (unless ((@ (vcomponent formats vdir save-delete) save-event) event) (return (build-response code: 500) "Saving event to disk failed.")) @@ -266,7 +266,7 @@ ;; 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 vdir save-delete) remove-event) old-event)) + ((@ (vcomponent formats vdir save-delete) remove-event) old-event)) (format (current-error-port) @@ -284,7 +284,7 @@ ;; NOTE Posibly defer save to a later point. ;; That would allow better asyncronous preformance. - (unless ((@ (vcomponent vdir save-delete) save-event) event) + (unless ((@ (vcomponent formats vdir save-delete) save-event) event) (return (build-response code: 500) "Saving event to disk failed.")) @@ -339,7 +339,7 @@ ;; Look into changing how events carry around their ;; parent information, possibly splitting "source parent" ;; and "program parent" into different fields. - (lambda () (sxml->xml ((@ (vcomponent xcal output) vcomponent->sxcal) it))))) + (lambda () (sxml->xml ((@ (vcomponent formats xcal output) vcomponent->sxcal) it))))) (return (build-response code: 404) (format #f "No component with UID=~a found." uid)))) diff --git a/module/calp/terminal.scm b/module/calp/terminal.scm index 4b62895d..1014b94c 100644 --- a/module/calp/terminal.scm +++ b/module/calp/terminal.scm @@ -3,18 +3,17 @@ #:use-module (datetime) #:use-module (srfi srfi-17) #:use-module (srfi srfi-26) - #:use-module (srfi srfi-41) - #:use-module (srfi srfi-41 util) + #:use-module ((srfi srfi-41) :select (stream-car)) #:use-module (calp util) #:use-module (vulgar) #:use-module (vulgar info) #:use-module (vulgar color) #:use-module (vulgar components) - #:use-module (vcomponent group) #:use-module (vcomponent) #:use-module (vcomponent datetime) - #:use-module (vcomponent search) + #:use-module (vcomponent util search) + #:use-module (vcomponent util group) #:use-module (text util) #:use-module (text flow) @@ -28,7 +27,7 @@ #:use-module (oop goops) #:use-module (oop goops describe) - #:autoload (vcomponent instance) (global-event-object) + #:autoload (vcomponent util instance) (global-event-object) #:export (main-loop)) diff --git a/module/calp/util.scm b/module/calp/util.scm index 70091b2e..93e9fd0c 100644 --- a/module/calp/util.scm +++ b/module/calp/util.scm @@ -14,6 +14,7 @@ case* define-many and=>> label print-and-return + begin1 ) #:replace (let* set! define-syntax when unless)) @@ -136,6 +137,14 @@ (let* ((head tail (split-at lst len))) (append head (list tail)))) + +(define-syntax-rule (begin1 first rest ...) + (let ((return first)) + rest ... + return)) + + + (define-macro (print-and-return expr) diff --git a/module/calp/util/exceptions.scm b/module/calp/util/exceptions.scm index 04fc7a67..d9df30ed 100644 --- a/module/calp/util/exceptions.scm +++ b/module/calp/util/exceptions.scm @@ -7,44 +7,7 @@ #:use-module ((system vm frame) :select (frame-bindings binding-ref)) - #:export (throw-returnable - catch-multiple - assert)) - -(define-syntax-rule (throw-returnable symb args ...) - (call/cc (lambda (cont) (throw symb cont args ...)))) - -;; Takes a (non nested) list, and replaces all single underscore -;; symbols with a generated symbol. For macro usage. -(define (multiple-ignore lst) - (map/dotted (lambda (symb) (if (eq? symb '_) (gensym "ignored_") symb)) - lst)) - -;; Like @var{catch}, but multiple handlers can be specified. -;; Each handler is on the form -;; @example -;; [err-symb (args ...) body ...] -;; @end example -;; -;; Only errors with a handler are caught. Error can *not* be given as -;; an early argument. -(define-macro (catch-multiple thunk . cases) - (let catch-recur% ((errs (map car cases)) (cases cases)) - (let* ((v (car errs)) - (case other (partition (lambda (case) (eq? v (car case))) cases)) - (g!rest (gensym "rest"))) - `(catch (quote ,v) - ,(if (null? (cdr errs)) - thunk - `(lambda () ,(catch-recur% (cdr errs) other))) - (lambda (err . ,g!rest) - (apply (lambda ,(let ((param-list (second (car case)))) - (if (not (pair? param-list)) - param-list - (multiple-ignore param-list))) - ,@(cddr (car case))) - ,g!rest)))))) - + #:export (assert)) (define-public warning-handler @@ -81,7 +44,6 @@ [else tree])) - (define-macro (assert form) `(unless ,form (throw 'assertion-error "Assertion failed. ~a expected, ~a got" @@ -89,16 +51,6 @@ ((@@ (calp util exceptions) prettify-tree) (list ,form))))) -(define-syntax catch-warnings - (syntax-rules () - ((_ default body ...) - (parametrize ((warnings-are-errors #t)) - (catch 'warning - (lambda () - body ...) - (lambda _ default)))))) - - (define-public (filter-stack pred? stk) (concatenate (for i in (iota (stack-length stk)) diff --git a/module/datetime/instance.scm b/module/datetime/instance.scm index 6cce17f4..a03916d9 100644 --- a/module/datetime/instance.scm +++ b/module/datetime/instance.scm @@ -9,7 +9,13 @@ (define-config tz-list '() description: "List of default zoneinfo files to be parsed") -;; TODO see (vcomponent instance), this has a similar problem with early load +;; TODO see (vcomponent uil instance), this has a similar problem with early load +;; Takes a list of zoneinfo files relative +;; $XDG-DATA-HOME/calp/zoneinfo, which will probably be +;; '("tzdata/europe" "tzdata/afrifa" ...) +;; and builds all these into one giant zoneinfo database object +;; Note that scripts/tzget should be run beforehand, to download the +;; data (define-once zoneinfo (let ((cache (make-hash-table))) (label self diff --git a/module/vcomponent.scm b/module/vcomponent.scm index 226b740f..c1983977 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -2,14 +2,15 @@ :use-module (calp util) :use-module (calp util config) :use-module (vcomponent base) - :use-module (vcomponent parse) - :use-module (vcomponent instance methods) - :re-export (make-vcomponent - parse-cal-path parse-calendar)) + ;; :use-module ((vcomponent util instance methods) + ;; :select (make-vcomponent)) + :use-module ((vcomponent util parse-cal-path) + :select (parse-cal-path)) + :re-export (make-vcomponent parse-cal-path)) (define cm (module-public-interface (current-module))) (module-use! cm (resolve-interface '(vcomponent base))) -(module-use! cm (resolve-interface '(vcomponent instance methods))) +(module-use! cm (resolve-interface '(vcomponent util instance methods))) (define-config calendar-files '() diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index ab2121a2..66e6534f 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -85,9 +85,6 @@ => (lambda (vline) (set-vline-value! vline value))] [else (hashq-set! ht key (make-vline key value))]))) -(define-public (set-vline! component key vline) - (hashq-set! (get-component-properties component) - key vline)) @@ -158,9 +155,6 @@ (define-public (properties component) (hash-map->list cons (get-component-properties component))) -(define-public (property-keys component) - (hash-map->list (lambda (a _) a) (get-component-properties component))) - (define (copy-vline vline) (make-vline (vline-key vline) (get-vline-value vline) @@ -186,10 +180,6 @@ (define-public (extract* field) (lambda (e) (prop* e field))) -(define-public (key=? k1 k2) - (eq? (as-symb k1) - (as-symb k2))) - (define-public (x-property? symb) (string=? "X-" (string-take (symbol->string symb) 2))) diff --git a/module/vcomponent/build.scm b/module/vcomponent/build.scm deleted file mode 100644 index d49844cc..00000000 --- a/module/vcomponent/build.scm +++ /dev/null @@ -1,38 +0,0 @@ -;;; Commentary: -;; Module for quickly building new vcomponents from code. -;; @example -;; (vevent -;; summary: "This is a test event" -;; dtstart: #2020-01-01T13:37:00 -;; children: (list -;; (valarm ...))) -;;; Code: - -(define-module (vcomponent build) - :use-module (calp util) - :use-module (vcomponent base) - :use-module (srfi srfi-26) - :use-module ((srfi srfi-88) :select (keyword->string))) - -(define-public (vevent . body) (apply vcomponent 'VEVENT body)) -(define-public (vcalendar . body) (apply vcomponent 'VCALENDAR body)) -(define-public (valarm . body) (apply vcomponent 'VALARM body)) - -(define-public (vcomponent tag . rest) - (define v (make-vcomponent tag)) - - (let loop ((rem rest)) - (unless (null? rem) - (if (eq? children: (car rem)) - (for-each (cut add-child! v <>) (cadr rem)) - (let ((symb (-> (car rem) - keyword->string - string-upcase - string->symbol))) - (set! (prop v symb) (cadr rem)))) - (loop (cddr rem)))) - - ;; Return - v) - - diff --git a/module/vcomponent/control.scm b/module/vcomponent/control.scm index 5fe5b8b0..4cb6c708 100644 --- a/module/vcomponent/control.scm +++ b/module/vcomponent/control.scm @@ -1,4 +1,4 @@ -(define-module (vcomponent control) +(define-module (vcomponent util control) #:use-module (calp util) #:use-module (vcomponent) #:export (with-replaced-properties)) diff --git a/module/vcomponent/describe.scm b/module/vcomponent/describe.scm deleted file mode 100644 index af0f9433..00000000 --- a/module/vcomponent/describe.scm +++ /dev/null @@ -1,44 +0,0 @@ -(define-module (vcomponent describe) - :use-module (calp util) - :use-module (vcomponent base) - :use-module (text util)) - -(define*-public (describe vcomponent optional: (indent 0)) - (define ii (make-string indent #\space)) - (define iii (make-string (1+ indent) #\space)) - - (define maxlen (find-max (map - (lambda (a) (string-length (symbol->string a))) - (map car (properties vcomponent))))) - - (format #t "~aBEGIN ~a~%" ii (type vcomponent)) - - (for-each (lambda (kv) - (let* (((key . values) kv)) - (define (out vline) - (format #t "~a~a = ~a" - iii - (trim-to-width (symbol->string key) maxlen) - (trim-to-width - (format #f "~a" (value vline)) - (- 80 indent maxlen))) - (awhen (vline-source vline) - (display ((@@ (vcomponent ical parse) get-line) it))) - (unless (null? (parameters vline)) - (display " ;") - (for (key value) in (parameters vline) - (format #t " ~a=~a" key value))) - (newline)) - (if (list? values) - (for-each out values) - (out values)))) - (sort* (properties vcomponent) - stringstring car))) - - (for child in (children vcomponent) - - (describe child (+ indent 2))) - - (format #t "~aEND ~a~%" ii (type vcomponent))) diff --git a/module/vcomponent/formats/common/types.scm b/module/vcomponent/formats/common/types.scm new file mode 100644 index 00000000..87425c01 --- /dev/null +++ b/module/vcomponent/formats/common/types.scm @@ -0,0 +1,139 @@ +(define-module (vcomponent formats common types) + :use-module (calp util) + :use-module (calp util exceptions) + :use-module (base64) + :use-module (datetime) + :use-module (srfi srfi-9 gnu) + :use-module (datetime timespec) + ) + +;; BINARY +(define (parse-binary props value) + ;; p 30 + (unless (string=? "BASE64" (hashq-ref props 'ENCODING)) + (warning "Binary field not marked ENCODING=BASE64")) + + ;; For icalendar no extra whitespace is allowed in a + ;; binary field (except for line wrapping). This differs + ;; from xcal. + (base64-string->bytevector value)) + +;; BOOLEAN +(define (parse-boolean props value) + (cond + [(string=? "TRUE" value) #t] + [(string=? "FALSE" value) #f] + [else (warning "~a invalid boolean" value)])) + +;; CAL-ADDRESS ⇒ uri + +;; DATE +(define (parse-date props value) + (parse-ics-date value)) + +;; DATE-TIME +(define (parse-datetime props value) + (define parsed + (parse-ics-datetime + value (hashq-ref props 'TZID #f))) + (hashq-set! props '-X-HNH-ORIGINAL parsed) + (get-datetime parsed)) + +;; DURATION +(define (parse-duration props value) + ((@ (vcomponent duration) parse-duration) + value)) + +;; FLOAT +;; Note that this is overly permissive, and flawed. +;; Numbers such as @expr{1/2} is accepted as exact +;; rationals. Some floats are rounded. +(define (parse-float props value) + (string->number value)) + + +;; INTEGER +(define (parse-integer props value) + (let ((n (string->number value))) + (unless (integer? n) + (warning "Non integer as integer")) + n)) + +;; PERIOD +(define (parse-period props value) + (let* (((left right) (string-split value #\/))) + ;; TODO timezones? VALUE=DATE? + (cons (parse-ics-datetime left) + ((if (memv (string-ref right 0) + '(#\P #\+ #\-)) + (@ (vcomponent duration) parse-duration) + parse-ics-datetime) + right)))) + +;; RECUR +(define (parse-recur props value) + ((@ (vcomponent recurrence parse) parse-recurrence-rule) value)) + +;; TEXT +;; TODO quoted strings +(define (parse-text props value) + (let loop ((rem (string->list value)) + (str '()) + (done '())) + (if (null? rem) + (cons (reverse-list->string str) done) + (case (car rem) + [(#\\) + (case (cadr rem) + [(#\n #\N) (loop (cddr rem) (cons #\newline str) done)] + [(#\; #\, #\\) => (lambda (c) (loop (cddr rem) (cons c str) done))] + [else => (lambda (c) (warning "Non-escapable character: ~a" c) + (loop (cddr rem) str done))])] + [(#\,) + (loop (cdr rem) '() (cons (reverse-list->string str) done))] + [else + (loop (cdr rem) (cons (car rem) str) done)])))) + + +;; TIME +(define (parse-time props value) + ;; TODO time can have timezones... + (parse-ics-time value)) + +;; URI +(define (parse-uri props value) + value) + +;; UTC-OFFSET +(define (parse-utc-offset props value) + (make-timespec + (time + hour: (string->number (substring value 1 3)) + minute: (string->number (substring value 3 5)) + second: (if (= 7 (string-length value)) + (string->number (substring value 5 7)) + 0)) + ;; sign + (string->symbol (substring value 0 1)) + #\z)) + + +(define type-parsers (make-hash-table)) +(hashq-set! type-parsers 'BINARY parse-binary) +(hashq-set! type-parsers 'BOOLEAN parse-boolean) +(hashq-set! type-parsers 'CAL-ADDRESS parse-uri) +(hashq-set! type-parsers 'DATE parse-date) +(hashq-set! type-parsers 'DATE-TIME parse-datetime) +(hashq-set! type-parsers 'DURATION parse-duration) +(hashq-set! type-parsers 'FLOAT parse-float) +(hashq-set! type-parsers 'INTEGER parse-integer) +(hashq-set! type-parsers 'PERIOD parse-period) +(hashq-set! type-parsers 'RECUR parse-recur) +(hashq-set! type-parsers 'TEXT parse-text) +(hashq-set! type-parsers 'TIME parse-time) +(hashq-set! type-parsers 'URI parse-uri) +(hashq-set! type-parsers 'UTC-OFFSET parse-utc-offset) + +(define-public (get-parser type) + (or (hashq-ref type-parsers type #f) + (error "No parser for type" type))) diff --git a/module/vcomponent/formats/ical/output.scm b/module/vcomponent/formats/ical/output.scm new file mode 100644 index 00000000..9efac3c4 --- /dev/null +++ b/module/vcomponent/formats/ical/output.scm @@ -0,0 +1,234 @@ +(define-module (vcomponent formats ical output) + :use-module (calp util exceptions) + :use-module (calp util) + :use-module (datetime) + :use-module (datetime zic) + :use-module ((datetime instance) :select (zoneinfo)) + :use-module (glob) + :use-module (ice-9 format) + :use-module (ice-9 match) + :use-module (srfi srfi-1) + :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) + :use-module (vcomponent) + :use-module (vcomponent datetime) + :use-module (vcomponent geo) + :use-module (vcomponent formats ical types) + :use-module (vcomponent recurrence) + :autoload (vcomponent util instance) (global-event-object) + ) + +(define (prodid) + (format #f "-//hugo//calp ~a//EN" + (@ (calp) version))) + + +;; Format value depending on key type. +;; Should NOT emit the key. +(define (value-format key vline) + + (define writer + ;; fields which can hold lists need not be considered here, + ;; since they are split into multiple vlines when we parse them. + (cond + ;; TODO parameters return? One or many‽ + [(and=> (param vline 'VALUE) (compose string->symbol car)) => get-writer] + [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID + CREATED DTSTAMP LAST-MODIFIED + ACKNOWLEDGED EXDATE)) + (get-writer 'DATE-TIME)] + + [(memv key '(TRIGGER DURATION)) + (get-writer 'DURATION)] + + [(memv key '(FREEBUSY)) + (get-writer 'PERIOD)] + + [(memv key '(CATEGORIES RESOURCES)) + (lambda (p v) + (string-join (map (lambda (v) ((get-writer 'TEXT) p v)) + v) + ","))] + + [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION + LOCATION SUMMARY TZID TZNAME + CONTACT RELATED-TO UID + + VERSION)) + (get-writer 'TEXT)] + + [(memv key '(TRANSP + CLASS + PARTSTAT + STATUS + ACTION)) + (lambda (p v) ((get-writer 'TEXT) p (symbol->string v)))] + + [(memv key '(TZOFFSETFROM TZOFFSETTO)) + (get-writer 'UTC-OFFSET)] + + [(memv key '(ATTACH TZURL URL)) + (get-writer 'URI)] + + [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) + (get-writer 'INTEGER)] + + [(memv key '(GEO)) + (lambda (_ v) + (define fl (get-writer 'FLOAT)) + (format #f "~a:~a" + (fl (geo-latitude v)) + (fl (geo-longitude v))))] + + [(memv key '(RRULE)) + (get-writer 'RECUR)] + + [(memv key '(ORGANIZER ATTENDEE)) + (get-writer 'CAL-ADDRESS)] + + [(x-property? key) + (get-writer 'TEXT)] + + [else + (warning "Unknown key ~a" key) + (get-writer 'TEXT)])) + + (catch #t #; 'wrong-type-arg + (lambda () + (writer ((@@ (vcomponent base) get-vline-parameters) vline) + (value vline))) + (lambda (err caller fmt args call-args) + (define fallback-string + (with-output-to-string (lambda () (display value)))) + (warning "key = ~a, caller = ~s, call-args = ~s~%~k~%Falling back to ~s" + key caller call-args fmt args + fallback-string) + fallback-string))) + + +;; Fold long lines to limit width. +;; Since this works in characters, but ics works in bytes +;; this will overshoot when faced with multi-byte characters. +;; But since the line wrapping is mearly a recomendation it's +;; not a problem. +;; Setting the wrap-len to slightly lower than allowed also help +;; us not overshoot. +(define* (ical-line-fold string #:key (wrap-len 70)) + (cond [(< wrap-len (string-length string)) + (format #f "~a\r\n ~a" + (string-take string wrap-len) + (ical-line-fold (string-drop string wrap-len)))] + [else string])) + + + +(define (vline->string vline) + (define key (vline-key vline)) + (ical-line-fold + ;; Expected output: key;p1=v;p3=10:value + (string-append + (symbol->string key) + (string-concatenate + (map (match-lambda + [(? (compose internal-field? car)) ""] + [(key values ...) + (string-append + ";" (symbol->string key) "=" + (string-join (map (compose escape-chars ->string) values) + "," 'infix))]) + (parameters vline))) + ":" (value-format key vline)))) + +(define-public (component->ical-string component) + (format #t "BEGIN:~a\r\n" (type component)) + (for-each + ;; Special cases depending on key. + ;; Value formatting is handled in @code{value-format}. + (match-lambda + + [(? (compose internal-field? car)) 'noop] + + [(key vlines ...) + (for vline in vlines + (display (vline->string vline)) + (display "\r\n"))] + + [(key . vline) + (display (vline->string vline)) + (display "\r\n")]) + (properties component)) + (for-each component->ical-string (children component)) + (format #t "END:~a\r\n" (type component)) + + ;; If we have alternatives, splice them in here. + (cond [(prop component '-X-HNH-ALTERNATIVES) + => (lambda (alts) (hash-map->list (lambda (_ comp) (component->ical-string comp)) + alts))])) + + + +(define (print-header) + (format #t +"BEGIN:VCALENDAR\r +PRODID:~a\r +VERSION:2.0\r +CALSCALE:GREGORIAN\r +" (prodid) +)) + + +(define (print-footer) + (format #t "END:VCALENDAR\r\n")) + +(define (get-tz-names events) + (lset-difference + equal? (lset-union + equal? '("dummy") + (filter-map + (lambda (vline) (and=> (param vline 'TZID) car)) + (filter-map (extract* 'DTSTART) + events))) + '("dummy" "local"))) + + +(define-public (print-components-with-fake-parent events) + + ;; The events are probably sorted before, but until I can guarantee + ;; that we sort them again here. We need them sorted from earliest + ;; and up to send the earliest to zoneinfo->vtimezone + (set! events (sort* events date/-time<=? (extract 'DTSTART))) + + (print-header) + + (when (provided? 'zoneinfo) + (let ((tz-names (get-tz-names events))) + (for-each component->ical-string + ;; TODO we realy should send the earliest event from each timezone here, + ;; instead of just the first. + (map (lambda (name) (zoneinfo->vtimezone + (zoneinfo) + name (car events))) + tz-names)))) + + (for-each component->ical-string events) + + (print-footer)) + + +(define-public (print-all-events) + (print-components-with-fake-parent + (append (get-fixed-events global-event-object) + ;; TODO RECCURENCE-ID exceptions + ;; We just dump all repeating objects, since it's much cheaper to do + ;; it this way than to actually figure out which are applicable for + ;; the given date range. + (get-repeating-events global-event-object)))) + +(define-public (print-events-in-interval start end) + (print-components-with-fake-parent + (append (fixed-events-in-range start end) + ;; TODO RECCURENCE-ID exceptions + ;; We just dump all repeating objects, since it's much cheaper to do + ;; it this way than to actually figure out which are applicable for + ;; the given date range. + (get-repeating-events global-event-object)))) diff --git a/module/vcomponent/formats/ical/parse.scm b/module/vcomponent/formats/ical/parse.scm new file mode 100644 index 00000000..d76044a3 --- /dev/null +++ b/module/vcomponent/formats/ical/parse.scm @@ -0,0 +1,336 @@ +(define-module (vcomponent formats ical parse) + :use-module ((ice-9 rdelim) :select (read-line)) + :use-module (calp util exceptions) + :use-module (calp util) + :use-module (datetime) + :use-module (srfi srfi-1) + :use-module (srfi srfi-26) + :use-module (srfi srfi-9 gnu) + :use-module (vcomponent base) + :use-module (vcomponent geo) + :use-module (vcomponent formats common types) + ) + +(define string->symbol + (let ((ht (make-hash-table 1000))) + (lambda (str) + (or (hash-ref ht str) + (let ((symb ((@ (guile) string->symbol) str))) + (hash-set! ht str symb) + symb))))) + +;; TODO rename to parse-vcomponent, or parse-ical (?). +(define-public (parse-calendar port) + (parse (map tokenize (read-file port)))) + +(define-immutable-record-type + (make-line string file line) + line? + (string get-string) + (file get-file) + (line get-line)) + + +;; port → (list ) +(define (read-file port) + (define fname (port-filename port)) + (let loop ((line-number 1) (done '())) + (let ((ostr (open-output-string))) + (define ret + (let loop ((line (read-line port))) + (if (eof-object? line) + 'eof + (let ((line (string-trim-right line #\return))) + (let ((next (peek-char port))) + (display line ostr) + (cond ((eof-object? next) + 'final-line) + ;; Line Wrapping + ;; If the first character on a line is space (whitespace?) + ;; then it's a continuation line, and should be merged + ;; with the one preceeding it. + ;; TODO if the line is split inside a unicode character + ;; then this produces multiple broken unicode characters. + ;; It could be solved by checking the start of the new line, + ;; and the tail of the old line for broken char + ;; TODO what about other leading whitespace? + ((char=? next #\space) + (read-char port) ; discard leading whitespace + (loop (read-line port))) + (else + ;; (unread-char next) + 'line))))))) + (case ret + ((line) + (let ((str (get-output-string ostr))) + (close-port ostr) + (loop (1+ line-number) + (cons (make-line str fname line-number) + done)))) + ((eof) + (close-port ostr) + (reverse! done)) + ((final-line) + (let ((str (get-output-string ostr))) + (close-port ostr) + (reverse! (cons (make-line str fname line-number) + done)))))))) + +(define-immutable-record-type + (make-tokens metadata data) + tokens? + (metadata get-metadata) ; + (data get-data) ; (key kv ... value) + ) + +;; → +(define (tokenize line-obj) + (define line (get-string line-obj)) + (define colon-idx (string-index line #\:)) + (define semi-idxs + (let loop ((idx 0)) + (aif (string-index line #\; idx colon-idx) + (cons it (loop (1+ it))) + (list colon-idx (string-length line))))) + (make-tokens + line-obj + (map (lambda (start end) + (substring line (1+ start) end)) + (cons -1 semi-idxs) + semi-idxs))) + + +#; +'(ATTACH ATTENDEE CATEGORIES + COMMENT CONTACT EXDATE + REQUEST-STATUS RELATED-TO + RESOURCES RDATE + ;; x-prop + ;; iana-prop + ) + +(define (list-parser symbol) + (let ((parser (get-parser symbol))) + (lambda (params value) + (map (lambda (v) (parser params v)) + (string-split value #\,))))) + +(define* (enum-parser enum optional: (allow-other #t)) + (let ((parser (compose car (get-parser 'TEXT)))) + (lambda (params value) + (let ((vv (parser params value))) + (when (list? vv) + (throw 'parse-error "List in enum field")) + (let ((v (string->symbol vv))) + (unless (memv v enum) + (warning "~a ∉ { ~{~a~^, ~} }" + v enum)) + v))))) + +;; params could be made optional, with an empty hashtable as default +(define (build-vline key value params) + (let ((parser + (cond + [(and=> (hashq-ref params 'VALUE) string->symbol) => get-parser] + + [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID RDATE + CREATED DTSTAMP LAST-MODIFIED + ;; only on VALARM + ACKNOWLEDGED + )) + (get-parser 'DATE-TIME)] + + [(memv key '(EXDATE)) + (list-parser 'DATE-TIME)] + + [(memv key '(TRIGGER DURATION)) + (get-parser 'DURATION)] + + [(memv key '(FREEBUSY)) + (list-parser 'PERIOD)] + + [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION + LOCATION SUMMARY TZID TZNAME + CONTACT RELATED-TO UID)) + (lambda (params value) + (let ((v ((get-parser 'TEXT) params value))) + (unless (= 1 (length v)) + (warning "List in non-list field: ~s" v)) + (string-join v ",")))] + + ;; TEXT, but allow a list + [(memv key '(CATEGORIES RESOURCES)) + ;; TODO An empty value should lead to an empty set + ;; currently it seems to lead to '("") + (get-parser 'TEXT)] + + [(memv key '(VERSION)) + (lambda (params value) + (let ((v (car ((get-parser 'TEXT) params value)))) + (unless (and (string? v) (string=? "2.0" v)) + #f + ;; (warning "File of unsuported version. Proceed with caution") + ) + v))] + + [(memv key '(TRANSP)) + (enum-parser '(OPAQUE TRANSPARENT) #f)] + + [(memv key '(CLASS)) + (enum-parser '(PUBLIC PRIVATE CONFIDENTIAL))] + + [(memv key '(PARTSTAT)) + (enum-parser '(NEEDS-ACTION + ACCEPTED DECLINED + TENTATIVE DELEGATED + IN-PROCESS))] + + [(memv key '(STATUS)) + (enum-parser '(TENTATIVE + CONFIRMED CANCELLED + NEEDS-ACTION COMPLETED IN-PROCESS + DRAFT FINAL CANCELED))] + + [(memv key '(REQUEST-STATUS)) + (throw 'parse-error "TODO Implement REQUEST-STATUS")] + + [(memv key '(ACTION)) + (enum-parser '(AUDIO DISPLAY EMAIL + NONE ; I don't know where NONE is from + ; but it appears to be prevelant. + ))] + + [(memv key '(TZOFFSETFROM TZOFFSETTO)) + (get-parser 'UTC-OFFSET)] + + [(memv key '(ATTACH TZURL URL)) + (get-parser 'URI)] + + [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) + (get-parser 'INTEGER)] + + [(memv key '(GEO)) + ;; two semicolon sepparated floats + (lambda (params value) + (let* (((left right) (string-split value #\;))) + (make-geo ((get-parser 'FLOAT) params left) + ((get-parser 'FLOAT) params right))))] + + [(memv key '(RRULE)) + (get-parser 'RECUR)] + + [(memv key '(ORGANIZER ATTENDEE)) + (get-parser 'CAL-ADDRESS)] + + [(x-property? key) + (compose car (get-parser 'TEXT))] + + [else + (warning "Unknown key ~a" key) + (compose car (get-parser 'TEXT))]))) + + ;; If we produced a list create multiple VLINES from it. + ;; NOTE that the created vlines share parameter tables. + ;; TODO possibly allow vlines to reference each other, to + ;; indicate that all these vlines are the same. + (let ((parsed (parser params value))) + (if (list? parsed) + (apply values + (map (lambda (p) (make-vline key p params)) + parsed)) + (make-vline key parsed params))))) + +;; (parse-itemline '("DTEND" "20200407T130000")) +;; => DTEND +;; => "20200407T130000" +;; => # +(define (parse-itemline itemline) + (define key (string->symbol (car itemline))) + (define parameters (make-hash-table)) + (let loop ((rem (cdr itemline))) + (if (null? (cdr rem)) + (values key (car rem) parameters ) + (let* ((kv (car rem)) + (idx (string-index kv #\=))) + ;; TODO lists in parameters + (hashq-set! parameters (string->symbol (substring kv 0 idx)) + (substring kv (1+ idx))) + (loop (cdr rem)))))) + + +;; (list ) → +(define (parse lst) + (let loop ((lst lst) + (stack '())) + (if (null? lst) + stack + (let* ((head* (car lst)) + (head (get-data head*))) + (catch 'parse-error + (lambda () + (parameterize + ((warning-handler + (lambda (fmt . args) + (let ((linedata (get-metadata head*))) + (format + #f "WARNING parse error around ~a + ~? + line ~a ~a~%" + (get-string linedata) + fmt args + (get-line linedata) + (get-file linedata) + ))))) + (cond [(string=? "BEGIN" (car head)) + (loop (cdr lst) + (cons (make-vcomponent (string->symbol (cadr head))) + stack))] + [(string=? "END" (car head)) + (loop (cdr lst) + (if (null? (cdr stack)) + ;; return + (car stack) + (begin (add-child! (cadr stack) (car stack)) + (cdr stack))))] + [else + (let* ((key value params (parse-itemline head))) + (call-with-values (lambda () (build-vline key value params)) + (lambda vlines + (for vline in vlines + (define key (vline-key vline)) + + (set! (vline-source vline) + (get-metadata head*)) + + ;; See RFC 5545 p.53 for list of all repeating types + ;; (for vcomponent) + (if (memv key '(ATTACH ATTENDEE CATEGORIES + COMMENT CONTACT EXDATE + REQUEST-STATUS RELATED-TO + RESOURCES RDATE + ;; x-prop + ;; iana-prop + )) + (aif (prop* (car stack) key) + (set! (prop* (car stack) key) (cons vline it)) + (set! (prop* (car stack) key) (list vline))) + ;; else + (set! (prop* (car stack) key) vline)))))) + + (loop (cdr lst) stack)]))) + (lambda (err fmt . args) + (let ((linedata (get-metadata head*))) + (display (format + #f "ERROR parse error around ~a + ~? + line ~a ~a + Defaulting to string~%" + (get-string linedata) + fmt args + (get-line linedata) + (get-file linedata)) + (current-error-port)) + (let* ((key value params (parse-itemline head))) + (set! (prop* (car stack) key) + (make-vline key value params)) + (loop (cdr lst) stack))))))))) diff --git a/module/vcomponent/formats/ical/types.scm b/module/vcomponent/formats/ical/types.scm new file mode 100644 index 00000000..d063ca8f --- /dev/null +++ b/module/vcomponent/formats/ical/types.scm @@ -0,0 +1,95 @@ +;; see (vcomponent parse types) +(define-module (vcomponent formats ical types) + :use-module (calp util) + :use-module (calp util exceptions) + :use-module (base64) + :use-module (datetime) + :use-module (datetime timespec)) + +;; TODO shouldn't these really take vline:s? + +(define (write-binary _ value) + (bytevector->base64-string value)) + +(define (write-boolean _ value) + (if value "TRUE" "FALSE")) + +(define (write-date _ value) + (date->string value "~Y~m~d")) + +(define (write-datetime param value) + ;; NOTE We really should output TZID from param here, but + ;; we first need to change so these writers can output + ;; parameters. + (datetime->string (hashq-ref param '-X-HNH-ORIGINAL value) + "~Y~m~dT~H~M~S~Z")) + +(define (write-duration _ value) + ((@ (vcomponent duration) format-duration) value)) + +(define (write-float _ value) + (number->string value)) + +(define (write-integer _ value) + (number->string value)) + +;; TODO +(define (write-period _ value) + (warning "PERIOD writer not yet implemented") + (with-output-to-string + (lambda () (write value)))) + +(define (write-recur _ value) + ((@ (vcomponent recurrence internal) + recur-rule->rrule-string) value)) + +(define-public (escape-chars str) + (define (escape char) + (string #\\ char)) + (string-concatenate + (map (lambda (c) + (case c + ((#\newline) "\\n") + ((#\, #\; #\\) => escape) + (else => string))) + (string->list str)))) + +(define (write-text _ value) + (escape-chars value)) + +(define (write-time _ value) + (time->string value "~H~M~S")) + +(define (write-uri _ value) + value) + + +(define (write-utc-offset _ value) + (with-output-to-string + (lambda () + (display (if (time-zero? (timespec-time value)) + '+ (timespec-sign value))) + (display (time->string (timespec-time value) "~H~M")) + (when (not (zero? (second (timespec-time value)))) + (display (time->string (timespec-time value) "~S")))))) + + +(define type-writers (make-hash-table)) +(hashq-set! type-writers 'BINARY write-binary) +(hashq-set! type-writers 'BOOLEAN write-boolean) +(hashq-set! type-writers 'CAL-ADDRESS write-uri) +(hashq-set! type-writers 'DATE write-date) +(hashq-set! type-writers 'DATE-TIME write-datetime) +(hashq-set! type-writers 'DURATION write-duration) +(hashq-set! type-writers 'FLOAT write-float) +(hashq-set! type-writers 'INTEGER write-integer) +(hashq-set! type-writers 'PERIOD write-period) +(hashq-set! type-writers 'RECUR write-recur) +(hashq-set! type-writers 'TEXT write-text) +(hashq-set! type-writers 'TIME write-time) +(hashq-set! type-writers 'URI write-uri) +(hashq-set! type-writers 'UTC-OFFSET write-utc-offset) + +(define-public (get-writer type) + (or (hashq-ref type-writers type #f) + (error "No writer for type" type))) diff --git a/module/vcomponent/formats/vdir/parse.scm b/module/vcomponent/formats/vdir/parse.scm new file mode 100644 index 00000000..f3810887 --- /dev/null +++ b/module/vcomponent/formats/vdir/parse.scm @@ -0,0 +1,123 @@ +;;; Commentary: +;; Code for parsing vdir's and icalendar files. +;; This module handles the finding of files, while +;; (vcomponent formats parse ical) handles reading data from icalendar files. +;;; Code: + +(define-module (vcomponent formats vdir parse) + :use-module (srfi srfi-1) + + :use-module ((ice-9 hash-table) :select (alist->hash-table)) + :use-module ((ice-9 rdelim) :select (read-line)) + :use-module ((ice-9 ftw) :select (scandir ftw)) + + :use-module (calp util) + :use-module (calp util exceptions) + :use-module (vcomponent base) + + :use-module (vcomponent formats ical parse) + ) + + + + +;; All VTIMEZONE's seem to be in "local" time in relation to +;; themselves. Therefore, a simple comparison should work, +;; and then the TZOFFSETTO properties can be subtd. +(define-public (parse-vdir path) + ;; TODO empty files here cause "#" to appear in the output XML, which is *really* bad. + (let ((color + (catch 'system-error + (lambda () (call-with-input-file (path-append path "color") read-line)) + (const "#FFFFFF"))) + (name + (catch 'system-error + (lambda () (call-with-input-file (path-append path "displayname") read-line)) + (const #f)))) + + (reduce (lambda (item calendar) + + (define-values (events other) (partition (lambda (e) (eq? 'VEVENT (type e))) + (children item))) + + + ;; (assert (eq? 'VCALENDAR (type calendar))) + (assert (eq? 'VCALENDAR (type item))) + + (for child in (children item) + (set! (prop child '-X-HNH-FILENAME) + (prop (parent child) '-X-HNH-FILENAME))) + + ;; NOTE The vdir standard says that each file should contain + ;; EXACTLY one event. It can however contain multiple VEVENT + ;; components, but they are still the same event. + ;; In our case this means exceptions to reccurence rules, which + ;; is set up here, and then later handled in rrule-generate. + ;; NOTE These events also share UID, but are diferentiated + ;; by RECURRENCE-ID. As far as I can tell this goes against + ;; the standard. Section 3.8.4.4. + (case (length events) + [(0) (warning "No events in component~%~a" + (prop item '-X-HNH-FILENAME))] + [(1) + (let ((child (car events))) + (assert (memv (type child) '(VTIMEZONE VEVENT))) + (add-child! calendar child))] + + ;; two or more + [else + ;; Sequence numbers on their own specifies revisions of a + ;; single compenent, incremented by a central authorative + ;; source. In that case simply picking the version with the + ;; highest SEQUENCE number would suffice. However, for + ;; recurring events where each instance is its own VEVENT + ;; they also signify something. + ;; TODO Neither version is handled here (or anywhere else). + + + ;; Multiple VEVENT objects can share a UID if they have + ;; different RECURRENCE-ID fields. This signifies that they + ;; are instances of the same event, similar to RDATE. + ;; Here we first check if we have a component which contains + ;; an RRULE or lacks a RECURRENCE-ID, and uses that as base. + ;; Otherwise we just take the first component as base. + ;; + ;; All alternatives (and the base) is added the the -X-HNH-ALTERNATIVES + ;; property of the base object, to be extracted where needed. + (let* ((head (or (find (extract 'RRULE) events) + (find (negate (extract 'RECURRENCE-ID)) events) + (car events))) + (rest (delete head events eq?))) + + (set! (prop head '-X-HNH-ALTERNATIVES) + (alist->hash-table + (map cons + ;; head is added back to the collection to simplify + ;; generation of recurrences. The recurrence + ;; generation assumes that the base event either + ;; contains an RRULE property, OR is in the + ;; -X-HNH-ALTERNATIVES set. This might produce + ;; duplicates, since the base event might also + ;; get included through an RRULE. This however + ;; is almost a non-problem, since RDATES and RRULES + ;; can already produce duplicates, meaning that + ;; we need to filter duplicates either way. + (map (extract 'RECURRENCE-ID) (cons head rest)) + (cons head rest)))) + (add-child! calendar head))]) + + ;; return + calendar) + (make-vcomponent) + (map #; (@ (ice-9 threads) par-map) + (lambda (fname) + (let ((fullname (path-append path fname))) + (let ((cal (call-with-input-file fullname + parse-calendar))) + (set! (prop cal 'COLOR) color + (prop cal 'NAME) name + (prop cal '-X-HNH-FILENAME) fullname) + cal))) + (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) + (string= "ics" (string-take-right s 3))))))))) + diff --git a/module/vcomponent/formats/vdir/save-delete.scm b/module/vcomponent/formats/vdir/save-delete.scm new file mode 100644 index 00000000..1c70dabf --- /dev/null +++ b/module/vcomponent/formats/vdir/save-delete.scm @@ -0,0 +1,40 @@ +;;; Commentary: +;;; Module for writing components to the vdir storage format. +;;; Currently also has some cases for "big" icalendar files, +;;; but those are currently unsupported. + +;;; TODO generalize save-event and remove-event into a general interface, +;;; which different database backends can implement. Actually, do that for all +;;; loading and writing. + +;;; Code: + +(define-module (vcomponent formats vdir save-delete) + :use-module (calp util) + :use-module ((calp util exceptions) :select (assert)) + :use-module (vcomponent formats ical output) + :use-module (vcomponent) + :use-module ((calp util io) :select (with-atomic-output-to-file)) + ) + + +(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"))) + (with-atomic-output-to-file (prop event '-X-HNH-FILENAME) + (lambda () (print-components-with-fake-parent (list event)))) + uid)) + + +(define-public (remove-event event) + (define calendar (parent event)) + (assert (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE))) + (delete-file (prop event '-X-HNH-FILENAME))) diff --git a/module/vcomponent/formats/xcal/output.scm b/module/vcomponent/formats/xcal/output.scm new file mode 100644 index 00000000..e2cada83 --- /dev/null +++ b/module/vcomponent/formats/xcal/output.scm @@ -0,0 +1,133 @@ +(define-module (vcomponent formats xcal output) + :use-module (calp util) + :use-module (calp util exceptions) + :use-module (vcomponent) + :use-module (vcomponent geo) + :use-module (vcomponent formats xcal types) + :use-module (ice-9 match) + :use-module (datetime) + :use-module (srfi srfi-1) + ) + + +(define (vline->value-tag vline) + (define key (vline-key vline)) + + (define writer + (cond + [(and=> (param vline 'VALUE) (compose string->symbol car)) + => get-writer] + [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID + CREATED DTSTAMP LAST-MODIFIED + ACKNOWLEDGED EXDATE)) + (get-writer 'DATE-TIME)] + + [(memv key '(TRIGGER DURATION)) + (get-writer 'DURATION)] + + [(memv key '(FREEBUSY)) + (get-writer 'PERIOD)] + + [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION + LOCATION SUMMARY TZID TZNAME + CONTACT RELATED-TO UID + + CATEGORIES RESOURCES + + VERSION)) + (get-writer 'TEXT)] + + [(memv key '(TRANSP + CLASS + PARTSTAT + STATUS + ACTION)) + (lambda (p v) ((get-writer 'TEXT) p (symbol->string v)))] + + [(memv key '(TZOFFSETFROM TZOFFSETTO)) + (get-writer 'UTC-OFFSET)] + + [(memv key '(ATTACH TZURL URL)) + (get-writer 'URI)] + + [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) + (get-writer 'INTEGER)] + + [(memv key '(GEO)) + (lambda (_ v) + `(geo + (latitude ,(geo-latitude v)) + (longitude ,(geo-longitude v))))] + + [(memv key '(RRULE)) + (get-writer 'RECUR)] + + [(memv key '(ORGANIZER ATTENDEE)) + (get-writer 'CAL-ADDRESS)] + + [(x-property? key) + (get-writer 'TEXT)] + + [else + (warning "Unknown key ~a" key) + (get-writer 'TEXT)])) + + (writer ((@@ (vcomponent base) get-vline-parameters) vline) (value vline))) + +(define (property->value-tag tag . values) + (if (or (eq? tag 'VALUE) + (internal-field? tag)) + #f + `(,(downcase-symbol tag) + ,@(map (lambda (v) + ;; TODO parameter types!!!! (rfc6321 3.5.) + `(text ,(->string v))) + values)))) + +;; ((key value ...) ...) -> `(parameters , ... ) +(define (parameters-tag parameters) + (define outparams (filter-map + (lambda (x) (apply property->value-tag x)) + parameters)) + + (unless (null? outparams) + `(parameters ,@outparams))) + +(define-public (vcomponent->sxcal component) + + (define tagsymb (downcase-symbol (type component))) + + + (remove null? + `(,tagsymb + ;; only have when it's non-empty. + ,(let ((props + (filter-map + (match-lambda + [(? (compose internal-field? car)) #f] + + [(key vlines ...) + (remove null? + `(,(downcase-symbol key) + ,(parameters-tag (reduce assq-merge + '() (map parameters vlines))) + ,@(for vline in vlines + (vline->value-tag vline))))] + + [(key . vline) + (remove null? + `(,(downcase-symbol key) + ,(parameters-tag (parameters vline)) + ,(vline->value-tag vline)))]) + (properties component)))) + (unless (null? props) + `(properties + ;; NOTE + ;; (x-hnh-calendar-name (text ,(prop (parent component) 'NAME))) + ,@props))) + ,(unless (null? (children component)) + `(components ,@(map vcomponent->sxcal (children component))))))) + +(define-public (ns-wrap sxml) + `(icalendar (@ (xmlns "urn:ietf:params:xml:ns:icalendar-2.0")) + ,sxml)) diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm new file mode 100644 index 00000000..e84f380e --- /dev/null +++ b/module/vcomponent/formats/xcal/parse.scm @@ -0,0 +1,259 @@ +(define-module (vcomponent formats xcal parse) + :use-module (calp util) + :use-module (calp util exceptions) + :use-module (base64) + :use-module (ice-9 match) + :use-module (sxml match) + :use-module (vcomponent) + :use-module (vcomponent geo) + :use-module (vcomponent formats common types) + :use-module (datetime) + :use-module (srfi srfi-1) + ) + +;; symbol, ht, (list a) -> non-list +(define (handle-value type props value) + (case type + + [(binary) + ;; rfc6321 allows whitespace in binary + (base64-string->bytevector + (string-delete char-set:whitespace (car value)))] + + [(boolean) (string=? "true" (car value))] + + ;; TODO possibly trim whitespace on text fields + [(cal-address uri text unknown) (car value)] + + [(date) + ;; TODO this is correct, but ensure remaining types + (hashq-set! props 'VALUE "DATE") + (parse-iso-date (car value))] + + [(date-time) (parse-iso-datetime (car value))] + + [(duration) + ((get-parser 'DURATION) props value)] + + [(float integer) ; (3.0) + (string->number (car value))] + + [(period) + (sxml-match + (cons 'period value) + [(period (start ,start-dt) (end ,end-dt)) + (cons (parse-iso-datetime start-dt) + (parse-iso-datetime end-dt))] + [(period (start ,start-dt) (duration ,duration)) + (cons (parse-iso-datetime start-dt) + ((@ (vcomponent duration) parse-duration) duration))])] + + [(recur) + ;; RFC6221 (xcal) Appendix A 3.3.10 specifies that all components should + ;; come in a specified order, and by extension that all components of the + ;; same type should follow each other. Actually checking that is harder + ;; than to just accept anything in any order. It would also make us less + ;; robust for other implementations with other ideas. + (let ((parse-value-of-that-type + (lambda (type value) + (case type + ((wkst) + ((@ (vcomponent recurrence parse) + rfc->datetime-weekday) + (string->symbol value))) + ((freq) (string->symbol value)) + ((until) + ;; RFC 6321 (xcal), p. 30 specifies type-until as + ;; type-until = element until { + ;; type-date | + ;; type-date-time + ;; } + ;; but doesn't bother defining type-date[-time]... + ;; This is acknowledged in errata 3315 [1], but + ;; it lacks a solution... + ;; Seeing as RFC 7265 (jcal) in Example 2 (p. 16) + ;; show the date as a direct string we will roll + ;; with that here to. + ;; [1]: https://www.rfc-editor.org/errata/eid3315 + (string->date/-time value)) + ((byday) ((@@ (vcomponent recurrence parse) parse-day-spec) value)) + ((count interval bysecond bymunite byhour + bymonthday byyearday byweekno + bymonth bysetpos) + (string->number value)) + (else (throw + 'key-error + "Invalid type ~a, with value ~a" + type value)))))) + + ;; freq until count interval wkst + + (apply (@ (vcomponent recurrence internal) make-recur-rule) + (concatenate + (filter identity + (for key in '(bysecond byminute byhour byday bymonthday + byyearday byweekno bymonth bysetpos + freq until count interval wkst) + (define values (assoc-ref-all value key)) + (if (null? values) + #f + (case key + ;; These fields all have zero or one value + ((freq until count interval wkst) + (list (symbol->keyword key) + (parse-value-of-that-type + key (car (map car values))))) + ;; these fields take lists + ((bysecond byminute byhour byday bymonthday + byyearday byweekno bymonth bysetpos) + (list (symbol->keyword key) + (map (lambda (v) (parse-value-of-that-type key v)) + (map car values))) + ) + (else (throw 'error)))))))))] + + [(time) (parse-iso-time (car value))] + + [(utc-offset) ((get-parser 'UTC-OFFSET) props (car value))] + + [(geo) ; ((long 1) (lat 2)) + (sxml-match + (cons 'geo value) + [(geo (latitude ,x) (longitude ,y)) + ((@ (vcomponent geo) make-geo) x y)])])) + +(define (symbol-upcase symb) + (-> symb + symbol->string + string-upcase + string->symbol)) + +(define (handle-parameters parameters) + + (define ht (make-hash-table)) + + (for param in parameters + (match param + [(ptag (ptype pvalue ...) ...) + ;; TODO parameter type (rfc6321 3.5.) + ;; TODO multi-valued parameters!!! + (hashq-set! ht (symbol-upcase ptag) + (car (concatenate pvalue)))])) + ht) + +(define* (parse-enum str enum optional: (allow-other #t)) + (let ((symb (string->symbol str))) + (unless (memv symb enum) + (warning "~a ∉ { ~{~a~^, ~} }" symb enum)) + symb)) + + +;; symbol non-list -> non-list +(define (handle-tag tag-name data) + (case tag-name + [(request-status) + ;; TODO + (warning "Request status not yet implemented") + #f] + + ((transp) (parse-enum + data '(OPAQUE TRANSPARENT) #f)) + ((class) (parse-enum + data '(PUBLIC PRIVATE CONFIDENTIAL))) + ((partstat) (parse-enum + data '(NEEDS-ACTION ACCEPTED DECLINED TENTATIVE + DELEGATED IN-PROCESS))) + ((status) (parse-enum + data '(TENTATIVE CONFIRMED CANCELLED NEEDS-ACTION COMPLETED + IN-PROCESS DRAFT FINAL CANCELED))) + ((action) (parse-enum + data '(AUDIO DISPLAY EMAIL NONE))) + [else data])) + +;; Note +;; This doesn't verify the inter-field validity of the object, +;; meaning that value(DTSTART) == DATE and value(DTEND) == DATE-TIME +;; are possibilities, which other parts of the code will crash on. +;; TODO +;; since we are feeding user input into this it really should be fixed. +(define-public (sxcal->vcomponent sxcal) + (define type (symbol-upcase (car sxcal))) + (define component (make-vcomponent type)) + + (awhen (assoc-ref sxcal 'properties) + ;; Loop over multi valued fields, creating one vline + ;; for every value. So + ;; KEY;p=1:a,b + ;; would be expanded into + ;; KEY;p=1:a + ;; KEY;p=1:b + (for property in it + (match property + ;; TODO request-status + + [(tag ('parameters parameters ...) + (type value ...) ...) + (let ((params (handle-parameters parameters)) + (tag* (symbol-upcase tag))) + (for (type value) in (zip type value) + ;; ignore empty fields + ;; mostly for + (unless (null? value) + (let () + (define vline + (make-vline tag* + (handle-tag + tag (handle-value type params value)) + params)) + (if (memv tag* '(ATTACH ATTENDEE CATEGORIES + COMMENT CONTACT EXDATE + REQUEST-STATUS RELATED-TO + RESOURCES RDATE + ;; x-prop + ;; iana-prop + )) + (aif (prop* component tag*) + (set! (prop* component tag*) (cons vline it)) + (set! (prop* component tag*) (list vline))) + ;; else + (set! (prop* component tag*) vline)) + ))))] + + [(tag (type value ...) ...) + (for (type value) in (zip type value) + ;; ignore empty fields + ;; mostly for + (unless (null? value) + (let ((params (make-hash-table)) + (tag* (symbol-upcase tag))) + (define vline + (make-vline tag* + (handle-tag + tag (let ((v (handle-value type params value))) + ;; TODO possibly more list fields + (if (eq? tag 'categories) + (string-split v #\,) + v))) + params)) + ;; + + (if (memv tag* '(ATTACH ATTENDEE CATEGORIES + COMMENT CONTACT EXDATE + REQUEST-STATUS RELATED-TO + RESOURCES RDATE + ;; x-prop + ;; iana-prop + )) + (aif (prop* component tag*) + (set! (prop* component tag*) (cons vline it)) + (set! (prop* component tag*) (list vline))) + ;; else + (set! (prop* component tag*) vline)) + )))]))) + + ;; children + (awhen (assoc-ref sxcal 'components) + (for child in (map sxcal->vcomponent it) + (add-child! component child))) + + component) diff --git a/module/vcomponent/formats/xcal/types.scm b/module/vcomponent/formats/xcal/types.scm new file mode 100644 index 00000000..34c7c40d --- /dev/null +++ b/module/vcomponent/formats/xcal/types.scm @@ -0,0 +1,54 @@ +(define-module (vcomponent formats xcal types) + :use-module (calp util) + :use-module (vcomponent formats ical types) + :use-module (datetime) + ) + +(define (write-boolean _ v) + `(boolean ,(if v "true" "false"))) + +(define (write-date _ v) + `(date ,(date->string v "~Y-~m-~d"))) + +(define (write-datetime p v) + `(date-time + ,(datetime->string + (hashq-ref p '-X-HNH-ORIGINAL v) + ;; 'Z' should be included for UTC, + ;; other timezones MUST be specified + ;; in the TZID parameter. + "~Y-~m-~dT~H:~M:~S~Z"))) + +(define (write-time _ v) + `(time ,(time->string v "~H:~M:S"))) + +(define (write-recur _ v) + `(recur ,@((@@ (vcomponent recurrence internal) recur-rule->rrule-sxml) v))) + +;; sepparate since this text shouldn't be escaped +(define (write-text _ v) + ;; TODO out type should be xsd:string. + ;; Look into what that means, and escape + ;; from there + `(text ,v)) + + + +(define sxml-writers (make-hash-table)) +(for simple-type in '(BINARY DURATION CAL-ADDRESS DURATION FLOAT INTEGER + #| TODO PERIOD |# URI UTC-OFFSET) + (hashq-set! sxml-writers simple-type + (lambda (p v) + `(,(downcase-symbol simple-type) + ,(((@ (vcomponent formats ical types) get-writer) simple-type) p v))))) + +(hashq-set! sxml-writers 'BOOLEAN write-boolean) +(hashq-set! sxml-writers 'DATE write-date) +(hashq-set! sxml-writers 'DATE-TIME write-datetime) +(hashq-set! sxml-writers 'TIME write-time) +(hashq-set! sxml-writers 'RECUR write-recur) +(hashq-set! sxml-writers 'TEXT write-text) + +(define-public (get-writer type) + (or (hashq-ref sxml-writers type #f) + (error "No writer for type" type))) diff --git a/module/vcomponent/group.scm b/module/vcomponent/group.scm deleted file mode 100644 index d23787ef..00000000 --- a/module/vcomponent/group.scm +++ /dev/null @@ -1,71 +0,0 @@ -(define-module (vcomponent group) - #:use-module (vcomponent) - #:use-module (vcomponent datetime) - #:use-module (datetime) - #:use-module (srfi srfi-41) - #:use-module (srfi srfi-41 util) - #:export (group-stream get-groups-between)) - -;; TODO templetize this -(define-stream (group-stream in-stream) - (define (ein? day) (lambda (e) (event-contains? e day))) - - (if (stream-null? in-stream) - stream-null - (let loop ((days (day-stream (as-date (prop (stream-car in-stream) 'DTSTART)))) - (stream in-stream)) - (let* ((day (stream-car days)) - (tomorow (stream-car (stream-cdr days)))) - - (let ((head (stream-take-while (ein? day) stream)) - (tail - ;; This is a filter, instead of a stream-span together with head, - ;; since events can span multiple days. - ;; This starts with taking everything which end after the beginning - ;; of tommorow, and finishes with the rest when it finds the first - ;; object which begins tomorow (after midnight, exclusize). - (filter-sorted-stream* - (lambda (e) (date/-timestream - (map (lambda (d) (cons d stream-null)) - (date-range start-date end-date)))] - [(car (stream-car good-part)) - (lambda (d) (date< start-date d)) - => (lambda (d) - (stream-append - (list->stream - (map (lambda (d) (cons d stream-null)) - (date-range start-date - (date- d (date day: 1))))) - good-part))] - [else good-part])) - - -(define-public (group->event-list group) - (stream->list (cdr group))) diff --git a/module/vcomponent/ical/output.scm b/module/vcomponent/ical/output.scm deleted file mode 100644 index bcc6bb1d..00000000 --- a/module/vcomponent/ical/output.scm +++ /dev/null @@ -1,260 +0,0 @@ -(define-module (vcomponent ical output) - :use-module (ice-9 format) - :use-module (ice-9 match) - :use-module (calp util) - :use-module (calp util exceptions) - :use-module (vcomponent) - :use-module (vcomponent datetime) - :use-module (srfi srfi-1) - :use-module (datetime) - :use-module (srfi srfi-41) - :use-module (srfi srfi-41 util) - :use-module (datetime zic) - :use-module (glob) - :use-module (vcomponent recurrence) - :use-module (vcomponent geo) - :use-module (vcomponent ical types) - :autoload (vcomponent instance) (global-event-object) - :use-module ((datetime instance) :select (zoneinfo)) - ) - -(define (prodid) - (format #f "-//hugo//calp ~a//EN" - (@ (calp) version))) - - -;; Format value depending on key type. -;; Should NOT emit the key. -(define (value-format key vline) - - (define writer - ;; fields which can hold lists need not be considered here, - ;; since they are split into multiple vlines when we parse them. - (cond - ;; TODO parameters return? One or many‽ - [(and=> (param vline 'VALUE) (compose string->symbol car)) => get-writer] - [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID - CREATED DTSTAMP LAST-MODIFIED - ACKNOWLEDGED EXDATE)) - (get-writer 'DATE-TIME)] - - [(memv key '(TRIGGER DURATION)) - (get-writer 'DURATION)] - - [(memv key '(FREEBUSY)) - (get-writer 'PERIOD)] - - [(memv key '(CATEGORIES RESOURCES)) - (lambda (p v) - (string-join (map (lambda (v) ((get-writer 'TEXT) p v)) - v) - ","))] - - [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION - LOCATION SUMMARY TZID TZNAME - CONTACT RELATED-TO UID - - VERSION)) - (get-writer 'TEXT)] - - [(memv key '(TRANSP - CLASS - PARTSTAT - STATUS - ACTION)) - (lambda (p v) ((get-writer 'TEXT) p (symbol->string v)))] - - [(memv key '(TZOFFSETFROM TZOFFSETTO)) - (get-writer 'UTC-OFFSET)] - - [(memv key '(ATTACH TZURL URL)) - (get-writer 'URI)] - - [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) - (get-writer 'INTEGER)] - - [(memv key '(GEO)) - (lambda (_ v) - (define fl (get-writer 'FLOAT)) - (format #f "~a:~a" - (fl (geo-latitude v)) - (fl (geo-longitude v))))] - - [(memv key '(RRULE)) - (get-writer 'RECUR)] - - [(memv key '(ORGANIZER ATTENDEE)) - (get-writer 'CAL-ADDRESS)] - - [(x-property? key) - (get-writer 'TEXT)] - - [else - (warning "Unknown key ~a" key) - (get-writer 'TEXT)])) - - (catch #t #; 'wrong-type-arg - (lambda () - (writer ((@@ (vcomponent base) get-vline-parameters) vline) - (value vline))) - (lambda (err caller fmt args call-args) - (define fallback-string - (with-output-to-string (lambda () (display value)))) - (warning "key = ~a, caller = ~s, call-args = ~s~%~k~%Falling back to ~s" - key caller call-args fmt args - fallback-string) - fallback-string))) - - -;; Fold long lines to limit width. -;; Since this works in characters, but ics works in bytes -;; this will overshoot when faced with multi-byte characters. -;; But since the line wrapping is mearly a recomendation it's -;; not a problem. -;; Setting the wrap-len to slightly lower than allowed also help -;; us not overshoot. -(define* (ical-line-fold string #:key (wrap-len 70)) - (cond [(< wrap-len (string-length string)) - (format #f "~a\r\n ~a" - (string-take string wrap-len) - (ical-line-fold (string-drop string wrap-len)))] - [else string])) - - - -(define (vline->string vline) - (define key (vline-key vline)) - (ical-line-fold - ;; Expected output: key;p1=v;p3=10:value - (string-append - (symbol->string key) - (string-concatenate - (map (match-lambda - [(? (compose internal-field? car)) ""] - [(key values ...) - (string-append - ";" (symbol->string key) "=" - (string-join (map (compose escape-chars ->string) values) - "," 'infix))]) - (parameters vline))) - ":" (value-format key vline)))) - -(define-public (component->ical-string component) - (format #t "BEGIN:~a\r\n" (type component)) - (for-each - ;; Special cases depending on key. - ;; Value formatting is handled in @code{value-format}. - (match-lambda - - [(? (compose internal-field? car)) 'noop] - - [(key vlines ...) - (for vline in vlines - (display (vline->string vline)) - (display "\r\n"))] - - [(key . vline) - (display (vline->string vline)) - (display "\r\n")]) - (properties component)) - (for-each component->ical-string (children component)) - (format #t "END:~a\r\n" (type component)) - - ;; If we have alternatives, splice them in here. - (cond [(prop component '-X-HNH-ALTERNATIVES) - => (lambda (alts) (hash-map->list (lambda (_ comp) (component->ical-string comp)) - alts))])) - -;; TODO tzid param on dtstart vs tz field in datetime object -;; TODO remove this, replace with methods from (output vdir) -;; how do we keep these two in sync? -(define (write-event-to-file event calendar-path) - (define cal (make-vcomponent 'VCALENDAR)) - - (set! (prop cal 'PRODID) (prodid) - (prop cal 'VERSION) "2.0" - (prop cal 'CALSCALE) "GREGORIAN") - - (add-child! cal event) - - (awhen (and (provided? 'zoneinfo) - (param (prop* event 'DTSTART) 'TZID)) - ;; TODO this is broken - (add-child! cal (zoneinfo->vtimezone (zoneinfo) it))) - - (unless (prop event 'UID) - (set! (prop event 'UID) - (uuidgen))) - - (with-output-to-file (glob (format #f "~a/~a.ics" - calendar-path - (prop event 'UID))) - (lambda () (component->ical-string cal)))) - - - -(define (print-header) - (format #t -"BEGIN:VCALENDAR\r -PRODID:~a\r -VERSION:2.0\r -CALSCALE:GREGORIAN\r -" (prodid) -)) - - -(define (print-footer) - (format #t "END:VCALENDAR\r\n")) - -(define (get-tz-names events) - (lset-difference - equal? (lset-union - equal? '("dummy") - (filter-map - (lambda (vline) (and=> (param vline 'TZID) car)) - (filter-map (extract* 'DTSTART) - events))) - '("dummy" "local"))) - - -(define-public (print-components-with-fake-parent events) - - ;; The events are probably sorted before, but until I can guarantee - ;; that we sort them again here. We need them sorted from earliest - ;; and up to send the earliest to zoneinfo->vtimezone - (set! events (sort* events date/-time<=? (extract 'DTSTART))) - - (print-header) - - (when (provided? 'zoneinfo) - (let ((tz-names (get-tz-names events))) - (for-each component->ical-string - ;; TODO we realy should send the earliest event from each timezone here, - ;; instead of just the first. - (map (lambda (name) (zoneinfo->vtimezone - (zoneinfo) - name (car events))) - tz-names)))) - - (for-each component->ical-string events) - - (print-footer)) - - -(define-public (print-all-events) - (print-components-with-fake-parent - (append (get-fixed-events global-event-object) - ;; TODO RECCURENCE-ID exceptions - ;; We just dump all repeating objects, since it's much cheaper to do - ;; it this way than to actually figure out which are applicable for - ;; the given date range. - (get-repeating-events global-event-object)))) - -(define-public (print-events-in-interval start end) - (print-components-with-fake-parent - (append (fixed-events-in-range start end) - ;; TODO RECCURENCE-ID exceptions - ;; We just dump all repeating objects, since it's much cheaper to do - ;; it this way than to actually figure out which are applicable for - ;; the given date range. - (get-repeating-events global-event-object)))) diff --git a/module/vcomponent/ical/parse.scm b/module/vcomponent/ical/parse.scm deleted file mode 100644 index b67ae593..00000000 --- a/module/vcomponent/ical/parse.scm +++ /dev/null @@ -1,336 +0,0 @@ -(define-module (vcomponent ical parse) - :use-module (calp util) - :use-module (calp util exceptions) - :use-module ((ice-9 rdelim) :select (read-line)) - :use-module (vcomponent base) - :use-module (datetime) - :use-module (srfi srfi-1) - :use-module (srfi srfi-9 gnu) - :use-module (srfi srfi-26) - :use-module (vcomponent parse types) - :use-module (vcomponent geo) - ) - -(define string->symbol - (let ((ht (make-hash-table 1000))) - (lambda (str) - (or (hash-ref ht str) - (let ((symb ((@ (guile) string->symbol) str))) - (hash-set! ht str symb) - symb))))) - -;; TODO rename to parse-vcomponent, or parse-ical (?). -(define-public (parse-calendar port) - (parse (map tokenize (read-file port)))) - -(define-immutable-record-type - (make-line string file line) - line? - (string get-string) - (file get-file) - (line get-line)) - - -;; port → (list ) -(define (read-file port) - (define fname (port-filename port)) - (let loop ((line-number 1) (done '())) - (let ((ostr (open-output-string))) - (define ret - (let loop ((line (read-line port))) - (if (eof-object? line) - 'eof - (let ((line (string-trim-right line #\return))) - (let ((next (peek-char port))) - (display line ostr) - (cond ((eof-object? next) - 'final-line) - ;; Line Wrapping - ;; If the first character on a line is space (whitespace?) - ;; then it's a continuation line, and should be merged - ;; with the one preceeding it. - ;; TODO if the line is split inside a unicode character - ;; then this produces multiple broken unicode characters. - ;; It could be solved by checking the start of the new line, - ;; and the tail of the old line for broken char - ;; TODO what about other leading whitespace? - ((char=? next #\space) - (read-char port) ; discard leading whitespace - (loop (read-line port))) - (else - ;; (unread-char next) - 'line))))))) - (case ret - ((line) - (let ((str (get-output-string ostr))) - (close-port ostr) - (loop (1+ line-number) - (cons (make-line str fname line-number) - done)))) - ((eof) - (close-port ostr) - (reverse! done)) - ((final-line) - (let ((str (get-output-string ostr))) - (close-port ostr) - (reverse! (cons (make-line str fname line-number) - done)))))))) - -(define-immutable-record-type - (make-tokens metadata data) - tokens? - (metadata get-metadata) ; - (data get-data) ; (key kv ... value) - ) - -;; → -(define (tokenize line-obj) - (define line (get-string line-obj)) - (define colon-idx (string-index line #\:)) - (define semi-idxs - (let loop ((idx 0)) - (aif (string-index line #\; idx colon-idx) - (cons it (loop (1+ it))) - (list colon-idx (string-length line))))) - (make-tokens - line-obj - (map (lambda (start end) - (substring line (1+ start) end)) - (cons -1 semi-idxs) - semi-idxs))) - - -#; -'(ATTACH ATTENDEE CATEGORIES - COMMENT CONTACT EXDATE - REQUEST-STATUS RELATED-TO - RESOURCES RDATE - ;; x-prop - ;; iana-prop - ) - -(define (list-parser symbol) - (let ((parser (get-parser symbol))) - (lambda (params value) - (map (lambda (v) (parser params v)) - (string-split value #\,))))) - -(define* (enum-parser enum optional: (allow-other #t)) - (let ((parser (compose car (get-parser 'TEXT)))) - (lambda (params value) - (let ((vv (parser params value))) - (when (list? vv) - (throw 'parse-error "List in enum field")) - (let ((v (string->symbol vv))) - (unless (memv v enum) - (warning "~a ∉ { ~{~a~^, ~} }" - v enum)) - v))))) - -;; params could be made optional, with an empty hashtable as default -(define (build-vline key value params) - (let ((parser - (cond - [(and=> (hashq-ref params 'VALUE) string->symbol) => get-parser] - - [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID RDATE - CREATED DTSTAMP LAST-MODIFIED - ;; only on VALARM - ACKNOWLEDGED - )) - (get-parser 'DATE-TIME)] - - [(memv key '(EXDATE)) - (list-parser 'DATE-TIME)] - - [(memv key '(TRIGGER DURATION)) - (get-parser 'DURATION)] - - [(memv key '(FREEBUSY)) - (list-parser 'PERIOD)] - - [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION - LOCATION SUMMARY TZID TZNAME - CONTACT RELATED-TO UID)) - (lambda (params value) - (let ((v ((get-parser 'TEXT) params value))) - (unless (= 1 (length v)) - (warning "List in non-list field: ~s" v)) - (string-join v ",")))] - - ;; TEXT, but allow a list - [(memv key '(CATEGORIES RESOURCES)) - ;; TODO An empty value should lead to an empty set - ;; currently it seems to lead to '("") - (get-parser 'TEXT)] - - [(memv key '(VERSION)) - (lambda (params value) - (let ((v (car ((get-parser 'TEXT) params value)))) - (unless (and (string? v) (string=? "2.0" v)) - #f - ;; (warning "File of unsuported version. Proceed with caution") - ) - v))] - - [(memv key '(TRANSP)) - (enum-parser '(OPAQUE TRANSPARENT) #f)] - - [(memv key '(CLASS)) - (enum-parser '(PUBLIC PRIVATE CONFIDENTIAL))] - - [(memv key '(PARTSTAT)) - (enum-parser '(NEEDS-ACTION - ACCEPTED DECLINED - TENTATIVE DELEGATED - IN-PROCESS))] - - [(memv key '(STATUS)) - (enum-parser '(TENTATIVE - CONFIRMED CANCELLED - NEEDS-ACTION COMPLETED IN-PROCESS - DRAFT FINAL CANCELED))] - - [(memv key '(REQUEST-STATUS)) - (throw 'parse-error "TODO Implement REQUEST-STATUS")] - - [(memv key '(ACTION)) - (enum-parser '(AUDIO DISPLAY EMAIL - NONE ; I don't know where NONE is from - ; but it appears to be prevelant. - ))] - - [(memv key '(TZOFFSETFROM TZOFFSETTO)) - (get-parser 'UTC-OFFSET)] - - [(memv key '(ATTACH TZURL URL)) - (get-parser 'URI)] - - [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) - (get-parser 'INTEGER)] - - [(memv key '(GEO)) - ;; two semicolon sepparated floats - (lambda (params value) - (let* (((left right) (string-split value #\;))) - (make-geo ((get-parser 'FLOAT) params left) - ((get-parser 'FLOAT) params right))))] - - [(memv key '(RRULE)) - (get-parser 'RECUR)] - - [(memv key '(ORGANIZER ATTENDEE)) - (get-parser 'CAL-ADDRESS)] - - [(x-property? key) - (compose car (get-parser 'TEXT))] - - [else - (warning "Unknown key ~a" key) - (compose car (get-parser 'TEXT))]))) - - ;; If we produced a list create multiple VLINES from it. - ;; NOTE that the created vlines share parameter tables. - ;; TODO possibly allow vlines to reference each other, to - ;; indicate that all these vlines are the same. - (let ((parsed (parser params value))) - (if (list? parsed) - (apply values - (map (lambda (p) (make-vline key p params)) - parsed)) - (make-vline key parsed params))))) - -;; (parse-itemline '("DTEND" "20200407T130000")) -;; => DTEND -;; => "20200407T130000" -;; => # -(define (parse-itemline itemline) - (define key (string->symbol (car itemline))) - (define parameters (make-hash-table)) - (let loop ((rem (cdr itemline))) - (if (null? (cdr rem)) - (values key (car rem) parameters ) - (let* ((kv (car rem)) - (idx (string-index kv #\=))) - ;; TODO lists in parameters - (hashq-set! parameters (string->symbol (substring kv 0 idx)) - (substring kv (1+ idx))) - (loop (cdr rem)))))) - - -;; (list ) → -(define (parse lst) - (let loop ((lst lst) - (stack '())) - (if (null? lst) - stack - (let* ((head* (car lst)) - (head (get-data head*))) - (catch 'parse-error - (lambda () - (parameterize - ((warning-handler - (lambda (fmt . args) - (let ((linedata (get-metadata head*))) - (format - #f "WARNING parse error around ~a - ~? - line ~a ~a~%" - (get-string linedata) - fmt args - (get-line linedata) - (get-file linedata) - ))))) - (cond [(string=? "BEGIN" (car head)) - (loop (cdr lst) - (cons (make-vcomponent (string->symbol (cadr head))) - stack))] - [(string=? "END" (car head)) - (loop (cdr lst) - (if (null? (cdr stack)) - ;; return - (car stack) - (begin (add-child! (cadr stack) (car stack)) - (cdr stack))))] - [else - (let* ((key value params (parse-itemline head))) - (call-with-values (lambda () (build-vline key value params)) - (lambda vlines - (for vline in vlines - (define key (vline-key vline)) - - (set! (vline-source vline) - (get-metadata head*)) - - ;; See RFC 5545 p.53 for list of all repeating types - ;; (for vcomponent) - (if (memv key '(ATTACH ATTENDEE CATEGORIES - COMMENT CONTACT EXDATE - REQUEST-STATUS RELATED-TO - RESOURCES RDATE - ;; x-prop - ;; iana-prop - )) - (aif (prop* (car stack) key) - (set! (prop* (car stack) key) (cons vline it)) - (set! (prop* (car stack) key) (list vline))) - ;; else - (set! (prop* (car stack) key) vline)))))) - - (loop (cdr lst) stack)]))) - (lambda (err fmt . args) - (let ((linedata (get-metadata head*))) - (display (format - #f "ERROR parse error around ~a - ~? - line ~a ~a - Defaulting to string~%" - (get-string linedata) - fmt args - (get-line linedata) - (get-file linedata)) - (current-error-port)) - (let* ((key value params (parse-itemline head))) - (set! (prop* (car stack) key) - (make-vline key value params)) - (loop (cdr lst) stack))))))))) diff --git a/module/vcomponent/ical/types.scm b/module/vcomponent/ical/types.scm deleted file mode 100644 index 1ec9d0bd..00000000 --- a/module/vcomponent/ical/types.scm +++ /dev/null @@ -1,95 +0,0 @@ -;; see (vcomponent parse types) -(define-module (vcomponent ical types) - :use-module (calp util) - :use-module (calp util exceptions) - :use-module (base64) - :use-module (datetime)) - - -(define (write-binary _ value) - (bytevector->base64-string value)) - -(define (write-boolean _ value) - (if value "TRUE" "FALSE")) - -(define (write-date _ value) - (date->string value "~Y~m~d")) - -(define (write-datetime param value) - ;; NOTE We really should output TZID from param here, but - ;; we first need to change so these writers can output - ;; parameters. - (datetime->string (hashq-ref param '-X-HNH-ORIGINAL value) - "~Y~m~dT~H~M~S~Z")) - -(define (write-duration _ value) - ((@ (vcomponent duration) format-duration) value)) - -(define (write-float _ value) - (number->string value)) - -(define (write-integer _ value) - (number->string value)) - -;; TODO -(define (write-period _ value) - (warning "PERIOD writer not yet implemented") - (with-output-to-string - (lambda () (write value)))) - -(define (write-recur _ value) - ((@ (vcomponent recurrence internal) - recur-rule->rrule-string) value)) - -(define-public (escape-chars str) - (define (escape char) - (string #\\ char)) - (string-concatenate - (map (lambda (c) - (case c - ((#\newline) "\\n") - ((#\, #\; #\\) => escape) - (else => string))) - (string->list str)))) - -(define (write-text _ value) - (escape-chars value)) - -(define (write-time _ value) - (time->string value "~H~M~S")) - -(define (write-uri _ value) - value) - - -(use-modules (datetime timespec)) - -(define (write-utc-offset _ value) - (with-output-to-string - (lambda () - (display (if (time-zero? (timespec-time value)) - '+ (timespec-sign value))) - (display (time->string (timespec-time value) "~H~M")) - (when (not (zero? (second (timespec-time value)))) - (display (time->string (timespec-time value) "~S")))))) - - -(define type-writers (make-hash-table)) -(hashq-set! type-writers 'BINARY write-binary) -(hashq-set! type-writers 'BOOLEAN write-boolean) -(hashq-set! type-writers 'CAL-ADDRESS write-uri) -(hashq-set! type-writers 'DATE write-date) -(hashq-set! type-writers 'DATE-TIME write-datetime) -(hashq-set! type-writers 'DURATION write-duration) -(hashq-set! type-writers 'FLOAT write-float) -(hashq-set! type-writers 'INTEGER write-integer) -(hashq-set! type-writers 'PERIOD write-period) -(hashq-set! type-writers 'RECUR write-recur) -(hashq-set! type-writers 'TEXT write-text) -(hashq-set! type-writers 'TIME write-time) -(hashq-set! type-writers 'URI write-uri) -(hashq-set! type-writers 'UTC-OFFSET write-utc-offset) - -(define-public (get-writer type) - (or (hashq-ref type-writers type #f) - (error "No writer for type" type))) diff --git a/module/vcomponent/instance.scm b/module/vcomponent/instance.scm deleted file mode 100644 index 206d7f19..00000000 --- a/module/vcomponent/instance.scm +++ /dev/null @@ -1,22 +0,0 @@ -(define-module (vcomponent instance) - :use-module (calp util) - :use-module ((calp util config) :select (get-config)) - :use-module ((oop goops) :select (make)) - :export (global-event-object) -) - - - - - -;; TODO this is loaded on compile, meaning that Guile's auto-compiler may -;; evaluate this to early. -(define-once global-event-object - (make (@@ (vcomponent instance methods) ) - calendar-files: (get-config 'calendar-files))) - -(define-public (reload) - (let ((new-value (make (@@ (vcomponent instance methods) ) - calendar-files: (get-config 'calendar-files)))) - (display "Reload done\n" (current-error-port)) - (set! global-event-object new-value))) diff --git a/module/vcomponent/instance/methods.scm b/module/vcomponent/instance/methods.scm deleted file mode 100644 index 414587a9..00000000 --- a/module/vcomponent/instance/methods.scm +++ /dev/null @@ -1,138 +0,0 @@ -(define-module (vcomponent instance methods) - :use-module (calp util) - :use-module (srfi srfi-1) - :use-module (srfi srfi-41) - :use-module (srfi srfi-41 util) - :use-module (datetime) - :use-module (vcomponent base) - :use-module (vcomponent parse) - :use-module ((vcomponent recurrence) :select (generate-recurrence-set repeating?)) - :use-module ((vcomponent datetime) :select (ev-time () - (calendar-files init-keyword: calendar-files:) - (calendars getter: get-calendars) - (events getter: get-events) - (repeating-events getter: get-repeating-events) - (fixed-events getter: get-fixed-events) - (event-set getter: get-event-set) - uid-map - ) - - -(define-method (get-event-by-uid (this ) uid) - (hash-ref (slot-ref this 'uid-map) uid)) - - - -(define-method (fixed-events-in-range (this ) start end) - (filter-sorted (lambda (ev) ((in-date-range? start end) - (as-date (prop ev 'DTSTART)))) - (slot-ref this 'fixed-events))) - - -(define-method (initialize (this ) args) - (next-method) - - (format (current-error-port) "Building from~%") - (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* ((groups - (group-by - type (concatenate - (map children (slot-ref this 'calendars))))) - (events (awhen (assoc-ref groups 'VEVENT) - (car it))) - (removed remaining (partition (extract 'X-HNH-REMOVED) events))) - - ;; TODO figure out what to do with removed events - - (slot-set! this 'events (append #|removed|# remaining))) - - (let* ((repeating regular (partition repeating? (slot-ref this 'events)))) - (slot-set! this 'fixed-events (sort*! regular date/-timestream (slot-ref this 'fixed-events)) - (map generate-recurrence-set (slot-ref this 'repeating-events))))) - - (slot-set! this 'uid-map - (let ((ht (make-hash-table))) - (for-each (lambda (event) (hash-set! ht (prop event 'UID) event)) - (slot-ref this 'events)) - ht))) - -;;; TODO what should happen when an event with that UID already exists -;;; in the calendar? Fail? Overwrite? Currently it adds a second element -;;; with the same UID, which is BAD. -(define-method (add-event (this ) calendar event) - - (add-child! calendar event) - (unless (prop event 'UID) - (set! (prop event 'UID) (uuidgen))) - - - - - (slot-set! this 'events - (cons event (slot-ref this 'events))) - - (let* ((slot-name (if (repeating? event) 'repeating-events 'fixed-events)) - (events (slot-ref this slot-name))) - (slot-set! this slot-name (insert-ordered event events ev-time) event) - ;; cons #f so delq1! can delete the first element - - (delq1! event (cons #f (slot-ref this 'events))) - - (let ((slot-name (if (repeating? event) 'repeating-events 'fixed-events))) - (delq1! event (cons #f (slot-ref this slot-name)))) - - (slot-set! this 'event-set - (stream-remove - (lambda (ev) - (equal? (prop ev 'UID) - (prop event 'UID))) - (slot-ref this 'event-set))) - - (hash-set! (slot-ref this 'uid-map) (prop event 'UID) - #f)) - diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm deleted file mode 100644 index 9790d1eb..00000000 --- a/module/vcomponent/parse.scm +++ /dev/null @@ -1,35 +0,0 @@ -(define-module (vcomponent parse) - :use-module (calp util) - :use-module (vcomponent base) - :use-module ((vcomponent vdir parse) :select (parse-vdir)) - :use-module ((calp util time) :select (report-time!)) - - :use-module (vcomponent ical parse) - :re-export (parse-calendar) - ) - -;; Parse a vdir or ics file at the given path. -(define-public (parse-cal-path path) - ;; TODO check (access? path R_OK) ? - (define st (stat path)) - (define cal - (case (stat:type st) - [(regular) - (let ((comp (call-with-input-file path parse-calendar))) - (set! (prop comp '-X-HNH-SOURCETYPE) 'file) - comp) ] - [(directory) - (report-time! "Parsing ~a" path) - (let ((comp (parse-vdir path))) - (set! (prop comp '-X-HNH-SOURCETYPE) 'vdir - (prop comp '-X-HNH-DIRECTORY) path) - comp)] - [(block-special char-special fifo socket unknown symlink) - => (lambda (t) (error "Can't parse file of type " t))])) - - (unless (prop cal "NAME") - (set! (prop cal "NAME") - (or (prop cal "X-WR-CALNAME") - (string-append "[" (basename path) "]")))) - - cal) diff --git a/module/vcomponent/parse/types.scm b/module/vcomponent/parse/types.scm deleted file mode 100644 index ba4b2b47..00000000 --- a/module/vcomponent/parse/types.scm +++ /dev/null @@ -1,140 +0,0 @@ -(define-module (vcomponent parse types) - :use-module (calp util) - :use-module (calp util exceptions) - :use-module (base64) - :use-module (datetime) - :use-module (srfi srfi-9 gnu) - ) - -;; BINARY -(define (parse-binary props value) - ;; p 30 - (unless (string=? "BASE64" (hashq-ref props 'ENCODING)) - (warning "Binary field not marked ENCODING=BASE64")) - - ;; For icalendar no extra whitespace is allowed in a - ;; binary field (except for line wrapping). This differs - ;; from xcal. - (base64-string->bytevector value)) - -;; BOOLEAN -(define (parse-boolean props value) - (cond - [(string=? "TRUE" value) #t] - [(string=? "FALSE" value) #f] - [else (warning "~a invalid boolean" value)])) - -;; CAL-ADDRESS ⇒ uri - -;; DATE -(define (parse-date props value) - (parse-ics-date value)) - -;; DATE-TIME -(define (parse-datetime props value) - (define parsed - (parse-ics-datetime - value (hashq-ref props 'TZID #f))) - (hashq-set! props '-X-HNH-ORIGINAL parsed) - (get-datetime parsed)) - -;; DURATION -(define (parse-duration props value) - ((@ (vcomponent duration) parse-duration) - value)) - -;; FLOAT -;; Note that this is overly permissive, and flawed. -;; Numbers such as @expr{1/2} is accepted as exact -;; rationals. Some floats are rounded. -(define (parse-float props value) - (string->number value)) - - -;; INTEGER -(define (parse-integer props value) - (let ((n (string->number value))) - (unless (integer? n) - (warning "Non integer as integer")) - n)) - -;; PERIOD -(define (parse-period props value) - (let* (((left right) (string-split value #\/))) - ;; TODO timezones? VALUE=DATE? - (cons (parse-ics-datetime left) - ((if (memv (string-ref right 0) - '(#\P #\+ #\-)) - (@ (vcomponent duration) parse-duration) - parse-ics-datetime) - right)))) - -;; RECUR -(define (parse-recur props value) - ((@ (vcomponent recurrence parse) parse-recurrence-rule) value)) - -;; TEXT -;; TODO quoted strings -(define (parse-text props value) - (let loop ((rem (string->list value)) - (str '()) - (done '())) - (if (null? rem) - (cons (reverse-list->string str) done) - (case (car rem) - [(#\\) - (case (cadr rem) - [(#\n #\N) (loop (cddr rem) (cons #\newline str) done)] - [(#\; #\, #\\) => (lambda (c) (loop (cddr rem) (cons c str) done))] - [else => (lambda (c) (warning "Non-escapable character: ~a" c) - (loop (cddr rem) str done))])] - [(#\,) - (loop (cdr rem) '() (cons (reverse-list->string str) done))] - [else - (loop (cdr rem) (cons (car rem) str) done)])))) - - -;; TIME -(define (parse-time props value) - ;; TODO time can have timezones... - (parse-ics-time value)) - -;; URI -(define (parse-uri props value) - value) - -(use-modules (datetime timespec)) - -;; UTC-OFFSET -(define (parse-utc-offset props value) - (make-timespec - (time - hour: (string->number (substring value 1 3)) - minute: (string->number (substring value 3 5)) - second: (if (= 7 (string-length value)) - (string->number (substring value 5 7)) - 0)) - ;; sign - (string->symbol (substring value 0 1)) - #\z)) - - -(define type-parsers (make-hash-table)) -(hashq-set! type-parsers 'BINARY parse-binary) -(hashq-set! type-parsers 'BOOLEAN parse-boolean) -(hashq-set! type-parsers 'CAL-ADDRESS parse-uri) -(hashq-set! type-parsers 'DATE parse-date) -(hashq-set! type-parsers 'DATE-TIME parse-datetime) -(hashq-set! type-parsers 'DURATION parse-duration) -(hashq-set! type-parsers 'FLOAT parse-float) -(hashq-set! type-parsers 'INTEGER parse-integer) -(hashq-set! type-parsers 'PERIOD parse-period) -(hashq-set! type-parsers 'RECUR parse-recur) -(hashq-set! type-parsers 'TEXT parse-text) -(hashq-set! type-parsers 'TIME parse-time) -(hashq-set! type-parsers 'URI parse-uri) -(hashq-set! type-parsers 'UTC-OFFSET parse-utc-offset) - -(define-public (get-parser type) - (or (hashq-ref type-parsers type #f) - (error "No parser for type" type))) diff --git a/module/vcomponent/search.scm b/module/vcomponent/search.scm deleted file mode 100644 index a850fb40..00000000 --- a/module/vcomponent/search.scm +++ /dev/null @@ -1,175 +0,0 @@ -;;; Commentary: - -;; Procedures for searching in a (possibly) infinite stream. Everything is general, -;; with the exception of @var{build-query-proc}, which is tailored for searches on -;; sets on vcomponents. - -;; > TODO since most of this module is generic, break it out and only have the -;; > vcomponent-specific parts here. - -;; A search isn't guaranteed to include all available objects, since each object -;; only has a limited time to get found. This is mostly a problem if the matches -;; are /really/ far from one another. -;; NOTE a system of continuations to allow a search to be resumed with a higher -;; timeout would be cool to have. - -;; Currently all searches is assumed to go through prepare-query and the paginator -;; interface. It shouldn't however be a problem to work with the flat result-set -;; returned by @var{execute-query} directly. - -;; @var{} isn't strictly necessary even for paginated queries, since the -;; evaluation time and pagination is baked into the stream. It is however useful -;; for keeping track of the number of available pages, and if we have found the -;; "final" element. - -;;; Code: - -(define-module (vcomponent search) - :use-module (calp util) - :use-module (srfi srfi-1) - :use-module (srfi srfi-9) - :use-module (srfi srfi-41) - :use-module (srfi srfi-41 util) - :use-module ((ice-9 sandbox) - :select (make-sandbox-module - all-pure-bindings))) - - -;; Takes a string and appends closing parenthese until all parenthese are -;; closed. -(define (close-parenthese str) - (define missing-parenthesis-count - (string-fold (lambda (char count) - (case char - ((#\() (1+ count)) - ((#\)) (1- count)) - (else count))) - 0 str)) - (string-append str (make-string missing-parenthesis-count #\)))) - -;; Prepares a string to be sent to build-query-proc -;; sexp-like string -> sexp -(define-public (prepare-string str) - (call-with-input-string (close-parenthese str) read)) - -;; TODO place this in a proper module -(define (bindings-for module-name) - ;; Wrapping list so we can later export sub-modules. - (list (cons module-name - (module-map (lambda (a . _) a) - (resolve-interface module-name))))) - -;; Evaluates the given expression in a sandbox. -;; NOTE Should maybe be merged inte prepare-query. The argument against is that -;; eval-in-sandbox is possibly slow, and that would prevent easy caching by the -;; caller. -;; sexp -> (event → bool) -(define-public (build-query-proc . expressions) - ;; TODO does this eval help? Or will the body of the procedure - ;; be evalutade later? - (eval `(lambda (event) ,@expressions) - (make-sandbox-module - `( - ((vcomponent base) prop param children type parent) - ((ice-9 regex) string-match) - ,@(bindings-for '(datetime)) - ,@all-pure-bindings) - ))) - - -;; Returns a new stream which is the result of filtering the input set with the -;; query procedure. -;; (a → bool), (stream a) → (stream a) -(define-public (execute-query query-proc event-set) - (stream-timeslice-limit - (stream-filter query-proc event-set) - ;; .5s, tested on my laptop. .1s sometimes doesn't get to events on - ;; 2020-08-10, where the first event is on 1974-12-02. - 0.5)) - -;; Creates a prepared query wrappend in a paginator. -;; (event → bool), (stream event) → -(define*-public (prepare-query query-proc event-set optional: (page-size 10)) - (make-paginator (stream-paginate (execute-query query-proc event-set) - page-size))) - -(define-record-type - (make-paginator% query max-page true-max-page?) - paginator? - (query get-query) ; (paginated-stream event) - (max-page get-max-page set-max-page!) ; int - (true-max-page? true-max-page? %set-true-max-page!)) - -(define (set-true-max-page! paginator) - (%set-true-max-page! paginator #t)) - -(define (unset-true-max-page! paginator) - (%set-true-max-page! paginator #f)) - -(export paginator? get-query get-max-page true-max-page?) - -(define (make-paginator query) - (make-paginator% query 0 #f)) - -;; a fancy version of 1+ which caps at max page -;; , int → int -(define*-public (next-page paginator optional: (page (get-max-page paginator))) - (if (true-max-page? paginator) - (min (1+ page) (get-max-page paginator)) - (1+ page))) - -(define-public (paginator->list paginator proc tail-proc) - (if (true-max-page? paginator) - (map proc (iota (1+ (get-max-page paginator)))) - (append (map proc (iota (1+ (get-max-page paginator)))) - (list (tail-proc (next-page paginator)))))) - - -(define*-public (paginator->sub-list paginator current-page proc - key: head-proc tail-proc - (ahead 5) (behind 5) - ) - - (let ((start (max 0 (- current-page behind))) - (end (min (+ current-page ahead) - (get-max-page paginator)))) - - (display (head-proc start)) - (for-each proc (iota (1+ (- end start)) start)) - (display (tail-proc end))) - - ) - -;; returns the contents of the requested page, or throws 'max-page with the -;; highest known available page. -;; , int → (list event) throws ('max-page ) -(define-public (get-page paginator page) - (catch 'wrong-type-arg - (lambda () (let ((q (get-query paginator))) - (if (stream-null? q) - (begin - (set-true-max-page! paginator) - '()) - (let ((result (stream->list - (stream-ref (get-query paginator) page)))) - ;; This check isn't strictly necessary, but without it - ;; we always needs to force the next page. And since this - ;; page is "incomplete" we already know that this is the - ;; final page. - (when (> 10 (length result)) - (set-true-max-page! paginator)) - - (set-max-page! paginator (max page (get-max-page paginator))) - result)))) - (lambda (err proc fmt args data) - ;; NOTE This is mostly a hack to see that we - ;; actually check for the correct error. - (unless (string=? fmt "beyond end of stream") - (scm-error err proc fmt args data)) - - (set-max-page! paginator (get-max-page paginator)) - (set-true-max-page! paginator) - (throw 'max-page (get-max-page paginator)) - ))) - - diff --git a/module/vcomponent/util/control.scm b/module/vcomponent/util/control.scm new file mode 100644 index 00000000..4cb6c708 --- /dev/null +++ b/module/vcomponent/util/control.scm @@ -0,0 +1,36 @@ +(define-module (vcomponent util control) + #:use-module (calp util) + #:use-module (vcomponent) + #:export (with-replaced-properties)) + + +(eval-when (expand load) ; No idea why I must have load here. + (define href (make-procedure-with-setter hash-ref hash-set!)) + + (define (set-temp-values! table component kvs) + (for-each (lambda (kv) + (let* (((key val) kv)) + (when (prop component key) + (set! (href table key) (prop component key)) + (set! (prop component key) val)))) + kvs)) + + (define (restore-values! table component keys) + (for-each (lambda (key) + (and=> (href table key) + (lambda (val) + (set! (prop component key) val)))) + keys))) + +;; TODO what is this even used for? +(define-syntax with-replaced-properties + (syntax-rules () + [(_ (component (key val) ...) + body ...) + + (let ((htable (make-hash-table 10))) + (dynamic-wind + (lambda () (set-temp-values! htable component (quote ((key val) ...)))) ; In guard + (lambda () body ...) + (lambda () (restore-values! htable component (quote (key ...))))))])) ; Out guard + diff --git a/module/vcomponent/util/describe.scm b/module/vcomponent/util/describe.scm new file mode 100644 index 00000000..5c3afd30 --- /dev/null +++ b/module/vcomponent/util/describe.scm @@ -0,0 +1,44 @@ +(define-module (vcomponent util describe) + :use-module (calp util) + :use-module (vcomponent base) + :use-module (text util)) + +(define*-public (describe vcomponent optional: (indent 0)) + (define ii (make-string indent #\space)) + (define iii (make-string (1+ indent) #\space)) + + (define maxlen (find-max (map + (lambda (a) (string-length (symbol->string a))) + (map car (properties vcomponent))))) + + (format #t "~aBEGIN ~a~%" ii (type vcomponent)) + + (for-each (lambda (kv) + (let* (((key . values) kv)) + (define (out vline) + (format #t "~a~a = ~a" + iii + (trim-to-width (symbol->string key) maxlen) + (trim-to-width + (format #f "~a" (value vline)) + (- 80 indent maxlen))) + (awhen (vline-source vline) + (display ((@@ (vcomponent formats ical parse) get-line) it))) + (unless (null? (parameters vline)) + (display " ;") + (for (key value) in (parameters vline) + (format #t " ~a=~a" key value))) + (newline)) + (if (list? values) + (for-each out values) + (out values)))) + (sort* (properties vcomponent) + stringstring car))) + + (for child in (children vcomponent) + + (describe child (+ indent 2))) + + (format #t "~aEND ~a~%" ii (type vcomponent))) diff --git a/module/vcomponent/util/group.scm b/module/vcomponent/util/group.scm new file mode 100644 index 00000000..f328cd18 --- /dev/null +++ b/module/vcomponent/util/group.scm @@ -0,0 +1,71 @@ +(define-module (vcomponent util group) + #:use-module (vcomponent) + #:use-module (vcomponent datetime) + #:use-module (datetime) + #:use-module (srfi srfi-41) + #:use-module (srfi srfi-41 util) + #:export (group-stream get-groups-between)) + +;; TODO templetize this +(define-stream (group-stream in-stream) + (define (ein? day) (lambda (e) (event-contains? e day))) + + (if (stream-null? in-stream) + stream-null + (let loop ((days (day-stream (as-date (prop (stream-car in-stream) 'DTSTART)))) + (stream in-stream)) + (let* ((day (stream-car days)) + (tomorow (stream-car (stream-cdr days)))) + + (let ((head (stream-take-while (ein? day) stream)) + (tail + ;; This is a filter, instead of a stream-span together with head, + ;; since events can span multiple days. + ;; This starts with taking everything which end after the beginning + ;; of tommorow, and finishes with the rest when it finds the first + ;; object which begins tomorow (after midnight, exclusize). + (filter-sorted-stream* + (lambda (e) (date/-timestream + (map (lambda (d) (cons d stream-null)) + (date-range start-date end-date)))] + [(car (stream-car good-part)) + (lambda (d) (date< start-date d)) + => (lambda (d) + (stream-append + (list->stream + (map (lambda (d) (cons d stream-null)) + (date-range start-date + (date- d (date day: 1))))) + good-part))] + [else good-part])) + + +(define-public (group->event-list group) + (stream->list (cdr group))) diff --git a/module/vcomponent/util/instance.scm b/module/vcomponent/util/instance.scm new file mode 100644 index 00000000..15c020b1 --- /dev/null +++ b/module/vcomponent/util/instance.scm @@ -0,0 +1,22 @@ +(define-module (vcomponent util instance) + :use-module (calp util) + :use-module ((calp util config) :select (get-config)) + :use-module ((oop goops) :select (make)) + :export (global-event-object) +) + + + + + +;; TODO this is loaded on compile, meaning that Guile's auto-compiler may +;; evaluate this to early. +(define-once global-event-object + (make (@@ (vcomponent util instance methods) ) + calendar-files: (get-config 'calendar-files))) + +(define-public (reload) + (let ((new-value (make (@@ (vcomponent util instance methods) ) + calendar-files: (get-config 'calendar-files)))) + (display "Reload done\n" (current-error-port)) + (set! global-event-object new-value))) diff --git a/module/vcomponent/util/instance/methods.scm b/module/vcomponent/util/instance/methods.scm new file mode 100644 index 00000000..37aef3bc --- /dev/null +++ b/module/vcomponent/util/instance/methods.scm @@ -0,0 +1,139 @@ +(define-module (vcomponent util instance methods) + :use-module (calp util) + :use-module (srfi srfi-1) + :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) + :use-module (datetime) + :use-module (vcomponent base) + ;; :use-module (vcomponent parse) + :use-module ((vcomponent util parse-cal-path) :select (parse-cal-path)) + :use-module ((vcomponent recurrence) :select (generate-recurrence-set repeating?)) + :use-module ((vcomponent datetime) :select (ev-time () + (calendar-files init-keyword: calendar-files:) + (calendars getter: get-calendars) + (events getter: get-events) + (repeating-events getter: get-repeating-events) + (fixed-events getter: get-fixed-events) + (event-set getter: get-event-set) + uid-map + ) + + +(define-method (get-event-by-uid (this ) uid) + (hash-ref (slot-ref this 'uid-map) uid)) + + + +(define-method (fixed-events-in-range (this ) start end) + (filter-sorted (lambda (ev) ((in-date-range? start end) + (as-date (prop ev 'DTSTART)))) + (slot-ref this 'fixed-events))) + + +(define-method (initialize (this ) args) + (next-method) + + (format (current-error-port) "Building from~%") + (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* ((groups + (group-by + type (concatenate + (map children (slot-ref this 'calendars))))) + (events (awhen (assoc-ref groups 'VEVENT) + (car it))) + (removed remaining (partition (extract 'X-HNH-REMOVED) events))) + + ;; TODO figure out what to do with removed events + + (slot-set! this 'events (append #|removed|# remaining))) + + (let* ((repeating regular (partition repeating? (slot-ref this 'events)))) + (slot-set! this 'fixed-events (sort*! regular date/-timestream (slot-ref this 'fixed-events)) + (map generate-recurrence-set (slot-ref this 'repeating-events))))) + + (slot-set! this 'uid-map + (let ((ht (make-hash-table))) + (for-each (lambda (event) (hash-set! ht (prop event 'UID) event)) + (slot-ref this 'events)) + ht))) + +;;; TODO what should happen when an event with that UID already exists +;;; in the calendar? Fail? Overwrite? Currently it adds a second element +;;; with the same UID, which is BAD. +(define-method (add-event (this ) calendar event) + + (add-child! calendar event) + (unless (prop event 'UID) + (set! (prop event 'UID) (uuidgen))) + + + + + (slot-set! this 'events + (cons event (slot-ref this 'events))) + + (let* ((slot-name (if (repeating? event) 'repeating-events 'fixed-events)) + (events (slot-ref this slot-name))) + (slot-set! this slot-name (insert-ordered event events ev-time) event) + ;; cons #f so delq1! can delete the first element + + (delq1! event (cons #f (slot-ref this 'events))) + + (let ((slot-name (if (repeating? event) 'repeating-events 'fixed-events))) + (delq1! event (cons #f (slot-ref this slot-name)))) + + (slot-set! this 'event-set + (stream-remove + (lambda (ev) + (equal? (prop ev 'UID) + (prop event 'UID))) + (slot-ref this 'event-set))) + + (hash-set! (slot-ref this 'uid-map) (prop event 'UID) + #f)) + diff --git a/module/vcomponent/util/parse-cal-path.scm b/module/vcomponent/util/parse-cal-path.scm new file mode 100644 index 00000000..94c0c6ed --- /dev/null +++ b/module/vcomponent/util/parse-cal-path.scm @@ -0,0 +1,35 @@ +(define-module (vcomponent util parse-cal-path) + :use-module (calp util) + :use-module ((calp util time) :select (report-time!)) + :use-module (vcomponent base) + :use-module ((vcomponent formats ical parse) + :select (parse-calendar)) + :use-module ((vcomponent formats vdir parse) + :select (parse-vdir))) + + +;; Parse a vdir or ics file at the given path. +(define-public (parse-cal-path path) + ;; TODO check (access? path R_OK) ? + (define st (stat path)) + (define cal + (case (stat:type st) + [(regular) + (let ((comp (call-with-input-file path parse-calendar))) + (set! (prop comp '-X-HNH-SOURCETYPE) 'file) + comp) ] + [(directory) + (report-time! "Parsing ~a" path) + (let ((comp (parse-vdir path))) + (set! (prop comp '-X-HNH-SOURCETYPE) 'vdir + (prop comp '-X-HNH-DIRECTORY) path) + comp)] + [(block-special char-special fifo socket unknown symlink) + => (lambda (t) (error "Can't parse file of type " t))])) + + (unless (prop cal "NAME") + (set! (prop cal "NAME") + (or (prop cal "X-WR-CALNAME") + (string-append "[" (basename path) "]")))) + + cal) diff --git a/module/vcomponent/util/search.scm b/module/vcomponent/util/search.scm new file mode 100644 index 00000000..fb395022 --- /dev/null +++ b/module/vcomponent/util/search.scm @@ -0,0 +1,175 @@ +;;; Commentary: + +;; Procedures for searching in a (possibly) infinite stream. Everything is general, +;; with the exception of @var{build-query-proc}, which is tailored for searches on +;; sets on vcomponents. + +;; > TODO since most of this module is generic, break it out and only have the +;; > vcomponent-specific parts here. + +;; A search isn't guaranteed to include all available objects, since each object +;; only has a limited time to get found. This is mostly a problem if the matches +;; are /really/ far from one another. +;; NOTE a system of continuations to allow a search to be resumed with a higher +;; timeout would be cool to have. + +;; Currently all searches is assumed to go through prepare-query and the paginator +;; interface. It shouldn't however be a problem to work with the flat result-set +;; returned by @var{execute-query} directly. + +;; @var{} isn't strictly necessary even for paginated queries, since the +;; evaluation time and pagination is baked into the stream. It is however useful +;; for keeping track of the number of available pages, and if we have found the +;; "final" element. + +;;; Code: + +(define-module (vcomponent util search) + :use-module (calp util) + :use-module (srfi srfi-1) + :use-module (srfi srfi-9) + :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) + :use-module ((ice-9 sandbox) + :select (make-sandbox-module + all-pure-bindings))) + + +;; Takes a string and appends closing parenthese until all parenthese are +;; closed. +(define (close-parenthese str) + (define missing-parenthesis-count + (string-fold (lambda (char count) + (case char + ((#\() (1+ count)) + ((#\)) (1- count)) + (else count))) + 0 str)) + (string-append str (make-string missing-parenthesis-count #\)))) + +;; Prepares a string to be sent to build-query-proc +;; sexp-like string -> sexp +(define-public (prepare-string str) + (call-with-input-string (close-parenthese str) read)) + +;; TODO place this in a proper module +(define (bindings-for module-name) + ;; Wrapping list so we can later export sub-modules. + (list (cons module-name + (module-map (lambda (a . _) a) + (resolve-interface module-name))))) + +;; Evaluates the given expression in a sandbox. +;; NOTE Should maybe be merged inte prepare-query. The argument against is that +;; eval-in-sandbox is possibly slow, and that would prevent easy caching by the +;; caller. +;; sexp -> (event → bool) +(define-public (build-query-proc . expressions) + ;; TODO does this eval help? Or will the body of the procedure + ;; be evalutade later? + (eval `(lambda (event) ,@expressions) + (make-sandbox-module + `( + ((vcomponent base) prop param children type parent) + ((ice-9 regex) string-match) + ,@(bindings-for '(datetime)) + ,@all-pure-bindings) + ))) + + +;; Returns a new stream which is the result of filtering the input set with the +;; query procedure. +;; (a → bool), (stream a) → (stream a) +(define-public (execute-query query-proc event-set) + (stream-timeslice-limit + (stream-filter query-proc event-set) + ;; .5s, tested on my laptop. .1s sometimes doesn't get to events on + ;; 2020-08-10, where the first event is on 1974-12-02. + 0.5)) + +;; Creates a prepared query wrappend in a paginator. +;; (event → bool), (stream event) → +(define*-public (prepare-query query-proc event-set optional: (page-size 10)) + (make-paginator (stream-paginate (execute-query query-proc event-set) + page-size))) + +(define-record-type + (make-paginator% query max-page true-max-page?) + paginator? + (query get-query) ; (paginated-stream event) + (max-page get-max-page set-max-page!) ; int + (true-max-page? true-max-page? %set-true-max-page!)) + +(define (set-true-max-page! paginator) + (%set-true-max-page! paginator #t)) + +(define (unset-true-max-page! paginator) + (%set-true-max-page! paginator #f)) + +(export paginator? get-query get-max-page true-max-page?) + +(define (make-paginator query) + (make-paginator% query 0 #f)) + +;; a fancy version of 1+ which caps at max page +;; , int → int +(define*-public (next-page paginator optional: (page (get-max-page paginator))) + (if (true-max-page? paginator) + (min (1+ page) (get-max-page paginator)) + (1+ page))) + +(define-public (paginator->list paginator proc tail-proc) + (if (true-max-page? paginator) + (map proc (iota (1+ (get-max-page paginator)))) + (append (map proc (iota (1+ (get-max-page paginator)))) + (list (tail-proc (next-page paginator)))))) + + +(define*-public (paginator->sub-list paginator current-page proc + key: head-proc tail-proc + (ahead 5) (behind 5) + ) + + (let ((start (max 0 (- current-page behind))) + (end (min (+ current-page ahead) + (get-max-page paginator)))) + + (display (head-proc start)) + (for-each proc (iota (1+ (- end start)) start)) + (display (tail-proc end))) + + ) + +;; returns the contents of the requested page, or throws 'max-page with the +;; highest known available page. +;; , int → (list event) throws ('max-page ) +(define-public (get-page paginator page) + (catch 'wrong-type-arg + (lambda () (let ((q (get-query paginator))) + (if (stream-null? q) + (begin + (set-true-max-page! paginator) + '()) + (let ((result (stream->list + (stream-ref (get-query paginator) page)))) + ;; This check isn't strictly necessary, but without it + ;; we always needs to force the next page. And since this + ;; page is "incomplete" we already know that this is the + ;; final page. + (when (> 10 (length result)) + (set-true-max-page! paginator)) + + (set-max-page! paginator (max page (get-max-page paginator))) + result)))) + (lambda (err proc fmt args data) + ;; NOTE This is mostly a hack to see that we + ;; actually check for the correct error. + (unless (string=? fmt "beyond end of stream") + (scm-error err proc fmt args data)) + + (set-max-page! paginator (get-max-page paginator)) + (set-true-max-page! paginator) + (throw 'max-page (get-max-page paginator)) + ))) + + diff --git a/module/vcomponent/vdir/parse.scm b/module/vcomponent/vdir/parse.scm deleted file mode 100644 index 6bbd1329..00000000 --- a/module/vcomponent/vdir/parse.scm +++ /dev/null @@ -1,123 +0,0 @@ -;;; Commentary: -;; Code for parsing vdir's and icalendar files. -;; This module handles the finding of files, while -;; (vcomponent parse ical) handles reading data from icalendar files. -;;; Code: - -(define-module (vcomponent vdir parse) - :use-module (srfi srfi-1) - - :use-module ((ice-9 hash-table) :select (alist->hash-table)) - :use-module ((ice-9 rdelim) :select (read-line)) - :use-module ((ice-9 ftw) :select (scandir ftw)) - - :use-module (calp util) - :use-module (calp util exceptions) - :use-module (vcomponent base) - - :use-module (vcomponent ical parse) - ) - - - - -;; All VTIMEZONE's seem to be in "local" time in relation to -;; themselves. Therefore, a simple comparison should work, -;; and then the TZOFFSETTO properties can be subtd. -(define-public (parse-vdir path) - ;; TODO empty files here cause "#" to appear in the output XML, which is *really* bad. - (let ((color - (catch 'system-error - (lambda () (call-with-input-file (path-append path "color") read-line)) - (const "#FFFFFF"))) - (name - (catch 'system-error - (lambda () (call-with-input-file (path-append path "displayname") read-line)) - (const #f)))) - - (reduce (lambda (item calendar) - - (define-values (events other) (partition (lambda (e) (eq? 'VEVENT (type e))) - (children item))) - - - ;; (assert (eq? 'VCALENDAR (type calendar))) - (assert (eq? 'VCALENDAR (type item))) - - (for child in (children item) - (set! (prop child '-X-HNH-FILENAME) - (prop (parent child) '-X-HNH-FILENAME))) - - ;; NOTE The vdir standard says that each file should contain - ;; EXACTLY one event. It can however contain multiple VEVENT - ;; components, but they are still the same event. - ;; In our case this means exceptions to reccurence rules, which - ;; is set up here, and then later handled in rrule-generate. - ;; NOTE These events also share UID, but are diferentiated - ;; by RECURRENCE-ID. As far as I can tell this goes against - ;; the standard. Section 3.8.4.4. - (case (length events) - [(0) (warning "No events in component~%~a" - (prop item '-X-HNH-FILENAME))] - [(1) - (let ((child (car events))) - (assert (memv (type child) '(VTIMEZONE VEVENT))) - (add-child! calendar child))] - - ;; two or more - [else - ;; Sequence numbers on their own specifies revisions of a - ;; single compenent, incremented by a central authorative - ;; source. In that case simply picking the version with the - ;; highest SEQUENCE number would suffice. However, for - ;; recurring events where each instance is its own VEVENT - ;; they also signify something. - ;; TODO Neither version is handled here (or anywhere else). - - - ;; Multiple VEVENT objects can share a UID if they have - ;; different RECURRENCE-ID fields. This signifies that they - ;; are instances of the same event, similar to RDATE. - ;; Here we first check if we have a component which contains - ;; an RRULE or lacks a RECURRENCE-ID, and uses that as base. - ;; Otherwise we just take the first component as base. - ;; - ;; All alternatives (and the base) is added the the -X-HNH-ALTERNATIVES - ;; property of the base object, to be extracted where needed. - (let* ((head (or (find (extract 'RRULE) events) - (find (negate (extract 'RECURRENCE-ID)) events) - (car events))) - (rest (delete head events eq?))) - - (set! (prop head '-X-HNH-ALTERNATIVES) - (alist->hash-table - (map cons - ;; head is added back to the collection to simplify - ;; generation of recurrences. The recurrence - ;; generation assumes that the base event either - ;; contains an RRULE property, OR is in the - ;; -X-HNH-ALTERNATIVES set. This might produce - ;; duplicates, since the base event might also - ;; get included through an RRULE. This however - ;; is almost a non-problem, since RDATES and RRULES - ;; can already produce duplicates, meaning that - ;; we need to filter duplicates either way. - (map (extract 'RECURRENCE-ID) (cons head rest)) - (cons head rest)))) - (add-child! calendar head))]) - - ;; return - calendar) - (make-vcomponent) - (map #; (@ (ice-9 threads) par-map) - (lambda (fname) - (let ((fullname (path-append path fname))) - (let ((cal (call-with-input-file fullname - parse-calendar))) - (set! (prop cal 'COLOR) color - (prop cal 'NAME) name - (prop cal '-X-HNH-FILENAME) fullname) - cal))) - (scandir path (lambda (s) (and (not (string= "." (string-take s 1))) - (string= "ics" (string-take-right s 3))))))))) - diff --git a/module/vcomponent/vdir/save-delete.scm b/module/vcomponent/vdir/save-delete.scm deleted file mode 100644 index b3c7f9c5..00000000 --- a/module/vcomponent/vdir/save-delete.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; Commentary: -;;; Module for writing components to the vdir storage format. -;;; Currently also has some cases for "big" icalendar files, -;;; but those are currently unsupported. - -;;; TODO generalize save-event and remove-event into a general interface, -;;; which different database backends can implement. Actually, do that for all -;;; loading and writing. - -;;; Code: - -(define-module (vcomponent vdir save-delete) - :use-module (calp util) - :use-module ((calp util exceptions) :select (assert)) - :use-module (vcomponent ical output) - :use-module (vcomponent) - :use-module ((calp util io) :select (with-atomic-output-to-file)) - ) - - -(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"))) - (with-atomic-output-to-file (prop event '-X-HNH-FILENAME) - (lambda () (print-components-with-fake-parent (list event)))) - uid)) - - -(define-public (remove-event event) - (define calendar (parent event)) - (assert (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE))) - (delete-file (prop event '-X-HNH-FILENAME))) diff --git a/module/vcomponent/xcal/output.scm b/module/vcomponent/xcal/output.scm deleted file mode 100644 index 70288cba..00000000 --- a/module/vcomponent/xcal/output.scm +++ /dev/null @@ -1,133 +0,0 @@ -(define-module (vcomponent xcal output) - :use-module (calp util) - :use-module (calp util exceptions) - :use-module (vcomponent) - :use-module (vcomponent geo) - :use-module (vcomponent xcal types) - :use-module (ice-9 match) - :use-module (datetime) - :use-module (srfi srfi-1) - ) - - -(define (vline->value-tag vline) - (define key (vline-key vline)) - - (define writer - (cond - [(and=> (param vline 'VALUE) (compose string->symbol car)) - => get-writer] - [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID - CREATED DTSTAMP LAST-MODIFIED - ACKNOWLEDGED EXDATE)) - (get-writer 'DATE-TIME)] - - [(memv key '(TRIGGER DURATION)) - (get-writer 'DURATION)] - - [(memv key '(FREEBUSY)) - (get-writer 'PERIOD)] - - [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION - LOCATION SUMMARY TZID TZNAME - CONTACT RELATED-TO UID - - CATEGORIES RESOURCES - - VERSION)) - (get-writer 'TEXT)] - - [(memv key '(TRANSP - CLASS - PARTSTAT - STATUS - ACTION)) - (lambda (p v) ((get-writer 'TEXT) p (symbol->string v)))] - - [(memv key '(TZOFFSETFROM TZOFFSETTO)) - (get-writer 'UTC-OFFSET)] - - [(memv key '(ATTACH TZURL URL)) - (get-writer 'URI)] - - [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) - (get-writer 'INTEGER)] - - [(memv key '(GEO)) - (lambda (_ v) - `(geo - (latitude ,(geo-latitude v)) - (longitude ,(geo-longitude v))))] - - [(memv key '(RRULE)) - (get-writer 'RECUR)] - - [(memv key '(ORGANIZER ATTENDEE)) - (get-writer 'CAL-ADDRESS)] - - [(x-property? key) - (get-writer 'TEXT)] - - [else - (warning "Unknown key ~a" key) - (get-writer 'TEXT)])) - - (writer ((@@ (vcomponent base) get-vline-parameters) vline) (value vline))) - -(define (property->value-tag tag . values) - (if (or (eq? tag 'VALUE) - (internal-field? tag)) - #f - `(,(downcase-symbol tag) - ,@(map (lambda (v) - ;; TODO parameter types!!!! (rfc6321 3.5.) - `(text ,(->string v))) - values)))) - -;; ((key value ...) ...) -> `(parameters , ... ) -(define (parameters-tag parameters) - (define outparams (filter-map - (lambda (x) (apply property->value-tag x)) - parameters)) - - (unless (null? outparams) - `(parameters ,@outparams))) - -(define-public (vcomponent->sxcal component) - - (define tagsymb (downcase-symbol (type component))) - - - (remove null? - `(,tagsymb - ;; only have when it's non-empty. - ,(let ((props - (filter-map - (match-lambda - [(? (compose internal-field? car)) #f] - - [(key vlines ...) - (remove null? - `(,(downcase-symbol key) - ,(parameters-tag (reduce assq-merge - '() (map parameters vlines))) - ,@(for vline in vlines - (vline->value-tag vline))))] - - [(key . vline) - (remove null? - `(,(downcase-symbol key) - ,(parameters-tag (parameters vline)) - ,(vline->value-tag vline)))]) - (properties component)))) - (unless (null? props) - `(properties - ;; NOTE - ;; (x-hnh-calendar-name (text ,(prop (parent component) 'NAME))) - ,@props))) - ,(unless (null? (children component)) - `(components ,@(map vcomponent->sxcal (children component))))))) - -(define-public (ns-wrap sxml) - `(icalendar (@ (xmlns "urn:ietf:params:xml:ns:icalendar-2.0")) - ,sxml)) diff --git a/module/vcomponent/xcal/parse.scm b/module/vcomponent/xcal/parse.scm deleted file mode 100644 index c6a2122f..00000000 --- a/module/vcomponent/xcal/parse.scm +++ /dev/null @@ -1,259 +0,0 @@ -(define-module (vcomponent xcal parse) - :use-module (calp util) - :use-module (calp util exceptions) - :use-module (base64) - :use-module (ice-9 match) - :use-module (sxml match) - :use-module (vcomponent) - :use-module (vcomponent geo) - :use-module (vcomponent parse types) - :use-module (datetime) - :use-module (srfi srfi-1) - ) - -;; symbol, ht, (list a) -> non-list -(define (handle-value type props value) - (case type - - [(binary) - ;; rfc6321 allows whitespace in binary - (base64-string->bytevector - (string-delete char-set:whitespace (car value)))] - - [(boolean) (string=? "true" (car value))] - - ;; TODO possibly trim whitespace on text fields - [(cal-address uri text unknown) (car value)] - - [(date) - ;; TODO this is correct, but ensure remaining types - (hashq-set! props 'VALUE "DATE") - (parse-iso-date (car value))] - - [(date-time) (parse-iso-datetime (car value))] - - [(duration) - ((get-parser 'DURATION) props value)] - - [(float integer) ; (3.0) - (string->number (car value))] - - [(period) - (sxml-match - (cons 'period value) - [(period (start ,start-dt) (end ,end-dt)) - (cons (parse-iso-datetime start-dt) - (parse-iso-datetime end-dt))] - [(period (start ,start-dt) (duration ,duration)) - (cons (parse-iso-datetime start-dt) - ((@ (vcomponent duration) parse-duration) duration))])] - - [(recur) - ;; RFC6221 (xcal) Appendix A 3.3.10 specifies that all components should - ;; come in a specified order, and by extension that all components of the - ;; same type should follow each other. Actually checking that is harder - ;; than to just accept anything in any order. It would also make us less - ;; robust for other implementations with other ideas. - (let ((parse-value-of-that-type - (lambda (type value) - (case type - ((wkst) - ((@ (vcomponent recurrence parse) - rfc->datetime-weekday) - (string->symbol value))) - ((freq) (string->symbol value)) - ((until) - ;; RFC 6321 (xcal), p. 30 specifies type-until as - ;; type-until = element until { - ;; type-date | - ;; type-date-time - ;; } - ;; but doesn't bother defining type-date[-time]... - ;; This is acknowledged in errata 3315 [1], but - ;; it lacks a solution... - ;; Seeing as RFC 7265 (jcal) in Example 2 (p. 16) - ;; show the date as a direct string we will roll - ;; with that here to. - ;; [1]: https://www.rfc-editor.org/errata/eid3315 - (string->date/-time value)) - ((byday) ((@@ (vcomponent recurrence parse) parse-day-spec) value)) - ((count interval bysecond bymunite byhour - bymonthday byyearday byweekno - bymonth bysetpos) - (string->number value)) - (else (throw - 'key-error - "Invalid type ~a, with value ~a" - type value)))))) - - ;; freq until count interval wkst - - (apply (@ (vcomponent recurrence internal) make-recur-rule) - (concatenate - (filter identity - (for key in '(bysecond byminute byhour byday bymonthday - byyearday byweekno bymonth bysetpos - freq until count interval wkst) - (define values (assoc-ref-all value key)) - (if (null? values) - #f - (case key - ;; These fields all have zero or one value - ((freq until count interval wkst) - (list (symbol->keyword key) - (parse-value-of-that-type - key (car (map car values))))) - ;; these fields take lists - ((bysecond byminute byhour byday bymonthday - byyearday byweekno bymonth bysetpos) - (list (symbol->keyword key) - (map (lambda (v) (parse-value-of-that-type key v)) - (map car values))) - ) - (else (throw 'error)))))))))] - - [(time) (parse-iso-time (car value))] - - [(utc-offset) ((get-parser 'UTC-OFFSET) props (car value))] - - [(geo) ; ((long 1) (lat 2)) - (sxml-match - (cons 'geo value) - [(geo (latitude ,x) (longitude ,y)) - ((@ (vcomponent geo) make-geo) x y)])])) - -(define (symbol-upcase symb) - (-> symb - symbol->string - string-upcase - string->symbol)) - -(define (handle-parameters parameters) - - (define ht (make-hash-table)) - - (for param in parameters - (match param - [(ptag (ptype pvalue ...) ...) - ;; TODO parameter type (rfc6321 3.5.) - ;; TODO multi-valued parameters!!! - (hashq-set! ht (symbol-upcase ptag) - (car (concatenate pvalue)))])) - ht) - -(define* (parse-enum str enum optional: (allow-other #t)) - (let ((symb (string->symbol str))) - (unless (memv symb enum) - (warning "~a ∉ { ~{~a~^, ~} }" symb enum)) - symb)) - - -;; symbol non-list -> non-list -(define (handle-tag tag-name data) - (case tag-name - [(request-status) - ;; TODO - (warning "Request status not yet implemented") - #f] - - ((transp) (parse-enum - data '(OPAQUE TRANSPARENT) #f)) - ((class) (parse-enum - data '(PUBLIC PRIVATE CONFIDENTIAL))) - ((partstat) (parse-enum - data '(NEEDS-ACTION ACCEPTED DECLINED TENTATIVE - DELEGATED IN-PROCESS))) - ((status) (parse-enum - data '(TENTATIVE CONFIRMED CANCELLED NEEDS-ACTION COMPLETED - IN-PROCESS DRAFT FINAL CANCELED))) - ((action) (parse-enum - data '(AUDIO DISPLAY EMAIL NONE))) - [else data])) - -;; Note -;; This doesn't verify the inter-field validity of the object, -;; meaning that value(DTSTART) == DATE and value(DTEND) == DATE-TIME -;; are possibilities, which other parts of the code will crash on. -;; TODO -;; since we are feeding user input into this it really should be fixed. -(define-public (sxcal->vcomponent sxcal) - (define type (symbol-upcase (car sxcal))) - (define component (make-vcomponent type)) - - (awhen (assoc-ref sxcal 'properties) - ;; Loop over multi valued fields, creating one vline - ;; for every value. So - ;; KEY;p=1:a,b - ;; would be expanded into - ;; KEY;p=1:a - ;; KEY;p=1:b - (for property in it - (match property - ;; TODO request-status - - [(tag ('parameters parameters ...) - (type value ...) ...) - (let ((params (handle-parameters parameters)) - (tag* (symbol-upcase tag))) - (for (type value) in (zip type value) - ;; ignore empty fields - ;; mostly for - (unless (null? value) - (let () - (define vline - (make-vline tag* - (handle-tag - tag (handle-value type params value)) - params)) - (if (memv tag* '(ATTACH ATTENDEE CATEGORIES - COMMENT CONTACT EXDATE - REQUEST-STATUS RELATED-TO - RESOURCES RDATE - ;; x-prop - ;; iana-prop - )) - (aif (prop* component tag*) - (set! (prop* component tag*) (cons vline it)) - (set! (prop* component tag*) (list vline))) - ;; else - (set! (prop* component tag*) vline)) - ))))] - - [(tag (type value ...) ...) - (for (type value) in (zip type value) - ;; ignore empty fields - ;; mostly for - (unless (null? value) - (let ((params (make-hash-table)) - (tag* (symbol-upcase tag))) - (define vline - (make-vline tag* - (handle-tag - tag (let ((v (handle-value type params value))) - ;; TODO possibly more list fields - (if (eq? tag 'categories) - (string-split v #\,) - v))) - params)) - ;; - - (if (memv tag* '(ATTACH ATTENDEE CATEGORIES - COMMENT CONTACT EXDATE - REQUEST-STATUS RELATED-TO - RESOURCES RDATE - ;; x-prop - ;; iana-prop - )) - (aif (prop* component tag*) - (set! (prop* component tag*) (cons vline it)) - (set! (prop* component tag*) (list vline))) - ;; else - (set! (prop* component tag*) vline)) - )))]))) - - ;; children - (awhen (assoc-ref sxcal 'components) - (for child in (map sxcal->vcomponent it) - (add-child! component child))) - - component) diff --git a/module/vcomponent/xcal/types.scm b/module/vcomponent/xcal/types.scm deleted file mode 100644 index 468400f4..00000000 --- a/module/vcomponent/xcal/types.scm +++ /dev/null @@ -1,54 +0,0 @@ -(define-module (vcomponent xcal types) - :use-module (calp util) - :use-module (vcomponent ical types) - :use-module (datetime) - ) - -(define (write-boolean _ v) - `(boolean ,(if v "true" "false"))) - -(define (write-date _ v) - `(date ,(date->string v "~Y-~m-~d"))) - -(define (write-datetime p v) - `(date-time - ,(datetime->string - (hashq-ref p '-X-HNH-ORIGINAL v) - ;; 'Z' should be included for UTC, - ;; other timezones MUST be specified - ;; in the TZID parameter. - "~Y-~m-~dT~H:~M:~S~Z"))) - -(define (write-time _ v) - `(time ,(time->string v "~H:~M:S"))) - -(define (write-recur _ v) - `(recur ,@((@@ (vcomponent recurrence internal) recur-rule->rrule-sxml) v))) - -;; sepparate since this text shouldn't be escaped -(define (write-text _ v) - ;; TODO out type should be xsd:string. - ;; Look into what that means, and escape - ;; from there - `(text ,v)) - - - -(define sxml-writers (make-hash-table)) -(for simple-type in '(BINARY DURATION CAL-ADDRESS DURATION FLOAT INTEGER - #| TODO PERIOD |# URI UTC-OFFSET) - (hashq-set! sxml-writers simple-type - (lambda (p v) - `(,(downcase-symbol simple-type) - ,(((@ (vcomponent ical types) get-writer) simple-type) p v))))) - -(hashq-set! sxml-writers 'BOOLEAN write-boolean) -(hashq-set! sxml-writers 'DATE write-date) -(hashq-set! sxml-writers 'DATE-TIME write-datetime) -(hashq-set! sxml-writers 'TIME write-time) -(hashq-set! sxml-writers 'RECUR write-recur) -(hashq-set! sxml-writers 'TEXT write-text) - -(define-public (get-writer type) - (or (hashq-ref sxml-writers type #f) - (error "No writer for type" type))) diff --git a/tests/datetime.scm b/tests/datetime.scm index 5bf2df6d..1eb3fb3b 100644 --- a/tests/datetime.scm +++ b/tests/datetime.scm @@ -149,3 +149,5 @@ #2020-02-29 (date+ #2020-02-28 (date day: 1))) + +;; TODO string->date family diff --git a/tests/param.scm b/tests/param.scm index a60e8d47..c5a23cbe 100644 --- a/tests/param.scm +++ b/tests/param.scm @@ -4,7 +4,7 @@ ;;; Code: (((vcomponent base) param prop* parameters prop) - ((vcomponent parse) parse-calendar) + ((vcomponent formats ical parse) parse-calendar) ((vcomponent) make-vcomponent) ((calp util) sort* set!)) diff --git a/tests/recurrence-simple.scm b/tests/recurrence-simple.scm index bbe6dd9d..cd170976 100644 --- a/tests/recurrence-simple.scm +++ b/tests/recurrence-simple.scm @@ -11,8 +11,8 @@ ((calp util exceptions) warnings-are-errors warning-handler) ((guile) format @@) - ((vcomponent) parse-calendar) - ((vcomponent xcal parse) sxcal->vcomponent) + ((vcomponent formats ical parse) parse-calendar) + ((vcomponent formats xcal parse) sxcal->vcomponent) ((vcomponent recurrence) parse-recurrence-rule make-recur-rule @@ -243,7 +243,7 @@ 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 xcal parse) handle-value) + ((@@ (vcomponent formats xcal parse) handle-value) 'recur 'props-are-unused-for-recur '((freq "WEEKLY") (interval "1") diff --git a/tests/run-tests.scm b/tests/run-tests.scm index 4f871299..6ec8dea7 100755 --- a/tests/run-tests.scm +++ b/tests/run-tests.scm @@ -115,7 +115,8 @@ (append modules '(((srfi srfi-64) test-assert test-equal test-error - test-eqv) + test-eqv test-eq + test-approximate) ((ice-9 ports) call-with-input-string) ((guile) make-struct/no-tail) ) diff --git a/tests/vcomponent-control.scm b/tests/vcomponent-control.scm index a1300a8c..1f4d6801 100644 --- a/tests/vcomponent-control.scm +++ b/tests/vcomponent-control.scm @@ -2,8 +2,8 @@ ;; Tests that with-replaced-properties work. ;;; Code: -(((vcomponent control) with-replaced-properties) - ((vcomponent) parse-calendar) +(((vcomponent util control) with-replaced-properties) + ((vcomponent formats ical parse) parse-calendar) ((vcomponent base) prop)) diff --git a/tests/vcomponent-datetime.scm b/tests/vcomponent-datetime.scm index 0bc584f6..0f410979 100644 --- a/tests/vcomponent-datetime.scm +++ b/tests/vcomponent-datetime.scm @@ -8,7 +8,7 @@ datetime) ((vcomponent datetime) event-length/clamped) - ((vcomponent) parse-calendar) + ((vcomponent formats ical parse) parse-calendar) ) (define ev (call-with-input-string diff --git a/tests/vcomponent-formats-common-types.scm b/tests/vcomponent-formats-common-types.scm new file mode 100644 index 00000000..d9c80ff9 --- /dev/null +++ b/tests/vcomponent-formats-common-types.scm @@ -0,0 +1,115 @@ +(((vcomponent formats common types) + get-parser) + ((datetime) date time datetime)) + + + +(define parse-binary (get-parser 'BINARY)) +;; TODO + + + +(define parse-boolean (get-parser 'BOOLEAN)) + +(test-equal #t (parse-boolean #f "TRUE")) +(test-equal #f (parse-boolean #f "FALSE")) + +(test-error 'warning (parse-boolean #f "ANYTHING ELSE")) + + + +(define parse-cal-address (get-parser 'CAL-ADDRESS)) + +(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")) +;; TODO negative test here + + + +(define parse-datetime (get-parser 'DATE-TIME)) + +(test-equal #2021-12-02T10:20:30 + (parse-datetime (make-hash-table) "20211202T102030")) + +;; TODO tests with timezones here +;; TODO test -X-HNH-ORIGINAL here + +;; TODO negative test here + + + +(define parse-duration (get-parser 'DURATION)) + +;; assume someone else tests this one +;; (test-eq (@ (vcomponent duration) parse-duration) +;; parse-duration) + + + +(define parse-float (get-parser 'FLOAT)) + +(test-equal 1.0 (parse-float #f "1.0")) +(test-equal 1 (parse-float #f "1")) +(test-equal 1/2 (parse-float #f "1/2")) + +;; TODO negative test here? + + + +(define parse-integer (get-parser 'INTEGER)) + +(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")) + +(test-equal "But exact floats are" + 1.0 (parse-integer #f "1.0")) + + + +(define parse-period (get-parser 'PERIOD)) + +;; TODO + + + +(define parse-recur (get-parser 'RECUR)) + +;; (test-eq (@ (vcomponent recurrence parse) parse-recurrence-rule)) + + + +(define parse-text (get-parser 'TEXT)) + +;; TODO + + + +(define parse-time (get-parser 'TIME)) + +(test-equal #10:20:30 (parse-time #f "102030")) +;; TODO negative test here + + + +(define parse-uri (get-parser 'URI)) + +(test-equal "Test uri is passthrough" 74 (parse-uri #f 74)) + + + +(define parse-utc-offset (get-parser 'UTC-OFFSET)) + +;; TODO diff --git a/tests/vcomponent.scm b/tests/vcomponent.scm index 28f1cf91..acdb970b 100644 --- a/tests/vcomponent.scm +++ b/tests/vcomponent.scm @@ -3,7 +3,7 @@ ;;; Code: (((vcomponent base) prop) - ((vcomponent) parse-calendar)) + ((vcomponent formats ical parse) parse-calendar)) (define ev (call-with-input-string "BEGIN:DUMMY diff --git a/tests/xcal.scm b/tests/xcal.scm index babb2218..df8a5135 100644 --- a/tests/xcal.scm +++ b/tests/xcal.scm @@ -3,9 +3,9 @@ ;; Currently only checks that events survive a round trip. ;;; Code: -(((vcomponent xcal parse) sxcal->vcomponent) - ((vcomponent xcal output) vcomponent->sxcal) - ((vcomponent ical parse) parse-calendar) +(((vcomponent formats xcal parse) sxcal->vcomponent) + ((vcomponent formats xcal output) vcomponent->sxcal) + ((vcomponent formats ical parse) parse-calendar) ((calp util) ->) ((vcomponent base) parameters prop* children) -- cgit v1.2.3