Skip to content

Commit

Permalink
server-test: test unidrectional server
Browse files Browse the repository at this point in the history
  • Loading branch information
@coot
coot committed Oct 14, 2021
1 parent f7610db commit def2ed4
Showing 1 changed file with 65 additions and 30 deletions.
95 changes: 65 additions & 30 deletions ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs
View file
Expand Up @@ -291,6 +291,7 @@ withInitiatorOnlyConnectionManager
=> name
-- ^ identifier (for logging)
-> Timeouts
-> Tracer m (WithName name (AbstractTransitionTrace peerAddr))
-> Snocket m socket peerAddr
-- ^ series of request possible to do with the bidirectional connection
-- manager towards some peer.
Expand All @@ -302,7 +303,7 @@ withInitiatorOnlyConnectionManager
UnversionedProtocol ByteString m [resp] Void
-> m a)
-> m a
withInitiatorOnlyConnectionManager name timeouts snocket localAddr nextRequests k = do
withInitiatorOnlyConnectionManager name timeouts trTracer snocket localAddr nextRequests k = do
mainThreadId <- myThreadId
let muxTracer = (name,) `contramap` nullTracer -- mux tracer
withConnectionManager
Expand All @@ -311,14 +312,14 @@ withInitiatorOnlyConnectionManager name timeouts snocket localAddr nextRequests
cmTracer = WithName name
`contramap` connectionManagerTracer,
cmTrTracer = (WithName name . fmap abstractState)
`contramap` nullTracer,
`contramap` trTracer,
-- MuxTracer
cmMuxTracer = muxTracer,
cmIPv4Address = localAddr,
cmIPv6Address = Nothing,
cmAddressType = \_ -> Just IPv4Address,
cmSnocket = snocket,
connectionDataFlow = const Duplex,
connectionDataFlow = const Unidirectional,
cmPrunePolicy = simplePrunePolicy,
cmConnectionsLimits = AcceptedConnectionsLimit {
acceptedConnectionsHardLimit = maxBound,
Expand Down Expand Up @@ -719,7 +720,7 @@ unidirectionalExperiment
unidirectionalExperiment timeouts snocket socket clientAndServerData = do
nextReqs <- oneshotNextRequests clientAndServerData
withInitiatorOnlyConnectionManager
"client" timeouts snocket Nothing nextReqs
"client" timeouts nullTracer snocket Nothing nextReqs
$ \connectionManager ->
withBidirectionalConnectionManager "server" timeouts nullTracer
snocket socket Nothing
Expand Down Expand Up @@ -1211,13 +1212,16 @@ multinodeExperiment
(AbstractTransitionTrace peerAddr))
-> Snocket m socket peerAddr
-> Snocket.AddressFamily peerAddr
-- ^ either run the main node in 'Duplex' or 'Unidirectional' mode.
-> peerAddr
-> req
-> DataFlow
-> MultiNodeScript req peerAddr
-> m ()
multinodeExperiment trTracer snocket addrFamily serverAddr accInit (MultiNodeScript script) =
multinodeExperiment trTracer snocket addrFamily serverAddr accInit
dataFlow0 (MultiNodeScript script) =
withJobPool $ \jobpool -> do
cc <- startServerConnectionHandler MainServer [accInit] serverAddr jobpool
cc <- startServerConnectionHandler MainServer dataFlow0 [accInit] serverAddr jobpool
loop (Map.singleton serverAddr [accInit]) (Map.singleton serverAddr cc) script jobpool
where

