blob: d693782c7addccdc9874e76aeeb8f273fc648a7c (
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
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
|
(define-module (vcomponent datetime)
#:use-module (srfi srfi-1)
#:use-module (vcomponent base)
#:use-module (datetime)
#:use-module (datetime util)
#:use-module (datetime zic)
#:use-module (util)
#:export (#;parse-datetime
event-overlaps?
overlapping?
event-contains?
ev-time<?)
)
;;; date time pointer
#;
(define (parse-datetime dtime)
"Parse the given date[time] string into a date object."
(string->date
dtime (case (string-length dtime)
((8) "~Y~m~d") ; All day
((15) "~Y~m~dT~H~M~S") ; "local" or TZID-param
((16) "~Y~m~dT~H~M~S~z")))) ; UTC-time
(define (event-overlaps? event begin end)
"Returns if the event overlaps the timespan.
Event must have the DTSTART and DTEND attribute set."
(timespan-overlaps? (attr event 'DTSTART)
(attr event 'DTEND)
begin end))
(define (overlapping? event-a event-b)
(timespan-overlaps? (attr event-a 'DTSTART)
(attr event-a 'DTEND)
(attr event-b 'DTSTART)
(attr event-b 'DTEND)))
(define (event-contains? ev date/-time)
"Does event overlap the date that contains time."
(let* ((start (as-date date/-time))
(end (add-day start)))
(event-overlaps? ev start end)))
(define-public (ev-time<? a b)
(date/-time<? (attr a 'DTSTART)
(attr b 'DTSTART)))
;; Returns length of the event @var{e}, as a time-duration object.
(define-public (event-length e)
(if (not (attr e 'DTEND))
(datetime date:
(if (date? (attr e 'DTSTART))
#24:00:00
#01:00:00))
((if (date? (attr e 'DTSTART))
date-difference datetime-difference)
(attr e 'DTEND) (attr e 'DTSTART))))
(define-public (event-length/clamped start-date end-date e)
(if (date? (attr e 'DTSTART))
(date-difference (date-min (date+ end-date (date day: 1))
(attr e 'DTEND))
(date-max start-date
(attr e 'DTSTART)))
(datetime-difference (datetime-min (datetime date: (date+ end-date (date day: 1)))
(get-datetime (attr e 'DTEND)))
(datetime-max (datetime date: start-date)
(get-datetime (attr e 'DTSTART))))))
;; Returns the length of the part of @var{e} which is within the day
;; starting at the time @var{start-of-day}.
;; currently the secund argument is a date, but should possibly be changed
;; to a datetime to allow for more explicit TZ handling?
(define-public (event-length/day date e)
;; TODO date= > 2 elements
(let ((start (get-datetime (attr e 'DTSTART)))
(end (get-datetime (attr e 'DTEND))))
(cond [(and (date= (as-date start)
(as-date end))
(date= (as-date start)
date))
(time- (as-time end)
(as-time start))]
;; Starts today, end in future day
[(date= (as-date start)
date)
(time- #24:00:00 (as-time start))]
;; Ends today, start earlier day
[(date= (as-date end)
date)
(as-time end)]
;; start earlier date, end later date
[else #24:00:00])))
;; 22:00 - 03:00
;; 2h för dag 1
;; 3h för dag 2
;; An event is considered long if it's DTSTART (and thereby DTEND) lacks a time component,
;; or if the total length of the event is greater than 24h.
;; For practical purposes, an event being long means that it shouldn't be rendered as a part
;; of a regular day.
(define-public (long-event? ev)
(or (date? (attr ev 'DTSTART))
(datetime<= (datetime date: (date day: 1))
(datetime-difference (attr ev 'DTEND)
(attr ev 'DTSTART)))))
(define-public (zoneinfo->vtimezone zoneinfo zone-name)
(define vtimezone (make-vcomponent 'VTIMEZONE))
(define last-until (datetime date: #1000-01-01))
(define last-offset (timespec-zero))
(set! (attr vtimezone 'TZID) zone-name)
(for zone-entry in (get-zone zoneinfo zone-name)
(cond [(zone-entry-rule zone-entry) timespec?
=> (lambda (inline-rule)
(let ((component (make-vcomponent 'DAYLIGHT))
(new-timespec (timespec-add
(zone-entry-stdoff zone-entry)
inline-rule)))
(set! (attr component 'DTSTART) last-until
(attr component 'TZOFFSETFROM) last-offset
(attr component 'TZOFFSETTO) new-timespec
(attr component 'TZNAME) (zone-entry-format zone-entry)
last-until (zone-entry-until zone-entry)
last-offset new-timespec)
(add-child! vtimezone component)))]
[(zone-entry-rule zone-entry)
=> (lambda (rule-name)
(map (lambda (rule)
(let ((component (make-vcomponent
;; NOTE the zoneinfo database doesn't
;; come with information if a given
;; rule is in standard or daylight time,
;; since that's mostly nonsencical
;; (e.g. war- and peacetime).
;; But the ical standard requires that,
;; so this is a fair compromize.
(if (string-null? (rule-letters rule))
'STANDARD 'DAYLIGHT)))
(new-timespec (timespec-add
(zone-entry-stdoff zone-entry)
(rule-save rule))))
(set! (attr component 'DTSTART) (rule->dtstart rule)
(attr component 'TZOFFSETFROM) last-offset
(attr component 'TZOFFSETTO) new-timespec
(attr component 'TZNAME) (zone-format
(zone-entry-format zone-entry)
(rule-letters rule))
;; NOTE this can both be a number or the
;; symbol 'maximum
last-until (zone-entry-until zone-entry)
last-offset new-timespec)
(awhen (rule->rrule rule)
(set! (attr component 'RRULE) it))
(add-child! vtimezone component)))
(drop-while
;; TODO
;; some of the rules might not apply to us since we only
;; started using that rule set later. It's also possible
;; that we stopped using a ruleset which continues existing.
;;
;; Both these cases should be filtered here.
(const #f)
#;
(lambda (rule)
(rule-from rule) ; 1970
(rule-in rule) ; 4 (apr)
(rule-on rule) ; 5 | (last sat)
(rule-to rule)
last-until)
(get-rule zoneinfo rule-name))))]
[else ; no rule
(let ((component (make-vcomponent 'STANDARD)))
;; DTSTART MUST be a datetime in local time
(set! (attr component 'DTSTART) last-until
(attr component 'TZOFFSETFROM) last-offset
(attr component 'TZOFFSETTO) (zone-entry-stdoff zone-entry)
(attr component 'TZNAME) (zone-entry-format zone-entry)
last-until (zone-entry-until zone-entry)
last-offset (zone-entry-stdoff zone-entry))
(add-child! vtimezone component))]))
vtimezone)
|
