Minor refactor.

3 files changed, 28 insertions, 14 deletions

diff --git a/dht/src/Network/QueryResponse.hs b/dht/src/Network/QueryResponse.hs
index 89723da2..44039ee0 100644
--- a/dht/src/Network/QueryResponse.hs
+++ b/dht/src/Network/QueryResponse.hs
@@ -161,6 +161,10 @@ partitionTransport parse encodex tr =
 --      * f add x --> Nothing, consume x
 --                --> Just id, leave x to a different handler
 --                --> Just g, apply g to x and leave that to a different handler
+--
+-- Note: If you add a handler to one of the branches before applying a
+-- 'mergeTransports' combinator, then this handler may not block or return
+-- Nothing.
 addHandler :: (err -> IO ()) -> (addr -> x -> IO (Maybe (x -> x))) -> Transport err addr x -> Transport err addr x
 addHandler onParseError f tr = tr
     { awaitMessage = \kont -> fix $ \eat -> awaitMessage tr $ \case
diff --git a/dht/src/Network/Tox.hs b/dht/src/Network/Tox.hs
index 60b793af..f17bad2c 100644
--- a/dht/src/Network/Tox.hs
+++ b/dht/src/Network/Tox.hs
@@ -327,9 +327,16 @@ newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do
         tbl4 = DHT.routing4 $ mkrouting (error "missing client")
         tbl6 = DHT.routing6 $ mkrouting (error "missing client")
         updateOnion bkts tr = hookBucketList DHT.toxSpace bkts orouter (trampolinesUDP orouter) tr
+        updateOnUDP client = DHT.updateRouting client (mkrouting client) updateOnion
+        -- -- I was going to update the kademlia tables on onion responses so
+        -- -- that there is a pool of nodes to search without UDP, but it is a
+        -- -- bad idea because the kademlia table update algorithm requires the
+        -- -- ability to do a ping and it's not clear what that ping operation
+        -- -- should be.
+        -- updateOnTCP = const $ DHT.updateTable dhtclient (mkrouting client) updateOnion . udpNodeInfo
 
     dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr tbl4 tbl6) (DHT.handlers crypto . mkrouting) id
-                    (\client net -> onInbound (DHT.updateRouting client (mkrouting client) updateOnion) net)
+                    (\client net -> onInbound (updateOnUDP client) net)
 
     hscache <- newHandshakeCache crypto (sendMessage handshakes)
     let sparams = SessionParams
@@ -351,7 +358,7 @@ newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do
 
     onioncrypt <- mergeTransports $ DMap.fromList
         [ Multi.OnionUDP :=> ByAddress onioncryptUDP
-        , Multi.OnionTCP :=> ByAddress onioncryptTCP ]
+        , Multi.OnionTCP :=> ByAddress {- $ onInbound updateOnTCP -} onioncryptTCP ]
     oniondrg <- drgNew
     let onionnet = layerTransportM
                         (\msg od -> Onion.decrypt crypto msg $ Multi.untagOnion od)
diff --git a/dht/src/Network/Tox/DHT/Handlers.hs b/dht/src/Network/Tox/DHT/Handlers.hs
index 5156ec44..73bc2229 100644
--- a/dht/src/Network/Tox/DHT/Handlers.hs
+++ b/dht/src/Network/Tox/DHT/Handlers.hs
@@ -445,30 +445,33 @@ updateRouting client routing orouter naddr0 msg
         forM_ m $ mapM_ $ \NodeInfoCallback{interestingNodeId,observedAddress} -> do
             when (interestingNodeId == nodeId naddr)
                 $ observedAddress now naddr
-    case prefer4or6 (Multi.UDP ==> naddr) Nothing of
-        Want_IP4 -> updateTable client naddr orouter (committee4 routing) (refresher4 routing)
-        Want_IP6 -> updateTable client naddr orouter (committee6 routing) (refresher6 routing)
-        Want_Both -> do dput XMisc "BUG:unreachable"
-                        error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__
+    updateTable client routing orouter naddr
 
-updateTable :: Client -> NodeInfo
+updateTable :: Client -> Routing
                       -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ())
-                      -> TriadCommittee NodeId SockAddr
-                      -> BucketRefresher NodeId NodeInfo
+                      -> NodeInfo
                       -> IO ()
-updateTable client naddr orouter committee refresher = do
+updateTable client routing orouter naddr = do
+    case prefer4or6 (Multi.UDP ==> naddr) Nothing of
+        Want_IP4 -> go (committee4 routing) (refresher4 routing)
+        Want_IP6 -> go (committee6 routing) (refresher6 routing)
+        Want_Both -> do dput XMisc "BUG:unreachable"
+                        error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__
+ where
+    go :: TriadCommittee NodeId SockAddr -> BucketRefresher NodeId NodeInfo -> IO ()
+    go committee refresher = do
         self <- atomically $ R.thisNode <$> readTVar (refreshBuckets refresher)
         -- dput XMisc $ "(tox)updateRouting: " ++ show (nodeIP self, nodeIP naddr)
         when (self /= naddr) $ do
             -- TODO: IP address vote?
-            insertNode (toxKademlia client committee orouter refresher) naddr
+            insertNode (toxKademlia client orouter committee refresher) naddr
 
 toxKademlia :: Client
-                -> TriadCommittee NodeId SockAddr
                 -> (TVar (R.BucketList NodeInfo) -> RoutingTransition NodeInfo -> STM ())
+                -> TriadCommittee NodeId SockAddr
                 -> BucketRefresher NodeId NodeInfo
                 -> Kademlia NodeId NodeInfo
-toxKademlia client committee orouter refresher
+toxKademlia client orouter committee refresher
     = Kademlia quietInsertions
                toxSpace
                (vanillaIO (refreshBuckets refresher) $ pingUDP client)