git.iko.soy/distributed-process
on 87bb129 help sign in
distributed-process/distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs
125 lines 4.2 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 "finish" <- 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 "die" <- expect
56 return ()
58 monRef <- liftIO $ takeMVar mon
60 mpInfo <- getProcessInfo self
61 case mpInfo of
62 Nothing -> stash result False
63 Just p -> verifyPInfo p pid monRef node
64 where verifyPInfo :: ProcessInfo
65 -> ProcessId
66 -> MonitorRef
67 -> NodeId
68 -> Process ()
69 verifyPInfo pInfo pid mref node =
70 stash result $ infoNode pInfo == node &&
71 infoLinks pInfo == [pid] &&
72 infoMonitors pInfo == [(pid, mref)] &&
73-- infoMessageQueueLength pInfo == Just 4 &&
74 infoRegisteredNames pInfo == ["foobar"]
76testRemoteLiveProcessInfo :: TestTransport -> LocalNode -> Assertion
77testRemoteLiveProcessInfo TestTransport{..} node1 = do
78 serverAddr <- liftIO $ newEmptyMVar :: IO (MVar ProcessId)
79 liftIO $ launchRemote serverAddr
80 serverPid <- liftIO $ takeMVar serverAddr
81 withActiveRemote node1 $ \result -> do
82 self <- getSelfPid
83 link serverPid
84 -- our send op shouldn't overtake link or monitor requests AFAICT
85 -- so a little table tennis should get us synchronised properly
86 send serverPid (self, "ping")
87 "pong" <- expect
88 pInfo <- getProcessInfo serverPid
89 stash result $ pInfo /= Nothing
90 where
91 launchRemote :: MVar ProcessId -> IO ()
92 launchRemote locMV = do
93 node2 <- liftIO $ newLocalNode testTransport initRemoteTable
94 _ <- liftIO $ forkProcess node2 $ do
95 self <- getSelfPid
96 liftIO $ putMVar locMV self
97 _ <- receiveWait [
98 match (\(pid, "ping") -> send pid "pong")
99 ]
100 "stop" <- expect
101 return ()
102 return ()
104 withActiveRemote :: LocalNode
105 -> ((TestResult Bool -> Process ()) -> Assertion)
106 withActiveRemote n = do
107 a <- delayedAssertion "getProcessInfo remotePid failed" n True
108 return a
110tests :: TestTransport -> IO [Test]
111tests testtrans@TestTransport{..} = do
112 node1 <- newLocalNode testTransport initRemoteTable
113 return [
114 testGroup "Process Info" [
115 testCase "testLocalDeadProcessInfo"
116 (delayedAssertion
117 "expected dead process-info to be ProcessInfoNone"
118 node1 (Nothing) testLocalDeadProcessInfo)
119 , testCase "testLocalLiveProcessInfo"
120 (delayedAssertion
121 "expected process-info to be correctly populated"
122 node1 True testLocalLiveProcessInfo)
123 , testCase "testRemoveLiveProcessInfo"
124 (testRemoteLiveProcessInfo testtrans node1)
125 ] ]