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

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

ugarit: Test for storing and extracting a directory

Still lacking an actual comparison of the extracted
result to the original input, though. Is there an easy
way to compare two directories, to save me writing a
heap of logic to do that recursively? That'd be a bit of
a yak-shaving exercise.

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