diff --git a/FediChord.asn1 b/FediChord.asn1 index 79b894a..f278f8f 100644 --- a/FediChord.asn1 +++ b/FediChord.asn1 @@ -89,8 +89,8 @@ StabiliseResponsePayload ::= SEQUENCE { LeaveRequestPayload ::= SEQUENCE { successors SEQUENCE OF NodeState, - predecessors SEQUENCE OF NodeState, - doMigration BOOLEAN + predecessors SEQUENCE OF NodeState + -- ToDo: transfer of own data to newly responsible node } LeaveResponsePayload ::= NULL -- just a confirmation diff --git a/src/Hash2Pub/ASN1Coding.hs b/src/Hash2Pub/ASN1Coding.hs index 10177ab..456dac6 100644 --- a/src/Hash2Pub/ASN1Coding.hs +++ b/src/Hash2Pub/ASN1Coding.hs @@ -38,7 +38,6 @@ 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 { @@ -135,8 +134,9 @@ encodePayload payload'@LeaveRequestPayload{} = <> [End Sequence , Start Sequence] <> concatMap encodeNodeState (leavePredecessors payload') - <> [End Sequence] - <> [Boolean (leaveDoMigration payload'), End Sequence] + <> [End Sequence + , End Sequence] +-- currently StabiliseResponsePayload and LeaveRequestPayload are equal encodePayload payload'@StabiliseResponsePayload{} = Start Sequence : Start Sequence @@ -144,7 +144,8 @@ 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 @@ -414,11 +415,9 @@ 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 972059f..13dd434 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_, void, when) +import Control.Monad (foldM, forM, forM_, when) import qualified Data.ByteString as BS import Data.Either (rights) import Data.Foldable (foldl', foldr') @@ -352,7 +352,8 @@ respondQueryID nsSTM msgSet = do -- | Respond to a Leave request by removing the leaving node from local data structures -- and confirming with response. -respondLeave :: Service s (RealNodeSTM s) => LocalNodeStateSTM s -> Set.Set FediChordMessage -> IO (Map.Map Integer BS.ByteString) +-- TODO: copy over key data from leaver and confirm +respondLeave :: 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) -> @@ -370,6 +371,7 @@ 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 @@ -379,10 +381,6 @@ 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 @@ -665,15 +663,13 @@ 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 doMigration target = do +requestLeave ns 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 399ddfd..f544061 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 False + forM_ (predecessors ns <> successors ns) $ liftIO . requestLeave ns where sendUntilSuccess i = maybe (pure $ Left "Exhausted all successors") (\neighb -> do - leaveResponse <- requestLeave ns True neighb + leaveResponse <- requestLeave ns neighb case leaveResponse of Left _ -> sendUntilSuccess (i+1) -- return first successfully contacted neighbour, diff --git a/src/Hash2Pub/PostService.hs b/src/Hash2Pub/PostService.hs index a871343..c277327 100644 --- a/src/Hash2Pub/PostService.hs +++ b/src/Hash2Pub/PostService.hs @@ -232,12 +232,10 @@ subscriptionDelivery serv senderID subList = do :: STM (Either String ())) -- TODO: should this always signal migration finished to avoid deadlocksP liftIO $ putMVar syncMVar () -- wakes up waiting thread - -- allow response to be completed independently from waiting thread - _ <- liftIO . forkIO $ do - putMVar syncMVar () -- blocks until waiting thread has resumed - -- delete this migration from ongoing ones - liftIO . atomically $ modifyTVar' (migrationsInProgress serv) $ - HMap.delete (fromInteger senderID) + liftIO $ putMVar syncMVar () -- blocks until waiting thread has resumed + -- delete this migration from ongoing ones + liftIO . atomically $ modifyTVar' (migrationsInProgress serv) $ + HMap.delete (fromInteger senderID) case res of Left err -> throwError err410 {errBody = BSUL.fromString err} Right _ -> pure "" diff --git a/src/Hash2Pub/ProtocolTypes.hs b/src/Hash2Pub/ProtocolTypes.hs index 86825a7..37c00e9 100644 --- a/src/Hash2Pub/ProtocolTypes.hs +++ b/src/Hash2Pub/ProtocolTypes.hs @@ -55,7 +55,6 @@ data ActionPayload = QueryIDRequestPayload | LeaveRequestPayload { leaveSuccessors :: [RemoteNodeState] , leavePredecessors :: [RemoteNodeState] - , leaveDoMigration :: Bool } | StabiliseRequestPayload | PingRequestPayload