diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-17 18:06:18 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-17 18:06:18 +0200 |
commit | b157c326fa2139529eee14781f39c9d3ab65668a (patch) | |
tree | 4b632256fd1689600cb7ca3e8322efab251eadd5 /module/vcomponent | |
parent | Move a bunch of files into calp module. (diff) | |
download | calp-b157c326fa2139529eee14781f39c9d3ab65668a.tar.gz calp-b157c326fa2139529eee14781f39c9d3ab65668a.tar.xz |
Start moving stuff out from output.
Diffstat (limited to 'module/vcomponent')
-rw-r--r-- | module/vcomponent/ical/output.scm | 244 | ||||
-rw-r--r-- | module/vcomponent/ical/parse.scm (renamed from module/vcomponent/parse/ical.scm) | 2 | ||||
-rw-r--r-- | module/vcomponent/parse.scm | 2 | ||||
-rw-r--r-- | module/vcomponent/xcal/output.scm | 131 | ||||
-rw-r--r-- | module/vcomponent/xcal/parse.scm (renamed from module/vcomponent/parse/xcal.scm) | 2 |
5 files changed, 378 insertions, 3 deletions
diff --git a/module/vcomponent/ical/output.scm b/module/vcomponent/ical/output.scm new file mode 100644 index 00000000..530203e6 --- /dev/null +++ b/module/vcomponent/ical/output.scm @@ -0,0 +1,244 @@ +(define-module (vcomponent ical output) + :use-module (ice-9 format) + :use-module (ice-9 match) + :use-module (util) + :use-module (util exceptions) + :use-module (vcomponent) + :use-module (vcomponent datetime) + :use-module (srfi srfi-1) + :use-module (datetime) + :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) + :use-module (datetime zic) + :use-module (glob) + :use-module (vcomponent recurrence) + :use-module (vcomponent geo) + :use-module (output types) + :use-module (output common) + :autoload (vcomponent instance) (global-event-object) + :use-module ((datetime instance) :select (zoneinfo)) + ) + + +;; 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 '(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) + (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))])) + +;; TODO tzid param on dtstart vs tz field in datetime object +;; TODO remove this, replace with methods from (output vdir) +;; how do we keep these two in sync? +(define (write-event-to-file event calendar-path) + (define cal (make-vcomponent 'VCALENDAR)) + + (set! (prop cal 'PRODID) (@ (global) *prodid*) + (prop cal 'VERSION) "2.0" + (prop cal 'CALSCALE) "GREGORIAN") + + (add-child! cal event) + + (awhen (and (provided? 'zoneinfo) + (param (prop* event 'DTSTART) 'TZID)) + ;; TODO this is broken + (add-child! cal (zoneinfo->vtimezone (zoneinfo) it))) + + (unless (prop event 'UID) + (set! (prop event 'UID) + (uuidgen))) + + (with-output-to-file (glob (format #f "~a/~a.ics" + calendar-path + (prop event 'UID))) + (lambda () (component->ical-string cal)))) + + + +(define (print-header) + (format #t +"BEGIN:VCALENDAR\r +PRODID:~a\r +VERSION:2.0\r +CALSCALE:GREGORIAN\r +" (@ (global) *prodid*) +)) + + +(define (print-footer) + (format #t "END:VCALENDAR\r\n")) + + + +(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)))) diff --git a/module/vcomponent/parse/ical.scm b/module/vcomponent/ical/parse.scm index c4bb059f..2c01927b 100644 --- a/module/vcomponent/parse/ical.scm +++ b/module/vcomponent/ical/parse.scm @@ -1,4 +1,4 @@ -(define-module (vcomponent parse ical) +(define-module (vcomponent ical parse) :use-module (util) :use-module (util exceptions) :use-module ((ice-9 rdelim) :select (read-line)) diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index 56e62dad..67d66b02 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -16,7 +16,7 @@ :use-module (util exceptions) :use-module (vcomponent base) - :use-module (vcomponent parse ical) + :use-module (vcomponent ical parse) :re-export (parse-calendar) ) diff --git a/module/vcomponent/xcal/output.scm b/module/vcomponent/xcal/output.scm new file mode 100644 index 00000000..a689b2cf --- /dev/null +++ b/module/vcomponent/xcal/output.scm @@ -0,0 +1,131 @@ +(define-module (vcomponent xcal output) + :use-module (util) + :use-module (util exceptions) + :use-module (vcomponent) + :use-module (vcomponent geo) + :use-module (output sxml-types) + :use-module (ice-9 match) + :use-module (output common) + :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 <properties> 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 ,@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/parse/xcal.scm b/module/vcomponent/xcal/parse.scm index 2c8b7fe8..16e47e6f 100644 --- a/module/vcomponent/parse/xcal.scm +++ b/module/vcomponent/xcal/parse.scm @@ -1,4 +1,4 @@ -(define-module (vcomponent parse xcal) +(define-module (vcomponent xcal parse) :use-module (util) :use-module (util exceptions) :use-module (util base64) |