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

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

ugarit: Unit test suite now covers everything except fold-archive-node over directories (but that's really hard to test, and really simple to implement, so not worth testing, right?)

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