Skip to content

Commit

Permalink
server-test: introduce WithName
Browse files Browse the repository at this point in the history 
Also expose transition tracer by 'withBidirectionalConnectionManager',
what prepares for further changes.
  • Loading branch information
@coot
coot committed Oct 14, 2021
1 parent 111d0f0 commit b85fca1
Showing 1 changed file with 65 additions and 38 deletions.
103 changes: 65 additions & 38 deletions ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs
View file
Expand Up @@ -261,7 +261,7 @@ type ConnectionState_ muxMode peerAddr m a b =
m

withInitiatorOnlyConnectionManager
:: forall peerAddr socket req resp m acc a.
:: forall name peerAddr socket req resp m a.
( ConnectionManagerMonad m

, resp ~ [req]
Expand All @@ -280,8 +280,9 @@ withInitiatorOnlyConnectionManager
, MonadAsync m
, MonadLabelledSTM m
, MonadSay m, Show req
, Show name
)
=> String
=> name
-- ^ identifier (for logging)
-> Timeouts
-> Snocket m socket peerAddr
Expand All @@ -301,9 +302,9 @@ withInitiatorOnlyConnectionManager name timeouts snocket localAddr nextRequests
withConnectionManager
ConnectionManagerArguments {
-- ConnectionManagerTrace
cmTracer = (name,)
cmTracer = WithName name
`contramap` connectionManagerTracer,
cmTrTracer = ((name,) . fmap abstractState)
cmTrTracer = (WithName name . fmap abstractState)
`contramap` nullTracer,
-- MuxTracer
cmMuxTracer = muxTracer,
Expand Down Expand Up @@ -425,7 +426,7 @@ assertRethrowPolicy =
-- across warm \/ how \/ established) protocols.
--
withBidirectionalConnectionManager
:: forall peerAddr socket acc req resp m a.
:: forall name peerAddr socket acc req resp m a.
( ConnectionManagerMonad m

, acc ~ [req], resp ~ [req]
Expand All @@ -436,10 +437,12 @@ withBidirectionalConnectionManager
, MonadAsync m
, MonadLabelledSTM m
, MonadSay m, Show req
, Show name
)
=> String
=> name
-> Timeouts
-- ^ identifier (for logging)
-> Tracer m (WithName name (AbstractTransitionTrace peerAddr))
-> Snocket m socket peerAddr
-> socket
-- ^ listening socket
Expand All @@ -457,21 +460,21 @@ withBidirectionalConnectionManager
-> Async m Void
-> m a)
-> m a
withBidirectionalConnectionManager name timeouts snocket socket localAddress
withBidirectionalConnectionManager name timeouts trTracer snocket socket localAddress
accumulatorInit nextRequests k = do
mainThreadId <- myThreadId
inbgovControlChannel <- Server.newControlChannel
-- we are not using the randomness
observableStateVar <- Server.newObservableStateVarFromSeed 0
let muxTracer = (name,) `contramap` nullTracer -- mux tracer
let muxTracer = WithName name `contramap` nullTracer -- mux tracer

