refactor vservers map to RingMap to be able to index it

- in preparation for periodical rebalancing
- makes it possible to look up the next vserver for iterating through
  it, after refreshing the map in-between
- added some necessary RingMap functions

src/Hash2Pub/DHTProtocol.hs

@@ -91,10 +91,9 @@ import           Hash2Pub.FediChordTypes        (CacheEntry (..),
                                                  cacheGetNodeStateUnvalidated,
                                                  cacheLookup, cacheLookupPred,
                                                  cacheLookupSucc, genNodeID,
-                                                 getKeyID, localCompare,
+                                                 getKeyID, hasValidNodeId,
-                                                 rMapFromList, rMapLookupPred,
+                                                 localCompare, rMapFromList,
-                                                 rMapLookupSucc,
+                                                 rMapLookupPred, rMapLookupSucc,
-                                                 hasValidNodeId,
                                                  remainingLoadTarget,
                                                  setPredecessors, setSuccessors)
 import           Hash2Pub.ProtocolTypes

src/Hash2Pub/FediChord.hs

@@ -92,6 +92,7 @@ import           System.Random                 (randomRIO)
 
 import           Hash2Pub.DHTProtocol
 import           Hash2Pub.FediChordTypes
+import           Hash2Pub.RingMap
 import           Hash2Pub.Utils
 
 import           Debug.Trace                   (trace)
@@ -107,7 +108,7 @@ fediChordInit initConf serviceRunner = do
     cacheSTM <- newTVarIO initCache
     cacheQ <- atomically newTQueue
     let realNode = RealNode
