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

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

ugarit: Better use of sqlite, which will hopefully improve performance. 1.0.1 release.

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