{-# LANGUAGE DeriveDataTypeable        #-}
{-# OPTIONS_GHC -fno-warn-orphans      #-}
module Control.Distributed.Process.Tests.Stats (tests) where

import Control.Distributed.Process.Tests.Internal.Utils
import Network.Transport.Test (TestTransport(..))

import Control.Concurrent.MVar
  ( MVar
  , newEmptyMVar
  , putMVar
  , takeMVar
  )
import Control.Distributed.Process
import Control.Distributed.Process.Node
import Data.Binary ()
import Data.Typeable ()

#if ! MIN_VERSION_base(4,6,0)
import Prelude hiding (catch)
#endif

import Test.Framework
  ( Test
  , testGroup
  )
import Test.HUnit (Assertion)
import Test.Framework.Providers.HUnit (testCase)

testLocalDeadProcessInfo :: TestResult (Maybe ProcessInfo) -> Process ()
testLocalDeadProcessInfo :: TestResult (Maybe ProcessInfo) -> Process ()
testLocalDeadProcessInfo TestResult (Maybe ProcessInfo)
result = do
  ProcessId
pid <- Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ do (String
_ :: String) <- Process String
forall a. Serializable a => Process a
expect; () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  MonitorRef
mref <- ProcessId -> Process MonitorRef
monitor ProcessId
pid
  ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid String
"finish"
  ProcessMonitorNotification
_ <- [Match ProcessMonitorNotification]
-> Process ProcessMonitorNotification
forall b. [Match b] -> Process b
receiveWait [
      (ProcessMonitorNotification -> Bool)
-> (ProcessMonitorNotification
    -> Process ProcessMonitorNotification)
-> Match ProcessMonitorNotification
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(ProcessMonitorNotification MonitorRef
ref' ProcessId
pid' DiedReason
r) ->
                    MonitorRef
ref' MonitorRef -> MonitorRef -> Bool
forall a. Eq a => a -> a -> Bool
== MonitorRef
mref Bool -> Bool -> Bool
&& ProcessId
pid' ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid Bool -> Bool -> Bool
&& DiedReason
r DiedReason -> DiedReason -> Bool
forall a. Eq a => a -> a -> Bool
== DiedReason
DiedNormal)
              (\ProcessMonitorNotification
p -> ProcessMonitorNotification -> Process ProcessMonitorNotification
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessMonitorNotification
p)
    ]
  ProcessId -> Process (Maybe ProcessInfo)
getProcessInfo ProcessId
pid Process (Maybe ProcessInfo)
-> (Maybe ProcessInfo -> Process ()) -> Process ()
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TestResult (Maybe ProcessInfo) -> Maybe ProcessInfo -> Process ()
forall a. TestResult a -> a -> Process ()
stash TestResult (Maybe ProcessInfo)
result

testLocalLiveProcessInfo :: TestResult Bool -> Process ()
testLocalLiveProcessInfo :: TestResult Bool -> Process ()
testLocalLiveProcessInfo TestResult Bool
result = do
  ProcessId
self <- Process ProcessId
getSelfPid
  NodeId
node <- Process NodeId
getSelfNode
  String -> ProcessId -> Process ()
register String
"foobar" ProcessId
self

  MVar MonitorRef
mon <- IO (MVar MonitorRef) -> Process (MVar MonitorRef)
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar MonitorRef) -> Process (MVar MonitorRef))
-> IO (MVar MonitorRef) -> Process (MVar MonitorRef)
forall a b. (a -> b) -> a -> b
$ IO (MVar MonitorRef)
forall a. IO (MVar a)
newEmptyMVar
  -- TODO: we can't get the mailbox's length
  -- mapM (send self) ["hello", "there", "mr", "process"]
  ProcessId
pid <- Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ do
       ProcessId -> Process ()
link ProcessId
self
       MonitorRef
mRef <- ProcessId -> Process MonitorRef
monitor ProcessId
self
       MVar MonitorRef -> MonitorRef -> Process ()
forall a. TestResult a -> a -> Process ()
stash MVar MonitorRef
mon MonitorRef
mRef
       String
res <- Process String
forall a. Serializable a => Process a
expect
       case String
res of
         String
"die" -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         String
_     -> String -> Process ()
forall a b. Serializable a => a -> Process b
die (String -> Process ()) -> String -> Process ()
forall a b. (a -> b) -> a -> b
$ String
"unexpected message received: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
res

  MonitorRef
