aboutsummaryrefslogtreecommitdiff
path: root/module/vcomponent/xcal
diff options
context:
space:
mode:
Diffstat (limited to 'module/vcomponent/xcal')
-rw-r--r--module/vcomponent/xcal/output.scm131
-rw-r--r--module/vcomponent/xcal/parse.scm157
2 files changed, 288 insertions, 0 deletions
diff --git a/module/vcomponent/xcal/output.scm b/module/vcomponent/xcal/output.scm
new file mode 100644
index 00000000..a689b2cf
--- /dev/null
+++ b/module/vcomponent/xcal/output.scm
@@ -0,0 +1,131 @@
+(define-module (vcomponent xcal output)
+ :use-module (util)
+ :use-module (util exceptions)
+ :use-module (vcomponent)
+ :use-module (vcomponent geo)
+ :use-module (output sxml-types)
+ :use-module (ice-9 match)
+ :use-module (output common)
+ :use-module (datetime)
+ :use-module (srfi srfi-1)
+ )
+
+
+(define (vline->value-tag vline)
+ (define key (vline-key vline))
+
+ (define writer
+ (cond
+ [(and=> (param vline 'VALUE) (compose string->symbol car))
+ => get-writer]
+ [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID
+ CREATED DTSTAMP LAST-MODIFIED
+ ACKNOWLEDGED EXDATE))
+ (get-writer 'DATE-TIME)]
+
+ [(memv key '(TRIGGER DURATION))
+ (get-writer 'DURATION)]
+
+ [(memv key '(FREEBUSY))
+ (get-writer 'PERIOD)]
+
+ [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION
+ LOCATION SUMMARY TZID TZNAME
+ CONTACT RELATED-TO UID
+
+ CATEGORIES RESOURCES
+
+ VERSION))
+ (get-writer 'TEXT)]
+
+ [(memv key '(TRANSP
+ CLASS
+ PARTSTAT
+ STATUS
+ ACTION))
+ (lambda (p v) ((get-writer 'TEXT) p (symbol->string v)))]
+
+ [(memv key '(TZOFFSETFROM TZOFFSETTO))
+ (get-writer 'UTC-OFFSET)]
+
+ [(memv key '(ATTACH TZURL URL))
+ (get-writer 'URI)]
+
+ [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE))
+ (get-writer 'INTEGER)]
+
+ [(memv key '(GEO))
+ (lambda (_ v)
+ `(geo
+ (latitude ,(geo-latitude v))
+ (longitude ,(geo-longitude v))))]
+
+ [(memv key '(RRULE))
+ (get-writer 'RECUR)]
+
+ [(memv key '(ORGANIZER ATTENDEE))
+ (get-writer 'CAL-ADDRESS)]
+
+ [(x-property? key)
+ (get-writer 'TEXT)]
+
+ [else
+ (warning "Unknown key ~a" key)
+ (get-writer 'TEXT)]))
+
+ (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)
+ ,@(map (lambda (v)
+ ;; TODO parameter types!!!! (rfc6321 3.5.)
+ `(text ,(->string v)))
+ values))))
+
+;; ((key value ...) ...) -> `(parameters , ... )
+(define (parameters-tag parameters)
+ (define outparams (filter-map
+ (lambda (x) (apply property->value-tag x))
+ parameters))
+
+ (unless (null? outparams)
+ `(parameters ,@outparams)))
+
+(define-public (vcomponent->sxcal component)
+
+ (define tagsymb (downcase-symbol (type component)))
+
+
+ (remove null?
+ `(,tagsymb
+ ;; only have <properties> when it's non-empty.
+ ,(let ((props
+ (filter-map
+ (match-lambda
+ [(? (compose internal-field? car)) #f]
+
+ [(key vlines ...)
+ (remove null?
+ `(,(downcase-symbol key)
+ ,(parameters-tag (reduce assq-merge
+ '() (map parameters vlines)))
+ ,@(for vline in vlines
+ (vline->value-tag vline))))]
+
+ [(key . vline)
+ (remove null?
+ `(,(downcase-symbol key)
+ ,(parameters-tag (parameters vline))
+ ,(vline->value-tag vline)))])
+ (properties component))))
+ (unless (null? props)
+ `(properties ,@props)))
+ ,(unless (null? (children component))
+ `(components ,@(map vcomponent->sxcal (children component)))))))
+
+(define-public (ns-wrap sxml)
+ `(icalendar (@ (xmlns "urn:ietf:params:xml:ns:icalendar-2.0"))
+ ,sxml))
diff --git a/module/vcomponent/xcal/parse.scm b/module/vcomponent/xcal/parse.scm
new file mode 100644
index 00000000..16e47e6f
--- /dev/null
+++ b/module/vcomponent/xcal/parse.scm
@@ -0,0 +1,157 @@
+(define-module (vcomponent xcal parse)
+ :use-module (util)
+ :use-module (util exceptions)
+ :use-module (util base64)
+ :use-module (ice-9 match)
+ :use-module (sxml match)
+ :use-module (vcomponent)
+ :use-module (vcomponent geo)
+ :use-module (vcomponent parse types)
+ :use-module (datetime)
+ :use-module (srfi srfi-1)
+ )
+
+;; symbol, ht, (list a) -> non-list
+(define (handle-value type props value)
+ (case type
+
+ [(binary)
+ ;; rfc6321 allows whitespace in binary
+ (base64-string->bytevector
+ (string-delete char-set:whitespace (car value)))]
+
+ [(boolean) (string=? "true" (car value))]
+
+ ;; TODO possibly trim whitespace on text fields
+ [(cal-address uri text unknown) (car value)]
+
+ [(date) (parse-iso-date (car value))]
+
+ [(date-time) (parse-iso-datetime (car value))]
+
+ [(duration)
+ ((get-parser 'DURATION) props value)]
+
+ [(float integer) ; (3.0)
+ (string->number (car value))]
+
+ [(period)
+ (sxml-match
+ (cons 'period value)
+ [(period (start ,start-dt) (end ,end-dt))
+ (cons (parse-iso-datetime start-dt)
+ (parse-iso-datetime end-dt))]
+ [(period (start ,start-dt) (duration ,duration))
+ (cons (parse-iso-datetime start-dt)
+ ((@ (vcomponent duration) parse-duration) duration))])]
+
+ [(recur)
+ (apply (@ (vcomponent recurrence internal) make-recur-rule)
+ (for (k v) in value
+ (list (symbol->keyword k) v)))]
+
+ [(time) (parse-iso-time (car value))]
+
+ [(utc-offset) ((get-parser 'UTC-OFFSET) props (car value))]
+
+ [(geo) ; ((long 1) (lat 2))
+ (sxml-match
+ (cons 'geo value)
+ [(geo (latitude ,x) (longitude ,y))
+ ((@ (vcomponent geo) make-geo) x y)])]))
+
+(define (symbol-upcase symb)
+ (-> symb
+ symbol->string
+ string-upcase
+ string->symbol))
+
+(define (handle-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)))]))
+ ht)
+
+(define* (parse-enum str enum optional: (allow-other #t))
+ (let ((symb (string->symbol str)))
+ (unless (memv symb enum)
+ (warning "~a ∉ { ~{~a~^, ~} }" symb enum))
+ symb))
+
+
+;; symbol non-list -> non-list
+(define (handle-tag tag-name data)
+ (case tag-name
+ [(request-status)
+ ;; TODO
+ (warning "Request status not yet implemented")
+ #f]
+
+ ((transp) (parse-enum
+ data '(OPAQUE TRANSPARENT) #f))
+ ((class) (parse-enum
+ data '(PUBLIC PRIVATE CONFIDENTIAL)))
+ ((partstat) (parse-enum
+ data '(NEEDS-ACTION ACCEPTED DECLINED TENTATIVE
+ DELEGATED IN-PROCESS)))
+ ((status) (parse-enum
+ data '(TENTATIVE CONFIRMED CANCELLED NEEDS-ACTION COMPLETED
+ IN-PROCESS DRAFT FINAL CANCELED)))
+ ((action) (parse-enum
+ data '(AUDIO DISPLAY EMAIL NONE)))
+ [else data]))
+
+(define-public (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)
+ (set! (prop* component tag*)
+ (make-vline tag*
+ (handle-tag
+ tag (handle-value type params value))
+ params)))))]
+
+ [(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)))
+ (set! (prop* component tag*)
+ (make-vline tag*
+ (handle-tag
+ tag (handle-value type params value))
+ params)))))])))
+
+ ;; children
+ (awhen (assoc-ref sxcal 'components)
+ (for child in (map sxcal->vcomponent it)
+ (add-child! component child)))
+
+ component)
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-26 01:40:14 +0200