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

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

import Control.Applicative ((<*))
import Control.Concurrent (threadDelay)
import Control.Concurrent.MVar
  ( MVar
  , newEmptyMVar
  , newMVar
  , putMVar
  , takeMVar
  )
import Control.Distributed.Process
import Control.Distributed.Process.Node
import Control.Distributed.Process.Debug
import Control.Distributed.Process.Management
  ( MxEvent(..)
  )
import qualified Control.Exception as IO (bracket)
import Data.List (isPrefixOf, isSuffixOf)

#if ! MIN_VERSION_base(4,6,0)
import Prelude hiding (catch, log)
#else
import Prelude hiding ((<*))
#endif

import Test.Framework
  ( Test
  , testGroup
  )
import Test.Framework.Providers.HUnit (testCase)
import System.Environment (getEnvironment)
-- These are available in System.Environment only since base 4.7
import System.SetEnv (setEnv, unsetEnv)


testSpawnTracing :: TestResult Bool -> Process ()
testSpawnTracing :: TestResult Bool -> Process ()
testSpawnTracing TestResult Bool
result = do
  TraceFlags -> Process ()
setTraceFlags TraceFlags
defaultTraceFlags {
      traceSpawned = (Just TraceAll)
    , traceDied    = (Just TraceAll)
    }

  MVar ProcessId
evSpawned <- IO (MVar ProcessId) -> Process (MVar ProcessId)
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar ProcessId) -> Process (MVar ProcessId))
-> IO (MVar ProcessId) -> Process (MVar ProcessId)
forall a b. (a -> b) -> a -> b
$ IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar (ProcessId, DiedReason)
evDied <- IO (MVar (ProcessId, DiedReason))
-> Process (MVar (ProcessId, DiedReason))
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar (ProcessId, DiedReason))
 -> Process (MVar (ProcessId, DiedReason)))
-> IO (MVar (ProcessId, DiedReason))
-> Process (MVar (ProcessId, DiedReason))
forall a b. (a -> b) -> a -> b
$ IO (MVar (ProcessId, DiedReason))
forall a. IO (MVar a)
newEmptyMVar
  ProcessId
tracer <- (MxEvent -> Process ()) -> Process ProcessId
startTracer ((MxEvent -> Process ()) -> Process ProcessId)
-> (MxEvent -> Process ()) -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ \MxEvent
ev -> do
    case MxEvent
ev of
      (MxSpawned ProcessId
p)       -> IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
evSpawned ProcessId
p
      (MxProcessDied ProcessId
p DiedReason
r) -> IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ MVar (ProcessId, DiedReason) -> (ProcessId, DiedReason) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (ProcessId, DiedReason)
evDied (ProcessId
p, DiedReason
r)
      MxEvent
_ -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  (SendPort ()
sp, ReceivePort ()
rp) <- Process (SendPort (), ReceivePort ())
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
  ProcessId
pid <- Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ SendPort () -> () -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort ()
sp ()
  () <- ReceivePort () -> Process ()
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort ()
rp

  ProcessId
tracedAlive <- IO ProcessId -> Process ProcessId
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessId -> Process ProcessId)
-> IO ProcessId -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
takeMVar MVar ProcessId
evSpawned
  (ProcessId
tracedDead, DiedReason
tracedReason) <- IO (ProcessId, DiedReason) -> Process (ProcessId, DiedReason)
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ProcessId, DiedReason) -> Process (ProcessId, DiedReason))
-> IO (ProcessId, DiedReason) -> Process (ProcessId, DiedReason)
forall a b. (a -> b) -> a -> b
$ MVar (ProcessId, DiedReason) -> IO (ProcessId, DiedReason)
forall a. MVar a -> IO a
takeMVar MVar (ProcessId, DiedReason)
evDied

  MonitorRef
mref <- ProcessId -> Process MonitorRef
monitor ProcessId
tracer
  Process ()
stopTracer -- this is asynchronous, so we need to wait...
  [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [
      (ProcessMonitorNotification -> Bool)
-> (ProcessMonitorNotification -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(ProcessMonitorNotification MonitorRef
ref ProcessId
_ DiedReason
_) -> MonitorRef
ref MonitorRef -> MonitorRef -> Bool
forall a. Eq a => a -> a -> Bool
== MonitorRef
mref)
              ((\ProcessMonitorNotification
_ -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()))
    ]
  TraceFlags -> Process ()
setTraceFlags TraceFlags
defaultTraceFlags
  TestResult Bool -> Bool -> Process ()
forall a. TestResult a -> a -> Process ()
stash TestResult Bool
result (ProcessId
tracedAlive  ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid Bool -> Bool -> Bool
&&
                ProcessId
tracedDead   ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid Bool -> Bool -> Bool
&&
                DiedReason
tracedReason DiedReason -> DiedReason -> Bool
forall a. Eq a => a -> a -> Bool
== DiedReason
DiedNormal)

testTraceRecvExplicitPid :: TestResult Bool -> Process ()
testTraceRecvExplicitPid :: TestResult Bool -> Process ()
testTraceRecvExplicitPid TestResult Bool
result = do
  TestResult Bool
res <- IO (TestResult Bool) -> Process (TestResult Bool)
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TestResult Bool) -> Process (TestResult Bool))
-> IO (TestResult Bool) -> Process (TestResult Bool)
forall a b. (a -> b) -> a -> b
$ IO (TestResult Bool)
forall a. IO (MVar a)
newEmptyMVar
  ProcessId
pid <- Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
self <- Process ProcessId
getSelfPid
    Process (SendPort ProcessId)
