diff --git a/src/Hash2Pub/DHTProtocol.hs b/src/Hash2Pub/DHTProtocol.hs index 68b6b9d..165ec39 100644 --- a/src/Hash2Pub/DHTProtocol.hs +++ b/src/Hash2Pub/DHTProtocol.hs @@ -16,6 +16,7 @@ module Hash2Pub.DHTProtocol , sendQueryIdMessage , requestQueryID , requestJoin + , requestPing , requestStabilise , queryIdLookupLoop , resolve @@ -531,6 +532,35 @@ requestStabilise ns neighbour = do ) responses +requestPing :: LocalNodeState -- ^ sending node + -> RemoteNodeState -- ^ node to be PINGed + -> IO (Either String [RemoteNodeState]) -- ^ all active vServers of the pinged node +requestPing ns target = do + responses <- bracket (mkSendSocket (getDomain target) (getDhtPort target)) close (fmap Right . sendRequestTo 5000 3 (\rid -> + Request { + requestID = rid + , sender = toRemoteNodeState ns + , part = 1 + , isFinalPart = False + , action = Ping + , payload = Just PingRequestPayload + } + ) + ) `catch` (\e -> pure . Left $ displayException (e :: IOException)) + either + -- forward IO error messages + (pure . Left) + (\respSet -> do + -- fold all reply parts together + let responseVss = foldr' (\msg acc -> + maybe acc (foldr' (:) acc) (pingNodeStates <$> payload msg) + ) + [] respSet + pure $ if null responseVss + then Left "no active vServer IDs returned, ignoring node" + else Right responseVss + ) responses + -- | Generic function for sending a request over a connected socket and collecting the response.