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/output.scm | 133 -------------------- module/vcomponent/xcal/parse.scm | 259 -------------------------------------- module/vcomponent/xcal/types.scm | 54 -------- 3 files changed, 446 deletions(-) delete mode 100644 module/vcomponent/xcal/output.scm delete mode 100644 module/vcomponent/xcal/parse.scm delete mode 100644 module/vcomponent/xcal/types.scm (limited to 'module/vcomponent/xcal') diff --git a/module/vcomponent/xcal/output.scm b/module/vcomponent/xcal/output.scm deleted file mode 100644 index 70288cba..00000000 --- a/module/vcomponent/xcal/output.scm +++ /dev/null @@ -1,133 +0,0 @@ -(define-module (vcomponent xcal output) - :use-module (calp util) - :use-module (calp util exceptions) - :use-module (vcomponent) - :use-module (vcomponent geo) - :use-module (vcomponent xcal types) - :use-module (ice-9 match) - :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 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 - ;; NOTE - ;; (x-hnh-calendar-name (text ,(prop (parent component) 'NAME))) - ,@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 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) diff --git a/module/vcomponent/xcal/types.scm b/module/vcomponent/xcal/types.scm deleted file mode 100644 index 468400f4..00000000 --- a/module/vcomponent/xcal/types.scm +++ /dev/null @@ -1,54 +0,0 @@ -(define-module (vcomponent xcal types) - :use-module (calp util) - :use-module (vcomponent ical types) - :use-module (datetime) - ) - -(define (write-boolean _ v) - `(boolean ,(if v "true" "false"))) - -(define (write-date _ v) - `(date ,(date->string v "~Y-~m-~d"))) - -(define (write-datetime p v) - `(date-time - ,(datetime->string - (hashq-ref p '-X-HNH-ORIGINAL v) - ;; 'Z' should be included for UTC, - ;; other timezones MUST be specified - ;; in the TZID parameter. - "~Y-~m-~dT~H:~M:~S~Z"))) - -(define (write-time _ v) - `(time ,(time->string v "~H:~M:S"))) - -(define (write-recur _ v) - `(recur ,@((@@ (vcomponent recurrence internal) recur-rule->rrule-sxml) v))) - -;; sepparate since this text shouldn't be escaped -(define (write-text _ v) - ;; TODO out type should be xsd:string. - ;; Look into what that means, and escape - ;; from there - `(text ,v)) - - - -(define sxml-writers (make-hash-table)) -(for simple-type in '(BINARY DURATION CAL-ADDRESS DURATION FLOAT INTEGER - #| TODO PERIOD |# URI UTC-OFFSET) - (hashq-set! sxml-writers simple-type - (lambda (p v) - `(,(downcase-symbol simple-type) - ,(((@ (vcomponent ical types) get-writer) simple-type) p v))))) - -(hashq-set! sxml-writers 'BOOLEAN write-boolean) -(hashq-set! sxml-writers 'DATE write-date) -(hashq-set! sxml-writers 'DATE-TIME write-datetime) -(hashq-set! sxml-writers 'TIME write-time) -(hashq-set! sxml-writers 'RECUR write-recur) -(hashq-set! sxml-writers 'TEXT write-text) - -(define-public (get-writer type) - (or (hashq-ref sxml-writers type #f) - (error "No writer for type" type))) -- cgit v1.2.3