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

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

ugarit: Added missing file

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