1 | (use ugarit-backend) |
---|
2 | (use sql-de-lite) |
---|
3 | (use matchable) |
---|
4 | |
---|
5 | (define cache-sql-schema |
---|
6 | (list |
---|
7 | "CREATE TABLE cache (key TEXT PRIMARY KEY, type TEST);")) |
---|
8 | |
---|
9 | (define (backend-cache cachepath be) |
---|
10 | (define *db* (open-database cachepath)) |
---|
11 | (when (null? (schema *db*)) |
---|
12 | (for-each (lambda (statement) |
---|
13 | (exec (sql *db* statement))) |
---|
14 | cache-sql-schema)) |
---|
15 | (define *warn-about-delete* #t) |
---|
16 | |
---|
17 | (define (cache-set! key type) |
---|
18 | (when type |
---|
19 | (exec (sql *db* "INSERT OR REPLACE INTO cache (key, type) VALUES (?,?)") key (symbol->string type))) |
---|
20 | type) |
---|
21 | |
---|
22 | (define (cache-get key) |
---|
23 | (let ((result |
---|
24 | (query fetch (sql *db* "SELECT type FROM cache WHERE key = ?") key))) |
---|
25 | (if (pair? result) |
---|
26 | (string->symbol (car result)) |
---|
27 | #f))) |
---|
28 | |
---|
29 | (define (cache-delete! key) |
---|
30 | (exec (sql *db* "DELETE FROM cache WHERE key = ?") key)) |
---|
31 | |
---|
32 | (make-storage |
---|
33 | (storage-max-block-size be) |
---|
34 | (storage-writable? be) |
---|
35 | (storage-unlinkable? be) |
---|
36 | (lambda (key data type) ; put! |
---|
37 | (begin |
---|
38 | ((storage-put! be) key data type) |
---|
39 | (cache-set! key type) |
---|
40 | (void))) |
---|
41 | (lambda (key) ; exists? |
---|
42 | (or |
---|
43 | (cache-get key) |
---|
44 | (cache-set! key ((storage-exists? be) key)))) |
---|
45 | (lambda (key) ; get |
---|
46 | ((storage-get be) key)) |
---|
47 | (lambda (key) ; link! |
---|
48 | ((storage-link! be) key)) |
---|
49 | (lambda (key) ; unlink! |
---|
50 | (let ((result ((storage-unlink! be) key))) |
---|
51 | (if result |
---|
52 | (begin |
---|
53 | (if *warn-about-delete* |
---|
54 | (begin |
---|
55 | (printf "WARNING: Deleting from a shared storage backend will INVALIDATE\nany OTHER caches. Please flush your caches on any other computers\nthat use the same backend store!\n") |
---|
56 | (set! *warn-about-delete* #f))) |
---|
57 | (cache-delete! key) |
---|
58 | result) |
---|
59 | result))) |
---|
60 | (lambda (tag key) ; set-tag! |
---|
61 | ((storage-set-tag! be) tag key)) |
---|
62 | (lambda (tag) ; tag |
---|
63 | ((storage-tag be) tag)) |
---|
64 | (lambda () ; all-tags |
---|
65 | ((storage-all-tags be))) |
---|
66 | (lambda (tag) ; remove-tag! |
---|
67 | ((storage-remove-tag! be) tag)) |
---|
68 | (lambda (tag) ; lock-tag! |
---|
69 | ((storage-lock-tag! be) tag)) |
---|
70 | (lambda (tag) ; tag-locked? |
---|
71 | ((storage-tag-locked? be) tag)) |
---|
72 | (lambda (tag) ; unlock-tag! |
---|
73 | ((storage-unlock-tag! be) tag)) |
---|
74 | (lambda () ; close! |
---|
75 | ((begin |
---|
76 | (close-database *db*) |
---|
77 | (storage-close! be)))))) |
---|
78 | |
---|
79 | |
---|
80 | (define backend |
---|
81 | (match (command-line-arguments) |
---|
82 | ((cachepath backend) |
---|
83 | (backend-cache cachepath (import-storage backend))) |
---|
84 | |
---|
85 | (else |
---|
86 | (printf "USAGE:\nbackend-cache <path-to-cache-file> \"<backend command line>\"\n") |
---|
87 | #f))) |
---|
88 | |
---|
89 | (if backend |
---|
90 | (export-storage! backend)) |
---|