Skip to content

Commit

Permalink
Fix MultiNodeScript generator
Browse files Browse the repository at this point in the history 
Fix #4607
  • Loading branch information
@bolt12
bolt12 committed Jul 12, 2023
1 parent ff47da1 commit 159aebd
Showing 1 changed file with 158 additions and 52 deletions.
210 changes: 158 additions & 52 deletions ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -116,16 +117,18 @@ 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)

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,
Expand Down Expand Up @@ -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
Expand All @@ -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)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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,
Expand Down

0 comments on commit 159aebd

Please sign in to comment.