1 files changed, 91 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)))))