1 files changed, 144 insertions, 0 deletions
diff --git a/module/web/http/dav.scm b/module/web/http/dav.scm
new file mode 100644
index 00000000..9adc8b87
--- /dev/null
+++ b/module/web/http/dav.scm
@@ -0,0 +1,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))
+
+