monRef <- IO MonitorRef -> Process MonitorRef
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MonitorRef -> Process MonitorRef)
-> IO MonitorRef -> Process MonitorRef
forall a b. (a -> b) -> a -> b
$ MVar MonitorRef -> IO MonitorRef
forall a. MVar a -> IO a
takeMVar MVar MonitorRef
mon

  Maybe ProcessInfo
mpInfo <- ProcessId -> Process (Maybe ProcessInfo)
getProcessInfo ProcessId
self
  case Maybe ProcessInfo
mpInfo of
    Maybe ProcessInfo
Nothing -> TestResult Bool -> Bool -> Process ()
forall a. TestResult a -> a -> Process ()
stash TestResult Bool
result Bool
False
    Just ProcessInfo
p  -> ProcessInfo -> ProcessId -> MonitorRef -> NodeId -> Process ()
verifyPInfo ProcessInfo
p ProcessId
pid MonitorRef
monRef NodeId
node
  where verifyPInfo :: ProcessInfo
                    -> ProcessId
                    -> MonitorRef
                    -> NodeId
                    -> Process ()
        verifyPInfo :: ProcessInfo -> ProcessId -> MonitorRef -> NodeId -> Process ()
verifyPInfo ProcessInfo
pInfo ProcessId
pid MonitorRef
mref NodeId
node =
          TestResult Bool -> Bool -> Process ()
forall a. TestResult a -> a -> Process ()
stash TestResult Bool
result (Bool -> Process ()) -> Bool -> Process ()
forall a b. (a -> b) -> a -> b
$ ProcessInfo -> NodeId
infoNode ProcessInfo
pInfo     NodeId -> NodeId -> Bool
forall a. Eq a => a -> a -> Bool
== NodeId
node           Bool -> Bool -> Bool
&&
                         ProcessInfo -> [ProcessId]
infoLinks ProcessInfo
pInfo    [ProcessId] -> [ProcessId] -> Bool
forall a. Eq a => a -> a -> Bool
== [ProcessId
pid]          Bool -> Bool -> Bool
&&
                         ProcessInfo -> [(ProcessId, MonitorRef)]
infoMonitors ProcessInfo
pInfo [(ProcessId, MonitorRef)] -> [(ProcessId, MonitorRef)] -> Bool
forall a. Eq a => a -> a -> Bool
== [(ProcessId
pid, MonitorRef
mref)]  Bool -> Bool -> Bool
&&
--                         infoMessageQueueLength pInfo == Just 4 &&
                         ProcessInfo -> [String]
infoRegisteredNames ProcessInfo
pInfo [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
== [String
"foobar"]

testRemoteLiveProcessInfo :: TestTransport -> LocalNode -> Assertion
testRemoteLiveProcessInfo :: TestTransport -> LocalNode -> Assertion
testRemoteLiveProcessInfo TestTransport{Transport
EndPointAddress -> EndPointAddress -> Assertion
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> Assertion
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> Assertion
testTransport :: TestTransport -> Transport
..} LocalNode
node1 = do
  MVar ProcessId
serverAddr <- IO (MVar ProcessId) -> IO (MVar ProcessId)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar ProcessId) -> IO (MVar ProcessId))
-> IO (MVar ProcessId) -> IO (MVar ProcessId)
forall a b. (a -> b) -> a -> b
$ IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar :: IO (MVar ProcessId)
  Assertion -> Assertion
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Assertion -> Assertion) -> Assertion -> Assertion
forall a b. (a -> b) -> a -> b
$ MVar ProcessId -> Assertion
launchRemote MVar ProcessId
serverAddr
  ProcessId
serverPid <- IO ProcessId -> IO ProcessId
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessId -> IO ProcessId) -> IO ProcessId -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
takeMVar MVar ProcessId
serverAddr
  LocalNode -> (TestResult Bool -> Process ()) -> Assertion
withActiveRemote LocalNode
node1 ((TestResult Bool -> Process ()) -> Assertion)
-> (TestResult Bool -> Process ()) -> Assertion
forall a b. (a -> b) -> a -> b
$ \TestResult Bool
result -> do
    ProcessId
self <- Process ProcessId
getSelfPid
    ProcessId -> Process ()
link ProcessId
serverPid
    -- our send op shouldn't overtake link or monitor requests AFAICT
    -- so a little table tennis should get us synchronised properly
    ProcessId -> (ProcessId, String) -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
serverPid (ProcessId
self, String
"ping")
    String
pong <- Process String
forall a. Serializable a => Process a
expect
    Maybe ProcessInfo
pInfo <- ProcessId -> Process (Maybe ProcessInfo)
getProcessInfo ProcessId
serverPid
    TestResult Bool -> Bool -> Process ()
