From ddea599022ae290eb7070b4ac24e3ac084b4c22a Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 18 Sep 2020 01:01:40 +0200 Subject: [PATCH 01/38] extend ASN.1 schema for requesting load information contributes to #71 --- FediChord.asn1 | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) diff --git a/FediChord.asn1 b/FediChord.asn1 index 79b894a..eb31730 100644 --- a/FediChord.asn1 +++ b/FediChord.asn1 @@ -6,7 +6,7 @@ Domain ::= VisibleString Partnum ::= INTEGER (0..150) -Action ::= ENUMERATED {queryID, join, leave, stabilise, ping} +Action ::= ENUMERATED {queryID, join, leave, stabilise, ping, queryLoad} Request ::= SEQUENCE { action Action, @@ -17,9 +17,10 @@ Request ::= SEQUENCE { actionPayload CHOICE { queryIDRequestPayload QueryIDRequestPayload, joinRequestPayload JoinRequestPayload, - leaveRequestPayload LeaveRequestPayload, - stabiliseRequestPayload StabiliseRequestPayload, - pingRequestPayload PingRequestPayload + leaveRequestPayload LeaveRequestPayload, + stabiliseRequestPayload StabiliseRequestPayload, + pingRequestPayload PingRequestPayload, + loadRequestPayload LoadRequestPayload } OPTIONAL -- just for symmetry reasons with response, requests without a payload have no meaning } @@ -34,11 +35,12 @@ Response ::= SEQUENCE { finalPart BOOLEAN, -- flag indicating this `part` to be the last of this response action Action, actionPayload CHOICE { - queryIDResponsePayload QueryIDResponsePayload, - joinResponsePayload JoinResponsePayload, + queryIDResponsePayload QueryIDResponsePayload, + joinResponsePayload JoinResponsePayload, leaveResponsePayload LeaveResponsePayload, stabiliseResponsePayload StabiliseResponsePayload, - pingResponsePayload PingResponsePayload + pingResponsePayload PingResponsePayload, + loadResponsePayload LoadResponsePayload } OPTIONAL -- no payload when just ACKing a previous request } @@ -101,5 +103,14 @@ PingRequestPayload ::= NULL -- do not include a node/ vserver ID, so that -- learning all active vserver IDs handled by the server at once PingResponsePayload ::= SEQUENCE OF NodeState +LoadRequestPayload ::= SEQUENCE { + lowerBound NodeID, + upperBound NodeID + } + +LoadResponsePayload ::= SEQUENCE { + loadSum REAL, + remainingLoadTarget REAL + } END From 41aaa8ff7018b30062425ce7cb4e24e0715c872b Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 18 Sep 2020 01:33:31 +0200 Subject: [PATCH 02/38] parse ASN.1 representation of load querying includes tests contributes to #71 --- src/Hash2Pub/ASN1Coding.hs | 40 +++++++++++++++++++++++++++++++++++ src/Hash2Pub/ProtocolTypes.hs | 9 ++++++++ test/FediChordSpec.hs | 10 +++++++++ 3 files changed, 59 insertions(+) diff --git a/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs index 10177ab..6080ff3 100644 --- a/src/Hash2Pub/ASN1Coding.hs +++ b/src/Hash2Pub/ASN1Coding.hs @@ -184,6 +184,18 @@ encodePayload payload'@PingResponsePayload{} = Start Sequence : concatMap encodeNodeState (pingNodeStates payload') <> [End Sequence] +encodePayload payload'@LoadRequestPayload{} = + [ Start Sequence + , IntVal . getNodeID $ loadLowerBound payload' + , IntVal . getNodeID $ loadUpperBound payload' + , End Sequence + ] +encodePayload payload'@LoadResponsePayload{} = + [ Start Sequence + , Real $ loadSum payload' + , Real $ loadRemainingTarget payload' + , End Sequence + ] encodeNodeState :: NodeState a => a -> [ASN1] encodeNodeState ns = [ @@ -272,6 +284,7 @@ parseRequest action = do Leave -> parseLeaveRequest Stabilise -> parseStabiliseRequest Ping -> parsePingRequest + QueryLoad -> parseLoadRequestPayload pure $ Request requestID sender part isFinalPart action payload @@ -288,6 +301,7 @@ parseResponse requestID = do Leave -> parseLeaveResponse Stabilise -> parseStabiliseResponse Ping -> parsePingResponse + QueryLoad -> parseLoadResponsePayload pure $ Response requestID senderID part isFinalPart action payload @@ -305,6 +319,13 @@ parseInteger = do IntVal parsed -> pure parsed x -> throwParseError $ "Expected IntVal but got " <> show x +parseReal :: ParseASN1 Double +parseReal = do + i <- getNext + case i of + Real parsed -> pure parsed + x -> throwParseError $ "Expected Real but got " <> show x + parseEnum :: Enum a => ParseASN1 a parseEnum = do e <- getNext @@ -437,3 +458,22 @@ parsePingResponse = onNextContainer Sequence $ do pure $ PingResponsePayload { pingNodeStates = handledNodes } + +parseLoadRequestPayload :: ParseASN1 ActionPayload +parseLoadRequestPayload = onNextContainer Sequence $ do + loadLowerBound' <- fromInteger <$> parseInteger + loadUpperBound' <- fromInteger <$> parseInteger + pure LoadRequestPayload + { loadLowerBound = loadLowerBound' + , loadUpperBound = loadUpperBound' + } + +parseLoadResponsePayload :: ParseASN1 ActionPayload +parseLoadResponsePayload = onNextContainer Sequence $ do + loadSum' <- parseReal + loadRemainingTarget' <- parseReal + pure LoadResponsePayload + { loadSum = loadSum' + , loadRemainingTarget = loadRemainingTarget' + } + diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index a5af10c..e7f1e3c 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -16,6 +16,7 @@ data Action = QueryID | Leave | Stabilise | Ping + | QueryLoad deriving (Show, Eq, Enum) data FediChordMessage = Request @@ -73,6 +74,14 @@ data ActionPayload = QueryIDRequestPayload | PingResponsePayload { pingNodeStates :: [RemoteNodeState] } + | LoadRequestPayload + { loadLowerBound :: NodeID + , loadUpperBound :: NodeID + } + | LoadResponsePayload + { loadSum :: Double + , loadRemainingTarget :: Double + } deriving (Show, Eq) -- | global limit of parts per message used when (de)serialising messages. diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index 6a3ca5d..8756b69 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -221,6 +221,14 @@ spec = do , exampleNodeState {nid = fromInteger (-5)} ] } + qLoadReqPayload = LoadRequestPayload + { loadLowerBound = fromInteger 12 + , loadUpperBound = fromInteger 1025 + } + qLoadResPayload = LoadResponsePayload + { loadSum = 3.141 + , loadRemainingTarget = -1.337 + } requestTemplate = Request { requestID = 2342 , sender = exampleNodeState @@ -259,6 +267,8 @@ spec = do encodeDecodeAndCheck $ responseWith Leave lResPayload encodeDecodeAndCheck $ responseWith Stabilise stabResPayload encodeDecodeAndCheck $ responseWith Ping pingResPayload + encodeDecodeAndCheck $ requestWith QueryLoad qLoadReqPayload + encodeDecodeAndCheck $ responseWith QueryLoad qLoadResPayload it "messages are encoded and decoded to ASN.1 DER properly" $ deserialiseMessage (fromJust $ Map.lookup 1 (serialiseMessage 652 $ responseWith Ping pingResPayload)) `shouldBe` Right (responseWith Ping pingResPayload) it "messages too large for a single packet can (often) be split into multiple parts" $ do From af27cded195b0350ca5984a3a51177f9d4126025 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 18 Sep 2020 01:36:02 +0200 Subject: [PATCH 03/38] adjust payload parser naming for consistency and clarity --- src/Hash2Pub/ASN1Coding.hs | 60 +++++++++++++++++++------------------- 1 file changed, 30 insertions(+), 30 deletions(-) diff --git a/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs index 6080ff3..e29863e 100644 --- a/src/Hash2Pub/ASN1Coding.hs +++ b/src/Hash2Pub/ASN1Coding.hs @@ -279,11 +279,11 @@ parseRequest action = do isFinalPart <- parseBool hasPayload <- hasNext payload <- if not hasPayload then pure Nothing else Just <$> case action of - QueryID -> parseQueryIDRequest - Join -> parseJoinRequest - Leave -> parseLeaveRequest - Stabilise -> parseStabiliseRequest - Ping -> parsePingRequest + QueryID -> parseQueryIDRequestPayload + Join -> parseJoinRequestPayload + Leave -> parseLeaveRequestPayload + Stabilise -> parseStabiliseRequestPayload + Ping -> parsePingRequestPayload QueryLoad -> parseLoadRequestPayload pure $ Request requestID sender part isFinalPart action payload @@ -296,11 +296,11 @@ parseResponse requestID = do action <- parseEnum :: ParseASN1 Action hasPayload <- hasNext payload <- if not hasPayload then pure Nothing else Just <$> case action of - QueryID -> parseQueryIDResponse - Join -> parseJoinResponse - Leave -> parseLeaveResponse - Stabilise -> parseStabiliseResponse - Ping -> parsePingResponse + QueryID -> parseQueryIDResponsePayload + Join -> parseJoinResponsePayload + Leave -> parseLeaveResponsePayload + Stabilise -> parseStabiliseResponsePayload + Ping -> parsePingResponsePayload QueryLoad -> parseLoadResponsePayload pure $ Response requestID senderID part isFinalPart action payload @@ -381,13 +381,13 @@ parseCacheEntry = onNextContainer Sequence $ do parseNodeCache :: ParseASN1 [RemoteCacheEntry] parseNodeCache = onNextContainer Sequence $ getMany parseCacheEntry -parseJoinRequest :: ParseASN1 ActionPayload -parseJoinRequest = do +parseJoinRequestPayload :: ParseASN1 ActionPayload +parseJoinRequestPayload = do parseNull pure JoinRequestPayload -parseJoinResponse :: ParseASN1 ActionPayload -parseJoinResponse = onNextContainer Sequence $ do +parseJoinResponsePayload :: ParseASN1 ActionPayload +parseJoinResponsePayload = onNextContainer Sequence $ do succ' <- onNextContainer Sequence (getMany parseNodeState) pred' <- onNextContainer Sequence (getMany parseNodeState) cache <- parseNodeCache @@ -397,8 +397,8 @@ parseJoinResponse = onNextContainer Sequence $ do , joinCache = cache } -parseQueryIDRequest :: ParseASN1 ActionPayload -parseQueryIDRequest = onNextContainer Sequence $ do +parseQueryIDRequestPayload :: ParseASN1 ActionPayload +parseQueryIDRequestPayload = onNextContainer Sequence $ do targetID <- fromInteger <$> parseInteger lBestNodes <- parseInteger pure $ QueryIDRequestPayload { @@ -406,8 +406,8 @@ parseQueryIDRequest = onNextContainer Sequence $ do , queryLBestNodes = lBestNodes } -parseQueryIDResponse :: ParseASN1 ActionPayload -parseQueryIDResponse = onNextContainer Sequence $ do +parseQueryIDResponsePayload :: ParseASN1 ActionPayload +parseQueryIDResponsePayload = onNextContainer Sequence $ do Enumerated resultType <- getNext result <- case resultType of 0 -> FOUND <$> parseNodeState @@ -417,13 +417,13 @@ parseQueryIDResponse = onNextContainer Sequence $ do queryResult = result } -parseStabiliseRequest :: ParseASN1 ActionPayload -parseStabiliseRequest = do +parseStabiliseRequestPayload :: ParseASN1 ActionPayload +parseStabiliseRequestPayload = do parseNull pure StabiliseRequestPayload -parseStabiliseResponse :: ParseASN1 ActionPayload -parseStabiliseResponse = onNextContainer Sequence $ do +parseStabiliseResponsePayload :: ParseASN1 ActionPayload +parseStabiliseResponsePayload = onNextContainer Sequence $ do succ' <- onNextContainer Sequence (getMany parseNodeState) pred' <- onNextContainer Sequence (getMany parseNodeState) pure $ StabiliseResponsePayload { @@ -431,8 +431,8 @@ parseStabiliseResponse = onNextContainer Sequence $ do , stabilisePredecessors = pred' } -parseLeaveRequest :: ParseASN1 ActionPayload -parseLeaveRequest = onNextContainer Sequence $ do +parseLeaveRequestPayload :: ParseASN1 ActionPayload +parseLeaveRequestPayload = onNextContainer Sequence $ do succ' <- onNextContainer Sequence (getMany parseNodeState) pred' <- onNextContainer Sequence (getMany parseNodeState) doMigration <- parseBool @@ -442,18 +442,18 @@ parseLeaveRequest = onNextContainer Sequence $ do , leaveDoMigration = doMigration } -parseLeaveResponse :: ParseASN1 ActionPayload -parseLeaveResponse = do +parseLeaveResponsePayload :: ParseASN1 ActionPayload +parseLeaveResponsePayload = do parseNull pure LeaveResponsePayload -parsePingRequest :: ParseASN1 ActionPayload -parsePingRequest = do +parsePingRequestPayload :: ParseASN1 ActionPayload +parsePingRequestPayload = do parseNull pure PingRequestPayload -parsePingResponse :: ParseASN1 ActionPayload -parsePingResponse = onNextContainer Sequence $ do +parsePingResponsePayload :: ParseASN1 ActionPayload +parsePingResponsePayload = onNextContainer Sequence $ do handledNodes <- getMany parseNodeState pure $ PingResponsePayload { pingNodeStates = handledNodes From a1cfbbac4860ab78f31ddf390839319d121eaa9a Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 18 Sep 2020 20:25:15 +0200 Subject: [PATCH 04/38] bump nixpkgs revision --- default.nix | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/default.nix b/default.nix index cea4aa3..c6ef23a 100644 --- a/default.nix +++ b/default.nix @@ -14,7 +14,8 @@ let name = "nixpkgs-pinned"; url = https://github.com/NixOS/nixpkgs/; ref = "refs/heads/release-20.03"; - rev = "de3780b937d2984f9b5e20d191f23be4f857b3aa"; + #rev = "de3780b937d2984f9b5e20d191f23be4f857b3aa"; + rev = "faf5bdea5d9f0f9de26deaa7e864cdcd3b15b4e8"; }) { # Pass no config for purity config = {}; From 7dd7e96cce9915ad82985a4ee0711d2dc695c610 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 18 Sep 2020 20:26:20 +0200 Subject: [PATCH 05/38] conversion of RingMap to key-value list --- src/Hash2Pub/RingMap.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Hash2Pub/RingMap.hs b/src/Hash2Pub/RingMap.hs index a2fe3ae..a083b59 100644 --- a/src/Hash2Pub/RingMap.hs +++ b/src/Hash2Pub/RingMap.hs @@ -201,6 +201,13 @@ deleteRMapEntry nid = RingMap . Map.update modifier nid . getRingMap rMapToList :: (Bounded k, Ord k) => RingMap k a -> [a] rMapToList = mapMaybe extractRingEntry . Map.elems . getRingMap +rMapToListWithKeys :: (Bounded k, Ord k) => RingMap k a -> [(k, a)] +rMapToListWithKeys = Map.foldrWithKey (\k v acc -> + maybe acc (\val -> (k, val):acc) $ extractRingEntry v + ) + [] + . getRingMap + rMapFromList :: (Bounded k, Ord k) => [(k, a)] -> RingMap k a rMapFromList = setRMapEntries From 576ea2c3f6cba1a2b0a97e17929a681e8483d47c Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 18 Sep 2020 20:26:50 +0200 Subject: [PATCH 06/38] calculate service load rates, interface for querying loads - define data type for load representation - this representation can be queried from any Service (closes #72) - loads are periodically calculated from measured rates (contributes to #2) --- src/Hash2Pub/FediChordTypes.hs | 26 +++++++++++++++-- src/Hash2Pub/PostService.hs | 51 ++++++++++++++++++++++++++++++---- 2 files changed, 69 insertions(+), 8 deletions(-) diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 4ce20a7..af3d285 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -7,8 +7,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -module Hash2Pub.FediChordTypes ( - NodeID -- abstract, but newtype constructors cannot be hidden +module Hash2Pub.FediChordTypes + ( NodeID -- abstract, but newtype constructors cannot be hidden , idBits , getNodeID , toNodeID @@ -18,6 +18,8 @@ module Hash2Pub.FediChordTypes ( , RemoteNodeState (..) , RealNode (..) , RealNodeSTM + , LoadStats (..) + , emptyLoadStats , setSuccessors , setPredecessors , NodeCache @@ -60,7 +62,7 @@ module Hash2Pub.FediChordTypes ( , DHT(..) , Service(..) , ServiceConf(..) - ) where + ) where import Control.Exception import Data.Foldable (foldr') @@ -430,6 +432,23 @@ data FediChordConf = FediChordConf } deriving (Show, Eq) +-- ====== k-choices load balancing types ====== + +data LoadStats = LoadStats + { loadPerTag :: RingMap NodeID Double + , totalCapacity :: Double + , remainingLoadTarget :: Double + } + deriving (Show, Eq) + +-- TODO: figure out a better way of initialising +emptyLoadStats :: LoadStats +emptyLoadStats = LoadStats + { loadPerTag = emptyRMap + , totalCapacity = 0 + , remainingLoadTarget = 0 + } + -- ====== Service Types ============ class Service s d where @@ -445,6 +464,7 @@ class Service s d where -> IO (Either String ()) -- ^ success or failure -- | Wait for an incoming migration from a given node to succeed, may block forever waitForMigrationFrom :: s d -> NodeID -> IO () + getServiceLoadStats :: s d -> IO LoadStats instance Hashable.Hashable NodeID where hashWithSalt salt = Hashable.hashWithSalt salt . getNodeID diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs index ffeef17..a02d1d7 100644 --- a/src/Hash2Pub/PostService.hs +++ b/src/Hash2Pub/PostService.hs @@ -22,7 +22,7 @@ import qualified Data.DList as D import Data.Either (lefts, rights) import qualified Data.HashMap.Strict as HMap import qualified Data.HashSet as HSet -import Data.Maybe (fromJust, isJust) +import Data.Maybe (fromJust, fromMaybe, isJust) import Data.String (fromString) import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as Txt @@ -64,8 +64,10 @@ data PostService d = PostService , migrationsInProgress :: TVar (HMap.HashMap NodeID (MVar ())) , httpMan :: HTTP.Manager , statsQueue :: TQueue StatsEvent - , loadStats :: TVar RelayStats - -- ^ current load stats, replaced periodically + , relayStats :: TVar RelayStats + -- ^ current relay stats, replaced periodically + , loadStats :: TVar LoadStats + -- ^ current load values of the relay, replaced periodically and used by , logFileHandle :: Handle } deriving (Typeable) @@ -96,7 +98,8 @@ instance DHT d => Service PostService d where migrationsInProgress' <- newTVarIO HMap.empty httpMan' <- HTTP.newManager HTTP.defaultManagerSettings statsQueue' <- newTQueueIO - loadStats' <- newTVarIO emptyStats + relayStats' <- newTVarIO emptyStats + loadStats' <- newTVarIO emptyLoadStats loggingFile <- openFile (confLogfilePath conf) WriteMode hSetBuffering loggingFile LineBuffering let @@ -112,6 +115,7 @@ instance DHT d => Service PostService d where , migrationsInProgress = migrationsInProgress' , httpMan = httpMan' , statsQueue = statsQueue' + , relayStats = relayStats' , loadStats = loadStats' , logFileHandle = loggingFile } @@ -153,6 +157,12 @@ instance DHT d => Service PostService d where -- block until migration finished takeMVar migrationSynchroniser + getServiceLoadStats = getLoadStats + + +getLoadStats :: PostService d -> IO LoadStats +getLoadStats serv = readTVarIO $ loadStats serv + -- | return a WAI application postServiceApplication :: DHT d => PostService d -> Application @@ -835,7 +845,12 @@ evaluateStatsThread serv statsAcc = getPOSIXTime >>= loop -- persistently store in a TVar so it can be retrieved later by the DHT let timePassed = (now - previousTs) * fromIntegral (confSpeedupFactor $ serviceConf serv) rateStats = evaluateStats timePassed summedStats - atomically $ writeTVar (loadStats serv) rateStats + currentSubscribers <- readTVarIO $ subscribers serv + -- translate the rate statistics to load values + loads <- evaluateLoadStats rateStats currentSubscribers + atomically $ + writeTVar (relayStats serv) rateStats + >> writeTVar (loadStats serv) loads -- and now what? write a log to file -- format: total relayReceiveRates;total relayDeliveryRates;postFetchRate;postPublishRate; subscriberSum -- later: current (reported) load, target load @@ -859,6 +874,32 @@ evaluateStatsThread serv statsAcc = getPOSIXTime >>= loop 0 tagMap +-- | calculate load values from rate statistics +evaluateLoadStats :: RelayStats -> RelayTags -> IO LoadStats +evaluateLoadStats currentStats currentSubscribers = do + -- load caused by each tag: incomingPostRate * ( 1 + subscribers) + -- calculate remaining load target: post publish rate * 2.5 - sum loadPerTag - postFetchRate + let + totalCapacity' = 2.5 * postPublishRate currentStats + (loadSum, loadPerTag') <- foldM (\(loadSum, loadPerTag') (key, (subscriberMapSTM, _, _)) -> do + numSubscribers <- HMap.size <$> readTVarIO subscriberMapSTM + let + thisTagRate = fromMaybe 0 $ rMapLookup key (relayReceiveRates currentStats) + thisTagLoad = thisTagRate * (1 + fromIntegral numSubscribers) + pure (loadSum + thisTagLoad, addRMapEntry key thisTagLoad loadPerTag') + ) + (0, emptyRMap) + $ rMapToListWithKeys currentSubscribers + -- TODO: use underload and overload limits instead of capacity + let remainingLoadTarget' = totalCapacity' - loadSum - postFetchRate currentStats + pure LoadStats + { loadPerTag = loadPerTag' + , totalCapacity = totalCapacity' + , remainingLoadTarget = remainingLoadTarget' + } + + + -- | Evaluate the accumulated statistic events: Currently mostly calculates the event -- rates by dividing through the collection time frame evaluateStats :: POSIXTime -> RelayStats -> RelayStats From 30bf0529ed2d972fc0aa672bfa9dde874bbf06ff Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 19 Sep 2020 01:58:25 +0200 Subject: [PATCH 07/38] send load query request, parse result and represent it - sending side of #71 - introduces SegmentLoadStats to hold the response data - contributes to #2 --- src/Hash2Pub/DHTProtocol.hs | 52 +++++++++++++++++++++++++++++++++- src/Hash2Pub/FediChordTypes.hs | 15 ++++++++++ 2 files changed, 66 insertions(+), 1 deletion(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index c86c0f1..37a1dea 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -22,6 +22,7 @@ module Hash2Pub.DHTProtocol , requestLeave , requestPing , requestStabilise + , requestQueryLoad , lookupMessage , sendRequestTo , queryIdLookupLoop @@ -49,7 +50,8 @@ import Control.Concurrent.STM.TQueue import Control.Concurrent.STM.TVar import Control.Exception import Control.Monad (foldM, forM, forM_, void, when) -import Control.Monad.Except (MonadError (..), runExceptT) +import Control.Monad.Except (MonadError (..), liftEither, + runExceptT) import Control.Monad.IO.Class (MonadIO (..)) import qualified Data.ByteString as BS import Data.Either (rights) @@ -81,6 +83,7 @@ import Hash2Pub.FediChordTypes (CacheEntry (..), RealNode (..), RealNodeSTM, RemoteNodeState (..), RingEntry (..), RingMap (..), + SegmentLoadStats (..), Service (..), addRMapEntry, addRMapEntryWith, cacheGetNodeStateUnvalidated, @@ -744,6 +747,53 @@ requestPing ns target = do ) responses +-- still need a particular vserver as LocalNodeState, because requests need a sender +requestQueryLoad :: (MonadError String m, MonadIO m) + => LocalNodeState s + -> NodeID + -> NodeID + -> RemoteNodeState + -> m SegmentLoadStats +requestQueryLoad ns lowerIdBound upperIdBound target = do + nodeConf <- nodeConfig <$> liftIO (readTVarIO $ parentRealNode ns) + let + srcAddr = confIP nodeConf + loadPl = LoadRequestPayload + { loadLowerBound = lowerIdBound + , loadUpperBound = upperIdBound + } + responses <- liftIO $ bracket (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) close + (fmap Right . sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (\rid -> + Request { + requestID = rid + , sender = toRemoteNodeState ns + , part = 1 + , isFinalPart = False + , action = QueryLoad + , payload = Just loadPl + } + ) + ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) + responseMsgSet <- liftEither responses + -- throws an error if an exception happened + loadPl <- maybe (throwError "no load response payload found") pure + (foldr' (\msg acc -> case payload msg of + -- just extract the first found LoadResponsePayload + Just pl@LoadResponsePayload{} | isNothing acc -> Just pl + _ -> Nothing + ) + Nothing + responseMsgSet + ) + pure SegmentLoadStats + { segmentLowerKeyBound = lowerIdBound + , segmentUpperKeyBound = upperIdBound + , segmentLoad = loadSum loadPl + , segmentOwnerLoadTarget = loadRemainingTarget loadPl + } + + + -- | Generic function for sending a request over a connected socket and collecting the response. -- Serialises the message and tries to deliver its parts for a number of attempts within a specified timeout. sendRequestTo :: Int -- ^ timeout in milliseconds diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index af3d285..d8bbe4c 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -20,6 +20,7 @@ module Hash2Pub.FediChordTypes , RealNodeSTM , LoadStats (..) , emptyLoadStats + , SegmentLoadStats (..) , setSuccessors , setPredecessors , NodeCache @@ -436,11 +437,25 @@ data FediChordConf = FediChordConf data LoadStats = LoadStats { loadPerTag :: RingMap NodeID Double + -- ^ map of loads for each handled tag , totalCapacity :: Double + -- ^ total designated capacity of the service , remainingLoadTarget :: Double + -- ^ current mismatch between actual load and target load/capacity } deriving (Show, Eq) +data SegmentLoadStats = SegmentLoadStats + { segmentLowerKeyBound :: NodeID + -- ^ segment start key + , segmentUpperKeyBound :: NodeID + -- ^ segment end key + , segmentLoad :: Double + -- ^ sum of load of all keys in the segment + , segmentOwnerLoadTarget :: Double + -- ^ remaining load target of the current segment handler + } + -- TODO: figure out a better way of initialising emptyLoadStats :: LoadStats emptyLoadStats = LoadStats From 5e745cd03526dec098d5edcdf0b06aaf8e830c15 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 19 Sep 2020 14:46:41 +0200 Subject: [PATCH 08/38] only specify upper key bound when querying load MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit As a querying node does not always know the lower bound of the queried segment – determined by the predecessor – let the currently responsible node provide that bound instead. affects #71 --- FediChord.asn1 | 6 +++--- src/Hash2Pub/ASN1Coding.hs | 10 +++++----- src/Hash2Pub/DHTProtocol.hs | 18 ++++++++---------- src/Hash2Pub/ProtocolTypes.hs | 13 +++++++------ test/FediChordSpec.hs | 4 ++-- 5 files changed, 25 insertions(+), 26 deletions(-) diff --git a/FediChord.asn1 b/FediChord.asn1 index eb31730..ce5ea9e 100644 --- a/FediChord.asn1 +++ b/FediChord.asn1 @@ -104,13 +104,13 @@ PingRequestPayload ::= NULL -- do not include a node/ vserver ID, so that PingResponsePayload ::= SEQUENCE OF NodeState LoadRequestPayload ::= SEQUENCE { - lowerBound NodeID, - upperBound NodeID + upperSegmentBound NodeID } LoadResponsePayload ::= SEQUENCE { loadSum REAL, - remainingLoadTarget REAL + remainingLoadTarget REAL, + lowerBound NodeID } END diff --git a/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs index e29863e..e5efdad 100644 --- a/src/Hash2Pub/ASN1Coding.hs +++ b/src/Hash2Pub/ASN1Coding.hs @@ -186,14 +186,14 @@ encodePayload payload'@PingResponsePayload{} = <> [End Sequence] encodePayload payload'@LoadRequestPayload{} = [ Start Sequence - , IntVal . getNodeID $ loadLowerBound payload' - , IntVal . getNodeID $ loadUpperBound payload' + , IntVal . getNodeID $ loadSegmentUpperBound payload' , End Sequence ] encodePayload payload'@LoadResponsePayload{} = [ Start Sequence , Real $ loadSum payload' , Real $ loadRemainingTarget payload' + , IntVal . getNodeID $ loadSegmentLowerBound payload' , End Sequence ] @@ -461,19 +461,19 @@ parsePingResponsePayload = onNextContainer Sequence $ do parseLoadRequestPayload :: ParseASN1 ActionPayload parseLoadRequestPayload = onNextContainer Sequence $ do - loadLowerBound' <- fromInteger <$> parseInteger loadUpperBound' <- fromInteger <$> parseInteger pure LoadRequestPayload - { loadLowerBound = loadLowerBound' - , loadUpperBound = loadUpperBound' + { loadSegmentUpperBound = loadUpperBound' } parseLoadResponsePayload :: ParseASN1 ActionPayload parseLoadResponsePayload = onNextContainer Sequence $ do loadSum' <- parseReal loadRemainingTarget' <- parseReal + loadSegmentLowerBound' <- fromInteger <$> parseInteger pure LoadResponsePayload { loadSum = loadSum' , loadRemainingTarget = loadRemainingTarget' + , loadSegmentLowerBound = loadSegmentLowerBound' } diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 37a1dea..0b3e7ae 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -751,16 +751,14 @@ requestPing ns target = do requestQueryLoad :: (MonadError String m, MonadIO m) => LocalNodeState s -> NodeID - -> NodeID -> RemoteNodeState -> m SegmentLoadStats -requestQueryLoad ns lowerIdBound upperIdBound target = do +requestQueryLoad ns upperIdBound target = do nodeConf <- nodeConfig <$> liftIO (readTVarIO $ parentRealNode ns) let srcAddr = confIP nodeConf - loadPl = LoadRequestPayload - { loadLowerBound = lowerIdBound - , loadUpperBound = upperIdBound + loadReqPl = LoadRequestPayload + { loadSegmentUpperBound = upperIdBound } responses <- liftIO $ bracket (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) close (fmap Right . sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (\rid -> @@ -770,13 +768,13 @@ requestQueryLoad ns lowerIdBound upperIdBound target = do , part = 1 , isFinalPart = False , action = QueryLoad - , payload = Just loadPl + , payload = Just loadReqPl } ) ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) responseMsgSet <- liftEither responses -- throws an error if an exception happened - loadPl <- maybe (throwError "no load response payload found") pure + loadResPl <- maybe (throwError "no load response payload found") pure (foldr' (\msg acc -> case payload msg of -- just extract the first found LoadResponsePayload Just pl@LoadResponsePayload{} | isNothing acc -> Just pl @@ -786,10 +784,10 @@ requestQueryLoad ns lowerIdBound upperIdBound target = do responseMsgSet ) pure SegmentLoadStats - { segmentLowerKeyBound = lowerIdBound + { segmentLowerKeyBound = loadSegmentLowerBound loadResPl , segmentUpperKeyBound = upperIdBound - , segmentLoad = loadSum loadPl - , segmentOwnerLoadTarget = loadRemainingTarget loadPl + , segmentLoad = loadSum loadResPl + , segmentOwnerLoadTarget = loadRemainingTarget loadResPl } diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index e7f1e3c..03a2d19 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -58,6 +58,10 @@ data ActionPayload = QueryIDRequestPayload } | StabiliseRequestPayload | PingRequestPayload + | LoadRequestPayload + { loadSegmentUpperBound :: NodeID + -- ^ upper bound of segment interested in, + } | QueryIDResponsePayload { queryResult :: QueryResponse } @@ -74,13 +78,10 @@ data ActionPayload = QueryIDRequestPayload | PingResponsePayload { pingNodeStates :: [RemoteNodeState] } - | LoadRequestPayload - { loadLowerBound :: NodeID - , loadUpperBound :: NodeID - } | LoadResponsePayload - { loadSum :: Double - , loadRemainingTarget :: Double + { loadSum :: Double + , loadRemainingTarget :: Double + , loadSegmentLowerBound :: NodeID } deriving (Show, Eq) diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index 8756b69..8983ca4 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -222,12 +222,12 @@ spec = do ] } qLoadReqPayload = LoadRequestPayload - { loadLowerBound = fromInteger 12 - , loadUpperBound = fromInteger 1025 + { loadSegmentUpperBound = 1025 } qLoadResPayload = LoadResponsePayload { loadSum = 3.141 , loadRemainingTarget = -1.337 + , loadSegmentLowerBound = 12 } requestTemplate = Request { requestID = 2342 From 9bf7365a2c4864b5bc8888652cdc8e2e71f2a48d Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 19 Sep 2020 20:41:58 +0200 Subject: [PATCH 09/38] include target ID in request to address individual vserver - necessary for dispatching the request to a certain vserver - also refactored request sending to use a common `mkRequest` - contributes to #2 --- FediChord.asn1 | 1 + src/Hash2Pub/ASN1Coding.hs | 6 ++- src/Hash2Pub/DHTProtocol.hs | 70 ++++++++++++++--------------------- src/Hash2Pub/ProtocolTypes.hs | 1 + test/FediChordSpec.hs | 24 +++++------- 5 files changed, 42 insertions(+), 60 deletions(-) diff --git a/FediChord.asn1 b/FediChord.asn1 index ce5ea9e..f978151 100644 --- a/FediChord.asn1 +++ b/FediChord.asn1 @@ -11,6 +11,7 @@ Action ::= ENUMERATED {queryID, join, leave, stabilise, ping, queryLoad} Request ::= SEQUENCE { action Action, requestID INTEGER (0..4294967295), -- arbitrarily restricting to an unsigned 32bit integer + receiverID NodeID, sender NodeState, part Partnum, -- part number of this message, starts at 1 finalPart BOOLEAN, -- flag indicating this `part` to be the last of this reuest diff --git a/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs index e5efdad..7701097 100644 --- a/src/Hash2Pub/ASN1Coding.hs +++ b/src/Hash2Pub/ASN1Coding.hs @@ -227,10 +227,11 @@ encodeQueryResult FORWARD{} = Enumerated 1 encodeMessage :: FediChordMessage -- ^ the 'FediChordMessage to be encoded -> [ASN1] encodeMessage - (Request requestID sender part isFinalPart action requestPayload) = + (Request requestID receiverID sender part isFinalPart action requestPayload) = Start Sequence : (Enumerated . fromIntegral . fromEnum $ action) : IntVal requestID + : (IntVal . getNodeID $ receiverID) : encodeNodeState sender <> [IntVal part , Boolean isFinalPart] @@ -274,6 +275,7 @@ parseMessage = do parseRequest :: Action -> ParseASN1 FediChordMessage parseRequest action = do requestID <- parseInteger + receiverID' <- fromInteger <$> parseInteger sender <- parseNodeState part <- parseInteger isFinalPart <- parseBool @@ -286,7 +288,7 @@ parseRequest action = do Ping -> parsePingRequestPayload QueryLoad -> parseLoadRequestPayload - pure $ Request requestID sender part isFinalPart action payload + pure $ Request requestID receiverID' sender part isFinalPart action payload parseResponse :: Integer -> ParseASN1 FediChordMessage parseResponse requestID = do diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 0b3e7ae..38c0dcb 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -15,6 +15,7 @@ module Hash2Pub.DHTProtocol , Action(..) , ActionPayload(..) , FediChordMessage(..) + , mkRequest , maximumParts , sendQueryIdMessages , requestQueryID @@ -484,6 +485,21 @@ respondJoin nsSTM msgSet = do -- ....... request sending ....... +-- | defautl constructor for request messages, fills standard values like +-- part number to avoid code repition +mkRequest :: LocalNodeState s -> NodeID -> Action -> Maybe ActionPayload -> (Integer -> FediChordMessage) +mkRequest ns targetID action pl rid = Request + { requestID = rid + , receiverID = targetID + , sender = toRemoteNodeState ns + -- part number and final flag can be changed by ASN1 encoder to make packet + -- fit the MTU restrictions + , part = 1 + , isFinalPart = True + , action = action + , payload = pl + } + -- | send a join request and return the joined 'LocalNodeState' including neighbours requestJoin :: (NodeState a, Service s (RealNodeSTM s)) => a -- ^ currently responsible node to be contacted -> LocalNodeStateSTM s -- ^ joining NodeState @@ -495,7 +511,7 @@ requestJoin toJoinOn ownStateSTM = do let srcAddr = confIP nodeConf bracket (mkSendSocket srcAddr (getDomain toJoinOn) (getDhtPort toJoinOn)) close (\sock -> do -- extract own state for getting request information - responses <- sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (\rid -> Request rid (toRemoteNodeState ownState) 1 True Join (Just JoinRequestPayload)) sock + responses <- sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (mkRequest ownState (getNid toJoinOn) Join (Just JoinRequestPayload)) sock (cacheInsertQ, joinedState) <- atomically $ do stateSnap <- readTVar ownStateSTM let @@ -628,7 +644,7 @@ lookupMessage :: Integral i -> LocalNodeState s -- ^ sender node state -> Maybe i -- ^ optionally provide a different l parameter -> (Integer -> FediChordMessage) -lookupMessage targetID ns lParam = \rID -> Request rID (toRemoteNodeState ns) 1 True QueryID (Just $ pl ns targetID) +lookupMessage targetID ns lParam = mkRequest ns targetID QueryID (Just $ pl ns targetID) where pl ns' targetID' = QueryIDRequestPayload { queryTargetID = targetID', queryLBestNodes = maybe (fromIntegral $ lNumBestNodes ns) fromIntegral lParam } @@ -641,16 +657,7 @@ requestStabilise :: LocalNodeState s -- ^ sending node requestStabilise ns neighbour = do nodeConf <- nodeConfig <$> readTVarIO (parentRealNode ns) let srcAddr = confIP nodeConf - responses <- bracket (mkSendSocket srcAddr (getDomain neighbour) (getDhtPort neighbour)) close (fmap Right . sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (\rid -> - Request { - requestID = rid - , sender = toRemoteNodeState ns - , part = 1 - , isFinalPart = False - , action = Stabilise - , payload = Just StabiliseRequestPayload - } - ) + responses <- bracket (mkSendSocket srcAddr (getDomain neighbour) (getDhtPort neighbour)) close (fmap Right . sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (mkRequest ns (getNid neighbour) Stabilise (Just StabiliseRequestPayload)) ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) either -- forward IO error messages @@ -685,17 +692,12 @@ requestLeave ns doMigration target = do , leavePredecessors = predecessors ns , leaveDoMigration = doMigration } - responses <- bracket (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) close (fmap Right . sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (\rid -> - Request { - requestID = rid - , sender = toRemoteNodeState ns - , part = 1 - , isFinalPart = False - , action = Leave - , payload = Just leavePayload - } - ) - ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) + responses <- bracket + (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) + close + (fmap Right + . sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (mkRequest ns (getNid target) Leave (Just leavePayload)) + ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) either -- forward IO error messages (pure . Left) @@ -711,16 +713,7 @@ requestPing ns target = do let srcAddr = confIP nodeConf responses <- bracket (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) close (\sock -> do - resp <- sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (\rid -> - Request { - requestID = rid - , sender = toRemoteNodeState ns - , part = 1 - , isFinalPart = False - , action = Ping - , payload = Just PingRequestPayload - } - ) sock + resp <- sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (mkRequest ns (getNid target) Ping (Just PingRequestPayload)) sock (SockAddrInet6 _ _ peerAddr _) <- getPeerName sock pure $ Right (peerAddr, resp) ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) @@ -761,16 +754,7 @@ requestQueryLoad ns upperIdBound target = do { loadSegmentUpperBound = upperIdBound } responses <- liftIO $ bracket (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) close - (fmap Right . sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (\rid -> - Request { - requestID = rid - , sender = toRemoteNodeState ns - , part = 1 - , isFinalPart = False - , action = QueryLoad - , payload = Just loadReqPl - } - ) + (fmap Right . sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (mkRequest ns (getNid target) QueryLoad (Just loadReqPl)) ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) responseMsgSet <- liftEither responses -- throws an error if an exception happened diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index 03a2d19..b5438fa 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -21,6 +21,7 @@ data Action = QueryID data FediChordMessage = Request { requestID :: Integer + , receiverID :: NodeID , sender :: RemoteNodeState , part :: Integer , isFinalPart :: Bool diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index 8983ca4..5130ab1 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -229,14 +229,7 @@ spec = do , loadRemainingTarget = -1.337 , loadSegmentLowerBound = 12 } - requestTemplate = Request { - requestID = 2342 - , sender = exampleNodeState - , part = 1 - , isFinalPart = True - , action = undefined - , payload = undefined - } + responseTemplate = Response { requestID = 2342 , senderID = nid exampleNodeState @@ -245,7 +238,7 @@ spec = do , action = undefined , payload = undefined } - requestWith a pa = requestTemplate {action = a, payload = Just pa} + requestWith senderNode a pa = mkRequest senderNode 4545 a (Just pa) $ 2342 responseWith a pa = responseTemplate {action = a, payload = Just pa} encodeDecodeAndCheck msg = runParseASN1 parseMessage (encodeMessage msg) `shouldBe` pure msg @@ -256,18 +249,19 @@ spec = do } it "messages are encoded and decoded correctly from and to ASN1" $ do - encodeDecodeAndCheck $ requestWith QueryID qidReqPayload - encodeDecodeAndCheck $ requestWith Join jReqPayload - encodeDecodeAndCheck $ requestWith Leave lReqPayload - encodeDecodeAndCheck $ requestWith Stabilise stabReqPayload - encodeDecodeAndCheck $ requestWith Ping pingReqPayload + localNS <- exampleLocalNode + encodeDecodeAndCheck $ requestWith localNS QueryID qidReqPayload + encodeDecodeAndCheck $ requestWith localNS Join jReqPayload + encodeDecodeAndCheck $ requestWith localNS Leave lReqPayload + encodeDecodeAndCheck $ requestWith localNS Stabilise stabReqPayload + encodeDecodeAndCheck $ requestWith localNS Ping pingReqPayload + encodeDecodeAndCheck $ requestWith localNS QueryLoad qLoadReqPayload encodeDecodeAndCheck $ responseWith QueryID qidResPayload1 encodeDecodeAndCheck $ responseWith QueryID qidResPayload2 encodeDecodeAndCheck $ responseWith Join jResPayload encodeDecodeAndCheck $ responseWith Leave lResPayload encodeDecodeAndCheck $ responseWith Stabilise stabResPayload encodeDecodeAndCheck $ responseWith Ping pingResPayload - encodeDecodeAndCheck $ requestWith QueryLoad qLoadReqPayload encodeDecodeAndCheck $ responseWith QueryLoad qLoadResPayload it "messages are encoded and decoded to ASN.1 DER properly" $ deserialiseMessage (fromJust $ Map.lookup 1 (serialiseMessage 652 $ responseWith Ping pingResPayload)) `shouldBe` Right (responseWith Ping pingResPayload) From 12dfc56a7321ffeb204e3978b6010992ee4df8dc Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 19 Sep 2020 23:01:55 +0200 Subject: [PATCH 10/38] fediChordInit returns a RealNode, manages vservers as map - contributes to #34 --- src/Hash2Pub/FediChord.hs | 20 +++++++++++--------- src/Hash2Pub/FediChordTypes.hs | 6 ++++-- 2 files changed, 15 insertions(+), 11 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 9f14a1e..0dcba44 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -73,6 +73,8 @@ import Data.IP (IPv6, fromHostAddress6, toHostAddress6) import Data.List ((\\)) import qualified Data.Map.Strict as Map +import qualified Data.HashMap.Strict as HMap +import Data.HashMap.Strict (HashMap) import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, isNothing, mapMaybe) import qualified Data.Set as Set @@ -96,11 +98,11 @@ import Debug.Trace (trace) fediChordInit :: (Service s (RealNodeSTM s)) => FediChordConf -> (RealNodeSTM s -> IO (s (RealNodeSTM s))) -- ^ runner function for service - -> IO (Socket, LocalNodeStateSTM s) + -> IO (Socket, RealNodeSTM s) fediChordInit initConf serviceRunner = do emptyLookupCache <- newTVarIO Map.empty let realNode = RealNode { - vservers = [] + vservers = HMap.empty , nodeConfig = initConf , bootstrapNodes = confBootstrapNodes initConf , lookupCacheSTM = emptyLookupCache @@ -110,13 +112,13 @@ fediChordInit initConf serviceRunner = do -- launch service and set the reference in the RealNode serv <- serviceRunner realNodeSTM atomically . modifyTVar' realNodeSTM $ \rn -> rn { nodeService = serv } - -- initialise a single vserver - initialState <- nodeStateInit realNodeSTM - initialStateSTM <- newTVarIO initialState + -- TODO: k-choices way of joining, so far just initialise a single vserver + firstVS <- nodeStateInit realNodeSTM + firstVSSTM <- newTVarIO firstVS -- add vserver to list at RealNode - atomically . modifyTVar' realNodeSTM $ \rn -> rn { vservers = initialStateSTM:vservers rn } - serverSock <- mkServerSocket (getIpAddr initialState) (getDhtPort initialState) - pure (serverSock, initialStateSTM) + atomically . modifyTVar' realNodeSTM $ \rn -> rn { vservers = HMap.insert (getNid firstVS) firstVSSTM (vservers rn) } + serverSock <- mkServerSocket (confIP initConf) (fromIntegral $ confDhtPort initConf) + pure (serverSock, realNodeSTM) -- | initialises the 'NodeState' for this local node. -- Separated from 'fediChordInit' to be usable in tests. @@ -757,7 +759,7 @@ updateLookupCache :: RealNodeSTM s -> NodeID -> IO (Maybe (String, PortNumber)) updateLookupCache nodeSTM keyToLookup = do (node, lookupSource) <- atomically $ do node <- readTVar nodeSTM - let firstVs = headMay (vservers node) + let firstVs = headMay (HMap.elems $ vservers node) lookupSource <- case firstVs of Nothing -> pure Nothing Just vs -> Just <$> readTVar vs diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index d8bbe4c..fd9d0f9 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -71,6 +71,8 @@ import Data.Function (on) import qualified Data.Hashable as Hashable import Data.List (delete, nub, sortBy) import qualified Data.Map.Strict as Map +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HMap import Data.Maybe (fromJust, fromMaybe, isJust, isNothing, mapMaybe) import qualified Data.Set as Set @@ -151,8 +153,8 @@ a `localCompare` b -- Also contains shared data and config values. -- TODO: more data structures for k-choices bookkeeping data RealNode s = RealNode - { vservers :: [LocalNodeStateSTM s] - -- ^ references to all active versers + { vservers :: HashMap NodeID (LocalNodeStateSTM s) + -- ^ map of all active VServer node IDs to their node state , nodeConfig :: FediChordConf -- ^ holds the initial configuration read at program start , bootstrapNodes :: [(String, PortNumber)] From 0ab6ee9c8fc6a4e2c3e3c27d723830303221d4fd Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sun, 20 Sep 2020 19:30:35 +0200 Subject: [PATCH 11/38] re-strucuture fediChordInit flow to also do the bootstrapping --- app/Main.hs | 25 ++------------ src/Hash2Pub/FediChord.hs | 59 +++++++++++++++++++++++----------- src/Hash2Pub/FediChordTypes.hs | 11 +++++-- 3 files changed, 52 insertions(+), 43 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index eac223d..ed599f8 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -18,29 +18,10 @@ main = do -- ToDo: parse and pass config -- probably use `tomland` for that (fConf, sConf) <- readConfig - -- TODO: first initialise 'RealNode', then the vservers -- ToDo: load persisted caches, bootstrapping nodes … - (serverSock, thisNode) <- fediChordInit fConf (runService sConf :: DHT d => d -> IO (PostService d)) - -- currently no masking is necessary, as there is nothing to clean up - nodeCacheWriterThread <- forkIO $ nodeCacheWriter thisNode - -- try joining the DHT using one of the provided bootstrapping nodes - joinedState <- tryBootstrapJoining thisNode - either (\err -> do - -- handle unsuccessful join - - putStrLn $ err <> " Error joining, start listening for incoming requests anyways" - print =<< readTVarIO thisNode - -- launch thread attempting to join on new cache entries - _ <- forkIO $ joinOnNewEntriesThread thisNode - wait =<< async (fediMainThreads serverSock thisNode) - ) - (\joinedNS -> do - -- launch main eventloop with successfully joined state - putStrLn "successful join" - wait =<< async (fediMainThreads serverSock thisNode) - ) - joinedState - pure () + (fediThreads, thisNode) <- fediChordInit fConf (runService sConf :: DHT d => d -> IO (PostService d)) + -- wait for all DHT threads to terminate, this keeps the main thread running + wait fediThreads readConfig :: IO (FediChordConf, ServiceConf) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 0dcba44..6f9caf6 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -98,38 +98,59 @@ import Debug.Trace (trace) fediChordInit :: (Service s (RealNodeSTM s)) => FediChordConf -> (RealNodeSTM s -> IO (s (RealNodeSTM s))) -- ^ runner function for service - -> IO (Socket, RealNodeSTM s) + -> IO (Async (), RealNodeSTM s) fediChordInit initConf serviceRunner = do emptyLookupCache <- newTVarIO Map.empty - let realNode = RealNode { - vservers = HMap.empty + cacheSTM <- newTVarIO initCache + cacheQ <- atomically newTQueue + let realNode = RealNode + { vservers = HMap.empty , nodeConfig = initConf , bootstrapNodes = confBootstrapNodes initConf , lookupCacheSTM = emptyLookupCache , nodeService = undefined - } + , globalNodeCacheSTM = cacheSTM + , globalCacheWriteQueue = cacheQ + } realNodeSTM <- newTVarIO realNode + serverSock <- mkServerSocket (confIP initConf) (fromIntegral $ confDhtPort initConf) -- launch service and set the reference in the RealNode serv <- serviceRunner realNodeSTM atomically . modifyTVar' realNodeSTM $ \rn -> rn { nodeService = serv } + -- prepare for joining: start node cache writer thread + -- currently no masking is necessary, as there is nothing to clean up + nodeCacheWriterThread <- forkIO $ nodeCacheWriter realNodeSTM -- TODO: k-choices way of joining, so far just initialise a single vserver - firstVS <- nodeStateInit realNodeSTM + firstVS <- nodeStateInit realNodeSTM 0 firstVSSTM <- newTVarIO firstVS -- add vserver to list at RealNode atomically . modifyTVar' realNodeSTM $ \rn -> rn { vservers = HMap.insert (getNid firstVS) firstVSSTM (vservers rn) } - serverSock <- mkServerSocket (confIP initConf) (fromIntegral $ confDhtPort initConf) - pure (serverSock, realNodeSTM) + -- try joining the DHT using one of the provided bootstrapping nodes + joinedState <- tryBootstrapJoining firstVSSTM + fediThreadsAsync <- either (\err -> do + -- handle unsuccessful join + + putStrLn $ err <> " Error joining, start listening for incoming requests anyways" + -- launch thread attempting to join on new cache entries + _ <- forkIO $ joinOnNewEntriesThread firstVSSTM + async (fediMainThreads serverSock firstVSSTM) + ) + (\joinedNS -> do + -- launch main eventloop with successfully joined state + putStrLn "successful join" + async (fediMainThreads serverSock firstVSSTM) + ) + joinedState + pure (fediThreadsAsync, realNodeSTM) -- | initialises the 'NodeState' for this local node. -- Separated from 'fediChordInit' to be usable in tests. -nodeStateInit :: Service s (RealNodeSTM s) => RealNodeSTM s -> IO (LocalNodeState s) -nodeStateInit realNodeSTM = do +nodeStateInit :: Service s (RealNodeSTM s) => RealNodeSTM s -> Integer -> IO (LocalNodeState s) +nodeStateInit realNodeSTM vsID' = do realNode <- readTVarIO realNodeSTM - cacheSTM <- newTVarIO initCache - q <- atomically newTQueue let conf = nodeConfig realNode - vsID = 0 + vsID = vsID' containedState = RemoteNodeState { domain = confDomain conf , ipAddr = confIP conf @@ -140,8 +161,8 @@ nodeStateInit realNodeSTM = do } initialState = LocalNodeState { nodeState = containedState - , nodeCacheSTM = cacheSTM - , cacheWriteQueue = q + , nodeCacheSTM = globalNodeCacheSTM realNode + , cacheWriteQueue = globalCacheWriteQueue realNode , successors = [] , predecessors = [] , kNeighbours = 3 @@ -336,12 +357,12 @@ joinOnNewEntriesThread nsSTM = loop -- | cache updater thread that waits for incoming NodeCache update instructions on -- the node's cacheWriteQueue and then modifies the NodeCache as the single writer. -nodeCacheWriter :: LocalNodeStateSTM s -> IO () -nodeCacheWriter nsSTM = +nodeCacheWriter :: RealNodeSTM s -> IO () +nodeCacheWriter nodeSTM = do + node <- readTVarIO nodeSTM forever $ atomically $ do - ns <- readTVar nsSTM - cacheModifier <- readTQueue $ cacheWriteQueue ns - modifyTVar' (nodeCacheSTM ns) cacheModifier + cacheModifier <- readTQueue $ globalCacheWriteQueue node + modifyTVar' (globalNodeCacheSTM node) cacheModifier -- | Periodically iterate through cache, clean up expired entries and verify unverified ones diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index fd9d0f9..a1c0937 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -161,6 +161,13 @@ data RealNode s = RealNode -- ^ nodes to be used as bootstrapping points, new ones learned during operation , lookupCacheSTM :: TVar LookupCache -- ^ a global cache of looked up keys and their associated nodes + , globalNodeCacheSTM :: TVar NodeCache + -- ^ EpiChord node cache with expiry times for nodes. + -- Shared between all vservers, each 'LocalNodeState' holds a reference to + -- the same TVar for avoiding unnecessary reads of parent node + , globalCacheWriteQueue :: TQueue (NodeCache -> NodeCache) + -- ^ cache updates are not written directly to the 'globalNodeCacheSTM' + -- but queued and processed by a single thread , nodeService :: s (RealNodeSTM s) } @@ -190,9 +197,9 @@ data LocalNodeState s = LocalNodeState { nodeState :: RemoteNodeState -- ^ represents common data present both in remote and local node representations , nodeCacheSTM :: TVar NodeCache - -- ^ EpiChord node cache with expiry times for nodes + -- ^ reference to the 'globalNodeCacheSTM' , cacheWriteQueue :: TQueue (NodeCache -> NodeCache) - -- ^ cache updates are not written directly to the 'nodeCache' but queued and + -- ^ reference to the 'globalCacheWriteQueue , successors :: [RemoteNodeState] -- could be a set instead as these are ordered as well -- ^ successor nodes in ascending order by distance , predecessors :: [RemoteNodeState] From 68de73d919b54dc7e4a8248e3c689f1c37be10d5 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sun, 20 Sep 2020 21:19:17 +0200 Subject: [PATCH 12/38] re-structure fediChordMessageHandler to dispatch requests to the responsible vserver contributes to #34 --- src/Hash2Pub/DHTProtocol.hs | 8 ++++---- src/Hash2Pub/FediChord.hs | 33 +++++++++++++++++---------------- 2 files changed, 21 insertions(+), 20 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 38c0dcb..eca145a 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -241,16 +241,16 @@ sendMessageSize = 1200 -- ====== message send and receive operations ====== -- encode the response to a request that just signals successful receipt -ackRequest :: NodeID -> FediChordMessage -> Map.Map Integer BS.ByteString -ackRequest ownID req@Request{} = serialiseMessage sendMessageSize $ Response { +ackRequest :: FediChordMessage -> Map.Map Integer BS.ByteString +ackRequest req@Request{} = serialiseMessage sendMessageSize $ Response { requestID = requestID req - , senderID = ownID + , senderID = receiverID req , part = part req , isFinalPart = False , action = action req , payload = Nothing } -ackRequest _ _ = Map.empty +ackRequest _ = Map.empty -- | Dispatch incoming requests to the dedicated handling and response function, and enqueue diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 6f9caf6..ee5e9b6 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -138,7 +138,7 @@ fediChordInit initConf serviceRunner = do (\joinedNS -> do -- launch main eventloop with successfully joined state putStrLn "successful join" - async (fediMainThreads serverSock firstVSSTM) + async (fediMainThreads serverSock realNodeSTM) ) joinedState pure (fediThreadsAsync, realNodeSTM) @@ -626,16 +626,16 @@ sendThread sock sendQ = forever $ do sendAllTo sock packet addr -- | Sets up and manages the main server threads of FediChord -fediMainThreads :: Service s (RealNodeSTM s) => Socket -> LocalNodeStateSTM s -> IO () -fediMainThreads sock nsSTM = do - ns <- readTVarIO nsSTM +fediMainThreads :: Service s (RealNodeSTM s) => Socket -> RealNodeSTM s -> IO () +fediMainThreads sock nodeSTM = do + node <- readTVarIO nodeSTM putStrLn "launching threads" sendQ <- newTQueueIO recvQ <- newTQueueIO -- concurrently launch all handler threads, if one of them throws an exception -- all get cancelled concurrently_ - (fediMessageHandler sendQ recvQ nsSTM) $ + (fediMessageHandler sendQ recvQ nodeSTM) $ concurrently_ (stabiliseThread nsSTM) $ concurrently_ (nodeCacheVerifyThread nsSTM) $ concurrently_ (convergenceSampleThread nsSTM) $ @@ -668,20 +668,17 @@ requestMapPurge purgeAge mapVar = forever $ do fediMessageHandler :: Service s (RealNodeSTM s) => TQueue (BS.ByteString, SockAddr) -- ^ send queue -> TQueue (BS.ByteString, SockAddr) -- ^ receive queue - -> LocalNodeStateSTM s -- ^ acting NodeState + -> RealNodeSTM s -- ^ node -> IO () -fediMessageHandler sendQ recvQ nsSTM = do - -- Read node state just once, assuming that all relevant data for this function does - -- not change. - -- Other functions are passed the nsSTM reference and thus can get the latest state. - nsSnap <- readTVarIO nsSTM - nodeConf <- nodeConfig <$> readTVarIO (parentRealNode nsSnap) +fediMessageHandler sendQ recvQ nodeSTM = do + nodeConf <- nodeConfig <$> readTVarIO nodeSTM -- handling multipart messages: -- Request parts can be insert into a map (key: (sender IP against spoofing, request ID), value: timestamp + set of message parts, handle all of them when size of set == parts) before being handled. This map needs to be purged periodically by a separate thread and can be protected by an MVar for fairness. requestMap <- newMVar (Map.empty :: RequestMap) -- run receive loop and requestMapPurge concurrently, so that an exception makes -- both of them fail concurrently_ (requestMapPurge (confResponsePurgeAge nodeConf) requestMap) $ forever $ do + node <- readTVarIO nodeSTM -- wait for incoming messages (rawMsg, sourceAddr) <- atomically $ readTQueue recvQ let aMsg = deserialiseMessage rawMsg @@ -691,12 +688,14 @@ fediMessageHandler sendQ recvQ nsSTM = do ) (\validMsg -> case validMsg of - aRequest@Request{} + aRequest@Request{} -> case dispatchVS node aRequest of + -- if no match to an active vserver ID, just ignore + Nothing -> pure () -- if not a multipart message, handle immediately. Response is at the same time an ACK - | part aRequest == 1 && isFinalPart aRequest -> + Just nsSTM | part aRequest == 1 && isFinalPart aRequest -> forkIO (handleIncomingRequest nsSTM sendQ (Set.singleton aRequest) sourceAddr) >> pure () -- otherwise collect all message parts first before handling the whole request - | otherwise -> do + Just nsSTM | otherwise -> do now <- getPOSIXTime -- critical locking section of requestMap rMapState <- takeMVar requestMap @@ -714,7 +713,7 @@ fediMessageHandler sendQ recvQ nsSTM = do -- put map back into MVar, end of critical section putMVar requestMap newMapState -- ACK the received part - forM_ (ackRequest (getNid nsSnap) aRequest) $ + forM_ (ackRequest aRequest) $ \msg -> atomically $ writeTQueue sendQ (msg, sourceAddr) -- if all parts received, then handle request. let @@ -730,6 +729,8 @@ fediMessageHandler sendQ recvQ nsSTM = do aMsg pure () + where + dispatchVS node req = HMap.lookup (receiverID req) (vservers node) -- ==== interface to service layer ==== From 33ae904d17055c37225b165440058d3e816aff42 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 21 Sep 2020 02:11:43 +0200 Subject: [PATCH 13/38] re-structure cacheVerifyThread to work on a RealNode and iterate over all joined vservers contributes to #34 --- src/Hash2Pub/DHTProtocol.hs | 26 ++--- src/Hash2Pub/FediChord.hs | 225 +++++++++++++++++++----------------- 2 files changed, 135 insertions(+), 116 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index eca145a..f462a26 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -269,7 +269,7 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do Nothing -> pure () Just aPart -> do let (SockAddrInet6 _ _ sourceIP _) = sourceAddr - queueAddEntries (Identity $ RemoteCacheEntry (sender aPart) now) ns + queueAddEntries (Identity $ RemoteCacheEntry (sender aPart) now) (cacheWriteQueue ns) -- distinguish on whether and how to respond. If responding, pass message to response generating function and write responses to send queue maybe (pure ()) ( mapM_ (\resp -> atomically $ writeTQueue sendQ (resp, sourceAddr)) @@ -542,7 +542,7 @@ requestJoin toJoinOn ownStateSTM = do writeTVar ownStateSTM newState pure (cacheInsertQ, newState) -- execute the cache insertions - mapM_ (\f -> f joinedState) cacheInsertQ + mapM_ (\f -> f (cacheWriteQueue joinedState)) cacheInsertQ if responses == Set.empty then pure . Left $ "join error: got no response from " <> show (getNid toJoinOn) else do @@ -624,7 +624,7 @@ sendQueryIdMessages targetID ns lParam targets = do _ -> Set.empty -- forward entries to global cache - queueAddEntries entrySet ns + queueAddEntries entrySet (cacheWriteQueue ns) -- return accumulated QueryResult pure $ case acc of -- once a FOUND as been encountered, return this as a result @@ -670,7 +670,7 @@ requestStabilise ns neighbour = do ) ([],[]) respSet -- update successfully responded neighbour in cache - maybe (pure ()) (\p -> queueUpdateVerifieds (Identity $ senderID p) ns) $ headMay (Set.elems respSet) + maybe (pure ()) (\p -> queueUpdateVerifieds (Identity $ senderID p) (cacheWriteQueue ns)) $ headMay (Set.elems respSet) pure $ if null responsePreds && null responseSuccs then Left "no neighbours returned" else Right (responsePreds, responseSuccs) @@ -832,24 +832,24 @@ sendRequestTo timeoutMillis numAttempts msgIncomplete sock = do -- | enqueue a list of RemoteCacheEntries to be added to the global NodeCache queueAddEntries :: Foldable c => c RemoteCacheEntry - -> LocalNodeState s + -> TQueue (NodeCache -> NodeCache) -> IO () -queueAddEntries entries ns = do +queueAddEntries entries cacheQ = do now <- getPOSIXTime - forM_ entries $ \entry -> atomically $ writeTQueue (cacheWriteQueue ns) $ addCacheEntryPure now entry + forM_ entries $ \entry -> atomically $ writeTQueue cacheQ $ addCacheEntryPure now entry -- | enque a list of node IDs to be deleted from the global NodeCache queueDeleteEntries :: Foldable c => c NodeID - -> LocalNodeState s + -> TQueue (NodeCache -> NodeCache) -> IO () -queueDeleteEntries ids ns = forM_ ids $ atomically . writeTQueue (cacheWriteQueue ns) . deleteCacheEntry +queueDeleteEntries ids cacheQ = forM_ ids $ atomically . writeTQueue cacheQ . deleteCacheEntry -- | enque a single node ID to be deleted from the global NodeCache queueDeleteEntry :: NodeID - -> LocalNodeState s + -> TQueue (NodeCache -> NodeCache) -> IO () queueDeleteEntry toDelete = queueDeleteEntries $ Identity toDelete @@ -858,11 +858,11 @@ queueDeleteEntry toDelete = queueDeleteEntries $ Identity toDelete -- global 'NodeCache'. queueUpdateVerifieds :: Foldable c => c NodeID - -> LocalNodeState s + -> TQueue (NodeCache -> NodeCache) -> IO () -queueUpdateVerifieds nIds ns = do +queueUpdateVerifieds nIds cacheQ = do now <- getPOSIXTime - forM_ nIds $ \nid' -> atomically $ writeTQueue (cacheWriteQueue ns) $ + forM_ nIds $ \nid' -> atomically $ writeTQueue cacheQ $ markCacheEntryAsVerified (Just now) nid' -- | retry an IO action at most *i* times until it delivers a result diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index ee5e9b6..9565bae 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -366,59 +366,72 @@ nodeCacheWriter nodeSTM = do -- | Periodically iterate through cache, clean up expired entries and verify unverified ones -nodeCacheVerifyThread :: LocalNodeStateSTM s -> IO () -nodeCacheVerifyThread nsSTM = forever $ do - -- get cache - (ns, cache, maxEntryAge) <- atomically $ do - ns <- readTVar nsSTM - cache <- readTVar $ nodeCacheSTM ns - maxEntryAge <- confMaxNodeCacheAge . nodeConfig <$> readTVar (parentRealNode ns) - pure (ns, cache, maxEntryAge) +nodeCacheVerifyThread :: RealNodeSTM s -> IO () +nodeCacheVerifyThread nodeSTM = forever $ do + (node, firstVSSTM) <- atomically $ do + node <- readTVar nodeSTM + case headMay (HMap.elems $ vservers node) of + -- wait until first VS is joined + Nothing -> retry + Just vs' -> pure (node, vs') + let + maxEntryAge = confMaxNodeCacheAge $ nodeConfig node + cacheQ = globalCacheWriteQueue node + cache <- readTVarIO $ globalNodeCacheSTM node + -- always use the first active VS as a sender for operations like Ping + firstVS <- readTVarIO firstVSSTM -- iterate entries: -- for avoiding too many time syscalls, get current time before iterating. now <- getPOSIXTime - forM_ (nodeCacheEntries cache) (\(CacheEntry validated node ts) -> + forM_ (nodeCacheEntries cache) (\(CacheEntry validated cacheNode ts) -> -- case too old: delete (future work: decide whether pinging and resetting timestamp is better) if (now - ts) > maxEntryAge then - queueDeleteEntry (getNid node) ns - -- case unverified: try verifying, otherwise delete + queueDeleteEntry (getNid cacheNode) cacheQ + -- case unverified: try verifying, otherwise delete else if not validated then do -- marking as verified is done by 'requestPing' as well - pong <- requestPing ns node + pong <- requestPing firstVS cacheNode either (\_-> - queueDeleteEntry (getNid node) ns + queueDeleteEntry (getNid cacheNode) cacheQ ) (\vss -> - if node `notElem` vss - then queueDeleteEntry (getNid node) ns + if cacheNode `notElem` vss + then queueDeleteEntry (getNid cacheNode) firstVS -- after verifying a node, check whether it can be a closer neighbour - else do - if node `isPossiblePredecessor` ns + -- do this for each node + -- TODO: optimisation: place all LocalNodeStates on the cache ring and check whether any of them is the predecessor/ successor + else forM_ (vservers node) (\nsSTM -> do + ns <- readTVarIO nsSTM + if cacheNode `isPossiblePredecessor` ns then atomically $ do ns' <- readTVar nsSTM - writeTVar nsSTM $ addPredecessors [node] ns' + writeTVar nsSTM $ addPredecessors [cacheNode] ns' else pure () - if node `isPossibleSuccessor` ns + if cacheNode `isPossibleSuccessor` ns then atomically $ do ns' <- readTVar nsSTM - writeTVar nsSTM $ addSuccessors [node] ns' + writeTVar nsSTM $ addSuccessors [cacheNode] ns' else pure () + ) ) pong else pure () ) -- check the cache invariant per slice and, if necessary, do a single lookup to the -- middle of each slice not verifying the invariant - latestNs <- readTVarIO nsSTM - latestCache <- readTVarIO $ nodeCacheSTM latestNs - let nodesToQuery targetID = case queryLocalCache latestNs latestCache (lNumBestNodes latestNs) targetID of - FOUND node -> [node] - FORWARD nodeSet -> remoteNode <$> Set.elems nodeSet - forM_ (checkCacheSliceInvariants latestNs latestCache) (\targetID -> - forkIO $ sendQueryIdMessages targetID latestNs (Just (1 + jEntriesPerSlice latestNs)) (nodesToQuery targetID) >> pure () -- ask for 1 entry more than j because of querying the middle - ) + latestNode <- readTVarIO nodeSTM + forM_ (vservers latestNode) (\nsSTM -> do + latestNs <- readTVarIO nsSTM + latestCache <- readTVarIO $ nodeCacheSTM latestNs + let nodesToQuery targetID = case queryLocalCache latestNs latestCache (lNumBestNodes latestNs) targetID of + FOUND node -> [node] + FORWARD nodeSet -> remoteNode <$> Set.elems nodeSet + forM_ (checkCacheSliceInvariants latestNs latestCache) (\targetID -> + forkIO $ sendQueryIdMessages targetID latestNs (Just (1 + jEntriesPerSlice latestNs)) (nodesToQuery targetID) >> pure () -- ask for 1 entry more than j because of querying the middle + ) + ) threadDelay $ fromEnum (maxEntryAge / 20) `div` 10^6 -- convert from pico to milliseconds @@ -482,90 +495,93 @@ checkCacheSliceInvariants ns -- | Periodically send @StabiliseRequest' s to the closest neighbour nodes, until -- one responds, and get their neighbours for maintaining the own neighbour lists. -- If necessary, request new neighbours. -stabiliseThread :: Service s (RealNodeSTM s) => LocalNodeStateSTM s -> IO () -stabiliseThread nsSTM = forever $ do - oldNs <- readTVarIO nsSTM +stabiliseThread :: Service s (RealNodeSTM s) => RealNodeSTM s -> IO () +stabiliseThread nodeSTM = forever $ do + node <- readTVarIO nodeSTM + forM_ (vservers node) (\nsSTM -> do + oldNs <- 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. + -- 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 + -- don't contact all neighbours unless the previous one failed/ Left ed - predStabilise <- stabiliseClosestResponder oldNs predecessors 1 [] - succStabilise <- stabiliseClosestResponder oldNs predecessors 1 [] + predStabilise <- stabiliseClosestResponder oldNs predecessors 1 [] + succStabilise <- stabiliseClosestResponder oldNs 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 - -- delete unresponding nodes from cache as well - mapM_ (atomically . writeTQueue (cacheWriteQueue updatedNs) . deleteCacheEntry . getNid) allDeletes + (predDeletes, predNeighbours) = either (const ([], [])) id predStabilise + (succDeletes, succNeighbours) = either (const ([], [])) id succStabilise + allDeletes = predDeletes <> succDeletes + allNeighbours = predNeighbours <> succNeighbours - -- try looking up additional neighbours if list too short - forM_ [(length $ predecessors updatedNs)..(kNeighbours updatedNs)] (\_ -> do - ns' <- readTVarIO nsSTM - nextEntry <- runExceptT . requestQueryID ns' $ pred . getNid $ lastDef (toRemoteNodeState ns') (predecessors ns') - either - (const $ pure ()) - (\entry -> atomically $ do - latestNs <- readTVar nsSTM - writeTVar nsSTM $ addPredecessors [entry] latestNs - ) - nextEntry - ) + -- 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 + -- delete unresponding nodes from cache as well + mapM_ (atomically . writeTQueue (cacheWriteQueue updatedNs) . deleteCacheEntry . getNid) allDeletes - forM_ [(length $ successors updatedNs)..(kNeighbours updatedNs)] (\_ -> do - ns' <- readTVarIO nsSTM - nextEntry <- runExceptT . requestQueryID ns' $ succ . getNid $ lastDef (toRemoteNodeState ns') (successors ns') - either - (const $ pure ()) - (\entry -> atomically $ do - latestNs <- readTVar nsSTM - writeTVar nsSTM $ addSuccessors [entry] latestNs - ) - nextEntry - ) + -- try looking up additional neighbours if list too short + forM_ [(length $ predecessors updatedNs)..(kNeighbours updatedNs)] (\_ -> do + ns' <- readTVarIO nsSTM + nextEntry <- runExceptT . requestQueryID ns' $ pred . getNid $ lastDef (toRemoteNodeState ns') (predecessors ns') + either + (const $ pure ()) + (\entry -> atomically $ do + latestNs <- readTVar nsSTM + writeTVar nsSTM $ addPredecessors [entry] latestNs + ) + nextEntry + ) - newNs <- readTVarIO nsSTM + forM_ [(length $ successors updatedNs)..(kNeighbours updatedNs)] (\_ -> do + ns' <- readTVarIO nsSTM + nextEntry <- runExceptT . requestQueryID ns' $ succ . getNid $ lastDef (toRemoteNodeState ns') (successors ns') + either + (const $ pure ()) + (\entry -> atomically $ do + latestNs <- readTVar nsSTM + writeTVar nsSTM $ addSuccessors [entry] latestNs + ) + nextEntry + ) - let - oldPredecessor = headDef (toRemoteNodeState oldNs) $ predecessors oldNs - newPredecessor = headMay $ predecessors newNs - -- manage need for service data migration: - maybe (pure ()) (\newPredecessor' -> - when ( - isJust newPredecessor - && oldPredecessor /= newPredecessor' - -- case: predecessor has changed in some way => own responsibility has changed in some way - -- case 1: new predecessor is further away => broader responsibility, but new pred needs to push the data - -- If this is due to a node leaving without transfering its data, try getting it from a redundant copy - -- case 2: new predecessor is closer, it takes some of our data but somehow didn't join on us => push data to it - && isInOwnResponsibilitySlice newPredecessor' oldNs) $ do - ownService <- nodeService <$> (liftIO . readTVarIO $ parentRealNode newNs) - migrationResult <- migrateData ownService (getNid newNs) (getNid oldPredecessor) (getNid newPredecessor') (getDomain newPredecessor', fromIntegral $ getServicePort newPredecessor') - -- TODO: deal with migration failure, e.g retry - pure () - ) - newPredecessor + newNs <- readTVarIO nsSTM - stabiliseDelay <- confStabiliseInterval . nodeConfig <$> readTVarIO (parentRealNode newNs) - threadDelay stabiliseDelay + let + oldPredecessor = headDef (toRemoteNodeState oldNs) $ predecessors oldNs + newPredecessor = headMay $ predecessors newNs + -- manage need for service data migration: + maybe (pure ()) (\newPredecessor' -> + when ( + isJust newPredecessor + && oldPredecessor /= newPredecessor' + -- case: predecessor has changed in some way => own responsibility has changed in some way + -- case 1: new predecessor is further away => broader responsibility, but new pred needs to push the data + -- If this is due to a node leaving without transfering its data, try getting it from a redundant copy + -- case 2: new predecessor is closer, it takes some of our data but somehow didn't join on us => push data to it + && isInOwnResponsibilitySlice newPredecessor' oldNs) $ do + ownService <- nodeService <$> (liftIO . readTVarIO $ parentRealNode newNs) + migrationResult <- migrateData ownService (getNid newNs) (getNid oldPredecessor) (getNid newPredecessor') (getDomain newPredecessor', fromIntegral $ getServicePort newPredecessor') + -- TODO: deal with migration failure, e.g retry + pure () + ) + newPredecessor + + ) + + threadDelay . confStabiliseInterval . nodeConfig $ node where -- | send a stabilise request to the n-th neighbour -- (specified by the provided getter function) and on failure retry @@ -636,8 +652,11 @@ fediMainThreads sock nodeSTM = do -- all get cancelled concurrently_ (fediMessageHandler sendQ recvQ nodeSTM) $ - concurrently_ (stabiliseThread nsSTM) $ - concurrently_ (nodeCacheVerifyThread nsSTM) $ + -- decision whether to [1] launch 1 thread per VS or [2] let a single + -- thread process all VSes sequentially: + -- choose option 2 for the sake of limiting concurrency in simulation scenario + concurrently_ (stabiliseThread nodeSTM) $ + concurrently_ (nodeCacheVerifyThread nodeSTM) $ concurrently_ (convergenceSampleThread nsSTM) $ concurrently_ (lookupCacheCleanup $ parentRealNode ns) $ concurrently_ From 8e8ea41dc4836a3c450785a5d5a7a2c72dca0a04 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 21 Sep 2020 02:18:28 +0200 Subject: [PATCH 14/38] re-structure convergenceSampleThread to work on a RealNode and iterate over all joined vservers contributes to #34 --- src/Hash2Pub/FediChord.hs | 61 ++++++++++++++++++++------------------- 1 file changed, 32 insertions(+), 29 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 9565bae..307dc51 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -133,7 +133,7 @@ fediChordInit initConf serviceRunner = do putStrLn $ err <> " Error joining, start listening for incoming requests anyways" -- launch thread attempting to join on new cache entries _ <- forkIO $ joinOnNewEntriesThread firstVSSTM - async (fediMainThreads serverSock firstVSSTM) + async (fediMainThreads serverSock realNodeSTM) ) (\joinedNS -> do -- launch main eventloop with successfully joined state @@ -195,33 +195,36 @@ fediChordBootstrapJoin nsSTM bootstrapNode = do -- Periodically lookup own ID through a random bootstrapping node to discover and merge separated DHT clusters. -- Unjoined try joining instead. -convergenceSampleThread :: Service s (RealNodeSTM s) => LocalNodeStateSTM s -> IO () -convergenceSampleThread nsSTM = forever $ do - nsSnap <- readTVarIO nsSTM - parentNode <- readTVarIO $ parentRealNode nsSnap - if isJoined nsSnap - then - runExceptT (do - -- joined node: choose random node, do queryIDLoop, compare result with own responsibility - let bss = bootstrapNodes parentNode - randIndex <- liftIO $ randomRIO (0, length bss - 1) - chosenNode <- maybe (throwError "invalid bootstrapping node index") pure $ atMay bss randIndex - lookupResult <- liftIO $ bootstrapQueryId nsSTM chosenNode (getNid nsSnap) - currentlyResponsible <- liftEither lookupResult - if getNid currentlyResponsible /= getNid nsSnap - -- if mismatch, stabilise on the result, else do nothing - then do - stabResult <- liftIO $ requestStabilise nsSnap currentlyResponsible - (preds, succs) <- liftEither stabResult - -- TODO: verify neighbours before adding, see #55 - liftIO . atomically $ do - ns <- readTVar nsSTM - writeTVar nsSTM $ addPredecessors preds ns - else pure () - ) >> pure () - -- unjoined node: try joining through all bootstrapping nodes - else tryBootstrapJoining nsSTM >> pure () - let delaySecs = confBootstrapSamplingInterval . nodeConfig $ parentNode +convergenceSampleThread :: Service s (RealNodeSTM s) => RealNodeSTM s -> IO () +convergenceSampleThread nodeSTM = forever $ do + node <- readTVarIO nodeSTM + forM_ (vservers node) $ \nsSTM -> do + nsSnap <- readTVarIO nsSTM + parentNode <- readTVarIO $ parentRealNode nsSnap + if isJoined nsSnap + then + runExceptT (do + -- joined node: choose random node, do queryIDLoop, compare result with own responsibility + let bss = bootstrapNodes parentNode + randIndex <- liftIO $ randomRIO (0, length bss - 1) + chosenNode <- maybe (throwError "invalid bootstrapping node index") pure $ atMay bss randIndex + lookupResult <- liftIO $ bootstrapQueryId nsSTM chosenNode (getNid nsSnap) + currentlyResponsible <- liftEither lookupResult + if getNid currentlyResponsible /= getNid nsSnap + -- if mismatch, stabilise on the result, else do nothing + then do + stabResult <- liftIO $ requestStabilise nsSnap currentlyResponsible + (preds, succs) <- liftEither stabResult + -- TODO: verify neighbours before adding, see #55 + liftIO . atomically $ do + ns <- readTVar nsSTM + writeTVar nsSTM $ addPredecessors preds ns + else pure () + ) >> pure () + -- unjoined node: try joining through all bootstrapping nodes + else tryBootstrapJoining nsSTM >> pure () + + let delaySecs = confBootstrapSamplingInterval . nodeConfig $ node threadDelay delaySecs @@ -657,7 +660,7 @@ fediMainThreads sock nodeSTM = do -- choose option 2 for the sake of limiting concurrency in simulation scenario concurrently_ (stabiliseThread nodeSTM) $ concurrently_ (nodeCacheVerifyThread nodeSTM) $ - concurrently_ (convergenceSampleThread nsSTM) $ + concurrently_ (convergenceSampleThread nodeSTM) $ concurrently_ (lookupCacheCleanup $ parentRealNode ns) $ concurrently_ (sendThread sock sendQ) From 1a7afed06223129c28f33165cd2abff856aca2b8 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 21 Sep 2020 02:22:46 +0200 Subject: [PATCH 15/38] finish restructuring fediMainThreads contributes to #34 --- src/Hash2Pub/FediChord.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 307dc51..0624abd 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -401,7 +401,7 @@ nodeCacheVerifyThread nodeSTM = forever $ do ) (\vss -> if cacheNode `notElem` vss - then queueDeleteEntry (getNid cacheNode) firstVS + then queueDeleteEntry (getNid cacheNode) cacheQ -- after verifying a node, check whether it can be a closer neighbour -- do this for each node -- TODO: optimisation: place all LocalNodeStates on the cache ring and check whether any of them is the predecessor/ successor @@ -661,7 +661,7 @@ fediMainThreads sock nodeSTM = do concurrently_ (stabiliseThread nodeSTM) $ concurrently_ (nodeCacheVerifyThread nodeSTM) $ concurrently_ (convergenceSampleThread nodeSTM) $ - concurrently_ (lookupCacheCleanup $ parentRealNode ns) $ + concurrently_ (lookupCacheCleanup nodeSTM) $ concurrently_ (sendThread sock sendQ) (recvThread sock recvQ) From 499c90e63af74499ca895e26e697cdf81b433011 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 21 Sep 2020 02:23:06 +0200 Subject: [PATCH 16/38] stylish run --- src/Hash2Pub/FediChord.hs | 6 +++--- src/Hash2Pub/FediChordTypes.hs | 21 +++++++++------------ 2 files changed, 12 insertions(+), 15 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 0624abd..9baf160 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -69,12 +69,12 @@ import qualified Data.ByteString.UTF8 as BSU import Data.Either (rights) import Data.Foldable (foldr') import Data.Functor.Identity +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HMap import Data.IP (IPv6, fromHostAddress6, toHostAddress6) import Data.List ((\\)) import qualified Data.Map.Strict as Map -import qualified Data.HashMap.Strict as HMap -import Data.HashMap.Strict (HashMap) import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, isNothing, mapMaybe) import qualified Data.Set as Set @@ -375,7 +375,7 @@ nodeCacheVerifyThread nodeSTM = forever $ do node <- readTVar nodeSTM case headMay (HMap.elems $ vservers node) of -- wait until first VS is joined - Nothing -> retry + Nothing -> retry Just vs' -> pure (node, vs') let maxEntryAge = confMaxNodeCacheAge $ nodeConfig node diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index a1c0937..04396d6 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -69,10 +69,10 @@ import Control.Exception import Data.Foldable (foldr') import Data.Function (on) import qualified Data.Hashable as Hashable -import Data.List (delete, nub, sortBy) -import qualified Data.Map.Strict as Map import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HMap +import Data.List (delete, nub, sortBy) +import qualified Data.Map.Strict as Map import Data.Maybe (fromJust, fromMaybe, isJust, isNothing, mapMaybe) import qualified Data.Set as Set @@ -153,22 +153,19 @@ a `localCompare` b -- Also contains shared data and config values. -- TODO: more data structures for k-choices bookkeeping data RealNode s = RealNode - { vservers :: HashMap NodeID (LocalNodeStateSTM s) + { vservers :: HashMap NodeID (LocalNodeStateSTM s) -- ^ map of all active VServer node IDs to their node state - , nodeConfig :: FediChordConf + , nodeConfig :: FediChordConf -- ^ holds the initial configuration read at program start - , bootstrapNodes :: [(String, PortNumber)] + , bootstrapNodes :: [(String, PortNumber)] -- ^ nodes to be used as bootstrapping points, new ones learned during operation - , lookupCacheSTM :: TVar LookupCache + , lookupCacheSTM :: TVar LookupCache -- ^ a global cache of looked up keys and their associated nodes - , globalNodeCacheSTM :: TVar NodeCache + , globalNodeCacheSTM :: TVar NodeCache -- ^ EpiChord node cache with expiry times for nodes. - -- Shared between all vservers, each 'LocalNodeState' holds a reference to - -- the same TVar for avoiding unnecessary reads of parent node - , globalCacheWriteQueue :: TQueue (NodeCache -> NodeCache) + , globalCacheWriteQueue :: TQueue (NodeCache -> NodeCache) -- ^ cache updates are not written directly to the 'globalNodeCacheSTM' - -- but queued and processed by a single thread - , nodeService :: s (RealNodeSTM s) + , nodeService :: s (RealNodeSTM s) } type RealNodeSTM s = TVar (RealNode s) From 1ed02814170105364dcc386c8ed6fe058f0ab010 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 21 Sep 2020 18:14:52 +0200 Subject: [PATCH 17/38] respond to QueryLoad requests closes #71 closes #72 contributes to #2 --- src/Hash2Pub/DHTProtocol.hs | 67 ++++++++++++++++++++++++++++--------- 1 file changed, 52 insertions(+), 15 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index f462a26..c3cc858 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -77,7 +77,7 @@ import Hash2Pub.ASN1Coding import Hash2Pub.FediChordTypes (CacheEntry (..), CacheEntry (..), FediChordConf (..), - HasKeyID (..), + HasKeyID (..), LoadStats (..), LocalNodeState (..), LocalNodeStateSTM, NodeCache, NodeID, NodeState (..), @@ -95,6 +95,7 @@ import Hash2Pub.FediChordTypes (CacheEntry (..), rMapLookupSucc, setPredecessors, setSuccessors) import Hash2Pub.ProtocolTypes +import Hash2Pub.RingMap import Debug.Trace (trace) @@ -253,6 +254,15 @@ ackRequest req@Request{} = serialiseMessage sendMessageSize $ Response { ackRequest _ = Map.empty +-- | extract the first payload from a received message set +extractFirstPayload :: Set.Set FediChordMessage -> Maybe ActionPayload +extractFirstPayload msgSet = foldr' (\msg plAcc -> + if isNothing plAcc && isJust (payload msg) + then payload msg + else plAcc + ) Nothing msgSet + + -- | Dispatch incoming requests to the dedicated handling and response function, and enqueue -- the response to be sent. handleIncomingRequest :: Service s (RealNodeSTM s) @@ -282,6 +292,7 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do -- only when joined Leave -> if isJoined ns then dropSpoofedIDs sourceIP nsSTM msgSet respondLeave else pure Nothing Stabilise -> if isJoined ns then dropSpoofedIDs sourceIP nsSTM msgSet respondStabilise else pure Nothing + QueryLoad -> if isJoined ns then Just <$> respondLoadQuery nsSTM msgSet else pure Nothing ) -- for single part request, response starts with part number 1. For multipart requests, response starts with part number n+1. @@ -321,12 +332,8 @@ respondQueryID nsSTM msgSet = do let aRequestPart = Set.elemAt 0 msgSet senderID = getNid . sender $ aRequestPart - senderPayload = foldr' (\msg plAcc -> - if isNothing plAcc && isJust (payload msg) - then payload msg - else plAcc - ) Nothing msgSet - -- return only empty message serialisation if no payload was included in parts + senderPayload = extractFirstPayload msgSet + -- return only empty message serialisation if no payload was included in parts maybe (pure Map.empty) (\senderPayload' -> do responseMsg <- atomically $ do nsSnap <- readTVar nsSTM @@ -426,6 +433,43 @@ respondPing nsSTM msgSet = do } pure $ serialiseMessage sendMessageSize pingResponse +respondLoadQuery :: Service s (RealNodeSTM s) => LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString) +respondLoadQuery nsSTM msgSet = do + nsSnap <- readTVarIO nsSTM + -- this message cannot be split reasonably, so just + -- consider the first payload + let + aRequestPart = Set.elemAt 0 msgSet + senderPayload = extractFirstPayload msgSet + responsePl <- maybe (pure Nothing) (\pl -> + case pl of + LoadRequestPayload{} -> do + serv <- nodeService <$> readTVarIO (parentRealNode nsSnap) + lStats <- getServiceLoadStats serv + let + directSucc = getNid . head . predecessors $ nsSnap + handledTagSum = sum . takeRMapSuccessorsFromTo directSucc (loadSegmentUpperBound pl) $ loadPerTag lStats + pure $ Just LoadResponsePayload + { loadSum = handledTagSum + , loadRemainingTarget = remainingLoadTarget lStats + , loadSegmentLowerBound = directSucc + } + _ -> pure Nothing + ) + senderPayload + + pure $ maybe + Map.empty + (\pl -> serialiseMessage sendMessageSize $ Response + { requestID = requestID aRequestPart + , senderID = getNid nsSnap + , part = if Set.size msgSet == 1 then 1 else fromIntegral $ Set.size msgSet + 1 + , isFinalPart = False + , action = QueryLoad + , payload = Just pl + } + ) responsePl + respondJoin :: Service s (RealNodeSTM s) => LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString) respondJoin nsSTM msgSet = do @@ -759,14 +803,7 @@ requestQueryLoad ns upperIdBound target = do responseMsgSet <- liftEither responses -- throws an error if an exception happened loadResPl <- maybe (throwError "no load response payload found") pure - (foldr' (\msg acc -> case payload msg of - -- just extract the first found LoadResponsePayload - Just pl@LoadResponsePayload{} | isNothing acc -> Just pl - _ -> Nothing - ) - Nothing - responseMsgSet - ) + (extractFirstPayload responseMsgSet) pure SegmentLoadStats { segmentLowerKeyBound = loadSegmentLowerBound loadResPl , segmentUpperKeyBound = upperIdBound From 13c5b385b1e5d36ce566d6b3bfc68accb3e2acf2 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 21 Sep 2020 22:14:33 +0200 Subject: [PATCH 18/38] make inclusion of HIE overlay conditional as well --- default.nix | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/default.nix b/default.nix index c6ef23a..126975a 100644 --- a/default.nix +++ b/default.nix @@ -14,14 +14,13 @@ let name = "nixpkgs-pinned"; url = https://github.com/NixOS/nixpkgs/; ref = "refs/heads/release-20.03"; - #rev = "de3780b937d2984f9b5e20d191f23be4f857b3aa"; rev = "faf5bdea5d9f0f9de26deaa7e864cdcd3b15b4e8"; }) { # Pass no config for purity config = {}; - overlays = [ + overlays = if withHIE then [ (import all-hies {}).overlay - ]; + ] else []; }; hp = pkgs.haskell.packages."${compiler}"; src = pkgs.nix-gitignore.gitignoreSource [] ./.; From 62da66aadedb4024d93841c797d401e854bfee81 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 22 Sep 2020 23:12:07 +0200 Subject: [PATCH 19/38] add runtime flag for enabling k-choices or not any value except "off" means on contributes to #2 --- app/Main.hs | 3 ++- src/Hash2Pub/FediChord.hs | 45 +++++++++++++++++++--------------- src/Hash2Pub/FediChordTypes.hs | 2 ++ 3 files changed, 29 insertions(+), 21 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index ed599f8..964748a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -26,7 +26,7 @@ main = do readConfig :: IO (FediChordConf, ServiceConf) readConfig = do - confDomainString : ipString : portString : servicePortString : speedupString : remainingArgs <- getArgs + confDomainString : ipString : portString : servicePortString : speedupString : loadBalancingEnabled : remainingArgs <- getArgs -- allow starting the initial node without bootstrapping info to avoid -- waiting for timeout let @@ -48,6 +48,7 @@ readConfig = do , confResponsePurgeAge = 60 / fromIntegral speedup , confRequestTimeout = 5 * 10^6 `div` speedup , confRequestRetries = 3 + , confEnableKChoices = loadBalancingEnabled /= "off" } sConf = ServiceConf { confSubscriptionExpiryTime = 24*3600 / fromIntegral speedup diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 9baf160..bab064d 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -120,27 +120,32 @@ fediChordInit initConf serviceRunner = do -- prepare for joining: start node cache writer thread -- currently no masking is necessary, as there is nothing to clean up nodeCacheWriterThread <- forkIO $ nodeCacheWriter realNodeSTM - -- TODO: k-choices way of joining, so far just initialise a single vserver - firstVS <- nodeStateInit realNodeSTM 0 - firstVSSTM <- newTVarIO firstVS - -- add vserver to list at RealNode - atomically . modifyTVar' realNodeSTM $ \rn -> rn { vservers = HMap.insert (getNid firstVS) firstVSSTM (vservers rn) } - -- try joining the DHT using one of the provided bootstrapping nodes - joinedState <- tryBootstrapJoining firstVSSTM - fediThreadsAsync <- either (\err -> do - -- handle unsuccessful join + fediThreadsAsync <- if confEnableKChoices initConf + then + -- TODO: k-choices way of joining + async (fediMainThreads serverSock realNodeSTM) + else do + -- without k-choices, just initialise a single vserver + firstVS <- nodeStateInit realNodeSTM 0 + firstVSSTM <- newTVarIO firstVS + -- add vserver to list at RealNode + atomically . modifyTVar' realNodeSTM $ \rn -> rn { vservers = HMap.insert (getNid firstVS) firstVSSTM (vservers rn) } + -- try joining the DHT using one of the provided bootstrapping nodes + joinedState <- tryBootstrapJoining firstVSSTM - putStrLn $ err <> " Error joining, start listening for incoming requests anyways" - -- launch thread attempting to join on new cache entries - _ <- forkIO $ joinOnNewEntriesThread firstVSSTM - async (fediMainThreads serverSock realNodeSTM) - ) - (\joinedNS -> do - -- launch main eventloop with successfully joined state - putStrLn "successful join" - async (fediMainThreads serverSock realNodeSTM) - ) - joinedState + either (\err -> do + -- handle unsuccessful join + putStrLn $ err <> " Error joining, start listening for incoming requests anyways" + -- launch thread attempting to join on new cache entries + _ <- forkIO $ joinOnNewEntriesThread firstVSSTM + async (fediMainThreads serverSock realNodeSTM) + ) + (\joinedNS -> do + -- launch main eventloop with successfully joined state + putStrLn "successful join" + async (fediMainThreads serverSock realNodeSTM) + ) + joinedState pure (fediThreadsAsync, realNodeSTM) -- | initialises the 'NodeState' for this local node. diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 04396d6..d8b9ce2 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -436,6 +436,8 @@ data FediChordConf = FediChordConf -- ^ how long to wait until response has arrived, in milliseconds , confRequestRetries :: Int -- ^ how often re-sending a timed-out request can be retried + , confEnableKChoices :: Bool + -- ^ whether to enable k-choices load balancing } deriving (Show, Eq) From 3b6d129bfc34190c8b2d76702a3b6a6780df84cf Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 25 Sep 2020 00:42:41 +0200 Subject: [PATCH 20/38] implement k-choices join functions large commit, contains a number of things: - k-choices #2 cost calculation - k-choices parameters - adjusting ASN.1 network messages to contain all values required for cost calculation #71 - adjusting stats to contain required values - k-choices node and vserver join functions - placeholder/ dummy invocation of k-choices join --- FediChord.asn1 | 1 + app/Main.hs | 3 + src/Hash2Pub/ASN1Coding.hs | 3 + src/Hash2Pub/DHTProtocol.hs | 19 +++-- src/Hash2Pub/FediChord.hs | 138 ++++++++++++++++++++++++++++++++- src/Hash2Pub/FediChordTypes.hs | 43 +++++++--- src/Hash2Pub/PostService.hs | 5 +- src/Hash2Pub/ProtocolTypes.hs | 1 + 8 files changed, 190 insertions(+), 23 deletions(-) diff --git a/FediChord.asn1 b/FediChord.asn1 index f978151..eafd303 100644 --- a/FediChord.asn1 +++ b/FediChord.asn1 @@ -111,6 +111,7 @@ LoadRequestPayload ::= SEQUENCE { LoadResponsePayload ::= SEQUENCE { loadSum REAL, remainingLoadTarget REAL, + totalCapacity REAL, lowerBound NodeID } diff --git a/app/Main.hs b/app/Main.hs index 964748a..24d66a9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -49,6 +49,9 @@ readConfig = do , confRequestTimeout = 5 * 10^6 `div` speedup , confRequestRetries = 3 , confEnableKChoices = loadBalancingEnabled /= "off" + , confKChoicesOverload = 0.9 + , confKChoicesUnderload = 0.1 + , confKChoicesMaxVS = 8 } sConf = ServiceConf { confSubscriptionExpiryTime = 24*3600 / fromIntegral speedup diff --git a/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs index 7701097..c2a5cc4 100644 --- a/src/Hash2Pub/ASN1Coding.hs +++ b/src/Hash2Pub/ASN1Coding.hs @@ -193,6 +193,7 @@ encodePayload payload'@LoadResponsePayload{} = [ Start Sequence , Real $ loadSum payload' , Real $ loadRemainingTarget payload' + , Real $ loadTotalCapacity payload' , IntVal . getNodeID $ loadSegmentLowerBound payload' , End Sequence ] @@ -472,10 +473,12 @@ parseLoadResponsePayload :: ParseASN1 ActionPayload parseLoadResponsePayload = onNextContainer Sequence $ do loadSum' <- parseReal loadRemainingTarget' <- parseReal + loadTotalCapacity' <- parseReal loadSegmentLowerBound' <- fromInteger <$> parseInteger pure LoadResponsePayload { loadSum = loadSum' , loadRemainingTarget = loadRemainingTarget' + , loadTotalCapacity = loadTotalCapacity' , loadSegmentLowerBound = loadSegmentLowerBound' } diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index c3cc858..1682e16 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -93,6 +93,7 @@ import Hash2Pub.FediChordTypes (CacheEntry (..), getKeyID, localCompare, rMapFromList, rMapLookupPred, rMapLookupSucc, + remainingLoadTarget, setPredecessors, setSuccessors) import Hash2Pub.ProtocolTypes import Hash2Pub.RingMap @@ -292,7 +293,7 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do -- only when joined Leave -> if isJoined ns then dropSpoofedIDs sourceIP nsSTM msgSet respondLeave else pure Nothing Stabilise -> if isJoined ns then dropSpoofedIDs sourceIP nsSTM msgSet respondStabilise else pure Nothing - QueryLoad -> if isJoined ns then Just <$> respondLoadQuery nsSTM msgSet else pure Nothing + QueryLoad -> if isJoined ns then Just <$> respondQueryLoad nsSTM msgSet else pure Nothing ) -- for single part request, response starts with part number 1. For multipart requests, response starts with part number n+1. @@ -433,8 +434,8 @@ respondPing nsSTM msgSet = do } pure $ serialiseMessage sendMessageSize pingResponse -respondLoadQuery :: Service s (RealNodeSTM s) => LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString) -respondLoadQuery nsSTM msgSet = do +respondQueryLoad :: Service s (RealNodeSTM s) => LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString) +respondQueryLoad nsSTM msgSet = do nsSnap <- readTVarIO nsSTM -- this message cannot be split reasonably, so just -- consider the first payload @@ -444,14 +445,18 @@ respondLoadQuery nsSTM msgSet = do responsePl <- maybe (pure Nothing) (\pl -> case pl of LoadRequestPayload{} -> do - serv <- nodeService <$> readTVarIO (parentRealNode nsSnap) + parentNode <- readTVarIO (parentRealNode nsSnap) + let + serv = nodeService parentNode + conf = nodeConfig parentNode lStats <- getServiceLoadStats serv let directSucc = getNid . head . predecessors $ nsSnap handledTagSum = sum . takeRMapSuccessorsFromTo directSucc (loadSegmentUpperBound pl) $ loadPerTag lStats pure $ Just LoadResponsePayload { loadSum = handledTagSum - , loadRemainingTarget = remainingLoadTarget lStats + , loadRemainingTarget = remainingLoadTarget conf lStats + , loadTotalCapacity = totalCapacity lStats , loadSegmentLowerBound = directSucc } _ -> pure Nothing @@ -808,7 +813,9 @@ requestQueryLoad ns upperIdBound target = do { segmentLowerKeyBound = loadSegmentLowerBound loadResPl , segmentUpperKeyBound = upperIdBound , segmentLoad = loadSum loadResPl - , segmentOwnerLoadTarget = loadRemainingTarget loadResPl + , segmentOwnerRemainingLoadTarget = loadRemainingTarget loadResPl + , segmentOwnerCapacity = loadTotalCapacity loadResPl + , segmentCurrentOwner = target } diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index bab064d..c5836c0 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -63,6 +63,7 @@ import Control.Exception import Control.Monad (forM_, forever) import Control.Monad.Except import Crypto.Hash +import Data.Bifunctor (first) import qualified Data.ByteArray as BA import qualified Data.ByteString as BS import qualified Data.ByteString.UTF8 as BSU @@ -71,9 +72,11 @@ import Data.Foldable (foldr') import Data.Functor.Identity import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HSet import Data.IP (IPv6, fromHostAddress6, toHostAddress6) -import Data.List ((\\)) +import Data.List (sortBy, sortOn, (\\)) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, isNothing, mapMaybe) @@ -123,7 +126,9 @@ fediChordInit initConf serviceRunner = do fediThreadsAsync <- if confEnableKChoices initConf then -- TODO: k-choices way of joining - async (fediMainThreads serverSock realNodeSTM) + -- placeholder + runExceptT (kChoicesNodeJoin realNodeSTM ("foo", fromIntegral 3)) + >> async (fediMainThreads serverSock realNodeSTM) else do -- without k-choices, just initialise a single vserver firstVS <- nodeStateInit realNodeSTM 0 @@ -148,6 +153,23 @@ fediChordInit initConf serviceRunner = do joinedState pure (fediThreadsAsync, realNodeSTM) + +-- | Create a new vserver and join it through a provided remote node. +-- TODO: Many fediChord* functions already cover parts of this, refactor these to use +-- this function. +fediChordJoinNewVs :: (MonadError String m, MonadIO m, Service s (RealNodeSTM s)) + => RealNodeSTM s -- ^ parent real node + -> Integer -- ^ vserver ID + -> RemoteNodeState -- ^ target node to join on + -> m (NodeID, LocalNodeStateSTM s) -- ^ on success: (vserver ID, TVar of vserver) +fediChordJoinNewVs nodeSTM vsId target = do + newVs <- liftIO $ nodeStateInit nodeSTM vsId + newVsSTM <- liftIO $ newTVarIO newVs + liftIO . putStrLn $ "Trying to join on " <> show (getNid target) + liftIO $ putStrLn "send a Join" + _ <- liftIO . requestJoin target $ newVsSTM + pure (getNid newVs, newVsSTM) + -- | initialises the 'NodeState' for this local node. -- Separated from 'fediChordInit' to be usable in tests. nodeStateInit :: Service s (RealNodeSTM s) => RealNodeSTM s -> Integer -> IO (LocalNodeState s) @@ -178,6 +200,114 @@ nodeStateInit realNodeSTM vsID' = do } pure initialState + +kChoicesNodeJoin :: (MonadError String m, MonadIO m, Service s (RealNodeSTM s)) + => RealNodeSTM s + -> (String, PortNumber) -- ^ domain and port of a bootstrapping node + -> m () +kChoicesNodeJoin nodeSTM bootstrapNode = do + node <- liftIO $ readTVarIO nodeSTM + -- use vserver 0 as origin of bootstrapping messages + vs0 <- liftIO $ nodeStateInit nodeSTM 0 + vs0STM <- liftIO $ newTVarIO vs0 + + ownLoadStats <- liftIO . getServiceLoadStats . nodeService $ node + let + conf = nodeConfig node + -- T_a of k-choices + -- compute load target + joinLoadTarget = totalCapacity ownLoadStats * (confKChoicesUnderload conf + confKChoicesOverload conf) / 2 + initialJoins = confKChoicesMaxVS conf `div` 2 + -- edge case: however small the target is, at least join 1 vs + -- kCoicesVsJoin until target is met + joinedVss <- vsJoins vs0STM (totalCapacity ownLoadStats) (vservers node) joinLoadTarget (fromIntegral initialJoins) nodeSTM + liftIO . atomically . modifyTVar' nodeSTM $ \node' -> node' + { vservers = HMap.union (vservers node') joinedVss } + pure () + + where + vsJoins :: (MonadError String m, MonadIO m, Service s (RealNodeSTM s)) + => LocalNodeStateSTM s -> Double -> VSMap s -> Double -> Int -> RealNodeSTM s -> m (VSMap s) + vsJoins _ _ vsmap _ 0 _ = pure vsmap + vsJoins queryVsSTM capacity vsmap remainingTargetLoad remainingJoins nodeSTM' + | remainingTargetLoad <= 0 = pure vsmap + | otherwise = (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' + ) + -- TODO: decide on whether and how to catch errors + -- error cause 1: not a single queried node has responded -> indicates permanent failure + -- error cause 2: only a certain join failed, just ignore that join target for now, but problem: it will be the chosen + -- target even at the next attempt again + -- `catchError` (const . + +kChoicesVsJoin :: (MonadError String m, MonadIO m, Service s (RealNodeSTM s)) + => LocalNodeStateSTM s -- ^ vserver to be used for querying + -> (String, PortNumber) -- ^ domain and port of a bootstrapping node + -> Double -- ^ own capacity + -> VSMap s -- ^ currently active VServers + -> RealNodeSTM s -- ^ parent node is needed for initialising a new vserver + -> Double -- ^ remaining load target + -> m (Double, (NodeID, LocalNodeStateSTM s)) -- ^ on success return tuple of acquired load and newly acquired vserver +kChoicesVsJoin queryVsSTM bootstrapNode capacity activeVss nodeSTM remainingTarget = do + 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) (fromInteger v), v) | v <- [0..confKChoicesMaxVS conf]] + queryVs <- liftIO $ readTVarIO queryVsSTM + + -- query load of all possible segments + -- simplification: treat each load lookup failure as a general unavailability of that segment + -- TODO: retries for transient failures + segmentLoads <- fmap catMaybes . forM nonJoinedIDs $ (\(vsNid, vsId) -> (do + lookupResp <- liftIO $ bootstrapQueryId queryVsSTM bootstrapNode vsNid + currentlyResponsible <- liftEither lookupResp + segment <- requestQueryLoad queryVs vsNid currentlyResponsible + pure $ Just (segment, vsId, currentlyResponsible) + -- store segment stats and vserver ID together, so it's clear + -- which vs needs to be joined to acquire this segment + ) `catchError` const (pure Nothing) + ) + + + -- cost calculation and sort by cost + -- edge case: no possible ID has responded + (mincost, vsId, toJoinOn) <- maybe (throwError "received no load information") pure + . headMay + . sortOn (\(cost, _, _) -> cost) + . fmap (\(segment, vsId, toJoinOn) -> (kChoicesJoinCost remainingTarget capacity segment, vsId, toJoinOn)) + $ segmentLoads + -- join at min cost + joinedNode <- fediChordJoinNewVs nodeSTM vsId toJoinOn + pure (mincost, joinedNode) + + -- Possible optimisation: + -- Instead of sampling all join candidates again at each invocation, querying + -- all segment loads before the first join and trying to re-use these + -- load information can save round trips. + -- possible edge case: detect when joining a subsegment of one already owned + -- joining into own segments => When first joining into segment S1 and then + -- later joining into the subsegment S2, the + -- resulting load l(S1+S2) = l(S1) != l(S1) + l(S2) + -- => need to re-query the load of both S1 and S2 + -- possible edge case 2: taking multiple segments from the same owner + -- changes the remainingLoadTarget at each vsJoin. This target change + -- needs to be accounted for starting from the 2nd vsJoin. + +kChoicesJoinCost :: Double -- ^ own remaining load target + -> Double -- ^ own capacity + -> SegmentLoadStats + -> Double +kChoicesJoinCost remainingOwnLoad ownCap segment = + abs (segmentOwnerRemainingLoadTarget segment + segmentLoad segment) / segmentOwnerCapacity segment + + abs (remainingOwnLoad - segmentLoad segment) / ownCap + - abs (segmentOwnerRemainingLoadTarget segment) / segmentOwnerCapacity segment + -- | Join a new node into the DHT, using a provided bootstrap node as initial cache seed -- for resolving the new node's position. fediChordBootstrapJoin :: Service s (RealNodeSTM s) @@ -277,8 +407,7 @@ bootstrapQueryId nsSTM (bootstrapHost, bootstrapPort) targetID = do Just (FORWARD resultset) -> foldr' (addCacheEntryPure now) cacheAcc resultset ) initCache resp - currentlyResponsible <- runExceptT $ queryIdLookupLoop bootstrapCache ns 50 $ getNid ns - pure currentlyResponsible + runExceptT $ queryIdLookupLoop bootstrapCache ns 50 $ getNid ns -- | join a node to the DHT using the global node cache @@ -296,6 +425,7 @@ fediChordVserverJoin nsSTM = do joinResult <- liftIO $ requestJoin currentlyResponsible nsSTM liftEither joinResult + fediChordVserverLeave :: (MonadError String m, MonadIO m, Service s (RealNodeSTM s)) => LocalNodeState s -> m () fediChordVserverLeave ns = do -- TODO: deal with failure of all successors, e.g. by invoking a stabilise diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index d8b9ce2..2ddcaf2 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -18,8 +18,10 @@ module Hash2Pub.FediChordTypes , RemoteNodeState (..) , RealNode (..) , RealNodeSTM + , VSMap , LoadStats (..) , emptyLoadStats + , remainingLoadTarget , SegmentLoadStats (..) , setSuccessors , setPredecessors @@ -153,7 +155,7 @@ a `localCompare` b -- Also contains shared data and config values. -- TODO: more data structures for k-choices bookkeeping data RealNode s = RealNode - { vservers :: HashMap NodeID (LocalNodeStateSTM s) + { vservers :: VSMap s -- ^ map of all active VServer node IDs to their node state , nodeConfig :: FediChordConf -- ^ holds the initial configuration read at program start @@ -168,6 +170,8 @@ data RealNode s = RealNode , nodeService :: s (RealNodeSTM s) } + +type VSMap s = HashMap NodeID (LocalNodeStateSTM s) type RealNodeSTM s = TVar (RealNode s) -- | represents a node and all its important state @@ -438,30 +442,47 @@ data FediChordConf = FediChordConf -- ^ how often re-sending a timed-out request can be retried , confEnableKChoices :: Bool -- ^ whether to enable k-choices load balancing + , confKChoicesOverload :: Double + -- ^ fraction of capacity above which a node considers itself overloaded + , confKChoicesUnderload :: Double + -- ^ fraction of capacity below which a node considers itself underloaded + , confKChoicesMaxVS :: Integer + -- ^ upper limit of vserver index κ } deriving (Show, Eq) -- ====== k-choices load balancing types ====== data LoadStats = LoadStats - { loadPerTag :: RingMap NodeID Double + { loadPerTag :: RingMap NodeID Double -- ^ map of loads for each handled tag - , totalCapacity :: Double + , totalCapacity :: Double -- ^ total designated capacity of the service - , remainingLoadTarget :: Double - -- ^ current mismatch between actual load and target load/capacity + , compensatedLoadSum :: Double + -- ^ effective load reevant for load balancing after compensating for } deriving (Show, Eq) +-- | calculates the mismatch from the target load by taking into account the +-- underload and overload limits +remainingLoadTarget :: FediChordConf -> LoadStats -> Double +remainingLoadTarget conf lstats = targetLoad - compensatedLoadSum lstats + where + targetLoad = totalCapacity lstats * (confKChoicesUnderload conf + confKChoicesOverload conf) / 2 + data SegmentLoadStats = SegmentLoadStats - { segmentLowerKeyBound :: NodeID + { segmentLowerKeyBound :: NodeID -- ^ segment start key - , segmentUpperKeyBound :: NodeID + , segmentUpperKeyBound :: NodeID -- ^ segment end key - , segmentLoad :: Double + , segmentLoad :: Double -- ^ sum of load of all keys in the segment - , segmentOwnerLoadTarget :: Double - -- ^ remaining load target of the current segment handler + , segmentOwnerRemainingLoadTarget :: Double + -- ^ remaining load target of the current segment handler: + , segmentOwnerCapacity :: Double + -- ^ total capacity of the current segment handler node, used for normalisation + , segmentCurrentOwner :: RemoteNodeState + -- ^ the current owner of the segment that needs to be joined on } -- TODO: figure out a better way of initialising @@ -469,7 +490,7 @@ emptyLoadStats :: LoadStats emptyLoadStats = LoadStats { loadPerTag = emptyRMap , totalCapacity = 0 - , remainingLoadTarget = 0 + , compensatedLoadSum = 0 } -- ====== Service Types ============ diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs index a02d1d7..f1376e4 100644 --- a/src/Hash2Pub/PostService.hs +++ b/src/Hash2Pub/PostService.hs @@ -890,12 +890,13 @@ evaluateLoadStats currentStats currentSubscribers = do ) (0, emptyRMap) $ rMapToListWithKeys currentSubscribers - -- TODO: use underload and overload limits instead of capacity let remainingLoadTarget' = totalCapacity' - loadSum - postFetchRate currentStats pure LoadStats { loadPerTag = loadPerTag' , totalCapacity = totalCapacity' - , remainingLoadTarget = remainingLoadTarget' + -- load caused by post fetches cannot be influenced by re-balancing nodes, + -- but still reduces the totally available capacity + , compensatedLoadSum = loadSum + postFetchRate currentStats } diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index b5438fa..b5ce0a9 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -82,6 +82,7 @@ data ActionPayload = QueryIDRequestPayload | LoadResponsePayload { loadSum :: Double , loadRemainingTarget :: Double + , loadTotalCapacity :: Double , loadSegmentLowerBound :: NodeID } deriving (Show, Eq) From 7a87d86c32d5b6ea30b41453dd13d696ddb52984 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 25 Sep 2020 02:03:42 +0200 Subject: [PATCH 21/38] k-choices error handling: detect empty joins, finer fail granularity --- src/Hash2Pub/FediChord.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index c5836c0..ec970cb 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -221,7 +221,9 @@ kChoicesNodeJoin nodeSTM bootstrapNode = do -- edge case: however small the target is, at least join 1 vs -- kCoicesVsJoin until target is met joinedVss <- vsJoins vs0STM (totalCapacity ownLoadStats) (vservers node) joinLoadTarget (fromIntegral initialJoins) nodeSTM - liftIO . atomically . modifyTVar' nodeSTM $ \node' -> node' + if HMap.null joinedVss + then throwError "k-choices join unsuccessful, no vserver joined" + else liftIO . atomically . modifyTVar' nodeSTM $ \node' -> node' { vservers = HMap.union (vservers node') joinedVss } pure () @@ -231,13 +233,14 @@ kChoicesNodeJoin nodeSTM bootstrapNode = do vsJoins _ _ vsmap _ 0 _ = pure vsmap vsJoins queryVsSTM capacity vsmap remainingTargetLoad remainingJoins nodeSTM' | remainingTargetLoad <= 0 = pure vsmap - | otherwise = (do + | otherwise = 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' - ) - -- TODO: decide on whether and how to catch errors + -- on error, just reduce the amount of tries and retry + `catchError` (\e -> liftIO (putStrLn e) >> vsJoins queryVsSTM capacity vsmap remainingTargetLoad (pred remainingJoins) nodeSTM') + -- error cause 1: not a single queried node has responded -> indicates permanent failure -- error cause 2: only a certain join failed, just ignore that join target for now, but problem: it will be the chosen -- target even at the next attempt again @@ -284,6 +287,8 @@ kChoicesVsJoin queryVsSTM bootstrapNode capacity activeVss nodeSTM remainingTarg $ segmentLoads -- join at min cost joinedNode <- fediChordJoinNewVs nodeSTM vsId toJoinOn + -- idea: a single join failure shall not make the whole process fail + --`catchError` pure (mincost, joinedNode) -- Possible optimisation: From 1a0de55b8c6a8a9da4838866155c93d9a9cecbe7 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 25 Sep 2020 20:40:45 +0200 Subject: [PATCH 22/38] integrate k-choices into `tryBootstrapJoin` flow part of #2 --- src/Hash2Pub/FediChord.hs | 91 ++++++++++++++++++++------------------- 1 file changed, 46 insertions(+), 45 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index ec970cb..befa8ce 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -123,34 +123,21 @@ fediChordInit initConf serviceRunner = do -- prepare for joining: start node cache writer thread -- currently no masking is necessary, as there is nothing to clean up nodeCacheWriterThread <- forkIO $ nodeCacheWriter realNodeSTM - fediThreadsAsync <- if confEnableKChoices initConf - then - -- TODO: k-choices way of joining - -- placeholder - runExceptT (kChoicesNodeJoin realNodeSTM ("foo", fromIntegral 3)) - >> async (fediMainThreads serverSock realNodeSTM) - else do - -- without k-choices, just initialise a single vserver - firstVS <- nodeStateInit realNodeSTM 0 - firstVSSTM <- newTVarIO firstVS - -- add vserver to list at RealNode - atomically . modifyTVar' realNodeSTM $ \rn -> rn { vservers = HMap.insert (getNid firstVS) firstVSSTM (vservers rn) } - -- try joining the DHT using one of the provided bootstrapping nodes - joinedState <- tryBootstrapJoining firstVSSTM - - either (\err -> do - -- handle unsuccessful join - putStrLn $ err <> " Error joining, start listening for incoming requests anyways" - -- launch thread attempting to join on new cache entries - _ <- forkIO $ joinOnNewEntriesThread firstVSSTM - async (fediMainThreads serverSock realNodeSTM) - ) - (\joinedNS -> do - -- launch main eventloop with successfully joined state - putStrLn "successful join" - async (fediMainThreads serverSock realNodeSTM) - ) - joinedState + fediThreadsAsync <- do + either (\err -> do + -- handle unsuccessful join + putStrLn $ err <> " Error joining, start listening for incoming requests anyways" + -- launch thread attempting to join on new cache entries + -- TODO: adjust joinOnNewEntriesThread to k-choices + --_ <- forkIO $ joinOnNewEntriesThread firstVSSTM + async (fediMainThreads serverSock realNodeSTM) + ) + (\_ -> do + -- launch main eventloop with successfully joined state + putStrLn "successful join" + async (fediMainThreads serverSock realNodeSTM) + ) + =<< tryBootstrapJoining realNodeSTM pure (fediThreadsAsync, realNodeSTM) @@ -318,7 +305,7 @@ kChoicesJoinCost remainingOwnLoad ownCap segment = fediChordBootstrapJoin :: Service s (RealNodeSTM s) => LocalNodeStateSTM s -- ^ the local 'NodeState' -> (String, PortNumber) -- ^ domain and port of a bootstrapping node - -> IO (Either String (LocalNodeStateSTM s)) -- ^ the joined 'NodeState' after a + -> IO (Either String ()) -- ^ the joined 'NodeState' after a -- successful join, otherwise an error message fediChordBootstrapJoin nsSTM bootstrapNode = do -- can be invoked multiple times with all known bootstrapping nodes until successfully joined @@ -330,10 +317,10 @@ fediChordBootstrapJoin nsSTM bootstrapNode = do liftIO . putStrLn $ "Trying to join on " <> show (getNid currentlyResponsible) -- 2. then send a join to the currently responsible node liftIO $ putStrLn "send a bootstrap Join" - joinResult <- liftIO $ requestJoin currentlyResponsible nsSTM - liftEither joinResult + _ <- liftEither =<< liftIO (requestJoin currentlyResponsible nsSTM) + pure () --- Periodically lookup own ID through a random bootstrapping node to discover and merge separated DHT clusters. +-- Periodically lookup own IDs through a random bootstrapping node to discover and merge separated DHT clusters. -- Unjoined try joining instead. convergenceSampleThread :: Service s (RealNodeSTM s) => RealNodeSTM s -> IO () convergenceSampleThread nodeSTM = forever $ do @@ -362,27 +349,41 @@ convergenceSampleThread nodeSTM = forever $ do else pure () ) >> pure () -- unjoined node: try joining through all bootstrapping nodes - else tryBootstrapJoining nsSTM >> pure () + else tryBootstrapJoining nodeSTM >> pure () let delaySecs = confBootstrapSamplingInterval . nodeConfig $ node threadDelay delaySecs -- | Try joining the DHT through any of the bootstrapping nodes until it succeeds. -tryBootstrapJoining :: Service s (RealNodeSTM s) => LocalNodeStateSTM s -> IO (Either String (LocalNodeStateSTM s)) -tryBootstrapJoining nsSTM = do - bss <- atomically $ do - nsSnap <- readTVar nsSTM - realNodeSnap <- readTVar $ parentRealNode nsSnap - pure $ bootstrapNodes realNodeSnap - tryJoining bss +tryBootstrapJoining :: Service s (RealNodeSTM s) => RealNodeSTM s -> IO (Either String ()) +tryBootstrapJoining nodeSTM = do + node <- readTVarIO nodeSTM + let + bss = bootstrapNodes node + conf = nodeConfig node + if confEnableKChoices conf + then tryJoining bss $ runExceptT . kChoicesNodeJoin nodeSTM + else do + firstVS <- nodeStateInit nodeSTM 0 + firstVSSTM <- newTVarIO firstVS + joinResult <- tryJoining bss (fediChordBootstrapJoin firstVSSTM) + either + (pure . Left) + (\_ -> fmap Right . atomically . modifyTVar' nodeSTM $ (\rn -> rn + { vservers = HMap.insert (getNid firstVS) firstVSSTM (vservers rn) } + ) + ) + (joinResult :: Either String ()) + where - tryJoining (bn:bns) = do - j <- fediChordBootstrapJoin nsSTM bn + tryJoining :: [(String, PortNumber)] -> ((String, PortNumber) -> IO (Either String ())) -> IO (Either String ()) + tryJoining (bn:bns) joinFunc = do + j <- joinFunc bn case j of - Left err -> putStrLn ("join error: " <> err) >> tryJoining bns - Right joined -> pure $ Right joined - tryJoining [] = pure $ Left "Exhausted all bootstrap points for joining." + Left err -> putStrLn ("join error: " <> err) >> tryJoining bns joinFunc + Right joined -> pure $ Right () + tryJoining [] _ = pure $ Left "Exhausted all bootstrap points for joining." -- | Look up a key just based on the responses of a single bootstrapping node. From 578cc362b907ae0d17f69508b57506a0091ea805 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 25 Sep 2020 22:33:29 +0200 Subject: [PATCH 23/38] fix tests --- test/FediChordSpec.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index 5130ab1..38bc9e9 100644 --- a/test/FediChordSpec.hs +++ b/test/FediChordSpec.hs @@ -7,6 +7,7 @@ import Control.Concurrent.STM.TVar import Control.Exception import Data.ASN1.Parse (runParseASN1) import qualified Data.ByteString as BS +import qualified Data.HashMap.Strict as HMap import qualified Data.Map.Strict as Map import Data.Maybe (fromJust, isJust) import qualified Data.Set as Set @@ -227,6 +228,7 @@ spec = do qLoadResPayload = LoadResponsePayload { loadSum = 3.141 , loadRemainingTarget = -1.337 + , loadTotalCapacity = 2.21 , loadSegmentLowerBound = 12 } @@ -238,7 +240,7 @@ spec = do , action = undefined , payload = undefined } - requestWith senderNode a pa = mkRequest senderNode 4545 a (Just pa) $ 2342 + requestWith senderNode a pa = mkRequest senderNode 4545 a (Just pa) 2342 responseWith a pa = responseTemplate {action = a, payload = Just pa} encodeDecodeAndCheck msg = runParseASN1 parseMessage (encodeMessage msg) `shouldBe` pure msg @@ -301,13 +303,13 @@ exampleNodeState = RemoteNodeState { exampleLocalNode :: IO (LocalNodeState MockService) exampleLocalNode = do - realNode <- newTVarIO $ RealNode { - vservers = [] + realNodeSTM <- newTVarIO $ RealNode { + vservers = HMap.empty , nodeConfig = exampleFediConf , bootstrapNodes = confBootstrapNodes exampleFediConf , nodeService = MockService } - nodeStateInit realNode + nodeStateInit realNodeSTM 0 exampleFediConf :: FediChordConf From 9a61c186e30dbaf3a97f80b975d62fd27169725e Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 26 Sep 2020 22:08:09 +0200 Subject: [PATCH 24/38] start restructuring joinOnNewEntries flow - overview comment on possible flow - cache query - doesn't compile yet --- src/Hash2Pub/FediChord.hs | 54 +++++++++++++++++++++++++--------- src/Hash2Pub/FediChordTypes.hs | 5 ++++ 2 files changed, 45 insertions(+), 14 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index befa8ce..685caea 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -127,9 +127,16 @@ fediChordInit initConf serviceRunner = do either (\err -> do -- handle unsuccessful join putStrLn $ err <> " Error joining, start listening for incoming requests anyways" + -- add an unjoined placeholder vserver to be able to listen for + -- incoming request + placeholderVS <- nodeStateInit realNodeSTM 0 + placeholderVSSTM <- newTVarIO placeholderVS + atomically . modifyTVar' realNodeSTM $ + addVserver (getNid placeholderVS, placeholderVSSTM) + -- TODO: on which bootstrap node vserver to join? (#77) -- launch thread attempting to join on new cache entries -- TODO: adjust joinOnNewEntriesThread to k-choices - --_ <- forkIO $ joinOnNewEntriesThread firstVSSTM + _ <- forkIO $ joinOnNewEntriesThread realNodeSTM async (fediMainThreads serverSock realNodeSTM) ) (\_ -> do @@ -370,9 +377,8 @@ tryBootstrapJoining nodeSTM = do joinResult <- tryJoining bss (fediChordBootstrapJoin firstVSSTM) either (pure . Left) - (\_ -> fmap Right . atomically . modifyTVar' nodeSTM $ (\rn -> rn - { vservers = HMap.insert (getNid firstVS) firstVSSTM (vservers rn) } - ) + (\_ -> fmap Right . atomically . modifyTVar' nodeSTM $ + addVserver (getNid firstVS, firstVSSTM) ) (joinResult :: Either String ()) @@ -473,24 +479,44 @@ fediChordVserverLeave ns = do -- | Wait for new cache entries to appear and then try joining on them. -- Exits after successful joining. -joinOnNewEntriesThread :: Service s (RealNodeSTM s) => LocalNodeStateSTM s -> IO () -joinOnNewEntriesThread nsSTM = loop +joinOnNewEntriesThread :: Service s (RealNodeSTM s) => RealNodeSTM s -> IO () +joinOnNewEntriesThread nodeSTM = loop where + -- situation 1: not joined yet -> vservers == empty + -- problem: empty vservers means not responding to incoming requests, so + -- another node cannot join on us an we not on them (as they're still + -- unjoined as well) + -- solution: on failure still join a dummy node, also add it as vserver + -- problem: once another node has joined on the dummy vserver, we shouldn't + -- just delete it again as it now relies on it as a neighbour + -- => either trigger a kChoicesNodeJoin with the flag that **not** at least one + -- single node needs to be joined (read vservers initially), or do an accelerated + -- periodic rebalance + -- TODO: document this approach in the docs loop = do - nsSnap <- readTVarIO nsSTM - (lookupResult, parentNode) <- atomically $ do - cache <- readTVar $ nodeCacheSTM nsSnap - parentNode <- readTVar $ parentRealNode nsSnap - case queryLocalCache nsSnap cache 1 (getNid nsSnap) of - -- empty cache, block until cache changes and then retry - (FORWARD s) | Set.null s -> retry - result -> pure (result, parentNode) + lookupResult <- atomically $ do + nodeSnap <- readTVar nodeSTM + case headMay (HMap.toList $ vservers nodeSnap) of + Nothing -> retry + Just vsSTM -> do + -- take any active vserver as heuristic for whether this node has + -- successfully joined: + -- If the node hasn't joined yet, only a single placeholder node + -- is active… + firstVS <- readTVar vsSTM + cache <- readTVar $ globalNodeCacheSTM nodeSnap + case queryLocalCache firstVS cache 1 (getNid firstVS) of + -- …which, having no neighbours, returns an empty forward list + -- -> block until cache changes and then retry + (FORWARD s) | Set.null s -> retry + result -> pure result case lookupResult of -- already joined FOUND _ -> pure () -- otherwise try joining FORWARD _ -> do + -- do normal join, but without bootstrap nodes joinResult <- runExceptT $ fediChordVserverJoin nsSTM either -- on join failure, sleep and retry diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 2ddcaf2..a20c156 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -22,6 +22,7 @@ module Hash2Pub.FediChordTypes , LoadStats (..) , emptyLoadStats , remainingLoadTarget + , addVserver , SegmentLoadStats (..) , setSuccessors , setPredecessors @@ -170,6 +171,10 @@ data RealNode s = RealNode , nodeService :: s (RealNodeSTM s) } +-- | 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) } type VSMap s = HashMap NodeID (LocalNodeStateSTM s) type RealNodeSTM s = TVar (RealNode s) From 21ecf9b0417878b52191f0f2dea2994f97f23c30 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sun, 27 Sep 2020 02:06:45 +0200 Subject: [PATCH 25/38] bootstrapQueryID: try all possible node IDs of a bootstrap node - closes #77 - when k-choices (#2) joining, try addressing each possible node ID of the bootstrap node until success - bugfix: include correct target ID of node that shall respond in QueryID requests --- src/Hash2Pub/DHTProtocol.hs | 11 ++--- src/Hash2Pub/FediChord.hs | 89 +++++++++++++++++++++++-------------- 2 files changed, 62 insertions(+), 38 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 1682e16..249ebef 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -649,14 +649,14 @@ sendQueryIdMessages :: (Integral i) -> Maybe i -- ^ optionally provide an explicit @l@ parameter of number of nodes to be returned -> [RemoteNodeState] -- ^ nodes to query -> IO QueryResponse -- ^ accumulated response -sendQueryIdMessages targetID ns lParam targets = do +sendQueryIdMessages lookupID ns lParam targets = do -- create connected sockets to all query targets and use them for request handling nodeConf <- nodeConfig <$> readTVarIO (parentRealNode ns) let srcAddr = confIP nodeConf queryThreads <- mapM (\resultNode -> async $ bracket (mkSendSocket srcAddr (getDomain resultNode) (getDhtPort resultNode)) close ( - sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (lookupMessage targetID ns Nothing) + sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (lookupMessage lookupID ns Nothing (getNid resultNode)) )) targets -- ToDo: process results immediately instead of waiting for the last one to finish, see https://stackoverflow.com/a/38815224/9198613 -- ToDo: exception handling, maybe log them @@ -689,13 +689,14 @@ sendQueryIdMessages targetID ns lParam targets = do -- | Create a QueryID message to be supplied to 'sendRequestTo' lookupMessage :: Integral i - => NodeID -- ^ target ID + => NodeID -- ^ lookup ID to be looked up -> LocalNodeState s -- ^ sender node state -> Maybe i -- ^ optionally provide a different l parameter + -> NodeID -- ^ target ID of message destination -> (Integer -> FediChordMessage) -lookupMessage targetID ns lParam = mkRequest ns targetID QueryID (Just $ pl ns targetID) +lookupMessage lookupID ns lParam targetID = mkRequest ns targetID QueryID (Just $ pl ns lookupID) where - pl ns' targetID' = QueryIDRequestPayload { queryTargetID = targetID', queryLBestNodes = maybe (fromIntegral $ lNumBestNodes ns) fromIntegral lParam } + pl ns' lookupID' = QueryIDRequestPayload { queryTargetID = lookupID', queryLBestNodes = maybe (fromIntegral $ lNumBestNodes ns') fromIntegral lParam } -- | Send a stabilise request to provided 'RemoteNode' and, if successful, diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 685caea..6c90b5d 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -123,7 +123,7 @@ fediChordInit initConf serviceRunner = do -- prepare for joining: start node cache writer thread -- currently no masking is necessary, as there is nothing to clean up nodeCacheWriterThread <- forkIO $ nodeCacheWriter realNodeSTM - fediThreadsAsync <- do + fediThreadsAsync <- either (\err -> do -- handle unsuccessful join putStrLn $ err <> " Error joining, start listening for incoming requests anyways" @@ -255,15 +255,14 @@ kChoicesVsJoin queryVsSTM bootstrapNode capacity activeVss nodeSTM remainingTarg 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) (fromInteger v), v) | v <- [0..confKChoicesMaxVS conf]] + nonJoinedIDs = filter (not . flip HSet.member activeVsSet . fst) [ (genNodeID (confIP conf) (confDomain conf) (fromInteger v), v) | v <- [0..pred (confKChoicesMaxVS conf)]] queryVs <- liftIO $ readTVarIO queryVsSTM -- query load of all possible segments -- simplification: treat each load lookup failure as a general unavailability of that segment -- TODO: retries for transient failures segmentLoads <- fmap catMaybes . forM nonJoinedIDs $ (\(vsNid, vsId) -> (do - lookupResp <- liftIO $ bootstrapQueryId queryVsSTM bootstrapNode vsNid - currentlyResponsible <- liftEither lookupResp + currentlyResponsible <- bootstrapQueryId queryVsSTM bootstrapNode vsNid segment <- requestQueryLoad queryVs vsNid currentlyResponsible pure $ Just (segment, vsId, currentlyResponsible) -- store segment stats and vserver ID together, so it's clear @@ -319,8 +318,7 @@ fediChordBootstrapJoin nsSTM bootstrapNode = do ns <- readTVarIO nsSTM runExceptT $ do -- 1. get routed to the currently responsible node - lookupResp <- liftIO $ bootstrapQueryId nsSTM bootstrapNode $ getNid ns - currentlyResponsible <- liftEither lookupResp + currentlyResponsible <- bootstrapQueryId nsSTM bootstrapNode $ getNid ns liftIO . putStrLn $ "Trying to join on " <> show (getNid currentlyResponsible) -- 2. then send a join to the currently responsible node liftIO $ putStrLn "send a bootstrap Join" @@ -342,8 +340,7 @@ convergenceSampleThread nodeSTM = forever $ do let bss = bootstrapNodes parentNode randIndex <- liftIO $ randomRIO (0, length bss - 1) chosenNode <- maybe (throwError "invalid bootstrapping node index") pure $ atMay bss randIndex - lookupResult <- liftIO $ bootstrapQueryId nsSTM chosenNode (getNid nsSnap) - currentlyResponsible <- liftEither lookupResult + currentlyResponsible <- bootstrapQueryId nsSTM chosenNode (getNid nsSnap) if getNid currentlyResponsible /= getNid nsSnap -- if mismatch, stabilise on the result, else do nothing then do @@ -393,34 +390,60 @@ tryBootstrapJoining nodeSTM = do -- | Look up a key just based on the responses of a single bootstrapping node. -bootstrapQueryId :: LocalNodeStateSTM s -> (String, PortNumber) -> NodeID -> IO (Either String RemoteNodeState) +bootstrapQueryId :: (MonadError String m, MonadIO m, Service s (RealNodeSTM s)) + => LocalNodeStateSTM s + -> (String, PortNumber) + -> NodeID + -> m RemoteNodeState bootstrapQueryId nsSTM (bootstrapHost, bootstrapPort) targetID = do - ns <- readTVarIO nsSTM - nodeConf <- nodeConfig <$> readTVarIO (parentRealNode ns) + ns <- liftIO $ readTVarIO nsSTM + nodeConf <- nodeConfig <$> liftIO (readTVarIO $ parentRealNode ns) let srcAddr = confIP nodeConf - bootstrapResponse <- bracket (mkSendSocket srcAddr bootstrapHost bootstrapPort) close ( - -- Initialise an empty cache only with the responses from a bootstrapping node - fmap Right . sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (lookupMessage targetID ns Nothing) - ) - `catch` (\e -> pure . Left $ "Error at bootstrap QueryId: " <> displayException (e :: IOException)) - - case bootstrapResponse of - Left err -> pure $ Left err - Right resp - | resp == Set.empty -> pure . Left $ "Bootstrapping node " <> show bootstrapHost <> " gave no response." - | otherwise -> do - now <- getPOSIXTime - -- create new cache with all returned node responses - let bootstrapCache = - -- traverse response parts - foldr' (\resp cacheAcc -> case queryResult <$> payload resp of - Nothing -> cacheAcc - Just (FOUND result1) -> addCacheEntryPure now (RemoteCacheEntry result1 now) cacheAcc - Just (FORWARD resultset) -> foldr' (addCacheEntryPure now) cacheAcc resultset - ) - initCache resp - runExceptT $ queryIdLookupLoop bootstrapCache ns 50 $ getNid ns + -- IP address needed for ID generation, so look it up + bootstrapAddr <- addrAddress <$> liftIO (resolve (Just bootstrapHost) (Just bootstrapPort)) + bootstrapIP <- case bootstrapAddr of + SockAddrInet6 _ _ bootstrapIP _ -> pure bootstrapIP + _ -> throwError $ "Expected an IPv6 address, but got " <> show bootstrapAddr + let possibleJoinIDs = + [ genNodeID bootstrapIP bootstrapHost (fromInteger v) | v <- [0..pred ( + if confEnableKChoices nodeConf then confKChoicesMaxVS nodeConf else 1)]] + tryQuery ns srcAddr nodeConf possibleJoinIDs + where + -- | try bootstrapping a query through any possible ID of the + -- given bootstrap node + tryQuery :: (MonadError String m, MonadIO m) + => LocalNodeState s + -> HostAddress6 + -> FediChordConf + -> [NodeID] + -> m RemoteNodeState + tryQuery _ _ _ [] = throwError $ "No ID of " <> show bootstrapHost <> " has responded." + tryQuery ns srcAddr nodeConf (bnid:bnids) = (do + bootstrapResponse <- liftIO $ bracket (mkSendSocket srcAddr bootstrapHost bootstrapPort) close ( + -- Initialise an empty cache only with the responses from a bootstrapping node + fmap Right . sendRequestTo (confRequestTimeout nodeConf) (confRequestRetries nodeConf) (lookupMessage targetID ns Nothing bnid) + ) + `catch` (\e -> pure . Left $ "Error at bootstrap QueryId: " <> displayException (e :: IOException)) + case bootstrapResponse of + Left err -> throwError err + Right resp + | resp == Set.empty -> throwError $ "Bootstrapping node " <> show bootstrapHost <> " gave no response." + | otherwise -> do + now <- liftIO getPOSIXTime + -- create new cache with all returned node responses + let bootstrapCache = + -- traverse response parts + foldr' (\resp' cacheAcc -> case queryResult <$> payload resp' of + Nothing -> cacheAcc + Just (FOUND result1) -> addCacheEntryPure now (RemoteCacheEntry result1 now) cacheAcc + Just (FORWARD resultset) -> foldr' (addCacheEntryPure now) cacheAcc resultset + ) + initCache resp + queryIdLookupLoop bootstrapCache ns 50 $ getNid ns + ) `catchError` (\_ -> + -- only throw an error if all IDs have been tried + tryQuery ns srcAddr nodeConf bnids) -- | join a node to the DHT using the global node cache -- node's position. From 0ee8f0dc43ace1173d18095c0f99f20131d43cfa Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 28 Sep 2020 00:55:45 +0200 Subject: [PATCH 26/38] adjust joinOnNewEntreisThread to k-choices join --- src/Hash2Pub/FediChord.hs | 46 ++++++++++++++++++++++++--------------- 1 file changed, 28 insertions(+), 18 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 6c90b5d..e8a3260 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -133,9 +133,7 @@ fediChordInit initConf serviceRunner = do placeholderVSSTM <- newTVarIO placeholderVS atomically . modifyTVar' realNodeSTM $ addVserver (getNid placeholderVS, placeholderVSSTM) - -- TODO: on which bootstrap node vserver to join? (#77) -- launch thread attempting to join on new cache entries - -- TODO: adjust joinOnNewEntriesThread to k-choices _ <- forkIO $ joinOnNewEntriesThread realNodeSTM async (fediMainThreads serverSock realNodeSTM) ) @@ -195,9 +193,12 @@ nodeStateInit realNodeSTM vsID' = do pure initialState +-- | Joins a 'RealNode' to the DHT by joining several vservers, trying to match +-- the own load target best. +-- Triggers 'kChoicesVsJoin' kChoicesNodeJoin :: (MonadError String m, MonadIO m, Service s (RealNodeSTM s)) => RealNodeSTM s - -> (String, PortNumber) -- ^ domain and port of a bootstrapping node + -> Maybe (String, PortNumber) -- ^ domain and port of a bootstrapping node, if bootstrap joining -> m () kChoicesNodeJoin nodeSTM bootstrapNode = do node <- liftIO $ readTVarIO nodeSTM @@ -213,13 +214,14 @@ kChoicesNodeJoin nodeSTM bootstrapNode = do joinLoadTarget = totalCapacity ownLoadStats * (confKChoicesUnderload conf + confKChoicesOverload conf) / 2 initialJoins = confKChoicesMaxVS conf `div` 2 -- edge case: however small the target is, at least join 1 vs - -- kCoicesVsJoin until target is met - joinedVss <- vsJoins vs0STM (totalCapacity ownLoadStats) (vservers node) joinLoadTarget (fromIntegral initialJoins) nodeSTM - if HMap.null joinedVss - then throwError "k-choices join unsuccessful, no vserver joined" - else liftIO . atomically . modifyTVar' nodeSTM $ \node' -> node' - { vservers = HMap.union (vservers node') joinedVss } - pure () + -- kCoicesVsJoin until target is met – unless there's already an active & joined VS causing enough load + alreadyJoinedVss <- liftIO $ foldM (\sumAcc vsSTM -> readTVarIO vsSTM >>= (\vs -> pure . (+) sumAcc $ if isJoined 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 + then throwError "k-choices join unsuccessful, no vserver joined" + else liftIO . atomically . modifyTVar' nodeSTM $ \node' -> node' + { vservers = HMap.union (vservers node') joinedVss } where vsJoins :: (MonadError String m, MonadIO m, Service s (RealNodeSTM s)) @@ -242,7 +244,7 @@ kChoicesNodeJoin nodeSTM bootstrapNode = do kChoicesVsJoin :: (MonadError String m, MonadIO m, Service s (RealNodeSTM s)) => LocalNodeStateSTM s -- ^ vserver to be used for querying - -> (String, PortNumber) -- ^ domain and port of a bootstrapping node + -> Maybe (String, PortNumber) -- ^ domain and port of a bootstrapping node, if bootstrappinG -> Double -- ^ own capacity -> VSMap s -- ^ currently active VServers -> RealNodeSTM s -- ^ parent node is needed for initialising a new vserver @@ -262,7 +264,11 @@ kChoicesVsJoin queryVsSTM bootstrapNode capacity activeVss nodeSTM remainingTarg -- simplification: treat each load lookup failure as a general unavailability of that segment -- TODO: retries for transient failures segmentLoads <- fmap catMaybes . forM nonJoinedIDs $ (\(vsNid, vsId) -> (do - currentlyResponsible <- bootstrapQueryId queryVsSTM bootstrapNode vsNid + -- if bootstrap node is provided, do initial lookup via that + currentlyResponsible <- maybe + (requestQueryID queryVs vsNid) + (\bs -> bootstrapQueryId queryVsSTM bs vsNid) + bootstrapNode segment <- requestQueryLoad queryVs vsNid currentlyResponsible pure $ Just (segment, vsId, currentlyResponsible) -- store segment stats and vserver ID together, so it's clear @@ -367,7 +373,7 @@ tryBootstrapJoining nodeSTM = do bss = bootstrapNodes node conf = nodeConfig node if confEnableKChoices conf - then tryJoining bss $ runExceptT . kChoicesNodeJoin nodeSTM + then tryJoining bss $ runExceptT . kChoicesNodeJoin nodeSTM . Just else do firstVS <- nodeStateInit nodeSTM 0 firstVSSTM <- newTVarIO firstVS @@ -517,9 +523,10 @@ joinOnNewEntriesThread nodeSTM = loop -- periodic rebalance -- TODO: document this approach in the docs loop = do - lookupResult <- atomically $ do + (lookupResult, conf, firstVSSTM) <- atomically $ do nodeSnap <- readTVar nodeSTM - case headMay (HMap.toList $ vservers nodeSnap) of + let conf = nodeConfig nodeSnap + case headMay (HMap.elems $ vservers nodeSnap) of Nothing -> retry Just vsSTM -> do -- take any active vserver as heuristic for whether this node has @@ -532,7 +539,7 @@ joinOnNewEntriesThread nodeSTM = loop -- …which, having no neighbours, returns an empty forward list -- -> block until cache changes and then retry (FORWARD s) | Set.null s -> retry - result -> pure result + result -> pure (result, conf, vsSTM) case lookupResult of -- already joined FOUND _ -> @@ -540,10 +547,13 @@ joinOnNewEntriesThread nodeSTM = loop -- otherwise try joining FORWARD _ -> do -- do normal join, but without bootstrap nodes - joinResult <- runExceptT $ fediChordVserverJoin nsSTM + joinResult <- if confEnableKChoices conf + then runExceptT $ kChoicesNodeJoin nodeSTM Nothing + else runExceptT $ fediChordVserverJoin firstVSSTM + >> pure () either -- on join failure, sleep and retry - (const $ threadDelay (confJoinAttemptsInterval . nodeConfig $ parentNode) >> loop) + (const $ threadDelay (confJoinAttemptsInterval conf) >> loop) (const $ pure ()) joinResult From c208aeceaac66892bc3d4878527fa3d827cd6adb Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 29 Sep 2020 00:45:15 +0200 Subject: [PATCH 27/38] rename `isJoined` to reflect its scope on a single VS This should be enough to close #76, as it was only used in the scope of a single LocalNodeState anyways. --- src/Hash2Pub/DHTProtocol.hs | 18 +++++++++--------- src/Hash2Pub/FediChord.hs | 6 +++--- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 249ebef..a51b117 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -38,7 +38,7 @@ module Hash2Pub.DHTProtocol , isPossibleSuccessor , isPossiblePredecessor , isInOwnResponsibilitySlice - , isJoined + , vsIsJoined , closestCachePredecessors ) where @@ -109,7 +109,7 @@ queryLocalCache ownState nCache lBestNodes targetID -- as target ID falls between own ID and first predecessor, it is handled by this node -- This only makes sense if the node is part of the DHT by having joined. -- A default answer to nodes querying an unjoined node is provided by 'respondQueryID'. - | isJoined ownState && targetID `isInOwnResponsibilitySlice` ownState = FOUND . toRemoteNodeState $ ownState + | vsIsJoined ownState && targetID `isInOwnResponsibilitySlice` ownState = FOUND . toRemoteNodeState $ ownState -- my interpretation: the "l best next hops" are the l-1 closest preceding nodes and -- the closest succeeding node (like with the p initiated parallel queries | otherwise = FORWARD $ closestSuccessor `Set.union` closestCachePredecessors (lBestNodes-1) targetID nCache @@ -233,8 +233,8 @@ markCacheEntryAsVerified timestamp nid = RingMap . Map.adjust adjustFunc nid . g -- | uses the successor and predecessor list of a node as an indicator for whether a -- node has properly joined the DHT -isJoined :: LocalNodeState s -> Bool -isJoined ns = not . all null $ [successors ns, predecessors ns] +vsIsJoined :: LocalNodeState s -> Bool +vsIsJoined ns = not . all null $ [successors ns, predecessors ns] -- | the size limit to be used when serialising messages for sending sendMessageSize :: Num i => i @@ -291,9 +291,9 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do -- ToDo: figure out what happens if not joined QueryID -> Just <$> respondQueryID nsSTM msgSet -- only when joined - Leave -> if isJoined ns then dropSpoofedIDs sourceIP nsSTM msgSet respondLeave else pure Nothing - Stabilise -> if isJoined ns then dropSpoofedIDs sourceIP nsSTM msgSet respondStabilise else pure Nothing - QueryLoad -> if isJoined ns then Just <$> respondQueryLoad nsSTM msgSet else pure Nothing + Leave -> if vsIsJoined ns then dropSpoofedIDs sourceIP nsSTM msgSet respondLeave else pure Nothing + Stabilise -> if vsIsJoined ns then dropSpoofedIDs sourceIP nsSTM msgSet respondStabilise else pure Nothing + QueryLoad -> if vsIsJoined ns then Just <$> respondQueryLoad nsSTM msgSet else pure Nothing ) -- for single part request, response starts with part number 1. For multipart requests, response starts with part number n+1. @@ -341,7 +341,7 @@ respondQueryID nsSTM msgSet = do cache <- readTVar $ nodeCacheSTM nsSnap let responsePayload = QueryIDResponsePayload { - queryResult = if isJoined nsSnap + queryResult = if vsIsJoined nsSnap then queryLocalCache nsSnap cache (fromIntegral $ queryLBestNodes senderPayload') (queryTargetID senderPayload') -- if not joined yet, attract responsibility for -- all keys to make bootstrapping possible @@ -487,7 +487,7 @@ respondJoin nsSTM msgSet = do senderNS = sender aRequestPart -- if not joined yet, attract responsibility for -- all keys to make bootstrapping possible - responsibilityLookup = if isJoined nsSnap then queryLocalCache nsSnap cache 1 (getNid senderNS) else FOUND (toRemoteNodeState nsSnap) + responsibilityLookup = if vsIsJoined nsSnap then queryLocalCache nsSnap cache 1 (getNid senderNS) else FOUND (toRemoteNodeState nsSnap) thisNodeResponsible (FOUND _) = True thisNodeResponsible (FORWARD _) = False -- check whether the joining node falls into our responsibility diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index e8a3260..d4a94a6 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -215,7 +215,7 @@ kChoicesNodeJoin nodeSTM bootstrapNode = do initialJoins = confKChoicesMaxVS conf `div` 2 -- edge case: however small the target is, at least join 1 vs -- kCoicesVsJoin until target is met – unless there's already an active & joined VS causing enough load - alreadyJoinedVss <- liftIO $ foldM (\sumAcc vsSTM -> readTVarIO vsSTM >>= (\vs -> pure . (+) sumAcc $ if isJoined vs then 1 else 0)) 0 $ vservers node + 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 @@ -339,7 +339,7 @@ convergenceSampleThread nodeSTM = forever $ do forM_ (vservers node) $ \nsSTM -> do nsSnap <- readTVarIO nsSTM parentNode <- readTVarIO $ parentRealNode nsSnap - if isJoined nsSnap + if vsIsJoined nsSnap then runExceptT (do -- joined node: choose random node, do queryIDLoop, compare result with own responsibility @@ -647,7 +647,7 @@ checkCacheSliceInvariants :: LocalNodeState s -> [NodeID] -- ^ list of middle IDs of slices not -- ^ fulfilling the invariant checkCacheSliceInvariants ns - | isJoined ns = checkPredecessorSlice jEntries (getNid ns) startBound lastPred <> checkSuccessorSlice jEntries (getNid ns) startBound lastSucc + | vsIsJoined ns = checkPredecessorSlice jEntries (getNid ns) startBound lastPred <> checkSuccessorSlice jEntries (getNid ns) startBound lastSucc | otherwise = const [] where jEntries = jEntriesPerSlice ns From b2b4fe3dd816427901a607a14baf005afc5f2390 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 29 Sep 2020 02:06:31 +0200 Subject: [PATCH 28/38] change vserver ID representation type to Word8 - performance improvement: avoid unnecessary representation and conversion from/to Integer - part of hot path: with k-choices, all possible IDs are regularly generated and checked - preparation for #74 --- src/Hash2Pub/ASN1Coding.hs | 4 ++-- src/Hash2Pub/DHTProtocol.hs | 4 ++-- src/Hash2Pub/FediChord.hs | 10 +++++----- src/Hash2Pub/FediChordTypes.hs | 13 +++++++++---- 4 files changed, 18 insertions(+), 13 deletions(-) diff --git a/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs index c2a5cc4..65f5e21 100644 --- a/src/Hash2Pub/ASN1Coding.hs +++ b/src/Hash2Pub/ASN1Coding.hs @@ -206,7 +206,7 @@ encodeNodeState ns = [ , OctetString (ipAddrAsBS $ getIpAddr ns) , IntVal (toInteger . getDhtPort $ ns) , IntVal (toInteger . getServicePort $ ns) - , IntVal (getVServerID ns) + , IntVal (toInteger $ getVServerID ns) , End Sequence ] @@ -370,7 +370,7 @@ parseNodeState = onNextContainer Sequence $ do , domain = domain' , dhtPort = dhtPort' , servicePort = servicePort' - , vServerID = vServer' + , vServerID = fromInteger vServer' , ipAddr = ip' } diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index a51b117..3ad5747 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -313,7 +313,7 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do aRequestPart = Set.elemAt 0 msgSet senderNs = sender aRequestPart givenSenderID = getNid senderNs - recomputedID = genNodeID addr (getDomain senderNs) (fromInteger $ getVServerID senderNs) + recomputedID = genNodeID addr (getDomain senderNs) (getVServerID senderNs) in if recomputedID == givenSenderID then Just <$> responder nsSTM' msgSet' @@ -779,7 +779,7 @@ requestPing ns target = do -- recompute ID for each received node and mark as verified in cache now <- getPOSIXTime forM_ responseVss (\vs -> - let recomputedID = genNodeID peerAddr (getDomain vs) (fromInteger $ getVServerID vs) + let recomputedID = genNodeID peerAddr (getDomain vs) (getVServerID vs) in if recomputedID == getNid vs then atomically $ writeTQueue (cacheWriteQueue ns) $ addNodeAsVerifiedPure now vs else pure () diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index d4a94a6..1aea94e 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -151,7 +151,7 @@ fediChordInit initConf serviceRunner = do -- this function. fediChordJoinNewVs :: (MonadError String m, MonadIO m, Service s (RealNodeSTM s)) => RealNodeSTM s -- ^ parent real node - -> Integer -- ^ vserver ID + -> Word8 -- ^ vserver ID -> RemoteNodeState -- ^ target node to join on -> m (NodeID, LocalNodeStateSTM s) -- ^ on success: (vserver ID, TVar of vserver) fediChordJoinNewVs nodeSTM vsId target = do @@ -164,7 +164,7 @@ fediChordJoinNewVs nodeSTM vsId target = do -- | initialises the 'NodeState' for this local node. -- Separated from 'fediChordInit' to be usable in tests. -nodeStateInit :: Service s (RealNodeSTM s) => RealNodeSTM s -> Integer -> IO (LocalNodeState s) +nodeStateInit :: Service s (RealNodeSTM s) => RealNodeSTM s -> Word8 -> IO (LocalNodeState s) nodeStateInit realNodeSTM vsID' = do realNode <- readTVarIO realNodeSTM let @@ -173,7 +173,7 @@ nodeStateInit realNodeSTM vsID' = do containedState = RemoteNodeState { domain = confDomain conf , ipAddr = confIP conf - , nid = genNodeID (confIP conf) (confDomain conf) $ fromInteger vsID + , nid = genNodeID (confIP conf) (confDomain conf) vsID , dhtPort = toEnum $ confDhtPort conf , servicePort = getListeningPortFromService $ nodeService realNode , vServerID = vsID @@ -257,7 +257,7 @@ kChoicesVsJoin queryVsSTM bootstrapNode capacity activeVss nodeSTM remainingTarg 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) (fromInteger v), v) | v <- [0..pred (confKChoicesMaxVS conf)]] + nonJoinedIDs = filter (not . flip HSet.member activeVsSet . fst) [ (genNodeID (confIP conf) (confDomain conf) v, v) | v <- [0..pred (confKChoicesMaxVS conf)]] queryVs <- liftIO $ readTVarIO queryVsSTM -- query load of all possible segments @@ -411,7 +411,7 @@ bootstrapQueryId nsSTM (bootstrapHost, bootstrapPort) targetID = do SockAddrInet6 _ _ bootstrapIP _ -> pure bootstrapIP _ -> throwError $ "Expected an IPv6 address, but got " <> show bootstrapAddr let possibleJoinIDs = - [ genNodeID bootstrapIP bootstrapHost (fromInteger v) | v <- [0..pred ( + [ genNodeID bootstrapIP bootstrapHost v | v <- [0..pred ( if confEnableKChoices nodeConf then confKChoicesMaxVS nodeConf else 1)]] tryQuery ns srcAddr nodeConf possibleJoinIDs where diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index a20c156..0171177 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -190,7 +190,7 @@ data RemoteNodeState = RemoteNodeState -- ^ port of the DHT itself , servicePort :: PortNumber -- ^ port of the service provided on top of the DHT - , vServerID :: Integer + , vServerID :: Word8 -- ^ ID of this vserver } deriving (Show, Eq) @@ -235,14 +235,14 @@ class NodeState a where getIpAddr :: a -> HostAddress6 getDhtPort :: a -> PortNumber getServicePort :: a -> PortNumber - getVServerID :: a -> Integer + getVServerID :: a -> Word8 -- setters for common properties setNid :: NodeID -> a -> a setDomain :: String -> a -> a setIpAddr :: HostAddress6 -> a -> a setDhtPort :: PortNumber -> a -> a setServicePort :: PortNumber -> a -> a - setVServerID :: Integer -> a -> a + setVServerID :: Word8 -> a -> a toRemoteNodeState :: a -> RemoteNodeState instance NodeState RemoteNodeState where @@ -391,6 +391,11 @@ genNodeID :: HostAddress6 -- ^a node's IPv6 address -> NodeID -- ^the generated @NodeID@ genNodeID ip nodeDomain vs = NodeID . byteStringToUInteger $ genNodeIDBS ip nodeDomain vs + +isValidIdForNode :: Word8 -> RemoteNodeState -> HostAddress6 -> Bool +isValidIdForNode numVs rns addr = getNid rns `elem` [genNodeID addr (getDomain rns) v | v <- [0..(numVs-1)] ] + + -- | generates a 256 bit long key identifier, represented as ByteString, for looking up its data on the DHT genKeyIDBS :: String -- ^the key string -> BS.ByteString -- ^the key ID represented as a @ByteString@ @@ -451,7 +456,7 @@ data FediChordConf = FediChordConf -- ^ fraction of capacity above which a node considers itself overloaded , confKChoicesUnderload :: Double -- ^ fraction of capacity below which a node considers itself underloaded - , confKChoicesMaxVS :: Integer + , confKChoicesMaxVS :: Word8 -- ^ upper limit of vserver index κ } deriving (Show, Eq) From bb0fb0919a227321bcb74f066a7b32f34776d549 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 29 Sep 2020 02:59:42 +0200 Subject: [PATCH 29/38] refactor request sender ID spoof check to suit k-choices - mostly refactored the checks into its own function - now additionally check the vserver number limit - refactoring to pass that limit to the checking function invocations - closes #74 --- src/Hash2Pub/DHTProtocol.hs | 33 +++++++++++++++++---------------- src/Hash2Pub/FediChord.hs | 10 ++++++++-- src/Hash2Pub/FediChordTypes.hs | 5 +++-- 3 files changed, 28 insertions(+), 20 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 3ad5747..50a2ec8 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -66,6 +66,7 @@ import Data.Maybe (fromJust, fromMaybe, isJust, isNothing, mapMaybe, maybe) import qualified Data.Set as Set import Data.Time.Clock.POSIX +import Data.Word (Word8) import Network.Socket hiding (recv, recvFrom, send, sendTo) import Network.Socket.ByteString @@ -93,6 +94,7 @@ import Hash2Pub.FediChordTypes (CacheEntry (..), getKeyID, localCompare, rMapFromList, rMapLookupPred, rMapLookupSucc, + hasValidNodeId, remainingLoadTarget, setPredecessors, setSuccessors) import Hash2Pub.ProtocolTypes @@ -267,12 +269,13 @@ extractFirstPayload msgSet = foldr' (\msg plAcc -> -- | Dispatch incoming requests to the dedicated handling and response function, and enqueue -- the response to be sent. handleIncomingRequest :: Service s (RealNodeSTM s) - => LocalNodeStateSTM s -- ^ the handling node + => Word8 -- ^ maximum number of vservers, because of decision to @dropSpoofedIDs@ in here and not already in @fediMessageHandler@ + -> LocalNodeStateSTM s -- ^ the handling node -> TQueue (BS.ByteString, SockAddr) -- ^ send queue -> Set.Set FediChordMessage -- ^ all parts of the request to handle -> SockAddr -- ^ source address of the request -> IO () -handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do +handleIncomingRequest vsLimit nsSTM sendQ msgSet sourceAddr = do ns <- readTVarIO nsSTM -- add nodestate to cache now <- getPOSIXTime @@ -287,12 +290,12 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do ) =<< (case action aPart of Ping -> Just <$> respondPing nsSTM msgSet - Join -> dropSpoofedIDs sourceIP nsSTM msgSet respondJoin + Join -> dropSpoofedIDs vsLimit sourceIP nsSTM msgSet respondJoin -- ToDo: figure out what happens if not joined QueryID -> Just <$> respondQueryID nsSTM msgSet -- only when joined - Leave -> if vsIsJoined ns then dropSpoofedIDs sourceIP nsSTM msgSet respondLeave else pure Nothing - Stabilise -> if vsIsJoined ns then dropSpoofedIDs sourceIP nsSTM msgSet respondStabilise else pure Nothing + Leave -> if vsIsJoined ns then dropSpoofedIDs vsLimit sourceIP nsSTM msgSet respondLeave else pure Nothing + Stabilise -> if vsIsJoined ns then dropSpoofedIDs vsLimit sourceIP nsSTM msgSet respondStabilise else pure Nothing QueryLoad -> if vsIsJoined ns then Just <$> respondQueryLoad nsSTM msgSet else pure Nothing ) -- for single part request, response starts with part number 1. For multipart requests, response starts with part number n+1. @@ -303,19 +306,18 @@ handleIncomingRequest nsSTM sendQ msgSet sourceAddr = do -- | Filter out requests with spoofed node IDs by recomputing the ID using -- the sender IP. -- For valid (non-spoofed) sender IDs, the passed responder function is invoked. - dropSpoofedIDs :: HostAddress6 -- msg source address + dropSpoofedIDs :: Word8 -- ^ maximum number of vservers per node + -> HostAddress6 -- ^ msg source address -> LocalNodeStateSTM s - -> Set.Set FediChordMessage -- message parts of the request - -> (LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString)) -- reponder function to be invoked for valid requests + -> Set.Set FediChordMessage -- ^ message parts of the request + -> (LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString)) -- ^ reponder function to be invoked for valid requests -> IO (Maybe (Map.Map Integer BS.ByteString)) - dropSpoofedIDs addr nsSTM' msgSet' responder = + dropSpoofedIDs limVs addr nsSTM' msgSet' responder = let aRequestPart = Set.elemAt 0 msgSet senderNs = sender aRequestPart - givenSenderID = getNid senderNs - recomputedID = genNodeID addr (getDomain senderNs) (getVServerID senderNs) in - if recomputedID == givenSenderID + if hasValidNodeId limVs senderNs addr then Just <$> responder nsSTM' msgSet' else pure Nothing @@ -779,10 +781,9 @@ requestPing ns target = do -- recompute ID for each received node and mark as verified in cache now <- getPOSIXTime forM_ responseVss (\vs -> - let recomputedID = genNodeID peerAddr (getDomain vs) (getVServerID vs) - in if recomputedID == getNid vs - then atomically $ writeTQueue (cacheWriteQueue ns) $ addNodeAsVerifiedPure now vs - else pure () + if hasValidNodeId (confKChoicesMaxVS nodeConf) vs peerAddr + then atomically $ writeTQueue (cacheWriteQueue ns) $ addNodeAsVerifiedPure now vs + else pure () ) pure $ if null responseVss then Left "no active vServer IDs returned, ignoring node" diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 1aea94e..488c92d 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -901,6 +901,12 @@ fediMessageHandler sendQ recvQ nodeSTM = do -- both of them fail concurrently_ (requestMapPurge (confResponsePurgeAge nodeConf) requestMap) $ forever $ do node <- readTVarIO nodeSTM + -- Messages from invalid (spoofed) sender IDs could already be dropped here + -- or in @dispatchVS@. But as the checking on each possible ID causes an + -- overhead, it is only done for critical operations and the case + -- differentiation is done in @handleIncomingRequest@. Thus the vserver + -- number limit, required for this check, needs to be passed to that function. + let handlerFunc = handleIncomingRequest $ confKChoicesMaxVS nodeConf -- wait for incoming messages (rawMsg, sourceAddr) <- atomically $ readTQueue recvQ let aMsg = deserialiseMessage rawMsg @@ -915,7 +921,7 @@ fediMessageHandler sendQ recvQ nodeSTM = do Nothing -> pure () -- if not a multipart message, handle immediately. Response is at the same time an ACK Just nsSTM | part aRequest == 1 && isFinalPart aRequest -> - forkIO (handleIncomingRequest nsSTM sendQ (Set.singleton aRequest) sourceAddr) >> pure () + forkIO (handlerFunc nsSTM sendQ (Set.singleton aRequest) sourceAddr) >> pure () -- otherwise collect all message parts first before handling the whole request Just nsSTM | otherwise -> do now <- getPOSIXTime @@ -942,7 +948,7 @@ fediMessageHandler sendQ recvQ nodeSTM = do (RequestMapEntry theseParts mayMaxParts _) = fromJust $ Map.lookup thisKey newMapState numParts = Set.size theseParts if maybe False (numParts ==) (fromIntegral <$> mayMaxParts) - then forkIO (handleIncomingRequest nsSTM sendQ theseParts sourceAddr) >> pure() + then forkIO (handlerFunc nsSTM sendQ theseParts sourceAddr) >> pure() else pure() -- Responses should never arrive on the main server port, as they are always -- responses to requests sent from dedicated sockets on another port diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 0171177..2b9dbad 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -57,6 +57,7 @@ module Hash2Pub.FediChordTypes , localCompare , genNodeID , genNodeIDBS + , hasValidNodeId , genKeyID , genKeyIDBS , byteStringToUInteger @@ -392,8 +393,8 @@ genNodeID :: HostAddress6 -- ^a node's IPv6 address genNodeID ip nodeDomain vs = NodeID . byteStringToUInteger $ genNodeIDBS ip nodeDomain vs -isValidIdForNode :: Word8 -> RemoteNodeState -> HostAddress6 -> Bool -isValidIdForNode numVs rns addr = getNid rns `elem` [genNodeID addr (getDomain rns) v | v <- [0..(numVs-1)] ] +hasValidNodeId :: Word8 -> RemoteNodeState -> HostAddress6 -> Bool +hasValidNodeId numVs rns addr = getVServerID rns < numVs && getNid rns == genNodeID addr (getDomain rns) (getVServerID rns) -- | generates a 256 bit long key identifier, represented as ByteString, for looking up its data on the DHT From 5ed8a28fde581aa65bb544763b95ff3dc2339f4c Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 5 Oct 2020 02:22:25 +0200 Subject: [PATCH 30/38] 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 | 7 +++---- src/Hash2Pub/FediChord.hs | 20 ++++++++++---------- src/Hash2Pub/FediChordTypes.hs | 4 ++-- src/Hash2Pub/RingMap.hs | 26 ++++++++++++++++++++++++++ test/FediChordSpec.hs | 3 ++- 5 files changed, 43 insertions(+), 17 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 50a2ec8..d9f7e05 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -91,10 +91,9 @@ import Hash2Pub.FediChordTypes (CacheEntry (..), cacheGetNodeStateUnvalidated, cacheLookup, cacheLookupPred, cacheLookupSucc, genNodeID, - getKeyID, localCompare, - rMapFromList, rMapLookupPred, - rMapLookupSucc, - hasValidNodeId, + getKeyID, hasValidNodeId, + localCompare, rMapFromList, + rMapLookupPred, rMapLookupSucc, remainingLoadTarget, setPredecessors, setSuccessors) import Hash2Pub.ProtocolTypes diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 488c92d..050f2ab 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/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 diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 2b9dbad..3852bd1 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/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 diff --git a/src/Hash2Pub/RingMap.hs b/src/Hash2Pub/RingMap.hs index a083b59..36f95ec 100644 --- a/src/Hash2Pub/RingMap.hs +++ b/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 diff --git a/test/FediChordSpec.hs b/test/FediChordSpec.hs index 38bc9e9..9a0ea9f 100644 --- a/test/FediChordSpec.hs +++ b/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 From ecb127e6afe897cb311da772564904a65ef789b2 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Mon, 5 Oct 2020 22:48:56 +0200 Subject: [PATCH 31/38] k-choices cost calculation for departure cost --- src/Hash2Pub/FediChord.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 050f2ab..27d662f 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -305,13 +305,23 @@ kChoicesVsJoin queryVsSTM bootstrapNode capacity activeVss nodeSTM remainingTarg kChoicesJoinCost :: Double -- ^ own remaining load target -> Double -- ^ own capacity - -> SegmentLoadStats + -> SegmentLoadStats -- ^ load stats of neighbour vs -> Double kChoicesJoinCost remainingOwnLoad ownCap segment = abs (segmentOwnerRemainingLoadTarget segment + segmentLoad segment) / segmentOwnerCapacity segment + abs (remainingOwnLoad - segmentLoad segment) / ownCap - abs (segmentOwnerRemainingLoadTarget segment) / segmentOwnerCapacity segment +kChoicesDepartureCost :: Double -- ^ own remaining load target + -> Double -- ^ own capacity + -> Double -- ^ load of own segment to hand over + -> SegmentLoadStats -- ^ load stats of neighbour VS + -> Double +kChoicesDepartureCost remainingOwnLoad ownCap thisSegmentLoad segment = + abs (segmentOwnerRemainingLoadTarget segment - thisSegmentLoad) / segmentOwnerCapacity segment + + abs (remainingOwnLoad + thisSegmentLoad) / ownCap + - abs (segmentOwnerRemainingLoadTarget segment) / segmentOwnerCapacity segment + -- | Join a new node into the DHT, using a provided bootstrap node as initial cache seed -- for resolving the new node's position. fediChordBootstrapJoin :: Service s (RealNodeSTM s) From b1115151781831ab0f5b057d7da5c44ba1279e8b Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Tue, 6 Oct 2020 16:01:29 +0200 Subject: [PATCH 32/38] add config option for k-choices rebalance interval --- app/Main.hs | 4 +++- src/Hash2Pub/FediChordTypes.hs | 2 ++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index 24d66a9..043d123 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -31,6 +31,7 @@ readConfig = do -- waiting for timeout let speedup = read speedupString + statsEvalD = 120 * 10^6 `div` speedup confBootstrapNodes' = case remainingArgs of bootstrapHost : bootstrapPortString : _ -> [(bootstrapHost, read bootstrapPortString)] @@ -52,6 +53,7 @@ readConfig = do , confKChoicesOverload = 0.9 , confKChoicesUnderload = 0.1 , confKChoicesMaxVS = 8 + , confKChoicesRebalanceInterval = round (realToFrac statsEvalD * 1.1 :: Double) } sConf = ServiceConf { confSubscriptionExpiryTime = 24*3600 / fromIntegral speedup @@ -59,7 +61,7 @@ readConfig = do , confServiceHost = confDomainString , confLogfilePath = "../simulationData/logs/" <> confDomainString <> ".log" , confSpeedupFactor = speedup - , confStatsEvalDelay = 120 * 10^6 `div` speedup + , confStatsEvalDelay = statsEvalD } pure (fConf, sConf) diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 3852bd1..3a954d1 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -459,6 +459,8 @@ data FediChordConf = FediChordConf -- ^ fraction of capacity below which a node considers itself underloaded , confKChoicesMaxVS :: Word8 -- ^ upper limit of vserver index κ + , confKChoicesRebalanceInterval :: Int + -- ^ interval between vserver rebalance attempts } deriving (Show, Eq) From 0cb4b6815ccabcfeff412b67f70aa95f0e806352 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 7 Oct 2020 00:42:33 +0200 Subject: [PATCH 33/38] start implementing k-choices rebalancing, considering 1 VS each run only loop implemented, rebalancing not implemented --- src/Hash2Pub/FediChord.hs | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 27d662f..4936e7c 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -322,6 +322,34 @@ kChoicesDepartureCost remainingOwnLoad ownCap thisSegmentLoad segment = + abs (remainingOwnLoad + thisSegmentLoad) / ownCap - abs (segmentOwnerRemainingLoadTarget segment) / segmentOwnerCapacity segment + +kChoicesRebalanceThread :: (Service s (RealNodeSTM s)) => RealNodeSTM s -> IO () +kChoicesRebalanceThread nodeSTM = (confKChoicesRebalanceInterval . nodeConfig <$> readTVarIO nodeSTM) >>= rebalanceVS 0 + where + rebalanceVS :: NodeID -> Int -> IO () + rebalanceVS startAt interval = do + threadDelay interval + (vsToRebalance', serv) <- atomically $ do + node <- readTVar nodeSTM + pure (rMapLookupPred 0 (vservers node), nodeService node) + maybe + -- wait and retry if no active VS available + (rebalanceVS startAt interval) + (\(vsNid, vsSTM) -> do + vs <- readTVarIO vsSTM + -- query neighbour node(s) load + -- query own load + -- calculate departure cost + -- if deciding to re-balance, first leave and then join + -- loop + rebalanceVS vsNid interval + ) + vsToRebalance' + + + -- placeholder + pure () + -- | Join a new node into the DHT, using a provided bootstrap node as initial cache seed -- for resolving the new node's position. fediChordBootstrapJoin :: Service s (RealNodeSTM s) From 8bd4e04bcd5736c5cd80010536c181a77024282c Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 7 Oct 2020 15:50:44 +0200 Subject: [PATCH 34/38] bootstrapQueryId doesn't need a STM'd node state --- src/Hash2Pub/FediChord.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 4936e7c..8c13a0d 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -267,7 +267,7 @@ kChoicesVsJoin queryVsSTM bootstrapNode capacity activeVss nodeSTM remainingTarg -- if bootstrap node is provided, do initial lookup via that currentlyResponsible <- maybe (requestQueryID queryVs vsNid) - (\bs -> bootstrapQueryId queryVsSTM bs vsNid) + (\bs -> bootstrapQueryId queryVs bs vsNid) bootstrapNode segment <- requestQueryLoad queryVs vsNid currentlyResponsible pure $ Just (segment, vsId, currentlyResponsible) @@ -362,7 +362,7 @@ fediChordBootstrapJoin nsSTM bootstrapNode = do ns <- readTVarIO nsSTM runExceptT $ do -- 1. get routed to the currently responsible node - currentlyResponsible <- bootstrapQueryId nsSTM bootstrapNode $ getNid ns + currentlyResponsible <- bootstrapQueryId ns bootstrapNode $ getNid ns liftIO . putStrLn $ "Trying to join on " <> show (getNid currentlyResponsible) -- 2. then send a join to the currently responsible node liftIO $ putStrLn "send a bootstrap Join" @@ -384,7 +384,7 @@ convergenceSampleThread nodeSTM = forever $ do let bss = bootstrapNodes parentNode randIndex <- liftIO $ randomRIO (0, length bss - 1) chosenNode <- maybe (throwError "invalid bootstrapping node index") pure $ atMay bss randIndex - currentlyResponsible <- bootstrapQueryId nsSTM chosenNode (getNid nsSnap) + currentlyResponsible <- bootstrapQueryId nsSnap chosenNode (getNid nsSnap) if getNid currentlyResponsible /= getNid nsSnap -- if mismatch, stabilise on the result, else do nothing then do @@ -435,12 +435,11 @@ tryBootstrapJoining nodeSTM = do -- | Look up a key just based on the responses of a single bootstrapping node. bootstrapQueryId :: (MonadError String m, MonadIO m, Service s (RealNodeSTM s)) - => LocalNodeStateSTM s + => LocalNodeState s -> (String, PortNumber) -> NodeID -> m RemoteNodeState -bootstrapQueryId nsSTM (bootstrapHost, bootstrapPort) targetID = do - ns <- liftIO $ readTVarIO nsSTM +bootstrapQueryId ns (bootstrapHost, bootstrapPort) targetID = do nodeConf <- nodeConfig <$> liftIO (readTVarIO $ parentRealNode ns) let srcAddr = confIP nodeConf -- IP address needed for ID generation, so look it up From 048a6ce3913a972a243ab73d82812b895950962e Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 7 Oct 2020 16:17:45 +0200 Subject: [PATCH 35/38] modularise VS candidate load querying into own function --- src/Hash2Pub/FediChord.hs | 105 ++++++++++++++++++++------------------ 1 file changed, 54 insertions(+), 51 deletions(-) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 8c13a0d..51c23c5 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -218,7 +218,7 @@ kChoicesNodeJoin nodeSTM bootstrapNode = do -- kCoicesVsJoin until target is met – unless there's already an active & joined VS causing enough load 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 + joinedVss <- vsJoins vs0 (totalCapacity ownLoadStats) (vservers node) joinLoadTarget (fromIntegral initialJoins - alreadyJoinedVss) nodeSTM if nullRMap joinedVss then throwError "k-choices join unsuccessful, no vserver joined" else liftIO . atomically . modifyTVar' nodeSTM $ \node' -> node' @@ -226,17 +226,17 @@ kChoicesNodeJoin nodeSTM bootstrapNode = do where vsJoins :: (MonadError String m, MonadIO m, Service s (RealNodeSTM s)) - => LocalNodeStateSTM s -> Double -> VSMap s -> Double -> Int -> RealNodeSTM s -> m (VSMap s) + => LocalNodeState s -> Double -> VSMap s -> Double -> Int -> RealNodeSTM s -> m (VSMap s) vsJoins _ _ vsmap _ 0 _ = pure vsmap - vsJoins queryVsSTM capacity vsmap remainingTargetLoad remainingJoins nodeSTM' + vsJoins queryVs capacity vsmap remainingTargetLoad remainingJoins nodeSTM' | remainingTargetLoad <= 0 = pure vsmap | otherwise = do - (acquiredLoad, (newNid, newVs)) <- kChoicesVsJoin queryVsSTM bootstrapNode capacity vsmap nodeSTM' remainingTargetLoad + (acquiredLoad, (newNid, newVs)) <- kChoicesVsJoin queryVs bootstrapNode capacity vsmap nodeSTM' remainingTargetLoad -- on successful vserver join add the new VS to node and recurse - vsJoins queryVsSTM capacity (addRMapEntry newNid newVs vsmap) (remainingTargetLoad - acquiredLoad) (pred remainingJoins) nodeSTM' + vsJoins queryVs 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') + `catchError` (\e -> liftIO (putStrLn e) >> vsJoins queryVs capacity vsmap remainingTargetLoad (pred remainingJoins) nodeSTM') -- error cause 1: not a single queried node has responded -> indicates permanent failure -- error cause 2: only a certain join failed, just ignore that join target for now, but problem: it will be the chosen @@ -244,39 +244,17 @@ kChoicesNodeJoin nodeSTM bootstrapNode = do -- `catchError` (const . kChoicesVsJoin :: (MonadError String m, MonadIO m, Service s (RealNodeSTM s)) - => LocalNodeStateSTM s -- ^ vserver to be used for querying - -> Maybe (String, PortNumber) -- ^ domain and port of a bootstrapping node, if bootstrappinG + => LocalNodeState s -- ^ vserver to be used for querying + -> Maybe (String, PortNumber) -- ^ domain and port of a bootstrapping node, if bootstrapping -> Double -- ^ own capacity -> VSMap s -- ^ currently active VServers -> RealNodeSTM s -- ^ parent node is needed for initialising a new vserver -> Double -- ^ remaining load target -> m (Double, (NodeID, LocalNodeStateSTM s)) -- ^ on success return tuple of acquired load and newly acquired vserver -kChoicesVsJoin queryVsSTM bootstrapNode capacity activeVss nodeSTM remainingTarget = do +kChoicesVsJoin queryVs bootstrapNode capacity activeVss nodeSTM remainingTarget = do conf <- nodeConfig <$> liftIO (readTVarIO nodeSTM) -- generate all possible vs IDs - let - -- tuples of node IDs and vserver IDs, because vserver IDs are needed for - -- LocalNodeState creation - 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 - -- simplification: treat each load lookup failure as a general unavailability of that segment - -- TODO: retries for transient failures - segmentLoads <- fmap catMaybes . forM nonJoinedIDs $ (\(vsNid, vsId) -> (do - -- if bootstrap node is provided, do initial lookup via that - currentlyResponsible <- maybe - (requestQueryID queryVs vsNid) - (\bs -> bootstrapQueryId queryVs bs vsNid) - bootstrapNode - segment <- requestQueryLoad queryVs vsNid currentlyResponsible - pure $ Just (segment, vsId, currentlyResponsible) - -- store segment stats and vserver ID together, so it's clear - -- which vs needs to be joined to acquire this segment - ) `catchError` const (pure Nothing) - ) - - + segmentLoads <- kChoicesSegmentLoads conf queryVs bootstrapNode activeVss -- cost calculation and sort by cost -- edge case: no possible ID has responded (mincost, vsId, toJoinOn) <- maybe (throwError "received no load information") pure @@ -303,6 +281,39 @@ kChoicesVsJoin queryVsSTM bootstrapNode capacity activeVss nodeSTM remainingTarg -- changes the remainingLoadTarget at each vsJoin. This target change -- needs to be accounted for starting from the 2nd vsJoin. + +-- | query the load of all still unjoined VS positions +kChoicesSegmentLoads :: (Service s (RealNodeSTM s), MonadError String m, MonadIO m) + => FediChordConf -- ^ config params needed for generating all possible VSs + -> LocalNodeState s -- ^ vserver to be used for querying + -> Maybe (String, PortNumber) -- ^ domain and port of a bootstrapping node, if bootstrapping + -> VSMap s -- ^ currently active VServers + -> m [(SegmentLoadStats, Word8, RemoteNodeState)] +kChoicesSegmentLoads conf queryVs bootstrapNode activeVss = do + let + -- tuples of node IDs and vserver IDs, because vserver IDs are needed for + -- LocalNodeState creation + nonJoinedIDs = filter (not . flip memberRMap activeVss . fst) [ (genNodeID (confIP conf) (confDomain conf) v, v) | v <- [0..pred (confKChoicesMaxVS conf)]] + + -- query load of all possible segments + -- simplification: treat each load lookup failure as a general unavailability of that segment + -- TODO: retries for transient failures + fmap catMaybes . forM nonJoinedIDs $ (\(vsNid, vsId) -> (do + -- if bootstrap node is provided, do initial lookup via that + currentlyResponsible <- maybe + (requestQueryID queryVs vsNid) + (\bs -> bootstrapQueryId queryVs bs vsNid) + bootstrapNode + segment <- requestQueryLoad queryVs vsNid currentlyResponsible + pure $ Just (segment, vsId, currentlyResponsible) + -- store segment stats and vserver ID together, so it's clear + -- which vs needs to be joined to acquire this segment + ) `catchError` const (pure Nothing) + ) + + + + kChoicesJoinCost :: Double -- ^ own remaining load target -> Double -- ^ own capacity -> SegmentLoadStats -- ^ load stats of neighbour vs @@ -324,27 +335,19 @@ kChoicesDepartureCost remainingOwnLoad ownCap thisSegmentLoad segment = kChoicesRebalanceThread :: (Service s (RealNodeSTM s)) => RealNodeSTM s -> IO () -kChoicesRebalanceThread nodeSTM = (confKChoicesRebalanceInterval . nodeConfig <$> readTVarIO nodeSTM) >>= rebalanceVS 0 +kChoicesRebalanceThread nodeSTM = (confKChoicesRebalanceInterval . nodeConfig <$> readTVarIO nodeSTM) >>= rebalanceVS where - rebalanceVS :: NodeID -> Int -> IO () - rebalanceVS startAt interval = do + rebalanceVS :: Int -> IO () + rebalanceVS interval = do threadDelay interval - (vsToRebalance', serv) <- atomically $ do - node <- readTVar nodeSTM - pure (rMapLookupPred 0 (vservers node), nodeService node) - maybe - -- wait and retry if no active VS available - (rebalanceVS startAt interval) - (\(vsNid, vsSTM) -> do - vs <- readTVarIO vsSTM - -- query neighbour node(s) load - -- query own load - -- calculate departure cost - -- if deciding to re-balance, first leave and then join - -- loop - rebalanceVS vsNid interval - ) - vsToRebalance' + -- query load of all possible available VS IDs + -- query load of all existing VSes neighbours + -- calculate all departure costs + -- select VS with lowest departure cost + -- calculate all relocation costs of that VS + -- if deciding to re-balance, first leave and then join + -- loop + rebalanceVS interval -- placeholder From 6aebd982f886b45c7163f67bebe10920cdf84e02 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Wed, 7 Oct 2020 19:24:15 +0200 Subject: [PATCH 36/38] make RingMap an instance of Traversable - some examples tested out by hand, but not thorough test case or even QuickCheck coverage --- src/Hash2Pub/RingMap.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Hash2Pub/RingMap.hs b/src/Hash2Pub/RingMap.hs index 36f95ec..d26835c 100644 --- a/src/Hash2Pub/RingMap.hs +++ b/src/Hash2Pub/RingMap.hs @@ -47,6 +47,13 @@ instance (Bounded k, Ord k) => Foldable (RingMap k) where traversingFL acc (ProxyEntry _ Nothing) = acc traversingFL acc (ProxyEntry _ (Just entry)) = traversingFL acc entry +instance (Bounded k, Ord k) => Traversable (RingMap k) where + traverse f = fmap RingMap . traverse traversingF . getRingMap + where + traversingF (KeyEntry entry) = KeyEntry <$> f entry + traversingF (ProxyEntry to Nothing) = pure $ ProxyEntry to Nothing + traversingF (ProxyEntry to (Just entry)) = ProxyEntry to . Just <$> traversingF entry + -- | entry of a 'RingMap' that holds a value and can also -- wrap around the lookup direction at the edges of the name space. From 4aa4667a1d1f3a22a4bcda9a30242714acf8ef17 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Sat, 10 Oct 2020 04:33:37 +0200 Subject: [PATCH 37/38] kChoices cost calculations for rebalance decisions - loop with load queries and cost calculations on whether to do a vs relocation - actual relocation still missing though - untested --- src/Hash2Pub/DHTProtocol.hs | 13 ++--- src/Hash2Pub/FediChord.hs | 86 +++++++++++++++++++++++++++++++--- src/Hash2Pub/FediChordTypes.hs | 10 ++++ 3 files changed, 97 insertions(+), 12 deletions(-) diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index d9f7e05..39eaad2 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -92,8 +92,9 @@ import Hash2Pub.FediChordTypes (CacheEntry (..), cacheLookup, cacheLookupPred, cacheLookupSucc, genNodeID, getKeyID, hasValidNodeId, - localCompare, rMapFromList, - rMapLookupPred, rMapLookupSucc, + loadSliceSum, localCompare, + rMapFromList, rMapLookupPred, + rMapLookupSucc, remainingLoadTarget, setPredecessors, setSuccessors) import Hash2Pub.ProtocolTypes @@ -453,7 +454,7 @@ respondQueryLoad nsSTM msgSet = do lStats <- getServiceLoadStats serv let directSucc = getNid . head . predecessors $ nsSnap - handledTagSum = sum . takeRMapSuccessorsFromTo directSucc (loadSegmentUpperBound pl) $ loadPerTag lStats + handledTagSum = loadSliceSum lStats directSucc (loadSegmentUpperBound pl) pure $ Just LoadResponsePayload { loadSum = handledTagSum , loadRemainingTarget = remainingLoadTarget conf lStats @@ -792,9 +793,9 @@ requestPing ns target = do -- still need a particular vserver as LocalNodeState, because requests need a sender requestQueryLoad :: (MonadError String m, MonadIO m) - => LocalNodeState s - -> NodeID - -> RemoteNodeState + => LocalNodeState s -- ^ the local source vserver for the request + -> NodeID -- ^ upper bound of the segment queried, lower bound is set automatically by the queried node + -> RemoteNodeState -- ^ target node to query -> m SegmentLoadStats requestQueryLoad ns upperIdBound target = do nodeConf <- nodeConfig <$> liftIO (readTVarIO $ parentRealNode ns) diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index 51c23c5..ab413cf 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -298,6 +298,7 @@ kChoicesSegmentLoads conf queryVs bootstrapNode activeVss = do -- query load of all possible segments -- simplification: treat each load lookup failure as a general unavailability of that segment -- TODO: retries for transient failures + -- TODO: parallel queries fmap catMaybes . forM nonJoinedIDs $ (\(vsNid, vsId) -> (do -- if bootstrap node is provided, do initial lookup via that currentlyResponsible <- maybe @@ -335,23 +336,96 @@ kChoicesDepartureCost remainingOwnLoad ownCap thisSegmentLoad segment = kChoicesRebalanceThread :: (Service s (RealNodeSTM s)) => RealNodeSTM s -> IO () -kChoicesRebalanceThread nodeSTM = (confKChoicesRebalanceInterval . nodeConfig <$> readTVarIO nodeSTM) >>= rebalanceVS +kChoicesRebalanceThread nodeSTM = do + interval <- confKChoicesRebalanceInterval . nodeConfig <$> readTVarIO nodeSTM + runExceptT $ loop interval + pure () where - rebalanceVS :: Int -> IO () + loop interval = rebalanceVS interval `catchError` \_ -> loop interval + rebalanceVS :: (MonadError String m, MonadIO m) => Int -> m () rebalanceVS interval = do - threadDelay interval - -- query load of all possible available VS IDs + liftIO $ threadDelay interval + node <- liftIO $ readTVarIO nodeSTM + let + activeVssSTM = vservers node + conf = nodeConfig node + -- use an active vserver for load queries + queryVsSTM <- maybe (throwError "no active vserver") pure + $ headMay (rMapToList activeVssSTM) + queryVs <- liftIO . readTVarIO $ queryVsSTM + -- TODO: segment load and neighbour load queries can be done in parallel -- query load of all existing VSes neighbours + -- TODO: what happens if neighbour is one of our own vservers? + neighbourLoadFetches <- liftIO . forM activeVssSTM $ async . (\vsSTM -> runExceptT $ do + vs <- liftIO . readTVarIO $ vsSTM + succNode <- maybe + (throwError "vs has no successor") + pure + . headMay . successors $ vs + neighbourStats <- requestQueryLoad queryVs (getNid succNode) succNode + pure (getNid succNode, neighbourStats) + ) + -- TODO: deal with exceptions + -- TODO: better handling of nested Eithers + -- so far this is a RingMap NodeID (Either SomeException (Either String (NodeID, SegmentLoadStats))) + neighbourLoads <- liftIO . mapM waitCatch $ neighbourLoadFetches + -- get local load stats + ownLoadStats <- liftIO . getServiceLoadStats . nodeService $ node -- calculate all departure costs + let + departureCosts = + sortOn (\(cost, _, _) -> cost) + . foldl (\acc (ownVsId, neighbourLoad) -> case neighbourLoad of + Right (Right (neighbourId, neighbourStats)) -> + let + ownRemainingTarget = remainingLoadTarget conf ownLoadStats + thisSegmentLoad = loadSliceSum ownLoadStats ownVsId neighbourId + in + ( kChoicesDepartureCost ownRemainingTarget (totalCapacity ownLoadStats) thisSegmentLoad neighbourStats + , thisSegmentLoad + , ownVsId) + :acc + _ -> acc + ) + [] + $ rMapToListWithKeys neighbourLoads -- select VS with lowest departure cost + (lowestDepartionCost, departingSegmentLoad, lowestCostDeparter) <- maybe + (throwError "not enough data for calculating departure costs") + pure + $ headMay departureCosts + -- query load of all possible available VS IDs + segmentLoads <- kChoicesSegmentLoads conf queryVs Nothing activeVssSTM -- calculate all relocation costs of that VS + (joinCost, toJoinOn) <- + maybe (throwError "got no segment loads") pure + . headMay + . sortOn fst + . fmap (\(segment, vsId, toJoinOn) -> + let joinCosts = kChoicesJoinCost + -- when relocating a node, the load of the departing node is freed + (remainingLoadTarget conf ownLoadStats + departingSegmentLoad) + (totalCapacity ownLoadStats) + segment + in + (joinCosts, segmentCurrentOwner segment) + ) + $ segmentLoads + -- if deciding to re-balance, first leave and then join + -- combined costs need to be a gain (negative) and that gain needs + -- to be larger than Epsilon + when (lowestDepartionCost + joinCost <= negate kChoicesEpsilon) $ do + liftIO . putStrLn $ "here will be a relocation!" -- loop rebalanceVS interval - -- placeholder - pure () + +-- TODO: make parameterisable +-- | dampening factor constant for deciding whether the match gain is worth relocating +kChoicesEpsilon :: Double +kChoicesEpsilon = 0.05 -- | Join a new node into the DHT, using a provided bootstrap node as initial cache seed -- for resolving the new node's position. diff --git a/src/Hash2Pub/FediChordTypes.hs b/src/Hash2Pub/FediChordTypes.hs index 3a954d1..347c90c 100644 --- a/src/Hash2Pub/FediChordTypes.hs +++ b/src/Hash2Pub/FediChordTypes.hs @@ -22,6 +22,7 @@ module Hash2Pub.FediChordTypes , LoadStats (..) , emptyLoadStats , remainingLoadTarget + , loadSliceSum , addVserver , SegmentLoadStats (..) , setSuccessors @@ -483,6 +484,15 @@ remainingLoadTarget conf lstats = targetLoad - compensatedLoadSum lstats where targetLoad = totalCapacity lstats * (confKChoicesUnderload conf + confKChoicesOverload conf) / 2 + +-- | calculates the sum of tag load in a contiguous slice between to keys +loadSliceSum :: LoadStats + -> NodeID -- ^ lower segment bound + -> NodeID -- ^ upper segment bound + -> Double -- ^ sum of all tag loads within that segment +loadSliceSum stats from to = sum . takeRMapSuccessorsFromTo from to $ loadPerTag stats + + data SegmentLoadStats = SegmentLoadStats { segmentLowerKeyBound :: NodeID -- ^ segment start key From e79ba52e00371148ab032b8e509f71d0d257fe84 Mon Sep 17 00:00:00 2001 From: Trolli Schmittlauch Date: Fri, 1 Jan 2021 14:30:33 +0100 Subject: [PATCH 38/38] update ghc to 8.6.4, nixpkgs base to 20.09 - relaxes some version constraints as dirty update quickfix - removes hie integration as that project is abandoned, todo: switch to haskell-languageserver instead --- Hash2Pub.cabal | 2 +- default.nix | 19 +++++-------------- shell.nix | 2 +- 3 files changed, 7 insertions(+), 16 deletions(-) diff --git a/Hash2Pub.cabal b/Hash2Pub.cabal index b343df3..94fd6a5 100644 --- a/Hash2Pub.cabal +++ b/Hash2Pub.cabal @@ -46,7 +46,7 @@ category: Network extra-source-files: CHANGELOG.md common deps - build-depends: base ^>=4.12.0.0, containers ^>=0.6.0.1, bytestring, utf8-string ^>=1.0.1.1, network ^>=2.8.0.1, time ^>=1.8.0.2, cmdargs ^>= 0.10, cryptonite ^>= 0.25, memory, async, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client, http-types, unbounded-delays, dlist, formatting + build-depends: base >=4, containers ^>=0.6.0.1, bytestring, utf8-string ^>=1.0.1.1, network ^>=3.1, time, cmdargs ^>= 0.10, cryptonite, memory, async, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, unordered-containers, hashable, unicode-transforms, http-client, http-types, unbounded-delays, dlist, formatting ghc-options: -Wall -Wpartial-fields -O2 diff --git a/default.nix b/default.nix index 126975a..a3f7640 100644 --- a/default.nix +++ b/default.nix @@ -1,26 +1,18 @@ { - compiler ? "ghc865", - withHIE ? false + compiler ? "ghc884" }: let - # pin all-hies for getting the language server - all-hies = fetchTarball { - url = "https://github.com/infinisil/all-hies/tarball/b8fb659620b99b4a393922abaa03a1695e2ca64d"; - sha256 = "sha256:0br6wsqpfk1lzz90f7zw439w1ir2p54268qilw9l2pk6yz7ganfx"; - }; pkgs = import ( builtins.fetchGit { name = "nixpkgs-pinned"; url = https://github.com/NixOS/nixpkgs/; - ref = "refs/heads/release-20.03"; - rev = "faf5bdea5d9f0f9de26deaa7e864cdcd3b15b4e8"; + ref = "refs/heads/release-20.09"; + rev = "e065200fc90175a8f6e50e76ef10a48786126e1c"; }) { # Pass no config for purity config = {}; - overlays = if withHIE then [ - (import all-hies {}).overlay - ] else []; + overlays = []; }; hp = pkgs.haskell.packages."${compiler}"; src = pkgs.nix-gitignore.gitignoreSource [] ./.; @@ -38,7 +30,6 @@ in hlint stylish-haskell pkgs.python3Packages.asn1ate - ] - ++ (if withHIE then [ hie ] else []); + ]; }; } diff --git a/shell.nix b/shell.nix index dafd212..82fb296 100644 --- a/shell.nix +++ b/shell.nix @@ -1 +1 @@ -(import ./default.nix {withHIE = true;}).shell +(import ./default.nix {}).shell