git.iko.soy/distributed-process
on mxsend-fix help sign in
distributed-process/distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs
129 lines 4.4 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# OPTIONS_GHC -fno-warn-orphans #-}
3module Control.Distributed.Process.Tests.Stats (tests) where
5import Control.Distributed.Process.Tests.Internal.Utils
6import Network.Transport.Test (TestTransport(..))
8import Control.Concurrent.MVar
9 ( MVar
10 , newEmptyMVar
11 , putMVar
12 , takeMVar
13 )
14import Control.Distributed.Process
15import Control.Distributed.Process.Node
16import Data.Binary ()
17import Data.Typeable ()
19#if ! MIN_VERSION_base(4,6,0)
20import Prelude hiding (catch)
21#endif
23import Test.Framework
24 ( Test
25 , testGroup
26 )
27import Test.HUnit (Assertion)
28import Test.Framework.Providers.HUnit (testCase)
30testLocalDeadProcessInfo :: TestResult (Maybe ProcessInfo) -> Process ()
31testLocalDeadProcessInfo result = do
32 pid <- spawnLocal $ do (_ :: String) <- expect; return ()
33 mref <- monitor pid
34 send pid "finish"
35 _ <- receiveWait [
36 matchIf (\(ProcessMonitorNotification ref' pid' r) ->
37 ref' == mref && pid' == pid && r == DiedNormal)
38 (\p -> return p)
39 ]
40 getProcessInfo pid >>= stash result
42testLocalLiveProcessInfo :: TestResult Bool -> Process ()
43testLocalLiveProcessInfo result = do
44 self <- getSelfPid
45 node <- getSelfNode
46 register "foobar" self
48 mon <- liftIO $ newEmptyMVar
49 -- TODO: we can't get the mailbox's length
50 -- mapM (send self) ["hello", "there", "mr", "process"]
51 pid <- spawnLocal $ do
52 link self
53 mRef <- monitor self
54 stash mon mRef
55 res <- expect
56 case res of
57 "die" -> return ()
58 _ -> die $ "unexpected message received: " ++ res
60 monRef <- liftIO $ takeMVar mon
62 mpInfo <- getProcessInfo self
63 case mpInfo of
64 Nothing -> stash result False
65 Just p -> verifyPInfo p pid monRef node
66 where verifyPInfo :: ProcessInfo
67 -> ProcessId
68 -> MonitorRef
69 -> NodeId
70 -> Process ()
71 verifyPInfo pInfo pid mref node =
72 stash result $ infoNode pInfo == node &&
73 infoLinks pInfo == [pid] &&
74 infoMonitors pInfo == [(pid, mref)] &&
75-- infoMessageQueueLength pInfo == Just 4 &&
76 infoRegisteredNames pInfo == ["foobar"]
78testRemoteLiveProcessInfo :: TestTransport -> LocalNode -> Assertion
79testRemoteLiveProcessInfo TestTransport{..} node1 = do
80 serverAddr <- liftIO $ newEmptyMVar :: IO (MVar ProcessId)
81 liftIO $ launchRemote serverAddr
82 serverPid <- liftIO $ takeMVar serverAddr
83 withActiveRemote node1 $ \result -> do
84 self <- getSelfPid
85 link serverPid
86 -- our send op shouldn't overtake link or monitor requests AFAICT
87 -- so a little table tennis should get us synchronised properly
88 send serverPid (self, "ping")
89 pong <- expect
90 pInfo <- getProcessInfo serverPid
91 stash result $ pong == "pong" && pInfo /= Nothing
92 where
93 launchRemote :: MVar ProcessId -> IO ()
94 launchRemote locMV = do
95 node2 <- liftIO $ newLocalNode testTransport initRemoteTable
96 _ <- liftIO $ forkProcess node2 $ do
97 self <- getSelfPid
98 liftIO $ putMVar locMV self
99 _ <- receiveWait [
100 match (\(pid, "ping") -> send pid "pong")
101 ]
102 res <- expect
103 case res of
104 "stop" -> return ()
105 _ -> die $ "unexpected message received: " ++ res
106 return ()
108 withActiveRemote :: LocalNode
109 -> ((TestResult Bool -> Process ()) -> Assertion)
110 withActiveRemote n = do
111 a <- delayedAssertion "getProcessInfo remotePid failed" n True
112 return a
114tests :: TestTransport -> IO [Test]
115tests testtrans@TestTransport{..} = do
116 node1 <- newLocalNode testTransport initRemoteTable
117 return [
118 testGroup "Process Info" [
119 testCase "testLocalDeadProcessInfo"
120 (delayedAssertion
121 "expected dead process-info to be ProcessInfoNone"
122 node1 (Nothing) testLocalDeadProcessInfo)
123 , testCase "testLocalLiveProcessInfo"
124 (delayedAssertion
125 "expected process-info to be correctly populated"
126 node1 True testLocalLiveProcessInfo)
127 , testCase "testRemoveLiveProcessInfo"
128 (testRemoteLiveProcessInfo testtrans node1)
129 ] ]