blob: d1a0abff1b752b54d9c11e851a733fa539be2c62 (
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
197
198
199
200
201
202
203
204
|
(define-module (vcomponent)
#:use-module (vcomponent primitive)
#:use-module (vcomponent datetime)
#:use-module (vcomponent recurrence)
#:use-module (vcomponent timezone)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-17)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-19 util)
#:use-module (srfi srfi-19 setters)
#:use-module (srfi srfi-26)
#:use-module ((ice-9 optargs) #:select (define*-public))
#: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 parse-datetime))
(define (parse-dates! cal)
"Parse all start times into scheme date objects."
(for tz in (children cal 'VTIMEZONE)
(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 ev in (children cal 'VEVENT)
(define date (parse-datetime (attr ev 'DTSTART)))
(define end-date (parse-datetime (attr ev 'DTEND)))
(set! (attr ev "DTSTART") (date->time-utc date)
(attr ev "DTEND") (date->time-utc end-date))
(when (prop (attr* ev 'DTSTART) 'TZID)
(set! (zone-offset date) (get-tz-offset ev)
(attr ev 'DTSTART) (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)
(attr ev 'DTEND) (date->time-utc end-date)))))
(define-public (type-filter t lst)
(filter (lambda (e) (eqv? t (type e)))
lst))
(define*-public (children component #:optional only-type)
(let ((childs (%vcomponent-children component)))
(if only-type
(type-filter only-type childs)
childs)))
(define (get-attr component attr)
(%vcomponent-get-attribute
component
(as-symb attr)))
(define (set-attr! component attr value)
(set! (car (get-attr component (as-string attr)))
value))
(define-public value caar)
(define-public next cdr)
;; (define-public next! pop!)
(define-public (values-left-count attr-list)
(length (take-while identity attr-list)))
(define-public (value-count attr-list)
(length (take-while identity (cdr (drop-while identity attr-list)))))
;; (define-public (reset! attr-list)
;; (while (not (car attr-list))
;; (next! attr-list))
;; (next! attr-list))
(define-public attr* get-attr)
(define (get-first c a)
(and=> (car (get-attr c a)) car))
(define (set-first! c a v)
(and=> (car (get-attr c a))
(lambda (f) (set! (car f) v))))
(define-public attr
(make-procedure-with-setter
get-first set-first!))
;; value
;; (define-public v
;; (make-procedure-with-setter car set-car!))
(define-public prop
(make-procedure-with-setter
(lambda (attr-obj prop-key)
(hashq-ref (cdar attr-obj) prop-key))
(lambda (attr-obj prop-key val)
(hashq-set! (cdar attr-obj) prop-key val))))
;; Returns the properties of attribute as an assoc list.
;; @code{(map car <>)} leads to available properties.
(define-public (properties attrptr)
(hash-map->list cons (cdar attrptr)))
;; (define-public type %vcomponent-get-type)
(define-public type (make-procedure-with-setter
%vcomponent-get-type
%vcomponent-set-type!))
(define-public parent %vcomponent-parent)
(define-public push-child! %vcomponent-push-child!)
(define-public attributes %vcomponent-attribute-list)
(define-public copy-vcomponent %vcomponent-shallow-copy)
;; (define-public filter-children! %vcomponent-filter-children!)
(define-public (extract field)
(lambda (e) (attr e field)))
(define-public (extract* field)
(lambda (e) (attr* e field)))
(define-public (search cal term)
(cdr (let ((events (filter (lambda (ev) (eq? 'VEVENT (type ev)))
(children cal))))
(find (lambda (ev) (string-contains-ci (car ev) term))
(map cons (map (extract "SUMMARY")
events)
events)))))
(define-public (key=? k1 k2)
(eq? (as-symb k1)
(as-symb k2)))
(define* (make-vcomponent #:optional path)
(if (not path)
(%vcomponent-make)
(let* ((root (%vcomponent-make path))
(component
(case (or (attr root "X-HNH-SOURCETYPE") 'no-type)
;; == Single ICS file ==
;; Remove the abstract ROOT component,
;; returning the wanted VCALENDAR component
((file)
;; TODO test this when an empty file is given.
(car (children root)))
;; == Assume vdir ==
;; Also removes the abstract ROOT component, but also
;; merges all VCALENDAR's children into the a newly
;; created VCALENDAR component, and return that component.
;;
;; TODO the other VCALENDAR components might not get thrown away,
;; this since I protect them from the GC in the C code.
((vdir)
(let ((accum (make-vcomponent))
(ch (children root)))
(set! (type accum) 'VCALENDAR)
(unless (null? ch)
(for key in (attributes (car ch))
(set! (attr accum key) (attr (car ch) key))))
(for cal in ch
(for component in (children cal)
(case (type component)
((VTIMEZONE)
(unless (find (lambda (z)
(string=? (attr z "TZID")
(attr component "TZID")))
(children accum 'VTIMEZONE))
(push-child! accum component)))
(else (push-child! accum component)))))
;; return
accum))
((no-type) (throw 'no-type))
(else (throw 'something)))))
(parse-dates! component)
(unless (attr component "NAME")
(set! (attr component "NAME")
(or (attr component "X-WR-CALNAME")
(attr root "NAME"))))
(unless (attr component "COLOR")
(set! (attr component "COLOR")
(attr root "COLOR")))
;; return
component)))
|