forall a. Serializable a => Process a
expect Process (SendPort ProcessId)
-> (SendPort ProcessId -> 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
>>= ((SendPort ProcessId -> ProcessId -> Process ())
-> ProcessId -> SendPort ProcessId -> Process ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip SendPort ProcessId -> ProcessId -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan) ProcessId
self
  TraceFlags
-> Process (Either SomeException ())
-> Process (Either SomeException (Either SomeException ()))
forall a.
TraceFlags -> Process a -> Process (Either SomeException a)
withFlags TraceFlags
defaultTraceFlags {
    traceRecv = traceOnly [pid]
    } (Process (Either SomeException ())
 -> Process (Either SomeException (Either SomeException ())))
-> Process (Either SomeException ())
-> Process (Either SomeException (Either SomeException ()))
forall a b. (a -> b) -> a -> b
$ do
    (MxEvent -> Process ())
-> Process () -> Process (Either SomeException ())
forall a.
(MxEvent -> Process ())
-> Process a -> Process (Either SomeException a)
withTracer
      (\MxEvent
ev ->
        case MxEvent
ev of
          (MxReceived ProcessId
pid' Message
_) -> TestResult Bool -> Bool -> Process ()
forall a. TestResult a -> a -> Process ()
stash TestResult Bool
res (ProcessId
pid ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid')
          MxEvent
_                        -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Process () -> Process (Either SomeException ()))
-> Process () -> Process (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ do
        (SendPort ProcessId
sp, ReceivePort ProcessId
rp) <- Process (SendPort ProcessId, ReceivePort ProcessId)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
        ProcessId -> SendPort ProcessId -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid SendPort ProcessId
sp
        ProcessId
p <- ReceivePort ProcessId -> Process ProcessId
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort ProcessId
rp
        Bool
res' <- IO Bool -> Process Bool
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Process Bool) -> IO Bool -> Process Bool
forall a b. (a -> b) -> a -> b
$ TestResult Bool -> IO Bool
forall a. MVar a -> IO a
takeMVar TestResult Bool
res
        TestResult Bool -> Bool -> Process ()
forall a. TestResult a -> a -> Process ()
stash TestResult Bool
result (Bool
res' Bool -> Bool -> Bool
&& (ProcessId
p ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid))
  () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

testTraceRecvNamedPid :: TestResult Bool -> Process ()
testTraceRecvNamedPid :: TestResult Bool -> Process ()
testTraceRecvNamedPid TestResult Bool
result = do
  TestResult Bool
res <- IO (TestResult Bool) -> Process (TestResult Bool)
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TestResult Bool) -> Process (TestResult Bool))
-> IO (TestResult Bool) -> Process (TestResult Bool)
forall a b. (a -> b) -> a -> b
$ IO (TestResult Bool)
forall a. IO (MVar a)
newEmptyMVar
  ProcessId
pid <- Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
self <- Process ProcessId
getSelfPid
    String -> ProcessId -> Process ()
register String
"foobar" ProcessId
self
    Process (SendPort ProcessId)
forall a. Serializable a => Process a
expect Process (SendPort ProcessId)
-> (SendPort ProcessId -> 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
>>= ((SendPort ProcessId -> ProcessId -> Process ())
-> ProcessId -> SendPort ProcessId -> Process ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip SendPort ProcessId -> ProcessId -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan) ProcessId
self
  TraceFlags
-> Process (Either SomeException ())
-> Process (Either SomeException (Either SomeException ()))
forall a.
TraceFlags -> Process a -> Process (Either SomeException a)
withFlags TraceFlags
defaultTraceFlags {
    traceRecv = traceOnly ["foobar"]
    } (Process (Either SomeException ())
 -> Process (Either SomeException (Either SomeException ())))
-> Process (Either SomeException ())
-> Process (Either SomeException (Either SomeException ()))
forall a b. (a -> b) -> a -> b
$ do
    (MxEvent -> Process ())
-> Process () -> Process (Either SomeException ())
forall a.
(MxEvent -> Process ())
-> Process a -> Process (Either SomeException a)
withTracer
      (\MxEvent
ev ->
        case MxEvent
ev of
          (MxReceived ProcessId
pid' Message
_) -> TestResult Bool -> Bool -> Process ()
forall a. TestResult a -> a -> Process ()
stash TestResult Bool
res (ProcessId
pid ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid')
          MxEvent
_                        -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Process () -> Process (Either SomeException ()))
-> Process () -> Process (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ do
        (SendPort ProcessId
sp, ReceivePort ProcessId
rp) <- Process (SendPort ProcessId, ReceivePort ProcessId)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
        ProcessId -> SendPort ProcessId -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid SendPort ProcessId
sp
        ProcessId
p <- ReceivePort ProcessId -> Process ProcessId
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort ProcessId
rp
        Bool
res' <- IO Bool -> Process Bool
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Process Bool) -> IO Bool -> Process Bool
forall a b. (a -> b) -> a -> b
$ TestResult Bool -> IO Bool
forall a. MVar a -> IO a
takeMVar TestResult Bool
res
        TestResult Bool -> Bool -> Process ()
forall a. TestResult a -> a -> Process ()
stash TestResult Bool
result (Bool
res' Bool -> Bool -> Bool
&& (ProcessId
p ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid))
  () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

testTraceSending :: TestResult Bool -> Process ()
testTraceSending :: TestResult Bool -> Process ()
testTraceSending TestResult Bool
result = do
  ProcessId
pid <- Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ (Process String
forall a. Serializable a => Process a
expect :: Process String) Process String -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  ProcessId
self <- Process ProcessId
getSelfPid
  TestResult Bool
res <- IO (TestResult Bool) -> Process (TestResult Bool)
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TestResult Bool) -> Process (TestResult Bool))
-> IO (TestResult Bool) -> Process (TestResult Bool)
forall a b. (a -> b) -> a -> b
$ IO (TestResult Bool)
forall a. IO (MVar a)
newEmptyMVar
  TraceFlags
