Map all fields into types.

2 files changed, 147 insertions, 38 deletions

diff --git a/module/vcomponent/parse/component.scm b/module/vcomponent/parse/component.scm
index 70af3963..9ab9c004 100644
--- a/module/vcomponent/parse/component.scm
+++ b/module/vcomponent/parse/component.scm
@@ -6,6 +6,7 @@
   :use-module (datetime)
   :use-module (srfi srfi-1)
   :use-module (srfi srfi-26)
+  :use-module (vcomponent parse types)
  )
 
 (define-public (parse-calendar port)
@@ -43,43 +44,115 @@
        (cons -1 semi-idxs)
        semi-idxs))
 
+(define (x-property? symb)
+  (string=? "X-" (string-take (symbol->string symb) 2)))
+
+#;
+'(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)
+  (let ((parser (get-parser 'TEXT)))
+    (lambda (params value)
+      (let ((vv (parser params value)))
+        (when (list? vv)
+          (error ""))
+        (let ((v (symbol->string vv)))
+          (unless (memv v enum)
+            (warning ""))
+          v)))))
+
 ;; params could be made optional, with an empty hashtable as default
 (define (build-vline key value params)
-  (case key
-    [(DTSTART DTEND RECURRENCE-ID LAST-MODIFIED DTSTAMP EXDATE)
-
-     ;; '("Africa/Ceuta" "Europe/Stockholm" "local")
-     (let ((tz (or (hashq-ref params 'TZID)
-                   (and (string= "Z" (string-take-right value 1)) "UTC"))))
-
-       (let ((type (hashq-ref params 'VALUE)))
-         (if (or (and=> type (cut string=? <> "DATE-TIME"))
-                 (string-index value #\T))
-             ;; we move all parsed datetimes to local time here. This
-             ;; gives a MASSIVE performance boost over calling get-datetime
-             ;; in all procedures which want to guarantee local time for proper calculations.
-             ;; 20s vs 70s runtime on my laptop.
-             (let ((datetime (parse-ics-datetime value tz)))
-               (hashq-set! params 'VALUE 'DATE-TIME)
-               (values (make-vline key (get-datetime datetime) params)
-                       (make-vline (symbol-append 'X-HNH-ORIGINAL- key) datetime params)))
-             (begin (hashq-set! params 'VALUE 'DATE)
-                    (make-vline key (parse-ics-date value) params)))))]
-
-    [else
-     (make-vline key
-                 (list->string
-                  (let loop ((rem (string->list value)))
-                    (if (null? rem)
-                        '()
-                        (if (char=? #\\ (car rem))
-                            (case (cadr rem)
-                              [(#\n #\N) (cons #\newline (loop (cddr rem)))]
-                              [(#\; #\, #\\) => (lambda (c) (cons c (loop (cddr rem))))]
-                              [else => (lambda (c) (warning "Non-escapable character: ~a" c)
-                                          (loop (cddr rem)))])
-                            (cons (car rem) (loop (cdr rem)))))))
-                 params)]))
+  (let ((parser
+         (cond
+          [(hashq-ref params 'TYPE) => get-parser]
+
+          [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID  RDATE
+                              CREATED DTSTAMP LAST-MODIFIED))
+           (get-parser 'DATE-TIME)]
+
+          [(memv key '(EXDATE))
+           (list-parser 'DATE-TIME)]
+
+          [(memv key '(DURATION))
+           (get-parser 'DURATION)]
+
+          [(memv key '(FREEBUSY))
+           (list-parser 'PERIOD)]
+
+          [(memv key '(CALSCALE METHOD PRODID  COMMENT DESCRIPTION
+                             LOCATION STATUS SUMMARY TZID TZNAME
+                             CONTACT RELATED-TO UID))
+           (lambda (params value)
+             (let ((v ((get-parser 'TEXT) params value)))
+               (when (list? v)
+                 (warning "List in non-list field"))
+               v))]
+
+          ;; TEXT, but allow a list
+          [(memv key '(CATEGORIES RESOURCES))
+           (get-parser 'TEXT)]
+
+          [(memv key '(VERSION))
+           (lambda (params value)
+             (let ((v ((get-parser 'TEXT) params value)))
+               (unless (string=? "2.0" v)
+                 (warning "File of unsuported version. Proceed with caution"))))]
+
+          [(memv key '(TRANSP))
+           (enum-parser '(OPAQUE TRANSPARENT))]
+
+          [(memv key '(CLASS))
+           (enum-parser '(PUBLIC PRIVATE CONFIDENTIAL) #t)]
+
+          ;; TODO
+          [(memv key '(REQUEST-STATUS))]
+
+          [(memv key '(ACTION))
+           (enum-parser '(AUDIO DISPLAY EMAIL) #t)]
+
+          [(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 #\;)))
+               (cons ((get-parser 'FLOAT) params left)
+                     ((get-parser 'FLOAT) params right))))]
+
+          [(memv key '(RRULE))
+           ;; TODO date/datetime
+           (get-parser 'RECUR)]
+
+          [(memv key '(ORGANIZER ATTENDEE))
+           (get-parser 'CAL-ADDRESS)]
+
+          [(x-property? key)
+           (get-parser 'TEXT)]
+
+          [else
+           (warning "Unknown key ~a" key)
+           (get-parser 'TEXT)])))
+    (make-vline key (parser params value) params)))
 
 ;; (parse-itemline '("DTEND"  "20200407T130000"))
 ;; => DTEND
diff --git a/module/vcomponent/parse/types.scm b/module/vcomponent/parse/types.scm
index 2468f038..7472b8c2 100644
--- a/module/vcomponent/parse/types.scm
+++ b/module/vcomponent/parse/types.scm
@@ -4,6 +4,7 @@
   :use-module (util base64)
   :use-module (rnrs io ports)
   :use-module (datetime)
+  :use-module (srfi srfi-9 gnu)
   )
 
 ;; BINARY
@@ -65,12 +66,27 @@
 
 ;; RECUR
 (define (parse-recur props value)
-  (parse-recurrence-rule value))
+  ((@ (vcomponent recurrence parse) parse-recurrence-rule) value))
 
 ;; TEXT
-;; TODO quoted strings and escaped chars
+;; TODO quoted strings
 (define (parse-text props value)
-  value)
+  (let loop ((rem (string->list value))
+             (str '())
+             (done '()))
+    (if (null? rem)
+        (cons (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
@@ -99,3 +115,23 @@
    (if (= 7 (string-length value))
        (number->string (substring value 5 7))
        0)))
+
+(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)))