-          { vservers = HMap.empty
+          { vservers = emptyRMap
           , nodeConfig = initConf
           , bootstrapNodes = confBootstrapNodes initConf
           , lookupCacheSTM = emptyLookupCache
@@ -218,10 +219,10 @@ kChoicesNodeJoin nodeSTM bootstrapNode = do
     alreadyJoinedVss <- liftIO $ foldM (\sumAcc vsSTM -> readTVarIO vsSTM >>= (\vs -> pure . (+) sumAcc $ if vsIsJoined vs then 1 else 0)) 0 $ vservers node
     unless (alreadyJoinedVss > 0 && compensatedLoadSum ownLoadStats >= joinLoadTarget) $ do
         joinedVss <- vsJoins vs0STM (totalCapacity ownLoadStats) (vservers node) joinLoadTarget (fromIntegral initialJoins - alreadyJoinedVss) nodeSTM
-        if HMap.null joinedVss
+        if nullRMap joinedVss
            then throwError "k-choices join unsuccessful, no vserver joined"
            else liftIO . atomically . modifyTVar' nodeSTM $ \node' -> node'
-            { vservers = HMap.union (vservers node') joinedVss }
+            { vservers = unionRMap joinedVss (vservers node') }
 
   where
       vsJoins :: (MonadError String m, MonadIO m, Service s (RealNodeSTM s))
@@ -233,7 +234,7 @@ kChoicesNodeJoin nodeSTM bootstrapNode = do
 
             (acquiredLoad, (newNid, newVs)) <-  kChoicesVsJoin queryVsSTM bootstrapNode capacity vsmap nodeSTM' remainingTargetLoad
             -- on successful vserver join add the new VS to node and recurse
-            vsJoins queryVsSTM capacity (HMap.insert newNid newVs vsmap) (remainingTargetLoad - acquiredLoad) (pred remainingJoins) nodeSTM'
+            vsJoins queryVsSTM capacity (addRMapEntry newNid newVs vsmap) (remainingTargetLoad - acquiredLoad) (pred remainingJoins) nodeSTM'
                 -- on error, just reduce the amount of tries and retry
                 `catchError` (\e -> liftIO (putStrLn e) >> vsJoins queryVsSTM capacity vsmap remainingTargetLoad (pred remainingJoins) nodeSTM')
 
@@ -254,10 +255,9 @@ kChoicesVsJoin queryVsSTM bootstrapNode capacity activeVss nodeSTM remainingTarg
     conf <- nodeConfig <$> liftIO (readTVarIO nodeSTM)
     -- generate all possible vs IDs
     let
-        activeVsSet = HMap.keysSet activeVss
         -- tuples of node IDs and vserver IDs, because vserver IDs are needed for
         -- LocalNodeState creation
-        nonJoinedIDs = filter (not . flip HSet.member activeVsSet . fst) [ (genNodeID (confIP conf) (confDomain conf) v, v) | v <- [0..pred (confKChoicesMaxVS conf)]]
+        nonJoinedIDs = filter (not . flip memberRMap activeVss . fst) [ (genNodeID (confIP conf) (confDomain conf) v, v) | v <- [0..pred (confKChoicesMaxVS conf)]]
     queryVs <- liftIO $ readTVarIO queryVsSTM
 
     -- query load of all possible segments
@@ -526,7 +526,7 @@ joinOnNewEntriesThread nodeSTM = loop
         (lookupResult, conf, firstVSSTM) <- atomically $ do
             nodeSnap <- readTVar nodeSTM
             let conf = nodeConfig nodeSnap
-            case headMay (HMap.elems $ vservers nodeSnap) of
+            case headMay (rMapToList $ vservers nodeSnap) of
               Nothing -> retry
               Just vsSTM -> do
                 -- take any active vserver as heuristic for whether this node has
@@ -573,7 +573,7 @@ nodeCacheVerifyThread :: RealNodeSTM s -> IO ()
 nodeCacheVerifyThread nodeSTM = forever $ do
     (node, firstVSSTM) <- atomically $ do
         node <- readTVar nodeSTM
-        case headMay (HMap.elems $ vservers node) of
+        case headMay (rMapToList $ vservers node) of
           -- wait until first VS is joined
           Nothing  -> retry
           Just vs' -> pure (node, vs')
@@ -958,7 +958,7 @@ fediMessageHandler sendQ recvQ nodeSTM = do
 
         pure ()
   where
-      dispatchVS node req = HMap.lookup (receiverID req) (vservers node)
+      dispatchVS node req = rMapLookup (receiverID req) (vservers node)
 
 
 -- ==== interface to service layer ====
@@ -1009,7 +1009,7 @@ updateLookupCache :: RealNodeSTM s -> NodeID -> IO (Maybe (String, PortNumber))
 updateLookupCache nodeSTM keyToLookup = do
     (node, lookupSource) <- atomically $ do
         node <- readTVar nodeSTM
-        let firstVs = headMay (HMap.elems $ vservers node)
+        let firstVs = headMay (rMapToList $ vservers node)
         lookupSource <- case firstVs of
                           Nothing -> pure Nothing
                           Just vs -> Just <$> readTVar vs

src/Hash2Pub/FediChordTypes.hs

@@ -175,9 +175,9 @@ data RealNode s = RealNode
 -- | insert a new vserver mapping into a node
 addVserver :: (NodeID, LocalNodeStateSTM s) -> RealNode s -> RealNode s
 addVserver (key, nstate) node = node
-    { vservers = HMap.insert key nstate (vservers node) }
+    { vservers = addRMapEntry key nstate (vservers node) }
 
-type VSMap s = HashMap NodeID (LocalNodeStateSTM s)
+type VSMap s = RingMap NodeID (LocalNodeStateSTM s)
 type RealNodeSTM s = TVar (RealNode s)
 
 -- | represents a node and all its important state

src/Hash2Pub/RingMap.hs

@@ -106,6 +106,23 @@ rMapSize rmap = fromIntegral $ Map.size innerMap - oneIfEntry rmap minBound - on
       | isNothing (rMapLookup nid rmap') = 1
       | otherwise = 0
 
+
+-- | whether the RingMap is empty (except for empty proxy entries)
+nullRMap :: (Num k, Bounded k, Ord k)
+         => RingMap k a
+         -> Bool
+-- basic idea: look for a predecessor starting from the upper Map bound,
+-- Nothing indicates no entry being found
+nullRMap = isNothing . rMapLookupPred maxBound
+
+
+-- | O(logn( Is the key a member of the RingMap?
+memberRMap :: (Bounded k, Ord k)
+           => k
+           -> RingMap k a
+           -> Bool
+memberRMap key = isJust . rMapLookup key
+
 -- | a wrapper around lookup functions, making the lookup redirectable by a @ProxyEntry@
 -- to simulate a modular ring
 lookupWrapper :: (Bounded k, Ord k, Num k)
@@ -198,9 +215,11 @@ deleteRMapEntry nid = RingMap . Map.update modifier nid . getRingMap
     modifier (ProxyEntry idPointer _) = Just (ProxyEntry idPointer Nothing)
     modifier KeyEntry {}              = Nothing
 
+-- TODO: rename this to elems
 rMapToList :: (Bounded k, Ord k) => RingMap k a -> [a]
 rMapToList = mapMaybe extractRingEntry . Map.elems . getRingMap
 
+-- TODO: rename this to toList
 rMapToListWithKeys :: (Bounded k, Ord k) => RingMap k a -> [(k, a)]
 rMapToListWithKeys = Map.foldrWithKey (\k v acc ->
     maybe acc (\val -> (k, val):acc) $ extractRingEntry v
@@ -211,6 +230,13 @@ rMapToListWithKeys = Map.foldrWithKey (\k v acc ->
 rMapFromList :: (Bounded k, Ord k) => [(k, a)] -> RingMap k a
 rMapFromList = setRMapEntries
 
+
+-- | this just merges the underlying 'Map.Map' s and does not check whether the
+-- ProxyEntry pointers are consistent, so better only create unions of
+-- equal-pointered RingMaps
+unionRMap :: (Bounded k, Ord k) => RingMap k a -> RingMap k a -> RingMap k a
+unionRMap a b = RingMap $ Map.union (getRingMap a) (getRingMap b)
+
 -- | takes up to i entries from a 'RingMap' by calling a getter function on a
 -- *startAt* value and after that on the previously returned value.
 -- Stops once i entries have been taken or an entry has been encountered twice

test/FediChordSpec.hs

@@ -19,6 +19,7 @@ import           Hash2Pub.ASN1Coding
 import           Hash2Pub.DHTProtocol
 import           Hash2Pub.FediChord
 import           Hash2Pub.FediChordTypes
+import           Hash2Pub.RingMap
 
 spec :: Spec
 spec = do
@@ -304,7 +305,7 @@ exampleNodeState = RemoteNodeState {
 exampleLocalNode :: IO (LocalNodeState MockService)
 exampleLocalNode = do
     realNodeSTM <- newTVarIO $ RealNode {
-            vservers = HMap.empty
+            vservers = emptyRMap
           , nodeConfig = exampleFediConf
           , bootstrapNodes = confBootstrapNodes exampleFediConf
           , nodeService = MockService