forall a. TestResult a -> a -> Process ()
stash TestResult Bool
result (Bool -> Process ()) -> Bool -> Process ()
forall a b. (a -> b) -> a -> b
$ String
pong String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"pong" Bool -> Bool -> Bool
&& Maybe ProcessInfo
pInfo Maybe ProcessInfo -> Maybe ProcessInfo -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe ProcessInfo
forall a. Maybe a
Nothing
  where
    launchRemote :: MVar ProcessId -> IO ()
    launchRemote :: MVar ProcessId -> Assertion
launchRemote MVar ProcessId
locMV = do
        LocalNode
node2 <- IO LocalNode -> IO LocalNode
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LocalNode -> IO LocalNode) -> IO LocalNode -> IO LocalNode
forall a b. (a -> b) -> a -> b
$ Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
        ProcessId
_ <- IO ProcessId -> IO ProcessId
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessId -> IO ProcessId) -> IO ProcessId -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node2 (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
            ProcessId
self <- Process ProcessId
getSelfPid
            Assertion -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Assertion -> Process ()) -> Assertion -> Process ()
forall a b. (a -> b) -> a -> b
$ MVar ProcessId -> ProcessId -> Assertion
forall a. MVar a -> a -> Assertion
putMVar MVar ProcessId
locMV ProcessId
self
            ()
_ <- [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [
                  ((ProcessId, String) -> Process ()) -> Match ()
forall a b. Serializable a => (a -> Process b) -> Match b
match (\(ProcessId
pid, String
"ping") -> ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid String
"pong")
                ]
            String
res <- Process String
forall a. Serializable a => Process a
expect
            case String
res of
              String
"stop" -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              String
_      -> String -> Process ()
forall a b. Serializable a => a -> Process b
die (String -> Process ()) -> String -> Process ()
forall a b. (a -> b) -> a -> b
$ String
"unexpected message received: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
res
        () -> Assertion
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    withActiveRemote :: LocalNode
                     -> ((TestResult Bool -> Process ()) -> Assertion)
    withActiveRemote :: LocalNode -> (TestResult Bool -> Process ()) -> Assertion
withActiveRemote LocalNode
n = do
      Assertion
a <- String
-> LocalNode
-> Bool
-> (TestResult Bool -> Process ())
-> Assertion
forall a.
Eq a =>
String
-> LocalNode -> a -> (TestResult a -> Process ()) -> Assertion
delayedAssertion String
"getProcessInfo remotePid failed" LocalNode
n Bool
True
      Assertion -> (TestResult Bool -> Process ()) -> Assertion
forall a. a -> (TestResult Bool -> Process ()) -> a
forall (m :: * -> *) a. Monad m => a -> m a
return Assertion
a

tests :: TestTransport -> IO [Test]
tests :: TestTransport -> IO [Test]
tests testtrans :: TestTransport
testtrans@TestTransport{Transport
EndPointAddress -> EndPointAddress -> Assertion
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> Assertion
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> Assertion
..} = do
  LocalNode
node1 <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  [Test] -> IO [Test]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [
    String -> [Test] -> Test
testGroup String
"Process Info" [
        String -> Assertion -> Test
testCase String
"testLocalDeadProcessInfo"
            (String
-> LocalNode
-> Maybe ProcessInfo
-> (TestResult (Maybe ProcessInfo) -> Process ())
-> Assertion
forall a.
Eq a =>
String
-> LocalNode -> a -> (TestResult a -> Process ()) -> Assertion
delayedAssertion
             String
"expected dead process-info to be ProcessInfoNone"
             LocalNode
node1 (Maybe ProcessInfo
forall a. Maybe a
Nothing) TestResult (Maybe ProcessInfo) -> Process ()
testLocalDeadProcessInfo)
      , String -> Assertion -> Test
testCase String
"testLocalLiveProcessInfo"
            (String
-> LocalNode
-> Bool
-> (TestResult Bool -> Process ())
-> Assertion
forall a.
Eq a =>
String
-> LocalNode -> a -> (TestResult a -> Process ()) -> Assertion
delayedAssertion
             String
"expected process-info to be correctly populated"
             LocalNode
node1 Bool
True TestResult Bool -> Process ()
testLocalLiveProcessInfo)
      , String -> Assertion -> Test
testCase String
"testRemoveLiveProcessInfo"
                 (TestTransport -> LocalNode -> Assertion
testRemoteLiveProcessInfo TestTransport
testtrans LocalNode
node1)
    ] ]