{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TemplateHaskell #-}
module Main where
import Control.Concurrent (threadDelay)
import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)
import Control.Distributed.Process
import Control.Distributed.Process.Node
import Control.Distributed.Process.Serializable()
import Control.Distributed.Process.Extras hiding (__remoteTable, monitor, send)
import qualified Control.Distributed.Process.Extras (__remoteTable)
import Control.Distributed.Process.Extras.Call
import Control.Distributed.Process.Extras.Monitoring
import Control.Distributed.Process.Extras.Time
import Control.Monad (void)
import Network.Transport.TCP()
import Test.HUnit (Assertion, assertEqual, assertBool)
import Test.Framework (Test, testGroup, defaultMain)
import Test.Framework.Providers.HUnit (testCase)
import Network.Transport.TCP
import qualified Network.Transport as NT
import Control.Distributed.Process.SysTest.Utils
testLinkingWithNormalExits :: TestResult DiedReason -> Process ()
testLinkingWithNormalExits result = do
testPid <- getSelfPid
pid <- spawnLocal $ do
worker <- spawnLocal $ do
"finish" <- expect
return ()
linkOnFailure worker
send testPid worker
() <- expect
return ()
workerPid <- expect :: Process ProcessId
ref <- monitor workerPid
send workerPid "finish"
receiveWait [
matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')
(\_ -> return ())
]
-- by now, the worker is gone, so we can check that the
-- insulator is still alive and well and that it exits normally
-- when asked to do so
ref2 <- monitor pid
send pid ()
r <- receiveWait [
matchIf (\(ProcessMonitorNotification ref2' _ _) -> ref2 == ref2')
(\(ProcessMonitorNotification _ _ reason) -> return reason)
]
stash result r
testLinkingWithAbnormalExits :: TestResult (Maybe Bool) -> Process ()
testLinkingWithAbnormalExits result = do
testPid <- getSelfPid
pid <- spawnLocal $ do
worker <- spawnLocal $ do
"finish" <- expect
return ()
linkOnFailure worker
send testPid worker
() <- expect
return ()
workerPid <- expect :: Process ProcessId
ref <- monitor pid
kill workerPid "finish" -- note the use of 'kill' instead of send
r <- receiveTimeout (asTimeout $ seconds 20) [
matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')
(\(ProcessMonitorNotification _ _ reason) -> return reason)
]
case r of
Just (DiedException _) -> stash result $ Just True
(Just _) -> stash result $ Just False
Nothing -> stash result Nothing
testMonitorNodeDeath :: NT.Transport -> TestResult () -> Process ()
testMonitorNodeDeath transport result = do
void $ nodeMonitor >> monitorNodes -- start node monitoring
nid1 <- getSelfNode
nid2 <- liftIO $ newEmptyMVar
nid3 <- liftIO $ newEmptyMVar
node2 <- liftIO $ newLocalNode transport initRemoteTable
node3 <- liftIO $ newLocalNode transport initRemoteTable
-- sending to (nodeId, "ignored") is a short cut to force a connection
liftIO $ tryForkProcess node2 $ ensureNodeRunning nid2 (nid1, "ignored")
liftIO $ tryForkProcess node3 $ ensureNodeRunning nid3 (nid1, "ignored")
NodeUp _ <- expect
NodeUp _ <- expect
void $ liftIO $ closeLocalNode node2
void $ liftIO $ closeLocalNode node3
NodeDown n1 <- expect
NodeDown n2 <- expect
mn1 <- liftIO $ takeMVar nid2
mn2 <- liftIO $ takeMVar nid3
liftIO $ do
assertBool mempty $ n1 `elem` [mn1, mn2]
assertBool mempty $ n2 `elem` [mn1, mn2]
nid4 <- liftIO $ newEmptyMVar
node4 <- liftIO $ newLocalNode transport initRemoteTable
void $ liftIO $ runProcess node4 $ do
us <- getSelfNode
liftIO $ putMVar nid4 us
monitorNode nid1 >> return ()
mn3 <- liftIO $ takeMVar nid4
NodeUp n3 <- expect
liftIO $ assertEqual mempty n3 mn3
liftIO $ closeLocalNode node4
stash result ()
where
ensureNodeRunning mvar nid = do
us <- getSelfNode
liftIO $ putMVar mvar us
sendTo nid "connected"
myRemoteTable :: RemoteTable
myRemoteTable = Control.Distributed.Process.Extras.__remoteTable initRemoteTable
multicallTest :: NT.Transport -> Assertion
multicallTest transport =
do node1 <- newLocalNode transport myRemoteTable
tryRunProcess node1 $
do pid1 <- whereisOrStart "server1" server1
_ <- whereisOrStart "server2" server2
pid2 <- whereisOrStart "server2" server2
tag <- newTagPool
-- First test: expect positives answers from both processes
tag1 <- getTag tag
result1 <- multicall [pid1,pid2] mystr tag1 infiniteWait
case result1 of
[Just reversed, Just doubled] |
reversed == reverse mystr && doubled == mystr ++ mystr -> return ()
_ -> error "Unmatched"
-- Second test: First process works, second thread throws an exception
tag2 <- getTag tag
[Just 10, Nothing] <- multicall [pid1,pid2] (5::Int) tag2 infiniteWait :: Process [Maybe Int]
-- Third test: First process exceeds time limit, second process is still dead
tag3 <- getTag tag
[Nothing, Nothing] <- multicall [pid1,pid2] (23::Int) tag3 (Just 1000000) :: Process [Maybe Int]
return ()
where server1 = receiveWait [callResponse (\str -> mention (str::String) (return (reverse str,())))] >>
receiveWait [callResponse (\i -> mention (i::Int) (return (i*2,())))] >>
receiveWait [callResponse (\i -> liftIO (threadDelay 2000000) >> mention (i::Int) (return (i*10,())))]
server2 = receiveWait [callResponse (\str -> mention (str::String) (return (str++str,())))] >>
receiveWait [callResponse (\i -> error "barf" >> mention (i::Int) (return (i :: Int,())))]
mystr = "hello"
mention :: a -> b -> b
mention _a b = b
--------------------------------------------------------------------------------
-- Utilities and Plumbing --
--------------------------------------------------------------------------------
tests :: NT.Transport -> LocalNode -> [Test]
tests transport localNode = [
testGroup "Linking Tests" [
testCase "testLinkingWithNormalExits"
(delayedAssertion
"normal exit should not terminate the caller"
localNode DiedNormal testLinkingWithNormalExits)
, testCase "testLinkingWithAbnormalExits"
(delayedAssertion
"abnormal exit should terminate the caller"
localNode (Just True) testLinkingWithAbnormalExits)
],
testGroup "Call/RPC" [
testCase "multicallTest" (multicallTest transport)
]
-- TODO: the test below has been very flaky in CI
-- testGroup "Node Monitoring" [
-- testCase "Death Notifications"
-- (delayedAssertion
-- "subscribers should both have received NodeDown twice"
-- localNode () (testMonitorNodeDeath transport))
-- ]
]
primitivesTests :: NT.Transport -> IO [Test]
primitivesTests transport = do
localNode <- newLocalNode transport initRemoteTable
let testData = tests transport localNode
return testData
-- | Given a @builder@ function, make and run a test suite on a single transport
testMain :: (NT.Transport -> IO [Test]) -> IO ()
testMain builder = do
Right (transport, _) <- createTransportExposeInternals (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters
testData <- builder transport
defaultMain testData
main :: IO ()
main = testMain $ primitivesTests