withConnectionManager
ConnectionManagerArguments {
-- ConnectionManagerTrace
cmTracer = (name,)
cmTracer = WithName name
`contramap` connectionManagerTracer,
cmTrTracer = ((name,) . fmap abstractState)
`contramap` nullTracer,
cmTrTracer = (WithName name . fmap abstractState)
`contramap` trTracer,
-- MuxTracer
cmMuxTracer = muxTracer,
cmIPv4Address = localAddress,
Expand All @@ -494,7 +497,7 @@ withBidirectionalConnectionManager name timeouts snocket socket localAddress
serverMiniProtocolBundle
HandshakeArguments {
-- TraceSendRecv
haHandshakeTracer = (name,) `contramap` nullTracer,
haHandshakeTracer = WithName name `contramap` nullTracer,
haHandshakeCodec = unversionedHandshakeCodec,
haVersionDataCodec = cborTermVersionDataCodec unversionedProtocolDataCodec,
haAcceptVersion = acceptableVersion,
Expand All @@ -514,8 +517,8 @@ withBidirectionalConnectionManager name timeouts snocket socket localAddress
ServerArguments {
serverSockets = socket :| [],
serverSnocket = snocket,
serverTracer = (name,) `contramap` nullTracer, -- ServerTrace
serverInboundGovernorTracer = (name,) `contramap` nullTracer, -- InboundGovernorTrace
serverTracer = WithName name `contramap` nullTracer, -- ServerTrace
serverInboundGovernorTracer = WithName name `contramap` nullTracer, -- InboundGovernorTrace
serverConnectionLimits = AcceptedConnectionsLimit maxBound maxBound 0,
serverConnectionManager = connectionManager,
serverInboundIdleTimeout = tProtocolIdleTimeout timeouts,
Expand Down Expand Up @@ -589,13 +592,13 @@ withBidirectionalConnectionManager name timeouts snocket socket localAddress
reqRespInitiatorAndResponder protocolNum accInit nextRequest =
InitiatorAndResponderProtocol
(MuxPeer
((name,"Initiator",protocolNum,) `contramap` nullTracer) -- TraceSendRecv
(WithName (name,"Initiator",protocolNum) `contramap` nullTracer) -- TraceSendRecv
codecReqResp
(Effect $ do
reqs <- atomically nextRequest
pure $ reqRespClientPeer (reqRespClientMap reqs)))
(MuxPeer
((name,"Responder",protocolNum,) `contramap` nullTracer) -- TraceSendRecv
(WithName (name,"Responder",protocolNum) `contramap` nullTracer) -- TraceSendRecv
codecReqResp
(reqRespServerPeer $ reqRespServerMapAccumL' accInit))

Expand Down Expand Up @@ -721,7 +724,7 @@ unidirectionalExperiment timeouts snocket socket clientAndServerData = do
withInitiatorOnlyConnectionManager
"client" timeouts snocket Nothing nextReqs
$ \connectionManager ->
withBidirectionalConnectionManager "server" timeouts
withBidirectionalConnectionManager "server" timeouts nullTracer
snocket socket Nothing
[accumulatorInit clientAndServerData]
noNextRequests
Expand Down Expand Up @@ -823,13 +826,13 @@ bidirectionalExperiment
lock <- newTMVarIO ()
nextRequests0 <- oneshotNextRequests clientAndServerData0
nextRequests1 <- oneshotNextRequests clientAndServerData1
withBidirectionalConnectionManager "node-0" timeouts
withBidirectionalConnectionManager "node-0" timeouts nullTracer
snocket socket0
(Just localAddr0)
[accumulatorInit clientAndServerData0]
nextRequests0
(\connectionManager0 _serverAddr0 _serverAsync0 ->
withBidirectionalConnectionManager "node-1" timeouts
withBidirectionalConnectionManager "node-1" timeouts nullTracer
snocket socket1
(Just localAddr1)
[accumulatorInit clientAndServerData1]
Expand Down Expand Up @@ -1118,6 +1121,18 @@ data ConnectionHandlerMessage peerAddr req
-- ^ Run a bundle of mini protocols against the server at the given address (requires an active
-- connection).


data Name addr = Client addr
| Node addr
| MainServer
deriving Eq

instance Show addr => Show (Name addr) where
show (Client addr) = "client-" ++ show addr
show (Node addr) = "node-" ++ show addr
show MainServer = "main-server"


-- | Run a central server that talks to any number of clients and other nodes.
multinodeExperiment
:: forall peerAddr socket acc req resp m.
Expand Down Expand Up @@ -1155,7 +1170,7 @@ multinodeExperiment snocket addrFamily serverAddr accInit (MultiNodeScript scrip
-- mini-protocol run.
propVar <- newTVarIO (property True)
labelTVarIO propVar "propVar"
cc <- startServerConnectionHandler "main-server" [accInit] serverAddr lock propVar jobpool
cc <- startServerConnectionHandler MainServer [accInit] serverAddr lock propVar jobpool
loop lock (Map.singleton serverAddr [accInit]) (Map.singleton serverAddr cc) propVar script jobpool
where

Expand All @@ -1174,12 +1189,12 @@ multinodeExperiment snocket addrFamily serverAddr accInit (MultiNodeScript scrip

StartClient delay localAddr -> do
threadDelay delay
cc <- startClientConnectionHandler ("client-" ++ show localAddr) localAddr lock propVar jobpool
cc <- startClientConnectionHandler (Client localAddr) localAddr lock propVar jobpool
loop lock nodeAccs (Map.insert localAddr cc servers) propVar events jobpool

StartServer delay localAddr nodeAcc -> do
threadDelay delay
cc <- startServerConnectionHandler ("node-" ++ show localAddr) [nodeAcc] localAddr lock propVar jobpool
cc <- startServerConnectionHandler (Node localAddr) [nodeAcc] localAddr lock propVar jobpool
loop lock (Map.insert localAddr [nodeAcc] nodeAccs) (Map.insert localAddr cc servers) propVar events jobpool

InboundConnection delay nodeAddr -> do
Expand Down Expand Up @@ -1245,16 +1260,17 @@ multinodeExperiment snocket addrFamily serverAddr accInit (MultiNodeScript scrip
assertProperty :: StrictTVar m Property -> Property -> STM m ()
assertProperty propVar p = modifyTVar propVar (.&&. p)

startClientConnectionHandler :: String -> peerAddr
startClientConnectionHandler :: Name peerAddr
-> peerAddr
-> StrictTMVar m ()
-> StrictTVar m Property
-> JobPool () m (Maybe SomeException)
-> m (TQueue m (ConnectionHandlerMessage peerAddr req))
startClientConnectionHandler name localAddr lock propVar jobpool = do
cc <- atomically $ newTQueue
labelTQueueIO cc $ "cc/" ++ name
labelTQueueIO cc $ "cc/" ++ show name
connVar <- newTVarIO Map.empty
labelTVarIO connVar $ "connVar/" ++ name
labelTVarIO connVar $ "connVar/" ++ show name
threadId <- myThreadId
forkJob jobpool
$ Job
Expand All @@ -1272,10 +1288,12 @@ multinodeExperiment snocket addrFamily serverAddr accInit (MultiNodeScript scrip
)
(return . Just)
()
name
(show name)
return cc

startServerConnectionHandler :: String -> acc -> peerAddr
startServerConnectionHandler :: Name peerAddr
-> acc
-> peerAddr
-> StrictTMVar m ()
-> StrictTVar m Property
-> JobPool () m (Maybe SomeException)
Expand All @@ -1285,14 +1303,15 @@ multinodeExperiment snocket addrFamily serverAddr accInit (MultiNodeScript scrip
Snocket.bind snocket fd localAddr
Snocket.listen snocket fd
cc <- atomically $ newTQueue
labelTQueueIO cc $ "cc/" ++ name
labelTQueueIO cc $ "cc/" ++ show name
connVar <- newTVarIO Map.empty
labelTVarIO connVar $ "connVar/" ++ name
labelTVarIO connVar $ "connVar/" ++ show name
threadId <- myThreadId
forkJob jobpool
$ Job
( withBidirectionalConnectionManager
name simTimeouts snocket fd (Just localAddr) serverAcc
name simTimeouts nullTracer
snocket fd (Just localAddr) serverAcc
(mkNextRequests connVar)
(\ connectionManager _ _serverAsync -> do
connectionLoop SingInitiatorResponderMode localAddr lock propVar cc connectionManager Map.empty connVar
Expand All @@ -1307,7 +1326,7 @@ multinodeExperiment snocket addrFamily serverAddr accInit (MultiNodeScript scrip
)
(return . Just)
()
name
(show name)
return cc

connectionLoop
Expand Down Expand Up @@ -1410,6 +1429,14 @@ ppScript (MultiNodeScript script) = intercalate "\n" $ go 0 script
-- Utils
--

data WithName name event = WithName {
wnName :: name,
wnEvent :: event
}
deriving Show

type AbstractTransitionTrace addr = TransitionTrace' addr AbstractState

debugTracer :: (MonadSay m, MonadTime m, Show a) => Tracer m a
debugTracer = Tracer $
\msg -> (,msg) <$> getCurrentTime >>= say . show
Expand All @@ -1426,22 +1453,22 @@ connectionManagerTracer
, Show peerAddr
, Show versionNumber
, Show versionData
, Show name
)
=> Tracer m ( String
, ConnectionManagerTrace peerAddr
(ConnectionHandlerTrace versionNumber versionData)
)
=> Tracer m (WithName name
(ConnectionManagerTrace peerAddr
(ConnectionHandlerTrace versionNumber versionData)))
connectionManagerTracer =
Tracer
$ \msg ->
case msg of
(_, TrConnectError{})
WithName _ TrConnectError{}
-> -- this way 'debugTracer' does not trigger a warning :)
traceWith debugTracer msg
(_, TrConnectionHandler _ TrError {})
WithName _ (TrConnectionHandler _ TrError {})
->
traceWith debugTracer msg
(_, _) ->
WithName _ _ ->
pure ()


Expand Down

0 comments on commit b85fca1

Please sign in to comment.