Rewrite test running system.

1 files changed, 92 insertions, 0 deletions

diff --git a/tests/unit/webdav/webdav-tree.scm b/tests/unit/webdav/webdav-tree.scm
new file mode 100644
index 00000000..da6073eb
--- /dev/null
+++ b/tests/unit/webdav/webdav-tree.scm
@@ -0,0 +1,92 @@
+(define-module (test webdav-tree)
+  :use-module (srfi srfi-64)
+  :use-module (srfi srfi-71)
+  :use-module (srfi srfi-88)
+  :use-module (calp webdav resource)
+  :use-module (calp webdav resource virtual)
+  :use-module (calp webdav resource file)
+  :use-module (oop goops)
+  :use-module (rnrs bytevectors)
+  :use-module (rnrs io ports)
+  :use-module ((hnh util) :select (sort*))
+  :use-module (hnh util path)
+  )
+
+(define* (pretty-print-tree tree
+                            optional: (formatter (lambda (el) (write el) (newline)))
+                            key: (depth 0))
+  (cond ((null? tree) 'noop)
+        ((pair? tree)
+         (display (make-string (* depth 2) #\space)) (formatter (car tree))
+         (for-each (lambda (el) (pretty-print-tree el formatter depth: (+ depth 1)))
+                   (cdr tree)))
+        (else (formatter tree))))
+
+(define-method (resource-tree (self <resource>))
+  (cons self
+        (map resource-tree (children self))))
+
+
+
+(define dir (mkdtemp (string-copy "/tmp/webdav-tree-XXXXXX")))
+(with-output-to-file (path-append dir "greeting")
+  (lambda () (display "Hello, World!\n")))
+
+(define root-resource (make <virtual-resource>
+                        name: "*root*"))
+
+(define virtual-resource (make <virtual-resource>
+                           name: "virtual"
+                           content: (string->bytevector "I'm Virtual!" (native-transcoder))))
+
+(define file-tree (make <file-resource>
+                    root: dir
+                    name: "files"))
+
+(mount-resource! root-resource file-tree)
+(mount-resource! root-resource virtual-resource)
+
+(test-equal "All resources in tree, along with href items"
+    (list (cons '() root-resource)
+          (cons '("files") file-tree)
+          (cons '("files" "greeting") (car (children file-tree)))
+          (cons '("virtual") virtual-resource))
+  (sort* (all-resources-under root-resource) string< (compose string-concatenate car)))
+
+
+
+;; (pretty-print-tree (resource-tree root-resource))
+
+
+
+;; (test-equal '("") (href root-resource) )                 ; /
+;; ;; (test-equal '("" "virtual") (href virtual-resource))     ; /virtual & /virtual/
+;; (test-equal '("virtual") (href virtual-resource))  ; /virtual & /virtual/
+;; ;; (test-equal '("" "files") (href file-tree))              ; /files & /files/
+;; (test-equal '("files") (href file-tree))           ; /files & /files/
+
+(test-eqv "Correct amount of children are mounted"
+  2 (length (children root-resource)))
+
+(test-eq "Lookup root"
+  root-resource (lookup-resource root-resource '()))
+
+(test-eq "Lookup of mount works (virtual)"
+  virtual-resource (lookup-resource root-resource '("virtual")))
+(test-eq "Lookup of mount works (files)"
+  file-tree (lookup-resource root-resource '("files")))
+
+;; (test-equal "File resource works as expected"
+;;   "/home/hugo/tmp"
+;;   (path file-tree))
+
+(let ((resource (lookup-resource root-resource (string->href "/files/greeting"))))
+  (test-assert (resource? resource))
+  (test-assert (file-resource? resource))
+  ;; (test-equal "/files/greeting" (href->string (href resource)))
+  (test-equal "Hello, World!\n" (bytevector->string (content resource) (native-transcoder)))
+ )
+
+'((calp webdav resource)
+  (calp webdav resource virtual)
+  (calp webdav resource file))