diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/output/ical.scm | 84 | ||||
-rw-r--r-- | module/vcomponent/recurrence/generate.scm | 13 |
2 files changed, 64 insertions, 33 deletions
diff --git a/module/output/ical.scm b/module/output/ical.scm index 11633e52..a0df6445 100644 --- a/module/output/ical.scm +++ b/module/output/ical.scm @@ -3,6 +3,7 @@ :use-module (ice-9 format) :use-module (util) :use-module (vcomponent) + :use-module (srfi srfi-1) :use-module (srfi srfi-19) :use-module (srfi srfi-19 util) :use-module (srfi srfi-41) @@ -13,20 +14,30 @@ '((from (value #t) (single-char #\f)) (to (value #t) (single-char #\t)))) -(define (value-format key value) - ;; TODO remove once key's are normalized to symbols. - (case key - ((DTSTART DTEND) - (time->string value "~Y~m~dT~H~M~SZ")) - ((DURATION) +(define (value-format key vline) + (catch 'wrong-type-arg + (lambda () + (case key + ((DTSTART DTEND) + (time->string (value vline) (if (prop vline 'TZID) + "~Y~m~dT~H~M~S" + "~Y~m~dT~H~M~SZ" ))) + ((DURATION X-HNH-DURATION) #; (time->string value "~H~M~S") - (let ((s (time-second value))) - (format #f "~a~a~a" - (floor/ s 3600) - (floor/ (modulo s 3600) 60) - (modulo s 60)) - )) - (else value))) + (let ((s (time-second (value vline)))) + (format #f "~a~a~a" + (floor/ s 3600) + (floor/ (modulo s 3600) 60) + (modulo s 60)) + )) + ((RRULE) (value vline)) + + (else (escape-chars (value vline))))) + (lambda (err caller fmt args call-args) + (format (current-error-port) + "WARNING: ~k~%" fmt args) + (with-output-to-string (lambda () (display (value vline)))) + ))) (define (escape-chars str) (with-output-to-string @@ -38,36 +49,48 @@ (else (display ch))) ) str)))) +(define wrap-len 70 #; (floor/ 75 2) + ) + +(define (ical-line-fold string) + (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 (component->ical-string component) - (format #t "BEGIN:~a~%" (type component)) + (format #t "BEGIN:~a\r\n" (type component)) (hash-for-each (lambda (key vline) ;; key;p1=v;p3=10:value - (format #t "~a~:{;~a=~@{~a~^,~}~}:~a~%" - key (properties vline) - ;; TODO wrap lines - (escape-chars (value-format key (value vline))))) + + (display + (ical-line-fold + (format #f "~a~:{;~a=~@{~a~^,~}~}:~a" + key (properties vline) + ;; TODO wrap lines + (value-format key vline)))) + (display "\r\n")) (attributes component)) (for-each component->ical-string (children component)) - (format #t "END:~a~%" (type component)) + (format #t "END:~a\r\n" (type component)) ) (define (print-header) (format #t -"BEGIN:VCALENDAR -PRODID:-//hugo//Calparse 0.5//EN -VERSION:2.0 -CALSCALE:GREGORIAN +"BEGIN:VCALENDAR\r +PRODID:-//hugo//Calparse 0.5//EN\r +VERSION:2.0\r +CALSCALE:GREGORIAN\r " )) (define (print-footer) - (format #t "END:VCALENDAR~%")) + (format #t "END:VCALENDAR\r\n")) (define-public (ical-main calendars events args) - - (define opts (getopt-long args opt-spec)) (define start (cond [(option-ref opts 'from #f) => parse-freeform-date] @@ -77,6 +100,15 @@ CALSCALE:GREGORIAN (print-header) + (let ((tzs (make-hash-table))) + (for cal in calendars + (for tz in (filter (lambda (e) (eq? 'VTIMEZONE (type e))) (children cal)) + (hash-set! tzs (attr tz 'TZID) tz))) + + (hash-for-each (lambda (key component) (component->ical-string component)) + tzs)) + + ;; TODO this contains repeated events multiple times (stream-for-each component->ical-string (filter-sorted-stream (lambda (ev) ((in-date-range? start end) diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index 58961f5e..84025d2f 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -65,7 +65,7 @@ (when (attr e 'DTEND) (set! (attr e 'DTEND) - (add-duration (attr e 'DTSTART) (attr e 'DURATION))))) + (add-duration (attr e 'DTSTART) (attr e 'X-HNH-DURATION))))) e)) @@ -114,12 +114,11 @@ (if (not (attr event 'RRULE)) (stream event) (begin - (when (and (attr event 'DTEND) - (not (attr event 'DURATION))) - (set! (attr event "DURATION") - (time-difference - (attr event "DTEND") - (attr event "DTSTART")))) + (set! (attr event 'X-HNH-DURATION) + (cond [(attr event 'DURATION) => identity] + [(attr event 'DTEND) => (lambda (end) + (time-difference + end (attr event "DTSTART")))])) (if (attr event "RRULE") (recur-event-stream event (parse-recurrence-rule (attr event "RRULE"))) ;; TODO some events STANDARD and DAYLIGT doesn't have RRULE's, but rather |