diff options
| -rw-r--r-- | module/calp/webdav/resource/calendar.scm | 130 | ||||
| -rw-r--r-- | module/calp/webdav/resource/calendar/collection.scm | 298 | ||||
| -rw-r--r-- | module/calp/webdav/resource/calendar/object.scm | 76 |
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"))))) |