summaryrefslogtreecommitdiff
path: root/src/Network/QueryResponse.hs
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2018-06-19 16:34:03 -0400
committerjoe <joe@jerkface.net>2018-06-19 16:34:03 -0400
commita564eb632153b7e194c7b09fe646817d621c8f40 (patch)
tree2467c8beb405143e65060f40c344cd172af3e743 /src/Network/QueryResponse.hs
parentc2df7b1192801862112a0f741014e27d490d12b3 (diff)
Slower onion queries improve performance.
Diffstat (limited to 'src/Network/QueryResponse.hs')
-rw-r--r--src/Network/QueryResponse.hs18
1 files changed, 15 insertions, 3 deletions
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
31 ;import Data.Word64Map (Word64Map) 31 ;import Data.Word64Map (Word64Map)
32import Data.Word 32import Data.Word
33import Data.Maybe 33import Data.Maybe
34import Data.Typeable
35import Network.Socket 34import Network.Socket
36import Network.Socket.ByteString as B 35import Network.Socket.ByteString as B
37import System.Endian 36import System.Endian
@@ -180,7 +179,7 @@ sendQuery ::
180 -> a -- ^ The outbound query. 179 -> a -- ^ The outbound query.
181 -> addr -- ^ Destination address of query. 180 -> addr -- ^ Destination address of query.
182 -> IO (Maybe b) -- ^ The response, or 'Nothing' if it timed out. 181 -> IO (Maybe b) -- ^ The response, or 'Nothing' if it timed out.
183sendQuery (Client net d err pending whoami _) meth q addr0 = do 182sendQuery (Client net d err pending whoami _ enterQuery leaveQuery) meth q addr0 = do
184 mvar <- newEmptyMVar 183 mvar <- newEmptyMVar
185 (tid,addr,expiry) <- atomically $ do 184 (tid,addr,expiry) <- atomically $ do
186 tbl <- readTVar pending 185 tbl <- readTVar pending
@@ -189,9 +188,11 @@ sendQuery (Client net d err pending whoami _) meth q addr0 = do
189 writeTVar pending tbl' 188 writeTVar pending tbl'
190 return (tid,addr,expiry) 189 return (tid,addr,expiry)
191 self <- whoami (Just addr) 190 self <- whoami (Just addr)
191 enterQuery tid
192 mres <- do sendMessage net addr (wrapQuery meth tid self addr q) 192 mres <- do sendMessage net addr (wrapQuery meth tid self addr q)
193 timeout expiry $ takeMVar mvar 193 timeout expiry $ takeMVar mvar
194 `catchIOError` (\e -> return Nothing) 194 `catchIOError` (\e -> return Nothing)
195 leaveQuery tid (isJust mres)
195 case mres of 196 case mres of
196 Just x -> return $ Just $ unwrapResponse meth x 197 Just x -> return $ Just $ unwrapResponse meth x
197 Nothing -> do 198 Nothing -> do
@@ -224,6 +225,10 @@ data Client err meth tid addr x = forall tbl. Client
224 -- /tid/ includes a unique cryptographic nonce, then it should be 225 -- /tid/ includes a unique cryptographic nonce, then it should be
225 -- generated here. 226 -- generated here.
226 , clientResponseId :: tid -> IO tid 227 , clientResponseId :: tid -> IO tid
228 -- | The enter/leave methods are no-ops by default. They are useful for
229 -- serializing all queries for debugging purposes.
230 , clientEnterQuery :: tid -> IO ()
231 , clientLeaveQuery :: tid -> Bool -> IO ()
227 } 232 }
228 233
229-- | An incoming message can be classified into three cases. 234-- | An incoming message can be classified into three cases.
@@ -449,7 +454,7 @@ handleMessage ::
449 -> addr 454 -> addr
450 -> x 455 -> x
451 -> IO (Maybe (x -> x)) 456 -> IO (Maybe (x -> x))
452handleMessage (Client net d err pending whoami responseID) addr plain = do 457handleMessage (Client net d err pending whoami responseID _ _) addr plain = do
453 -- Just (Left e) -> do reportParseError err e 458 -- Just (Left e) -> do reportParseError err e
454 -- return $! Just id 459 -- return $! Just id
455 -- Just (Right (plain, addr)) -> do 460 -- Just (Right (plain, addr)) -> do
@@ -553,3 +558,10 @@ udpTransport' bind_address = do
553 , closeTransport = close sock 558 , closeTransport = close sock
554 } 559 }
555 return (tr, sock) 560 return (tr, sock)
561
562serializeClient :: Client err meth tid addr x -> IO (Client err meth tid addr x)
563serializeClient c = do
564 mvar <- newMVar ()
565 return $ c { clientEnterQuery = \tid -> takeMVar mvar
566 , clientLeaveQuery = \tid didRespond -> putMVar mvar ()
567 }