Prefer IPv4 when parsing TCP nodes JSON.

1 files changed, 12 insertions, 1 deletions

diff --git a/dht/src/Network/QueryResponse/TCP.hs b/dht/src/Network/QueryResponse/TCP.hs
index fdca86b4..45ff73a6 100644
--- a/dht/src/Network/QueryResponse/TCP.hs
+++ b/dht/src/Network/QueryResponse/TCP.hs
@@ -27,6 +27,7 @@ import System.IO
 import System.IO.Error
 
 import DebugTag
+import DebugUtil
 import DPut
 import Connection.Tcp (socketFamily)
 import qualified Data.MinMaxPSQ as MM
@@ -104,7 +105,13 @@ acquireConnection mvar tcpcache stream addr bDoCon = do
                                    return h)
                                $ \e -> return Nothing
             ret <- fmap join $ forM mh $ \h -> do
-                st <- streamHello stream addr h
+             mst <- catchIOError (Just <$> streamHello stream addr h)
+                                 (\e -> return Nothing)
+             case mst of
+               Nothing -> do
+                atomically $ modifyTVar' (lru tcpcache) $ MM.delete (TCPAddress $ streamAddr stream addr)
+                return Nothing
+               Just st -> do
                 dput XTCP $ "TCP Connected! " ++ show (streamAddr stream addr)
                 signal <- newTVarIO False
                 let showAddr a = show (streamAddr stream a)
@@ -129,6 +136,10 @@ acquireConnection mvar tcpcache stream addr bDoCon = do
                             now <- getPOSIXTime
                             forM_ (zip [1..] $ MM.toList c) $ \(i,MM.Binding (TCPAddress addr) r (Down tm)) -> do
                                 dput XTCP $ unwords [show i ++ ".", "Still connected:",  show addr, show (now - tm), showStat r]
+                            mreport <- timeout 10000000 $ threadReport False -- XXX: Paranoid timeout
+                            case mreport of
+                                Just treport -> dput XTCP treport
+                                Nothing      -> dput XTCP "TCP ERROR: threadReport timed out."
                             hClose h
                 let v = TCPSession
                         { tcpHandle = h