├── RedisSharding.cabal ├── MyNetLazy.hs ├── MyForkManager.hs ├── LICENSE ├── README ├── RedisParser.hs ├── redis_sharding.hs └── RedisSharding.hs /RedisSharding.cabal: -------------------------------------------------------------------------------- 1 | Name: RedisSharding 2 | Version: 0.9 3 | Author: Nick Kostitya 4 | License: BSD3 5 | license-file: LICENSE 6 | Build-type: Simple 7 | Cabal-version: >=1.2 8 | Tested-with: GHC==7.0.3, GHC==7.4, GHC==7.6, GHC==7.8, GHC==7.10 9 | 10 | Library 11 | build-depends: 12 | base >= 4.3, 13 | bytestring >= 0.9, 14 | unix >= 2.4, 15 | network >= 2.3, 16 | digest, 17 | time, 18 | old-locale 19 | 20 | Executable redis_sharding 21 | main-is: redis_sharding.hs 22 | build-tools: ghc >= 7.0.3 23 | ghc-options: -threaded -rtsopts -O2 -fno-warn-tabs 24 | -------------------------------------------------------------------------------- /MyNetLazy.hs: -------------------------------------------------------------------------------- 1 | module MyNetLazy ( 2 | module Network.Socket.ByteString.Lazy, 3 | getContentsWith 4 | ) where 5 | 6 | import Network.Socket.ByteString.Lazy 7 | 8 | import Control.Monad (liftM) 9 | import Data.ByteString.Lazy.Internal (ByteString(..), defaultChunkSize) 10 | import Network.Socket (Socket(..), ShutdownCmd(..), shutdown) 11 | import System.IO.Unsafe (unsafeInterleaveIO) 12 | 13 | import qualified Data.ByteString as S 14 | import qualified Network.Socket.ByteString as N 15 | 16 | 17 | getContentsWith :: Socket -- ^ Connected socket 18 | -> (Socket -> IO ()) -- ^ On shutdown 19 | -> IO ByteString -- ^ Data received 20 | getContentsWith sock quit = loop where 21 | loop = unsafeInterleaveIO $ do 22 | s <- N.recv sock defaultChunkSize 23 | case S.null s of 24 | True -> quit sock >> return Empty 25 | False -> Chunk s `liftM` loop 26 | -------------------------------------------------------------------------------- /MyForkManager.hs: -------------------------------------------------------------------------------- 1 | module MyForkManager where 2 | 3 | import Control.Concurrent 4 | import Control.Exception (mask, bracket, finally) 5 | 6 | newtype ForkManager = FM ( MVar [ ( ThreadId, MVar () ) ] ) 7 | 8 | 9 | withForkManagerDo :: (ForkManager -> IO ()) -> IO () 10 | withForkManagerDo io = 11 | bracket 12 | (newMVar [] >>= return . FM) 13 | (waitForChildren) 14 | io 15 | where 16 | -- Ожидание завержения всех потомкив 17 | waitForChildren :: ForkManager -> IO () 18 | waitForChildren (FM fm) = mapM_ (takeMVar . snd) =<< takeMVar fm 19 | 20 | 21 | waitAllThread :: ForkManager -> IO () 22 | waitAllThread (FM fm) = mapM_ (readMVar . snd) =<< readMVar fm 23 | 24 | 25 | forkWith :: ForkManager -> IO () -> IO ThreadId 26 | forkWith (FM fm) io = mask $ \restore -> do 27 | mvar <- newEmptyMVar 28 | thr_id <- forkIO $ finally (restore io) $ putMVar mvar () 29 | childs <- takeMVar fm 30 | putMVar fm $ (thr_id,mvar):childs 31 | return thr_id 32 | 33 | 34 | killAllThread :: ForkManager -> IO () 35 | killAllThread (FM fm) = mapM_ (killThread . fst) =<< readMVar fm 36 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2011-2012, Nick Kostirya 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | * Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | * Neither the name of the author nor the 13 | names of its contributors may be used to endorse or promote products 14 | derived from this software without specific prior written permission. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 17 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY 20 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 21 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 22 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 23 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 24 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Redis Sharding 2 | ************** 3 | 4 | http://github.com/kni/redis-sharding-hs 5 | 6 | Haskell version of "Redis Sharding" (http://github.com/kni/redis-sharding) 7 | 8 | For resharding see http://github.com/kni/redis-sharding. 9 | 10 | Redis Sharding with fully support MSET, MSETNX, MGET, DEL commands. 11 | 12 | This Lazy version. 13 | Strict version of Redis Sharding available also: http://github.com/kni/redis-sharding-hs-strict. 14 | ATTENTION. Strict version faster in 4 time for Pipeline mode! 15 | 16 | Standard ML version (https://github.com/kni/redis-sharding-sml) is even more productive. 17 | 18 | 19 | Nota bene 20 | --------- 21 | 22 | To achieve the best efficiency while sharding data it is especially important to use pipelining by the client. 23 | The importance increases according to the number of node for multikeys commands (multi-nodes commands, if more precisely). 24 | And it increases twice only in comparison with the usual redis server. :-) 25 | 26 | 27 | Build 28 | ----- 29 | 30 | ghc -threaded -rtsopts -O2 --make redis_sharding.hs 31 | or 32 | cabal configure && cabal build 33 | 34 | Run 35 | ----- 36 | 37 | ./redis_sharding --nodes=10.1.1.1:6380,10.1.1.1:6381,... 38 | 39 | or to use all CPU core run as 40 | 41 | ./redis_sharding --nodes=10.1.1.1:6380,10.1.1.1:6381,... +RTS -N 42 | 43 | ATTENTION! +RTS -N must be after of all others parameters. 44 | 45 | Others parameters: 46 | 47 | --host=10.1.1.1 48 | --port=6379 49 | --timeout=300 (0 - disable timeout) 50 | 51 | Tuning 52 | ------ 53 | 54 | ./redis_sharding --nodes=10.1.1.1:6380,10.1.1.1:6381,... +RTS -N -A10M -qa 55 | 56 | Bug 57 | ----- 58 | 59 | Do not use too long keys (and values) or the excessive number of keys in one command (>100Kb). 60 | GHC threaded runtime contains an error that causes data loss of a socket status that it's ready for write. 61 | Not-threaded runtime does not have the above mentioned bug but it is slower and uses the system select call instead of using kevent or epoll. 62 | Tests showed that this error is present in GHC 7.8.[34] and 8.0.1. 63 | 64 | 65 | Notes 66 | ----- 67 | 68 | timeout 69 | ~~~~~~~ 70 | 71 | As opposed to the Perl version, the Haskell version RedisSharding is built in the "lazy style". 72 | If the client is not responding, RedisSharding won't detect closing connection by the server because of time-out. 73 | So, the time-outs execution is added into the RedisSharding itself (timeout keys, seconds). 74 | -------------------------------------------------------------------------------- /RedisParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module RedisParser ( 4 | multi_bulk_parser, server_parser, server_parser_multi, Reply(..), 5 | cmd2stream, arg2stream 6 | ) where 7 | 8 | 9 | import Data.Int (Int64) 10 | 11 | import Data.ByteString.Lazy.Char8 (ByteString) 12 | import qualified Data.ByteString.Lazy.Char8 as BSL 13 | 14 | 15 | 16 | showInt :: Int64 -> ByteString 17 | showInt a = BSL.pack $ show a 18 | 19 | 20 | multi_bulk_parser :: ByteString -> Maybe (ByteString, Maybe [Maybe ByteString]) 21 | multi_bulk_parser s = do 22 | (s, c) <- get_bulk_size s '*' 23 | get_args s c [] 24 | where 25 | get_args :: ByteString -> Int64 -> [Maybe ByteString] -> Maybe (ByteString, Maybe [Maybe ByteString]) 26 | get_args s (-1) as = return (s, Nothing) 27 | get_args s 0 as = return (s, Just $ reverse as) 28 | get_args s c as = do 29 | (s, a) <- get_bulk_arg s 30 | get_args s (c - 1) (a:as) 31 | 32 | 33 | get_bulk_arg :: ByteString -> Maybe (ByteString, Maybe ByteString) 34 | get_bulk_arg s = do 35 | (s, c) <- get_bulk_size s '$' 36 | get_bulk_value s c 37 | 38 | 39 | get_bulk_size :: ByteString -> Char -> Maybe (ByteString, Int64) 40 | get_bulk_size s char = do 41 | (f, s) <- BSL.uncons s 42 | when_ (f == char) 43 | (s, c) <- readInt64CRLF s 44 | return (s, c) 45 | 46 | 47 | get_bulk_value :: ByteString -> Int64 -> Maybe (ByteString, Maybe ByteString) 48 | get_bulk_value s (-1) = return (s, Nothing) 49 | get_bulk_value s c = do 50 | let a = BSL.take c s 51 | when_ (isCRLF s c) 52 | let t = BSL.drop (c + 2) s 53 | return (t, Just a) 54 | 55 | 56 | isCRLF :: ByteString -> Int64 -> Bool 57 | isCRLF s i = BSL.index s i == '\r' && BSL.index s (i + 1) == '\n' 58 | 59 | when :: Bool -> a -> Maybe a 60 | when False _ = Nothing 61 | when True a = Just a 62 | 63 | when_ :: Bool -> Maybe Bool 64 | when_ a = when a True 65 | 66 | 67 | readInt64CRLF :: ByteString -> Maybe (ByteString, Int64) 68 | readInt64CRLF s = do 69 | (c, s) <- BSL.readInteger s 70 | when_ (isCRLF s 0) 71 | let t = BSL.drop 2 s 72 | return (t, fromIntegral c) 73 | 74 | 75 | data Reply = RInt Int64 | RInline ByteString | RBulk (Maybe ByteString) | RMultiSize Int64 76 | 77 | server_parser :: ByteString -> Maybe (ByteString, Reply) 78 | server_parser s = do 79 | (h, _) <- BSL.uncons s 80 | case h of 81 | '+' -> do 82 | (s, c) <- beforeCRLF s 83 | return (s, RInline c) 84 | '-' -> do 85 | (s, c) <- beforeCRLF s 86 | return (s, RInline c) 87 | ':' -> do 88 | (s, c) <- readInt64CRLF $ BSL.drop 1 s 89 | return (s, RInt c) 90 | '$' -> do 91 | (s, c) <- get_bulk_size s '$' 92 | (s, a) <- get_bulk_value s c 93 | return (s, RBulk a) 94 | '*' -> do 95 | (s, c) <- readInt64CRLF $ BSL.drop 1 s 96 | return (s, RMultiSize c) 97 | 98 | 99 | server_parser_multi :: ByteString -> Maybe (ByteString, Reply) 100 | server_parser_multi s = do 101 | (s, c) <- get_bulk_size s '$' 102 | (s, a) <- get_bulk_value s c 103 | return (s, RBulk a) 104 | 105 | 106 | beforeCRLF :: ByteString -> Maybe (ByteString, ByteString) 107 | beforeCRLF s = do 108 | ri <- BSL.elemIndex '\r' s 109 | case BSL.index s (ri + 1) == '\n' of 110 | True -> do 111 | let h = BSL.take (ri) s 112 | let t = BSL.drop (ri + 2) s 113 | return (t, h) 114 | False -> do 115 | let h = BSL.take (ri + 1) s 116 | let t = BSL.drop (ri + 1) s 117 | (t2, h2) <- beforeCRLF t 118 | return (t2, BSL.concat [h, h2]) 119 | 120 | 121 | 122 | -- Преобразование команды (список аргументов) в строку, поток байтов, соответствующий протоколу redis. 123 | cmd2stream :: [Maybe ByteString] -> [ByteString] 124 | cmd2stream [] = ["*0\r\n"] 125 | cmd2stream as = ["*", (showInt $ fromIntegral $ length as), "\r\n"] ++ concat (map arg2stream as) 126 | 127 | 128 | -- Преобразование аргумента в строку, поток байтов, соответствующий протоколу redis. 129 | arg2stream :: Maybe ByteString -> [ByteString] 130 | arg2stream Nothing = ["$-1\r\n"] 131 | arg2stream (Just s) = ["$", (showInt $ fromIntegral $ BSL.length s), "\r\n", s, "\r\n"] 132 | -------------------------------------------------------------------------------- /redis_sharding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main (main) where 4 | 5 | import Prelude hiding (catch, getContents, concat) 6 | import Control.Concurrent 7 | import Control.Monad (mapM_, forM, forM_) 8 | import Control.Exception (catch, throw, SomeException, IOException, AsyncException (ThreadKilled)) 9 | import Data.ByteString.Lazy.Char8 (ByteString, pack, unpack, split, concat) 10 | import Data.Maybe (maybe, fromJust) 11 | import Data.Time.Clock 12 | import Data.Tuple (fst, snd) 13 | import System.IO 14 | import System.Posix.Signals 15 | import System.Environment (getArgs, getProgName) 16 | import System.Console.GetOpt 17 | import System.Exit 18 | import Network.Socket hiding (recv) 19 | 20 | import MyForkManager 21 | import MyNetLazy -- На основе Network.Socket.ByteString.Lazy 22 | 23 | import RedisSharding 24 | 25 | 26 | version = "0.9" 27 | 28 | 29 | options :: [OptDescr (String, String)] 30 | options = [ 31 | Option [] ["host"] (ReqArg (pair "host") "IP") "host", 32 | Option [] ["port"] (ReqArg (pair "port") "port") "port", 33 | Option [] ["nodes"] (ReqArg (pair "nodes") "nodes") "nodes (host1:port1,host2:port2)", 34 | Option [] ["timeout"] (ReqArg (pair "timeout") "timeout") "timeout" 35 | ] 36 | where 37 | pair :: a -> b -> (a, b) 38 | pair a b = (a, b) 39 | 40 | 41 | 42 | main = withSocketsDo $ do 43 | installHandler sigPIPE Ignore Nothing 44 | 45 | hSetBuffering stdout LineBuffering 46 | 47 | printLog ["Start RedisSharding, (version - ", version, ")."] 48 | 49 | argv <- getArgs 50 | 51 | let get_opt = case getOpt Permute options argv of (opts, _, _) -> flip lookup opts 52 | -- get_opt :: String -> Maybe String -- name -> value 53 | 54 | progName <- getProgName 55 | 56 | case get_opt "nodes" of 57 | Just _ -> return () 58 | Nothing -> putStr ( 59 | "Parameter 'nodes' is required.\n\nUsing example:\n" ++ 60 | progName ++ " --nodes=10.1.1.2:6380,10.1.1.3:6380,...\n\n" ++ 61 | "Others parameters:\n--host=10.1.1.1\n--port=6379\n" ++ 62 | "--timeout=300 (0 - disable timeout)\n" 63 | ) >> exitWith ExitSuccess 64 | 65 | host <- maybe (return iNADDR_ANY) inet_addr (get_opt "host") 66 | let port = (maybe 6379 (\a -> fromIntegral $ read a) (get_opt "port"))::PortNumber 67 | let servers = split ',' $ pack $ fromJust $ get_opt "nodes" 68 | let timeout = (maybe 300 (\a -> fromIntegral $ read a) (get_opt "timeout"))::Int 69 | 70 | sock <- socket AF_INET Stream defaultProtocol 71 | setSocketOption sock ReuseAddr 1 72 | bindSocket sock (SockAddrInet port host) 73 | listen sock 200 74 | 75 | let accepter = accept sock >>= \(c_sock, _) -> forkIO (welcome c_sock servers timeout) >> accepter 76 | 77 | accepter 78 | 79 | 80 | welcome c_sock servers timeout = withForkManagerDo $ \fm -> do 81 | setSocketOption c_sock KeepAlive 1 82 | 83 | addr2sMV <- newMVar [] -- Список пар "server address" => "server socket" 84 | 85 | catch (forM_ servers (server c_sock addr2sMV)) 86 | (\e -> printLog [ pack (show (e::SomeException) ) ] >> clean_from_client c_sock addr2sMV) 87 | 88 | -- Получили список пар "server address" => "server socket" после заполнения, дальше он изментся не будет. 89 | addr2s <- readMVar addr2sMV 90 | 91 | quit <- newEmptyMVar 92 | let fquit = putMVar quit True >> throw ThreadKilled 93 | 94 | waitMVar <- newEmptyMVar 95 | case timeout > 0 of 96 | True -> forkWithQuit fm fquit (timer waitMVar timeout fquit) >> return () 97 | False -> return () 98 | 99 | cmds <- newChan -- Канал для команд 100 | let set_cmd c = writeChan cmds c 101 | let get_cmd = getCurrentTime >>= putMVar waitMVar >> readChan cmds >>= \cmd -> takeMVar waitMVar >> return cmd 102 | 103 | let c_send s = sendAll c_sock $ concat s 104 | 105 | forkWithQuit fm fquit (_servers_reader c_sock c_send servers addr2s get_cmd fquit) 106 | forkWithQuit fm fquit (_client_reader c_sock c_send servers addr2s set_cmd fquit) 107 | 108 | takeMVar quit 109 | killAllThread fm >> waitAllThread fm 110 | clean_from_client c_sock addr2sMV 111 | 112 | where 113 | clean_from_client c_sock addr2sMV = do 114 | takeMVar addr2sMV >>= return . map snd >>= mapM_ sClose 115 | sClose c_sock 116 | 117 | -- Соединение с сервером 118 | server c_sock addr2sMV addr = do 119 | s_sock <- socket AF_INET Stream defaultProtocol 120 | ia <- inet_addr (unpack host) 121 | connect s_sock (SockAddrInet port_number ia) 122 | setSocketOption s_sock KeepAlive 1 123 | 124 | modifyMVar_ addr2sMV (return . (++) [(addr,s_sock)]) 125 | 126 | where 127 | [host, port] = split ':' addr 128 | port_number = fromIntegral (read (unpack port))::PortNumber 129 | 130 | 131 | forkWithQuit fm fquit io = forkWith fm (catch io (\e -> chokeIOException e >> fquit) ) 132 | where 133 | chokeIOException :: IOException -> IO () 134 | chokeIOException e = return () 135 | 136 | timer waitMVar timeout fquit = do 137 | t0 <- readMVar waitMVar 138 | t <- getCurrentTime 139 | let d = ceiling $ diffUTCTime t t0 140 | case d < timeout of 141 | True -> threadDelay (1000000 * d) >> timer waitMVar timeout fquit 142 | False -> fquit 143 | 144 | 145 | _client_reader c_sock c_send servers addr2s set_cmd fquit = 146 | client_reader getContents c_send servers s_send set_cmd fquit 147 | where 148 | getContents :: IO ByteString 149 | getContents = getContentsWith c_sock (\_ -> fquit) 150 | 151 | s_send s_addr s = sendAll (fromJust $ lookup s_addr addr2s) $ concat s 152 | 153 | 154 | _servers_reader c_sock c_send servers addr2s get_cmd fquit = do 155 | sss <- forM addr2s (\(s_addr, s_sock) -> do 156 | s <- getContentsWith s_sock (\_ -> fquit) 157 | return (s_addr, s_sock, s) 158 | ) 159 | servers_reader c_send sss get_cmd fquit 160 | -------------------------------------------------------------------------------- /RedisSharding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE CPP #-} 3 | 4 | module RedisSharding ( 5 | client_reader, servers_reader 6 | , printLog 7 | ) where 8 | 9 | 10 | import Control.Monad (forM_) 11 | import Data.Char (toUpper) 12 | import Data.Int (Int64) 13 | import Data.Digest.CRC32 (crc32) 14 | import Data.Maybe (fromJust) 15 | import System.IO (stderr) 16 | 17 | 18 | import qualified Data.List as L 19 | import qualified Data.ByteString.Char8 as BS 20 | import Data.ByteString.Lazy.Char8 (ByteString) 21 | import qualified Data.ByteString.Lazy.Char8 as BSL 22 | import qualified Data.ByteString.Lazy.Internal as BSLI 23 | 24 | import RedisParser 25 | 26 | 27 | import Data.Time.Clock (getCurrentTime) 28 | #if MIN_VERSION_time(1,5,0) 29 | import Data.Time.Format (formatTime, defaultTimeLocale) 30 | #else 31 | import Data.Time.Format (formatTime) 32 | import System.Locale (defaultTimeLocale) 33 | #endif 34 | 35 | formatDataTime t = BSL.pack $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" t 36 | 37 | 38 | printLog s = do 39 | t <- getCurrentTime 40 | BSL.putStrLn $ BSL.concat $ [formatDataTime t, "\t", BSL.concat s] 41 | 42 | 43 | firstChunk :: BSL.ByteString -> BSL.ByteString 44 | firstChunk BSLI.Empty = BSL.empty 45 | firstChunk (BSLI.Chunk f t) = BSL.fromStrict f 46 | 47 | 48 | warn = BS.hPutStrLn stderr . BS.concat . BSL.toChunks . BSL.concat 49 | 50 | showInt :: Int64 -> ByteString 51 | showInt a = BSL.pack $ show a 52 | 53 | 54 | key2server key servers = servers !! i 55 | where 56 | i = fromIntegral $ (toInteger $ crc32 $ key_tag key) `rem` (toInteger $ length servers) 57 | 58 | key_tag "" = "" 59 | key_tag key = 60 | case BSL.last key == '}' && clams /= [] of 61 | True -> BSL.drop (1 + last clams) $ BSL.take (BSL.length key - 1) key 62 | False -> key 63 | where 64 | clams = BSL.findIndices (=='{') key 65 | 66 | 67 | cmd_type = 68 | init_cmd_type 1 "PING AUTH SELECT FLUSHDB FLUSHALL DBSIZE KEYS" ++ 69 | init_cmd_type 2 "EXISTS TYPE EXPIRE PERSIST TTL MOVE SET GET GETSET SETNX SETEX INCR INCRBY INCRBYFLOAT DECR DECRBY APPEND SUBSTR RPUSH LPUSH LLEN LRANGE LTRIM LINDEX LSET LREM LPOP RPOP SADD SREM SPOP SCARD SISMEMBER SMEMBERS SRANDMEMBER ZADD ZREM ZINCRBY ZRANK ZREVRANK ZRANGE ZREVRANGE ZRANGEBYSCORE ZCOUNT ZCARD ZSCORE ZREMRANGEBYRANK ZREMRANGEBYSCORE HSET HGET HMGET HMSET HINCRBY HEXISTS HDEL HLEN HKEYS HVALS HGETALL PUBLISH" ++ 70 | init_cmd_type 3 "DEL MGET SUBSCRIBE UNSUBSCRIBE" ++ 71 | init_cmd_type 4 "MSET MSETNX" ++ 72 | init_cmd_type 5 "BLPOP BRPOP" 73 | where 74 | init_cmd_type t s = map (\a -> (a, t)) $ filter (/= "") $ BS.split ' ' s 75 | 76 | 77 | client_reader getContents c_send servers s_send set_cmd fquit = 78 | getContents >>= client_loop 79 | where 80 | client_loop :: ByteString -> IO () 81 | client_loop s = do 82 | s <- case multi_bulk_parser s of 83 | Just (s, Just as@((Just cmd):args)) -> do 84 | let c = BS.pack $ map toUpper (BS.unpack $ BS.concat $ BSL.toChunks cmd) 85 | case lookup c cmd_type of 86 | Just 1 -> do -- На все сервера 87 | set_cmd (c, []) 88 | let cs = cmd2stream as 89 | forM_ servers (\s_addr -> s_send s_addr cs) 90 | Just 2 -> do -- На конкретные сервер 91 | let (Just key):_ = args 92 | let s_addr = key2server key servers 93 | set_cmd (c, [s_addr]) 94 | let cs = cmd2stream as 95 | s_send s_addr cs 96 | Just 3 -> do -- На множество серверов. CMD key1 key2 ... keyN 97 | let arg_and_s_addr = map (\arg -> (arg, key2server (fromJust arg) servers)) args 98 | let s_addrs = map snd arg_and_s_addr 99 | let uniq_s_addrs = L.nub s_addrs 100 | set_cmd (c, s_addrs) 101 | mapM_ (\s_addr -> do 102 | let _args = map fst $ filter ( \(arg, _s_addr) -> _s_addr == s_addr ) arg_and_s_addr 103 | let cs = cmd2stream $ concat [[Just cmd],_args] 104 | s_send s_addr cs 105 | ) uniq_s_addrs 106 | Just 4 -> do -- На множество серверов. CMD key1 value1 key2 value2 ... keyN valueN 107 | let arg_and_s_addr = map (\(k, v) -> ((k, v), key2server (fromJust k) servers)) $ to_pair args 108 | let s_addrs = map snd arg_and_s_addr 109 | let uniq_s_addrs = L.nub s_addrs 110 | set_cmd (c, s_addrs) 111 | mapM_ (\s_addr -> do 112 | let _args = concat $ map (\((k,v),_)-> [k,v]) $ 113 | filter ( \(arg, _s_addr) -> _s_addr == s_addr ) arg_and_s_addr 114 | let cs = cmd2stream $ concat [[Just cmd],_args] 115 | s_send s_addr cs 116 | ) uniq_s_addrs 117 | where 118 | to_pair [] = [] 119 | to_pair (a:b:l) = (a,b):to_pair l 120 | Just 5 -> do -- На множество серверов. CMD key1 key2 ... keyN timeout (блокирующие команды) 121 | let timeout = last args 122 | let arg_and_s_addr = map (\arg -> (arg, key2server (fromJust arg) servers)) $ init args 123 | let s_addrs = map snd arg_and_s_addr 124 | let uniq_s_addrs = L.nub s_addrs 125 | case length uniq_s_addrs == 1 of 126 | False -> c_send ["-ERR Keys of the '", cmd, "' command should be on one node; use key tags\r\n"] 127 | True -> do 128 | set_cmd (c, s_addrs) 129 | mapM_ (\s_addr -> do 130 | let _args = map fst $ filter ( \(arg, _s_addr) -> _s_addr == s_addr ) arg_and_s_addr 131 | let cs = cmd2stream $ concat [[Just cmd],_args,[timeout]] 132 | s_send s_addr cs 133 | ) uniq_s_addrs 134 | Nothing -> do 135 | c_send ["-ERR unsupported command '", cmd, "'\r\n"] 136 | return s 137 | Nothing -> do 138 | printLog ["unified protocol error for\r\n", ">>>\r\n", (firstChunk s), "<<<"] 139 | c_send ["-ERR unified protocol error\r\n"] 140 | fquit 141 | getContents 142 | client_loop s 143 | 144 | 145 | 146 | servers_reader c_send sss get_cmd fquit = servers_loop sss 147 | where 148 | servers_loop sss = server_responses get_cmd sss c_send fquit >>= servers_loop 149 | 150 | 151 | server_responses get_cmd sss c_send fquit = do 152 | (cmd, ss) <- get_cmd 153 | (sss, rs) <- read_responses cmd ss sss 154 | join_responses cmd ss sss rs -- return sss 155 | where 156 | read_responses cmd ss sss = _read_loop sss [] [] 157 | where 158 | _read_loop [] new_sss rs = return (new_sss, rs) 159 | _read_loop ((s_addr, s_sock, s):old_sss) new_sss rs = 160 | case ss == [] || elem s_addr ss of 161 | True -> 162 | case server_parser s of 163 | Just (s, r) -> 164 | _read_loop old_sss ((s_addr, s_sock, s ):new_sss) ((s_addr,r):rs) 165 | Nothing -> warn ["Parsing error server response (", lcmd, ")"] >> fquit >> 166 | _read_loop old_sss ((s_addr, s_sock, ""):new_sss) rs 167 | where lcmd = BSL.fromChunks [cmd] 168 | False -> _read_loop old_sss ((s_addr, s_sock, s ):new_sss) rs 169 | 170 | join_responses cmd ss sss rs = do 171 | let lcmd = BSL.fromChunks [cmd] 172 | let ((_,fr):_) = rs 173 | case fr of 174 | RInt fr -> do 175 | -- Числовой ответ складываем. 176 | let sm = sum $ map (\(RInt r) -> r) (map snd rs) 177 | c_send [":", showInt sm, "\r\n"] 178 | return sss 179 | 180 | RInline fr -> do 181 | case any (== fr) $ map ( \(RInline r) -> r) (map snd rs) of 182 | True -> c_send [fr, "\r\n"] -- Ответы идентичны. 183 | False -> c_send ["-ERR nodes return different results\r\n"] -- Ответы отличаются. 184 | return sss 185 | 186 | RBulk fmr -> do 187 | -- Кажется все эти команды должны быть с одного сервера. 188 | let (Just ctype) = lookup cmd cmd_type 189 | case ctype == 2 of 190 | False -> warn ["bulk cmd ", lcmd, " with ", showInt ctype, " != 2"] 191 | True -> case length rs == 1 of 192 | False -> warn ["logic error"] 193 | True -> c_send $ arg2stream fmr 194 | return sss 195 | 196 | RMultiSize fmrs | length rs == 1 && fmrs == -1 -> c_send ["*-1\r\n"] >> return sss 197 | RMultiSize fmrs -> do 198 | case sm > 0 of 199 | False -> c_send resp >> return sss 200 | True -> case length ss of 201 | 0 -> read_loop resp sss $ spiral rs -- Со всех нод все 202 | 1 -> read_loop resp sss $ spiral rs -- С одной ноды все 203 | otherwise -> read_loop resp sss ss -- С каждого упоминание нод по одному 204 | 205 | where 206 | sm = sum $ map (\(RMultiSize r) -> r) (map snd rs) 207 | 208 | resp = ["*", showInt sm, "\r\n"] 209 | 210 | -- Спираль, по одному с каждого и так до конца (челнок). Не удаляй ленивость. 211 | -- print $ take 5 $ spiral [ ("a", 3), ("b", 4), ("c", 2), ("d", 0) ] 212 | spiral a = go a [] 213 | where 214 | go [] [] = [] 215 | go [] new = go new [] 216 | go ((k,RMultiSize v):t) new 217 | | v == 0 = go t new 218 | | otherwise = k : go t ((k, RMultiSize(v-1)):new) 219 | 220 | read_loop resp sss ss = go sss [] ss resp (sum $ map BSL.length resp) 221 | where 222 | go sss [] [] resp resp_l = c_send resp >> return sss 223 | go [] new_sss (h:t) resp resp_l = go new_sss [] t resp resp_l 224 | go ((s_addr, s_sock, s):old_sss) new_sss (h:t) resp resp_l 225 | | s_addr == h = case server_parser_multi s of 226 | Just (s, RBulk r) -> 227 | case new_resp_l > 1024 of 228 | True -> c_send new_resp >> 229 | go old_sss ((s_addr, s_sock, s):new_sss) (h:t) [] 0 230 | False -> 231 | go old_sss ((s_addr, s_sock, s):new_sss) (h:t) new_resp new_resp_l 232 | where 233 | arg = arg2stream r 234 | new_resp = resp L.++ arg 235 | new_resp_l = resp_l + (sum $ map BSL.length arg) 236 | Nothing -> 237 | warn ["Parsing error server response (", lcmd, ")"] >> fquit >> 238 | go old_sss ((s_addr, s_sock, s):new_sss) (h:t) resp resp_l 239 | | otherwise = 240 | go old_sss ((s_addr, s_sock, s):new_sss) (h:t) resp resp_l 241 | --------------------------------------------------------------------------------