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.scm204
1 files changed, 104 insertions, 100 deletions
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-02 09:39:50 +0200