Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

coot/framework io tests #4702

Merged
merged 3 commits into from
Oct 27, 2023
Merged

coot/framework io tests #4702

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
89e2754
flake.nix: increase heap size for mux tests
coot Oct 26, 2023
36c4c96
framework-io-tests: run prop_send_recv on ephemeral port
coot Oct 26, 2023
34361cd
framework-io-tests: code style
coot Oct 26, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion flake.nix
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -143,7 +143,7 @@
# don't run checks using Wine when cross compiling
packages.ntp-client.components.tests.test.doCheck = !pkgs.stdenv.hostPlatform.isWindows;
packages.network-mux.components.tests.test.doCheck = !pkgs.stdenv.hostPlatform.isWindows;
packages.network-mux.components.tests.test.preCheck = "export GHCRTS=-M350M";
packages.network-mux.components.tests.test.preCheck = "export GHCRTS=-M500M";
packages.ouroboros-network-api.components.tests.test.doCheck = !pkgs.stdenv.hostPlatform.isWindows;
packages.ouroboros-network-protocols.components.tests.test.doCheck = !pkgs.stdenv.hostPlatform.isWindows;
packages.ouroboros-network-framework.components.tests.sim-tests.doCheck = !pkgs.stdenv.hostPlatform.isWindows;
Expand Down
206 changes: 106 additions & 100 deletions ouroboros-network-framework/io-tests/Test/Ouroboros/Network/Subscription.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -438,7 +438,7 @@ prop_sub_io lr = ioProperty $ withIOManager $ \iocp -> do
c <- readTVar serverCountVar
when (c > 0) retry

serverPortMap <- atomically $ readTVar serverPortMapVar
serverPortMap <- readTVarIO serverPortMapVar
networkState <- newNetworkMutableState
dnsSubscriptionWorker'
(socketSnocket iocp)
Expand Down Expand Up @@ -467,7 +467,7 @@ prop_sub_io lr = ioProperty $ withIOManager $ \iocp -> do

mapM_ wait serverAids

observerdConnectionOrder <- fmap reverse $ atomically $ readTVar observerdConnectionOrderVar
observerdConnectionOrder <- reverse <$> readTVarIO observerdConnectionOrderVar

return $ property $ verifyOrder observerdConnectionOrder

Expand Down Expand Up @@ -536,104 +536,110 @@ prop_send_recv
-> Property
prop_send_recv f xs _first = ioProperty $ withIOManager $ \iocp -> do

let first = Socket.AF_INET6
let lr = LookupResultIO (Right [0]) (Right [0]) first 1
serverPortMap = M.fromList [((Socket.AF_INET, 0), 6062), ((Socket.AF_INET6, 0), 6062)]

responderAddr4:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "6062")
responderAddr6:_ <- Socket.getAddrInfo Nothing (Just "::1") (Just "6062")
let (responderAddr, faultyAddress) = case first of
Socket.AF_INET -> (responderAddr6, responderAddr4)
Socket.AF_INET6 -> (responderAddr4, responderAddr6)
_ -> error "prop_send_recv: invalid address family"
initiatorAddr4:_ <- Socket.getAddrInfo Nothing (Just "127.0.0.1") (Just "0")
initiatorAddr6:_ <- Socket.getAddrInfo Nothing (Just "::1") (Just "0")

firstDoneVar <- newEmptyTMVarIO

cv <- newEmptyTMVarIO
sv <- newEmptyTMVarIO
siblingVar <- newTVarIO 2
tbl <- newConnectionTable
clientTbl <- newConnectionTable

let -- Server Node; only req-resp server
responderApp :: OuroborosApplicationWithMinimalCtx
ResponderMode Socket.SockAddr BL.ByteString IO Void ()
responderApp = testProtocols2 reqRespResponder

reqRespResponder =
ResponderProtocolOnly $
MiniProtocolCb $ \_ctx channel -> do
(r, trailing) <- runPeer (tagTrace "Responder" activeTracer)
ReqResp.codecReqResp
channel
(ReqResp.reqRespServerPeer (ReqResp.reqRespServerMapAccumL (\a -> pure . f a) 0))
atomically $ putTMVar sv r
((), trailing)
<$ waitSiblingSub siblingVar

-- Client Node; only req-resp client
initiatorApp :: OuroborosApplicationWithMinimalCtx
InitiatorMode Socket.SockAddr BL.ByteString IO () Void
initiatorApp = testProtocols2 reqRespInitiator

reqRespInitiator =
InitiatorProtocolOnly $
MiniProtocolCb $ \_ctx channel -> do
(r, trailing) <- runPeer (tagTrace "Initiator" activeTracer)
ReqResp.codecReqResp
channel
(ReqResp.reqRespClientPeer (ReqResp.reqRespClientMap xs))
atomically $ putTMVar cv r
((), trailing) <$
waitSiblingSub siblingVar

