aboutsummaryrefslogtreecommitdiff
path: root/module/vcomponent/formats/xcal
diff options
context:
space:
mode:
Diffstat (limited to 'module/vcomponent/formats/xcal')
-rw-r--r--module/vcomponent/formats/xcal/output.scm69
-rw-r--r--module/vcomponent/formats/xcal/parse.scm235
-rw-r--r--module/vcomponent/formats/xcal/types.scm16
3 files changed, 169 insertions, 151 deletions
diff --git a/module/vcomponent/formats/xcal/output.scm b/module/vcomponent/formats/xcal/output.scm
index 8e92b280..7cf8c591 100644
--- a/module/vcomponent/formats/xcal/output.scm
+++ b/module/vcomponent/formats/xcal/output.scm
@@ -8,28 +8,31 @@
: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))
(define (vline->value-tag vline)
- (define key (vline-key vline))
+ (define k (key vline))
(define writer
(cond
[(and=> (param vline 'VALUE) (compose string->symbol car))
=> get-writer]
- [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID
+ [(memv k '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID
CREATED DTSTAMP LAST-MODIFIED
ACKNOWLEDGED EXDATE))
(get-writer 'DATE-TIME)]
- [(memv key '(TRIGGER DURATION))
+ [(memv k '(TRIGGER DURATION))
(get-writer 'DURATION)]
- [(memv key '(FREEBUSY))
+ [(memv k '(FREEBUSY))
(get-writer 'PERIOD)]
- [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION
+ [(memv k '(CALSCALE METHOD PRODID COMMENT DESCRIPTION
LOCATION SUMMARY TZID TZNAME
CONTACT RELATED-TO UID
@@ -38,69 +41,69 @@
VERSION))
(get-writer 'TEXT)]
- [(memv key '(TRANSP
+ [(memv k '(TRANSP
CLASS
PARTSTAT
STATUS
ACTION))
(lambda (p v) ((get-writer 'TEXT) p (symbol->string v)))]
- [(memv key '(TZOFFSETFROM TZOFFSETTO))
+ [(memv k '(TZOFFSETFROM TZOFFSETTO))
(get-writer 'UTC-OFFSET)]
- [(memv key '(ATTACH TZURL URL))
+ [(memv k '(ATTACH TZURL URL))
(get-writer 'URI)]
- [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE))
+ [(memv k '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE))
(get-writer 'INTEGER)]
- [(memv key '(GEO))
+ [(memv k '(GEO))
(lambda (_ v)
- `(geo
+ `(,(xml xcal 'geo)
(latitude ,(geo-latitude v))
(longitude ,(geo-longitude v))))]
- [(memv key '(RRULE))
+ [(memv k '(RRULE))
(get-writer 'RECUR)]
- [(memv key '(ORGANIZER ATTENDEE))
+ [(memv k '(ORGANIZER ATTENDEE))
(get-writer 'CAL-ADDRESS)]
- [(x-property? key)
+ [(x-property? k)
(get-writer 'TEXT)]
[else
- (warning (G_ "Unknown key ~a") key)
+ (warning (G_ "Unknown key ~a") k)
(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 , ... )
(define (parameters-tag parameters)
(define outparams (filter-map
- (lambda (x) (apply property->value-tag x))
+ (lambda (x) (property->value-tag x))
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
@@ -108,27 +111,33 @@
[(? (compose internal-field? car)) #f]
[(key vlines ...)
+ (format (current-error-port) "vlines: ~s~%" vlines)
(remove null?
- `(,(downcase-symbol key)
+ `(,(xml xcal (downcase-symbol key))
,(parameters-tag (reduce assq-merge
- '() (map parameters vlines)))
+ '()
+ (map parameters vlines)))
,@(for vline in vlines
(vline->value-tag vline))))]
[(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 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)))
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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-29 09:40:17 +0200