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
|
(define-module (web http dav)
:use-module (srfi srfi-9)
:use-module (srfi srfi-88)
:use-module (rnrs bytevectors)
:use-module (rnrs io ports)
:use-module ((ice-9 binary-ports) :select (call-with-output-bytevector))
:use-module (web request)
:use-module (web response)
:use-module (web client)
:use-module (web uri)
:use-module (sxml simple)
:use-module (sxml xpath)
:use-module ((hnh util) :select (->))
:export (caldav
user-agent dav
propfind
get-principal
get-calendar-home-set
get-calendar-paths
get-calendar-name
)
)
(define caldav "urn:ietf:params:xml:ns:caldav")
(define user-agent (make-parameter ""))
(user-agent "calp/0.1")
(define-record-type <info>
(make-info uri-creator password)
info?
(uri-creator uri-creator)
(password info-password)
)
(define (with-output-to-bytevector thunk)
(call-with-output-bytevector
(lambda (port)
(with-output-to-port port thunk))))
;; Make a webdav HTTP request, body should be a sxml tree without the *TOP* or
;; *PI* element.
(define* (dav uri key: method authorization body (depth 1))
(define request-body
(if body
(with-output-to-bytevector
(lambda ()
(sxml->xml
`(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
,body))))
#f))
(define headers
`((user-agent . ,(user-agent))
(depth . ,(cond (depth number? => number->string)
(else depth)))
;; (accept . ((*/*)))
(authorization . ,authorization)
,@(if body
`((content-type . (application/xml (charset . "UTF-8")))
(content-length . ,(bytevector-length request-body)))
'())))
(http-request uri
method: method
body: request-body
headers: headers
keep-alive?: #t
decode-body?: #f
streaming?: #t))
(define* (propfind uri resource key: (depth 1) password)
(define authorization
(if password
`(Basic ,password)
#f))
(define-values (response port)
(dav uri
method: 'PROPFIND
authorization: authorization
depth: depth
body: `(propfind (@ (xmlns "DAV:")
(xmlns:d "DAV:")
(xmlns:c ,caldav))
(prop (,resource)))))
(unless (= 207 (response-code response))
(scm-error 'dav-error "propfind"
"HTTP error ~a: ~a"
(list
(response-code response)
(response-reason-phrase response))
(list response)))
(xml->sxml port
declare-namespaces?: #t
trim-whitespace?: #t
namespaces: `((d . "DAV:")
(c . ,caldav))))
;; (define (get-collections)
;; (-> (propfind "/" 'resourcetype)
;; ((sxpath '(// (d:response (// d:resourcetype d:collection))
;; d:href *text*)))))
;; => ((d:resourcetype (d:collection)))
(define* (get-principal uri key: password)
(-> (propfind uri 'current-user-principal
depth: 0
password: password)
((sxpath '(// (d:response (d:href (equal? "/")))
//
d:prop d:current-user-principal
d:href *text*)))
car))
(define* (get-calendar-home-set principal-uri key: password)
(-> (propfind principal-uri
'c:calendar-home-set
password: password)
((sxpath `(// (d:response (d:href
(equal? ,(uri-path principal-uri))))
// d:prop c:calendar-home-set
d:href *text*
)))
car))
(define* (get-calendar-paths calendar-home-set-uri key: password)
(-> (propfind calendar-home-set-uri
'resourcetype
depth: "infinity"
password: password)
((sxpath '(// (d:response (// d:resourcetype c:calendar))
d:href *text*)))))
;; => ("Calendar")
(define* (get-calendar-name calendar-path
key: password)
(-> (propfind calendar-path 'displayname
depth: 0
password: password)
((sxpath '(// d:response // d:prop d:displayname *text*)))
car))
|
