Skip to content

Commit

Permalink
Fix MultiNodeScript generator
Browse files Browse the repository at this point in the history 
Fix #4607

In particular fix the delays of generated events in order to not lead to
wrong schedules
  • Loading branch information
@bolt12
bolt12 committed Sep 1, 2023
1 parent d4e8622 commit 5fe5bbf
Show file tree
Hide file tree
Showing 2 changed files with 194 additions and 50 deletions.
3 changes: 3 additions & 0 deletions ouroboros-network-framework/CHANGELOG.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,6 +8,9 @@

* 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.

## 0.9.0.0 -- 2023-08-21

### Breaking changes
Expand Down
241 changes: 191 additions & 50 deletions ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -226,7 +227,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
Expand All @@ -248,47 +281,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)
Expand Down Expand Up @@ -346,20 +387,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
Expand Down Expand Up @@ -486,26 +562,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
Expand All @@ -520,11 +589,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,
Expand Down

0 comments on commit 5fe5bbf

Please sign in to comment.