aboutsummaryrefslogtreecommitdiff
path: root/module/calp/webdav
diff options
context:
space:
mode:
Diffstat (limited to 'module/calp/webdav')
-rw-r--r--module/calp/webdav/property.scm91
-rw-r--r--module/calp/webdav/propfind.scm93
-rw-r--r--module/calp/webdav/proppatch.scm67
-rw-r--r--module/calp/webdav/resource.scm15
-rw-r--r--module/calp/webdav/resource/base.scm572
-rw-r--r--module/calp/webdav/resource/calendar.scm129
-rw-r--r--module/calp/webdav/resource/file.scm188
-rw-r--r--module/calp/webdav/resource/virtual.scm70
8 files changed, 1225 insertions, 0 deletions
diff --git a/module/calp/webdav/property.scm b/module/calp/webdav/property.scm
new file mode 100644
index 00000000..092d270a
--- /dev/null
+++ b/module/calp/webdav/property.scm
@@ -0,0 +1,91 @@
+(define-module (calp webdav property)
+ :use-module (sxml namespaced)
+ :use-module (web http status-codes)
+ :use-module ((srfi srfi-1) :select (concatenate find))
+ :use-module (srfi srfi-9)
+ :use-module (srfi srfi-71)
+ :use-module (srfi srfi-88)
+ :use-module (hnh util)
+ :use-module (calp namespaces)
+ :export (make-propstat
+ propstat?
+ propstat-status-code
+ propstat-property
+ propstat-error
+ propstat-response-description
+
+ propstat
+
+ merge-propstats
+ propstat-200?
+ ;; propstat->sxml
+ propstat->namespaced-sxml
+ ))
+
+;;; Commentary:
+;;; Code:
+
+
+;; Maps directly to [WEBDAV]'s propstat objects. This is just a simpler interface in the code.
+
+(define-record-type <propstat>
+ (make-propstat status prop error responsedescription)
+ propstat?
+ ;; An http status code indicating if this property is present
+ (status propstat-status-code)
+ ;; A list of namespaced sxml elements, such that they could all be
+ ;; directly inserted as the children of <DAV::prop/>
+ ;; @example
+ ;; `((,(xml ns tag) "Content"))
+ ;; @end example
+ (prop propstat-property)
+
+ ;; See [WEBCAL] propstat XML element
+ (error propstat-error)
+ (responsedescription propstat-response-description))
+
+(define* (propstat code prop key: error responsedescription)
+ (make-propstat code prop error responsedescription))
+
+;; Query a given dead property from the given resource
+;; property should be a xml-element item
+;; (define (propfind-selected-property resource property)
+;; (cond ((get-dead-property resource property)
+;; => (lambda (it) (propstat 200 (list it))))
+;; (else (propstat 404 (list (list property))))))
+;; Takes a list of <propstat> items, finds all where status, error, and
+;; responsedescription are all equal, and merges the prop tags of all those.
+;; Returns a new list of <propstat> items
+(define (merge-propstats propstats)
+ (map (lambda (group)
+ (define-values (code error desc) (unlist (car group)))
+ (make-propstat code
+ (concatenate
+ (map propstat-property (cdr group)))
+ error desc))
+ (group-by (lambda (propstat)
+ (list (propstat-status-code propstat)
+ (propstat-error propstat )
+ (propstat-response-description propstat)))
+ propstats)))
+
+(define (propstat-200? prop)
+ (= 200 (propstat-status-code prop)))
+
+
+;; (define (propstat->sxml propstat)
+;; `(d:propstat (d:prop ,(propstat-property propstat))
+;; (d:status ,(http-status-line (propstat-status-code propstat)))
+;; ,@(awhen (propstat-error propstat)
+;; `((d:error ,it)))
+;; ,@(awhen (propstat-response-description propstat)
+;; `((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)))))
diff --git a/module/calp/webdav/propfind.scm b/module/calp/webdav/propfind.scm
new file mode 100644
index 00000000..e6becafd
--- /dev/null
+++ b/module/calp/webdav/propfind.scm
@@ -0,0 +1,93 @@
+(define-module (calp webdav propfind)
+ :use-module (calp webdav property)
+ :use-module (calp webdav resource)
+ :use-module (sxml match)
+ :use-module (sxml namespaced)
+ :export (propfind-selected-properties
+ propfind-all-live-properties
+ propfind-most-live-properties
+ propfind-all-dead-properties
+
+ parse-propfind
+ ))
+
+;;; Commentary:
+;;; Procedures for the WebDav PROPFIND method
+;;; Code:
+
+;; Properties should be a list of xml-tag-elements
+;; return a list of propstat elements
+;; work for both dead and alive objects
+(define (propfind-selected-properties resource properties)
+ (map (lambda (el) (get-property resource el))
+ properties))
+
+
+;; (define-method (supported-properties (self <resource>))
+;; (map (lambda (v) (cons webdav v))
+;; `()))
+
+;; Returns a list of <propstat> objects.
+(define (propfind-all-live-properties resource)
+ (map (lambda (p) ((cdr p) resource))
+ (live-properties resource)))
+
+;; Returns a list of <propstat> objects.
+;; The list being the live properties defined by [WEBDAV]
+(define (propfind-most-live-properties resource)
+ (map (lambda (p) ((property-getter (cdr p)) resource))
+ webdav-properties))
+
+;; Returns a list of <propstat> objects.
+;; All "dead" properties on resource.
+(define (propfind-all-dead-properties resource)
+ (map (lambda (v) (propstat 200 (list v)))
+ (dead-properties resource)))
+
+
+
+
+
+
+;; Takes a propfind xml element (tree), and a webdav resource object.
+;; Returns a list of <propstat> objects.
+(define (parse-propfind sxml namespaces resource)
+ (merge-propstats
+ ;; TODO Allow *TOP* and *PI*?
+ (sxml-match sxml
+ ((d:propfind (d:propname))
+ ;; Return the list of available properties
+ (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))))))
+
+ ((d:propfind (d:allprop))
+ ;; Return "all" properties
+ (append
+ (propfind-most-live-properties resource)
+ (propfind-all-dead-properties resource)))
+
+ ((d:propfind (d:allprop) (d:include ,properties ...))
+ ;; Return "all" properties + those noted by <include/>
+ (append
+ (propfind-most-live-properties resource)
+ (propfind-all-dead-properties resource)
+ (propfind-selected-properties
+ resource
+ (map (lambda (prop) (car (sxml->namespaced-sxml prop namespaces)))
+ properties))))
+
+ ((d:propfind (d:prop ,properties ...))
+ ;; Return the properties listed
+ (propfind-selected-properties
+ resource
+ (map (lambda (prop) (car (sxml->namespaced-sxml prop namespaces)))
+ properties)))
+
+ (,default (scm-error 'bad-request "parse-propfind"
+ "Invalid search query ~s" (list default) (list default)))
+ )))
diff --git a/module/calp/webdav/proppatch.scm b/module/calp/webdav/proppatch.scm
new file mode 100644
index 00000000..db7f5f95
--- /dev/null
+++ b/module/calp/webdav/proppatch.scm
@@ -0,0 +1,67 @@
+(define-module (calp webdav proppatch)
+ :use-module (srfi srfi-1)
+ :use-module (srfi srfi-71)
+ :use-module (srfi srfi-88)
+ :use-module (calp webdav property)
+ :use-module (calp webdav resource)
+ :use-module (sxml match)
+ :use-module (sxml namespaced)
+ :use-module ((hnh util) :select (for))
+ :export (parse-propertyupdate)
+ )
+
+
+(define (parse-propertyupdate body namespaces resource)
+ (merge-propstats
+ (sxml-match body
+ [(d:propertyupdate . ,changes)
+ (define continuations
+ (concatenate
+ (for change in changes
+ (sxml-match change
+ [(d:remove (d:prop . ,properties))
+ (map (lambda (prop) (cons prop
+ (remove-property
+ resource
+ (car
+ (sxml->namespaced-sxml prop namespaces)))))
+ properties)]
+
+ ;; TODO handle xmllang correctly
+ [(d:set (d:prop . ,properties))
+ (map (lambda (prop) (cons prop
+ (set-property resource
+ (sxml->namespaced-sxml prop namespaces))))
+ properties)]
+
+ [,else (scm-error 'bad-request ""
+ "Invalid propertyupdate: ~s"
+ (list body)
+ (list body))]))))
+
+ ;; (format (current-error-port) "~s~%" continuations)
+ (let loop ((continuations continuations))
+ (if (null? continuations)
+ '()
+ (let ((tag proc (car+cdr (car continuations))))
+ (set! tag (sxml->namespaced-sxml tag namespaces))
+ ;; (format (current-error-port) "tag: ~s~%" tag)
+ (catch #t (lambda ()
+ ;; This is expected to throw quite often
+ (proc)
+ (cons (propstat 200 (list tag))
+ (loop (cdr continuations))))
+ (lambda err
+ (cons (propstat 409 (list tag))
+ (mark-remaining-as-failed-dependency (cdr continuations))))))))]
+
+ [,else (scm-error 'bad-request ""
+ "Invalid root element: ~s"
+ (list else)
+ (list else))])))
+
+
+(define (mark-remaining-as-failed-dependency pairs)
+ (map (lambda (item)
+ (propstat 424 (list (car item))))
+ pairs))
diff --git a/module/calp/webdav/resource.scm b/module/calp/webdav/resource.scm
new file mode 100644
index 00000000..47c5aded
--- /dev/null
+++ b/module/calp/webdav/resource.scm
@@ -0,0 +1,15 @@
+(define-module (calp webdav resource)
+ :use-module (srfi srfi-88)
+ :use-module (oop goops)
+ :use-module (calp webdav resource base)
+ :export (mount-resource!))
+
+(define cm (module-public-interface (current-module)))
+(module-use! cm (resolve-interface '(calp webdav resource base)))
+
+;;; TODO mount-resource! vs add-child!
+;;; Would a good idea be that add-resource! adds directly, and should
+;;; be considered internal, while mount-resource! also runs post-add
+;;; hooks, and could thereby be exported
+(define-method (mount-resource! (this <resource>) (child <resource>))
+ (add-child! this child))
diff --git a/module/calp/webdav/resource/base.scm b/module/calp/webdav/resource/base.scm
new file mode 100644
index 00000000..0b1d4ace
--- /dev/null
+++ b/module/calp/webdav/resource/base.scm
@@ -0,0 +1,572 @@
+(define-module (calp webdav resource base)
+ :use-module ((srfi srfi-1) :select (find remove last append-map drop-while))
+ :use-module (srfi srfi-9)
+ :use-module (srfi srfi-71)
+ :use-module (srfi srfi-88)
+ :use-module (oop goops)
+ :use-module (sxml namespaced)
+ :use-module (calp webdav property)
+ :use-module (calp namespaces)
+ :use-module ((hnh util) :select (unless))
+ :use-module (rnrs bytevectors)
+ :use-module (hnh util)
+ :use-module (hnh util env)
+ :use-module (datetime)
+ :export (<resource>
+ ;; href
+ href->string
+ string->href
+ ;; local-path
+ name
+ dead-properties
+ ;; resource-children
+ resource?
+ children
+ xml-element-hash-key
+
+
+
+ get-live-property
+ get-dead-property
+ get-property
+
+ set-dead-property
+ set-dead-property!
+ set-live-property
+ set-live-property!
+ set-property
+ set-property!
+
+ remove-dead-property
+ remove-dead-property!
+ remove-live-property
+ remove-live-property!
+ remove-property
+ remove-property!
+
+
+
+
+ live-properties
+ add-child!
+ add-resource!
+ add-collection!
+ is-collection?
+
+ content
+ set-content!
+
+ copy-resource
+ cleanup-resource
+ delete-child!
+ move-resource!
+ setup-new-resource!
+ ;; prepare-for-add!
+
+ creationdate
+ displayname
+ getcontentlanguage
+ getcontentlength
+ getcontenttype
+ getetag
+ getlastmodified
+ lockdiscovery
+ resourcetype
+ supportedlock
+
+ webdav-properties
+
+ ;; absolute-path
+ ;; find-resource
+ lookup-resource
+ all-resources-under
+
+ ;; dereference
+
+ make-live-property
+ live-property?
+ property-getter
+ property-setter-generator
+ property-remover-generator
+
+ prepare-update-properties
+
+ ))
+
+
+(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* (make-live-property getter setter-generator optional: remover-generator)
+ (make-live-property% getter setter-generator remover-generator))
+
+
+
+;; Collections are also resources, this is non-collection resources
+(define-class <resource> ()
+ ;; (href init-keyword: href: getter: href init-value: #f)
+ ;; (local-path init-keyword: local-path: getter: local-path)
+
+ ;; name is a part of its search path.
+ ;; For example: the component located at /a/b
+ ;; would have name="a", its parent name="b", and the root element
+ ;; would have an unspecified name (probably the empty string, or "*root*")
+ (name init-keyword: name: getter: name)
+
+ (dead-properties
+ ;; Map from (namespace . tagname) pairs to namespaced xml element
+ init-form: (make-hash-table)
+ getter: dead-properties%)
+
+ ;; Attributes on data
+ (displayname accessor: displayname* init-value: #f)
+ (contentlanguage accessor: contentlanguage init-value: #f)
+
+ ;; Direct children, used by @code{children} if not overwritten by child
+ (resource-children init-value: '()
+ accessor: resource-children)
+
+ ;; Table containing href -> resource mappings, saves us from recursivly searching children each time.
+ (resource-cache init-value: (make-hash-table 0)
+ getter: resource-cache))
+
+(define (resource? x)
+ (is-a? x <resource>))
+
+
+(define (href->string href)
+ (if (null? href)
+ "/" (string-join href "/" 'prefix)))
+
+(define (string->href s)
+ (remove string-null?
+ (string-split s #\/)))
+
+(define-method (children (self <resource>))
+ (resource-children self))
+
+;;; TODO merge content and set-content! into an accessor?
+(define-method (content (self <resource>))
+ (throw 'misc-error "content<resource>"
+ "Base <resource> doesn't implement (getting) content, please override this method"
+ '() #f))
+
+(define-method (set-content! (self <resource>) content)
+ (throw 'msic-error "set-content!<resource>"
+ "Base <resource> doesn't implement (setting) content, please override this method"
+ '() #f))
+
+(define-method (content-length (self <resource>))
+ (if (is-collection? self)
+ 0
+ (let ((c (content self)))
+ (cond ((bytevector? c) (bytevector-length c))
+ ((string? c) (string-length c))
+ (else -1)))))
+
+(define-method (write (self <resource>) port)
+ (catch #t
+ (lambda ()
+ (display ; Make output atomic
+ (call-with-output-string
+ (lambda (port)
+ ;; (define o (dereference self))
+ (format port "#<~a name=~s"
+ (class-name (class-of self))
+ (name self))
+ (cond ((displayname self)
+ propstat-200?
+ (lambda (name) (format port ", displayname=~s" name))))
+ (format port ">")))
+ port))
+ (lambda _
+ (format port "#<~a>" (class-name (class-of self))))))
+
+
+;;; TODO should add-resource! be kept? It would probably be better to merge it
+;;; with add-child!
+
+
+
+;; Possibly change this to a fixed procedure
+(define-method (add-resource! (self <resource>)
+ (new-name <string>)
+ content)
+ (if (lookup-resource self (list new-name))
+ (throw 'resource-exists)
+ (let ((resource (make (class-of self) name: new-name)))
+ (setup-new-resource! resource self)
+ (add-child! self resource)
+ (set-content! resource content)
+ resource)))
+
+;; Possibly change this to a fixed procedure,
+;; adding a setup method instead
+(define-method (add-collection! (self <resource>) new-name)
+ (if (lookup-resource self (list new-name))
+ (throw 'resource-exists)
+ (let ((resource (make (class-of self) name: new-name)))
+ (add-child! self resource)
+ resource)))
+
+(define-method (copy-resource (self <resource>) include-children?)
+ (copy-resource self include-children? #f))
+
+(define-method (copy-resource (self <resource>) include-children? new-name)
+ (let ((resource (make (class-of self) name: (or new-name (name self)))))
+ (for-each (lambda (tag) (set-dead-property! resource tag))
+ (dead-properties self))
+ (set! (displayname* resource) (displayname* self)
+ (contentlanguage resource) (contentlanguage self))
+ (set-content! resource (content self))
+ (when include-children?
+ (for-each (lambda (c) (add-child! resource c))
+ (map (lambda (c) (copy-resource c #t))
+ (children self))))
+ ;; resource-cache should never be copied
+ resource))
+
+(define (xml-element-hash-key tag)
+ "Returns a value suitable as a key to hash-ref (and family)"
+ (cons (xml-element-namespace tag)
+ (xml-element-tagname tag)))
+
+;; Only tagname and namespaces are checked on the <xml-element> for the {get,set}-property
+
+
+;;; 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)))
+
+;;; TODO should {get,set}{,-{dead,live}}-property really be methods?
+;;; - Live properties are defined by lookup-live-property, which isn't a
+;;; method, which in turn calls live-properties, which MUST be a method.
+;;; - Dead properties may have a reason. For example, file resources might
+;;; want to store them directly in xattrs, ignoring its built in hash-table.
+;;; - The combined should always just dispatch to either one
+
+(define-method (get-live-property (resource <resource>) xml-el)
+ (cond ((lookup-live-property resource xml-el)
+ => (lambda (pair) ((property-getter pair) resource)))
+ (else (propstat 404 (list (list xml-el))))))
+
+(define-method (get-dead-property (resource <resource>) xml-el)
+ (cond ((hash-ref (dead-properties% resource)
+ (xml-element-hash-key xml-el))
+ => (lambda (it) (propstat 200 (list it))))
+ (else (propstat 404 (list (list xml-el))))))
+
+;;; Return a list xml tags (including containing list)
+(define-method (dead-properties (resource <resource>))
+ (hash-map->list (lambda (_ v) v)
+ (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))
+ (lambda ()
+ (hash-set! (dead-properties% resource)
+ (xml-element-hash-key (car value))
+ value)))
+
+(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))
+ (cond ((lookup-live-property resource (car value))
+ => (lambda (prop) (apply (property-setter-generator prop)
+ resource (cdr value))))
+ (else #f)))
+
+(define (set-dead-property! resource value)
+ ((set-dead-property resource value)))
+
+(define (set-live-property! resource value)
+ ((set-live-property resource value)))
+
+(define (set-property resource value)
+ (or (set-live-property resource value)
+ (set-dead-property resource value)))
+
+(define (set-property! resource value)
+ ((set-property resource value)))
+
+;;; The remove-* procedures still take "correct" namespaced sxml (so an
+;;; xml-element object inside a list). These extra lists are a bit of a waste,
+;;; 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))
+ (lambda ()
+ (hash-remove! (dead-properties% resource)
+ (xml-element-hash-key xml-tag))))
+
+(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))
+
+ (cond ((lookup-live-property resource xml-tag)
+ => (lambda (prop)
+ (cond ((property-remover-generator prop)
+ => (lambda (f) (f resource)))
+ (else (throw 'irremovable-live-property)))))
+ (else #f)))
+
+(define (remove-dead-property! resource xml-tag)
+ ((remove-dead-property resource xml-tag)))
+
+(define (remove-live-property! resource xml-tag)
+ ((remove-live-property resource xml-tag)))
+
+(define-method (remove-property (resource <resource>) xml-tag)
+ (or (remove-live-property resource xml-tag)
+ (remove-dead-property resource xml-tag)))
+
+(define (remove-property! resource xml-tag)
+ ((remove-property resource xml-tag)))
+
+
+
+;; xml-tag should be just the tag element, without a surounding list
+(define-method (get-property (resource <resource>) xml-tag)
+ (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)
+;; to generic procedures returning that value.
+;; SHOULD be extended by children, which append their result to this result
+;; @example
+;; (define-method (live-properties (self <specific-resource>)
+;; (append (next-method)
+;; 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)))
+ webdav-properties))
+
+(define-method (setup-new-resource! (this <resource>) (parent <resource>))
+ 'noop)
+
+(define-method (add-child! (this <resource>) (child <resource>))
+ ;; TODO this should call a method on child, allowing it to be updated
+ ;; with aditional context
+ ;; (prepare-for-add! child this)
+ (set! (resource-children this)
+ (cons child (resource-children this)))
+ 'created)
+
+(define-method (add-child! (this <resource>) (child <resource>) (overwrite? <boolean>))
+ (let ((existing (lookup-resource this (list (name child)))))
+ (cond ((and overwrite? existing)
+ (set! (resource-children this)
+ ;; TODO properly remove the old node, similar to mov DELETE
+ ;; will do it (calling cleanup, and so on).
+ (cons child (delete existing (children this))))
+ 'replaced)
+ (existing 'collision)
+ (else
+ (add-child! this child)
+ 'created))))
+
+;; Free any aditional system resources held by this object.
+;; For example, file resources will remove the underlying file here.
+(define-method (cleanup-resource (this <resource>))
+ 'noop)
+
+(define-method (delete-child! (this <resource>) (child <resource>))
+ (set! (resource-children this)
+ (delq1! child (children this)))
+ (for-each (lambda (grandchild)
+ (delete-child! child grandchild))
+ (children child))
+ (cleanup-resource child))
+
+
+(define-method (move-resource! (root <resource>)
+ from to
+ (overwrite? <boolean>))
+ (let* ((dest-path dest-name (init+last to))
+ (from-path from-name (init+last from))
+ (dest-parent (or (lookup-resource root dest-path)
+ (throw 'target-parent-not-found)))
+ (from-parent (or (lookup-resource root from-path)
+ (throw 'source-not-found)))
+ (source (or (lookup-resource from-parent (list from-name))
+ (throw 'source-not-found))))
+ (if (and (is-collection? source)
+ (not overwrite?))
+ 'collision
+ ;; run move by running a copy followed by a delete.
+ ;; [RFC4918] 9.9.3 specifies that the server MUST run a DELETE
+ ;; on the target if overwrite is true, but I actually don't
+ ;; see the difference between that and a propper move...
+ (let ((status (add-child! dest-parent (copy-resource source #t dest-name)
+ overwrite?)))
+ (case status
+ ((created replaced)
+ (delete-child! from-parent source)
+ status)
+ (else status))))))
+
+
+
+
+
+;;; TODO rename to simply @code{collection?}
+(define-method (is-collection? (self <resource>))
+ (not (null? (resource-children self))))
+
+
+
+
+(define-method (creationdate (self <resource>))
+ (propstat 501 `((,(xml webdav 'creationdate)))))
+
+(define-method (set-creationdate! (self <resource>) _)
+ (throw 'protected-resource "creationdate"))
+
+(define-method (displayname (self <resource>))
+ (cond ((displayname* self)
+ => (lambda (name)
+ (propstat 200 `((,(xml webdav 'displayname)
+ ,name)))))
+ (else
+ (propstat 404 `((,(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)))))))
+
+(define-method (set-getcontentlanguage! (self <resource>) value)
+ (lambda () (set! (contentlanguage self) value)))
+
+(define-method (getcontentlength (self <resource>))
+ (propstat 501 `((,(xml webdav 'getcontentlength)))))
+
+(define-method (getcontentlength (self <resource>))
+ (propstat 200
+ (list
+ (list (xml webdav 'getcontentlength)
+ (content-length self)))))
+
+(define-method (set-getcontentlength! (self <resource>) _)
+ (throw 'protected-resource "getcontentlength"))
+
+(define-method (getcontenttype (self <resource>))
+ (propstat 501 `((,(xml webdav 'getcontenttype)))))
+
+(define-method (set-getcontenttype! (self <resource>) _)
+ (throw 'protected-resource "getcontenttype"))
+
+(define-method (getetag (self <resource>))
+ ;; TODO
+ (propstat 501 `((,(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")))))))
+
+(define-method (set-getlastmodified! (self <resource>) _)
+ (throw 'protected-resource "getlastmodified"))
+
+(define-method (lockdiscovery (self <resource>))
+ (propstat 200 `((,(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))))))))
+
+(define-method (set-resourcetype! (self <resource>) _)
+ (throw 'protected-resource "resourcetype"))
+
+(define-method (supportedlock (self <resource>))
+ (propstat 200 `((,(xml webdav 'supportedlock) ()))))
+
+(define-method (set-supportedlock! (self <resource>) _)
+ (throw 'protected-resource "supportedlock"))
+
+(define webdav-properties
+ `((creationdate . ,(make-live-property creationdate set-creationdate!))
+ (displayname . ,(make-live-property displayname set-displayname!))
+ (getcontentlanguage . ,(make-live-property getcontentlanguage set-getcontentlanguage!))
+ (getcontentlength . ,(make-live-property getcontentlength set-getcontentlength!))
+ (getcontenttype . ,(make-live-property getcontenttype set-getcontenttype!))
+ (getetag . ,(make-live-property getetag set-getetag!))
+ (getlastmodified . ,(make-live-property getlastmodified set-getlastmodified!))
+ (lockdiscovery . ,(make-live-property lockdiscovery set-lockdiscovery!))
+ (resourcetype . ,(make-live-property resourcetype set-resourcetype!))
+ (supportedlock . ,(make-live-property supportedlock set-supportedlock!))))
+
+
+
+;;; TODO remove! This is a remnant of the old mount system
+;; (define-method (dereference (self <resource>))
+;; self)
+
+(define (find-resource resource path)
+ ;; Resource should be a <resource> (or something descended from it)
+ ;; path should be a list of strings
+ (cond ((null? path) resource)
+ ((string-null? (car path))
+ ;; resource
+ (find-resource resource (cdr path)))
+ ((find (lambda (r) (string=? (car path) (name r)))
+ (children resource))
+ => (lambda (r) (find-resource r (cdr path))))
+ (else #f)))
+
+;; Lookup up a given resource first in the cache,
+;; Then in the tree
+;; and finaly fails and returns #f
+(define (lookup-resource root-resource path)
+ (find-resource root-resource path)
+ #;
+ (or (hash-ref (resource-cache root-resource) path)
+ (and=> (find-resource root-resource path)
+ (lambda (resource)
+ (hash-set! (resource-cache root-resource) path resource)
+ resource))))
+
+(define* (all-resources-under* resource optional: (prefix '()))
+ (define s (append prefix (list (name resource))))
+ (cons (cons s resource)
+ (append-map (lambda (c) (all-resources-under* c s))
+ (children resource))))
+
+;; Returns a flat list of this resource, and all its decendants
+(define* (all-resources-under resource optional: (prefix '()))
+ (cons (cons prefix resource)
+ (append-map (lambda (c) (all-resources-under* c prefix))
+ (children resource))))
diff --git a/module/calp/webdav/resource/calendar.scm b/module/calp/webdav/resource/calendar.scm
new file mode 100644
index 00000000..6c20df31
--- /dev/null
+++ b/module/calp/webdav/resource/calendar.scm
@@ -0,0 +1,129 @@
+(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>
+ 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 (calendar-resource? x)
+ (is-a? x <calendar-resource>))
+
+(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/file.scm b/module/calp/webdav/resource/file.scm
new file mode 100644
index 00000000..58e71e2c
--- /dev/null
+++ b/module/calp/webdav/resource/file.scm
@@ -0,0 +1,188 @@
+(define-module (calp webdav resource file)
+ :use-module (srfi srfi-1)
+ :use-module (oop goops)
+ :use-module (hnh util)
+ :use-module (hnh util env)
+ :use-module (hnh util path)
+ :use-module (datetime)
+ :use-module (ice-9 popen)
+ :use-module (ice-9 rdelim)
+ :use-module (ice-9 ftw)
+ :use-module (sxml namespaced)
+ :use-module (calp webdav resource)
+ :use-module (calp webdav property)
+ :use-module (calp namespaces)
+ :use-module (rnrs io ports)
+ :use-module (rnrs bytevectors)
+ :export (<file-resource> file-resource? root ; path
+ ))
+
+;;; Resources backed by the filesystem
+(define-class <file-resource> (<resource>)
+ ;; Directory to act as root for this file tree.
+ ;; Should be inherited by all children
+
+ ;; DO NOT export the setters. These fields needs to be carefully managed to
+ ;; ensure that they stay consistant with the @var{name} trail.
+ (root getter: root setter: set-root! init-value: "/" init-keyword: root:)
+ (path getter: path setter: set-path! init-value: "/" init-keyword: path:))
+
+(define (file-resource? x)
+ (is-a? x <file-resource>))
+
+;; TODO this is global, so most certanly leaks info between different
+;; <file-resource> trees.
+(define *realized-resource* (make-hash-table))
+
+(define (file-resource-for-path root path)
+ (or (hash-ref *realized-resource* path)
+ (let ((resource (make <file-resource>
+ ;; href:
+ root: root
+ ; local-path: path
+ name: (basename path)
+ path: path
+ )))
+ (hash-set! *realized-resource* path resource)
+ resource)))
+
+(define (filepath self)
+ (path-append (root self)
+ (path self)))
+
+(define-method (children (self <file-resource>))
+ ;; (format (current-error-port) "root=~s, path=~s~%"
+ ;; (root self)
+ ;; (local-path self))
+ (when (is-collection? self)
+ (map (lambda (p) (file-resource-for-path (root self)
+ (path-append (path self)
+ p)))
+ (remove (lambda (p) (member p '("." "..")))
+ (scandir (filepath self))))))
+
+(define-method (is-collection? (self <file-resource>))
+ (eq? 'directory (stat:type (stat (filepath self)))))
+
+(define (file-creation-date path)
+ (let ((pipe (open-pipe* OPEN_READ "stat" "-c" "%W" path)))
+ (begin1 (unix-time->datetime (read pipe))
+ (close-pipe pipe))))
+
+(define (mimetype path)
+ (let ((pipe (open-pipe* OPEN_READ "file" "--brief" "--mime-type"
+ path)))
+ (begin1 (read-line pipe)
+ (close-pipe pipe))))
+
+(define-method (creationdate (self <file-resource>))
+ (propstat 200
+ `((,(xml webdav 'creationdate)
+ ,(with-locale1
+ LC_TIME "C"
+ (lambda ()
+ (-> (file-creation-date (filepath self))
+ (datetime->string "~Y-~m-~dT~H:~M:~S~Z"))))))))
+
+(define-method (content (self <file-resource>))
+ (if (is-collection? self)
+ #f
+ (call-with-input-file (filepath self)
+ get-bytevector-all binary: #t)))
+
+(define-method (set-content! (self <file-resource>) data)
+ (cond ((bytevector? data)
+ (call-with-output-file (filepath self)
+ (lambda (port) (put-bytevector port data))))
+ ((string? data)
+ (call-with-output-file (filepath self)
+ (lambda (port) (put-string port data))))
+ (else (scm-error 'misc-error "set-content!<file-resource>"
+ "Content must be bytevector or string: ~s"
+ (list data) #f))))
+
+
+;; This is currently ONLY called from add-resource! which creates a
+;; child from the type of the parent.
+(define-method (setup-new-resource! (self <file-resource>)
+ (parent <file-resource>))
+ (set-root! self (root parent))
+ (set-path! self (path-append (path parent) (name self))))
+
+
+(define-method (add-collection! (self <file-resource>) new-name)
+ (let ((resource (next-method)))
+ (set-root! resource (root self))
+ (set-path! resource (path-append (path self) new-name))
+ (mkdir (path-append (root resource) (path resource)))
+ resource))
+
+(define-method (cleanup-resource (self <file-resource>))
+ ((if (is-collection? self)
+ rmdir
+ delete-file)
+ (filepath self)))
+
+(define-method (content-length (self <file-resource>))
+ (-> (filepath self) stat stat:size))
+
+
+(define-method (getcontenttype (self <file-resource>))
+ ;; TODO 404 if collection
+ ;; Or just omit it?
+ (propstat 200 `((,(xml webdav 'getcontenttype)
+ ,(mimetype (filepath self))))))
+
+(define-method (getlastmodified (self <file-resource>))
+ (propstat 200
+ `((,(xml webdav 'getlastmodified)
+ ,(with-locale1
+ LC_TIME "C"
+ (lambda ()
+ (-> (filepath self)
+ stat
+ stat:mtime
+ unix-time->datetime
+ (datetime->string "~a, ~d ~b ~Y ~H:~M:~S GMT"))))))))
+
+;; (define (xattr-key xml-el)
+;; (format #f "caldav.~a"
+;; (base64-encode
+;; (format #f "~a:~a"
+;; (xml-element-namespace xml-el)
+;; (xml-element-tagname xml-el)))))
+
+
+;; (define-method (set-dead-property (self <file-resource>) value)
+;; (unless (and (list? value)
+;; (xml-element? (car value)))
+;; (scm-error 'misc-error "set-dead-property"
+;; "Invalid value, expected namespaced sxml"
+;; '() #f))
+;; (catch #t
+;; (lambda ()
+;; (lambda ()
+;; (xattr-set!
+;; (filename self)
+;; (xattr-key (car value))
+;; (with-output-to-string
+;; (lambda () (namespaced-sxml->xml value))))))
+;; (lambda _ (next-method))))
+
+
+;; (define-method (get-dead-property (self <file-resource>)
+;; xml-el)
+;; (catch #t
+;; (lambda ()
+;; (propstat 200
+;; (list
+;; (xattr-ref (filepath self)
+;; (xattr-key el)))))
+;; (lambda _ (next-method))))
+
+
+;; (define-method (remove-dead-property (self <file-resource>)
+;; xml-el)
+;; (catch #t
+;; (lambda () (xattr-remove! (filepath self) xml-el))
+;; (lambda _ (next-method))))
diff --git a/module/calp/webdav/resource/virtual.scm b/module/calp/webdav/resource/virtual.scm
new file mode 100644
index 00000000..2fcaa76a
--- /dev/null
+++ b/module/calp/webdav/resource/virtual.scm
@@ -0,0 +1,70 @@
+(define-module (calp webdav resource virtual)
+ :use-module (oop goops)
+ :use-module (datetime)
+ :use-module (rnrs bytevectors)
+ :use-module (hnh util)
+ :use-module (sxml namespaced)
+ :use-module (calp webdav resource)
+ :use-module (calp webdav property)
+ :use-module (calp namespaces)
+ :export (<virtual-resource>
+ virtual-resource?
+ virtual-ns
+ ;; content
+ isvirtual
+ )
+ )
+
+(define virtual-ns (string->symbol "http://example.com/virtual"))
+
+(define-class <virtual-resource> (<resource>)
+ (content* init-value: #vu8()
+ init-keyword: content:
+ accessor: content*)
+ (creation-time init-form: (current-datetime)
+ init-keyword: creation-time:
+ getter: creation-time))
+
+(define (virtual-resource? x)
+ (is-a? x <virtual-resource>))
+
+(define-method (write (self <virtual-resource>) port)
+ (format port "#<<virtual-resource> name=~s, creation-time=~s, content=~s>"
+ (name self)
+ (creation-time self)
+ (content self)))
+
+(define-method (live-properties (self <virtual-resource>))
+ (append
+ (next-method)
+ (list (cons (xml-element-hash-key (xml virtual-ns 'isvirtual)) (make-live-property isvirtual set-isvirtual!)))))
+
+(define-method (content (self <virtual-resource>))
+ (content* self))
+
+(define-method (set-content! (self <virtual-resource>) data)
+ (set! (content* self) data))
+
+(define-method (creationdate (self <virtual-resource>))
+ (propstat 200
+ (list
+ (list (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"))))
+
+(define-method (isvirtual (self <virtual-resource>))
+ (propstat 200
+ (list
+ (list (xml virtual-ns 'isvirtual)
+ "true"))))
+
+
+(define-method (set-isvirtual! (self <virtual-resource>) _)
+ (throw 'protected-resource "isvirtual"))
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-26 17:09:50 +0200