Merge branch 'front'

12 files changed, 361 insertions, 88 deletions

diff --git a/module/calp/html/components.scm b/module/calp/html/components.scm
index ebc359b8..03e1cef1 100644
--- a/module/calp/html/components.scm
+++ b/module/calp/html/components.scm
@@ -1,6 +1,8 @@
 (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)
   )
 
@@ -112,6 +114,54 @@
                             ,key)
                      (div (@ (class "content")) ,body)))))
 
+(define ((set-attribute attr) el)
+  (match el
+    [(tagname ('@ params ...) inner-body ...)
+     `(,tagname (@ ,@(assq-merge params attr))
+                ,@inner-body)]
+    [(tagname inner-body ...)
+     `(,tagname (@ ,attr)
+                ,@inner-body)]))
+
+
+(define-public (with-label lbl . forms)
+
+  (define id (gensym "label"))
+
+  (cons `(label (@ (for ,id)) ,lbl)
+   (let recurse ((forms forms))
+     (map (lambda (form)
+            (cond [(not (list? form)) form]
+                  [(null? form) '()]
+                  [(eq? 'input (car form))
+                   ((set-attribute `((id ,id))) form)]
+                  [(list? (car form))
+                   (cons (recurse (car form))
+                         (recurse (cdr form)))]
+                  [else
+                   (cons (car form)
+                         (recurse (cdr form)))]))
+          forms))))
+
+
+(define-public (form elements)
+  `(form
+    ,@(map (label self
+                  (lambda (el)
+                    (match el
+                      ((name ('@ tags ...) body ...)
+                       (let ((id (gensym "formelement")))
+                         (cons
+                          `(label (@ (for ,id)) ,name)
+                          (map
+                           (set-attribute `((name ,name)))
+                           (cons
+                            ((set-attribute `((id ,id))) (car body))
+                            (cdr body))))))
+                      ((name body ...)
+                       (self `(,name (@) ,@body))))))
+           elements)))
+
 
 (define-public (include-css path . extra-attributes)
   `(link (@ (type "text/css")
diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm
index c4e15374..fbf344b0 100644
--- a/module/calp/html/vcomponent.scm
+++ b/module/calp/html/vcomponent.scm
@@ -5,9 +5,10 @@
   :use-module (srfi srfi-41)
   :use-module (datetime)
   :use-module ((text util) :select (add-enumeration-punctuation))
+  :use-module ((web uri-query) :select (encode-query-parameters))
   :use-module (calp html util)
   :use-module ((calp html config) :select (edit-mode))
-  :use-module ((calp html components) :select (btn tabset))
+  :use-module ((calp html components) :select (btn tabset form with-label))
   :use-module ((calp util color) :select (calculate-fg-color))
   :use-module ((vcomponent datetime output)
                :select (fmt-time-span
@@ -56,18 +57,21 @@
   ;; (format (current-error-port) "fmt-single-event: ~a~%" (prop ev 'X-HNH-FILENAME))
   `(div (@ ,@(assq-merge
               attributes
-              `((class " eventtext "
+              `((class " eventtext summary-tab "
                   ,(when (and (prop ev 'PARTSTAT)
                               (eq? 'TENTATIVE (prop ev 'PARTSTAT)))
                      " tentative ")))))
         (h3 ,(fmt-header
               (when (prop ev 'RRULE)
                 `(span (@ (class "repeating")) "↺"))
-              `(span (@ (class "summary")) ,(prop ev 'SUMMARY))))
+              `(span (@ (class "bind summary")
+                        (data-property "summary"))
+                     ,(prop ev 'SUMMARY))))
         (div
          ,(call-with-values (lambda () (fmt-time-span ev))
             (case-lambda [(start)
-                          `(div (time (@ (class "dtstart")
+                          `(div (time (@ (class "bind dtstart")
+                                         (data-property "dtstart")
                                          (data-fmt ,(string-append "~L" start))
                                          (datetime ,(datetime->string
                                                      (as-datetime (prop ev 'DTSTART))
@@ -76,7 +80,8 @@
                                         (as-datetime (prop ev 'DTSTART))
                                         start)))]
                          [(start end)
-                          `(div (time (@ (class "dtstart")
+                          `(div (time (@ (class "bind dtstart")
+                                         (data-property "dtstart")
                                          (data-fmt ,(string-append "~L" start))
                                          (datetime ,(datetime->string
                                                      (as-datetime (prop ev 'DTSTART))
@@ -84,31 +89,170 @@
                                       ,(datetime->string (as-datetime (prop ev 'DTSTART))
                                                          start))
                                 " — "
-                                (time (@ (class "dtend")
+                                (time (@ (class "bind dtend")
+                                         (data-property "dtend")
                                          (data-fmt ,(string-append "~L" end))
                                          (datetime ,(datetime->string
                                                      (as-datetime (prop ev 'DTSTART))
                                                      "~1T~3")))
                                       ,(datetime->string (as-datetime (prop ev 'DTEND))
                                                          end)))]))
+
+         ;; TODO add optional fields when added in frontend
+         ;; Possibly by always having them here, just hidden.
+
          (div (@ (class "fields"))
           ,(when (and=> (prop ev 'LOCATION) (negate string-null?))
              `(div (b "Plats: ")
-                   (div (@ (class "location"))
+                   (div (@ (class "bind location") (data-property "location"))
                         ,(string-map (lambda (c) (if (char=? c #\,) #\newline c))
                                      (prop ev 'LOCATION)))))
           ,(awhen (prop ev 'DESCRIPTION)
-                  `(span (@ (class "description"))
+                  `(div (@ (class "bind description")
+                           (data-property "description"))
                          ,(format-description ev it)))
+
+          ;; TODO add bind once I figure out how to bind lists
+          ,(awhen (prop ev 'CATEGORIES)
+                  `(div (@ (class "categories"))
+                        ,@(map (lambda (c)
+                                 `(a (@ (class "category")
+                                        ;; TODO centralize search terms
+                                        (href
+                                         "/search/?"
+                                         ,(encode-query-parameters
+                                           `((q . (member
+                                                   ,(->quoted-string c)
+                                                   (or (prop event 'CATEGORIES)
+                                                       '())))))))
+                                     ,c))
+                               it)))
+
+          ;; TODO bind
           ,(awhen (prop ev 'RRULE)
-                  `(span (@ (class "rrule"))
-                         ,@(format-recurrence-rule ev)))
+                  `(div (@ (class "rrule"))
+                        ,@(format-recurrence-rule ev)))
+
           ,(when (prop ev 'LAST-MODIFIED)
-             `(span (@ (class "last-modified")) "Senast ändrad "
-                    ,(datetime->string (prop ev 'LAST-MODIFIED) "~1 ~H:~M"))))
+             `(div (@ (class "last-modified")) "Senast ändrad "
+                   ,(datetime->string (prop ev 'LAST-MODIFIED) "~1 ~H:~M"))))
 
          )))
 
+(define*-public (fmt-for-edit ev
+                              optional: (attributes '())
+                              key: (fmt-header list))
+  `(div (@ (class " eventtext edit-tab "))
+        (form (@ (class "edit-form"))
+              (div (@ (class "dropdown-goes-here")))
+              (h3 (input (@ (type "text")
+                            (placeholder "Sammanfattning")
+                            (name "summary") (required)
+                            (class "bind") (data-property "summary")
+                            (value ,(prop ev 'SUMMARY)))))
+
+              ,(let ((start (prop ev 'DTSTART))
+                     (end (prop ev 'DTEND)))
+                 `(div (@ (class "timeinput"))
+
+                       (input (@ (type "date")
+                                 (name "dtstart-date")
+                                 (style "grid-column:1;grid-row:2")
+                                 (class "bind")
+                                 (data-property "--dtstart-date")
+                                 (value ,(date->string (as-date start)))))
+
+                       (input (@ (type "date")
+                                 (name "dtend-date")
+                                 (style "grid-column:1;grid-row:3")
+                                 (class "bind")
+                                 (data-property "--dtend-date")
+                                 ,@(when end `((value ,(date->string (as-date end)))))))
+
+                       ,@(with-label
+                          "Heldag?"
+                          `(input (@ (type "checkbox") (style "display:none")
+                                     (name "wholeday"))))
+
+                       (input (@ (type "time")
+                                 (name "dtstart-time")
+                                 (class "bind")
+                                 (data-property "--dtstart-time")
+                                 (style "grid-column:3;grid-row:2;"
+                                   ,(when (date? start) "display:none"))
+                                 (value ,(time->string (as-time start)))))
+
+                       (input (@ (type "time")
+                                 (name "dtend-time")
+                                 (class "bind")
+                                 (data-property "--dtend-time")
+                                 (style "grid-column:3;grid-row:3;"
+                                   ,(when (date? end) "display:none"))
+                                 ,@(when end `((value ,(time->string (as-time end)))))
+                                 ))))
+
+              ,@(with-label
+                 "Plats"
+                 `(input (@ (placeholder "Plats")
+                            (name "location")
+                            (type "text")
+                            (class "bind") (data-property "location")
+                            (value ,(or (prop ev 'LOCATION) "")))))
+
+              ,@(with-label
+                 "Beskrivning"
+                 `(textarea (@ (placeholder "Beskrivning")
+                               (class "bind") (data-property "description")
+                               (name "description"))
+                            ,(prop ev 'DESCRIPTION)))
+
+              ,@(with-label
+                 "Kategorier"
+                 ;; It would be better if these input-list's worked on the same
+                 ;; class=bind system as the fields above. The problem with that
+                 ;; is however that each input-list requires different search
+                 ;; and join procedures. Currently this is bound in the JS, see
+                 ;; [CATEGORIES_BIND].
+                 ;; It matches on ".input-list[data-property='categories']".
+                 `(div (@ (class "input-list")
+                          (data-property "categories"))
+                       ,@(awhen (prop ev 'CATEGORIES)
+                                (map (lambda (c)
+                                       `(input (@ (size 2)
+                                                  (class "unit")
+                                                  (value ,c))))
+                                     it))
+
+                       (input (@ (class "unit final")
+                                 (size 2)
+                                 (type "text")
+                                 ))))
+
+              (hr)
+
+              ;; For custom user fields
+              ;; TODO these are currently not bound to anything, so entering data
+              ;; here does nothing. Bigest hurdle to overcome is supporting arbitrary
+              ;; fields which will come and go in the JavaScript.
+              ;; TODO also, all (most? maybe not LAST-MODIFIED) remaining properties
+              ;; should be exposed here.
+              (div (@ (class "input-list"))
+               (div (@ (class "unit final newfield"))
+                    (input (@ (type "text")
+                              (list "known-fields")
+                              (placeholder "Nytt fält")))
+                    (select (@ (name "TYPE"))
+                      (option (@ (value "TEXT")) "Text"))
+                    (span
+                     (input (@ (type "text")
+                               (placeholder "Värde"))))))
+
+              (hr)
+
+
+              (input (@ (type "submit")))
+              )))
+
 
 ;; Single event in side bar (text objects)
 (define-public (fmt-day day)
@@ -176,10 +320,12 @@
             (div (@ (class "event-body"))
              ,(when (prop ev 'RRULE)
                 `(span (@ (class "repeating")) "↺"))
-             (span (@ (class "summary"))
+             (span (@ (class "bind summary")
+                      (data-property "summary"))
                    ,(format-summary  ev (prop ev 'SUMMARY)))
              ,(when (prop ev 'LOCATION)
-                `(span (@ (class "location"))
+                `(span (@ (class "bind location")
+                          (data-property "location"))
                        ,(string-map (lambda (c) (if (char=? c #\,) #\newline c))
                                     (prop ev 'LOCATION)))))
             (div (@ (style "display:none !important;"))
@@ -238,6 +384,10 @@
              ,(tabset
                 `(("📅" title: "Översikt"
                    ,(fmt-single-event ev))
+
+                  ("📅" title: "Redigera"
+                   ,(fmt-for-edit ev))
+
                   ("⤓" title: "Nedladdning"
                    (div (@ (class "eventtext") (style "font-family:sans"))
                         (h2 "Ladda ner")
@@ -245,6 +395,7 @@
                                    "som iCal"))
                             (li (a (@ (href "/calendar/" ,(prop ev 'UID) ".xcs"))
                                    "som xCal")))))
+
                   ,@(when (prop ev 'RRULE)
                       `(("↺" title: "Upprepningar" class: "repeating"
                          ,(repeat-info ev)))))))))
diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm
index a583d82b..0e90e5d4 100644
--- a/module/calp/html/view/calendar.scm
+++ b/module/calp/html/view/calendar.scm
@@ -104,7 +104,9 @@
     ,(include-alt-css "/static/dark.css"  '(title "Dark"))
     ,(include-alt-css "/static/light.css" '(title "Light"))
 
+    (script (@ (defer) (src "/static/types.js")))
     (script (@ (defer) (src "/static/lib.js")))
+    (script (@ (defer) (src "/static/input_list.js")))
     (script (@ (defer) (src "/static/script.js")))
     ,(calendar-styles calendars))
 
@@ -296,4 +298,27 @@
           ;; TODO merge this into the event-set, add attribute
           ;; for non-displaying elements.
           (div (@ (class "template") (id "popup-template"))
-               ,(popup event (string-append "popup" (html-id event)))))))))
+               ,(popup event (string-append "popup" (html-id event))))))
+
+    ;; Auto-complets when adding new fields to a component
+    ;; Any string is however still valid.
+    (datalist (@ (id "known-fields"))
+              ,@(map (lambda (f)
+                       `(option (@ (value ,f))))
+                     '(CALSCALE
+                       METHOD PRODID VERSION ATTACH
+                       CATEGORIES CLASS COMMENT
+                       DESCRIPTION GEO LOCATION
+                       PERCENT-COMPLETE PRIORITY
+                       RESOURCES STATUS SUMMARY
+                       COMPLETED DTEND DUE DTSTART
+                       DURATION FREEBUSY
+                       TRANSP TZID TZNAME
+                       TZOFFSETFROM TZOFFSETTO
+                       TZURL ATTENDEE CONTACT
+                       ORGANIZER RECURRENCE-ID
+                       RELATED-TO URL EXDATE
+                       RDATE RRULE ACTION REPEAT
+                       TRIGGER CREATED DTSTAMP LAST-MODIFIED
+                       SEQUENCE REQUEST-STATUS
+                       ))))))
diff --git a/module/calp/main.scm b/module/calp/main.scm
index 33da1554..c93ae795 100644
--- a/module/calp/main.scm
+++ b/module/calp/main.scm
@@ -15,6 +15,8 @@
   :use-module (ice-9 getopt-long)
   :use-module (ice-9 regex)
   :use-module ((ice-9 popen) :select (open-input-pipe))
+  :use-module ((ice-9 sandbox) :select
+               (make-sandbox-module all-pure-and-impure-bindings))
 
   :use-module (statprof)
   :use-module (calp repl)
@@ -99,13 +101,26 @@
   (if (null? a)
       b a))
 
-
 (define (wrapped-main args)
   (define opts (getopt-long args (getopt-opt options) #:stop-at-first-non-option #t))
   (define stprof (option-ref opts 'statprof #f))
   (define repl (option-ref opts 'repl #f))
   (define altconfig (option-ref opts 'config #f))
 
+  (define config-file
+    (cond [altconfig
+           (if (file-exists? altconfig)
+               altconfig
+               (throw 'option-error
+                      "Configuration file ~a missing" altconfig))]
+         ;; altconfig could be placed in the list below. But I want to raise an error
+         ;; if an explicitly given config is missing.
+         [(find file-exists?
+                (list
+                 (path-append (xdg-config-home) "/calp/config.scm")
+                 (path-append (xdg-sysconfdir) "/calp/config.scm")))
+          => identity]))
+
   (when stprof (statprof-start))
 
   (cond [(eqv? #t repl) (repl-start (format #f "~a/calp-~a"
@@ -113,18 +128,40 @@
                                             (getpid)))]
         [repl => repl-start])
 
-  (if altconfig
-      (begin
-        (if (file-exists? altconfig)
-            (primitive-load altconfig)
-            (throw 'option-error "Configuration file ~a missing" altconfig)))
-      ;; if not altconfig, then regular config
-
-      (awhen (find file-exists?
-                   (list
-                     (path-append (xdg-config-home) "/calp/config.scm")
-                     (path-append (xdg-sysconfdir) "/calp/config.scm")))
-             (primitive-load it)))
+
+  ;; Load config
+  ;; Sandbox and "stuff" not for security from the user. The config script is
+  ;; assumed to be "safe". Instead it's so we can control the environment in
+  ;; which it is executed.
+  (catch #t
+    (lambda ()
+      (eval
+       `(begin
+          (use-modules (srfi srfi-1)
+                       (srfi srfi-88)
+                       (datetime)
+                       (vcomponent)
+                       (calp util config)
+                       (glob))
+          ,@(with-input-from-file config-file
+              (lambda ()
+                (let loop ((done '()))
+                  (let ((form (read)))
+                    (if (eof-object? form)
+                        (reverse done)
+                        (loop (cons form done))))))))
+       (make-sandbox-module
+        `(((guile) use-modules)
+          ,@all-pure-and-impure-bindings
+          ))
+       ))
+    (lambda args
+      (format (current-error-port)
+              "Failed loading config file ~a~%~s~%"
+              config-file
+              args
+              )))
+
 
 
   ;; NOTE this doesn't stop at first non-option, meaning that -o flags
diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm
index 184b4481..276513f5 100644
--- a/module/calp/server/routes.scm
+++ b/module/calp/server/routes.scm
@@ -218,55 +218,43 @@
               [(get-event-by-uid global-event-object (prop event 'UID))
                => (lambda (old-event)
 
-                    ;; procedure to run after save.
-                    ;; used as hook to remove old event from disk below
-                    (define after-save (const #f))
-
-                    (if (eq? calendar (parent old-event))
-                        (begin (vcomponent-update! old-event event)
-                               ;; for save below
-                               (set! event old-event))
-
-                        ;; change calendar
-                        (begin
-
-                          (format (current-error-port)
-                                  "Calendar change~%")
-
-                          ;; remove from runtime
-                          ((@ (vcomponent instance methods) remove-event)
-                           global-event-object old-event)
-
-                          ;; Actually puring the old event should be safe,
-                          ;; since we first make sure we write the new event to disk.
-                          ;; Currently the whole transaction isn't atomic, so a duplicate
-                          ;; event can still be created.
-                          (set! after-save
-                            ;; remove from disk
-                            (lambda ()
-                              (format (current-error-port)
-                                      "Unlinking old event from ~a~%"
-                                      (prop old-event '-X-HNH-FILENAME))
-                              ((@ (vcomponent vdir save-delete) remove-event) old-event)))
-
-                          (parameterize ((warnings-are-errors #t))
-                            (catch 'warning
-                              (lambda () (add-event global-event-object calendar event))
-                              (lambda (err fmt args)
-                                (return (build-response code: 400)
-                                        (format #f "~?~%" fmt args)))))))
+                    ;; remove old instance of event from runtime
+                    ((@ (vcomponent instance methods) remove-event)
+                     global-event-object old-event)
+
+                    ;; Add new event to runtime,
+                    ;; MUST be done after since the two events SHOULD share UID.
+                    (parameterize ((warnings-are-errors #t))
+                      (catch 'warning
+                        (lambda () (add-event global-event-object calendar event))
+                        (lambda (err fmt args)
+                          (return (build-response code: 400)
+                                  (format #f "~?~%" fmt args)))))
 
                     (set! (prop event 'LAST-MODIFIED)
                       (current-datetime))
 
-
                     ;; NOTE Posibly defer save to a later point.
                     ;; That would allow better asyncronous preformance.
+
+                    ;; save-event sets -X-HNH-FILENAME from the UID. This is fine
+                    ;; since the two events are guaranteed to have the same UID.
                     (unless ((@ (vcomponent vdir save-delete) save-event) event)
                       (return (build-response code: 500)
                               "Saving event to disk failed."))
 
-                    (after-save)
+
+                    (unless (eq? calendar (parent old-event))
+                        ;; change to a new calendar
+                        (format (current-error-port)
+                                "Unlinking old event from ~a~%"
+                                (prop old-event '-X-HNH-FILENAME))
+                        ;; NOTE that this may fail, leading to a duplicate event being
+                        ;; created (since we save beforehand). This is just a minor problem
+                        ;; which either a better atomic model, or a propper error
+                        ;; recovery log would solve.
+                        ((@ (vcomponent vdir save-delete) remove-event) old-event))
+
 
                     (format (current-error-port)
                             "Event updated ~a~%" (prop event 'UID)))]
diff --git a/module/calp/util/config.scm b/module/calp/util/config.scm
index 32dabb69..fbe35d59 100644
--- a/module/calp/util/config.scm
+++ b/module/calp/util/config.scm
@@ -106,10 +106,6 @@
 
 (export format-procedure)
 
-(define (->str any)
-  (with-output-to-string
-    (lambda () (display any))))
-
 (define-public (get-configuration-documentation)
   (define groups
     (group-by (compose source-module car)
diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm
index ae10fe01..34d4416b 100644
--- a/module/vcomponent/base.scm
+++ b/module/vcomponent/base.scm
@@ -169,14 +169,6 @@
                                     (copy-vline value))))
                     (get-component-properties component)))))
 
-;; updates target with all fields from source.
-;; fields in target but not in source left unchanged.
-;; parent and children unchanged
-(define-public (vcomponent-update! target source)
-  (for key in (property-keys source)
-       (set! (prop* target key)
-         (prop* source key))))
-
 (define-public (extract field)
   (lambda (e) (prop e field)))
 
diff --git a/module/vcomponent/ical/output.scm b/module/vcomponent/ical/output.scm
index a0816679..bcc6bb1d 100644
--- a/module/vcomponent/ical/output.scm
+++ b/module/vcomponent/ical/output.scm
@@ -44,12 +44,16 @@
      [(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
 
-                        CATEGORIES RESOURCES
-
                         VERSION))
       (get-writer 'TEXT)]
 
diff --git a/module/vcomponent/ical/parse.scm b/module/vcomponent/ical/parse.scm
index 9c555bca..8499d289 100644
--- a/module/vcomponent/ical/parse.scm
+++ b/module/vcomponent/ical/parse.scm
@@ -135,7 +135,7 @@
              (let ((v ((get-parser 'TEXT) params value)))
                (unless (= 1 (length v))
                  (warning "List in non-list field: ~s" v))
-               (car v)))]
+               (string-join v ",")))]
 
           ;; TEXT, but allow a list
           [(memv key '(CATEGORIES RESOURCES))
diff --git a/module/vcomponent/search.scm b/module/vcomponent/search.scm
index a402bd49..a850fb40 100644
--- a/module/vcomponent/search.scm
+++ b/module/vcomponent/search.scm
@@ -52,6 +52,13 @@
 (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
@@ -63,9 +70,9 @@
   (eval `(lambda (event) ,@expressions)
         (make-sandbox-module
          `(
-           ((vcomponent base) prop param children type)
+           ((vcomponent base) prop param children type parent)
            ((ice-9 regex) string-match)
-           ;; TODO datetime
+           ,@(bindings-for '(datetime))
            ,@all-pure-bindings)
          )))
 
@@ -155,8 +162,11 @@
                   (set-max-page! paginator (max page (get-max-page paginator)))
                   result))))
     (lambda (err proc fmt args data)
-      ;; TODO ensure the error actually is index out of range.
-      ;; (format (current-error-port) "~?~%" fmt args)
+      ;; 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/xcal/parse.scm b/module/vcomponent/xcal/parse.scm
index 17c684fc..6b877b9f 100644
--- a/module/vcomponent/xcal/parse.scm
+++ b/module/vcomponent/xcal/parse.scm
@@ -25,7 +25,10 @@
     ;; TODO possibly trim whitespace on text fields
     [(cal-address uri text unknown) (car value)]
 
-    [(date) (parse-iso-date (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))]
 
@@ -108,6 +111,12 @@
                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))
@@ -147,7 +156,11 @@
                           (set! (prop* component tag*)
                             (make-vline tag*
                                         (handle-tag
-                                          tag (handle-value type params value))
+                                         tag (let ((v (handle-value type params value)))
+                                               ;; TODO possibly more list fields
+                                               (if (eq? tag 'categories)
+                                                   (string-split v #\,)
+                                                   v)))
                                         params)))))])))
 
   ;; children
diff --git a/module/web/http/make-routes.scm b/module/web/http/make-routes.scm
index ab5f88a7..4fb5397a 100644
--- a/module/web/http/make-routes.scm
+++ b/module/web/http/make-routes.scm
@@ -71,6 +71,8 @@
            (r:port    ((@ (web request) request-port)    request)))
        (let ((r:scheme   ((@ (web uri) uri-scheme)   r:uri))
              (r:userinfo ((@ (web uri) uri-userinfo) r:uri))
+             ;; TODO can sometimes be a pair of host and port
+             ;; '("localhost" . 8080). It shouldn't...
              (r:host     (or ((@ (web uri) uri-host) r:uri)
                              ((@ (web request) request-host)
                               request)))
@@ -80,6 +82,11 @@
              (r:path     ((@ (web uri) uri-path)     r:uri))
              (r:query    ((@ (web uri) uri-query)    r:uri))
              (r:fragment ((@ (web uri) uri-fragment) r:uri)))
+         ;; TODO propper logging
+         (display (format #f "[~a] ~a ~a/~a?~a~%"
+                          (datetime->string (current-datetime))
+                          r:method r:host r:path (or r:query ""))
+                  (current-error-port))
          (call-with-values
              (lambda ()
                ((@ (ice-9 control) call/ec)