From c3387383f7d5dcb6c0017303ca559d63234fe11c Mon Sep 17 00:00:00 2001 From: Armando Santos Date: Fri, 15 Oct 2021 14:54:44 +0100 Subject: [PATCH] Used Script of Script for BearerInfo Attenuation - Modified Snocket's connect to use one script per connection --- .../src/Simulation/Network/Snocket.hs | 54 ++++++-- .../test/Test/Ouroboros/Network/Server2.hs | 126 ++++++++++-------- .../test/Test/Simulation/Network/Snocket.hs | 18 ++- .../Network/Testing/Data/AbsBearerInfo.hs | 33 ++--- .../Ouroboros/Network/Testing/Data/Script.hs | 9 ++ .../Network/Protocol/Handshake/Test.hs | 2 +- 6 files changed, 146 insertions(+), 96 deletions(-) diff --git a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs index c41305e5f08..e39c46bcf90 100644 --- a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs +++ b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} @@ -9,6 +8,8 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} +{-# LANGUAGE TypeApplications #-} -- | This module provides simulation environment and a snocket implementation -- suitable for 'IOSim'. @@ -25,8 +26,10 @@ module Simulation.Network.Snocket withSnocket , ObservableNetworkState (..) , ResourceException (..) + , SDUSize + , Script (..) + , Size , SnocketTrace (..) - , TimeoutDetail (..) , SockType (..) , OpenType (..) @@ -35,10 +38,9 @@ module Simulation.Network.Snocket , IOErrType (..) , IOErrThrowOrReturn (..) , SuccessOrFailure (..) - , Size + , TimeoutDetail (..) , noAttenuation , FD - , SDUSize , GlobalAddressScheme (..) , AddressType (..) @@ -78,7 +80,7 @@ import Ouroboros.Network.ConnectionManager.Types (AddressType (..)) import Ouroboros.Network.Snocket import Ouroboros.Network.Testing.Data.Script - (Script(..), stepScriptSTM, initScript) + (Script(..), initScript, stepScriptSTM, stepScriptSTMTx, stepScript) data Connection m addr = Connection { -- | Attenuated channels of a connection. @@ -199,13 +201,23 @@ data NetworkState m addr = NetworkState { -- | Registry of active connections. -- - nsConnections :: StrictTVar m (Map (NormalisedId addr) (Connection m addr)), + nsConnections :: StrictTVar + m + (Map (NormalisedId addr) (Connection m addr)), -- | Get an unused ephemeral address. -- nsNextEphemeralAddr :: AddressType -> STM m addr, - nsBearerInfo :: LazySTM.TVar m (Script BearerInfo) + nsBearerInfo :: LazySTM.TVar + m + (Script (LazySTM.STM m (LazySTM.TVar m (Script BearerInfo)))), + + -- | Get the BearerInfo Script for a given connection. + -- + nsAttenuationMap :: StrictTVar + m (Map (ConnectionId addr) + (LazySTM.TVar m (Script BearerInfo))) } @@ -312,10 +324,10 @@ newNetworkState ( MonadLabelledSTM m , GlobalAddressScheme peerAddr ) - => Script BearerInfo + => Script (Script BearerInfo) -- ^ the largest ephemeral address -> m (NetworkState m (TestAddress peerAddr)) -newNetworkState bearerInfoScript = atomically $ do +newNetworkState script = atomically $ do (v :: StrictTVar m Natural) <- newTVar 0 let nextEphemeralAddr :: AddressType -> STM m (TestAddress peerAddr) nextEphemeralAddr addrType = do @@ -323,6 +335,7 @@ newNetworkState bearerInfoScript = atomically $ do -- include PR #3172. a <- stateTVar v (\s -> let s' = succ s in (s', s')) return (ephemeralAddress addrType a) + s <- NetworkState -- nsListeningFDs <$> newTVar Map.empty @@ -331,7 +344,10 @@ newNetworkState bearerInfoScript = atomically $ do -- nsNextEphemeralAddr <*> pure nextEphemeralAddr -- nsBearerInfo - <*> initScript bearerInfoScript + <*> LazySTM.newTVar (initScript <$> script) + -- attenuationMap + <*> newTVar Map.empty + labelTVar (nsListeningFDs s) "nsListeningFDs" labelTVar (nsConnections s) "nsConnections" return s @@ -387,7 +403,7 @@ withSnocket ) => Tracer m (WithAddr (TestAddress peerAddr) (SnocketTrace m (TestAddress peerAddr))) - -> Script BearerInfo + -> Script (Script BearerInfo) -> (Snocket m (FD m (TestAddress peerAddr)) (TestAddress peerAddr) -> m (ObservableNetworkState (TestAddress peerAddr)) -> m a) @@ -721,13 +737,23 @@ mkSnocket state tr = Snocket { getLocalAddr -- accepted. FDUninitialised mbLocalAddr -> mask $ \unmask -> do (connId, bearerInfo, simOpen) <- atomically $ do - bearerInfo <- stepScriptSTM (nsBearerInfo state) localAddress <- case mbLocalAddr of Just addr -> return addr Nothing -> nsNextEphemeralAddr state (getAddressType remoteAddress) let connId = ConnectionId { localAddress, remoteAddress } + attenuationMap <- readTVar (nsAttenuationMap state) + + bearerInfo <- case Map.lookup connId attenuationMap of + Nothing -> do + script <- stepScriptSTMTx (nsBearerInfo state) + writeTVar (nsAttenuationMap state) + (Map.insert connId script attenuationMap) + stepScriptSTM script + + Just script -> stepScriptSTM script + connMap <- readTVar (nsConnections state) case Map.lookup (normaliseId connId) connMap of Just Connection { connState = ESTABLISHED } -> @@ -997,7 +1023,9 @@ mkSnocket state tr = Snocket { getLocalAddr -> m (Accept m (FD m (TestAddress addr)) (TestAddress addr)) accept FD { fdVar } = do time <- getMonotonicTime - deltaAndIOErr <- biAcceptFailures <$> atomically (stepScriptSTM $ nsBearerInfo state) + script <- atomically . stepScriptSTMTx $ nsBearerInfo state + bearerInfo <- stepScript script + let deltaAndIOErr = biAcceptFailures bearerInfo return $ accept_ time deltaAndIOErr where -- non-blocking; return 'True' if a connection is in 'SYN_SENT' state diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs index 27645dea303..1e69a23937c 100644 --- a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs +++ b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs @@ -53,6 +53,7 @@ import Data.Functor (void, ($>), (<&>)) import Data.List (dropWhileEnd, find, mapAccumL, intercalate, (\\), delete, foldl') import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.Trace as Trace +import qualified Data.List.NonEmpty as NonEmpty (fromList) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, fromJust, isJust) import Data.Monoid (Sum (..)) @@ -116,15 +117,16 @@ import qualified Ouroboros.Network.Snocket as Snocket import Simulation.Network.Snocket -import Ouroboros.Network.Testing.Data.Script (Script (..), singletonScript) +import Ouroboros.Network.Testing.Data.AbsBearerInfo + (NonFailingBearerInfoScript(..), AbsBearerInfo (..), + AbsDelay (..), AbsAttenuation (..), AbsSpeed (..), + AbsSDUSize (..), BearerInfoScript (..)) +import Ouroboros.Network.Testing.Data.Script (singletonScript) import Ouroboros.Network.Testing.Utils (genDelayWithPrecision) + import Test.Ouroboros.Network.Orphans () -- ShowProxy ReqResp instance import Test.Simulation.Network.Snocket hiding (tests) import Test.Ouroboros.Network.ConnectionManager (verifyAbstractTransition) -import Ouroboros.Network.Testing.Data.AbsBearerInfo - (NonFailingBearerInfoScript(..), AbsBearerInfo (..), - AbsDelay (..), AbsAttenuation (..), AbsSpeed (..), - AbsSDUSize (..), BearerInfoScript (BearerInfoScript)) tests :: TestTree tests = @@ -854,18 +856,19 @@ unidirectionalExperiment timeouts snocket socket clientAndServerData = do (property True) $ zip rs (expectedResult clientAndServerData clientAndServerData) -prop_unidirectional_Sim :: NonFailingBearerInfoScript +prop_unidirectional_Sim :: Script NonFailingBearerInfoScript -> ClientAndServerData Int -> Property -prop_unidirectional_Sim (NonFailingBearerInfoScript script) clientAndServerData = +prop_unidirectional_Sim script clientAndServerData = simulatedPropertyWithTimeout 7200 $ withSnocket nullTracer - (toBearerInfo <$> script) $ \snock _ -> - bracket (Snocket.open snock Snocket.TestFamily) - (Snocket.close snock) $ \fd -> do - Snocket.bind snock fd serverAddr - Snocket.listen snock fd - unidirectionalExperiment simTimeouts snock fd clientAndServerData + ((toBearerInfo <$>) . unNFBIScript <$> script) + $ \snock _ -> + bracket (Snocket.open snock Snocket.TestFamily) + (Snocket.close snock) $ \fd -> do + Snocket.bind snock fd serverAddr + Snocket.listen snock fd + unidirectionalExperiment simTimeouts snock fd clientAndServerData where serverAddr = Snocket.TestAddress (0 :: Int) @@ -1015,11 +1018,11 @@ bidirectionalExperiment )) -prop_bidirectional_Sim :: NonFailingBearerInfoScript -> ClientAndServerData Int -> ClientAndServerData Int -> Property -prop_bidirectional_Sim (NonFailingBearerInfoScript script) data0 data1 = +prop_bidirectional_Sim :: Script NonFailingBearerInfoScript -> ClientAndServerData Int -> ClientAndServerData Int -> Property +prop_bidirectional_Sim script data0 data1 = simulatedPropertyWithTimeout 7200 $ withSnocket sayTracer - (toBearerInfo <$> script) + ((toBearerInfo <$>) . unNFBIScript <$> script) $ \snock _ -> bracket ((,) <$> Snocket.open snock Snocket.TestFamily <*> Snocket.open snock Snocket.TestFamily) @@ -2012,11 +2015,11 @@ verifyRemoteTransitionOrder (h:t) = go t h -- prop_connection_manager_valid_transitions :: Int -> ArbDataFlow - -> BearerInfoScript + -> Script BearerInfoScript -> MultiNodeScript Int TestAddr -> Property prop_connection_manager_valid_transitions serverAcc (ArbDataFlow dataFlow) - (BearerInfoScript biScript) + biScript script@(MultiNodeScript events) = let trace = runSimTrace sim @@ -2073,7 +2076,7 @@ prop_connection_manager_valid_transitions serverAcc (ArbDataFlow dataFlow) where sim :: IOSim s () sim = multiNodeSim serverAcc dataFlow - biScript + (unBIScript <$> biScript) maxAcceptedConnectionsLimit events -- | Property wrapping `multinodeExperiment`. @@ -2083,11 +2086,11 @@ prop_connection_manager_valid_transitions serverAcc (ArbDataFlow dataFlow) -- prop_connection_manager_no_invalid_traces :: Int -> ArbDataFlow - -> BearerInfoScript + -> Script BearerInfoScript -> MultiNodeScript Int TestAddr -> Property prop_connection_manager_no_invalid_traces serverAcc (ArbDataFlow dataFlow) - (BearerInfoScript biScript) + biScript (MultiNodeScript events) = let trace = runSimTrace sim @@ -2123,7 +2126,7 @@ prop_connection_manager_no_invalid_traces serverAcc (ArbDataFlow dataFlow) where sim :: IOSim s () sim = multiNodeSim serverAcc dataFlow - biScript + (unBIScript <$> biScript) maxAcceptedConnectionsLimit events -- | Property wrapping `multinodeExperiment`. @@ -2132,11 +2135,11 @@ prop_connection_manager_no_invalid_traces serverAcc (ArbDataFlow dataFlow) -- prop_connection_manager_valid_transition_order :: Int -> ArbDataFlow - -> BearerInfoScript + -> Script BearerInfoScript -> MultiNodeScript Int TestAddr -> Property prop_connection_manager_valid_transition_order serverAcc (ArbDataFlow dataFlow) - (BearerInfoScript biScript) + biScript script@(MultiNodeScript events) = let trace = runSimTrace sim @@ -2159,7 +2162,7 @@ prop_connection_manager_valid_transition_order serverAcc (ArbDataFlow dataFlow) where sim :: IOSim s () sim = multiNodeSim serverAcc dataFlow - biScript + (unBIScript <$> biScript) maxAcceptedConnectionsLimit events -- | Check connection manager counters in `multinodeExperiment`. @@ -2176,11 +2179,11 @@ prop_connection_manager_valid_transition_order serverAcc (ArbDataFlow dataFlow) -- prop_connection_manager_counters :: Int -> ArbDataFlow - -> NonFailingBearerInfoScript + -> Script NonFailingBearerInfoScript -> MultiNodeScript Int TestAddr -> Property prop_connection_manager_counters serverAcc (ArbDataFlow dataFlow) - (NonFailingBearerInfoScript nfbiScript) + nfbiScript (MultiNodeScript events) = let trace = runSimTrace sim @@ -2334,7 +2337,7 @@ prop_connection_manager_counters serverAcc (ArbDataFlow dataFlow) sim = do mb <- timeout 7200 ( withSnocket nullTracer - (toBearerInfo <$> nfbiScript) + ((toBearerInfo <$>) . unNFBIScript <$> nfbiScript) $ \snocket getState -> multinodeExperiment (sayTracer <> Tracer traceM) (sayTracer <> Tracer traceM) @@ -2359,11 +2362,11 @@ prop_connection_manager_counters serverAcc (ArbDataFlow dataFlow) -- prop_inbound_governor_valid_transitions :: Int -> ArbDataFlow - -> BearerInfoScript + -> Script BearerInfoScript -> MultiNodeScript Int TestAddr -> Property prop_inbound_governor_valid_transitions serverAcc (ArbDataFlow dataFlow) - (BearerInfoScript biScript) + biScript script@(MultiNodeScript events) = let trace = runSimTrace sim @@ -2392,7 +2395,7 @@ prop_inbound_governor_valid_transitions serverAcc (ArbDataFlow dataFlow) where sim :: IOSim s () sim = multiNodeSim serverAcc dataFlow - biScript + (unBIScript <$> biScript) maxAcceptedConnectionsLimit events -- | Property wrapping `multinodeExperiment`. @@ -2401,11 +2404,11 @@ prop_inbound_governor_valid_transitions serverAcc (ArbDataFlow dataFlow) -- prop_inbound_governor_no_unsupported_state :: Int -> ArbDataFlow - -> BearerInfoScript + -> Script BearerInfoScript -> MultiNodeScript Int TestAddr -> Property prop_inbound_governor_no_unsupported_state serverAcc (ArbDataFlow dataFlow) - (BearerInfoScript biScript) + biScript script@(MultiNodeScript events) = let trace = runSimTrace sim @@ -2444,7 +2447,7 @@ prop_inbound_governor_no_unsupported_state serverAcc (ArbDataFlow dataFlow) where sim :: IOSim s () sim = multiNodeSim serverAcc dataFlow - biScript + (unBIScript <$> biScript) maxAcceptedConnectionsLimit events -- | Property wrapping `multinodeExperiment`. @@ -2454,11 +2457,11 @@ prop_inbound_governor_no_unsupported_state serverAcc (ArbDataFlow dataFlow) -- prop_inbound_governor_no_invalid_traces :: Int -> ArbDataFlow - -> BearerInfoScript + -> Script BearerInfoScript -> MultiNodeScript Int TestAddr -> Property prop_inbound_governor_no_invalid_traces serverAcc (ArbDataFlow dataFlow) - (BearerInfoScript absBi) + biScript (MultiNodeScript events) = let trace = runSimTrace sim @@ -2491,7 +2494,7 @@ prop_inbound_governor_no_invalid_traces serverAcc (ArbDataFlow dataFlow) where sim :: IOSim s () sim = multiNodeSim serverAcc dataFlow - absBi + (unBIScript <$> biScript) maxAcceptedConnectionsLimit events -- | Property wrapping `multinodeExperiment`. @@ -2500,11 +2503,11 @@ prop_inbound_governor_no_invalid_traces serverAcc (ArbDataFlow dataFlow) -- prop_inbound_governor_valid_transition_order :: Int -> ArbDataFlow - -> BearerInfoScript + -> Script BearerInfoScript -> MultiNodeScript Int TestAddr -> Property prop_inbound_governor_valid_transition_order serverAcc (ArbDataFlow dataFlow) - (BearerInfoScript biScript) + biScript script@(MultiNodeScript events) = let trace = runSimTrace sim @@ -2530,7 +2533,7 @@ prop_inbound_governor_valid_transition_order serverAcc (ArbDataFlow dataFlow) where sim :: IOSim s () sim = multiNodeSim serverAcc dataFlow - biScript + (unBIScript <$> biScript) maxAcceptedConnectionsLimit events -- | Check inbound governor counters in `multinodeExperiment`. @@ -2539,11 +2542,11 @@ prop_inbound_governor_valid_transition_order serverAcc (ArbDataFlow dataFlow) -- prop_inbound_governor_counters :: Int -> ArbDataFlow - -> NonFailingBearerInfoScript + -> Script NonFailingBearerInfoScript -> MultiNodeScript Int TestAddr -> Property prop_inbound_governor_counters serverAcc (ArbDataFlow dataFlow) - (NonFailingBearerInfoScript nfbiScript) + nfbiScript script@(MultiNodeScript events) = let trace = runSimTrace sim @@ -2627,7 +2630,7 @@ prop_inbound_governor_counters serverAcc (ArbDataFlow dataFlow) sim :: IOSim s () sim = multiNodeSim serverAcc dataFlow - nfbiScript + (unNFBIScript <$> nfbiScript) maxAcceptedConnectionsLimit events -- | Property wrapping `multinodeExperiment` that has a generator optimized for triggering @@ -2638,11 +2641,11 @@ prop_inbound_governor_counters serverAcc (ArbDataFlow dataFlow) -- Manager. -- prop_connection_manager_pruning :: Int - -> NonFailingBearerInfoScript + -> Script NonFailingBearerInfoScript -> MultiNodePruningScript Int -> Property prop_connection_manager_pruning serverAcc - (NonFailingBearerInfoScript nfbiScript) + nfbiScript (MultiNodePruningScript acceptedConnLimit events) = let trace = runSimTrace sim @@ -2697,7 +2700,8 @@ prop_connection_manager_pruning serverAcc $ abstractTransitionEvents where sim :: IOSim s () - sim = multiNodeSim serverAcc Duplex nfbiScript + sim = multiNodeSim serverAcc Duplex + (unNFBIScript <$> nfbiScript) acceptedConnLimit events -- | Property wrapping `multinodeExperiment` that has a generator optimized for triggering @@ -2708,11 +2712,11 @@ prop_connection_manager_pruning serverAcc -- Inbound Governor. -- prop_inbound_governor_pruning :: Int - -> NonFailingBearerInfoScript + -> Script NonFailingBearerInfoScript -> MultiNodePruningScript Int -> Property prop_inbound_governor_pruning serverAcc - (NonFailingBearerInfoScript nfbiScript) + nfbiScript (MultiNodePruningScript acceptedConnLimit events) = let trace = runSimTrace sim @@ -2789,7 +2793,8 @@ prop_inbound_governor_pruning serverAcc $ (remoteTransitionTraceEvents, inboundGovernorEvents) where sim :: IOSim s () - sim = multiNodeSim serverAcc Duplex nfbiScript + sim = multiNodeSim serverAcc Duplex + (unNFBIScript <$> nfbiScript) acceptedConnLimit events -- | Property wrapping `multinodeExperiment` that has a generator optimized for triggering @@ -2802,11 +2807,11 @@ prop_inbound_governor_pruning serverAcc -- the picked peers belong to the choice set. -- prop_never_above_hardlimit :: Int - -> NonFailingBearerInfoScript + -> Script NonFailingBearerInfoScript -> MultiNodePruningScript Int -> Property prop_never_above_hardlimit serverAcc - (NonFailingBearerInfoScript nfbiScript) + nfbiScript (MultiNodePruningScript acceptedConnLimit@AcceptedConnectionsLimit { acceptedConnectionsHardLimit = hardlimit } @@ -2869,7 +2874,8 @@ prop_never_above_hardlimit serverAcc $ connectionManagerEvents where sim :: IOSim s () - sim = multiNodeSim serverAcc Duplex nfbiScript + sim = multiNodeSim serverAcc Duplex + (unNFBIScript <$> nfbiScript) acceptedConnLimit events @@ -2894,7 +2900,8 @@ unit_server_accept_error ioErrType ioErrThrowOrReturn = Nothing -> property False ) $ withSnocket nullTracer - (singletonScript bearerAttenuation ) + ( singletonScript + $ singletonScript bearerAttenuation ) $ \snock _ -> bracket ((,) <$> Snocket.open snock Snocket.TestFamily <*> Snocket.open snock Snocket.TestFamily) @@ -2970,7 +2977,7 @@ unit_server_accept_error ioErrType ioErrThrowOrReturn = multiNodeSim :: (Serialise req, Show req, Eq req, Typeable req) => req -> DataFlow - -> Script AbsBearerInfo + -> Script (Script AbsBearerInfo) -> AcceptedConnectionsLimit -> [ConnectionEvent req TestAddr] -> IOSim s () @@ -2978,7 +2985,7 @@ multiNodeSim serverAcc dataFlow script acceptedConnLimit events = do mb <- timeout 7200 ( withSnocket nullTracer - (toBearerInfo <$> script) + ((toBearerInfo <$>) <$> script) $ \snocket _ -> multinodeExperiment (Tracer traceM) (Tracer traceM) @@ -3002,8 +3009,13 @@ unit_connection_terminated_when_negotiating :: Property unit_connection_terminated_when_negotiating = let arbDataFlow = ArbDataFlow Unidirectional absBearerInfo = - BearerInfoScript - $ singletonScript + Script + $ NonEmpty.fromList + $ replicate 4 + $ BearerInfoScript + $ Script + $ NonEmpty.fromList + $ repeat $ AbsBearerInfo { abiConnectionDelay = SmallDelay , abiInboundAttenuation = NoAttenuation FastSpeed diff --git a/ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs b/ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs index 7a6d004a76b..4635186eb16 100644 --- a/ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs +++ b/ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs @@ -66,7 +66,9 @@ import Network.TypedProtocol.ReqResp.Client import Network.TypedProtocol.ReqResp.Server import Test.Ouroboros.Network.Orphans () -- ShowProxy ReqResp instance -import Ouroboros.Network.Testing.Data.Script (Script(..)) +-- ShowProxy ReqResp instance +import Ouroboros.Network.Testing.Data.Script + (Script(..), singletonScript) import Test.QuickCheck hiding (Result (..)) import Test.QuickCheck.Instances.ByteString @@ -176,11 +178,12 @@ clientServerSimulation , Show payload , Ord (Async m ()) ) - => Script BearerInfo + => Script (Script BearerInfo) -> [payload] -> m (Maybe Bool) clientServerSimulation script payloads = - withSnocket nullTracer script $ \snocket _ -> + withSnocket nullTracer script + $ \snocket _ -> withAsync (server snocket) $ \_serverAsync -> do res <- untilSuccess (client snocket) return (Just res) @@ -338,8 +341,8 @@ toBearerInfo abi = -- Properties -- -prop_client_server :: [ByteString] -> BearerInfoScript -> Property -prop_client_server payloads (BearerInfoScript script) = +prop_client_server :: [ByteString] -> Script BearerInfoScript -> Property +prop_client_server payloads (Script script) = let tr = runSimTrace $ clientServerSimulation script' payloads in -- Debug.traceShow script $ case traceResult True tr of @@ -356,7 +359,10 @@ prop_client_server payloads (BearerInfoScript script) = Right Nothing -> property False Right (Just b) -> property b where - script' = toBearerInfo <$> script + Script noAttenuationScript = + singletonScript (BearerInfoScript (singletonScript absNoAttenuation)) + script' = + (toBearerInfo <$>) . unBIScript <$> Script (script <> noAttenuationScript) -- diff --git a/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/AbsBearerInfo.hs b/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/AbsBearerInfo.hs index 95b0f88d413..359a0b0c275 100644 --- a/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/AbsBearerInfo.hs +++ b/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/AbsBearerInfo.hs @@ -241,24 +241,16 @@ instance Arbitrary AbsBearerInfo where | a <- shrink (abiSDUSize abi) ] -newtype BearerInfoScript = BearerInfoScript (Script AbsBearerInfo) +newtype BearerInfoScript = + BearerInfoScript { unBIScript :: Script AbsBearerInfo } deriving Show via (Script AbsBearerInfo) deriving stock Eq fixupAbsBearerInfos :: [AbsBearerInfo] -> [AbsBearerInfo] fixupAbsBearerInfos bis = if canFail (last bis) - then bis ++ [abiNoAttenuation] + then bis ++ [absNoAttenuation] else bis - where - abiNoAttenuation = AbsBearerInfo { - abiConnectionDelay = NormalDelay, - abiInboundAttenuation = NoAttenuation NormalSpeed, - abiOutboundAttenuation = NoAttenuation NormalSpeed, - abiInboundWriteFailure = Nothing, - abiOutboundWriteFailure = Nothing, - abiSDUSize = NormalSDU - } instance Arbitrary BearerInfoScript where arbitrary = BearerInfoScript @@ -270,7 +262,8 @@ instance Arbitrary BearerInfoScript where shrink (BearerInfoScript (Script script)) = [ BearerInfoScript (Script script') | script' - <- map (NonEmpty.fromList . fixupAbsBearerInfos) . filter (not . List.null) + <- map (NonEmpty.fromList . fixupAbsBearerInfos) + . filter (not . List.null) -- TODO: shrinking of 'AbsBearerInfo' needs to be more aggresive to use -- @shrinkList shrink@ $ shrinkList (const []) (NonEmpty.toList script) @@ -278,7 +271,7 @@ instance Arbitrary BearerInfoScript where ] newtype NonFailingBearerInfoScript = - NonFailingBearerInfoScript (Script AbsBearerInfo) + NonFailingBearerInfoScript { unNFBIScript :: Script AbsBearerInfo } deriving Show via (Script AbsBearerInfo) deriving stock Eq @@ -287,11 +280,12 @@ toNonFailingBearerInfoScript (BearerInfoScript script) = NonFailingBearerInfoScript $ fmap unfail script where unfail :: AbsBearerInfo -> AbsBearerInfo - unfail bi = bi { abiInboundWriteFailure = Nothing - , abiOutboundWriteFailure = Nothing - , abiInboundAttenuation = unfailAtt $ abiInboundAttenuation bi - , abiOutboundAttenuation = unfailAtt $ abiOutboundAttenuation bi - } + unfail bi = + bi { abiInboundWriteFailure = Nothing + , abiOutboundWriteFailure = Nothing + , abiInboundAttenuation = unfailAtt $ abiInboundAttenuation bi + , abiOutboundAttenuation = unfailAtt $ abiOutboundAttenuation bi + } unfailAtt (ErrorInterval speed _ _) = NoAttenuation speed unfailAtt (SpeedAttenuation speed _ _) = NoAttenuation speed @@ -299,4 +293,5 @@ toNonFailingBearerInfoScript (BearerInfoScript script) = instance Arbitrary NonFailingBearerInfoScript where arbitrary = toNonFailingBearerInfoScript <$> arbitrary - shrink (NonFailingBearerInfoScript script) = toNonFailingBearerInfoScript <$> shrink (BearerInfoScript script) + shrink (NonFailingBearerInfoScript script) = + toNonFailingBearerInfoScript <$> shrink (BearerInfoScript script) diff --git a/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/Script.hs b/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/Script.hs index 441592630ed..a66bd1776c8 100644 --- a/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/Script.hs +++ b/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/Script.hs @@ -11,6 +11,7 @@ module Ouroboros.Network.Testing.Data.Script ( initScript, stepScript, stepScriptSTM, + stepScriptSTMTx, initScript', stepScript', stepScriptSTM', @@ -79,6 +80,14 @@ stepScriptSTM scriptVar = do x':xs' -> LazySTM.writeTVar scriptVar (Script (x' :| xs')) return x +stepScriptSTMTx :: MonadSTMTx m => TVar_ m (Script (m b)) -> m b +stepScriptSTMTx scriptVar = do + Script (x :| xs) <- LazySTM.readTVar scriptVar + case xs of + [] -> return () + x':xs' -> LazySTM.writeTVar scriptVar (Script (x' :| xs')) + x + initScript' :: MonadSTM m => Script a -> m (TVar m (Script a)) initScript' = newTVarIO diff --git a/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/Handshake/Test.hs b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/Handshake/Test.hs index 6a3b7513e3a..5acfc985c12 100644 --- a/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/Handshake/Test.hs +++ b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/Handshake/Test.hs @@ -998,7 +998,7 @@ prop_channel_simultaneous_open_sim codec versionDataCodec clientVersions serverVersions = let attenuation = noAttenuation { biConnectionDelay = 1 } in withSnocket nullTracer - (singletonScript attenuation) + (singletonScript $ singletonScript attenuation) $ \sn _ -> do let addr, addr' :: TestAddress Int addr = Snocket.TestAddress 1