aboutsummaryrefslogtreecommitdiff
path: root/module/vcomponent/formats/xcal/parse.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/vcomponent/formats/xcal/parse.scm')
-rw-r--r--module/vcomponent/formats/xcal/parse.scm235
1 files changed, 121 insertions, 114 deletions
diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm
index 0e638d36..5ae1b928 100644
--- a/module/vcomponent/formats/xcal/parse.scm
+++ b/module/vcomponent/formats/xcal/parse.scm
@@ -3,18 +3,24 @@
: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)
+ :use-module (hnh util table)
: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 +31,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 +102,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,16 +144,20 @@
(define (handle-parameters parameters)
- (define ht (make-hash-table))
+ ;; (assert (element-matches? (xml xcal 'parameters)
+ ;; parameters))
- (for param in parameters
- (match param
- [(ptag (ptype pvalue ...) ...)
- ;; TODO parameter type (rfc6321 3.5.)
+ (fold (lambda (param table)
+ (define ptag (xml-element-tagname (car param)))
+ ;; (define-values (ptype pvalue) (car+cdr cdr))
;; TODO multi-valued parameters!!!
- (hashq-set! ht (symbol-upcase ptag)
- (car (concatenate pvalue)))]))
- ht)
+ (define-values (pytpe pvalue) (car+cdr (cadr param)))
+ ;; TODO parameter type (rfc6321 3.5.)
+ ;; TODO namespaces
+ (table-put table (symbol-upcase ptag)
+ (concatenate pvalue)))
+ (table)
+ (cdr parameters)))
(define* (parse-enum str enum optional: (allow-other #t))
(let ((symb (string->symbol str)))
@@ -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,51 @@
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)))
+
+ (fold (lambda (typetag component)
+ (define type (xml-element-tagname (car typetag)))
+ ;; TODO multi valued data
+ (define raw-value (cdr typetag))
+ (define vline*
+ (vline type: tag*
+ value: (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: parameters))
+ (if (memv tag* '(ATTACH ATTENDEE CATEGORIES
+ COMMENT CONTACT EXDATE
+ REQUEST-STATUS RELATED-TO
+ RESOURCES RDATE
+ ;; x-prop
+ ;; iana-prop
+ ))
+ (aif (prop* component tag*)
+ (prop* component tag* (cons vline* it))
+ (prop* component tag* (list vline*)))
+ (prop* component tag* vline*)))
+ component data))
+
;; Note
;; This doesn't verify the inter-field validity of the object,
;; meaning that value(DTSTART) == DATE and value(DTEND) == DATE-TIME
@@ -181,83 +241,30 @@
;; TODO
;; since we are feeding user input into this it really should be fixed.
(define (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)
+
+ ;; 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)))
+
+ (let ((component
+ (aif (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
+ (fold swap handle-single-property
+ (vcomponent type: type) (cdr it))
+ (vcomponent type: type))))
+
+ ;; children
+ (aif (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).
+ (fold (swap add-child)
+ component
+ (map sxcal->vcomponent
+ (reverse (cdr it))))
+ component)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-26 16:53:30 +0200