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 xcal parse)
:use-module (calp util)
:use-module (calp util exceptions)
:use-module (base64)
:use-module (ice-9 match)
:use-module (sxml match)
:use-module (vcomponent)
:use-module (vcomponent geo)
:use-module (vcomponent parse 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)
(apply (@ (vcomponent recurrence internal) make-recur-rule)
(for (k v) in value
(list (symbol->keyword k) v)))]
[(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)
(set! (prop* component tag*)
(make-vline tag*
(handle-tag
tag (handle-value type params value))
params)))))]
[(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)))
(set! (prop* component tag*)
(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)))))])))
;; children
(awhen (assoc-ref sxcal 'components)
(for child in (map sxcal->vcomponent it)
(add-child! component child)))
component)
|
