diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index a071132..ca87295 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -338,15 +338,15 @@ respondLeave nsSTM msgSet = do ) ([],[]) msgSet aRequestPart = Set.elemAt 0 msgSet - senderID = getNid . sender $ aRequestPart + leaveSenderID = getNid . sender $ aRequestPart responseMsg <- atomically $ do nsSnap <- readTVar nsSTM -- remove leaving node from successors, predecessors and NodeCache - writeTQueue (cacheWriteQueue nsSnap) $ deleteCacheEntry senderID + writeTQueue (cacheWriteQueue nsSnap) $ deleteCacheEntry leaveSenderID writeTVar nsSTM $ -- add predecessors and successors of leaving node to own lists - setPredecessors (filter ((/=) senderID . getNid) $ requestPreds <> predecessors nsSnap) - . setSuccessors (filter ((/=) senderID . getNid) $ requestSuccs <> successors nsSnap) $ nsSnap + 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 @@ -625,6 +625,36 @@ requestStabilise ns neighbour = do ) responses +-- | Send a Leave request to the specified node. +-- 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 + -> RemoteNodeState -- target node + -> IO (Either String ()) -- error or success +requestLeave ns target = do + srcAddr <- confIP . nodeConfig <$> readTVarIO (parentRealNode ns) + let leavePayload = LeaveRequestPayload { + leaveSuccessors = successors ns + , leavePredecessors = predecessors ns + } + responses <- bracket (mkSendSocket srcAddr (getDomain target) (getDhtPort target)) close (fmap Right . sendRequestTo 5000 3 (\rid -> + Request { + requestID = rid + , sender = toRemoteNodeState ns + , part = 1 + , isFinalPart = False + , action = Leave + , payload = Just leavePayload + } + ) + ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) + either + -- forward IO error messages + (pure . Left) + -- empty payload, so no processing required + (const . pure . Right $ ()) + responses + requestPing :: LocalNodeState s -- ^ sending node -> RemoteNodeState -- ^ node to be PINGed -> IO (Either String [RemoteNodeState]) -- ^ all active vServers of the pinged node