dhtd "ping" command

1 files changed, 18 insertions, 0 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 1790d10a..f8ca8575 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -30,6 +30,9 @@ import System.Posix.Process (getProcessID)
 import Data.Torrent (InfoHash)
 import Network.BitTorrent.Address
 import Network.BitTorrent.DHT
+import Network.BitTorrent.DHT.Query
+import Network.KRPC.Manager (QueryFailure(..))
+import Network.KRPC.Message (ReflectedIP(..))
 import qualified Network.BitTorrent.DHT.Routing as R
 import Network.BitTorrent.DHT.Session
 import Network.SocketLike
@@ -201,10 +204,25 @@ clientSession st signalQuit sock n h = do
                                 hPutClient h $ unlines $ map (showEnry . (flip (,) 0)) nodes
                             Left er -> return $ hPutClient h er
 
+        ("ping", s) -> cmd $ do
+                    case readEither s of
+                        Right addr -> do result <- try $ pingQ addr
+                                         let rs = either (pure . showQueryFail) reportPong result
+                                         return $ do
+                                         hPutClient h $ unlines rs
+                        Left er -> return $ hPutClient h er
+
         _    -> cmd0 $ hPutClient h "error."
 
 defaultPort = error "TODO defaultPort"
 
+showQueryFail :: QueryFailure -> String
+showQueryFail e = show e
+
+reportPong (info,myip) = maybe id consip myip [show $ pPrint info]
+ where
+    consip (ReflectedIP ip) xs = ("(external-ip " ++ show ip ++ ")") : xs
+
 main :: IO ()
 main = do
     args <- getArgs