Add xcal parser.

1 files changed, 149 insertions, 0 deletions

diff --git a/module/vcomponent/parse/xcal.scm b/module/vcomponent/parse/xcal.scm
new file mode 100644
index 00000000..2e4b80aa
--- /dev/null
+++ b/module/vcomponent/parse/xcal.scm
@@ -0,0 +1,149 @@
+(define-module (vcomponent parse xcal)
+  :use-module (util)
+  :use-module (util exceptions)
+  :use-module (util base64)
+  :use-module (ice-9 match)
+  :use-module (sxml match)
+  :use-module (vcomponent)
+  :use-module (vcomponent geo)
+  :use-module (vcomponent parse types)
+  :use-module (datetime)
+  :use-module (srfi srfi-1)
+  )
+
+;; symbol, ht, (list a) -> non-list
+(define (handle-value type props value)
+  (case type
+
+    [(binary)
+     ;; TODO rfc6321 allows whitespace in binary?
+     (base64-string->bytevector (car value))]
+
+    [(boolean) (string=? "true" (car value))]
+
+    [(cal-address uri text unknown) (car 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)
+     (apply (@ (vcomponent recurrence internal) make-recur-rule)
+            (for (k v) in value
+                 (list (symbol->keyword k) v)))]
+
+    [(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 ...) ...)
+          ;; TOOD 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]))
+
+(define-public (sxcal->vcomponent sxcal)
+  (define type (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)
+                        (set! (attr* component tag*)
+                          (make-vline tag*
+                                      (handle-tag
+                                       tag (handle-value type params value))
+                                      params))))]
+
+                [(tag (type value ...) ...)
+                 (for (type value) in (zip type value)
+                      (let ((params (make-hash-table))
+                            (tag* (symbol-upcase tag)))
+                        (set! (attr* component tag*)
+                          (make-vline tag*
+                                      (handle-tag
+                                       tag (handle-value type params value))
+                                      params))))])))
+
+  ;; children
+  (awhen (assoc-ref sxcal 'components)
+         (for child in (map sxcal->vcomponent it)
+              (add-child! component child)))
+
+  component)