From d00fea566004e67161ee45246b239fff5d416b0e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 21 Dec 2021 16:17:28 +0100 Subject: Cleanup modules. Primarly this moves all vcompenent input and output code to clearly labeled modules, instead of being spread out. At the same time it also removes a handfull of unused procedures. --- module/vcomponent/xcal/parse.scm | 259 --------------------------------------- 1 file changed, 259 deletions(-) delete mode 100644 module/vcomponent/xcal/parse.scm (limited to 'module/vcomponent/xcal/parse.scm') diff --git a/module/vcomponent/xcal/parse.scm b/module/vcomponent/xcal/parse.scm deleted file mode 100644 index c6a2122f..00000000 --- a/module/vcomponent/xcal/parse.scm +++ /dev/null @@ -1,259 +0,0 @@ -(define-module (vcomponent 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 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) - ;; 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 - (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 - (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) -- cgit v1.2.3