diff options
Diffstat (limited to 'module/calp/webdav/resource/calendar/collection.scm')
| -rw-r--r-- | module/calp/webdav/resource/calendar/collection.scm | 295 |
1 files changed, 295 insertions, 0 deletions
diff --git a/module/calp/webdav/resource/calendar/collection.scm b/module/calp/webdav/resource/calendar/collection.scm new file mode 100644 index 00000000..e1bf73fd --- /dev/null +++ b/module/calp/webdav/resource/calendar/collection.scm @@ -0,0 +1,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>) + (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) (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)))) |