proposers now checks if message received is for the right ticket

src/Acceptor.hs

@@ -35,10 +35,10 @@ servePrepare ServerInfo{..} (Prepare t proposerPid) = do
         liftIO $ writeIORef tMaxRef t
         -- answer with ok(T_store, C) (line 5)
         self <- getSelfPid
-        send proposerPid $ PromiseOk tStore cmd self
+        send proposerPid $ PromiseOk tStore cmd self t
     else
         -- send negative answer to proposer
-        send proposerPid $ PromiseNotOk tMax
+        send proposerPid $ PromiseNotOk tMax t
 
 -- | Acceptor serving a phase-2 client.
 servePropose :: ServerInfo -> Propose -> Process ()
@@ -51,10 +51,10 @@ servePropose ServerInfo{..} (Propose t cmd' proposerPid) = do
         liftIO $ writeIORef    cmdRef cmd'
         liftIO $ writeIORef tStoreRef   t
         -- answer with success (line 17)
-        send proposerPid ProposalSuccess
+        send proposerPid $ ProposalSuccess t
     else do
         acceptorSay "Sent 'ProposalFailure' "
-        send proposerPid ProposalFailure
+        send proposerPid $ ProposalFailure t
 
 -- | Acceptor serving an 'Execute' message.
 serveExecute :: ServerInfo -> Execute -> Process ()

src/Messages.hs

@@ -26,19 +26,19 @@ data Prepare = Prepare TicketId ProcessId
 -- The promise-not-ok message is mentioned in the second
 -- remark as a negative message the acceptor can send to the
 -- proposer in the case it cannot make a promise.
-data Promise = PromiseOk TicketId Command ProcessId | PromiseNotOk TicketId
+data Promise = PromiseOk TicketId Command ProcessId TicketId | PromiseNotOk TicketId TicketId
     deriving (Generic, Typeable, Binary, Show)
 
 instance Eq Promise where
-    (==) (PromiseOk a b c) (PromiseOk a' b' c') = a==a' && b==b' && c==c'
-    (==)  PromiseOk{}      (PromiseNotOk _)     = False
-    (==) (PromiseNotOk _)   PromiseOk{}         = False
-    (==) (PromiseNotOk a)  (PromiseNotOk a')    = a==a'
+    (==) (PromiseOk a b c d) (PromiseOk a' b' c' d') = a==a' && b==b' && c==c' && d==d'
+    (==)  PromiseOk{}        (PromiseNotOk _ _)      = False
+    (==) (PromiseNotOk _ _)   PromiseOk{}            = False
+    (==) (PromiseNotOk a b)    (PromiseNotOk a' b')  = a==a' && b==b'
 
 instance Ord Promise where
-    compare (PromiseOk    a _ _) (PromiseOk    a' _ _) = compare a a'
-    compare (PromiseNotOk a    ) (PromiseNotOk a'    ) = compare a a'
-    compare                   _                     _  = error
+    compare (PromiseOk    a _ _ _) (PromiseOk    a' _ _ _) = compare a a'
+    compare (PromiseNotOk a _)     (PromiseNotOk a' _)     = compare a a'
+    compare                   _                     _      = error
         "You must not compare PromiseOk with PromiseNotOk"
 
 -- | The propose message is the one sent by the proposer
@@ -51,7 +51,7 @@ data Propose = Propose TicketId Command ProcessId
 -- Once again, the proposal-failure is mentioned in the
 -- second remark as a negative message the acceptor can send
 -- to the proposer in the case it cannot accept a proposal.
-data Proposal = ProposalSuccess | ProposalFailure
+data Proposal = ProposalSuccess TicketId | ProposalFailure TicketId
     deriving (Generic, Typeable, Binary, Show)
 
 -- | The execute message is the one sent by the proposer to

src/Proposer.hs

@@ -8,6 +8,7 @@ import Control.Distributed.Process (
     receiveTimeout, kill, Process, ProcessId
     )
 import Control.Monad (forM_, replicateM)
+import Data.List (partition)
 import Data.Maybe (catMaybes)
 import System.Random (randomRIO)
 
@@ -16,25 +17,32 @@ isPromiseOk :: Promise -> Bool
 isPromiseOk PromiseOk{} =  True
 isPromiseOk           _ = False
 
+-- | Rejects messages that do not refer to the right
+-- 'TicketId'
+isRelevant :: TicketId -> Promise -> Bool
+isRelevant tCurrent (PromiseOk    _ _ _ t) = tCurrent == t
+isRelevant tCurrent (PromiseNotOk _ t)     = tCurrent == t
+
 -- | Splits a 'Maybe' 'Promise' list to two lists, from
 -- which the first contains 'PromiseOk' messages and the
 -- second 'PromiseNotOk' messages.
-splitOkNotOk :: [Maybe Promise] -> ([Promise], [Promise])
-splitOkNotOk list =
-    let list' = catMaybes list in
-        (filter isPromiseOk list', filter (not.isPromiseOk) list')
+splitOkNotOk :: TicketId -> [Maybe Promise] -> ([Promise], [Promise])
+splitOkNotOk tCurrent list =
+    let list' = filter (isRelevant tCurrent) (catMaybes list) in
+        partition isPromiseOk list'
+        -- (filter isPromiseOk list', filter (not.isPromiseOk) list')
 
-isProposalSuccess :: Proposal -> Bool
-isProposalSuccess ProposalSuccess =  True
-isProposalSuccess               _ = False
+isProposalSuccess :: TicketId -> Proposal -> Bool
+isProposalSuccess tCurrent (ProposalSuccess t) = t == tCurrent
+isProposalSuccess        _                  _  = False
 
 -- | The 'catProposalSuccess' function takes a list of 'Maybe'
 -- 'Proposal's and returns a list of all the 'Just'
--- 'ProposalSuccess' values.
-catProposalSuccess :: [Maybe Proposal] -> [Proposal]
-catProposalSuccess list =
+-- 'ProposalSuccess' values for the specified 'TicketId'.
+catProposalSuccess :: [Maybe Proposal] -> TicketId -> [Proposal]
+catProposalSuccess list t =
     let list' = catMaybes list in
-        filter isProposalSuccess list'
+        filter (isProposalSuccess t) list'
 
 -- | Sends 'Prepare' to every acceptor.
 sendPrepare :: TicketId -> ProcessId -> [ProcessId] -> Process ()
@@ -62,27 +70,27 @@ propose serverPids cmd t = do
 
     let a = length serverPids
     answers <- replicateM a (receiveTimeout second [ match receivePromise ])
-    let (listOk, listNotOk) = splitOkNotOk answers
+    let (listOk, listNotOk) = splitOkNotOk t' answers
 
     kill senderPid "Receiving is over"
 
     if length listOk < a `div` 2 + 1 then
         case listNotOk of
             [] -> propose serverPids cmd t'
-            _  -> let PromiseNotOk t'' = maximum listNotOk in
+            _  -> let PromiseNotOk t'' _ = maximum listNotOk in
                 do
                     proposerSay $ "Received 'PromiseNotOk'. Changing t: " ++
                         show t' ++ " -> " ++ show (t''+1)
                     propose serverPids cmd t''
     else do
         -- Phase 2
-        let (PromiseOk tStore c _) = maximum listOk
+        let (PromiseOk tStore c _ _) = maximum listOk
         let cmd' = if tStore > 0 then c else cmd
-        let pidsListOk = map (\(PromiseOk _ _ pid) -> pid) listOk
+        let pidsListOk = map (\(PromiseOk _ _ pid _) -> pid) listOk
         forM_ pidsListOk $ flip send $ Propose t' cmd' self
 
         ans <- replicateM a (receiveTimeout second [ match receiveProposal ])
-        if length (catProposalSuccess ans) < a `div` 2 + 1 then
+        if length (catProposalSuccess ans t') < a `div` 2 + 1 then
             propose serverPids cmd t'
         else
             forM_ serverPids $ flip send $ Execute cmd'