(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
(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
(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)