Add xcal output!

3 files changed, 204 insertions, 25 deletions

diff --git a/module/output/sxml-types.scm b/module/output/sxml-types.scm
new file mode 100644
index 00000000..623ff9e8
--- /dev/null
+++ b/module/output/sxml-types.scm
@@ -0,0 +1,53 @@
+(define-module (output sxml-types)
+  :use-module (util)
+  :use-module (output types)
+  :use-module (datetime)
+  :use-module (datetime util)
+  )
+
+(define (write-boolean _ v)
+  `(boolean ,(if v "true" "false")))
+
+(define (write-date _ value)
+  `(date ,(date->string v "~Y-~m-~d")))
+
+(define (write-datetime p v)
+  ;; TODO TZID?
+  (datetime->string
+   (hashq-ref p 'X-HNH-ORIGINAL v)
+   ;; TODO ~z?
+   "~Y-~m-~dT~H:~M:~S~Z"))
+
+(define (write-time _ v)
+  (time->string v "~H:~M:S"))
+
+(define (write-recur _ v)
+  `(recur ,@(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)
+                     ,((get-writer simple-type) p v)))))
+
+(hashq-set! sxml-writers 'BOOLEAN write-boolean)
+(hashq-set! sxml-writers 'DATE write-date)
+(hashq-set! sxml-writers 'DATE-TIME write-datetime)
+(hashq-set! sxml-writers 'TIME write-time)
+(hashq-set! sxml-writers 'RECUR write-recur)
+(hashq-set! sxml-writers 'TEXT write-text)
+
+(define-public (get-writer type)
+  (or (hashq-ref sxml-writers type #f)
+      (error "No writer for type" type)))
diff --git a/module/output/xcal.scm b/module/output/xcal.scm
new file mode 100644
index 00000000..554955c5
--- /dev/null
+++ b/module/output/xcal.scm
@@ -0,0 +1,108 @@
+(define-module (output xcal)
+  :use-module (util)
+  :use-module (util exceptions)
+  :use-module (vcomponent)
+  :use-module (vcomponent geo)
+  :use-module (output sxml-types)
+  :use-module (ice-9 match)
+  :use-module (output common)
+  :use-module (datetime)
+  :use-module (datetime util)
+  )
+
+
+(define (vline->value-tag vline)
+  (define key (vline-key vline))
+
+  (define writer
+   (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))
+     (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-public (vcomponent->sxml component)
+  `(,(downcase-symbol (type component))
+    (properties
+     ,@(hash-map->list
+        (match-lambda*
+          [(? (compose internal-field? car)) '()]
+
+          ;; TODO parameters
+
+          [(key (vlines ...))
+           `(,(downcase-symbol key)
+             #;
+             ,(unless (null? (properties vline))
+                `(parameters
+                  ,@(map vline->value-tag (properties vline))))
+             ,@(for vline in vlines
+                    (vline->value-tag vline)))]
+
+          [(key vline)
+           `(,(downcase-symbol key)
+             #;
+             ,(unless (null? (properties vline))
+                `(parameters
+                  ,@(map vline->value-tag (properties vline))))
+             ,(vline->value-tag vline))])
+        (attributes component)))
+    (components ,@(map vcomponent->sxml (children component)))))
+
+(define-public (main calendar)
+  `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+          (icalendar (@ (xmlns "urn:ietf:params:xml:ns:icalendar-2.0"))
+                     ,(vcomponent->sxml calendar))))
diff --git a/module/vcomponent/recurrence/internal.scm b/module/vcomponent/recurrence/internal.scm
index b15ce90e..8c295bb9 100644
--- a/module/vcomponent/recurrence/internal.scm
+++ b/module/vcomponent/recurrence/internal.scm
@@ -82,36 +82,54 @@
              (datetime)
              (srfi srfi-1))
 
-(define-public (recur-rule->rrule-string rrule)
+(define (field->string field value)
+  (case field
+    [(wkst)
+     (string-upcase
+      (week-day-name value 2
+                     locale: (make-locale (list LC_TIME) "C")))]
+    [(byday)
+     (string-join (map byday->string value) ",")]
+    [(freq count interval)
+     (format #f "~a" value)]
+    [(until)
+     (if (date? value)
+         (date->string value "~Y~m~d")
+         (datetime->string value "~Y~m~dT~H~M~S~Z"))]
+    [else (format #f "~{~a~^,~}" value)]))
+
+(define (map-fields proc rrule)
   (define (get f)
     ((record-accessor <recur-rule> f) rrule))
+  (filter-map
+   (lambda (field)
+     (if (not (get field))
+         #f (proc field (get field))))
+   (record-type-fields <recur-rule>)))
+
+(define-public (recur-rule->rrule-string rrule)
   (string-join
-   (filter-map
-    (lambda (field)
-      (if (not (get field))
-          #f
-          (string-append
-           (string-upcase (symbol->string field))
-           "="
-           (case field
-             [(wkst)
-              (string-upcase
-               (week-day-name (get field) 2
-                              locale: (make-locale (list LC_TIME) "C")))]
-             [(byday)
-              (string-join (map byday->string (get field)) ",")]
-             [(freq count interval)
-              (format #f "~a" (get field))]
-             [(until)
-              (let ((o (get field)))
-                (if (date? o)
-                    (date->string o "~Y~m~d")
-                    (datetime->string o "~Y~m~dT~H~M~S~Z")
-                    ))]
-             [else (format #f "~{~a~^,~}" (get field))]))))
-    (record-type-fields <recur-rule>))
+   (map-fields
+    (lambda (field value)
+      (string-append
+       (string-upcase (symbol->string field))
+       "=" (field->string field value)))
+    rrule)
    ";"))
 
+(define (downcase-symbol symb)
+  (-> symb
+      symbol->string
+      string-downcase
+      string->symbol))
+
+(define-public (recur-rule->rrule-sxml rrule)
+  (map-fields
+   (lambda (field value)
+    `(,(downcase-symbol field)
+      ,(field->string filed value)))
+   rrule))
+