source: project/release/4/ugarit/trunk/backend-cache.scm @ 25565

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

ugarit: tag locking, and strict enforcement of maximum file size in splitlog archives

File size: 3.6 KB
Line 
1(use ugarit-backend)
2(use sql-de-lite)
3(use matchable)
4(use miscmacros)
5
6(define cache-sql-schema
7  (list
8   "CREATE TABLE cache (key TEXT PRIMARY KEY, type TEST);"))
9
10(define (backend-cache cachepath be)
11   (define *db* (open-database cachepath))
12   (change-file-mode cachepath (bitwise-ior perm/irusr perm/iwusr))
13   (when (null? (schema *db*))
14         (for-each (lambda (statement)
15                     (exec (sql *db* statement)))
16                   cache-sql-schema))
17   (exec (sql *db* "BEGIN;"))
18
19   (define cache-set-query (sql *db* "INSERT OR REPLACE INTO cache (key, type) VALUES (?,?)"))
20   (define cache-get-query (sql *db* "SELECT type FROM cache WHERE key = ?"))
21   (define cache-delete-query (sql *db* "DELETE FROM cache WHERE key = ?"))
22
23   (define commit-interval 1000)
24   (define *updates-since-last-commit* 0)
25   (define (flush!)
26     (when (> *updates-since-last-commit* 0)
27      (exec (sql *db* "COMMIT;"))
28      (exec (sql *db* "BEGIN;"))
29      (set! *updates-since-last-commit* 0)))
30   (define (maybe-flush!)
31     (inc! *updates-since-last-commit*)
32     (when (> *updates-since-last-commit* commit-interval)
33           ((storage-flush! be))
34           (flush!)))
35
36   (define (cache-set! key type)
37      (when type
38            (begin
39              (exec cache-set-query key (symbol->string type))
40              (maybe-flush!)))
41      type)
42
43   (define (cache-get key)
44      (let ((result
45             (query fetch cache-get-query key)))
46        (if (pair? result)
47            (string->symbol (car result))
48            #f)))
49
50   (define (cache-delete! key)
51     (exec cache-delete-query key)
52     (maybe-flush!))
53
54   (make-storage
55      (storage-max-block-size be)
56      (storage-writable? be)
57      (storage-unlinkable? be)
58      (lambda (key data type) ; put!
59         (begin
60            ((storage-put! be) key data type)
61            (cache-set! key type)
62            (void)))
63      (lambda ()                        ; flush!
64        (begin
65          ((storage-flush! be))
66          (flush!)
67          (void)))
68      (lambda (key) ; exists?
69         (or
70            (cache-get key)
71            (cache-set! key ((storage-exists? be) key))))
72      (lambda (key) ; get
73         ((storage-get be) key))
74      (lambda (key) ; link!
75         ((storage-link! be) key))
76      (lambda (key) ; unlink!
77         (let ((result ((storage-unlink! be) key)))
78            (if result
79               (begin
80                  (cache-delete! key)
81                  result)
82               result)))
83      (lambda (tag key) ; set-tag!
84        ((storage-set-tag! be) tag key)
85        ((storage-flush! be))
86        (flush!))
87      (lambda (tag) ; tag
88         ((storage-tag be) tag))
89      (lambda () ; all-tags
90         ((storage-all-tags be)))
91      (lambda (tag) ; remove-tag!
92         ((storage-remove-tag! be) tag)
93         ((storage-flush! be))
94         (flush!))
95      (lambda (tag) ; lock-tag!
96         (let ((result ((storage-lock-tag! be) tag)))
97           ((storage-flush! be))
98           (flush!)
99           result))
100      (lambda (tag) ; tag-locked?
101         ((storage-tag-locked? be) tag))
102      (lambda (tag) ; unlock-tag!
103         ((storage-unlock-tag! be) tag)
104          ((storage-flush! be))
105          (flush!))
106      (lambda () ; close!
107        (begin
108          ((storage-close! be))
109          (exec (sql *db* "COMMIT;"))
110          (close-database *db*)))))
111
112
113(define backend
114  (match (command-line-arguments)
115         ((cachepath backend)
116          (backend-cache cachepath (import-storage backend)))
117
118         (else
119          (printf "USAGE:\nbackend-cache <path-to-cache-file> \"<backend command line>\"\n")
120          #f)))
121
122(if backend
123    (export-storage! backend))
Note: See TracBrowser for help on using the repository browser.