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
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
|
(define-module (vcomponent formats xcal parse)
:use-module (hnh util)
:use-module (hnh util exceptions)
:use-module (base64)
:use-module (ice-9 match)
:use-module (sxml match)
:use-module (vcomponent)
:use-module (vcomponent geo)
:use-module (vcomponent formats common types)
:use-module (datetime)
:use-module (srfi srfi-1)
)
;; symbol, ht, (list a) -> non-list
(define (handle-value type props value)
(case type
[(binary)
;; rfc6321 allows whitespace in binary
(base64-string->bytevector
(string-delete char-set:whitespace (car value)))]
[(boolean) (string=? "true" (car value))]
;; TODO possibly trim whitespace on text fields
[(cal-address uri text unknown) (car value)]
[(date)
;; TODO this is correct, but ensure remaining types
(hashq-set! props 'VALUE "DATE")
(parse-iso-date (car value))]
[(date-time) (parse-iso-datetime (car value))]
[(duration)
((get-parser 'DURATION) props value)]
[(float integer) ; (3.0)
(string->number (car value))]
[(period)
(sxml-match
(cons 'period value)
[(period (start ,start-dt) (end ,end-dt))
(cons (parse-iso-datetime start-dt)
(parse-iso-datetime end-dt))]
[(period (start ,start-dt) (duration ,duration))
(cons (parse-iso-datetime start-dt)
((@ (vcomponent duration) parse-duration) duration))])]
[(recur)
;; RFC6221 (xcal) Appendix A 3.3.10 specifies that all components should
;; come in a specified order, and by extension that all components of the
;; same type should follow each other. Actually checking that is harder
;; than to just accept anything in any order. It would also make us less
;; robust for other implementations with other ideas.
(let ((parse-value-of-that-type
(lambda (type value)
(case type
((wkst)
((@ (vcomponent recurrence parse)
rfc->datetime-weekday)
(string->symbol value)))
((freq) (string->symbol value))
((until)
;; RFC 6321 (xcal), p. 30 specifies type-until as
;; type-until = element until {
;; type-date |
;; type-date-time
;; }
;; but doesn't bother defining type-date[-time]...
;; This is acknowledged in errata 3315 [1], but
;; it lacks a solution...
;; Seeing as RFC 7265 (jcal) in Example 2 (p. 16)
;; show the date as a direct string we will roll
;; with that here to.
;; [1]: https://www.rfc-editor.org/errata/eid3315
(string->date/-time value))
((byday) ((@@ (vcomponent recurrence parse) parse-day-spec) value))
((count interval bysecond bymunite byhour
bymonthday byyearday byweekno
bymonth bysetpos)
(string->number value))
(else (scm-error 'key-error "handle-value"
"Invalid type ~a, with value ~a"
(list type value)
#f))))))
;; freq until count interval wkst
(apply (@ (vcomponent recurrence internal) make-recur-rule)
(concatenate
(filter identity
(for key in '(bysecond byminute byhour byday bymonthday
byyearday byweekno bymonth bysetpos
freq until count interval wkst)
(define values (assoc-ref-all value key))
(if (null? values)
#f
(case key
;; These fields all have zero or one value
((freq until count interval wkst)
(list (symbol->keyword key)
(parse-value-of-that-type
key (car (map car values)))))
;; these fields take lists
((bysecond byminute byhour byday bymonthday
byyearday byweekno bymonth bysetpos)
(list (symbol->keyword key)
(map (lambda (v) (parse-value-of-that-type key v))
(map car values))))
(else (scm-error 'misc-error "handle-value"
"Invalid key ~s"
(list key)
#f)))))))))]
[(time) (parse-iso-time (car value))]
[(utc-offset) ((get-parser 'UTC-OFFSET) props (car value))]
[(geo) ; ((long 1) (lat 2))
(sxml-match
(cons 'geo value)
[(geo (latitude ,x) (longitude ,y))
((@ (vcomponent geo) make-geo) x y)])]))
(define (symbol-upcase symb)
(-> symb
symbol->string
string-upcase
string->symbol))
(define (handle-parameters parameters)
(define ht (make-hash-table))
(for param in parameters
(match param
[(ptag (ptype pvalue ...) ...)
;; TODO parameter type (rfc6321 3.5.)
;; TODO multi-valued parameters!!!
(hashq-set! ht (symbol-upcase ptag)
(car (concatenate pvalue)))]))
ht)
(define* (parse-enum str enum optional: (allow-other #t))
(let ((symb (string->symbol str)))
(unless (memv symb enum)
(warning "~a ∉ { ~{~a~^, ~} }" symb enum))
symb))
;; symbol non-list -> non-list
(define (handle-tag tag-name data)
(case tag-name
[(request-status)
;; TODO
(warning "Request status not yet implemented")
#f]
((transp) (parse-enum
data '(OPAQUE TRANSPARENT) #f))
((class) (parse-enum
data '(PUBLIC PRIVATE CONFIDENTIAL)))
((partstat) (parse-enum
data '(NEEDS-ACTION ACCEPTED DECLINED TENTATIVE
DELEGATED IN-PROCESS)))
((status) (parse-enum
data '(TENTATIVE CONFIRMED CANCELLED NEEDS-ACTION COMPLETED
IN-PROCESS DRAFT FINAL CANCELED)))
((action) (parse-enum
data '(AUDIO DISPLAY EMAIL NONE)))
[else data]))
;; Note
;; This doesn't verify the inter-field validity of the object,
;; meaning that value(DTSTART) == DATE and value(DTEND) == DATE-TIME
;; are possibilities, which other parts of the code will crash on.
;; TODO
;; since we are feeding user input into this it really should be fixed.
(define-public (sxcal->vcomponent sxcal)
(define type (symbol-upcase (car sxcal)))
(define component (make-vcomponent type))
(awhen (assoc-ref sxcal 'properties)
;; Loop over multi valued fields, creating one vline
;; for every value. So
;; KEY;p=1:a,b
;; would be expanded into
;; KEY;p=1:a
;; KEY;p=1:b
(for property in it
(match property
;; TODO request-status
[(tag ('parameters parameters ...)
(type value ...) ...)
(let ((params (handle-parameters parameters))
(tag* (symbol-upcase tag)))
(for (type value) in (zip type value)
;; ignore empty fields
;; mostly for <text/>
(unless (null? value)
(let ()
(define vline
(make-vline tag*
(handle-tag
tag (handle-value type params value))
params))
(if (memv tag* '(ATTACH ATTENDEE CATEGORIES
COMMENT CONTACT EXDATE
REQUEST-STATUS RELATED-TO
RESOURCES RDATE
;; x-prop
;; iana-prop
))
(aif (prop* component tag*)
(set! (prop* component tag*) (cons vline it))
(set! (prop* component tag*) (list vline)))
;; else
(set! (prop* component tag*) vline))
))))]
[(tag (type value ...) ...)
(for (type value) in (zip type value)
;; ignore empty fields
;; mostly for <text/>
(unless (null? value)
(let ((params (make-hash-table))
(tag* (symbol-upcase tag)))
(define vline
(make-vline tag*
(handle-tag
tag (let ((v (handle-value type params value)))
;; TODO possibly more list fields
(if (eq? tag 'categories)
(string-split v #\,)
v)))
params))
;;
(if (memv tag* '(ATTACH ATTENDEE CATEGORIES
COMMENT CONTACT EXDATE
REQUEST-STATUS RELATED-TO
RESOURCES RDATE
;; x-prop
;; iana-prop
))
(aif (prop* component tag*)
(set! (prop* component tag*) (cons vline it))
(set! (prop* component tag*) (list vline)))
;; else
(set! (prop* component tag*) vline))
)))])))
;; children
(awhen (assoc-ref sxcal 'components)
(for child in (map sxcal->vcomponent it)
(add-child! component child)))
component)
|