peerStatesVar <- newPeerStatesVar
let sn = socketSnocket iocp
withDummyServer faultyAddress $
withServerNode
sn
Mx.makeSocketBearer
((. Just) <$> configureSocket)
nullNetworkServerTracers
(NetworkMutableState tbl peerStatesVar)
(AcceptedConnectionsLimit maxBound maxBound 0)
(Socket.addrAddress responderAddr)
unversionedHandshakeCodec
noTimeLimitsHandshake
unversionedProtocolDataCodec
(HandshakeCallbacks acceptableVersion queryVersion)
(unversionedProtocol (SomeResponderApplication responderApp))
nullErrorPolicies
$ \_ _ -> do
dnsSubscriptionWorker'
sn activeTracer activeTracer activeTracer
(NetworkMutableState clientTbl peerStatesVar)
(return lr)
(withMockResolverIO firstDoneVar serverPortMap)
SubscriptionParams {
spLocalAddresses =
LocalAddresses
(Just $ Socket.addrAddress initiatorAddr4)
(Just $ Socket.addrAddress initiatorAddr6)
Nothing,
spConnectionAttemptDelay = \_ -> Just minConnectionAttemptDelay,
spErrorPolicies = nullErrorPolicies,
spSubscriptionTarget = DnsSubscriptionTarget "shelley-0.iohk.example" 6062 1
}
(\_ -> waitSiblingSTM siblingVar)
(connectToNodeSocket
iocp
unversionedHandshakeCodec
noTimeLimitsHandshake
unversionedProtocolDataCodec
nullNetworkConnectTracers
(HandshakeCallbacks acceptableVersion queryVersion)
(unversionedProtocol initiatorApp))

res <- atomically $ (,) <$> takeTMVar sv <*> takeTMVar cv
return (res == L.mapAccumL f 0 xs)
let lr = LookupResultIO (Right [0]) (Right [0]) Socket.AF_INET6 1
hints = Just $ Socket.defaultHints {Socket.addrSocketType = Socket.Stream}

coot marked this conversation as resolved.
Show resolved Hide resolved
responderAddress0:_ <- Socket.getAddrInfo hints (Just "127.0.0.1") Nothing

initiatorAddr4:_ <- Socket.getAddrInfo hints (Just "127.0.0.1") (Just "0")
initiatorAddr6:_ <- Socket.getAddrInfo hints (Just "::1") (Just "0")

-- listening socket
bracket (Socket.openSocket responderAddress0) Socket.close $ \socket -> do
Socket.bind socket (Socket.addrAddress responderAddress0)
Socket.listen socket 10

responderAddr <- Socket.getSocketName socket
let responderPort = case responderAddr of
Socket.SockAddrInet port _ -> port
_ -> error "impossible happened"
serverPortMap = M.fromList [((Socket.AF_INET, 0), responderPort), ((Socket.AF_INET6, 0), responderPort)]
faultyAddress:_ <- Socket.getAddrInfo Nothing (Just "::1") (Just $ show responderPort)

firstDoneVar <- newEmptyTMVarIO

cv <- newEmptyTMVarIO
sv <- newEmptyTMVarIO
siblingVar <- newTVarIO 2
tbl <- newConnectionTable
clientTbl <- newConnectionTable

let -- Server Node; only req-resp server
responderApp :: OuroborosApplicationWithMinimalCtx
ResponderMode Socket.SockAddr BL.ByteString IO Void ()
responderApp = testProtocols2 reqRespResponder

reqRespResponder =
ResponderProtocolOnly $
MiniProtocolCb $ \_ctx channel -> do
(r, trailing) <- runPeer (tagTrace "Responder" activeTracer)
ReqResp.codecReqResp
channel
(ReqResp.reqRespServerPeer (ReqResp.reqRespServerMapAccumL (\a -> pure . f a) 0))
atomically $ putTMVar sv r
((), trailing)
<$ waitSiblingSub siblingVar

-- Client Node; only req-resp client
initiatorApp :: OuroborosApplicationWithMinimalCtx
InitiatorMode Socket.SockAddr BL.ByteString IO () Void
initiatorApp = testProtocols2 reqRespInitiator

reqRespInitiator =
InitiatorProtocolOnly $
MiniProtocolCb $ \_ctx channel -> do
(r, trailing) <- runPeer (tagTrace "Initiator" activeTracer)
ReqResp.codecReqResp
channel
(ReqResp.reqRespClientPeer (ReqResp.reqRespClientMap xs))
atomically $ putTMVar cv r
((), trailing) <$
waitSiblingSub siblingVar

peerStatesVar <- newPeerStatesVar
let sn = socketSnocket iocp
withDummyServer faultyAddress $
withServerNode'
sn
Mx.makeSocketBearer
nullNetworkServerTracers
(NetworkMutableState tbl peerStatesVar)
(AcceptedConnectionsLimit maxBound maxBound 0)
socket
unversionedHandshakeCodec
noTimeLimitsHandshake
unversionedProtocolDataCodec
(HandshakeCallbacks acceptableVersion queryVersion)
(unversionedProtocol (SomeResponderApplication responderApp))
nullErrorPolicies
$ \_ _ -> do
dnsSubscriptionWorker'
sn activeTracer activeTracer activeTracer
(NetworkMutableState clientTbl peerStatesVar)
(return lr)
(withMockResolverIO firstDoneVar serverPortMap)
SubscriptionParams {
spLocalAddresses =
LocalAddresses
(Just $ Socket.addrAddress initiatorAddr4)
(Just $ Socket.addrAddress initiatorAddr6)
Nothing,
spConnectionAttemptDelay = \_ -> Just minConnectionAttemptDelay,
spErrorPolicies = nullErrorPolicies,
spSubscriptionTarget = DnsSubscriptionTarget "shelley-0.iohk.example" responderPort 1
}
(\_ -> waitSiblingSTM siblingVar)
(connectToNodeSocket
iocp
unversionedHandshakeCodec
noTimeLimitsHandshake
unversionedProtocolDataCodec
nullNetworkConnectTracers
(HandshakeCallbacks acceptableVersion queryVersion)
(unversionedProtocol initiatorApp))

res <- atomically $ (,) <$> takeTMVar sv <*> takeTMVar cv
return (res == L.mapAccumL f 0 xs)

where
withDummyServer :: Socket.AddrInfo
Expand Down
Loading