blob: ef6fbd922074c1fd9fafd547beb5678e7d6be247 (
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
|
(define-module (vcalendar)
#: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 '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)
(define-public (type-filter t lst)
(filter (lambda (e) (eqv? t (type e)))
lst))
(define* (children component #:optional only-type)
(let ((childs (%vcomponent-children component)))
(if only-type
(type-filter only-type childs)
childs)))
(export children)
(define (get-attr component attr)
(%vcomponent-get-attribute
component
(as-string attr)))
(define (set-attr! component attr value)
(set-car! (get-attr component (as-string attr))
value))
(define-public attr*
(make-procedure-with-setter
get-attr set-attr!))
(define-public attr
(make-procedure-with-setter
(compose car get-attr) set-attr!))
;; 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 (cdr attr-obj) prop-key))
(lambda (attr-obj prop-key val)
(hashq-set! (cdr attr-obj) prop-key val))))
(define-public (properties component attr-key)
(hash-map->list cons (cdr (attr component (as-string attr-key)))))
;; (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 component) (map string->symbol (%vcomponent-attribute-list component)))
(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
(parse-dates!
(case (string->symbol (or (attr root "X-HNH-SOURCETYPE") "no-type"))
;; == Single ICS file ==
;; Remove the abstract ROOT component,
;; returning the wanted VCALENDAR component
((file)
(car (%vcomponent-children root)))
;; == Assume vdir ==
;; Also removes the abstract ROOT component, but also
;; merges all VCALENDAR's children into the first
;; VCALENDAR, and return that VCALENDAR.
;;
;; TODO the other VCALENDAR components might not get thrown away,
;; this since I protect them from the GC in the C code.
((vdir)
(reduce (lambda (cal accum)
(for-each (lambda (component)
(case (type component)
((VTIMEZONE)
(let ((zones (children accum 'VTIMEZONE)))
(unless (find (lambda (z)
(string=? (attr z "TZID")
(attr component "TZID")))
zones)
(%vcomponent-push-child! accum component))))
(else (%vcomponent-push-child! accum component))))
(%vcomponent-children cal))
accum)
'() (%vcomponent-children root)))
((no-type) (throw 'no-type))
(else (throw 'something))))))
(set! (attr component "NAME")
(attr root "NAME"))
(set! (attr component "COLOR")
(attr root "COLOR"))
component)))
|
