From 2d26a10be45a377cd76346336de9667b278a2c28 Mon Sep 17 00:00:00 2001 From: joe Date: Fri, 15 Sep 2017 03:36:00 -0400 Subject: Moved TriadCommittee to hierarchical location. --- DHTHandlers.hs | 2 +- Mainline.hs | 2 +- Tox.hs | 2 +- TriadCommittee.hs | 89 ------------------------------------------- src/Control/TriadCommittee.hs | 89 +++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 92 insertions(+), 92 deletions(-) delete mode 100644 TriadCommittee.hs create mode 100644 src/Control/TriadCommittee.hs diff --git a/DHTHandlers.hs b/DHTHandlers.hs index ba5ee295..1cc4cf83 100644 --- a/DHTHandlers.hs +++ b/DHTHandlers.hs @@ -12,7 +12,7 @@ import qualified Data.Wrapper.PSQInt as Int import Network.Kademlia import Network.Address (WantIP (..), ipFamily, testIdBit,fromSockAddr, sockAddrPort) import qualified Network.DHT.Routing as R -import TriadCommittee +import Control.TriadCommittee import System.Global6 import qualified Data.ByteArray as BA diff --git a/Mainline.hs b/Mainline.hs index be9248ce..b6f99487 100644 --- a/Mainline.hs +++ b/Mainline.hs @@ -79,7 +79,7 @@ import qualified Data.Aeson as JSON ;import Data.Aeson (FromJSON, ToJSON, (.=)) import Text.Read import System.Global6 -import TriadCommittee +import Control.TriadCommittee newtype NodeId = NodeId ByteString deriving (Eq,Ord,ByteArrayAccess, Bits, Hashable) diff --git a/Tox.hs b/Tox.hs index 802c466d..7ba0d63e 100644 --- a/Tox.hs +++ b/Tox.hs @@ -79,7 +79,7 @@ import System.IO import qualified Text.ParserCombinators.ReadP as RP import Text.Printf import Text.Read -import TriadCommittee +import Control.TriadCommittee import Network.BitTorrent.DHT.Token as Token import GHC.TypeLits diff --git a/TriadCommittee.hs b/TriadCommittee.hs deleted file mode 100644 index 3e5a710a..00000000 --- a/TriadCommittee.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE TupleSections #-} -module TriadCommittee where - -import Control.Concurrent.STM -import Control.Monad -import Data.Maybe - - -data TriadSlot = SlotA | SlotB | SlotC - deriving (Eq,Ord,Enum,Show,Read) - -data TriadCommittee voter a = TriadCommittee - { triadDecider :: TVar TriadSlot - , triadA :: TVar (Maybe (voter,a)) - , triadB :: TVar (Maybe (voter,a)) - , triadC :: TVar (Maybe (voter,a)) - , triadNewDecision :: a -> STM () - } - -triadSlot :: TriadSlot -> TriadCommittee voter a -> TVar (Maybe (voter,a)) -triadSlot SlotA = triadA -triadSlot SlotB = triadB -triadSlot SlotC = triadC - -triadDecision :: a -> TriadCommittee voter a -> STM a -triadDecision fallback triad = do - slot <- readTVar (triadDecider triad) - maybe fallback snd <$> readTVar (triadSlot slot triad) - - -newTriadCommittee :: (a -> STM ()) -> STM (TriadCommittee voter a) -newTriadCommittee onChange = - TriadCommittee <$> newTVar SlotA - <*> newTVar Nothing - <*> newTVar Nothing - <*> newTVar Nothing - <*> pure onChange - - -triadCountVotes :: Eq a => Maybe a -> TriadCommittee voter a -> STM () -triadCountVotes prior triad = do - a <- fmap ((SlotA,) . snd) <$> readTVar (triadA triad) - b <- fmap ((SlotB,) . snd) <$> readTVar (triadB triad) - c <- fmap ((SlotC,) . snd) <$> readTVar (triadC triad) - let (slot,vote) = case catMaybes [a,b,c] of - [ (x,xvote) - , (y,yvote) - , (z,zvote) ] -> if xvote == yvote then (x,Just xvote) - else (z,Just zvote) - [] -> (SlotA,Nothing) - ((slot,vote):_) -> (slot, Just vote) - writeTVar (triadDecider triad) slot - case vote of - Just v | vote /= prior -> triadNewDecision triad v - _ -> return () - - -addVote :: (Eq voter, Eq a) => TriadCommittee voter a -> voter -> a -> STM () -addVote triad voter vote = do - a <- (SlotA,) . fmap fst <$> readTVar (triadA triad) - b <- (SlotB,) . fmap fst <$> readTVar (triadB triad) - c <- (SlotC,) . fmap fst <$> readTVar (triadC triad) - let avail (_,Nothing) = True - avail (_,Just x ) = (x == voter) - slots = filter avail [a,b,c] - forM_ (take 1 slots) $ \(slot,_) -> do - prior <- do - slotp <- readTVar (triadDecider triad) - fmap snd <$> readTVar (triadSlot slotp triad) - writeTVar (triadSlot slot triad) - (Just (voter,vote)) - triadCountVotes prior triad - - -delVote :: (Eq voter, Eq a) => TriadCommittee voter a -> voter -> STM () -delVote triad voter = do - a <- (SlotA,) . fmap fst <$> readTVar (triadA triad) - b <- (SlotB,) . fmap fst <$> readTVar (triadB triad) - c <- (SlotC,) . fmap fst <$> readTVar (triadC triad) - let match (_,Just x ) = (x == voter) - match _ = False - slots = filter match [a,b,c] - forM_ (take 1 slots) $ \(slot,_) -> do - prior <- do - slotp <- readTVar (triadDecider triad) - fmap snd <$> readTVar (triadSlot slotp triad) - writeTVar (triadSlot slot triad) Nothing - triadCountVotes prior triad - diff --git a/src/Control/TriadCommittee.hs b/src/Control/TriadCommittee.hs new file mode 100644 index 00000000..88e665b6 --- /dev/null +++ b/src/Control/TriadCommittee.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE TupleSections #-} +module Control.TriadCommittee where + +import Control.Concurrent.STM +import Control.Monad +import Data.Maybe + + +data TriadSlot = SlotA | SlotB | SlotC + deriving (Eq,Ord,Enum,Show,Read) + +data TriadCommittee voter a = TriadCommittee + { triadDecider :: TVar TriadSlot + , triadA :: TVar (Maybe (voter,a)) + , triadB :: TVar (Maybe (voter,a)) + , triadC :: TVar (Maybe (voter,a)) + , triadNewDecision :: a -> STM () + } + +triadSlot :: TriadSlot -> TriadCommittee voter a -> TVar (Maybe (voter,a)) +triadSlot SlotA = triadA +triadSlot SlotB = triadB +triadSlot SlotC = triadC + +triadDecision :: a -> TriadCommittee voter a -> STM a +triadDecision fallback triad = do + slot <- readTVar (triadDecider triad) + maybe fallback snd <$> readTVar (triadSlot slot triad) + + +newTriadCommittee :: (a -> STM ()) -> STM (TriadCommittee voter a) +newTriadCommittee onChange = + TriadCommittee <$> newTVar SlotA + <*> newTVar Nothing + <*> newTVar Nothing + <*> newTVar Nothing + <*> pure onChange + + +triadCountVotes :: Eq a => Maybe a -> TriadCommittee voter a -> STM () +triadCountVotes prior triad = do + a <- fmap ((SlotA,) . snd) <$> readTVar (triadA triad) + b <- fmap ((SlotB,) . snd) <$> readTVar (triadB triad) + c <- fmap ((SlotC,) . snd) <$> readTVar (triadC triad) + let (slot,vote) = case catMaybes [a,b,c] of + [ (x,xvote) + , (y,yvote) + , (z,zvote) ] -> if xvote == yvote then (x,Just xvote) + else (z,Just zvote) + [] -> (SlotA,Nothing) + ((slot,vote):_) -> (slot, Just vote) + writeTVar (triadDecider triad) slot + case vote of + Just v | vote /= prior -> triadNewDecision triad v + _ -> return () + + +addVote :: (Eq voter, Eq a) => TriadCommittee voter a -> voter -> a -> STM () +addVote triad voter vote = do + a <- (SlotA,) . fmap fst <$> readTVar (triadA triad) + b <- (SlotB,) . fmap fst <$> readTVar (triadB triad) + c <- (SlotC,) . fmap fst <$> readTVar (triadC triad) + let avail (_,Nothing) = True + avail (_,Just x ) = (x == voter) + slots = filter avail [a,b,c] + forM_ (take 1 slots) $ \(slot,_) -> do + prior <- do + slotp <- readTVar (triadDecider triad) + fmap snd <$> readTVar (triadSlot slotp triad) + writeTVar (triadSlot slot triad) + (Just (voter,vote)) + triadCountVotes prior triad + + +delVote :: (Eq voter, Eq a) => TriadCommittee voter a -> voter -> STM () +delVote triad voter = do + a <- (SlotA,) . fmap fst <$> readTVar (triadA triad) + b <- (SlotB,) . fmap fst <$> readTVar (triadB triad) + c <- (SlotC,) . fmap fst <$> readTVar (triadC triad) + let match (_,Just x ) = (x == voter) + match _ = False + slots = filter match [a,b,c] + forM_ (take 1 slots) $ \(slot,_) -> do + prior <- do + slotp <- readTVar (triadDecider triad) + fmap snd <$> readTVar (triadSlot slotp triad) + writeTVar (triadSlot slot triad) Nothing + triadCountVotes prior triad + -- cgit v1.2.3