{-# 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)
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
[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
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
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
[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)
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 ())
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
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
[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 () ]
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..."
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
Bool -> Bool -> Bool
&& Bool -> Bool
not (String
":: RegisterReply" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
msg)
)
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")
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)
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)
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")
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
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
]
] ]