Adding 'memcached' vocab to talk to memcached servers.
John Benediktsson
parent
2d35b1b164
commit
f960a194b5
|
|
@ -0,0 +1 @@
|
|||
John Benediktsson
|
||||
|
|
@ -0,0 +1,122 @@
|
|||
! Copyright (C) 2010 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: help.syntax help.markup io.sockets math memcached
|
||||
quotations sequences strings ;
|
||||
|
||||
IN: memcached
|
||||
|
||||
HELP: memcached-server
|
||||
{ $var-description
|
||||
"Holds an " { $link inet } " object with the address of "
|
||||
"an Memcached server."
|
||||
} ;
|
||||
|
||||
HELP: with-memcached
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description
|
||||
"Opens a network connection to the " { $link memcached-server }
|
||||
" and runs the specified quotation."
|
||||
} ;
|
||||
|
||||
HELP: m/get
|
||||
{ $values { "key" string } { "val" string } }
|
||||
{ $description
|
||||
"Gets a single key."
|
||||
} ;
|
||||
|
||||
HELP: m/set
|
||||
{ $values { "val" string } { "key" string } }
|
||||
{ $description
|
||||
"Sets a single key to a particular value, whether the item "
|
||||
"exists or not."
|
||||
} ;
|
||||
|
||||
HELP: m/add
|
||||
{ $values { "val" string } { "key" string } }
|
||||
{ $description
|
||||
"Adds an item only if the item does not already exist. "
|
||||
"If the item already exists, throws an error."
|
||||
} ;
|
||||
|
||||
HELP: m/replace
|
||||
{ $values { "val" string } { "key" string } }
|
||||
{ $description
|
||||
"Replaces an item only if it already eixsts. "
|
||||
"If the item does not exist, throws an error."
|
||||
} ;
|
||||
|
||||
HELP: m/delete
|
||||
{ $values { "key" string } }
|
||||
{ $description
|
||||
"Deletes an item."
|
||||
} ;
|
||||
|
||||
HELP: m/append
|
||||
{ $values { "val" string } { "key" string } }
|
||||
{ $description
|
||||
"Appends the value to the specified item."
|
||||
} ;
|
||||
|
||||
HELP: m/prepend
|
||||
{ $values { "val" string } { "key" string } }
|
||||
{ $description
|
||||
"Prepends the value to the specified item."
|
||||
} ;
|
||||
|
||||
HELP: m/incr
|
||||
{ $values { "key" string } }
|
||||
{ $description
|
||||
"Increments the value of the specified item by 1."
|
||||
} ;
|
||||
|
||||
HELP: m/incr-val
|
||||
{ $values { "amt" "key" string } }
|
||||
{ $description
|
||||
"Increments the value of the specified item by the specified amount."
|
||||
} ;
|
||||
|
||||
HELP: m/decr
|
||||
{ $values { "key" string } }
|
||||
{ $description
|
||||
"Decrements the value of the specified item by 1."
|
||||
} ;
|
||||
|
||||
HELP: m/decr-val
|
||||
{ $values { "amt" "key" string } }
|
||||
{ $description
|
||||
"Decrements the value of the specified item by the specified amount."
|
||||
} ;
|
||||
|
||||
HELP: m/version
|
||||
{ $description
|
||||
"Retrieves the version of the " { $link memcached-server } "."
|
||||
} ;
|
||||
|
||||
HELP: m/noop
|
||||
{ $description
|
||||
"Used as a keep-alive. Also flushes any outstanding quiet gets."
|
||||
} ;
|
||||
|
||||
HELP: m/stats
|
||||
{ $values { "stats" sequence } }
|
||||
{ $description
|
||||
"Get various statistics about the " { $link memcached-server } "."
|
||||
} ;
|
||||
|
||||
HELP: m/flush
|
||||
{ $description
|
||||
"Deletes all the items in the cache now."
|
||||
} ;
|
||||
|
||||
HELP: m/flush-later
|
||||
{ $values { "seconds" integer } }
|
||||
{ $description
|
||||
"Deletes all the items in the cache sometime in the future."
|
||||
} ;
|
||||
|
||||
HELP: m/quit
|
||||
{ $description
|
||||
"Close the connection to the " { $link memcached-server } "."
|
||||
} ;
|
||||
|
||||
|
|
@ -0,0 +1,97 @@
|
|||
! Copyright (C) 2010 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: calendar math math.functions memcached memcached.private
|
||||
kernel sequences threads tools.test ;
|
||||
|
||||
IN: memcached.tests
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: not-found? ( quot -- )
|
||||
[ "key not found" = ] must-fail-with ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! test version
|
||||
[ t ] [ [ m/version ] with-memcached length 0 > ] unit-test
|
||||
|
||||
! test simple set get
|
||||
[ m/flush ] with-memcached
|
||||
[ "valuex" "x" m/set ] with-memcached
|
||||
[ "valuex" ] [ [ "x" m/get ] with-memcached ] unit-test
|
||||
|
||||
! test flush
|
||||
[ m/flush ] with-memcached
|
||||
[ "valuex" "x" m/set "valuey" "y" m/set ] with-memcached
|
||||
[ "valuex" ] [ [ "x" m/get ] with-memcached ] unit-test
|
||||
[ "valuey" ] [ [ "y" m/get ] with-memcached ] unit-test
|
||||
[ m/flush ] with-memcached
|
||||
[ [ "x" m/get ] with-memcached ] not-found?
|
||||
[ [ "y" m/get ] with-memcached ] not-found?
|
||||
|
||||
! test noop
|
||||
[ m/noop ] with-memcached
|
||||
|
||||
! test delete
|
||||
[ m/flush ] with-memcached
|
||||
[ "valuex" "x" m/set ] with-memcached
|
||||
[ "valuex" ] [ [ "x" m/get ] with-memcached ] unit-test
|
||||
[ "x" m/delete ] with-memcached
|
||||
[ [ "x" m/get ] with-memcached ] not-found?
|
||||
|
||||
! test replace
|
||||
[ m/flush ] with-memcached
|
||||
[ [ "x" m/get ] with-memcached ] not-found?
|
||||
[ [ "ex" "x" m/replace ] with-memcached ] not-found?
|
||||
[ "ex" "x" m/add ] with-memcached
|
||||
[ "ex" ] [ [ "x" m/get ] with-memcached ] unit-test
|
||||
[ "ex2" "x" m/replace ] with-memcached
|
||||
[ "ex2" ] [ [ "x" m/get ] with-memcached ] unit-test
|
||||
|
||||
! test incr
|
||||
[ m/flush ] with-memcached
|
||||
[ 0 ] [ [ "x" m/incr ] with-memcached ] unit-test
|
||||
[ 1 ] [ [ "x" m/incr ] with-memcached ] unit-test
|
||||
[ 212 ] [ [ 211 "x" m/incr-val ] with-memcached ] unit-test
|
||||
[ 8589934804 ] [ [ 2 33 ^ "x" m/incr-val ] with-memcached ] unit-test
|
||||
|
||||
! test decr
|
||||
[ m/flush ] with-memcached
|
||||
[ "5" "x" m/set ] with-memcached
|
||||
[ 4 ] [ [ "x" m/decr ] with-memcached ] unit-test
|
||||
[ 0 ] [ [ 211 "x" m/decr-val ] with-memcached ] unit-test
|
||||
|
||||
! test timebombed flush
|
||||
[ m/flush ] with-memcached
|
||||
[ [ "x" m/get ] with-memcached ] not-found?
|
||||
[ "valuex" "x" m/set ] with-memcached
|
||||
[ "valuex" ] [ [ "x" m/get ] with-memcached ] unit-test
|
||||
[ 2 m/flush-later ] with-memcached
|
||||
[ "valuex" ] [ [ "x" m/get ] with-memcached ] unit-test
|
||||
3 seconds sleep
|
||||
[ [ "x" m/get ] with-memcached ] not-found?
|
||||
|
||||
! test append
|
||||
[ m/flush ] with-memcached
|
||||
[ "some" "x" m/set ] with-memcached
|
||||
[ "thing" "x" m/append ] with-memcached
|
||||
[ "something" ] [ [ "x" m/get ] with-memcached ] unit-test
|
||||
|
||||
! test prepend
|
||||
[ m/flush ] with-memcached
|
||||
[ "some" "x" m/set ] with-memcached
|
||||
[ "thing" "x" m/prepend ] with-memcached
|
||||
[ "thingsome" ] [ [ "x" m/get ] with-memcached ] unit-test
|
||||
|
||||
! test multi-get
|
||||
[ m/flush ] with-memcached
|
||||
[ H{ } ] [ [ { "x" "y" "z" } m/getseq ] with-memcached ] unit-test
|
||||
[ "5" "x" m/set ] with-memcached
|
||||
[ "valuex" "y" m/set ] with-memcached
|
||||
[ H{ { "x" "5" } { "y" "valuex" } } ]
|
||||
[ [ { "x" "y" "z" } m/getseq ] with-memcached ] unit-test
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,219 @@
|
|||
! Copyright (C) 2010 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: accessors arrays assocs byte-arrays combinators fry
|
||||
io io.encodings.binary io.sockets kernel make math math.parser
|
||||
namespaces pack random sequences strings ;
|
||||
|
||||
IN: memcached
|
||||
|
||||
! TODO:
|
||||
! - quiet commands
|
||||
! - CAS
|
||||
! - expirations
|
||||
! - initial-value for incr/decr
|
||||
|
||||
|
||||
SYMBOL: memcached-server
|
||||
"127.0.0.1" 11211 <inet> memcached-server set-global
|
||||
|
||||
: with-memcached ( quot -- )
|
||||
memcached-server get-global
|
||||
binary [ call ] with-client ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! Commands
|
||||
CONSTANT: GET HEX: 00
|
||||
CONSTANT: SET HEX: 01
|
||||
CONSTANT: ADD HEX: 02
|
||||
CONSTANT: REPLACE HEX: 03
|
||||
CONSTANT: DELETE HEX: 04
|
||||
CONSTANT: INCR HEX: 05
|
||||
CONSTANT: DECR HEX: 06
|
||||
CONSTANT: QUIT HEX: 07
|
||||
CONSTANT: FLUSH HEX: 08
|
||||
CONSTANT: GETQ HEX: 09
|
||||
CONSTANT: NOOP HEX: 0A
|
||||
CONSTANT: VERSION HEX: 0B
|
||||
CONSTANT: GETK HEX: 0C
|
||||
CONSTANT: GETKQ HEX: 0D
|
||||
CONSTANT: APPEND HEX: 0E
|
||||
CONSTANT: PREPEND HEX: 0F
|
||||
CONSTANT: STAT HEX: 10
|
||||
CONSTANT: SETQ HEX: 11
|
||||
CONSTANT: ADDQ HEX: 12
|
||||
CONSTANT: REPLACEQ HEX: 13
|
||||
CONSTANT: DELETEQ HEX: 14
|
||||
CONSTANT: INCRQ HEX: 15
|
||||
CONSTANT: DECRQ HEX: 16
|
||||
CONSTANT: QUITQ HEX: 17
|
||||
CONSTANT: FLUSHQ HEX: 18
|
||||
CONSTANT: APPENDQ HEX: 19
|
||||
CONSTANT: PREPENDQ HEX: 1A
|
||||
|
||||
! Errors
|
||||
CONSTANT: NOT_FOUND HEX: 01
|
||||
CONSTANT: EXISTS HEX: 02
|
||||
CONSTANT: TOO_LARGE HEX: 03
|
||||
CONSTANT: INVALID_ARGS HEX: 04
|
||||
CONSTANT: NOT_STORED HEX: 05
|
||||
CONSTANT: NOT_NUMERIC HEX: 06
|
||||
CONSTANT: UNKNOWN_CMD HEX: 81
|
||||
CONSTANT: MEMORY HEX: 82
|
||||
|
||||
TUPLE: request cmd key val extra opaque cas ;
|
||||
|
||||
: <request> ( cmd -- request )
|
||||
"" "" "" random-32 0 \ request boa ;
|
||||
|
||||
: send-header ( request -- )
|
||||
{
|
||||
[ cmd>> ]
|
||||
[ key>> length ]
|
||||
[ extra>> length ]
|
||||
[
|
||||
[ key>> length ]
|
||||
[ extra>> length ]
|
||||
[ val>> length ] tri + +
|
||||
]
|
||||
[ opaque>> ]
|
||||
[ cas>> ]
|
||||
} cleave
|
||||
! magic, opcode, keylen, extralen, datatype, status,
|
||||
! bodylen, opaque, cas [ big-endian ]
|
||||
'[ HEX: 80 _ _ _ 0 0 _ _ _ ] "CCSCCSIIQ" pack-be write ;
|
||||
|
||||
: (send) ( str -- )
|
||||
[ >byte-array write ] unless-empty ;
|
||||
|
||||
: send-request ( request -- )
|
||||
{
|
||||
[ send-header ]
|
||||
[ extra>> (send) ]
|
||||
[ key>> (send) ]
|
||||
[ val>> (send) ]
|
||||
} cleave flush ;
|
||||
|
||||
: read-header ( -- header )
|
||||
"CCSCCSIIQ" [ packed-length read ] [ unpack-be ] bi ;
|
||||
|
||||
: check-magic ( header -- )
|
||||
first HEX: 81 = [ "bad magic" throw ] unless ;
|
||||
|
||||
: check-status ( header -- )
|
||||
[ 5 ] dip nth {
|
||||
{ NOT_FOUND [ "key not found" throw ] }
|
||||
{ EXISTS [ "key exists" throw ] }
|
||||
{ TOO_LARGE [ "value too large" throw ] }
|
||||
{ INVALID_ARGS [ "invalid arguments" throw ] }
|
||||
{ NOT_STORED [ "item not stored" throw ] }
|
||||
{ NOT_NUMERIC [ "value not numeric" throw ] }
|
||||
{ UNKNOWN_CMD [ "unknown command" throw ] }
|
||||
{ MEMORY [ "out of memory" throw ] }
|
||||
[ drop ]
|
||||
} case ;
|
||||
|
||||
: check-opaque ( opaque header -- ? )
|
||||
[ 7 ] dip nth = ;
|
||||
|
||||
: (read) ( n -- str )
|
||||
dup 0 > [ read >string ] [ drop "" ] if ;
|
||||
|
||||
: read-key ( header -- key )
|
||||
[ 2 ] dip nth (read) ;
|
||||
|
||||
: read-val ( header -- val )
|
||||
[ [ 6 ] dip nth ] [ [ 2 ] dip nth ] bi - (read) ;
|
||||
|
||||
: read-body ( header -- val key )
|
||||
{
|
||||
[ check-magic ]
|
||||
[ check-status ]
|
||||
[ read-key ]
|
||||
[ read-val ]
|
||||
} cleave swap ;
|
||||
|
||||
: read-response ( -- val key )
|
||||
read-header read-body ;
|
||||
|
||||
: submit ( request -- response )
|
||||
send-request read-response drop ;
|
||||
|
||||
: (cmd) ( key cmd -- request )
|
||||
<request> swap >>key ;
|
||||
|
||||
: (incr/decr) ( amt key cmd -- response )
|
||||
(cmd) swap '[ _ 0 0 ] "QQI" pack-be >>extra ! amt init exp
|
||||
submit "Q" unpack-be first ;
|
||||
|
||||
: (mutate) ( val key cmd -- )
|
||||
(cmd) swap >>val { 0 0 } "II" pack-be >>extra ! flags exp
|
||||
submit drop ;
|
||||
|
||||
: (cat) ( val key cmd -- )
|
||||
(cmd) swap >>val submit drop ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: m/version ( -- version ) VERSION <request> submit ;
|
||||
|
||||
: m/noop ( -- ) NOOP <request> submit drop ;
|
||||
|
||||
: m/incr-val ( amt key -- val ) INCR (incr/decr) ;
|
||||
|
||||
: m/incr ( key -- val ) 1 swap m/incr-val ;
|
||||
|
||||
: m/decr-val ( amt key -- val ) DECR (incr/decr) ;
|
||||
|
||||
: m/decr ( key -- val ) 1 swap m/decr-val ;
|
||||
|
||||
: m/get ( key -- val ) GET (cmd) submit 4 tail ;
|
||||
|
||||
: m/getq ( opaque key -- )
|
||||
GETQ (cmd) swap >>opaque send-request ;
|
||||
|
||||
: m/getseq ( keys -- vals )
|
||||
[ H{ } clone ] dip
|
||||
[ <enum> [ m/getq ] assoc-each ]
|
||||
[ length 10 + NOOP <request> swap >>opaque send-request ]
|
||||
[
|
||||
<enum> [
|
||||
assoc-size 10 + '[
|
||||
_ read-header [ check-opaque ] keep swap
|
||||
]
|
||||
] [
|
||||
'[
|
||||
[ read-body drop 4 tail ]
|
||||
[ [ 7 ] dip nth _ at ]
|
||||
bi pick set-at
|
||||
]
|
||||
] bi until drop
|
||||
] tri ;
|
||||
|
||||
: m/set ( val key -- ) SET (mutate) ;
|
||||
|
||||
: m/add ( val key -- ) ADD (mutate) ;
|
||||
|
||||
: m/replace ( val key -- ) REPLACE (mutate) ;
|
||||
|
||||
: m/delete ( key -- ) DELETE (cmd) submit drop ;
|
||||
|
||||
: m/append ( val key -- ) APPEND (cat) ;
|
||||
|
||||
: m/prepend ( val key -- ) PREPEND (cat) ;
|
||||
|
||||
: m/flush-later ( seconds -- )
|
||||
FLUSH <request> swap 1array "I" pack-be >>extra ! timebomb
|
||||
submit drop ;
|
||||
|
||||
: m/flush ( -- ) 0 m/flush-later ;
|
||||
|
||||
: m/stats ( -- stats )
|
||||
STAT <request> send-request
|
||||
[ read-response dup length 0 > ]
|
||||
[ swap 2array ] produce 2nip ;
|
||||
|
||||
: m/quit ( -- ) QUIT <request> submit drop ;
|
||||
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Provides access to memcached, a high-performance, distributed memory object caching system.
|
||||
Loading…
Reference in New Issue