diff options
Diffstat (limited to 'module/vcomponent/formats/xcal/parse.scm')
-rw-r--r-- | module/vcomponent/formats/xcal/parse.scm | 259 |
1 files changed, 259 insertions, 0 deletions
diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm new file mode 100644 index 00000000..e84f380e --- /dev/null +++ b/module/vcomponent/formats/xcal/parse.scm @@ -0,0 +1,259 @@ +(define-module (vcomponent formats xcal parse) + :use-module (calp util) + :use-module (calp util exceptions) + :use-module (base64) + :use-module (ice-9 match) + :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) + ) + +;; 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) + ;; TODO this is correct, but ensure remaining types + (hashq-set! props '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) + ;; RFC6221 (xcal) Appendix A 3.3.10 specifies that all components should + ;; come in a specified order, and by extension that all components of the + ;; same type should follow each other. Actually checking that is harder + ;; than to just accept anything in any order. It would also make us less + ;; robust for other implementations with other ideas. + (let ((parse-value-of-that-type + (lambda (type value) + (case type + ((wkst) + ((@ (vcomponent recurrence parse) + rfc->datetime-weekday) + (string->symbol value))) + ((freq) (string->symbol value)) + ((until) + ;; RFC 6321 (xcal), p. 30 specifies type-until as + ;; type-until = element until { + ;; type-date | + ;; type-date-time + ;; } + ;; but doesn't bother defining type-date[-time]... + ;; This is acknowledged in errata 3315 [1], but + ;; it lacks a solution... + ;; Seeing as RFC 7265 (jcal) in Example 2 (p. 16) + ;; show the date as a direct string we will roll + ;; with that here to. + ;; [1]: https://www.rfc-editor.org/errata/eid3315 + (string->date/-time value)) + ((byday) ((@@ (vcomponent recurrence parse) parse-day-spec) value)) + ((count interval bysecond bymunite byhour + bymonthday byyearday byweekno + bymonth bysetpos) + (string->number value)) + (else (throw + 'key-error + "Invalid type ~a, with value ~a" + type value)))))) + + ;; freq until count interval wkst + + (apply (@ (vcomponent recurrence internal) make-recur-rule) + (concatenate + (filter identity + (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 (throw 'error)))))))))] + + [(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])) + +;; Note +;; This doesn't verify the inter-field validity of the object, +;; meaning that value(DTSTART) == DATE and value(DTEND) == DATE-TIME +;; are possibilities, which other parts of the code will crash on. +;; TODO +;; since we are feeding user input into this it really should be fixed. +(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) + (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) |