From 36562749e2204da4500742c7f62676c19f0ce999 Mon Sep 17 00:00:00 2001 From: joe Date: Thu, 13 Jul 2017 16:53:05 -0400 Subject: TOX rewrite: Response nonces are now distinct from query nonces. --- Tox.hs | 22 ++++++++----- src/Network/QueryResponse.hs | 76 +++++++++++++++++++++++--------------------- 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 -- cgit v1.2.3