Prefer IPv4 when parsing TCP nodes JSON.

5 files changed, 47 insertions, 9 deletions

diff --git a/dht/src/Data/Tox/Msg.hs b/dht/src/Data/Tox/Msg.hs
index 66ec6eb1..8819faa7 100644
--- a/dht/src/Data/Tox/Msg.hs
+++ b/dht/src/Data/Tox/Msg.hs
@@ -97,6 +97,7 @@ deriving instance (Show (Pkt a))
 
 type CryptoMessage = DSum Pkt Identity
 
+msgID :: DSum Pkt Identity -> SomeMsg
 msgID (Pkt mid :=> Identity _) = M mid
 
 -- TODO
@@ -227,6 +228,7 @@ fromEnum8 = fromIntegral . fromEnum
 
 data LossyOrLossless = Lossless | Lossy deriving (Eq,Ord,Enum,Show,Bounded)
 
+someLossyness :: SomeMsg -> LossyOrLossless
 someLossyness (M m) = lossyness m
 
 lossyness :: KnownNat n => Msg n t -> LossyOrLossless
diff --git a/dht/src/Data/Tox/Relay.hs b/dht/src/Data/Tox/Relay.hs
index c563db8d..f28a1685 100644
--- a/dht/src/Data/Tox/Relay.hs
+++ b/dht/src/Data/Tox/Relay.hs
@@ -16,7 +16,9 @@ import Data.Data
 import Data.Functor.Contravariant
 import Data.Hashable
 import qualified Data.HashMap.Strict as HashMap
+import Data.List
 import Data.Monoid
+import Data.Ord
 import Data.Serialize
 import qualified Data.Vector as Vector
 import Data.Word
@@ -217,13 +219,27 @@ instance ToJSON NodeInfo where
                                                         tbl
         x               -> x -- Shouldn't happen.
 
+tcpPortScore :: Word16 -> Word16
+tcpPortScore 443  = 0
+tcpPortScore 80   = 0
+tcpPortScore 3389 = 1
+tcpPortScore _    = 2
+
 instance FromJSON NodeInfo where
     parseJSON json = do
-        udp <- parseJSON json
+        -- Instead of using ordinary parseJSON to parse the udp node,
+        -- we are using a variation that prefers IPv4 over IPv6.
+        -- The rationale is that must lans without UDP will be using
+        -- IPv4.
+        udp <- UDP.nodeInfoFromJSON True json
         port <- case json of
             JSON.Object v -> do
-                portnum:_ <- v JSON..: "tcp_ports"
-                return  (fromIntegral (portnum :: Word16))
+                ps <- v JSON..: "tcp_ports"
+                if Prelude.null (ps :: [Word16])
+                    then fail "TCP.NodeInfo: missing tcp port"
+                    else do
+                        let portnum = minimumBy (comparing tcpPortScore) ps
+                        return  (fromIntegral portnum)
             _ -> fail "TCP.NodeInfo: Expected JSON object."
         return $ NodeInfo udp port
 
diff --git a/dht/src/DebugUtil.hs b/dht/src/DebugUtil.hs
index e7a10397..96ab8cc5 100644
--- a/dht/src/DebugUtil.hs
+++ b/dht/src/DebugUtil.hs
@@ -25,7 +25,8 @@ showColumns rows = do
     "  " ++ concat (zipWith (printf "%-*s") (init ws) (init fs)) ++ last fs ++ "\n"
 
 
-threadReport :: Bool -> IO String
+threadReport :: Bool -- ^ False to summarize search threads.
+                -> IO String
 threadReport want_ss = do
     threads <- threadsInformation
     tm <- getCurrentTime
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
diff --git a/dht/src/Network/Tox/NodeId.hs b/dht/src/Network/Tox/NodeId.hs
index 9a9c893a..e0169199 100644
--- a/dht/src/Network/Tox/NodeId.hs
+++ b/dht/src/Network/Tox/NodeId.hs
@@ -39,6 +39,7 @@ module Network.Tox.NodeId
     , ToxProgress(..)
     , parseToken32
     , showToken32
+    , nodeInfoFromJSON
     ) where
 
 import Control.Applicative
@@ -52,7 +53,7 @@ import Crypto.Error
 #endif
 
 import Crypto.PubKey.Curve25519
-import qualified Data.Aeson                   as JSON
+import qualified Data.Aeson.Types             as JSON
          ;import Data.Aeson                   (FromJSON, ToJSON, (.=))
 import Data.Bits.ByteString                   ()
 import qualified Data.ByteArray               as BA
@@ -251,13 +252,20 @@ instance ToJSON NodeInfo where
                         , "port" .= (fromIntegral port :: Int)
                         ]
 instance FromJSON NodeInfo where
-    parseJSON (JSON.Object v) = do
+    parseJSON = nodeInfoFromJSON False
+
+nodeInfoFromJSON :: Bool -> JSON.Value
+                         -> JSON.Parser NodeInfo
+nodeInfoFromJSON prefer4 (JSON.Object v) = do
         nidstr <- v JSON..: "public_key"
         ip6str <- v JSON..:? "ipv6"
         ip4str <- v JSON..:? "ipv4"
         portnum <- v JSON..: "port"
-        ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe)
-              <|> maybe empty (return . IPv4) (ip4str >>= readMaybe)
+        ip <- if prefer4
+                then maybe empty (return . IPv4) (ip4str >>= readMaybe)
+                      <|> maybe empty (return . IPv6) (ip6str >>= readMaybe)
+                else maybe empty (return . IPv6) (ip6str >>= readMaybe)
+                      <|> maybe empty (return . IPv4) (ip4str >>= readMaybe)
         let (bs,_) = Base16.decode (C8.pack nidstr)
             enid   = Base64.decode (C8.pack $ 'A' : map (nmtoken64 False) nidstr)
         idbs <- (guard (B.length bs == 32) >> return bs)