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

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

ugarit: Version 2 of the backend protocol, supporting better reporting back to the user, and administrative interfaces. Backends outfitted with admin interfaces, and a ugarit-archive-admin tool added to drive them.

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