@@ -44,13 +44,13 @@ import Control.Distributed.Process.Internal.Types
4444import Control.Distributed.Process.Node
4545import Control.Distributed.Process.Debug
4646import Control.Distributed.Process.Management.Internal.Types
47−import Control.Distributed.Process.Tests.Internal.Utils (shouldBe)
47+import Control.Distributed.Process.Tests.Internal.Utils (shouldBe, pause)
4848import Control.Distributed.Process.Serializable (Serializable)
49−
49+import Data.Maybe (isNothing)
5050import Test.HUnit (Assertion, assertBool, assertFailure)
5151import Test.Framework (Test, testGroup)
5252import Test.Framework.Providers.HUnit (testCase)
53−import Control.Rematch hiding (match)
53+import Control.Rematch hiding (match, isNothing)
5454import Control.Rematch.Run (Match(..))
5555
5656newtype Ping = Ping ProcessId
@@ -1273,6 +1273,76 @@ testReceiveChanFeatures TestTransport{..} = do
12731273
12741274 takeMVar done
12751275
1276+testChanLifecycle :: TestTransport -> Assertion
1277+testChanLifecycle TestTransport{..} = let delay = 3000000 in do
1278+ result <- newEmptyMVar
1279+ tchMV <- newEmptyMVar
1280+ localNode <- newLocalNode testTransport initRemoteTable
1281+ runProcess localNode $ do
1282+
1283+ pid <- spawnLocal $ do tCh <- newChan :: Process (SendPort (), ReceivePort ())
1284+ liftIO $ putMVar tchMV tCh
1285+ expect :: Process ()
1286+ let (sp, _) = tCh
1287+ sendChan sp ()
1288+ expect :: Process ()
1289+
1290+ mRefPid <- monitor pid
1291+
1292+ cPid <- spawnLocal $ do
1293+ (sp', rp) <- liftIO $ takeMVar tchMV
1294+ -- say "picked up our test channel"
1295+ send pid ()
1296+ -- say "told pid to continue"
1297+ res <- receiveChanTimeout delay rp
1298+ case res of
1299+ Nothing -> say "initial chan () missing!" >> (liftIO $ putMVar result False)
1300+ Just () -> do mr <- monitor pid
1301+ pause 10000
1302+ -- say "sending pid a second () will cause it to exit"
1303+ send pid ()
1304+
1305+ -- say "make sure we see a DOWN notification for pid having stopped"
1306+ receiveWait [ match (\(_ :: ProcessMonitorNotification) -> return ()) ]
1307+
1308+ -- now that pid has died, the send port should be useless...
1309+ liftIO $ putMVar tchMV (sp', rp)
1310+
1311+ -- let's verify that we do not see the message from our
1312+ -- parent process on the channel, once pid has died...
1313+ recv <- receiveChanTimeout delay rp
1314+ -- say $ "finished waiting for second (), writing result" ++ (show recv)
1315+ liftIO $ putMVar result $ isNothing recv
1316+
1317+ mRefCPid <- monitor cPid
1318+
1319+ receiveWait
1320+ [ matchIf (\(ProcessMonitorNotification r _ _) -> r == mRefPid)
1321+ (\_ -> return ())
1322+ ]
1323+
1324+ -- say "seen first pid die..."
1325+
1326+ (sendPort, _) <- liftIO $ takeMVar tchMV
1327+ sendChan sendPort ()
1328+ -- say "sent () after owning pid died"
1329+
1330+ -- let cPid know we've written to the channel...
1331+ send cPid ()
1332+
1333+ receiveWait
1334+ [ matchIf (\(ProcessMonitorNotification r _ _) -> r == mRefCPid)
1335+ (\_ -> return ())
1336+ ]
1337+
1338+ -- say "seen both pids die now..."
1339+
1340+ -- and wait on the result back in IO land...
1341+ testRes <- takeMVar result
1342+ -- runProcess localNode $ say "got result..."
1343+ assertBool "Expected sending on the channel to fail, but received data!" testRes
1344+
1345+
12761346testKillLocal :: TestTransport -> Assertion
12771347testKillLocal TestTransport{..} = do
12781348 localNode <- newLocalNode testTransport initRemoteTable
@@ -1737,6 +1807,7 @@ tests testtrans = return [
17371807 , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)
17381808 , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)
17391809 , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)
1810+ , testCase "ChanLifecycle" (testChanLifecycle testtrans)
17401811 , testCase "KillLocal" (testKillLocal testtrans)
17411812 , testCase "KillRemote" (testKillRemote testtrans)
17421813 , testCase "Die" (testDie testtrans)