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

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

ugarit: Ongoing test development, and removed the version number

  • Salmonella seems to complain that we have version 0.7 declared, but we're building from trunk, so I commented out the version numbers. When the tests are complete, I'll tag it as v1.0 anyway.
  • sexpr stream tests are now complete
  • file store/restore tests are complete
  • directory operation tests are still to be ported
  • mtime caching tests are still to be written in the first place
File size: 19.4 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   (test-group "2-element sexpr stream"
240               (define test-list (list 1 2 3 4 5 6 7 8 9 10 11 12))
241               (define test-data (list->u8vector test-list))
242               (test-define "Archive hash" test-key ((archive-hash a) test-data 'test))
243               (test "Archive write" (void) (archive-put! a test-key test-data 'test))
244               (test-define "Create sexpr-stream writer" ssw (make-sexpr-stream-writer* a 't 'ti))
245               (test "Write to sexpr stream" (void)
246                     ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f))))
247               (test "Write to sexpr stream" (void)
248                     ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #t))))
249               (test-define-values "Close sexpr-stream writer" (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
250               (test-assert "Sexpr stream did not already exist" (not ss-reused?))
251               (test "Sexpr stream reads back OK"
252                     `((foo ,test-key) (foo ,test-key))
253                     (fold-sexpr-stream a ss-hash 't 'ti cons '()))
254
255               (if (archive-unlinkable? a)
256                   (begin
257                     (define unlinks 0)
258
259                     (test "Unlink sexpr stream" (void)
260                           (unlink-sexpr-stream! a ss-hash 't 'ti
261                                                 (lambda (sexpr)
262                                                   (test "Correct entry read back" `(foo ,test-key) (identity sexpr))
263                                                   (test (sprintf "Unlink entry ~a" unlinks) (if (zero? unlinks) #f test-data) (archive-unlink! a test-key))
264                                                   (set! unlinks (+ unlinks 1)))))
265                     (test-assert "Sexpr stream is gone" (not (archive-exists? a ss-hash)))
266                     (test-assert "Test block is gone" (not (archive-exists? a test-key)))
267                     (check-dir-is-empty store-path))))
268
269   (test-group (sprintf "~A-element sexpr stream" iterations)
270               (define test-list (list 1 2 3 4 5 6 7 8 9 10 11 12 13))
271               (define test-data (list->u8vector test-list))
272               (test-define "Archive hash" test-key ((archive-hash a) test-data 'test))
273               (test "Archive write" (void) (archive-put! a test-key test-data 'test))
274               (test-define "Create sexpr-stream writer" ssw (make-sexpr-stream-writer* a 't 'ti))
275               ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f)))
276               (dotimes (iter iterations)
277                        (test "Write to sexpr stream" (void)
278                     ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #t)))))
279               (test-define-values "Close sexpr-stream writer" (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
280               (test-assert "Sexpr stream did not already exist" (not ss-reused?))
281               (test-define "Sexpr stream reads back OK" sexprs
282                            (fold-sexpr-stream a ss-hash 't 'ti cons '()))
283               (test "Correct number of sexprs read back" (+ 1 iterations) (length sexprs))
284               (test-assert "Correct sexprs read back"
285                            (every
286                             (lambda (sexpr) (equal? sexpr `(foo ,test-key)))
287                            sexprs))
288
289               (if (archive-unlinkable? a)
290                   (begin
291                     (define unlinks 0)
292
293                     (test "Unlink sexpr stream" (void)
294                           (unlink-sexpr-stream! a ss-hash 't 'ti
295                                                 (lambda (sexpr)
296                                                   (test "Correct entry read back" `(foo ,test-key) (identity sexpr))
297                                                   (test (sprintf "Unlink entry ~a" unlinks) (if (< unlinks iterations) #f test-data) (archive-unlink! a test-key))
298                                                   (set! unlinks (+ unlinks 1)))))
299                     (test-assert "Sexpr stream is gone" (not (archive-exists? a ss-hash)))
300                     (test-assert "Test block is gone" (not (archive-exists? a test-key)))
301                     (check-dir-is-empty store-path))))
302
303   (test-group "Files"
304               (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.")
305
306   (test-define-values "Store a file" (file-key file-reused?)
307                       (with-input-from-string test-string (lambda ()
308                                                             (store-file! a "/test-file" (vector 0 0 0 0 0 0 0 0 0 0 0 0 0)))))
309
310
311   (test "Read it back" test-string
312         (with-output-to-string
313           (lambda ()
314             (write-file-contents a file-key))))
315   
316   (if (archive-unlinkable? a)
317      (begin
318         (test "Delete the file" (void) (unlink-file! archive file-key))
319         (check-dir-is-empty store-path))))
320#|
321   
322   
323   (printf "directories...\n")
324   
325   (printf "\tStore a directory\n")
326   
327   (define-values (dir-key dir-reused?)
328      (store-directory! archive "test-data"))
329
330   (printf "\tExtract the directory\n")
331   (create-directory (string-append store-path "-extract"))
332   (extract-directory! archive dir-key (string-append store-path "-extract"))
333   
334   (if (archive-unlinkable? a)
335      (begin
336         (printf "\tDelete the directory\n")
337         (unlink-directory! archive dir-key)
338         (check-dir-is-empty store-path)))
339   
340   (printf "snapshots\n")
341
342   (printf "\tStore a directory\n")
343   
344   (define-values (dir-key dir-reused?)
345      (store-directory! archive "test-data"))
346
347   (if (archive-unlinkable? a)
348      (assert (not dir-reused?)))
349
350   (printf "\tTag it (~A ~A)\n" dir-key dir-reused?)
351   (define sk1 (tag-snapshot! archive "Test" dir-key dir-reused? (list)))
352   
353   (printf "\tStore another directory\n")
354
355   (define-values (dir-key-two dir-reused?)
356      (store-directory! archive "test-data"))
357   
358   (assert dir-reused?)
359   (assert (string=? dir-key dir-key-two))
360   
361   (printf "\tTag it (~A ~A)\n" dir-key  dir-reused?)
362   (define sk1 (tag-snapshot! archive "Test" dir-key-two dir-reused? (list)))
363   
364   (printf "\tWalk the history\n")
365   
366   (define result
367      (fold-history archive (archive-tag archive "Test")
368         (lambda (snapshot-key snapshot acc)
369            (cons snapshot acc))
370         '()))
371   (assert (match result
372     (((('previous . sk1)
373        ('mtime . _)
374        ('contents . dir-key-two))
375       (('mtime . _)
376        ('contents . dir-key))) #t)
377     (else #f)))
378   
379   ;(printf "\tTest fold-archive-node\n")
380   ;
381   ;(printf "Root: \n") (pp (fold-archive-node archive '() (lambda (name dirent acc) (cons (cons name dirent) acc)) '()))
382   ;(printf "Tag 'Test': \n") (pp (fold-archive-node archive (cons 'tag "Test") (lambda (name dirent acc) (cons (cons name dirent) acc))  '()))
383   ;(printf "Root directory: \n") (pp (fold-archive-node archive dir-key (lambda (name dirent acc) (cons (cons name dirent) acc))  '()))
384   
385|#
386
387   "This archive seems to work!")
388
389
390;; Actual Tests
391
392(create-directory "./tmp")
393
394(test-group "Filesystem backend"
395 (create-directory "./tmp/be1")
396 (test-define "Open storage" be (import-storage "backend-fs fs ./tmp/be1"))
397 (test-backend be)
398 (test "Close storage" (void) ((storage-close! be))))
399
400(test-group "Log backend"
401 (create-directory "./tmp/be2")
402 (test-define "Open storage" be (import-storage "backend-fs log ./tmp/be2/log ./tmp/be2/index ./tmp/be2/tags"))
403 (test-backend be)
404 (test "Close storage" (void) ((storage-close! be))))
405
406(test-group "Splitlog backend"
407 (create-directory "./tmp/be3")
408 (test-define "Open storage" be (import-storage "backend-fs splitlog ./tmp/be3 ./tmp/be3 1024"))
409 (test-backend be)
410 (test "Close storage" (void) ((storage-close! be))))
411
412(test-group "Limited cached splitlog backend"
413 (create-directory "./tmp/be4")
414 (test-define "Open storage" be (import-storage "backend-fs splitlog ./tmp/be4 ./tmp/be4 1024"))
415 (test-define "Wrap in cache" cbe (backend-cache be "./tmp/be4-cache"))
416 (test-define "Wrap in block-limiter" lbe (backend-limit-block-size cbe 1024))
417 (test-backend lbe)
418 (test "Close storage" (void) ((storage-close! lbe))))
419
420(test-group "Filesystem backend archive"
421 (create-directory "./tmp/be5")
422 (test-define "Open archive" be (open-archive '((storage "backend-fs fs ./tmp/be5")) #f #t))
423 (test-archive be "./tmp/be5")
424 (test "Close archive" (void) (archive-close! be)))
425
426(test-group "Log backend archive"
427 (create-directory "./tmp/be6")
428 (test-define "Open archive" be (open-archive '((storage  "backend-fs log ./tmp/be6/log ./tmp/be6/index ./tmp/be6/tags")) #f #t))
429 (test-archive be "./tmp/be6")
430 (test "Close archive" (void) (archive-close! be)))
431
432(test-group "Splitlog backend archive"
433 (create-directory "./tmp/be7")
434 (test-define "Open archive" be (open-archive '((storage  "backend-fs splitlog ./tmp/be7 ./tmp/be7 1024")) #f #t))
435 (test-archive be "./tmp/be7")
436 (test "Close archive" (void) (archive-close! be)))
437
438(test-exit)
Note: See TracBrowser for help on using the repository browser.