1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
|
{-# 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
|
