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
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
|
(define-module (calp webdav resource calendar collection)
:use-module (srfi srfi-1)
:use-module (srfi srfi-71)
:use-module (srfi srfi-88)
:use-module (oop goops)
:use-module (calp webdav resource)
:use-module (calp webdav property)
:use-module (calp webdav propfind)
:use-module ((vcomponent formats ical) :prefix #{ics:}#)
:use-module ((vcomponent) :prefix vcs-)
:use-module ((vcomponent base)
:select (type prop vcomponent))
:use-module (web request)
:use-module (web uri)
:use-module ((calp namespaces) :select (webdav caldav))
:use-module (sxml namespaced)
:use-module (sxml namespaced util)
:use-module (ice-9 hash-table)
:use-module (hnh util)
:use-module (calp webdav resource calendar object)
;; propfind-most-live-properties propfind-all-dead-properties propname uri-path request-uri type
:export (<calendar-collection-resource>
caldav-properties
calendar-collection-resource?)
)
;;; Resoruces containing calendar components
(define-class <calendar-collection-resource> (<resource>)
;; TODO typecheck
(description init-value: #f
accessor: description)
(data-store getter: data-store
init-keyword: store:))
(define-method (is-collection? (_ <calendar-collection-resource>))
#t)
(define-method (children (this <calendar-collection-resource>))
(map (lambda (ev)
(make <calendar-object-resource>
name: (prop ev 'UID)
component: ev))
(vcs-children this)))
(define (calendar-collection-resource? x)
(is-a? x <calendar-collection-resource>))
(define-method (base-timezone <calendar-collection-resource>)
;; (zoneinfo->vtimezone '() "Europe/Stockholm" 'ev)
(vcomponent type: 'VTIMEZONE)
)
(define-method (live-properties (self <calendar-collection-resource>))
(append (next-method)
(map (lambda (pair) ((xml caldav (car pair)) (cdr pair)))
caldav-properties)))
(define-method (displayname (self <calendar-collection-resource>))
(propstat 200
(list ((xml webdav 'displayname)
(prop (content self) 'displayname)))))
(define-method (resourcetype (self <calendar-collection-resource>))
(propstat 200
(list ((xml webdav 'resourcetype)
((xml caldav 'calendar))))))
;;; CALDAV Properties
(define-method (calendar-description (self <calendar-collection-resource>))
(cond ((description self)
=> (lambda (it)
(propstat 200
(list ((xml caldav 'calendar-description '((xml:lang "en")))
it)))))
(else
(propstat 404 (list ((xml caldav 'calendar-description)))))))
(define-method (calendar-timezone (self <calendar-collection-resource>))
(propstat 200
(list
((xml caldav 'calendar-description)
(call-with-output-string
(lambda (port)
(ics:serialize (base-timezone self) port)))))))
(define-method (supported-calendar-component-set (self <calendar-collection-resource>))
(propstat 200
(list ((xml caldav 'supported-calendar-component-set)
((xml caldav 'comp
'((name "VEVENT"))))))))
(define-method (supported-calendar-data (self <calendar-collection-resource>))
(propstat 200
(list
((xml caldav 'supported-calendar-data)
(map (lambda (content-type)
((xml caldav 'calendar-data
'((content-type ,content-type)
(version "2.0")))))
'("text/calendar"
"application/calendar+xml"))))))
;; (define-method (max-resource-size (self <calendar-collection-resource>))
;; )
;; (define-method (min-date-time ))
;; (define-method (max-date-time ))
;; (define-method (max-instances ))
;; (define-method (max-attendees-per-instance ))
(define-method (supported-collation-set (self <calendar-collection-resource>))
(propstat 200
(list ((xml caldav 'supported-collation-set)
(map (lambda (cs) ((xml caldav 'supported-collation) cs))
`(;; Required by CalDAV
"i;ascii-casemap"
"i;octet"
;; Added (RFC 5051))
"i;unicode-casemap"))))))
(define caldav-properties
`((calendar-description . ,calendar-description)
(calendar-timezone . ,calendar-timezone)
(supported-calendar-component-set . ,supported-calendar-component-set)
(supported-calendar-data . ,supported-calendar-data)
(supported-collation-set . ,supported-collation-set)
;; (max-resource-size . ,max-resource-size)
;; (min-date-time . ,min-date-time)
;; (max-date-time . ,max-date-time)
;; (max-instances . ,max-instances)
;; (max-attendees-per-instance . ,max-attendees-per-instance)
))
;;; Reports
(define-method (supported-reports* (this <calendar-collection-resource>))
(append (next-method)
(list
;; Required for ACL, but not for CalDAV
;; (xml webdav 'version-tree)
;; Optional for ACL, but REQUIRED for CalDAV
((xml webdav 'expand-property) expand-property)
;; REQUIRED by CalDAV
((xml caldav 'calendar-query) calendar-query)
((xml caldav 'calendar-multiget) calendar-multiget)
((xml caldav 'free-busy-report) free-busy-report)
)))
(define-method (calendar-query (this <calendar-collection-resource>) headers body)
;; Request body MUST be a caldav:calendar-query
;; Request MAY include a depth header, default = 0
;; Respnose-body MUST be a dav:multistatus
;; Responseb body MUST contain DAV:respons element for each iCalendar object that matched the search filter
(let ((allprop (find-element (xml webdav 'allprop) (cdr body)))
(propname (find-element (xml webdav 'propname) (cdr body)))
(prop (find-element (xml webdav 'prop) (cdr body)))
(filter (find-element (xml caldav 'filter) (cdr body)))
(timezone (find-element (xml caldav 'timezone) (cdr body))))
(when (< 1 (count identity (list allprop propname prop)))
(throw 'bad-request 400 "allprop, propname, and prop are mutually exclusive"))
(unless filter
(throw 'bad-request 400 "filter required"))
#;
(when timezone
(case (assoc-ref (attributes timezone) 'content-type)
((application/calendar+xml)
(xcs:serialize default-timezone))
;; ((application/calendar+json))
(else ; includes text/calendar
(ics:serialieze default-timezone)
)))
(let ((resources (select-components-by-comp-filter this comp-filter)))
(apply (xml webdav 'multistatus)
(for (href . resource) in resources
(apply (xml webdav 'response)
((xml webdav 'href) (href->string href))
(map propstat->namespaced-sxml
(merge-propstats
(cond (allprop
(append (propfind-most-live-properties resource)
(propfind-all-dead-properties resource)))
(propname
(list (propstat
200
(map (compose (lambda (x) ((xml x))) car)
(append (dead-properties resource)
(live-properties resource))))))
(prop
(map (lambda (prop) (get-property resource prop))
prop)))))))))))
(define-method (expand-property (this <calendar-collection-resource>) request body))
(define-method (free-busy-report (this <calendar-collection-resource>) request body))
(define-method (calendar-multiget (this <calendar-collection-resource>) request body)
(define base-href (-> request request-uri uri-path href->string))
(let ((allprop (find-children ((xml webdav 'allprop)) (cdr body)))
(propname (find-children ((xml webdav 'propname)) (cdr body)))
(prop (find-children ((xml webdav 'prop)) (cdr body)))
(hrefs (find-children ((xml webdav 'href)) (cdr body))))
(when (< 1 (count identity (list allprop propname prop)))
(throw 'bad-request 400 "allprop, propname, and prop are mutually exclusive"))
(when (null? hrefs)
(throw 'bad-request 400 "At least one href is required"))
;; (assert (memv href hrefs))
(let ((resources
(for href in hrefs
(cons href
(lookup-resource
this
(href-relative base-href href))))))
(apply (xml webdav 'multistatus)
(for (href . resource) in resources
(apply (xml webdav 'response)
((xml webdav 'href) (href->string href))
(cond (resource
(cond (allprop
(append (propfind-most-live-properties resource)
(propfind-all-dead-properties resource)))
(propname
(list (propstat
200
;; car to get tagname, list to construct a valid xml element
(map (compose (lambda (x) ((xml x))) car)
(append
(dead-properties resource)
(live-properties resource))))))
(prop
(propfind-selected-properties
resource
;; TODO???
(map car (cdr prop))))))
(else
((xml webdav 'status)
(http-status-line 404))))))))))
(define-method (select-components-by-comp-filter (this <calendar-collection-resource>) comp-filter)
)
;;; TODO
(define (overlaps? a b)
#t)
(define (comp-filter scope filter)
;; CaldDAV 9.7.1
(or (and (null? (children filter))
(eq? (attribute filter 'name)
(type scope)))
(and (find-element (xml caldav 'is-not-defined)
(children filter))
(not
(find (lambda (el) (eq? (type el) (attribute filter 'name)))
(children scope))))
(and (cond ((find-element (xml caldav 'time-range)
(children filter))
=> (lambda (range)
(overlaps? scope range)))
(else #f))
(every (lambda (filt) (comp-filter scope filt)) (children filter)))
(every (lambda (filt) (comp-filter scope filt)) (children filter))))
|
