diff --git a/src/Acceptor.hs b/src/Acceptor.hs index ea4d004..1d83611 100644 --- a/src/Acceptor.hs +++ b/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 () diff --git a/src/Messages.hs b/src/Messages.hs index 3dd686d..779e0d9 100755 --- a/src/Messages.hs +++ b/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 diff --git a/src/Proposer.hs b/src/Proposer.hs index 12c64fd..52a2d33 100644 --- a/src/Proposer.hs +++ b/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' \ No newline at end of file