From 8903c7e0b9eea11dbf229747e7f9729bfe5d2f7b Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 4 Nov 2017 22:21:24 -0400 Subject: Quieter output and some bug fixes. --- src/Network/QueryResponse.hs | 24 ++++++++++++++++-------- src/Network/Tox.hs | 27 +++++++++++++++++---------- src/Network/Tox/DHT/Handlers.hs | 10 +++++++++- src/Network/Tox/Onion/Transport.hs | 6 +++--- 4 files changed, 45 insertions(+), 22 deletions(-) (limited to 'src') diff --git a/src/Network/QueryResponse.hs b/src/Network/QueryResponse.hs index b757aed7..0345dd88 100644 --- a/src/Network/QueryResponse.hs +++ b/src/Network/QueryResponse.hs @@ -503,6 +503,17 @@ ignoreEOF def e | isEOFError e = pure def udpBufferSize :: Int udpBufferSize = 65536 +-- | Wrapper around 'B.sendTo' that silently ignores DoesNotExistError. +saferSendTo :: Socket -> ByteString -> SockAddr -> IO () +saferSendTo sock bs saddr = void (B.sendTo sock bs saddr) + `catch` \e -> + -- sendTo: does not exist (Network is unreachable) + -- Occurs when IPv6 or IPv4 network is not available. + -- Currently, we require -threaded to prevent a forever-hang in this case. + if isDoesNotExistError e + then return () + else throw e + -- | A 'udpTransport' uses a UDP socket to send and receive 'ByteString's. The -- argument is the listen-address for incoming packets. This is a useful -- low-level 'Transport' that can be transformed for higher-level protocols @@ -520,22 +531,19 @@ udpTransport bind_address = do Just . Right <$!> B.recvFrom sock udpBufferSize kont $! r , sendMessage = case family of - -- TODO: sendTo: does not exist (Network is unreachable) - -- Occurs when IPv6 network is not available. - -- Currently, we require -threaded to prevent a forever-hang in this case. AF_INET6 -> \case (SockAddrInet port addr) -> \bs -> -- Change IPv4 to 4mapped6 address. - void $ B.sendTo sock bs $ SockAddrInet6 port 0 (0,0,0x0000ffff,fromBE32 addr) 0 - addr6 -> \bs -> void $ B.sendTo sock bs addr6 + saferSendTo sock bs $ SockAddrInet6 port 0 (0,0,0x0000ffff,fromBE32 addr) 0 + addr6 -> \bs -> saferSendTo sock bs addr6 AF_INET -> \case (SockAddrInet6 port 0 (0,0,0x0000ffff,raw4) 0) -> \bs -> do let host4 = toBE32 raw4 -- Change 4mapped6 to ordinary IPv4. -- hPutStrLn stderr $ "4mapped6 -> "++show (SockAddrInet port host4) - void $ B.sendTo sock bs (SockAddrInet port host4) + saferSendTo sock bs (SockAddrInet port host4) addr@(SockAddrInet6 {}) -> \bs -> hPutStrLn stderr ("Discarding packet to "++show addr) - addr4 -> \bs -> void $ B.sendTo sock bs addr4 - _ -> \addr bs -> void $ B.sendTo sock bs addr + addr4 -> \bs -> saferSendTo sock bs addr4 + _ -> \addr bs -> saferSendTo sock bs addr , closeTransport = close sock } diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs index 9f41fbe5..7179e3c2 100644 --- a/src/Network/Tox.hs +++ b/src/Network/Tox.hs @@ -284,24 +284,31 @@ getOnionAlias crypto dhtself remoteNode = atomically $ do newTox :: TVar Onion.AnnouncedKeys -> SockAddr -> Maybe NetCryptoSessions -> Maybe SecretKey -> IO Tox newTox keydb addr mbSessionsState suppliedDHTKey = do - udp <- addVerbosity <$> udpTransport addr - (crypto,sessionsState) <- case mbSessionsState of + udp <- {- addVerbosity <$> -} udpTransport addr + (crypto0,sessionsState) <- case mbSessionsState of Nothing -> do - crypto0 <- newCrypto - let crypto = fromMaybe crypto0 $do - k <- suppliedDHTKey - return crypto0 - { transportSecret = k - , transportPublic = toPublic k - } + crypto <- newCrypto sessionsState <- newSessionsState crypto defaultUnRecHook defaultCryptoDataHooks return (crypto,sessionsState) Just s -> return (transportCrypto s, s) + + let crypto = fromMaybe crypto0 $do + k <- suppliedDHTKey + return crypto0 + { transportSecret = k + , transportPublic = toPublic k + } + forM_ suppliedDHTKey $ \k -> do + maybe (hPutStrLn stderr "failed to encode suppliedDHTKey") + (C8.hPutStrLn stderr . C8.append "Using suppliedDHTKey: ") + $ encodeSecret k + drg <- drgNew let lookupClose _ = return Nothing routing <- DHT.newRouting addr crypto updateIP updateIP - orouter <- newOnionRouter + let ignoreErrors _ = return () -- Set this to (hPutStrLn stderr) to debug onion route building. + orouter <- newOnionRouter ignoreErrors (dhtcrypt,onioncrypt,dtacrypt,cryptonet) <- toxTransport crypto orouter lookupClose udp let dhtnet0 = layerTransport (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr routing) (DHT.handlers crypto routing) id diff --git a/src/Network/Tox/DHT/Handlers.hs b/src/Network/Tox/DHT/Handlers.hs index 89f3d442..fc28e2d2 100644 --- a/src/Network/Tox/DHT/Handlers.hs +++ b/src/Network/Tox/DHT/Handlers.hs @@ -383,12 +383,20 @@ isCookieRequest _ _ = Left "Bad cookie request" mkCookie :: TransactionId -> NodeInfo -> NodeInfo -> Cookie -> DHTMessage ((,) Nonce8) mkCookie (TransactionId n8 n24) src dst cookie = DHTCookie n24 (n8,cookie) +isDHTRequest :: (f DHTRequest -> DHTRequest) -> DHTMessage f -> Either String DHTRequest +isDHTRequest unpack (DHTDHTRequest pubkey a) = Right $ unpack $ asymmData a +isDHTRequest _ _ = Left "Bad dht relay request" + +dhtRequestH :: NodeInfo -> DHTRequest -> IO () +dhtRequestH ni req = do + hPutStrLn stderr $ "Unhandled DHT Request: " ++ show req handlers :: TransportCrypto -> Routing -> PacketKind -> Maybe Handler handlers _ routing PingType = Just $ MethodHandler (isPing snd) mkPong $ pingH handlers _ routing GetNodesType = Just $ MethodHandler (isGetNodes snd) mkSendNodes $ getNodesH routing handlers crypto _ CookieRequestType = Just $ MethodHandler (isCookieRequest snd) mkCookie $ cookieRequestH crypto -handlers _ _ _ = error "TODO handlers" +handlers _ _ DHTRequestType = Just $ NoReply (isDHTRequest snd) $ dhtRequestH +handlers _ _ typ = error $ "TODO DHT handlers " ++ show typ nodeSearch :: Client -> Search NodeId (IP,PortNumber) () NodeInfo NodeInfo nodeSearch client = Search diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs index 39ea8c46..5b7aad0b 100644 --- a/src/Network/Tox/Onion/Transport.hs +++ b/src/Network/Tox/Onion/Transport.hs @@ -247,8 +247,8 @@ encodeOnionAddr getRoute (msg,OnionDestination _ ni (Just rid)) = do , nodeAddr $ routeNodeA route) mapM' f x = do let _ = x :: Maybe OnionRoute - hPutStrLn stderr $ "ONION encode sending to " ++ show ni - hPutStrLn stderr $ "ONION encode getRoute -> " ++ show (fmap (\y -> map ($ y) [routeNodeA,routeNodeB,routeNodeC]) x) + -- hPutStrLn stderr $ "ONION encode sending to " ++ show ni + -- hPutStrLn stderr $ "ONION encode getRoute -> " ++ show (fmap (\y -> map ($ y) [routeNodeA,routeNodeB,routeNodeC]) x) mapM f x -- ONION encode getRoute -> Nothing getRoute ni rid >>= mapM' go @@ -846,7 +846,7 @@ parseDataToRoute crypto (OnionToRouteResponse dta, od) = do (Left (dataFromKey dtr, dataToRoute dtr)) return (pk,dtr,omsg) - eInner = foldr1 (<|>) eInners + eInner = foldr (<|>) (Left "no user key") eInners e = do (pk,dtr,omsg) <- eInner -- cgit v1.2.3