blob: 5c2a6a9b9f08cf113f1664892838fb086c7d1c06 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
|
(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)))
)
|
