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

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

ugarit: Starting to test the sexpr-stream engine

File size: 19.3 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 "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 "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 "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 "~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   (test-group "0-element sexpr stream"
204               (test-define "Create sexpr-stream writer" ssw (make-sexpr-stream-writer* a 't 'ti))
205               (test-define-values "Close sexpr-stream writer" (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
206               (test-assert "Sexpr stream did not already exist" (not ss-reused?))
207               (test "Correct hash"  "3293ac630c13f0245f92bbb1766e16167a4e58492dde73f3t" ss-hash)
208               (test "Sexpr stream reads back OK" '() (fold-sexpr-stream a ss-hash 't 'ti cons '()))
209
210               (if (archive-unlinkable? a)
211                   (begin
212                     (test-assert (archive-unlink! a ss-hash))
213                     (check-dir-is-empty store-path))))
214
215   (test-group "1-element sexpr stream"
216               (define test-list (list 1 2 3 4 5 6 7 8 9 10 11))
217               (define test-data (list->u8vector test-list))
218               (test-define "Archive hash" test-key ((archive-hash a) test-data 'test))
219               (test-define "Create sexpr-stream writer" ssw (make-sexpr-stream-writer* a 't 'ti))
220               (test "Write to sexpr stream" (void)
221                     ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f))))
222               (test-define-values "Close sexpr-stream writer" (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
223               (test-assert "Sexpr stream did not already exist" (not ss-reused?))
224               (test "Sexpr stream reads back OK"
225                     `((foo ,test-key))
226                     (fold-sexpr-stream a ss-hash 't 'ti cons '()))
227
228               (if (archive-unlinkable? a)
229                   (begin
230                     (test "Unlink sexpr stream" (void)
231                           (unlink-sexpr-stream! a ss-hash 't 'ti
232                                                 (lambda (sexpr)
233                                                   (test "Correct entry read back" `(foo ,test-key) (identity sexpr))
234                                                   (test "Unlink entry" #f (archive-unlink! a test-key)))))
235                     (test-assert "Sexpr stream is gone" (not (archive-exists? a ss-hash)))
236                     (test-assert "Test block is gone" (not (archive-exists? a test-key)))
237                     (check-dir-is-empty store-path))))
238
239#|
240
241   (printf "1-element sexpr stream...\n")
242   (define test-list (list 1 2 3 4 5 6 7 8 9 10 11))
243   (define test-data (list->u8vector test-list))
244   (define test-key ((archive-hash a) test-data 'test))
245   (define ssw (make-sexpr-stream-writer* a 't 'ti))
246   (archive-put! a test-key test-data 'test)
247   ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f)))
248   (define-values (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
249   (assert (not ss-reused?))
250   (define sexprs (fold-sexpr-stream archive ss-hash 't 'ti cons '()))
251   (assert (equal? sexprs `((foo ,test-key))))
252   (if (archive-unlinkable? a)
253      (begin
254         (unlink-sexpr-stream! archive ss-hash 't 'ti
255            (lambda (sexpr)
256               (assert (equal? sexpr `(foo ,test-key)))
257               (archive-unlink! archive test-key)))
258         (assert (not (archive-exists? archive ss-hash)))
259         (assert (not (archive-exists? archive test-key)))
260         (check-dir-is-empty store-path)))
261
262   (printf "2-element sexpr stream...\n")
263   (define test-list (list 1 2 3 4 5 6 7 8 9 10 11 12))
264   (define test-data (list->u8vector test-list))
265   (define test-key ((archive-hash a) test-data 'test))
266   (define ssw (make-sexpr-stream-writer* a 't 'ti))
267   (archive-put! a test-key test-data 'test)
268   ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f)))
269   ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f)))
270   (define-values (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
271   (assert (not ss-reused?))
272   (define sexprs (fold-sexpr-stream archive ss-hash 't 'ti cons '()))
273   (assert (equal? sexprs `((foo ,test-key) (foo ,test-key))))
274
275   (if (archive-unlinkable? a)
276      (begin
277         (unlink-sexpr-stream! archive ss-hash 't 'ti
278            (lambda (sexpr)
279               (assert (equal? sexpr `(foo ,test-key)))
280               (archive-unlink! archive test-key)))
281         (assert (not (archive-exists? archive ss-hash)))
282         (assert (not (archive-exists? archive test-key)))
283         (check-dir-is-empty store-path)))
284   
285   (printf "~A-element sexpr stream...\n" iterations)
286   (define test-list (list 1 2 3 4 5 6 7 8 9 10 11 12 13))
287   (define test-data (list->u8vector test-list))
288   (define test-key ((archive-hash a) test-data 'test))
289   (define ssw (make-sexpr-stream-writer* a 't 'ti))
290   (archive-put! a test-key test-data 'test)
291   (dotimes (iter iterations)
292      ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f))))
293   (define-values (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
294   (assert (not ss-reused?))
295   (define sexprs (fold-sexpr-stream archive ss-hash 't 'ti cons '()))
296   (assert (= (length sexprs) iterations))
297   (assert (every
298      (lambda (sexpr) (equal? sexpr `(foo ,test-key)))
299      sexprs))
300
301   ;(sexpr-stream-cat a ss-hash 't 'ti 0)
302
303   (if (archive-unlinkable? a)
304      (begin
305         (unlink-sexpr-stream! archive ss-hash 't 'ti
306            (lambda (sexpr)
307               (assert (equal? sexpr `(foo ,test-key)))
308               (archive-unlink! archive test-key)))
309   
310         (assert (not (archive-exists? archive test-key)))
311         (check-dir-is-empty store-path)))
312   
313   (printf "files...\n")
314   (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.")
315   
316   (printf "\tStore a file\n")
317   (define-values (file-key file-reused?)
318      (with-input-from-string test-string (lambda ()
319         (store-file! archive))))
320
321   (printf "\tRead it back\n")
322   (define result (with-output-to-string
323      (lambda ()
324         (write-file-contents archive file-key))))
325   
326   (assert (string=? test-string result))
327   
328   (if (archive-unlinkable? a)
329      (begin
330         (printf "\tDelete the file\n")
331         (unlink-file! archive file-key)
332         (check-dir-is-empty store-path)))
333   
334   (printf "directories...\n")
335   
336   (printf "\tStore a directory\n")
337   
338   (define-values (dir-key dir-reused?)
339      (store-directory! archive "test-data"))
340
341   (printf "\tExtract the directory\n")
342   (create-directory (string-append store-path "-extract"))
343   (extract-directory! archive dir-key (string-append store-path "-extract"))
344   
345   (if (archive-unlinkable? a)
346      (begin
347         (printf "\tDelete the directory\n")
348         (unlink-directory! archive dir-key)
349         (check-dir-is-empty store-path)))
350   
351   (printf "snapshots\n")
352
353   (printf "\tStore a directory\n")
354   
355   (define-values (dir-key dir-reused?)
356      (store-directory! archive "test-data"))
357
358   (if (archive-unlinkable? a)
359      (assert (not dir-reused?)))
360
361   (printf "\tTag it (~A ~A)\n" dir-key dir-reused?)
362   (define sk1 (tag-snapshot! archive "Test" dir-key dir-reused? (list)))
363   
364   (printf "\tStore another directory\n")
365
366   (define-values (dir-key-two dir-reused?)
367      (store-directory! archive "test-data"))
368   
369   (assert dir-reused?)
370   (assert (string=? dir-key dir-key-two))
371   
372   (printf "\tTag it (~A ~A)\n" dir-key  dir-reused?)
373   (define sk1 (tag-snapshot! archive "Test" dir-key-two dir-reused? (list)))
374   
375   (printf "\tWalk the history\n")
376   
377   (define result
378      (fold-history archive (archive-tag archive "Test")
379         (lambda (snapshot-key snapshot acc)
380            (cons snapshot acc))
381         '()))
382   (assert (match result
383     (((('previous . sk1)
384        ('mtime . _)
385        ('contents . dir-key-two))
386       (('mtime . _)
387        ('contents . dir-key))) #t)
388     (else #f)))
389   
390   ;(printf "\tTest fold-archive-node\n")
391   ;
392   ;(printf "Root: \n") (pp (fold-archive-node archive '() (lambda (name dirent acc) (cons (cons name dirent) acc)) '()))
393   ;(printf "Tag 'Test': \n") (pp (fold-archive-node archive (cons 'tag "Test") (lambda (name dirent acc) (cons (cons name dirent) acc))  '()))
394   ;(printf "Root directory: \n") (pp (fold-archive-node archive dir-key (lambda (name dirent acc) (cons (cons name dirent) acc))  '()))
395   
396|#
397
398   "This archive seems to work!")
399
400
401;; Actual Tests
402
403(create-directory "./tmp")
404
405(test-group "Filesystem backend"
406 (create-directory "./tmp/be1")
407 (test-define "Open storage" be (import-storage "backend-fs fs ./tmp/be1"))
408 (test-backend be)
409 (test "Close storage" (void) ((storage-close! be))))
410
411(test-group "Log backend"
412 (create-directory "./tmp/be2")
413 (test-define "Open storage" be (import-storage "backend-fs log ./tmp/be2/log ./tmp/be2/index ./tmp/be2/tags"))
414 (test-backend be)
415 (test "Close storage" (void) ((storage-close! be))))
416
417(test-group "Splitlog backend"
418 (create-directory "./tmp/be3")
419 (test-define "Open storage" be (import-storage "backend-fs splitlog ./tmp/be3 ./tmp/be3 1024"))
420 (test-backend be)
421 (test "Close storage" (void) ((storage-close! be))))
422
423(test-group "Limited cached splitlog backend"
424 (create-directory "./tmp/be4")
425 (test-define "Open storage" be (import-storage "backend-fs splitlog ./tmp/be4 ./tmp/be4 1024"))
426 (test-define "Wrap in cache" cbe (backend-cache be "./tmp/be4-cache"))
427 (test-define "Wrap in block-limiter" lbe (backend-limit-block-size cbe 1024))
428 (test-backend lbe)
429 (test "Close storage" (void) ((storage-close! lbe))))
430
431(test-group "Filesystem backend archive"
432 (create-directory "./tmp/be5")
433 (test-define "Open archive" be (open-archive '((storage "backend-fs fs ./tmp/be5")) #f #t))
434 (test-archive be "./tmp/be5")
435 (test "Close archive" (void) (archive-close! be)))
436
437(test-group "Log backend archive"
438 (create-directory "./tmp/be6")
439 (test-define "Open archive" be (open-archive '((storage  "backend-fs log ./tmp/be6/log ./tmp/be6/index ./tmp/be6/tags")) #f #t))
440 (test-archive be "./tmp/be6")
441 (test "Close archive" (void) (archive-close! be)))
442
443(test-group "Splitlog backend archive"
444 (create-directory "./tmp/be7")
445 (test-define "Open archive" be (open-archive '((storage  "backend-fs splitlog ./tmp/be7 ./tmp/be7 1024")) #f #t))
446 (test-archive be "./tmp/be7")
447 (test "Close archive" (void) (archive-close! be)))
448
449(test-exit)
Note: See TracBrowser for help on using the repository browser.