From 7f6eebf37ac9310cfa5de4a33963b997bb873299 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 23 Dec 2019 02:17:59 +0100 Subject: Fix reccuring events with exceptions. An event with an RRULE can have extra VEVENT's which share their UID, but add a RECCURENCE-ID which contains when the event was supposed to take place. In place of that time it may supply it's own overriding time. It may also override other fields. --- module/vcomponent/parse.scm | 139 +++++++++++++++++------------- module/vcomponent/recurrence/generate.scm | 16 +++- 2 files changed, 95 insertions(+), 60 deletions(-) (limited to 'module') diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm index effc51c1..b3334a99 100644 --- a/module/vcomponent/parse.scm +++ b/module/vcomponent/parse.scm @@ -132,6 +132,8 @@ (set! component child))] [(eq? (get-line-key ctx) 'END) + (case (type component) ; HERE + [(VEVENT DAYLIGHT STANDARD) (parse-date! component)]) (set! component (parent component))] [else @@ -208,52 +210,47 @@ row ~a column ~a ctx = ~a +(define (parse-date! ev) + (awhen (attr* ev 'RECURRENCE-ID) + (let-env ((TZ (and=> (prop it 'TZID) car))) + (set! (value it) + (date->time-utc (parse-datetime (value it)))))) + + (let-env ((TZ (and=> (prop (attr* ev 'DTSTART) 'TZID) car))) + (let* + ((dptr (attr* ev 'DTSTART)) + (eptr (attr* ev 'DTEND)) + + (date (parse-datetime (value dptr))) + (end-date + (cond ;; [(attr ev 'DURATION) => (lambda (d) (add-duration ...))] + [(not eptr) + (let ((d (set (date-hour date) = (+ 1)))) + (set! (attr ev 'DTEND) d + eptr (attr* ev 'DTEND)) + d)] + [(value eptr) => parse-datetime] + [else + (set (date-hour date) = (+ 1))]))) + + (set! (value dptr) (date->time-utc date) + (value eptr) (date->time-utc end-date)) + + (when (prop (attr* ev 'DTSTART) 'TZID) + ;; Re-align date to have correect timezone. This is since time->date gives + ;; correct, but the code above may (?) fail to update the timezone. + (set! (zone-offset date) (zone-offset (time-utc->date (value dptr))) + (value dptr) (date->time-utc date) + + ;; The standard says that DTEND must have the same + ;; timezone as DTSTART. Here we trust that blindly. + (zone-offset end-date) (zone-offset date) + (value eptr) (date->time-utc end-date)))))) + + ;; 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. - -;; Goes through a vcomponent, finds all it's direct children of type VEVENT -;; and parses their DTSTART and DTEND attributes -(define (parse-dates! cal) - "Parse all start times into scheme date objects." - - (for ev in (filter (lambda (o) (eq? 'VEVENT (type o))) (children cal)) - (let-env ((TZ (and=> (prop (attr* ev 'DTSTART) 'TZID) car))) - (let* - ((dptr (attr* ev 'DTSTART)) - (eptr (attr* ev 'DTEND)) - - (date (parse-datetime (value dptr))) - (end-date - (cond ;; [(attr ev 'DURATION) => (lambda (d) (add-duration ...))] - [(not eptr) - (let ((d (set (date-hour date) = (+ 1)))) - (set! (attr ev 'DTEND) d - eptr (attr* ev 'DTEND)) - d)] - [(value eptr) => parse-datetime] - [else - (set (date-hour date) = (+ 1))]))) - - (set! (value dptr) (date->time-utc date) - (value eptr) (date->time-utc end-date)) - - (when (prop (attr* ev 'DTSTART) 'TZID) - ;; Re-align date to have correect timezone. This is since time->date gives - ;; correct, but the code above may (?) fail to update the timezone. - (set! (zone-offset date) (zone-offset (time-utc->date (value dptr))) - (value dptr) (date->time-utc date) - - ;; The standard says that DTEND must have the same - ;; timezone as DTSTART. Here we trust that blindly. - (zone-offset end-date) (zone-offset date) - (value eptr) (date->time-utc end-date))))))) - - -;; Takse a path to a vdir, and returns all ics files in the directory merged -;; together into a single vcalendar. The first found vcalendar is used as the -;; parent. Meaning other vcalendars are discarded. +;; and then the TZOFFSETTO attribute can be subtd. (define (parse-vdir path) (let ((/ (lambda args (string-join args file-name-separator-string 'infix)))) (let ((color @@ -266,24 +263,48 @@ row ~a column ~a ctx = ~a (const (basename path "/"))))) (reduce (lambda (item calendar) - (assert (eq? 'VCALENDAR (type calendar))) - (assert (eq? 'VCALENDAR (type item))) - (unless (= 1 (length (filter (lambda (e) (eq? 'VEVENT (type e))) - (children item)))) - (format (current-error-port) - "WARNING: File contains more that 1 VEVENT~%~a~%" - (attr item 'X-HNH-FILENAME))) + (define-values (events other) (partition (lambda (e) (eq? 'VEVENT (type e))) + (children item))) + + ;; (assert (eq? 'VCALENDAR (type calendar))) + (assert (eq? 'VCALENDAR (type item))) - ;; TODO The vdir standard says that each file should contain - ;; EXACTLY one event. It can however contain multiple VEVENT - ;; components, but they are still the same event. Probable exceptions - ;; to a recurrence rule. (for child in (children item) - (assert (memv (type child) '(VTIMEZONE VEVENT))) (set! (attr child 'X-HNH-FILENAME) - (attr (parent child) 'X-HNH-FILENAME)) - (add-child! calendar child)) + (attr (parent child) 'X-HNH-FILENAME))) + + ;; NOTE The vdir standard says that each file should contain + ;; EXACTLY one event. It can however contain multiple VEVENT + ;; components, but they are still the same event. + ;; In our case this means exceptions to reccurence rules, which + ;; is set up here, and then later handled in rrule-generate. + (case (length events) + [(0) (format (current-error-port) + "WARNING: No events in component~%~a~%" + (attr item 'X-HNH-FILENAME))] + [(1) + (let ((child (car events))) + (assert (memv (type child) '(VTIMEZONE VEVENT))) + (add-child! calendar child))] + + ;; two or more + [else + + ;; Sorting on SEQUENCE here would have been nice. + ;; But the patches can apparently share a sequence number + ;; of 0 with the original event! + ;; (╯°□°）╯ ┻━┻ + (let* ((head (find (negate (extract 'RECURRENCE-ID)) + events)) + (rest (delete head events eq?))) + + (set! (attr head 'X-HNH-ALTERNATIVES) + (sort*! rest ;; HERE + time (lambda (t) (error "Can't parse file of type " t))])) - (parse-dates! cal) + ;; (parse-dates! cal) (unless (attr cal "NAME") (set! (attr cal "NAME") diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index 84025d2f..0ad30c84 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -1,4 +1,5 @@ (define-module (vcomponent recurrence generate) + #:use-module ((srfi srfi-1) :select (find)) #:use-module (srfi srfi-19) ; Datetime #:use-module (srfi srfi-19 util) #:use-module (srfi srfi-19 setters) @@ -85,7 +86,20 @@ (stream-unfold ;; Event x Rule → Event - car + (match-lambda + ((e _) + (let ((expected-start (attr e 'DTSTART))) + ;; If we have alternatives, check them + (cond [(attr e 'X-HNH-ALTERNATIVES) + (lambda (alternatives) + ;; A recurrence id matching the expected time means that + ;; we have an actuall alternative/exception, use that + ;; instead of the regular event. + (find (lambda (alt) (time=? expected-start (attr alt 'RECURRENCE-ID))) + alternatives)) + => identity] + ;; If we did't have an exception just return the regular event. + [else e])))) ;; Event x Rule → Bool (continue?) (match-lambda -- cgit v1.2.3