├── Setup.hs ├── .travis.yml ├── examples ├── TestServer.hs ├── SqliteServer.hs ├── DummyProtocol.hs ├── TestProtocol.hs ├── ClientTypes.hs └── Client.hs ├── src ├── Network │ ├── Protocol.hs │ ├── Stream │ │ ├── Types.hs │ │ └── Socket.hs │ ├── Protocol │ │ └── Server.hs │ └── Stream.hs └── Raft │ ├── Store │ ├── Volatile.hs │ └── Sqlite.hs │ ├── Types.hs │ └── Protocol.hs ├── README.md ├── tests └── test.hs ├── LICENSE └── raft.cabal /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | 3 | ghc: 4 | - 7.8 5 | 6 | install: 7 | - cabal install tasty-hunit 8 | - cabal install tasty-quickcheck 9 | - cabal install --enable-tests 10 | 11 | -------------------------------------------------------------------------------- /examples/TestServer.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Network 4 | 5 | import Network.Protocol.Server 6 | 7 | import TestProtocol 8 | import Raft.Store.Volatile 9 | 10 | ---------------------------------------------------------------------- 11 | 12 | main :: IO () 13 | main = serveOn (PortNumber 44444) testProtocol empty 14 | -------------------------------------------------------------------------------- /src/Network/Protocol.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | module Network.Protocol ( 4 | Protocol(..) 5 | ) where 6 | 7 | class Protocol p where 8 | 9 | type Request p :: * 10 | 11 | type Response p :: * 12 | 13 | type Effects p :: * -> * 14 | 15 | step :: p -> Request p -> Effects p (p, Maybe (Response p)) 16 | -------------------------------------------------------------------------------- /examples/SqliteServer.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Network 4 | 5 | import Network.Protocol.Server 6 | 7 | import Raft.Store.Sqlite 8 | 9 | import TestProtocol 10 | 11 | ---------------------------------------------------------------------- 12 | 13 | main :: IO () 14 | main = open "test.db" >>= serveOn (PortNumber 44444) testProtocol 15 | -------------------------------------------------------------------------------- /examples/DummyProtocol.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | module DummyProtocol where 4 | 5 | import Network.Protocol 6 | 7 | import qualified Consensus.Types as Consensus 8 | 9 | data Dummy = Dummy Int 10 | 11 | data DummyRequest = QueryDummy | SetDummy Int 12 | data DummyResponse = DummyIs Int 13 | 14 | instance Protocol Dummy where 15 | type Request Dummy = DummyRequest 16 | type Response Dummy = DummyResponse 17 | 18 | step (Dummy n) (QueryDummy) = return (Dummy n, Just $ DummyIs n) 19 | step (Dummy _) (SetDummy n) = return (Dummy n, Just $ DummyIs n) 20 | 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://secure.travis-ci.org/kfish/raft.png)](http://travis-ci.org/kfish/raft) 2 | 3 | # raft 4 | 5 | A Haskell implementation of the [Raft consensus protocol](http://raftconsensus.github.io/), 6 | deconstructed as a menagerie of cooperating abstractions for communication, storage 7 | and control. A pure protocol description allows local testing and validation of 8 | exactly the code that is run on a production cluster. 9 | 10 | ## YOW! LambdaJam 2015: Pure Consensus in a World Full of Failure 11 | 12 | This implementation was the subject of a talk at YOW! LambdaJam 2015 in Brisbane, 13 | Australia. 14 | [Watch on YouTube.](http://www.youtube.com/watch?v=ZwldfZW8a3I) 15 | 16 | [![Pure Consensus in a World Full of Failure](http://img.youtube.com/vi/ZwldfZW8a3I/0.jpg)](http://www.youtube.com/watch?v=ZwldfZW8a3I "Play on YouTube") 17 | 18 | -------------------------------------------------------------------------------- /tests/test.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | import Test.Tasty 5 | import Test.Tasty.HUnit 6 | import Test.Tasty.QuickCheck as QC 7 | 8 | import Raft.Types 9 | -- import TestStore 10 | 11 | ------------------------------------------------------------ 12 | 13 | main = defaultMain tests 14 | 15 | ------------------------------------------------------------ 16 | 17 | tests :: TestTree 18 | tests = testGroup "Tests" [unitTests] 19 | 20 | unitTests = testGroup "Unit tests" 21 | [ 22 | {- 23 | testCase "Query empty" $ 24 | testQuery 0 empty 25 | @?= Nothing 26 | , testCase "Store seven" $ 27 | testQuery 0 (testStore 0 [7] (Term 1) empty) 28 | @?= Just (7, Term 1) 29 | , testCase "Store nine" $ 30 | testQuery 2 (testStore 1 [8,9] (Term 1) (testStore 0 [7] (Term 1) empty)) 31 | @?= Just (9, Term 1) 32 | , testCase "Truncate" $ 33 | testQuery 2 (testTruncate 1 $ testStore 1 [8,9] (Term 1) (testStore 0 [7] (Term 1) empty)) 34 | @?= Nothing 35 | 36 | , testCase "run1" $ 37 | testState (query' 0) 0 38 | @?= Nothing 39 | -} 40 | ] 41 | -------------------------------------------------------------------------------- /examples/TestProtocol.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | module TestProtocol where 4 | 5 | import Control.Monad.Free 6 | 7 | import ClientTypes 8 | 9 | import Network.Protocol 10 | 11 | import Raft.Types 12 | 13 | ---------------------------------------------------------------------- 14 | 15 | data TestProtocol a = TestProtocol a 16 | 17 | testProtocol :: TestProtocol a 18 | testProtocol = TestProtocol undefined 19 | 20 | instance Protocol (TestProtocol a) where 21 | 22 | type Request (TestProtocol a) = ClientCommand Index a 23 | type Response (TestProtocol a) = ClientResponse Index a 24 | type Effects (TestProtocol a) = Free (LogStoreF [] a) 25 | 26 | step p cmd = case cmd of 27 | CmdSet k v -> do 28 | store' k (Term 0) [v] 29 | return (p, Just $ RspSetOK k v) 30 | 31 | CmdGet k -> do 32 | res <- query' k 33 | let rsp = case res of 34 | Just (v, _) -> RspGetOK k v 35 | Nothing -> RspGetFail k 36 | return (p, Just rsp) 37 | 38 | CmdSleep n -> return (p, Nothing) 39 | -------------------------------------------------------------------------------- /src/Network/Stream/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | module Network.Stream.Types where 4 | 5 | import Control.Exception (Exception) 6 | import Data.Text (Text) 7 | import Data.Data (Data) 8 | import Data.Typeable (Typeable) 9 | {- 10 | import Data.ByteString (ByteString) 11 | import qualified Data.Vector as V 12 | import Data.Word (Word16, Word64) 13 | -} 14 | 15 | ------------------------------------------------------------------------ 16 | 17 | data Endpoint = Endpoint 18 | { epHost :: !HostName 19 | , epPort :: !Port 20 | } deriving (Eq, Ord, Show) 21 | 22 | type HostName = Text 23 | type Port = Int 24 | 25 | ------------------------------------------------------------------------ 26 | 27 | data RemoteError = RemoteError !Text !Text 28 | deriving (Show, Eq, Data, Typeable) 29 | 30 | instance Exception RemoteError 31 | 32 | ------------------------------------------------------------------------ 33 | 34 | data DecodeError = DecodeError !Text 35 | deriving (Show, Eq, Data, Typeable) 36 | 37 | instance Exception DecodeError 38 | 39 | ------------------------------------------------------------------------ 40 | 41 | data ConnectionClosed = ConnectionClosed 42 | deriving (Show, Eq, Data, Typeable) 43 | 44 | instance Exception ConnectionClosed 45 | 46 | ------------------------------------------------------------------------ 47 | -------------------------------------------------------------------------------- /src/Network/Protocol/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module Network.Protocol.Server ( 5 | serveOn 6 | ) where 7 | 8 | import Control.Concurrent (forkIO) 9 | import Control.Exception (finally) 10 | import Control.Monad (forever) 11 | import Control.Monad.Trans (liftIO) 12 | import qualified Data.ByteString.Char8 as BS 13 | import Data.Serialize 14 | import Network 15 | import Network.Socket as S 16 | import System.IO 17 | import Text.Printf 18 | 19 | import Network.Protocol 20 | 21 | import Network.Stream as Stream 22 | import Network.Stream.Socket as Stream 23 | import Network.Stream.Types as Stream 24 | 25 | import Control.Monad.Free 26 | import Raft.Types(Store(..), StoreIO(..), LogStoreF) 27 | 28 | ---------------------------------------------------------------------- 29 | 30 | serveOn :: (StoreIO s, Protocol p, Serialize (Request p), Serialize (Response p), 31 | Effects p ~ Free (LogStoreF [] (Value s))) 32 | => PortID -> p -> s -> IO () 33 | serveOn port p0 store0 = do 34 | s <- listenOn port 35 | forever $ do 36 | (h, addr) <- S.accept s 37 | stream <- mkSocketStream h 38 | forkIO (loop stream p0 store0 `finally` S.sClose h) 39 | where 40 | loop stream p store = do 41 | cmd <- Stream.runGet stream get 42 | 43 | let e = step p cmd 44 | (store', (p', m'rsp)) <- interpret e store 45 | case m'rsp of 46 | Just rsp -> Stream.runPut stream $ put rsp 47 | Nothing -> return () 48 | loop stream p' store' 49 | 50 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Conrad Parker 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Conrad Parker nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /examples/ClientTypes.hs: -------------------------------------------------------------------------------- 1 | module ClientTypes ( 2 | ClientCommand(..) 3 | , ClientResponse(..) 4 | ) where 5 | 6 | import Control.Applicative ((<$>), (<*>)) 7 | import Control.Monad (mzero) 8 | import Data.Serialize 9 | import qualified Data.ByteString.Char8 as S 10 | 11 | data ClientCommand k v = 12 | CmdSet k v 13 | | CmdGet k 14 | | CmdSleep Int 15 | | CmdHelp (Maybe S.ByteString) 16 | -- | CmdUse Host PortNumber 17 | -- | CmdPause 18 | -- | CmdDump 19 | deriving (Show, Eq) 20 | 21 | data ClientResponse k v = 22 | RspSetOK k v 23 | | RspGetOK k v 24 | | RspGetFail k 25 | deriving (Show, Eq) 26 | 27 | instance (Serialize k, Serialize v) => Serialize (ClientCommand k v) where 28 | put (CmdSet k v) = do 29 | put 'S' 30 | put k 31 | put v 32 | put (CmdGet k) = do 33 | put 'G' 34 | put k 35 | put (CmdSleep n) = do 36 | put 'D' 37 | put n 38 | put _ = return () 39 | 40 | get = do 41 | x <- get :: Get Char 42 | case x of 43 | 'S' -> CmdSet <$> get <*> get 44 | 'G' -> CmdGet <$> get 45 | 'D' -> CmdSleep <$> get 46 | _ -> mzero 47 | 48 | instance (Serialize k, Serialize v) => Serialize (ClientResponse k v) where 49 | put (RspSetOK k v) = do 50 | put 'S' 51 | put k 52 | put v 53 | put (RspGetOK k v) = do 54 | put 'G' 55 | put k 56 | put v 57 | put (RspGetFail k) = do 58 | put 'F' 59 | put k 60 | 61 | get = do 62 | x <- get :: Get Char 63 | case x of 64 | 'S' -> RspSetOK <$> get <*> get 65 | 'G' -> RspGetOK <$> get <*> get 66 | 'F' -> RspGetFail <$> get 67 | -------------------------------------------------------------------------------- /src/Network/Stream/Socket.hs: -------------------------------------------------------------------------------- 1 | module Network.Stream.Socket 2 | ( S.Socket 3 | , bracketSocket 4 | , connectSocket 5 | , closeSocket 6 | ) where 7 | 8 | import Control.Monad.Catch (MonadMask, bracket, bracketOnError) 9 | import Control.Monad.Fail (MonadFail) 10 | import Control.Monad.IO.Class (MonadIO(..)) 11 | import qualified Data.Text as T 12 | import Network (PortID(PortNumber)) 13 | import qualified Network.Socket as S 14 | import Network.Stream.Types 15 | 16 | ------------------------------------------------------------------------ 17 | 18 | bracketSocket :: (MonadFail m, MonadMask m, MonadIO m) => Endpoint -> (S.Socket -> m a) -> m a 19 | bracketSocket endpoint = bracket (connectSocket endpoint) closeSocket 20 | 21 | closeSocket :: MonadIO m => S.Socket -> m () 22 | closeSocket = liftIO . S.sClose 23 | 24 | ------------------------------------------------------------------------ 25 | 26 | connectSocket :: (MonadFail m, MonadMask m, MonadIO m) => Endpoint -> m S.Socket 27 | connectSocket endpoint = do 28 | (addr:_) <- liftIO $ S.getAddrInfo (Just hints) (Just host) (Just port) 29 | bracketOnError (newSocket addr) closeSocket $ \sock -> do 30 | liftIO $ S.connect sock (S.addrAddress addr) 31 | return sock 32 | where 33 | host = T.unpack (epHost endpoint) 34 | port = show (epPort endpoint) 35 | hints = S.defaultHints { S.addrFlags = [S.AI_ADDRCONFIG] 36 | , S.addrSocketType = S.Stream } 37 | 38 | newSocket :: MonadIO m => S.AddrInfo -> m S.Socket 39 | newSocket addr = liftIO $ S.socket (S.addrFamily addr) 40 | (S.addrSocketType addr) 41 | (S.addrProtocol addr) 42 | -------------------------------------------------------------------------------- /src/Raft/Store/Volatile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module Raft.Store.Volatile ( 5 | VolatileStore(..) 6 | , empty 7 | ) where 8 | 9 | import Control.Applicative ((<$>)) 10 | import qualified Data.ByteString.Char8 as S 11 | import Data.Functor.Identity 12 | 13 | import Control.Monad.Free 14 | import Control.Monad.State 15 | import qualified Data.Foldable as Fold 16 | import Data.Map (Map) 17 | import qualified Data.Map as Map 18 | 19 | import qualified Raft.Protocol as CS 20 | import qualified Raft.Types as CS 21 | 22 | ---------------------------------------------------------------------- 23 | 24 | data VolatileStore = VolatileStore { 25 | tsInternal :: Map CS.Index (Int, CS.Term) 26 | , tsLatestCommit :: CS.Index 27 | } 28 | 29 | empty :: VolatileStore 30 | empty = VolatileStore Map.empty 0 31 | 32 | ---------------------------------------------------------------------- 33 | 34 | runVolatileStore :: (MonadState VolatileStore m, Fold.Foldable t) 35 | => Free (CS.LogStoreF t Int) r -> m r 36 | runVolatileStore (Pure r) = return r 37 | runVolatileStore (Free x) = case x of 38 | CS.LogQuery ix cont -> do 39 | VolatileStore s c <- get 40 | let res = Map.lookup ix s 41 | runVolatileStore $ cont res 42 | CS.LogStore ix term xs next -> do 43 | modify $ \(VolatileStore s c) -> 44 | (\m -> VolatileStore m c) . fst $ Fold.foldl' (\(m, ixx) x -> (Map.insert ixx (x,term) m, ixx+1)) (s, ix) xs 45 | runVolatileStore next 46 | CS.LogCommit ix next -> do 47 | modify $ \ts -> ts { tsLatestCommit = ix } 48 | runVolatileStore next 49 | CS.LogTruncate ix next -> do 50 | modify $ \(VolatileStore s c) -> 51 | VolatileStore (fst (Map.split ix s)) (min ix c) 52 | runVolatileStore next 53 | 54 | instance CS.Store VolatileStore where 55 | type Value VolatileStore = Int 56 | 57 | instance CS.StoreIO VolatileStore where 58 | interpret cmds s = do 59 | (r, s') <- runStateT (runVolatileStore cmds) s 60 | return (s', r) 61 | -------------------------------------------------------------------------------- /src/Raft/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | 6 | module Raft.Types ( 7 | Identifier 8 | , Index 9 | , Term(..) 10 | 11 | , Store(..) 12 | , StoreIO(..) 13 | 14 | , LogStoreF(..) 15 | , query' 16 | , store' 17 | , commit' 18 | , truncate' 19 | ) where 20 | 21 | import Control.Applicative ((<$>)) 22 | import Control.Monad.Free 23 | import Control.Monad.Trans (MonadIO) 24 | import Data.Foldable (Foldable) 25 | import qualified Data.Foldable as Fold 26 | import Data.Serialize 27 | 28 | import Network.Protocol 29 | 30 | ---------------------------------------------------------------------- 31 | 32 | type Identifier = Int 33 | 34 | type Index = Int 35 | 36 | ---------------------------------------------------------------------- 37 | -- Term 38 | 39 | newtype Term = Term Int 40 | deriving (Show, Eq, Ord, Serialize) 41 | 42 | class HasTerm a where 43 | termOf :: a -> Term 44 | 45 | ---------------------------------------------------------------------- 46 | 47 | {- 48 | class Node a where 49 | 50 | identify :: a -> Identifier 51 | 52 | receive :: Monad m => a -> m (a, Request b) 53 | 54 | send :: Monad m => Response b -> a -> m a 55 | -} 56 | 57 | data LogStoreF t entry next 58 | -- | Query the value at a given index 59 | = LogQuery Index (Maybe (entry, Term) -> next) 60 | -- | Store a value at a given index 61 | | LogStore Index Term (t entry) next 62 | | LogCommit Index next 63 | -- | Delete a given entry and all that follow it 64 | | LogTruncate Index next 65 | deriving Functor 66 | 67 | query' :: MonadFree (LogStoreF t entry) m => Index -> m (Maybe (entry, Term)) 68 | query' ix = liftF (LogQuery ix id) 69 | 70 | store' :: MonadFree (LogStoreF t entry) m => Index -> Term -> t entry -> m () 71 | store' ix term entries = liftF (LogStore ix term entries ()) 72 | 73 | commit' :: MonadFree (LogStoreF t entry) m => Index -> m () 74 | commit' ix = liftF (LogCommit ix ()) 75 | 76 | truncate' :: MonadFree (LogStoreF t entry) m => Index -> m () 77 | truncate' ix = liftF (LogTruncate ix ()) 78 | 79 | class Store s where 80 | type Value s :: * 81 | 82 | class Store s => StoreIO s where 83 | interpret :: Free (LogStoreF [] (Value s)) r -> s -> IO (s, r) 84 | -------------------------------------------------------------------------------- /raft.cabal: -------------------------------------------------------------------------------- 1 | name: raft 2 | version: 0.1.0.0 3 | 4 | synopsis: 5 | Raft distributed consensus algorithm 6 | 7 | -- description: 8 | 9 | homepage: http://github.com/kfish/raft 10 | license: Apache-2.0 11 | license-file: LICENSE 12 | author: Conrad Parker 13 | maintainer: Conrad Parker 14 | -- copyright: 15 | category: Database 16 | build-type: Simple 17 | cabal-version: >=1.10 18 | 19 | library 20 | hs-source-dirs: src 21 | default-language: Haskell2010 22 | 23 | exposed-modules: 24 | Raft.Protocol 25 | Raft.Types 26 | Raft.Store.Sqlite 27 | Raft.Store.Volatile 28 | Network.Protocol 29 | Network.Protocol.Server 30 | Network.Stream 31 | Network.Stream.Socket 32 | Network.Stream.Types 33 | 34 | build-depends: 35 | base >=4.7 36 | , attoparsec 37 | , cereal 38 | , bytestring 39 | , containers >=0.5 40 | , exceptions >= 0.6 41 | , free 42 | , mtl >= 2.0 43 | , network 44 | , sqlite-simple >= 0.4 45 | , text 46 | , transformers >= 0.4 47 | 48 | executable test-server 49 | hs-source-dirs: examples 50 | default-language: Haskell2010 51 | main-is: 52 | TestServer.hs 53 | build-depends: 54 | base >= 4 && < 5 55 | , cereal 56 | , containers >=0.5 57 | , bytestring 58 | , free 59 | , mtl >= 2.0 60 | , network 61 | , transformers >= 0.4 62 | , raft 63 | 64 | executable sqlite-server 65 | hs-source-dirs: examples 66 | default-language: Haskell2010 67 | main-is: 68 | SqliteServer.hs 69 | build-depends: 70 | base >= 4 && < 5 71 | , cereal 72 | , containers >=0.5 73 | , bytestring 74 | , free 75 | , mtl >= 2.0 76 | , network 77 | , sqlite-simple >= 0.4 78 | , text 79 | , transformers >= 0.4 80 | , raft 81 | 82 | executable raft-client 83 | hs-source-dirs: examples 84 | default-language: Haskell2010 85 | main-is: 86 | Client.hs 87 | build-depends: 88 | base >= 4 && < 5 89 | , attoparsec 90 | , cereal 91 | , bytestring 92 | , containers >=0.5 93 | , filepath 94 | , haskeline 95 | , mtl >= 2.0 96 | , network 97 | , transformers >= 0.4 98 | , raft 99 | 100 | test-suite test 101 | default-language: Haskell2010 102 | type: 103 | exitcode-stdio-1.0 104 | hs-source-dirs: 105 | tests 106 | main-is: 107 | test.hs 108 | build-depends: 109 | base >= 4 110 | , containers >=0.5 111 | , free 112 | , mtl >= 2.0 113 | , transformers >= 0.4 114 | , tasty >= 0.7 115 | , tasty-hunit 116 | , tasty-quickcheck 117 | , raft 118 | -------------------------------------------------------------------------------- /src/Raft/Store/Sqlite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Raft.Store.Sqlite ( 6 | SqliteStore(..) 7 | , open 8 | ) where 9 | 10 | import Data.Functor.Identity 11 | 12 | import Control.Applicative ((<$>)) 13 | import Control.Arrow (second) 14 | import Control.Monad (unless) 15 | import Control.Monad.Free 16 | import Control.Monad.State 17 | 18 | import qualified Data.Foldable as Fold 19 | import Data.Map (Map) 20 | import qualified Data.Map as Map 21 | import Data.Maybe (fromMaybe, listToMaybe) 22 | import qualified Data.Text as T 23 | 24 | import qualified Database.SQLite.Simple as Sqlite 25 | 26 | import qualified Raft.Protocol as CS 27 | import qualified Raft.Types as CS 28 | 29 | ---------------------------------------------------------------------- 30 | 31 | tableExists :: Sqlite.Connection -> String -> IO Bool 32 | tableExists conn tblName = do 33 | r <- Sqlite.query conn 34 | "SELECT name FROM sqlite_master WHERE type='table' AND name=?" 35 | (Sqlite.Only tblName) 36 | case r of 37 | [Sqlite.Only (_ :: String)] -> return True 38 | _ -> return False 39 | 40 | createTables :: Sqlite.Connection -> IO () 41 | createTables conn = do 42 | schemaCreated <- tableExists conn "store" 43 | unless schemaCreated $ do 44 | Sqlite.execute_ conn (Sqlite.Query $ T.concat 45 | [ "CREATE TABLE store (" 46 | , "ix INTEGER PRIMARY KEY, " 47 | , "value INTEGER, " 48 | , "term INTEGER " 49 | , ")" 50 | ]) 51 | Sqlite.execute_ conn (Sqlite.Query $ T.concat 52 | [ "CREATE TABLE meta (" 53 | , "latestCommit INTEGER" 54 | , ")" 55 | ]) 56 | 57 | ---------------------------------------------------------------------- 58 | 59 | data SqliteStore = SqliteStore { 60 | ssConnection :: Sqlite.Connection 61 | } 62 | 63 | type SqliteStoreM = StateT SqliteStore IO 64 | 65 | open :: FilePath -> IO SqliteStore 66 | open path = do 67 | conn <- Sqlite.open path 68 | createTables conn 69 | return (SqliteStore conn) 70 | 71 | runSqliteStore :: (Fold.Foldable t) 72 | => Free (CS.LogStoreF t Int) r -> SqliteStoreM r 73 | runSqliteStore (Pure r) = return r 74 | runSqliteStore (Free x) = case x of 75 | CS.LogQuery ix cont -> do 76 | SqliteStore conn <- get 77 | res <- liftIO $ Sqlite.query conn "select value, term from store where ix = (?)" [ix] 78 | runSqliteStore $ cont (second CS.Term <$> listToMaybe res) 79 | CS.LogStore ix (CS.Term term) xs next -> do 80 | SqliteStore conn <- get 81 | liftIO $ mapM_ (\(ixx, x) -> 82 | Sqlite.execute conn "insert into store (ix,value,term) values (?,?,?)" [ixx, x, term]) 83 | (zip [ix..] (Fold.toList xs)) 84 | runSqliteStore next 85 | CS.LogCommit ix next -> do 86 | SqliteStore conn <- get 87 | liftIO $ Sqlite.execute conn "insert into meta (latestCommit) values (?)" [ix] 88 | runSqliteStore next 89 | CS.LogTruncate ix next -> do 90 | SqliteStore conn <- get 91 | liftIO $ do 92 | res <- Sqlite.query_ conn "select from meta (latestCommit)" 93 | let [c] = fromMaybe [0] (listToMaybe res) 94 | Sqlite.execute conn "delete from store where ix > (?)" [min ix c] 95 | runSqliteStore next 96 | 97 | instance CS.Store SqliteStore where 98 | type Value SqliteStore = Int 99 | 100 | instance CS.StoreIO SqliteStore where 101 | interpret cmds s = do 102 | (r, s') <- runStateT (runSqliteStore cmds) s 103 | return (s', r) 104 | -------------------------------------------------------------------------------- /src/Network/Stream.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -------------------------------------------------------------------------------- 4 | -- | Lightweight abstraction over an input/output stream. 5 | -- (stolen from 'websockets' package via 'hadoop-rpc') 6 | 7 | module Network.Stream 8 | ( Stream 9 | , mkStream 10 | , mkSocketStream 11 | , mkEchoStream 12 | , parse 13 | , maybeGet 14 | , runGet 15 | , runPut 16 | , write 17 | , close 18 | ) where 19 | 20 | import Control.Applicative ((<$>)) 21 | import qualified Control.Concurrent.Chan as Chan 22 | import Control.Exception (throwIO) 23 | import Control.Monad (forM_) 24 | import qualified Data.Attoparsec.ByteString as Atto 25 | import qualified Data.ByteString as B 26 | import qualified Data.ByteString.Lazy as L 27 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) 28 | import qualified Data.Serialize.Get as Get 29 | import qualified Data.Serialize.Put as Put 30 | import qualified Network.Socket as S 31 | import qualified Network.Socket.ByteString as B (recv) 32 | import qualified Network.Socket.ByteString.Lazy as L (sendAll) 33 | 34 | import Network.Stream.Types 35 | -- import Data.Hadoop.Types 36 | 37 | -------------------------------------------------------------------------------- 38 | 39 | -- | State of the stream 40 | data StreamState 41 | = Closed !B.ByteString -- Remainder 42 | | Open !B.ByteString -- Buffer 43 | 44 | -------------------------------------------------------------------------------- 45 | 46 | -- | Lightweight abstraction over an input/output stream. 47 | data Stream = Stream 48 | { streamIn :: IO (Maybe B.ByteString) 49 | , streamOut :: (Maybe L.ByteString -> IO ()) 50 | , streamState :: !(IORef StreamState) 51 | } 52 | 53 | -------------------------------------------------------------------------------- 54 | 55 | mkStream 56 | :: IO (Maybe B.ByteString) -- ^ Reading 57 | -> (Maybe L.ByteString -> IO ()) -- ^ Writing 58 | -> IO Stream -- ^ Resulting stream 59 | mkStream i o = Stream i o <$> newIORef (Open B.empty) 60 | 61 | -------------------------------------------------------------------------------- 62 | 63 | mkSocketStream :: S.Socket -> IO Stream 64 | mkSocketStream socket = mkStream receive send 65 | where 66 | receive = do 67 | bs <- B.recv socket (1024*1024) 68 | return $ if B.null bs then Nothing else Just bs 69 | 70 | send Nothing = return () 71 | send (Just bs) = L.sendAll socket bs 72 | 73 | -------------------------------------------------------------------------------- 74 | 75 | mkEchoStream :: IO Stream 76 | mkEchoStream = do 77 | chan <- Chan.newChan 78 | mkStream (Chan.readChan chan) $ \mbBs -> case mbBs of 79 | Nothing -> Chan.writeChan chan Nothing 80 | Just bs -> forM_ (L.toChunks bs) $ \c -> Chan.writeChan chan (Just c) 81 | 82 | -------------------------------------------------------------------------------- 83 | 84 | parse :: Stream -> Atto.Parser a -> IO (Maybe a) 85 | parse stream parser = do 86 | state <- readIORef (streamState stream) 87 | case state of 88 | Closed remainder 89 | | B.null remainder -> return Nothing 90 | | otherwise -> go (Atto.parse parser remainder) True 91 | Open buffer 92 | | B.null buffer -> do 93 | mbBs <- streamIn stream 94 | case mbBs of 95 | Nothing -> do 96 | writeIORef (streamState stream) (Closed B.empty) 97 | return Nothing 98 | Just bs -> go (Atto.parse parser bs) False 99 | | otherwise -> go (Atto.parse parser buffer) False 100 | where 101 | -- Buffer is empty when entering this function. 102 | go (Atto.Done remainder x) closed = do 103 | writeIORef (streamState stream) $ 104 | if closed then Closed remainder else Open remainder 105 | return (Just x) 106 | go (Atto.Partial f) closed 107 | | closed = go (f B.empty) True 108 | | otherwise = do 109 | mbBs <- streamIn stream 110 | case mbBs of 111 | Nothing -> go (f B.empty) True 112 | Just bs -> go (f bs) False 113 | go (Atto.Fail _ _ err) _ = error ("parse: " ++ err) 114 | 115 | maybeGet :: Stream -> Get.Get a -> IO (Maybe a) 116 | maybeGet stream getter = do 117 | state <- readIORef (streamState stream) 118 | case state of 119 | Closed remainder 120 | | B.null remainder -> return Nothing 121 | | otherwise -> go (Get.runGetPartial getter remainder) True 122 | Open buffer 123 | | B.null buffer -> do 124 | mbBs <- streamIn stream 125 | case mbBs of 126 | Nothing -> do 127 | writeIORef (streamState stream) (Closed B.empty) 128 | return Nothing 129 | Just bs -> go (Get.runGetPartial getter bs) False 130 | | otherwise -> go (Get.runGetPartial getter buffer) False 131 | where 132 | -- Buffer is empty when entering this function. 133 | go (Get.Done x remainder) closed = do 134 | writeIORef (streamState stream) $ 135 | if closed then Closed remainder else Open remainder 136 | return (Just x) 137 | go (Get.Partial f) closed 138 | | closed = go (f B.empty) True 139 | | otherwise = do 140 | mbBs <- streamIn stream 141 | case mbBs of 142 | Nothing -> go (f B.empty) True 143 | Just bs -> go (f bs) False 144 | go (Get.Fail err _) _ = error ("runGetStream: " ++ err) 145 | 146 | runGet :: Stream -> Get.Get a -> IO a 147 | runGet stream getter = maybe throwClosed return =<< maybeGet stream getter 148 | where 149 | throwClosed = throwIO (RemoteError "ConnectionClosed" "The socket connection was closed") 150 | 151 | -------------------------------------------------------------------------------- 152 | 153 | runPut :: Stream -> Put.Put -> IO () 154 | runPut stream = write stream . Put.runPutLazy 155 | 156 | write :: Stream -> L.ByteString -> IO () 157 | write stream = streamOut stream . Just 158 | 159 | -------------------------------------------------------------------------------- 160 | 161 | close :: Stream -> IO () 162 | close stream = streamOut stream Nothing 163 | -------------------------------------------------------------------------------- /src/Raft/Protocol.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | 7 | {- 8 | 9 | https://www.usenix.org/system/files/conference/atc14/atc14-paper-ongaro.pdf 10 | 11 | -} 12 | 13 | module Raft.Protocol ( 14 | 15 | ) where 16 | 17 | import GHC.Generics 18 | 19 | import Control.Applicative ((<$>), (<*>)) 20 | import Control.Monad.Free 21 | import Control.Monad (when) 22 | import Data.Serialize 23 | import Data.Map (Map) 24 | import Data.Foldable (Foldable) 25 | import qualified Data.Foldable as Fold 26 | 27 | import Network.Protocol 28 | 29 | import qualified Raft.Types as Raft 30 | 31 | ---------------------------------------------------------------------- 32 | 33 | data RaftPersistentState s = RaftPersistentState 34 | { 35 | 36 | -- | Latest term server has seen (initialized to 0 on first boot, 37 | -- increases monotonically 38 | currentTerm :: Raft.Term 39 | 40 | -- candidateId that received vote in current term (or Nothing if none) 41 | , votedFor :: Maybe Raft.Identifier 42 | 43 | -- log entries; each entry contains command for state machine, and term 44 | -- when entry was received by leader (first index is 1) 45 | , log :: s 46 | } 47 | 48 | data RaftVolatileState = RaftVolatileState 49 | { 50 | 51 | -- | Index of highest log entry known to be committed (initialized to 0, 52 | -- increases monotonically) 53 | commitIndex :: Raft.Index 54 | 55 | -- | Index of highest log entry applied to state machine (initalized to 0, 56 | -- increases monotonically) 57 | , lastApplied :: Raft.Index 58 | } 59 | 60 | data RaftLeaderVolatileState = RaftLeaderVolatileState 61 | { 62 | 63 | -- For each server, index of the next log entry to send to that server 64 | -- (initialized to leader last log index + 1) 65 | nextIndex :: Map Raft.Identifier Int 66 | 67 | -- For each server, index of highest log entry known to be replicated on 68 | -- server (initialized to 0, increases monotonically) 69 | , matchIndex :: Map Raft.Identifier Int 70 | } 71 | 72 | data Raft s = RaftLeader (RaftPersistentState s) RaftVolatileState RaftLeaderVolatileState 73 | | RaftFollower (RaftPersistentState s) RaftVolatileState 74 | | RaftCandidate (RaftPersistentState s) RaftVolatileState 75 | 76 | pstate :: Raft s -> RaftPersistentState s 77 | pstate (RaftLeader rps _ _) = rps 78 | pstate (RaftFollower rps _) = rps 79 | pstate (RaftCandidate rps _) = rps 80 | 81 | ---------------------------------------------------------------------- 82 | -- RPC 83 | -- 84 | 85 | data AppendEntries s = AppendEntries 86 | { 87 | -- Leader's term 88 | aeTerm :: Raft.Term 89 | 90 | -- So follower can redirect clients 91 | , leaderId :: Raft.Identifier 92 | 93 | -- Index of log entry immediately preceding new ones 94 | , prevLogIndex :: Raft.Index 95 | 96 | -- Term of prevLogIndex entry 97 | , prevLogTerm :: Raft.Term 98 | 99 | -- Log entries to store (empty for heartbeat, may send more than one 100 | -- for efficiency 101 | -- , entries :: t (Raft.Value s) 102 | , entries :: [Raft.Value s] 103 | 104 | -- Leader's commitIndex 105 | , leaderCommit :: Raft.Index 106 | } 107 | deriving Generic 108 | 109 | instance ( Raft.Store s 110 | , Serialize (Raft.Value s) 111 | ) => Serialize (AppendEntries s) 112 | 113 | data AppendEntriesResponse = AppendEntriesResponse 114 | { 115 | -- currentTerm, for leader to update itself 116 | aerTerm :: Raft.Term 117 | 118 | -- True if follower contained entry matching prevLogIndex and prevLogTerm 119 | , aerSuccess :: Bool 120 | } 121 | deriving Generic 122 | 123 | instance Serialize AppendEntriesResponse 124 | 125 | data RequestVote = RequestVote 126 | { 127 | -- Candidate's term 128 | rvTerm :: Raft.Term 129 | 130 | -- Candidate requesting vote 131 | , candidateId :: Raft.Identifier 132 | 133 | -- Index of candidate's last log entry 134 | , lastLogIndex :: Raft.Index 135 | 136 | -- Term of candidate's last log entry 137 | , lastLogTerm :: Raft.Term 138 | } 139 | deriving Generic 140 | 141 | instance Serialize RequestVote 142 | 143 | data RequestVoteResponse = RequestVoteResponse 144 | { 145 | -- currentTerm, for candidate to update itself 146 | rvrTerm :: Raft.Term 147 | 148 | -- True means candidate received vote 149 | , voteGranted :: Bool 150 | } 151 | deriving Generic 152 | 153 | instance Serialize RequestVoteResponse 154 | 155 | ---------------------------------------------------------------------- 156 | 157 | data RaftRequest s = AE (AppendEntries s) 158 | | RV RequestVote 159 | 160 | data RaftResponse = AER AppendEntriesResponse 161 | | RVR RequestVoteResponse 162 | 163 | instance (Raft.Store s) => Protocol (Raft s) where 164 | type Request (Raft s) = RaftRequest s 165 | 166 | type Response (Raft s) = RaftResponse 167 | 168 | type Effects (Raft s) = Free (Raft.LogStoreF [] (Raft.Value s)) 169 | 170 | step receiver (AE AppendEntries{..}) 171 | -- Reply False if term < currentTerm 172 | | aeTerm < currentTerm = 173 | return (receiver, Just . AER$ AppendEntriesResponse currentTerm False) 174 | 175 | | otherwise = do 176 | 177 | -- Reply False if log doesn't contain an entry at prevLogIndex 178 | -- whose term matches prevLogTerm 179 | 180 | t <- fmap snd <$> Raft.query' prevLogIndex 181 | 182 | if (t /= Just prevLogTerm) 183 | then return (receiver, Just . AER$ AppendEntriesResponse currentTerm False) 184 | else do 185 | 186 | -- If an existing entry conflicts with a new one (same index but 187 | -- different terms), delete the existing entry and all that 188 | -- follow it. 189 | when (t /= Just aeTerm) $ Raft.truncate' prevLogIndex 190 | 191 | -- Append any new entries not already in the log 192 | Raft.store' (prevLogIndex+1) aeTerm entries 193 | {- 194 | -- If leaderCommit > commitIndex, set commitIndex = min (leaderCommit, index of last new entry) 195 | 196 | -} 197 | return (receiver, Just . AER$ AppendEntriesResponse aeTerm True) 198 | where 199 | RaftPersistentState{..} = pstate receiver 200 | 201 | -- match prevLogIndex s Nothing = False 202 | -- match prevLogIndex s (Just (v, t)) = t == prevLogIndex 203 | 204 | -- Follower receiving RequestVote 205 | step receiver@(RaftFollower p@RaftPersistentState{..} vol) (RV RequestVote{..}) 206 | -- Reply False if term < currentTerm 207 | | rvTerm < currentTerm 208 | = return (receiver, Just. RVR$ RequestVoteResponse currentTerm False) 209 | 210 | -- If votedFor is null or candidateId, and candidate's log is at 211 | -- least as up-to-date as receiver's log, grant vote 212 | | (votedFor == Nothing || votedFor == Just candidateId) 213 | && lastLogTerm <= currentTerm 214 | = return (RaftFollower granted vol, Just . RVR$ RequestVoteResponse rvTerm True) 215 | where 216 | granted = p { votedFor = Just candidateId } 217 | 218 | -- Leader or Candidate receiving RequestVote 219 | 220 | -- ??? If a server that is not a Follower receives a RequestVote, return False 221 | -- ??? what term to return? update volatile term? 222 | step receiver (RV _) 223 | = return (receiver, Just . RVR$ RequestVoteResponse (currentTerm (pstate receiver)) False) 224 | -------------------------------------------------------------------------------- /examples/Client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | module Main where 5 | 6 | import Control.Applicative 7 | import Control.Arrow (second) 8 | import Control.Monad (forever) 9 | import Control.Monad.Trans (lift, liftIO, MonadIO) 10 | import Control.Monad.Trans.State.Strict (StateT, evalStateT) 11 | import qualified Control.Monad.Trans.State.Strict as State 12 | 13 | import Control.Concurrent (threadDelay) 14 | 15 | import Data.Attoparsec.ByteString.Char8 as Atto hiding (isSpace) 16 | import qualified Data.ByteString.Char8 as S 17 | import Data.Char (isSpace) 18 | import Data.Serialize 19 | import Data.Foldable (for_) 20 | import Data.Function (on) 21 | import Data.Functor.Identity (Identity) 22 | import Data.List (intersperse, isPrefixOf, sort, sortBy) 23 | import qualified Data.List as List 24 | import Data.Maybe (fromMaybe) 25 | 26 | import Network 27 | 28 | import Network.Socket (Socket) 29 | import Network.Stream as Stream 30 | import Network.Stream.Socket as Stream 31 | import Network.Stream.Types as Stream 32 | 33 | import System.Console.Haskeline 34 | import System.Environment (getArgs, getEnvironment) 35 | import System.FilePath (()) 36 | import System.IO 37 | 38 | import ClientTypes 39 | 40 | data Client k v = Client 41 | { -- leaderSocket :: Maybe Handle 42 | leaderStream :: Maybe Stream.Stream 43 | } 44 | 45 | data Command k v = Command 46 | { commandParsers :: [(S.ByteString, Atto.Parser (ClientCommand k v))] 47 | , commandHelp :: [(String, String)] 48 | , commandExamples :: [(S.ByteString, ClientCommand k v)] 49 | } 50 | 51 | type ClientKey = Int 52 | type ClientValue = Int 53 | 54 | emptyClient :: Client ClientKey ClientValue 55 | emptyClient = Client Nothing 56 | 57 | main :: IO () 58 | main = do 59 | args <- getArgs 60 | Stream.bracketSocket (Endpoint "localhost" 44444) (shell commands) 61 | 62 | shell :: (Show k, Show v, Serialize k, Serialize v) => [Command k v] -> Socket -> IO () 63 | shell commands0 socket = do 64 | S.putStrLn $ "type help for help" 65 | stream <- mkSocketStream socket 66 | home <- fromMaybe "." . lookup "HOME" <$> getEnvironment 67 | let settings = setComplete (completeWordWithPrev Nothing " \t" (clientComplete commands0)) 68 | defaultSettings { historyFile = Just $ home ".raft_history" } 69 | runInputT settings loop `evalStateT` emptyClient { leaderStream = Just stream } 70 | where 71 | comment = fst . break ('#' ==) 72 | chomp = fst . S.spanEnd isSpace . snd . S.span isSpace . S.pack 73 | -- loop :: (Show k, Show v) => InputT (StateT (Client k v) IO) () 74 | loop = do 75 | m'ln <- fmap (chomp . comment) <$> getInputLine ("> ") 76 | for_ m'ln $ \ln -> if S.null ln then loop else do 77 | env <- lift State.get 78 | case parseOnly (parseCommand commands0) ln of 79 | Left err -> outputStrLn $ "parse error: " ++ show err 80 | Right cmd -> lift $ execCommand commands0 cmd 81 | loop 82 | 83 | clientComplete :: Monad m => [Command k v] -> String -> String -> m [Completion] 84 | clientComplete commands0 rPrev = return . map simpleCompletion . 85 | possible (words (reverse rPrev)) 86 | where 87 | 88 | possible :: [String] -> String -> [String] 89 | possible prior current = case prior of 90 | [] -> prefixes cmdNames 91 | _ -> [] 92 | where 93 | prefixes = filter (current `isPrefixOf`) 94 | cmdNames = concatMap (map (S.unpack . fst) . commandParsers) commands0 95 | 96 | parseCommand :: [Command k v] -> Atto.Parser (ClientCommand k v) 97 | parseCommand commands0 = prefixChoice (concatMap commandParsers commands0) 98 | where 99 | prefixChoice = choice . fmap both . sortBy (flip $ on compare fst) 100 | both (s, p) = try (string s *> p) -- try, in case p fails 101 | 102 | getStream :: StateT (Client k v) IO Stream.Stream 103 | getStream = do 104 | env <- State.get 105 | case leaderStream env of 106 | Just s -> return s 107 | Nothing -> threadDelayMS 10 >> getStream 108 | 109 | execCommand :: (Show k, Show v, Serialize k, Serialize v) => [Command k v] -> ClientCommand k v -> StateT (Client k v) IO () 110 | execCommand commands0 cmd = case cmd of 111 | CmdHelp mCmd -> liftIO . putStrLn $ showMaybeCommandHelp commands0 mCmd 112 | _ -> do 113 | stream <- getStream 114 | liftIO $ do 115 | Stream.runPut stream $ put cmd 116 | rsp <- Stream.runGet stream (get :: Get (ClientResponse ClientKey ClientValue)) 117 | putStrLn $ "Got response " ++ show rsp 118 | -- response <- hGetLine h 119 | -- putStrLn $ "Got response " ++ response 120 | 121 | {- 122 | CmdSet k v -> liftIO . putStrLn $ "Set " ++ show k ++ " to " ++ show v 123 | CmdGet k -> liftIO . putStrLn $ "Get " ++ show k 124 | CmdSleep n -> do 125 | h <- getSocket 126 | liftIO $ do 127 | putStrLn $ "Sleep for " ++ show n 128 | hPutStrLn h $ show n 129 | response <- hGetLine h 130 | putStrLn $ "Got response " ++ response 131 | -} 132 | 133 | 134 | showMaybeCommandHelp :: [Command k v] -> Maybe S.ByteString -> String 135 | showMaybeCommandHelp commands0 = maybe (showCommandsHelp False commands0) $ \cmd -> 136 | showCommandsHelp True (filter (elem cmd . fmap fst . commandParsers) commands0) 137 | 138 | showCommandsHelp :: Bool -> [Command k v] -> String 139 | showCommandsHelp showExamples = removeBlanks . concat . sort . 140 | map (showCommandHelp showExamples) 141 | where 142 | removeBlanks = unlines . filter (not . blank) . lines 143 | blank l = null l || all isSpace l 144 | 145 | showCommandHelp :: Bool -> Command k v -> String 146 | showCommandHelp showExamples Command{..} = unlines $ case showExamples of 147 | False -> blurb 148 | True -> blurb ++ examples 149 | where 150 | blurb :: [String] 151 | blurb = concatMap b commandHelp 152 | b :: (String, String) -> [String] 153 | b (synopsis, explanation) = synopsis : [indent 4 (para [explanation])] 154 | examples :: [String] 155 | examples = "Examples:" : [indent 8 (unlines (map (S.unpack . fst) commandExamples))] 156 | 157 | 158 | ------------------------------------------------------------ 159 | -- Paragraph rendering 160 | -- 161 | 162 | para :: [String] -> String 163 | para ss = concat $ intersperse "\n" (map (\s -> breakLines 76 s) ss) 164 | 165 | indent :: Int -> String -> String 166 | indent i s = unlines $ map (\x -> indentation ++ x) (lines s) 167 | where 168 | indentation = List.take i $ repeat ' ' 169 | 170 | -- breakLines leftIndent columnWidth text 171 | breakLines :: Int -> String -> String 172 | breakLines n s 173 | | length s < n = s ++ "\n" 174 | | otherwise = line' ++ "\n" ++ breakLines n rest' 175 | where 176 | (line, rest) = splitAt n s 177 | (rSpill, rLine) = break isSpace (reverse line) 178 | line' = reverse rLine 179 | rest' = reverse rSpill ++ rest 180 | 181 | 182 | ---------------------------------------------------------------------- 183 | 184 | commands :: [Command ClientKey ClientValue] 185 | commands = [cmdHelp, cmdGet, cmdSet, cmdSleep] 186 | 187 | cmdHelp :: Command ClientKey ClientValue 188 | cmdHelp = Command [("help", parser)] 189 | [] 190 | [] 191 | where 192 | parser = CmdHelp <$ skipSpace <*> ((Just <$> (takeWhile1 (not . isSpace))) <|> pure Nothing) 193 | 194 | cmdGet :: Command ClientKey ClientValue 195 | cmdGet = Command [("get", parser)] 196 | [("get", "Request a value from the log")] 197 | [("get 7", CmdGet 7)] 198 | where 199 | parser = CmdGet <$ skipSpace <*> decimal 200 | 201 | cmdSet :: Command ClientKey ClientValue 202 | cmdSet = Command [("set", parser)] 203 | [("set", "Request to set a value in the log")] 204 | [("set 7=7", CmdSet 7 7)] 205 | where 206 | parser = CmdSet <$ skipSpace 207 | -- <*> (takeWhile1 (\x -> not (isSpace x) && x /= '=') 208 | <*> (decimal 209 | <* skipMany space <* char '=' <* skipMany space) 210 | <*> decimal 211 | -- <*> takeWhile1 (not . isSpace) 212 | 213 | cmdSleep :: Command ClientKey ClientValue 214 | cmdSleep = Command [("sleep", parser)] 215 | [] 216 | [] 217 | where 218 | parser = CmdSleep <$ skipSpace <*> decimal 219 | 220 | ---------------------------------------------------------------------- 221 | 222 | threadDelayMS :: MonadIO m => Int -> m () 223 | threadDelayMS = liftIO . threadDelay . (*1000) 224 | --------------------------------------------------------------------------------