From 00a66eca0f32fcf585d2c21375641020e877e3ea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 13 Dec 2023 11:06:57 +0100 Subject: Update things depending on namespaced sxml. Update all code to emit correctly formed namespaced sxml objects, instead of the old list based approach. Also introduces a number of typechecks which in semi-related parts of the code. Note that the webdav-server test is currently broken. --- module/calp/server/webdav.scm | 48 +++--- module/calp/webdav/property.scm | 21 ++- module/calp/webdav/propfind.scm | 52 ++++--- module/calp/webdav/resource/base.scm | 163 ++++++++++++--------- .../calp/webdav/resource/calendar/collection.scm | 154 +++++++++---------- module/calp/webdav/resource/calendar/object.scm | 1 + module/calp/webdav/resource/file.scm | 6 + module/calp/webdav/resource/virtual.scm | 22 ++- module/hnh/util/table.scm | 1 + module/sxml/namespaced.scm | 44 +++--- module/sxml/namespaced/util.scm | 3 + module/vcomponent/formats/xcal.scm | 7 +- module/vcomponent/formats/xcal/output.scm | 94 ++++++------ module/vcomponent/formats/xcal/types.scm | 30 ++-- testrunner.scm | 7 +- tests/unit/sxml/sxml-namespaced.scm | 24 ++- tests/unit/webdav/webdav-file.scm | 1 + tests/unit/webdav/webdav-property.scm | 28 ++-- tests/unit/webdav/webdav-propfind.scm | 157 ++++++++++---------- tests/unit/webdav/webdav-resource.scm | 28 ++-- 20 files changed, 491 insertions(+), 400 deletions(-) diff --git a/module/calp/server/webdav.scm b/module/calp/server/webdav.scm index 3413f254..703e4783 100644 --- a/module/calp/server/webdav.scm +++ b/module/calp/server/webdav.scm @@ -219,15 +219,17 @@ ;; Body, if it exists, MUST have be a DAV::propfind object (define property-request - (cond ((string? body) - (xml->namespaced-sxml body)) - ((bytevector? body) - (-> body - (bytevector->string - (make-transcoder (utf-8-codec))) - xml->namespaced-sxml)) - (else `(,(xml webdav 'propfind) - (,(xml webdav 'allprop)))))) + (xml-document-root + (cond ((string? body) + (xml->namespaced-sxml body)) + ((bytevector? body) + (-> body + (bytevector->string + (make-transcoder (utf-8-codec))) + xml->namespaced-sxml)) + (else (xml-document + root: ((xml webdav 'propfind) + ((xml webdav 'allprop)))))))) (catch 'bad-request @@ -238,11 +240,12 @@ headers: '((content-type . (application/xml)))) (lambda (port) (namespaced-sxml->xml - `(,(xml webdav 'multistatus) - ,@(for (href . resource) in requested-resources - `(,(xml webdav 'response) - (,(xml webdav 'href) ,(href->string href)) - ,@(map propstat->namespaced-sxml + (apply + (xml webdav 'multistatus) + (for (href . resource) in requested-resources + (apply (xml webdav 'response) + ((xml webdav 'href) (href->string href)) + (map propstat->namespaced-sxml (parse-propfind (root-element/namespaced property-request) resource))))) namespaces: output-namespaces @@ -284,14 +287,15 @@ (else (throw 'body-required)))) (namespaced-sxml->xml - `(,(xml webdav 'multistatus) - (,(xml webdav 'response) - (,(xml webdav 'href) ,(href->string href)) - ,@(map propstat->namespaced-sxml - (parse-propertyupdate - (root-element request) - (map swap namespaces*) - resource)))) + ((xml webdav 'multistatus) + (apply + (xml webdav 'response) + ((xml webdav 'href) (href->string href)) + (map propstat->namespaced-sxml + (parse-propertyupdate + (root-element request) + (map swap namespaces*) + resource)))) port: port)))) (lambda (err proc fmt args data) (values (build-response diff --git a/module/calp/webdav/property.scm b/module/calp/webdav/property.scm index 4e235f81..3c919e2e 100644 --- a/module/calp/webdav/property.scm +++ b/module/calp/webdav/property.scm @@ -42,7 +42,7 @@ ;; @example ;; `((,(xml ns tag) "Content")) ;; @end example - propstat-property + (propstat-property type: (list-of xml-element?)) ;; See [WEBCAL] propstat XML element (propstat-error keyword: error) @@ -87,10 +87,15 @@ ;; `((d:responsedescription ,it))))) (define (propstat->namespaced-sxml propstat) - `(,(xml webdav 'propstat) - (,(xml webdav 'prop) ,@(propstat-property propstat)) - (,(xml webdav 'status) ,(http-status-line (propstat-status-code propstat))) - ,@(awhen (propstat-error propstat) - `((,(xml webdav 'error) ,it))) - ,@(awhen (propstat-response-description propstat) - `((,(xml webdav 'responsedescription) ,it))))) + (apply (xml webdav 'propstat) + (append + + (list + (apply (xml webdav 'prop) (propstat-property propstat)) + ((xml webdav 'status) (http-status-line (propstat-status-code propstat)))) + + (awhen (propstat-error propstat) + (list ((xml webdav 'error) it))) + + (awhen (propstat-response-description propstat) + (list ((xml webdav 'responsedescription) it)))))) diff --git a/module/calp/webdav/propfind.scm b/module/calp/webdav/propfind.scm index 83725825..f2aab8d4 100644 --- a/module/calp/webdav/propfind.scm +++ b/module/calp/webdav/propfind.scm @@ -1,10 +1,14 @@ (define-module (calp webdav propfind) :use-module (calp webdav property) :use-module (calp webdav resource) + :use-module ((calp webdav resource base) :select (resource?)) :use-module (calp namespaces) :use-module (srfi srfi-1) :use-module (sxml namespaced) :use-module (sxml namespaced util) + :use-module ((hnh util) :select (->)) + :use-module ((hnh util table) :select (table)) + :use-module (hnh util type) :export (propfind-selected-properties propfind-all-live-properties propfind-most-live-properties @@ -21,6 +25,8 @@ ;; return a list of propstat elements ;; work for both dead and alive objects (define (propfind-selected-properties resource properties) + (typecheck resource resource?) + (typecheck properties (list-of xml-element?)) (map (lambda (el) (get-property resource el)) properties)) @@ -31,18 +37,21 @@ ;; Returns a list of objects. (define (propfind-all-live-properties resource) - (map (lambda (p) ((cdr p) resource)) + (typecheck resource resource?) + (map (lambda (p) ((property-getter (cdr p)) resource)) (live-properties resource))) ;; Returns a list of objects. ;; The list being the live properties defined by [WEBDAV] (define (propfind-most-live-properties resource) + (typecheck resource resource?) (map (lambda (p) ((property-getter (cdr p)) resource)) webdav-properties)) ;; Returns a list of objects. ;; All "dead" properties on resource. (define (propfind-all-dead-properties resource) + (typecheck resource resource?) (map (lambda (v) (propstat 200 (list v))) (dead-properties resource))) @@ -50,24 +59,17 @@ -(define (find-element target list) - (define target* (xml-element-hash-key target)) - (find (lambda (x) (and (list? x) - (not (null? x)) - (xml-element? (car x)) - (equal? target* (xml-element-hash-key (car x))))) - list)) - ;; Takes a propfind xml element (tree), and a webdav resource object. ;; Returns a list of objects. (define (parse-propfind sxml resource) - ;; (assert (list? sxml)) - ;; (assert (not (null? sxml))) - ;; (assert eq? 'd:propfid (car sxml)) - (let ((propname (find-element (xml webdav 'propname) (cdr sxml))) - (allprop (find-element (xml webdav 'allprop) (cdr sxml))) - (include (find-element (xml webdav 'include) (cdr sxml))) - (prop (find-element (xml webdav 'prop) (cdr sxml)))) + (typecheck sxml xml-element?) + (typecheck resource resource?) + + (let ((propname (find-child ((xml webdav 'propname)) (xml-element-children sxml))) + (allprop (find-child ((xml webdav 'allprop)) (xml-element-children sxml))) + (include (find-child ((xml webdav 'include)) (xml-element-children sxml))) + (prop (find-child ((xml webdav 'prop)) (xml-element-children sxml)))) + (merge-propstats (cond ((and allprop include) ;; Return "all" properties + those noted by @@ -75,25 +77,29 @@ (propfind-all-dead-properties resource) (propfind-selected-properties resource - (map car (cdr include))))) + (xml-element-children include)))) + (allprop ;; Return "all" properties (append (propfind-most-live-properties resource) (propfind-all-dead-properties resource))) + (propname ;; Return the list of available properties + ;; each entry is an xml element, with no content (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)))))) + (append + (map (lambda (el) (-> el (children '()) (properties (table)))) + (dead-properties resource)) + (map car (live-properties resource)))))) + (prop ;; Return the properties listed (propfind-selected-properties resource - (map car (cdr prop)))) + (xml-element-children prop))) + (else (scm-error 'bad-request "parse-propfind" "Invalid search query ~s" (list sxml) (list sxml))))))) 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 - (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 ) args) + (next-method) + ;; TODO (name self) when name is unbound gives a really weird error + (typecheck (name self) string? ".name") + (typecheck (displayname* self) (or false? string?) ".displayname") + (typecheck (contentlanguage self) (or false? string?) ".contentlanguage") + ;; (typecheck (dead-properties self) (list-of xml-element?) ".dead-properties") + ;; (typecheck (resource-children self) ...) + ) + (define (resource? x) (is-a? x )) (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 ) content) - (throw 'msic-error "set-content!" + (throw 'misc-error "set-content!" "Base 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 ) 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 ) 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 )) - (hash-map->list (lambda (_ v) v) - (dead-properties% resource))) + (dead-properties% resource)) -;; Value should be a list with an in it's car (define-method (set-dead-property (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 ) 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 ) 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 ) 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 ) 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 )) - (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 ) (parent )) @@ -463,7 +488,7 @@ (define-method (creationdate (self )) - (propstat 501 `((,(xml webdav 'creationdate))))) + (propstat 501 (list ((xml webdav 'creationdate))))) (define-method (set-creationdate! (self ) _) (throw 'protected-resource "creationdate")) @@ -471,74 +496,74 @@ (define-method (displayname (self )) (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 ) value) (lambda () (set! (displayname* self) value))) (define-method (getcontentlanguage (self )) (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 ) value) (lambda () (set! (contentlanguage self) value))) (define-method (getcontentlength (self )) - (propstat 501 `((,(xml webdav 'getcontentlength))))) + (propstat 501 (list ((xml webdav 'getcontentlength))))) (define-method (getcontentlength (self )) (propstat 200 (list - (list (xml webdav 'getcontentlength) - (content-length self))))) + ((xml webdav 'getcontentlength) + (number->string + (content-length self)))))) (define-method (set-getcontentlength! (self ) _) (throw 'protected-resource "getcontentlength")) (define-method (getcontenttype (self )) - (propstat 501 `((,(xml webdav 'getcontenttype))))) + (propstat 501 (list ((xml webdav 'getcontenttype))))) (define-method (set-getcontenttype! (self ) _) (throw 'protected-resource "getcontenttype")) (define-method (getetag (self )) ;; TODO - (propstat 501 `((,(xml webdav 'getetag))))) + (propstat 501 (list ((xml webdav 'getetag))))) (define-method (set-getetag! (self ) _) (throw 'protected-resource "getetag")) (define-method (getlastmodified (self )) - (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 ) _) (throw 'protected-resource "getlastmodified")) (define-method (lockdiscovery (self )) - (propstat 200 `((,(xml webdav 'lockdiscovery) - ())))) + (propstat 200 (list ((xml webdav 'lockdiscovery))))) (define-method (set-lockdiscovery! (self ) _) (throw 'protected-resource "lockdiscovery")) (define-method (resourcetype (self )) - (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 ) _) (throw 'protected-resource "resourcetype")) (define-method (supportedlock (self )) - (propstat 200 `((,(xml webdav 'supportedlock) ())))) + (propstat 200 (list ((xml webdav 'supportedlock))))) (define-method (set-supportedlock! (self ) _) (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 () + ;; TODO typecheck (description init-value: #f accessor: description) (data-store getter: data-store @@ -61,7 +62,7 @@ (define-method (live-properties (self )) (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 )) (propstat 200 - `((,(xml webdav 'displayname) - ,(prop (content self) 'displayname))))) + (list ((xml webdav 'displayname) + (prop (content self) 'displayname))))) (define-method (resourcetype (self )) (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 )) (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 )) (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 )) (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 )) (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 ) 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 () + ;; 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 ) args) + (next-method) + (typecheck (root self) string? ".root") + (typecheck (path self) string? ".path")) + (define-method (write (self ) port) (display (format #f "#< 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 ) args) + (next-method) + (typecheck (content* self) bytevector? ".content*") + (typecheck (creation-time self) datetime? ".creation-time")) + (define (virtual-resource? x) (is-a? x )) @@ -38,7 +44,7 @@ (define-method (live-properties (self )) (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 )) @@ -50,22 +56,22 @@ (define-method (creationdate (self )) (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 )) (propstat 200 (list - (list (xml webdav 'getcontenttype) - "application/binary")))) + ((xml webdav 'getcontenttype) + "application/binary")))) (define-method (isvirtual (self )) (propstat 200 (list - (list (xml virtual-ns 'isvirtual) - "true")))) + ((xml virtual-ns 'isvirtual) + "true")))) (define-method (set-isvirtual! (self ) _) diff --git a/module/hnh/util/table.scm b/module/hnh/util/table.scm index 94d3c110..2c174448 100644 --- a/module/hnh/util/table.scm +++ b/module/hnh/util/table.scm @@ -51,6 +51,7 @@ (define-type (tree-terminal printer: (lambda (_ p) (write '(table) p)))) ;; Wrapped for better error messages +;;; TODO possibly only have one tree-terminal shared by everyone (define (make-tree) (tree-terminal)) (define (tree? x) diff --git a/module/sxml/namespaced.scm b/module/sxml/namespaced.scm index 1c2eb322..82a137c5 100644 --- a/module/sxml/namespaced.scm +++ b/module/sxml/namespaced.scm @@ -24,6 +24,7 @@ xml-element xml-element? + xml-element*? xml-element-tagname xml-element-namespace xml-element-attributes @@ -39,6 +40,7 @@ pi-body )) + (define (car+cadr p) (values (car p) (cadr p))) (define (2list->pair l) (call-with-values (lambda () (car+cadr l)) cons)) @@ -66,14 +68,16 @@ ns: ,(xml-element-namespace el) attributes: ,(serialize-table (xml-element-attributes el)) children: (list ,@(map (lambda (e) - (cond ((xml-element? e) + (cond ((xml-element*? e) (serialize-xml-element e)) (else e))) (xml-element-children el))))) -(define-type (xml-element printer: (lambda (r p) - (pretty-print (serialize-xml-element r) - p))) + +(define-type (xml-element + printer: (lambda (r p) + (pretty-print (serialize-xml-element r) + p))) (xml-element-tagname type: symbol? keyword: tag) (xml-element-namespace type: (or false? symbol?) @@ -91,8 +95,15 @@ default: '())) +;;; NOTE Due to how define-type works, and how guile expands forms, +;;; this MUST be placed after the xml-element declaration. Otherwise +;;; `xml-element?' is of type syntax-transformer, which isn't a procedure. +(define (xml-element*? x) + (xml-element? x)) + + (define-type (xml-document) - (xml-document-root type: xml-element? + (xml-document-root type: xml-element*? keyword: root) (xml-document-pis type: (list-of pi-element?) keyword: pi @@ -104,7 +115,7 @@ ((tag) (lambda children (xml-element children: children tag: tag))) ((ns tag) (lambda children (xml-element children: children tag: tag ns: ns))) ((ns tag attrs) (lambda children (xml-element children: children tag: tag ns: ns - attributes: (attributes->table attrs)))))) + attributes: (attributes->table attrs)))))) (define (attribute xml attr) (assoc-ref (xml-element-attributes xml) attr)) @@ -162,7 +173,7 @@ (lambda (elem-gi attributes namespaces parent-seed seed) (let ((head tail (pop seed))) (modify tail - (find* xml-element?) + (find* xml-element*?) (lambda (parent) (add-child (modify head xml-element-children* reverse) @@ -174,9 +185,9 @@ (if trim-whitespace? (string-trim-both (string-append s1 s2)) (string-append s1 s2))) - (if (null? s) + (if (string-null? s) seed - (modify seed (lens-compose (find* xml-element?) + (modify seed (lens-compose (find* xml-element*?) xml-element-children*) (lambda (ch) (cons s ch))))) @@ -185,7 +196,7 @@ ((*DEFAULT* . (lambda (port pi-tag seed) (let ((body (ssax:read-pi-body-as-string port))) (modify seed - (find* xml-element?) + (find* xml-element*?) (lambda (parent) (add-child (pi-element pi-tag body) parent))))))))) @@ -196,11 +207,11 @@ (with-ssax-error-to-port (current-error-port) (lambda () ((parser trim-whitespace?: trim-whitespace?) - (->port port-or-string) - (list ((xml 'ROOT))))))) + (->port port-or-string) + (list ((xml 'ROOT))))))) (let ((roots pis - (partition xml-element? + (partition xml-element*? (-> result peek xml-element-children)))) (xml-document root: (car roots) @@ -277,13 +288,13 @@ (define (namespaced-sxml->sxml* tree) (cond ((string? tree) (return tree)) - ((xml-element? tree) (xml-element->sxml tree)) + ((xml-element*? tree) (xml-element->sxml tree)) ((pi-element? tree) (return (pi-element->sxml tree))) ((xml-document? tree) (do pis <- (sequence (map namespaced-sxml->sxml* (xml-document-pis tree))) el <- (namespaced-sxml->sxml* - (xml-document-root tree)) + (xml-document-root tree)) (return `(*TOP* ,@pis ,el)))) (else (scm-error 'misc-error "namespaced-sxml->sxml*" "Unexpected token in tree: ~s" @@ -326,7 +337,7 @@ (('*TOP* rest ...) (let ((groups (group-by (lambda (x) - (cond ((xml-element? x) 'el) + (cond ((xml-element*? x) 'el) ((pi-element? x) 'pi) (else #f))) (map (lambda (r) (sxml->namespaced-sxml r namespaces)) @@ -362,4 +373,3 @@ ;;; TODO Figure out how to still use (sxml match) and (sxml xpath) with these ;;; new trees (probably rewriting to a "regular" sxml tree, and keeping ;;; a strict mapping of namespaces) - diff --git a/module/sxml/namespaced/util.scm b/module/sxml/namespaced/util.scm index 9a4e72d7..e60254b7 100644 --- a/module/sxml/namespaced/util.scm +++ b/module/sxml/namespaced/util.scm @@ -2,6 +2,7 @@ :use-module (sxml namespaced) :use-module (srfi srfi-1) :use-module ((ice-9 control) :select (call/ec)) + :use-module (hnh util type) :export (xml-element-hash-key find-child element-matches? @@ -14,6 +15,8 @@ (xml-element-tagname tag))) (define (find-child target list) + (typecheck target xml-element?) + (typecheck list (list-of (or xml-element? string?))) (define target* (xml-element-hash-key target)) (find (lambda (x) (and (xml-element? x) (equal? target* (xml-element-hash-key x)))) diff --git a/module/vcomponent/formats/xcal.scm b/module/vcomponent/formats/xcal.scm index 8fadde75..a0c8620d 100644 --- a/module/vcomponent/formats/xcal.scm +++ b/module/vcomponent/formats/xcal.scm @@ -23,6 +23,9 @@ (define* (deserialize port) (-> port xml->namespaced-sxml - root-element ; Strip potential *TOP* - cadr ; Remove containing icalendar + xml-document-root + + ;; Remove containing icalendar + xml-element-children car + sxcal->vcomponent)) diff --git a/module/vcomponent/formats/xcal/output.scm b/module/vcomponent/formats/xcal/output.scm index a5f8a934..f0c11a4e 100644 --- a/module/vcomponent/formats/xcal/output.scm +++ b/module/vcomponent/formats/xcal/output.scm @@ -59,9 +59,10 @@ [(memv k '(GEO)) (lambda (_ v) - `(,(xml xcal 'geo) - (latitude ,(geo-latitude v)) - (longitude ,(geo-longitude v))))] + ((xml xcal 'geo) + (list + ((xml xcal 'latitude) (geo-latitude v)) + ((xml xcal 'longitude) (geo-longitude v)))))] [(memv k '(RRULE)) (get-writer 'RECUR)] @@ -84,60 +85,59 @@ (if (or (eq? tag 'VALUE) (internal-field? tag)) #f - `(,(xml xcal (downcase-symbol tag)) - ,@(map (lambda (v) - ;; TODO parameter types!!!! (rfc6321 3.5.) - `(,(xml xcal 'text) ,(->string v))) - value)))) + (apply (xml xcal (downcase-symbol tag)) + (map (lambda (v) + ;; TODO parameter types!!!! (rfc6321 3.5.) + ((xml xcal 'text) (->string v))) + value)))) -;; ((key value ...) ...) -> `(parameters , ... ) +;; ((key value ...) ...) -> # (define (parameters-tag parameters) (define outparams (filter-map (lambda (x) (property->value-tag x)) parameters)) - (unless (null? outparams) - `(,(xml xcal 'parameters) ,@outparams))) + (apply (xml xcal 'parameters) outparams)) (define (vcomponent->sxcal component) (define tagsymb (downcase-symbol (type component))) - (remove null? - `(,(xml xcal tagsymb) - ;; only have when it's non-empty. - ,(let ((props - (filter-map - (match-lambda - [(? (compose internal-field? car)) #f] - - [(key (vlines ...)) - (remove null? - `(,(xml xcal (downcase-symbol key)) - ,(parameters-tag (reduce assq-merge - '() - (map parameters vlines))) - ,@(for vline in vlines - (vline->value-tag vline))))] - - [(key vline) - (remove null? - `(,(xml xcal (downcase-symbol key)) - ,(parameters-tag (parameters vline)) - ,(vline->value-tag vline)))]) - ;; NOTE this sort is unnecesasary, but here so tests can work - ;; Possibly add it as a flag instead - (sort* (properties component) - string< (compose symbol->string car))))) - (unless (null? props) - `(,(xml xcal 'properties) - ;; NOTE - ;; (x-hnh-calendar-name (text ,(prop (parent component) 'NAME))) - ,@props))) - ,(unless (null? (children component)) - `(,(xml xcal 'components) - ,@(map vcomponent->sxcal (children component))))))) + (apply (xml xcal tagsymb) + (remove (compose null? xml-element-children) + ;; only have when it's non-empty. + (list + (let ((props + (filter-map + (match-lambda + [(? (compose internal-field? car)) #f] + + [(key (vlines ...)) + (apply (xml xcal (downcase-symbol key)) + (remove (compose null? xml-element-children) + (cons + (parameters-tag (reduce assq-merge + '() + (map parameters vlines))) + (map vline->value-tag vlines))))] + + [(key vline) + (apply (xml xcal (downcase-symbol key)) + (remove (compose null? xml-element-children) + (list + (parameters-tag (parameters vline)) + (vline->value-tag vline))))]) + ;; NOTE this sort is unnecesasary, but here so tests can work + ;; Possibly add it as a flag instead + (sort* (properties component) + string< (compose symbol->string car))))) + (apply (xml xcal 'properties) + ;; NOTE + ;; (x-hnh-calendar-name (text ,(prop (parent component) 'NAME))) + props)) + (apply (xml xcal 'components) + (map vcomponent->sxcal (children component))))))) (define (ns-wrap sxml) - `(,(xml xcal 'icalendar) - ,sxml)) + ((xml xcal 'icalendar) + sxml)) diff --git a/module/vcomponent/formats/xcal/types.scm b/module/vcomponent/formats/xcal/types.scm index 812f1d20..b9b8239d 100644 --- a/module/vcomponent/formats/xcal/types.scm +++ b/module/vcomponent/formats/xcal/types.scm @@ -9,32 +9,33 @@ :export (get-writer)) (define (write-boolean _ v) - `(,(xml xcal 'boolean) ,(if v "true" "false"))) + ((xml xcal 'boolean) (if v "true" "false"))) (define (write-date _ v) - `(,(xml xcal 'date) ,(date->string v "~Y-~m-~d"))) + ((xml xcal 'date) (date->string v "~Y-~m-~d"))) (define (write-datetime p v) - `(,(xml xcal 'date-time) - ,(datetime->string - (table-get p '-X-HNH-ORIGINAL v) - ;; 'Z' should be included for UTC, - ;; other timezones MUST be specified - ;; in the TZID parameter. - "~Y-~m-~dT~H:~M:~S~Z"))) + ((xml xcal 'date-time) + (datetime->string + (table-get p '-X-HNH-ORIGINAL v) + ;; 'Z' should be included for UTC, + ;; other timezones MUST be specified + ;; in the TZID parameter. + "~Y-~m-~dT~H:~M:~S~Z"))) (define (write-time _ v) - `(,(xml xcal 'time) ,(time->string v "~H:~M:S"))) + ((xml xcal 'time) (time->string v "~H:~M:S"))) (define (write-recur _ v) - `(,(xml xcal 'recur) ,@((@@ (vcomponent recurrence internal) recur-rule->rrule-sxml) v))) + (apply (xml xcal 'recur) + ((@@ (vcomponent recurrence internal) recur-rule->rrule-sxml) v))) ;; sepparate since this text shouldn't be escaped (define (write-text _ v) ;; TODO out type should be xsd:string. ;; Look into what that means, and escape ;; from there - `(,(xml xcal 'text) ,v)) + ((xml xcal 'text) v)) @@ -43,8 +44,9 @@ #| TODO PERIOD |# URI UTC-OFFSET) (hashq-set! sxml-writers simple-type (lambda (p v) - `(,(xml xcal (downcase-symbol simple-type)) - ,(((@ (vcomponent formats ical types) get-writer) simple-type) p v))))) + ((xml xcal (downcase-symbol simple-type)) + (((@ (vcomponent formats ical types) get-writer) simple-type) + p v))))) (hashq-set! sxml-writers 'BOOLEAN write-boolean) (hashq-set! sxml-writers 'DATE write-date) diff --git a/testrunner.scm b/testrunner.scm index 8abea1e2..a757fdee 100755 --- a/testrunner.scm +++ b/testrunner.scm @@ -183,7 +183,12 @@ exec "$GUILE" --debug --no-auto-compile -e main -s "$0" "$@" (lambda args (enqueue! (format-test-runner-crash-message args) error-queue) - (values #f '())))) + (values #f '())) + (lambda _ + ;; TODO make backtrace configurable + ;; TODO backtrace should be placed AFTER the error + (enqueue! (with-output-to-string (lambda () (backtrace))) error-queue) + ))) (catch 'wrong-type-arg (lambda () (typecheck module-names (list-of (list-of symbol?)))) (lambda (_ __ fmt args ___) diff --git a/tests/unit/sxml/sxml-namespaced.scm b/tests/unit/sxml/sxml-namespaced.scm index 18e35225..ee1407d6 100644 --- a/tests/unit/sxml/sxml-namespaced.scm +++ b/tests/unit/sxml/sxml-namespaced.scm @@ -42,6 +42,18 @@ ;;; TODO Attributes ;;; TODO children +(test-group "Constructing XML documents" + (test-assert "With simple content" + ((xml 'a) "Hello")) + + (test-assert "Full document" + ((xml 'html) + ((xml 'head) + ((xml #f 'meta '((charset "UTF-8")))) + ((xml 'title) "Title text")) + ((xml 'body) + "This document left blank")))) + (test-group "xml->namespaced-sxml" @@ -73,7 +85,7 @@ root: ((xml 'tag))) (xml->namespaced-sxml "")) - (test-equal "Document with whitespace in it" + (test-equal "Document with (untrimmed) whitespace in it" (xml-document pi: (list (pi-element 'xml "")) root: ((xml 'root) @@ -82,6 +94,16 @@ (xml->namespaced-sxml " " trim-whitespace?: #f)) + ;; An earlier version trimmed whitespace down inte empty strings, + ;; instead of (correctly) omitting the strings completely. + (test-equal "Document with (trimmed) whitespace in it" + (xml-document + pi: (list (pi-element 'xml "")) + root: ((xml 'root) + ((xml 'a)))) + (xml->namespaced-sxml " " + trim-whitespace?: #t)) + (test-equal "Whitespace before root is discarded kept" (xml-document pi: (list (pi-element 'xml "")) diff --git a/tests/unit/webdav/webdav-file.scm b/tests/unit/webdav/webdav-file.scm index 85f4738d..cc7c98dd 100644 --- a/tests/unit/webdav/webdav-file.scm +++ b/tests/unit/webdav/webdav-file.scm @@ -20,6 +20,7 @@ (define test-root (mkdtemp (string-copy "/tmp/calp-test-XXXXXX"))) (define root-resource (make + name: "*root*" root: test-root)) diff --git a/tests/unit/webdav/webdav-property.scm b/tests/unit/webdav/webdav-property.scm index 0b465e82..b3edf7ac 100644 --- a/tests/unit/webdav/webdav-property.scm +++ b/tests/unit/webdav/webdav-property.scm @@ -25,34 +25,34 @@ ;; (test-equal "/" (href->string (href resource))) (test-equal "Basic propstat" - (propstat 200 (list (list (xml webdav 'getcontentlength) 4))) + (propstat 200 (list ((xml webdav 'getcontentlength) "4"))) (getcontentlength resource)) ;;; NOTE propstat's return order isn't stable, making this test possibly fail -(let ((ps (list (propstat 200 (list `(,(xml webdav 'displayname) "Displayname"))) - (propstat 200 (list `(,(xml webdav 'getcontenttype) "text/plain")))))) +(let ((ps (list (propstat 200 (list ((xml webdav 'displayname) "Displayname"))) + (propstat 200 (list ((xml webdav 'getcontenttype) "text/plain")))))) (test-equal "Propstat merger" (list (propstat 200 - (list (list (xml webdav 'getcontenttype) "text/plain") - (list (xml webdav 'displayname) "Displayname")))) + (list ((xml webdav 'getcontenttype) "text/plain") + ((xml webdav 'displayname) "Displayname")))) (merge-propstats ps))) (test-group "Propstat -> namespaced sxml" (test-equal "Simple" - `(,(xml webdav 'propstat) - (,(xml webdav 'prop) (,(xml webdav 'displayname) "test")) - (,(xml webdav 'status) "HTTP/1.1 200 OK")) - (propstat->namespaced-sxml (propstat 200 `((,(xml webdav 'displayname) "test")) ))) + ((xml webdav 'propstat) + ((xml webdav 'prop) ((xml webdav 'displayname) "test")) + ((xml webdav 'status) "HTTP/1.1 200 OK")) + (propstat->namespaced-sxml (propstat 200 (list ((xml webdav 'displayname) "test"))))) ;; TODO populated error field (test-equal "With response description" - `(,(xml webdav 'propstat) - (,(xml webdav 'prop) (,(xml webdav 'displayname) "test")) - (,(xml webdav 'status) "HTTP/1.1 403 Forbidden") - (,(xml webdav 'responsedescription) "Try logging in")) - (propstat->namespaced-sxml (propstat 403 `((,(xml webdav 'displayname) "test")) + ((xml webdav 'propstat) + ((xml webdav 'prop) ((xml webdav 'displayname) "test")) + ((xml webdav 'status) "HTTP/1.1 403 Forbidden") + ((xml webdav 'responsedescription) "Try logging in")) + (propstat->namespaced-sxml (propstat 403 (list ((xml webdav 'displayname) "test")) responsedescription: "Try logging in")))) '((calp webdav property)) diff --git a/tests/unit/webdav/webdav-propfind.scm b/tests/unit/webdav/webdav-propfind.scm index 8144605a..220b84d3 100644 --- a/tests/unit/webdav/webdav-propfind.scm +++ b/tests/unit/webdav/webdav-propfind.scm @@ -17,6 +17,8 @@ (define (sort-symbols symbs) (sort* symbs string<=? symbol->string)) +;;; Propstats are unsorted, we just sort them here for easier +;;; equivalence checks in the tests. (define (sort-propstats propstats) (map (lambda (pr) @@ -24,7 +26,7 @@ (modify pr propstat-property* (lambda (it) (sort* it - string< (compose symbol->string xml-element-tagname car))))) + string< (compose symbol->string xml-element-tagname))))) (sort* propstats < propstat-status-code))) @@ -49,24 +51,25 @@ (test-equal (format #f "Propstat well formed: ~a" (propstat-property propstat)) 1 (length (propstat-property propstat))) (test-assert "Propstat child is xml" - (xml-element? (caar (propstat-property propstat))))) + (xml-element? (car (propstat-property propstat))))) most) (test-equal "Correct keys" '(creationdate displayname getcontentlanguage getcontentlength getcontenttype getetag getlastmodified lockdiscovery resourcetype supportedlock) - (sort-symbols (map (compose xml-element-tagname caar propstat-property) most))))) + (sort-symbols (map (compose xml-element-tagname car propstat-property) + most))))) (test-equal "propfind-selected-properties" - (list (propstat 404 `((,(xml webdav 'displayname))))) - (propfind-selected-properties resource (list (xml webdav 'displayname)))) + (list (propstat 404 (list ((xml webdav 'displayname))))) + (propfind-selected-properties resource (list ((xml webdav 'displayname))))) (test-group "parse-propfind" (test-group "propname" - (let ((props (parse-propfind `(,(xml webdav 'propfind) - (,(xml webdav 'propname))) + (let ((props (parse-propfind ((xml webdav 'propfind) + ((xml webdav 'propname))) resource))) @@ -76,11 +79,8 @@ (test-assert "Propstat objects are returned" (propstat? (car props))) (for-each (lambda (el) - (test-assert "Base is list" (list? el)) - (test-eqv "List only contains head el" 1 (length el)) - #; - (test-assert (format #f "Head is an xml tag: ~a" el) - (xml-element? (car el)))) + (test-assert "Each entry is an xml element" (xml-element*? el)) + (test-eqv "The enrties lack children" 0 (length (xml-element-children el)))) (propstat-property (car props))) #; @@ -88,128 +88,119 @@ (sort-symbols (cons* 'test 'is-virtual webdav-keys)) (sort-symbols (map (compose xml-element-tagname car) (propstat-property (car props))))) - - (test-group "No property should contain any data" - (for-each (lambda (el) - (test-eqv (format #f "Propname property: ~s" el) - 1 (length el))) - (propstat-property (car props)))))) + )) (test-group "direct property list" - (let ((props (parse-propfind `((xml webdav 'propfind) - (,(xml webdav 'prop) - (,(xml webdav 'displayname)))) + (let ((props (parse-propfind ((xml webdav 'propfind) + ((xml webdav 'prop) + ((xml webdav 'displayname)))) resource))) (test-equal "Simple lookup" - (list (propstat 404 (list (list (xml webdav 'displayname) - )))) + (list (propstat 404 (list ((xml webdav 'displayname))))) props))) ;; TODO test that calendar properties are reported by propname ;; TODO test that non-native caldav propreties aren't reported by allprop (test-group "allprop" - (let ((props (parse-propfind `(,(xml webdav 'propfind) - (,(xml webdav 'allprop))) + (let ((props (parse-propfind ((xml webdav 'propfind) + ((xml webdav 'allprop))) resource))) (test-equal "Propfind result" (list (propstat 200 - (list (list (xml webdav 'creationdate) - (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) - (list (xml webdav 'getcontentlength) - 4) - (list (xml webdav 'getcontenttype) - "application/binary") - (list (xml webdav 'getlastmodified) - "Thu, 01 Jan 1970 00:00:00 GMT") - (list (xml webdav 'lockdiscovery) '()) - (list (xml webdav 'resourcetype) + (list ((xml webdav 'creationdate) + (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) + ((xml webdav 'getcontentlength) + "4") + ((xml webdav 'getcontenttype) + "application/binary") + ((xml webdav 'getlastmodified) + "Thu, 01 Jan 1970 00:00:00 GMT") + ((xml webdav 'lockdiscovery)) + ((xml webdav 'resourcetype) ; (list (xml webdav 'collection)) - ) - (list (xml webdav 'supportedlock) '()) + ) + ((xml webdav 'supportedlock)) ;; (list (xml ns1 'test) "Content") )) - (propstat 404 (list (list (xml webdav 'displayname)) - (list (xml webdav 'getcontentlanguage)))) + (propstat 404 (list ((xml webdav 'displayname)) + ((xml webdav 'getcontentlanguage)))) (propstat 501 - (list (list (xml webdav 'getetag)) - ))) + (list ((xml webdav 'getetag))))) (sort-propstats props)))) (test-group "allprop with include" - (let ((props (parse-propfind `((xml webdav 'propfind) - (,(xml webdav 'allprop)) - (,(xml webdav 'include))) + (let ((props (parse-propfind ((xml webdav 'propfind) + ((xml webdav 'allprop)) + ((xml webdav 'include))) resource))) (test-equal "Include NOTHING" (list (propstat 200 - (list (list (xml webdav 'creationdate) - (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) - (list (xml webdav 'getcontentlength) - 4) - (list (xml webdav 'getcontenttype) - "application/binary") - (list (xml webdav 'getlastmodified) - "Thu, 01 Jan 1970 00:00:00 GMT") - (list (xml webdav 'lockdiscovery) '()) - (list (xml webdav 'resourcetype) + (list ((xml webdav 'creationdate) + (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) + ((xml webdav 'getcontentlength) + "4") + ((xml webdav 'getcontenttype) + "application/binary") + ((xml webdav 'getlastmodified) + "Thu, 01 Jan 1970 00:00:00 GMT") + ((xml webdav 'lockdiscovery)) + ((xml webdav 'resourcetype) ; (list (xml webdav 'collection)) - ) - (list (xml webdav 'supportedlock) '()) + ) + ((xml webdav 'supportedlock)) ;; (list (xml ns1 'test) "Content") )) - (propstat 404 (list (list (xml webdav 'displayname)) - (list (xml webdav 'getcontentlanguage)))) + (propstat 404 (list ((xml webdav 'displayname)) + ((xml webdav 'getcontentlanguage)))) (propstat 501 - (list (list (xml webdav 'getetag)) + (list ((xml webdav 'getetag)) ))) (sort-propstats props))) - (let ((props (parse-propfind `(,(xml webdav 'propfind) - (,(xml webdav 'allprop)) - (,(xml webdav 'include) - (,(xml virtual-ns 'isvirtual)))) + (let ((props (parse-propfind ((xml webdav 'propfind) + ((xml webdav 'allprop)) + ((xml webdav 'include) + ((xml virtual-ns 'isvirtual)))) resource))) (test-equal "Include isvirtual" (list (propstat 200 - (list (list (xml webdav 'creationdate) (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) - (list (xml webdav 'getcontentlength) 4) - (list (xml webdav 'getcontenttype) "application/binary") - (list (xml webdav 'getlastmodified) "Thu, 01 Jan 1970 00:00:00 GMT") - (list (xml virtual-ns 'isvirtual) "true") - (list (xml webdav 'lockdiscovery) '()) - (list (xml webdav 'resourcetype)) - (list (xml webdav 'supportedlock) '()) + (list ((xml webdav 'creationdate) (datetime->string dt "~Y-~m-~dT~H:~M:~SZ")) + ((xml webdav 'getcontentlength) "4") + ((xml webdav 'getcontenttype) "application/binary") + ((xml webdav 'getlastmodified) "Thu, 01 Jan 1970 00:00:00 GMT") + ((xml virtual-ns 'isvirtual) "true") + ((xml webdav 'lockdiscovery)) + ((xml webdav 'resourcetype)) + ((xml webdav 'supportedlock)) ;; (list (xml ns1 'test) "Content") )) - (propstat 404 (list (list (xml webdav 'displayname)) - (list (xml webdav 'getcontentlanguage)))) - (propstat 501 - (list (list (xml webdav 'getetag)) - ))) + (propstat 404 (list ((xml webdav 'displayname)) + ((xml webdav 'getcontentlanguage)))) + (propstat 501 (list ((xml webdav 'getetag))))) (sort-propstats props))))) (test-equal (list (propstat 200 - `((,(xml webdav 'getcontentlength) 4) - (,(xml webdav 'getlastmodified) "Thu, 01 Jan 1970 00:00:00 GMT") - (,(xml webdav 'resourcetype)))) + (list ((xml webdav 'getcontentlength) "4") + ((xml webdav 'getlastmodified) "Thu, 01 Jan 1970 00:00:00 GMT") + ((xml webdav 'resourcetype)))) (propstat 404 - `((,(xml webdav 'checked-in)) - (,(xml webdav 'checked-out)) - (,(xml (string->symbol "http://apache.org/dav/props/") 'executable))))) + (list ((xml webdav 'checked-in)) + ((xml webdav 'checked-out)) + ((xml (string->symbol "http://apache.org/dav/props/") 'executable))))) (let ((request (xml->namespaced-sxml " @@ -223,7 +214,7 @@ "))) - (sort-propstats (parse-propfind (caddr request) resource)))) + (sort-propstats (parse-propfind (xml-document-root request) resource)))) (test-equal "All dead properties" (list #; diff --git a/tests/unit/webdav/webdav-resource.scm b/tests/unit/webdav/webdav-resource.scm index f6ebf3bb..f81487ed 100644 --- a/tests/unit/webdav/webdav-resource.scm +++ b/tests/unit/webdav/webdav-resource.scm @@ -52,7 +52,7 @@ (let ((props (live-properties resource))) (test-assert (list? props)) (for-each (lambda (pair) - ;; (test-assert (xml-element? (car pair))) + (test-assert (xml-element? (car pair))) (test-assert (live-property? (cdr pair))) (test-assert (procedure? (property-getter (cdr pair)))) (test-assert (procedure? (property-setter-generator (cdr pair))))) @@ -61,36 +61,36 @@ (define ns1 (string->symbol "http://example.com/namespace")) -(set-dead-property! resource `(,(xml ns1 'test) "Content")) +(set-dead-property! resource ((xml ns1 'test) "Content")) (test-equal "Get dead property" - (propstat 200 (list (list (xml ns1 'test) "Content"))) - (get-dead-property resource (xml ns1 'test))) + (propstat 200 (list ((xml ns1 'test) "Content"))) + (get-dead-property resource ((xml ns1 'test)))) (test-equal "Get live property" - (propstat 404 (list (list (xml ns1 'test)))) - (get-live-property resource (xml ns1 'test))) + (propstat 404 (list ((xml ns1 'test)))) + (get-live-property resource ((xml ns1 'test)))) (test-group "Dead properties" (test-equal "Existing property" - (propstat 200 (list (list (xml ns1 'test) "Content"))) - (get-property resource (xml ns1 'test))) + (propstat 200 (list ((xml ns1 'test) "Content"))) + (get-property resource ((xml ns1 'test)))) (test-equal "Missing property" - (propstat 404 (list (list (xml ns1 'test2)))) - (get-property resource (xml ns1 'test2)))) + (propstat 404 (list ((xml ns1 'test2)))) + (get-property resource ((xml ns1 'test2))))) (test-group "Live Properties" ;; TODO these tests were written when displayname always returned 200, but have since changed to test for 404. ;; Change to another property which return 200 (test-equal "Existing live property (through get-live-property)" - (propstat 404 `((,(xml webdav 'displayname)))) - (get-live-property resource (xml webdav 'displayname))) + (propstat 404 (list ((xml webdav 'displayname)))) + (get-live-property resource ((xml webdav 'displayname)))) (test-equal "Existing live property (thrtough get-property)" - (propstat 404 `((,(xml webdav 'displayname)))) - (get-property resource (xml webdav 'displayname)))) + (propstat 404 (list ((xml webdav 'displayname)))) + (get-property resource ((xml webdav 'displayname))))) (test-group "lookup-resource" (let* ((root (make name: "*root*")) -- cgit v1.2.3