diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs index 04d04618553..e7313112396 100644 --- a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs +++ b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs @@ -44,7 +44,8 @@ import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as LBS import Data.Foldable (foldMap') import Data.Functor (void, ($>), (<&>)) -import Data.List (delete, foldl', intercalate, mapAccumL, nub, (\\)) +import Data.List (deleteBy, find, foldl', intercalate, mapAccumL, nub, + (\\)) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.Trace as Trace import Data.Map.Strict (Map) @@ -116,9 +117,10 @@ import Simulation.Network.Snocket import Ouroboros.Network.Testing.Data.AbsBearerInfo (AbsAttenuation (..), AbsBearerInfo (..), - AbsBearerInfoScript (..), AbsDelay (..), AbsSDUSize (..), - AbsSpeed (..), NonFailingAbsBearerInfoScript (..), - absNoAttenuation, toNonFailingAbsBearerInfoScript) + AbsBearerInfoScript (..), AbsDelay (..), + AbsSDUSize (..), AbsSpeed (..), + NonFailingAbsBearerInfoScript (..), absNoAttenuation, + toNonFailingAbsBearerInfoScript) import Ouroboros.Network.Testing.Utils (WithName (..), WithTime (..), genDelayWithPrecision, nightlyTest, sayTracer, tracerWithTime) @@ -126,6 +128,7 @@ import Ouroboros.Network.Testing.Utils (WithName (..), WithTime (..), import Test.Ouroboros.Network.Orphans () import Test.Simulation.Network.Snocket hiding (tests) +import Data.Function (on) import Ouroboros.Network.ConnectionManager.InformationChannel (newInformationChannel) import TestLib.ConnectionManager (abstractStateIsFinalTransition, @@ -1072,7 +1075,39 @@ 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) + +connectionEventToShape :: ConnectionEvent req peerAddr -> ConnectionEventShape +connectionEventToShape StartClient{} = StartClientShape +connectionEventToShape StartServer{} = StartServerShape +connectionEventToShape InboundConnection{} = InboundConnectionShape +connectionEventToShape OutboundConnection{} = OutboundConnectionShape +connectionEventToShape InboundMiniprotocols{} = InboundMiniprotocolsShape +connectionEventToShape OutboundMiniprotocols{} = OutboundMiniprotocolsShape +connectionEventToShape CloseInboundConnection{} = CloseInboundConnectionShape +connectionEventToShape CloseOutboundConnection{} = CloseOutboundConnectionShape +connectionEventToShape ShutdownClientServer{} = ShutdownClientServerShape -- | A sequence of connection events that make up a test scenario for `prop_multinode_Sim`. data MultiNodeScript req peerAddr = MultiNodeScript @@ -1095,45 +1130,53 @@ 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. +-- 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) @@ -1191,20 +1234,55 @@ 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 InboundConnection InboundConnectionShape) | not $ null possibleInboundConnections] ++ + [ (4, genEventWithDelay OutboundConnection OutboundConnectionShape) | not $ null possibleOutboundConnections] ++ + [ (6, genEventWithDelay CloseInboundConnection CloseInboundConnectionShape) | not $ null inboundConnections ] ++ + [ (4, genEventWithDelay CloseOutboundConnection CloseOutboundConnectionShape) | not $ null outboundConnections ] ++ + [ (10, genEventWithBundle InboundMiniprotocols InboundMiniprotocolsShape genBundle) | not $ null inboundConnections ] ++ + [ (8, genEventWithBundle OutboundMiniprotocols OutboundMiniprotocolsShape genBundle) | not $ null outboundConnections ] ++ + [ (4, genEventWithDelay ShutdownClientServer ShutdownClientServerShape) | not $ null possibleStoppable] (event :) <$> go (nextState event s) (n - 1) where + genEventWithDelay :: (DiffTime -> peerAddr -> ConnectionEvent req peerAddr) + -> ConnectionEventShape + -> Gen (ConnectionEvent req peerAddr) + genEventWithDelay eventCtor eventShape = do + (x1, _) <- elements (connectionMap eventShape) + let prevDelay = maybe delay (return . snd) + $ find ((== x1) . fst) + $ connectionMap (connectionEventToShape (eventCtor undefined x1)) + d <- max <$> prevDelay <*> delay + return $ eventCtor d x1 + + genEventWithBundle :: (DiffTime -> peerAddr -> TemperatureBundle [req] -> ConnectionEvent req peerAddr) + -> ConnectionEventShape + -> Gen (TemperatureBundle [req]) + -> Gen (ConnectionEvent req peerAddr) + genEventWithBundle eventCtor eventShape genB = do + (x1, _) <- elements (connectionMap eventShape) + let prevDelay = maybe delay (return . snd) + $ find ((== x1) . fst) + $ connectionMap (connectionEventToShape (eventCtor undefined x1 undefined)) + d <- max <$> prevDelay <*> delay + eventCtor d x1 <$> genB + + 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 @@ -1331,26 +1409,19 @@ instance Arbitrary req => frequency $ [ (1, StartClient <$> delay <*> newServer) , (16, StartServer <$> delay <*> newServer <*> arbitrary) ] ++ - [ (4, InboundConnection - <$> delay <*> elements possibleInboundConnections) + [ (4, genEventWithDelay InboundConnection InboundConnectionShape) | not $ null possibleInboundConnections ] ++ - [ (4, OutboundConnection - <$> delay <*> elements possibleOutboundConnections) + [ (4, genEventWithDelay OutboundConnection OutboundConnectionShape) | not $ null possibleOutboundConnections] ++ - [ (4, CloseInboundConnection - <$> delay <*> elements inboundConnections) + [ (4, genEventWithDelay CloseInboundConnection CloseInboundConnectionShape) | not $ null inboundConnections ] ++ - [ (20, CloseOutboundConnection - <$> delay <*> elements outboundConnections) + [ (20, genEventWithDelay CloseOutboundConnection CloseOutboundConnectionShape) | not $ null outboundConnections ] ++ - [ (16, InboundMiniprotocols - <$> delay <*> elements inboundConnections <*> genBundle) + [ (16, genEventWithBundle InboundMiniprotocols InboundMiniprotocolsShape genBundle) | not $ null inboundConnections ] ++ - [ (4, OutboundMiniprotocols - <$> delay <*> elements outboundConnections <*> genBundle) + [ (4, genEventWithBundle OutboundMiniprotocols InboundMiniprotocolsShape genBundle) | not $ null outboundConnections ] ++ - [ (1, ShutdownClientServer - <$> delay <*> elements possibleStoppable) + [ (1, genEventWithDelay ShutdownClientServer ShutdownClientServerShape) | not $ null possibleStoppable ] case event of StartServer _ c _ -> do @@ -1365,11 +1436,46 @@ instance Arbitrary req => _ -> (event :) <$> go (nextState event s) (n - 1) where + genEventWithDelay :: (DiffTime -> TestAddr -> ConnectionEvent req TestAddr) + -> ConnectionEventShape + -> Gen (ConnectionEvent req TestAddr) + genEventWithDelay eventCtor eventShape = do + (x1, _) <- elements (connectionMap eventShape) + let prevDelay = maybe delay (return . snd) + $ find ((== x1) . fst) + $ connectionMap (connectionEventToShape (eventCtor undefined x1)) + d <- max <$> prevDelay <*> delay + return $ eventCtor d x1 + + genEventWithBundle :: (DiffTime -> TestAddr -> TemperatureBundle [req] -> ConnectionEvent req TestAddr) + -> ConnectionEventShape + -> Gen (TemperatureBundle [req]) + -> Gen (ConnectionEvent req TestAddr) + genEventWithBundle eventCtor eventShape genB = do + (x1, _) <- elements (connectionMap eventShape) + let prevDelay = maybe delay (return . snd) + $ find ((== x1) . fst) + $ connectionMap (connectionEventToShape (eventCtor undefined x1 undefined)) + d <- max <$> prevDelay <*> delay + eventCtor d x1 <$> genB + + 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,