Quieter output and some bug fixes.

4 files changed, 45 insertions, 22 deletions

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