6 files changed, 32 insertions, 30 deletions

diff --git a/dht/src/Network/BitTorrent/MainlineDHT.hs b/dht/src/Network/BitTorrent/MainlineDHT.hs
index 2ea2551e..7589f538 100644
--- a/dht/src/Network/BitTorrent/MainlineDHT.hs
+++ b/dht/src/Network/BitTorrent/MainlineDHT.hs
@@ -1072,7 +1072,7 @@ mainlineSerializeer :: (BEncode a2, BEncode a1) =>
                         -> MethodSerializer
                              TransactionId NodeInfo (Message BValue) Method a1 (Either Error b)
 mainlineSerializeer meth unwrap client = MethodSerializer
-        { methodTimeout  = \_ ni -> return (ni, 5000000)
+        { methodTimeout  = \ni -> return (ni, 5000000)
         , method         = meth
         , wrapQuery      = encodeQueryPayload meth (isReadonlyClient client)
         , unwrapResponse = (>>= either (Left . Error GenericError . C8.pack)
diff --git a/dht/src/Network/QueryResponse.hs b/dht/src/Network/QueryResponse.hs
index 9c33b911..5fcd1989 100644
--- a/dht/src/Network/QueryResponse.hs
+++ b/dht/src/Network/QueryResponse.hs
@@ -217,11 +217,11 @@ asyncQuery_ (Client net d err pending whoami _) meth q addr0 withResponse = do
     now <- getPOSIXTime
     (tid,addr,expiry) <- atomically $ do
         tbl <- readTVar pending
-        ((tid,addr,expiry), tbl') <- dispatchRegister (tableMethods d)
-                (methodTimeout meth)
-                now
+        (addr,expiry) <- methodTimeout meth addr0
+        (tid, tbl') <- dispatchRegister (tableMethods d)
+                (now + microsecondsDiff expiry)
                 (withResponse . fmap (unwrapResponse meth))
-                addr0
+                addr -- XXX: Should be addr0 or addr?
                 tbl
         -- (addr,expiry) <- methodTimeout meth tid addr0
         writeTVar pending tbl'
@@ -365,7 +365,7 @@ data MethodSerializer tid addr x meth a b = MethodSerializer
     { -- | Returns the microseconds to wait for a response to this query being
       -- sent to the given address.  The /addr/ may also be modified to add
       -- routing information.
-      methodTimeout :: tid -> addr -> STM (addr,Int)
+      methodTimeout :: addr -> STM (addr,Int)
       -- | A method identifier used for error reporting.  This needn't be the
       -- same as the /meth/ argument to 'MethodHandler', but it is suggested.
     , method :: meth
@@ -385,21 +385,25 @@ data MethodSerializer tid addr x meth a b = MethodSerializer
 --
 -- The type variable /d/ is used to represent the current state of the
 -- transaction generator and the table of pending transactions.
-data TransactionMethods d tid addr x = TransactionMethods
+data TransactionMethods d qid addr x = TransactionMethods
     {
       -- | Before a query is sent, this function stores an 'MVar' to which the
-      -- response will be written too.  The returned /tid/ is a transaction id
+      -- response will be written too.  The returned /qid/ is a transaction id
       -- that can be used to forget the 'MVar' if the remote peer is not
       -- responding.
-      dispatchRegister :: (tid -> addr -> STM (addr,Int)) -> POSIXTime -> (Maybe x -> IO ()) -> addr -> d -> STM ((tid,addr,Int), d)
+      dispatchRegister :: POSIXTime -- time of expiry
+                          -> (Maybe x -> IO ()) -- callback upon response (or timeout)
+                          -> addr
+                          -> d
+                          -> STM (qid, d)
       -- | This method is invoked when an incoming packet /x/ indicates it is
-      -- a response to the transaction with id /tid/.  The returned IO action
+      -- a response to the transaction with id /qid/.  The returned IO action
       -- will write the packet to the correct 'MVar' thus completing the
       -- dispatch.
-    , dispatchResponse :: tid -> x -> d -> STM (d, IO ())
+    , dispatchResponse :: qid -> x -> d -> STM (d, IO ())
       -- | When a timeout interval elapses, this method is called to remove the
       -- transaction from the table.
-    , dispatchCancel :: tid -> d -> STM d
+    , dispatchCancel :: qid -> d -> STM d
     }
 
 -- | Construct 'TransactionMethods' methods out of 3 lookup table primitives and a
@@ -424,11 +428,10 @@ transactionMethods' ::
     -> TransactionMethods (g,t a) tid addr x
 transactionMethods' store load (TableMethods insert delete lookup) generate = TransactionMethods
     { dispatchCancel = \tid (g,t) -> return (g, delete tid t)
-    , dispatchRegister = \getTimeout now v a0 (g,t) -> do
+    , dispatchRegister = \nowPlusExpiry v a (g,t) -> do
         let (tid,g') = generate g
-        (a,expiry) <- getTimeout tid a0
-        let t' = insert tid (store v) (now + microsecondsDiff expiry) t
-        return ( (tid,a,expiry), (g',t') )
+        let t' = insert tid (store v) nowPlusExpiry t -- (now + microsecondsDiff expiry) t
+        return ( tid, (g',t') )
     , dispatchResponse = \tid x (g,t) ->
         case lookup tid t of
             Just v -> let t' = delete tid t
diff --git a/dht/src/Network/Tox.hs b/dht/src/Network/Tox.hs
index 8a952aa4..34e63ad8 100644
--- a/dht/src/Network/Tox.hs
+++ b/dht/src/Network/Tox.hs
@@ -391,8 +391,8 @@ newToxOverTransport keydb addr onNewSession (crypto,roster) udp tcp = do
         , toxRelayServer    = Nothing
         }
 
-onionTimeout :: Tox extra -> DHT.TransactionId -> Onion.OnionDestination RouteId -> STM (Onion.OnionDestination RouteId, Int)
-onionTimeout Tox { toxOnionRoutes = or } (DHT.TransactionId n8 _) od = lookupTimeout or n8 od
+onionTimeout :: Tox extra -> Onion.OnionDestination RouteId -> STM (Onion.OnionDestination RouteId, Int)
+onionTimeout Tox { toxOnionRoutes = or } od = lookupTimeout or od
 
 routing4nodeInfo :: DHT.Routing -> IO NodeInfo
 routing4nodeInfo (DHT.routing4 -> tv) = R.thisNode <$> readTVarIO tv
diff --git a/dht/src/Network/Tox/DHT/Handlers.hs b/dht/src/Network/Tox/DHT/Handlers.hs
index 1eec93b9..e97cab96 100644
--- a/dht/src/Network/Tox/DHT/Handlers.hs
+++ b/dht/src/Network/Tox/DHT/Handlers.hs
@@ -330,7 +330,7 @@ serializer :: PacketKind
                 -> (Message -> Maybe (Asymm (Nonce8,pong)))
                 -> MethodSerializer TransactionId NodeInfo Message PacketKind ping (Maybe pong)
 serializer pktkind mkping mkpong = MethodSerializer
-        { methodTimeout  = \tid addr -> return (addr, 5000000)
+        { methodTimeout  = \addr -> return (addr, 5000000)
         , method         = pktkind
         -- wrapQuery :: tid -> addr -> addr -> qry -> x
         , wrapQuery      = \tid src dst ping -> mkping $ wrapAsymm tid src dst (, ping)
@@ -376,7 +376,7 @@ cookieRequest crypto client localUserKey addr = do
         nid = id2key $ nodeId addr
         cookieSerializer
             = MethodSerializer
-                   { methodTimeout  = \tid addr -> return (addr, 5000000)
+                   { methodTimeout  = \addr -> return (addr, 5000000)
                    , method    = CookieRequestType
                    , wrapQuery = \tid src dst cr -> DHTCookieRequest $ wrapAsymm tid src dst (, cr)
                    , unwrapResponse = fmap snd . unCookie
diff --git a/dht/src/Network/Tox/Onion/Handlers.hs b/dht/src/Network/Tox/Onion/Handlers.hs
index 25713aa1..3ea7395f 100644
--- a/dht/src/Network/Tox/Onion/Handlers.hs
+++ b/dht/src/Network/Tox/Onion/Handlers.hs
@@ -212,7 +212,7 @@ handlers net routing toks keydb AnnounceType
 handlers net _ _ keydb _ = Just $ NoReply Right $ dataToRouteH keydb net
 
 
-toxidSearch :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+toxidSearch :: (OnionDestination r -> STM (OnionDestination r, Int))
                -> TransportCrypto
                -> Client r
                -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Rendezvous
@@ -224,7 +224,7 @@ toxidSearch getTimeout crypto client = Search
     , searchK     = 6
     }
 
-announceSerializer :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+announceSerializer :: (OnionDestination r -> STM (OnionDestination r, Int))
                    -> MethodSerializer
                         TransactionId
                         (OnionDestination r)
@@ -276,7 +276,7 @@ unwrapAnnounceResponse alias ni (AnnounceResponse is_stored (SendNodes ns))
 -- started.
 
 
-sendOnion :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+sendOnion :: (OnionDestination r -> STM (OnionDestination r, Int))
             -> Client r
             -> AnnounceRequest
             -> OnionDestination r
@@ -291,8 +291,7 @@ sendOnion getTimeout client req oaddr unwrap =
           (return . Just . unwrap (onionNodeInfo oaddr))
           $ join mb
 
-asyncOnion :: (TransactionId
-                     -> OnionDestination r -> STM (OnionDestination r, Int))
+asyncOnion :: (OnionDestination r -> STM (OnionDestination r, Int))
                     -> QR.Client
                          err
                          PacketKind
@@ -316,7 +315,7 @@ asyncOnion getTimeout client req oaddr unwrap go =
 
 
 -- | Lookup the secret counterpart for a given alias key.
-getRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+getRendezvous :: (OnionDestination r -> STM (OnionDestination r, Int))
             -> TransportCrypto
             -> Client r
             -> NodeId
@@ -334,7 +333,7 @@ getRendezvous getTimeout crypto client nid ni = do
         (unwrapAnnounceResponse rkey)
 
 asyncGetRendezvous
-    :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+    :: (OnionDestination r -> STM (OnionDestination r, Int))
        -> TransportCrypto
        -> Client r
        -> NodeId
@@ -353,7 +352,7 @@ asyncGetRendezvous getTimeout crypto client nid ni go = do
         (unwrapAnnounceResponse rkey)
         go
 
-putRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
+putRendezvous :: (OnionDestination r -> STM (OnionDestination r, Int))
                -> TransportCrypto
                -> Client r
                -> PublicKey
diff --git a/dht/src/Network/Tox/TCP.hs b/dht/src/Network/Tox/TCP.hs
index d0d67f25..e80a22d1 100644
--- a/dht/src/Network/Tox/TCP.hs
+++ b/dht/src/Network/Tox/TCP.hs
@@ -229,7 +229,7 @@ getUDPNodes' tcp seeking dst0 = do
                         AnnounceRequest
                         (Either String AnnounceResponse)
             meth = MethodSerializer
-                    { methodTimeout = \tid addr -> return (addr,12000000) -- 12 second timeout
+                    { methodTimeout = \addr -> return (addr,12000000) -- 12 second timeout
                     , method = OnionPacketID -- meth
                     , wrapQuery = \n8 src gateway x -> (,) True $
                         OnionPacket n24 $ Addressed (UDP.nodeAddr dst)
@@ -269,7 +269,7 @@ tcpPing client dst = do
  where meth = MethodSerializer
                 { wrapQuery      = \n8 src dst () -> (True,RelayPing n8)
                 , unwrapResponse = \_ -> ()
-                , methodTimeout  = \n8 dst -> return (dst,5000000)
+                , methodTimeout  = \dst -> return (dst,5000000)
                 , method         = PingPacket
                 }