-> Process (Either SomeException ())
-> Process (Either SomeException (Either SomeException ()))
forall a.
TraceFlags -> Process a -> Process (Either SomeException a)
withFlags TraceFlags
defaultTraceFlags { traceSend = traceOn } (Process (Either SomeException ())
 -> Process (Either SomeException (Either SomeException ())))
-> Process (Either SomeException ())
-> Process (Either SomeException (Either SomeException ()))
forall a b. (a -> b) -> a -> b
$ do
    (MxEvent -> Process ())
-> Process () -> Process (Either SomeException ())
forall a.
(MxEvent -> Process ())
-> Process a -> Process (Either SomeException a)
withTracer
      (\MxEvent
ev ->
        case MxEvent
ev of
          (MxSent ProcessId
to ProcessId
from Message
msg) -> do
            Maybe String
mS <- Message -> Process (Maybe String)
forall (m :: * -> *) a.
(Monad m, Serializable a) =>
Message -> m (Maybe a)
unwrapMessage Message
msg :: Process (Maybe String)
            case Maybe String
mS of
              (Just String
s) -> do TestResult Bool -> Bool -> Process ()
forall a. TestResult a -> a -> Process ()
stash TestResult Bool
res (ProcessId
to ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid Bool -> Bool -> Bool
&& ProcessId
from ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
self Bool -> Bool -> Bool
&& String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"hello there")
                             TestResult Bool -> Bool -> Process ()
forall a. TestResult a -> a -> Process ()
stash TestResult Bool
res (ProcessId
to ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid Bool -> Bool -> Bool
&& ProcessId
from ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
self)
              Maybe String
_        -> String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"failed state invariant, message type unmatched..."
          MxEvent
_ ->
            () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Process () -> Process (Either SomeException ()))
-> Process () -> Process (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ do
        ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid String
"hello there"
  Bool
res' <- IO Bool -> Process Bool
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Process Bool) -> IO Bool -> Process Bool
forall a b. (a -> b) -> a -> b
$ TestResult Bool -> IO Bool
forall a. MVar a -> IO a
takeMVar TestResult Bool
res
  TestResult Bool -> Bool -> Process ()
forall a. TestResult a -> a -> Process ()
stash TestResult Bool
result Bool
res'

testTraceRegistration :: TestResult Bool -> Process ()
testTraceRegistration :: TestResult Bool -> Process ()
testTraceRegistration TestResult Bool
result = do
  (SendPort ()
sp, ReceivePort ()
rp) <- Process (SendPort (), ReceivePort ())
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
  ProcessId
pid <- Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
self <- Process ProcessId
getSelfPid
    () <- Process ()
forall a. Serializable a => Process a
expect
    String -> ProcessId -> Process ()
register String
"foobar" ProcessId
self
    SendPort () -> () -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort ()
sp ()
    () <- Process ()
forall a. Serializable a => Process a
expect
    () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  TestResult Bool
res <- IO (TestResult Bool) -> Process (TestResult Bool)
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TestResult Bool) -> Process (TestResult Bool))
-> IO (TestResult Bool) -> Process (TestResult Bool)
forall a b. (a -> b) -> a -> b
$ IO (TestResult Bool)
forall a. IO (MVar a)
newEmptyMVar
  TraceFlags
-> Process (Either SomeException ())
-> Process (Either SomeException (Either SomeException ()))
forall a.
TraceFlags -> Process a -> Process (Either SomeException a)
withFlags TraceFlags
defaultTraceFlags { traceRegistered = traceOn } (Process (Either SomeException ())
 -> Process (Either SomeException (Either SomeException ())))
-> Process (Either SomeException ())
-> Process (Either SomeException (Either SomeException ()))
forall a b. (a -> b) -> a -> b
$ do
    (MxEvent -> Process ())
-> Process () -> Process (Either SomeException ())
forall a.
(MxEvent -> Process ())
-> Process a -> Process (Either SomeException a)
withTracer
      (\MxEvent
ev ->
        case MxEvent
ev of
          MxRegistered ProcessId
p String
s ->
            TestResult Bool -> Bool -> Process ()
forall a. TestResult a -> a -> Process ()
stash TestResult Bool
res (ProcessId
p ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid Bool -> Bool -> Bool
&& String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"foobar")
          MxEvent
_ ->
            () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Process () -> Process (Either SomeException ()))
-> Process () -> Process (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ do
        MonitorRef
_ <- ProcessId -> Process MonitorRef
monitor ProcessId
pid
        ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid ()
        () <- ReceivePort () -> Process ()
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort ()
rp
        ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid ()
        [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [
          (ProcessMonitorNotification -> Process ()) -> Match ()
forall a b. Serializable a => (a -> Process b) -> Match b
match (\(ProcessMonitorNotification MonitorRef
_ ProcessId
_ DiedReason
_) -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
          ]
  Bool
res' <- IO Bool -> Process Bool
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Process Bool) -> IO Bool -> Process Bool
forall a b. (a -> b) -> a -> b
$ TestResult Bool -> IO Bool
forall a. MVar a -> IO a
takeMVar TestResult Bool
res
  TestResult Bool -> Bool -> Process ()
forall a. TestResult a -> a -> Process ()
stash TestResult Bool
result Bool
res'

testTraceUnRegistration :: TestResult Bool -> Process ()
testTraceUnRegistration :: TestResult Bool -> Process ()
testTraceUnRegistration TestResult Bool
result = do
  ProcessId
pid <- Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ do
    () <- Process ()
forall a. Serializable a => Process a
expect
    String -> Process ()
unregister String
"foobar"
    () <- Process ()
forall a. Serializable a => Process a
expect
    () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  String -> ProcessId -> Process ()
register String
"foobar" ProcessId
pid
  TestResult Bool
res <- IO (TestResult Bool) -> Process (TestResult Bool)
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TestResult Bool) -> Process (TestResult Bool))
-> IO (TestResult Bool) -> Process (TestResult Bool)
forall a b. (a -> b) -> a -> b
$ IO (TestResult Bool)
forall a. IO (MVar a)
newEmptyMVar
  TraceFlags
