9 files changed, 1413 insertions, 0 deletions
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 <line>
+  (make-line string file line)
+  line?
+  (string get-string)
+  (file get-file)
+  (line get-line))
+
+
+;; port → (list <line>)
+(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 <tokens>
+  (make-tokens metadata data)
+  tokens?
+  (metadata get-metadata) ; <line>
+  (data get-data) ; (key kv ... value)
+  )
+
+;; <line> → <tokens>
+(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"
+;; => #<hash-table 7f76b5f82a60 0/31>
+(define (parse-itemline itemline)
+  (define key (string->symbol (car itemline)))
+  (define parameters (make-hash-table))
+  (let loop ((rem (cdr itemline)))
+    (if (null? (cdr rem))
+        (values key (car rem) parameters )
+        (let* ((kv (car rem))
+               (idx (string-index kv #\=)))
+          ;; TODO lists in parameters
+          (hashq-set! parameters (string->symbol (substring kv 0 idx))
+                      (substring kv (1+ idx)))
+          (loop (cdr rem))))))
+
+
+;; (list <tokens>) → <vcomponent>
+(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 "#<eof>" 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 <properties> 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 <text/>
+                        (unless (null? value)
+                          (let ()
+                            (define vline
+                              (make-vline tag*
+                                          (handle-tag
+                                           tag (handle-value type params value))
+                                          params))
+                            (if (memv tag* '(ATTACH ATTENDEE CATEGORIES
+                                                 COMMENT CONTACT EXDATE
+                                                 REQUEST-STATUS RELATED-TO
+                                                 RESOURCES RDATE
+                                                 ;; x-prop
+                                                 ;; iana-prop
+                                                 ))
+                                (aif (prop* component tag*)
+                                     (set! (prop* component tag*) (cons vline it))
+                                     (set! (prop* component tag*) (list vline)))
+                                ;; else
+                                (set! (prop* component tag*) vline))
+                            ))))]
+
+                [(tag (type value ...) ...)
+                 (for (type value) in (zip type value)
+                      ;; ignore empty fields
+                      ;; mostly for <text/>
+                      (unless (null? value)
+                        (let ((params (make-hash-table))
+                              (tag* (symbol-upcase tag)))
+                          (define vline
+                            (make-vline tag*
+                                        (handle-tag
+                                         tag (let ((v (handle-value type params value)))
+                                               ;; TODO possibly more list fields
+                                               (if (eq? tag 'categories)
+                                                   (string-split v #\,)
+                                                   v)))
+                                        params))
+                          ;;
+
+                          (if (memv tag* '(ATTACH ATTENDEE CATEGORIES
+                                               COMMENT CONTACT EXDATE
+                                               REQUEST-STATUS RELATED-TO
+                                               RESOURCES RDATE
+                                               ;; x-prop
+                                               ;; iana-prop
+                                               ))
+                              (aif (prop* component tag*)
+                                   (set! (prop* component tag*) (cons vline it))
+                                   (set! (prop* component tag*) (list vline)))
+                              ;; else
+                              (set! (prop* component tag*) vline))
+                          )))])))
+
+  ;; children
+  (awhen (assoc-ref sxcal 'components)
+         (for child in (map sxcal->vcomponent it)
+              (add-child! component child)))
+
+  component)
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)))