diff options
Diffstat (limited to 'module/vcomponent/parse/xcal.scm')
-rw-r--r-- | module/vcomponent/parse/xcal.scm | 157 |
1 files changed, 0 insertions, 157 deletions
diff --git a/module/vcomponent/parse/xcal.scm b/module/vcomponent/parse/xcal.scm deleted file mode 100644 index 2c8b7fe8..00000000 --- a/module/vcomponent/parse/xcal.scm +++ /dev/null @@ -1,157 +0,0 @@ -(define-module (vcomponent parse xcal) - :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) |