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

Last change on this file since 15242 was 15241, checked in by Alaric Snell-Pym, 11 years ago

Initial import of chicken3 code

File size: 15.0 KB
Line 
1(use miscmacros)
2
3(include "ugarit-core.scm")
4
5(define (test-backend w)
6   (assert (storage-writable? w))
7   (assert (not ((storage-exists? w) "TEST")))
8   ((storage-put! w) "TEST" (list->u8vector (list 1 2 3 4 5)) 'test)
9   (assert ((storage-exists? w) "TEST"))
10   (assert (equal? (u8vector->list ((storage-get w) "TEST")) (list 1 2 3 4 5)))
11   (if (storage-unlinkable? w)
12      (begin
13         (assert (equal? (u8vector->list ((storage-unlink! w) "TEST")) (list 1 2 3 4 5)))
14         (assert (not ((storage-exists? w) "TEST")))))
15   ((storage-set-tag! w) "TEST" "TEST123")
16   (assert (equal? ((storage-tag w) "TEST") "TEST123"))
17   (assert (equal? ((storage-all-tags w)) (list "TEST")))
18   ((storage-remove-tag! w) "TEST")
19   "This backend seems to work!")
20
21(create-directory "./tmp/be1")
22(define be (backend-fs "./tmp/be1"))
23(printf "backend-fs: ~A\n" (test-backend be))
24((storage-close! be))
25
26(create-directory "./tmp/be2")
27(define be (backend-log "./tmp/be2/log" "./tmp/be2/index" "./tmp/be2/tags"))
28(printf "backend-log: ~A\n" (test-backend be))
29((storage-close! be))
30
31(create-directory "./tmp/be2a")
32(define be (backend-splitlog "./tmp/be2a" "./tmp/be2a" 1024))
33(printf "backend-splitlog: ~A\n" (test-backend be))
34((storage-close! be))
35
36(create-directory "./tmp/be3")
37(define be (backend-fs "./tmp/be3"))
38(define cbe (backend-cache be "./tmp/be3-cache"))
39(printf "backend-cache(backend-fs): ~A\n" (test-backend cbe))
40((storage-close! cbe))
41
42(create-directory "./tmp/be4")
43(define be (backend-fs "./tmp/be4"))
44(define cbe (backend-cache be "./tmp/be4-cache"))
45(define lbe (backend-limit-block-size cbe 1024)) 
46(printf "backend-limit-block-size(backend-cache(backend-fs)): ~A\n" (test-backend lbe))
47((storage-close! lbe))
48
49(define (key-stream-cat a ks-hash ks-type level)
50   (define type (archive-exists? a ks-hash))
51   (if (eq? type ks-type)
52      (begin
53         (printf "ks(~A): ~A (~A)\n" level ks-hash type)
54            (for-each (lambda (subkey)
55               (key-stream-cat a subkey ks-type (+ level 1)))
56               (deserialise-key-stream (archive-get a ks-hash))))
57      (printf "kleaf(~A): ~A (~A)\n" level ks-hash type)))
58
59(define (sexpr-stream-cat a ss-hash leaf-type ss-type level)
60   (define type (archive-exists? a ss-hash))
61   (cond
62      ((eq? type ss-type)
63         (begin ; key stream node
64            (printf "ss(~A): ~A (~A)\n" level ss-hash type)
65               (for-each (lambda (subkey)
66                  (sexpr-stream-cat a subkey leaf-type ss-type (+ level 1)))
67                  (deserialise-key-stream (archive-get a ss-hash)))))
68      ((eq? type leaf-type)
69         (begin ; leaf node
70            (printf "sleaf(~A): ~A (~A)\n" level ss-hash type)
71               (for-each (lambda (sexpr)
72                  (printf " ~A\n" sexpr))
73                  (deserialise-sexpr-stream (archive-get a ss-hash)))))
74      (else
75         (assert (or (eq? type ss-type) (eq? type leaf-type))))))
76
77
78(define (check-dir-is-empty store-path)
79   (assert (null? (directory store-path))))
80
81(define (test-archive a store-path)
82   (if (archive-unlinkable? a)
83      (check-dir-is-empty store-path)) ; Precondition
84   
85   (printf "Testing basic archive operations...\n")
86   (define test-list (list 1 2 3 4 5))
87   (define test-data (list->u8vector test-list))
88   (define test-key ((archive-hash a) test-data 'test))
89   (assert (archive-writable? a))
90   (assert (not (archive-exists? a test-key)))
91   (archive-put! a test-key test-data 'test)
92   (assert (archive-exists? a test-key))
93   (assert (equal? (u8vector->list (archive-get a test-key)) test-list))
94   (if (archive-unlinkable? a)
95      (begin
96         (assert (equal? (u8vector->list (archive-unlink! a test-key)) test-list))
97         (assert (not (archive-exists? a test-key)))))
98   (archive-set-tag! a "TEST" test-key)
99   (assert (equal? (archive-tag a "TEST") test-key))
100   (assert (equal? (archive-all-tags a) (list "TEST")))
101   (archive-remove-tag! a "TEST")
102   (if (archive-unlinkable? a)
103      (check-dir-is-empty store-path))
104
105   (printf "Testing 0-element key stream...\n")
106   (define test-list (list 1 2 3 4 5 6))
107   (define test-data (list->u8vector test-list))
108   (define test-key ((archive-hash a) test-data 'test))
109   (define ksw (make-key-stream-writer* a 'test-ks))
110   (define-values (ks-hash ks-reused?) ((key-stream-writer-finish! ksw)))
111   (assert (not ks-reused?))
112   (assert (string=? ks-hash "3293ac630c13f0245f92bbb1766e16167a4e58492dde73f3test-ks"))
113   (assert (equal? (fold-key-stream archive ks-hash 'test-ks cons '()) '()))
114   (if (archive-unlinkable? a)
115      (begin
116         (assert (archive-unlink! a ks-hash))
117         (check-dir-is-empty store-path)))
118
119   (printf "Testing 1-element key stream...\n")
120   (define test-list (list 1 2 3 4 5 6 7))
121   (define test-data (list->u8vector test-list))
122   (define test-key ((archive-hash a) test-data 'test))
123   (define ksw (make-key-stream-writer* a 'test-ks))
124   (archive-put! a test-key test-data 'test)
125   ((key-stream-writer-write! ksw) test-key #f)
126   (define-values (ks-hash ks-reused?) ((key-stream-writer-finish! ksw)))
127   (assert (not ks-reused?))
128   (assert (string=? ks-hash test-key))
129   
130   (define keys (fold-key-stream archive ks-hash 'test-ks 
131      (lambda (key type acc)
132         (cons (cons key type) acc)) '()))
133   (assert (equal? keys (list (cons test-key 'test))))
134   
135   (if (archive-unlinkable? a)
136      (begin
137         (assert (archive-unlink! a test-key))
138         (check-dir-is-empty store-path)))
139
140   (printf "Testing 2-element key stream...\n")
141   (define test-list (list 1 2 3 4 5 6 7 8))
142   (define test-data (list->u8vector test-list))
143   (define test-key ((archive-hash a) test-data 'test))
144   (define ksw (make-key-stream-writer* a 'test-ks))
145   (archive-put! a test-key test-data 'test)
146   ((key-stream-writer-write! ksw) test-key #f)
147   ((key-stream-writer-write! ksw) test-key #t)
148   (define-values (ks-hash ks-reused?) ((key-stream-writer-finish! ksw)))
149   (assert (not ks-reused?))
150   
151   (assert (archive-exists? a ks-hash))
152   
153   (define keys (fold-key-stream archive ks-hash 'test-ks 
154      (lambda (key type acc)
155         (cons (cons key type) acc)) '()))
156   (assert (equal? keys (list (cons test-key 'test) (cons test-key 'test))))
157   
158   (if (archive-unlinkable? a)
159      (begin
160         (assert (archive-unlink! a ks-hash))
161         (assert (not (archive-unlink! a test-key)))
162         (assert (archive-unlink! a test-key))
163         (check-dir-is-empty store-path)))
164   
165   (define iterations 1024)
166   (printf "Testing ~A-element key stream...\n" iterations)
167   (define test-list (list 1 2 3 4 5 6 7 8 9))
168   (define test-data (list->u8vector test-list))
169   (define test-key ((archive-hash a) test-data 'test))
170   (define ksw (make-key-stream-writer* a 'test-ks))
171   (archive-put! a test-key test-data 'test)
172
173   ((key-stream-writer-write! ksw) test-key #t) ; ensure one reference is left
174   (dotimes (iter iterations)
175      ((key-stream-writer-write! ksw) test-key #t))
176
177   (define-values (ks-hash ks-reused?) ((key-stream-writer-finish! ksw)))
178   (assert (not ks-reused?))
179
180;   (key-stream-cat archive ks-hash 'test-ks 0)
181   
182   (define keys (fold-key-stream archive ks-hash 'test-ks 
183      (lambda (key type acc)
184         (cons (cons key type) acc)) '()))
185   (assert (= (length keys) (+ 1 iterations)))
186   (assert (every
187      (lambda (key) (string=? (car key) test-key))
188      keys))
189   
190   (if (archive-unlinkable? a)
191      (begin
192         (unlink-key-stream! archive ks-hash 'test-ks
193            (lambda (archive key type)
194               (assert (not (archive-unlink! archive key)))))
195   
196         (assert (archive-unlink! a test-key)) ; clean up the one final reference
197         (check-dir-is-empty store-path)))
198   
199   (printf "Testing 0-element sexpr stream...\n")
200   (define test-list (list 1 2 3 4 5 6 7 8 9 10))
201   (define test-data (list->u8vector test-list))
202   (define test-key ((archive-hash a) test-data 'test))
203   (define ssw (make-sexpr-stream-writer* a 't 'ti))
204   (define-values (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
205   (assert (not ss-reused?))
206   (assert (string=? ss-hash "3293ac630c13f0245f92bbb1766e16167a4e58492dde73f3t"))
207   (assert (equal? (fold-sexpr-stream archive ss-hash 't 'ti cons '()) '()))
208   (if (archive-unlinkable? a)
209      (begin
210         (assert (archive-unlink! a ss-hash))
211         (check-dir-is-empty store-path)))
212
213   (printf "Testing 1-element sexpr stream...\n")
214   (define test-list (list 1 2 3 4 5 6 7 8 9 10 11))
215   (define test-data (list->u8vector test-list))
216   (define test-key ((archive-hash a) test-data 'test))
217   (define ssw (make-sexpr-stream-writer* a 't 'ti))
218   (archive-put! a test-key test-data 'test)
219   ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f)))
220   (define-values (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
221   (assert (not ss-reused?))
222   (define sexprs (fold-sexpr-stream archive ss-hash 't 'ti cons '()))
223   (assert (equal? sexprs `((foo ,test-key))))
224   (if (archive-unlinkable? a)
225      (begin
226         (unlink-sexpr-stream! archive ss-hash 't 'ti
227            (lambda (sexpr)
228               (assert (equal? sexpr `(foo ,test-key)))
229               (archive-unlink! archive test-key)))
230         (assert (not (archive-exists? archive ss-hash)))
231         (assert (not (archive-exists? archive test-key)))
232         (check-dir-is-empty store-path)))
233
234   (printf "Testing 2-element sexpr stream...\n")
235   (define test-list (list 1 2 3 4 5 6 7 8 9 10 11 12))
236   (define test-data (list->u8vector test-list))
237   (define test-key ((archive-hash a) test-data 'test))
238   (define ssw (make-sexpr-stream-writer* a 't 'ti))
239   (archive-put! a test-key test-data 'test)
240   ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f)))
241   ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f)))
242   (define-values (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
243   (assert (not ss-reused?))
244   (define sexprs (fold-sexpr-stream archive ss-hash 't 'ti cons '()))
245   (assert (equal? sexprs `((foo ,test-key) (foo ,test-key))))
246
247   (if (archive-unlinkable? a)
248      (begin
249         (unlink-sexpr-stream! archive ss-hash 't 'ti
250            (lambda (sexpr)
251               (assert (equal? sexpr `(foo ,test-key)))
252               (archive-unlink! archive test-key)))
253         (assert (not (archive-exists? archive ss-hash)))
254         (assert (not (archive-exists? archive test-key)))
255         (check-dir-is-empty store-path)))
256   
257   (printf "Testing ~A-element sexpr stream...\n" iterations)
258   (define test-list (list 1 2 3 4 5 6 7 8 9 10 11 12 13))
259   (define test-data (list->u8vector test-list))
260   (define test-key ((archive-hash a) test-data 'test))
261   (define ssw (make-sexpr-stream-writer* a 't 'ti))
262   (archive-put! a test-key test-data 'test)
263   (dotimes (iter iterations)
264      ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f))))
265   (define-values (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw)))
266   (assert (not ss-reused?))
267   (define sexprs (fold-sexpr-stream archive ss-hash 't 'ti cons '()))
268   (assert (= (length sexprs) iterations))
269   (assert (every
270      (lambda (sexpr) (equal? sexpr `(foo ,test-key)))
271      sexprs))
272
273   ;(sexpr-stream-cat a ss-hash 't 'ti 0)
274
275   (if (archive-unlinkable? a)
276      (begin
277         (unlink-sexpr-stream! archive ss-hash 't 'ti
278            (lambda (sexpr)
279               (assert (equal? sexpr `(foo ,test-key)))
280               (archive-unlink! archive test-key)))
281   
282         (assert (not (archive-exists? archive test-key)))
283         (check-dir-is-empty store-path)))
284   
285   (printf "Testing files...\n")
286   (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.")
287   
288   (printf "\tStore a file\n")
289   (define-values (file-key file-reused?)
290      (with-input-from-string test-string (lambda ()
291         (store-file! archive))))
292
293   (printf "\tRead it back\n")
294   (define result (with-output-to-string
295      (lambda ()
296         (write-file-contents archive file-key))))
297   
298   (assert (string=? test-string result))
299   
300   (if (archive-unlinkable? a)
301      (begin
302         (printf "\tDelete the file\n")
303         (unlink-file! archive file-key)
304         (check-dir-is-empty store-path)))
305   
306   (printf "Testing directories...\n")
307   
308   (printf "\tStore a directory\n")
309   
310   (define-values (dir-key dir-reused?)
311      (store-directory! archive "test-data"))
312
313   (printf "\tExtract the directory\n")
314   (create-directory (string-append store-path "-extract"))
315   (extract-directory! archive dir-key (string-append store-path "-extract"))
316   
317   (if (archive-unlinkable? a)
318      (begin
319         (printf "\tDelete the directory\n")
320         (unlink-directory! archive dir-key)
321         (check-dir-is-empty store-path)))
322   
323   (printf "Testing snapshots\n")
324
325   (printf "\tStore a directory\n")
326   
327   (define-values (dir-key dir-reused?)
328      (store-directory! archive "test-data"))
329
330   (if (archive-unlinkable? a)
331      (assert (not dir-reused?)))
332
333   (printf "\tTag it (~A ~A)\n" dir-key dir-reused?)
334   (define sk1 (tag-snapshot! archive "Test" dir-key dir-reused? (list)))
335   
336   (printf "\tStore another directory\n")
337
338   (define-values (dir-key-two dir-reused?)
339      (store-directory! archive "test-data"))
340   
341   (assert dir-reused?)
342   (assert (string=? dir-key dir-key-two))
343   
344   (printf "\tTag it (~A ~A)\n" dir-key  dir-reused?)
345   (define sk1 (tag-snapshot! archive "Test" dir-key-two dir-reused? (list)))
346   
347   (printf "\tWalk the history\n")
348   
349   (define result
350      (fold-history archive (archive-tag archive "Test")
351         (lambda (snapshot-key snapshot acc)
352            (cons snapshot acc))
353         '()))
354   (assert (match result
355     (((('previous . sk1)
356        ('mtime . _)
357        ('contents . dir-key-two))
358       (('mtime . _)
359        ('contents . dir-key))) #t)
360     (else #f)))
361   
362   ;(printf "\tTest fold-archive-node\n")
363   ;
364   ;(printf "Root: \n") (pp (fold-archive-node archive '() (lambda (name dirent acc) (cons (cons name dirent) acc)) '()))
365   ;(printf "Tag 'Test': \n") (pp (fold-archive-node archive (cons 'tag "Test") (lambda (name dirent acc) (cons (cons name dirent) acc))  '()))
366   ;(printf "Root directory: \n") (pp (fold-archive-node archive dir-key (lambda (name dirent acc) (cons (cons name dirent) acc))  '()))
367   
368   "This archive seems to work!")
369
370(create-directory "./tmp/be5")
371
372(define archive (open-archive '((storage fs "./tmp/be5")) #f #t))
373(printf "archive on fs: ~A\n" (test-archive archive "./tmp/be5"))
374(archive-close! archive)
375
376(create-directory "./tmp/be6")
377
378(define archive (open-archive '((storage log "./tmp/be6/log" "./tmp/be6/index" "./tmp/be6/tags")) #f #t))
379(printf "archive on log: ~A\n" (test-archive archive "./tmp/be6"))
380(archive-close! archive)
381
382(create-directory "./tmp/be7")
383
384(define archive (open-archive '((storage splitlog "./tmp/be7" "./tmp/be7" 10000)) #f #t))
385(printf "archive on splitlog: ~A\n" (test-archive archive "./tmp/be7"))
386(archive-close! archive)
387
Note: See TracBrowser for help on using the repository browser.