Cleanup modules.

Primarly this moves all vcompenent input and output code to clearly
labeled modules, instead of being spread out. At the same time it also
removes a handfull of unused procedures.

3 files changed, 446 insertions, 0 deletions

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)))