From 6d5a9c21158b81b61278d39868597324e44444c1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 18 Apr 2023 19:28:12 +0200 Subject: Change xcal to work on namespaced sxml instead. --- module/vcomponent/formats/xcal/parse.scm | 204 ++++++++++++++++--------------- 1 file changed, 104 insertions(+), 100 deletions(-) (limited to 'module/vcomponent/formats/xcal/parse.scm') 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 - (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 - (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) -- cgit v1.2.3