@@ -9,6 +9,7 @@ import Network.Transport.Test (TestTransport(..))
9import Data.Binary (Binary(..))
9import Data.Binary (Binary(..))
10import Data.Typeable (Typeable)
10import Data.Typeable (Typeable)
11import Data.Foldable (forM_)
11import Data.Foldable (forM_)
12+import Data.Function (fix)
12import Data.IORef
13import Data.IORef
13 ( readIORef
14 ( readIORef
14 , writeIORef
15 , writeIORef
@@ -410,16 +411,14 @@ testTimeout0 :: TestTransport -> Assertion
410testTimeout0 TestTransport{..} = do
411testTimeout0 TestTransport{..} = do
411 serverAddr <- newEmptyMVar
412 serverAddr <- newEmptyMVar
412 clientDone <- newEmptyMVar
413 clientDone <- newEmptyMVar
413− messagesSent <- newEmptyMVar
415 forkIO $ do
415 forkIO $ do
416 localNode <- newLocalNode testTransport initRemoteTable
416 localNode <- newLocalNode testTransport initRemoteTable
417 addr <- forkProcess localNode $ do
417 addr <- forkProcess localNode $ do
418− liftIO $ readMVar messagesSent >> threadDelay 1000000
419 -- Variation on the venerable ping server which uses a zero timeout
418 -- Variation on the venerable ping server which uses a zero timeout
420− -- Since we wait for all messages to be sent before doing this receive,
419+ partner <- fix $ \loop ->
421− -- we should nevertheless find the right message immediately
422− Just partner <- receiveTimeout 0 [match (\(Pong partner) -> return partner)]
420+ receiveTimeout 0 [match (\(Pong partner) -> return partner)]
421+ >>= maybe (liftIO (threadDelay 100000) >> loop) return
423 self <- getSelfPid
422 self <- getSelfPid
424 send partner (Ping self)
423 send partner (Ping self)
425 putMVar serverAddr addr
424 putMVar serverAddr addr
@@ -433,7 +432,6 @@ testTimeout0 TestTransport{..} = do
433 -- is not interested in, and then a single message that it wants
432 -- is not interested in, and then a single message that it wants
434 replicateM_ 10000 $ send server "Irrelevant message"
433 replicateM_ 10000 $ send server "Irrelevant message"
435 send server (Pong pid)
434 send server (Pong pid)
436− liftIO $ putMVar messagesSent ()
437 Ping _ <- expect
435 Ping _ <- expect
438 liftIO $ putMVar clientDone ()
436 liftIO $ putMVar clientDone ()