Split WebDAV calendar resources into 2.

Differentiate between calendar collection and calendar objects already
at the DAV level. This is sensible since they support completely
different properties, and only collections support REPORTS (as for as I
can tell).

3 files changed, 388 insertions, 116 deletions

diff --git a/module/calp/webdav/resource/calendar.scm b/module/calp/webdav/resource/calendar.scm
index 6c20df31..314d66aa 100644
--- a/module/calp/webdav/resource/calendar.scm
+++ b/module/calp/webdav/resource/calendar.scm
@@ -1,129 +1,27 @@
 (define-module (calp webdav resource calendar)
-  :use-module (srfi srfi-88)
-  :use-module (hnh util)
-  :use-module (oop goops)
-  :use-module (vcomponent)
-  :use-module (datetime)
-  :use-module (sxml namespaced)
-  :use-module (calp webdav resource)
-  :use-module (calp webdav property)
-  :use-module (calp namespaces)
-  :use-module (ice-9 hash-table)
-  :use-module ((vcomponent formats ical) :prefix #{ics:}#)
-  :export (<calendar-resource>
+  ;; :use-module (hnh util)
+  ;; :use-module (datetime)
+  ;; :use-module (sxml namespaced util)
+  ;; :use-module (calp webdav property)
+  ;; :use-module (ice-9 hash-table)
+  :use-module (calp webdav resource calendar collection)
+  :use-module (calp webdav resource calendar object)
+  :export (
            calendar-resource?
-           content
-           caldav-properties)
+)
   )
 
-;;; Resoruces containing calendar components
-(define-class <calendar-resoruce> (<resource>)
-  (description init-value: #f
-               accessor: description)
-  (content init-value: (make-vcomponent 'VIRTUAL)
-           accessor: content))
+(define cm (module-public-interface (current-module)))
+(module-use! cm (resolve-interface '(calp webdav resource calendar collection)))
+(module-use! cm (resolve-interface '(calp webdav resource calendar object)))
 
 (define (calendar-resource? x)
-  (is-a? x <calendar-resource>))
+  (or (calendar-collection-resource? x)
+      (calendar-object-resource? x)))
 
-(define-method (live-properties (self <calendar-resource>))
-  (append (next-method)
-          (map (lambda (pair) (cons (xml caldav (car pair)) (cdr pair)))
-               caldav-properties)))
 
-(define-method (creationdate (self <calendar-resource>))
-  (propstat 200
-            `((,(xml webdav 'creationdate)
-               (-> (content self)
-                   (prop 'CREATED)
-                   ;; TODO timezone
-                   (datetime->string "~Y-~m-~dT~H:~M:~SZ"))))))
 
-(define-method (displayname (self <calendar-resource>))
-  (propstat 200
-            `((,(xml webdav 'displayname)
-               ,(prop (content self) 'displayname)))))
 
 
-(define-method (getcontentlength (self <calendar-resoruce>))
-  ;; TODO which representation should be choosen to calculate length?
-  (propstat 501 `((,(xml webdav 'getcontentlength)))))
-
-(define-method (getcontenttyype (self <calendar-resource>))
-  ;; TODO different representations
-  (propstat 200 `((,(xml webdav 'getcontentlength)
-                   "text/calendar"))))
-
-
-(define-method (getlastmodified (self <calendar-resource>))
-  (propstat 200
-            `((,(xml webdav 'getlastmodified)
-               (string->datetime (prop (content self) 'LAST-MODIFIED)
-                                 "~Y~m~dT~H~M~S")))))
-
-
-(define-method (resourcetype (self <calendar-resource>))
-  (propstat 200
-   `((,(xml webdav 'resourcetype)
-      (,(xml caldav 'calendar))))))
-
-;;; CALDAV Properties
-
-;; NOT in allprop
-(define-method (calendar-description (self <calendar-resource>))
-  (cond ((description self)
-         => (lambda (it)
-              (propstat 200
-                        (list (list (xml caldav 'calendar-description (alist->hashq-table '((xml:lang . "en"))))
-                                    it)))))
-        (else
-         (propstat 404 (list (list (xml caldav 'calendar-description)))))))
-
-;; NOT in allprop
-(define-method (calendar-timezone (self <calendar-resource>))
-  (propstat 200
-            (list
-             (list (xml caldav 'calendar-description)
-                   ;; TODO serialize, base-timezone
-                   (ics:serialize (base-timezone (content self)))))))
-
-;; NOT in allprop
-(define-method (supported-calendar-component-set (self <calendar-resource>))
-  (propstat 200
-            `((,(xml caldav 'supported-calendar-component-set)
-               (,(xml caldav 'comp
-                      (alist->hashq-table '((name . "VEVENT")))))))))
-
-(define-method (supported-calendar-data (self <calendar-resource>))
-  (propstat 200
-   (list
-    (list
-     (xml caldav 'supported-calendar-data)
-     (map (lambda (content-type)
-            (list (xml caldav 'calendar-data
-                       (alist->hashq-table
-                        '((content-type . ,content-type)
-                          (version . "2.0"))))))
-          '("text/calendar" "application/calendar+xml"))))))
-
-;; (define-method (max-resource-size (self <calendar-resource>))
-;;   )
-
-;; (define-method (min-date-time ))
-;; (define-method (max-date-time ))
-;; (define-method (max-instances ))
-;; (define-method (max-attendees-per-instance ))
-
-(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)
-    ;; (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)
-    ))
 
 
diff --git a/module/calp/webdav/resource/calendar/collection.scm b/module/calp/webdav/resource/calendar/collection.scm
new file mode 100644
index 00000000..9acb6701
--- /dev/null
+++ b/module/calp/webdav/resource/calendar/collection.scm
@@ -0,0 +1,298 @@
+(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 make-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>)
+  (description init-value: #f
+               accessor: description)
+  (data-store getter: data-store
+              init-keyword: store:)
+  #;
+  (content% init-value: (make-vcomponent 'VIRTUAL)
+            accessor: content%))
+
+
+(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)
+  (make-vcomponent 'VTIMEZONE)
+  )
+
+
+
+(define-method (live-properties (self <calendar-collection-resource>))
+  (append (next-method)
+          (map (lambda (pair) (cons (xml caldav (car pair)) (cdr pair)))
+               caldav-properties)))
+
+
+
+
+(define-method (displayname (self <calendar-collection-resource>))
+  (propstat 200
+            `((,(xml webdav 'displayname)
+               ,(prop (content self) 'displayname)))))
+
+
+(define-method (resourcetype (self <calendar-collection-resource>))
+  (propstat 200
+   `((,(xml webdav 'resourcetype)
+      (,(xml caldav 'calendar))))))
+
+;;; CALDAV Properties
+
+(define-method (calendar-description (self <calendar-collection-resource>))
+  (cond ((description self)
+         => (lambda (it)
+              (propstat 200
+                        (list (list (xml caldav 'calendar-description (alist->hashq-table '((xml:lang . "en"))))
+                                    it)))))
+        (else
+         (propstat 404 (list (list (xml caldav 'calendar-description)))))))
+
+(define-method (calendar-timezone (self <calendar-collection-resource>))
+  (propstat 200
+            (list
+             (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
+            `((,(xml caldav 'supported-calendar-component-set)
+               (,(xml caldav 'comp
+                      (alist->hashq-table '((name . "VEVENT")))))))))
+
+(define-method (supported-calendar-data (self <calendar-collection-resource>))
+  (propstat 200
+   (list
+    (list
+     (xml caldav 'supported-calendar-data)
+     (map (lambda (content-type)
+            (list (xml caldav 'calendar-data
+                       (alist->hashq-table
+                        '((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
+           (cons (xml webdav 'expand-property) expand-property)
+           ;; REQUIRED by CalDAV
+           (cons (xml caldav 'calendar-query) calendar-query)
+           (cons (xml caldav 'calendar-multiget) calendar-multiget)
+           (cons (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)))
+      `(,(xml webdav 'multistatus)
+        ,@(for (href . resource) in resources
+               `(,(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 list 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-element (xml webdav 'allprop)  (cdr body)))
+        (propname (find-element (xml webdav 'propname) (cdr body)))
+        (prop     (find-element (xml webdav 'prop)     (cdr body)))
+        (hrefs    (find-elements (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))))))
+      `(,(xml webdav 'multistatus)
+        (for (href . resource) in resources
+             `(,(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 list car)
+                                           (append
+                                            (dead-properties resource)
+                                            (live-properties resource))))))
+                              (prop
+                               (propfind-selected-properties
+                                resource
+                                (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))))
diff --git a/module/calp/webdav/resource/calendar/object.scm b/module/calp/webdav/resource/calendar/object.scm
new file mode 100644
index 00000000..82a8c18e
--- /dev/null
+++ b/module/calp/webdav/resource/calendar/object.scm
@@ -0,0 +1,76 @@
+(define-module (calp webdav resource calendar object)
+  :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 ((vcomponent formats ical) :prefix #{ics:}#)
+  :use-module ((vcomponent formats xcal) :prefix #{xcs:}#)
+  :use-module ((vcomponent) :prefix vcs-)
+  :use-module ((calp namespaces) :select (webdav))
+  :use-module (calp webdav property)
+  :use-module (sxml namespaced)
+
+  :export (<calendar-object-resource>
+           calendar-object-resource?
+           component)
+  )
+
+;;; content%
+
+(define-class <calendar-object-resource> (<resource>)
+  (component getter: component
+             init-keyword: component:))
+
+
+
+(define-method (is-collection? (_ <calendar-object-resource>))
+  #f)
+
+
+
+(define-method (children (_ <calendar-object-resource>))
+  '())
+
+(define (calendar-object-resource? x)
+ (is-a? x <calendar-object-resource>))
+
+(define-method (content (self <calendar-object-resource>) content-type)
+  (case content-type
+    ((text/calendar)
+     (call-with-output-string (lambda (port) (ics:serialize (content% self) port))))
+    ((application/calendar+xml)
+     (call-with-output-string (lambda (port) (xcs:serialize (content% self) port))))
+    ;; ((text/html))
+    ;; ((application/xhtml+xml))
+    ;; ((application/calendar+json))
+    (else (content self 'text/calendar))
+    )
+  )
+
+(define-method (creationdate (self <calendar-object-resource>))
+  (propstat 200
+            `((,(xml webdav 'creationdate)
+               (-> (content self)
+                   (prop 'CREATED)
+                   ;; TODO timezone
+                   (datetime->string "~Y-~m-~dT~H:~M:~SZ"))))))
+
+
+(define-method (getcontentlength (self <calendar-object-resource>))
+  ;; TODO which representation should be choosen to calculate length?
+  (propstat 501 `((,(xml webdav 'getcontentlength)))))
+
+
+
+(define-method (getcontenttyype (self <calendar-object-resource>))
+  ;; TODO different representations
+  (propstat 200 `((,(xml webdav 'getcontentlength)
+                   "text/calendar"))))
+
+
+(define-method (getlastmodified (self <calendar-object-resource>))
+  (propstat 200
+            `((,(xml webdav 'getlastmodified)
+               (string->datetime (prop (content self) 'LAST-MODIFIED)
+                                 "~Y~m~dT~H~M~S")))))