diff --git a/ouroboros-network-framework/CHANGELOG.md b/ouroboros-network-framework/CHANGELOG.md index 1d0a2600368..39a88a8c913 100644 --- a/ouroboros-network-framework/CHANGELOG.md +++ b/ouroboros-network-framework/CHANGELOG.md @@ -8,6 +8,11 @@ * Split `test` component into `io-tests` and `sim-tests`. +* Fix MultiNodeScript Generator, in particular fix the delays between two events that + depend on each other. +* Fix `multiNodeExperiment`, in particular wait to disconnect from a peer only + after the peer has connected to it. + ## 0.9.0.0 -- 2023-08-21 ### Breaking changes diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs index 56be217f203..1171d9eb046 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs @@ -43,7 +43,7 @@ import Data.Bool (bool) import Data.ByteString.Lazy (ByteString) import Data.Foldable (foldMap') import Data.Functor (void, ($>), (<&>)) -import Data.List (delete, foldl', intercalate, nub, (\\)) +import Data.List (deleteBy, find, foldl', intercalate, nub, (\\)) import qualified Data.List.Trace as Trace import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -97,6 +97,7 @@ import Ouroboros.Network.Testing.Utils (WithName (..), WithTime (..), import Ouroboros.Network.Test.Orphans () import Test.Simulation.Network.Snocket hiding (tests) +import Data.Function (on) import Ouroboros.Network.ConnectionManager.Test.Experiments import Ouroboros.Network.ConnectionManager.Test.Timeouts import Ouroboros.Network.ConnectionManager.Test.Utils @@ -226,7 +227,28 @@ data ConnectionEvent req peerAddr -- ^ Close an outbound connection. | ShutdownClientServer DiffTime peerAddr -- ^ Shuts down a client/server (simulates power loss) - deriving (Show, Functor) + deriving (Eq, Show, Functor) + +data ConnectionEventShape + = StartClientShape + -- ^ Start a new client at the given address + | StartServerShape + -- ^ Start a new server at the given address + | InboundConnectionShape + -- ^ Create a connection from client or server with the given address to the central server. + | OutboundConnectionShape + -- ^ Create a connection from the central server to another server. + | InboundMiniprotocolsShape + -- ^ Run a bundle of mini protocols on the inbound connection from the given address. + | OutboundMiniprotocolsShape + -- ^ Run a bundle of mini protocols on the outbound connection to the given address. + | CloseInboundConnectionShape + -- ^ Close an inbound connection. + | CloseOutboundConnectionShape + -- ^ Close an outbound connection. + | ShutdownClientServerShape + -- ^ Shuts down a client/server (simulates power loss) + deriving (Eq, Show) -- | A sequence of connection events that make up a test scenario for `prop_multinode_Sim`. data MultiNodeScript req peerAddr = MultiNodeScript @@ -248,47 +270,55 @@ data MultiNodePruningScript req = MultiNodePruningScript } deriving (Show) --- | To generate well-formed scripts we need to keep track of what nodes are --- started and what connections they've made. +-- | To generate well-formed scripts we need to keep track of what nodes are started and what +-- connections they've made. We also need to track the delay each peer action took so we +-- can make sure, e.g. that we don't have: +-- +-- OutboundConnection 0.1s A -> CloseOutboundConnection 0s A +-- +-- We should consider the delay of creating outbound connection to A: +-- +-- OutboundConnection 0.1s A -> CloseOutboundConnection 0.1s A -- -- NOTE: this does not track failures, e.g. `requestOutboundConnection` when -- there's already a `Unidirectional` inbound connection (i.e. -- a `ForbiddenOperation`). -- -data ScriptState peerAddr = ScriptState { startedClients :: [peerAddr] - , startedServers :: [peerAddr] - , clientConnections :: [peerAddr] - , inboundConnections :: [peerAddr] - , outboundConnections :: [peerAddr] } +data ScriptState peerAddr = ScriptState { startedClients :: [(peerAddr, DiffTime)] + , startedServers :: [(peerAddr, DiffTime)] + , clientConnections :: [(peerAddr, DiffTime)] + , inboundConnections :: [(peerAddr, DiffTime)] + , outboundConnections :: [(peerAddr, DiffTime)] + } -- | Update the state after a connection event. nextState :: Eq peerAddr => ConnectionEvent req peerAddr -> ScriptState peerAddr -> ScriptState peerAddr nextState e s@ScriptState{..} = case e of - StartClient _ a -> s{ startedClients = a : startedClients } - StartServer _ a _ -> s{ startedServers = a : startedServers } - InboundConnection _ a -> s{ inboundConnections = a : inboundConnections } - OutboundConnection _ a -> s{ outboundConnections = a : outboundConnections } - CloseInboundConnection _ a -> s{ inboundConnections = delete a inboundConnections } - CloseOutboundConnection _ a -> s{ outboundConnections = delete a outboundConnections } + StartClient d a -> s{ startedClients = (a, d) : startedClients } + StartServer d a _ -> s{ startedServers = (a, d) : startedServers } + InboundConnection d a -> s{ inboundConnections = (a, d) : inboundConnections } + OutboundConnection d a -> s{ outboundConnections = (a, d) : outboundConnections } + CloseInboundConnection d a -> s{ inboundConnections = deleteBy ((==) `on` fst) (a , d) inboundConnections } + CloseOutboundConnection d a -> s{ outboundConnections = deleteBy ((==) `on` fst) (a , d) outboundConnections } InboundMiniprotocols{} -> s OutboundMiniprotocols{} -> s - ShutdownClientServer _ a -> s{ startedClients = delete a startedClients - , startedServers = delete a startedServers } + ShutdownClientServer d a -> s{ startedClients = deleteBy ((==) `on` fst) (a , d) startedClients + , startedServers = deleteBy ((==) `on` fst) (a , d) startedServers } -- | Check if an event makes sense in a given state. isValidEvent :: Eq peerAddr => ConnectionEvent req peerAddr -> ScriptState peerAddr -> Bool isValidEvent e ScriptState{..} = case e of - StartClient _ a -> notElem a (startedClients ++ startedServers) - StartServer _ a _ -> notElem a (startedClients ++ startedServers) - InboundConnection _ a -> elem a (startedServers ++ startedClients) && notElem a inboundConnections - OutboundConnection _ a -> elem a startedServers && notElem a outboundConnections - CloseInboundConnection _ a -> elem a inboundConnections - CloseOutboundConnection _ a -> elem a outboundConnections - InboundMiniprotocols _ a _ -> elem a inboundConnections - OutboundMiniprotocols _ a _ -> elem a outboundConnections - ShutdownClientServer _ a -> elem a (startedClients ++ startedServers) + StartClient _ a -> notElem a (map fst (startedClients ++ startedServers)) + StartServer _ a _ -> notElem a (map fst (startedClients ++ startedServers)) + InboundConnection _ a -> elem a (map fst (startedServers ++ startedClients)) && notElem a (map fst inboundConnections) + OutboundConnection _ a -> elem a (map fst startedServers) && notElem a (map fst outboundConnections) + CloseInboundConnection _ a -> elem a (map fst inboundConnections) + CloseOutboundConnection _ a -> elem a (map fst outboundConnections) + InboundMiniprotocols _ a _ -> elem a (map fst inboundConnections) + OutboundMiniprotocols _ a _ -> elem a (map fst outboundConnections) + ShutdownClientServer _ a -> elem a (map fst (startedClients ++ startedServers)) -- This could be an Arbitrary instance, but it would be an orphan. genBundle :: Arbitrary a => Gen (TemperatureBundle a) @@ -346,20 +376,92 @@ instance (Arbitrary peerAddr, Arbitrary req, Ord peerAddr) => event <- frequency $ [ (6, StartClient <$> delay <*> newClient) , (6, StartServer <$> delay <*> newServer <*> arbitrary) ] ++ - [ (4, InboundConnection <$> delay <*> elements possibleInboundConnections) | not $ null possibleInboundConnections] ++ - [ (4, OutboundConnection <$> delay <*> elements possibleOutboundConnections) | not $ null possibleOutboundConnections] ++ - [ (6, CloseInboundConnection <$> delay <*> elements inboundConnections) | not $ null inboundConnections ] ++ - [ (4, CloseOutboundConnection <$> delay <*> elements outboundConnections) | not $ null outboundConnections ] ++ - [ (10, InboundMiniprotocols <$> delay <*> elements inboundConnections <*> genBundle) | not $ null inboundConnections ] ++ - [ (8, OutboundMiniprotocols <$> delay <*> elements outboundConnections <*> genBundle) | not $ null outboundConnections ] ++ - [ (4, ShutdownClientServer <$> delay <*> elements possibleStoppable) | not $ null possibleStoppable ] + [ (4, genEventWithDelay InboundConnectionShape) | not $ null possibleInboundConnections] ++ + [ (4, genEventWithDelay OutboundConnectionShape) | not $ null possibleOutboundConnections] ++ + [ (6, genEventWithDelay CloseInboundConnectionShape) | not $ null inboundConnections ] ++ + [ (4, genEventWithDelay CloseOutboundConnectionShape) | not $ null outboundConnections ] ++ + [ (10, genEventWithBundle InboundMiniprotocolsShape genBundle) | not $ null inboundConnections ] ++ + [ (8, genEventWithBundle OutboundMiniprotocolsShape genBundle) | not $ null outboundConnections ] ++ + [ (4, genEventWithDelay ShutdownClientServerShape) | not $ null possibleStoppable] (event :) <$> go (nextState event s) (n - 1) where + genEventWithDelay :: ConnectionEventShape + -> Gen (ConnectionEvent req peerAddr) + genEventWithDelay es@InboundConnectionShape = do + (x1, _) <- elements (connectionMap es) + let prevDelay = maybe delay (return . snd) + $ find ((== x1) . fst) + $ connectionMap es + d <- max <$> prevDelay <*> delay + return $ InboundConnection d x1 + genEventWithDelay es@OutboundConnectionShape = do + (x1, _) <- elements (connectionMap es) + let prevDelay = maybe delay (return . snd) + $ find ((== x1) . fst) + $ connectionMap es + d <- max <$> prevDelay <*> delay + return $ OutboundConnection d x1 + genEventWithDelay es@CloseInboundConnectionShape = do + (x1, _) <- elements (connectionMap es) + let prevDelay = maybe delay (return . snd) + $ find ((== x1) . fst) + $ connectionMap es + d <- max <$> prevDelay <*> delay + return $ CloseInboundConnection d x1 + genEventWithDelay es@CloseOutboundConnectionShape = do + (x1, _) <- elements (connectionMap es) + let prevDelay = maybe delay (return . snd) + $ find ((== x1) . fst) + $ connectionMap es + d <- max <$> prevDelay <*> delay + return $ CloseOutboundConnection d x1 + genEventWithDelay es@ShutdownClientServerShape = do + (x1, _) <- elements (connectionMap es) + let prevDelay = maybe delay (return . snd) + $ find ((== x1) . fst) + $ connectionMap es + d <- max <$> prevDelay <*> delay + return $ ShutdownClientServer d x1 + genEventWithDelay _ = + error "genEventWithDelay: wrong ConnectionEventShape" + + genEventWithBundle :: ConnectionEventShape + -> Gen (TemperatureBundle [req]) + -> Gen (ConnectionEvent req peerAddr) + genEventWithBundle es@InboundMiniprotocolsShape genB = do + (x1, _) <- elements (connectionMap es) + let prevDelay = maybe delay (return . snd) + $ find ((== x1) . fst) + $ connectionMap es + d <- max <$> prevDelay <*> delay + InboundMiniprotocols d x1 <$> genB + genEventWithBundle es@OutboundMiniprotocolsShape genB = do + (x1, _) <- elements (connectionMap es) + let prevDelay = maybe delay (return . snd) + $ find ((== x1) . fst) + $ connectionMap es + d <- max <$> prevDelay <*> delay + OutboundMiniprotocols d x1 <$> genB + genEventWithBundle _ _ = + error "genEventWithBundle: wrong ConnectionEventShape" + + connectionMap :: ConnectionEventShape -> [(peerAddr, DiffTime)] + connectionMap eventCtor = case eventCtor of + StartClientShape -> startedClients ++ startedServers + StartServerShape -> startedClients ++ startedServers + InboundConnectionShape -> possibleInboundConnections + OutboundConnectionShape -> possibleOutboundConnections + InboundMiniprotocolsShape -> inboundConnections + OutboundMiniprotocolsShape -> outboundConnections + CloseInboundConnectionShape -> inboundConnections + CloseOutboundConnectionShape -> outboundConnections + ShutdownClientServerShape -> possibleStoppable + possibleStoppable = startedClients ++ startedServers possibleInboundConnections = (startedClients ++ startedServers) \\ inboundConnections possibleOutboundConnections = startedServers \\ outboundConnections - newClient = arbitrary `suchThat` (`notElem` (startedClients ++ startedServers)) - newServer = arbitrary `suchThat` (`notElem` (startedClients ++ startedServers)) + newClient = arbitrary `suchThat` (`notElem` (map fst (startedClients ++ startedServers))) + newServer = arbitrary `suchThat` (`notElem` (map fst (startedClients ++ startedServers))) shrink (MultiNodeScript events attenuationMap) = do events' <- makeValid <$> shrinkList shrinkEvent events @@ -486,26 +588,19 @@ instance Arbitrary req => frequency $ [ (1, StartClient <$> delay <*> newServer) , (16, StartServer <$> delay <*> newServer <*> arbitrary) ] ++ - [ (4, InboundConnection - <$> delay <*> elements possibleInboundConnections) + [ (4, genEventWithDelay InboundConnectionShape) | not $ null possibleInboundConnections ] ++ - [ (4, OutboundConnection - <$> delay <*> elements possibleOutboundConnections) + [ (4, genEventWithDelay OutboundConnectionShape) | not $ null possibleOutboundConnections] ++ - [ (4, CloseInboundConnection - <$> delay <*> elements inboundConnections) + [ (4, genEventWithDelay CloseInboundConnectionShape) | not $ null inboundConnections ] ++ - [ (20, CloseOutboundConnection - <$> delay <*> elements outboundConnections) + [ (20, genEventWithDelay CloseOutboundConnectionShape) | not $ null outboundConnections ] ++ - [ (16, InboundMiniprotocols - <$> delay <*> elements inboundConnections <*> genBundle) + [ (16, genEventWithBundle InboundMiniprotocolsShape genBundle) | not $ null inboundConnections ] ++ - [ (4, OutboundMiniprotocols - <$> delay <*> elements outboundConnections <*> genBundle) + [ (4, genEventWithBundle OutboundMiniprotocolsShape genBundle) | not $ null outboundConnections ] ++ - [ (1, ShutdownClientServer - <$> delay <*> elements possibleStoppable) + [ (1, genEventWithDelay ShutdownClientServerShape) | not $ null possibleStoppable ] case event of StartServer _ c _ -> do @@ -520,11 +615,83 @@ instance Arbitrary req => _ -> (event :) <$> go (nextState event s) (n - 1) where + genEventWithDelay :: ConnectionEventShape + -> Gen (ConnectionEvent req TestAddr) + genEventWithDelay es@InboundConnectionShape = do + (x1, _) <- elements (connectionMap es) + let prevDelay = maybe delay (return . snd) + $ find ((== x1) . fst) + $ connectionMap es + d <- max <$> prevDelay <*> delay + return $ InboundConnection d x1 + genEventWithDelay es@OutboundConnectionShape = do + (x1, _) <- elements (connectionMap es) + let prevDelay = maybe delay (return . snd) + $ find ((== x1) . fst) + $ connectionMap es + d <- max <$> prevDelay <*> delay + return $ OutboundConnection d x1 + genEventWithDelay es@CloseInboundConnectionShape = do + (x1, _) <- elements (connectionMap es) + let prevDelay = maybe delay (return . snd) + $ find ((== x1) . fst) + $ connectionMap es + d <- max <$> prevDelay <*> delay + return $ CloseInboundConnection d x1 + genEventWithDelay es@CloseOutboundConnectionShape = do + (x1, _) <- elements (connectionMap es) + let prevDelay = maybe delay (return . snd) + $ find ((== x1) . fst) + $ connectionMap es + d <- max <$> prevDelay <*> delay + return $ CloseOutboundConnection d x1 + genEventWithDelay es@ShutdownClientServerShape = do + (x1, _) <- elements (connectionMap es) + let prevDelay = maybe delay (return . snd) + $ find ((== x1) . fst) + $ connectionMap es + d <- max <$> prevDelay <*> delay + return $ ShutdownClientServer d x1 + genEventWithDelay _ = + error "genEventWithDelay: wrong ConnectionEventShape" + + genEventWithBundle :: ConnectionEventShape + -> Gen (TemperatureBundle [req]) + -> Gen (ConnectionEvent req TestAddr) + genEventWithBundle es@InboundMiniprotocolsShape genB = do + (x1, _) <- elements (connectionMap es) + let prevDelay = maybe delay (return . snd) + $ find ((== x1) . fst) + $ connectionMap es + d <- max <$> prevDelay <*> delay + InboundMiniprotocols d x1 <$> genB + genEventWithBundle es@OutboundMiniprotocolsShape genB = do + (x1, _) <- elements (connectionMap es) + let prevDelay = maybe delay (return . snd) + $ find ((== x1) . fst) + $ connectionMap es + d <- max <$> prevDelay <*> delay + OutboundMiniprotocols d x1 <$> genB + genEventWithBundle _ _ = + error "genEventWithBundle: wrong ConnectionEventShape" + + connectionMap :: ConnectionEventShape -> [(TestAddr, DiffTime)] + connectionMap eventCtor = case eventCtor of + StartClientShape -> startedClients ++ startedServers + StartServerShape -> startedClients ++ startedServers + InboundConnectionShape -> possibleInboundConnections + OutboundConnectionShape -> possibleOutboundConnections + InboundMiniprotocolsShape -> inboundConnections + OutboundMiniprotocolsShape -> outboundConnections + CloseInboundConnectionShape -> inboundConnections + CloseOutboundConnectionShape -> outboundConnections + ShutdownClientServerShape -> possibleStoppable + possibleStoppable = startedClients ++ startedServers possibleInboundConnections = (startedClients ++ startedServers) \\ inboundConnections possibleOutboundConnections = startedServers \\ outboundConnections - newServer = arbitrary `suchThat` (`notElem` possibleStoppable) + newServer = arbitrary `suchThat` (`notElem` map fst possibleStoppable) -- TODO: The shrinking here is not optimal. It works better if we shrink one -- value at a time rather than all of them at once. If we shrink to quickly, @@ -860,9 +1027,12 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer cmTracer go True (Map.insert remoteAddr h connMap) Right Disconnected {} -> return () Disconnect remoteAddr -> do - atomically $ modifyTVar connVar $ Map.delete (connId remoteAddr) when unregister $ void (unregisterOutboundConnection cm remoteAddr) + atomically $ do + m <- readTVar connVar + check (Map.member (connId remoteAddr) m) + writeTVar connVar (Map.delete (connId remoteAddr) m) go False (Map.delete remoteAddr connMap) RunMiniProtocols remoteAddr reqs -> do atomically $ do