-> Process (Either SomeException ())
-> Process (Either SomeException (Either SomeException ()))
forall a.
TraceFlags -> Process a -> Process (Either SomeException a)
withFlags TraceFlags
defaultTraceFlags { traceUnregistered = traceOn } (Process (Either SomeException ())
 -> Process (Either SomeException (Either SomeException ())))
-> Process (Either SomeException ())
-> Process (Either SomeException (Either SomeException ()))
forall a b. (a -> b) -> a -> b
$ do
    (MxEvent -> Process ())
-> Process () -> Process (Either SomeException ())
forall a.
(MxEvent -> Process ())
-> Process a -> Process (Either SomeException a)
withTracer
      (\MxEvent
ev ->
        case MxEvent
ev of
          MxUnRegistered ProcessId
p String
n -> do
            TestResult Bool -> Bool -> Process ()
forall a. TestResult a -> a -> Process ()
stash TestResult Bool
res (ProcessId
p ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid Bool -> Bool -> Bool
&& String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"foobar")
            ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid ()
          MxEvent
_ ->
            () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Process () -> Process (Either SomeException ()))
-> Process () -> Process (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ do
        MonitorRef
mref <- ProcessId -> Process MonitorRef
monitor ProcessId
pid
        ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid ()
        [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [
          (ProcessMonitorNotification -> Bool)
-> (ProcessMonitorNotification -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(ProcessMonitorNotification MonitorRef
mref' ProcessId
_ DiedReason
_) -> MonitorRef
mref MonitorRef -> MonitorRef -> Bool
forall a. Eq a => a -> a -> Bool
== MonitorRef
mref')
                  (\ProcessMonitorNotification
_ -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
          ]
  Bool
res' <- IO Bool -> Process Bool
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Process Bool) -> IO Bool -> Process Bool
forall a b. (a -> b) -> a -> b
$ TestResult Bool -> IO Bool
forall a. MVar a -> IO a
takeMVar TestResult Bool
res
  TestResult Bool -> Bool -> Process ()
forall a. TestResult a -> a -> Process ()
stash TestResult Bool
result Bool
res'

testTraceLayering :: TestResult () -> Process ()
testTraceLayering :: TestResult () -> Process ()
testTraceLayering TestResult ()
result = do
  ProcessId
pid <- Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ do
    Process ProcessId
getSelfPid Process ProcessId -> (ProcessId -> 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
>>= String -> ProcessId -> Process ()
register String
"foobar"
    () <- Process ()
forall a. Serializable a => Process a
expect
    (String, Int) -> Process ()
forall m. Serializable m => m -> Process ()
traceMessage (String
"traceMsg", Int
123 :: Int)
    () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  TraceFlags -> Process () -> Process (Either SomeException ())
forall a.
TraceFlags -> Process a -> Process (Either SomeException a)
withFlags TraceFlags
defaultTraceFlags {
      traceDied = traceOnly [pid]
    , traceRecv = traceOnly ["foobar"]
    } (Process () -> Process (Either SomeException ()))
-> Process () -> Process (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ ProcessId -> TestResult () -> Process ()
doTest ProcessId
pid TestResult ()
result
  () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    doTest :: ProcessId -> MVar () -> Process ()
    doTest :: ProcessId -> TestResult () -> Process ()
doTest ProcessId
pid TestResult ()
result' = do
      -- TODO: this is pretty gross, even for a test case
      TestResult ()
died <- IO (TestResult ()) -> Process (TestResult ())
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TestResult ()) -> Process (TestResult ()))
-> IO (TestResult ()) -> Process (TestResult ())
forall a b. (a -> b) -> a -> b
$ IO (TestResult ())
forall a. IO (MVar a)
newEmptyMVar
      (MxEvent -> Process ())
-> Process () -> Process (Either SomeException ())
forall a.
(MxEvent -> Process ())
-> Process a -> Process (Either SomeException a)
withTracer
       (\MxEvent
ev ->
         case MxEvent
ev of
           MxProcessDied ProcessId
_ DiedReason
_ -> IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ TestResult () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar TestResult ()
died ()
           MxEvent
_                 -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
       ( do {
           TestResult ()
recv <- IO (TestResult ()) -> Process (TestResult ())
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TestResult ()) -> Process (TestResult ()))
-> IO (TestResult ()) -> Process (TestResult ())
forall a b. (a -> b) -> a -> b
$ IO (TestResult ())
forall a. IO (MVar a)
newEmptyMVar
         ; (MxEvent -> Process ())
-> Process () -> Process (Either SomeException ())
forall a.
(MxEvent -> Process ())
-> Process a -> Process (Either SomeException a)
withTracer
            (\MxEvent
ev' ->
              case MxEvent
ev' of
                MxReceived ProcessId
_ Message
_ -> IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ TestResult () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar TestResult ()
recv ()
                MxEvent
_                   -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
            ( do {
                TestResult ()
user <- IO (TestResult ()) -> Process (TestResult ())
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TestResult ()) -> Process (TestResult ()))
-> IO (TestResult ()) -> Process (TestResult ())
forall a b. (a -> b) -> a -> b
$ IO (TestResult ())
forall a. IO (MVar a)
newEmptyMVar
              ; (MxEvent -> Process ())
-> Process () -> Process (Either SomeException ())
forall a.
(MxEvent -> Process ())
-> Process a -> Process (Either SomeException a)
withTracer
                  (\MxEvent
ev'' ->
                    case MxEvent
ev'' of
                      MxUser Message
_ -> IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ TestResult () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar TestResult ()
user ()
                      MxEvent
_             -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                  (ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid () Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ TestResult () -> IO ()
forall a. MVar a -> IO a
takeMVar TestResult ()
user))
              ; IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ TestResult () -> IO ()
forall a. MVar a -> IO a
takeMVar TestResult ()
recv
              })
         ; IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ TestResult () -> IO ()
forall a. MVar a -> IO a
takeMVar TestResult ()
died
         })
      IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ TestResult () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar TestResult ()
result' ()

testRemoteTraceRelay :: TestTransport -> TestResult Bool -> Process ()
testRemoteTraceRelay :: TestTransport -> TestResult Bool -> Process ()
testRemoteTraceRelay TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
..} TestResult Bool
result =
  let flags :: TraceFlags
