path: root/module/calp/webdav/resource/base.scm

(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))))