diff --git a/flake.lock b/flake.lock index c08d26d06ad..a2ead992edb 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1727364445, - "narHash": "sha256-i/m1fmNx0BQbRvHz9ZbY6t0I5BGqwyCA/Jd/BL1Lp0Q=", + "lastModified": 1728296934, + "narHash": "sha256-bMr85Sf2+nWStBTVXgiyqsIArXgP2BdTZ1W3lJICtWE=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "a28f93d778031ddabda3ac1aef9616ae933eea82", + "rev": "c5affa10c9765b8bd79146a7042cffbb87e791ce", "type": "github" }, "original": { diff --git a/network-mux/demo/mux-demo.hs b/network-mux/demo/mux-demo.hs index e80a2dbc76e..2329cd85d43 100644 --- a/network-mux/demo/mux-demo.hs +++ b/network-mux/demo/mux-demo.hs @@ -133,7 +133,7 @@ serverWorker bearer = do putStrLn $ "Result: " ++ show result Mx.stop mux - Mx.run nullTracer mux bearer + Mx.run nullTracer 1 mux bearer where ptcls :: [MiniProtocolInfo ResponderMode] ptcls = [ MiniProtocolInfo { @@ -192,7 +192,7 @@ clientWorker bearer n msg = do putStrLn $ "Result: " ++ show result Mx.stop mux - Mx.run nullTracer mux bearer + Mx.run nullTracer 0 mux bearer where ptcls :: [MiniProtocolInfo Mx.InitiatorMode] ptcls = [ MiniProtocolInfo { diff --git a/network-mux/src/Control/Concurrent/JobPool.hs b/network-mux/src/Control/Concurrent/JobPool.hs index c78ad01c381..d8f81c9ec27 100644 --- a/network-mux/src/Control/Concurrent/JobPool.hs +++ b/network-mux/src/Control/Concurrent/JobPool.hs @@ -12,6 +12,7 @@ module Control.Concurrent.JobPool , Job (..) , withJobPool , forkJob + , forkJobOn , readSize , readGroupSize , waitForJob @@ -29,6 +30,9 @@ import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork (MonadThread (..)) import Control.Monad.Class.MonadThrow +import Control.Concurrent (getNumCapabilities) +import System.IO.Unsafe (unsafePerformIO) + -- | JobPool allows to submit asynchronous jobs, wait for their completion or -- cancel. Jobs are grouped, each group can be cancelled separately. -- @@ -69,16 +73,18 @@ withJobPool = jobs <- readTVarIO jobsVar mapM_ uninterruptibleCancel jobs -forkJob :: forall group m a. - ( MonadAsync m, MonadMask m - , Ord group - ) - => JobPool group m a - -> Job group m a - -> m () -forkJob JobPool{jobsVar, completionQueue} (Job action handler group label) = + +forkJob' :: forall group m a. + ( MonadAsync m, MonadMask m + , Ord group + ) + => (m () -> m (Async m ())) + -> JobPool group m a + -> Job group m a + -> m () +forkJob' doFork JobPool{jobsVar, completionQueue} (Job action handler group label) = mask $ \restore -> do - jobAsync <- async $ do + jobAsync <- doFork $ do tid <- myThreadId io tid restore `onException` @@ -104,6 +110,35 @@ forkJob JobPool{jobsVar, completionQueue} (Job action handler group label) = restore action atomically $ writeTQueue completionQueue res + + +forkJob :: forall group m a. + ( MonadAsync m, MonadMask m + , Ord group + ) + => JobPool group m a + -> Job group m a + -> m () +forkJob = forkJob' async + + +forkJobOn :: forall group m a. + ( MonadAsync m, MonadMask m + , Ord group + ) + => Int + -> JobPool group m a + -> Job group m a + -> m () +forkJobOn c = forkJob' (asyncOn limitCapability) + where + limitCapability :: Int + limitCapability = + -- TODO: add `getNumCapabilities` to `MonadFork` + let sysCap = unsafePerformIO getNumCapabilities in + c `mod` (max 1 $ sysCap - 2) + + readSize :: MonadSTM m => JobPool group m a -> STM m Int readSize JobPool{jobsVar} = Map.size <$> readTVar jobsVar diff --git a/network-mux/src/Network/Mux.hs b/network-mux/src/Network/Mux.hs index 34f66cb1ef0..66cfae68f39 100644 --- a/network-mux/src/Network/Mux.hs +++ b/network-mux/src/Network/Mux.hs @@ -211,10 +211,11 @@ run :: forall m mode. , MonadMask m ) => Tracer m Trace + -> Int -> Mux mode m -> Bearer m -> m () -run tracer Mux {muxMiniProtocols, muxControlCmdQueue, muxStatus} bearer@Bearer {name} = do +run tracer peerHash Mux {muxMiniProtocols, muxControlCmdQueue, muxStatus} bearer@Bearer{name} = do egressQueue <- atomically $ newTBQueue 100 -- label shared variables @@ -231,7 +232,8 @@ run tracer Mux {muxMiniProtocols, muxControlCmdQueue, muxStatus} bearer@Bearer { -- Wait for someone to shut us down by calling muxStop or an error. -- Outstanding jobs are shut down Upon completion of withJobPool. withTimeoutSerial $ \timeout -> - monitor tracer + monitor peerHash + tracer timeout jobpool egressQueue @@ -375,14 +377,15 @@ monitor :: forall mode m. , Alternative (STM m) , MonadThrow (STM m) ) - => Tracer m Trace + => Int + -> Tracer m Trace -> TimeoutFn m -> JobPool.JobPool Group m JobResult -> EgressQueue m -> StrictTQueue m (ControlCmd mode m) -> StrictTVar m Status -> m () -monitor tracer timeout jobpool egressQueue cmdQueue muxStatus = +monitor peerHash tracer timeout jobpool egressQueue cmdQueue muxStatus = go (MonitorCtx Map.empty) where go :: MonitorCtx m mode -> m () @@ -451,7 +454,7 @@ monitor tracer timeout jobpool egressQueue cmdQueue muxStatus = ptclAction) -> do traceWith tracer (TraceStartEagerly miniProtocolNum (protocolDirEnum miniProtocolDir)) - JobPool.forkJob jobpool $ + JobPool.forkJobOn peerHash jobpool $ miniProtocolJob tracer egressQueue diff --git a/network-mux/test/Test/Mux.hs b/network-mux/test/Test/Mux.hs index f8049b8cb2f..24a8acede7e 100644 --- a/network-mux/test/Test/Mux.hs +++ b/network-mux/test/Test/Mux.hs @@ -358,8 +358,8 @@ prop_mux_snd_recv (DummyRun messages) = ioProperty $ do serverMux <- Mx.new [serverApp] - withAsync (Mx.run clientTracer clientMux clientBearer) $ \clientAsync -> - withAsync (Mx.run serverTracer serverMux serverBearer) $ \serverAsync -> do + withAsync (Mx.run clientTracer 0 clientMux clientBearer) $ \clientAsync -> + withAsync (Mx.run serverTracer 0 serverMux serverBearer) $ \serverAsync -> do r <- step clientMux clientApp serverMux serverApp messages Mx.stop serverMux @@ -434,10 +434,10 @@ prop_mux_snd_recv_bi (DummyRun messages) = ioProperty $ do clientMux <- Mx.new clientApps - clientAsync <- async $ Mx.run clientTracer clientMux clientBearer + clientAsync <- async $ Mx.run clientTracer 0 clientMux clientBearer serverMux <- Mx.new serverApps - serverAsync <- async $ Mx.run serverTracer serverMux serverBearer + serverAsync <- async $ Mx.run serverTracer 1 serverMux serverBearer r <- step clientMux clientApps serverMux serverApps messages Mx.stop clientMux @@ -541,7 +541,7 @@ prop_mux_snd_recv_compat messages = ioProperty $ do ) -- Wait for the first MuxApplication to finish, then stop the mux. - withAsync (Mx.run clientTracer clientMux clientBearer) $ \aid -> do + withAsync (Mx.run clientTracer 0 clientMux clientBearer) $ \aid -> do _ <- atomically res Mx.stop clientMux wait aid @@ -559,7 +559,7 @@ prop_mux_snd_recv_compat messages = ioProperty $ do ) -- Wait for the first MuxApplication to finish, then stop the mux. - withAsync (Mx.run serverTracer serverMux serverBearer) $ \aid -> do + withAsync (Mx.run serverTracer 1 serverMux serverBearer) $ \aid -> do _ <- atomically res Mx.stop serverMux wait aid @@ -719,7 +719,7 @@ runMuxApplication initApps initBearer respApps respBearer = do respMux <- Mx.new $ map (\(pn,_) -> MiniProtocolInfo (Mx.MiniProtocolNum pn) Mx.ResponderDirectionOnly defaultMiniProtocolLimits) respApps' - respAsync <- async $ Mx.run serverTracer respMux respBearer + respAsync <- async $ Mx.run serverTracer 1 respMux respBearer getRespRes <- sequence [ Mx.runMiniProtocol respMux (Mx.MiniProtocolNum pn) @@ -732,7 +732,7 @@ runMuxApplication initApps initBearer respApps respBearer = do initMux <- Mx.new $ map (\(pn,_) -> MiniProtocolInfo (Mx.MiniProtocolNum pn) Mx.InitiatorDirectionOnly defaultMiniProtocolLimits) initApps' - initAsync <- async $ Mx.run clientTracer initMux initBearer + initAsync <- async $ Mx.run clientTracer 0 initMux initBearer getInitRes <- sequence [ Mx.runMiniProtocol initMux (Mx.MiniProtocolNum pn) @@ -952,17 +952,17 @@ prop_mux_starvation (Uneven response0 response1) = } serverMux <- Mx.new [serverApp2, serverApp3] - serverMux_aid <- async $ Mx.run serverTracer serverMux serverBearer + serverMux_aid <- async $ Mx.run serverTracer 0 serverMux serverBearer serverRes2 <- Mx.runMiniProtocol serverMux (miniProtocolNum serverApp2) (miniProtocolDir serverApp2) Mx.StartOnDemand server_short serverRes3 <- Mx.runMiniProtocol serverMux (miniProtocolNum serverApp3) (miniProtocolDir serverApp3) Mx.StartOnDemand server_long clientMux <- Mx.new [clientApp2, clientApp3] - clientMux_aid <- async $ Mx.run (clientTracer <> headerTracer) clientMux clientBearer - clientRes2 <- Mx.runMiniProtocol clientMux (Mx.miniProtocolNum clientApp2) (Mx.miniProtocolDir clientApp2) + clientMux_aid <- async $ Mx.run (clientTracer <> headerTracer) 1 clientMux clientBearer + clientRes2 <- Mx.runMiniProtocol clientMux (miniProtocolNum clientApp2) (miniProtocolDir clientApp2) Mx.StartEagerly client_short - clientRes3 <- Mx.runMiniProtocol clientMux (Mx.miniProtocolNum clientApp3) (Mx.miniProtocolDir clientApp3) + clientRes3 <- Mx.runMiniProtocol clientMux (miniProtocolNum clientApp3) (miniProtocolDir clientApp3) Mx.StartEagerly client_long @@ -1157,7 +1157,7 @@ prop_demux_sdu a = do serverRes <- Mx.runMiniProtocol serverMux (Mx.miniProtocolNum serverApp) (Mx.miniProtocolDir serverApp) Mx.StartEagerly server_mp - said <- async $ Mx.run serverTracer serverMux serverBearer + said <- async $ Mx.run serverTracer 1 serverMux serverBearer return (server_r, said, serverRes, serverMux) -- Server that expects to receive a specific ByteString. @@ -1432,7 +1432,7 @@ prop_mux_restart_m (DummyRestartingInitiatorApps apps) = do let minis = map (appToInfo Mx.InitiatorDirectionOnly . fst) apps mux <- Mx.new minis - mux_aid <- async $ Mx.run nullTracer mux bearer + mux_aid <- async $ Mx.run nullTracer 0 mux bearer getRes <- sequence [ Mx.runMiniProtocol mux (daNum $ fst app) @@ -1479,7 +1479,7 @@ prop_mux_restart_m (DummyRestartingResponderApps rapps) = do minis = map (appToInfo Mx.ResponderDirectionOnly) apps mux <- Mx.new minis - mux_aid <- async $ Mx.run nullTracer mux bearer + mux_aid <- async $ Mx.run nullTracer 1 mux bearer getRes <- sequence [ Mx.runMiniProtocol mux (daNum $ fst app) @@ -1528,7 +1528,7 @@ prop_mux_restart_m (DummyRestartingInitiatorResponderApps rapps) = do respMinis = map (appToInfo Mx.ResponderDirection) apps mux <- Mx.new $ initMinis ++ respMinis - mux_aid <- async $ Mx.run nullTracer mux bearer + mux_aid <- async $ Mx.run nullTracer 1 mux bearer getInitRes <- sequence [ Mx.runMiniProtocol mux (daNum $ fst app) @@ -1603,7 +1603,7 @@ prop_mux_start_m bearer _ checkRes (DummyInitiatorApps apps) runTime = do minRunTime = minimum $ runTime : (map daRunTime $ filter (\app -> daAction app == DummyAppFail) apps) mux <- Mx.new minis - mux_aid <- async $ Mx.run nullTracer mux bearer + mux_aid <- async $ Mx.run nullTracer 0 mux bearer killer <- async $ (threadDelay runTime) >> Mx.stop mux getRes <- sequence [ Mx.runMiniProtocol mux @@ -1624,7 +1624,7 @@ prop_mux_start_m bearer trigger checkRes (DummyResponderApps apps) runTime = do minRunTime = minimum $ runTime : (map (\a -> daRunTime a + daStartAfter a) $ filter (\app -> daAction app == DummyAppFail) apps) mux <- Mx.new minis - mux_aid <- async $ Mx.run verboseTracer mux bearer + mux_aid <- async $ Mx.run verboseTracer 0 mux bearer getRes <- sequence [ Mx.runMiniProtocol mux (daNum app) @@ -1650,7 +1650,7 @@ prop_mux_start_m bearer _trigger _checkRes (DummyResponderAppsKillMux apps) runT let minis = map (appToInfo Mx.ResponderDirectionOnly) apps mux <- Mx.new minis - mux_aid <- async $ Mx.run verboseTracer mux bearer + mux_aid <- async $ Mx.run verboseTracer 1 mux bearer getRes <- sequence [ Mx.runMiniProtocol mux (daNum app) @@ -1673,7 +1673,7 @@ prop_mux_start_m bearer trigger checkRes (DummyInitiatorResponderApps apps) runT minRunTime = minimum $ runTime : (map (\a -> daRunTime a) $ filter (\app -> daAction app == DummyAppFail) apps) mux <- Mx.new $ initMinis ++ respMinis - mux_aid <- async $ Mx.run verboseTracer mux bearer + mux_aid <- async $ Mx.run verboseTracer 0 mux bearer getInitRes <- sequence [ Mx.runMiniProtocol mux (daNum app) @@ -1835,7 +1835,7 @@ close_experiment ]) Mx.stop $ \mux -> withNetworkCtx clientCtx $ \clientBearer -> - withAsync (Mx.run ((Client,) `contramap` muxTracer) mux clientBearer) $ \_muxAsync -> + withAsync (Mx.run ((Client,) `contramap` muxTracer) 0 mux clientBearer) $ \_muxAsync -> Mx.runMiniProtocol mux miniProtocolNum Mx.InitiatorDirectionOnly Mx.StartEagerly @@ -1853,7 +1853,7 @@ close_experiment ]) Mx.stop $ \mux -> withNetworkCtx serverCtx $ \serverBearer -> - withAsync (Mx.run ((Server,) `contramap` muxTracer) mux serverBearer) $ \_muxAsync -> do + withAsync (Mx.run ((Server,) `contramap` muxTracer) 0 mux serverBearer) $ \_muxAsync -> do Mx.runMiniProtocol mux miniProtocolNum Mx.ResponderDirectionOnly Mx.StartOnDemand diff --git a/ouroboros-network-api/src/Ouroboros/Network/SizeInBytes.hs b/ouroboros-network-api/src/Ouroboros/Network/SizeInBytes.hs index e92259d8de0..c7c9e018d77 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/SizeInBytes.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/SizeInBytes.hs @@ -17,6 +17,7 @@ import Quiet (Quiet (..)) newtype SizeInBytes = SizeInBytes { getSizeInBytes :: Word32 } deriving (Eq, Ord) deriving Show via Quiet SizeInBytes + deriving Bounded via Word32 deriving Enum via Word32 deriving Num via Word32 deriving Real via Word32 diff --git a/ouroboros-network-framework/demo/connection-manager.hs b/ouroboros-network-framework/demo/connection-manager.hs index af64c266c90..49a0ed34dfa 100644 --- a/ouroboros-network-framework/demo/connection-manager.hs +++ b/ouroboros-network-framework/demo/connection-manager.hs @@ -37,6 +37,7 @@ import Control.Tracer (Tracer (..), contramap, nullTracer, traceWith) import Data.ByteString.Lazy (ByteString) import Data.Either (partitionEithers) import Data.Functor (($>)) +import Data.Hashable (Hashable) import Data.List.NonEmpty (NonEmpty (..)) import Data.Typeable (Typeable) @@ -77,6 +78,7 @@ import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) import Ouroboros.Network.Server2 qualified as Server import Ouroboros.Network.Snocket (Snocket, socketSnocket) import Ouroboros.Network.Snocket qualified as Snocket +import Ouroboros.Network.Socket () -- Hashable SockAddr import Ouroboros.Network.Util.ShowProxy @@ -174,7 +176,10 @@ withBidirectionalConnectionManager :: forall peerAddr socket m a. ( ConnectionManagerMonad m - , Ord peerAddr, Show peerAddr, Typeable peerAddr + , Hashable peerAddr + , Ord peerAddr + , Show peerAddr + , Typeable peerAddr -- debugging , MonadFix m @@ -441,7 +446,8 @@ runInitiatorProtocols -- bidirectionalExperiment :: forall peerAddr socket. - ( Ord peerAddr + ( Hashable peerAddr + , Ord peerAddr , Show peerAddr , Typeable peerAddr , Eq peerAddr diff --git a/ouroboros-network-framework/ouroboros-network-framework.cabal b/ouroboros-network-framework/ouroboros-network-framework.cabal index 44b0158fb3a..af6c5b5521b 100644 --- a/ouroboros-network-framework/ouroboros-network-framework.cabal +++ b/ouroboros-network-framework/ouroboros-network-framework.cabal @@ -140,6 +140,7 @@ library testlib cborg, containers, contra-tracer, + hashable, io-classes, io-sim, network-mux, @@ -331,6 +332,7 @@ executable demo-connection-manager base >=4.14 && <4.21, bytestring, contra-tracer, + hashable, io-classes, network, network-mux, diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs index 650b4299043..4ef7f2f139a 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs @@ -49,6 +49,7 @@ import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer, contramap, traceWith) +import Data.Hashable import Data.ByteString.Lazy (ByteString) import Data.Map (Map) import Data.Text (Text) @@ -220,6 +221,7 @@ makeConnectionHandler , Ord versionNumber , Show peerAddr , Typeable peerAddr + , Hashable peerAddr ) => Tracer m (Mx.WithBearer (ConnectionId peerAddr) Mx.Trace) -> SingMuxMode muxMode @@ -332,7 +334,9 @@ makeConnectionHandler muxTracer singMuxMode } atomically $ writePromise (Right $ HandshakeConnectionResult handle (versionNumber, agreedOptions)) bearer <- mkMuxBearer sduTimeout socket + -- TODO: salt should be a random value drawn at startup. Mx.run (Mx.WithBearer connectionId `contramap` muxTracer) + (hashWithSalt 42 remoteAddress) mux bearer Right (HandshakeQueryResult vMap) -> do @@ -402,8 +406,11 @@ makeConnectionHandler muxTracer singMuxMode } atomically $ writePromise (Right $ HandshakeConnectionResult handle (versionNumber, agreedOptions)) bearer <- mkMuxBearer sduTimeout socket + -- TODO: salt should be a random value drawn at startup. Mx.run (Mx.WithBearer connectionId `contramap` muxTracer) - mux bearer + (hashWithSalt 42 remoteAddress) + mux bearer + Right (HandshakeQueryResult vMap) -> do atomically $ writePromise (Right HandshakeConnectionQuery) traceWith tracer $ TrHandshakeQuery vMap diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs b/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs index 247ed78b9e2..182ce460c78 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs @@ -438,7 +438,7 @@ connectToNodeWithMux' traceWith muxTracer $ Mx.TraceHandshakeClientEnd (diffTime ts_end ts_start) bearer <- Mx.getBearer makeBearer sduTimeout muxTracer sd mux <- Mx.new (toMiniProtocolInfos app) - withAsync (Mx.run muxTracer mux bearer) $ \aid -> + withAsync (Mx.run muxTracer undefined mux bearer) $ \aid -> k connectionId versionNumber agreedOptions app mux aid Right (HandshakeQueryResult _vMap) -> do @@ -612,7 +612,7 @@ beginConnection makeBearer muxTracer handshakeTracer handshakeCodec handshakeTim traceWith muxTracer' Mx.TraceHandshakeServerEnd bearer <- Mx.getBearer makeBearer sduTimeout muxTracer' sd mux <- Mx.new (toMiniProtocolInfos app) - withAsync (Mx.run muxTracer' mux bearer) $ \aid -> + withAsync (Mx.run muxTracer' undefined mux bearer) $ \aid -> void $ simpleMuxCallback connectionId versionNumber agreedOptions app mux aid Right (HandshakeQueryResult _vMap) -> do diff --git a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs index a6a49ee14e6..37318681e2b 100644 --- a/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs +++ b/ouroboros-network-framework/testlib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs @@ -50,6 +50,7 @@ import Codec.Serialise.Class (Serialise) import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy qualified as LBS import Data.Functor (($>), (<&>)) +import Data.Hashable import Data.List (mapAccumL) import Data.List.NonEmpty (NonEmpty (..)) import Data.Proxy (Proxy (..)) @@ -238,7 +239,7 @@ withInitiatorOnlyConnectionManager ( ConnectionManagerMonad m , resp ~ [req] - , Ord peerAddr, Show peerAddr, Typeable peerAddr + , Ord peerAddr, Show peerAddr, Typeable peerAddr, Hashable peerAddr , Serialise req, Typeable req , MonadAsync m , MonadDelay m @@ -406,7 +407,7 @@ withBidirectionalConnectionManager ( ConnectionManagerMonad m , acc ~ [req], resp ~ [req] - , Ord peerAddr, Show peerAddr, Typeable peerAddr + , Ord peerAddr, Show peerAddr, Typeable peerAddr, Hashable peerAddr , Serialise req, Typeable req -- debugging @@ -713,6 +714,7 @@ unidirectionalExperiment , acc ~ [req], resp ~ [req] , Ord peerAddr, Show peerAddr, Typeable peerAddr, Eq peerAddr + , Hashable peerAddr , Serialise req, Show req , Serialise resp, Show resp, Eq resp , Typeable req, Typeable resp @@ -790,6 +792,7 @@ bidirectionalExperiment , acc ~ [req], resp ~ [req] , Ord peerAddr, Show peerAddr, Typeable peerAddr, Eq peerAddr + , Hashable peerAddr , Serialise req, Show req , Serialise resp, Show resp, Eq resp diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Server.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Server.hs index 1b55d318ed4..d59a7dd98f7 100644 --- a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Server.hs +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Server.hs @@ -82,9 +82,9 @@ data ServerStIdle (n :: N) txid tx m a where -- | Collect a pipelined result. -- CollectPipelined - :: Maybe (ServerStIdle (S n) txid tx m a) - -> (Collect txid tx -> m (ServerStIdle n txid tx m a)) - -> ServerStIdle (S n) txid tx m a + :: Maybe (m (ServerStIdle (S n) txid tx m a)) + -> (Collect txid tx -> m ( ServerStIdle n txid tx m a)) + -> ServerStIdle (S n) txid tx m a -- | Transform a 'TxSubmissionServerPipelined' into a 'PeerPipelined'. @@ -134,6 +134,6 @@ txSubmissionServerPeerPipelined (TxSubmissionServerPipelined server) = (Effect (go <$> k)) go (CollectPipelined mNone collect) = - Collect (fmap go mNone) - (Effect . fmap go . collect) + Collect (Effect . fmap go <$> mNone) + (Effect . fmap go . collect) diff --git a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Direct.hs b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Direct.hs index 2cf0526216a..28118703e9f 100644 --- a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Direct.hs +++ b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Direct.hs @@ -54,7 +54,8 @@ directPipelined (TxSubmissionServerPipelined mserver) SendMsgReplyTxs txs client' <- recvMsgRequestTxs txids directSender (enqueue (CollectTxs txids txs) q) server' client' - directSender q (CollectPipelined (Just server') _) client = + directSender q (CollectPipelined (Just server) _) client = do + server' <- server directSender q server' client directSender (ConsQ c q) (CollectPipelined _ collect) client = do diff --git a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Examples.hs b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Examples.hs index 1b0aa7dbaa1..ac2804aebf7 100644 --- a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Examples.hs +++ b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/TxSubmission2/Examples.hs @@ -272,7 +272,7 @@ txSubmissionServer tracer txId maxUnacked maxTxIdsToRequest maxTxToRequest = -- | canRequestMoreTxs st = CollectPipelined - (Just (serverReqTxs accum (Succ n) st)) + (Just (pure $ serverReqTxs accum (Succ n) st)) (handleReply accum n st) -- In this case there is nothing else to do so we block until we diff --git a/ouroboros-network/io-tests/Test/Ouroboros/Network/Pipe.hs b/ouroboros-network/io-tests/Test/Ouroboros/Network/Pipe.hs index 5866ab49e3b..917e4cd01f1 100644 --- a/ouroboros-network/io-tests/Test/Ouroboros/Network/Pipe.hs +++ b/ouroboros-network/io-tests/Test/Ouroboros/Network/Pipe.hs @@ -216,7 +216,7 @@ demo chain0 updates = do InitiatorProtocolOnly initiator -> [(Mx.InitiatorDirectionOnly, void . runMiniProtocolCb initiator initCtx)] ] - withAsync (Mx.run nullTracer clientMux clientBearer) $ \aid -> do + withAsync (Mx.run nullTracer 0 clientMux clientBearer) $ \aid -> do _ <- atomically $ runFirstToFinish $ foldMap FirstToFinish resOps Mx.stop clientMux wait aid @@ -241,7 +241,7 @@ demo chain0 updates = do ResponderProtocolOnly responder -> [(Mx.ResponderDirectionOnly, void . runMiniProtocolCb responder respCtx)] ] - withAsync (Mx.run nullTracer serverMux serverBearer) $ \aid -> do + withAsync (Mx.run nullTracer 1 serverMux serverBearer) $ \aid -> do _ <- atomically $ runFirstToFinish $ foldMap FirstToFinish resOps Mx.stop serverMux wait aid diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index f7909d1fb51..a8115829dbd 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -92,6 +92,12 @@ library Ouroboros.Network.PeerSharing Ouroboros.Network.Tracers Ouroboros.Network.TxSubmission.Inbound + Ouroboros.Network.TxSubmission.Inbound.Decision + Ouroboros.Network.TxSubmission.Inbound.Policy + Ouroboros.Network.TxSubmission.Inbound.Registry + Ouroboros.Network.TxSubmission.Inbound.Server + Ouroboros.Network.TxSubmission.Inbound.State + Ouroboros.Network.TxSubmission.Inbound.Types Ouroboros.Network.TxSubmission.Mempool.Reader Ouroboros.Network.TxSubmission.Outbound @@ -171,6 +177,7 @@ library random, si-timers, strict-checked-vars ^>=0.2, + strict-mvar, strict-stm, transformers, typed-protocols ^>=0.3, @@ -203,6 +210,7 @@ library sim-tests-lib cardano-binary, cardano-prelude, cardano-slotting, + cardano-strict-containers, cborg, containers, contra-tracer, @@ -232,6 +240,7 @@ library sim-tests-lib random, serialise, si-timers, + strict-mvar, strict-stm, tasty, tasty-hunit, @@ -271,6 +280,10 @@ library sim-tests-lib Test.Ouroboros.Network.Testnet.Node.MiniProtocols Test.Ouroboros.Network.Testnet.Policies Test.Ouroboros.Network.TxSubmission + Test.Ouroboros.Network.TxSubmission.AppV1 + Test.Ouroboros.Network.TxSubmission.AppV2 + Test.Ouroboros.Network.TxSubmission.TxLogic + Test.Ouroboros.Network.TxSubmission.Types Test.Ouroboros.Network.Version -- Simulation tests, and IO tests which don't require native system calls. diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Mux.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Mux.hs index a16be96ed2c..3d025c18202 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Mux.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Mux.hs @@ -183,7 +183,7 @@ demo chain0 updates delay = do InitiatorProtocolOnly initiator -> [(Mx.InitiatorDirectionOnly, void . runMiniProtocolCb initiator initCtx)] ] - withAsync (Mx.run nullTracer clientMux clientBearer) $ \aid -> do + withAsync (Mx.run nullTracer 1 clientMux clientBearer) $ \aid -> do _ <- atomically $ runFirstToFinish $ foldMap FirstToFinish resOps Mx.stop clientMux wait aid @@ -208,7 +208,7 @@ demo chain0 updates delay = do ResponderProtocolOnly responder -> [(Mx.ResponderDirectionOnly, void . runMiniProtocolCb responder respCtx)] ] - withAsync (Mx.run nullTracer serverMux serverBearer) $ \aid -> do + withAsync (Mx.run nullTracer 1 serverMux serverBearer) $ \aid -> do _ <- atomically $ runFirstToFinish $ foldMap FirstToFinish resOps Mx.stop serverMux wait aid diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs index 9aad3e425d6..e0e7325883b 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs @@ -23,16 +23,19 @@ import Control.Monad.Class.MonadTime.SI (DiffTime, Time (Time), addTime, import Control.Monad.IOSim import Data.Bifoldable (bifoldMap) -import Data.Bifunctor (first) +import Data.Bifunctor (bimap, first) +import Data.Char (ord) import Data.Dynamic (fromDynamic) -import Data.Foldable (fold) +import Data.Foldable (fold, foldr') import Data.IP qualified as IP +import Data.List (foldl', intercalate, sort) import Data.List qualified as List import Data.List.Trace qualified as Trace import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, mapMaybe) import Data.Monoid (Sum (..)) +import Data.Ratio (Ratio) import Data.Set (Set) import Data.Set qualified as Set import Data.Time (secondsToDiffTime) @@ -45,7 +48,7 @@ import System.Random (mkStdGen) import Network.DNS.Types qualified as DNS -import Ouroboros.Network.BlockFetch (PraosFetchMode (..), +import Ouroboros.Network.BlockFetch (FetchMode (..), PraosFetchMode (..), TraceFetchClientState (..)) import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace (..)) import Ouroboros.Network.ConnectionId @@ -80,7 +83,7 @@ import Ouroboros.Network.PeerSelection.Types import Ouroboros.Network.PeerSharing (PeerSharingResult (..)) import Ouroboros.Network.Server2 qualified as Server -import Simulation.Network.Snocket (BearerInfo (..)) +import Simulation.Network.Snocket (BearerInfo (..), noAttenuation) import Test.Ouroboros.Network.ConnectionManager.Timeouts import Test.Ouroboros.Network.ConnectionManager.Utils @@ -97,7 +100,16 @@ import Test.Ouroboros.Network.Utils hiding (SmallDelay, debugTracer) import Test.QuickCheck import Test.QuickCheck.Monoids import Test.Tasty -import Test.Tasty.QuickCheck +import Test.Tasty.QuickCheck (testProperty) + +import Ouroboros.Network.TxSubmission.Inbound.Policy (defaultTxDecisionPolicy, + txInflightMultiplicity) +import Ouroboros.Network.TxSubmission.Inbound.State (inflightTxs) +import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxLogic (..), + TraceTxSubmissionInbound (..)) +import Ouroboros.Network.TxSubmission.Outbound (TxSubmissionProtocolError (..)) +import Test.Ouroboros.Network.TxSubmission.TxLogic (ArbTxDecisionPolicy (..)) +import Test.Ouroboros.Network.TxSubmission.Types (Tx (..)) tests :: TestTree tests = @@ -153,6 +165,10 @@ tests = (testWithIOSimPOR prop_only_bootstrap_peers_in_fallback_state 10000) , nightlyTest $ testProperty "no non trustable peers before caught up state" (testWithIOSimPOR prop_no_non_trustable_peers_before_caught_up_state 10000) + , testGroup "Tx Submission" + [ nightlyTest $ testProperty "no protocol errors" + (testWithIOSimPOR prop_no_txSubmission_error 125000) + ] , testGroup "Churn" [ nightlyTest $ testProperty "no timeouts" (testWithIOSimPOR prop_churn_notimeouts 10000) @@ -226,6 +242,14 @@ tests = [ testProperty "share a peer" unit_peer_sharing ] + , testGroup "Tx Submission" + [ testProperty "no protocol errors" + (testWithIOSim prop_no_txSubmission_error 125000) + , testProperty "all transactions" + unit_txSubmission_allTransactions + , testProperty "inflight coverage" + prop_check_inflight_ratio + ] , testGroup "Churn" [ testProperty "no timeouts" (testWithIOSim prop_churn_notimeouts 125000) @@ -372,7 +396,7 @@ unit_connection_manager_trace_coverage = script@(DiffusionScript _ _ nodes) = DiffusionScript - (SimArgs 1 20) + (SimArgs 1 20 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [ -- a relay node (NodeArgs { @@ -402,7 +426,9 @@ unit_connection_manager_trace_coverage = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0.1} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] + } , [JoinNetwork 0] ) @@ -438,7 +464,8 @@ unit_connection_manager_trace_coverage = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0.1} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] } , [JoinNetwork 0] ) @@ -500,7 +527,7 @@ unit_connection_manager_transitions_coverage = script@(DiffusionScript _ _ nodes) = DiffusionScript - (SimArgs 1 20) + (SimArgs 1 20 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [ -- a relay node (NodeArgs { @@ -530,7 +557,8 @@ unit_connection_manager_transitions_coverage = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0.1} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] } , [JoinNetwork 0] ) @@ -566,7 +594,8 @@ unit_connection_manager_transitions_coverage = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0.1} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] } , [JoinNetwork 0] ) @@ -603,6 +632,242 @@ prop_inbound_governor_trace_coverage defaultBearerInfo diffScript = in tabulate "inbound governor trace" eventsSeenNames True +-- | This test check that we don't have any tx submission protocol error +-- +prop_no_txSubmission_error :: SimTrace Void + -> Int + -> Property +prop_no_txSubmission_error ioSimTrace traceNumber = + let events = Trace.toList + . fmap (\(WithTime t (WithName _ b)) -> (t, b)) + . withTimeNameTraceEvents + @DiffusionTestTrace + @NtNAddr + . Trace.take traceNumber + $ ioSimTrace + + in counterexample (intercalate "\n" $ map show $ events) + $ all (\case + (_, DiffusionInboundGovernorTrace (IG.TrMuxErrored _ err)) -> + case fromException err of + Just ProtocolErrorRequestBlocking -> False + Just ProtocolErrorRequestedNothing -> False + Just ProtocolErrorAckedTooManyTxids -> False + Just (ProtocolErrorRequestedTooManyTxids _ _ _) -> False + Just ProtocolErrorRequestNonBlocking -> False + Just ProtocolErrorRequestedUnavailableTx -> False + _ -> True + _ -> True + ) + events + +-- | This test checks that even in a scenario where nodes keep disconnecting, +-- but eventually stay online. We manage to get all transactions. +-- +unit_txSubmission_allTransactions :: ArbTxDecisionPolicy + -> TurbulentCommands + -> (NonEmptyList (Tx Int), NonEmptyList (Tx Int)) + -> Property +unit_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) + (TurbulentCommands commands) + (NonEmpty txsA, NonEmpty txsB) = + let localRootConfig = LocalRootConfig + DoNotAdvertisePeer + IsNotTrustable + InitiatorAndResponderDiffusionMode + diffScript = + DiffusionScript + (SimArgs 1 10 decisionPolicy) + (singletonTimedScript Map.empty) + [(NodeArgs + (-3) + InitiatorAndResponderDiffusionMode + (Just 224) + Map.empty + PraosMode + (Script (DontUseBootstrapPeers :| [])) + (TestAddress (IPAddr (read "0.0.0.0") 0)) + PeerSharingDisabled + [ (2,2,Map.fromList [ (RelayAccessAddress "0.0.0.1" 0, localRootConfig) + , (RelayAccessAddress "0.0.0.2" 0, localRootConfig) + ]) + ] + (Script (LedgerPools [] :| [])) + (let targets = + PeerSelectionTargets { + targetNumberOfRootPeers = 1, + targetNumberOfKnownPeers = 1, + targetNumberOfEstablishedPeers = 1, + targetNumberOfActivePeers = 1, + + targetNumberOfKnownBigLedgerPeers = 0, + targetNumberOfEstablishedBigLedgerPeers = 0, + targetNumberOfActiveBigLedgerPeers = 0 + } + in ConsensusModePeerTargets targets targets) + (Script (DNSTimeout {getDNSTimeout = 10} :| [])) + (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| [])) + Nothing + False + (Script (PraosFetchMode FetchModeDeadline :| [])) + uniqueTxsA + , [ JoinNetwork 0 + ]) + , (NodeArgs + (-1) + InitiatorAndResponderDiffusionMode + (Just 2) + Map.empty + PraosMode + (Script (DontUseBootstrapPeers :| [])) + (TestAddress (IPAddr (read "0.0.0.1") 0)) + PeerSharingDisabled + [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.0" 0, localRootConfig)])] + (Script (LedgerPools [] :| [])) + (let targets = + PeerSelectionTargets { + targetNumberOfRootPeers = 1, + targetNumberOfKnownPeers = 1, + targetNumberOfEstablishedPeers = 1, + targetNumberOfActivePeers = 1, + + targetNumberOfKnownBigLedgerPeers = 0, + targetNumberOfEstablishedBigLedgerPeers = 0, + targetNumberOfActiveBigLedgerPeers = 0 + } + in ConsensusModePeerTargets targets targets + ) + (Script (DNSTimeout {getDNSTimeout = 10} :| [ ])) + (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| [])) + Nothing + False + (Script (PraosFetchMode FetchModeDeadline :| [])) + uniqueTxsB + , commands) + ] + in checkAllTransactions (runSimTrace + (diffusionSimulation noAttenuation + diffScript + iosimTracer) + ) + 500000 -- ^ Running for 500k might not be enough. + where + -- We need to make sure the transactions are unique, this simplifies + -- things. + uniqueTxsA = map (\(t, i) -> t { getTxId = (foldl' (+) 0 $ map ord "0.0.0.0") + i }) + (zip txsA [0 :: Int ..]) + uniqueTxsB = map (\(t, i) -> t { getTxId = (foldl' (+) 0 $ map ord "0.0.0.1") + i }) + (zip txsB [100 :: Int ..]) + + -- This checks the property that after running the simulation for a while + -- both nodes manage to get all valid transactions. + -- + checkAllTransactions :: SimTrace Void + -> Int + -> Property + checkAllTransactions ioSimTrace traceNumber = + let events = fmap (\(WithTime t (WithName name b)) -> WithName name (WithTime t b)) + . withTimeNameTraceEvents + @DiffusionTestTrace + @NtNAddr + . Trace.take traceNumber + $ ioSimTrace + + -- Build the accepted (sorted) txids map for each peer + -- + sortedAcceptedTxidsMap :: Map NtNAddr [Int] + sortedAcceptedTxidsMap = + foldr (\l r -> + foldl' (\rr (WithName n (WithTime _ x)) -> + case x of + -- When we add txids to the mempool, we collect them + -- into the map + DiffusionTxSubmissionInbound (TraceTxInboundAddedToMempool txids _) -> + Map.alter (maybe (Just []) (Just . sort . (txids ++))) n rr + -- When the node is shutdown we have to reset the accepted + -- txids list + DiffusionDiffusionSimulationTrace TrKillingNode -> + Map.alter (Just . const []) n rr + _ -> rr) r l + ) Map.empty + . Trace.toList + . splitWithNameTrace + $ events + + -- Construct the list of valid (sorted) txs from peer A and peer B. + -- This is essentially our goal lists + -- + (validSortedTxidsA, validSortedTxidsB) = + let f = sort + . map (\Tx {getTxId} -> getTxId) + . filter (\Tx {getTxValid} -> getTxValid) + in bimap f f (uniqueTxsA, uniqueTxsB) + + in counterexample (intercalate "\n" $ map show $ Trace.toList $ events) + $ counterexample ("unique txs: " ++ show uniqueTxsA ++ " " ++ show uniqueTxsB) + $ counterexample ("accepted txids map: " ++ show sortedAcceptedTxidsMap) + $ counterexample ("valid transactions that should be accepted: " + ++ show validSortedTxidsA ++ " " ++ show validSortedTxidsB) + + -- Success criteria, after running for 500k events, we check the map + -- for the two nodes involved in the simulation and verify that indeed + -- each peer managed to learn about the other peer' transactions. + -- + $ case ( Map.lookup (TestAddress (IPAddr (read "0.0.0.0") 0)) sortedAcceptedTxidsMap + , Map.lookup (TestAddress (IPAddr (read "0.0.0.1") 0)) sortedAcceptedTxidsMap + ) of + (Just acceptedTxidsA, Just acceptedTxidsB) -> + acceptedTxidsA === validSortedTxidsB + .&&. acceptedTxidsB === validSortedTxidsA + _ -> counterexample "Didn't find any entry in the map!" + $ False + +-- | This test checks the ratio of the inflight txs against the allowed by the +-- TxDecisionPolicy. +-- +prop_check_inflight_ratio :: AbsBearerInfo + -> DiffusionScript + -> Property +prop_check_inflight_ratio bi ds@(DiffusionScript simArgs _ _) = + let sim :: forall s . IOSim s Void + sim = diffusionSimulation (toBearerInfo bi) + ds + iosimTracer + + events :: Events DiffusionTestTrace + events = Signal.eventsFromList + . Trace.toList + . fmap ( (\(WithTime t (WithName _ b)) -> (t, b)) + ) + . withTimeNameTraceEvents + @DiffusionTestTrace + @NtNAddr + . Trace.take 500000 + $ runSimTrace + $ sim + + inflightTxsMap = + foldr' + (\(_, m) r -> Map.unionWith (max) m r + ) + Map.empty + $ Signal.eventsToList + $ Signal.selectEvents + (\case + DiffusionTxLogic (TraceSharedTxState _ d) -> Just (inflightTxs d) + _ -> Nothing + ) + $ events + + txDecisionPolicy = saTxDecisionPolicy simArgs + + in tabulate "Max observeed ratio of inflight multiplicity by the max stipulated by the policy" + (map (\m -> "has " ++ show m ++ " in flight - ratio: " + ++ show @(Ratio Int) (fromIntegral m / fromIntegral (txInflightMultiplicity txDecisionPolicy)) + ) + (Map.elems inflightTxsMap)) + $ True + -- | This test coverage of InboundGovernor transitions. -- prop_inbound_governor_transitions_coverage :: AbsBearerInfo @@ -899,7 +1164,7 @@ unit_4177 = prop_inbound_governor_transitions_coverage absNoAttenuation script where script :: DiffusionScript script = - DiffusionScript (SimArgs 1 10) + DiffusionScript (SimArgs 1 10 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [ ( NodeArgs (-6) InitiatorAndResponderDiffusionMode (Just 180) (Map.fromList [(RelayAccessDomain "test2" 65535, DoAdvertisePeer)]) @@ -925,7 +1190,8 @@ unit_4177 = prop_inbound_governor_transitions_coverage absNoAttenuation script (Script (DNSLookupDelay {getDNSLookupDelay = 0.067} :| [DNSLookupDelay {getDNSLookupDelay = 0.097},DNSLookupDelay {getDNSLookupDelay = 0.101},DNSLookupDelay {getDNSLookupDelay = 0.096},DNSLookupDelay {getDNSLookupDelay = 0.051}])) Nothing False - (Script (FetchModeDeadline :| [])) + (Script (PraosFetchMode FetchModeDeadline :| [])) + [] , [JoinNetwork 1.742857142857 ,Reconfigure 6.33333333333 [(1,1,Map.fromList [(RelayAccessDomain "test2" 65535,LocalRootConfig DoAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)]), (1,1,Map.fromList [(RelayAccessAddress "0:6:0:3:0:6:0:5" 65530,LocalRootConfig DoAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode) @@ -959,7 +1225,8 @@ unit_4177 = prop_inbound_governor_transitions_coverage absNoAttenuation script ])) Nothing False - (Script (FetchModeDeadline :| [])) + (Script (PraosFetchMode FetchModeDeadline :| [])) + [] , [JoinNetwork 0.183783783783 ,Reconfigure 4.533333333333 [(1,1,Map.empty)] ] @@ -1490,7 +1757,7 @@ unit_4191 = testWithIOSim prop_diffusion_dns_can_recover 125000 absInfo script } script = DiffusionScript - (SimArgs 1 20) + (SimArgs 1 20 defaultTxDecisionPolicy) (singletonTimedScript $ Map.fromList [ ("test2", [ (read "810b:4c8a:b3b5:741:8c0c:b437:64cf:1bd9", 300) @@ -1556,7 +1823,8 @@ unit_4191 = testWithIOSim prop_diffusion_dns_can_recover 125000 absInfo script ])) Nothing False - (Script (FetchModeDeadline :| [])) + (Script (PraosFetchMode FetchModeDeadline :| [])) + [] , [ JoinNetwork 6.710144927536 , Kill 7.454545454545 , JoinNetwork 10.763157894736 @@ -1636,7 +1904,7 @@ prop_connect_failure (AbsIOError ioerr) = script = DiffusionScript - (SimArgs 1 20) + (SimArgs 1 20 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [ (NodeArgs { naSeed = 0, @@ -1666,7 +1934,8 @@ prop_connect_failure (AbsIOError ioerr) = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] } , [JoinNetwork 10] ), @@ -1698,7 +1967,8 @@ prop_connect_failure (AbsIOError ioerr) = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] } , [JoinNetwork 0] ) @@ -1768,7 +2038,7 @@ prop_accept_failure (AbsIOError ioerr) = script = DiffusionScript - (SimArgs 1 20) + (SimArgs 1 20 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [ (NodeArgs { naSeed = 0, @@ -1798,7 +2068,8 @@ prop_accept_failure (AbsIOError ioerr) = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] } , [JoinNetwork 10] ), @@ -1830,7 +2101,8 @@ prop_accept_failure (AbsIOError ioerr) = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] } , [JoinNetwork 0] ) @@ -2750,7 +3022,8 @@ async_demotion_network_script = simArgs = SimArgs { saSlot = secondsToDiffTime 1, - saQuota = 5 -- 5% chance of producing a block + saQuota = 5, -- 5% chance of producing a block + saTxDecisionPolicy = defaultTxDecisionPolicy } peerTargets = Governor.nullPeerSelectionTargets { targetNumberOfKnownPeers = 1, @@ -2778,7 +3051,8 @@ async_demotion_network_script = naChainSyncEarlyExit = False, naPeerSharing = PeerSharingDisabled, - naFetchModeScript = singletonScript FetchModeDeadline + naFetchModeScript = singletonScript (PraosFetchMode FetchModeDeadline), + naTxs = [] } @@ -3298,7 +3572,7 @@ prop_unit_4258 = abiSDUSize = LargeSDU } diffScript = DiffusionScript - (SimArgs 1 10) + (SimArgs 1 10 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [( NodeArgs (-3) InitiatorAndResponderDiffusionMode (Just 224) Map.empty @@ -3327,7 +3601,8 @@ prop_unit_4258 = (Script (DNSLookupDelay {getDNSLookupDelay = 0.065} :| [])) Nothing False - (Script (FetchModeDeadline :| [])) + (Script (PraosFetchMode FetchModeDeadline :| [])) + [] , [ JoinNetwork 4.166666666666, Kill 0.3, JoinNetwork 1.517857142857, @@ -3370,7 +3645,8 @@ prop_unit_4258 = ])) Nothing False - (Script (FetchModeDeadline :| [])) + (Script (PraosFetchMode FetchModeDeadline :| [])) + [] , [ JoinNetwork 3.384615384615, Reconfigure 3.583333333333 [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.4" 9,LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)])], Kill 15.55555555555, @@ -3403,7 +3679,7 @@ prop_unit_reconnect :: Property prop_unit_reconnect = let diffScript = DiffusionScript - (SimArgs 1 10) + (SimArgs 1 10 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [(NodeArgs (-3) @@ -3434,7 +3710,8 @@ prop_unit_reconnect = (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| [])) Nothing False - (Script (FetchModeDeadline :| [])) + (Script (PraosFetchMode FetchModeDeadline :| [])) + [] , [ JoinNetwork 0 ]) , (NodeArgs @@ -3463,7 +3740,8 @@ prop_unit_reconnect = (Script (DNSLookupDelay {getDNSLookupDelay = 0} :| [])) Nothing False - (Script (FetchModeDeadline :| [])) + (Script (PraosFetchMode FetchModeDeadline :| [])) + [] , [ JoinNetwork 10 ]) ] @@ -3865,12 +4143,13 @@ unit_peer_sharing = naDNSLookupDelayScript = singletonScript (DNSLookupDelay 0.01), naChainSyncEarlyExit = False, naChainSyncExitOnBlockNo = Nothing, - naFetchModeScript = singletonScript FetchModeDeadline, - naConsensusMode + naFetchModeScript = singletonScript (PraosFetchMode FetchModeDeadline), + naConsensusMode, + naTxs = [] } script = DiffusionScript - (mainnetSimArgs 3) + (mainnetSimArgs 3 defaultTxDecisionPolicy) (singletonScript (mempty, ShortDelay)) [ ( (defaultNodeArgs GenesisMode) { naAddr = ip_0, naLocalRootPeers = [(1, 1, Map.fromList [(ra_1, LocalRootConfig DoNotAdvertisePeer IsNotTrustable InitiatorAndResponderDiffusionMode)])], @@ -4260,7 +4539,7 @@ unit_local_root_diffusion_mode diffusionMode = script = DiffusionScript - (SimArgs 1 20) + (SimArgs 1 20 defaultTxDecisionPolicy) (singletonTimedScript Map.empty) [ -- a relay node (NodeArgs { @@ -4290,7 +4569,8 @@ unit_local_root_diffusion_mode diffusionMode = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0.1} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] } , [JoinNetwork 0] ) @@ -4326,7 +4606,8 @@ unit_local_root_diffusion_mode diffusionMode = naDNSLookupDelayScript = Script (DNSLookupDelay {getDNSLookupDelay = 0.1} :| []), naChainSyncExitOnBlockNo = Nothing, naChainSyncEarlyExit = False, - naFetchModeScript = Script (FetchModeDeadline :| []) + naFetchModeScript = Script (PraosFetchMode FetchModeDeadline :| []), + naTxs = [] } , [JoinNetwork 0] ) diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Internal.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Internal.hs index 0f5b9bc791c..746ad899607 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Internal.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Internal.hs @@ -24,6 +24,8 @@ module Test.Ouroboros.Network.Testnet.Internal -- * QuickCheck properties , prop_diffusionScript_fixupCommands , prop_diffusionScript_commandScript_valid + , fixupCommands + , TurbulentCommands (..) -- * Tracing , DiffusionSimulationTrace (..) , DiffusionTestTrace (..) @@ -51,8 +53,10 @@ import Control.Tracer (Tracer (..), contramap, nullTracer, traceWith) import Control.Monad.IOSim (IOSim, traceM) +import Data.Bool (bool) import Data.ByteString.Char8 qualified as BSC import Data.ByteString.Lazy qualified as BL +import Data.Function (on) import Data.IP (IP (..)) import Data.List (delete, nubBy) import Data.List.NonEmpty qualified as NonEmpty @@ -63,6 +67,7 @@ import Data.Proxy (Proxy (..)) import Data.Set (Set) import Data.Set qualified as Set import Data.Time.Clock (secondsToDiffTime) +import Data.Typeable (Typeable) import Data.Void (Void) import System.Random (StdGen, mkStdGen) import System.Random qualified as Random @@ -72,6 +77,8 @@ import Network.DNS (Domain, TTL) import Network.TypedProtocol.Core import Network.TypedProtocol.PingPong.Type qualified as PingPong +import Ouroboros.Network.BlockFetch (FetchMode (..), PraosFetchMode (..), + TraceFetchClientState, TraceLabelPeer (..)) import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace) import Ouroboros.Network.ConnectionManager.Core qualified as CM import Ouroboros.Network.ConnectionManager.State qualified as CM @@ -83,6 +90,7 @@ import Ouroboros.Network.Driver.Limits (ProtocolSizeLimits (..), import Ouroboros.Network.InboundGovernor qualified as IG import Ouroboros.Network.Mux (MiniProtocolLimits (..)) import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) +import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..)) import Ouroboros.Network.PeerSelection.Governor (ConsensusModePeerTargets (..), DebugPeerSelection (..), PeerSelectionTargets (..), TracePeerSelection) @@ -90,8 +98,21 @@ import Ouroboros.Network.PeerSelection.Governor qualified as PeerSelection import Ouroboros.Network.PeerSelection.LedgerPeers (AfterSlot (..), LedgerPeersConsensusInterface (..), LedgerStateJudgement (..), TraceLedgerPeers, UseLedgerPeers (..), accPoolStake) +import Ouroboros.Network.PeerSelection.LocalRootPeers + (OutboundConnectionsState (..)) +import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) +import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing) import Ouroboros.Network.PeerSelection.PeerStateActions (PeerSelectionActionsTrace) +import Ouroboros.Network.PeerSelection.RelayAccessPoint (DomainAccessPoint (..), + PortNumber, RelayAccessPoint (..)) +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions (DNSLookupType) +import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers + (TraceLocalRootPeers) +import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers + (TracePublicRootPeers) +import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), + LocalRootConfig, WarmValency (..)) import Ouroboros.Network.Protocol.BlockFetch.Codec (byteLimitsBlockFetch, timeLimitsBlockFetch) import Ouroboros.Network.Protocol.ChainSync.Codec (ChainSyncTimeout (..), @@ -100,9 +121,16 @@ import Ouroboros.Network.Protocol.Handshake.Version (Accept (Accept)) import Ouroboros.Network.Protocol.KeepAlive.Codec (byteLimitsKeepAlive, timeLimitsKeepAlive) import Ouroboros.Network.Protocol.Limits (shortWait, smallByteLimit) +import Ouroboros.Network.Protocol.PeerSharing.Codec (byteLimitsPeerSharing, + timeLimitsPeerSharing) +import Ouroboros.Network.Protocol.TxSubmission2.Codec (byteLimitsTxSubmission2, + timeLimitsTxSubmission2) import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) import Ouroboros.Network.Server2 qualified as Server import Ouroboros.Network.Snocket (Snocket, TestAddress (..)) +import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy) +import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxLogic, + TraceTxSubmissionInbound) import Ouroboros.Network.Block (BlockNo) import Ouroboros.Network.Mock.ConcreteBlock (Block (..), BlockHeader (..)) @@ -110,7 +138,9 @@ import Simulation.Network.Snocket (BearerInfo (..), FD, SnocketTrace, WithAddr (..), makeFDBearer, withSnocket) import Test.Ouroboros.Network.Data.Script +import Test.Ouroboros.Network.LedgerPeers (LedgerPools (..), genLedgerPoolsFrom) import Test.Ouroboros.Network.PeerSelection.Instances qualified as PeerSelection +import Test.Ouroboros.Network.PeerSelection.LocalRootPeers () import Test.Ouroboros.Network.PeerSelection.RootPeersDNS (DNSLookupDelay (..), DNSTimeout (..)) import Test.Ouroboros.Network.PeerSelection.RootPeersDNS qualified as PeerSelection hiding @@ -119,31 +149,9 @@ import Test.Ouroboros.Network.Testnet.Node qualified as Node import Test.Ouroboros.Network.Testnet.Node.Kernel (BlockGeneratorArgs, NtCAddr, NtCVersion, NtCVersionData, NtNAddr, NtNAddr_ (IPAddr), NtNVersion, NtNVersionData, ntnAddrToRelayAccessPoint, randomBlockGenerationArgs) +import Test.Ouroboros.Network.TxSubmission.TxLogic (ArbTxDecisionPolicy (..)) +import Test.Ouroboros.Network.TxSubmission.Types (Tx (..)) import Test.Ouroboros.Network.Utils - -import Data.Bool (bool) -import Data.Function (on) -import Data.Typeable (Typeable) -import Ouroboros.Network.BlockFetch (PraosFetchMode (..), TraceFetchClientState, - TraceLabelPeer (..)) -import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..)) -import Ouroboros.Network.PeerSelection.LocalRootPeers - (OutboundConnectionsState (..)) -import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) -import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing) -import Ouroboros.Network.PeerSelection.RelayAccessPoint (DomainAccessPoint (..), - PortNumber, RelayAccessPoint (..)) -import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions (DNSLookupType) -import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers - (TraceLocalRootPeers) -import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers - (TracePublicRootPeers) -import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..), - LocalRootConfig, WarmValency (..)) -import Ouroboros.Network.Protocol.PeerSharing.Codec (byteLimitsPeerSharing, - timeLimitsPeerSharing) -import Test.Ouroboros.Network.LedgerPeers (LedgerPools (..), genLedgerPoolsFrom) -import Test.Ouroboros.Network.PeerSelection.LocalRootPeers () import Test.QuickCheck -- | Diffusion Simulator Arguments @@ -153,17 +161,20 @@ import Test.QuickCheck -- data SimArgs = SimArgs - { saSlot :: DiffTime + { saSlot :: DiffTime -- ^ 'randomBlockGenerationArgs' slot duration argument - , saQuota :: Int + , saQuota :: Int -- ^ 'randomBlockGenerationArgs' quota value + , saTxDecisionPolicy :: TxDecisionPolicy + -- ^ Decision policy for tx submission protocol } instance Show SimArgs where - show SimArgs { saSlot, saQuota } = + show SimArgs { saSlot, saQuota, saTxDecisionPolicy } = unwords [ "SimArgs" , show saSlot , show saQuota + , "(" ++ show saTxDecisionPolicy ++ ")" ] data ServiceDomainName = @@ -219,14 +230,15 @@ data NodeArgs = -- ^ 'Arguments' 'aDNSLookupDelayScript' value , naChainSyncExitOnBlockNo :: Maybe BlockNo , naChainSyncEarlyExit :: Bool - , naFetchModeScript :: Script PraosFetchMode + , naFetchModeScript :: Script FetchMode + , naTxs :: [Tx Int] } instance Show NodeArgs where show NodeArgs { naSeed, naDiffusionMode, naMbTime, naBootstrapPeers, naPublicRoots, naAddr, naPeerSharing, naLocalRootPeers, naPeerTargets, naDNSTimeoutScript, naDNSLookupDelayScript, naChainSyncExitOnBlockNo, - naChainSyncEarlyExit, naFetchModeScript, naConsensusMode } = + naChainSyncEarlyExit, naFetchModeScript, naConsensusMode, naTxs } = unwords [ "NodeArgs" , "(" ++ show naSeed ++ ")" , show naDiffusionMode @@ -243,6 +255,7 @@ instance Show NodeArgs where , "(" ++ show naChainSyncExitOnBlockNo ++ ")" , show naChainSyncEarlyExit , show naFetchModeScript + , show naTxs , "============================================\n" ] @@ -306,6 +319,48 @@ fixupCommands (jn@(JoinNetwork _):t) = jn : go jn t _ -> cmd : go cmd cmds fixupCommands (_:t) = fixupCommands t +-- | Turbulent commands have some turbulence by connecting and disconnecting +-- the node, but eventually keeping the node online. +-- +newtype TurbulentCommands = TurbulentCommands [Command] + deriving (Eq, Show) + +instance Arbitrary TurbulentCommands where + arbitrary = do + turbulenceNumber <- choose (2, 7) + -- Make sure turbulenceNumber is an even number + -- This simplifies making sure we keep the node online. + let turbulenceNumber' = + if odd turbulenceNumber + then turbulenceNumber + 1 + else turbulenceNumber + delays <- vectorOf turbulenceNumber' delay + let commands = zipWith (\f d -> f d) (cycle [JoinNetwork, Kill]) delays + ++ [JoinNetwork 0] + return (TurbulentCommands commands) + where + delay = frequency [ (3, genDelayWithPrecision 65) + , (1, (/ 10) <$> genDelayWithPrecision 60) + ] + shrink (TurbulentCommands xs) = + [ TurbulentCommands xs' | xs' <- shrinkList shrinkCommand xs, invariant xs' ] ++ + [ TurbulentCommands (take n xs) | n <- [0, length xs - 3], n `mod` 3 == 0, invariant (take n xs) ] + + where + shrinkDelay = map fromRational . shrink . toRational + + shrinkCommand :: Command -> [Command] + shrinkCommand (JoinNetwork d) = JoinNetwork <$> shrinkDelay d + shrinkCommand (Kill d) = Kill <$> shrinkDelay d + shrinkCommand (Reconfigure d lrp) = Reconfigure <$> shrinkDelay d + <*> pure lrp + + invariant :: [Command] -> Bool + invariant [JoinNetwork _] = True + invariant [JoinNetwork _, Kill _, JoinNetwork _] = True + invariant (JoinNetwork _ : Kill _ : JoinNetwork _ : rest) = invariant rest + invariant _ = False + -- | Simulation arguments. -- -- Slot length needs to be greater than 0 else we get a livelock on the IOSim. @@ -313,13 +368,16 @@ fixupCommands (_:t) = fixupCommands t -- Quota values matches mainnet, so a slot length of 1s and 1 / 20 chance that -- someone gets to make a block. -- -mainnetSimArgs :: Int -> SimArgs -mainnetSimArgs numberOfNodes = +mainnetSimArgs :: Int + -> TxDecisionPolicy + -> SimArgs +mainnetSimArgs numberOfNodes txDecisionPolicy = SimArgs { saSlot = secondsToDiffTime 1, saQuota = if numberOfNodes > 0 then 20 `div` numberOfNodes - else 100 + else 100, + saTxDecisionPolicy = txDecisionPolicy } @@ -363,8 +421,9 @@ genNodeArgs :: [RelayAccessInfo] -> Int -> [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)] -> RelayAccessInfo + -> [Tx Int] -> Gen NodeArgs -genNodeArgs relays minConnected localRootPeers relay = flip suchThat hasUpstream $ do +genNodeArgs relays minConnected localRootPeers relay txs = flip suchThat hasUpstream $ do -- Slot length needs to be greater than 0 else we get a livelock on -- the IOSim. -- @@ -429,7 +488,7 @@ genNodeArgs relays minConnected localRootPeers relay = flip suchThat hasUpstream firstLedgerPool <- arbitrary let ledgerPeerPoolsScript = Script (firstLedgerPool :| ledgerPeerPools) - fetchModeScript <- fmap (bool FetchModeBulkSync FetchModeDeadline) <$> arbitrary + fetchModeScript <- fmap (PraosFetchMode . bool FetchModeBulkSync FetchModeDeadline) <$> arbitrary naConsensusMode <- arbitrary bootstrapPeersDomain <- @@ -457,6 +516,7 @@ genNodeArgs relays minConnected localRootPeers relay = flip suchThat hasUpstream , naChainSyncEarlyExit = chainSyncEarlyExit , naPeerSharing = peerSharing , naFetchModeScript = fetchModeScript + , naTxs = txs } where hasActive :: SmallPeerSelectionTargets -> Bool @@ -686,10 +746,24 @@ genDiffusionScript :: ([RelayAccessInfo] genDiffusionScript genLocalRootPeers (RelayAccessInfosWithDNS relays dnsMapScript) = do - let simArgs = mainnetSimArgs (length relays') - nodesWithCommands <- mapM go (nubBy ((==) `on` getRelayIP) relays') + ArbTxDecisionPolicy txDecisionPolicy <- arbitrary + let simArgs = mainnetSimArgs (length relays') txDecisionPolicy + txs <- makeUniqueIds 0 + <$> vectorOf (length relays') (choose (10, 100) >>= \c -> vectorOf c arbitrary) + nodesWithCommands <- mapM go (zip (nubBy ((==) `on` getRelayIP) relays') txs) return (simArgs, dnsMapScript, nodesWithCommands) where + makeUniqueIds :: Int -> [[Tx Int]] -> [[Tx Int]] + makeUniqueIds _ [] = [] + makeUniqueIds i (l:ls) = + let (r, i') = makeUniqueIds' l i + in r : makeUniqueIds i' ls + + makeUniqueIds' :: [Tx Int] -> Int -> ([Tx Int], Int) + makeUniqueIds' l i = ( map (\(tx, x) -> tx {getTxId = x}) (zip l [i..]) + , i + length l + 1 + ) + getRelayIP :: RelayAccessInfo -> IP getRelayIP (RelayAddrInfo ip _ _) = ip getRelayIP (RelayDomainInfo _ ip _ _) = ip @@ -697,12 +771,12 @@ genDiffusionScript genLocalRootPeers relays' :: [RelayAccessInfo] relays' = getRelayAccessInfos relays - go :: RelayAccessInfo -> Gen (NodeArgs, [Command]) - go relay = do + go :: (RelayAccessInfo, [Tx Int]) -> Gen (NodeArgs, [Command]) + go (relay, txs) = do let otherRelays = relay `delete` relays' minConnected = 3 `max` (length relays' - 1) localRts <- genLocalRootPeers otherRelays relay - nodeArgs <- genNodeArgs relays' minConnected localRts relay + nodeArgs <- genNodeArgs relays' minConnected localRts relay txs commands <- genCommands localRts return (nodeArgs, commands) @@ -929,6 +1003,8 @@ data DiffusionTestTrace = | DiffusionInboundGovernorTrace (IG.Trace NtNAddr) | DiffusionServerTrace (Server.Trace NtNAddr) | DiffusionFetchTrace (TraceFetchClientState BlockHeader) + | DiffusionTxSubmissionInbound (TraceTxSubmissionInbound Int (Tx Int)) + | DiffusionTxLogic (TraceTxLogic NtNAddr Int (Tx Int)) | DiffusionDebugTrace String deriving (Show) @@ -1061,6 +1137,7 @@ diffusionSimulation runNode SimArgs { saSlot = bgaSlotDuration , saQuota = quota + , saTxDecisionPolicy = txDecisionPolicy } NodeArgs { naSeed = seed @@ -1076,6 +1153,7 @@ diffusionSimulation , naChainSyncExitOnBlockNo = chainSyncExitOnBlockNo , naChainSyncEarlyExit = chainSyncEarlyExit , naPeerSharing = peerSharing + , naTxs = txs } ntnSnocket ntcSnocket @@ -1118,14 +1196,14 @@ diffusionSimulation limitsAndTimeouts = Node.LimitsAndTimeouts { Node.chainSyncLimits = defaultMiniProtocolsLimit - , Node.chainSyncSizeLimits = byteLimitsChainSync (const 0) + , Node.chainSyncSizeLimits = byteLimitsChainSync (fromIntegral . BL.length) , Node.chainSyncTimeLimits = timeLimitsChainSync stdChainSyncTimeout , Node.blockFetchLimits = defaultMiniProtocolsLimit - , Node.blockFetchSizeLimits = byteLimitsBlockFetch (const 0) + , Node.blockFetchSizeLimits = byteLimitsBlockFetch (fromIntegral . BL.length) , Node.blockFetchTimeLimits = timeLimitsBlockFetch , Node.keepAliveLimits = defaultMiniProtocolsLimit - , Node.keepAliveSizeLimits = byteLimitsKeepAlive (const 0) + , Node.keepAliveSizeLimits = byteLimitsKeepAlive (fromIntegral . BL.length) , Node.keepAliveTimeLimits = timeLimitsKeepAlive , Node.pingPongLimits = defaultMiniProtocolsLimit , Node.pingPongSizeLimits = byteLimitsPingPong @@ -1140,8 +1218,10 @@ diffusionSimulation , Node.peerSharingTimeLimits = timeLimitsPeerSharing , Node.peerSharingSizeLimits = - byteLimitsPeerSharing (const 0) - + byteLimitsPeerSharing (fromIntegral . BL.length) + , Node.txSubmissionLimits = defaultMiniProtocolsLimit + , Node.txSubmissionTimeLimits = timeLimitsTxSubmission2 + , Node.txSubmissionSizeLimits = byteLimitsTxSubmission2 (fromIntegral . BL.length) } interfaces :: Node.Interfaces m @@ -1212,6 +1292,8 @@ diffusionSimulation , Node.aDNSLookupDelayScript = dnsLookupDelay , Node.aDebugTracer = (\s -> WithTime (Time (-1)) (WithName addr (DiffusionDebugTrace s))) `contramap` nodeTracer + , Node.aTxDecisionPolicy = txDecisionPolicy + , Node.aTxs = txs } Node.run blockGeneratorArgs @@ -1223,8 +1305,14 @@ diffusionSimulation . tracerWithName addr . tracerWithTime $ nodeTracer) - `catch` \e -> traceWith (diffSimTracer addr) (TrErrored e) - >> throwIO e + ( contramap DiffusionTxSubmissionInbound + . tracerWithName addr + . tracerWithTime + $ nodeTracer) + ( contramap DiffusionTxLogic + . tracerWithName addr + . tracerWithTime + $ nodeTracer) domainResolver :: StrictTVar m (Map Domain [(IP, TTL)]) -> DNSLookupType diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node.hs index ba823f49749..41ae847c268 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node.hs @@ -66,6 +66,7 @@ import Ouroboros.Network.AnchoredFragment qualified as AF import Ouroboros.Network.Block (MaxSlotNo (..), maxSlotNoFromWithOrigin, pointSlot) import Ouroboros.Network.BlockFetch +import Ouroboros.Network.BlockFetch.ClientRegistry (readPeerGSVs) import Ouroboros.Network.BlockFetch.ConsensusInterface (ChainSelStarvation (..)) import Ouroboros.Network.ConnectionManager.State qualified as CM import Ouroboros.Network.ConnectionManager.Types (DataFlow (..)) @@ -74,10 +75,22 @@ import Ouroboros.Network.Diffusion qualified as Diff import Ouroboros.Network.Diffusion.P2P qualified as Diff.P2P import Ouroboros.Network.ExitPolicy (RepromoteDelay (..)) import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) +import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers) import Ouroboros.Network.PeerSelection.Governor (ConsensusModePeerTargets, PeerSelectionTargets (..), PublicPeerSelectionState (..)) +import Ouroboros.Network.PeerSelection.LedgerPeers.Type + (LedgerPeersConsensusInterface, + MinBigLedgerPeersForTrustedState (..), UseLedgerPeers) +import Ouroboros.Network.PeerSelection.LocalRootPeers (OutboundConnectionsState) +import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) import Ouroboros.Network.PeerSelection.PeerMetric (PeerMetricsConfiguration (..), newPeerMetric) +import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) +import Ouroboros.Network.PeerSelection.RelayAccessPoint (DomainAccessPoint, + RelayAccessPoint) +import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions (DNSLookupType) +import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, + LocalRootConfig, WarmValency) import Ouroboros.Network.Protocol.Handshake (HandshakeArguments (..)) import Ouroboros.Network.Protocol.Handshake.Codec (VersionDataCodec (..), noTimeLimitsHandshake, timeLimitsHandshake) @@ -89,24 +102,14 @@ import Ouroboros.Network.RethrowPolicy (ErrorCommand (ShutdownNode), import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) import Ouroboros.Network.Snocket (MakeBearer, Snocket, TestAddress (..), invalidFileDescriptor) - +import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy) +import Ouroboros.Network.TxSubmission.Inbound.Registry (decisionLogicThread) +import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxLogic, + TraceTxSubmissionInbound) import Simulation.Network.Snocket (AddressType (..), FD) -import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers) -import Ouroboros.Network.PeerSelection.LedgerPeers.Type - (LedgerPeersConsensusInterface, - MinBigLedgerPeersForTrustedState (..), UseLedgerPeers) -import Ouroboros.Network.PeerSelection.LocalRootPeers (OutboundConnectionsState) -import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..)) -import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) -import Ouroboros.Network.PeerSelection.RelayAccessPoint (DomainAccessPoint, - RelayAccessPoint) -import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions (DNSLookupType) -import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, - LocalRootConfig, WarmValency) - -import Test.Ouroboros.Network.Data.Script (Script (..), stepScriptSTM') +import Test.Ouroboros.Network.Data.Script import Test.Ouroboros.Network.PeerSelection.RootPeersDNS (DNSLookupDelay, DNSTimeout, mockDNSActions) import Test.Ouroboros.Network.Testnet.Node.ChainDB (addBlock, getBlockPointSet) @@ -114,6 +117,7 @@ import Test.Ouroboros.Network.Testnet.Node.Kernel (NodeKernel (..), NtCAddr, NtCVersion, NtCVersionData, NtNAddr, NtNVersion, NtNVersionData (..)) import Test.Ouroboros.Network.Testnet.Node.Kernel qualified as Node import Test.Ouroboros.Network.Testnet.Node.MiniProtocols qualified as Node +import Test.Ouroboros.Network.TxSubmission.Types (Tx) data Interfaces m = Interfaces @@ -158,6 +162,8 @@ data Arguments m = Arguments , aDNSTimeoutScript :: Script DNSTimeout , aDNSLookupDelayScript :: Script DNSLookupDelay , aDebugTracer :: Tracer m String + , aTxDecisionPolicy :: TxDecisionPolicy + , aTxs :: [Tx Int] } -- The 'mockDNSActions' is not using \/ specifying 'resolverException', thus we @@ -193,9 +199,11 @@ run :: forall resolver m. NtCAddr NtCVersion NtCVersionData ResolverException m -> Tracer m (TraceLabelPeer NtNAddr (TraceFetchClientState BlockHeader)) + -> Tracer m (TraceTxSubmissionInbound Int (Tx Int)) + -> Tracer m (TraceTxLogic NtNAddr Int (Tx Int)) -> m Void -run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = - Node.withNodeKernelThread blockGeneratorArgs +run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch tracerTxSubmissionInbound tracerTxLogic = + Node.withNodeKernelThread blockGeneratorArgs (aTxs na) $ \ nodeKernel nodeKernelThread -> do dnsTimeoutScriptVar <- newTVarIO (aDNSTimeoutScript na) dnsLookupDelayScriptVar <- newTVarIO (aDNSLookupDelayScript na) @@ -271,7 +279,7 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = , Diff.P2P.daPeerSharingRegistry = nkPeerSharingRegistry nodeKernel } - let apps = Node.applications (aDebugTracer na) nodeKernel Node.cborCodecs limits appArgs blockHeader + let apps = Node.applications (aDebugTracer na) tracerTxSubmissionInbound tracerTxLogic nodeKernel Node.cborCodecs limits appArgs blockHeader withAsync (Diff.P2P.runM interfaces @@ -281,11 +289,19 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = (mkArgsExtra useBootstrapPeersScriptVar) apps appsExtra) $ \ diffusionThread -> withAsync (blockFetch nodeKernel) $ \blockFetchLogicThread -> - wait diffusionThread - <> wait blockFetchLogicThread - <> wait nodeKernelThread + + withAsync (decisionLogicThread + tracerTxLogic + (aTxDecisionPolicy na) + (readPeerGSVs (nkFetchClientRegistry nodeKernel)) + (nkTxChannelsVar nodeKernel) + (nkSharedTxStateVar nodeKernel)) $ \decLogicThread -> + wait diffusionThread + <> wait blockFetchLogicThread + <> wait nodeKernelThread + <> wait decLogicThread where - blockFetch :: NodeKernel BlockHeader Block s m + blockFetch :: NodeKernel BlockHeader Block s txid m -> m Void blockFetch nodeKernel = do blockFetchLogic @@ -305,7 +321,7 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = } }) - blockFetchPolicy :: NodeKernel BlockHeader Block s m + blockFetchPolicy :: NodeKernel BlockHeader Block s txid m -> BlockFetchConsensusInterface NtNAddr BlockHeader Block m blockFetchPolicy nodeKernel = BlockFetchConsensusInterface { @@ -429,6 +445,7 @@ run blockGeneratorArgs limits ni na tracersExtra tracerBlockFetch = , Node.aaOwnPeerSharing = aOwnPeerSharing na , Node.aaUpdateOutboundConnectionsState = iUpdateOutboundConnectionsState ni + , Node.aaTxDecisionPolicy = aTxDecisionPolicy na } --- Utils diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node/Kernel.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node/Kernel.hs index 7ce29dbfc32..142c2b5ce61 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node/Kernel.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node/Kernel.hs @@ -51,7 +51,7 @@ import Data.Typeable (Typeable) import Data.Void (Void) import Numeric.Natural (Natural) -import System.Random (RandomGen, StdGen, randomR, split) +import System.Random (RandomGen, StdGen, mkStdGen, random, randomR, split) import Data.Monoid.Synchronisation @@ -76,6 +76,7 @@ import Test.Ouroboros.Network.Orphans () import Codec.CBOR.Decoding qualified as CBOR import Codec.CBOR.Encoding qualified as CBOR +import Control.Concurrent.Class.MonadMVar.Strict qualified as Strict import Ouroboros.Network.Mock.Chain (Chain (..)) import Ouroboros.Network.NodeToNode () import Ouroboros.Network.PeerSelection.Governor (PublicPeerSelectionState, @@ -85,8 +86,11 @@ import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..)) import Ouroboros.Network.PeerSharing (PeerSharingAPI, PeerSharingRegistry (..), newPeerSharingAPI, newPeerSharingRegistry, ps_POLICY_PEER_SHARE_MAX_PEERS, ps_POLICY_PEER_SHARE_STICKY_TIME) +import Ouroboros.Network.TxSubmission.Inbound.Registry (SharedTxStateVar, + TxChannels (..), TxChannelsVar, newSharedTxStateVar) import Test.Ouroboros.Network.Testnet.Node.ChainDB (ChainDB (..)) import Test.Ouroboros.Network.Testnet.Node.ChainDB qualified as ChainDB +import Test.Ouroboros.Network.TxSubmission.Types (Mempool, Tx, newMempool) import Test.QuickCheck (Arbitrary (..), choose, chooseInt, frequency, oneof) @@ -251,7 +255,7 @@ randomBlockGenerationArgs bgaSlotDuration bgaSeed quota = , bgaSeed } -data NodeKernel header block s m = NodeKernel { +data NodeKernel header block s txid m = NodeKernel { -- | upstream chains nkClientChains :: StrictTVar m (Map NtNAddr (StrictTVar m (Chain header))), @@ -268,12 +272,25 @@ data NodeKernel header block s m = NodeKernel { nkPeerSharingAPI :: PeerSharingAPI NtNAddr s m, - nkPublicPeerSelectionVar :: StrictTVar m (PublicPeerSelectionState NtNAddr) + nkPublicPeerSelectionVar :: StrictTVar m (PublicPeerSelectionState NtNAddr), + + nkMempool :: Mempool m txid, + + nkTxChannelsVar :: TxChannelsVar m NtNAddr txid (Tx txid), + + nkSharedTxStateVar :: SharedTxStateVar m NtNAddr txid (Tx txid) } -newNodeKernel :: MonadSTM m - => s -> m (NodeKernel header block s m) -newNodeKernel rng = do +newNodeKernel :: ( MonadSTM m + , Strict.MonadMVar m + , RandomGen s + , Eq txid + ) + => s + -> Int + -> [Tx txid] + -> m (NodeKernel header block s txid m) +newNodeKernel psRng txSeed txs = do publicStateVar <- makePublicPeerSelectionStateVar NodeKernel <$> newTVarIO Map.empty @@ -281,15 +298,18 @@ newNodeKernel rng = do <*> newFetchClientRegistry <*> newPeerSharingRegistry <*> ChainDB.newChainDB - <*> newPeerSharingAPI publicStateVar rng + <*> newPeerSharingAPI publicStateVar psRng ps_POLICY_PEER_SHARE_STICKY_TIME ps_POLICY_PEER_SHARE_MAX_PEERS <*> pure publicStateVar + <*> newMempool txs + <*> Strict.newMVar (TxChannels Map.empty) + <*> newSharedTxStateVar (mkStdGen txSeed) -- | Register a new upstream chain-sync client. -- registerClientChains :: MonadSTM m - => NodeKernel header block s m + => NodeKernel header block s txid m -> NtNAddr -> m (StrictTVar m (Chain header)) registerClientChains NodeKernel { nkClientChains } peerAddr = atomically $ do @@ -301,7 +321,7 @@ registerClientChains NodeKernel { nkClientChains } peerAddr = atomically $ do -- | Unregister an upstream chain-sync client. -- unregisterClientChains :: MonadSTM m - => NodeKernel header block s m + => NodeKernel header block s txid m -> NtNAddr -> m () unregisterClientChains NodeKernel { nkClientChains } peerAddr = atomically $ @@ -353,29 +373,34 @@ instance Exception NodeKernelError where -- | Run chain selection \/ block production thread. -- withNodeKernelThread - :: forall block header m seed a. + :: forall block header m seed txid a. ( Alternative (STM m) , MonadAsync m , MonadDelay m , MonadThrow m , MonadThrow (STM m) + , Strict.MonadMVar m , HasFullHeader block , RandomGen seed + , Eq txid ) => BlockGeneratorArgs block seed - -> (NodeKernel header block seed m -> Async m Void -> m a) + -> [Tx txid] + -> (NodeKernel header block seed txid m -> Async m Void -> m a) -- ^ The continuation which has a handle to the chain selection \/ block -- production thread. The thread might throw an exception. -> m a withNodeKernelThread BlockGeneratorArgs { bgaSlotDuration, bgaBlockGenerator, bgaSeed } + txs k = do - kernel <- newNodeKernel psSeed + kernel <- newNodeKernel psSeed txSeed txs withSlotTime bgaSlotDuration $ \waitForSlot -> withAsync (blockProducerThread kernel waitForSlot) (k kernel) where - (bpSeed, psSeed) = split bgaSeed + (bpSeed, rng) = split bgaSeed + (txSeed, psSeed) = random rng - blockProducerThread :: NodeKernel header block seed m + blockProducerThread :: NodeKernel header block seed txid m -> (SlotNo -> STM m SlotNo) -> m Void blockProducerThread NodeKernel { nkChainProducerState, nkChainDB } diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node/MiniProtocols.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node/MiniProtocols.hs index fb57179fda4..3ad6c7d20fc 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node/MiniProtocols.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet/Node/MiniProtocols.hs @@ -88,7 +88,7 @@ import Pipes qualified import Ouroboros.Network.NodeToNode (blockFetchMiniProtocolNum, chainSyncMiniProtocolNum, keepAliveMiniProtocolNum, - peerSharingMiniProtocolNum) + peerSharingMiniProtocolNum, txSubmissionMiniProtocolNum) import Ouroboros.Network.PeerSelection.LedgerPeers import Ouroboros.Network.PeerSelection.LocalRootPeers (OutboundConnectionsState) import Ouroboros.Network.PeerSelection.PeerSharing qualified as PSTypes @@ -98,7 +98,21 @@ import Ouroboros.Network.Protocol.PeerSharing.Client (peerSharingClientPeer) import Ouroboros.Network.Protocol.PeerSharing.Codec (codecPeerSharing) import Ouroboros.Network.Protocol.PeerSharing.Server (peerSharingServerPeer) import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharing) +import Ouroboros.Network.Protocol.TxSubmission2.Client (txSubmissionClientPeer) +import Ouroboros.Network.Protocol.TxSubmission2.Server + (txSubmissionServerPeerPipelined) +import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck (..), + NumTxIdsToReq (..), TxSubmission2) +import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy (..)) +import Ouroboros.Network.TxSubmission.Inbound.Registry (SharedTxStateVar, + TxChannelsVar, withPeer) +import Ouroboros.Network.TxSubmission.Inbound.Server (txSubmissionInboundV2) +import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxLogic, + TraceTxSubmissionInbound) +import Ouroboros.Network.TxSubmission.Outbound (txSubmissionOutbound) import Test.Ouroboros.Network.Testnet.Node.Kernel +import Test.Ouroboros.Network.TxSubmission.Types (Mempool, Tx (..), + getMempoolReader, getMempoolWriter, txSubmissionCodec2) -- | Protocol codecs. @@ -114,6 +128,8 @@ data Codecs addr header block m = Codecs CBOR.DeserialiseFailure m ByteString , peerSharingCodec :: Codec (PeerSharing addr) CBOR.DeserialiseFailure m ByteString + , txSubmissionCodec :: Codec (TxSubmission2 Int (Tx Int)) + CBOR.DeserialiseFailure m ByteString } cborCodecs :: MonadST m => Codecs NtNAddr BlockHeader Block m @@ -127,6 +143,7 @@ cborCodecs = Codecs , keepAliveCodec = codecKeepAlive_v2 , pingPongCodec = codecPingPong , peerSharingCodec = codecPeerSharing encodeNtNAddr decodeNtNAddr + , txSubmissionCodec = txSubmissionCodec2 } @@ -180,6 +197,14 @@ data LimitsAndTimeouts header block = LimitsAndTimeouts :: ProtocolTimeLimits (PeerSharing NtNAddr) , peerSharingSizeLimits :: ProtocolSizeLimits (PeerSharing NtNAddr) ByteString + + -- tx submission + , txSubmissionLimits + :: MiniProtocolLimits + , txSubmissionTimeLimits + :: ProtocolTimeLimits (TxSubmission2 Int (Tx Int)) + , txSubmissionSizeLimits + :: ProtocolSizeLimits (TxSubmission2 Int (Tx Int)) ByteString } @@ -210,6 +235,8 @@ data AppArgs header block m = AppArgs :: PSTypes.PeerSharing , aaUpdateOutboundConnectionsState :: OutboundConnectionsState -> STM m () + + , aaTxDecisionPolicy :: TxDecisionPolicy } @@ -235,7 +262,9 @@ applications :: forall block header s m. , RandomGen s ) => Tracer m String - -> NodeKernel header block s m + -> Tracer m (TraceTxSubmissionInbound Int (Tx Int)) + -> Tracer m (TraceTxLogic NtNAddr Int (Tx Int)) + -> NodeKernel header block s Int m -> Codecs NtNAddr header block m -> LimitsAndTimeouts header block -> AppArgs header block m @@ -243,10 +272,11 @@ applications :: forall block header s m. -> Diff.Applications NtNAddr NtNVersion NtNVersionData NtCAddr NtCVersion NtCVersionData m () -applications debugTracer nodeKernel +applications debugTracer txSubmissionInboundTracer txSubmissionInboundDebug nodeKernel Codecs { chainSyncCodec, blockFetchCodec , keepAliveCodec, pingPongCodec , peerSharingCodec + , txSubmissionCodec } limits AppArgs @@ -259,6 +289,7 @@ applications debugTracer nodeKernel , aaChainSyncEarlyExit , aaOwnPeerSharing , aaUpdateOutboundConnectionsState + , aaTxDecisionPolicy } toHeader = Diff.Applications @@ -318,6 +349,17 @@ applications debugTracer nodeKernel blockFetchInitiator blockFetchResponder } + + , MiniProtocol { + miniProtocolNum = txSubmissionMiniProtocolNum, + miniProtocolLimits = txSubmissionLimits limits, + miniProtocolRun = + InitiatorAndResponderProtocol + (txSubmissionInitiator aaTxDecisionPolicy (nkMempool nodeKernel)) + (txSubmissionResponder (nkMempool nodeKernel) + (nkTxChannelsVar nodeKernel) + (nkSharedTxStateVar nodeKernel)) + } ] , withWarm = WithWarm [ MiniProtocol @@ -601,6 +643,63 @@ applications debugTracer nodeKernel $ peerSharingServerPeer $ peerSharingServer psAPI + txSubmissionInitiator + :: TxDecisionPolicy + -> Mempool m Int + -> MiniProtocolCb (ExpandedInitiatorContext NtNAddr m) ByteString m () + txSubmissionInitiator txDecisionPolicy mempool = + MiniProtocolCb $ + \ ExpandedInitiatorContext { + eicConnectionId = connId, + eicControlMessage = controlMessageSTM + } + channel + -> do + let client = txSubmissionOutbound + ((show . (connId,)) `contramap` debugTracer) + (NumTxIdsToAck $ getNumTxIdsToReq + $ maxUnacknowledgedTxIds + $ txDecisionPolicy) + (getMempoolReader mempool) + maxBound + controlMessageSTM + labelThisThread "TxSubmissionClient" + runPeerWithLimits + ((show . (connId,)) `contramap` debugTracer) + txSubmissionCodec + (txSubmissionSizeLimits limits) + (txSubmissionTimeLimits limits) + channel + (txSubmissionClientPeer client) + + txSubmissionResponder + :: Mempool m Int + -> TxChannelsVar m NtNAddr Int (Tx Int) + -> SharedTxStateVar m NtNAddr Int (Tx Int) + -> MiniProtocolCb (ResponderContext NtNAddr) ByteString m () + txSubmissionResponder mempool txChannelsVar sharedTxStateVar = + MiniProtocolCb $ + \ ResponderContext { rcConnectionId = connId@ConnectionId { remoteAddress = them }} channel + -> do + withPeer txSubmissionInboundDebug + txChannelsVar + sharedTxStateVar + (getMempoolReader mempool) + getTxSize + them $ \api -> do + let server = txSubmissionInboundV2 + txSubmissionInboundTracer + (getMempoolReader mempool) + (getMempoolWriter mempool) + api + labelThisThread "TxSubmissionServer" + runPipelinedPeerWithLimits + ((show . (connId,)) `contramap` debugTracer) + txSubmissionCodec + (txSubmissionSizeLimits limits) + (txSubmissionTimeLimits limits) + channel + (txSubmissionServerPeerPipelined server) -- -- Orphaned Instances diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission.hs index e16dde5ee6e..ef97a176eaf 100644 --- a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission.hs +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission.hs @@ -1,390 +1,14 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeOperators #-} - module Test.Ouroboros.Network.TxSubmission (tests) where -import Prelude hiding (seq) - -import NoThunks.Class (NoThunks) - -import Control.Concurrent.Class.MonadSTM -import Control.Exception (SomeException (..)) -import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadFork -import Control.Monad.Class.MonadSay -import Control.Monad.Class.MonadST -import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime.SI -import Control.Monad.Class.MonadTimer.SI -import Control.Monad.IOSim hiding (SimResult) -import Control.Tracer (Tracer (..), contramap, nullTracer, showTracing, - traceWith) - -import Codec.CBOR.Decoding qualified as CBOR -import Codec.CBOR.Encoding qualified as CBOR -import Codec.CBOR.Read qualified as CBOR - -import Data.ByteString.Lazy (ByteString) -import Data.ByteString.Lazy qualified as BSL -import Data.Foldable as Foldable (find, foldl', toList) -import Data.Function (on) -import Data.List (intercalate, nubBy) -import Data.Maybe (fromMaybe, isJust) -import Data.Sequence (Seq) -import Data.Sequence qualified as Seq -import Data.Set qualified as Set -import Data.Word (Word16) -import GHC.Generics (Generic) - -import Network.TypedProtocol.Codec - -import Ouroboros.Network.Channel -import Ouroboros.Network.ControlMessage (ControlMessage (..), ControlMessageSTM) -import Ouroboros.Network.Driver -import Ouroboros.Network.NodeToNode (NodeToNodeVersion (..)) -import Ouroboros.Network.Protocol.TxSubmission2.Client -import Ouroboros.Network.Protocol.TxSubmission2.Codec -import Ouroboros.Network.Protocol.TxSubmission2.Server -import Ouroboros.Network.Protocol.TxSubmission2.Type -import Ouroboros.Network.TxSubmission.Inbound -import Ouroboros.Network.TxSubmission.Mempool.Reader -import Ouroboros.Network.TxSubmission.Outbound -import Ouroboros.Network.Util.ShowProxy +import Test.Ouroboros.Network.TxSubmission.AppV1 qualified as AppV1 +import Test.Ouroboros.Network.TxSubmission.AppV2 qualified as AppV2 +import Test.Ouroboros.Network.TxSubmission.TxLogic qualified as TxLogic -import Test.Ouroboros.Network.Utils - -import Test.QuickCheck import Test.Tasty (TestTree, testGroup) -import Test.Tasty.QuickCheck (testProperty) -import Text.Printf - tests :: TestTree -tests = testGroup "TxSubmission" - [ testProperty "txSubmission" prop_txSubmission - , testProperty "x" prop_x +tests = testGroup "Ouroboros.Network.TxSubmission" + [ TxLogic.tests + , AppV1.tests + , AppV2.tests ] - - -data Tx txid = Tx { - getTxId :: txid, - getTxSize :: !SizeInBytes, - -- | If false this means that when this tx will be submitted to a remote - -- mempool it will not be valid. The outbound mempool might contain - -- invalid tx's in this sense. - getTxValid :: Bool - } - deriving (Eq, Show, Generic) - -instance NoThunks txid => NoThunks (Tx txid) -instance ShowProxy txid => ShowProxy (Tx txid) where - showProxy _ = "Tx " ++ showProxy (Proxy :: Proxy txid) - -instance Arbitrary txid => Arbitrary (Tx txid) where - arbitrary = - Tx <$> arbitrary - <*> chooseEnum (0, maxTxSize) - -- note: - -- generating small tx sizes avoids overflow error when semigroup - -- instance of `SizeInBytes` is used (summing up all inflight tx - -- sizes). - <*> frequency [ (3, pure True) - , (1, pure False) - ] - - --- maximal tx size -maxTxSize :: SizeInBytes -maxTxSize = 65536 - - -newtype Mempool m txid = Mempool (TVar m (Seq (Tx txid))) - - -emptyMempool :: MonadSTM m => m (Mempool m txid) -emptyMempool = Mempool <$> newTVarIO Seq.empty - -newMempool :: MonadSTM m - => [Tx txid] - -> m (Mempool m txid) -newMempool = fmap Mempool - . newTVarIO - . Seq.fromList - -readMempool :: MonadSTM m => Mempool m txid -> m [Tx txid] -readMempool (Mempool mempool) = toList <$> readTVarIO mempool - - -getMempoolReader :: forall txid m. - ( MonadSTM m - , Eq txid - ) - => Mempool m txid - -> TxSubmissionMempoolReader txid (Tx txid) Int m -getMempoolReader (Mempool mempool) = - TxSubmissionMempoolReader { mempoolGetSnapshot, mempoolZeroIdx = 0 } - where - mempoolGetSnapshot :: STM m (MempoolSnapshot txid (Tx txid) Int) - mempoolGetSnapshot = getSnapshot <$> readTVar mempool - - getSnapshot :: Seq (Tx txid) - -> MempoolSnapshot txid (Tx txid) Int - getSnapshot seq = - MempoolSnapshot { - mempoolTxIdsAfter = - \idx -> zipWith f [idx + 1 ..] (toList $ Seq.drop idx seq), - -- why do I need to use `pred`? - mempoolLookupTx = flip Seq.lookup seq . pred, - mempoolHasTx = \txid -> isJust $ find (\tx -> getTxId tx == txid) seq - } - - f :: Int -> Tx txid -> (txid, Int, SizeInBytes) - f idx Tx {getTxId, getTxSize} = (getTxId, idx, getTxSize) - - -getMempoolWriter :: forall txid m. - ( MonadSTM m - , Ord txid - ) - => Mempool m txid - -> TxSubmissionMempoolWriter txid (Tx txid) Int m -getMempoolWriter (Mempool mempool) = - TxSubmissionMempoolWriter { - txId = getTxId, - - mempoolAddTxs = \txs -> do - atomically $ do - mempoolTxs <- readTVar mempool - let currentIds = Set.fromList (map getTxId (toList mempoolTxs)) - validTxs = nubBy (on (==) getTxId) - $ filter - (\Tx { getTxId, getTxValid } -> - getTxValid - && getTxId `Set.notMember` currentIds) - $ txs - mempoolTxs' = Foldable.foldl' (Seq.|>) mempoolTxs validTxs - writeTVar mempool mempoolTxs' - return (map getTxId validTxs) - } - - -txSubmissionCodec2 :: MonadST m - => Codec (TxSubmission2 Int (Tx Int)) - CBOR.DeserialiseFailure m ByteString -txSubmissionCodec2 = - codecTxSubmission2 CBOR.encodeInt CBOR.decodeInt - encodeTx decodeTx - where - encodeTx Tx {getTxId, getTxSize, getTxValid} = - CBOR.encodeListLen 3 - <> CBOR.encodeInt getTxId - <> CBOR.encodeWord32 (getSizeInBytes getTxSize) - <> CBOR.encodeBool getTxValid - - decodeTx = do - _ <- CBOR.decodeListLen - Tx <$> CBOR.decodeInt - <*> (SizeInBytes <$> CBOR.decodeWord32) - <*> CBOR.decodeBool - - -txSubmissionSimulation - :: forall m txid. - ( MonadAsync m - , MonadDelay m - , MonadFork m - , MonadLabelledSTM m - , MonadMask m - , MonadSay m - , MonadST m - , MonadTimer m - , MonadThrow (STM m) - , Ord txid - , ShowProxy txid - , NoThunks (Tx txid) - - , txid ~ Int - ) - => NumTxIdsToAck - -> [Tx txid] - -> ControlMessageSTM m - -> Maybe DiffTime - -> Maybe DiffTime - -> m ([Tx txid], [Tx txid]) -txSubmissionSimulation maxUnacked outboundTxs - controlMessageSTM - inboundDelay outboundDelay = do - - inboundMempool <- emptyMempool - outboundMempool <- newMempool outboundTxs - (outboundChannel, inboundChannel) <- createConnectedBufferedChannels - (fromIntegral maxUnacked) - outboundAsync <- - async $ runPeerWithLimits - (("OUTBOUND",) `contramap` verboseTracer) - txSubmissionCodec2 - (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) - timeLimitsTxSubmission2 - (maybe id delayChannel outboundDelay outboundChannel) - (txSubmissionClientPeer (outboundPeer outboundMempool)) - - inboundAsync <- - async $ runPipelinedPeerWithLimits - (("INBOUND",) `contramap` verboseTracer) - txSubmissionCodec2 - (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) - timeLimitsTxSubmission2 - (maybe id delayChannel inboundDelay inboundChannel) - (txSubmissionServerPeerPipelined (inboundPeer inboundMempool)) - - _ <- waitAnyCancel [ outboundAsync, inboundAsync ] - - inmp <- readMempool inboundMempool - outmp <- readMempool outboundMempool - return (inmp, outmp) - where - - outboundPeer :: Mempool m txid -> TxSubmissionClient txid (Tx txid) m () - outboundPeer outboundMempool = - txSubmissionOutbound - nullTracer - maxUnacked - (getMempoolReader outboundMempool) - (maxBound :: NodeToNodeVersion) - controlMessageSTM - - inboundPeer :: Mempool m txid -> TxSubmissionServerPipelined txid (Tx txid) m () - inboundPeer inboundMempool = - txSubmissionInbound - nullTracer - maxUnacked - (getMempoolReader inboundMempool) - (getMempoolWriter inboundMempool) - (maxBound :: NodeToNodeVersion) - - -newtype LargeNonEmptyList a = LargeNonEmpty { getLargeNonEmpty :: [a] } - deriving Show - -instance Arbitrary a => Arbitrary (LargeNonEmptyList a) where - arbitrary = - LargeNonEmpty <$> suchThat (resize 500 (listOf arbitrary)) ((>25) . length) - -prop_txSubmission :: Positive Word16 - -> NonEmptyList (Tx Int) - -> Maybe (Positive SmallDelay) - -- ^ The delay must be smaller (<) than 5s, so that overall - -- delay is less than 10s, otherwise 'smallDelay' in - -- 'timeLimitsTxSubmission2' will kick in. - -> Property -prop_txSubmission (Positive maxUnacked) (NonEmpty outboundTxs) delay = - let mbDelayTime = getSmallDelay . getPositive <$> delay - tr = (runSimTrace $ do - controlMessageVar <- newTVarIO Continue - _ <- - async $ do - threadDelay - (fromMaybe 1 mbDelayTime - * realToFrac (length outboundTxs `div` 4)) - atomically (writeTVar controlMessageVar Terminate) - txSubmissionSimulation - (NumTxIdsToAck maxUnacked) outboundTxs - (readTVar controlMessageVar) - mbDelayTime mbDelayTime - ) in - ioProperty $ do - tr' <- evaluateTrace tr - case tr' of - SimException e trace -> do - return $ counterexample (intercalate "\n" $ show e : trace) False - SimDeadLock trace -> do - return $ counterexample (intercalate "\n" $ "Deadlock" : trace) False - SimReturn (inmp, outmp) _trace -> do - -- printf "Log: %s\n" (intercalate "\n" _trace) - let outUniqueTxIds = nubBy (on (==) getTxId) outmp - outValidTxs = filter getTxValid outmp - case (length outUniqueTxIds == length outmp, length outValidTxs == length outmp) of - (True, True) -> - -- If we are presented with a stream of unique txids for valid - -- transactions the inbound transactions should match the outbound - -- transactions exactly. - return $ inmp === take (length inmp) outValidTxs - (True, False) -> - -- If we are presented with a stream of unique txids then we should have - -- fetched all valid transactions. - return $ inmp === take (length inmp) outValidTxs - (False, True) -> - -- If we are presented with a stream of valid txids then we should have - -- fetched some version of those transactions. - return $ map getTxId inmp === take (length inmp) (map getTxId $ - filter getTxValid outUniqueTxIds) - (False, False) - -- If we are presented with a stream of valid and invalid Txs with - -- duplicate txids we're content with completing the protocol - -- without error. - -> return $ property True - -prop_x :: Property -prop_x = prop_txSubmission - Positive {getPositive = 3} - NonEmpty {getNonEmpty = [Tx {getTxId = -83, getTxSize = SizeInBytes 62352, getTxValid = True},Tx {getTxId = 66, getTxSize = SizeInBytes 37084, getTxValid = True},Tx {getTxId = 55, getTxSize = SizeInBytes 54825, getTxValid = False},Tx {getTxId = -94, getTxSize = SizeInBytes 54298, getTxValid = True},Tx {getTxId = -83, getTxSize = SizeInBytes 30932, getTxValid = True},Tx {getTxId = 33, getTxSize = SizeInBytes 40377, getTxValid = True},Tx {getTxId = 87, getTxSize = SizeInBytes 42883, getTxValid = False},Tx {getTxId = -87, getTxSize = SizeInBytes 21529, getTxValid = True},Tx {getTxId = 85, getTxSize = SizeInBytes 15222, getTxValid = True},Tx {getTxId = -13, getTxSize = SizeInBytes 529, getTxValid = True},Tx {getTxId = -21, getTxSize = SizeInBytes 14755, getTxValid = True},Tx {getTxId = 37, getTxSize = SizeInBytes 3921, getTxValid = True},Tx {getTxId = -44, getTxSize = SizeInBytes 42390, getTxValid = True},Tx {getTxId = 47, getTxSize = SizeInBytes 27061, getTxValid = False},Tx {getTxId = 64, getTxSize = SizeInBytes 8540, getTxValid = True},Tx {getTxId = -85, getTxSize = SizeInBytes 15138, getTxValid = False},Tx {getTxId = -23, getTxSize = SizeInBytes 16317, getTxValid = False},Tx {getTxId = -35, getTxSize = SizeInBytes 4372, getTxValid = True},Tx {getTxId = -11, getTxSize = SizeInBytes 13524, getTxValid = True},Tx {getTxId = 98, getTxSize = SizeInBytes 62024, getTxValid = True},Tx {getTxId = -42, getTxSize = SizeInBytes 63227, getTxValid = False},Tx {getTxId = 74, getTxSize = SizeInBytes 31476, getTxValid = True},Tx {getTxId = 72, getTxSize = SizeInBytes 42959, getTxValid = True},Tx {getTxId = 72, getTxSize = SizeInBytes 53084, getTxValid = True},Tx {getTxId = 6, getTxSize = SizeInBytes 5013, getTxValid = True},Tx {getTxId = -62, getTxSize = SizeInBytes 52590, getTxValid = True},Tx {getTxId = -18, getTxSize = SizeInBytes 59325, getTxValid = False},Tx {getTxId = 70, getTxSize = SizeInBytes 40956, getTxValid = True},Tx {getTxId = -82, getTxSize = SizeInBytes 33213, getTxValid = True},Tx {getTxId = -73, getTxSize = SizeInBytes 31026, getTxValid = True},Tx {getTxId = -4, getTxSize = SizeInBytes 19421, getTxValid = True},Tx {getTxId = 68, getTxSize = SizeInBytes 37501, getTxValid = False},Tx {getTxId = 47, getTxSize = SizeInBytes 25707, getTxValid = False},Tx {getTxId = -99, getTxSize = SizeInBytes 58538, getTxValid = False},Tx {getTxId = 86, getTxSize = SizeInBytes 63432, getTxValid = False},Tx {getTxId = -73, getTxSize = SizeInBytes 32185, getTxValid = True},Tx {getTxId = 52, getTxSize = SizeInBytes 55174, getTxValid = False},Tx {getTxId = 52, getTxSize = SizeInBytes 20715, getTxValid = False},Tx {getTxId = -21, getTxSize = SizeInBytes 37063, getTxValid = False},Tx {getTxId = 15, getTxSize = SizeInBytes 63172, getTxValid = True},Tx {getTxId = -26, getTxSize = SizeInBytes 51314, getTxValid = True},Tx {getTxId = 19, getTxSize = SizeInBytes 5042, getTxValid = True},Tx {getTxId = 36, getTxSize = SizeInBytes 40532, getTxValid = True},Tx {getTxId = -30, getTxSize = SizeInBytes 18812, getTxValid = True},Tx {getTxId = 22, getTxSize = SizeInBytes 61634, getTxValid = True},Tx {getTxId = 89, getTxSize = SizeInBytes 44309, getTxValid = True},Tx {getTxId = -98, getTxSize = SizeInBytes 61700, getTxValid = True},Tx {getTxId = -17, getTxSize = SizeInBytes 46606, getTxValid = True},Tx {getTxId = -37, getTxSize = SizeInBytes 25004, getTxValid = False},Tx {getTxId = -53, getTxSize = SizeInBytes 51991, getTxValid = False},Tx {getTxId = -88, getTxSize = SizeInBytes 17941, getTxValid = True},Tx {getTxId = 24, getTxSize = SizeInBytes 19866, getTxValid = True},Tx {getTxId = -99, getTxSize = SizeInBytes 52082, getTxValid = True},Tx {getTxId = 50, getTxSize = SizeInBytes 48715, getTxValid = True},Tx {getTxId = -8, getTxSize = SizeInBytes 24522, getTxValid = True},Tx {getTxId = 92, getTxSize = SizeInBytes 53516, getTxValid = True},Tx {getTxId = 59, getTxSize = SizeInBytes 16151, getTxValid = False},Tx {getTxId = -85, getTxSize = SizeInBytes 57386, getTxValid = True},Tx {getTxId = 23, getTxSize = SizeInBytes 36444, getTxValid = False},Tx {getTxId = -59, getTxSize = SizeInBytes 63727, getTxValid = False},Tx {getTxId = -59, getTxSize = SizeInBytes 12656, getTxValid = True},Tx {getTxId = 13, getTxSize = SizeInBytes 19160, getTxValid = False},Tx {getTxId = -35, getTxSize = SizeInBytes 1681, getTxValid = True},Tx {getTxId = -13, getTxSize = SizeInBytes 46705, getTxValid = False}]} - (Just (Positive {getPositive = SmallDelay {getSmallDelay = 4.3}})) - --- TODO: Belongs in iosim. -data SimResult a = SimReturn a [String] - | SimException SomeException [String] - | SimDeadLock [String] - --- Traverses a list of trace events and returns the result along with all log messages. --- Incase of a pure exception, ie an assert, all tracers evaluated so far are returned. -evaluateTrace :: SimTrace a -> IO (SimResult a) -evaluateTrace = go [] - where - go as tr = do - r <- try (evaluate tr) - case r of - Right (SimTrace _ _ _ (EventSay s) tr') -> go (s : as) tr' - Right (SimTrace _ _ _ _ tr' ) -> go as tr' - Right (SimPORTrace _ _ _ _ (EventSay s) tr') -> go (s : as) tr' - Right (SimPORTrace _ _ _ _ _ tr' ) -> go as tr' - Right (TraceMainReturn _ _ a _) -> pure $ SimReturn a (reverse as) - Right (TraceMainException _ _ e _) -> pure $ SimException e (reverse as) - Right (TraceDeadlock _ _) -> pure $ SimDeadLock (reverse as) - Right TraceLoop -> error "IOSimPOR step time limit exceeded" - Right (TraceInternalError e) -> error ("IOSim: " ++ e) - Left (SomeException e) -> pure $ SimException (SomeException e) (reverse as) - -data WithThreadAndTime a = WithThreadAndTime { - wtatOccuredAt :: !Time - , wtatWithinThread :: !String - , wtatEvent :: !a - } - -instance (Show a) => Show (WithThreadAndTime a) where - show WithThreadAndTime {wtatOccuredAt, wtatWithinThread, wtatEvent} = - printf "%s: %s: %s" (show wtatOccuredAt) (show wtatWithinThread) (show wtatEvent) - -verboseTracer :: forall a m. - ( MonadAsync m - , MonadSay m - , MonadMonotonicTime m - , Show a - ) - => Tracer m a -verboseTracer = threadAndTimeTracer $ showTracing $ Tracer say - -threadAndTimeTracer :: forall a m. - ( MonadAsync m - , MonadMonotonicTime m - ) - => Tracer m (WithThreadAndTime a) -> Tracer m a -threadAndTimeTracer tr = Tracer $ \s -> do - !now <- getMonotonicTime - !tid <- myThreadId - traceWith tr $ WithThreadAndTime now (show tid) s diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/AppV1.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/AppV1.hs new file mode 100644 index 00000000000..abeff672ee6 --- /dev/null +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/AppV1.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Ouroboros.Network.TxSubmission.AppV1 (tests) where + +import Prelude hiding (seq) + +import NoThunks.Class + +import Control.Concurrent.Class.MonadMVar (MonadMVar) +import Control.Concurrent.Class.MonadSTM +import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadSay +import Control.Monad.Class.MonadST +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI +import Control.Monad.IOSim hiding (SimResult) +import Control.Tracer (Tracer (..), contramap, nullTracer) + +import Data.ByteString.Lazy qualified as BSL +import Data.Function (on) +import Data.List (intercalate, nubBy) +import Data.Maybe (fromMaybe) +import Data.Word (Word16) + +import Ouroboros.Network.Channel +import Ouroboros.Network.ControlMessage (ControlMessage (..), ControlMessageSTM) +import Ouroboros.Network.Driver +import Ouroboros.Network.NodeToNode (NodeToNodeVersion (..)) +import Ouroboros.Network.Protocol.TxSubmission2.Client +import Ouroboros.Network.Protocol.TxSubmission2.Codec +import Ouroboros.Network.Protocol.TxSubmission2.Server +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Inbound +import Ouroboros.Network.TxSubmission.Outbound +import Ouroboros.Network.Util.ShowProxy + +import Test.QuickCheck +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +import Test.Ouroboros.Network.TxSubmission.Types +import Test.Ouroboros.Network.Utils + + +tests :: TestTree +tests = testGroup "AppV1" + [ testProperty "txSubmission" prop_txSubmission + ] + +txSubmissionSimulation + :: forall m txid. + ( MonadAsync m + , MonadDelay m + , MonadFork m + , MonadMask m + , MonadMVar m + , MonadSay m + , MonadST m + , MonadSTM m + , MonadTimer m + , MonadThrow m + , MonadThrow (STM m) + , MonadMonotonicTime m + , Ord txid + , Eq txid + , ShowProxy txid + , NoThunks (Tx txid) + + , txid ~ Int + ) + => Tracer m (String, TraceSendRecv (TxSubmission2 txid (Tx txid))) + -> NumTxIdsToAck + -> [Tx txid] + -> ControlMessageSTM m + -> Maybe DiffTime + -> Maybe DiffTime + -> m ([Tx txid], [Tx txid]) +txSubmissionSimulation tracer maxUnacked outboundTxs + controlMessageSTM + inboundDelay outboundDelay = do + + inboundMempool <- emptyMempool + outboundMempool <- newMempool outboundTxs + (outboundChannel, inboundChannel) <- createConnectedChannels + outboundAsync <- + async $ runPeerWithLimits + (("OUTBOUND",) `contramap` tracer) + txSubmissionCodec2 + (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) + timeLimitsTxSubmission2 + (maybe id delayChannel outboundDelay outboundChannel) + (txSubmissionClientPeer (outboundPeer outboundMempool)) + + inboundAsync <- + async $ runPipelinedPeerWithLimits + (("INBOUND",) `contramap` verboseTracer) + txSubmissionCodec2 + (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) + timeLimitsTxSubmission2 + (maybe id delayChannel inboundDelay inboundChannel) + (txSubmissionServerPeerPipelined (inboundPeer inboundMempool)) + + _ <- waitAnyCancel [ outboundAsync, inboundAsync ] + + inmp <- readMempool inboundMempool + outmp <- readMempool outboundMempool + return (inmp, outmp) + where + + outboundPeer :: Mempool m txid -> TxSubmissionClient txid (Tx txid) m () + outboundPeer outboundMempool = + txSubmissionOutbound + nullTracer + maxUnacked + (getMempoolReader outboundMempool) + (maxBound :: NodeToNodeVersion) + controlMessageSTM + + inboundPeer :: Mempool m txid -> TxSubmissionServerPipelined txid (Tx txid) m () + inboundPeer inboundMempool = + txSubmissionInbound + nullTracer + maxUnacked + (getMempoolReader inboundMempool) + (getMempoolWriter inboundMempool) + (maxBound :: NodeToNodeVersion) + +prop_txSubmission :: Positive Word16 + -> NonEmptyList (Tx Int) + -> Maybe (Positive SmallDelay) + -- ^ The delay must be smaller (<) than 5s, so that overall + -- delay is less than 10s, otherwise 'smallDelay' in + -- 'timeLimitsTxSubmission2' will kick in. + -> Property +prop_txSubmission (Positive maxUnacked) (NonEmpty outboundTxs) delay = + let mbDelayTime = getSmallDelay . getPositive <$> delay + tr = (runSimTrace $ do + controlMessageVar <- newTVarIO Continue + _ <- + async $ do + threadDelay + (fromMaybe 1 mbDelayTime + * realToFrac (length outboundTxs `div` 4)) + atomically (writeTVar controlMessageVar Terminate) + txSubmissionSimulation + verboseTracer + (NumTxIdsToAck maxUnacked) outboundTxs + (readTVar controlMessageVar) + mbDelayTime mbDelayTime + ) in + ioProperty $ do + tr' <- evaluateTrace tr + case tr' of + SimException e trace -> do + return $ counterexample (intercalate "\n" $ show e : trace) False + SimDeadLock trace -> do + return $ counterexample (intercalate "\n" $ "Deadlock" : trace) False + SimReturn (inmp, outmp) _trace -> do + -- printf "Log: %s\n" (intercalate "\n" _trace) + let outUniqueTxIds = nubBy (on (==) getTxId) outmp + outValidTxs = filter getTxValid outmp + case (length outUniqueTxIds == length outmp, length outValidTxs == length outmp) of + (True, True) -> + -- If we are presented with a stream of unique txids for valid + -- transactions the inbound transactions should match the outbound + -- transactions exactly. + return $ inmp === take (length inmp) outValidTxs + (True, False) -> + -- If we are presented with a stream of unique txids then we should have + -- fetched all valid transactions. + return $ inmp === take (length inmp) outValidTxs + (False, True) -> + -- If we are presented with a stream of valid txids then we should have + -- fetched some version of those transactions. + return $ map getTxId inmp === take (length inmp) (map getTxId $ + filter getTxValid outUniqueTxIds) + (False, False) + -- If we are presented with a stream of valid and invalid Txs with + -- duplicate txids we're content with completing the protocol + -- without error. + -> return $ property True diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/AppV2.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/AppV2.hs new file mode 100644 index 00000000000..9292c61581e --- /dev/null +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/AppV2.hs @@ -0,0 +1,409 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Ouroboros.Network.TxSubmission.AppV2 (tests) where + +import Prelude hiding (seq) + +import NoThunks.Class + +import Control.Concurrent.Class.MonadMVar.Strict +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad (forM) +import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadSay +import Control.Monad.Class.MonadST +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI +import Control.Monad.IOSim hiding (SimResult) +import Control.Tracer (Tracer (..), contramap) + + +import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Lazy qualified as BSL +import Data.Foldable (traverse_) +import Data.Function (on) +import Data.Hashable +import Data.List (nubBy) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Void (Void) +import System.Random (mkStdGen) + +import Ouroboros.Network.Channel +import Ouroboros.Network.ControlMessage (ControlMessage (..), ControlMessageSTM) +import Ouroboros.Network.DeltaQ (PeerGSV) +import Ouroboros.Network.Driver +import Ouroboros.Network.NodeToNode (NodeToNodeVersion (..)) +import Ouroboros.Network.Protocol.TxSubmission2.Client +import Ouroboros.Network.Protocol.TxSubmission2.Codec +import Ouroboros.Network.Protocol.TxSubmission2.Server +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Inbound.Policy +import Ouroboros.Network.TxSubmission.Inbound.Registry +import Ouroboros.Network.TxSubmission.Inbound.Server (txSubmissionInboundV2) +import Ouroboros.Network.TxSubmission.Inbound.Types (TraceTxLogic) +import Ouroboros.Network.TxSubmission.Outbound +import Ouroboros.Network.Util.ShowProxy + +import Test.Ouroboros.Network.TxSubmission.TxLogic hiding (tests) +import Test.Ouroboros.Network.TxSubmission.Types +import Test.Ouroboros.Network.Utils hiding (debugTracer) + +import Test.QuickCheck +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) + + +tests :: TestTree +tests = testGroup "AppV2" + [ testProperty "txSubmission" prop_txSubmission + , testProperty "txSubmission inflight" prop_txSubmission_inflight + ] + +data TxSubmissionState = + TxSubmissionState { + peerMap :: Map Int ( [Tx Int] + , Maybe (Positive SmallDelay) + , Maybe (Positive SmallDelay) + -- ^ The delay must be smaller (<) than 5s, so that overall + -- delay is less than 10s, otherwise 'smallDelay' in + -- 'timeLimitsTxSubmission2' will kick in. + ) + , decisionPolicy :: TxDecisionPolicy + } deriving (Show) + +instance Arbitrary TxSubmissionState where + arbitrary = do + ArbTxDecisionPolicy decisionPolicy <- arbitrary + peersN <- choose (1, 10) + txsN <- choose (1, 10) + txs <- divvy txsN . nubBy (on (==) getTxId) <$> vectorOf (peersN * txsN) arbitrary + peers <- vectorOf peersN arbitrary + peersState <- map (\(a, (b, c)) -> (a, b, c)) + . zip txs + <$> vectorOf peersN arbitrary + return TxSubmissionState { peerMap = Map.fromList (zip peers peersState), + decisionPolicy + } + shrink TxSubmissionState { peerMap, decisionPolicy } = + TxSubmissionState <$> shrinkMap1 peerMap + <*> [ policy + | ArbTxDecisionPolicy policy <- shrink (ArbTxDecisionPolicy decisionPolicy) + ] + where + shrinkMap1 :: (Ord k, Arbitrary k, Arbitrary v) => Map k v -> [Map k v] + shrinkMap1 m + | Map.size m <= 1 = [m] + | otherwise = [Map.delete k m | k <- Map.keys m] ++ singletonMaps + where + singletonMaps = [Map.singleton k v | (k, v) <- Map.toList m] + +runTxSubmission + :: forall m peeraddr txid. + ( MonadAsync m + , MonadDelay m + , MonadFork m + , MonadMask m + , MonadMVar m + , MonadSay m + , MonadST m + , MonadLabelledSTM m + , MonadTimer m + , MonadThrow m + , MonadThrow (STM m) + , MonadMonotonicTime m + , Ord txid + , Eq txid + , ShowProxy txid + , NoThunks (Tx txid) + , Show peeraddr + , Ord peeraddr + , Hashable peeraddr + + , txid ~ Int + ) + => Tracer m (String, TraceSendRecv (TxSubmission2 txid (Tx txid))) + -> Tracer m (TraceTxLogic peeraddr txid (Tx txid)) + -> Map peeraddr ( [Tx txid] + , ControlMessageSTM m + , Maybe DiffTime + , Maybe DiffTime + ) + -> TxDecisionPolicy + -> m ([Tx txid], [[Tx txid]]) +runTxSubmission tracer tracerTxLogic state txDecisionPolicy = do + + state' <- traverse (\(b, c, d, e) -> do + mempool <- newMempool b + (outChannel, inChannel) <- createConnectedChannels + return (mempool, c, d, e, outChannel, inChannel) + ) state + + inboundMempool <- emptyMempool + let txRng = mkStdGen 42 -- TODO + + txChannelsMVar <- newMVar (TxChannels Map.empty) + sharedTxStateVar <- newSharedTxStateVar txRng + labelTVarIO sharedTxStateVar "shared-tx-state" + gsvVar <- newTVarIO Map.empty + labelTVarIO gsvVar "gsv" + + run state' + txChannelsMVar + sharedTxStateVar + inboundMempool + gsvVar + (\(a, as) -> do + _ <- waitAnyCancel as + cancel a + + inmp <- readMempool inboundMempool + outmp <- forM (Map.elems state') + (\(outMempool, _, _, _, _, _) -> readMempool outMempool) + return (inmp, outmp) + ) + + where + run :: Map peeraddr ( Mempool m txid -- ^ Outbound mempool + , ControlMessageSTM m + , Maybe DiffTime -- ^ Outbound delay + , Maybe DiffTime -- ^ Inbound delay + , Channel m ByteString -- ^ Outbound channel + , Channel m ByteString -- ^ Inbound channel + ) + -> TxChannelsVar m peeraddr txid (Tx txid) + -> SharedTxStateVar m peeraddr txid (Tx txid) + -> Mempool m txid -- ^ Inbound mempool + -> StrictTVar m (Map peeraddr PeerGSV) + -> ((Async m Void, [Async m ((), Maybe ByteString)]) -> m b) + -> m b + run st txChannelsVar sharedTxStateVar + inboundMempool gsvVar k = + withAsync (decisionLogicThread tracerTxLogic txDecisionPolicy (readTVar gsvVar) txChannelsVar sharedTxStateVar) $ \a -> do + -- Construct txSubmission outbound client + let clients = (\(addr, (mempool, ctrlMsgSTM, outDelay, _, outChannel, _)) -> do + let client = txSubmissionOutbound (Tracer $ say . show) + (NumTxIdsToAck $ getNumTxIdsToReq + $ maxUnacknowledgedTxIds + $ txDecisionPolicy) + (getMempoolReader mempool) + (maxBound :: NodeToNodeVersion) + ctrlMsgSTM + runPeerWithLimits (("OUTBOUND " ++ show addr,) `contramap` tracer) + txSubmissionCodec2 + (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) + timeLimitsTxSubmission2 + (maybe id delayChannel outDelay outChannel) + (txSubmissionClientPeer client) + ) + <$> Map.assocs st + + -- Construct txSubmission inbound server + servers = (\(addr, (_, _, _, inDelay, _, inChannel)) -> + withPeer tracerTxLogic + txChannelsVar + sharedTxStateVar + (getMempoolReader inboundMempool) + getTxSize + addr $ \api -> do + let server = txSubmissionInboundV2 verboseTracer + (getMempoolReader inboundMempool) + (getMempoolWriter inboundMempool) + api + runPipelinedPeerWithLimits + (("INBOUND " ++ show addr,) `contramap` verboseTracer) + txSubmissionCodec2 + (byteLimitsTxSubmission2 (fromIntegral . BSL.length)) + timeLimitsTxSubmission2 + (maybe id delayChannel inDelay inChannel) + (txSubmissionServerPeerPipelined server) + ) <$> Map.assocs st + + -- Run clients and servers + withAsyncAll (clients ++ servers) (\asyncs -> k (a, asyncs)) + + withAsyncAll :: MonadAsync m => [m a] -> ([Async m a] -> m b) -> m b + withAsyncAll xs0 action = go [] xs0 + where + go as [] = action (reverse as) + go as (x:xs) = withAsync x (\a -> go (a:as) xs) + +txSubmissionSimulation :: forall s . TxSubmissionState -> IOSim s ([Tx Int], [[Tx Int]]) +txSubmissionSimulation (TxSubmissionState state txDecisionPolicy) = do + state' <- traverse (\(txs, mbOutDelay, mbInDelay) -> do + let mbOutDelayTime = getSmallDelay . getPositive <$> mbOutDelay + mbInDelayTime = getSmallDelay . getPositive <$> mbInDelay + controlMessageVar <- newTVarIO Continue + return ( txs + , controlMessageVar + , mbOutDelayTime + , mbInDelayTime + ) + ) + state + + state'' <- traverse (\(txs, var, mbOutDelay, mbInDelay) -> do + return ( txs + , readTVar var + , mbOutDelay + , mbInDelay + ) + ) + state' + + let simDelayTime = Map.foldl' (\m (txs, _, mbInDelay, mbOutDelay) -> + max m ( fromMaybe 1 (max <$> mbInDelay <*> mbOutDelay) + * realToFrac (length txs `div` 4) + ) + ) + 0 + $ state'' + controlMessageVars = (\(_, x, _, _) -> x) + <$> Map.elems state' + + _ <- async do + threadDelay (simDelayTime + 1000) + atomically (traverse_ (`writeTVar` Terminate) controlMessageVars) + + let tracer :: forall a. Show a => Tracer (IOSim s) a + tracer = verboseTracer <> debugTracer + runTxSubmission tracer tracer state'' txDecisionPolicy + +-- | Tests overall tx submission semantics. The properties checked in this +-- property test are the same as for tx submission v1. We need this to know we +-- didn't regress. +-- +prop_txSubmission :: TxSubmissionState -> Property +prop_txSubmission st = + let tr = runSimTrace (txSubmissionSimulation st) in + case traceResult True tr of + Left e -> + counterexample (show e) + . counterexample (ppTrace tr) + $ False + Right (inmp, outmps) -> + counterexample (ppTrace tr) + $ conjoin (validate inmp `map` outmps) + where + validate :: [Tx Int] -- the inbound mempool + -> [Tx Int] -- one of the outbound mempools + -> Property + validate inmp outmp = + let outUniqueTxIds = nubBy (on (==) getTxId) outmp + outValidTxs = filter getTxValid outmp + in + case ( length outUniqueTxIds == length outmp + , length outValidTxs == length outmp + ) of + x@(True, True) -> + -- If we are presented with a stream of unique txids for valid + -- transactions the inbound transactions should match the outbound + -- transactions exactly. + counterexample (show x) + . counterexample (show inmp) + . counterexample (show outmp) + $ checkMempools inmp (take (length inmp) outValidTxs) + + x@(True, False) -> + -- If we are presented with a stream of unique txids then we should have + -- fetched all valid transactions. + counterexample (show x) + . counterexample (show inmp) + . counterexample (show outmp) + $ checkMempools inmp (take (length inmp) outValidTxs) + + x@(False, True) -> + -- If we are presented with a stream of valid txids then we should have + -- fetched some version of those transactions. + counterexample (show x) + . counterexample (show inmp) + . counterexample (show outmp) + $ checkMempools (map getTxId inmp) + (take (length inmp) + (map getTxId $ filter getTxValid outUniqueTxIds)) + + (False, False) -> + -- If we are presented with a stream of valid and invalid Txs with + -- duplicate txids we're content with completing the protocol + -- without error. + property True + +-- | This test checks that all txs are downloaded from all available peers if +-- available. +-- +-- This test takes advantage of the fact that the mempool implementation +-- allows duplicates. +-- +prop_txSubmission_inflight :: TxSubmissionState -> Property +prop_txSubmission_inflight st@(TxSubmissionState state _) = + let trace = runSimTrace (txSubmissionSimulation st) + maxRepeatedValidTxs = Map.foldr (\(txs, _, _) r -> + foldr (\tx rr -> + if Map.member tx rr && getTxValid tx + then Map.update (Just . succ @Int) tx rr + else if getTxValid tx + then Map.insert tx 1 rr + else rr + ) + r + txs + ) + Map.empty + state + + in case traceResult True trace of + Left err -> counterexample (ppTrace trace) + $ counterexample (show err) + $ property False + Right (inmp, _) -> + let resultRepeatedValidTxs = + foldr (\tx rr -> + if Map.member tx rr && getTxValid tx + then Map.update (Just . succ @Int) tx rr + else if getTxValid tx + then Map.insert tx 1 rr + else rr + ) + Map.empty + inmp + in resultRepeatedValidTxs === maxRepeatedValidTxs + + +-- | Check that the inbound mempool contains all outbound `tx`s as a proper +-- subsequence. It might contain more `tx`s from other peers. +-- +checkMempools :: Eq tx + => [tx] -- inbound mempool + -> [tx] -- outbound mempool + -> Bool +checkMempools _ [] = True -- all outbound `tx` were found in the inbound + -- mempool +checkMempools [] (_:_) = False -- outbound mempool contains `tx`s which were + -- not transferred to the inbound mempool +checkMempools (i : is') os@(o : os') + | i == o + = checkMempools is' os' + + | otherwise + -- `_i` is not present in the outbound mempool, we can skip it. + = checkMempools is' os + + +-- | Split a list into sub list of at most `n` elements. +-- +divvy :: Int -> [a] -> [[a]] +divvy _ [] = [] +divvy n as = take n as : divvy n (drop n as) diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs new file mode 100644 index 00000000000..5a6ffb6c16f --- /dev/null +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs @@ -0,0 +1,1623 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Ouroboros.Network.TxSubmission.TxLogic where + +import Prelude hiding (seq) + +import Control.Monad.Class.MonadTime.SI (Time (..)) +import Control.Exception (assert) + +import Data.Foldable ( + fold, +#if !MIN_VERSION_base(4,20,0) + foldl', +#endif + toList) +import Data.List (intercalate, isPrefixOf, isSuffixOf, mapAccumR, nub, + stripPrefix) +import Data.Map.Merge.Strict qualified as Map +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, maybeToList) +import Data.Monoid (Sum (..)) +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Typeable +import System.Random (mkStdGen, StdGen) + +import NoThunks.Class + +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Inbound.Decision + (SharedDecisionContext (..), TxDecision (..)) +import Ouroboros.Network.TxSubmission.Inbound.Decision qualified as TXS +import Ouroboros.Network.TxSubmission.Inbound.Policy +import Ouroboros.Network.TxSubmission.Inbound.State (PeerTxState (..), + SharedTxState (..)) +import Ouroboros.Network.TxSubmission.Inbound.State qualified as TXS +import Ouroboros.Network.TxSubmission.Inbound.Types qualified as TXS + +import Test.Ouroboros.Network.BlockFetch (PeerGSVT (..)) +import Test.Ouroboros.Network.TxSubmission.Types + +import Test.QuickCheck +import Test.QuickCheck.Function (apply) +import Test.QuickCheck.Monoids (All (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty) +import Text.Pretty.Simple + + +tests :: TestTree +tests = testGroup "TxLogic" + [ testGroup "State" + [ testGroup "Arbitrary" + [ testGroup "ArbSharedTxState" + [ testProperty "generator" prop_SharedTxState_generator + , testProperty "shrinker" $ withMaxSuccess 10 + prop_SharedTxState_shrinker + , testProperty "nothunks" prop_SharedTxState_nothunks + ] + , testGroup "ArbReceivedTxIds" + [ testProperty "generator" prop_receivedTxIds_generator + ] + , testGroup "ArbCollectTxs" + [ testProperty "generator" prop_collectTxs_generator + , testProperty "shrinker" $ withMaxSuccess 10 + prop_collectTxs_shrinker + ] + ] + , testProperty "acknowledgeTxIds" prop_acknowledgeTxIds + , testProperty "receivedTxIdsImpl" prop_receivedTxIdsImpl + , testProperty "collectTxsImpl" prop_collectTxsImpl + , testProperty "numTxIdsToRequest" prop_numTxIdsToRequest + , testGroup "NoThunks" + [ testProperty "receivedTxIdsImpl" prop_receivedTxIdsImpl_nothunks + , testProperty "collectTxsImpl" prop_collectTxsImpl_nothunks + ] + ] + , testGroup "Decisions" + [ testGroup "ArbDecisionContexts" + [ testProperty "generator" prop_ArbDecisionContexts_generator + , testProperty "shrinker" $ withMaxSuccess 33 + prop_ArbDecisionContexts_shrinker + ] + , testProperty "shared state invariant" prop_makeDecisions_sharedstate + , testProperty "inflight" prop_makeDecisions_inflight + , testProperty "policy" prop_makeDecisions_policy + , testProperty "acknowledged" prop_makeDecisions_acknowledged + , testProperty "exhaustive" prop_makeDecisions_exhaustive + ] + , testGroup "Registry" + [ testGroup "filterActivePeers" + [ testProperty "not limiting decisions" prop_filterActivePeers_not_limitting_decisions + ] + ] + ] + + +-- +-- InboundState properties +-- + +type PeerAddr = Int + +-- | 'InboundState` invariant. +-- +sharedTxStateInvariant + :: forall peeraddr txid tx. + ( Ord txid + , Show txid + ) + => SharedTxState peeraddr txid tx + -> Property +sharedTxStateInvariant SharedTxState { + peerTxStates, + inflightTxs, + inflightTxsSize, + bufferedTxs, + referenceCounts + } = + + -- -- `inflightTxs` and `bufferedTxs` are disjoint + -- counterexample "inflightTxs not disjoint with bufferedTxs" + -- (null (inflightTxsSet `Set.intersection` bufferedTxsSet)) + + -- the set of buffered txids is equal to sum of the sets of + -- unacknowledged txids. + counterexample "bufferedTxs txid not a subset of unacknoledged txids" + (bufferedTxsSet + `Set.isSubsetOf` + foldr (\PeerTxState { unacknowledgedTxIds } r -> + r <> Set.fromList (toList unacknowledgedTxIds)) + Set.empty txStates) + + .&&. counterexample "referenceCounts invariant violation" + ( referenceCounts + === + foldl' + (\m PeerTxState { unacknowledgedTxIds = unacked } -> + foldl' + (flip $ + Map.alter (\case + Nothing -> Just $! 1 + Just cnt -> Just $! succ cnt) + ) + m + unacked + ) + Map.empty txStates + ) + + .&&. counterexample ("bufferedTxs contain tx which should be gc-ed: " + ++ show (Map.keysSet bufferedTxs `Set.difference` liveSet)) + (Map.keysSet bufferedTxs `Set.isSubsetOf` liveSet) + + .&&. counterexample "inflightTxs must be a sum of requestedTxInflight sets" + (inflightTxs + === + foldr (\PeerTxState { requestedTxsInflight } m -> + Map.unionWith (+) (Map.fromSet (\_ -> 1) requestedTxsInflight) m) + Map.empty + peerTxStates) + + -- PeerTxState invariants + .&&. counterexample "PeerTxState invariant violation" + (foldMap (\ps -> All + . counterexample (show ps) + . peerTxStateInvariant + $ ps + ) + peerTxStates) + + .&&. counterexample "inflightTxsSize invariant violation" + (inflightTxsSize === foldMap requestedTxsInflightSize peerTxStates) + + + + where + peerTxStateInvariant :: PeerTxState txid tx -> Property + peerTxStateInvariant PeerTxState { availableTxIds, + unacknowledgedTxIds, + unknownTxs, + requestedTxIdsInflight, + requestedTxsInflight, + requestedTxsInflightSize } = + + + counterexample ("unknownTxs is not a subset of unacknowledgedTxIds: " + ++ show (unknownTxs Set.\\ unacknowledgedTxIdsSet)) + (unknownTxs `Set.isSubsetOf` unacknowledgedTxIdsSet) + + .&&. counterexample ("availableTxs is not a subset of unacknowledgedTxIds: " + ++ show (availableTxIdsSet Set.\\ unacknowledgedTxIdsSet)) + (availableTxIdsSet `Set.isSubsetOf` unacknowledgedTxIdsSet) + + .&&. counterexample ("unacknowledged tx must be either available, unknown or buffered: " + ++ show (unacknowledgedTxIdsSet + Set.\\ availableTxIdsSet + Set.\\ unknownTxs + Set.\\ bufferedTxsSet)) + (unacknowledgedTxIdsSet + Set.\\ availableTxIdsSet + Set.\\ unknownTxs + `Set.isSubsetOf` + bufferedTxsSet + ) + + .&&. counterexample "requestedTxIdsInflight invariant violation" + (requestedTxIdsInflight >= 0) + + -- a requested tx is either available or buffered + .&&. counterexample ("requestedTxsInflight invariant violation: " + ++ show (requestedTxsInflight + Set.\\ availableTxIdsSet + Set.\\ bufferedTxsSet)) + (requestedTxsInflight Set.\\ availableTxIdsSet `Set.isSubsetOf` bufferedTxsSet) + + .&&. counterexample "requestedTxsInfightSize" + (requestedTxsInflightSize + === + fold (availableTxIds `Map.restrictKeys` requestedTxsInflight)) + + where + availableTxIdsSet :: Set txid + availableTxIdsSet = Map.keysSet availableTxIds + + unacknowledgedTxIdsSet :: Set txid + unacknowledgedTxIdsSet = Set.fromList (toList unacknowledgedTxIds) + + bufferedTxsSet = Map.keysSet bufferedTxs :: Set txid + liveSet = Map.keysSet referenceCounts :: Set txid + txStates = Map.elems peerTxStates :: [PeerTxState txid tx] + +-- +-- Generate `InboundState` +-- + +-- | PeerTxState generator. +-- +-- `mkArbPeerTxState` is the smart constructor. +-- +data ArbPeerTxState txid tx = + ArbPeerTxState { arbPeerTxState :: PeerTxState txid tx, + arbInflightSet :: Set tx, + -- ^ in-flight txs + arbBufferedMap :: Map txid (Maybe tx) + } + +data TxStatus = Available | Inflight | Unknown + +instance Arbitrary TxStatus where + arbitrary = oneof [ pure Available + , pure Inflight + , pure Unknown + ] + +data TxMask tx = TxAvailable tx TxStatus + -- ^ available txid with its size, the Bool indicates if it's + -- in-flight or not + | TxBuffered tx + +fixupTxMask :: txid -> TxMask (Tx txid) -> TxMask (Tx txid) +fixupTxMask txid (TxAvailable tx status) = TxAvailable tx { getTxId = txid } status +fixupTxMask txid (TxBuffered tx) = TxBuffered tx { getTxId = txid } + + +instance Arbitrary tx => Arbitrary (TxMask tx) where + arbitrary = oneof [ TxAvailable + <$> arbitrary + <*> arbitrary + , TxBuffered <$> arbitrary + ] + + -- TODO: implement shrinker; this can be done by writing an inverse of + -- `mkArbPeerTxState` and shrinking the unacknowledged txs & mask map. + + +-- | Smart constructor for `ArbPeerTxState`. +-- +mkArbPeerTxState :: Ord txid + => Fun txid Bool + -> Int -- ^ txids in-flight + -> [txid] + -> Map txid (TxMask (Tx txid)) + -> ArbPeerTxState txid (Tx txid) +mkArbPeerTxState mempoolHasTxFun txIdsInflight unacked txMaskMap = + ArbPeerTxState + PeerTxState { unacknowledgedTxIds = StrictSeq.fromList unacked, + availableTxIds, + requestedTxIdsInflight, + requestedTxsInflight, + requestedTxsInflightSize, + unknownTxs, + rejectedTxs = 0, + rejectedTxsTs = Time 0, + fetchedTxs = Set.empty } + (Set.fromList $ Map.elems inflightMap) + bufferedMap + where + mempoolHasTx = apply mempoolHasTxFun + availableTxIds = Map.fromList + [ (txid, getTxAdvSize tx) | (txid, TxAvailable tx _) <- Map.assocs txMaskMap + , not (mempoolHasTx txid) + ] + unknownTxs = Set.fromList + [ txid | (txid, TxAvailable _ Unknown) <- Map.assocs txMaskMap + , not (mempoolHasTx txid) + ] + + requestedTxIdsInflight = fromIntegral txIdsInflight + requestedTxsInflightSize = foldMap getTxAdvSize inflightMap + requestedTxsInflight = Map.keysSet inflightMap + + -- exclude `txid`s which are already in the mempool, we never request such + -- `txid`s + -- + -- TODO: this should be lifted, we might have the same txid in-flight from + -- multiple peers, one will win the race and land in the mempool first + inflightMap = Map.fromList + [ (txid, tx) + | (txid, TxAvailable tx Inflight) <- Map.assocs txMaskMap + , not (mempoolHasTx txid) + ] + + bufferedMap = Map.fromList + [ (txid, Nothing) + | txid <- Map.keys txMaskMap + , mempoolHasTx txid + ] + `Map.union` + Map.fromList + [ (txid, mtx) + | (txid, TxBuffered tx) <- Map.assocs txMaskMap + , let !mtx = if mempoolHasTx txid + then Nothing + else Just $! tx { getTxId = txid } + ] + + +genArbPeerTxState + :: forall txid. + ( Arbitrary txid + , Ord txid + ) + => Fun txid Bool + -> Int -- ^ max txids inflight + -> Gen (ArbPeerTxState txid (Tx txid)) +genArbPeerTxState mempoolHasTxFun maxTxIdsInflight = do + -- unacknowledged sequence + unacked <- arbitrary + -- generate `Map txid (TxMask tx)` + txIdsInflight <- choose (0, maxTxIdsInflight) + txMap <- Map.fromList + <$> traverse (\txid -> (\a -> (txid, fixupTxMask txid a)) <$> arbitrary) + (nub unacked) + return $ mkArbPeerTxState mempoolHasTxFun txIdsInflight unacked txMap + + +genSharedTxState + :: forall txid. + ( Arbitrary txid + , Ord txid + , Function txid + , CoArbitrary txid + ) + => Int -- ^ max txids inflight + -> Gen ( Fun txid Bool + , (PeerAddr, PeerTxState txid (Tx txid)) + , SharedTxState PeerAddr txid (Tx txid) + , Map PeerAddr (ArbPeerTxState txid (Tx txid)) + ) +genSharedTxState maxTxIdsInflight = do + _mempoolHasTxFun@(Fun (_, _, x) _) <- arbitrary :: Gen (Fun Bool Bool) + let mempoolHasTxFun = Fun (function (const False), False, x) (const False) + pss <- listOf1 (genArbPeerTxState mempoolHasTxFun maxTxIdsInflight) + seed <- arbitrary + + let pss' :: [(PeerAddr, ArbPeerTxState txid (Tx txid))] + pss' = [0..] `zip` pss + + peer <- choose (0, length pss - 1) + + let st :: SharedTxState PeerAddr txid (Tx txid) + st = fixupSharedTxState + (apply mempoolHasTxFun) + SharedTxState { + peerTxStates = Map.fromList + [ (peeraddr, arbPeerTxState) + | (peeraddr, ArbPeerTxState { arbPeerTxState }) + <- pss' + ], + inflightTxs = foldl' (Map.unionWith (+)) Map.empty + [ Map.fromSet (const 1) (Set.map getTxId arbInflightSet) + | ArbPeerTxState { arbInflightSet } + <- pss + ], + inflightTxsSize = 0, -- It is set by fixupSharedTxState + bufferedTxs = fold + [ arbBufferedMap + | ArbPeerTxState { arbBufferedMap } + <- pss + ], + referenceCounts = Map.empty, + peerRng = mkStdGen seed + } + + return ( mempoolHasTxFun + , (peer, peerTxStates st Map.! peer) + , st + , Map.fromList pss' + ) + + +-- | Make sure `SharedTxState` is well formed. +-- +fixupSharedTxState + :: Ord txid + => (txid -> Bool) -- ^ mempoolHasTx + -> SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx +fixupSharedTxState _mempoolHasTx st@SharedTxState { peerTxStates } = + st { peerTxStates = peerTxStates', + inflightTxs = inflightTxs', + inflightTxsSize = foldMap requestedTxsInflightSize peerTxStates', + bufferedTxs = bufferedTxs', + referenceCounts = referenceCounts' + } + where + peerTxStates' = + Map.map (\ps@PeerTxState { availableTxIds, + requestedTxsInflight } -> + + let -- requested txs must not be buffered + requestedTxsInflight' = requestedTxsInflight + Set.\\ Map.keysSet bufferedTxs' + requestedTxsInflightSize' = fold $ availableTxIds + `Map.restrictKeys` + requestedTxsInflight' + + in ps { requestedTxsInflight = requestedTxsInflight', + requestedTxsInflightSize = requestedTxsInflightSize' } + ) + peerTxStates + + inflightTxs' = foldr (\PeerTxState { requestedTxsInflight } m -> + Map.unionWith (+) + (Map.fromSet (const 1) requestedTxsInflight) + m + ) + Map.empty + peerTxStates' + + bufferedTxs' = + bufferedTxs st + `Map.restrictKeys` + foldr (\PeerTxState {unacknowledgedTxIds = unacked } r -> + r <> Set.fromList (toList unacked)) + Set.empty (Map.elems peerTxStates) + + + referenceCounts' = + foldl' + (\m PeerTxState { unacknowledgedTxIds } -> + foldl' + (flip $ + Map.alter (\case + Nothing -> Just $! 1 + Just cnt -> Just $! succ cnt) + ) + m + unacknowledgedTxIds + ) + Map.empty + (Map.elems peerTxStates) + + +shrinkSharedTxState :: ( Arbitrary txid + , Ord txid + , Function txid + , Ord peeraddr + ) + => (txid -> Bool) + -> SharedTxState peeraddr txid (Tx txid) + -> [SharedTxState peeraddr txid (Tx txid)] +shrinkSharedTxState mempoolHasTx st@SharedTxState { peerTxStates, + inflightTxs, + bufferedTxs } = + [ st' + | peerTxStates' <- Map.fromList <$> shrinkList (\_ -> []) (Map.toList peerTxStates) + , not (Map.null peerTxStates') + , let st' = fixupSharedTxState mempoolHasTx st { peerTxStates = peerTxStates' } + , st' /= st + ] + ++ + [ fixupSharedTxState mempoolHasTx st { inflightTxs = inflightTxs' } + | inflightTxs' <- Map.fromList <$> shrinkList (\_ -> []) (Map.toList inflightTxs) + ] + ++ + [ st + | bufferedTxs' <- Map.fromList + <$> shrinkList (\_ -> []) (Map.assocs bufferedTxs) + , let minBuffered = + foldMap + (\PeerTxState { + unacknowledgedTxIds, + availableTxIds, + unknownTxs + } + -> + Set.fromList (toList unacknowledgedTxIds) + Set.\\ Map.keysSet availableTxIds + Set.\\ unknownTxs + ) + peerTxStates + bufferedTxs'' = bufferedTxs' + `Map.union` + (bufferedTxs `Map.restrictKeys` minBuffered) + st' = fixupSharedTxState mempoolHasTx st { bufferedTxs = bufferedTxs'' } + , st' /= st + ] + +-- +-- Arbitrary `SharaedTxState` instance +-- + +data ArbSharedTxState = + ArbSharedTxState + (Fun TxId Bool) + (SharedTxState PeerAddr TxId (Tx TxId)) + deriving Show + +instance Arbitrary ArbSharedTxState where + arbitrary = do + Small maxTxIdsInflight <- arbitrary + (mempoolHasTx, _, sharedTxState, _) <- genSharedTxState maxTxIdsInflight + return $ ArbSharedTxState mempoolHasTx sharedTxState + + shrink (ArbSharedTxState mempoolHasTx st) = + [ ArbSharedTxState mempoolHasTx st' + | st' <- shrinkSharedTxState (apply mempoolHasTx) st + ] + + +-- | Verify that generated `SharedTxState` has no thunks if it's evaluated to +-- WHNF. +-- +prop_SharedTxState_nothunks :: ArbSharedTxState -> Property +prop_SharedTxState_nothunks (ArbSharedTxState _ !st) = + case unsafeNoThunks st of + Nothing -> property True + Just ctx -> counterexample (show ctx) False + + +prop_SharedTxState_generator + :: ArbSharedTxState + -> Property +prop_SharedTxState_generator (ArbSharedTxState _ st) = sharedTxStateInvariant st + + +prop_SharedTxState_shrinker + :: Fixed ArbSharedTxState + -> Property +prop_SharedTxState_shrinker = + property + . foldMap (\(ArbSharedTxState _ st) -> All $ sharedTxStateInvariant st) + . shrink + . getFixed + + +-- +-- `receivedTxIdsImpl` properties +-- + + +data ArbReceivedTxIds = + ArbReceivedTxIds (Fun TxId Bool) -- ^ mempoolHasTx + [Tx TxId] -- ^ some txs to acknowledge + PeerAddr -- ^ peer address + (PeerTxState TxId (Tx TxId)) + -- ^ peer state + (SharedTxState PeerAddr TxId (Tx TxId)) + -- ^ initial state + deriving Show + +instance Arbitrary ArbReceivedTxIds where + arbitrary = do + Small maxTxIdsInflight <- arbitrary + (mempoolHasTxFun, (peeraddr, ps), st, psMap) <- genSharedTxState maxTxIdsInflight + txsToAck <- sublistOf (Set.toList $ arbInflightSet (psMap Map.! peeraddr)) + pure $ ArbReceivedTxIds + mempoolHasTxFun + txsToAck + peeraddr + ps + st + + shrink (ArbReceivedTxIds mempoolHasTxFun txs peeraddr ps st) = + [ ArbReceivedTxIds mempoolHasTxFun txs' peeraddr ps st + | txs' <- shrink txs + ] + ++ + [ ArbReceivedTxIds + mempoolHasTxFun' txs peeraddr ps + (fixupSharedTxState (apply mempoolHasTxFun') st) + | mempoolHasTxFun' <- shrink mempoolHasTxFun + ] + + +prop_receivedTxIds_generator + :: ArbReceivedTxIds + -> Property +prop_receivedTxIds_generator (ArbReceivedTxIds _ someTxsToAck _peeraddr _ps st) = + label ("numToAck " ++ labelInt 100 10 (length someTxsToAck)) + . counterexample (show st) + $ sharedTxStateInvariant st + + +-- | This property verifies that `acknowledgeTxIds` acknowledges a prefix of +-- unacknowledged txs, and that the `numTxIdsToAck` as well as `RefCoundDiff` +-- are correct. +-- +-- It doesn't validate the returned `PeerTxState` holds it's properties as this +-- needs to be done in the context of updated `SharedTxState`. This is verified +-- by `prop_receivedTxIdsImpl`, `prop_collectTxsImpl` and +-- `prop_makeDecisions_acknowledged`. +-- +prop_acknowledgeTxIds :: ArbDecisionContextWithReceivedTxIds + -> Property +prop_acknowledgeTxIds (ArbDecisionContextWithReceivedTxIds policy SharedDecisionContext { sdcSharedTxState = st } ps _ _ _) = + case TXS.acknowledgeTxIds policy st ps of + (numTxIdsToAck, txIdsToRequest, txIdsTxs, TXS.RefCountDiff { TXS.txIdsToAck }, ps') | txIdsToRequest > 0 -> + counterexample "number of tx ids to ack must agree with RefCountDiff" + ( fromIntegral numTxIdsToAck + === + getSum (foldMap Sum txIdsToAck) + ) + + .&&. counterexample "acknowledged txs must form a prefix" + let unacked = toList (unacknowledgedTxIds ps) + unacked' = toList (unacknowledgedTxIds ps') + in case unacked `stripSuffix` unacked' of + Nothing -> counterexample "acknowledged txs are not a prefix" False + Just txIdsToAck' -> + txIdsToAck + === + Map.fromListWith (+) ((,1) <$> txIdsToAck') + + .&&. counterexample "acknowledged txs" (counterexample ("numTxIdsToAck = " ++ show numTxIdsToAck) + let acked :: [TxId] + acked = [ txid + | txid <- take (fromIntegral numTxIdsToAck) (toList $ unacknowledgedTxIds ps) + , Just _ <- maybeToList $ txid `Map.lookup` bufferedTxs st + ] + in map (getTxId . snd) txIdsTxs === acked) + _otherwise -> property True + where + stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] + stripSuffix as suffix = + reverse <$> reverse suffix `stripPrefix` reverse as + + +-- | Verify 'inboundStateInvariant' when acknowledging a sequence of txs. +-- +prop_receivedTxIdsImpl + :: ArbReceivedTxIds + -> Property +prop_receivedTxIdsImpl (ArbReceivedTxIds mempoolHasTxFun txs peeraddr ps st) = + -- InboundState invariant + counterexample + ( "Unacknowledged in mempool: " ++ + show (apply mempoolHasTxFun <$> toList (unacknowledgedTxIds ps)) ++ "\n" + ++ "InboundState invariant violation:\n" ++ + show st' + ) + (sharedTxStateInvariant st') + + -- unacknowledged txs are well formed + .&&. counterexample "unacknowledged txids are not well formed" + ( let unacked = toList $ unacknowledgedTxIds ps <> txidSeq + unacked' = toList $ unacknowledgedTxIds ps' + in counterexample ("old & received: " ++ show unacked ++ "\n" ++ + "new: " ++ show unacked') $ + unacked' `isSuffixOf` unacked + ) + + .&&. -- `receivedTxIdsImpl` doesn't acknowledge any `txids` + counterexample "acknowledged property violation" + ( let unacked = toList $ unacknowledgedTxIds ps + unacked' = toList $ unacknowledgedTxIds ps' + in unacked `isPrefixOf` unacked' + ) + where + st' = TXS.receivedTxIdsImpl (apply mempoolHasTxFun) + peeraddr 0 txidSeq txidMap st + ps' = peerTxStates st' Map.! peeraddr + + txidSeq = StrictSeq.fromList (getTxId <$> txs) + txidMap = Map.fromList [ (getTxId tx, getTxSize tx) | tx <- txs ] + + +-- | Verify that `SharedTxState` returned by `receivedTxIdsImpl` if evaluated +-- to WHNF it doesn't contain any thunks. +-- +prop_receivedTxIdsImpl_nothunks + :: ArbReceivedTxIds + -> Property +prop_receivedTxIdsImpl_nothunks (ArbReceivedTxIds mempoolHasTxFun txs peeraddr _ st) = + case TXS.receivedTxIdsImpl (apply mempoolHasTxFun) + peeraddr 0 txidSeq txidMap st of + !st' -> case unsafeNoThunks st' of + Nothing -> property True + Just ctx -> counterexample (show ctx) False + where + txidSeq = StrictSeq.fromList (getTxId <$> txs) + txidMap = Map.fromList [ (getTxId tx, getTxSize tx) | tx <- txs ] + + +-- +-- `collectTxs` properties +-- + + +data ArbCollectTxs = + ArbCollectTxs (Fun TxId Bool) -- ^ mempoolHasTx + (Set TxId) -- ^ requested txid's + (Map TxId (Tx TxId)) -- ^ received txs + PeerAddr -- ^ peeraddr + (PeerTxState TxId (Tx TxId)) + (SharedTxState PeerAddr TxId (Tx TxId)) + -- ^ 'InboundState' + deriving Show + + +instance Arbitrary ArbCollectTxs where + arbitrary = do + Small maxTxIdsInflight <- arbitrary + ( mempoolHasTxFun + , (peeraddr, ps@PeerTxState { availableTxIds, + requestedTxIdsInflight, + requestedTxsInflight, + requestedTxsInflightSize }) + , st + , _ + ) + <- genSharedTxState maxTxIdsInflight + requestedTxIds <- take (fromIntegral requestedTxIdsInflight) + <$> sublistOf (toList requestedTxsInflight) + + -- Limit the requested `txid`s to satisfy `requestedTxsInflightSize`. + let requestedTxIds' = fmap fst + . takeWhile (\(_,s) -> s <= requestedTxsInflightSize) + $ zip requestedTxIds + (scanl1 (<>) [availableTxIds Map.! txid | txid <- requestedTxIds ]) + + receivedTx <- sublistOf requestedTxIds' + >>= traverse (\txid -> do + -- real size, which might be different from + -- the advertised size + size <- frequency [ (9, pure (availableTxIds Map.! txid)) + , (1, chooseEnum (0, maxTxSize)) + ] + + valid <- frequency [(4, pure True), (1, pure False)] + pure $ Tx { getTxId = txid, + getTxSize = size, + -- `availableTxIds` contains advertised sizes + getTxAdvSize = availableTxIds Map.! txid, + getTxValid = valid }) + + pure $ assert (foldMap getTxAdvSize receivedTx <= requestedTxsInflightSize) + $ ArbCollectTxs mempoolHasTxFun + (Set.fromList requestedTxIds') + (Map.fromList [ (getTxId tx, tx) | tx <- receivedTx ]) + peeraddr + ps + st + + shrink (ArbCollectTxs mempoolHasTx requestedTxs receivedTxs peeraddr ps st) = + [ ArbCollectTxs mempoolHasTx + requestedTxs' + (receivedTxs `Map.restrictKeys` requestedTxs') + peeraddr ps st + | requestedTxs' <- Set.fromList <$> shrinkList (\_ -> []) (Set.toList requestedTxs) + ] + ++ + [ ArbCollectTxs mempoolHasTx + requestedTxs + (receivedTxs `Map.restrictKeys` receivedTxIds) + peeraddr ps st + | receivedTxIds <- Set.fromList <$> shrinkList (\_ -> []) (Map.keys receivedTxs) + ] + ++ + [ ArbCollectTxs mempoolHasTx + (requestedTxs + `Set.intersection` unacked + `Set.intersection` inflightTxSet) + (receivedTxs + `Map.restrictKeys` unacked + `Map.restrictKeys` inflightTxSet) + peeraddr ps + st' + | let unacked = Set.fromList + . toList + . unacknowledgedTxIds + $ ps + , st'@SharedTxState { inflightTxs } <- shrinkSharedTxState (apply mempoolHasTx) st + , let inflightTxSet = Map.keysSet inflightTxs + , peeraddr `Map.member` peerTxStates st' + , st' /= st + ] + + +prop_collectTxs_generator + :: ArbCollectTxs + -> Property +prop_collectTxs_generator (ArbCollectTxs _ requestedTxIds receivedTxs peeraddr + ps@PeerTxState { availableTxIds, + requestedTxsInflightSize } + st) = + counterexample "size of requested txs must not be larger than requestedTxsInflightSize" + (requestedSize <= requestedTxsInflightSize) + .&&. counterexample "inflightTxsSize must be greater than requestedSize" + (inflightTxsSize st >= requestedSize) + .&&. counterexample ("receivedTxs must be a subset of requestedTxIds " + ++ show (Map.keysSet receivedTxs Set.\\ requestedTxIds)) + (Map.keysSet receivedTxs `Set.isSubsetOf` requestedTxIds) + .&&. counterexample "peerTxState" + (Map.lookup peeraddr (peerTxStates st) === Just ps) + where + requestedSize = fold (availableTxIds `Map.restrictKeys` requestedTxIds) + + +prop_collectTxs_shrinker + :: Fixed ArbCollectTxs + -- ^ disabled shrinking + -> Property +prop_collectTxs_shrinker (Fixed txs) = + property $ foldMap (\a@(ArbCollectTxs _ _ _ _ _ st) -> + All . counterexample (show st) $ + f a =/= f txs + .&&. sharedTxStateInvariant st + ) (shrink txs) + where + f (ArbCollectTxs _ reqSet recvMap peeraddr ps st) = (reqSet, recvMap, peeraddr, ps, st) + + +-- | Verify `collectTxsImpl` properties: +-- +-- * verify `SharedTxState` invariant; +-- * unacknowledged txids after `collectTxsImpl` must be a suffix of the +-- original ones; +-- * progress property: we acknowledge as many `txid`s as possible +-- +prop_collectTxsImpl + :: ArbCollectTxs + -> Property +prop_collectTxsImpl (ArbCollectTxs _mempoolHasTxFun txidsRequested txsReceived peeraddr ps st) = + + label ("number of txids inflight " ++ labelInt 25 5 (Map.size $ inflightTxs st)) $ + label ("number of txids requested " ++ labelInt 25 5 (Set.size txidsRequested)) $ + label ("number of txids received " ++ labelInt 10 2 (Map.size txsReceived)) $ + label ("hasTxSizeError " ++ show hasTxSizeErr) $ + + case TXS.collectTxsImpl getTxSize peeraddr txidsRequested txsReceived st of + Right st' | not hasTxSizeErr -> + let ps' = peerTxStates st' Map.! peeraddr in + -- InboundState invariant + counterexample + ( "InboundState invariant violation:\n" ++ show st' ++ "\n" + ++ show ps' + ) + (sharedTxStateInvariant st') + + .&&. + -- `collectTxsImpl` doesn't modify unacknowledged TxId's + counterexample "acknowledged property violation" + ( let unacked = toList $ unacknowledgedTxIds ps + unacked' = toList $ unacknowledgedTxIds ps' + in unacked === unacked' + ) + + Right _ -> + counterexample "collectTxsImpl should return Left" + . counterexample (show txsReceived) + $ False + Left _ | not hasTxSizeErr -> + counterexample "collectTxsImpl should return Right" False + + Left (TXS.ProtocolErrorTxSizeError as) -> + counterexample (show as) + $ Set.fromList ((\(txid, _, _) -> coerceTxId txid) `map` as) + === + Map.keysSet (Map.filter (\tx -> getTxSize tx /= getTxAdvSize tx) txsReceived) + Left e -> + counterexample ("unexpected error: " ++ show e) False + where + hasTxSizeErr = any (\tx -> getTxSize tx /= getTxAdvSize tx) txsReceived + + -- The `ProtocolErrorTxSizeError` type is an existential type. We know that + -- the type of `txid` is `TxId`, we just don't have evidence for it. + coerceTxId :: Typeable txid => txid -> TxId + coerceTxId txid = case cast txid of + Just a -> a + Nothing -> error "impossible happened! Is the test still using `TxId` for `txid`?" + + + +deriving via OnlyCheckWhnfNamed "StdGen" StdGen instance NoThunks StdGen + +-- | Verify that `SharedTxState` returned by `collectTxsImpl` if evaluated to +-- WHNF, it doesn't contain any thunks. +-- +prop_collectTxsImpl_nothunks + :: ArbCollectTxs + -> Property +prop_collectTxsImpl_nothunks (ArbCollectTxs _mempoolHasTxFun txidsRequested txsReceived peeraddr _ st) = + case TXS.collectTxsImpl getTxSize peeraddr txidsRequested txsReceived st of + Right st' -> case unsafeNoThunks $! st' of + Nothing -> property True + Just ctx -> counterexample (show ctx) False + Left _ -> property True + + +newtype ArbTxDecisionPolicy = ArbTxDecisionPolicy TxDecisionPolicy + deriving Show + +instance Arbitrary ArbTxDecisionPolicy where + arbitrary = + ArbTxDecisionPolicy . fixupTxDecisionPolicy + <$> ( TxDecisionPolicy + <$> (getSmall . getPositive <$> arbitrary) + <*> (getSmall . getPositive <$> arbitrary) + <*> (SizeInBytes . getPositive <$> arbitrary) + <*> (SizeInBytes . getPositive <$> arbitrary) + <*> (getSmall . getPositive <$> arbitrary)) + + shrink (ArbTxDecisionPolicy a@TxDecisionPolicy { + maxNumTxIdsToRequest, + txsSizeInflightPerPeer, + maxTxsSizeInflight, + txInflightMultiplicity }) = + [ ArbTxDecisionPolicy a { maxNumTxIdsToRequest = NumTxIdsToReq x } + | (Positive (Small x)) <- shrink (Positive (Small (getNumTxIdsToReq maxNumTxIdsToRequest))) + ] + ++ + [ ArbTxDecisionPolicy . fixupTxDecisionPolicy + $ a { txsSizeInflightPerPeer = SizeInBytes s } + | Positive s <- shrink (Positive (getSizeInBytes txsSizeInflightPerPeer)) + ] + ++ + [ ArbTxDecisionPolicy . fixupTxDecisionPolicy + $ a { maxTxsSizeInflight = SizeInBytes s } + | Positive s <- shrink (Positive (getSizeInBytes maxTxsSizeInflight)) + ] + ++ + [ ArbTxDecisionPolicy . fixupTxDecisionPolicy + $ a { txInflightMultiplicity = x } + | Positive (Small x) <- shrink (Positive (Small txInflightMultiplicity)) + ] + + +fixupTxDecisionPolicy :: TxDecisionPolicy -> TxDecisionPolicy +fixupTxDecisionPolicy a@TxDecisionPolicy { txsSizeInflightPerPeer, + maxTxsSizeInflight } + = a { txsSizeInflightPerPeer = txsSizeInflightPerPeer', + maxTxsSizeInflight = maxTxsSizeInflight' } + where + txsSizeInflightPerPeer' = min txsSizeInflightPerPeer maxTxsSizeInflight + maxTxsSizeInflight' = max txsSizeInflightPerPeer maxTxsSizeInflight + + +-- | Generate `TxDecisionPolicy` and a valid `PeerTxState` with respect to +-- that policy. +-- +data ArbPeerTxStateWithPolicy = + ArbPeerTxStateWithPolicy { + ptspState :: PeerTxState TxId (Tx TxId), + ptspPolicy :: TxDecisionPolicy + } + deriving Show + +-- | Fix-up `PeerTxState` according to `TxDecisionPolicy`. +-- +fixupPeerTxStateWithPolicy :: Ord txid + => TxDecisionPolicy + -> PeerTxState txid tx + -> PeerTxState txid tx +fixupPeerTxStateWithPolicy + TxDecisionPolicy { maxUnacknowledgedTxIds, + maxNumTxIdsToRequest } + ps@PeerTxState { unacknowledgedTxIds, + availableTxIds, + requestedTxsInflight, + requestedTxIdsInflight, + unknownTxs + } + = + ps { unacknowledgedTxIds = unacknowledgedTxIds', + availableTxIds = availableTxIds', + requestedTxsInflight = requestedTxsInflight', + requestedTxIdsInflight = requestedTxIdsInflight', + unknownTxs = unknownTxs' + } + where + -- limit the number of unacknowledged txids, and then fix-up all the other + -- sets. + unacknowledgedTxIds' = StrictSeq.take (fromIntegral maxUnacknowledgedTxIds) + unacknowledgedTxIds + unackedSet = Set.fromList (toList unacknowledgedTxIds') + availableTxIds' = availableTxIds `Map.restrictKeys` unackedSet + requestedTxsInflight' = requestedTxsInflight `Set.intersection` unackedSet + -- requestedTxIdsInflight must be smaller than `maxNumTxIdsToRequest, and + -- also `requestedTxIdsInflight` and the number of `unacknowledgedTxIds'` + -- must be smaller or equal to `maxUnacknowledgedTxIds`. + requestedTxIdsInflight' = requestedTxIdsInflight + `min` maxNumTxIdsToRequest + `min` (maxUnacknowledgedTxIds - fromIntegral (StrictSeq.length unacknowledgedTxIds')) + unknownTxs' = unknownTxs `Set.intersection` unackedSet + + +instance Arbitrary ArbPeerTxStateWithPolicy where + arbitrary = do + mempoolHasTx <- arbitrary + ArbTxDecisionPolicy policy + <- arbitrary + ArbPeerTxState { arbPeerTxState = ps } + <- genArbPeerTxState + mempoolHasTx + (fromIntegral (maxUnacknowledgedTxIds policy)) + return ArbPeerTxStateWithPolicy { ptspState = fixupPeerTxStateWithPolicy policy ps, + ptspPolicy = policy + } + + +prop_numTxIdsToRequest + :: ArbPeerTxStateWithPolicy + -> Property +prop_numTxIdsToRequest + ArbPeerTxStateWithPolicy { + ptspPolicy = policy@TxDecisionPolicy { maxNumTxIdsToRequest, + maxUnacknowledgedTxIds }, + ptspState = ps + } + = + case TXS.numTxIdsToRequest policy ps of + (numToReq, ps') -> + numToReq <= maxNumTxIdsToRequest + .&&. numToReq + requestedTxIdsInflight ps === requestedTxIdsInflight ps' + .&&. fromIntegral (StrictSeq.length (unacknowledgedTxIds ps')) + + requestedTxIdsInflight ps' + <= maxUnacknowledgedTxIds + + +data ArbDecisionContexts txid = ArbDecisionContexts { + arbDecisionPolicy :: TxDecisionPolicy, + + arbSharedContext :: SharedDecisionContext PeerAddr txid (Tx txid), + + arbMempoolHasTx :: Fun txid Bool + -- ^ needed just for shrinking + } + +instance Show txid => Show (ArbDecisionContexts txid) where + show ArbDecisionContexts { + arbDecisionPolicy, + arbSharedContext = SharedDecisionContext { + sdcPeerGSV = gsv, + sdcSharedTxState = st + }, + arbMempoolHasTx + } + = + intercalate "\n\t" + [ "ArbDecisionContext" + , show arbDecisionPolicy + , show gsv + , show st + , show arbMempoolHasTx + ] + + +-- | Fix-up `SharedTxState` so it satisfies `TxDecisionPolicy`. +-- +fixupSharedTxStateForPolicy + :: forall peeraddr txid tx. + Ord txid + => (txid -> Bool) -- ^ mempoolHasTx + -> TxDecisionPolicy + -> SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx +fixupSharedTxStateForPolicy + mempoolHasTx + policy@TxDecisionPolicy { + txsSizeInflightPerPeer, + maxTxsSizeInflight, + txInflightMultiplicity + } + st@SharedTxState { peerTxStates } + = + fixupSharedTxState + mempoolHasTx + st { peerTxStates = snd . mapAccumR fn (0, Map.empty) $ peerTxStates } + where + -- fixup `PeerTxState` and accumulate size of all `tx`'s in-flight across + -- all peers. + fn :: (SizeInBytes, Map txid Int) + -> PeerTxState txid tx + -> ((SizeInBytes, Map txid Int), PeerTxState txid tx) + fn + (sizeInflightAll, inflightMap) + ps + = + ( ( sizeInflightAll + requestedTxsInflightSize' + , inflightMap' + ) + , ps' { requestedTxsInflight = requestedTxsInflight', + requestedTxsInflightSize = requestedTxsInflightSize' + } + ) + where + ps' = fixupPeerTxStateWithPolicy policy ps + + (requestedTxsInflightSize', requestedTxsInflight', inflightMap') = + Map.foldrWithKey + (\txid txSize r@(!inflightSize, !inflightSet, !inflight) -> + let (multiplicity, inflight') = + Map.alterF + (\case + Nothing -> (1, Just 1) + Just x -> let x' = x + 1 in (x', Just $! x')) + txid inflight + in if inflightSize <= txsSizeInflightPerPeer + && sizeInflightAll + inflightSize <= maxTxsSizeInflight + && multiplicity <= txInflightMultiplicity + then (txSize + inflightSize, Set.insert txid inflightSet, inflight') + else r + ) + (0, Set.empty, inflightMap) + (availableTxIds ps' `Map.restrictKeys` requestedTxsInflight ps') + +instance (Arbitrary txid, Ord txid, Function txid, CoArbitrary txid) + => Arbitrary (ArbDecisionContexts txid) where + + arbitrary = do + ArbTxDecisionPolicy policy <- arbitrary + (mempoolHasTx, _ps, st, _) <- + genSharedTxState (fromIntegral $ maxNumTxIdsToRequest policy) + let pss = Map.toList (peerTxStates st) + peers = fst `map` pss + -- each peer must have a GSV + gsvs <- zip peers + <$> infiniteListOf (unPeerGSVT <$> arbitrary) + let st' = fixupSharedTxStateForPolicy + (apply mempoolHasTx) policy st + + return $ ArbDecisionContexts { + arbDecisionPolicy = policy, + arbMempoolHasTx = mempoolHasTx, + arbSharedContext = SharedDecisionContext { + sdcPeerGSV = Map.fromList gsvs, + sdcSharedTxState = st' + } + } + + shrink a@ArbDecisionContexts { + arbDecisionPolicy = policy, + arbMempoolHasTx = mempoolHasTx, + arbSharedContext = b@SharedDecisionContext { + sdcPeerGSV = gsvs, + sdcSharedTxState = sharedState + } + } = + -- shrink shared state + [ a { arbSharedContext = b { sdcSharedTxState = sharedState'' } } + | sharedState' <- shrinkSharedTxState (apply mempoolHasTx) sharedState + , let sharedState'' = fixupSharedTxStateForPolicy + (apply mempoolHasTx) policy sharedState' + , sharedState'' /= sharedState + ] + ++ + -- shrink peers; note all peers are present in `sdcPeerGSV`. + [ a { arbSharedContext = SharedDecisionContext { + sdcPeerGSV = gsvs', + sdcSharedTxState = sharedState' + } } + | -- shrink the set of peers + peers' <- Set.fromList <$> shrinkList (const []) (Map.keys gsvs) + , let gsvs' = gsvs `Map.restrictKeys` peers' + sharedState' = + fixupSharedTxStateForPolicy + (apply mempoolHasTx) policy + $ sharedState { peerTxStates = peerTxStates sharedState + `Map.restrictKeys` + peers' + } + , sharedState' /= sharedState + ] + + +prop_ArbDecisionContexts_generator + :: ArbDecisionContexts TxId + -> Property +prop_ArbDecisionContexts_generator + ArbDecisionContexts { arbSharedContext = SharedDecisionContext { sdcSharedTxState = st } } + = + -- whenFail (pPrint a) $ + sharedTxStateInvariant st + + +prop_ArbDecisionContexts_shrinker + :: ArbDecisionContexts TxId + -> All +prop_ArbDecisionContexts_shrinker + ctx + = + foldMap (\a -> + All + . counterexample (show a) + . sharedTxStateInvariant + . sdcSharedTxState + . arbSharedContext + $ a) + $ shrink ctx + + +-- | Verify that `makeDecisions` preserves the `SharedTxState` invariant. +-- +prop_makeDecisions_sharedstate + :: ArbDecisionContexts TxId + -> Property +prop_makeDecisions_sharedstate + ArbDecisionContexts { arbDecisionPolicy = policy, + arbSharedContext = sharedCtx } = + let (sharedState, decisions) = TXS.makeDecisions policy sharedCtx (peerTxStates (sdcSharedTxState sharedCtx)) + in counterexample (show sharedState) + $ counterexample (show decisions) + $ sharedTxStateInvariant sharedState + + +-- | Verify that `makeDecisions`: +-- +-- * modifies `inflightTxs` map by adding `tx`s which are inflight; +-- * updates `requestedTxsInflightSize` correctly; +-- * in-flight `tx`s set is disjoint with `bufferedTxs`; +-- * requested `tx`s are coming from `availableTxIds`. +-- +prop_makeDecisions_inflight + :: ArbDecisionContexts TxId + -> Property +prop_makeDecisions_inflight + ArbDecisionContexts { + arbDecisionPolicy = policy, + arbSharedContext = sharedCtx@SharedDecisionContext { + sdcSharedTxState = sharedState + } + } + = + let (sharedState', decisions) = TXS.makeDecisions policy sharedCtx (peerTxStates sharedState) + + inflightSet :: Set TxId + inflightSet = foldMap txdTxsToRequest decisions + + inflightSize :: Map PeerAddr SizeInBytes + inflightSize = Map.foldrWithKey + (\peer TxDecision { txdTxsToRequest } m -> + Map.insert peer + (foldMap (\txid -> fromMaybe 0 $ Map.lookup peer (peerTxStates sharedState) + >>= Map.lookup txid . availableTxIds) + txdTxsToRequest) + m + ) Map.empty decisions + + bufferedSet :: Set TxId + bufferedSet = Map.keysSet (bufferedTxs sharedState) + in + counterexample (show sharedState') $ + counterexample (show decisions) $ + + -- 'inflightTxs' set is increased by exactly the requested txs + counterexample (concat + [ show inflightSet + , " not a subset of " + , show (inflightTxs sharedState') + ]) + ( inflightSet <> Map.keysSet (inflightTxs sharedState') + === + Map.keysSet (inflightTxs sharedState') + ) + + .&&. + + -- for each peer size in flight is equal to the original size in flight + -- plus size of all requested txs + property + (fold + (Map.merge + (Map.mapMaybeMissing + (\peer a -> + Just ( All + . counterexample + ("missing peer in requestedTxsInflightSize: " ++ show peer) + $ (a === 0)))) + (Map.mapMaybeMissing (\_ _ -> Nothing)) + (Map.zipWithMaybeMatched + (\peer delta PeerTxState { requestedTxsInflightSize } -> + let original = + case Map.lookup peer (peerTxStates sharedState) of + Nothing -> 0 + Just PeerTxState { requestedTxsInflightSize = a } -> a + in Just ( All + . counterexample (show peer) + $ original + delta + === + requestedTxsInflightSize + ) + )) + inflightSize + (peerTxStates sharedState'))) + + .&&. counterexample ("requested txs must not be buffered: " + ++ show (inflightSet `Set.intersection` bufferedSet)) + (inflightSet `Set.disjoint` bufferedSet) + + .&&. counterexample "requested txs must be available" + ( fold $ + Map.merge + (Map.mapMissing (\peeraddr _ -> + All $ + counterexample ("peer missing in peerTxStates " ++ show peeraddr) + False)) + (Map.mapMissing (\_ _ -> All True)) + (Map.zipWithMatched (\peeraddr a b -> All + . counterexample (show peeraddr) + $ a `Set.isSubsetOf` b)) + -- map of requested txs + (Map.fromList [ (peeraddr, txids) + | (peeraddr, TxDecision { txdTxsToRequest = txids }) + <- Map.assocs decisions + ]) + -- map of available txs + (Map.map (Map.keysSet . availableTxIds) + (peerTxStates sharedState))) + + +-- | Verify that `makeTxDecisions` obeys `TxDecisionPolicy`. +-- +prop_makeDecisions_policy + :: ArbDecisionContexts TxId + -> Property +prop_makeDecisions_policy + ArbDecisionContexts { + arbDecisionPolicy = policy@TxDecisionPolicy { maxTxsSizeInflight, + txsSizeInflightPerPeer, + txInflightMultiplicity }, + arbSharedContext = sharedCtx@SharedDecisionContext { sdcSharedTxState = sharedState } + } = + let (sharedState', _decisions) = TXS.makeDecisions policy sharedCtx (peerTxStates sharedState) + maxTxsSizeInflightEff = maxTxsSizeInflight + maxTxSize + txsSizeInflightPerPeerEff = txsSizeInflightPerPeer + maxTxSize + + sizeInflight = + foldMap (\PeerTxState { availableTxIds, requestedTxsInflight } -> + fold (availableTxIds `Map.restrictKeys` requestedTxsInflight)) + (peerTxStates sharedState') + + in counterexample (show sharedState') $ + + -- size of txs inflight cannot exceed `maxTxsSizeInflight` by more + -- than maximal tx size. + counterexample ("txs inflight exceed limit " ++ show (sizeInflight, maxTxsSizeInflightEff)) + (sizeInflight <= maxTxsSizeInflightEff) + .&&. + -- size in flight for each peer cannot exceed `txsSizeInflightPerPeer` + counterexample "size in flight per peer vaiolation" ( + foldMap + (\PeerTxState { availableTxIds, requestedTxsInflight } -> + let inflight = fold (availableTxIds `Map.restrictKeys` requestedTxsInflight) + in All $ counterexample (show (inflight, txsSizeInflightPerPeerEff)) $ + inflight + <= + txsSizeInflightPerPeerEff + ) + (peerTxStates sharedState') + ) + + .&&. + ( + -- none of the multiplicities should go above the + -- `txInflightMultiplicity` + let inflight = inflightTxs sharedState' + in + counterexample ("multiplicities violation: " ++ show inflight) + . foldMap (All . (<= txInflightMultiplicity)) + $ inflight + ) + + +-- | Verify that `makeDecisions` and `acknowledgeTxIds` are compatible. +-- +prop_makeDecisions_acknowledged + :: ArbDecisionContexts TxId + -> Property +prop_makeDecisions_acknowledged + ArbDecisionContexts { arbDecisionPolicy = policy, + arbSharedContext = + sharedCtx@SharedDecisionContext { + sdcSharedTxState = sharedTxState + } + } = + whenFail (pPrintOpt CheckColorTty defaultOutputOptionsDarkBg { outputOptionsCompact = True } sharedTxState) $ + let (_, decisions) = TXS.makeDecisions policy sharedCtx (peerTxStates sharedTxState) + + ackFromDecisions :: Map PeerAddr NumTxIdsToAck + ackFromDecisions = Map.fromList + [ (peer, txdTxIdsToAcknowledge) + | (peer, TxDecision { txdTxIdsToAcknowledge }) + <- Map.assocs decisions + ] + + ackFromState :: Map PeerAddr NumTxIdsToAck + ackFromState = + Map.map (\ps -> case TXS.acknowledgeTxIds policy sharedTxState ps of + (a, _, _, _, _) -> a) + . peerTxStates + $ sharedTxState + + in counterexample (show (ackFromDecisions, ackFromState)) + . fold + $ Map.merge + -- it is an error if `ackFromDecisions` contains a result which is + -- missing in `ackFromState` + (Map.mapMissing (\addr num -> All $ counterexample ("missing " ++ show (addr, num)) False)) + -- if `ackFromState` contains an enty which is missing in + -- `ackFromDecisions` it must be `0`; `makeDecisions` might want to + -- download some `tx`s even if there's nothing to acknowledge + (Map.mapMissing (\_ d -> All (d === 0))) + -- if both entries exists they must be equal + (Map.zipWithMatched (\_ a b -> All (a === b))) + ackFromDecisions + ackFromState + + +-- | `makeDecision` is exhaustive in the sense that it returns an empty +-- decision list on a state returned by a prior call of `makeDecision`. +-- +prop_makeDecisions_exhaustive + :: ArbDecisionContexts TxId + -> Property +prop_makeDecisions_exhaustive + ArbDecisionContexts { + arbDecisionPolicy = policy, + arbSharedContext = + sharedCtx@SharedDecisionContext { + sdcSharedTxState = sharedTxState + } + } + = + let (sharedTxState', decisions') + = TXS.makeDecisions policy + sharedCtx + (peerTxStates sharedTxState) + (sharedTxState'', decisions'') + = TXS.makeDecisions policy + sharedCtx { sdcSharedTxState = sharedTxState' } + (peerTxStates sharedTxState') + in counterexample ("decisions': " ++ show decisions') + . counterexample ("state': " ++ show sharedTxState') + . counterexample ("decisions'': " ++ show decisions'') + . counterexample ("state'': " ++ show sharedTxState'') + $ null decisions'' + + +data ArbDecisionContextWithReceivedTxIds = ArbDecisionContextWithReceivedTxIds { + adcrDecisionPolicy :: TxDecisionPolicy, + adcrSharedContext :: SharedDecisionContext PeerAddr TxId (Tx TxId), + adcrPeerTxState :: PeerTxState TxId (Tx TxId), + adcrMempoolHasTx :: Fun TxId Bool, + adcrTxsToAck :: [Tx TxId], + -- txids to acknowledge + adcrPeerAddr :: PeerAddr + -- the peer which owns the acknowledged txids + } + deriving Show + + +instance Arbitrary ArbDecisionContextWithReceivedTxIds where + arbitrary = do + ArbTxDecisionPolicy policy <- arbitrary + ArbReceivedTxIds mempoolHasTx + txIdsToAck + peeraddr + ps + st + <- arbitrary + + let st' = fixupSharedTxStateForPolicy + (apply mempoolHasTx) + policy st + ps' = fixupPeerTxStateWithPolicy policy ps + txIdsToAck' = take (fromIntegral (TXS.requestedTxIdsInflight $ peerTxStates st' Map.! peeraddr)) txIdsToAck + peers = Map.keys (peerTxStates st') + + gsvs <- zip peers + <$> infiniteListOf (unPeerGSVT <$> arbitrary) + + return ArbDecisionContextWithReceivedTxIds { + adcrDecisionPolicy = policy, + adcrSharedContext = SharedDecisionContext { + sdcPeerGSV = Map.fromList gsvs, + sdcSharedTxState = st' + }, + adcrPeerTxState = ps', + adcrMempoolHasTx = mempoolHasTx, + adcrTxsToAck = txIdsToAck', + adcrPeerAddr = peeraddr + } + + shrink ArbDecisionContextWithReceivedTxIds { + adcrDecisionPolicy = policy, + adcrSharedContext = ctx, + adcrPeerTxState = ps, + adcrMempoolHasTx = mempoolHasTx, + adcrTxsToAck = txIdsToAck, + adcrPeerAddr = peeraddr + } + = + [ ArbDecisionContextWithReceivedTxIds { + adcrDecisionPolicy = policy', + adcrSharedContext = ctx', + adcrPeerTxState = ps, + adcrMempoolHasTx = mempoolHasTx', + adcrTxsToAck = txIdsToAck', + adcrPeerAddr = peeraddr + } + | ArbDecisionContexts { + arbDecisionPolicy = policy', + arbSharedContext = ctx'@SharedDecisionContext { sdcSharedTxState = st' }, + arbMempoolHasTx = mempoolHasTx' + } + <- shrink ArbDecisionContexts { + arbDecisionPolicy = policy, + arbSharedContext = ctx, + arbMempoolHasTx = mempoolHasTx + } + , peeraddr `Map.member` peerTxStates st' + , let txIdsToAck' = take ( fromIntegral + . TXS.requestedTxIdsInflight + $ peerTxStates st' Map.! peeraddr + ) + txIdsToAck + ] + + +-- | `filterActivePeers` should not change decisions made by `makeDecisions` +-- +prop_filterActivePeers_not_limitting_decisions + :: ArbDecisionContexts TxId + -> Property +prop_filterActivePeers_not_limitting_decisions + ArbDecisionContexts { + arbDecisionPolicy = policy, + arbSharedContext = + sharedCtx@SharedDecisionContext { sdcSharedTxState = st } + } + = + counterexample (unlines + ["decisions: " ++ show decisions + ," " ++ show decisionPeers + ,"active decisions: " ++ show decisionsOfActivePeers + ," " ++ show activePeers]) $ + + counterexample ("active peers does not restrict the total number of valid decisions available" + ++ show (decisionsOfActivePeers Map.\\ decisions) + ) + (Map.keysSet decisionsOfActivePeers `Set.isSubsetOf` Map.keysSet decisions) + where + activePeersMap = TXS.filterActivePeers policy st + activePeers = Map.keysSet activePeersMap + (_, decisionsOfActivePeers) + = TXS.makeDecisions policy sharedCtx activePeersMap + + (_, decisions) = TXS.makeDecisions policy sharedCtx (peerTxStates st) + decisionPeers = Map.keysSet decisions + + +-- TODO: makeDecisions property: all peers which have txid's to ack are +-- included, this would catch the other bug, and it's important for the system +-- to run well. + +-- +-- Auxiliary functions +-- + +labelInt :: (Integral a, Eq a, Ord a, Show a) + => a -- ^ upper bound + -> a -- ^ width + -> a -- ^ value + -> String +labelInt _ _ 0 = "[0, 0]" +labelInt bound _ b | b >= bound = "[" ++ show bound ++ ", inf)" +labelInt _ a b = + let l = a * (b `div` a) + u = l + a + in (if l == 0 then "(" else "[") + ++ show l ++ ", " + ++ show u ++ ")" diff --git a/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/Types.hs b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/Types.hs new file mode 100644 index 00000000000..6c09b2c10b5 --- /dev/null +++ b/ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/Types.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Ouroboros.Network.TxSubmission.Types where + +import Prelude hiding (seq) + +import NoThunks.Class + +import Control.Concurrent.Class.MonadSTM +import Control.Exception (SomeException (..)) +import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadSay +import Control.Monad.Class.MonadST +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI +import Control.Monad.IOSim hiding (SimResult) +import Control.Tracer (Tracer (..), showTracing, traceWith) + +import Codec.CBOR.Decoding qualified as CBOR +import Codec.CBOR.Encoding qualified as CBOR +import Codec.CBOR.Read qualified as CBOR + +import Data.ByteString.Lazy (ByteString) +import Data.Foldable as Foldable (find, foldl', toList) +import Data.Function (on) +import Data.List (nubBy) +import Data.Maybe (isJust) +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Data.Set qualified as Set +import GHC.Generics (Generic) + +import Network.TypedProtocol.Codec + +import Ouroboros.Network.Protocol.TxSubmission2.Codec +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Inbound +import Ouroboros.Network.TxSubmission.Mempool.Reader +import Ouroboros.Network.Util.ShowProxy + +import Test.QuickCheck +import Text.Printf + + +data Tx txid = Tx { + getTxId :: !txid, + getTxSize :: !SizeInBytes, + getTxAdvSize :: !SizeInBytes, + -- | If false this means that when this tx will be submitted to a remote + -- mempool it will not be valid. The outbound mempool might contain + -- invalid tx's in this sense. + getTxValid :: !Bool + } + deriving (Eq, Ord, Show, Generic) + +instance NoThunks txid => NoThunks (Tx txid) +instance ShowProxy txid => ShowProxy (Tx txid) where + showProxy _ = "Tx " ++ showProxy (Proxy :: Proxy txid) + +instance Arbitrary txid => Arbitrary (Tx txid) where + arbitrary = do + -- note: + -- generating small tx sizes avoids overflow error when semigroup + -- instance of `SizeInBytes` is used (summing up all inflight tx + -- sizes). + (size, advSize) <- frequency [ (9, (\a -> (a,a)) <$> chooseEnum (0, maxTxSize)) + , (1, (,) <$> chooseEnum (0, maxTxSize) <*> chooseEnum (0, maxTxSize)) + ] + Tx <$> arbitrary + <*> pure size + <*> pure advSize + <*> frequency [ (3, pure True) + , (1, pure False) + ] + +-- maximal tx size +maxTxSize :: SizeInBytes +maxTxSize = 65536 + +type TxId = Int + +newtype Mempool m txid = Mempool (TVar m (Seq (Tx txid))) + + +emptyMempool :: MonadSTM m => m (Mempool m txid) +emptyMempool = Mempool <$> newTVarIO Seq.empty + +newMempool :: ( MonadSTM m + , Eq txid + ) + => [Tx txid] + -> m (Mempool m txid) +newMempool = fmap Mempool + . newTVarIO + . Seq.fromList + +readMempool :: MonadSTM m => Mempool m txid -> m [Tx txid] +readMempool (Mempool mempool) = toList <$> readTVarIO mempool + + +getMempoolReader :: forall txid m. + ( MonadSTM m + , Eq txid + , Show txid + ) + => Mempool m txid + -> TxSubmissionMempoolReader txid (Tx txid) Int m +getMempoolReader (Mempool mempool) = + TxSubmissionMempoolReader { mempoolGetSnapshot, mempoolZeroIdx = 0 } + where + mempoolGetSnapshot :: STM m (MempoolSnapshot txid (Tx txid) Int) + mempoolGetSnapshot = getSnapshot <$> readTVar mempool + + getSnapshot :: Seq (Tx txid) + -> MempoolSnapshot txid (Tx txid) Int + getSnapshot seq = + MempoolSnapshot { + mempoolTxIdsAfter = + \idx -> zipWith f [idx + 1 ..] (toList $ Seq.drop idx seq), + -- why do I need to use `pred`? + mempoolLookupTx = flip Seq.lookup seq . pred, + mempoolHasTx = \txid -> isJust $ find (\tx -> getTxId tx == txid) seq + } + + f :: Int -> Tx txid -> (txid, Int, SizeInBytes) + f idx Tx {getTxId, getTxSize} = (getTxId, idx, getTxSize) + + +getMempoolWriter :: forall txid m. + ( MonadSTM m + , Ord txid + , Eq txid + ) + => Mempool m txid + -> TxSubmissionMempoolWriter txid (Tx txid) Int m +getMempoolWriter (Mempool mempool) = + TxSubmissionMempoolWriter { + txId = getTxId, + + mempoolAddTxs = \txs -> do + atomically $ do + mempoolTxs <- readTVar mempool + let currentIds = Set.fromList (map getTxId (toList mempoolTxs)) + validTxs = nubBy (on (==) getTxId) + $ filter + (\Tx { getTxId, getTxValid } -> + getTxValid + && getTxId `Set.notMember` currentIds) + txs + mempoolTxs' = Foldable.foldl' (Seq.|>) mempoolTxs validTxs + writeTVar mempool mempoolTxs' + return (map getTxId validTxs) + } + + +txSubmissionCodec2 :: MonadST m + => Codec (TxSubmission2 Int (Tx Int)) + CBOR.DeserialiseFailure m ByteString +txSubmissionCodec2 = + codecTxSubmission2 CBOR.encodeInt CBOR.decodeInt + encodeTx decodeTx + where + encodeTx Tx {getTxId, getTxSize, getTxAdvSize, getTxValid} = + CBOR.encodeListLen 4 + <> CBOR.encodeInt getTxId + <> CBOR.encodeWord32 (getSizeInBytes getTxSize) + <> CBOR.encodeWord32 (getSizeInBytes getTxAdvSize) + <> CBOR.encodeBool getTxValid + + decodeTx = do + _ <- CBOR.decodeListLen + Tx <$> CBOR.decodeInt + <*> (SizeInBytes <$> CBOR.decodeWord32) + <*> (SizeInBytes <$> CBOR.decodeWord32) + <*> CBOR.decodeBool + + +newtype LargeNonEmptyList a = LargeNonEmpty { getLargeNonEmpty :: [a] } + deriving Show + +instance Arbitrary a => Arbitrary (LargeNonEmptyList a) where + arbitrary = + LargeNonEmpty <$> suchThat (resize 500 (listOf arbitrary)) ((>25) . length) + + +-- TODO: Belongs in iosim. +data SimResults a = SimReturn a [String] + | SimException SomeException [String] + | SimDeadLock [String] + +-- Traverses a list of trace events and returns the result along with all log messages. +-- Incase of a pure exception, ie an assert, all tracers evaluated so far are returned. +evaluateTrace :: SimTrace a -> IO (SimResults a) +evaluateTrace = go [] + where + go as tr = do + r <- try (evaluate tr) + case r of + Right (SimTrace _ _ _ (EventSay s) tr') -> go (s : as) tr' + Right (SimTrace _ _ _ _ tr' ) -> go as tr' + Right (SimPORTrace _ _ _ _ (EventSay s) tr') -> go (s : as) tr' + Right (SimPORTrace _ _ _ _ _ tr' ) -> go as tr' + Right (TraceMainReturn _ _ a _) -> pure $ SimReturn a (reverse as) + Right (TraceMainException _ _ e _) -> pure $ SimException e (reverse as) + Right (TraceDeadlock _ _) -> pure $ SimDeadLock (reverse as) + Right TraceLoop -> error "IOSimPOR step time limit exceeded" + Right (TraceInternalError e) -> error ("IOSim: " ++ e) + Left (SomeException e) -> pure $ SimException (SomeException e) (reverse as) + + +data WithThreadAndTime a = WithThreadAndTime { + wtatOccuredAt :: !Time + , wtatWithinThread :: !String + , wtatEvent :: !a + } + +instance (Show a) => Show (WithThreadAndTime a) where + show WithThreadAndTime {wtatOccuredAt, wtatWithinThread, wtatEvent} = + printf "%s: %s: %s" (show wtatOccuredAt) (show wtatWithinThread) (show wtatEvent) + +verboseTracer :: forall a m. + ( MonadAsync m + , MonadDelay m + , MonadSay m + , MonadMonotonicTime m + , Show a + ) + => Tracer m a +verboseTracer = threadAndTimeTracer $ showTracing $ Tracer say + +debugTracer :: forall a s. Show a => Tracer (IOSim s) a +debugTracer = threadAndTimeTracer $ showTracing $ Tracer (traceM . show) + +threadAndTimeTracer :: forall a m. + ( MonadAsync m + , MonadDelay m + , MonadMonotonicTime m + ) + => Tracer m (WithThreadAndTime a) -> Tracer m a +threadAndTimeTracer tr = Tracer $ \s -> do + !now <- getMonotonicTime + !tid <- myThreadId + traceWith tr $ WithThreadAndTime now (show tid) s diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs index e3df3fe2809..de035e22500 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Configuration.hs @@ -16,6 +16,7 @@ module Ouroboros.Network.Diffusion.Configuration , defaultSyncTargets , defaultDeadlineChurnInterval , defaultBulkChurnInterval + , defaultEnableNewTxSubmissionProtocol -- re-exports , AcceptedConnectionsLimit (..) , BlockFetchConfiguration (..) @@ -66,6 +67,8 @@ import Ouroboros.Network.Protocol.ChainSync.Codec (ChainSyncTimeout (..)) import Ouroboros.Network.Protocol.Handshake (handshake_QUERY_SHUTDOWN_DELAY) import Ouroboros.Network.Protocol.Limits (shortWait) import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) +import Ouroboros.Network.TxSubmission.Inbound.Server + (EnableNewTxSubmissionProtocol (..)) -- | Default number of bootstrap peers @@ -183,3 +186,6 @@ defaultDeadlineChurnInterval = 3300 defaultBulkChurnInterval :: DiffTime defaultBulkChurnInterval = 900 + +defaultEnableNewTxSubmissionProtocol :: EnableNewTxSubmissionProtocol +defaultEnableNewTxSubmissionProtocol = DisableNewTxSubmissionProtocol diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs index 4accbf9e2b6..43adc560ce7 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs @@ -587,6 +587,7 @@ runM , Typeable ntcAddr , Ord ntcAddr , Show ntcAddr + , Hashable ntcAddr , Ord ntcVersion , Exception resolverError ) diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index 69e0a7a34ff..e1a150bf093 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -4,6 +4,7 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -139,6 +140,7 @@ import Ouroboros.Network.Protocol.Handshake.Codec import Ouroboros.Network.Protocol.Handshake.Type import Ouroboros.Network.Protocol.Handshake.Version hiding (Accept) import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck (..)) +import Ouroboros.Network.SizeInBytes (SizeInBytes) import Ouroboros.Network.Snocket import Ouroboros.Network.Socket import Ouroboros.Network.Subscription.Dns (DnsSubscriptionParams, @@ -152,6 +154,8 @@ import Ouroboros.Network.Subscription.Worker (LocalAddresses (..), SubscriberError) import Ouroboros.Network.Tracers import Ouroboros.Network.TxSubmission.Inbound qualified as TxInbound +import Ouroboros.Network.TxSubmission.Inbound.Policy (TxDecisionPolicy (..), + defaultTxDecisionPolicy, max_TX_SIZE) import Ouroboros.Network.TxSubmission.Outbound qualified as TxOutbound import Ouroboros.Network.Util.ShowProxy (ShowProxy, showProxy) @@ -209,9 +213,8 @@ data MiniProtocolParameters = MiniProtocolParameters { blockFetchPipeliningMax :: !Word16, -- ^ maximal number of pipelined messages in 'block-fetch' mini-protocol. - txSubmissionMaxUnacked :: !NumTxIdsToAck - -- ^ maximal number of unacked tx (pipelining is bounded by twice this - -- number) + txDecisionPolicy :: !TxDecisionPolicy + -- ^ tx submission protocol decision logic parameters } defaultMiniProtocolParameters :: MiniProtocolParameters @@ -219,7 +222,7 @@ defaultMiniProtocolParameters = MiniProtocolParameters { chainSyncPipeliningLowMark = 200 , chainSyncPipeliningHighMark = 300 , blockFetchPipeliningMax = 100 - , txSubmissionMaxUnacked = 10 + , txDecisionPolicy = defaultTxDecisionPolicy } -- | Make an 'OuroborosApplication' for the bundle of mini-protocols that @@ -341,7 +344,9 @@ blockFetchProtocolLimits MiniProtocolParameters { blockFetchPipeliningMax } = Mi max (10 * 2_097_154 :: Int) (fromIntegral blockFetchPipeliningMax * 90_112) } -txSubmissionProtocolLimits MiniProtocolParameters { txSubmissionMaxUnacked } = MiniProtocolLimits { +txSubmissionProtocolLimits MiniProtocolParameters + { txDecisionPolicy = TxDecisionPolicy { maxUnacknowledgedTxIds } + } = MiniProtocolLimits { -- tx-submission server can pipeline both 'MsgRequestTxIds' and -- 'MsgRequestTx'. This means that there can be many -- 'MsgReplyTxIds', 'MsgReplyTxs' messages in an inbound queue (their @@ -399,12 +404,12 @@ txSubmissionProtocolLimits MiniProtocolParameters { txSubmissionMaxUnacked } = M -- queue of 'txSubmissionOutbound' is bounded by the ingress side of -- the 'txSubmissionInbound' -- - -- Currently the value of 'txSubmissionMaxUnacked' is '100', for - -- which the upper bound is `100 * (44 + 65_540) = 6_558_400`, we add + -- Currently the value of 'txSubmissionMaxUnacked' is '10', for + -- which the upper bound is `10 * (44 + 65_540) = 655_840`, we add -- 10% as a safety margin. -- maximumIngressQueue = addSafetyMargin $ - fromIntegral txSubmissionMaxUnacked * (44 + 65_540) + fromIntegral maxUnacknowledgedTxIds * (44 + fromIntegral @SizeInBytes @Int max_TX_SIZE) } keepAliveProtocolLimits _ = diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs index 8970edb2ea5..33a84921048 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound.hs @@ -36,6 +36,7 @@ import Control.Exception (assert) import Control.Monad (unless) import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer, traceWith) @@ -45,63 +46,12 @@ import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion) import Ouroboros.Network.Protocol.Limits import Ouroboros.Network.Protocol.TxSubmission2.Server import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Inbound.Types (ProcessedTxCount (..), + TraceTxSubmissionInbound (..), TxSubmissionMempoolWriter (..), + TxSubmissionProtocolError (..)) import Ouroboros.Network.TxSubmission.Mempool.Reader (MempoolSnapshot (..), TxSubmissionMempoolReader (..)) --- | The consensus layer functionality that the inbound side of the tx --- submission logic requires. --- --- This is provided to the tx submission logic by the consensus layer. --- -data TxSubmissionMempoolWriter txid tx idx m = - TxSubmissionMempoolWriter { - - -- | Compute the transaction id from a transaction. - -- - -- This is used in the protocol handler to verify a full transaction - -- matches a previously given transaction id. - -- - txId :: tx -> txid, - - -- | Supply a batch of transactions to the mempool. They are either - -- accepted or rejected individually, but in the order supplied. - -- - -- The 'txid's of all transactions that were added successfully are - -- returned. - mempoolAddTxs :: [tx] -> m [txid] - } - -data ProcessedTxCount = ProcessedTxCount { - -- | Just accepted this many transactions. - ptxcAccepted :: Int - -- | Just rejected this many transactions. - , ptxcRejected :: Int - } - deriving (Eq, Show) - -data TraceTxSubmissionInbound txid tx = - -- | Number of transactions just about to be inserted. - TraceTxSubmissionCollected Int - -- | Just processed transaction pass/fail breakdown. - | TraceTxSubmissionProcessed ProcessedTxCount - -- | Server received 'MsgDone' - | TraceTxInboundTerminated - | TraceTxInboundCanRequestMoreTxs Int - | TraceTxInboundCannotRequestMoreTxs Int - deriving (Eq, Show) - -data TxSubmissionProtocolError = - ProtocolErrorTxNotRequested - | ProtocolErrorTxIdsNotRequested - deriving Show - -instance Exception TxSubmissionProtocolError where - displayException ProtocolErrorTxNotRequested = - "The peer replied with a transaction we did not ask for." - displayException ProtocolErrorTxIdsNotRequested = - "The peer replied with more txids than we asked for." - - -- | Information maintained internally in the 'txSubmissionInbound' server -- implementation. -- @@ -262,7 +212,7 @@ txSubmissionInbound tracer (NumTxIdsToAck maxUnacked) mpReader mpWriter _version -- traceWith tracer (TraceTxInboundCanRequestMoreTxs (natToInt n)) pure $ CollectPipelined - (Just (continueWithState (serverReqTxs (Succ n')) st)) + (Just (pure $ continueWithState (serverReqTxs (Succ n')) st)) (collectAndContinueWithState (handleReply n') st) else do @@ -365,13 +315,18 @@ txSubmissionInbound tracer (NumTxIdsToAck maxUnacked) mpReader mpWriter _version traceWith tracer $ TraceTxSubmissionCollected collected + !start <- getMonotonicTime txidsAccepted <- mempoolAddTxs txsReady - + !end <- getMonotonicTime + let duration = diffTime end start + traceWith tracer $ + TraceTxInboundAddedToMempool txidsAccepted duration let !accepted = length txidsAccepted traceWith tracer $ TraceTxSubmissionProcessed ProcessedTxCount { ptxcAccepted = accepted , ptxcRejected = collected - accepted + , ptxcScore = 0 -- This implementatin does not track score } continueWithStateM (serverIdle n) st { diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs new file mode 100644 index 00000000000..c5759590db9 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Decision.hs @@ -0,0 +1,503 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +module Ouroboros.Network.TxSubmission.Inbound.Decision + ( TxDecision (..) + , emptyTxDecision + -- * Internal API exposed for testing + , makeDecisions + , filterActivePeers + , SharedDecisionContext (..) + , pickTxsToDownload + ) where + +import Control.Arrow ((>>>)) +import Control.Exception (assert) + +import Data.Bifunctor (second) +import Data.Hashable +import Data.List (mapAccumR, sortOn) +import Data.Map.Merge.Strict qualified as Map +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe) +import Data.Set (Set) +import Data.Set qualified as Set +import System.Random (random) + +import Data.Sequence.Strict qualified as StrictSeq +import Ouroboros.Network.DeltaQ (PeerGSV (..), defaultGSV, + gsvRequestResponseDuration) +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Inbound.Policy +import Ouroboros.Network.TxSubmission.Inbound.State +import Ouroboros.Network.TxSubmission.Inbound.Types + + +-- | Make download decisions. +-- +makeDecisions + :: forall peeraddr txid tx. + ( Ord peeraddr + , Ord txid + , Hashable peeraddr + ) + => TxDecisionPolicy + -- ^ decision policy + -> SharedDecisionContext peeraddr txid tx + -- ^ decision context + -> Map peeraddr (PeerTxState txid tx) + -- ^ list of available peers. + -- + -- This is a subset of `peerTxStates` of peers which either: + -- * can be used to download a `tx`, + -- * can acknowledge some `txid`s. + -- + -> ( SharedTxState peeraddr txid tx + , Map peeraddr (TxDecision txid tx) + ) +makeDecisions policy SharedDecisionContext { + sdcPeerGSV = _peerGSV, + sdcSharedTxState = st + } + = let (salt, rng') = random (peerRng st) + st' = st { peerRng = rng' } in + fn + . pickTxsToDownload policy st' + . orderByRejections salt + where + fn :: forall a. + (a, [(peeraddr, TxDecision txid tx)]) + -> (a, Map peeraddr (TxDecision txid tx)) + fn (a, as) = (a, Map.fromList as) + + +-- | Order peers by how useful the TXs they have provided are. +-- +-- TXs delivered late will fail to apply because they where included in +-- a recently adopted block. Peers can race against each other by setting +-- `txInflightMultiplicity` to > 1. In case of a tie a hash of the peeraddr +-- is used as a tie breaker. Since every invocation use a new salt a given +-- peeraddr does not have an advantage over time. +-- +orderByRejections :: Hashable peeraddr + => Int + -> Map peeraddr (PeerTxState txid tx) + -> [ (peeraddr, PeerTxState txid tx)] +orderByRejections salt = + sortOn (\(peeraddr, ps) -> (rejectedTxs ps, hashWithSalt salt peeraddr)) + . Map.toList + +-- | Order peers by `DeltaQ`. +-- +_orderByDeltaQ :: forall peeraddr txid tx. + Ord peeraddr + => Map peeraddr PeerGSV + -> Map peeraddr (PeerTxState txid tx) + -> [(peeraddr, PeerTxState txid tx)] +_orderByDeltaQ dq = + sortOn (\(peeraddr, _) -> + gsvRequestResponseDuration + (Map.findWithDefault defaultGSV peeraddr dq) + reqSize + respSize + ) + . Map.toList + where + -- according to calculations in `txSubmissionProtocolLimits`: sizes of + -- `MsgRequestTx` with a single `txid` and `MsgReplyTxs` with a single + -- `tx`. + reqSize :: SizeInBytes + reqSize = 36 -- 32 + 4 (MsgRequestTxs overhead) + + respSize :: SizeInBytes + respSize = 65540 + + +-- | Internal state of `pickTxsToDownload` computation. +-- +data St peeraddr txid tx = + St { stInflightSize :: !SizeInBytes, + -- ^ size of all `tx`s in-flight. + + stInflight :: !(Map txid Int), + -- ^ `txid`s in-flight. + + stAcknowledged :: !(Map txid Int) + -- ^ acknowledged `txid` with multiplicities. It is used to update + -- `referenceCounts`. + } + + +-- | Distribute `tx`'s to download among available peers. Peers are considered +-- in the given order. +-- +-- * pick txs from the set of available tx's (in `txid` order, note these sets +-- might be different for different peers). +-- * pick txs until the peers in-flight limit (we can go over the limit by one tx) +-- (`txsSizeInflightPerPeer` limit) +-- * pick txs until the overall in-flight limit (we can go over the limit by one tx) +-- (`maxTxsSizeInflight` limit) +-- * each tx can be downloaded simultaneously from at most +-- `txInflightMultiplicity` peers. +-- +pickTxsToDownload + :: forall peeraddr txid tx. + ( Ord peeraddr + , Ord txid + ) + => TxDecisionPolicy + -- ^ decision policy + -> SharedTxState peeraddr txid tx + -- ^ shared state + + -> [(peeraddr, PeerTxState txid tx)] + -> ( SharedTxState peeraddr txid tx + , [(peeraddr, TxDecision txid tx)] + ) + +pickTxsToDownload policy@TxDecisionPolicy { txsSizeInflightPerPeer, + maxTxsSizeInflight, + txInflightMultiplicity } + sharedState@SharedTxState { peerTxStates, + inflightTxs, + inflightTxsSize, + bufferedTxs, + referenceCounts } = + -- outer fold: fold `[(peeraddr, PeerTxState txid tx)]` + mapAccumR + accumFn + -- initial state + St { stInflight = inflightTxs, + stInflightSize = inflightTxsSize, + stAcknowledged = Map.empty } + + >>> + gn + where + accumFn :: St peeraddr txid tx + -> (peeraddr, PeerTxState txid tx) + -> ( St peeraddr txid tx + , ( (peeraddr, PeerTxState txid tx) + , TxDecision txid tx + ) + ) + accumFn + st@St { stInflight, + stInflightSize, + stAcknowledged } + ( peeraddr + , peerTxState@PeerTxState { availableTxIds, + unknownTxs, + requestedTxsInflight, + requestedTxsInflightSize + } + ) + = + let sizeInflightAll :: SizeInBytes + sizeInflightOther :: SizeInBytes + + sizeInflightAll = stInflightSize + sizeInflightOther = sizeInflightAll - requestedTxsInflightSize + + in if sizeInflightAll >= maxTxsSizeInflight + then let (numTxIdsToAck, numTxIdsToReq, txsToMempool, RefCountDiff { txIdsToAck }, peerTxState') = + acknowledgeTxIds policy sharedState peerTxState + + stAcknowledged' = Map.unionWith (+) stAcknowledged txIdsToAck + in + if requestedTxIdsInflight peerTxState' > 0 + then + -- we have txids to request + ( st { stAcknowledged = stAcknowledged' } + , ( (peeraddr, peerTxState') + , TxDecision { txdTxIdsToAcknowledge = numTxIdsToAck, + txdTxIdsToRequest = numTxIdsToReq, + txdPipelineTxIds = not + . StrictSeq.null + . unacknowledgedTxIds + $ peerTxState', + txdTxsToRequest = Set.empty, + txdTxsToMempool = txsToMempool + } + ) + ) + else + -- there are no `txid`s to request, nor we can request `tx`s due + -- to in-flight size limits + ( st + , ( (peeraddr, peerTxState') + , emptyTxDecision + ) + ) + else + let requestedTxsInflightSize' :: SizeInBytes + txsToRequest :: Set txid + + (requestedTxsInflightSize', txsToRequest) = + -- inner fold: fold available `txid`s + -- + -- Note: although `Map.foldrWithKey` could be used here, it + -- does not allow to short circuit the fold, unlike + -- `foldWithState`. + foldWithState + (\(txid, (txSize, inflightMultiplicity)) sizeInflight -> + if -- note that we pick `txid`'s as long the `s` is + -- smaller or equal to `txsSizeInflightPerPeer`. + sizeInflight <= txsSizeInflightPerPeer + -- overall `tx`'s in-flight must be smaller than + -- `maxTxsSizeInflight` + && sizeInflight + sizeInflightOther <= maxTxsSizeInflight + -- the transaction must not be downloaded from more + -- than `txInflightMultiplicity` peers simultaneously + && inflightMultiplicity < txInflightMultiplicity + -- TODO: we must validate that `txSize` is smaller than + -- maximum txs size + then Just (sizeInflight + txSize, txid) + else Nothing + ) + (Map.assocs $ + -- merge `availableTxIds` with `stInflight`, so we don't + -- need to lookup into `stInflight` on every `txid` which + -- is in `availableTxIds`. + Map.merge (Map.mapMaybeMissing \_txid -> Just . (,0)) + Map.dropMissing + (Map.zipWithMatched \_txid -> (,)) + + availableTxIds + stInflight + -- remove `tx`s which were already downloaded by some + -- other peer or are in-flight or unknown by this peer. + `Map.withoutKeys` + (Map.keysSet bufferedTxs <> requestedTxsInflight <> unknownTxs) + + ) + requestedTxsInflightSize + -- pick from `txid`'s which are available from that given + -- peer. Since we are folding a dictionary each `txid` + -- will be selected only once from a given peer (at least + -- in each round). + + peerTxState' = peerTxState { + requestedTxsInflightSize = requestedTxsInflightSize', + requestedTxsInflight = requestedTxsInflight + <> txsToRequest + } + + (numTxIdsToAck, numTxIdsToReq, txsToMempool, RefCountDiff { txIdsToAck }, peerTxState'') = + acknowledgeTxIds policy sharedState peerTxState' + + stAcknowledged' = Map.unionWith (+) stAcknowledged txIdsToAck + + stInflightDelta :: Map txid Int + stInflightDelta = Map.fromSet (\_ -> 1) txsToRequest + -- note: this is right since every `txid` + -- could be picked at most once + + stInflight' :: Map txid Int + stInflight' = Map.unionWith (+) stInflightDelta stInflight + in + if requestedTxIdsInflight peerTxState'' > 0 + then + -- we can request `txid`s & `tx`s + ( St { stInflight = stInflight', + stInflightSize = sizeInflightOther + requestedTxsInflightSize', + stAcknowledged = stAcknowledged' } + , ( (peeraddr, peerTxState'') + , TxDecision { txdTxIdsToAcknowledge = numTxIdsToAck, + txdPipelineTxIds = not + . StrictSeq.null + . unacknowledgedTxIds + $ peerTxState'', + txdTxIdsToRequest = numTxIdsToReq, + txdTxsToRequest = txsToRequest, + txdTxsToMempool = txsToMempool + } + ) + ) + else + -- there are no `txid`s to request, only `tx`s. + ( st { stInflight = stInflight', + stInflightSize = sizeInflightOther + requestedTxsInflightSize' + } + , ( (peeraddr, peerTxState'') + , emptyTxDecision { txdTxsToRequest = txsToRequest } + ) + ) + + gn :: ( St peeraddr txid tx + , [((peeraddr, PeerTxState txid tx), TxDecision txid tx)] + ) + -> ( SharedTxState peeraddr txid tx + , [(peeraddr, TxDecision txid tx)] + ) + gn + ( St { stInflight, + stInflightSize, + stAcknowledged } + , as + ) + = + let peerTxStates' = Map.fromList ((\(a,_) -> a) <$> as) + <> peerTxStates + + referenceCounts' = + Map.merge (Map.mapMaybeMissing \_ x -> Just x) + (Map.mapMaybeMissing \_ _ -> assert False Nothing) + (Map.zipWithMaybeMatched \_ x y -> if x > y then Just $! x - y + else Nothing) + referenceCounts + stAcknowledged + + liveSet = Map.keysSet referenceCounts' + + bufferedTxs' = bufferedTxs + `Map.restrictKeys` + liveSet + + in ( sharedState { + peerTxStates = peerTxStates', + inflightTxs = stInflight, + inflightTxsSize = stInflightSize, + bufferedTxs = bufferedTxs', + referenceCounts = referenceCounts' } + , -- exclude empty results + mapMaybe (\((a, _), b) -> case b of + TxDecision { txdTxIdsToAcknowledge = 0, + txdTxIdsToRequest = 0, + txdTxsToRequest, + txdTxsToMempool } + | null txdTxsToRequest + , null txdTxsToMempool + -> Nothing + _ -> Just (a, b) + ) + as + ) + + + +-- | Filter peers which can either download a `tx` or acknowledge `txid`s. +-- +filterActivePeers + :: forall peeraddr txid tx. + Ord txid + => TxDecisionPolicy + -> SharedTxState peeraddr txid tx + -> Map peeraddr (PeerTxState txid tx) +filterActivePeers + TxDecisionPolicy { maxUnacknowledgedTxIds, + txsSizeInflightPerPeer, + maxTxsSizeInflight, + txInflightMultiplicity, + maxNumTxIdsToRequest + } + SharedTxState { peerTxStates, + bufferedTxs, + inflightTxs, + inflightTxsSize } + | overLimit + = Map.filter fn peerTxStates + | otherwise + = Map.filter gn peerTxStates + where + overLimit = inflightTxsSize > maxTxsSizeInflight + unrequestable = Map.keysSet (Map.filter (>= txInflightMultiplicity) inflightTxs) + <> Map.keysSet bufferedTxs + + fn :: PeerTxState txid tx -> Bool + fn PeerTxState { unacknowledgedTxIds, + requestedTxIdsInflight, + unknownTxs + } = + -- hasTxIdsToAcknowledge st ps || + requestedTxIdsInflight == 0 -- document why it's not <= maxTxIdsInFlightPerPeer + && requestedTxIdsInflight + numOfUnacked <= maxUnacknowledgedTxIds + && txIdsToRequest > 0 + where + -- Split `unacknowledgedTxIds'` into the longest prefix of `txid`s which + -- can be acknowledged and the unacknowledged `txid`s. + (acknowledgedTxIds, _) = + StrictSeq.spanl (\txid -> txid `Map.member` bufferedTxs + || txid `Set.member` unknownTxs + ) + unacknowledgedTxIds + numOfUnacked = fromIntegral (StrictSeq.length unacknowledgedTxIds) + numOfAcked = StrictSeq.length acknowledgedTxIds + unackedAndRequested = numOfUnacked + requestedTxIdsInflight + txIdsToRequest = + assert (unackedAndRequested <= maxUnacknowledgedTxIds) $ + assert (requestedTxIdsInflight <= maxNumTxIdsToRequest) $ + (maxUnacknowledgedTxIds - unackedAndRequested + fromIntegral numOfAcked) + `min` + (maxNumTxIdsToRequest - requestedTxIdsInflight) + + gn :: PeerTxState txid tx -> Bool + gn PeerTxState { unacknowledgedTxIds, + requestedTxIdsInflight, + requestedTxsInflight, + requestedTxsInflightSize, + availableTxIds, + unknownTxs } = + ( requestedTxIdsInflight == 0 + && requestedTxIdsInflight + numOfUnacked <= maxUnacknowledgedTxIds + && txIdsToRequest > 0 + ) + || (underSizeLimit && not (Map.null downloadable)) + where + numOfUnacked = fromIntegral (StrictSeq.length unacknowledgedTxIds) + underSizeLimit = requestedTxsInflightSize <= txsSizeInflightPerPeer + downloadable = availableTxIds + `Map.withoutKeys` requestedTxsInflight + `Map.withoutKeys` unknownTxs + `Map.withoutKeys` unrequestable + + -- Split `unacknowledgedTxIds'` into the longest prefix of `txid`s which + -- can be acknowledged and the unacknowledged `txid`s. + (acknowledgedTxIds, _) = + StrictSeq.spanl (\txid -> txid `Map.member` bufferedTxs + || txid `Set.member` unknownTxs + ) + unacknowledgedTxIds + numOfAcked = StrictSeq.length acknowledgedTxIds + unackedAndRequested = numOfUnacked + requestedTxIdsInflight + txIdsToRequest = + assert (unackedAndRequested <= maxUnacknowledgedTxIds) $ + assert (requestedTxIdsInflight <= maxNumTxIdsToRequest) $ + (maxUnacknowledgedTxIds - unackedAndRequested + fromIntegral numOfAcked) + `min` + (maxNumTxIdsToRequest - requestedTxIdsInflight) + +-- +-- Auxiliary functions +-- + +-- | A fold with state implemented as a `foldr` to take advantage of fold-build +-- fusion optimisation. +-- +foldWithState + :: forall s a b. + Ord b + => (a -> s -> Maybe (s, b)) + -> [a] -> s -> (s, Set b) +{-# INLINE foldWithState #-} + +foldWithState f = foldr cons nil + where + cons :: a + -> (s -> (s, Set b)) + -> (s -> (s, Set b)) + cons a k = \ !s -> + case f a s of + Nothing -> nil s + Just (!s', !b) -> + case Set.insert b `second` k s' of + r@(!_s, !_bs) -> r + + nil :: s -> (s, Set b) + nil = \ !s -> (s, Set.empty) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs new file mode 100644 index 00000000000..85a17d9e44d --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Policy.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE NumericUnderscores #-} + +module Ouroboros.Network.TxSubmission.Inbound.Policy + ( TxDecisionPolicy (..) + , defaultTxDecisionPolicy + , max_TX_SIZE + ) where + +import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToReq (..)) +import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) + + +-- | Maximal tx size. +-- +-- Affects: +-- +-- * `TxDecisionPolicy` +-- * `maximumIngressQueue` for `tx-submission` mini-protocol, see +-- `Ouroboros.Network.NodeToNode.txSubmissionProtocolLimits` +-- +max_TX_SIZE :: SizeInBytes +max_TX_SIZE = 65_540 + + +-- | Policy for making decisions +-- +data TxDecisionPolicy = TxDecisionPolicy { + maxNumTxIdsToRequest :: !NumTxIdsToReq, + -- ^ a maximal number of txids requested at once. + + maxUnacknowledgedTxIds :: !NumTxIdsToReq, + -- ^ maximal number of unacknowledgedTxIds. Measured in `NumTxIdsToReq` + -- since we enforce this policy by requesting not more txids than what + -- this limit allows. + + -- + -- Configuration of tx decision logic. + -- + + txsSizeInflightPerPeer :: !SizeInBytes, + -- ^ a limit of tx size in-flight from a single peer. + -- It can be exceed by max tx size. + + maxTxsSizeInflight :: !SizeInBytes, + -- ^ a limit of tx size in-flight from all peers. + -- It can be exceed by max tx size. + + txInflightMultiplicity :: !Int + -- ^ from how many peers download the `txid` simultaneously + } + deriving Show + +defaultTxDecisionPolicy :: TxDecisionPolicy +defaultTxDecisionPolicy = + TxDecisionPolicy { + maxNumTxIdsToRequest = 3, + maxUnacknowledgedTxIds = 10, -- must be the same as txSubmissionMaxUnacked + txsSizeInflightPerPeer = max_TX_SIZE * 6, + maxTxsSizeInflight = max_TX_SIZE * 20, + txInflightMultiplicity = 2 + } diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs new file mode 100644 index 00000000000..f6b057d8310 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs @@ -0,0 +1,387 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Network.TxSubmission.Inbound.Registry + ( TxChannels (..) + , TxChannelsVar + , SharedTxStateVar + , newSharedTxStateVar + , newTxChannelsVar + , PeerTxAPI (..) + , decisionLogicThread + , drainRejectionThread + , withPeer + ) where + +import Control.Concurrent.Class.MonadMVar.Strict +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTimer.SI +import Control.Monad.Class.MonadTime.SI + +import Data.Foldable (traverse_ +#if !MIN_VERSION_base(4,20,0) + , foldl' +#endif + ) +import Data.Hashable +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Sequence.Strict (StrictSeq) +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Typeable (Typeable) +import Data.Void (Void) + +import Control.Tracer (Tracer, traceWith) +import Ouroboros.Network.DeltaQ (PeerGSV (..)) +import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.TxSubmission.Inbound.Decision +import Ouroboros.Network.TxSubmission.Inbound.Policy +import Ouroboros.Network.TxSubmission.Inbound.State +import Ouroboros.Network.TxSubmission.Inbound.Types +import Ouroboros.Network.TxSubmission.Mempool.Reader + +-- | Communication channels between `TxSubmission` client mini-protocol and +-- decision logic. +-- +newtype TxChannels m peeraddr txid tx = TxChannels { + txChannelMap :: Map peeraddr (StrictMVar m (TxDecision txid tx)) + } + +type TxChannelsVar m peeraddr txid tx = StrictMVar m (TxChannels m peeraddr txid tx) + +newTxChannelsVar :: MonadMVar m => m (TxChannelsVar m peeraddr txid tx) +newTxChannelsVar = newMVar (TxChannels Map.empty) + +-- | API to access `PeerTxState` inside `PeerTxStateVar`. +-- +data PeerTxAPI m txid tx = PeerTxAPI { + readTxDecision :: m (TxDecision txid tx), + -- ^ a blocking action which reads `TxDecision` + + handleReceivedTxIds :: NumTxIdsToReq + -> StrictSeq txid + -- ^ received txids + -> Map txid SizeInBytes + -- ^ received sizes of advertised tx's + -> m (), + -- ^ handle received txids + + handleReceivedTxs :: Set txid + -- ^ requested txids + -> Map txid tx + -- ^ received txs + -> m (Maybe TxSubmissionProtocolError), + -- ^ handle received txs + + countRejectedTxs :: Time + -> Double + -> m Double, + -- ^ updated score. The `Double` is difference between accepted and + -- rejected transactions. + + consumeFetchedTxs :: Set txid + -> m (Set txid) + } + + +-- | A bracket function which registers / de-registers a new peer in +-- `SharedTxStateVar` and `PeerTxStateVar`s, which exposes `PeerTxStateAPI`. +-- `PeerTxStateAPI` is only safe inside the `withPeer` scope. +-- +withPeer + :: forall tx peeraddr txid idx m a. + ( MonadMask m + , MonadMVar m + , MonadSTM m + , Ord txid + , Typeable txid + , Show txid + , Ord peeraddr + , Show peeraddr + ) + => Tracer m (TraceTxLogic peeraddr txid tx) + -> TxChannelsVar m peeraddr txid tx + -> SharedTxStateVar m peeraddr txid tx + -> TxSubmissionMempoolReader txid tx idx m + -> (tx -> SizeInBytes) + -> peeraddr + -- ^ new peer + -> (PeerTxAPI m txid tx -> m a) + -- ^ callback which gives access to `PeerTxStateAPI` + -> m a +withPeer tracer + channelsVar + sharedStateVar + TxSubmissionMempoolReader { mempoolGetSnapshot } + txSize + peeraddr io = + bracket + (do -- create a communication channel + !peerTxAPI <- + modifyMVar channelsVar + \ TxChannels { txChannelMap } -> do + chann <- newEmptyMVar + let (chann', txChannelMap') = + Map.alterF (\mbChann -> + let !chann'' = fromMaybe chann mbChann + in (chann'', Just chann'')) + peeraddr + txChannelMap + return + ( TxChannels { txChannelMap = txChannelMap' } + , PeerTxAPI { readTxDecision = takeMVar chann', + handleReceivedTxIds, + handleReceivedTxs, + countRejectedTxs, + consumeFetchedTxs } + ) + + atomically $ modifyTVar sharedStateVar registerPeer + return peerTxAPI + ) + -- the handler is a short blocking operation, thus we need to use + -- `uninterruptibleMask_` + (\_ -> uninterruptibleMask_ do + atomically $ modifyTVar sharedStateVar unregisterPeer + modifyMVar_ channelsVar + \ TxChannels { txChannelMap } -> + return TxChannels { txChannelMap = Map.delete peeraddr txChannelMap } + ) + io + where + registerPeer :: SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx + registerPeer st@SharedTxState { peerTxStates } = + st { peerTxStates = + Map.insert + peeraddr + PeerTxState { + availableTxIds = Map.empty, + requestedTxIdsInflight = 0, + requestedTxsInflightSize = 0, + requestedTxsInflight = Set.empty, + unacknowledgedTxIds = StrictSeq.empty, + unknownTxs = Set.empty, + rejectedTxs = 0, + rejectedTxsTs = Time 0, + fetchedTxs = Set.empty } + peerTxStates + } + + -- TODO: this function needs to be tested! + unregisterPeer :: SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx + unregisterPeer st@SharedTxState { peerTxStates, + bufferedTxs, + referenceCounts } = + st { peerTxStates = peerTxStates', + bufferedTxs = bufferedTxs', + referenceCounts = referenceCounts' } + where + (PeerTxState { unacknowledgedTxIds }, peerTxStates') = + Map.alterF + (\case + Nothing -> error ("TxSubmission.withPeer: invariant violation for peer " ++ show peeraddr) + Just a -> (a, Nothing)) + peeraddr + peerTxStates + + referenceCounts' = + foldl' (flip $ Map.update + \cnt -> if cnt > 1 + then Just $! pred cnt + else Nothing) + referenceCounts + unacknowledgedTxIds + + liveSet = Map.keysSet referenceCounts' + + bufferedTxs' = bufferedTxs + `Map.restrictKeys` + liveSet + + -- + -- PeerTxAPI + -- + + handleReceivedTxIds :: NumTxIdsToReq + -> StrictSeq txid + -> Map txid SizeInBytes + -> m () + handleReceivedTxIds numTxIdsToReq txidsSeq txidsMap = + receivedTxIds tracer + sharedStateVar + mempoolGetSnapshot + peeraddr + numTxIdsToReq + txidsSeq + txidsMap + + + handleReceivedTxs :: Set txid + -- ^ requested txids + -> Map txid tx + -- ^ received txs + -> m (Maybe TxSubmissionProtocolError) + handleReceivedTxs txids txs = do + atomically $ modifyTVar sharedStateVar addFetched + collectTxs tracer txSize sharedStateVar peeraddr txids txs + where + addFetched :: SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx + addFetched st@SharedTxState { peerTxStates } = + let peerTxStates' = + Map.update + (\ps -> Just $! ps { fetchedTxs = Set.union (fetchedTxs ps) txids }) + peeraddr peerTxStates + in st {peerTxStates = peerTxStates' } + + + countRejectedTxs :: Time + -> Double + -> m Double + countRejectedTxs now n = atomically $ do + modifyTVar sharedStateVar cntRejects + st <- readTVar sharedStateVar + case Map.lookup peeraddr (peerTxStates st) of + Nothing -> error "missing peer updated" + Just ps -> return $ rejectedTxs ps + where + cntRejects :: SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx + cntRejects st@SharedTxState { peerTxStates } = + let peerTxStates' = + Map.update (\ps -> Just $! (updateRejects now n ps)) + peeraddr peerTxStates + in st {peerTxStates = peerTxStates'} + + + consumeFetchedTxs :: Set txid + -> m (Set txid) + consumeFetchedTxs otxids = atomically $ do + st <- readTVar sharedStateVar + case Map.lookup peeraddr (peerTxStates st) of + Nothing -> error "missing peer in consumeFetchedTxs" + Just ps -> do + let o = Set.intersection (fetchedTxs ps) otxids + r = Set.difference (fetchedTxs ps) otxids + st' = st { peerTxStates = + Map.update + (\ps' -> Just $! ps' { fetchedTxs = r }) + peeraddr (peerTxStates st) + } + writeTVar sharedStateVar st' + return o + + +updateRejects + :: Time + -> Double + -> PeerTxState txid tx + -> PeerTxState txid tx +updateRejects now 0 pts | rejectedTxs pts == 0 + = pts {rejectedTxsTs = now} +updateRejects now n pts@PeerTxState { rejectedTxs, rejectedTxsTs } = + let duration = diffTime now rejectedTxsTs + rate = 0.1 -- 0.1 rejected tx/s + maxTokens = 15 * 60 * rate -- 15 minutes worth of rejections + !drain = realToFrac duration * rate + !drained = max 0 $ rejectedTxs - drain in + pts { rejectedTxs = max 0 $ min maxTokens $ drained + n + , rejectedTxsTs = now } + + +drainRejectionThread + :: forall m peeraddr txid tx. + ( MonadDelay m + , MonadSTM m + , MonadThread m + ) + => SharedTxStateVar m peeraddr txid tx + -> m Void +drainRejectionThread sharedStateVar = do + labelThisThread "tx-rejection-drain" + go + where + go :: m Void + go = do + threadDelay 7 + + !now <- getMonotonicTime + atomically $ do + st <- readTVar sharedStateVar + let ptss = Map.map (\pts -> updateRejects now 0 pts) (peerTxStates st) + writeTVar sharedStateVar (st { peerTxStates = ptss }) + + go + + +decisionLogicThread + :: forall m peeraddr txid tx. + ( MonadDelay m + , MonadMVar m + , MonadSTM m + , MonadMask m + , MonadFork m + , Ord peeraddr + , Ord txid + , Hashable peeraddr + ) + => Tracer m (TraceTxLogic peeraddr txid tx) + -> TxDecisionPolicy + -> STM m (Map peeraddr PeerGSV) + -> TxChannelsVar m peeraddr txid tx + -> SharedTxStateVar m peeraddr txid tx + -> m Void +decisionLogicThread tracer policy readGSVVar txChannelsVar sharedStateVar = do + labelThisThread "tx-decision" + go + where + go :: m Void + go = do + -- We rate limit the decision making process, it could overwhelm the CPU + -- if there are too many inbound connections. + threadDelay 0.005 -- 5ms + + (decisions, st) <- atomically do + sharedCtx <- + SharedDecisionContext + <$> readGSVVar + <*> readTVar sharedStateVar + let activePeers = filterActivePeers policy (sdcSharedTxState sharedCtx) + + -- block until at least one peer is active + check (not (Map.null activePeers)) + + let (sharedState, decisions) = makeDecisions policy sharedCtx activePeers + writeTVar sharedStateVar sharedState + return (decisions, sharedState) + traceWith tracer (TraceSharedTxState "decisionLogicThread" st) + traceWith tracer (TraceTxDecisions decisions) + TxChannels { txChannelMap } <- readMVar txChannelsVar + traverse_ + (\(mvar, d) -> modifyMVarWithDefault_ mvar d (\d' -> pure (d' <> d))) + (Map.intersectionWith (,) + txChannelMap + decisions) + go + + -- Variant of modifyMVar_ that puts a default value if the MVar is empty. + modifyMVarWithDefault_ :: StrictMVar m a -> a -> (a -> m a) -> m () + modifyMVarWithDefault_ m d io = + mask $ \restore -> do + mbA <- tryTakeMVar m + case mbA of + Just a -> do + a' <- restore (io a) `onException` putMVar m a + putMVar m a' + Nothing -> putMVar m d diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs new file mode 100644 index 00000000000..2c750170367 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Server.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Network.TxSubmission.Inbound.Server where + +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set qualified as Set + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Exception (assert) +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTime.SI +import Control.Tracer (Tracer, traceWith) + +import Network.TypedProtocol + +import Control.Monad (unless, when) +import Ouroboros.Network.Protocol.TxSubmission2.Server +import Ouroboros.Network.TxSubmission.Inbound.Registry (PeerTxAPI (..)) +import Ouroboros.Network.TxSubmission.Inbound.Types +import Ouroboros.Network.TxSubmission.Mempool.Reader + +-- | Flag to enable/disable the usage of the new tx submission protocol +-- +data EnableNewTxSubmissionProtocol = + EnableNewTxSubmissionProtocol + | DisableNewTxSubmissionProtocol + deriving (Eq, Show) + +-- | A tx-submission outbound side (server, sic!). +-- +-- The server blocks on receiving `TxDecision` from the decision logic. If +-- there are tx's to download it pipelines two requests: first for tx's second +-- for txid's. If there are no tx's to download, it either sends a blocking or +-- non-blocking request for txid's. +-- +txSubmissionInboundV2 + :: forall txid tx idx m. + ( MonadSTM m + , MonadThrow m + , MonadMonotonicTime m + , Ord txid + ) + => Tracer m (TraceTxSubmissionInbound txid tx) + -> TxSubmissionMempoolReader txid tx idx m + -> TxSubmissionMempoolWriter txid tx idx m + -> PeerTxAPI m txid tx + -> TxSubmissionServerPipelined txid tx m () +txSubmissionInboundV2 + tracer + TxSubmissionMempoolReader{ + mempoolGetSnapshot + } + TxSubmissionMempoolWriter { + txId, + mempoolAddTxs + } + PeerTxAPI { + readTxDecision, + handleReceivedTxIds, + handleReceivedTxs, + countRejectedTxs, + consumeFetchedTxs + } + = + TxSubmissionServerPipelined serverIdle + where + serverIdle + :: m (ServerStIdle Z txid tx m ()) + serverIdle = do + -- Block on next decision. + txd@TxDecision { txdTxsToRequest = txsToReq, txdTxsToMempool = txs } + <- readTxDecision + traceWith tracer (TraceTxInboundDecision txd) + + let !collected = length txs + mpSnapshot <- atomically mempoolGetSnapshot + fetchedSet <- consumeFetchedTxs (Set.fromList (map fst txs)) + + -- Only attempt to add TXs if we actually has fetched some. + when (not $ Set.null fetchedSet) $ do + let fetched = filter + (\(txid, _) -> Set.member txid fetchedSet) + txs + fetchedS = Set.fromList $ map fst fetched + + -- Note that checking if the mempool contains a TX before + -- spending several ms attempting to add it to the pool has + -- been judged immoral. + let fresh = filter + (\(txid, _) -> not $ mempoolHasTx mpSnapshot txid) + txs + + !start <- getMonotonicTime + txidsAccepted <- mempoolAddTxs $ map snd fresh + !end <- getMonotonicTime + let duration = diffTime end start + + let acceptedS = Set.fromList txidsAccepted + acceptedFetched = Set.intersection fetchedS acceptedS + !accepted = Set.size acceptedFetched + !rejected = Set.size fetchedS - accepted + + traceWith tracer $ + TraceTxInboundAddedToMempool txidsAccepted duration + traceWith tracer $ + TraceTxSubmissionCollected collected + + -- Accepted TXs are discounted from rejected. + -- + -- The number of rejected TXs may be too high. + -- The reason for that is that any peer which has downloaded a + -- TX is permitted to add TXs for all TXids hit has offered. + -- This is done to preserve TX ordering. + -- Accepted TXs are discounted + !s <- countRejectedTxs end $ fromIntegral (rejected - accepted) + + traceWith tracer $ TraceTxSubmissionProcessed ProcessedTxCount { + ptxcAccepted = accepted + , ptxcRejected = rejected + , ptxcScore = s + } + + -- TODO: + -- We can update the state so that other `tx-submission` servers will + -- not try to add these txs to the mempool. + if Set.null txsToReq + then serverReqTxIds Zero txd + else serverReqTxs txd + + + -- Pipelined request of txs + serverReqTxs :: TxDecision txid tx + -> m (ServerStIdle Z txid tx m ()) + serverReqTxs txd@TxDecision { txdTxsToRequest = txsToReq } = + pure $ SendMsgRequestTxsPipelined (Set.toList txsToReq) + (serverReqTxIds (Succ Zero) txd) + + + serverReqTxIds :: forall (n :: N). + Nat n + -> TxDecision txid tx + -> m (ServerStIdle n txid tx m ()) + serverReqTxIds + n TxDecision { txdTxIdsToRequest = 0 } + = + case n of + Zero -> serverIdle + Succ _ -> handleReplies n + + serverReqTxIds + -- if there are no unacknowledged txids, the protocol requires sending + -- a blocking `MsgRequestTxIds` request. This is important, as otherwise + -- the client side wouldn't have a chance to terminate the + -- mini-protocol. + Zero TxDecision { txdTxIdsToAcknowledge = txIdsToAck, + txdPipelineTxIds = False, + txdTxIdsToRequest = txIdsToReq + } + = + pure $ SendMsgRequestTxIdsBlocking + txIdsToAck txIdsToReq + -- Our result if the client terminates the protocol + (traceWith tracer TraceTxInboundTerminated) + (\txids -> do + let txids' = NonEmpty.toList txids + txidsSeq = StrictSeq.fromList $ fst <$> txids' + txidsMap = Map.fromList txids' + unless (StrictSeq.length txidsSeq <= fromIntegral txIdsToReq) $ + throwIO ProtocolErrorTxIdsNotRequested + handleReceivedTxIds txIdsToReq txidsSeq txidsMap + serverIdle + ) + + serverReqTxIds + n@Zero TxDecision { txdTxIdsToAcknowledge = txIdsToAck, + txdPipelineTxIds = True, + txdTxIdsToRequest = txIdsToReq + } + = + pure $ SendMsgRequestTxIdsPipelined + txIdsToAck txIdsToReq + (handleReplies (Succ n)) + + serverReqTxIds + n@Succ{} TxDecision { txdTxIdsToAcknowledge = txIdsToAck, + txdPipelineTxIds, + txdTxIdsToRequest = txIdsToReq + } + = + -- it is impossible that we have had `tx`'s to request (Succ{} - is an + -- evidence for that), but no unacknowledged `txid`s. + assert txdPipelineTxIds $ + pure $ SendMsgRequestTxIdsPipelined + txIdsToAck txIdsToReq + (handleReplies (Succ n)) + + + handleReplies :: forall (n :: N). + Nat (S n) + -> m (ServerStIdle (S n) txid tx m ()) + handleReplies (Succ n'@Succ{}) = + pure $ CollectPipelined + Nothing + (handleReply (handleReplies n')) + + handleReplies (Succ Zero) = + pure $ CollectPipelined + Nothing + (handleReply serverIdle) + + handleReply :: forall (n :: N). + m (ServerStIdle n txid tx m ()) + -- continuation + -> Collect txid tx + -> m (ServerStIdle n txid tx m ()) + handleReply k = \case + CollectTxIds txIdsToReq txids -> do + let txidsSeq = StrictSeq.fromList $ fst <$> txids + txidsMap = Map.fromList txids + unless (StrictSeq.length txidsSeq <= fromIntegral txIdsToReq) $ + throwIO ProtocolErrorTxIdsNotRequested + handleReceivedTxIds txIdsToReq txidsSeq txidsMap + k + CollectTxs txids txs -> do + let requested = Set.fromList txids + received = Map.fromList [ (txId tx, tx) | tx <- txs ] + + unless (Map.keysSet received `Set.isSubsetOf` requested) $ + throwIO ProtocolErrorTxNotRequested + + mbe <- handleReceivedTxs requested received + case mbe of + -- one of `tx`s had a wrong size + Just e -> throwIO e + Nothing -> k diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs new file mode 100644 index 00000000000..15ca9abfb23 --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs @@ -0,0 +1,506 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ouroboros.Network.TxSubmission.Inbound.State + ( -- * Core API + SharedTxState (..) + , PeerTxState (..) + , numTxIdsToRequest + , SharedTxStateVar + , newSharedTxStateVar + , receivedTxIds + , collectTxs + , acknowledgeTxIds + -- * Internals, only exported for testing purposes: + , RefCountDiff (..) + , updateRefCounts + , receivedTxIdsImpl + , collectTxsImpl + ) where + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Exception (assert) +import Control.Tracer (Tracer, traceWith) + +import Data.Foldable (fold, +#if !MIN_VERSION_base(4,20,0) + foldl', +#endif + toList) +import Data.Typeable (Typeable) +import Data.Functor (($>)) +import Data.Map.Merge.Strict qualified as Map +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromJust, maybeToList) +import Data.Sequence.Strict (StrictSeq) +import Data.Sequence.Strict qualified as StrictSeq +import Data.Set (Set) +import Data.Set qualified as Set +import System.Random (StdGen) + +import GHC.Stack (HasCallStack) +import Ouroboros.Network.Protocol.TxSubmission2.Type (NumTxIdsToAck (..), + NumTxIdsToReq (..)) +import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) +import Ouroboros.Network.TxSubmission.Inbound.Policy +import Ouroboros.Network.TxSubmission.Inbound.Types +import Ouroboros.Network.TxSubmission.Mempool.Reader (MempoolSnapshot (..)) + + +-- | Compute number of `txids` to request respecting `TxDecisionPolicy`; update +-- `PeerTxState`. +-- +numTxIdsToRequest :: TxDecisionPolicy + -> PeerTxState txid tx + -> (NumTxIdsToReq, PeerTxState txid tx) +numTxIdsToRequest + TxDecisionPolicy { maxNumTxIdsToRequest, + maxUnacknowledgedTxIds } + ps@PeerTxState { unacknowledgedTxIds, + requestedTxIdsInflight } + = + ( txIdsToRequest + , ps { requestedTxIdsInflight = requestedTxIdsInflight + + txIdsToRequest } + ) + where + -- we are forcing two invariants here: + -- * there are at most `maxUnacknowledgedTxIds` (what we request is added to + -- `unacknowledgedTxIds`) + -- * there are at most `maxNumTxIdsToRequest` txid requests at a time per + -- peer + -- + -- TODO: both conditions provide an upper bound for overall requests for + -- `txid`s to all inbound peers. + txIdsToRequest, unacked, unackedAndRequested :: NumTxIdsToReq + + txIdsToRequest = + assert (unackedAndRequested <= maxUnacknowledgedTxIds) $ + assert (requestedTxIdsInflight <= maxNumTxIdsToRequest) $ + (maxUnacknowledgedTxIds - unackedAndRequested) + `min` (maxNumTxIdsToRequest - requestedTxIdsInflight) + + unackedAndRequested = unacked + requestedTxIdsInflight + unacked = fromIntegral $ StrictSeq.length unacknowledgedTxIds + +-- +-- Pure public API +-- + +acknowledgeTxIds + :: forall peeraddr tx txid. + Ord txid + => TxDecisionPolicy + -> SharedTxState peeraddr txid tx + -> PeerTxState txid tx + -> (NumTxIdsToAck, NumTxIdsToReq, [(txid,tx)], RefCountDiff txid, PeerTxState txid tx) + -- ^ number of txid to acknowledge, txids to acknowledge with multiplicities, + -- updated PeerTxState. +{-# INLINE acknowledgeTxIds #-} + +acknowledgeTxIds + TxDecisionPolicy { maxNumTxIdsToRequest, + maxUnacknowledgedTxIds } + SharedTxState { bufferedTxs } + ps@PeerTxState { availableTxIds, + unacknowledgedTxIds, + unknownTxs, + requestedTxIdsInflight } + = + -- We can only acknowledge txids when we can request new ones, since + -- a `MsgRequestTxIds` for 0 txids is a protocol error. + if txIdsToRequest > 0 + then + ( txIdsToAcknowledge + , txIdsToRequest + , txsToMempool + , refCountDiff + , ps { unacknowledgedTxIds = unacknowledgedTxIds', + availableTxIds = availableTxIds', + unknownTxs = unknownTxs', + requestedTxIdsInflight = requestedTxIdsInflight + + txIdsToRequest } + ) + else + ( 0 + , 0 + , [] + , RefCountDiff Map.empty + , ps + ) + where + -- Split `unacknowledgedTxIds'` into the longest prefix of `txid`s which + -- can be acknowledged and the unacknowledged `txid`s. + (acknowledgedTxIds, unacknowledgedTxIds') = + StrictSeq.spanl (\txid -> txid `Map.member` bufferedTxs + || txid `Set.member` unknownTxs + ) + unacknowledgedTxIds + + txsToMempool :: [(txid, tx)] + txsToMempool = [ (txid,tx) + | txid <- toList acknowledgedTxIds + , Just tx <- maybeToList $ txid `Map.lookup` bufferedTxs + ] + + -- the set of live `txids` + liveSet = Set.fromList (toList unacknowledgedTxIds') + + availableTxIds' = availableTxIds + `Map.restrictKeys` + liveSet + + -- We remove all acknowledged `txid`s which are not in + -- `unacknowledgedTxIds''`, but also return the unknown set before any + -- modifications (which is used to compute `unacknowledgedTxIds''` + -- above). + unknownTxs' = unknownTxs `Set.intersection` liveSet + + refCountDiff = RefCountDiff + $ foldr (\txid -> Map.alter fn txid) + Map.empty acknowledgedTxIds + where + fn :: Maybe Int -> Maybe Int + fn Nothing = Just 1 + fn (Just n) = Just $! n + 1 + + txIdsToAcknowledge :: NumTxIdsToAck + txIdsToAcknowledge = fromIntegral $ StrictSeq.length acknowledgedTxIds + + txIdsToRequest, unacked, unackedAndRequested :: NumTxIdsToReq + + txIdsToRequest = + assert (unackedAndRequested <= maxUnacknowledgedTxIds) $ + assert (requestedTxIdsInflight <= maxNumTxIdsToRequest) $ + (maxUnacknowledgedTxIds - unackedAndRequested + fromIntegral txIdsToAcknowledge) + `min` + (maxNumTxIdsToRequest - requestedTxIdsInflight) + + unackedAndRequested = unacked + requestedTxIdsInflight + unacked = fromIntegral $ StrictSeq.length unacknowledgedTxIds + + +-- | `RefCountDiff` represents a map of `txid` which can be acknowledged +-- together with their multiplicities. +-- +newtype RefCountDiff txid = RefCountDiff { + txIdsToAck :: Map txid Int + } + +updateRefCounts :: Ord txid + => Map txid Int + -> RefCountDiff txid + -> Map txid Int +updateRefCounts referenceCounts (RefCountDiff diff) = + Map.merge (Map.mapMaybeMissing \_ x -> Just x) + (Map.mapMaybeMissing \_ _ -> Nothing) + (Map.zipWithMaybeMatched \_ x y -> assert (x >= y) + if x > y then Just $! x - y + else Nothing) + referenceCounts + diff + + +-- +-- Pure internal API +-- + +-- | Insert received `txid`s and return the number of txids to be acknowledged +-- and the updated `SharedTxState`. +-- +receivedTxIdsImpl + :: forall peeraddr tx txid. + (Ord txid, Ord peeraddr, HasCallStack) + => (txid -> Bool) -- ^ check if txid is in the mempool, ref + -- 'mempoolHasTx' + -> peeraddr + -> NumTxIdsToReq + -- ^ number of requests to subtract from + -- `requestedTxIdsInflight` + + -> StrictSeq txid + -- ^ sequence of received `txids` + -> Map txid SizeInBytes + -- ^ received `txid`s with sizes + + -> SharedTxState peeraddr txid tx + -> SharedTxState peeraddr txid tx + +receivedTxIdsImpl + mempoolHasTx + peeraddr reqNo txidsSeq txidsMap + st@SharedTxState{ peerTxStates, + bufferedTxs, + referenceCounts } + = + -- using `alterF` so the update of `PeerTxState` is done in one lookup + case Map.alterF (fmap Just . fn . fromJust) + peeraddr + peerTxStates of + ( st', peerTxStates' ) -> + st' { peerTxStates = peerTxStates' } + + where + -- update `PeerTxState` and return number of `txid`s to acknowledged and + -- updated `SharedTxState`. + fn :: PeerTxState txid tx + -> ( SharedTxState peeraddr txid tx + , PeerTxState txid tx + ) + fn ps@PeerTxState { availableTxIds, + requestedTxIdsInflight, + unacknowledgedTxIds } = + (st', ps') + where + -- + -- Handle new `txid`s + -- + + -- Divide the new txids in two: those that are already in the mempool + -- and those that are not. We'll request some txs from the latter. + (ignoredTxIds, availableTxIdsMap) = + Map.partitionWithKey + (\txid _ -> mempoolHasTx txid) + txidsMap + + -- Add all `txids` from `availableTxIdsMap` which are not + -- unacknowledged or already buffered. Unacknowledged txids must have + -- already been added to `availableTxIds` map before. + availableTxIds' = + Map.foldlWithKey + (\m txid sizeInBytes -> Map.insert txid sizeInBytes m) + availableTxIds + (Map.filterWithKey + (\txid _ -> txid `notElem` unacknowledgedTxIds + && txid `Map.notMember` bufferedTxs) + availableTxIdsMap) + + -- Add received txids to `unacknowledgedTxIds`. + unacknowledgedTxIds' = unacknowledgedTxIds <> txidsSeq + + -- Add ignored `txs` to buffered ones. + -- Note: we prefer to keep the `tx` if it's already in `bufferedTxs`. + bufferedTxs' = bufferedTxs + <> Map.map (const Nothing) ignoredTxIds + + referenceCounts' = + foldl' (flip $ Map.alter (\case + Nothing -> Just $! 1 + Just cnt -> Just $! succ cnt)) + referenceCounts + txidsSeq + + st' = st { bufferedTxs = bufferedTxs', + referenceCounts = referenceCounts' } + ps' = assert (requestedTxIdsInflight >= reqNo) + ps { availableTxIds = availableTxIds', + unacknowledgedTxIds = unacknowledgedTxIds', + requestedTxIdsInflight = requestedTxIdsInflight - reqNo } + + +collectTxsImpl + :: forall peeraddr tx txid. + (Ord txid, Ord peeraddr, + Typeable txid, Show txid) + => (tx -> SizeInBytes) -- ^ compute tx size + -> peeraddr + -> Set txid -- ^ set of requested txids + -> Map txid tx -- ^ received txs + -> SharedTxState peeraddr txid tx + -> Either TxSubmissionProtocolError + (SharedTxState peeraddr txid tx) + -- ^ Return list of `txid` which sizes didn't match or a new state. + -- If one of the `tx` has wrong size, we return an error. The + -- mini-protocol will throw, which will clean the state map from this peer. +collectTxsImpl txSize peeraddr requestedTxIds receivedTxs + st@SharedTxState { peerTxStates } = + + -- using `alterF` so the update of `PeerTxState` is done in one lookup + case Map.alterF (fmap Just . fn . fromJust) + peeraddr + peerTxStates of + (Right st', peerTxStates') -> + Right st' { peerTxStates = peerTxStates' } + (Left e, _) -> + Left $ ProtocolErrorTxSizeError e + + where + -- Update `PeerTxState` and partially update `SharedTxState` (except of + -- `peerTxStates`). + fn :: PeerTxState txid tx + -> ( Either [(txid, SizeInBytes, SizeInBytes)] + (SharedTxState peeraddr txid tx) + , PeerTxState txid tx + ) + fn ps = + case wrongSizedTxs of + [] -> ( Right st'' + , ps'' + ) + _ -> ( Left wrongSizedTxs + , ps + ) + where + wrongSizedTxs :: [(txid, SizeInBytes, SizeInBytes)] + wrongSizedTxs = + map (\(a, (b,c)) -> (a,b,c)) + . Map.toList + $ Map.merge + (Map.mapMaybeMissing \_ _ -> Nothing) + (Map.mapMaybeMissing \_ _ -> Nothing) + (Map.zipWithMaybeMatched \_ receivedSize advertisedSize -> + if receivedSize == advertisedSize + then Nothing + else Just (receivedSize, advertisedSize) + ) + (txSize `Map.map` receivedTxs) + (availableTxIds ps) + + + notReceived = requestedTxIds Set.\\ Map.keysSet receivedTxs + + -- add received `tx`s to buffered map + bufferedTxs' = bufferedTxs st + <> Map.map Just receivedTxs + + -- Add not received txs to `unknownTxs` before acknowledging txids. + unknownTxs' = unknownTxs ps <> notReceived + + requestedTxsInflight' = + assert (requestedTxIds `Set.isSubsetOf` requestedTxsInflight ps) $ + requestedTxsInflight ps Set.\\ requestedTxIds + + requestedSize = fold $ availableTxIds ps `Map.restrictKeys` requestedTxIds + requestedTxsInflightSize' = + -- TODO: VALIDATE size of received txs against what was announced + -- earlier; + assert (requestedTxsInflightSize ps >= requestedSize) $ + requestedTxsInflightSize ps - requestedSize + + st' = st { bufferedTxs = bufferedTxs' } + + -- subtract requested from in-flight + inflightTxs'' = + Map.merge + (Map.mapMaybeMissing \_ x -> Just x) + (Map.mapMaybeMissing \_ _ -> assert False Nothing) + (Map.zipWithMaybeMatched \_ x y -> assert (x >= y) + let z = x - y in + if z > 0 + then Just z + else Nothing) + (inflightTxs st') + (Map.fromSet (const 1) requestedTxIds) + + inflightTxsSize'' = assert (inflightTxsSize st' >= requestedSize) $ + inflightTxsSize st' - requestedSize + + st'' = st' { inflightTxs = inflightTxs'', + inflightTxsSize = inflightTxsSize'' + } + + -- + -- Update PeerTxState + -- + + -- Remove the downloaded `txid`s from the availableTxIds map, this + -- guarantees that we won't attempt to download the `txids` from this peer + -- once we collect the `txid`s. Also restrict keys to `liveSet`. + -- + -- NOTE: we could remove `notReceived` from `availableTxIds`; and + -- possibly avoid using `unknownTxs` field at all. + -- + availableTxIds'' = availableTxIds ps + `Map.withoutKeys` + requestedTxIds + + -- Remove all acknowledged `txid`s from unknown set, but only those + -- which are not present in `unacknowledgedTxIds'` + unknownTxs'' = unknownTxs' + `Set.intersection` + live + where + -- We cannot use `liveSet` as `unknown <> notReceived` might + -- contain `txids` which are in `liveSet` but are not `live`. + live = Set.fromList (toList (unacknowledgedTxIds ps)) + + ps'' = ps { availableTxIds = availableTxIds'', + unknownTxs = unknownTxs'', + requestedTxsInflightSize = requestedTxsInflightSize', + requestedTxsInflight = requestedTxsInflight' } + +-- +-- Monadic public API +-- + +type SharedTxStateVar m peeraddr txid tx = StrictTVar m (SharedTxState peeraddr txid tx) + +newSharedTxStateVar :: MonadSTM m + => StdGen + -> m (SharedTxStateVar m peeraddr txid tx) +newSharedTxStateVar rng = newTVarIO SharedTxState { peerTxStates = Map.empty, + inflightTxs = Map.empty, + inflightTxsSize = 0, + bufferedTxs = Map.empty, + referenceCounts = Map.empty, + peerRng = rng } + + +-- | Acknowledge `txid`s, return the number of `txids` to be acknowledged to the +-- remote side. +-- +receivedTxIds + :: forall m peeraddr idx tx txid. + (MonadSTM m, Ord txid, Ord peeraddr) + => Tracer m (TraceTxLogic peeraddr txid tx) + -> SharedTxStateVar m peeraddr txid tx + -> STM m (MempoolSnapshot txid tx idx) + -> peeraddr + -> NumTxIdsToReq + -- ^ number of requests to subtract from + -- `requestedTxIdsInflight` + -> StrictSeq txid + -- ^ sequence of received `txids` + -> Map txid SizeInBytes + -- ^ received `txid`s with sizes + -> m () +receivedTxIds tracer sharedVar getMempoolSnapshot peeraddr reqNo txidsSeq txidsMap = do + st <- atomically $ do + MempoolSnapshot{mempoolHasTx} <- getMempoolSnapshot + stateTVar sharedVar ((\a -> (a,a)) . receivedTxIdsImpl mempoolHasTx peeraddr reqNo txidsSeq txidsMap) + traceWith tracer (TraceSharedTxState "receivedTxIds" st) + + +-- | Include received `tx`s in `SharedTxState`. Return number of `txids` +-- to be acknowledged and list of `tx` to be added to the mempool. +-- +collectTxs + :: forall m peeraddr tx txid. + (MonadSTM m, Ord txid, Ord peeraddr, + Typeable txid, Show txid) + => Tracer m (TraceTxLogic peeraddr txid tx) + -> (tx -> SizeInBytes) + -> SharedTxStateVar m peeraddr txid tx + -> peeraddr + -> Set txid -- ^ set of requested txids + -> Map txid tx -- ^ received txs + -> m (Maybe TxSubmissionProtocolError) + -- ^ number of txids to be acknowledged and txs to be added to the + -- mempool +collectTxs tracer txSize sharedVar peeraddr txidsRequested txsMap = do + r <- atomically $ do + st <- readTVar sharedVar + case collectTxsImpl txSize peeraddr txidsRequested txsMap st of + r@(Right st') -> writeTVar sharedVar st' + $> r + r@Left {} -> pure r + case r of + Right st -> traceWith tracer (TraceSharedTxState "collectTxs" st) + $> Nothing + Left e -> return (Just e) diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs new file mode 100644 index 00000000000..a00c681f4ba --- /dev/null +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Types.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Ouroboros.Network.TxSubmission.Inbound.Types + ( -- * PeerTxState + PeerTxState (..) + -- * SharedTxState + , SharedTxState (..) + -- * Decisions + , TxDecision (..) + , emptyTxDecision + , SharedDecisionContext (..) + -- * Various + , ProcessedTxCount (..) + -- * Mempool API + , TxSubmissionMempoolWriter (..) + -- * Traces + , TraceTxSubmissionInbound (..) + , TraceTxLogic (..) + -- * Protocol Error + , TxSubmissionProtocolError (..) + ) where + +import Control.Exception (Exception (..)) +import Control.Monad.Class.MonadTime.SI +import Data.Map.Strict (Map) +import Data.Sequence.Strict (StrictSeq) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import System.Random (StdGen) + +import NoThunks.Class (NoThunks (..)) + +import Ouroboros.Network.DeltaQ (PeerGSV (..)) +import Ouroboros.Network.Protocol.TxSubmission2.Type + +-- +-- PeerTxState, SharedTxState +-- + +data PeerTxState txid tx = PeerTxState { + -- | Those transactions (by their identifier) that the client has told + -- us about, and which we have not yet acknowledged. This is kept in + -- the order in which the client gave them to us. This is the same order + -- in which we submit them to the mempool (or for this example, the final + -- result order). It is also the order we acknowledge in. + -- + unacknowledgedTxIds :: !(StrictSeq txid), + + -- | Set of known transaction ids which can be requested from this peer. + -- + availableTxIds :: !(Map txid SizeInBytes), + + -- | The number of transaction identifiers that we have requested but + -- which have not yet been replied to. We need to track this it keep + -- our requests within the limit on the number of unacknowledged txids. + -- + requestedTxIdsInflight :: !NumTxIdsToReq, + + -- | The size in bytes of transactions that we have requested but which + -- have not yet been replied to. We need to track this it keep our + -- requests within the limit on the number of unacknowledged txids. + -- + requestedTxsInflightSize :: !SizeInBytes, + + -- | The set of requested `txid`s. + -- + requestedTxsInflight :: !(Set txid), + + -- | A subset of `unacknowledgedTxIds` which were unknown to the peer. + -- We need to track these `txid`s since they need to be acknowledged. + -- + -- We track these `txid` per peer, rather than in `bufferedTxs` map, + -- since that could potentially lead to corrupting the node, not being + -- able to download a `tx` which is needed & available from other nodes. + -- + unknownTxs :: !(Set txid), + + -- | The TX score. Accepted tx's adds one, rejected removes one; previous + -- score fades at rate 0.1 (rejected tx)/s. + rejectedTxs :: !Double, + -- | Last time when TX score was updated. + rejectedTxsTs :: !Time, + + fetchedTxs :: !(Set txid) + } + deriving (Eq, Show, Generic) + +instance ( NoThunks txid + , NoThunks tx + ) => NoThunks (PeerTxState txid tx) + + +-- | Shared state of all `TxSubmission` clients. +-- +-- New `txid` enters `unacknowledgedTxIds` it is also added to `availableTxIds` +-- and `referenceCounts` (see `acknowledgeTxIdsImpl`). +-- +-- When a `txid` id is selected to be downloaded, it's added to +-- `requestedTxsInflightSize` (see +-- `Ouroboros.Network.TxSubmission.Inbound.Decision.pickTxsToDownload`). +-- +-- When the request arrives, the `txid` is removed from `inflightTxs`. It +-- might be added to `unknownTxs` if the server didn't have that `txid`, or +-- it's added to `bufferedTxs` (see `collectTxsImpl`). +-- +-- Whenever we choose `txid` to acknowledge (either in `acknowledtxsIdsImpl`, +-- `collectTxsImpl` or +-- `Ouroboros.Network.TxSubmission.Inbound.Decision.pickTxsToDownload`, we also +-- recalculate `referenceCounts` and only keep live `txid`s in other maps (e.g. +-- `availableTxIds`, `bufferedTxs`, `unknownTxs`). +-- +data SharedTxState peeraddr txid tx = SharedTxState { + + -- | Map of peer states. + -- + -- /Invariant:/ for peeraddr's which are registered using `withPeer`, + -- there's always an entry in this map even if the set of `txid`s is + -- empty. + -- + peerTxStates :: !(Map peeraddr (PeerTxState txid tx)), + + -- | Set of transactions which are in-flight (have already been + -- requested) together with multiplicities (from how many peers it is + -- currently in-flight) + -- + -- This set can intersect with `availableTxIds`. + -- + inflightTxs :: !(Map txid Int), + + -- | Overall size of all `tx`s in-flight. + -- + inflightTxsSize :: !SizeInBytes, + + -- | Map of `tx` which: + -- + -- * were downloaded, + -- * are already in the mempool (`Nothing` is inserted in that case), + -- + -- We only keep live `txid`, e.g. ones which `txid` is unacknowledged by + -- at least one peer. + -- + -- /Note:/ `txid`s which `tx` were unknown by a peer are tracked + -- separately in `unknownTxs`. + -- + -- /Note:/ previous implementation also needed to explicitly tracked + -- `txid`s which were already acknowledged, but are still unacknowledged. + -- In this implementation, this is done due to reference counting. + -- + -- This map is useful to acknowledge `txid`s, it's basically taking the + -- longest prefix which contains entries in `bufferedTxs` or `unknownTxs`. + -- + bufferedTxs :: !(Map txid (Maybe tx)), + + -- | We track reference counts of all unacknowledged txids. Once the + -- count reaches 0, a tx is removed from `bufferedTxs`. + -- + -- The `bufferedTx` map contains a subset of `txid` which + -- `referenceCounts` contains. + -- + -- /Invariants:/ + -- + -- * the txid count is equal to multiplicity of txid in all + -- `unacknowledgedTxIds` sequences; + -- * @Map.keysSet bufferedTxs `Set.isSubsetOf` Map.keysSet referenceCounts@; + -- * all counts are positive integers. + -- + referenceCounts :: !(Map txid Int), + + -- | Rng used to randomly order peers + peerRng :: !StdGen + } + deriving (Eq, Show, Generic) + +instance ( NoThunks peeraddr + , NoThunks tx + , NoThunks txid + , NoThunks StdGen + ) => NoThunks (SharedTxState peeraddr txid tx) + + +-- +-- Decisions +-- + +-- | Decision made by the decision logic. Each peer will receive a 'Decision'. +-- +-- /note:/ it is rather non-standard to represent a choice between requesting +-- `txid`s and `tx`'s as a product rather than a sum type. The client will +-- need to download `tx`s first and then send a request for more txids (and +-- acknowledge some `txid`s). Due to pipelining each client will request +-- decision from the decision logic quite often (every two pipelined requests), +-- but with this design a decision once taken will make the peer non-active +-- (e.g. it won't be returned by `filterActivePeers`) for longer, and thus the +-- expensive `makeDecision` computation will not need to take that peer into +-- account. +-- +data TxDecision txid tx = TxDecision { + txdTxIdsToAcknowledge :: !NumTxIdsToAck, + -- ^ txid's to acknowledge + + txdTxIdsToRequest :: !NumTxIdsToReq, + -- ^ number of txid's to request + + txdPipelineTxIds :: !Bool, + -- ^ the tx-submission protocol only allows to pipeline `txid`'s requests + -- if we have non-acknowledged `txid`s. + + txdTxsToRequest :: !(Set txid), + -- ^ txid's to download. + + txdTxsToMempool :: ![(txid,tx)] + -- ^ list of `tx`s to submit to the mempool. + } + deriving (Show, Eq) + +-- | A non-commutative semigroup instance. +-- +-- /note:/ this instance must be consistent with `pickTxsToDownload` and how +-- `PeerTxState` is updated. It is designed to work with `TMergeVar`s. +-- +instance Ord txid => Semigroup (TxDecision txid tx) where + TxDecision { txdTxIdsToAcknowledge, + txdTxIdsToRequest, + txdPipelineTxIds = _ignored, + txdTxsToRequest, + txdTxsToMempool } + <> + TxDecision { txdTxIdsToAcknowledge = txdTxIdsToAcknowledge', + txdTxIdsToRequest = txdTxIdsToRequest', + txdPipelineTxIds = txdPipelineTxIds', + txdTxsToRequest = txdTxsToRequest', + txdTxsToMempool = txdTxsToMempool' } + = + TxDecision { txdTxIdsToAcknowledge = txdTxIdsToAcknowledge + txdTxIdsToAcknowledge', + txdTxIdsToRequest = txdTxIdsToRequest + txdTxIdsToRequest', + txdPipelineTxIds = txdPipelineTxIds', + txdTxsToRequest = txdTxsToRequest <> txdTxsToRequest', + txdTxsToMempool = txdTxsToMempool ++ txdTxsToMempool' + } + +-- | A no-op decision. +emptyTxDecision :: TxDecision txid tx +emptyTxDecision = TxDecision { + txdTxIdsToAcknowledge = 0, + txdTxIdsToRequest = 0, + txdPipelineTxIds = False, + txdTxsToRequest = Set.empty, + txdTxsToMempool = [] + } + +data SharedDecisionContext peeraddr txid tx = SharedDecisionContext { + -- TODO: check how to access it. + sdcPeerGSV :: !(Map peeraddr PeerGSV), + + sdcSharedTxState :: !(SharedTxState peeraddr txid tx) + } + deriving Show + + +-- | TxLogic tracer. +-- +data TraceTxLogic peeraddr txid tx = + TraceSharedTxState String (SharedTxState peeraddr txid tx) + | TraceTxDecisions (Map peeraddr (TxDecision txid tx)) + deriving Show + + +data ProcessedTxCount = ProcessedTxCount { + -- | Just accepted this many transactions. + ptxcAccepted :: Int + -- | Just rejected this many transactions. + , ptxcRejected :: Int + , ptxcScore :: Double + } + deriving (Eq, Show) + + +-- | The consensus layer functionality that the inbound side of the tx +-- submission logic requires. +-- +-- This is provided to the tx submission logic by the consensus layer. +-- +data TxSubmissionMempoolWriter txid tx idx m = + TxSubmissionMempoolWriter { + + -- | Compute the transaction id from a transaction. + -- + -- This is used in the protocol handler to verify a full transaction + -- matches a previously given transaction id. + -- + txId :: tx -> txid, + + -- | Supply a batch of transactions to the mempool. They are either + -- accepted or rejected individually, but in the order supplied. + -- + -- The 'txid's of all transactions that were added successfully are + -- returned. + mempoolAddTxs :: [tx] -> m [txid] + } + + +data TraceTxSubmissionInbound txid tx = + -- | Number of transactions just about to be inserted. + TraceTxSubmissionCollected Int + -- | Just processed transaction pass/fail breakdown. + | TraceTxSubmissionProcessed ProcessedTxCount + -- | Server received 'MsgDone' + | TraceTxInboundCanRequestMoreTxs Int + | TraceTxInboundCannotRequestMoreTxs Int + | TraceTxInboundAddedToMempool [txid] DiffTime + + -- + -- messages emitted by the new implementation of the server in + -- "Ouroboros.Network.TxSubmission.Inbound.Server"; some of them are also + -- used in this module. + -- + + | TraceTxInboundTerminated + | TraceTxInboundDecision (TxDecision txid tx) + deriving (Eq, Show) + + +data TxSubmissionProtocolError = + ProtocolErrorTxNotRequested + | ProtocolErrorTxIdsNotRequested + | forall txid. (Typeable txid, Show txid) + => ProtocolErrorTxSizeError [(txid, SizeInBytes, SizeInBytes)] + -- ^ a list of txid for which the received size and advertised size didn't + -- match. + +deriving instance Show TxSubmissionProtocolError + +instance Exception TxSubmissionProtocolError where + displayException ProtocolErrorTxNotRequested = + "The peer replied with a transaction we did not ask for." + displayException ProtocolErrorTxIdsNotRequested = + "The peer replied with more txids than we asked for." + displayException (ProtocolErrorTxSizeError txids) = + "The peer received txs with wrong sizes " ++ show txids diff --git a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Outbound.hs b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Outbound.hs index 19cdfd4d6e4..26f9aa2d63f 100644 --- a/ouroboros-network/src/Ouroboros/Network/TxSubmission/Outbound.hs +++ b/ouroboros-network/src/Ouroboros/Network/TxSubmission/Outbound.hs @@ -15,12 +15,13 @@ import Data.List.NonEmpty qualified as NonEmpty import Data.Maybe (catMaybes, isNothing, mapMaybe) import Data.Sequence.Strict (StrictSeq) import Data.Sequence.Strict qualified as Seq +import Data.Word (Word16) import Control.Exception (assert) import Control.Monad (unless, when) import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadThrow -import Control.Tracer (Tracer, traceWith) +import Control.Tracer (Tracer (..), traceWith) import Ouroboros.Network.ControlMessage (ControlMessage, ControlMessageSTM, timeoutWithControlMessage) @@ -44,7 +45,7 @@ data TraceTxSubmissionOutbound txid tx data TxSubmissionProtocolError = ProtocolErrorAckedTooManyTxids | ProtocolErrorRequestedNothing - | ProtocolErrorRequestedTooManyTxids NumTxIdsToReq NumTxIdsToAck + | ProtocolErrorRequestedTooManyTxids NumTxIdsToReq Word16 NumTxIdsToAck | ProtocolErrorRequestBlocking | ProtocolErrorRequestNonBlocking | ProtocolErrorRequestedUnavailableTx @@ -54,7 +55,7 @@ instance Exception TxSubmissionProtocolError where displayException ProtocolErrorAckedTooManyTxids = "The peer tried to acknowledged more txids than are available to do so." - displayException (ProtocolErrorRequestedTooManyTxids reqNo maxUnacked) = + displayException (ProtocolErrorRequestedTooManyTxids reqNo _unackedNo maxUnacked) = "The peer requested " ++ show reqNo ++ " txids which would put the " ++ "total in flight over the limit of " ++ show maxUnacked @@ -96,15 +97,15 @@ txSubmissionOutbound tracer maxUnacked TxSubmissionMempoolReader{..} _version co -> NumTxIdsToReq -> m (ClientStTxIds blocking txid tx m ()) recvMsgRequestTxIds blocking ackNo reqNo = do - when (getNumTxIdsToAck ackNo > fromIntegral (Seq.length unackedSeq)) $ throwIO ProtocolErrorAckedTooManyTxids - when ( fromIntegral (Seq.length unackedSeq) + let unackedNo = fromIntegral (Seq.length unackedSeq) + when ( unackedNo - getNumTxIdsToAck ackNo + getNumTxIdsToReq reqNo > getNumTxIdsToAck maxUnacked) $ - throwIO (ProtocolErrorRequestedTooManyTxids reqNo maxUnacked) + throwIO (ProtocolErrorRequestedTooManyTxids reqNo unackedNo maxUnacked) -- Update our tracking state to remove the number of txids that the -- peer has acknowledged. diff --git a/scripts/ci/check-stylish-ignore b/scripts/ci/check-stylish-ignore index 10f9da46dea..6d491197f37 100644 --- a/scripts/ci/check-stylish-ignore +++ b/scripts/ci/check-stylish-ignore @@ -2,8 +2,13 @@ ouroboros-network-api/src/Ouroboros/Network/Protocol/Type.hs ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision/Genesis.hs ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs +ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs +ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/TxLogic.hs ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs +ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/Registry.hs +ouroboros-network/src/Ouroboros/Network/TxSubmission/Inbound/State.hs ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Testnet.hs +ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/TxLogic.hs network-mux/src/Network/Mux/TCPInfo.hs network-mux/src/Network/Mux/Bearer.hs network-mux/src/Network/Mux/Bearer/Pipe.hs