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

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

ugarit: Dotting is, crossing ts...

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