source: project/memcached/trunk/memcached.scm @ 4642

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

Single-server implementation

File size: 8.9 KB
Line 
1(declare (export
2        single-memcache-connect single-memcache-disconnect
3        single-memcache-set!
4        single-memcache-add!
5        single-memcache-replace!
6        single-memcache-get
7        single-memcache-get*
8        single-memcache-incr!
9        single-memcache-delete!
10        single-memcache-flush!
11
12        memcache-connect memcache-disconnect
13        memcache-set! memcache-set*!
14        memcache-add! memcache-add*!
15        memcache-replace! memcache-replace*!
16        memcache-get memcache-get*
17        memcache-incr! memcache-decr!
18        memcache-delete! memcache-delete*!
19        memcache-flush!))
20
21(require-extension srfi-1) ;lists
22(require-extension srfi-4) ;u8vectors
23(require-extension tcp) ;TCP ports
24(require-extension srfi-9) ;Records
25(require-extension srfi-13) ;String tools
26(require-extension regex) ;Regular expressions
27
28;; A few utility functions to massage input data into canonical forms
29
30;; Keys may be in one of two forms: a string, in which case we compute
31;; a hash ourselves, or (<int> <string>), in which case we use the int
32;; as the hash.
33
34(define (key-hash k)
35        (cond
36                ((pair? k) (car k))
37                ((string? k) (u8vector-hash k))
38                (else
39                (error "Keys must either by strings, or lists with an integer as the first element and a string as the second element"))))
40
41(define (key-key k)
42        (cond
43                ((pair? k) (cadr k))
44                ((string? k) k)
45                (else
46                (error "Keys must either by strings, or lists with an integer as the first element and a string as the second element"))))
47
48;;;; A small internal interface for connecting to a single memcached server
49;; At this level, keys are always strings
50
51(define-record-type memcache-server
52        (make-memcache-server hostname port in out live avoid-until)
53        memcache-server?
54        (hostname get-hostname)
55        (port get-port)
56        (in in-port set-in-port!)
57        (out out-port set-out-port!)
58        (live live? set-live!)
59        (avoid-until avoid-until set-avoid-until!))
60
61(define (single-memcache-connect hostname port)
62        (call-with-values (lambda () (tcp-connect hostname port))
63                (lambda (in out) (make-memcache-server hostname port in out #t #f))))
64
65(define (single-memcache-disconnect mcs)
66        (set-live! mcs #f)
67        (set-in-port! mcs #f)
68        (set-out-port! mcs #f)
69        (set-avoid-until! mcs #f)
70
71(define (single-memcache-usable? mcs)
72        (if (live? mcs)
73                #t
74                (if (= (avoid-until mcs) #f)
75                                #f ; deliberately closed down
76                ;; FIXME: If we're after the avoid-until date, attempt to reconnect;
77                ;; if we succeed, set the in in-port and out-port and set live.
78                ;; If not, add a timeout to avoid-until and return #f.
79                ;; Then wrap every operation in a handy macro that
80                ;; wraps in (if (single-memcache-usable? mcs) ...body...) and an
81                ;; exception catch thingy that, in the event of I/O exceptions,
82                ;; disconnects the mcs and sets avoid-until to a suitable timeout.
83
84;; Returns #t for stored, or #f for not stored for some good reason.
85(define (single-memcache-storage! operation mcs key flags exptime value)
86        (begin
87                (with-output-to-port (out-port mcs)
88                        (lambda ()
89                                (write-string operation)
90                                (write-string " ")
91                                (write-string key)
92                                (write-string " ")
93                                (write flags)
94                                (write-string " ")
95                                (write exptime)
96                                (write-string " ")
97                                (write (u8vector-length value))
98                                (write-string "\r\n")
99                                (write-u8vector value)
100                                (write-string "\r\n")
101                                (flush-output)))
102                (with-input-from-port (in-port mcs)
103                        (lambda ()
104                                (let ((result (read-line)))
105                                        (cond
106                                                ((equal? result "STORED") #t)
107                                                ((equal? result "NOT_STORED") #f)
108                                                (else (error "Error from memcached server" result))))))))
109
110(define (single-memcache-set! mcs key flags exptime value)
111        (single-memcache-storage! "set" mcs key flags exptime value))
112
113(define (single-memcache-add! mcs key flags exptime value)
114        (single-memcache-storage! "add" mcs key flags exptime value))
115
116(define (single-memcache-replace! mcs key flags exptime value)
117        (single-memcache-storage! "replace" mcs key flags exptime value))
118
119;; A regexp to match a VALUE line sent back from a GET request
120(define single-memcache-values-regex
121        (regexp "^VALUE ([^ ]+) ([0-9]+) ([0-9]+)"))
122
123;; Read back the values returned by the server from a GET request
124;; The result is a list of the form:
125;; ((key flags value) (key flags value)...)
126;; in order to tail recurse, we accept a starting alist as an argument.
127(define (single-memcache-read-keys-to-alist alist)
128        (let ((line (read-line)))
129                (if (equal? line "END")
130                        alist
131                        (let ((match (string-match single-memcache-values-regex line)))
132                                (if (not match)
133                                        (error "Invalid response from memcache server" line)
134                                        (let*
135                                                ((key (second match))
136                                                 (flags (string->number (third match)))
137                                                 (length (string->number (fourth match)))
138                                                 (value (read-u8vector length))
139                                                 (crlf (read-line)))
140                                                (single-memcache-read-keys-to-alist
141                                                        (cons
142                                                                (list key flags value)
143                                                                alist))))))))
144
145;; Organise a neat result. The actual alist returned by server
146;; and parsed by the above function may return values in any order,
147;; and miss values the server did not have.
148;; if the user asked for ("a" "b" "c") and the server replied with values
149;; for c and b, this function tidies up the result and gives ("c value" #f "a value").
150;; Why that way round? Well, to make the recursion neat, we need the keys
151;; list in reverse order. Sorry!
152;; We strip off the keys of the alist, thus just returning a list of lists
153;; of the form (flags value), or #fs.
154;; In order to tail-recurse, we accept a starting list.
155(define (single-memcache-organise-result keys alist list)
156        (if (null? keys)
157                list
158                (single-memcache-organise-result
159                        (cdr keys)
160                        alist
161                        (cons (assoc (car keys) alist) list))))
162
163;; (single-memcache-organise-result '("a" "b" "c") '(("c" "value of c") ("a" "value of a")) '())
164;; => (("c" "value of c") #f ("a" "value of a"))
165
166;; Returns a list, one element per key supplied; each element is a list of flags and value.
167(define (single-memcache-get* mcs keys)
168        (begin
169                (with-output-to-port (out-port mcs)
170                        (lambda ()
171                                (write-string "get ")
172                                (write-string (string-join keys))
173                                (write-string "\r\n")
174                                (flush-output)))
175                (with-input-from-port (in-port mcs)
176                        (lambda ()
177                                (single-memcache-organise-result (reverse keys) (single-memcache-read-keys-to-alist '()) '())))))
178
179;; Returns a list of flags and value.
180(define (single-memcache-get mcs key)
181        (car (single-memcache-get* mcs (list key))))
182
183;; Returns #t if the item was deleted OK, #f if it was not found.
184(define (single-memcache-delete! mcs key time)
185        (begin
186                (with-output-to-port (out-port mcs)
187                        (lambda ()
188                                (write-string "delete ")
189                                (write-string key)
190                                (write-string " ")
191                                (write time)
192                                (write-string "\r\n")
193                                (flush-output)))
194                (with-input-from-port (in-port mcs)
195                        (lambda ()
196                                (let ((result (read-line)))
197                                        (cond
198                                                ((equal? result "DELETED") #t)
199                                                ((equal? result "NOT_FOUND") #f)
200                                                (else (error "Error from memcached server" result))))))))
201
202(define (single-memcache-delta! operation mcs key delta)
203        (begin
204                (with-output-to-port (out-port mcs)
205                        (lambda ()
206                                (write-string operation)
207                                (write-string " ")
208                                (write-string key)
209                                (write-string " ")
210                                (write delta)
211                                (write-string "\r\n")
212                                (flush-output)))
213                (with-input-from-port (in-port mcs)
214                        (lambda ()
215                                (let ((result (read-line)))
216                                        (if (equal? result "NOT_FOUND")
217                                                #f
218                                                (string->number result)))))))
219
220(define (single-memcache-incr! mcs key delta)
221        (single-memcache-delta! "incr" mcs key delta))
222
223(define (single-memcache-decr! mcs key delta)
224        (single-memcache-delta! "decr" mcs key delta))
225
226(define (single-memcache-flush! mcs delay)
227        (begin
228                (with-output-to-port (out-port mcs)
229                        (lambda ()
230                                (write-string "flush_all")
231                                (if (> delay 0)
232                                        (begin
233                                                (write-string " ")
234                                                (write delay)))
235                                (write-string "\r\n")
236                                (flush-output)))
237                (with-input-from-port (in-port mcs)
238                        (lambda ()
239                                (let ((result (read-line)))
240                                        (if (equal? result "OK")
241                                                #t
242                                                (error "Error from memcached server" result)))))))
243
244
245(define (single-memcache-test hostname port)
246        (let ((mcs (single-memcache-connect hostname port)))
247                (begin
248                        (single-memcache-set! mcs "Hello" 0 0 '#u8(104 101 108 108 111))
249                        (display (single-memcache-get* mcs '("Hello" "world")))
250                        (newline)
251                        (single-memcache-delete! mcs "Hello" 0)
252                        (display (single-memcache-get* mcs '("Hello" "world")))
253                        (newline)
254                        (single-memcache-set! mcs "Hello" 0 0 '#u8(49 48)) ; 10
255                        (single-memcache-decr! mcs "Hello" 1)
256                        (display (single-memcache-get* mcs '("Hello" "world")))
257                        (newline)
258                        (single-memcache-incr! mcs "Hello" 1)
259                        (display (single-memcache-get* mcs '("Hello" "world")))
260                        (newline)
261                        (single-memcache-flush! mcs 0)
262                        (display (single-memcache-get* mcs '("Hello" "world")))
263                        (newline)
264                        )))
265                       
266;; (single-memcache-test "devel.curiosity" 11211)
267
268
269;; Memcache cluster operation
270
271;; Notes:
272;; 1) Mutex the server objects
273;; 2) Every operation should compute the list of servers to access,
274;;    sort them by hostname and port, then lock them in that order,
275;;    use them, then unlock them.
276;; 3) When a server is down, we don't care - just /dev/null any object stored
277;;    there and return nil for any gets. I think that's the best approach.
Note: See TracBrowser for help on using the repository browser.