From 59f6fc205b19f0cd2253adb7c656c4eda904a52e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 6 Apr 2019 19:08:59 +0200 Subject: Add earlier work on timezones. Add earlier work on timezones, with a few inline modifications. This is really to big of a commit. But we are so far from a stable release that it should be fine. The current version seems to eager, and recalculates to many times. This will soon be fixed in a future version. --- module/util.scm | 9 +++- module/vcalendar.scm | 40 +++++++++++++++-- module/vcalendar/datetime.scm | 22 +++++----- module/vcalendar/recurrence/generate.scm | 41 +++++++++++++----- module/vcalendar/recurrence/parse.scm | 4 +- module/vcalendar/timezone.scm | 73 ++++++++++++++++++++++++++++++++ 6 files changed, 162 insertions(+), 27 deletions(-) create mode 100644 module/vcalendar/timezone.scm (limited to 'module') diff --git a/module/util.scm b/module/util.scm index 25be0389..cdc6026d 100644 --- a/module/util.scm +++ b/module/util.scm @@ -152,8 +152,13 @@ (set! rest ...))))) ;; Like set!, but applies a transformer on the already present value. -(define-syntax-rule (mod! field transform-proc) - (set! field (transform-proc field))) +(define-syntax mod! + (syntax-rules () + ((_ field proc) + (set! field (proc field))) + ((_ field transform-proc rest ...) + (begin (set! field (transform-proc field)) + (mod! rest ...))))) (define-public (concat lists) (apply append lists)) diff --git a/module/vcalendar.scm b/module/vcalendar.scm index a4da1527..ef6fbd92 100644 --- a/module/vcalendar.scm +++ b/module/vcalendar.scm @@ -2,18 +2,50 @@ #:use-module (vcalendar primitive) #:use-module (vcalendar datetime) #:use-module (vcalendar recur) + #:use-module (vcalendar timezone) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-19 util) #:use-module (srfi srfi-26) #:use-module (util) #:export (make-vcomponent) #:re-export (repeating?)) +;; All VTIMEZONE's seem to be in "local" time in relation to +;; themselves. Therefore, a simple comparison should work, +;; and then the TZOFFSETTO attribute can be subtracted from +;; the event DTSTART to get UTC time. + +(define string->time-utc + (compose date->time-utc (unval parse-datetime))) + (define (parse-dates! cal) "Parse all start times into scheme date objects." - (for-each-in (children cal 'VEVENT) - (lambda (ev) - (mod! (attr ev "DTSTART") parse-datetime) - (mod! (attr ev "DTEND") parse-datetime))) + + (for-each-in (children cal 'VTIMEZONE) + (lambda (tz) + (for-each (lambda (p) (mod! (attr p "DTSTART") string->time-utc)) + (children tz)) + + ;; TZSET is the generated recurrence set of a timezone + (set! (attr tz 'X-HNH-TZSET) + (make-tz-set tz)))) + + (for-each + (lambda (ev) + (mod! (attr ev "DTSTART") string->time-utc + (attr ev "DTEND") string->time-utc) + + (when (prop (attr* ev 'DTSTART) 'TZID) + (let* ((of (get-tz-offset ev))) + (set! (prop (attr* ev 'DTSTART) 'TZID) #f) + ;; 5545 says that DTEND is local time iff DTSTART is local time. + ;; But who says that will be true... + (mod! (attr ev 'DTSTART) + (cut subtract-duration <> (make-duration of)))))) + (children cal 'VEVENT)) + + ;; Return cal) diff --git a/module/vcalendar/datetime.scm b/module/vcalendar/datetime.scm index f6df03d5..9b1cc82d 100644 --- a/module/vcalendar/datetime.scm +++ b/module/vcalendar/datetime.scm @@ -2,22 +2,24 @@ #:use-module (vcalendar) #:use-module (srfi srfi-19) #:use-module (srfi srfi-19 util) + #:use-module (util) #:export (parse-datetime event-overlaps? - event-in?) + event-in? + ev-timetime-utc - (string->date - dtime - (case (string-length dtime) - ((8) "~Y~m~d") - ((15) "~Y~m~dT~H~M~S") - ((16) "~Y~m~dT~H~M~S~z"))))) + (let* ((str type (case (string-length dtime) + ((8) (values "~Y~m~d" 'all-day)) ; All day + ((15) (values "~Y~m~dT~H~M~S" 'local)) ; "local" or TZID-param + ((16) (values "~Y~m~dT~H~M~S~z" 'utc)) ; UTC-time + )) + (date (string->date dtime str))) + (values date type))) (define (event-overlaps? event begin end) "Returns if the event overlaps the timespan. @@ -33,6 +35,6 @@ Event must have the DTSTART and DTEND attribute set." (end (add-day start))) (event-overlaps? ev start end))) -(define-public (ev-timedate (attr e 'DTSTART)))) + (case (freq r) + ((MONTHLY) (mod! (month sdate) (cut + <> (interval r)))) + ((YEARLY) (mod! (year sdate) (cut + <> (interval r))))) + (set! (attr e 'DTSTART) + (date->time-utc sdate)))) - (set! (attr e 'DTEND) - (add-duration (attr e 'DTSTART) (attr e 'DURATION))) + ;; TODO + ;; All the BY... fields + ) + + (when (attr e 'DTEND) + (set! (attr e 'DTEND) + (add-duration (attr e 'DTSTART) (attr e 'DURATION)))) ;; Return e)) @@ -102,9 +112,20 @@ (define (generate-recurrence-set event) - (unless (attr event "DURATION") - (set! (attr event "DURATION") - (time-difference - (attr event "DTEND") - (attr event "DTSTART")))) - (recur-event-stream event (parse-recurrence-rule (attr event "RRULE")))) + ;; TODO DURATION might be used for something else, check applicable types + ;; TODO Far from all events have DTEND + ;; VTIMEZONE's always lack it. + (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")))) + (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 + ;; just mention the current part. Handle this + stream-null)))) diff --git a/module/vcalendar/recurrence/parse.scm b/module/vcalendar/recurrence/parse.scm index ad8f06c3..de5d7e7c 100644 --- a/module/vcalendar/recurrence/parse.scm +++ b/module/vcalendar/recurrence/parse.scm @@ -87,7 +87,9 @@ (let* (((key val) kv) ;; Lazy fields for the poor man. (symb (lambda () (string->symbol val))) - (date (lambda () (parse-datetime val))) + (date (lambda () + (let* ((date type (parse-datetime val))) + (date->time-utc date)))) (days (lambda () (map parse-day-spec (string-split val #\,)))) (num (lambda () (string->number val))) (nums (lambda () (string->number-list val #\,)))) diff --git a/module/vcalendar/timezone.scm b/module/vcalendar/timezone.scm new file mode 100644 index 00000000..82d13a8d --- /dev/null +++ b/module/vcalendar/timezone.scm @@ -0,0 +1,73 @@ +(define-module (vcalendar timezone) + :use-module (vcalendar) + :use-module ((srfi srfi-1) :select (find)) + :use-module (srfi srfi-19) + :use-module (srfi srfi-19 util) + :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) + :use-module (util) + :use-module ((vcalendar recur) :select (generate-recurrence-set)) + :use-module ((vcalendar datetime) :select (ev-time :: "#" +;; TZID: Europe/Stockholm +;; X-LIC-LOCATION: Europe/Stockholm +;; : :: "#" +;; : RRULE: FREQ=YEARLY;BYMONTH=3;BYDAY=-1SU +;; : DTSTART: 19700329T020000 +;; : TZNAME: CEST +;; : TZOFFSETTO: +0200 +;; : TZOFFSETFROM: +0100 +;; : :: "#" +;; : RRULE: FREQ=YEARLY;BYMONTH=10;BYDAY=-1SU +;; : DTSTART: 19701025T030000 +;; : TZNAME: CET +;; : TZOFFSETTO: +0100 +;; : TZOFFSETFROM: +0200 +;; @end example + + +;; The RFC requires that at least one DAYLIGHT or STANDARD component is present. +;; Any number of both can be present. This should handle all these cases well, +;; as long as noone has multiple overlapping timezones, which depend on some +;; further condition. That feels like something that should be impossible, but +;; this is (human) time we are talking about. +(define-public (make-tz-set tz) + (let ((strm (interleave-streams + ev-timelist str))) + ((primitive-eval (symbol pm)) + (+ (* 60 (string->number (list->string (list m1 m0)))) + (* 60 60 (string->number (list->string (list h1 h0)))))))) + +;; Finds the VTIMEZONE with id @var{tzid} in calendar. +;; Crashes on error. +(define (find-tz cal tzid) + (let ((ret (find (lambda (tz) (string=? tzid (attr tz 'TZID))) + (children cal 'VTIMEZONE)))) + ret)) + +;; Takes a VEVENT. +;; Assumes that DTSTART has a TZID property, and that that TZID is available as +;; a direct child of the parent of @var{ev}. +(define-public (get-tz-offset ev) + (let ((ret (stream-find + (lambda (z) + (let* (((start end) (map (extract 'DTSTART) z))) + (and (time<=? start (attr ev 'DTSTART)) + (time