Slower onion queries improve performance.

3 files changed, 31 insertions, 5 deletions

diff --git a/src/Network/BitTorrent/MainlineDHT.hs b/src/Network/BitTorrent/MainlineDHT.hs
index 63e67ad3..991473a9 100644
--- a/src/Network/BitTorrent/MainlineDHT.hs
+++ b/src/Network/BitTorrent/MainlineDHT.hs
@@ -629,6 +629,8 @@ newClient swarms addr = do
                             _             -> routing4 routing
                 R.thisNode <$> readTVar var
             , clientResponseId    = return
+            , clientEnterQuery    = \_ -> return ()
+            , clientLeaveQuery    = \_ _ -> return ()
             }
 
     -- TODO: Provide some means of shutting down these five auxillary threads:
diff --git a/src/Network/QueryResponse.hs b/src/Network/QueryResponse.hs
index 4f65b886..70c35542 100644
--- a/src/Network/QueryResponse.hs
+++ b/src/Network/QueryResponse.hs
@@ -31,7 +31,6 @@ import qualified Data.Word64Map     as W64Map
          ;import Data.Word64Map     (Word64Map)
 import Data.Word
 import Data.Maybe
-import Data.Typeable
 import Network.Socket
 import Network.Socket.ByteString    as B
 import System.Endian
@@ -180,7 +179,7 @@ sendQuery ::
         -> a                                    -- ^ The outbound query.
         -> addr                                 -- ^ Destination address of query.
         -> IO (Maybe b)                         -- ^ The response, or 'Nothing' if it timed out.
-sendQuery (Client net d err pending whoami _) meth q addr0 = do
+sendQuery (Client net d err pending whoami _ enterQuery leaveQuery) meth q addr0 = do
     mvar <- newEmptyMVar
     (tid,addr,expiry) <- atomically $ do
         tbl <- readTVar pending
@@ -189,9 +188,11 @@ sendQuery (Client net d err pending whoami _) meth q addr0 = do
         writeTVar pending tbl'
         return (tid,addr,expiry)
     self <- whoami (Just addr)
+    enterQuery tid
     mres <- do sendMessage net addr (wrapQuery meth tid self addr q)
                timeout expiry $ takeMVar mvar
             `catchIOError` (\e -> return Nothing)
+    leaveQuery tid (isJust mres)
     case mres of
         Just x -> return $ Just $ unwrapResponse meth x
         Nothing -> do
@@ -224,6 +225,10 @@ data Client err meth tid addr x = forall tbl. Client
       -- /tid/ includes a unique cryptographic nonce, then it should be
       -- generated here.
     , clientResponseId :: tid -> IO tid
+      -- | The enter/leave methods are no-ops by default.  They are useful for
+      -- serializing all queries for debugging purposes.
+    , clientEnterQuery :: tid -> IO ()
+    , clientLeaveQuery :: tid -> Bool -> IO ()
     }
 
 -- | An incoming message can be classified into three cases.
@@ -449,7 +454,7 @@ handleMessage ::
     -> addr
     -> x
     -> IO (Maybe (x -> x))
-handleMessage (Client net d err pending whoami responseID) addr plain = do
+handleMessage (Client net d err pending whoami responseID _ _) addr plain = do
     -- Just (Left e)              -> do reportParseError err e
     --                                  return $! Just id
     -- Just (Right (plain, addr)) -> do
@@ -553,3 +558,10 @@ udpTransport' bind_address = do
     , closeTransport = close sock
     }
   return (tr, sock)
+
+serializeClient :: Client err meth tid addr x -> IO (Client err meth tid addr x)
+serializeClient c = do
+    mvar <- newMVar ()
+    return $ c { clientEnterQuery = \tid -> takeMVar mvar
+               , clientLeaveQuery = \tid didRespond -> putMVar mvar ()
+               }
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index ff42fb0d..4cff4f74 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -119,7 +119,6 @@ import Text.XXD
 import qualified Data.HashMap.Strict as HashMap
 import Data.HashMap.Strict (HashMap)
 import qualified Data.Map.Strict as Map
-import Control.Concurrent (threadDelay)
 import DPut
 import Network.Tox.Avahi
 
@@ -239,6 +238,8 @@ newClient drg net classify selfAddr handlers modifytbl modifynet = do
                     , clientPending       = var
                     , clientAddress       = selfAddr
                     , clientResponseId    = genNonce24 var
+                    , clientEnterQuery    = \_ -> return ()
+                    , clientLeaveQuery    = \_ _ -> return ()
                     }
             in client
     return $ either mkclient mkclient tblvar handlers
@@ -407,6 +408,14 @@ getOnionAlias crypto dhtself remoteNode = atomically $ do
     return $ Onion.OnionDestination Onion.SearchingAlias alias Nothing
 
 
+retardSend micros client = do
+    mvar <- newMVar () :: IO (MVar ())
+    return client { clientEnterQuery = \tid -> do
+                        takeMVar mvar
+                        threadDelay micros
+                        putMVar mvar ()
+                  }
+
 newTox :: TVar Onion.AnnouncedKeys   -- ^ Store of announced keys we are a rendezvous for.
        -> SockAddr                   -- ^ Bind-address to listen on.
        -> Maybe NetCryptoSessions    -- ^ State of all one-on-one Tox links.
@@ -484,9 +493,12 @@ newTox keydb addr mbSessionsState suppliedDHTKey = do
                     (hookQueries orouter' DHT.transactionKey)
                     (const id)
 
+    -- onionclientSerialized <- serializeClient onionclient
+    onionRetarded <- retardSend 200000 onionclient
+
     return Tox
         { toxDHT            = dhtclient
-        , toxOnion          = onionclient
+        , toxOnion          = onionRetarded
         , toxToRoute        = onInbound (updateContactInfo roster) dtacrypt
         , toxCrypto         = addHandler (hPutStrLn stderr) (sessionPacketH sessionsState) cryptonet
         , toxHandshakes     = addHandler (hPutStrLn stderr) (handshakeH     sessionsState) handshakes