TOX rewrite: Response nonces are now distinct from query nonces.

2 files changed, 54 insertions, 44 deletions

diff --git a/Tox.hs b/Tox.hs
index e1a1bf8a..77cd0ae0 100644
--- a/Tox.hs
+++ b/Tox.hs
@@ -240,16 +240,16 @@ encodePacket :: SecretKey -> SecretsCache -> Message ByteString -> NodeInfo -> (
 encodePacket sk cache msg ni = ( S.runPut . putMessage $ encryptMessage sk cache (nodeId ni) msg
                                , nodeAddr ni )
 
-newClient :: SockAddr -> IO (Client String Method TransactionId NodeInfo (Message ByteString) ())
+newClient :: SockAddr -> IO (Client String Method TransactionId NodeInfo (Message ByteString))
 newClient addr = do
     udp <- udpTransport addr
     secret <- generateSecretKey
     let pubkey = key2id $ toPublic secret
     cache <- newEmptyCache
     drg <- getSystemDRG
-    let me = NodeInfo pubkey (fromMaybe (toEnum 0) $ fromSockAddr addr)
-                             (fromMaybe 0 $ sockAddrPort addr)
-    tox <- atomically $ newTVar (me,())
+    self <- atomically $ newTVar
+             $ NodeInfo pubkey (fromMaybe (toEnum 0) $ fromSockAddr addr)
+                               (fromMaybe 0 $ sockAddrPort addr)
     let net = layerTransport (parsePacket secret cache)
                              (encodePacket secret cache)
                              udp
@@ -258,12 +258,18 @@ newClient addr = do
             , lookupHandler = handlers
             , tableMethods = tbl
             }
