blob: 76bdb25108e4746e429abc3f47bd4439809f9772 (
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
|
(define-module (vcomponent parse xcal)
:use-module (util)
:use-module (util exceptions)
:use-module (util 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))]
[(cal-address uri text unknown) (car 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]))
(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)
(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)
(let ((params (make-hash-table))
(tag* (symbol-upcase tag)))
(set! (prop* component tag*)
(make-vline tag*
(handle-tag
tag (handle-value type params value))
params))))])))
;; children
(awhen (assoc-ref sxcal 'components)
(for child in (map sxcal->vcomponent it)
(add-child! component child)))
component)
|
