diff options
Diffstat (limited to 'tests/test/webdav-tree.scm')
-rw-r--r-- | tests/test/webdav-tree.scm | 89 |
1 files changed, 0 insertions, 89 deletions
diff --git a/tests/test/webdav-tree.scm b/tests/test/webdav-tree.scm deleted file mode 100644 index 5c2a6a9b..00000000 --- a/tests/test/webdav-tree.scm +++ /dev/null @@ -1,89 +0,0 @@ -(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))) - ) - |