From a564eb632153b7e194c7b09fe646817d621c8f40 Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Tue, 19 Jun 2018 16:34:03 -0400
Subject: Slower onion queries improve performance.

---
 src/Network/QueryResponse.hs | 18 +++++++++++++++---
 1 file changed, 15 insertions(+), 3 deletions(-)

(limited to 'src/Network/QueryResponse.hs')

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 ()
+               }
-- 
cgit v1.2.3