ICS writer now handles types and parameters.

2 files changed, 198 insertions, 69 deletions

diff --git a/module/output/ical.scm b/module/output/ical.scm
index fd4091ed..7773cce7 100644
--- a/module/output/ical.scm
+++ b/module/output/ical.scm
@@ -14,69 +14,85 @@
   :use-module (datetime zic)
   :use-module (glob)
   :use-module (vcomponent recurrence)
+  :use-module (output types)
   )
 
+;; TODO this is also defined @ (vcomponent parse component)
+(define (x-property? symb)
+  (string=? "X-" (string-take (symbol->string symb) 2)))
+
 ;; Format value depending on key type.
 ;; Should NOT emit the key.
 (define (value-format key vline)
-  (define (handle-value value)
-    (catch #t #; 'wrong-type-arg
-      (lambda ()
-        (case key
-          ((DTSTART DTEND RECURRENCE-ID DTSTAMP
-                    LAST-MODIFIED EXDATE)
-           (with-output-to-string
-             (lambda ()
-               (case (and=> (prop vline 'VALUE) car)
-                 [(DATE) (display (date->string (as-date value)
-                                                "~Y~m~d"))]
-                 [else              ; (DATE-TIME)
-                  (display (datetime->string value "~Y~m~dT~H~M~S"))
-                  (let ((tz (and=> (prop vline 'TZID) car)))
-                    (when (and tz (string= tz "UTC"))
-                      (display #\Z)))]))))
-
-          [(TZOFFSETFROM TZOFFSETTO)
-           (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")))))]
-
-          [(RRULE)
-           ((@ (vcomponent recurrence internal)
-               recur-rule->rrule-string) value)]
-
-          (else
-           (escape-chars value)
-           )))
-      (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
-        )))
-
-  (if (list? (value vline))
-      (format #f "~{~a~^,~}"
-              (map handle-value (value vline)))
-      (handle-value (value vline))))
-
-(define (escape-chars str)
-  (define (escape char)
-    (string #\\ char))
-  (string-concatenate
-   (map (lambda (c)
-          (case c
-            ((#\newline) "\\n")
-            ((#\, #\; #\\) => escape)
-            (else => string)))
-        (string->list str))))
 
+  (define writer
+    ;; fields which can hold lists need not be considered here,
+    ;; since they are split into multiple vlines when we parse them.
+    (cond
+     [(and=> (prop vline 'VALUE) string->symbol) => 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))
+      (error "Fuck you")]
+
+     [(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)))
 
 (define (generate-uuid)
   ((@ (rnrs io ports) call-with-port)
@@ -102,6 +118,26 @@
             (string-take-to (symbol->string symbol)
                             (string-length prefix))))
 
+(define (->string a)
+  (with-output-to-string (lambda () (display a))))
+
+(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 (get-writer 'TEXT) ->string) values)
+                           "," 'infix))])
+          (properties vline)))
+    ":" (value-format key vline))))
+
 (define-public (component->ical-string component)
   (format #t "BEGIN:~a\r\n" (type component))
   ;; TODO this leaks internal information,
@@ -115,21 +151,11 @@
 
      [(key (vlines ...))
       (for vline in vlines
-           (display
-            (ical-line-fold
-             ;; Expected output: key;p1=v;p3=10:value
-             (format #f "~a~:{;~a=~@{~a~^,~}~}:~a"
-                     key (properties vline)
-                     (value-format key vline))))
+           (display (vline->string vline))
            (display "\r\n"))]
 
      [(key vline)
-      (display
-       (ical-line-fold
-        ;; Expected output: key;p1=v;p3=10:value
-        (format #f "~a~:{;~a=~@{~a~^,~}~}:~a"
-                key (properties vline)
-                (value-format key vline))))
+      (display (vline->string vline))
       (display "\r\n")])
    (attributes component))
   (for-each component->ical-string (children component))
diff --git a/module/output/types.scm b/module/output/types.scm
new file mode 100644
index 00000000..08ac878a
--- /dev/null
+++ b/module/output/types.scm
@@ -0,0 +1,103 @@
+;; see (vcomponent parse types)
+(define-module (output types)
+  :use-module (util)
+  :use-module (util exceptions)
+  :use-module (util base64)
+  :use-module (datetime)
+  :use-module (datetime util)
+  :use-module (rnrs io ports))
+
+
+(define (write-binary _ value)
+  (bytevector->string (bytevector->base64 value)
+                      (make-transcoder (latin-1-codec))))
+
+(define (write-boolean _ value)
+  (if value "TRUE" "FALSE"))
+
+(define (write-date _ value)
+  (date->string value "~Y~m~d"))
+
+(define (write-datetime prop value)
+  (datetime->string (hashq-ref prop 'X-HNH-ORIGINAL value)
+                    ;; TODO ~Z ?
+                    "~Y~m~dT~H~M~S~Z"
+                    #;
+                    (let ((tz (and=> (prop vline 'TZID) car)))
+                    (when (and tz (string= tz "UTC"))
+                      (display #\Z)))))
+
+;; TODO
+(define (write-duration _ value)
+  (warning "DURATION writer not yet implemented")
+  (with-output-to-string
+    (lambda () (write 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 (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)))