extra/memcached/memcached.factor

   1 ! Copyright (C) 2010 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   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 ;
   7
   8 IN: memcached
   9
  10 ! TODO:
  11 ! - quiet commands
  12 ! - CAS
  13 ! - expirations
  14 ! - initial-value for incr/decr
  15
  16
  17 SYMBOL: memcached-server
  18 "127.0.0.1" 11211 <inet> memcached-server set-global
  19
  20 : with-memcached ( quot -- )
  21     memcached-server get-global
  22     binary [ call ] with-client ; inline
  23
  24 <PRIVATE
  25
  26 ! Commands
  27 CONSTANT: GET      HEX: 00
  28 CONSTANT: SET      HEX: 01
  29 CONSTANT: ADD      HEX: 02
  30 CONSTANT: REPLACE  HEX: 03
  31 CONSTANT: DELETE   HEX: 04
  32 CONSTANT: INCR     HEX: 05
  33 CONSTANT: DECR     HEX: 06
  34 CONSTANT: QUIT     HEX: 07
  35 CONSTANT: FLUSH    HEX: 08
  36 CONSTANT: GETQ     HEX: 09
  37 CONSTANT: NOOP     HEX: 0A
  38 CONSTANT: VERSION  HEX: 0B
  39 CONSTANT: GETK     HEX: 0C
  40 CONSTANT: GETKQ    HEX: 0D
  41 CONSTANT: APPEND   HEX: 0E
  42 CONSTANT: PREPEND  HEX: 0F
  43 CONSTANT: STAT     HEX: 10
  44 CONSTANT: SETQ     HEX: 11
  45 CONSTANT: ADDQ     HEX: 12
  46 CONSTANT: REPLACEQ HEX: 13
  47 CONSTANT: DELETEQ  HEX: 14
  48 CONSTANT: INCRQ    HEX: 15
  49 CONSTANT: DECRQ    HEX: 16
  50 CONSTANT: QUITQ    HEX: 17
  51 CONSTANT: FLUSHQ   HEX: 18
  52 CONSTANT: APPENDQ  HEX: 19
  53 CONSTANT: PREPENDQ HEX: 1A
  54
  55 ! Errors
  56 CONSTANT: NOT_FOUND    HEX: 01
  57 CONSTANT: EXISTS       HEX: 02
  58 CONSTANT: TOO_LARGE    HEX: 03
  59 CONSTANT: INVALID_ARGS HEX: 04
  60 CONSTANT: NOT_STORED   HEX: 05
  61 CONSTANT: NOT_NUMERIC  HEX: 06
  62 CONSTANT: UNKNOWN_CMD  HEX: 81
  63 CONSTANT: MEMORY       HEX: 82
  64
  65 TUPLE: request cmd key val extra opaque cas ;
  66
  67 : <request> ( cmd -- request )
  68     "" "" "" random-32 0 \ request boa ;
  69
  70 : send-header ( request -- )
  71     {
  72         [ cmd>> ]
  73         [ key>> length ]
  74         [ extra>> length ]
  75         [
  76             [ key>> length ]
  77             [ extra>> length ]
  78             [ val>> length ] tri + +
  79         ]
  80         [ opaque>> ]
  81         [ cas>> ]
  82     } cleave
  83     ! magic, opcode, keylen, extralen, datatype, status,
  84     ! bodylen, opaque, cas [ big-endian ]
  85     '[ HEX: 80 _ _ _ 0 0 _ _ _ ] "CCSCCSIIQ" pack-be write ;
  86
  87 : (send) ( str -- )
  88     [ >byte-array write ] unless-empty ;
  89
  90 : send-request ( request -- )
  91     {
  92         [ send-header    ]
  93         [ extra>> (send) ]
  94         [ key>>   (send) ]
  95         [ val>>   (send) ]
  96     } cleave flush ;
  97
  98 : read-header ( -- header )
  99     "CCSCCSIIQ" [ packed-length read ] [ unpack-be ] bi ;
 100
 101 : check-magic ( header -- )
 102     first HEX: 81 = [ "bad magic" throw ] unless ;
 103
 104 : check-status ( header -- )
 105     [ 5 ] dip nth {
 106         { NOT_FOUND    [ "key not found" throw     ] }
 107         { EXISTS       [ "key exists" throw        ] }
 108         { TOO_LARGE    [ "value too large" throw   ] }
 109         { INVALID_ARGS [ "invalid arguments" throw ] }
 110         { NOT_STORED   [ "item not stored" throw   ] }
 111         { NOT_NUMERIC  [ "value not numeric" throw ] }
 112         { UNKNOWN_CMD  [ "unknown command" throw   ] }
 113         { MEMORY       [ "out of memory" throw     ] }
 114         [ drop ]
 115     } case ;
 116
 117 : check-opaque ( opaque header -- ? )
 118     [ 7 ] dip nth = ;
 119
 120 : (read) ( n -- str )
 121     dup 0 > [ read >string ] [ drop "" ] if ;
 122
 123 : read-key ( header -- key )
 124     [ 2 ] dip nth (read) ;
 125
 126 : read-val ( header -- val )
 127     [ [ 6 ] dip nth ] [ [ 2 ] dip nth ] bi - (read) ;
 128
 129 : read-body ( header -- val key )
 130     {
 131         [ check-magic  ]
 132         [ check-status ]
 133         [ read-key     ]
 134         [ read-val     ]
 135     } cleave swap ;
 136
 137 : read-response ( -- val key )
 138     read-header read-body ;
 139
 140 : submit ( request -- response )
 141     send-request read-response drop ;
 142
 143 : (cmd) ( key cmd -- request )
 144     <request> swap >>key ;
 145
 146 : (incr/decr) ( amt key cmd -- response )
 147     (cmd) swap '[ _ 0 0 ] "QQI" pack-be >>extra ! amt init exp
 148     submit "Q" unpack-be first ;
 149
 150 : (mutate) ( val key cmd -- )
 151     (cmd) swap >>val { 0 0 } "II" pack-be >>extra ! flags exp
 152     submit drop ;
 153
 154 : (cat) ( val key cmd -- )
 155     (cmd) swap >>val submit drop ;
 156
 157 PRIVATE>
 158
 159 : m/version ( -- version ) VERSION <request> submit ;
 160
 161 : m/noop ( -- ) NOOP <request> submit drop ;
 162
 163 : m/incr-val ( amt key -- val ) INCR (incr/decr) ;
 164
 165 : m/incr ( key -- val ) 1 swap m/incr-val ;
 166
 167 : m/decr-val ( amt key -- val ) DECR (incr/decr) ;
 168
 169 : m/decr ( key -- val ) 1 swap m/decr-val ;
 170
 171 : m/get ( key -- val ) GET (cmd) submit 4 tail ;
 172
 173 : m/getq ( opaque key -- )
 174     GETQ (cmd) swap >>opaque send-request ;
 175
 176 : m/getseq ( keys -- vals )
 177     [ H{ } clone ] dip
 178     [ <enum> [ m/getq ] assoc-each ]
 179     [ length 10 + NOOP <request> swap >>opaque send-request ]
 180     [
 181         <enum> [
 182             assoc-size 10 + '[
 183                 _ read-header [ check-opaque ] keep swap
 184             ]
 185         ] [
 186             '[
 187                 [ read-body drop 4 tail ]
 188                 [ [ 7 ] dip nth _ at ]
 189                 bi pick set-at
 190             ]
 191         ] bi until drop
 192     ] tri ;
 193
 194 : m/set ( val key -- ) SET (mutate) ;
 195
 196 : m/add ( val key -- ) ADD (mutate) ;
 197
 198 : m/replace ( val key -- ) REPLACE (mutate) ;
 199
 200 : m/delete ( key -- ) DELETE (cmd) submit drop ;
 201
 202 : m/append ( val key -- ) APPEND (cat) ;
 203
 204 : m/prepend ( val key -- ) PREPEND (cat) ;
 205
 206 : m/flush-later ( seconds -- )
 207     FLUSH <request> swap 1array "I" pack-be >>extra ! timebomb
 208     submit drop ;
 209
 210 : m/flush ( -- ) 0 m/flush-later ;
 211
 212 : m/stats ( -- stats )
 213     STAT <request> send-request
 214     [ read-response dup length 0 > ]
 215     [ swap 2array ] produce 2nip ;
 216
 217 : m/quit ( -- ) QUIT <request> submit drop ;
 218
 219