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

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

ugarit: tag locking, and strict enforcement of maximum file size in splitlog archives

File size: 30.3 KB
Line 
1(use ugarit-core)
2(use miscmacros)
3(use ugarit-backend)
4(use test)
5(use posix)
6(use posix-extras)
7(use directory-rules)
8(use matchable)
9(include "../backend-devtools.scm")
10
11;; Test egg extensions
12
13(define-syntax test-no-errors
14  (syntax-rules ()
15    ((_ expr)
16     (test-no-errors (->string expr) expr))
17    ((_ name expr)
18     (test name (void) (begin expr (void))))))
19
20(define-syntax test-define
21  (syntax-rules ()
22    ((_ var expr)
23     (test-define (->string '(define var expr)) var expr))
24    ((_ name var expr)
25     (begin
26       (define var (void))
27       (test-no-errors name (set! var expr))))))
28
29(define-syntax test-define-values
30  (syntax-rules ()
31    ((_ (var ...) expr)
32     (test-define-values (->string '(define-values (var ...) expr)) (var ...) expr))
33    ((_ name (var ...) expr)
34     (begin
35       (define var (void)) ...
36       (test-no-errors name (set!-values (var ...) expr))))))
37
38;; Test utilities
39
40(define (test-backend w)
41   (test-assert "Storage writable" (storage-writable? w))
42   (test-assert "Storage is empty" (not ((storage-exists? w) "TEST")))
43   (test "Load a block" (void) ((storage-put! w) "TEST" (list->u8vector (list 1 2 3 4 5)) 'test))
44   (test-assert "Block successfully loaded" ((storage-exists? w) "TEST"))
45   (test "Block contents reads back" (list 1 2 3 4 5) (u8vector->list ((storage-get w) "TEST")))
46   (if (storage-unlinkable? w)
47      (begin
48         (test "Unlink returns data" (list 1 2 3 4 5) (u8vector->list ((storage-unlink! w) "TEST")))
49         (test-assert "Unlinked block is gone" (not ((storage-exists? w) "TEST")))))
50   (test "Set a tag" (void) ((storage-set-tag! w) "TEST" "TEST123"))
51   (test "Tag is not locked" #f ((storage-tag-locked? w) "TEST"))
52   (test "Lock a tag" #t ((storage-lock-tag! w) "TEST"))
53   (test "Tag is now locked" #t ((storage-tag-locked? w) "TEST"))
54   (test "Lock a tag again" #f ((storage-lock-tag! w) "TEST"))
55   (test "Tag is still locked" #t ((storage-tag-locked? w) "TEST"))
56   (test "Unlock a tag" (void) ((storage-unlock-tag! w) "TEST"))
57   (test "Tag is no longer locked" #f ((storage-tag-locked? w) "TEST"))
58   (test "Tag reads back" "TEST123" ((storage-tag w) "TEST"))
59   (test "Tag list works" (list "TEST") ((storage-all-tags w)))
60   (test "Remove tag" (void)  ((storage-remove-tag! w) "TEST")))
61
62(define (key-stream-cat a ks-hash ks-type level)
63   (define type (archive-exists? a ks-hash))
64   (if (eq? type ks-type)
65      (begin
66         (printf "ks(~A): ~A (~A)\n" level ks-hash type)
67            (for-each (lambda (subkey)
68               (key-stream-cat a subkey ks-type (+ level 1)))
69               (deserialise-key-stream (archive-get a ks-hash))))
70      (printf "kleaf(~A): ~A (~A)\n" level ks-hash type)))
71
72(define (sexpr-stream-cat a ss-hash leaf-type ss-type level)
73   (define type (archive-exists? a ss-hash))
74   (test-assert "sexpr stream internal consistency" (or (eq? type ss-type) (eq? type leaf-type)))
75   (cond
76      ((eq? type ss-type)
77         (begin ; key stream node
78            (printf "ss(~A): ~A (~A)\n" level ss-hash type)
79               (for-each (lambda (subkey)
80                  (sexpr-stream-cat a subkey leaf-type ss-type (+ level 1)))
81                  (deserialise-key-stream (archive-get a ss-hash)))))
82      ((eq? type leaf-type)
83         (begin ; leaf node
84            (printf "sleaf(~A): ~A (~A)\n" level ss-hash type)
85               (for-each (lambda (sexpr)
86                  (printf " ~A\n" sexpr))
87                  (deserialise-sexpr-stream (archive-get a ss-hash)))))))
88
89(define (check-dir-is-empty store-path)
90   (test-assert "Archive is in initial state" (null? (directory store-path))))
91
92(define (check-extract-results path plain-file1-contents plain-file2-contents)
93  (let* ((tp (lambda (relative) (string-append path "/" relative)))
94         (check-file (lambda (relative contents)
95                       (when contents
96                             (test (sprintf "Contents of ~s are as expected" relative)
97                                   contents
98                                   (with-input-from-file (tp relative) read))))))
99
100    ;; Plain file(s)
101    (check-file "plain-file1" plain-file1-contents)
102    (check-file "plain-file2" plain-file2-contents)
103
104    ;; FIFO
105    (test-assert "FIFO exists" (fifo? (tp "fifo")))
106
107    ;; Specials
108    (if (zero? (current-user-id))
109        (begin
110          (let* ((stats (file-stat (tp "block-special")))
111                 (type (bitwise-and (vector-ref stats 1) stat/ifmt))
112                 (devnum (vector-ref stats 10)))
113            (test-assert "Block special file exists" (eq? type stat/ifblk))
114            (test "Block special file has correct devnum" 123 devnum))
115
116          (let* ((stats (file-stat (tp "character-special")))
117                 (type (bitwise-and (vector-ref stats 1) stat/ifmt))
118                 (devnum (vector-ref stats 10)))
119            (test-assert "Character special file exists" (eq? type stat/ifchr))
120            (test "Character special file has correct devnum" 456 devnum))))
121
122    ;; Directory
123    (test-assert "Directory exists" (directory? (tp "directory")))))
124
125(define (test-archive a store-path)
126   (if (archive-unlinkable? a)
127      (check-dir-is-empty store-path)) ; Precondition
128
129   (test-group "Basic archive operations"
130               (define test-list (list 1 2 3 4 5))
131               (define test-data (list->u8vector test-list))
132               (test-define "Archive hash" test-key ((archive-hash a) test-data 'test))
133               (test-assert "Archive is writable" (archive-writable? a))
134               (test-assert "Key does not already exist" (not (archive-exists? a test-key)))
135               (test "Data goes into archive" (void) (archive-put! a test-key test-data 'test))
136               (test-assert "Data now exists in archive" (archive-exists? a test-key))
137               (test "Data reads back" test-list (u8vector->list (archive-get a test-key)))
138
139               (if (archive-unlinkable? a)
140                   (begin
141                     (test "Unlink returns data" test-list (u8vector->list (archive-unlink! a test-key)))
142                     (test-assert "Unlinked data is gone" (not (archive-exists? a test-key)))))
143               (test "Tag setting" (void) (archive-set-tag! a "TEST" test-key))
144
145               (test "Tag is not locked" #f (archive-tag-locked? a "TEST"))
146               (test "Lock a tag" #t (archive-lock-tag! a "TEST"))
147               (test "Tag is now locked" #t (archive-tag-locked? a "TEST"))
148               (test-error "Lock a tag again" (archive-lock-tag! a "TEST"))
149               (test "Tag is still locked" #t (archive-tag-locked? a "TEST"))
150               (test "Unlock a tag" (void) (archive-unlock-tag! a "TEST"))
151               (test "Tag is no longer locked" #f (archive-tag-locked? a "TEST"))
152
153               (test "Tag reading" test-key (archive-tag a "TEST"))
154               (test "Tag listing" (list "TEST") (archive-all-tags a))
155               (test "Tag removal" (void) (archive-remove-tag! a "TEST"))
156               (if (archive-unlinkable? a)
157                   (check-dir-is-empty store-path)))
158
159   (test-group "0-element key stream"
160               (define test-list (list 1 2 3 4 5 6))
161               (define test-data (list->u8vector test-list))
162               (test-define "Archive hash" test-key ((archive-hash a) test-data 'test))
163               (test-define "Create key-stream writer" ksw (make-key-stream-writer* a 'test-ks))
164               (test-define-values "Close key-stream writer" (ks-hash ks-reused?) ((key-stream-writer-finish! ksw)))
165               (test-assert "Key stream did not already exist" (not ks-reused?))
166               (test "Correct hash"  "3293ac630c13f0245f92bbb1766e16167a4e58492dde73f3test-ks" ks-hash)
167               (test "Key stream reads back OK" '() (fold-key-stream a ks-hash 'test-ks cons '()))
168
169               (if (archive-unlinkable? a)
170                   (begin
171                     (test-assert (archive-unlink! a ks-hash))
172                     (check-dir-is-empty store-path))))
173
174   (test-group "1-element key stream...\n"
175               (define test-list (list 1 2 3 4 5 6 7))
176               (define test-data (list->u8vector test-list))
177               (test-define "Archive hash" test-key ((archive-hash a) test-data 'test))
178               (test-define "Create key-stream writer" ksw (make-key-stream-writer* a 'test-ks))
179               (test "Store a block into the archive" (void) (archive-put! a test-key test-data 'test))
180               (test "Insert hash into key stream" (void) ((key-stream-writer-write! ksw) test-key #f))
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 "Correct hash" test-key ks-hash)
184
185               (test "Correct result from reading back key stream"
186                     (list (cons test-key 'test))
187                     (fold-key-stream a ks-hash 'test-ks
188                                      (lambda (key type acc)
189                                        (cons (cons key type) acc)) '()))
190
191               (if (archive-unlinkable? a)
192                   (begin
193                     (test-assert (archive-unlink! a test-key))
194                     (check-dir-is-empty store-path))))
195
196   (test-group "2-element key stream...\n"
197               (define test-list (list 1 2 3 4 5 6 7 8))
198               (define test-data (list->u8vector test-list))
199               (test-define "Archive hash" test-key ((archive-hash a) test-data 'test))
200               (test-define "Create key-stream writer" ksw (make-key-stream-writer* a 'test-ks))
201               (test "Store a block into the archive" (void) (archive-put! a test-key test-data 'test))
202               (test "Insert hash 1 into key stream" (void) ((key-stream-writer-write! ksw) test-key #f))
203               (test "Insert hash 2 into key stream" (void) ((key-stream-writer-write! ksw) test-key #t))
204               (test-define-values "Close key-stream writer" (ks-hash ks-reused?) ((key-stream-writer-finish! ksw)))
205               (test-assert "Key stream did not already exist" (not ks-reused?))
206               (test-assert "Key stream now exists" (archive-exists? a ks-hash))
207
208               (test "Correct result from reading back key stream"
209                     (list (cons test-key 'test) (cons test-key 'test))
210                     (fold-key-stream a ks-hash 'test-ks
211                                      (lambda (key type acc)
212                                        (cons (cons key type) acc)) '()))
213
214               (if (archive-unlinkable? a)
215                   (begin
216                     (test-assert (archive-unlink! a ks-hash))
217                     (test-assert (not (archive-unlink! a test-key)))
218                     (test-assert (archive-unlink! a test-key))
219                     (check-dir-is-empty store-path))))
220
221   (define iterations 1024)
222   (test-group (sprintf "~a-element key stream..." iterations)
223               (define test-list (list 1 2 3 4 5 6 7 8 9))
224               (define test-data (list->u8vector test-list))
225               (test-define "Archive hash" test-key ((archive-hash a) test-data 'test))
226               (test-define "Create key-stream writer" ksw (make-key-stream-writer* a 'test-ks))
227               (test "Store a block into the archive" (void) (archive-put! a test-key test-data 'test))
228               (test "Insert hash 1 into key stream" (void) ((key-stream-writer-write! ksw) test-key #t)) ; Ensure one reference is left at the end
229               (test "Insert more hashes into key stream" (void)
230                     (dotimes (iter iterations)
231                              ((key-stream-writer-write! ksw) test-key #t)))
232               (test-define-values "Close key-stream writer" (ks-hash ks-reused?) ((key-stream-writer-finish! ksw)))
233               (test-assert "Key stream did not already exist" (not ks-reused?))
234               (test-assert "Key stream now exists" (archive-exists? a ks-hash))
235
236               (test-define "Key stream reads back OK" keys
237                            (fold-key-stream a ks-hash 'test-ks
238                                             (lambda (key type acc)
239                                               (cons (cons key type) acc)) '()))
240               (test "Correct number of keys come back" (+ 1 iterations) (length keys))
241               (test-assert "Correct keys come back" (every
242                                                      (lambda (key) (string=? (car key) test-key))
243                                                      keys))
244
245               (if (archive-unlinkable? a)
246                   (begin
247                     (test "Unlink key stream" (void)
248                           (unlink-key-stream! a ks-hash 'test-ks
249                                               (lambda (archive key type)
250                                                 (test-assert "Unlink non-final block" (not (archive-unlink! archive key))))))
251                     (test-assert "Unlink final block" (archive-unlink! a test-key))
252                     (check-dir-is-empty store-path))))
253
254   (test-group "0-element sexpr stream"
255               (test-define "Create sexpr-stream writer" ssw (make-sexpr-stream-writer* a 't 'ti))
256               (test-define-values "Close sexpr-stream writer" (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
257               (test-assert "Sexpr stream did not already exist" (not ss-reused?))
258               (test "Correct hash"  "3293ac630c13f0245f92bbb1766e16167a4e58492dde73f3t" ss-hash)
259               (test "Sexpr stream reads back OK" '() (fold-sexpr-stream a ss-hash 't 'ti cons '()))
260
261               (if (archive-unlinkable? a)
262                   (begin
263                     (test-assert (archive-unlink! a ss-hash))
264                     (check-dir-is-empty store-path))))
265
266   (test-group "1-element sexpr stream"
267               (define test-list (list 1 2 3 4 5 6 7 8 9 10 11))
268               (define test-data (list->u8vector test-list))
269               (test-define "Archive hash" test-key ((archive-hash a) test-data 'test))
270               (test-define "Create sexpr-stream writer" ssw (make-sexpr-stream-writer* a 't 'ti))
271               (test "Write to sexpr stream" (void)
272                     ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f))))
273               (test-define-values "Close sexpr-stream writer" (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
274               (test-assert "Sexpr stream did not already exist" (not ss-reused?))
275               (test "Sexpr stream reads back OK"
276                     `((foo ,test-key))
277                     (fold-sexpr-stream a ss-hash 't 'ti cons '()))
278
279               (if (archive-unlinkable? a)
280                   (begin
281                     (test "Unlink sexpr stream" (void)
282                           (unlink-sexpr-stream! a ss-hash 't 'ti
283                                                 (lambda (sexpr)
284                                                   (test "Correct entry read back" `(foo ,test-key) (identity sexpr))
285                                                   (test "Unlink entry" #f (archive-unlink! a test-key)))))
286                     (test-assert "Sexpr stream is gone" (not (archive-exists? a ss-hash)))
287                     (test-assert "Test block is gone" (not (archive-exists? a test-key)))
288                     (check-dir-is-empty store-path))))
289
290   (test-group "2-element sexpr stream"
291               (define test-list (list 1 2 3 4 5 6 7 8 9 10 11 12))
292               (define test-data (list->u8vector test-list))
293               (test-define "Archive hash" test-key ((archive-hash a) test-data 'test))
294               (test "Archive write" (void) (archive-put! a test-key test-data 'test))
295               (test-define "Create sexpr-stream writer" ssw (make-sexpr-stream-writer* a 't 'ti))
296               (test "Write to sexpr stream" (void)
297                     ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f))))
298               (test "Write to sexpr stream" (void)
299                     ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #t))))
300               (test-define-values "Close sexpr-stream writer" (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
301               (test-assert "Sexpr stream did not already exist" (not ss-reused?))
302               (test "Sexpr stream reads back OK"
303                     `((foo ,test-key) (foo ,test-key))
304                     (fold-sexpr-stream a ss-hash 't 'ti cons '()))
305
306               (if (archive-unlinkable? a)
307                   (begin
308                     (define unlinks 0)
309
310                     (test "Unlink sexpr stream" (void)
311                           (unlink-sexpr-stream! a ss-hash 't 'ti
312                                                 (lambda (sexpr)
313                                                   (test "Correct entry read back" `(foo ,test-key) (identity sexpr))
314                                                   (test (sprintf "Unlink entry ~a" unlinks) (if (zero? unlinks) #f test-data) (archive-unlink! a test-key))
315                                                   (set! unlinks (+ unlinks 1)))))
316                     (test-assert "Sexpr stream is gone" (not (archive-exists? a ss-hash)))
317                     (test-assert "Test block is gone" (not (archive-exists? a test-key)))
318                     (check-dir-is-empty store-path))))
319
320   (test-group (sprintf "~A-element sexpr stream" iterations)
321               (define test-list (list 1 2 3 4 5 6 7 8 9 10 11 12 13))
322               (define test-data (list->u8vector test-list))
323               (test-define "Archive hash" test-key ((archive-hash a) test-data 'test))
324               (test "Archive write" (void) (archive-put! a test-key test-data 'test))
325               (test-define "Create sexpr-stream writer" ssw (make-sexpr-stream-writer* a 't 'ti))
326               ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f)))
327               (dotimes (iter iterations)
328                        (test "Write to sexpr stream" (void)
329                     ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #t)))))
330               (test-define-values "Close sexpr-stream writer" (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
331               (test-assert "Sexpr stream did not already exist" (not ss-reused?))
332               (test-define "Sexpr stream reads back OK" sexprs
333                            (fold-sexpr-stream a ss-hash 't 'ti cons '()))
334               (test "Correct number of sexprs read back" (+ 1 iterations) (length sexprs))
335               (test-assert "Correct sexprs read back"
336                            (every
337                             (lambda (sexpr) (equal? sexpr `(foo ,test-key)))
338                            sexprs))
339
340               (if (archive-unlinkable? a)
341                   (begin
342                     (define unlinks 0)
343
344                     (test "Unlink sexpr stream" (void)
345                           (unlink-sexpr-stream! a ss-hash 't 'ti
346                                                 (lambda (sexpr)
347                                                   (test "Correct entry read back" `(foo ,test-key) (identity sexpr))
348                                                   (test (sprintf "Unlink entry ~a" unlinks) (if (< unlinks iterations) #f test-data) (archive-unlink! a test-key))
349                                                   (set! unlinks (+ unlinks 1)))))
350                     (test-assert "Sexpr stream is gone" (not (archive-exists? a ss-hash)))
351                     (test-assert "Test block is gone" (not (archive-exists? a test-key)))
352                     (check-dir-is-empty store-path))))
353
354   (test-group "Files"
355               (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.")
356
357   (test-define-values "Store a file" (file-key file-reused?)
358                       (with-input-from-string test-string (lambda ()
359                                                             (store-file! a "/test-file" (vector 0 0 0 0 0 0 0 0 0 0 0 0 0)))))
360
361
362   (test "Read it back" test-string
363         (with-output-to-string
364           (lambda ()
365             (write-file-contents a file-key))))
366
367   (if (archive-unlinkable? a)
368      (begin
369         (test "Delete the file" (void) (unlink-file! a file-key))
370         (check-dir-is-empty store-path))))
371
372   (test-group "Directories"
373               (let* ((test-dir (string-append store-path "-test-data"))
374                      (extract1-dir (string-append store-path "-test-extract1"))
375                      (extract2-dir (string-append store-path "-test-extract2"))
376                      (extract3-dir (string-append store-path "-test-extract3"))
377                      (extract4-dir (string-append store-path "-test-extract4"))
378                      (tp (lambda (relative)
379                            (string-append test-dir "/" relative))))
380                 (create-directory test-dir)
381                 (with-output-to-file (tp "plain-file1") (lambda () (write "Hello world")))
382                 (create-fifo (tp "fifo"))
383                 ;; These two need root!
384                 (if (zero? (current-user-id))
385                     (begin
386                       (create-special-file (tp "block-special") stat/ifblk 123)
387                       (create-special-file (tp "character-special") stat/ifchr 456)))
388                 (create-directory (tp "directory"))
389
390                 ;; Dump it
391                 (test-define-values "Store a directory" (dir1-key dir1-reused?)
392                                     (call-with-context-support
393                                      (archive-global-directory-rules a)
394                                      (lambda ()
395                                       (store-directory! a test-dir))))
396
397                 (create-directory extract1-dir)
398
399                 (test "Extract a directory" (void)
400                       (extract-directory! a dir1-key extract1-dir))
401
402                 (check-extract-results extract1-dir "Hello world" #f)
403
404                 ;; Now add an extra file and dump again
405                 (with-output-to-file (tp "plain-file2") (lambda () (write "Hello world 2")))
406
407                 (test-define-values "Store a directory again" (dir2-key dir2-reused?)
408                                     (call-with-context-support
409                                      (archive-global-directory-rules a)
410                                      (lambda ()
411                                       (store-directory! a test-dir))))
412
413                 (test-assert "Changed directory is not reused" (not dir2-reused?))
414
415                 (create-directory extract2-dir)
416                 (test "Extract a directory" (void)
417                       (extract-directory! a dir2-key extract2-dir))
418
419                 (check-extract-results extract2-dir "Hello world" "Hello world 2")
420
421                 ;; Now change an existing file and dump again
422                 (with-output-to-file (tp "plain-file1") (lambda () (write "Hello world again!")))
423
424                 (test-define-values "Store a directory again" (dir3-key dir3-reused?)
425                                     (call-with-context-support
426                                      (archive-global-directory-rules a)
427                                      (lambda ()
428                                       (store-directory! a test-dir))))
429
430                 (test-assert "Changed directory is not reused" (not dir3-reused?))
431
432                 (create-directory extract3-dir)
433                 (test "Extract a directory" (void)
434                       (extract-directory! a dir3-key extract3-dir))
435
436                 (check-extract-results extract3-dir "Hello world again!" "Hello world 2")
437
438                 ;; Now make no changes and dump again
439                 (test-define-values "Store a directory again" (dir4-key dir4-reused?)
440                                     (call-with-context-support
441                                      (archive-global-directory-rules a)
442                                      (lambda ()
443                                       (store-directory! a test-dir))))
444
445                 (test-assert "Unchanged directory is reused" dir4-reused?)
446                 (test "Mark reused directory" (void) (archive-link! a dir4-key))
447                 (create-directory extract4-dir)
448                 (test "Extract a directory" (void)
449                       (extract-directory! a dir4-key extract4-dir))
450                 (check-extract-results extract4-dir "Hello world again!" "Hello world 2")
451
452                 ;; Tidy up
453                 (if (archive-unlinkable? a)
454                     (begin
455                       (test "Delete the first directory" (void) (unlink-directory! a dir1-key))
456                       (check-extract-results extract2-dir "Hello world" "Hello world 2")
457                       (test "Delete the second directory" (void) (unlink-directory! a dir2-key))
458                       (check-extract-results extract3-dir "Hello world again!" "Hello world 2")
459                       (test "Delete the third directory" (void) (unlink-directory! a dir3-key))
460                       (check-extract-results extract4-dir "Hello world again!" "Hello world 2")
461                       (test "Delete the fourth directory" (void) (unlink-directory! a dir4-key))
462                       (check-dir-is-empty store-path)))))
463
464   (test-group "Snapshots"
465               (let* ((test-dir (string-append store-path "-test-data")))
466                 (test-define-values "Store a directory" (dir-key dir-reused?)
467                                     (call-with-context-support
468                                      (archive-global-directory-rules a)
469                                      (lambda ()
470                                        (store-directory! a test-dir))))
471
472                 (if (archive-unlinkable? a)
473                     (test-assert "Directory was not reused" (not dir-reused?)))
474
475                 (test-define-values "Tag it as a snapshot" (sk1)
476                                     (tag-snapshot! a "Test" dir-key dir-reused? (list)))
477
478                 (test-define-values "Store the directory again" (dir2-key dir2-reused?)
479                                     (call-with-context-support
480                                      (archive-global-directory-rules a)
481                                      (lambda ()
482                                        (store-directory! a test-dir))))
483
484                 (test-assert "Directory was reused" dir2-reused?)
485
486                 (test-assert "Directory has the same key" (string=? dir-key dir2-key))
487
488                 (test-define-values "Tag it as a snapshot" (sk2)
489                                     (tag-snapshot! a "Test" dir2-key dir2-reused? (list)))
490
491                 (test-define-values "Read the tag back" (tag2) (archive-tag a "Test"))
492                 (test-define-values "Walk the history with fold-history" (result)
493                                     (fold-history a tag2
494                                                   (lambda (snapshot-key snapshot acc)
495                                                     (cons snapshot acc))
496                                                   '()))
497                 (test-assert "History has expected form"
498                              (match result
499                                     (((('previous . sk1*)
500                                        ('mtime . _)
501                                        ('contents . dir2-key*)
502                                        ('stats . _))
503                                       (('mtime . _)
504                                        ('contents . dir-key*)
505                                        ('stats . _)))
506                                      (and (string=? sk1 sk1*)
507                                           (string=? dir2-key dir2-key*)
508                                           (string=? dir-key dir-key*)))
509                                     (else #f)))
510
511                 (test-define-values "Walk the tag list with fold-archive-node" (root)
512                                     (fold-archive-node a '() (lambda (name dirent acc) (cons (cons name dirent) acc)) '()))
513                 (test-assert "Root history has expected form"
514                              (match root
515                                     (((('tag . "Test")
516                                        "Test"
517                                        'tag
518                                        ('current . sk2*)))
519                                      (string=? sk2 sk2*))
520                                     (else #f)))
521                 (test-define-values "Walk the history of tag 'Test' with fold-archive-node" (tag)
522                                     (fold-archive-node a '(tag . "Test") (lambda (name dirent acc) (cons (cons name dirent) acc)) '()))
523                 (test-assert "Tag history has expected form"
524                              (match tag
525                                     (((dir-key-c*
526                                        "current"
527                                        'snapshot
528                                        ('previous . sk1*)
529                                        ('mtime . _)
530                                        ('contents . dir-key*)
531                                        ('stats . _))
532                                       (dir-key-c**
533                                        _
534                                        'snapshot
535                                        ('previous . sk1**)
536                                        ('mtime . _)
537                                        ('contents . dir-key**)
538                                        ('stats . _))
539                                       (dir-key-c***
540                                        _
541                                        'snapshot
542                                        ('mtime . _)
543                                        ('contents . dir-key***)
544                                        ('stats . _)))
545                                      (and
546                                       (string=? sk1 sk1*)
547                                       (string=? dir-key dir-key-c*)
548                                       (string=? dir-key dir-key*)
549                                       (string=? sk1 sk1**)
550                                       (string=? dir-key dir-key-c**)
551                                       (string=? dir-key dir-key**)
552                                       (string=? dir-key dir-key-c***)
553                                       (string=? dir-key dir-key***)))
554                                     (else #f)))
555                 (test-define-values "Walk the root directory with fold-archive-node" (dir)
556                                     (fold-archive-node a dir-key (lambda (name dirent acc) (cons (cons name dirent) acc)) '()))
557                 ; FIXME: Write a giant match to match this bad boy...
558                 (if (zero? (current-user-id))
559                     (test-assert "Directory history has the expected form (as root)"
560                                  (match dir
561                                         (((#f "block-special" 'block-device (number . 123) . _)
562                                           (#f "character-special" 'character-device (number . 456) . _)
563                                           (_ "directory" 'dir . _)
564                                           (#f "fifo" 'fifo . _)
565                                           (#f "plain-file1" 'file . _)
566                                           (#f "plain-file2" 'file . _)) #t)
567                                         (else #f)))
568                     (test-assert "Directory history has the expected form (not as root)"
569                                  (match dir
570                                         (((_ "directory" 'dir . _)
571                                           (#f "fifo" 'fifo . _)
572                                           (#f "plain-file1" 'file . _)
573                                           (#f "plain-file2" 'file . _)) #t)
574                                         (else #f))))))
575
576   "This archive seems to work!")
577
578;; Actual Tests
579
580(if (directory? "./tmp")
581    (delete-directory "./tmp" #t))
582(create-directory "./tmp")
583
584(test-group "Filesystem backend"
585 (create-directory "./tmp/be1")
586 (test-define "Open storage" be (import-storage "backend-fs fs ./tmp/be1"))
587 (test-backend be)
588 (test "Close storage" (void) ((storage-close! be))))
589
590(test-group "Splitlog backend"
591 (create-directory "./tmp/be3")
592 (test-define "Open storage" be (import-storage "backend-fs splitlog ./tmp/be3 ./tmp/be3/metadata 1024"))
593 (test-backend be)
594 (test "Close storage" (void) ((storage-close! be))))
595
596(test-group "Limited cached splitlog backend"
597 (create-directory "./tmp/be4")
598 (test-define "Open storage" be (import-storage "backend-cache ./tmp/be4-cache \"backend-fs splitlog ./tmp/be4 ./tmp/be4/metadata 1024\""))
599 (test-define "Wrap in block-limiter" lbe (backend-limit-block-size be 1024))
600 (test-backend lbe)
601 (test "Close storage" (void) ((storage-close! lbe))))
602
603(test-group "Filesystem backend archive"
604 (create-directory "./tmp/be5")
605 (test-define "Open archive" be (open-archive '((storage "backend-fs fs ./tmp/be5")) #f #t))
606 (test-archive be "./tmp/be5")
607 (test "Close archive" (void) (archive-close! be)))
608
609(test-group "Filesystem backend archive plus file cache"
610 (create-directory "./tmp/be6")
611 (test-define "Open archive" be (open-archive '((storage "backend-fs fs ./tmp/be6") (file-cache "./tmp/be6-file-cache")) #f #t))
612 (test-archive be "./tmp/be6")
613 (test "Close archive" (void) (archive-close! be)))
614
615(test-group "Splitlog backend archive"
616 (create-directory "./tmp/be7")
617 (test-define "Open archive" be (open-archive '((storage  "backend-fs splitlog ./tmp/be7 ./tmp/be7/metadata 1024")) #f #t))
618 (test-archive be "./tmp/be7")
619 (test "Close archive" (void) (archive-close! be)))
620
621(test-group "Splitlog backend archive plus file cache"
622 (create-directory "./tmp/be8")
623 (test-define "Open archive" be (open-archive '((storage  "backend-fs splitlog ./tmp/be8 ./tmp/be8/metadata 1024") (file-cache "./tmp/be8-file-cache")) #f #t))
624 (test-archive be "./tmp/be8")
625 (test "Close archive" (void) (archive-close! be)))
626
627(printf "Final count of failures: ~a\n" (test-failure-count))
628
629(test-exit)
Note: See TracBrowser for help on using the repository browser.