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

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

ugarit: Many minor improvements to crash safety (see README.txt)

File size: 9.3 KB
Line 
1(module ugarit-backend
2        (make-storage ; Storage records
3         storage?
4         storage-max-block-size
5         storage-writable?
6         storage-unlinkable?
7         storage-put!
8         storage-flush!
9         storage-exists?
10         storage-get
11         storage-link!
12         storage-unlink!
13         storage-set-tag!
14         storage-tag
15         storage-all-tags
16         storage-remove-tag!
17         storage-lock-tag!
18         storage-tag-locked?
19         storage-unlock-tag!
20         storage-close!
21
22         export-storage! ; Export a storage via stdin/stdout
23         import-storage ; Create a storage from a command line
24         )
25
26(import scheme)
27(import chicken)
28
29(use ports)
30(use matchable)
31(use posix)
32(use srfi-4)
33
34
35(define-record storage
36  max-block-size  ; Integer: largest size of block we can store
37  writable? ; Boolean: Can we call put!, link!, unlink!, set-tag!, lock-tag!, unlock-tag!?
38  unlinkable? ; Boolean: Can we call unlink?
39  put! ; Procedure: (put! key data type) - stores the data (u8vector) under the key (string) with the given type tag (symbol) and a refcount of 1. Does nothing of the key is already in use.
40  flush! ; Procedure: (flush!) - all previous changes must be flushed to disk by the time the continuation is applied.
41  exists? ; Procedure: (exists? key) - returns the type of the block with the given key if it exists, or #f otherwise
42  get ; Procedure: (get key) - returns the contents (u8vector) of the block with the given key (string) if it exists, or #f otherwise
43  link! ; Procedure: (link key) - increments the refcount of the block
44  unlink! ; Procedure: (unlink key) - decrements the refcount of the block. If it's now zero, deletes it but returns its value as a u8vector. If not, returns #f.
45  set-tag! ; Procedure: (set-tag! name key) - assigns the given key (string) to the given tag (named with a string). Creates a new tag if the name has not previously been used, otherwise updates an existing tag
46  tag ; Procedure: (tag name) - returns the key assigned to the given tag, or #f if it does not exist.
47  all-tags ; Procedure: (all-tags) - returns a list of all existing tag names
48  remove-tag! ; Procedure: (remove-tag! name) - removes the named tag
49  lock-tag! ; Procedure: (lock-tag! name) - locks the named tag, or blocks if already locked
50  tag-locked? ; Procedure: (tag-locked? name) - returns the locker identity string if the tag is locked, #f otherwise
51  unlock-tag! ; Procedure: (unlock-tag! name) - unlocks the named tag
52  close!)  ; Procedure: (close!) - closes the storage engine
53
54(define *magic* 'ugarit-backend-protocol-1)
55
56(define (describe-exception exn)
57  (list (##sys#slot exn 1) (##sys#slot exn 2)))
58
59(define-syntax with-error-reporting
60  (er-macro-transformer
61   (lambda (e r c)
62     (let ((body (cdr e)))
63       `(,(r 'call-with-current-continuation)
64         (,(r 'lambda) (,(r 'escape))
65          (,(r 'with-exception-handler)
66           (,(r 'lambda) (,(r 'k))
67            (,(r 'write) (,(r 'list) "error" (,(r 'describe-exception) ,(r 'k))))
68            (,(r 'escape) #f))
69           (,(r 'lambda) ()
70            ,@body))))))))
71
72;; Given a storage object, provide the storage remote access protocol
73;; via current-input-port / current-output-port until the storage is closed
74;; via the protocol.
75(define (export-storage! storage)
76  (set-buffering-mode! (current-output-port) #:none)
77
78  ; Write the header
79  (write *magic*) (newline)
80  (write (list (storage-max-block-size storage)
81               (storage-writable? storage)
82               (storage-unlinkable? storage)))
83
84  ; Engage command loop
85  (let loop ()
86    (newline)
87    (let ((command (read)))
88      (if (eof-object? command)
89          (begin
90            (with-error-reporting
91             ((storage-close! storage))
92             (write "goodbye"))
93            (void))
94          (match
95           command
96
97           (('put! key type length)
98            (let ((data (read-u8vector length)))
99              (with-error-reporting
100               ((storage-put! storage) key data type)
101               (write #t)))
102            (loop))
103
104           (('flush!)
105            (with-error-reporting
106             ((storage-flush! storage))
107             (write #t))
108            (loop))
109
110           (('exists? key)
111            (with-error-reporting
112             (write ((storage-exists? storage) key)))
113            (loop))
114
115           (('get key)
116            (with-error-reporting
117             (let ((data ((storage-get storage) key)))
118               (if data
119                   (begin
120                    (write (list (u8vector-length data)))
121                    (write-u8vector data))
122                   (write #f))))
123            (loop))
124
125           (('link! key)
126            (with-error-reporting
127             ((storage-link! storage) key)
128             (write #t))
129            (loop))
130
131           (('unlink! key)
132            (with-error-reporting
133             (let ((data ((storage-unlink! storage) key)))
134               (if data
135                   (begin
136                     (write (list (u8vector-length data)))
137                     (write-u8vector data))
138                   (write #f))))
139            (loop))
140
141           (('set-tag! name key)
142            (with-error-reporting
143             ((storage-set-tag! storage) name key)
144             (write #t))
145            (loop))
146
147           (('tag name)
148            (with-error-reporting
149             (write ((storage-tag storage) name)))
150            (loop))
151
152           (('all-tags)
153            (with-error-reporting
154             (write ((storage-all-tags storage))))
155            (loop))
156
157           (('remove-tag! name)
158            (with-error-reporting
159             ((storage-remove-tag! storage) name)
160             (write #t))
161            (loop))
162
163           (('lock-tag! name)
164            (with-error-reporting
165             ((storage-lock-tag! storage) name)
166             (write #t))
167            (loop))
168
169           (('tag-locked? name)
170            (with-error-reporting
171             (write ((storage-tag-locked? storage) name)))
172            (loop))
173
174           (('unlock-tag! name)
175            (with-error-reporting
176             ((storage-unlock-tag! storage) name)
177             (write #t))
178            (loop))
179
180           (('close!)
181            (with-error-reporting
182             ((storage-close! storage))
183             (write "goodbye"))
184            (void))
185
186           (else
187            (write (list "error" (sprintf "Bad command ~s" command)))
188            (loop)))))))
189
190(define (read-response port)
191  (let ((response (read port)))
192   (match response
193          (("error" err) (error "Backend protocol error" err))
194          (else response))))
195
196(define (read-response-body port)
197  (let ((response (read-response port)))
198    (if response
199        (read-u8vector (car response) port)
200        #f)))
201
202;; Given the command line to a storage remote access protocol server,
203;; activate it and return a storage object providing access to the
204;; server.
205(define (import-storage command-line . args)
206  (let-optionals args ((debug #f))
207   (let-values (((responses commands pid)
208                 (process command-line)))
209
210     #;(set-buffering-mode! commands #:none)
211
212     (if debug (print "~a: process opened" command-line))
213     (let ((magic (read responses)))
214       (if debug (print "~a: read magic ~a" command-line magic))
215       (if (not (equal? magic *magic*))
216           (error "Invalid backend protocol header magic" magic))
217
218       (let ((header (read responses)))
219         (if debug (print "~a: read header" command-line header))
220         (if (not (list? header))
221             (error "Invalid backend protocol header" header))
222         (if (not (= (length header) 3))
223             (error "Invalid backend protocol header" header))
224         (let ((max-block-size (car header))
225               (writable? (cadr header))
226               (unlinkable? (caddr header)))
227           (make-storage
228            max-block-size
229            writable?
230            unlinkable?
231
232            (lambda (key data type)     ; put!
233              (if debug (printf "~a: put!" command-line))
234              (write `(put! ,key ,type ,(u8vector-length data)) commands)
235              (write-u8vector data commands)
236              (read-response responses)
237              (void))
238
239            (lambda ()                  ; flush!
240              (if debug (printf "~a: flush!" command-line))
241              (write `(flush!) commands)
242              (read-response responses)
243              (void))
244
245            (lambda (key)               ; exists?
246              (if debug (printf "~a: exists?" command-line))
247              (write `(exists? ,key) commands)
248              (read-response responses))
249
250            (lambda (key)               ; get
251              (if debug (printf "~a: get" command-line))
252              (write `(get ,key) commands)
253              (read-response-body responses))
254
255            (lambda (key)               ; link!
256              (if debug (printf "~a: link!" command-line))
257              (write `(link! ,key) commands)
258              (read-response responses)
259              (void))
260
261            (lambda (key)               ; unlink!
262              (if debug (printf "~a: unlink! ~s" command-line key))
263              (write `(unlink! ,key) commands)
264              (read-response-body responses))
265
266            (lambda (name key)          ; set-tag!
267              (if debug (printf "~a: set-tag!" command-line))
268              (write `(set-tag! ,name ,key) commands)
269              (read-response responses)
270              (void))
271
272            (lambda (name)              ; tag
273              (if debug (printf "~a: tag" command-line))
274              (write `(tag ,name) commands)
275              (read-response responses))
276
277            (lambda ()                  ; all-tags
278              (if debug (printf "~a: all-tags" command-line))
279              (write `(all-tags) commands)
280              (read-response responses))
281
282            (lambda (name)              ; remove-tag!
283              (if debug (printf "~a: remove-tag!" command-line))
284              (write `(remove-tag! ,name) commands)
285              (read-response responses)
286              (void))
287
288            (lambda (name)              ; lock-tag!
289              (if debug (printf "~a: lock-tag!" command-line))
290              (write `(lock-tag! ,name) commands)
291              (read-response responses)
292              (void))
293
294            (lambda (name)              ; tag-locked?
295              (if debug (printf "~a: tag-locked?" command-line))
296              (write `(tag-locked? ,name) commands)
297              (read-response responses))
298
299            (lambda (name)              ; unlock-tag!
300              (if debug (printf "~a: unlock-tag!" command-line))
301              (write `(unlock-tag! ,name) commands)
302              (read-response responses)
303              (void))
304
305            (lambda ()                  ; close!
306              (if debug (printf "~a: close!!" command-line))
307              (write '(close!) commands)
308              (read-response responses)
309              (close-input-port responses)
310              (close-output-port commands)
311              (void)))))))))
312
313)
Note: See TracBrowser for help on using the repository browser.