Expand All @@ -1237,7 +1241,7 @@ multinodeExperiment trTracer snocket addrFamily serverAddr accInit (MultiNodeScr

StartServer delay localAddr nodeAcc -> do
threadDelay delay
cc <- startServerConnectionHandler (Node localAddr) [nodeAcc] localAddr jobpool
cc <- startServerConnectionHandler (Node localAddr) Duplex [nodeAcc] localAddr jobpool
loop (Map.insert localAddr [nodeAcc] nodeAccs) (Map.insert localAddr cc servers) events jobpool

InboundConnection delay nodeAddr -> do
Expand Down Expand Up @@ -1300,7 +1304,7 @@ multinodeExperiment trTracer snocket addrFamily serverAddr accInit (MultiNodeScr
forkJob jobpool
$ Job
( withInitiatorOnlyConnectionManager
name simTimeouts snocket (Just localAddr) (mkNextRequests connVar)
name simTimeouts nullTracer snocket (Just localAddr) (mkNextRequests connVar)
( \ connectionManager -> do
connectionLoop SingInitiatorMode localAddr cc connectionManager Map.empty connVar
return Nothing
Expand All @@ -1317,11 +1321,12 @@ multinodeExperiment trTracer snocket addrFamily serverAddr accInit (MultiNodeScr
return cc

startServerConnectionHandler :: Name peerAddr
-> DataFlow
-> acc
-> peerAddr
-> JobPool () m (Maybe SomeException)
-> m (TQueue m (ConnectionHandlerMessage peerAddr req))
startServerConnectionHandler name serverAcc localAddr jobpool = do
startServerConnectionHandler name dataFlow serverAcc localAddr jobpool = do
fd <- Snocket.open snocket addrFamily
Snocket.bind snocket fd localAddr
Snocket.listen snocket fd
Expand All @@ -1330,27 +1335,47 @@ multinodeExperiment trTracer snocket addrFamily serverAddr accInit (MultiNodeScr
connVar <- newTVarIO Map.empty
labelTVarIO connVar $ "connVar/" ++ show name
threadId <- myThreadId
forkJob jobpool
$ Job
( withBidirectionalConnectionManager
name simTimeouts trTracer
snocket fd (Just localAddr) serverAcc
(mkNextRequests connVar)
( \ connectionManager _ _serverAsync -> do
connectionLoop SingInitiatorResponderMode localAddr cc connectionManager Map.empty connVar
return Nothing
let job =
case dataFlow of
Duplex ->
Job ( withBidirectionalConnectionManager
name simTimeouts trTracer snocket fd (Just localAddr) serverAcc
(mkNextRequests connVar)
( \ connectionManager _ _serverAsync -> do
connectionLoop SingInitiatorResponderMode localAddr cc connectionManager Map.empty connVar
return Nothing
)
`catch` (\(e :: SomeException) ->
case fromException e :: Maybe MuxRuntimeError of
Nothing -> throwIO e
Just {} -> throwTo threadId e
>> throwIO e)
`finally` Snocket.close snocket fd
)
`catch` (\(e :: SomeException) ->
case fromException e :: Maybe MuxRuntimeError of
Nothing -> throwIO e
Just {} -> throwTo threadId e
>> throwIO e)
`finally` Snocket.close snocket fd
)
(return . Just)
()
(show name)
(return . Just)
()
(show name)
Unidirectional ->
Job ( withInitiatorOnlyConnectionManager
name simTimeouts trTracer snocket (Just localAddr)
(mkNextRequests connVar)
( \ connectionManager -> do
connectionLoop SingInitiatorMode localAddr cc connectionManager Map.empty connVar
return Nothing
)
`catch` (\(e :: SomeException) ->
case fromException e :: Maybe MuxRuntimeError of
Nothing -> throwIO e
Just {} -> throwTo threadId e
>> throwIO e)
`finally` Snocket.close snocket fd
)
(return . Just)
()
(show name)
forkJob jobpool job
return cc
where

connectionLoop
:: (HasInitiator muxMode ~ True)
Expand Down Expand Up @@ -1489,6 +1514,15 @@ instance Semigroup AllProperty where
instance Monoid AllProperty where
mempty = AllProperty (property True)

newtype ArbDataFlow = ArbDataFlow DataFlow
deriving Show

instance Arbitrary ArbDataFlow where
arbitrary = ArbDataFlow <$> frequency [ (3, pure Duplex)
, (1, pure Unidirectional)
]
shrink (ArbDataFlow Duplex) = [ArbDataFlow Unidirectional]
shrink (ArbDataFlow Unidirectional) = []

data ActivityType
= IdleConn
Expand Down Expand Up @@ -1523,8 +1557,8 @@ data EffectiveDataFlow
deriving (Eq, Show)

-- | Property wrapping `multinodeExperiment`.
prop_multinode_Sim :: Int -> MultiNodeScript Int TestAddr -> Property
prop_multinode_Sim serverAcc script =
prop_multinode_Sim :: Int -> ArbDataFlow -> MultiNodeScript Int TestAddr -> Property
prop_multinode_Sim serverAcc (ArbDataFlow dataFlow) script =
let evs :: Trace (SimResult ()) (AbstractTransitionTrace SimAddr)
evs = fmap wnEvent
. Trace.filter ((MainServer ==) . wnName)
Expand All @@ -1545,6 +1579,7 @@ prop_multinode_Sim serverAcc script =
Snocket.TestFamily
(Snocket.TestAddress 0)
serverAcc
dataFlow
(unTestAddr <$> script)
)
case mb of
Expand Down

0 comments on commit def2ed4

Please sign in to comment.