Skip to content

Commit

Permalink
Expand snocket tests with various scenarios
Browse files Browse the repository at this point in the history 
NOTE: Missing close tests
  • Loading branch information
@bolt12
bolt12 committed Oct 26, 2021
1 parent 2f311e7 commit d9824b7
Showing 1 changed file with 178 additions and 26 deletions.
204 changes: 178 additions & 26 deletions ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs
View file
Expand Up @@ -9,6 +9,7 @@
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RankNTypes #-}

{-# OPTIONS_GHC -Wno-unused-imports #-}

Expand Down Expand Up @@ -89,6 +90,14 @@ tests =
prop_generator_NonFailingBeararInfoScript
]
, testProperty "client-server" prop_client_server
, testProperty "connect_to_accepting_socket"
prop_connect_to_accepting_socket
, testProperty "connect_to_not_accepting_socket"
prop_connect_to_not_accepting_socket
, testProperty "connect_to_uninitialised_socket"
prop_connect_to_uninitialised_socket
, testProperty "simultaneous_open"
prop_simultaneous_open
]

type TestAddr = TestAddress Int
Expand Down Expand Up @@ -188,13 +197,13 @@ clientServerSimulation
)
=> Script BearerInfo
-> [payload]
-> m (Maybe Bool)
-> m (Either SomeException ())
clientServerSimulation script payloads =
withSnocket nullTracer script $ \snocket ->
withAsync (server snocket) $ \_serverAsync -> do
res <- untilSuccess (client snocket)
return (Just res)

withAsync (server' snocket) $ \_serverAsync -> do
res <- untilSuccess (client' snocket)
say $ "SIMULATION RESULT: " ++ show res
return (Right ())
where
reqRespProtocolNum :: MiniProtocolNum
reqRespProtocolNum = MiniProtocolNum 0
Expand All @@ -208,9 +217,9 @@ clientServerSimulation script payloads =
clientPeer :: Peer (ReqResp payload payload) AsClient StIdle m Bool
clientPeer = reqRespClientPeer (pingClient payloads)

server :: TestSnocket m
server' :: TestSnocket m
-> m ()
server snocket = do
server' snocket = do
labelThisThread "server"
threadsVar <- newTVarIO Set.empty
bracket (open snocket TestFamily)
Expand Down Expand Up @@ -280,9 +289,9 @@ clientServerSimulation script payloads =
say $ "SERVER HANDLER " ++ show res


client :: TestSnocket m
client' :: TestSnocket m
-> m Bool
client snocket = do
client' snocket = do
labelThisThread "client"
bracket (openToConnect snocket serverAddr)
(close snocket)
Expand Down Expand Up @@ -439,7 +448,6 @@ instance Arbitrary AbsAttenuation where
| Delay len' <- shrink (Delay len)
]


attenuation :: AbsAttenuation
-> Time -> Size -> (DiffTime, SuccessOrFailure)
attenuation (NoAttenuation speed) =
Expand Down Expand Up @@ -506,7 +514,6 @@ toBearerInfo abi =
biSDUSize = toSduSize (abiSDUSize abi)
}