flags = TraceFlags
defaultTraceFlags { traceSpawned = traceOn }
  in do
    LocalNode
node2 <- IO LocalNode -> Process LocalNode
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LocalNode -> Process LocalNode)
-> IO LocalNode -> Process LocalNode
forall a b. (a -> b) -> a -> b
$ Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    MVar NodeId
mvNid <- IO (MVar NodeId) -> Process (MVar NodeId)
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar NodeId) -> Process (MVar NodeId))
-> IO (MVar NodeId) -> Process (MVar NodeId)
forall a b. (a -> b) -> a -> b
$ IO (MVar NodeId)
forall a. IO (MVar a)
newEmptyMVar

    -- As well as needing node2's NodeId, we want to
    -- redirect all its logs back here, to avoid generating
    -- garbage on stderr for the duration of the test run.
    -- Here we set up that relay, and then wait for a signal
    -- that the tracer (on node1) has seen the expected
    -- MxSpawned message, at which point we're finished

    ProcessId
pid <- LocalNode -> MVar NodeId -> Process ProcessId
splinchLogger LocalNode
node2 MVar NodeId
mvNid
    NodeId
nid <- IO NodeId -> Process NodeId
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO NodeId -> Process NodeId) -> IO NodeId -> Process NodeId
forall a b. (a -> b) -> a -> b
$ MVar NodeId -> IO NodeId
forall a. MVar a -> IO a
takeMVar MVar NodeId
mvNid
    MonitorRef
mref <- ProcessId -> Process MonitorRef
monitor ProcessId
pid
    MVar ProcessId
observedPid <- IO (MVar ProcessId) -> Process (MVar ProcessId)
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar ProcessId) -> Process (MVar ProcessId))
-> IO (MVar ProcessId) -> Process (MVar ProcessId)
forall a b. (a -> b) -> a -> b
$ IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
    MVar ProcessId
spawnedPid <- IO (MVar ProcessId) -> Process (MVar ProcessId)
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar ProcessId) -> Process (MVar ProcessId))
-> IO (MVar ProcessId) -> Process (MVar ProcessId)
forall a b. (a -> b) -> a -> b
$ IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
    TraceFlags -> NodeId -> Process ()
setTraceFlagsRemote TraceFlags
flags NodeId
nid

    TraceFlags
-> Process (Either SomeException ())
-> Process (Either SomeException (Either SomeException ()))
forall a.
TraceFlags -> Process a -> Process (Either SomeException a)
withFlags TraceFlags
defaultTraceFlags { traceSpawned = traceOn } (Process (Either SomeException ())
 -> Process (Either SomeException (Either SomeException ())))
-> Process (Either SomeException ())
-> Process (Either SomeException (Either SomeException ()))
forall a b. (a -> b) -> a -> b
$ do
      (MxEvent -> Process ())
-> Process () -> Process (Either SomeException ())
forall a.
(MxEvent -> Process ())
-> Process a -> Process (Either SomeException a)
withTracer
        (\MxEvent
ev ->
          case MxEvent
ev of
            MxSpawned ProcessId
p -> MVar ProcessId -> ProcessId -> Process ()
forall a. TestResult a -> a -> Process ()
stash MVar ProcessId
observedPid ProcessId
p Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid ()
            MxEvent
_                -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Process () -> Process (Either SomeException ()))
-> Process () -> Process (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ do
          ProcessId
relayPid <- NodeId -> Process ProcessId
startTraceRelay NodeId
nid
          IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
1000000
          ProcessId
p <- IO ProcessId -> Process ProcessId
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessId -> Process ProcessId)
-> IO ProcessId -> Process 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
            Int -> Process (Maybe ())
forall a. Serializable a => Int -> Process (Maybe a)
expectTimeout Int
1000000 :: Process (Maybe ())
            () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          MVar ProcessId -> ProcessId -> Process ()
