diff options
author | joe <joe@jerkface.net> | 2018-06-19 16:34:03 -0400 |
---|---|---|
committer | joe <joe@jerkface.net> | 2018-06-19 16:34:03 -0400 |
commit | a564eb632153b7e194c7b09fe646817d621c8f40 (patch) | |
tree | 2467c8beb405143e65060f40c344cd172af3e743 /src/Network/QueryResponse.hs | |
parent | c2df7b1192801862112a0f741014e27d490d12b3 (diff) |
Slower onion queries improve performance.
Diffstat (limited to 'src/Network/QueryResponse.hs')
-rw-r--r-- | src/Network/QueryResponse.hs | 18 |
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) |
32 | import Data.Word | 32 | import Data.Word |
33 | import Data.Maybe | 33 | import Data.Maybe |
34 | import Data.Typeable | ||
35 | import Network.Socket | 34 | import Network.Socket |
36 | import Network.Socket.ByteString as B | 35 | import Network.Socket.ByteString as B |
37 | import System.Endian | 36 | import 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. |
183 | sendQuery (Client net d err pending whoami _) meth q addr0 = do | 182 | sendQuery (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)) |
452 | handleMessage (Client net d err pending whoami responseID) addr plain = do | 457 | handleMessage (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 | |||
562 | serializeClient :: Client err meth tid addr x -> IO (Client err meth tid addr x) | ||
563 | serializeClient c = do | ||
564 | mvar <- newMVar () | ||
565 | return $ c { clientEnterQuery = \tid -> takeMVar mvar | ||
566 | , clientLeaveQuery = \tid didRespond -> putMVar mvar () | ||
567 | } | ||