refactored stabilise: use first responding neighbour

contributes to #44

src/Hash2Pub/FediChord.hs

@@ -65,9 +65,10 @@ import           Data.Either                   (rights)
 import           Data.Foldable                 (foldr')
 import           Data.IP                       (IPv6, fromHostAddress6,
                                                 toHostAddress6)
+import           Data.List                     ((\\))
 import qualified Data.Map.Strict               as Map
 import           Data.Maybe                    (catMaybes, fromJust, fromMaybe,
-                                                isJust, mapMaybe)
+                                                isJust, isNothing, mapMaybe)
 import qualified Data.Set                      as Set
 import           Data.Time.Clock.POSIX
 import           Data.Typeable                 (Typeable (..), typeOf)
@@ -184,47 +185,67 @@ cacheWriter nsSTM =
 stabiliseThread :: LocalNodeStateSTM -> IO ()
 stabiliseThread nsSTM = forever $ do
     ns <- readTVarIO nsSTM
+
+    -- iterate through the same snapshot, collect potential new neighbours
+    -- and nodes to be deleted, and modify these changes only at the end of
+    -- each stabilise run.
+    -- This decision makes iterating through a potentially changing list easier.
+
+    -- don't contact all neighbours unless the previous one failed/ Left ed
+
+    predStabilise <- stabiliseClosestResponder ns predecessors 1 []
+    succStabilise <- stabiliseClosestResponder ns predecessors 1 []
+
+    let
+        (predDeletes, predNeighbours) = either (const ([], [])) id predStabilise
+        (succDeletes, succNeighbours) = either (const ([], [])) id succStabilise
+        allDeletes = predDeletes <> succDeletes
+        allNeighbours = predNeighbours <> succNeighbours
+
+    -- now actually modify the node state's neighbours
+    updatedNs <- atomically $ do
+        newerNsSnap <- readTVar nsSTM
+        let
+            -- sorting and taking only k neighbours is taken care of by the
+            -- setSuccessors/ setPredecessors functions
+            newPreds = (predecessors newerNsSnap \\ allDeletes) <> allNeighbours
+            newSuccs = (successors newerNsSnap \\ allDeletes) <> allNeighbours
+            newNs = setPredecessors newPreds . setSuccessors newSuccs $ newerNsSnap
+        writeTVar nsSTM newNs
+        pure newNs
+
     -- TODO: update successfully stabilised nodes in cache
-    -- first stabilise immediate neihbours, then the next ones
+
-    forM_ [1..(kNeighbours ns)] (\num -> do
+    -- try looking up additional neighbours if list too short
-        stabiliseNeighbour nsSTM predecessors num
+
-        stabiliseNeighbour nsSTM successors num
-                               )
     -- TODO: make delay configurable
     threadDelay (60 * 1000)
   where
-    stabiliseNeighbour :: LocalNodeStateSTM
+    stabiliseClosestResponder :: LocalNodeState
                        -> (LocalNodeState -> [RemoteNodeState])
                        -> Int
-                       -> IO (Either String ())
+                       -> [RemoteNodeState]     -- ^ delete accumulator
-    stabiliseNeighbour nsSTM neighbourGetter neighbourNum = do
+                       -> IO (Either String ([RemoteNodeState], [RemoteNodeState])) -- ^ (nodes to be deleted, successfully pinged potential neighbours)
-        nsSnap <- readTVarIO nsSTM
+    stabiliseClosestResponder ns neighbourGetter neighbourNum deleteAcc
-        let chosenNode = maybe (Left "no such neighbour entry") Right $ atMay (neighbourGetter nsSnap) neighbourNum
+      | isNothing (currentNeighbour ns neighbourGetter neighbourNum) = pure $ Left "exhausted all neigbours"
-        -- returning @Left@ signifies the need to try again with next from list
+      | otherwise = do
-        runExceptT $ requestToNeighbour nsSnap chosenNode >>= parseNeighbourResponse
+            let node = fromJust $ currentNeighbour ns neighbourGetter neighbourNum
-    requestToNeighbour :: (MonadError String m, MonadIO m)
+            stabResponse <- requestStabilise ns node
-                       => LocalNodeState
+            case stabResponse of
-                       -> Either String RemoteNodeState
+              -- returning @Left@ signifies the need to try again with next from list
-                       -> m (Either String ([RemoteNodeState],[RemoteNodeState]))
+              Left err -> stabiliseClosestResponder ns neighbourGetter (neighbourNum+1) (node:deleteAcc)
-    requestToNeighbour _ (Left err) = throwError err
+              Right (succs, preds) -> do
-    requestToNeighbour ns (Right n) = liftIO $ requestStabilise ns n
+                -- ping each returned node before actually inserting them
-    parseNeighbourResponse :: (MonadError String m, MonadIO m)
+                -- send pings in parallel, check whether ID is part of the returned IDs
-                           => Either String ([RemoteNodeState], [RemoteNodeState])
+                pingThreads <- mapM (async . checkReachability ns) $ preds <> succs
-                           -> m ()
+                -- ToDo: exception handling, maybe log them
-    parseNeighbourResponse (Left err) = throwError err
+                -- filter out own node
-    parseNeighbourResponse (Right (succs, preds)) = liftIO $ do
+                checkedNeighbours <- filter (/= toRemoteNodeState ns) . catMaybes . rights <$> mapM waitCatch pingThreads
-        -- ping each returned node before actually inserting them
+                pure $ Right (deleteAcc, checkedNeighbours)
-        -- send pings in parallel, check whether ID is part of the returned IDs
+
-        nsSnap <- readTVarIO nsSTM
+
-        pingThreads <- mapM (async . checkReachability nsSnap) $ preds <> succs
+    currentNeighbour ns neighbourGetter = atMay $ neighbourGetter ns
-        -- ToDo: exception handling, maybe log them
-        -- filter out own node
-        checkedNeighbours <- filter (/= toRemoteNodeState nsSnap) . catMaybes . rights <$> mapM waitCatch pingThreads
 
-        atomically $ do
-            newerNsSnap <- readTVar nsSTM
-            writeTVar nsSTM $ addPredecessors checkedNeighbours . addSuccessors checkedNeighbours $ newerNsSnap
-        pure ()
     checkReachability :: LocalNodeState -> RemoteNodeState -> IO (Maybe RemoteNodeState)
     checkReachability ns toCheck = do
         resp <- requestPing ns toCheck