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

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

ugarit: Version 2 of the backend protocol, supporting better reporting back to the user, and administrative interfaces. Backends outfitted with admin interfaces, and a ugarit-archive-admin tool added to drive them.

File size: 5.1 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 *hits* 0)
24   (define *misses* 0)
25   (define *flushes* 0)
26
27   (define commit-interval 1000)
28   (define *updates-since-last-commit* 0)
29   (define (flush!)
30     (when (> *updates-since-last-commit* 0)
31      (inc! *flushes*)
32      (exec (sql *db* "COMMIT;"))
33      (exec (sql *db* "BEGIN;"))
34      (set! *updates-since-last-commit* 0)))
35   (define (maybe-flush!)
36     (inc! *updates-since-last-commit*)
37     (when (> *updates-since-last-commit* commit-interval)
38           ((storage-flush! be))
39           (flush!)))
40
41   (define (cache-set! key type)
42      (when type
43            (begin
44              (exec cache-set-query key (symbol->string type))
45              (maybe-flush!)))
46      type)
47
48   (define (cache-get key)
49      (let ((result
50             (query fetch cache-get-query key)))
51        (if (pair? result)
52            (string->symbol (car result))
53            #f)))
54
55   (define (cache-delete! key)
56     (exec cache-delete-query key)
57     (maybe-flush!))
58
59   (define (cache-clear!)
60     (exec (sql *db* "DELETE FROM cache")))
61
62   (make-storage
63      (storage-max-block-size be)
64      (storage-writable? be)
65      (storage-unlinkable? be)
66      (lambda (key data type) ; put!
67         (begin
68            ((storage-put! be) key data type)
69            (cache-set! key type)
70            (void)))
71      (lambda ()                        ; flush!
72        (begin
73          ((storage-flush! be))
74          (flush!)
75          (void)))
76      (lambda (key) ; exists?
77        (let ((cached-result (cache-get key)))
78          (if cached-result
79              (begin
80                (inc! *hits*)
81                cached-result)
82              (begin
83                (inc! *misses*)
84                (cache-set! key ((storage-exists? be) key))))))
85      (lambda (key) ; get
86         ((storage-get be) key))
87      (lambda (key) ; link!
88         ((storage-link! be) key))
89      (lambda (key) ; unlink!
90         (let ((result ((storage-unlink! be) key)))
91            (if result
92               (begin
93                  (cache-delete! key)
94                  result)
95               result)))
96      (lambda (tag key) ; set-tag!
97        ((storage-set-tag! be) tag key)
98        ((storage-flush! be))
99        (flush!))
100      (lambda (tag) ; tag
101         ((storage-tag be) tag))
102      (lambda () ; all-tags
103         ((storage-all-tags be)))
104      (lambda (tag) ; remove-tag!
105         ((storage-remove-tag! be) tag)
106         ((storage-flush! be))
107         (flush!))
108      (lambda (tag) ; lock-tag!
109         (let ((result ((storage-lock-tag! be) tag)))
110           ((storage-flush! be))
111           (flush!)
112           result))
113      (lambda (tag) ; tag-locked?
114         ((storage-tag-locked? be) tag))
115      (lambda (tag) ; unlock-tag!
116         ((storage-unlock-tag! be) tag)
117          ((storage-flush! be))
118          (flush!))
119      (lambda (command) ; admin!
120        (match command
121               (('info)
122                (list (cons 'backend "cache")
123                      (cons 'block-size (storage-max-block-size be))
124                      (cons 'writable? (storage-writable? be))
125                      (cons 'unlinkable? (storage-unlinkable? be))
126                      (cons 'cache-file cachepath)
127                      (cons 'commit-interval commit-interval)))
128               (('help)
129                (list (cons 'info "Return information about the archive")
130                      (cons 'help "List available admin commands")
131                      (cons 'stats "Examine the cache and report back statistics")
132                      (cons 'clear! "Clear the cache")))
133               (('stats)
134                (list (cons 'entries (car (query fetch (sql *db* "SELECT COUNT(*) FROM cache"))))))
135               (('clear!)
136                (cache-clear!)
137                (flush!)
138                (list (cons 'result "Done")))
139               (else (error "Unknown admin command"))))
140      (lambda () ; close!
141        (begin
142          ((backend-log!) 'info (sprintf "Cache hits: ~A misses: ~A flushes: ~A" *hits* *misses* *flushes*))
143          ((storage-close! be))
144          (exec (sql *db* "COMMIT;"))
145          (close-database *db*)))))
146
147
148(define backend
149  (match (command-line-arguments)
150         ((cachepath backend)
151          (lambda () (backend-cache cachepath (import-storage backend))))
152
153         (else
154          (export-storage-error! "Invalid arguments to backend-cache")
155          (printf "USAGE:\nbackend-cache <path-to-cache-file> \"<backend command line>\"\n")
156          #f)))
157
158(if backend
159    (export-storage! backend))
Note: See TracBrowser for help on using the repository browser.