diff options
Diffstat (limited to 'module/calp/webdav/resource')
| -rw-r--r-- | module/calp/webdav/resource/base.scm | 163 | ||||
| -rw-r--r-- | module/calp/webdav/resource/calendar/collection.scm | 154 | ||||
| -rw-r--r-- | module/calp/webdav/resource/calendar/object.scm | 1 | ||||
| -rw-r--r-- | module/calp/webdav/resource/file.scm | 6 | ||||
| -rw-r--r-- | module/calp/webdav/resource/virtual.scm | 22 |
5 files changed, 192 insertions, 154 deletions
diff --git a/module/calp/webdav/resource/base.scm b/module/calp/webdav/resource/base.scm index 500aef90..d817342e 100644 --- a/module/calp/webdav/resource/base.scm +++ b/module/calp/webdav/resource/base.scm @@ -9,6 +9,8 @@ :use-module (calp webdav property) :use-module (calp namespaces) :use-module ((hnh util) :select (unless)) + :use-module (hnh util type) + :use-module (hnh util object) :use-module (rnrs bytevectors) :use-module (hnh util) :use-module (hnh util env) @@ -99,16 +101,16 @@ )) -(define-record-type <live-property> - (make-live-property% getter setter-generator remover-generator) - live-property? - (getter property-getter) - (setter-generator property-setter-generator) - (remover-generator property-remover-generator)) +(define-type (live-property) + (property-getter keyword: getter type: procedure?) + (property-setter-generator keyword: setter type: procedure?) + (property-remover-generator keyword: remover type: (or false? procedure?))) -(define* (make-live-property getter setter-generator optional: remover-generator) - (make-live-property% getter setter-generator remover-generator)) +(define* (make-live-property getter setter-generator optional: remover-generator) + (live-property getter: getter + setter: setter-generator + remover: remover-generator)) ;; Collections are also resources, this is non-collection resources @@ -124,8 +126,9 @@ (dead-properties ;; Map from (namespace . tagname) pairs to namespaced xml element - init-form: (make-hash-table) - getter: dead-properties%) + ;; init-form: (make-hash-table) + init-form: '() + accessor: dead-properties%) ;; Attributes on data (displayname accessor: displayname* init-value: #f) @@ -139,20 +142,38 @@ (resource-cache init-value: (make-hash-table 0) getter: resource-cache)) + +(define-method (initialize (self <resource>) args) + (next-method) + ;; TODO (name self) when name is unbound gives a really weird error + (typecheck (name self) string? "<resource>.name") + (typecheck (displayname* self) (or false? string?) "<resource>.displayname") + (typecheck (contentlanguage self) (or false? string?) "<resource>.contentlanguage") + ;; (typecheck (dead-properties self) (list-of xml-element?) "<resource>.dead-properties") + ;; (typecheck (resource-children self) ...) + ) + (define (resource? x) (is-a? x <resource>)) (define (href->string href) + (typecheck href (list-of string?)) + (if (null? href) "/" (string-join href "/" 'prefix))) (define (string->href s) + (typecheck s string?) + (remove string-null? (string-split s #\/))) ;; parent must be the head of child, elements in child after that is "free range" (define (href-relative parent child) + (typecheck parent (list-of string?)) + (typecheck child (list-of string?)) + (cond ((null? parent) child) ((null? child) (scm-error 'misc-error "href-relative" "Not a sub-href" '() #f)) ((equal? (car parent) (car child)) @@ -169,7 +190,7 @@ '() #f)) (define-method (set-content! (self <resource>) content) - (throw 'msic-error "set-content!<resource>" + (throw 'misc-error "set-content!<resource>" "Base <resource> doesn't implement (setting) content, please override this method" '() #f)) @@ -292,7 +313,10 @@ ;;; All get-*-property methods return propstat elements (define (lookup-live-property resource xml-el) - (assoc-ref (live-properties resource) (xml-element-hash-key xml-el))) + (typecheck resource resource?) + (typecheck xml-el xml-element?) + + (assoc-ref (live-properties resource) xml-el)) ;;; TODO should {get,set}{,-{dead,live}}-property really be methods? ;;; - Live properties are defined by lookup-live-property, which isn't a @@ -302,42 +326,43 @@ ;;; - The combined should always just dispatch to either one (define-method (get-live-property (resource <resource>) xml-el) + (typecheck xml-el xml-element?) + (cond ((lookup-live-property resource xml-el) - => (lambda (pair) ((property-getter pair) resource))) - (else (propstat 404 (list (list xml-el)))))) + => (lambda (prop) ((property-getter prop) resource))) + (else (propstat 404 (list xml-el))))) (define-method (get-dead-property (resource <resource>) xml-el) - (cond ((hash-ref (dead-properties% resource) - (xml-element-hash-key xml-el)) + (typecheck xml-el xml-element?) + + (cond ((find-child xml-el (dead-properties% resource)) => (lambda (it) (propstat 200 (list it)))) - (else (propstat 404 (list (list xml-el)))))) + (else (propstat 404 (list xml-el))))) -;;; Return a list xml tags (including containing list) +;;; Return a list of xml elements, where each entry is a property (define-method (dead-properties (resource <resource>)) - (hash-map->list (lambda (_ v) v) - (dead-properties% resource))) + (dead-properties% resource)) -;; Value should be a list with an <xml-element> in it's car (define-method (set-dead-property (resource <resource>) value) - (unless (and (list? value) - (xml-element? (car value))) - (scm-error 'misc-error "set-dead-property" - "Invalid value, expected namespaced sxml" - '() #f)) + (typecheck value xml-element?) (lambda () - (hash-set! (dead-properties% resource) - (xml-element-hash-key (car value)) - value))) + (set! (dead-properties% resource) + ;; TODO replace this with lens + (let loop ((rem (dead-properties% resource))) + (cond ((null? rem) + ;; Append + (list value)) + ((equal? (xml-element-hash-key value) + (xml-element-hash-key (car rem))) + ;; Replace + (cons value (cdr rem))) + (else (loop (cdr rem)))))))) (define-method (set-live-property (resource <resource>) value) - (unless (and (list? value) - (xml-element? (car value))) - (scm-error 'misc-error "set-live-property" - "Invalid value, expected namespaced sxml" - '() #f)) + (typecheck value xml-element?) (cond ((lookup-live-property resource (car value)) => (lambda (prop) (apply (property-setter-generator prop) - resource (cdr value)))) + resource (xml-element-children value)))) (else #f))) (define (set-dead-property! resource value) @@ -358,19 +383,16 @@ ;;; But allows remove-* to have the same signature as set-* (define-method (remove-dead-property (resource <resource>) xml-tag) - (unless (xml-element? xml-tag) - (scm-error 'misc-error "remove-dead-property" - "Bad property element" - '() #f)) + (typecheck xml-tag xml-element?) (lambda () - (hash-remove! (dead-properties% resource) - (xml-element-hash-key xml-tag)))) + (set! (dead-properties% resource) + (remove (lambda (el) + (equal? (xml-element-hash-key el) + (xml-element-hash-key xml-tag))) + (dead-properties% resource))))) (define-method (remove-live-property (resource <resource>) xml-tag) - (unless (xml-element? xml-tag) - (scm-error 'misc-error "remove-live-property" - "Bad property element" - '() #f)) + (typecheck xml-tag xml-element?) (cond ((lookup-live-property resource xml-tag) => (lambda (prop) @@ -396,11 +418,13 @@ ;; xml-tag should be just the tag element, without a surounding list (define-method (get-property (resource <resource>) xml-tag) + (typecheck xml-tag xml-element?) + (cond ((get-dead-property resource xml-tag) propstat-200? => identity) (else (get-live-property resource xml-tag)))) -;; Return an alist from xml-element tags (but not full elements with surrounding list) +;; Return an alist from xml-element objects without children, ;; to generic procedures returning that value. ;; SHOULD be extended by children, which append their result to this result ;; @example @@ -409,7 +433,8 @@ ;; specific-resource-properties)) ;; @end example (define-method (live-properties (self <resource>)) - (map (lambda (pair) (cons (xml-element-hash-key (xml webdav (car pair))) (cdr pair))) + (map (lambda (pair) (cons ((xml webdav (car pair))) + (cdr pair))) webdav-properties)) (define-method (setup-new-resource! (this <resource>) (parent <resource>)) @@ -463,7 +488,7 @@ (define-method (creationdate (self <resource>)) - (propstat 501 `((,(xml webdav 'creationdate))))) + (propstat 501 (list ((xml webdav 'creationdate))))) (define-method (set-creationdate! (self <resource>) _) (throw 'protected-resource "creationdate")) @@ -471,74 +496,74 @@ (define-method (displayname (self <resource>)) (cond ((displayname* self) => (lambda (name) - (propstat 200 `((,(xml webdav 'displayname) - ,name))))) + (propstat 200 (list ((xml webdav 'displayname) + name))))) (else - (propstat 404 `((,(xml webdav 'displayname))))))) + (propstat 404 (list ((xml webdav 'displayname))))))) (define-method (set-displayname! (self <resource>) value) (lambda () (set! (displayname* self) value))) (define-method (getcontentlanguage (self <resource>)) (cond ((contentlanguage self) - => (lambda (lang) (propstat 200 `((,(xml webdav 'getcontentlanguage) ,lang))))) - (else (propstat 404 `((,(xml webdav 'getcontentlanguage))))))) + => (lambda (lang) (propstat 200 (list ((xml webdav 'getcontentlanguage) lang))))) + (else (propstat 404 (list ((xml webdav 'getcontentlanguage))))))) (define-method (set-getcontentlanguage! (self <resource>) value) (lambda () (set! (contentlanguage self) value))) (define-method (getcontentlength (self <resource>)) - (propstat 501 `((,(xml webdav 'getcontentlength))))) + (propstat 501 (list ((xml webdav 'getcontentlength))))) (define-method (getcontentlength (self <resource>)) (propstat 200 (list - (list (xml webdav 'getcontentlength) - (content-length self))))) + ((xml webdav 'getcontentlength) + (number->string + (content-length self)))))) (define-method (set-getcontentlength! (self <resource>) _) (throw 'protected-resource "getcontentlength")) (define-method (getcontenttype (self <resource>)) - (propstat 501 `((,(xml webdav 'getcontenttype))))) + (propstat 501 (list ((xml webdav 'getcontenttype))))) (define-method (set-getcontenttype! (self <resource>) _) (throw 'protected-resource "getcontenttype")) (define-method (getetag (self <resource>)) ;; TODO - (propstat 501 `((,(xml webdav 'getetag))))) + (propstat 501 (list ((xml webdav 'getetag))))) (define-method (set-getetag! (self <resource>) _) (throw 'protected-resource "getetag")) (define-method (getlastmodified (self <resource>)) - (propstat 200 `((,(xml webdav 'getlastmodified) - ,(with-locale1 - LC_TIME "C" - (lambda () - (datetime->string (unix-time->datetime 0) "~a, ~d ~b ~Y ~H:~M:~S GMT"))))))) + (propstat 200 (list ((xml webdav 'getlastmodified) + (with-locale1 + LC_TIME "C" + (lambda () + (datetime->string (unix-time->datetime 0) "~a, ~d ~b ~Y ~H:~M:~S GMT"))))))) (define-method (set-getlastmodified! (self <resource>) _) (throw 'protected-resource "getlastmodified")) (define-method (lockdiscovery (self <resource>)) - (propstat 200 `((,(xml webdav 'lockdiscovery) - ())))) + (propstat 200 (list ((xml webdav 'lockdiscovery))))) (define-method (set-lockdiscovery! (self <resource>) _) (throw 'protected-resource "lockdiscovery")) (define-method (resourcetype (self <resource>)) - (propstat 200 `((,(xml webdav 'resourcetype) - ,@(when (is-collection? self) - `((,(xml webdav 'collection)))))))) + (propstat 200 (list (apply (xml webdav 'resourcetype) + (when (is-collection? self) + (list ((xml webdav 'collection)))))))) (define-method (set-resourcetype! (self <resource>) _) (throw 'protected-resource "resourcetype")) (define-method (supportedlock (self <resource>)) - (propstat 200 `((,(xml webdav 'supportedlock) ())))) + (propstat 200 (list ((xml webdav 'supportedlock))))) (define-method (set-supportedlock! (self <resource>) _) (throw 'protected-resource "supportedlock")) diff --git a/module/calp/webdav/resource/calendar/collection.scm b/module/calp/webdav/resource/calendar/collection.scm index e1bf73fd..95e3d923 100644 --- a/module/calp/webdav/resource/calendar/collection.scm +++ b/module/calp/webdav/resource/calendar/collection.scm @@ -30,6 +30,7 @@ ;;; Resoruces containing calendar components (define-class <calendar-collection-resource> (<resource>) + ;; TODO typecheck (description init-value: #f accessor: description) (data-store getter: data-store @@ -61,7 +62,7 @@ (define-method (live-properties (self <calendar-collection-resource>)) (append (next-method) - (map (lambda (pair) (cons (xml caldav (car pair)) (cdr pair))) + (map (lambda (pair) ((xml caldav (car pair)) (cdr pair))) caldav-properties))) @@ -69,14 +70,14 @@ (define-method (displayname (self <calendar-collection-resource>)) (propstat 200 - `((,(xml webdav 'displayname) - ,(prop (content self) 'displayname))))) + (list ((xml webdav 'displayname) + (prop (content self) 'displayname))))) (define-method (resourcetype (self <calendar-collection-resource>)) (propstat 200 - `((,(xml webdav 'resourcetype) - (,(xml caldav 'calendar)))))) + (list ((xml webdav 'resourcetype) + ((xml caldav 'calendar)))))) ;;; CALDAV Properties @@ -84,35 +85,33 @@ (cond ((description self) => (lambda (it) (propstat 200 - (list (list (xml caldav 'calendar-description (alist->hashq-table '((xml:lang . "en")))) - it))))) + (list ((xml caldav 'calendar-description '((xml:lang "en"))) + it))))) (else - (propstat 404 (list (list (xml caldav 'calendar-description))))))) + (propstat 404 (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))))))) + ((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"))))))))) + (list ((xml caldav 'supported-calendar-component-set) + ((xml caldav 'comp + '((name "VEVENT")))))))) (define-method (supported-calendar-data (self <calendar-collection-resource>)) (propstat 200 (list - (list - (xml caldav 'supported-calendar-data) + ((xml caldav 'supported-calendar-data) (map (lambda (content-type) - (list (xml caldav 'calendar-data - (alist->hashq-table - '((content-type . ,content-type) - (version . "2.0")))))) + ((xml caldav 'calendar-data + '((content-type ,content-type) + (version "2.0"))))) '("text/calendar" "application/calendar+xml")))))) @@ -128,13 +127,13 @@ (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")))))) + (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")))))) @@ -159,11 +158,11 @@ ;; 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) + ((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) + ((xml caldav 'calendar-query) calendar-query) + ((xml caldav 'calendar-multiget) calendar-multiget) + ((xml caldav 'free-busy-report) free-busy-report) ))) @@ -196,24 +195,24 @@ ))) (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))))))))))) + (apply (xml webdav 'multistatus) + (for (href . resource) in resources + (apply (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 (lambda (x) ((xml x))) car) + (append (dead-properties resource) + (live-properties resource)))))) + (prop + (map (lambda (prop) (get-property resource prop)) + prop))))))))))) @@ -224,10 +223,10 @@ (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)))) + (let ((allprop (find-children ((xml webdav 'allprop)) (cdr body))) + (propname (find-children ((xml webdav 'propname)) (cdr body))) + (prop (find-children ((xml webdav 'prop)) (cdr body))) + (hrefs (find-children ((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) @@ -241,29 +240,30 @@ (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)))))))))) + (apply (xml webdav 'multistatus) + (for (href . resource) in resources + (apply (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 (lambda (x) ((xml x))) car) + (append + (dead-properties resource) + (live-properties resource)))))) + (prop + (propfind-selected-properties + resource + ;; TODO??? + (map car (cdr prop)))))) + (else + ((xml webdav 'status) + (http-status-line 404)))))))))) diff --git a/module/calp/webdav/resource/calendar/object.scm b/module/calp/webdav/resource/calendar/object.scm index 82a8c18e..0f59ced7 100644 --- a/module/calp/webdav/resource/calendar/object.scm +++ b/module/calp/webdav/resource/calendar/object.scm @@ -19,6 +19,7 @@ ;;; content% (define-class <calendar-object-resource> (<resource>) + ;; TODO typecheck (component getter: component init-keyword: component:)) diff --git a/module/calp/webdav/resource/file.scm b/module/calp/webdav/resource/file.scm index e2fec9a5..0d85098c 100644 --- a/module/calp/webdav/resource/file.scm +++ b/module/calp/webdav/resource/file.scm @@ -4,6 +4,7 @@ :use-module (hnh util) :use-module (hnh util env) :use-module (hnh util path) + :use-module (hnh util type) :use-module (datetime) :use-module (ice-9 popen) :use-module (ice-9 rdelim) @@ -27,6 +28,11 @@ (root getter: root setter: set-root! init-value: "/" init-keyword: root:) (path getter: path setter: set-path! init-value: "/" init-keyword: path:)) +(define-method (initialize (self <file-resource>) args) + (next-method) + (typecheck (root self) string? "<file-resource>.root") + (typecheck (path self) string? "<file-resource>.path")) + (define-method (write (self <file-resource>) port) (display (format #f "#<<file-resource> name=~s, root=~s, path=~s>" diff --git a/module/calp/webdav/resource/virtual.scm b/module/calp/webdav/resource/virtual.scm index 42ffc123..047336c5 100644 --- a/module/calp/webdav/resource/virtual.scm +++ b/module/calp/webdav/resource/virtual.scm @@ -3,6 +3,7 @@ :use-module (datetime) :use-module (rnrs bytevectors) :use-module (hnh util) + :use-module (hnh util type) :use-module (sxml namespaced) :use-module (sxml namespaced util) :use-module (calp webdav resource) @@ -26,6 +27,11 @@ init-keyword: creation-time: getter: creation-time)) +(define-method (initialize (self <virtual-resource>) args) + (next-method) + (typecheck (content* self) bytevector? "<virtual-resource>.content*") + (typecheck (creation-time self) datetime? "<virtual-resource>.creation-time")) + (define (virtual-resource? x) (is-a? x <virtual-resource>)) @@ -38,7 +44,7 @@ (define-method (live-properties (self <virtual-resource>)) (append (next-method) - (list (cons (xml-element-hash-key (xml virtual-ns 'isvirtual)) + (list (cons ((xml virtual-ns 'isvirtual)) (make-live-property isvirtual set-isvirtual!))))) (define-method (content (self <virtual-resource>)) @@ -50,22 +56,22 @@ (define-method (creationdate (self <virtual-resource>)) (propstat 200 (list - (list (xml webdav 'creationdate) - (-> (creation-time self) - (datetime->string "~Y-~m-~dT~H:~M:~SZ")))))) + ((xml webdav 'creationdate) + (-> (creation-time self) + (datetime->string "~Y-~m-~dT~H:~M:~SZ")))))) (define-method (getcontenttype (self <resource>)) (propstat 200 (list - (list (xml webdav 'getcontenttype) - "application/binary")))) + ((xml webdav 'getcontenttype) + "application/binary")))) (define-method (isvirtual (self <virtual-resource>)) (propstat 200 (list - (list (xml virtual-ns 'isvirtual) - "true")))) + ((xml virtual-ns 'isvirtual) + "true")))) (define-method (set-isvirtual! (self <virtual-resource>) _) |