From 3482876d9be497afb8ac977d1fabf9e4365746f4 Mon Sep 17 00:00:00 2001
From: Trolli Schmittlauch <t.schmittlauch@orlives.de>
Date: Fri, 19 Jun 2020 23:03:27 +0200
Subject: [PATCH] send and parse Ping requests

contributes to #29 #44
---
 src/Hash2Pub/DHTProtocol.hs | 30 ++++++++++++++++++++++++++++++
 1 file changed, 30 insertions(+)

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.