From 05f443e31b52de18e6e2dd3b7b7bd599f28e4a6f Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Thu, 28 Nov 2019 21:10:25 -0500 Subject: Prefer IPv4 when parsing TCP nodes JSON. --- dht/src/Data/Tox/Msg.hs | 2 ++ dht/src/Data/Tox/Relay.hs | 22 +++++++++++++++++++--- dht/src/DebugUtil.hs | 3 ++- dht/src/Network/QueryResponse/TCP.hs | 13 ++++++++++++- dht/src/Network/Tox/NodeId.hs | 16 ++++++++++++---- 5 files changed, 47 insertions(+), 9 deletions(-) (limited to 'dht') 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) -- cgit v1.2.3