Change xcal to work on namespaced sxml instead.

5 files changed, 152 insertions, 131 deletions

diff --git a/module/vcomponent/formats/xcal.scm b/module/vcomponent/formats/xcal.scm
index cfc70a92..29a1d92f 100644
--- a/module/vcomponent/formats/xcal.scm
+++ b/module/vcomponent/formats/xcal.scm
@@ -1,5 +1,6 @@
 (define-module (vcomponent formats xcal)
-  :use-module (sxml simple)
+  :use-module (sxml namespaced)
+  :use-module (sxml namespaced util)
   :use-module ((vcomponent formats xcal output)
                :select (vcomponent->sxcal ns-wrap))
   :use-module ((vcomponent formats xcal parse)
@@ -8,16 +9,19 @@
   :export (serialize deserialize))
 
 
-(define (serialize component port)
+(define* (serialize component port key: (namespaces '()))
   (-> (vcomponent->sxcal component)
       ns-wrap
-      (sxml->xml port)
-      ))
+      (namespaced-sxml->xml port: port
+                            namespaces: namespaces)))
 
 (define (serialize/object component)
   (call-with-output-string (lambda (p) (serialize component p))))
 
 
-(define (deserialize port)
-  (-> (xml->sxml port)
+(define* (deserialize port)
+  (-> port
+      xml->namespaced-sxml
+      root-element                      ; Strip potential *TOP*
+      cadr                              ; Remove containing icalendar
       sxcal->vcomponent))
diff --git a/module/vcomponent/formats/xcal/output.scm b/module/vcomponent/formats/xcal/output.scm
index 8e92b280..e4a84efb 100644
--- a/module/vcomponent/formats/xcal/output.scm
+++ b/module/vcomponent/formats/xcal/output.scm
@@ -8,6 +8,9 @@
   :use-module (datetime)
   :use-module (srfi srfi-1)
   :use-module (calp translation)
+  :use-module (calp namespaces)
+  :use-module (sxml namespaced)
+  :use-module (sxml namespaced util)
   :export (vcomponent->sxcal ns-wrap))
 
 
@@ -56,7 +59,7 @@
 
     [(memv key '(GEO))
      (lambda (_ v)
-       `(geo
+       `(,(xml xcal 'geo)
          (latitude ,(geo-latitude v))
          (longitude ,(geo-longitude v))))]
 
@@ -73,16 +76,17 @@
      (warning (G_ "Unknown key ~a") key)
      (get-writer 'TEXT)]))
 
-  (writer ((@@ (vcomponent base) get-vline-parameters) vline) (value vline)))
+  (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)
+      `(,(xml xcal (downcase-symbol tag))
         ,@(map (lambda (v)
                  ;; TODO parameter types!!!! (rfc6321 3.5.)
-                 `(text ,(->string v)))
+                 `(,(xml xcal 'text) ,(->string v)))
                values))))
 
 ;; ((key value ...) ...) -> `(parameters , ... )
@@ -92,15 +96,14 @@
                      parameters))
 
   (unless (null? outparams)
-    `(parameters ,@outparams)))
+    `(,(xml xcal 'parameters) ,@outparams)))
 
 (define (vcomponent->sxcal component)
 
   (define tagsymb (downcase-symbol (type component)))
 
-
   (remove null?
-   `(,tagsymb
+   `(,(xml xcal tagsymb)
      ;; only have <properties> when it's non-empty.
      ,(let ((props
              (filter-map
@@ -109,7 +112,7 @@
 
                 [(key vlines ...)
                  (remove null?
-                         `(,(downcase-symbol key)
+                         `(,(xml xcal (downcase-symbol key))
                            ,(parameters-tag (reduce assq-merge
                                                     '() (map parameters vlines)))
                            ,@(for vline in vlines
@@ -117,18 +120,22 @@
 
                 [(key . vline)
                  (remove null?
-                         `(,(downcase-symbol key)
+                         `(,(xml xcal (downcase-symbol key))
                            ,(parameters-tag (parameters vline))
                            ,(vline->value-tag vline)))])
-              (properties component))))
+              ;; NOTE this sort is unnecesasary, but here so tests can work
+              ;; Possibly add it as a flag instead
+              (sort* (properties component)
+                     string< (compose symbol->string car)))))
         (unless (null? props)
-          `(properties
+          `(,(xml xcal 'properties)
             ;; NOTE
             ;; (x-hnh-calendar-name (text ,(prop (parent component) 'NAME)))
             ,@props)))
      ,(unless (null? (children component))
-        `(components ,@(map vcomponent->sxcal (children component)))))))
+        `(,(xml xcal 'components)
+          ,@(map vcomponent->sxcal (children component)))))))
 
 (define (ns-wrap sxml)
-  `(icalendar (@ (xmlns "urn:ietf:params:xml:ns:icalendar-2.0"))
-              ,sxml))
+  `(,(xml xcal 'icalendar)
+    ,sxml))
diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm
index 7200e18d..7ed8c637 100644
--- a/module/vcomponent/formats/xcal/parse.scm
+++ b/module/vcomponent/formats/xcal/parse.scm
@@ -3,18 +3,23 @@
   :use-module (hnh util exceptions)
   :use-module (base64)
   :use-module (ice-9 match)
+  :use-module (calp namespaces)
+  :use-module (sxml namespaced)
+  :use-module (sxml namespaced util)
   :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)
+  :use-module (srfi srfi-71)
+  :use-module (srfi srfi-88)
   :use-module (calp translation)
   :export (sxcal->vcomponent)
   )
 
 ;; symbol, ht, (list a) -> non-list
-(define (handle-value type props value)
+(define (handle-value type parameters value)
   (case type
 
     [(binary)
@@ -25,17 +30,17 @@
     [(boolean) (string=? "true" (car value))]
 
     ;; TODO possibly trim whitespace on text fields
-    [(cal-address uri text unknown) (car value)]
+    [(cal-address uri text unknown) (string-concatenate value)]
 
     [(date)
      ;; TODO this is correct, but ensure remaining types
-     (hashq-set! props 'VALUE "DATE")
+     (hashq-set! parameters 'VALUE "DATE")
      (parse-iso-date (car value))]
 
     [(date-time) (parse-iso-datetime (car value))]
 
     [(duration)
-     ((get-parser 'DURATION) props value)]
+     ((get-parser 'DURATION) parameters value)]
 
     [(float integer) ; (3.0)
      (string->number (car value))]
@@ -96,35 +101,39 @@
                        (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 (scm-error 'misc-error "handle-value"
-                                               "Invalid key ~s"
-                                               (list key)
-                                               #f)))))))))]
+                            (cond ((find-element (xml xcal key) value)
+                                   => (lambda (v)
+                                        (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 (cadr v))))
+                                          ;; 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))
+                                                      (cadr v))))
+                                          (else (scm-error 'misc-error "handle-value"
+                                                           "Invalid key ~s"
+                                                           (list key)
+                                                           #f)))))
+                                  (else #f)))))))]
 
     [(time) (parse-iso-time (car value))]
 
-    [(utc-offset) ((get-parser 'UTC-OFFSET) props (car value))]
+    [(utc-offset) ((get-parser 'UTC-OFFSET) parameters (car value))]
 
     [(geo) ; ((long 1) (lat 2))
      (sxml-match
       (cons 'geo value)
       [(geo (latitude ,x) (longitude ,y))
-       ((@ (vcomponent geo) make-geo) x y)])]))
+       ((@ (vcomponent geo) make-geo) x y)])]
+
+    [else (scm-error 'misc-error "handle-value"
+                     "Unknown value type: ~s"
+                     (list type) #f)]))
 
 (define (symbol-upcase symb)
   (-> symb
@@ -134,15 +143,20 @@
 
 (define (handle-parameters parameters)
 
+  ;; (assert (element-matches? (xml xcal '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)))]))
+  (for param in (cdr parameters)
+       (define ptag (xml-element-tagname (car param)))
+       ;; (define-values (ptype pvalue) (car+cdr cdr))
+       ;; TODO multi-valued parameters!!!
+       (define-values (pytpe pvalue) (car+cdr (cadr param)))
+       ;; TODO parameter type (rfc6321 3.5.)
+       ;; TODO namespaces
+       (hashq-set! ht (symbol-upcase ptag)
+                   (concatenate pvalue)))
   ht)
 
 (define* (parse-enum str enum optional: (allow-other #t))
@@ -153,7 +167,8 @@
 
 
 ;; symbol non-list -> non-list
-(define (handle-tag tag-name data)
+(define (handle-tag xml-tag data)
+  (define tag-name (xml-element-tagname xml-tag))
   (case tag-name
     [(request-status)
      ;; TODO
@@ -174,6 +189,49 @@
                data '(AUDIO DISPLAY EMAIL NONE)))
     [else data]))
 
+(define (handle-single-property! component tree)
+  (define xml-tag (car tree))
+  (define tag (xml-element-tagname xml-tag))
+  (define tag* (symbol-upcase tag))
+
+  (define body (cdr tree))
+
+  ;; TODO request-status
+  (define-values (parameters data)
+    (if (element-matches? (xml xcal 'parameters)
+                          (car body))
+        (values (handle-parameters (car body))
+                (cdr body))
+        (values (make-hash-table)
+                body)))
+
+  (for typetag in data
+       (define type (xml-element-tagname (car typetag)))
+       ;; TODO multi valued data
+       (define raw-value (cdr typetag))
+       (define vline
+         (make-vline tag* (handle-tag
+                           xml-tag
+                           (let ((v (handle-value type parameters raw-value)))
+                             ;; TODO possibly more list fields
+                             ;; (if (eq? tag 'categories)
+                             ;;     (string-split v #\,)
+                             ;;     v)
+
+                             v))
+                     parameters))
+       (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)))
+           (set! (prop* component tag*) vline))))
+
 ;; Note
 ;; This doesn't verify the inter-field validity of the object,
 ;; meaning that value(DTSTART) == DATE and value(DTEND) == DATE-TIME
@@ -181,83 +239,29 @@
 ;; TODO
 ;; since we are feeding user input into this it really should be fixed.
 (define (sxcal->vcomponent sxcal)
-  (define type (symbol-upcase (car sxcal)))
+
+  ;; TODO the surrounding icalendar element needs to be removed BEFORE this procedue is called
+
+  (define xml-tag (car sxcal))
+  (define type (symbol-upcase (xml-element-tagname xml-tag)))
   (define component (make-vcomponent type))
 
-  (awhen (assoc-ref sxcal 'properties)
+  (awhen (find-element (xml xcal 'properties) (cdr sxcal))
          ;; 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))
-                          )))])))
+         (map (lambda (x) (handle-single-property! component x))
+              (cdr it)))
 
   ;; children
-  (awhen (assoc-ref sxcal 'components)
-         (for child in (map sxcal->vcomponent it)
+  (awhen (find-element (xml xcal 'components) (cdr sxcal))
+         ;; NOTE Order of children is insignificant, but this allows
+         ;;      diffs to be stable (which is used by the format tests).
+         (for child in (map sxcal->vcomponent
+                            (reverse (cdr it)))
               (reparent! component child)))
 
   component)
diff --git a/module/vcomponent/formats/xcal/types.scm b/module/vcomponent/formats/xcal/types.scm
index 024ca61a..82121d5e 100644
--- a/module/vcomponent/formats/xcal/types.scm
+++ b/module/vcomponent/formats/xcal/types.scm
@@ -3,16 +3,18 @@
   :use-module (vcomponent formats ical types)
   :use-module (datetime)
   :use-module (calp translation)
+  :use-module ((calp namespaces) :select (xcal))
+  :use-module ((sxml namespaced) :select (xml))
   :export (get-writer))
 
 (define (write-boolean _ v)
-  `(boolean ,(if v "true" "false")))
+  `(,(xml xcal 'boolean) ,(if v "true" "false")))
 
 (define (write-date _ v)
-  `(date ,(date->string v "~Y-~m-~d")))
+  `(,(xml xcal 'date) ,(date->string v "~Y-~m-~d")))
 
 (define (write-datetime p v)
-  `(date-time
+  `(,(xml xcal 'date-time)
     ,(datetime->string
       (hashq-ref p '-X-HNH-ORIGINAL v)
       ;; 'Z' should be included for UTC,
@@ -21,17 +23,17 @@
       "~Y-~m-~dT~H:~M:~S~Z")))
 
 (define (write-time _ v)
-  `(time ,(time->string v "~H:~M:S")))
+  `(,(xml xcal 'time) ,(time->string v "~H:~M:S")))
 
 (define (write-recur _ v)
-  `(recur ,@((@@ (vcomponent recurrence internal) recur-rule->rrule-sxml) v)))
+  `(,(xml xcal '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))
+  `(,(xml xcal 'text) ,v))
 
 
 
@@ -40,7 +42,7 @@
                              #| TODO PERIOD |# URI UTC-OFFSET)
      (hashq-set! sxml-writers simple-type
                  (lambda (p v)
-                   `(,(downcase-symbol simple-type)
+                   `(,(xml xcal (downcase-symbol simple-type))
                      ,(((@ (vcomponent formats ical types) get-writer) simple-type) p v)))))
 
 (hashq-set! sxml-writers 'BOOLEAN write-boolean)
diff --git a/tests/test/recurrence-simple.scm b/tests/test/recurrence-simple.scm
index bf154fea..33900ceb 100644
--- a/tests/test/recurrence-simple.scm
+++ b/tests/test/recurrence-simple.scm
@@ -12,6 +12,9 @@
                :select (stream-take stream-map stream->list stream-car))
   :use-module ((datetime) :select (day-stream mon))
   :use-module ((vcomponent base) :select (extract prop))
+  :use-module ((sxml namespaced) :select (sxml->namespaced-sxml))
+  :use-module ((calp namespaces) :select (xcal))
+  :use-module ((hnh util) :select (->))
   :use-module ((hnh util exceptions)
                :select (warnings-are-errors warning-handler))
   :use-module ((vcomponent formats ical parse)
@@ -261,9 +264,8 @@ END:VCALENDAR"
    '((freq "WEEKLY") (interval "1") (wkst "MO"))))
 
 (define ev
-  (sxcal->vcomponent
-    '(vevent
-       (properties
+  (-> '(vevent
+        (properties
          (summary (text "reptest"))
          (dtend (date-time "2021-01-13T02:00:00"))
          (dtstart (date-time "2021-01-13T01:00:00"))
@@ -273,7 +275,9 @@ END:VCALENDAR"
                        (wkst "MO")))
          (dtstamp (date-time "2021-01-13T01:42:20Z"))
          (sequence (integer "0")))
-       (components))))
+        (components))
+      (sxml->namespaced-sxml `((#f . ,xcal)))
+      sxcal->vcomponent))
 
 (test-assert
   "Check that recurrence rule commint from xcal also works"