+        genNonce24 var (TransactionId nonce8 _) = atomically $ do
+            (g,pending) <- readTVar var
+            let (bs, g') = randomBytesGenerate 24 g
+            writeTVar var (g',pending)
+            return $ TransactionId nonce8 (Nonce24 bs)
         client tbl var = Client
             { clientNet           = net
             , clientDispatcher    = dispatch tbl
             , clientErrorReporter = ignoreErrors -- TODO
             , clientPending       = var
-            , clientContext       = atomically (readTVar tox)
+            , clientAddress       = atomically (readTVar self)
+            , clientResponseId    = genNonce24 var
             }
     if fitsInInt (Proxy :: Proxy Word64)
       then do
@@ -300,7 +306,7 @@ classify (Message { msgType    = typ
             PongType      -> IsResponse
             SendNodesType -> IsResponse
 
-encodePayload typ _ (TransactionId (Nonce8 tid) nonce) self dest b
+encodePayload typ (TransactionId (Nonce8 tid) nonce) self dest b
     = Message { msgType    = typ
               , msgOrigin  = nodeId self
               , msgNonce   = nonce
@@ -312,8 +318,8 @@ decodePayload msg = S.decode $ dropEnd8 $ msgPayload msg
 
 handler typ f = Just $ MethodHandler decodePayload (encodePayload typ) f
 
-handlers :: Method -> Maybe (MethodHandler String TransactionId NodeInfo (Message ByteString) ())
-handlers PingType     = error "handler PingType pingH"
+handlers :: Method -> Maybe (MethodHandler String TransactionId NodeInfo (Message ByteString))
+handlers PingType     = handler PingType pingH
 handlers GetNodesType = error "find_node"
 handlers _            = Nothing
 
diff --git a/src/Network/QueryResponse.hs b/src/Network/QueryResponse.hs
index 221c2284..9262132f 100644
--- a/src/Network/QueryResponse.hs
+++ b/src/Network/QueryResponse.hs
@@ -45,7 +45,7 @@ import System.Timeout
 --  > r <- sendQuery client method q
 --  > -- Quit client.
 --  > quitServer
-forkListener :: Client err meth tid addr x ctx -> IO (IO ())
+forkListener :: Client err meth tid addr x -> IO (IO ())
 forkListener client = do
     thread_id <- forkIO $ do
         myThreadId >>= flip labelThread "listener"
@@ -58,21 +58,21 @@ forkListener client = do
 -- out if 'forkListener' was never invoked to spawn a thread receive and
 -- dispatch the response.
 sendQuery ::
-    forall err a b tbl x ctx meth tid addr.
-        Client err meth tid addr x ctx          -- ^ A query/response implementation.
-        -> MethodSerializer addr x ctx meth a b -- ^ Information for marshalling the query.
-        -> 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 addr = do
+    forall err a b tbl x meth tid addr.
+        Client err meth tid addr x          -- ^ A query/response implementation.
+        -> MethodSerializer addr x meth a b -- ^ Information for marshalling the query.
+        -> 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 addr = do
     mvar <- newEmptyMVar
     tid <- atomically $ do
         tbl <- readTVar pending
         let (tid, tbl') = dispatchRegister (tableMethods d) mvar tbl
         writeTVar pending tbl'
         return tid
-    (self,ctx) <- whoami
-    sendMessage net addr (wrapQuery meth ctx self addr q)
+    self <- whoami
+    sendMessage net addr (wrapQuery meth self addr q)
     mres <- timeout (methodTimeout meth) $ takeMVar mvar
     case mres of
         Just x -> return $ Just $ unwrapResponse meth x
@@ -84,21 +84,25 @@ sendQuery (Client net d err pending whoami) meth q addr = do
 -- * Implementing a query\/response 'Client'.
 
 -- | All inputs required to implement a query\/response client.
-data Client err meth tid addr x ctx = forall tbl. Client
+data Client err meth tid addr x = forall tbl. Client
     { -- | The 'Transport' used to dispatch and receive packets.
       clientNet :: Transport err addr x
       -- | Methods for handling inbound packets.
-    , clientDispatcher :: DispatchMethods tbl err meth tid addr x ctx
+    , clientDispatcher :: DispatchMethods tbl err meth tid addr x
       -- | Methods for reporting various conditions.
     , clientErrorReporter :: ErrorReporter addr x meth tid err
       -- | State necessary for routing inbound responses and assigning unique
       -- /tid/ values for outgoing queries.
     , clientPending :: TVar tbl
-      -- | An action yielding this client\'s own address along with some
-      -- context neccessary for serializing outgoing packets.  It is invoked
-      -- once on each outbound and inbound packet.  It is valid for this to
-      -- always return the same value.
-    , clientContext :: IO (addr,ctx)
+      -- | An action yielding this client\'s own address.  It is invoked once
+      -- on each outbound and inbound packet.  It is valid for this to always
+      -- return the same value.
+    , clientAddress :: IO addr
+      -- | Transform a query /tid/ value to an appropriate response /tid/
+      -- value.  Normally, this would be the identity transformation, but if
+      -- /tid/ includes a unique cryptographic nonce, then it should be
+      -- generated here.
+    , clientResponseId :: tid -> IO tid
     }
 
 -- | An incomming message can be classified into three cases.
@@ -108,13 +112,13 @@ data MessageClass err meth tid
     | IsResponse tid   -- ^ A response to a outgoing query we associated with a /tid/ value.
     | IsUnknown err    -- ^ None of the above.
 
--- | Handler for an inbound query of type _x_ from an address of type _addr_.
-data MethodHandler err tid addr x ctx = forall a b. MethodHandler
+-- | Handler for an inbound query of type /x/ from an address of type _addr_.
+data MethodHandler err tid addr x = forall a b. MethodHandler
     { -- | Parse the query into a more specific type for this method.
       methodParse :: x -> Either err a
       -- | Serialize the response for transmission, given a context /ctx/ and the origin
       -- and destination addresses.
-    , methodSerialize :: ctx -> tid -> addr -> addr -> b -> x
+    , methodSerialize :: tid -> addr -> addr -> b -> x
       -- | Fully typed action to perform upon the query.  The remote origin
       -- address of the query is provided to the handler.
     , methodAction :: addr -> a -> IO b
@@ -123,20 +127,19 @@ data MethodHandler err tid addr x ctx = forall a b. MethodHandler
 -- | Attempt to invoke a 'MethodHandler' upon a given inbound query.  If the
 -- parse is successful, the returned IO action will construct our reply.
 -- Otherwise, a parse err is returned.
-dispatchQuery :: MethodHandler err tid addr x ctx -- ^ Handler to invoke.
-                 -> ctx                           -- ^ Arbitrary context used during serialization.
-                 -> tid                           -- ^ The transaction id for this query\/response session.
-                 -> addr                          -- ^ Our own address, to which the query was sent.
-                 -> x                             -- ^ The query packet.
-                 -> addr                          -- ^ The origin address of the query.
+dispatchQuery :: MethodHandler err tid addr x -- ^ Handler to invoke.
+                 -> tid                       -- ^ The transaction id for this query\/response session.
+                 -> addr                      -- ^ Our own address, to which the query was sent.
+                 -> x                         -- ^ The query packet.
+                 -> addr                      -- ^ The origin address of the query.
                  -> Either err (IO x)
-dispatchQuery (MethodHandler unwrapQ wrapR f) ctx tid self x addr =
-    fmap (\a -> wrapR ctx tid self addr <$> f addr a) $ unwrapQ x
+dispatchQuery (MethodHandler unwrapQ wrapR f) tid self x addr =
+    fmap (\a -> wrapR tid self addr <$> f addr a) $ unwrapQ x
 
 -- | These four parameters are required to implement an ougoing query.  A
 -- peer-to-peer algorithm will define a 'MethodSerializer' for every 'MethodHandler' that
 -- might be returned by 'lookupHandler'.
-data MethodSerializer addr x ctx meth a b = MethodSerializer
+data MethodSerializer addr x meth a b = MethodSerializer
     { -- | Seconds to wait for a response.
       methodTimeout :: Int
       -- | A method identifier used for error reporting.  This needn't be the
@@ -146,7 +149,7 @@ data MethodSerializer addr x ctx meth a b = MethodSerializer
       -- The /addr/ arguments are, respectively, our own origin address and the
       -- destination of the request.  The /ctx/ argument is useful for attaching
       -- auxillary notations on all outgoing packets.
-    , wrapQuery :: ctx -> addr -> addr -> a -> x
+    , wrapQuery :: addr -> addr -> a -> x
       -- | Parse an inbound packet /x/ into a response /b/ for this query.
     , unwrapResponse :: x -> b
     }
@@ -274,11 +277,11 @@ transactionMethods (TableMethods insert delete lookup) generate = TransactionMet
     }
 
 -- | A set of methods neccessary for dispatching incomming packets.
-data DispatchMethods tbl err meth tid addr x ctx = DispatchMethods
+data DispatchMethods tbl err meth tid addr x = DispatchMethods
     { -- | Clasify an inbound packet as a query or response.
       classifyInbound :: x -> MessageClass err meth tid
       -- | Lookup the handler for a inbound query.
-    , lookupHandler :: meth -> Maybe (MethodHandler err tid addr x ctx)
+    , lookupHandler :: meth -> Maybe (MethodHandler err tid addr x)
       -- | Methods for handling incomming responses.
     , tableMethods :: TransactionMethods tbl tid x
     }
@@ -326,10 +329,10 @@ contramapE f (ErrorReporter pe mh unk tim)
 -- 'fix' in a forked thread that loops until 'awaitMessage' returns 'Nothing'
 -- or throws an exception.
 handleMessage ::
-    Client err meth tid addr x ctx
+    Client err meth tid addr x
     -> IO ()
     -> IO ()
-handleMessage (Client net d err pending whoami) again = do
+handleMessage (Client net d err pending whoami responseID) again = do
   awaitMessage net >>= \case
     Just (Left e)              -> do reportParseError err e
                                      again
@@ -338,10 +341,11 @@ handleMessage (Client net d err pending whoami) again = do
             IsQuery meth tid -> case lookupHandler d meth of
                                 Nothing -> reportMissingHandler err meth addr plain
                                 Just m  -> do
-                                  (self,ctx) <- whoami
+                                  self <- whoami
+                                  tid' <- responseID tid
                                   either (reportParseError err)
                                          (>>= sendMessage net addr)
-                                         (dispatchQuery m ctx tid self plain addr)
+                                         (dispatchQuery m tid' self plain addr)
             IsResponse tid -> do
                 action <- atomically $ do
                     ts0 <- readTVar pending