blob: 70d21be1f9f21c2a0767a1c02d02f03ce619dc60 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
|
(define-module (vcomponent recurrence generate)
#:use-module ((srfi srfi-1) :select (find))
#:use-module (datetime)
#:use-module (datetime util)
#:use-module (srfi srfi-26) ; Cut
#:use-module (srfi srfi-41) ; Streams
#:use-module (ice-9 match)
#:use-module (util)
#:use-module (util exceptions)
#:use-module (vcomponent base)
#:use-module (vcomponent recurrence internal)
#:use-module (vcomponent recurrence parse)
#:export (generate-recurrence-set)
)
;;; TODO implement
;;; EXDATE and RDATE
;;; EXDATE (3.8.5.1)
;;; comma sepparated list of dates or datetimes.
;;; Can have TZID parameter
;;; Specifies list of dates that the event should not happen on, even
;;; if the RRULE say so.
;;; Can have VALUE field specifiying "DATE-TIME" or "DATE".
;;; RDATE (3.8.5.2)
;;; Comma sepparated list of dates the event should happen on.
;;; Can have TZID parameter.
;;; Can have VALUE parameter, specyfying "DATE-TIME", "DATE" or "PREIOD".
;;; PERIOD (see 3.3.9)
(define (seconds-in freq)
(case freq
((SECONDLY) 1)
((MINUTELY) 60)
((HOURLY) (* 60 60))
((DAILY) (* 60 60 24))
((WEEKLY) (* 60 60 24 7))))
;; Event x Rule → Event
;; TODO My current naïve aproach to simple adding a constant time to an event
;; breaks with time-zones. betwen 12:00 two adjacent days might NOT be 24h.
;; Specifically, 23h or 25h when going between summer and "normal" time.
(define (next-event ev r)
(let ((e (copy-vcomponent ev)))
(let-env ((TZ (and=> (prop (attr* e 'DTSTART) 'TZID) car)))
(let ((d (attr e 'DTSTART))
(i (interval r)))
(let ((date-change (case (freq r)
((DAILY) (date day: i))
((WEEKLY) (date day: (* i 7)))
((MONTHLY) (date month: i))
((YEARLY) (date year: i))
(else (date))))
(time-change (case (freq r)
((SECONDLY) (time second: i))
((MINUTELY) (time minute: i))
((HOURLY) (time hour: i))
(else (time)))))
(set! (attr e 'DTSTART)
(if (date? d)
(date+ d date-change)
(datetime+ d (datetime date: date-change time: time-change)))))
#;
(set! (zone-offset d) ;
(zone-offset (time-utc->date (date->time-utc d))))
(let ((start (attr e 'DTSTART))
(end (attr e 'DTEND))
(change (attr e 'X-HNH-DURATION)))
(when end
(set! (attr e 'DTEND)
(if (date? start)
(date+ start change)
(datetime+ start change)))))))
e))
;; BYDAY and the like depend on the freq?
;; Line 7100
;; Table @@ 2430
;;
;; Event x Rule → Bool (continue?)
;; Alternative, monadic solution using <optional>.
;; @example
;; (optional->bool
;; (do (<$> (cut time<=? (attr last 'DTSTART)) (until r))
;; (<$> (negate zero?) (count r))
;; (just #t)))
;; @end example
(define-stream (recur-event-stream event rule-obj)
(stream-unfold
;; Event x Rule → Event
(match-lambda
((e _)
(let ((expected-start (attr e 'DTSTART)))
;; If we have alternatives, check them
(or (and=> (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.
;; RFC 5545 3.8.4.4
(find (lambda (alt) ((if (datetime? expected-start)
datetime= date=)
expected-start (attr alt 'RECURRENCE-ID)))
alternatives)))
;; If we did't have an exception just return the regular event.
e))))
;; Event x Rule → Bool (continue?)
(match-lambda
((e r)
(or (and (not (until r)) (not (count r))) ; Never ending
(and=> (count r) (negate zero?)) ; COUNT
(and=> (until r) (lambda (dt) ((if (date? dt) date<= datetime<=) ; UNTIL
(attr e 'DTSTART) dt))))))
;; Event x Rule → next (Event, Rule)
(match-lambda
((e r)
(list (next-event e r)
(if (count r)
(set (count r) = (- 1))
r ))))
;; Seed
(list event rule-obj)))
(define (generate-recurrence-set event)
;; TODO DURATION might be used for something else, check applicable types
;; TODO Far from all events have DTEND
;; VTIMEZONE's always lack it.
(catch #t
(lambda ()
(if (not (attr event 'RRULE))
(stream event)
(begin
(set! (attr event 'X-HNH-DURATION)
(cond [(attr event 'DURATION) => identity]
[(attr event 'DTEND)
=> (lambda (end)
;; The value type of dtstart and dtend must be the same
;; according to RFC 5545 3.8.2.2 (Date-Time End).
(if (date? end)
(date-difference end (attr event 'DTSTART))
(datetime-difference end (attr event 'DTSTART))))]))
(if (attr event "RRULE")
(recur-event-stream
event (parse-recurrence-rule
(attr event "RRULE")
(if (date? (attr event 'DTSTART))
parse-ics-date parse-ics-datetime)))
;; TODO some events STANDARD and DAYLIGT doesn't have RRULE's, but rather
;; just mention the current part. Handle this
stream-null))))
(lambda (err . args)
(warning "while parsing recurrence rule ~%~a ~s~%~a"
err args (attr event 'X-HNH-FILENAME))
(stream ; event
)
)))
|
