diff options
Diffstat (limited to 'module/vcomponent/ical')
| -rw-r--r-- | module/vcomponent/ical/output.scm | 244 | ||||
| -rw-r--r-- | module/vcomponent/ical/parse.scm | 307 |
2 files changed, 551 insertions, 0 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/ical/parse.scm b/module/vcomponent/ical/parse.scm new file mode 100644 index 00000000..2c01927b --- /dev/null +++ b/module/vcomponent/ical/parse.scm @@ -0,0 +1,307 @@ +(define-module (vcomponent ical parse) + :use-module (util) + :use-module (util exceptions) + :use-module ((ice-9 rdelim) :select (read-line)) + :use-module (vcomponent base) + :use-module (datetime) + :use-module (srfi srfi-1) + :use-module (srfi srfi-9 gnu) + :use-module (srfi srfi-26) + :use-module (vcomponent parse types) + :use-module (vcomponent geo) + ) + +;; TODO rename to parse-vcomponent, or parse-ical (?). +(define-public (parse-calendar port) + (parse (map tokenize (read-file port)))) + +(define-immutable-record-type <line> + (make-line string file line) + line? + (string get-string) + (file get-file) + (line get-line)) + + +;; port → (list <line>) +(define (read-file port) + (define fname (port-filename port)) + (let loop ((line-number 1) (done '())) + (let ((line (read-line port))) + (if (eof-object? line) + (reverse! done) + (let ((line (string-trim-right line))) + (loop + (1+ line-number) + (if (char=? #\space (string-ref line 0)) + ;; Line Wrapping + ;; TODO if the line is split inside a unicode character + ;; then this produces multiple broken unicode characters. + ;; It could be solved by checking the start of the new line, + ;; and the tail of the old line for broken char + (cons (make-line (string-append (get-string (car done)) + (string-drop line 1)) + fname + (get-line (car done))) + (cdr done)) + (cons (make-line line fname line-number) + done)))))))) + +(define-immutable-record-type <tokens> + (make-tokens metadata data) + tokens? + (metadata get-metadata) ; <line> + (data get-data) ; (key kv ... value) + ) + +;; (list <line>) → (list <tokens>) +(define (tokenize line-obj) + (define line (get-string line-obj)) + (define colon-idx (string-index line #\:)) + (define semi-idxs + (let loop ((idx 0)) + (aif (string-index line #\; idx colon-idx) + (cons it (loop (1+ it))) + (list colon-idx (string-length line))))) + (make-tokens + line-obj + (map (lambda (start end) + (substring line (1+ start) end)) + (cons -1 semi-idxs) + semi-idxs))) + + +#; +'(ATTACH ATTENDEE CATEGORIES + COMMENT CONTACT EXDATE + REQUEST-STATUS RELATED-TO + RESOURCES RDATE + ;; x-prop + ;; iana-prop + ) + +(define (list-parser symbol) + (let ((parser (get-parser symbol))) + (lambda (params value) + (map (lambda (v) (parser params v)) + (string-split value #\,))))) + +(define* (enum-parser enum optional: (allow-other #t)) + (let ((parser (compose car (get-parser 'TEXT)))) + (lambda (params value) + (let ((vv (parser params value))) + (when (list? vv) + (throw 'parse-error "List in enum field")) + (let ((v (string->symbol vv))) + (unless (memv v enum) + (warning "~a ∉ { ~{~a~^, ~} }" + v enum)) + v))))) + +;; params could be made optional, with an empty hashtable as default +(define (build-vline key value params) + (let ((parser + (cond + [(and=> (hashq-ref params 'VALUE) string->symbol) => get-parser] + + [(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID RDATE + CREATED DTSTAMP LAST-MODIFIED + ;; only on VALARM + ACKNOWLEDGED + )) + (get-parser 'DATE-TIME)] + + [(memv key '(EXDATE)) + (list-parser 'DATE-TIME)] + + [(memv key '(TRIGGER DURATION)) + (get-parser 'DURATION)] + + [(memv key '(FREEBUSY)) + (list-parser 'PERIOD)] + + [(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION + LOCATION SUMMARY TZID TZNAME + CONTACT RELATED-TO UID)) + (lambda (params value) + (let ((v ((get-parser 'TEXT) params value))) + (unless (= 1 (length v)) + (warning "List in non-list field: ~s" v)) + (car v)))] + + ;; TEXT, but allow a list + [(memv key '(CATEGORIES RESOURCES)) + ;; TODO An empty value should lead to an empty set + ;; currently it seems to lead to '("") + (get-parser 'TEXT)] + + [(memv key '(VERSION)) + (lambda (params value) + (let ((v (car ((get-parser 'TEXT) params value)))) + (unless (and (string? v) (string=? "2.0" v)) + #f + ;; (warning "File of unsuported version. Proceed with caution") + ) + v))] + + [(memv key '(TRANSP)) + (enum-parser '(OPAQUE TRANSPARENT) #f)] + + [(memv key '(CLASS)) + (enum-parser '(PUBLIC PRIVATE CONFIDENTIAL))] + + [(memv key '(PARTSTAT)) + (enum-parser '(NEEDS-ACTION + ACCEPTED DECLINED + TENTATIVE DELEGATED + IN-PROCESS))] + + [(memv key '(STATUS)) + (enum-parser '(TENTATIVE + CONFIRMED CANCELLED + NEEDS-ACTION COMPLETED IN-PROCESS + DRAFT FINAL CANCELED))] + + [(memv key '(REQUEST-STATUS)) + (throw 'parse-error "TODO Implement REQUEST-STATUS")] + + [(memv key '(ACTION)) + (enum-parser '(AUDIO DISPLAY EMAIL + NONE ; I don't know where NONE is from + ; but it appears to be prevelant. + ))] + + [(memv key '(TZOFFSETFROM TZOFFSETTO)) + (get-parser 'UTC-OFFSET)] + + [(memv key '(ATTACH TZURL URL)) + (get-parser 'URI)] + + [(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE)) + (get-parser 'INTEGER)] + + [(memv key '(GEO)) + ;; two semicolon sepparated floats + (lambda (params value) + (let* (((left right) (string-split value #\;))) + (make-geo ((get-parser 'FLOAT) params left) + ((get-parser 'FLOAT) params right))))] + + [(memv key '(RRULE)) + (get-parser 'RECUR)] + + [(memv key '(ORGANIZER ATTENDEE)) + (get-parser 'CAL-ADDRESS)] + + [(x-property? key) + (compose car (get-parser 'TEXT))] + + [else + (warning "Unknown key ~a" key) + (compose car (get-parser 'TEXT))]))) + + ;; If we produced a list create multiple VLINES from it. + ;; NOTE that the created vlines share parameter tables. + ;; TODO possibly allow vlines to reference each other, to + ;; indicate that all these vlines are the same. + (let ((parsed (parser params value))) + (if (list? parsed) + (apply values + (map (lambda (p) (make-vline key p params)) + parsed)) + (make-vline key parsed params))))) + +;; (parse-itemline '("DTEND" "20200407T130000")) +;; => DTEND +;; => "20200407T130000" +;; => #<hash-table 7f76b5f82a60 0/31> +(define (parse-itemline itemline) + (define key (string->symbol (car itemline))) + (define parameters (make-hash-table)) + (let loop ((rem (cdr itemline))) + (if (null? (cdr rem)) + (values key (car rem) parameters ) + (let* ((kv (car rem)) + (idx (string-index kv #\=))) + ;; TODO lists in parameters + (hashq-set! parameters (string->symbol (substring kv 0 idx)) + (substring kv (1+ idx))) + (loop (cdr rem)))))) + + +;; (list <tokens>) → <vcomponent> +(define (parse lst) + (let loop ((lst lst) + (stack '())) + (if (null? lst) + stack + (let* ((head* (car lst)) + (head (get-data head*))) + (catch 'parse-error + (lambda () + (parameterize + ((warning-handler + (lambda (fmt . args) + (let ((linedata (get-metadata head*))) + (format + #f "WARNING parse error around ~a + ~? + line ~a ~a~%" + (get-string linedata) + fmt args + (get-line linedata) + (get-file linedata) + ))))) + (cond [(string=? "BEGIN" (car head)) + (loop (cdr lst) + (cons (make-vcomponent (string->symbol (cadr head))) + stack))] + [(string=? "END" (car head)) + (loop (cdr lst) + (if (null? (cdr stack)) + ;; return + (car stack) + (begin (add-child! (cadr stack) (car stack)) + (cdr stack))))] + [else + (let* ((key value params (parse-itemline head))) + (call-with-values (lambda () (build-vline key value params)) + (lambda vlines + (for vline in vlines + (define key (vline-key vline)) + + (set! (vline-source vline) + (get-metadata head*)) + + ;; See RFC 5545 p.53 for list of all repeating types + ;; (for vcomponent) + (if (memv key '(ATTACH ATTENDEE CATEGORIES + COMMENT CONTACT EXDATE + REQUEST-STATUS RELATED-TO + RESOURCES RDATE + ;; x-prop + ;; iana-prop + )) + (aif (prop* (car stack) key) + (set! (prop* (car stack) key) (cons vline it)) + (set! (prop* (car stack) key) (list vline))) + ;; else + (set! (prop* (car stack) key) vline)))))) + + (loop (cdr lst) stack)]))) + (lambda (err fmt . args) + (let ((linedata (get-metadata head*))) + (display (format + #f "ERROR parse error around ~a + ~? + line ~a ~a + Defaulting to string~%" + (get-string linedata) + fmt args + (get-line linedata) + (get-file linedata)) + (current-error-port)) + (let* ((key value params (parse-itemline head))) + (set! (prop* (car stack) key) + (make-vline key value params)) + (loop (cdr lst) stack))))))))) |