steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Adding 'memcached' vocab to talk to memcached servers.

db4
John Benediktsson 2011-08-19 13:11:24 -07:00
parent 2d35b1b164
commit f960a194b5
5 changed files with 440 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
extra/memcached/authors.txt Normal file
View File

@ -0,0 +1 @@
John Benediktsson

122
extra/memcached/memcached-docs.factor Normal file
View File

@ -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 } "."
} ;

97
extra/memcached/memcached-tests.factor Normal file
View File

@ -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

219
extra/memcached/memcached.factor Normal file
View File

@ -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 ;

1
extra/memcached/summary.txt Normal file
View File

@ -0,0 +1 @@
Provides access to memcached, a high-performance, distributed memory object caching system.