forall a. TestResult a -> a -> Process ()
stash MVar ProcessId
spawnedPid ProcessId
p

          -- Now we wait for (the outer) pid to exit. This won't happen until
          -- our tracer has seen the trace event for `p' and sent `p' the
          -- message it's waiting for prior to exiting
          [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [
            (ProcessMonitorNotification -> Bool)
-> (ProcessMonitorNotification -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(ProcessMonitorNotification MonitorRef
mref' ProcessId
_ DiedReason
_) -> MonitorRef
mref MonitorRef -> MonitorRef -> Bool
forall a. Eq a => a -> a -> Bool
== MonitorRef
mref')
                    (\ProcessMonitorNotification
_ -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
            ]

          MonitorRef
relayRef <- ProcessId -> Process MonitorRef
monitor ProcessId
relayPid
          ProcessId -> String -> Process ()
kill ProcessId
relayPid String
"stop"
          [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [
            (ProcessMonitorNotification -> Bool)
-> (ProcessMonitorNotification -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(ProcessMonitorNotification MonitorRef
rref' ProcessId
_ DiedReason
_) -> MonitorRef
rref' MonitorRef -> MonitorRef -> Bool
forall a. Eq a => a -> a -> Bool
== MonitorRef
relayRef)
                    (\ProcessMonitorNotification
_ -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
            ]
    ProcessId
observed <- IO ProcessId -> Process ProcessId
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessId -> Process ProcessId)
-> IO ProcessId -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
takeMVar MVar ProcessId
observedPid
    ProcessId
expected <- IO ProcessId -> Process ProcessId
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessId -> Process ProcessId)
-> IO ProcessId -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
takeMVar MVar ProcessId
spawnedPid
    TestResult Bool -> Bool -> Process ()
forall a. TestResult a -> a -> Process ()
stash TestResult Bool
result (ProcessId
observed ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
expected)
    -- and just to be polite...
    IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ LocalNode -> IO ()
closeLocalNode LocalNode
node2

  where
    splinchLogger :: LocalNode -> MVar NodeId -> Process ProcessId
splinchLogger LocalNode
n2 MVar NodeId
mv = do
      Maybe ProcessId
mLog <- String -> Process (Maybe ProcessId)
whereis String
"logger"
      case Maybe ProcessId
mLog of
        Maybe ProcessId
Nothing   -> String -> Process ProcessId
forall a b. Serializable a => a -> Process b
die String
"no logger registered"
        Just ProcessId
log' -> do IO ProcessId -> Process ProcessId
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessId -> Process ProcessId)
-> IO ProcessId -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
n2 (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
                          ProcessId
logRelay <- Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ ProcessId -> Process ()
relay ProcessId
log'
                          String -> ProcessId -> Process ()
reregister String
"logger" ProcessId
logRelay
                          Process NodeId
getSelfNode Process NodeId -> (NodeId -> 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
>>= MVar NodeId -> NodeId -> Process ()
forall a. TestResult a -> a -> Process ()
stash MVar NodeId
mv Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Process ()
forall a. Serializable a => Process a
expect :: Process ())


-- | Sets the value of an environment variable while executing the given IO
-- computation and restores the preceeding value upon completion.
withEnv :: String -> String -> IO a -> IO a
withEnv :: forall a. String -> String -> IO a -> IO a
withEnv String
var String
val =
    IO (Maybe String)
-> (Maybe String -> IO ()) -> (Maybe String -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
IO.bracket (([(String, String)] -> Maybe String)
-> IO [(String, String)] -> IO (Maybe String)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
var) IO [(String, String)]
getEnvironment IO (Maybe String) -> IO () -> IO (Maybe String)
forall a b. IO a -> IO b -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> String -> IO ()
setEnv String
var String
val)
               (IO () -> (String -> IO ()) -> Maybe String -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO ()
unsetEnv String
var) (String -> String -> IO ()
setEnv String
var))
    ((Maybe String -> IO a) -> IO a)
-> (IO a -> Maybe String -> IO a) -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> Maybe String -> IO a
forall a b. a -> b -> a
const

-- | Tests that one and only one interesting trace message is produced when a
-- given action is performed. A message is considered interesting when the given
-- function return @True@.
testSystemLoggerMsg :: TestTransport
                    -> Process a
                    -> (a -> String -> Bool)
                    -> IO ()
testSystemLoggerMsg :: forall a.
TestTransport -> Process a -> (a -> String -> Bool) -> IO ()
testSystemLoggerMsg TestTransport
t Process a
action a -> String -> Bool
interestingMessage =
    String -> String -> IO () -> IO ()
forall a. String -> String -> IO a -> IO a
withEnv String
"DISTRIBUTED_PROCESS_TRACE_CONSOLE" String
"yes" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> String -> IO () -> IO ()
forall a. String -> String -> IO a -> IO a
withEnv String
"DISTRIBUTED_PROCESS_TRACE_FLAGS" String
"pdnusrl" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
n <- Transport -> RemoteTable -> IO LocalNode
newLocalNode (TestTransport -> Transport
testTransport TestTransport
t) RemoteTable
initRemoteTable

    LocalNode -> Process () -> IO ()
runProcess LocalNode
n (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ProcessId
self <- Process ProcessId
getSelfPid
      String -> ProcessId -> Process ()
reregister String
"trace.logger" ProcessId
self
      a
a <- Process a
action
      let interestingMessage' :: (String, String) -> Bool
interestingMessage' (String
_ :: String, String
msg) = a -> String -> Bool
interestingMessage a
a String
msg
      -- Wait for the trace message.
      [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [ ((String, String) -> Bool)
-> ((String, String) -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (String, String) -> Bool
interestingMessage' (((String, String) -> Process ()) -> Match ())
-> ((String, String) -> Process ()) -> Match ()
forall a b. (a -> b) -> a -> b
$ Process () -> (String, String) -> Process ()
forall a b. a -> b -> a
const (Process () -> (String, String) -> Process ())
-> Process () -> (String, String) -> Process ()
forall a b. (a -> b) -> a -> b
$ () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return () ]
      -- Only one interesting message should arrive.
      Maybe ()
expectedTimeout <- Int -> [Match ()] -> Process (Maybe ())
forall b. Int -> [Match b] -> Process (Maybe b)
receiveTimeout
                           Int
100000
                           [ ((String, String) -> Bool)
-> ((String, String) -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (String, String) -> Bool
interestingMessage' (((String, String) -> Process ()) -> Match ())
-> ((String, String) -> Process ()) -> Match ()
forall a b. (a -> b) -> a -> b
$ Process () -> (String, String) -> Process ()
forall a b. a -> b -> a
const (Process () -> (String, String) -> Process ())
-> Process () -> (String, String) -> Process ()
forall a b. (a -> b) -> a -> b
$ () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return () ]
      case Maybe ()
expectedTimeout of
        Maybe ()
Nothing -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just ()
_  -> String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"Unexpected message arrived..."


-- | Tests that one and only one trace message is produced when a message is
-- received.
testSystemLoggerMxReceive :: TestTransport -> IO ()
testSystemLoggerMxReceive :: TestTransport -> IO ()
testSystemLoggerMxReceive TestTransport
t = TestTransport -> Process () -> (() -> String -> Bool) -> IO ()
forall a.
TestTransport -> Process a -> (a -> String -> Bool) -> IO ()
testSystemLoggerMsg TestTransport
t
    (Process ProcessId
getSelfPid Process ProcessId -> (ProcessId -> 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
>>= (ProcessId -> () -> Process ()) -> () -> ProcessId -> Process ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ())
    (\()
_ String
msg -> String
"MxReceived" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
msg
             -- discard traces of internal messages
          Bool -> Bool -> Bool
&& Bool -> Bool
not (String
":: RegisterReply" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
msg)
    )

-- | Tests that one and only one trace message is produced when a message is
-- sent.
testSystemLoggerMxSent :: TestTransport -> IO ()
testSystemLoggerMxSent :: TestTransport -> IO ()
testSystemLoggerMxSent TestTransport
t = TestTransport -> Process () -> (() -> String -> Bool) -> IO ()
forall a.
TestTransport -> Process a -> (a -> String -> Bool) -> IO ()
testSystemLoggerMsg TestTransport
t
    (Process ProcessId
getSelfPid Process ProcessId -> (ProcessId -> 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
>>= (ProcessId -> () -> Process ()) -> () -> ProcessId -> Process ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ())
    ((String -> Bool) -> () -> String -> Bool
forall a b. a -> b -> a
const ((String -> Bool) -> () -> String -> Bool)
-> (String -> Bool) -> () -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"MxSent")

-- | Tests that one and only one trace message is produced when a process dies.
testSystemLoggerMxProcessDied :: TestTransport -> IO ()
testSystemLoggerMxProcessDied :: TestTransport -> IO ()
testSystemLoggerMxProcessDied TestTransport
t = TestTransport
-> Process ProcessId -> (ProcessId -> String -> Bool) -> IO ()
forall a.
TestTransport -> Process a -> (a -> String -> Bool) -> IO ()
testSystemLoggerMsg TestTransport
t
    (Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    (\ProcessId
pid -> String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf (String -> String -> Bool) -> String -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"MxProcessDied " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ProcessId -> String
forall a. Show a => a -> String
show ProcessId
pid)

-- | Tests that one and only one trace message appears when a process spawns.
testSystemLoggerMxSpawned :: TestTransport -> IO ()
testSystemLoggerMxSpawned :: TestTransport -> IO ()
testSystemLoggerMxSpawned TestTransport
t = TestTransport
-> Process ProcessId -> (ProcessId -> String -> Bool) -> IO ()
forall a.
TestTransport -> Process a -> (a -> String -> Bool) -> IO ()
testSystemLoggerMsg TestTransport
t
    (Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    (\ProcessId
pid -> String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf (String -> String -> Bool) -> String -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"MxSpawned " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ProcessId -> String
forall a. Show a => a -> String
show ProcessId
pid)

-- | Tests that one and only one trace message appears when a process is
-- registered.
testSystemLoggerMxRegistered :: TestTransport -> IO ()
testSystemLoggerMxRegistered :: TestTransport -> IO ()
testSystemLoggerMxRegistered TestTransport
t = TestTransport
-> Process ProcessId -> (ProcessId -> String -> Bool) -> IO ()
forall a.
TestTransport -> Process a -> (a -> String -> Bool) -> IO ()
testSystemLoggerMsg TestTransport
t
    (Process ProcessId
getSelfPid Process ProcessId -> (ProcessId -> 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
>>= String -> ProcessId -> Process ()
register String
"a" Process () -> Process ProcessId -> Process ProcessId
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Process ProcessId
getSelfPid)
    (\ProcessId
self -> String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf (String -> String -> Bool) -> String -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"MxRegistered " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ProcessId -> String
forall a. Show a => a -> String
show ProcessId
self String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
"a")

-- | Tests that one and only one trace message appears when a process is
-- unregistered.
testSystemLoggerMxUnRegistered :: TestTransport -> IO ()
testSystemLoggerMxUnRegistered :: TestTransport -> IO ()
testSystemLoggerMxUnRegistered TestTransport
t = TestTransport
-> Process ProcessId -> (ProcessId -> String -> Bool) -> IO ()
forall a.
TestTransport -> Process a -> (a -> String -> Bool) -> IO ()
testSystemLoggerMsg TestTransport
t
    (Process ProcessId
getSelfPid Process ProcessId -> (ProcessId -> 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
>>= String -> ProcessId -> Process ()
register String
"a" Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Process ()
unregister String
"a" Process () -> Process ProcessId -> Process ProcessId
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Process ProcessId
getSelfPid)
    (\ProcessId
self -> String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf (String -> String -> Bool) -> String -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
"MxUnRegistered " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ProcessId -> String
forall a. Show a => a -> String
show ProcessId
self String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
"a")

tests :: TestTransport -> IO [Test]
tests :: TestTransport -> IO [Test]
tests testtrans :: TestTransport
testtrans@TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
node1 <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  -- if we execute the test cases in parallel, the
  -- various tracers will race with one another and
  -- we'll get garbage results (or worse, deadlocks)
  TestResult ()
lock <- IO (TestResult ()) -> IO (TestResult ())
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TestResult ()) -> IO (TestResult ()))
-> IO (TestResult ()) -> IO (TestResult ())
forall a b. (a -> b) -> a -> b
$ () -> IO (TestResult ())
forall a. a -> IO (MVar a)
newMVar ()
  [Test] -> IO [Test]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [
    String -> [Test] -> Test
testGroup String
"Tracing" [
           String -> IO () -> Test
testCase String
"Spawn Tracing"
             (String
-> LocalNode
-> Bool
-> (TestResult Bool -> Process ())
-> TestResult ()
-> IO ()
forall a.
Eq a =>
String
-> LocalNode
-> a
-> (TestResult a -> Process ())
-> TestResult ()
-> IO ()
synchronisedAssertion
              String
"expected dead process-info to be ProcessInfoNone"
              LocalNode
node1 Bool
True TestResult Bool -> Process ()
testSpawnTracing TestResult ()
lock)
         , String -> IO () -> Test
testCase String
"Recv Tracing (Explicit Pid)"
             (String
-> LocalNode
-> Bool
-> (TestResult Bool -> Process ())
-> TestResult ()
-> IO ()
forall a.
Eq a =>
String
-> LocalNode
-> a
-> (TestResult a -> Process ())
-> TestResult ()
-> IO ()
synchronisedAssertion
              String
"expected a recv trace for the supplied pid"
              LocalNode
node1 Bool
True TestResult Bool -> Process ()
testTraceRecvExplicitPid TestResult ()
lock)
         , String -> IO () -> Test
testCase String
"Recv Tracing (Named Pid)"
             (String
-> LocalNode
-> Bool
-> (TestResult Bool -> Process ())
-> TestResult ()
-> IO ()
forall a.
Eq a =>
String
-> LocalNode
-> a
-> (TestResult a -> Process ())
-> TestResult ()
-> IO ()
synchronisedAssertion
              String
"expected a recv trace for the process registered as 'foobar'"
              LocalNode
node1 Bool
True TestResult Bool -> Process ()
testTraceRecvNamedPid TestResult ()
lock)
         , String -> IO () -> Test
testCase String
"Trace Send(er)"
             (String
-> LocalNode
-> Bool
-> (TestResult Bool -> Process ())
-> TestResult ()
-> IO ()
forall a.
Eq a =>
String
-> LocalNode
-> a
-> (TestResult a -> Process ())
-> TestResult ()
-> IO ()
synchronisedAssertion
              String
"expected a 'send' trace with the requisite fields set"
              LocalNode
node1 Bool
True TestResult Bool -> Process ()
testTraceSending TestResult ()
lock)
         , String -> IO () -> Test
testCase String
"Trace Registration"
              (String
-> LocalNode
-> Bool
-> (TestResult Bool -> Process ())
-> TestResult ()
-> IO ()
forall a.
Eq a =>
String
-> LocalNode
-> a
-> (TestResult a -> Process ())
-> TestResult ()
-> IO ()
synchronisedAssertion
               String
"expected a 'registered' trace"
               LocalNode
node1 Bool
True TestResult Bool -> Process ()
testTraceRegistration TestResult ()
lock)
         , String -> IO () -> Test
testCase String
"Trace Unregistration"
              (String
-> LocalNode
-> Bool
-> (TestResult Bool -> Process ())
-> TestResult ()
-> IO ()
forall a.
Eq a =>
String
-> LocalNode
-> a
-> (TestResult a -> Process ())
-> TestResult ()
-> IO ()
synchronisedAssertion
               String
"expected an 'unregistered' trace"
               LocalNode
node1 Bool
True TestResult Bool -> Process ()
testTraceUnRegistration TestResult ()
lock)
         , String -> IO () -> Test
testCase String
"Trace Layering"
              (String
-> LocalNode
-> ()
-> (TestResult () -> Process ())
-> TestResult ()
-> IO ()
forall a.
Eq a =>
String
-> LocalNode
-> a
-> (TestResult a -> Process ())
-> TestResult ()
-> IO ()
synchronisedAssertion
               String
"expected blah"
               LocalNode
node1 () TestResult () -> Process ()
testTraceLayering TestResult ()
lock)
         , String -> IO () -> Test
testCase String
"Remote Trace Relay"
              (String
-> LocalNode
-> Bool
-> (TestResult Bool -> Process ())
-> TestResult ()
-> IO ()
forall a.
Eq a =>
String
-> LocalNode
-> a
-> (TestResult a -> Process ())
-> TestResult ()
-> IO ()
synchronisedAssertion
               String
"expected blah"
               LocalNode
node1 Bool
True (TestTransport -> TestResult Bool -> Process ()
testRemoteTraceRelay TestTransport
testtrans) TestResult ()
lock)
         , String -> [Test] -> Test
testGroup String
"SystemLoggerTracer"
           [ String -> IO () -> Test
testCase String
"MxReceive" (IO () -> Test) -> IO () -> Test
forall a b. (a -> b) -> a -> b
$ TestTransport -> IO ()
testSystemLoggerMxReceive TestTransport
testtrans
           , String -> IO () -> Test
testCase String
"MxSent" (IO () -> Test) -> IO () -> Test
forall a b. (a -> b) -> a -> b
$ TestTransport -> IO ()
testSystemLoggerMxSent TestTransport
testtrans
           , String -> IO () -> Test
testCase String
"MxProcessDied" (IO () -> Test) -> IO () -> Test
forall a b. (a -> b) -> a -> b
$ TestTransport -> IO ()
testSystemLoggerMxProcessDied TestTransport
testtrans
           , String -> IO () -> Test
testCase String
"MxSpawned" (IO () -> Test) -> IO () -> Test
forall a b. (a -> b) -> a -> b
$ TestTransport -> IO ()
testSystemLoggerMxSpawned TestTransport
testtrans
           , String -> IO () -> Test
testCase String
"MxRegistered" (IO () -> Test) -> IO () -> Test
forall a b. (a -> b) -> a -> b
$ TestTransport -> IO ()
testSystemLoggerMxRegistered TestTransport
testtrans
           , String -> IO () -> Test
testCase String
"MxUnRegistered" (IO () -> Test) -> IO () -> Test
forall a b. (a -> b) -> a -> b
$ TestTransport -> IO ()
testSystemLoggerMxUnRegistered TestTransport
testtrans
           ]
         ] ]