@@ -0,0 +1,162 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# OPTIONS_GHC -fno-warn-orphans #-}
3+module Main where
4+
5+import Prelude hiding (catch, log)
6+import Test.Framework
7+ ( Test
8+ , defaultMain
9+ , testGroup
10+ )
11+import Network.Transport.TCP
12+import Control.Distributed.Process
13+import Control.Distributed.Process.Node
14+ ( forkProcess
15+ , newLocalNode
16+ , initRemoteTable
17+ , closeLocalNode
18+ , LocalNode)
19+import Control.Concurrent.MVar
20+ ( MVar
21+ , newEmptyMVar
22+ , putMVar
23+ , takeMVar
24+ )
25+import Data.Binary()
26+import Data.Typeable()
27+import Test.HUnit (Assertion)
28+import Test.HUnit.Base (assertBool)
29+import Test.Framework.Providers.HUnit (testCase)
30+
31+-- these utilities have been cribbed from distributed-process-platform
32+-- we should really find a way to share them...
33+
34+-- | A mutable cell containing a test result.
35+type TestResult a = MVar a
36+
37+delayedAssertion :: (Eq a) => String -> LocalNode -> a ->
38+ (TestResult a -> Process ()) -> Assertion
39+delayedAssertion note localNode expected testProc = do
40+ result <- newEmptyMVar
41+ _ <- forkProcess localNode $ testProc result
42+ assertComplete note result expected
43+
44+assertComplete :: (Eq a) => String -> MVar a -> a -> IO ()
45+assertComplete msg mv a = do
46+ b <- takeMVar mv
47+ assertBool msg (a == b)
48+
49+stash :: TestResult a -> a -> Process ()
50+stash mvar x = liftIO $ putMVar mvar x
51+
52+------
53+
54+testLocalDeadProcessInfo :: TestResult (Maybe ProcessInfo) -> Process ()
55+testLocalDeadProcessInfo result = do
56+ pid <- spawnLocal $ do "finish" <- expect; return ()
57+ mref <- monitor pid
58+ send pid "finish"
59+ _ <- receiveWait [
60+ matchIf (\(ProcessMonitorNotification ref' pid' r) ->
61+ ref' == mref && pid' == pid && r == DiedNormal)
62+ (\p -> return p)
63+ ]
64+ getProcessInfo pid >>= stash result
65+
66+testLocalLiveProcessInfo :: TestResult Bool -> Process ()
67+testLocalLiveProcessInfo result = do
68+ self <- getSelfPid
69+ node <- getSelfNode
70+ register "foobar" self
71+
72+ mon <- liftIO $ newEmptyMVar
73+ -- TODO: we can't get the mailbox's length
74+ -- mapM (send self) ["hello", "there", "mr", "process"]
75+ pid <- spawnLocal $ do
76+ link self
77+ mRef <- monitor self
78+ stash mon mRef
79+ "die" <- expect
80+ return ()
81+
82+ monRef <- liftIO $ takeMVar mon
83+
84+ mpInfo <- getProcessInfo self
85+ case mpInfo of
86+ Nothing -> stash result False
87+ Just p -> verifyPInfo p pid monRef node
88+ where verifyPInfo :: ProcessInfo
89+ -> ProcessId
90+ -> MonitorRef
91+ -> NodeId
92+ -> Process ()
93+ verifyPInfo pInfo pid mref node =
94+ stash result $ infoNode pInfo == node &&
95+ infoLinks pInfo == [pid] &&
96+ infoMonitors pInfo == [(pid, mref)] &&
97+-- infoMessageQueueLength pInfo == Just 4 &&
98+ infoRegisteredNames pInfo == ["foobar"]
99+
100+testRemoteLiveProcessInfo :: LocalNode -> Assertion
101+testRemoteLiveProcessInfo node1 = do
102+ serverAddr <- liftIO $ newEmptyMVar :: IO (MVar ProcessId)
103+ liftIO $ launchRemote serverAddr
104+ serverPid <- liftIO $ takeMVar serverAddr
105+ withActiveRemote node1 $ \result -> do
106+ self <- getSelfPid
107+ link serverPid
108+ -- our send op shouldn't overtake link or monitor requests AFAICT
109+ -- so a little table tennis should get us synchronised properly
110+ send serverPid (self, "ping")
111+ "pong" <- expect
112+ pInfo <- getProcessInfo serverPid
113+ stash result $ pInfo /= Nothing
114+ where
115+ launchRemote :: MVar ProcessId -> IO ()
116+ launchRemote locMV = do
117+ node2 <- liftIO $ mkNode "8082"
118+ _ <- liftIO $ forkProcess node2 $ do
119+ self <- getSelfPid
120+ liftIO $ putMVar locMV self
121+ _ <- receiveWait [
122+ match (\(pid, "ping") -> send pid "pong")
123+ ]
124+ "stop" <- expect
125+ return ()
126+ return ()
127+
128+ withActiveRemote :: LocalNode
129+ -> ((TestResult Bool -> Process ()) -> Assertion)
130+ withActiveRemote n = do
131+ a <- delayedAssertion "getProcessInfo remotePid failed" n True
132+ return a
133+
134+tests :: LocalNode -> IO [Test]
135+tests node1 = do
136+ return [
137+ testGroup "Process Info" [
138+ testCase "testLocalDeadProcessInfo"
139+ (delayedAssertion
140+ "expected dead process-info to be ProcessInfoNone"
141+ node1 (Nothing) testLocalDeadProcessInfo)
142+ , testCase "testLocalLiveProcessInfo"
143+ (delayedAssertion
144+ "expected process-info to be correctly populated"
145+ node1 True testLocalLiveProcessInfo)
146+ , testCase "testRemoveLiveProcessInfo"
147+ (testRemoteLiveProcessInfo node1)
148+ ] ]
149+
150+mkNode :: String -> IO LocalNode
151+mkNode port = do
152+ Right (transport1, _) <- createTransportExposeInternals
153+ "127.0.0.1" port defaultTCPParameters
154+ newLocalNode transport1 initRemoteTable
155+
156+main :: IO ()
157+main = do
158+ node1 <- mkNode "8081"
159+ testData <- tests node1
160+ defaultMain testData
161+ closeLocalNode node1
162+ return ()