diff options
Diffstat (limited to 'module/calp/webdav/resource/base.scm')
| -rw-r--r-- | module/calp/webdav/resource/base.scm | 163 |
1 files changed, 94 insertions, 69 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")) |