Skip to content

Commit d3f6d2a

Browse files
olegkatolegkat
committed
Initial commit (version 0.1.2)
0 parents  commit d3f6d2a

File tree

10 files changed

+399
-0
lines changed

10 files changed

+399
-0
lines changed

‎Demo.lhs

+79
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,79 @@
1+
Memcached interface.
2+
Copyright (C) 2005 Evan Martin <[email protected]>
3+
4+
This program demonstrates the main use of the haskell-memcached API.
5+
It's runnable directly if you have a server running on localhost:11211.
6+
7+
We first import the "Memcache" type class directly as well as all the
8+
functions qualified. The latter two imports will be explained below.
9+
10+
> import Network.Memcache(Memcache)
11+
> import qualified Network.Memcache
12+
> import Network.Memcache.Protocol as Single
13+
> import Network.Memcache.Serializable(Serializable(..))
14+
15+
For this demonstration, we only use a single server. But working with
16+
a server pool ought to be transparent, as both single servers and the
17+
pool are instances of the "Memcache" type class.
18+
19+
> main = do
20+
> server <- Single.connect "localhost" 11211
21+
> simpleDemo server
22+
> serializeDemo server
23+
> Single.disconnect server
24+
25+
> simpleDemo :: (Memcache mc) => mc -> IO ()
26+
> simpleDemo memcache = do
27+
28+
When setting/getting keys, Haskell must be able to infer their type.
29+
Typically, context will determine this, but if it doesn't you need
30+
to annotate.
31+
32+
> let foo = 3 :: Int
33+
> success <- Network.Memcache.set memcache "foo" foo
34+
> putStrLn ("Setting foo => 3: " ++ show success ++ ".")
35+
36+
Similarly for "get":
37+
Generally this won't be a problem (the way you use the value will
38+
make it specific) but it means that a naive "get" followed by a
39+
"print" won't work -- there's no way to know whether you were trying
40+
to get an Int or a String.
41+
42+
> foo' <- Network.Memcache.get memcache "foo"
43+
> case foo' of
44+
> Nothing -> putStrLn "Retrieving foo: expired from cache?"
45+
> Just v -> putStrLn ("Cached value for foo is " ++ show (v::Int) ++ ".")
46+
47+
48+
49+
By implementing the "serializable" class, you can serialize more complicated
50+
data structures directly. Suppose we had a "User" record that contained
51+
information about a user that we wanted to be able to retrieve quickly.
52+
53+
> data User = User {
54+
> username :: String,
55+
> fontsize :: Int
56+
> } deriving Show
57+
58+
For this simple type we can stringify it as just "username fontsize".
59+
For more complicated data, you can do whatever crazy bitpacking necessary.
60+
61+
> instance Serializable User where
62+
> toString (User username fontsize) = username ++ " " ++ (show fontsize)
63+
> fromString str = case words str of
64+
> (a:b:[]) -> Just (User a (read b))
65+
> _ -> Nothing
66+
67+
> serializeDemo :: (Memcache mc) => mc -> IO ()
68+
> serializeDemo memcache = do
69+
> let fred = User "fred" 24 -- fred likes large fonts
70+
> Network.Memcache.set memcache "u:fred" fred
71+
72+
> fred' <- Network.Memcache.get memcache "u:fred"
73+
> putStrLn ("Fred is " ++ show (fred' :: Maybe User))
74+
75+
> invalid <- Network.Memcache.get memcache "this key doesn't exist"
76+
> putStrLn ("Unknown returns: " ++ show (invalid :: Maybe User))
77+
78+
79+
vim: set ts=2 sw=2 et :

‎LICENSE

+22
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,22 @@
1+
MIT License:
2+
3+
Copyright (c) 2005 Evan Martin <[email protected]>
4+
5+
Permission is hereby granted, free of charge, to any person obtaining a copy of
6+
this software and associated documentation files (the "Software"), to deal in
7+
the Software without restriction, including without limitation the rights to
8+
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
9+
of the Software, and to permit persons to whom the Software is furnished to do
10+
so, subject to the following conditions:
11+
12+
The above copyright notice and this permission notice shall be included in all
13+
copies or substantial portions of the Software.
14+
15+
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16+
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17+
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18+
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19+
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20+
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21+
SOFTWARE.
22+

‎Network/Memcache.hs

+15
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
-- Memcached interface.
2+
-- Copyright (C) 2005 Evan Martin <[email protected]>
3+
4+
module Network.Memcache where
5+
6+
import Network.Memcache.Serializable
7+
import Network.Memcache.Key
8+
9+
class Memcache a where
10+
set, add, replace :: (Key k, Serializable s) => a -> k -> s -> IO Bool
11+
get :: (Key k, Serializable s) => a -> k -> IO (Maybe s)
12+
delete :: (Key k) => a -> k -> Int -> IO Bool
13+
incr, decr :: (Key k) => a -> k -> Int -> IO (Maybe Int)
14+
15+
-- vim: set ts=2 sw=2 et :

‎Network/Memcache/Key.hs

+29
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,29 @@
1+
-- Memcached interface.
2+
-- Copyright (C) 2005 Evan Martin <[email protected]>
3+
4+
module Network.Memcache.Key(Key, hash, toKey) where
5+
6+
import Data.List(foldl')
7+
8+
-- A Memcached key must be hashable (so it can be deterministically distributed
9+
-- across multiple servers) and convertable to a string (as that's what
10+
-- Memcached uses).
11+
12+
class Key a where
13+
hash :: a -> Int
14+
toKey :: a -> String
15+
16+
-- I really just want to make String an instance of Key,
17+
-- but this is the best I can figure out.
18+
class KeyElem a where
19+
num :: a -> Int
20+
chr :: a -> Char
21+
instance KeyElem Char where
22+
num = fromEnum
23+
chr = id
24+
instance (KeyElem a) => Key [a] where
25+
-- glib's string hash: fast and good for short strings
26+
hash = foldl' (\h i -> 31*h + i) 0 . map num
27+
toKey = map chr
28+
29+
-- vim: set ts=2 sw=2 et :

‎Network/Memcache/Protocol.hs

+119
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,119 @@
1+
-- Memcached interface.
2+
-- Copyright (C) 2005 Evan Martin <[email protected]>
3+
4+
module Network.Memcache.Protocol (
5+
Server,
6+
connect,disconnect,stats -- server-specific commands
7+
) where
8+
9+
-- TODO:
10+
-- - use exceptions where appropriate for protocol errors
11+
-- - expiration time in store
12+
13+
import Network.Memcache
14+
import qualified Network
15+
import Network.Memcache.Key
16+
import Network.Memcache.Serializable
17+
import System.IO
18+
19+
-- | Gather results from action until condition is true.
20+
ioUntil :: (a -> Bool) -> IO a -> IO [a]
21+
ioUntil stop io = do
22+
val <- io
23+
if stop val then return []
24+
else do more <- ioUntil stop io
25+
return (val:more)
26+
27+
-- | Put out a line with \r\n terminator.
28+
hPutNetLn :: Handle -> String -> IO ()
29+
hPutNetLn h str = hPutStr h (str ++ "\r\n")
30+
31+
-- | Get a line, stripping \r\n terminator.
32+
hGetNetLn :: Handle -> IO [Char]
33+
hGetNetLn h = do
34+
str <- ioUntil (== '\r') (hGetChar h)
35+
hGetChar h -- read following newline
36+
return str
37+
38+
-- | Put out a command (words with terminator) and flush.
39+
hPutCommand :: Handle -> [String] -> IO ()
40+
hPutCommand h strs = hPutNetLn h (unwords strs) >> hFlush h
41+
42+
newtype Server = Server { sHandle :: Handle }
43+
44+
-- connect :: String -> Network.Socket.PortNumber -> IO Server
45+
connect :: Network.HostName -> Network.PortNumber -> IO Server
46+
connect host port = do
47+
handle <- Network.connectTo host (Network.PortNumber port)
48+
return (Server handle)
49+
50+
disconnect :: Server -> IO ()
51+
disconnect = hClose . sHandle
52+
53+
stats :: Server -> IO [(String, String)]
54+
stats (Server handle) = do
55+
hPutCommand handle ["stats"]
56+
statistics <- ioUntil (== "END") (hGetNetLn handle)
57+
return $ map (tupelize . stripSTAT) statistics where
58+
stripSTAT ('S':'T':'A':'T':' ':x) = x
59+
stripSTAT x = x
60+
tupelize line = case words line of
61+
(key:rest) -> (key, unwords rest)
62+
[] -> (line, "")
63+
64+
store :: (Key k, Serializable s) => String -> Server -> k -> s -> IO Bool
65+
store action (Server handle) key val = do
66+
let flags = (0::Int)
67+
let exptime = (0::Int)
68+
let valstr = toString val
69+
let bytes = length valstr
70+
let cmd = unwords [action, toKey key, show flags, show exptime, show bytes]
71+
hPutNetLn handle cmd
72+
hPutNetLn handle valstr
73+
hFlush handle
74+
response <- hGetNetLn handle
75+
return (response == "STORED")
76+
77+
getOneValue :: Handle -> IO (Maybe String)
78+
getOneValue handle = do
79+
s <- hGetNetLn handle
80+
case words s of
81+
["VALUE", _, _, sbytes] -> do
82+
let count = read sbytes
83+
val <- sequence $ take count (repeat $ hGetChar handle)
84+
return $ Just val
85+
_ -> return Nothing
86+
87+
incDec :: (Key k) => String -> Server -> k -> Int -> IO (Maybe Int)
88+
incDec cmd (Server handle) key delta = do
89+
hPutCommand handle [cmd, toKey key, show delta]
90+
response <- hGetNetLn handle
91+
case response of
92+
"NOT_FOUND" -> return Nothing
93+
x -> return $ Just (read x)
94+
95+
96+
instance Memcache Server where
97+
set = store "set"
98+
add = store "add"
99+
replace = store "replace"
100+
101+
get (Server handle) key = do
102+
hPutCommand handle ["get", toKey key]
103+
val <- getOneValue handle
104+
case val of
105+
Nothing -> return Nothing
106+
Just val -> do
107+
hGetNetLn handle
108+
hGetNetLn handle
109+
return $ fromString val
110+
111+
delete (Server handle) key delta = do
112+
hPutCommand handle [toKey key, show delta]
113+
response <- hGetNetLn handle
114+
return (response == "DELETED")
115+
116+
incr = incDec "incr"
117+
decr = incDec "decr"
118+
119+
-- vim: set ts=2 sw=2 et :

‎Network/Memcache/Serializable.hs

+47
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,47 @@
1+
-- Memcached interface.
2+
-- Copyright (C) 2005 Evan Martin <[email protected]>
3+
4+
module Network.Memcache.Serializable(Serializable, toString, fromString) where
5+
6+
-- It'd be nice to use "show" for serialization, but when we
7+
-- serialize a String we want to serialize it without the quotes.
8+
9+
-- TODO:
10+
-- - allow serializing bytes as Ptr
11+
-- to do this, add a "putToHandle", etc. method in Serializable
12+
-- where the default uses toString, but for Ptr uses socket stuff.
13+
14+
--import Foreign.Marshal.Utils
15+
--import Foreign.Storable (Storable, sizeOf)
16+
17+
class Serializable a where
18+
toString :: a -> String
19+
fromString :: String -> Maybe a
20+
21+
toStringL :: [a] -> String
22+
fromStringL :: String -> [a]
23+
24+
toStringL = error "unimp"
25+
fromStringL = error "unimp"
26+
27+
instance Serializable Char where
28+
-- people will rarely want to serialize a single char,
29+
-- but we define them for completeness.
30+
toString x = [x]
31+
fromString (c:[]) = Just c
32+
fromString _ = Nothing
33+
34+
-- the real use is for serializing strings.
35+
toStringL = id
36+
fromStringL = id
37+
38+
-- ...do I really need to copy everything instance of Show?
39+
instance Serializable Int where
40+
toString = show
41+
fromString = Just . read
42+
43+
instance (Serializable a) => Serializable [a] where
44+
toString = toStringL
45+
fromString = Just . fromStringL
46+
47+
-- vim: set ts=2 sw=2 et :

‎Network/Memcache/ServerPool.hs

+11
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
-- Memcached interface.
2+
-- Copyright (C) 2005 Evan Martin <[email protected]>
3+
4+
module Network.Memcache.ServerPool where
5+
6+
import qualified Network.Memcache.Protocol as P
7+
8+
data Server = Server P.Server Int
9+
data Pool = Pool (String -> Int)
10+
11+
-- vim: set ts=2 sw=2 et :

‎Setup.hs

+5
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
#!/usr/bin/runhaskell
2+
3+
import Distribution.Simple
4+
5+
main = defaultMainWithHooks simpleUserHooks

‎Test.hs

+51
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,51 @@
1+
-- Memcached interface.
2+
-- Copyright (C) 2005 Evan Martin <[email protected]>
3+
4+
module Main where
5+
6+
import qualified Network.Memcache
7+
import Network.Memcache.Key(hash)
8+
import qualified Network.Memcache.Protocol as S
9+
10+
import Control.Exception
11+
import System.Process
12+
import System.IO -- used for emulating sleep()
13+
import Test.HUnit
14+
15+
withServerConnection :: (S.Server -> IO ()) -> IO ()
16+
withServerConnection f = bracket connect disconnect f where
17+
connect = S.connect "localhost" 11211
18+
disconnect = S.disconnect
19+
20+
statsTest :: Test
21+
statsTest = TestCase $ withServerConnection $ \server -> do
22+
stats <- S.stats server
23+
assertBool "stats returns multiple stats" (length stats > 10)
24+
25+
setGetTest :: Test
26+
setGetTest = TestCase $ withServerConnection $ \server -> do
27+
let foo = 3 :: Int
28+
success <- Network.Memcache.set server "foo" foo
29+
foo' <- Network.Memcache.get server "foo"
30+
case foo' of
31+
Nothing -> assertFailure "'foo' not found just after setting it"
32+
Just v -> assertEqual "foo value" (3 :: Int) v
33+
34+
hashTest :: Test
35+
hashTest = TestCase $ do
36+
assertBool "hash produces different values" (hash key1 /= hash key2)
37+
where key1 = "foo"; key2 = "bar"
38+
39+
-- XXX hack: is there no other way to wait?
40+
sleep :: Int -> IO ()
41+
sleep x = hWaitForInput stdin x >> return ()
42+
43+
main :: IO ()
44+
main = bracket upDaemon downDaemon runTests >> return () where
45+
upDaemon = do m <- runCommand "memcached"
46+
sleep 200 -- give it time to start up and bind.
47+
return m
48+
downDaemon = terminateProcess
49+
runTests _ = runTestTT $ TestList [statsTest, setGetTest, hashTest]
50+
51+
-- vim: set ts=2 sw=2 et :

0 commit comments

Comments
 (0)