diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2021-12-21 16:17:28 +0100 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2021-12-22 22:58:30 +0100 |
commit | d00fea566004e67161ee45246b239fff5d416b0e (patch) | |
tree | 5641c0c0d0e78b046b6045ed2440512f12259560 /module/vcomponent/formats/ical/output.scm | |
parent | Complete rewrite of use2dot (diff) | |
download | calp-d00fea566004e67161ee45246b239fff5d416b0e.tar.gz calp-d00fea566004e67161ee45246b239fff5d416b0e.tar.xz |
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.
Diffstat (limited to 'module/vcomponent/formats/ical/output.scm')
-rw-r--r-- | module/vcomponent/formats/ical/output.scm | 234 |
1 files changed, 234 insertions, 0 deletions
diff --git a/module/vcomponent/formats/ical/output.scm b/module/vcomponent/formats/ical/output.scm new file mode 100644 index 00000000..9efac3c4 --- /dev/null +++ b/module/vcomponent/formats/ical/output.scm @@ -0,0 +1,234 @@ +(define-module (vcomponent formats ical output) + :use-module (calp util exceptions) + :use-module (calp util) + :use-module (datetime) + :use-module (datetime zic) + :use-module ((datetime instance) :select (zoneinfo)) + :use-module (glob) + :use-module (ice-9 format) + :use-module (ice-9 match) + :use-module (srfi srfi-1) + :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) + :use-module (vcomponent) + :use-module (vcomponent datetime) + :use-module (vcomponent geo) + :use-module (vcomponent formats ical types) + :use-module (vcomponent recurrence) + :autoload (vcomponent util instance) (global-event-object) + ) + +(define (prodid) + (format #f "-//hugo//calp ~a//EN" + (@ (calp) version))) + + +;; Format value depending on key type. +;; Should NOT emit the key. +(define (value-format key vline) + + (define writer + ;; fields which can hold lists need not be considered here, + ;; since they are split into multiple vlines when we parse them. + (cond + ;; TODO parameters return? One or many‽ + [(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 '(CATEGORIES RESOURCES)) + (lambda (p v) + (string-join (map (lambda (v) ((get-writer 'TEXT) p v)) + v) + ","))] + + [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION + LOCATION SUMMARY TZID TZNAME + CONTACT RELATED-TO UID + + 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) + (define fl (get-writer 'FLOAT)) + (format #f "~a:~a" + (fl (geo-latitude v)) + (fl (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)])) + + (catch #t #; 'wrong-type-arg + (lambda () + (writer ((@@ (vcomponent base) get-vline-parameters) vline) + (value vline))) + (lambda (err caller fmt args call-args) + (define fallback-string + (with-output-to-string (lambda () (display value)))) + (warning "key = ~a, caller = ~s, call-args = ~s~%~k~%Falling back to ~s" + key caller call-args fmt args + fallback-string) + fallback-string))) + + +;; Fold long lines to limit width. +;; Since this works in characters, but ics works in bytes +;; this will overshoot when faced with multi-byte characters. +;; But since the line wrapping is mearly a recomendation it's +;; not a problem. +;; Setting the wrap-len to slightly lower than allowed also help +;; us not overshoot. +(define* (ical-line-fold string #:key (wrap-len 70)) + (cond [(< wrap-len (string-length string)) + (format #f "~a\r\n ~a" + (string-take string wrap-len) + (ical-line-fold (string-drop string wrap-len)))] + [else string])) + + + +(define (vline->string vline) + (define key (vline-key vline)) + (ical-line-fold + ;; Expected output: key;p1=v;p3=10:value + (string-append + (symbol->string key) + (string-concatenate + (map (match-lambda + [(? (compose internal-field? car)) ""] + [(key values ...) + (string-append + ";" (symbol->string key) "=" + (string-join (map (compose escape-chars ->string) values) + "," 'infix))]) + (parameters vline))) + ":" (value-format key vline)))) + +(define-public (component->ical-string component) + (format #t "BEGIN:~a\r\n" (type component)) + (for-each + ;; Special cases depending on key. + ;; Value formatting is handled in @code{value-format}. + (match-lambda + + [(? (compose internal-field? car)) 'noop] + + [(key vlines ...) + (for vline in vlines + (display (vline->string vline)) + (display "\r\n"))] + + [(key . vline) + (display (vline->string vline)) + (display "\r\n")]) + (properties component)) + (for-each component->ical-string (children component)) + (format #t "END:~a\r\n" (type component)) + + ;; If we have alternatives, splice them in here. + (cond [(prop component '-X-HNH-ALTERNATIVES) + => (lambda (alts) (hash-map->list (lambda (_ comp) (component->ical-string comp)) + alts))])) + + + +(define (print-header) + (format #t +"BEGIN:VCALENDAR\r +PRODID:~a\r +VERSION:2.0\r +CALSCALE:GREGORIAN\r +" (prodid) +)) + + +(define (print-footer) + (format #t "END:VCALENDAR\r\n")) + +(define (get-tz-names events) + (lset-difference + equal? (lset-union + equal? '("dummy") + (filter-map + (lambda (vline) (and=> (param vline 'TZID) car)) + (filter-map (extract* 'DTSTART) + events))) + '("dummy" "local"))) + + +(define-public (print-components-with-fake-parent events) + + ;; The events are probably sorted before, but until I can guarantee + ;; that we sort them again here. We need them sorted from earliest + ;; and up to send the earliest to zoneinfo->vtimezone + (set! events (sort* events date/-time<=? (extract 'DTSTART))) + + (print-header) + + (when (provided? 'zoneinfo) + (let ((tz-names (get-tz-names events))) + (for-each component->ical-string + ;; TODO we realy should send the earliest event from each timezone here, + ;; instead of just the first. + (map (lambda (name) (zoneinfo->vtimezone + (zoneinfo) + name (car events))) + tz-names)))) + + (for-each component->ical-string events) + + (print-footer)) + + +(define-public (print-all-events) + (print-components-with-fake-parent + (append (get-fixed-events global-event-object) + ;; TODO RECCURENCE-ID exceptions + ;; We just dump all repeating objects, since it's much cheaper to do + ;; it this way than to actually figure out which are applicable for + ;; the given date range. + (get-repeating-events global-event-object)))) + +(define-public (print-events-in-interval start end) + (print-components-with-fake-parent + (append (fixed-events-in-range start end) + ;; TODO RECCURENCE-ID exceptions + ;; We just dump all repeating objects, since it's much cheaper to do + ;; it this way than to actually figure out which are applicable for + ;; the given date range. + (get-repeating-events global-event-object)))) |