source: project/release/4/ugarit/trunk/test/run.scm @ 22219

Last change on this file since 22219 was 22219, checked in by Alaric Snell-Pym, 11 years ago

ugarit: Porting old test.scm -> test/run.scm

File size: 18.1 KB
Line 
1(use ugarit-core)
2(use miscmacros)
3(use ugarit-backend)
4(use test)
5
6(include "../backend-devtools.scm")
7(include "../backend-cache.scm")
8
9;; Test egg extensions
10
11(define-syntax test-no-errors
12  (syntax-rules ()
13    ((_ expr)
14     (test-no-errors (->string expr) expr))
15    ((_ name expr)
16     (test name (void) (begin expr (void))))))
17
18(define-syntax test-define
19  (syntax-rules ()
20    ((_ var expr)
21     (test-define (->string '(define var expr)) var expr))
22    ((_ name var expr)
23     (begin
24       (define var (void))
25       (test-no-errors name (set! var expr))))))
26
27(define-syntax test-define-values
28  (syntax-rules ()
29    ((_ (var ...) expr)
30     (test-define-values (->string '(define-values (var ...) expr)) (var ...) expr))
31    ((_ name (var ...) expr)
32     (begin
33       (define var (void)) ...
34       (test-no-errors name (set!-values (var ...) expr))))))
35
36;; Test utilities
37
38(define (test-backend w)
39   (test-assert "Storage writable" (storage-writable? w))
40   (test-assert "Storage is empty" (not ((storage-exists? w) "TEST")))
41   (test "Load a block" (void) ((storage-put! w) "TEST" (list->u8vector (list 1 2 3 4 5)) 'test))
42   (test-assert "Block successfully loaded" ((storage-exists? w) "TEST"))
43   (test "Block contents reads back" (list 1 2 3 4 5) (u8vector->list ((storage-get w) "TEST")))
44   (if (storage-unlinkable? w)
45      (begin
46         (test "Unlink returns data" (list 1 2 3 4 5) (u8vector->list ((storage-unlink! w) "TEST")))
47         (test-assert "Unlinked block is gone" (not ((storage-exists? w) "TEST")))))
48   (test "Set a tag" (void) ((storage-set-tag! w) "TEST" "TEST123"))
49   (test "Tag reads back" "TEST123" ((storage-tag w) "TEST"))
50   (test "Tag list works" (list "TEST") ((storage-all-tags w)))
51   (test "Remove tag" (void)  ((storage-remove-tag! w) "TEST")))
52
53(define (key-stream-cat a ks-hash ks-type level)
54   (define type (archive-exists? a ks-hash))
55   (if (eq? type ks-type)
56      (begin
57         (printf "ks(~A): ~A (~A)\n" level ks-hash type)
58            (for-each (lambda (subkey)
59               (key-stream-cat a subkey ks-type (+ level 1)))
60               (deserialise-key-stream (archive-get a ks-hash))))
61      (printf "kleaf(~A): ~A (~A)\n" level ks-hash type)))
62
63(define (sexpr-stream-cat a ss-hash leaf-type ss-type level)
64   (define type (archive-exists? a ss-hash))
65   (test-assert "sexpr stream internal consistency" (or (eq? type ss-type) (eq? type leaf-type)))
66   (cond
67      ((eq? type ss-type)
68         (begin ; key stream node
69            (printf "ss(~A): ~A (~A)\n" level ss-hash type)
70               (for-each (lambda (subkey)
71                  (sexpr-stream-cat a subkey leaf-type ss-type (+ level 1)))
72                  (deserialise-key-stream (archive-get a ss-hash)))))
73      ((eq? type leaf-type)
74         (begin ; leaf node
75            (printf "sleaf(~A): ~A (~A)\n" level ss-hash type)
76               (for-each (lambda (sexpr)
77                  (printf " ~A\n" sexpr))
78                  (deserialise-sexpr-stream (archive-get a ss-hash)))))))
79
80(define (check-dir-is-empty store-path)
81   (test-assert "Archive is in initial state" (null? (directory store-path))))
82
83(define (test-archive a store-path)
84   (if (archive-unlinkable? a)
85      (check-dir-is-empty store-path)) ; Precondition
86
87   (test-group "Basic archive operations"
88               (define test-list (list 1 2 3 4 5))
89               (define test-data (list->u8vector test-list))
90               (test-define "Archive hash" test-key ((archive-hash a) test-data 'test))
91               (test-assert "Archive is writable" (archive-writable? a))
92               (test-assert "Key does not already exist" (not (archive-exists? a test-key)))
93               (test "Data goes into archive" (void) (archive-put! a test-key test-data 'test))
94               (test-assert "Data now exists in archive" (archive-exists? a test-key))
95               (test "Data reads back" test-list (u8vector->list (archive-get a test-key)))
96
97               (if (archive-unlinkable? a)
98                   (begin
99                     (test "Unlink returns data" test-list (u8vector->list (archive-unlink! a test-key)))
100                     (test-assert "Unlinked data is gone" (not (archive-exists? a test-key)))))
101               (test "Tag setting" (void) (archive-set-tag! a "TEST" test-key))
102               (test "Tag reading" test-key (archive-tag a "TEST"))
103               (test "Tag listing" (list "TEST") (archive-all-tags a))
104               (test "Tag removal" (void) (archive-remove-tag! a "TEST"))
105               (if (archive-unlinkable? a)
106                   (check-dir-is-empty store-path)))
107
108   (test-group "Testing 0-element key stream"
109               (define test-list (list 1 2 3 4 5 6))
110               (define test-data (list->u8vector test-list))
111               (test-define "Archive hash" test-key ((archive-hash a) test-data 'test))
112               (test-define "Create key-stream writer" ksw (make-key-stream-writer* a 'test-ks))
113               (test-define-values "Close key-stream writer" (ks-hash ks-reused?) ((key-stream-writer-finish! ksw)))
114               (test-assert "Key stream did not already exist" (not ks-reused?))
115               (test "Correct hash"  "3293ac630c13f0245f92bbb1766e16167a4e58492dde73f3test-ks" ks-hash)
116               (test "Key stream reads back OK" '() (fold-key-stream a ks-hash 'test-ks cons '()))
117
118               (if (archive-unlinkable? a)
119                   (begin
120                     (test-assert (archive-unlink! a ks-hash))
121                     (check-dir-is-empty store-path))))
122
123   (test-group "Testing 1-element key stream...\n"
124               (define test-list (list 1 2 3 4 5 6 7))
125               (define test-data (list->u8vector test-list))
126               (test-define "Archive hash" test-key ((archive-hash a) test-data 'test))
127               (test-define "Create key-stream writer" ksw (make-key-stream-writer* a 'test-ks))
128               (test "Store a block into the archive" (void) (archive-put! a test-key test-data 'test))
129               (test "Insert hash into key stream" (void) ((key-stream-writer-write! ksw) test-key #f))
130               (test-define-values "Close key-stream writer" (ks-hash ks-reused?) ((key-stream-writer-finish! ksw)))
131               (test-assert "Key stream did not already exist" (not ks-reused?))
132               (test "Correct hash" test-key ks-hash)
133
134               (test "Correct result from reading back key stream"
135                     (list (cons test-key 'test))
136                     (fold-key-stream a ks-hash 'test-ks
137                                      (lambda (key type acc)
138                                        (cons (cons key type) acc)) '()))
139
140               (if (archive-unlinkable? a)
141                   (begin
142                     (test-assert (archive-unlink! a test-key))
143                     (check-dir-is-empty store-path))))
144
145   (test-group "Testing 2-element key stream...\n"
146               (define test-list (list 1 2 3 4 5 6 7 8))
147               (define test-data (list->u8vector test-list))
148               (test-define "Archive hash" test-key ((archive-hash a) test-data 'test))
149               (test-define "Create key-stream writer" ksw (make-key-stream-writer* a 'test-ks))
150               (test "Store a block into the archive" (void) (archive-put! a test-key test-data 'test))
151               (test "Insert hash 1 into key stream" (void) ((key-stream-writer-write! ksw) test-key #f))
152               (test "Insert hash 2 into key stream" (void) ((key-stream-writer-write! ksw) test-key #t))
153               (test-define-values "Close key-stream writer" (ks-hash ks-reused?) ((key-stream-writer-finish! ksw)))
154               (test-assert "Key stream did not already exist" (not ks-reused?))
155               (test-assert "Key stream now exists" (archive-exists? a ks-hash))
156
157               (test "Correct result from reading back key stream"
158                     (list (cons test-key 'test) (cons test-key 'test))
159                     (fold-key-stream a ks-hash 'test-ks
160                                      (lambda (key type acc)
161                                        (cons (cons key type) acc)) '()))
162
163               (if (archive-unlinkable? a)
164                   (begin
165                     (test-assert (archive-unlink! a ks-hash))
166                     (test-assert (not (archive-unlink! a test-key)))
167                     (test-assert (archive-unlink! a test-key))
168                     (check-dir-is-empty store-path))))
169
170   (define iterations 1024)
171   (test-group (sprintf "Testing ~a-element key stream..." iterations)
172               (define test-list (list 1 2 3 4 5 6 7 8 9))
173               (define test-data (list->u8vector test-list))
174               (test-define "Archive hash" test-key ((archive-hash a) test-data 'test))
175               (test-define "Create key-stream writer" ksw (make-key-stream-writer* a 'test-ks))
176               (test "Store a block into the archive" (void) (archive-put! a test-key test-data 'test))
177               (test "Insert hash 1 into key stream" (void) ((key-stream-writer-write! ksw) test-key #t)) ; Ensure one reference is left at the end
178               (test "Insert more hashes into key stream" (void)
179                     (dotimes (iter iterations)
180                              ((key-stream-writer-write! ksw) test-key #t)))
181               (test-define-values "Close key-stream writer" (ks-hash ks-reused?) ((key-stream-writer-finish! ksw)))
182               (test-assert "Key stream did not already exist" (not ks-reused?))
183               (test-assert "Key stream now exists" (archive-exists? a ks-hash))
184
185               (test-define "Key stream reads back OK" keys
186                            (fold-key-stream a ks-hash 'test-ks
187                                             (lambda (key type acc)
188                                               (cons (cons key type) acc)) '()))
189               (test "Correct number of keys come back" (+ 1 iterations) (length keys))
190               (test-assert "Correct keys come back" (every
191                                                      (lambda (key) (string=? (car key) test-key))
192                                                      keys))
193
194               (if (archive-unlinkable? a)
195                   (begin
196                     (test "Unlink key stream" (void)
197                           (unlink-key-stream! a ks-hash 'test-ks
198                                               (lambda (archive key type)
199                                                 (test-assert "Unlink non-final block" (not (archive-unlink! archive key))))))
200                     (test-assert "Unlink final block" (archive-unlink! a test-key))
201                     (check-dir-is-empty store-path))))
202#|
203   (printf "Testing 0-element sexpr stream...\n")
204   (define test-list (list 1 2 3 4 5 6 7 8 9 10))
205   (define test-data (list->u8vector test-list))
206   (define test-key ((archive-hash a) test-data 'test))
207   (define ssw (make-sexpr-stream-writer* a 't 'ti))
208   (define-values (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
209   (assert (not ss-reused?))
210   (assert (string=? ss-hash "3293ac630c13f0245f92bbb1766e16167a4e58492dde73f3t"))
211   (assert (equal? (fold-sexpr-stream archive ss-hash 't 'ti cons '()) '()))
212   (if (archive-unlinkable? a)
213      (begin
214         (assert (archive-unlink! a ss-hash))
215         (check-dir-is-empty store-path)))
216
217   (printf "Testing 1-element sexpr stream...\n")
218   (define test-list (list 1 2 3 4 5 6 7 8 9 10 11))
219   (define test-data (list->u8vector test-list))
220   (define test-key ((archive-hash a) test-data 'test))
221   (define ssw (make-sexpr-stream-writer* a 't 'ti))
222   (archive-put! a test-key test-data 'test)
223   ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f)))
224   (define-values (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
225   (assert (not ss-reused?))
226   (define sexprs (fold-sexpr-stream archive ss-hash 't 'ti cons '()))
227   (assert (equal? sexprs `((foo ,test-key))))
228   (if (archive-unlinkable? a)
229      (begin
230         (unlink-sexpr-stream! archive ss-hash 't 'ti
231            (lambda (sexpr)
232               (assert (equal? sexpr `(foo ,test-key)))
233               (archive-unlink! archive test-key)))
234         (assert (not (archive-exists? archive ss-hash)))
235         (assert (not (archive-exists? archive test-key)))
236         (check-dir-is-empty store-path)))
237
238   (printf "Testing 2-element sexpr stream...\n")
239   (define test-list (list 1 2 3 4 5 6 7 8 9 10 11 12))
240   (define test-data (list->u8vector test-list))
241   (define test-key ((archive-hash a) test-data 'test))
242   (define ssw (make-sexpr-stream-writer* a 't 'ti))
243   (archive-put! a test-key test-data 'test)
244   ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f)))
245   ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f)))
246   (define-values (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
247   (assert (not ss-reused?))
248   (define sexprs (fold-sexpr-stream archive ss-hash 't 'ti cons '()))
249   (assert (equal? sexprs `((foo ,test-key) (foo ,test-key))))
250
251   (if (archive-unlinkable? a)
252      (begin
253         (unlink-sexpr-stream! archive ss-hash 't 'ti
254            (lambda (sexpr)
255               (assert (equal? sexpr `(foo ,test-key)))
256               (archive-unlink! archive test-key)))
257         (assert (not (archive-exists? archive ss-hash)))
258         (assert (not (archive-exists? archive test-key)))
259         (check-dir-is-empty store-path)))
260   
261   (printf "Testing ~A-element sexpr stream...\n" iterations)
262   (define test-list (list 1 2 3 4 5 6 7 8 9 10 11 12 13))
263   (define test-data (list->u8vector test-list))
264   (define test-key ((archive-hash a) test-data 'test))
265   (define ssw (make-sexpr-stream-writer* a 't 'ti))
266   (archive-put! a test-key test-data 'test)
267   (dotimes (iter iterations)
268      ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f))))
269   (define-values (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
270   (assert (not ss-reused?))
271   (define sexprs (fold-sexpr-stream archive ss-hash 't 'ti cons '()))
272   (assert (= (length sexprs) iterations))
273   (assert (every
274      (lambda (sexpr) (equal? sexpr `(foo ,test-key)))
275      sexprs))
276
277   ;(sexpr-stream-cat a ss-hash 't 'ti 0)
278
279   (if (archive-unlinkable? a)
280      (begin
281         (unlink-sexpr-stream! archive ss-hash 't 'ti
282            (lambda (sexpr)
283               (assert (equal? sexpr `(foo ,test-key)))
284               (archive-unlink! archive test-key)))
285   
286         (assert (not (archive-exists? archive test-key)))
287         (check-dir-is-empty store-path)))
288   
289   (printf "Testing files...\n")
290   (define test-string "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.")
291   
292   (printf "\tStore a file\n")
293   (define-values (file-key file-reused?)
294      (with-input-from-string test-string (lambda ()
295         (store-file! archive))))
296
297   (printf "\tRead it back\n")
298   (define result (with-output-to-string
299      (lambda ()
300         (write-file-contents archive file-key))))
301   
302   (assert (string=? test-string result))
303   
304   (if (archive-unlinkable? a)
305      (begin
306         (printf "\tDelete the file\n")
307         (unlink-file! archive file-key)
308         (check-dir-is-empty store-path)))
309   
310   (printf "Testing directories...\n")
311   
312   (printf "\tStore a directory\n")
313   
314   (define-values (dir-key dir-reused?)
315      (store-directory! archive "test-data"))
316
317   (printf "\tExtract the directory\n")
318   (create-directory (string-append store-path "-extract"))
319   (extract-directory! archive dir-key (string-append store-path "-extract"))
320   
321   (if (archive-unlinkable? a)
322      (begin
323         (printf "\tDelete the directory\n")
324         (unlink-directory! archive dir-key)
325         (check-dir-is-empty store-path)))
326   
327   (printf "Testing snapshots\n")
328
329   (printf "\tStore a directory\n")
330   
331   (define-values (dir-key dir-reused?)
332      (store-directory! archive "test-data"))
333
334   (if (archive-unlinkable? a)
335      (assert (not dir-reused?)))
336
337   (printf "\tTag it (~A ~A)\n" dir-key dir-reused?)
338   (define sk1 (tag-snapshot! archive "Test" dir-key dir-reused? (list)))
339   
340   (printf "\tStore another directory\n")
341
342   (define-values (dir-key-two dir-reused?)
343      (store-directory! archive "test-data"))
344   
345   (assert dir-reused?)
346   (assert (string=? dir-key dir-key-two))
347   
348   (printf "\tTag it (~A ~A)\n" dir-key  dir-reused?)
349   (define sk1 (tag-snapshot! archive "Test" dir-key-two dir-reused? (list)))
350   
351   (printf "\tWalk the history\n")
352   
353   (define result
354      (fold-history archive (archive-tag archive "Test")
355         (lambda (snapshot-key snapshot acc)
356            (cons snapshot acc))
357         '()))
358   (assert (match result
359     (((('previous . sk1)
360        ('mtime . _)
361        ('contents . dir-key-two))
362       (('mtime . _)
363        ('contents . dir-key))) #t)
364     (else #f)))
365   
366   ;(printf "\tTest fold-archive-node\n")
367   ;
368   ;(printf "Root: \n") (pp (fold-archive-node archive '() (lambda (name dirent acc) (cons (cons name dirent) acc)) '()))
369   ;(printf "Tag 'Test': \n") (pp (fold-archive-node archive (cons 'tag "Test") (lambda (name dirent acc) (cons (cons name dirent) acc))  '()))
370   ;(printf "Root directory: \n") (pp (fold-archive-node archive dir-key (lambda (name dirent acc) (cons (cons name dirent) acc))  '()))
371   
372|#
373
374   "This archive seems to work!")
375
376
377;; Actual Tests
378
379(create-directory "./tmp")
380
381(test-group "Filesystem backend"
382 (create-directory "./tmp/be1")
383 (test-define "Open storage" be (import-storage "backend-fs fs ./tmp/be1"))
384 (test-backend be)
385 (test "Close storage" (void) ((storage-close! be))))
386
387(test-group "Log backend"
388 (create-directory "./tmp/be2")
389 (test-define "Open storage" be (import-storage "backend-fs log ./tmp/be2/log ./tmp/be2/index ./tmp/be2/tags"))
390 (test-backend be)
391 (test "Close storage" (void) ((storage-close! be))))
392
393(test-group "Splitlog backend"
394 (create-directory "./tmp/be3")
395 (test-define "Open storage" be (import-storage "backend-fs splitlog ./tmp/be3 ./tmp/be3 1024"))
396 (test-backend be)
397 (test "Close storage" (void) ((storage-close! be))))
398
399(test-group "Limited cached splitlog backend"
400 (create-directory "./tmp/be4")
401 (test-define "Open storage" be (import-storage "backend-fs splitlog ./tmp/be4 ./tmp/be4 1024"))
402 (test-define "Wrap in cache" cbe (backend-cache be "./tmp/be4-cache"))
403 (test-define "Wrap in block-limiter" lbe (backend-limit-block-size cbe 1024))
404 (test-backend lbe)
405 (test "Close storage" (void) ((storage-close! lbe))))
406
407(test-group "Filesystem backend archive"
408 (create-directory "./tmp/be5")
409 (test-define "Open archive" be (open-archive '((storage "backend-fs fs ./tmp/be5")) #f #t))
410 (test-archive be "./tmp/be5")
411 (test "Close archive" (void) (archive-close! be)))
412
413(test-group "Log backend archive"
414 (create-directory "./tmp/be6")
415 (test-define "Open archive" be (open-archive '((storage  "backend-fs log ./tmp/be6/log ./tmp/be6/index ./tmp/be6/tags")) #f #t))
416 (test-archive be "./tmp/be6")
417 (test "Close archive" (void) (archive-close! be)))
418
419(test-group "Splitlog backend archive"
420 (create-directory "./tmp/be7")
421 (test-define "Open archive" be (open-archive '((storage  "backend-fs splitlog ./tmp/be7 ./tmp/be7 1024")) #f #t))
422 (test-archive be "./tmp/be7")
423 (test "Close archive" (void) (archive-close! be)))
424
425(test-exit)
Note: See TracBrowser for help on using the repository browser.