From 11987749fc6e6d3e53ea737d46d5ab13a16faeb8 Mon Sep 17 00:00:00 2001
From: James Crayne <jim.crayne@gmail.com>
Date: Sat, 28 Sep 2019 13:43:29 -0400
Subject: Factor out some new libraries

	word64-map:
		Data.Word64Map
	network-addr:
		Network.Address
	tox-crypto:
		Crypto.Tox
	lifted-concurrent:
		Control.Concurrent.Lifted.Instrument
		Control.Concurrent.Async.Lifted.Instrument
	psq-wrap:
		Data.Wrapper.PSQInt
		Data.Wrapper.PSQ
	minmax-psq:
		Data.MinMaxPSQ
        tasks:
                Control.Concurrent.Tasks
	kad:
		Network.Kademlia
		Network.Kademlia.Bootstrap
		Network.Kademlia.Routing
		Network.Kademlia.CommonAPI
		Network.Kademlia.Persistence
		Network.Kademlia.Search
---
 dht/src/Control/TriadCommittee.hs | 89 +++++++++++++++++++++++++++++++++++++++
 1 file changed, 89 insertions(+)
 create mode 100644 dht/src/Control/TriadCommittee.hs

(limited to 'dht/src/Control/TriadCommittee.hs')

diff --git a/dht/src/Control/TriadCommittee.hs b/dht/src/Control/TriadCommittee.hs
new file mode 100644
index 00000000..88e665b6
--- /dev/null
+++ b/dht/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