diff --git a/FediChord.asn1 b/FediChord.asn1 index f278f8f..79b894a 100644 --- a/FediChord.asn1 +++ b/FediChord.asn1 @@ -89,8 +89,8 @@ StabiliseResponsePayload ::= SEQUENCE { LeaveRequestPayload ::= SEQUENCE { successors SEQUENCE OF NodeState, - predecessors SEQUENCE OF NodeState - -- ToDo: transfer of own data to newly responsible node + predecessors SEQUENCE OF NodeState, + doMigration BOOLEAN } LeaveResponsePayload ::= NULL -- just a confirmation diff --git a/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs index 456dac6..10177ab 100644 --- a/src/Hash2Pub/ASN1Coding.hs +++ b/src/Hash2Pub/ASN1Coding.hs @@ -38,6 +38,7 @@ splitPayload numParts pl@LeaveRequestPayload{} = [ LeaveRequestPayload { leaveSuccessors = atDef [] (listInto numParts $ leaveSuccessors pl) (thisPart-1) , leavePredecessors = atDef [] (listInto numParts $ leavePredecessors pl) (thisPart-1) + , leaveDoMigration = leaveDoMigration pl } | thisPart <- [1..numParts] ] splitPayload numParts pl@StabiliseResponsePayload{} = [ StabiliseResponsePayload { @@ -134,9 +135,8 @@ encodePayload payload'@LeaveRequestPayload{} = <> [End Sequence , Start Sequence] <> concatMap encodeNodeState (leavePredecessors payload') - <> [End Sequence - , End Sequence] --- currently StabiliseResponsePayload and LeaveRequestPayload are equal + <> [End Sequence] + <> [Boolean (leaveDoMigration payload'), End Sequence] encodePayload payload'@StabiliseResponsePayload{} = Start Sequence : Start Sequence @@ -144,8 +144,7 @@ encodePayload payload'@StabiliseResponsePayload{} = <> [End Sequence , Start Sequence] <> concatMap encodeNodeState (stabilisePredecessors payload') - <> [End Sequence - , End Sequence] + <> [End Sequence, End Sequence] encodePayload payload'@StabiliseRequestPayload = [Null] encodePayload payload'@QueryIDResponsePayload{} = let @@ -415,9 +414,11 @@ parseLeaveRequest :: ParseASN1 ActionPayload parseLeaveRequest = onNextContainer Sequence $ do succ' <- onNextContainer Sequence (getMany parseNodeState) pred' <- onNextContainer Sequence (getMany parseNodeState) + doMigration <- parseBool pure $ LeaveRequestPayload { leaveSuccessors = succ' , leavePredecessors = pred' + , leaveDoMigration = doMigration } parseLeaveResponse :: ParseASN1 ActionPayload diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 13dd434..972059f 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -48,7 +48,7 @@ import Control.Concurrent.STM.TBQueue import Control.Concurrent.STM.TQueue import Control.Concurrent.STM.TVar import Control.Exception -import Control.Monad (foldM, forM, forM_, when) +import Control.Monad (foldM, forM, forM_, void, when) import qualified Data.ByteString as BS import Data.Either (rights) import Data.Foldable (foldl', foldr') @@ -352,8 +352,7 @@ respondQueryID nsSTM msgSet = do -- | Respond to a Leave request by removing the leaving node from local data structures -- and confirming with response. --- TODO: copy over key data from leaver and confirm -respondLeave :: LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString) +respondLeave :: Service s (RealNodeSTM s) => LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString) respondLeave nsSTM msgSet = do -- combine payload of all parts let (requestPreds, requestSuccs) = foldr' (\msg (predAcc, succAcc) -> @@ -371,7 +370,6 @@ respondLeave nsSTM msgSet = do -- add predecessors and successors of leaving node to own lists setPredecessors (filter ((/=) leaveSenderID . getNid) $ requestPreds <> predecessors nsSnap) . setSuccessors (filter ((/=) leaveSenderID . getNid) $ requestSuccs <> successors nsSnap) $ nsSnap - -- TODO: handle handover of key data let leaveResponse = Response { requestID = requestID aRequestPart , senderID = getNid nsSnap @@ -381,6 +379,10 @@ respondLeave nsSTM msgSet = do , payload = Just LeaveResponsePayload } pure leaveResponse + -- if awaiting an incoming service data migration, collect the lock without blocking this thread + when (maybe False leaveDoMigration (payload aRequestPart)) $ do + ownService <- atomically $ nodeService <$> ((readTVar nsSTM) >>= (readTVar . parentRealNode)) + void (forkIO $ waitForMigrationFrom ownService leaveSenderID) pure $ serialiseMessage sendMessageSize responseMsg -- | respond to stabilise requests by returning successor and predecessor list @@ -663,13 +665,15 @@ requestStabilise ns neighbour = do -- Service data transfer needs to be done separately, as not all neighbours -- that need to know about the leaving handle the new service data. requestLeave :: LocalNodeState s + -> Bool -- whether to migrate service data -> RemoteNodeState -- target node -> IO (Either String ()) -- error or success -requestLeave ns target = do +requestLeave ns doMigration target = do srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ns) let leavePayload = LeaveRequestPayload { leaveSuccessors = successors ns , leavePredecessors = predecessors ns + , leaveDoMigration = doMigration } responses <- bracket (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) close (fmap Right . sendRequestTo 5000 3 (\rid -> Request { diff --git a/src/Hash2Pub/FediChord.hs b/src/Hash2Pub/FediChord.hs index f544061..399ddfd 100644 --- a/src/Hash2Pub/FediChord.hs +++ b/src/Hash2Pub/FediChord.hs @@ -276,12 +276,12 @@ fediChordVserverLeave ns = do -- former could be worked around -- send a leave message to all neighbours - forM_ (predecessors ns <> successors ns) $ liftIO . requestLeave ns + forM_ (predecessors ns <> successors ns) $ liftIO . requestLeave ns False where sendUntilSuccess i = maybe (pure $ Left "Exhausted all successors") (\neighb -> do - leaveResponse <- requestLeave ns neighb + leaveResponse <- requestLeave ns True neighb case leaveResponse of Left _ -> sendUntilSuccess (i+1) -- return first successfully contacted neighbour, diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index 37c00e9..86825a7 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -55,6 +55,7 @@ data ActionPayload = QueryIDRequestPayload | LeaveRequestPayload { leaveSuccessors :: [RemoteNodeState] , leavePredecessors :: [RemoteNodeState] + , leaveDoMigration :: Bool } | StabiliseRequestPayload | PingRequestPayload