instance Arbitrary AbsBearerInfo where
arbitrary =
AbsBearerInfo <$> arbitrary
Expand Down Expand Up @@ -627,28 +634,173 @@ prop_generator_NonFailingBeararInfoScript (NonFailingBearerInfoScript s) = not (

prop_client_server :: [ByteString] -> BearerInfoScript -> Property
prop_client_server payloads (BearerInfoScript script) =
let tr = runSimTrace $ clientServerSimulation script' payloads
in -- Debug.traceShow script $
case traceResult True tr of
Left e -> counterexample
(unlines
[ "=== Say Events ==="
, unlines (selectTraceEventsSay' tr)
, "=== Error ==="
, show e ++ "\n"
, "=== Trace Events ==="
, unlines (show `map` traceEvents tr)
])
False
Right Nothing -> property False
Right (Just b) -> property b
prop_connect_to_template sim
where
sim :: forall s . IOSim s (Either SomeException ())
sim = clientServerSimulation script' payloads

script' = toBearerInfo <$> script

data TestError = UnexpectedOutcome
deriving (Show, Eq)

instance Exception TestError

prop_connect_to_template
:: (forall s . IOSim s (Either SomeException ()))
-> Property
prop_connect_to_template sim =
let tr = runSimTrace sim
in case traceResult True tr of
Left e -> counterexample
(unlines
[ "=== Say Events ==="
, unlines (selectTraceEventsSay' tr)
, "=== Trace Events ==="
, unlines (show `map` traceEvents tr)
, "=== Error ==="
, show e ++ "\n"
])
False
Right (Left e) -> counterexample
(unlines
[ "=== Say Events ==="
, unlines (selectTraceEventsSay' tr)
, "=== Trace Events ==="
, unlines (show `map` traceEvents tr)
, "=== Error ==="
, show e ++ "\n"
])
False
Right (Right _) -> property True

prop_connect_to_accepting_socket :: BearerInfoScript -> Property
prop_connect_to_accepting_socket (BearerInfoScript script) =
prop_connect_to_template sim
where
sim :: forall s . IOSim s (Either SomeException ())
sim =
withSnocket nullTracer (toBearerInfo <$> script) $ \snocket ->
withAsync (server (TestAddress (0 :: Int)) snocket accept') $ \serverAsync -> do
res <- client (TestAddress 1) (TestAddress 0) snocket
_ <- wait serverAsync
return res

prop_connect_to_not_accepting_socket :: BearerInfoScript -> Property
prop_connect_to_not_accepting_socket (BearerInfoScript script) =
prop_connect_to_template sim
where
sim :: forall s . IOSim s (Either SomeException ())
sim =
withSnocket nullTracer (toBearerInfo <$> script) $ \snocket ->
withAsync (server (TestAddress (0 :: Int)) snocket loop) $ \_serverAsync -> do
res <- client (TestAddress 1) (TestAddress 0) snocket
case res of
-- Should timeout
Left _ -> return (Right ())
Right _ -> return (Left (toException UnexpectedOutcome))

prop_connect_to_uninitialised_socket :: BearerInfoScript -> Property
prop_connect_to_uninitialised_socket (BearerInfoScript script) =
prop_connect_to_template sim
where
sim :: forall s . IOSim s (Either SomeException ())
sim =
withSnocket nullTracer (toBearerInfo <$> script) $ \snocket -> do
res <- client (TestAddress (1 :: Int)) (TestAddress 0) snocket
case res of
-- Should complain about no such listening socket
Left _ -> return (Right ())
Right _ -> return (Left (toException UnexpectedOutcome))

prop_simultaneous_open :: BearerInfoScript -> Property
prop_simultaneous_open (BearerInfoScript script) =
prop_connect_to_template sim
where
sim :: forall s . IOSim s (Either SomeException ())
sim =
withSnocket nullTracer (toBearerInfo <$> script) $ \snocket -> do
withAsync (connectingServer (TestAddress (0 :: Int)) (TestAddress 1) snocket)
$ \clientAsync -> do
_ <- connectingServer (TestAddress 1) (TestAddress 0) snocket
wait clientAsync

--
-- Utils
--

server
:: ( MonadThread m
, MonadThrow m
)
=> TestAddress addr
-> Snocket m fd (TestAddress addr)
-> (m (Accept m fd (TestAddress addr)) -> m (b, Maybe fd))
-> m b
server localAddress snocket acceptF = do
labelThisThread "server"
bracket (open snocket TestFamily)
(close snocket)
(\fd -> do
bind snocket fd localAddress
listen snocket fd
(b, mbFd) <- acceptF (accept snocket fd)
traverse_ (close snocket) mbFd
return b
)

loop :: MonadDelay m => a -> m b
loop a = do
threadDelay 10000
loop a

accept' :: MonadMask m => m (Accept m fd addr) -> m (Bool, Maybe fd)
accept' accept = mask $ \unmask -> do
accept0 <- accept
(accepted, _) <- runAccept accept0 unmask
case accepted of
Accepted fd' _ -> do
return (True, Just fd')
AcceptFailure _ ->
return (False, Nothing)

client
:: ( MonadThread m
, MonadCatch m
)
=> addr
-> addr
-> Snocket m fd addr
-> m (Either SomeException ())
client localAddress remoteAddress snocket = do
labelThisThread "client"
bracket (openToConnect snocket localAddress)
(close snocket)
$ \fd -> do
bind snocket fd localAddress
Right <$> connect snocket fd remoteAddress
`catch` (\(e :: SomeException) -> return (Left e))

connectingServer
:: ( MonadThread m
, MonadCatch m
)
=> TestAddress addr
-> TestAddress addr
-> Snocket m fd (TestAddress addr) -> m (Either SomeException ())
connectingServer localAddress remoteAddress snocket = do
labelThisThread "connectingServer"
bracket (open snocket TestFamily)
(close snocket)
$ \fd -> do
bind snocket fd localAddress
listen snocket fd
bracket (openToConnect snocket localAddress)
(close snocket)
$ \fd' -> do
bind snocket fd' localAddress
Right <$> connect snocket fd' remoteAddress
`catch` (\(e :: SomeException) -> return (Left e))

traceTime :: MonadMonotonicTime m => Tracer m (Time, a) -> Tracer m a
traceTime = contramapM (\a -> (,a) <$> getMonotonicTime)

0 comments on commit d9824b7

Please sign in to comment.