1 ! Copyright (C) 2010 John Benediktsson
2 ! See http://factorcode.org/license.txt for BSD license
4 USING: accessors arrays assocs byte-arrays combinators fry
5 io io.encodings.binary io.sockets kernel make math math.parser
6 namespaces pack random sequences strings ;
14 ! - initial-value for incr/decr
17 SYMBOL: memcached-server
18 "127.0.0.1" 11211 <inet> memcached-server set-global
20 : with-memcached ( quot -- )
21 memcached-server get-global
22 binary [ call ] with-client ; inline
24 ERROR: key-not-found ;
26 ERROR: value-too-large ;
27 ERROR: invalid-arguments ;
28 ERROR: item-not-stored ;
29 ERROR: value-not-numeric ;
30 ERROR: unknown-command ;
31 ERROR: out-of-memory ;
39 CONSTANT: REPLACE 0x03
47 CONSTANT: VERSION 0x0B
51 CONSTANT: PREPEND 0x0F
55 CONSTANT: REPLACEQ 0x13
56 CONSTANT: DELETEQ 0x14
61 CONSTANT: APPENDQ 0x19
62 CONSTANT: PREPENDQ 0x1A
65 CONSTANT: NOT_FOUND 0x01
67 CONSTANT: TOO_LARGE 0x03
68 CONSTANT: INVALID_ARGS 0x04
69 CONSTANT: NOT_STORED 0x05
70 CONSTANT: NOT_NUMERIC 0x06
71 CONSTANT: UNKNOWN_CMD 0x81
74 TUPLE: request cmd key val extra opaque cas ;
76 : <request> ( cmd -- request )
77 "" "" "" random-32 0 \ request boa ;
79 : send-header ( request -- )
87 [ val>> length ] tri + +
92 ! magic, opcode, keylen, extralen, datatype, status,
93 ! bodylen, opaque, cas [ big-endian ]
94 '[ 0x80 _ _ _ 0 0 _ _ _ ] "CCSCCSIIQ" pack-be write ;
97 [ >byte-array write ] unless-empty ;
99 : send-request ( request -- )
107 : read-header ( -- header )
108 "CCSCCSIIQ" [ packed-length read ] [ unpack-be ] bi ;
110 : check-magic ( header -- )
111 first 0x81 = [ "bad magic" throw ] unless ;
113 : check-status ( header -- )
115 { NOT_FOUND [ key-not-found ] }
116 { EXISTS [ key-exists ] }
117 { TOO_LARGE [ value-too-large ] }
118 { INVALID_ARGS [ invalid-arguments ] }
119 { NOT_STORED [ item-not-stored ] }
120 { NOT_NUMERIC [ value-not-numeric ] }
121 { UNKNOWN_CMD [ unknown-command ] }
122 { MEMORY [ out-of-memory ] }
126 : check-opaque ( opaque header -- ? )
129 : (read) ( n -- str )
130 dup 0 > [ read >string ] [ drop "" ] if ;
132 : read-key ( header -- key )
133 [ 2 ] dip nth (read) ;
135 : read-val ( header -- val )
136 [ [ 6 ] dip nth ] [ [ 2 ] dip nth ] bi - (read) ;
138 : read-body ( header -- val key )
146 : read-response ( -- val key )
147 read-header read-body ;
149 : submit ( request -- response )
150 send-request read-response drop ;
152 : (cmd) ( key cmd -- request )
153 <request> swap >>key ;
155 : (incr/decr) ( amt key cmd -- response )
156 (cmd) swap '[ _ 0 0 ] "QQI" pack-be >>extra ! amt init exp
157 submit "Q" unpack-be first ;
159 : (mutate) ( val key cmd -- )
160 (cmd) swap >>val { 0 0 } "II" pack-be >>extra ! flags exp
163 : (cat) ( val key cmd -- )
164 (cmd) swap >>val submit drop ;
168 : m/version ( -- version ) VERSION <request> submit ;
170 : m/noop ( -- ) NOOP <request> submit drop ;
172 : m/incr-val ( amt key -- val ) INCR (incr/decr) ;
174 : m/incr ( key -- val ) 1 swap m/incr-val ;
176 : m/decr-val ( amt key -- val ) DECR (incr/decr) ;
178 : m/decr ( key -- val ) 1 swap m/decr-val ;
180 : m/get ( key -- val ) GET (cmd) submit 4 tail ;
182 : m/getq ( opaque key -- )
183 GETQ (cmd) swap >>opaque send-request ;
185 : m/getseq ( keys -- vals )
187 [ <enum> [ m/getq ] assoc-each ]
188 [ length 10 + NOOP <request> swap >>opaque send-request ]
192 _ read-header [ check-opaque ] keep swap
196 [ read-body drop 4 tail ]
197 [ [ 7 ] dip nth _ at ]
203 : m/set ( val key -- ) SET (mutate) ;
205 : m/add ( val key -- ) ADD (mutate) ;
207 : m/replace ( val key -- ) REPLACE (mutate) ;
209 : m/delete ( key -- ) DELETE (cmd) submit drop ;
211 : m/append ( val key -- ) APPEND (cat) ;
213 : m/prepend ( val key -- ) PREPEND (cat) ;
215 : m/flush-later ( seconds -- )
216 FLUSH <request> swap 1array "I" pack-be >>extra ! timebomb
219 : m/flush ( -- ) 0 m/flush-later ;
221 : m/stats ( -- stats )
222 STAT <request> send-request
223 [ read-response dup length 0 > ]
224 [ swap 2array ] produce 2nip ;
226 : m/quit ( -- ) QUIT <request> submit drop ;