Initial import

.gitignore

@@ -0,0 +1,2 @@
+dist/
+cabal-dev/

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

bin/synod.hs

@@ -0,0 +1,153 @@
+{- Paxos - Implementations of Paxos-related consensus algorithms
+ -
+ - Copyright (C) 2012  Nicolas Trangez
+ -
+ - This library is free software; you can redistribute it and/or
+ - modify it under the terms of the GNU Lesser General Public
+ - License as published by the Free Software Foundation; either
+ - version 2.1 of the License, or (at your option) any later version.
+ -
+ - This library is distributed in the hope that it will be useful,
+ - but WITHOUT ANY WARRANTY; without even the implied warranty of
+ - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ - Lesser General Public License for more details.
+ -
+ - You should have received a copy of the GNU Lesser General Public
+ - License along with this library; if not, write to the Free Software
+ - Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301
+ - USA.
+ -}
+
+module Main (main) where
+
+import Control.Monad
+import Control.Applicative
+
+import Control.Concurrent
+import Control.Concurrent.STM
+
+import System.Random
+
+import Network.Paxos.Synod
+import qualified Network.Paxos.Synod.Proposer as P
+import qualified Network.Paxos.Synod.Acceptor as A
+import qualified Network.Paxos.Synod.Learner as L
+
+-- TODO Use System.Logger or something alike and log inside run* actions
+-- TODO Implement lossy and duplicating channels (and update code
+-- accordingly: restart a new round after a certain timeout etc)
+
+type NodeId = String
+type Value = String
+type Actions = [Action NodeId Value]
+type NetworkChannel = TChan (NodeId, Action NodeId Value)
+type MessageChannel = TChan (NodeId, Message NodeId Value)
+
+-- | A version of readTChan which adds some random delay before returning
+-- the actual message
+readTChan' :: TChan a -> IO a
+readTChan' chan = do
+    delay <- (`rem` 2000000) <$> randomIO
+    threadDelay delay
+    atomically $ readTChan chan
+
+handleActions :: NodeId -> NetworkChannel -> Actions -> IO ()
+handleActions name network = atomically . mapM_ (\a -> writeTChan network (name, a))
+
+runProposer :: Quorum -> P.ProposalId NodeId -> Value -> MessageChannel -> NetworkChannel -> IO ()
+runProposer q p v chan network = do
+    handleActions "proposer" network actions0
+    loop state0
+  where
+    (state0, actions0) = P.startRound q p v
+    loop state = do
+        (sender, msg) <- atomically $ readTChan chan
+        case msg of
+            MsgPromise m -> do
+                let (state', actions) = P.handlePromise state sender m
+                handleActions "proposer" network actions
+                loop state'
+            _ -> loop state
+
+runAcceptor :: Int -> MessageChannel -> NetworkChannel -> IO ()
+runAcceptor i chan network = loop state0
+  where
+    state0 = A.initialize
+    loop state = do
+        (sender, msg) <- readTChan' chan
+        case msg of
+            MsgPrepare m -> do
+                let (state', actions) = A.handlePrepare state sender m
+                handleActions ("acceptor" ++ show i) network actions
+                loop state'
+            MsgAccept m -> do
+                let (state', actions) = A.handleAccept state m
+                handleActions ("acceptor" ++ show i) network actions
+                loop state'
+            _ -> loop state
+
+runLearner :: Int -> Quorum -> MessageChannel -> NetworkChannel -> MVar Value -> IO ()
+runLearner _i q chan _network lock = loop state0
+  where
+    state0 = L.initialize q
+    loop state = do
+        (sender, msg) <- readTChan' chan
+        case msg of
+            MsgAccepted m -> do
+                let state' = L.handleAccepted state sender m
+                case L.getValue state' of
+                    Nothing -> loop state'
+                    Just v -> putMVar lock v
+            _ -> loop state
+
+runNetwork :: NetworkChannel -> MessageChannel -> MessageChannel -> MessageChannel -> IO ()
+runNetwork chan proposer acceptors learners = forever loop
+  where
+    loop = do
+        (sender, action) <- atomically $ readTChan chan
+        putStrLn $ sender ++ ": " ++ show action
+        case action of
+            Send target message -> if target == "proposer"
+                                      then atomically $ writeTChan proposer (sender, message)
+                                      else error $ "Unknown target '" ++ target ++ "'"
+            Broadcast group message -> case group of
+                                          Acceptors -> atomically $ writeTChan acceptors (sender, message)
+                                          Learners -> atomically $ writeTChan learners (sender, message)
+
+
+main :: IO ()
+main = do
+    proposerChan <- newTChanIO
+    acceptorsChan <- newBroadcastTChanIO
+    learnersChan <- newBroadcastTChanIO
+
+    network <- newTChanIO
+
+    lock <- newEmptyMVar
+
+    networkHandler <- forkIO $ runNetwork network proposerChan acceptorsChan learnersChan
+
+    learners <- forM [0 .. numLearners - 1] $ \i -> do
+                    chan <- atomically $ dupTChan learnersChan
+                    forkIO $ runLearner i q chan network lock
+
+    acceptors <- forM [0 .. numAcceptors - 1] $ \i -> do
+                    chan <- atomically $ dupTChan acceptorsChan
+                    forkIO $ runAcceptor i chan network
+
+    proposer <- forkIO $ runProposer q (P.initialProposalId "proposer") "Hello, world!" proposerChan network
+
+    result <- takeMVar lock
+
+    mapM_ killThread acceptors
+    mapM_ killThread learners
+    killThread proposer
+    killThread networkHandler
+
+    putStrLn $ "Learned value: " ++ result
+
+  where
+    numLearners, numAcceptors :: Int
+    numLearners = 2
+    numAcceptors = 5
+    q = quorum $ numAcceptors `div` 2 + 1

bin/tests.hs

@@ -0,0 +1,32 @@
+{- Paxos - Implementations of Paxos-related consensus algorithms
+ -
+ - Copyright (C) 2012  Nicolas Trangez
+ -
+ - This library is free software; you can redistribute it and/or
+ - modify it under the terms of the GNU Lesser General Public
+ - License as published by the Free Software Foundation; either
+ - version 2.1 of the License, or (at your option) any later version.
+ -
+ - This library is distributed in the hope that it will be useful,
+ - but WITHOUT ANY WARRANTY; without even the implied warranty of
+ - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ - Lesser General Public License for more details.
+ -
+ - You should have received a copy of the GNU Lesser General Public
+ - License along with this library; if not, write to the Free Software
+ - Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301
+ - USA.
+ -}
+
+module Main (main) where
+
+import Test.Framework (Test, defaultMain)
+
+import qualified Network.Paxos.Synod
+
+main :: IO ()
+main = defaultMain tests
+
+tests :: [Test]
+tests = [ Network.Paxos.Synod.tests
+        ]

paxos.cabal

@@ -0,0 +1,47 @@
+Name:                paxos
+Version:             0.1.0.0
+Synopsis:            Implementations of Paxos-related consensus algorithms
+-- Description:         
+Homepage:            http://github.com/NicolasT/Paxos
+License:             LGPL-2.1
+License-File:        LICENSE
+Author:              Nicolas Trangez
+Maintainer:          ikke@nicolast.be
+Copyright:           Copyright (c) 2012, Nicolas Trangez
+Category:            Network
+Build-Type:          Simple
+Cabal-Version:       >=1.8
+
+Library
+  Exposed-Modules:     Network.Paxos.Synod,
+                       Network.Paxos.Synod.Proposer,
+                       Network.Paxos.Synod.Acceptor,
+                       Network.Paxos.Synod.Learner
+  Other-Modules:       Network.Paxos.Synod.Action,
+                       Network.Paxos.Synod.Types,
+                       Network.Paxos.Synod.Messages
+  Build-Depends:       base >= 4 && < 5,
+                       containers,
+                       QuickCheck >= 2,
+                       test-framework,
+                       test-framework-quickcheck2
+  Hs-Source-Dirs:      src
+  Ghc-Options:         -Wall -fwarn-incomplete-patterns
+
+Executable synod
+  Main-Is:             synod.hs
+  Build-Depends:       base >= 4 && < 5,
+                       stm,
+                       random,
+                       paxos
+  Hs-Source-Dirs:      bin
+  Ghc-Options:         -Wall -fwarn-incomplete-patterns -rtsopts -threaded
+
+Test-Suite tests
+  Type:                exitcode-stdio-1.0
+  Main-Is:             tests.hs
+  Build-Depends:       base >= 4 && < 5,
+                       test-framework,
+                       paxos
+  Hs-Source-Dirs:      bin
+  Ghc-Options:         -Wall -fwarn-incomplete-patterns -rtsopts -threaded

src/Network/Paxos/Synod.hs

@@ -0,0 +1,50 @@
+{- Paxos - Implementations of Paxos-related consensus algorithms
+ -
+ - Copyright (C) 2012  Nicolas Trangez
+ -
+ - This library is free software; you can redistribute it and/or
+ - modify it under the terms of the GNU Lesser General Public
+ - License as published by the Free Software Foundation; either
+ - version 2.1 of the License, or (at your option) any later version.
+ -
+ - This library is distributed in the hope that it will be useful,
+ - but WITHOUT ANY WARRANTY; without even the implied warranty of
+ - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ - Lesser General Public License for more details.
+ -
+ - You should have received a copy of the GNU Lesser General Public
+ - License along with this library; if not, write to the Free Software
+ - Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301
+ - USA.
+ -}
+
+module Network.Paxos.Synod (
+    -- * Re-exports
+      BroadcastGroup(..)
+    , Action(..)
+    , Message(..)
+    , Quorum
+    , quorum
+    -- * Testing
+    , tests
+    ) where
+
+import Test.Framework (Test, testGroup)
+
+import Network.Paxos.Synod.Action
+import Network.Paxos.Synod.Messages
+import Network.Paxos.Synod.Types hiding (tests)
+
+import qualified Network.Paxos.Synod.Types
+import qualified Network.Paxos.Synod.Proposer
+import qualified Network.Paxos.Synod.Acceptor
+import qualified Network.Paxos.Synod.Learner
+
+-- | Tests for modules in "Network.Paxos.Synod"
+tests :: Test
+tests = testGroup "Network.Paxos.Synod" [
+          Network.Paxos.Synod.Types.tests
+        , Network.Paxos.Synod.Proposer.tests
+        , Network.Paxos.Synod.Acceptor.tests
+        , Network.Paxos.Synod.Learner.tests
+        ]