module Control.Distributed.Process.Tests.CH (tests) where


import Network.Transport.Test (TestTransport(..))

import Data.Binary (Binary(..))
import Data.Typeable (Typeable)
import Data.Foldable (forM_)
import Data.Function (fix)
import Data.IORef
  ( readIORef
  , writeIORef
  , newIORef
  )
import Control.Concurrent (forkIO, threadDelay, myThreadId, throwTo, ThreadId, yield)
import Control.Concurrent.MVar
  ( MVar
  , newEmptyMVar
  , putMVar
  , takeMVar
  , readMVar
  )
import Control.Monad (replicateM_, replicateM, forever, void, unless, join)
import Control.Exception (SomeException, throwIO, ErrorCall(..))
import Control.Monad.Catch (try, catch, finally, mask, onException)
import Control.Applicative ((<|>))
import qualified Network.Transport as NT (closeEndPoint, EndPointAddress)
import Control.Distributed.Process hiding
  ( try
  , catch
  , finally
  , mask
  , onException
  )
import Control.Distributed.Process.Internal.Types
  ( LocalNode(localEndPoint)
  , ProcessExitException(..)
  , nullProcessId
  , createUnencodedMessage
  )
import Control.Distributed.Process.Node
import Control.Distributed.Process.Tests.Internal.Utils (pause)
import Control.Distributed.Process.Serializable (Serializable)
import Data.Maybe (isNothing, isJust)
import Test.HUnit (Assertion, assertBool, assertEqual, assertFailure)
import Test.Framework (Test, testGroup)
import Test.Framework.Providers.HUnit (testCase)

newtype Ping = Ping ProcessId
  deriving (Typeable, Get Ping
[Ping] -> Put
Ping -> Put
(Ping -> Put) -> Get Ping -> ([Ping] -> Put) -> Binary Ping
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: Ping -> Put
put :: Ping -> Put
$cget :: Get Ping
get :: Get Ping
$cputList :: [Ping] -> Put
putList :: [Ping] -> Put
Binary, Int -> Ping -> ShowS
[Ping] -> ShowS
Ping -> String
(Int -> Ping -> ShowS)
-> (Ping -> String) -> ([Ping] -> ShowS) -> Show Ping
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Ping -> ShowS
showsPrec :: Int -> Ping -> ShowS
$cshow :: Ping -> String
show :: Ping -> String
$cshowList :: [Ping] -> ShowS
showList :: [Ping] -> ShowS
Show)

newtype Pong = Pong ProcessId
  deriving (Typeable, Get Pong
[Pong] -> Put
Pong -> Put
(Pong -> Put) -> Get Pong -> ([Pong] -> Put) -> Binary Pong
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: Pong -> Put
put :: Pong -> Put
$cget :: Get Pong
get :: Get Pong
$cputList :: [Pong] -> Put
putList :: [Pong] -> Put
Binary, Int -> Pong -> ShowS
[Pong] -> ShowS
Pong -> String
(Int -> Pong -> ShowS)
-> (Pong -> String) -> ([Pong] -> ShowS) -> Show Pong
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Pong -> ShowS
showsPrec :: Int -> Pong -> ShowS
$cshow :: Pong -> String
show :: Pong -> String
$cshowList :: [Pong] -> ShowS
showList :: [Pong] -> ShowS
Show)

--------------------------------------------------------------------------------
-- Supporting definitions                                                     --
--------------------------------------------------------------------------------

-- | Like fork, but throw exceptions in the child thread to the parent
forkTry :: IO () -> IO ThreadId
forkTry :: IO () -> IO ThreadId
forkTry IO ()
p = do
  ThreadId
tid <- IO ThreadId
myThreadId
  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> (SomeException -> IO ()) -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch IO ()
p (\SomeException
e -> ThreadId -> SomeException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
tid (SomeException
e :: SomeException))

-- | The ping server from the paper
ping :: Process ()
ping :: Process ()
ping = do
  Pong ProcessId
partner <- Process Pong
forall a. Serializable a => Process a
expect
  ProcessId
self <- Process ProcessId
getSelfPid
  ProcessId -> Ping -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
partner (ProcessId -> Ping
Ping ProcessId
self)
  Process ()
ping

verifyClient :: String -> MVar Bool -> IO ()
verifyClient :: String -> MVar Bool -> IO ()
verifyClient String
s MVar Bool
b = MVar Bool -> IO Bool
forall a. MVar a -> IO a
takeMVar MVar Bool
b IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
s

expectPing :: MVar Bool ->  Process ()
expectPing :: MVar Bool -> Process ()
expectPing MVar Bool
mv = Process Ping
forall a. Serializable a => Process a
expect  Process Ping -> (Ping -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (Ping -> IO ()) -> Ping -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
mv (Bool -> IO ()) -> (Ping -> Bool) -> Ping -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ping -> Bool
checkPing
  where
    checkPing :: Ping -> Bool
checkPing (Ping ProcessId
_) = Bool
True

-- | Quick and dirty synchronous version of whereisRemoteAsync
whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
whereisRemote NodeId
nid String
string = do
  NodeId -> String -> Process ()
whereisRemoteAsync NodeId
nid String
string
  [Match (Maybe ProcessId)] -> Process (Maybe ProcessId)
forall b. [Match b] -> Process b
receiveWait [
      (WhereIsReply -> Process (Maybe ProcessId))
-> Match (Maybe ProcessId)
forall a b. Serializable a => (a -> Process b) -> Match b
match (\(WhereIsReply String
_ Maybe ProcessId
mPid) -> Maybe ProcessId -> Process (Maybe ProcessId)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ProcessId
mPid)
    ]

verifyWhereIsRemote :: NodeId -> String -> Process ProcessId
verifyWhereIsRemote :: NodeId -> String -> Process ProcessId
verifyWhereIsRemote NodeId
n String
s = NodeId -> String -> Process (Maybe ProcessId)
whereisRemote NodeId
n String
s Process (Maybe ProcessId)
-> (Maybe ProcessId -> Process ProcessId) -> Process ProcessId
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Process ProcessId
-> (ProcessId -> Process ProcessId)
-> Maybe ProcessId
-> Process ProcessId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Process ProcessId
forall a b. Serializable a => a -> Process b
die String
"remote name not found") ProcessId -> Process ProcessId
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return

syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()
syncBreakConnection :: (EndPointAddress -> EndPointAddress -> IO ())
-> LocalNode -> LocalNode -> IO ()
syncBreakConnection EndPointAddress -> EndPointAddress -> IO ()
breakConnection LocalNode
nid0 LocalNode
nid1 = do
  MVar ProcessId
m <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  ProcessId
_ <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
nid1 (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ())
-> (ProcessId -> IO ()) -> ProcessId -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
m
  LocalNode -> Process () -> IO ()
runProcess LocalNode
nid0 (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
them <- 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
m
    ProcessId
pinger <- Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ Process () -> Process ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
them ()
    MonitorRef
_ <- NodeId -> Process MonitorRef
monitorNode (LocalNode -> NodeId
localNodeId LocalNode
nid1)
    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
$ EndPointAddress -> EndPointAddress -> IO ()
breakConnection (NodeId -> EndPointAddress
nodeAddress (NodeId -> EndPointAddress) -> NodeId -> EndPointAddress
forall a b. (a -> b) -> a -> b
$ LocalNode -> NodeId
localNodeId LocalNode
nid0)
                             (NodeId -> EndPointAddress
nodeAddress (NodeId -> EndPointAddress) -> NodeId -> EndPointAddress
forall a b. (a -> b) -> a -> b
$ LocalNode -> NodeId
localNodeId LocalNode
nid1)
    NodeMonitorNotification MonitorRef
_ NodeId
_ DiedReason
_ <- Process NodeMonitorNotification
forall a. Serializable a => Process a
expect
    ProcessId -> String -> Process ()
kill ProcessId
pinger String
"finished"
    () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

data Add       = Add    ProcessId Double Double deriving (Typeable)
data Divide    = Divide ProcessId Double Double deriving (Typeable)
data DivByZero = DivByZero deriving (Typeable)

instance Binary Add where
  put :: Add -> Put
put (Add ProcessId
pid Double
x Double
y) = ProcessId -> Put
forall t. Binary t => t -> Put
put ProcessId
pid Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Double -> Put
forall t. Binary t => t -> Put
put Double
x Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Double -> Put
forall t. Binary t => t -> Put
put Double
y
  get :: Get Add
get = ProcessId -> Double -> Double -> Add
Add (ProcessId -> Double -> Double -> Add)
-> Get ProcessId -> Get (Double -> Double -> Add)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ProcessId
forall t. Binary t => Get t
get Get (Double -> Double -> Add) -> Get Double -> Get (Double -> Add)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Double
forall t. Binary t => Get t
get Get (Double -> Add) -> Get Double -> Get Add
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Double
forall t. Binary t => Get t
get

instance Binary Divide where
  put :: Divide -> Put
put (Divide ProcessId
pid Double
x Double
y) = ProcessId -> Put
forall t. Binary t => t -> Put
put ProcessId
pid Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Double -> Put
forall t. Binary t => t -> Put
put Double
x Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Double -> Put
forall t. Binary t => t -> Put
put Double
y
  get :: Get Divide
get = ProcessId -> Double -> Double -> Divide
Divide (ProcessId -> Double -> Double -> Divide)
-> Get ProcessId -> Get (Double -> Double -> Divide)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ProcessId
forall t. Binary t => Get t
get Get (Double -> Double -> Divide)
-> Get Double -> Get (Double -> Divide)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Double
forall t. Binary t => Get t
get Get (Double -> Divide) -> Get Double -> Get Divide
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Double
forall t. Binary t => Get t
get

instance Binary DivByZero where
  put :: DivByZero -> Put
put DivByZero
DivByZero = () -> Put
forall a. a -> PutM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  get :: Get DivByZero
get = DivByZero -> Get DivByZero
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return DivByZero
DivByZero

-- The math server from the paper
math :: Process ()
math :: Process ()
math = do
  [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait
    [ (Add -> Process ()) -> Match ()
forall a b. Serializable a => (a -> Process b) -> Match b
match (\(Add ProcessId
pid Double
x Double
y) -> ProcessId -> Double -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
y))
    , (Divide -> Bool) -> (Divide -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(Divide ProcessId
_   Double
_ Double
y) -> Double
y Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0)
              (\(Divide ProcessId
pid Double
x Double
y) -> ProcessId -> Double -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid (Double
x Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
y))
    , (Divide -> Process ()) -> Match ()
forall a b. Serializable a => (a -> Process b) -> Match b
match (\(Divide ProcessId
pid Double
_ Double
_) -> ProcessId -> DivByZero -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid DivByZero
DivByZero)
    ]
  Process ()
math

-- | Monitor or link to a remote node
monitorOrLink :: Bool            -- ^ 'True' for monitor, 'False' for link
              -> ProcessId       -- ^ Process to monitor/link to
              -> Maybe (MVar ()) -- ^ MVar to signal on once the monitor has been set up
              -> Process (Maybe MonitorRef)
monitorOrLink :: Bool -> ProcessId -> Maybe (MVar ()) -> Process (Maybe MonitorRef)
monitorOrLink Bool
mOrL ProcessId
pid Maybe (MVar ())
mSignal = do
  Maybe MonitorRef
result <- if Bool
mOrL then MonitorRef -> Maybe MonitorRef
forall a. a -> Maybe a
Just (MonitorRef -> Maybe MonitorRef)
-> Process MonitorRef -> Process (Maybe MonitorRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProcessId -> Process MonitorRef
monitor ProcessId
pid
                    else ProcessId -> Process ()
link ProcessId
pid Process ()
-> Process (Maybe MonitorRef) -> Process (Maybe MonitorRef)
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe MonitorRef -> Process (Maybe MonitorRef)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe MonitorRef
forall a. Maybe a
Nothing
  -- Monitor is asynchronous, which usually does not matter but if we want a
  --  *specific* signal then it does. Therefore we wait until the MonitorRef is
  -- listed in the ProcessInfo and hope that this means the monitor has been set
  -- up.
  Maybe (MVar ()) -> (MVar () -> Process ProcessId) -> Process ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (MVar ())
mSignal ((MVar () -> Process ProcessId) -> Process ())
-> (MVar () -> Process ProcessId) -> Process ()
forall a b. (a -> b) -> a -> b
$ \MVar ()
signal -> do
    ProcessId
self <- Process ProcessId
getSelfPid
    Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ do
      let waitForMOrL :: Process ()
waitForMOrL = do
            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
100000
            Maybe ProcessInfo
mpinfo <- ProcessId -> Process (Maybe ProcessInfo)
getProcessInfo ProcessId
pid
            case Maybe ProcessInfo
mpinfo of
              Maybe ProcessInfo
Nothing -> Process ()
waitForMOrL
              Just ProcessInfo
pinfo ->
               if Bool
mOrL then
                 Bool -> Process () -> Process ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe MonitorRef
result Maybe MonitorRef -> Maybe MonitorRef -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId -> [(ProcessId, MonitorRef)] -> Maybe MonitorRef
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ProcessId
self (ProcessInfo -> [(ProcessId, MonitorRef)]
infoMonitors ProcessInfo
pinfo)) Process ()
waitForMOrL
               else
                 Bool -> Process () -> Process ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ProcessId -> [ProcessId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ProcessId
self ([ProcessId] -> Bool) -> [ProcessId] -> Bool
forall a b. (a -> b) -> a -> b
$ ProcessInfo -> [ProcessId]
infoLinks ProcessInfo
pinfo) Process ()
waitForMOrL
      Process ()
waitForMOrL
      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 () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
signal ()
  Maybe MonitorRef -> Process (Maybe MonitorRef)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe MonitorRef
result

monitorTestProcess :: ProcessId       -- Process to monitor/link to
                   -> Bool            -- 'True' for monitor, 'False' for link
                   -> Bool            -- Should we unmonitor?
                   -> DiedReason      -- Expected cause of death
                   -> Maybe (MVar ()) -- Signal for 'monitor set up'
                   -> MVar ()         -- Signal for successful termination
                   -> Process ()
monitorTestProcess :: ProcessId
-> Bool
-> Bool
-> DiedReason
-> Maybe (MVar ())
-> MVar ()
-> Process ()
monitorTestProcess ProcessId
theirAddr Bool
mOrL Bool
un DiedReason
reason Maybe (MVar ())
monitorSetup MVar ()
done =
  Process () -> (ProcessLinkException -> Process ()) -> Process ()
forall e a.
(HasCallStack, Exception e) =>
Process a -> (e -> Process a) -> Process a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch (do Maybe MonitorRef
mRef <- Bool -> ProcessId -> Maybe (MVar ()) -> Process (Maybe MonitorRef)
monitorOrLink Bool
mOrL ProcessId
theirAddr Maybe (MVar ())
monitorSetup
            case (Bool
un, Maybe MonitorRef
mRef) of
              (Bool
True, Maybe MonitorRef
Nothing) -> do
                ProcessId -> Process ()
unlink ProcessId
theirAddr
                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 () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ()
              (Bool
True, Just MonitorRef
ref) -> do
                MonitorRef -> Process ()
unmonitor MonitorRef
ref
                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 () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ()
              (Bool
False, Maybe MonitorRef
ref) -> do
                [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
ref' ProcessId
pid DiedReason
reason') -> do
                              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
$ do
                                HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Bad Monitor Signal"
                                           (MonitorRef -> Maybe MonitorRef
forall a. a -> Maybe a
Just MonitorRef
ref' Maybe MonitorRef -> Maybe MonitorRef -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe MonitorRef
ref Bool -> Bool -> Bool
&& ProcessId
pid ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
theirAddr Bool -> Bool -> Bool
&&
                                              Bool
mOrL Bool -> Bool -> Bool
&& DiedReason
reason DiedReason -> DiedReason -> Bool
forall a. Eq a => a -> a -> Bool
== DiedReason
reason')
                                MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ())
                  ]
        )
        (\(ProcessLinkException ProcessId
pid DiedReason
reason') -> do
            (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
$ HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"link exception unmatched" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$
              ProcessId
pid ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
theirAddr Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
mOrL Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
un Bool -> Bool -> Bool
&& DiedReason
reason DiedReason -> DiedReason -> Bool
forall a. Eq a => a -> a -> Bool
== DiedReason
reason')
            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 () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ()
        )

--------------------------------------------------------------------------------
-- The tests proper                                                           --
--------------------------------------------------------------------------------

-- | Basic ping test
testPing :: TestTransport -> Assertion
testPing :: TestTransport -> IO ()
testPing TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
..} = do
  MVar ProcessId
serverAddr <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
clientDone <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  -- Server
  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
addr <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode Process ()
ping
    MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
serverAddr ProcessId
addr

  -- Client
  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
pingServer <- MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar MVar ProcessId
serverAddr

    let numPings :: Int
numPings = Int
10000

    LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ProcessId
pid <- Process ProcessId
getSelfPid
      Int -> Process () -> Process ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
numPings (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ do
        ProcessId -> Pong -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pingServer (ProcessId -> Pong
Pong ProcessId
pid)
        Maybe Ping
p <- Int -> Process (Maybe Ping)
forall a. Serializable a => Int -> Process (Maybe a)
expectTimeout Int
3000000
        case Maybe Ping
p of
          Just (Ping ProcessId
_) -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Maybe Ping
Nothing       -> String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"Failed to receive Ping"

    MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
clientDone ()

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
clientDone

-- | Monitor a process on an unreachable node
testMonitorUnreachable :: TestTransport -> Bool -> Bool -> Assertion
testMonitorUnreachable :: TestTransport -> Bool -> Bool -> IO ()
testMonitorUnreachable TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} Bool
mOrL Bool
un = do
  MVar ProcessId
deadProcess <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
addr <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode Process ()
forall a. Serializable a => Process a
expect
    LocalNode -> IO ()
closeLocalNode LocalNode
localNode
    MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
deadProcess ProcessId
addr

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
theirAddr <- MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar MVar ProcessId
deadProcess
    LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$
      ProcessId
-> Bool
-> Bool
-> DiedReason
-> Maybe (MVar ())
-> MVar ()
-> Process ()
monitorTestProcess ProcessId
theirAddr Bool
mOrL Bool
un DiedReason
DiedDisconnect Maybe (MVar ())
forall a. Maybe a
Nothing MVar ()
done

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

-- | Monitor a process which terminates normally
testMonitorNormalTermination :: TestTransport -> Bool -> Bool -> Assertion
testMonitorNormalTermination :: TestTransport -> Bool -> Bool -> IO ()
testMonitorNormalTermination TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} Bool
mOrL Bool
un = do
  MVar ()
monitorSetup <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  MVar ProcessId
monitoredProcess <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
addr <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> 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
$ MVar () -> IO ()
forall a. MVar a -> IO a
readMVar MVar ()
monitorSetup
    MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
monitoredProcess ProcessId
addr

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
theirAddr <- MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar MVar ProcessId
monitoredProcess
    LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$
      ProcessId
-> Bool
-> Bool
-> DiedReason
-> Maybe (MVar ())
-> MVar ()
-> Process ()
monitorTestProcess ProcessId
theirAddr Bool
mOrL Bool
un DiedReason
DiedNormal (MVar () -> Maybe (MVar ())
forall a. a -> Maybe a
Just MVar ()
monitorSetup) MVar ()
done

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

-- | Monitor a process which terminates abnormally
testMonitorAbnormalTermination :: TestTransport -> Bool -> Bool -> Assertion
testMonitorAbnormalTermination :: TestTransport -> Bool -> Bool -> IO ()
testMonitorAbnormalTermination TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} Bool
mOrL Bool
un = do
  MVar ()
monitorSetup <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  MVar ProcessId
monitoredProcess <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  let err :: IOError
err = String -> IOError
userError String
"Abnormal termination"

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
addr <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId)
-> (IO () -> Process ()) -> IO () -> IO ProcessId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ProcessId) -> IO () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
      MVar () -> IO ()
forall a. MVar a -> IO a
readMVar MVar ()
monitorSetup
      IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOError
err
    MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
monitoredProcess ProcessId
addr

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
theirAddr <- MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar MVar ProcessId
monitoredProcess
    LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$
      ProcessId
-> Bool
-> Bool
-> DiedReason
-> Maybe (MVar ())
-> MVar ()
-> Process ()
monitorTestProcess ProcessId
theirAddr Bool
mOrL Bool
un (String -> DiedReason
DiedException (IOError -> String
forall a. Show a => a -> String
show IOError
err)) (MVar () -> Maybe (MVar ())
forall a. a -> Maybe a
Just MVar ()
monitorSetup) MVar ()
done

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

-- | Monitor a local process that is already dead
testMonitorLocalDeadProcess :: TestTransport -> Bool -> Bool -> Assertion
testMonitorLocalDeadProcess :: TestTransport -> Bool -> Bool -> IO ()
testMonitorLocalDeadProcess TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} Bool
mOrL Bool
un = do
  MVar ProcessId
processAddr <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
addr <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
processAddr ProcessId
addr

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
theirAddr <- MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar MVar ProcessId
processAddr
    LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ProcessId -> Process MonitorRef
monitor ProcessId
theirAddr
      -- wait for the process to die
      Process ProcessMonitorNotification
forall a. Serializable a => Process a
expect :: Process ProcessMonitorNotification
      ProcessId
-> Bool
-> Bool
-> DiedReason
-> Maybe (MVar ())
-> MVar ()
-> Process ()
monitorTestProcess ProcessId
theirAddr Bool
mOrL Bool
un DiedReason
DiedUnknownId Maybe (MVar ())
forall a. Maybe a
Nothing MVar ()
done

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

-- | Monitor a remote process that is already dead
testMonitorRemoteDeadProcess :: TestTransport -> Bool -> Bool -> Assertion
testMonitorRemoteDeadProcess :: TestTransport -> Bool -> Bool -> IO ()
testMonitorRemoteDeadProcess TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} Bool
mOrL Bool
un = do
  MVar ()
processDead <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  MVar ProcessId
processAddr <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
addr <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId)
-> (IO () -> Process ()) -> IO () -> IO ProcessId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ProcessId) -> IO () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
processDead ()
    MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
processAddr ProcessId
addr

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
theirAddr <- MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar MVar ProcessId
processAddr
    MVar () -> IO ()
forall a. MVar a -> IO a
readMVar MVar ()
processDead
    LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ProcessId
-> Bool
-> Bool
-> DiedReason
-> Maybe (MVar ())
-> MVar ()
-> Process ()
monitorTestProcess ProcessId
theirAddr Bool
mOrL Bool
un DiedReason
DiedUnknownId Maybe (MVar ())
forall a. Maybe a
Nothing MVar ()
done

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

-- | Monitor a process that becomes disconnected
testMonitorDisconnect :: TestTransport -> Bool -> Bool -> Assertion
testMonitorDisconnect :: TestTransport -> Bool -> Bool -> IO ()
testMonitorDisconnect TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} Bool
mOrL Bool
un = do
  MVar ProcessId
processAddr <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar ProcessId
processAddr2 <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
monitorSetup <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
addr <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ Process ()
forall a. Serializable a => Process a
expect
    ProcessId
addr2 <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
processAddr ProcessId
addr
    MVar () -> IO ()
forall a. MVar a -> IO a
readMVar MVar ()
monitorSetup
    EndPoint -> IO ()
NT.closeEndPoint (LocalNode -> EndPoint
localEndPoint LocalNode
localNode)
    MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
processAddr2 ProcessId
addr2

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
theirAddr <- MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar MVar ProcessId
processAddr
    LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
      ProcessId
lc <- 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
readMVar MVar ProcessId
processAddr2
      ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
lc ()
    LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ProcessId
-> Bool
-> Bool
-> DiedReason
-> Maybe (MVar ())
-> MVar ()
-> Process ()
monitorTestProcess ProcessId
theirAddr Bool
mOrL Bool
un DiedReason
DiedDisconnect (MVar () -> Maybe (MVar ())
forall a. a -> Maybe a
Just MVar ()
monitorSetup) MVar ()
done

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

-- | Test the math server (i.e., receiveWait)
testMath :: TestTransport -> Assertion
testMath :: TestTransport -> IO ()
testMath TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  MVar ProcessId
serverAddr <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar (Double, Double, DivByZero)
clientDone <- IO (MVar (Double, Double, DivByZero))
forall a. IO (MVar a)
newEmptyMVar

  -- Server
  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
addr <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode Process ()
math
    MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
serverAddr ProcessId
addr

  -- Client
  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
mathServer <- MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar MVar ProcessId
serverAddr

    LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ProcessId
pid <- Process ProcessId
getSelfPid
      ProcessId -> Add -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
mathServer (ProcessId -> Double -> Double -> Add
Add ProcessId
pid Double
1 Double
2)
      Double
three <- Process Double
forall a. Serializable a => Process a
expect :: Process Double
      ProcessId -> Divide -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
mathServer (ProcessId -> Double -> Double -> Divide
Divide ProcessId
pid Double
8 Double
2)
      Double
four <- Process Double
forall a. Serializable a => Process a
expect :: Process Double
      ProcessId -> Divide -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
mathServer (ProcessId -> Double -> Double -> Divide
Divide ProcessId
pid Double
8 Double
0)
      DivByZero
divByZ <- Process DivByZero
forall a. Serializable a => Process a
expect
      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 (Double, Double, DivByZero)
-> (Double, Double, DivByZero) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Double, Double, DivByZero)
clientDone (Double
three, Double
four, DivByZero
divByZ)

  (Double, Double, DivByZero)
res <- MVar (Double, Double, DivByZero) -> IO (Double, Double, DivByZero)
forall a. MVar a -> IO a
takeMVar MVar (Double, Double, DivByZero)
clientDone
  case (Double, Double, DivByZero)
res of
    (Double
3, Double
4, DivByZero
DivByZero) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (Double, Double, DivByZero)
_                 -> String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Something went horribly wrong"

-- | Send first message (i.e. connect) to an already terminated process
-- (without monitoring); then send another message to a second process on
-- the same remote node (we're checking that the remote node did not die)
testSendToTerminated :: TestTransport -> Assertion
testSendToTerminated :: TestTransport -> IO ()
testSendToTerminated TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  MVar ProcessId
serverAddr1 <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar ProcessId
serverAddr2 <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar Bool
clientDone <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    MVar ()
terminated <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
addr1 <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> 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
$ MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
terminated ()
    ProcessId
addr2 <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ Process ()
ping
    MVar () -> IO ()
forall a. MVar a -> IO a
readMVar MVar ()
terminated
    MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
serverAddr1 ProcessId
addr1
    MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
serverAddr2 ProcessId
addr2

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
server1 <- MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar MVar ProcessId
serverAddr1
    ProcessId
server2 <- MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar MVar ProcessId
serverAddr2
    LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ProcessId
pid <- Process ProcessId
getSelfPid
      ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
server1 String
"Hi"
      ProcessId -> Pong -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
server2 (ProcessId -> Pong
Pong ProcessId
pid)
      MVar Bool -> Process ()
expectPing MVar Bool
clientDone

  String -> MVar Bool -> IO ()
verifyClient String
"Expected Ping from server" MVar Bool
clientDone

-- | Test (non-zero) timeout
testTimeout :: TestTransport -> Assertion
testTimeout :: TestTransport -> IO ()
testTimeout TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  MVar Bool
done <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar

  LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe ()
res <- Int -> [Match ()] -> Process (Maybe ())
forall b. Int -> [Match b] -> Process (Maybe b)
receiveTimeout Int
1000000 [(Add -> Process ()) -> Match ()
forall a b. Serializable a => (a -> Process b) -> Match b
match (\Add{} -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())]
    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 Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
done (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe ()
res Maybe () -> Maybe () -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ()
forall a. Maybe a
Nothing

  String -> MVar Bool -> IO ()
verifyClient String
"Expected receiveTimeout to timeout..." MVar Bool
done

-- | Test zero timeout
testTimeout0 :: TestTransport -> Assertion
testTimeout0 :: TestTransport -> IO ()
testTimeout0 TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  MVar ProcessId
serverAddr <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar Bool
clientDone <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
addr <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
      -- Variation on the venerable ping server which uses a zero timeout
      ProcessId
partner <- (Process ProcessId -> Process ProcessId) -> Process ProcessId
forall a. (a -> a) -> a
fix ((Process ProcessId -> Process ProcessId) -> Process ProcessId)
-> (Process ProcessId -> Process ProcessId) -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ \Process ProcessId
loop ->
        Int -> [Match ProcessId] -> Process (Maybe ProcessId)
forall b. Int -> [Match b] -> Process (Maybe b)
receiveTimeout Int
0 [(Pong -> Process ProcessId) -> Match ProcessId
forall a b. Serializable a => (a -> Process b) -> Match b
match (\(Pong ProcessId
partner) -> ProcessId -> Process ProcessId
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessId
partner)]
          Process (Maybe ProcessId)
-> (Maybe ProcessId -> Process ProcessId) -> Process ProcessId
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Process ProcessId
-> (ProcessId -> Process ProcessId)
-> Maybe ProcessId
-> Process ProcessId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO ()
threadDelay Int
100000) 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
loop) ProcessId -> Process ProcessId
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return
      ProcessId
self <- Process ProcessId
getSelfPid
      ProcessId -> Ping -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
partner (ProcessId -> Ping
Ping ProcessId
self)
    MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
serverAddr ProcessId
addr

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
server <- MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar MVar ProcessId
serverAddr
    LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ProcessId
pid <- Process ProcessId
getSelfPid
      -- Send a bunch of messages. A large number of messages that the server
      -- is not interested in, and then a single message that it wants
      Int -> Process () -> Process ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
10000 (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
server String
"Irrelevant message"
      ProcessId -> Pong -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
server (ProcessId -> Pong
Pong ProcessId
pid)
      MVar Bool -> Process ()
expectPing MVar Bool
clientDone

  String -> MVar Bool -> IO ()
verifyClient String
"Expected Ping from server" MVar Bool
clientDone

-- | Test typed channels
testTypedChannels :: TestTransport -> Assertion
testTypedChannels :: TestTransport -> IO ()
testTypedChannels TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  MVar (SendPort (SendPort Bool, Int))
serverChannel <- IO (MVar (SendPort (SendPort Bool, Int)))
forall a. IO (MVar a)
newEmptyMVar :: IO (MVar (SendPort (SendPort Bool, Int)))
  MVar Bool
clientDone <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
      (SendPort (SendPort Bool, Int)
serverSendPort, ReceivePort (SendPort Bool, Int)
rport) <- Process
  (SendPort (SendPort Bool, Int), ReceivePort (SendPort Bool, Int))
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
      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 (SendPort (SendPort Bool, Int))
-> SendPort (SendPort Bool, Int) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (SendPort (SendPort Bool, Int))
serverChannel SendPort (SendPort Bool, Int)
serverSendPort
      (SendPort Bool
clientSendPort, Int
i) <- ReceivePort (SendPort Bool, Int) -> Process (SendPort Bool, Int)
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort (SendPort Bool, Int)
rport
      SendPort Bool -> Bool -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort Bool
clientSendPort (Int -> Bool
forall a. Integral a => a -> Bool
even Int
i)
    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    SendPort (SendPort Bool, Int)
serverSendPort <- MVar (SendPort (SendPort Bool, Int))
-> IO (SendPort (SendPort Bool, Int))
forall a. MVar a -> IO a
readMVar MVar (SendPort (SendPort Bool, Int))
serverChannel
    LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (SendPort Bool
clientSendPort, ReceivePort Bool
rport) <- Process (SendPort Bool, ReceivePort Bool)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
      SendPort (SendPort Bool, Int) -> (SendPort Bool, Int) -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort (SendPort Bool, Int)
serverSendPort (SendPort Bool
clientSendPort, Int
5)
      Bool
ch <- ReceivePort Bool -> Process Bool
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort Bool
rport
      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 Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
clientDone (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool
ch Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False

  String -> MVar Bool -> IO ()
verifyClient String
"Expected channel to send 'False'" MVar Bool
clientDone

-- | Test merging receive ports
testMergeChannels :: TestTransport -> Assertion
testMergeChannels :: TestTransport -> IO ()
testMergeChannels TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    LocalNode -> Bool -> String -> IO ()
testFlat LocalNode
localNode Bool
True          String
"aaabbbccc"
    LocalNode -> Bool -> String -> IO ()
testFlat LocalNode
localNode Bool
False         String
"abcabcabc"
    LocalNode -> Bool -> Bool -> String -> IO ()
testNested LocalNode
localNode Bool
True Bool
True   String
"aaabbbcccdddeeefffggghhhiii"
    LocalNode -> Bool -> Bool -> String -> IO ()
testNested LocalNode
localNode Bool
True Bool
False  String
"adgadgadgbehbehbehcficficfi"
    LocalNode -> Bool -> Bool -> String -> IO ()
testNested LocalNode
localNode Bool
False Bool
True  String
"abcabcabcdefdefdefghighighi"
    LocalNode -> Bool -> Bool -> String -> IO ()
testNested LocalNode
localNode Bool
False Bool
False String
"adgbehcfiadgbehcfiadgbehcfi"
    LocalNode -> Bool -> IO ()
testBlocked LocalNode
localNode Bool
True
    LocalNode -> Bool -> IO ()
testBlocked LocalNode
localNode Bool
False
  where
    -- Single layer of merging
    testFlat :: LocalNode -> Bool -> String -> IO ()
    testFlat :: LocalNode -> Bool -> String -> IO ()
testFlat LocalNode
localNode Bool
biased String
expected = do
      MVar Bool
done <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar
      LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
        [ReceivePort Char]
rs  <- (Char -> Process (ReceivePort Char))
-> String -> Process [ReceivePort Char]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Char -> Process (ReceivePort Char)
charChannel String
"abc"
        ReceivePort Char
m   <- Bool -> [ReceivePort Char] -> Process (ReceivePort Char)
forall a.
Serializable a =>
Bool -> [ReceivePort a] -> Process (ReceivePort a)
mergePorts Bool
biased [ReceivePort Char]
rs
        String
xs  <- Int -> Process Char -> Process String
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
9 (Process Char -> Process String) -> Process Char -> Process String
forall a b. (a -> b) -> a -> b
$ ReceivePort Char -> Process Char
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort Char
m
        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 Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
done (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ String
xs String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
expected
      String -> MVar Bool -> IO ()
verifyClient String
"Expected single layer merge to match expected ordering" MVar Bool
done

    -- Two layers of merging
    testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
    testNested :: LocalNode -> Bool -> Bool -> String -> IO ()
testNested LocalNode
localNode Bool
biasedInner Bool
biasedOuter String
expected = do
      MVar Bool
done <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar
      LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
        [[ReceivePort Char]]
rss  <- (String -> Process [ReceivePort Char])
-> [String] -> Process [[ReceivePort Char]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Char -> Process (ReceivePort Char))
-> String -> Process [ReceivePort Char]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Char -> Process (ReceivePort Char)
charChannel) [String
"abc", String
"def", String
"ghi"]
        [ReceivePort Char]
ms   <- ([ReceivePort Char] -> Process (ReceivePort Char))
-> [[ReceivePort Char]] -> Process [ReceivePort Char]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Bool -> [ReceivePort Char] -> Process (ReceivePort Char)
forall a.
Serializable a =>
Bool -> [ReceivePort a] -> Process (ReceivePort a)
mergePorts Bool
biasedInner) [[ReceivePort Char]]
rss
        ReceivePort Char
m    <- Bool -> [ReceivePort Char] -> Process (ReceivePort Char)
forall a.
Serializable a =>
Bool -> [ReceivePort a] -> Process (ReceivePort a)
mergePorts Bool
biasedOuter [ReceivePort Char]
ms
        String
xs   <- Int -> Process Char -> Process String
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
9 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3) (Process Char -> Process String) -> Process Char -> Process String
forall a b. (a -> b) -> a -> b
$ ReceivePort Char -> Process Char
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort Char
m
        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 Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
done (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ String
xs String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
expected
      String -> MVar Bool -> IO ()
verifyClient String
"Expected nested channels to match expeted ordering" MVar Bool
done

    -- Test that if no messages are (immediately) available, the scheduler makes no difference
    testBlocked :: LocalNode -> Bool -> IO ()
    testBlocked :: LocalNode -> Bool -> IO ()
testBlocked LocalNode
localNode Bool
biased = do
      [MVar (SendPort Char)]
vs <- Int -> IO (MVar (SendPort Char)) -> IO [MVar (SendPort Char)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
3 IO (MVar (SendPort Char))
forall a. IO (MVar a)
newEmptyMVar
      MVar Bool
done <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar

      LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
        [SendPort Char]
ss <- IO [SendPort Char] -> Process [SendPort Char]
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [SendPort Char] -> Process [SendPort Char])
-> IO [SendPort Char] -> Process [SendPort Char]
forall a b. (a -> b) -> a -> b
$ (MVar (SendPort Char) -> IO (SendPort Char))
-> [MVar (SendPort Char)] -> IO [SendPort Char]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM MVar (SendPort Char) -> IO (SendPort Char)
forall a. MVar a -> IO a
readMVar [MVar (SendPort Char)]
vs
        case [SendPort Char]
ss of
          [SendPort Char
sa, SendPort Char
sb, SendPort Char
sc] ->
            ((SendPort Char, Char) -> Process ())
-> [(SendPort Char, Char)] -> Process ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Process ()
pause Int
10000) (Process () -> Process ())
-> ((SendPort Char, Char) -> Process ())
-> (SendPort Char, Char)
-> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SendPort Char -> Char -> Process ())
-> (SendPort Char, Char) -> Process ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SendPort Char -> Char -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan)
              [ -- a, b, c
                (SendPort Char
sa, Char
'a')
              , (SendPort Char
sb, Char
'b')
              , (SendPort Char
sc, Char
'c')
                -- a, c, b
              , (SendPort Char
sa, Char
'a')
              , (SendPort Char
sc, Char
'c')
              , (SendPort Char
sb, Char
'b')
                -- b, a, c
              , (SendPort Char
sb, Char
'b')
              , (SendPort Char
sa, Char
'a')
              , (SendPort Char
sc, Char
'c')
                -- b, c, a
              , (SendPort Char
sb, Char
'b')
              , (SendPort Char
sc, Char
'c')
              , (SendPort Char
sa, Char
'a')
                -- c, a, b
              , (SendPort Char
sc, Char
'c')
              , (SendPort Char
sa, Char
'a')
              , (SendPort Char
sb, Char
'b')
                -- c, b, a
              , (SendPort Char
sc, Char
'c')
              , (SendPort Char
sb, Char
'b')
              , (SendPort Char
sa, Char
'a')
              ]
          [SendPort Char]
_ -> String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"Something went horribly wrong"

      LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
        ([SendPort Char]
ss, [ReceivePort Char]
rs) <- [(SendPort Char, ReceivePort Char)]
-> ([SendPort Char], [ReceivePort Char])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(SendPort Char, ReceivePort Char)]
 -> ([SendPort Char], [ReceivePort Char]))
-> Process [(SendPort Char, ReceivePort Char)]
-> Process ([SendPort Char], [ReceivePort Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Process (SendPort Char, ReceivePort Char)
-> Process [(SendPort Char, ReceivePort Char)]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
3 Process (SendPort Char, ReceivePort Char)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
        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 (SendPort Char), SendPort Char) -> IO ())
-> [(MVar (SendPort Char), SendPort Char)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((MVar (SendPort Char) -> SendPort Char -> IO ())
-> (MVar (SendPort Char), SendPort Char) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry MVar (SendPort Char) -> SendPort Char -> IO ()
forall a. MVar a -> a -> IO ()
putMVar) ([(MVar (SendPort Char), SendPort Char)] -> IO ())
-> [(MVar (SendPort Char), SendPort Char)] -> IO ()
forall a b. (a -> b) -> a -> b
$ [MVar (SendPort Char)]
-> [SendPort Char] -> [(MVar (SendPort Char), SendPort Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip [MVar (SendPort Char)]
vs [SendPort Char]
ss
        ReceivePort Char
m  <- Bool -> [ReceivePort Char] -> Process (ReceivePort Char)
forall a.
Serializable a =>
Bool -> [ReceivePort a] -> Process (ReceivePort a)
mergePorts Bool
biased [ReceivePort Char]
rs
        String
xs <- Int -> Process Char -> Process String
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
6 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3) (Process Char -> Process String) -> Process Char -> Process String
forall a b. (a -> b) -> a -> b
$ ReceivePort Char -> Process Char
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort Char
m
        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 Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
done (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ String
xs String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"abcacbbacbcacabcba"

      String -> MVar Bool -> IO ()
verifyClient String
"Expected merged ports to match expected ordering" MVar Bool
done

    mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)
    mergePorts :: forall a.
Serializable a =>
Bool -> [ReceivePort a] -> Process (ReceivePort a)
mergePorts Bool
True  = [ReceivePort a] -> Process (ReceivePort a)
forall a.
Serializable a =>
[ReceivePort a] -> Process (ReceivePort a)
mergePortsBiased
    mergePorts Bool
False = [ReceivePort a] -> Process (ReceivePort a)
forall a.
Serializable a =>
[ReceivePort a] -> Process (ReceivePort a)
mergePortsRR

    charChannel :: Char -> Process (ReceivePort Char)
    charChannel :: Char -> Process (ReceivePort Char)
charChannel Char
c = do
      (SendPort Char
sport, ReceivePort Char
rport) <- Process (SendPort Char, ReceivePort Char)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
      Int -> Process () -> Process ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
3 (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ SendPort Char -> Char -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort Char
sport Char
c
      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
10000 -- Make sure messages have been sent
      ReceivePort Char -> Process (ReceivePort Char)
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ReceivePort Char
rport

testTerminate :: TestTransport -> Assertion
testTerminate :: TestTransport -> IO ()
testTerminate TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Either ProcessTerminationException ()
e <- Process () -> Process (Either ProcessTerminationException ())
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try Process ()
forall a. Process a
terminate :: Process (Either ProcessTerminationException ())
    if (ProcessTerminationException -> String)
-> (() -> String)
-> Either ProcessTerminationException ()
-> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ProcessTerminationException -> String
forall a. Show a => a -> String
show () -> String
forall a. Show a => a -> String
show Either ProcessTerminationException ()
e String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessTerminationException -> String
forall a. Show a => a -> String
show ProcessTerminationException
ProcessTerminationException
      then () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      else String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"Unexpected result from terminate"

testMonitorNode :: TestTransport -> Assertion
testMonitorNode :: TestTransport -> IO ()
testMonitorNode TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  [LocalNode
node1, LocalNode
node2] <- Int -> IO LocalNode -> IO [LocalNode]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 (IO LocalNode -> IO [LocalNode]) -> IO LocalNode -> IO [LocalNode]
forall a b. (a -> b) -> a -> b
$ Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  MVar Bool
done <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar

  LocalNode -> IO ()
closeLocalNode LocalNode
node1

  LocalNode -> Process () -> IO ()
runProcess LocalNode
node2 (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    MonitorRef
ref <- NodeId -> Process MonitorRef
monitorNode (LocalNode -> NodeId
localNodeId LocalNode
node1)
    [Match Bool] -> Process Bool
forall b. [Match b] -> Process b
receiveWait [
        (NodeMonitorNotification -> Process Bool) -> Match Bool
forall a b. Serializable a => (a -> Process b) -> Match b
match (\(NodeMonitorNotification MonitorRef
ref' NodeId
nid DiedReason
DiedDisconnect) ->
                Bool -> Process Bool
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Process Bool) -> Bool -> Process Bool
forall a b. (a -> b) -> a -> b
$ MonitorRef
ref MonitorRef -> MonitorRef -> Bool
forall a. Eq a => a -> a -> Bool
== MonitorRef
ref' Bool -> Bool -> Bool
&& NodeId
nid NodeId -> NodeId -> Bool
forall a. Eq a => a -> a -> Bool
== LocalNode -> NodeId
localNodeId LocalNode
node1)
      ] Process Bool -> (Bool -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (Bool -> IO ()) -> Bool -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
done

  String -> MVar Bool -> IO ()
verifyClient String
"Expected NodeMonitorNotification with matching ref & nodeId" MVar Bool
done

testMonitorLiveNode :: TestTransport -> Assertion
testMonitorLiveNode :: TestTransport -> IO ()
testMonitorLiveNode TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  [LocalNode
node1, LocalNode
node2] <- Int -> IO LocalNode -> IO [LocalNode]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 (IO LocalNode -> IO [LocalNode]) -> IO LocalNode -> IO [LocalNode]
forall a b. (a -> b) -> a -> b
$ Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  MVar ()
ready <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
readyr <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  MVar Bool
done <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar

  ProcessId
p <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node1 (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node2 (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    MonitorRef
ref <- NodeId -> Process MonitorRef
monitorNode (LocalNode -> NodeId
localNodeId LocalNode
node1)
    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 () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
ready ()
    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 () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
readyr
    ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
p ()
    [Match Bool] -> Process Bool
forall b. [Match b] -> Process b
receiveWait [
        (NodeMonitorNotification -> Process Bool) -> Match Bool
forall a b. Serializable a => (a -> Process b) -> Match b
match (\(NodeMonitorNotification MonitorRef
ref' NodeId
nid DiedReason
_) ->
                (Bool -> Process Bool
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Process Bool) -> Bool -> Process Bool
forall a b. (a -> b) -> a -> b
$ MonitorRef
ref MonitorRef -> MonitorRef -> Bool
forall a. Eq a => a -> a -> Bool
== MonitorRef
ref' Bool -> Bool -> Bool
&& NodeId
nid NodeId -> NodeId -> Bool
forall a. Eq a => a -> a -> Bool
== LocalNode -> NodeId
localNodeId LocalNode
node1))
      ] Process Bool -> (Bool -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (Bool -> IO ()) -> Bool -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
done

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
ready
  LocalNode -> IO ()
closeLocalNode LocalNode
node1
  MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
readyr ()

  String -> MVar Bool -> IO ()
verifyClient String
"Expected NodeMonitorNotification for LIVE node" MVar Bool
done

testMonitorChannel :: TestTransport -> Assertion
testMonitorChannel :: TestTransport -> IO ()
testMonitorChannel TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
    [LocalNode
node1, LocalNode
node2] <- Int -> IO LocalNode -> IO [LocalNode]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 (IO LocalNode -> IO [LocalNode]) -> IO LocalNode -> IO [LocalNode]
forall a b. (a -> b) -> a -> b
$ Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    MVar Bool
gotNotification <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar

    ProcessId
pid <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node1 (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
      SendPort ()
sport <- Process (SendPort ())
forall a. Serializable a => Process a
expect :: Process (SendPort ())
      MonitorRef
ref <- SendPort () -> Process MonitorRef
forall a. Serializable a => SendPort a -> Process MonitorRef
monitorPort SendPort ()
sport
      [Match Bool] -> Process Bool
forall b. [Match b] -> Process b
receiveWait [
          -- reason might be DiedUnknownId if the receive port is GCed before the
          -- monitor is established (TODO: not sure that this is reasonable)
          (PortMonitorNotification -> Process Bool) -> Match Bool
forall a b. Serializable a => (a -> Process b) -> Match b
match (\(PortMonitorNotification MonitorRef
ref' SendPortId
port' DiedReason
reason) ->
                  Bool -> Process Bool
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Process Bool) -> Bool -> Process Bool
forall a b. (a -> b) -> a -> b
$ MonitorRef
ref' MonitorRef -> MonitorRef -> Bool
forall a. Eq a => a -> a -> Bool
== MonitorRef
ref Bool -> Bool -> Bool
&& SendPortId
port' SendPortId -> SendPortId -> Bool
forall a. Eq a => a -> a -> Bool
== SendPort () -> SendPortId
forall a. SendPort a -> SendPortId
sendPortId SendPort ()
sport Bool -> Bool -> Bool
&&
                    (DiedReason
reason DiedReason -> DiedReason -> Bool
forall a. Eq a => a -> a -> Bool
== DiedReason
DiedNormal Bool -> Bool -> Bool
|| DiedReason
reason DiedReason -> DiedReason -> Bool
forall a. Eq a => a -> a -> Bool
== DiedReason
DiedUnknownId))
        ] Process Bool -> (Bool -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (Bool -> IO ()) -> Bool -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
gotNotification

    LocalNode -> Process () -> IO ()
runProcess LocalNode
node2 (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (SendPort ()
sport, ReceivePort ()
_) <- Process (SendPort (), ReceivePort ())
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan :: Process (SendPort (), ReceivePort ())
      ProcessId -> SendPort () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid SendPort ()
sport
      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
100000

    String -> MVar Bool -> IO ()
verifyClient String
"Expected PortMonitorNotification" MVar Bool
gotNotification

testRegistry :: TestTransport -> Assertion
testRegistry :: TestTransport -> IO ()
testRegistry TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  ProcessId
pingServer <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node Process ()
ping
  ProcessId
deadProcess <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node (() -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

  LocalNode -> Process () -> IO ()
runProcess LocalNode
node (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> ProcessId -> Process ()
register String
"ping" ProcessId
pingServer
    String -> Process (Maybe ProcessId)
whereis String
"ping" Process (Maybe ProcessId)
-> (Maybe 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ())
-> (Maybe ProcessId -> IO ()) -> Maybe ProcessId -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Unexpected ping" (Bool -> IO ())
-> (Maybe ProcessId -> Bool) -> Maybe ProcessId -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ProcessId -> Maybe ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId -> Maybe ProcessId
forall a. a -> Maybe a
Just ProcessId
pingServer)
    ProcessId
us <- Process ProcessId
getSelfPid
    String -> Pong -> Process ()
forall a. Serializable a => String -> a -> Process ()
nsend String
"ping" (ProcessId -> Pong
Pong ProcessId
us)
    [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [
        (Ping -> Bool) -> (Ping -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(Ping ProcessId
pid') -> ProcessId
pingServer ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid') (Process () -> Ping -> Process ()
forall a b. a -> b -> a
const (Process () -> Ping -> Process ())
-> Process () -> Ping -> Process ()
forall a b. (a -> b) -> a -> b
$ () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
      ]
    String -> Maybe Any -> ProcessId -> Process ()
forall {p}. String -> p -> ProcessId -> Process ()
checkRegException String
"dead" Maybe Any
forall a. Maybe a
Nothing ProcessId
deadProcess
    String -> Maybe ProcessId -> ProcessId -> Process ()
forall {p}. String -> p -> ProcessId -> Process ()
checkRegException String
"ping" (ProcessId -> Maybe ProcessId
forall a. a -> Maybe a
Just ProcessId
pingServer) ProcessId
deadProcess
    Process () -> Process (Either ProcessRegistrationException ())
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (String -> Process ()
unregister String
"dead") Process (Either ProcessRegistrationException ())
-> (Either ProcessRegistrationException () -> 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
-> Maybe Any
-> Either ProcessRegistrationException ()
-> Process ()
forall {b} {p} {p}.
Show b =>
p -> p -> Either ProcessRegistrationException b -> Process ()
checkReg String
"dead" Maybe Any
forall a. Maybe a
Nothing
    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 () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ()

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

  where
    checkRegException :: String -> p -> ProcessId -> Process ()
checkRegException String
name p
pid ProcessId
dead =
      Process () -> Process (Either ProcessRegistrationException ())
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (String -> ProcessId -> Process ()
register String
name ProcessId
dead) Process (Either ProcessRegistrationException ())
-> (Either ProcessRegistrationException () -> 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 -> p -> Either ProcessRegistrationException () -> Process ()
forall {b} {p} {p}.
Show b =>
p -> p -> Either ProcessRegistrationException b -> Process ()
checkReg String
name p
pid

    checkReg :: p -> p -> Either ProcessRegistrationException b -> Process ()
checkReg p
_ p
_ Either ProcessRegistrationException b
res =
      case Either ProcessRegistrationException b
res of
        Left (ProcessRegistrationException String
_ Maybe ProcessId
_) -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Either ProcessRegistrationException b
_ -> String -> Process ()
forall a b. Serializable a => a -> Process b
die (String -> Process ()) -> String -> Process ()
forall a b. (a -> b) -> a -> b
$ String
"Unexpected Registration" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Either ProcessRegistrationException b -> String
forall a. Show a => a -> String
show Either ProcessRegistrationException b
res

testRegistryRemoteProcess :: TestTransport -> Assertion
testRegistryRemoteProcess :: TestTransport -> IO ()
testRegistryRemoteProcess TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
node1 <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  LocalNode
node2 <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  ProcessId
pingServer <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node1 Process ()
ping

  LocalNode -> Process () -> IO ()
runProcess LocalNode
node2 (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> ProcessId -> Process ()
register String
"ping" ProcessId
pingServer
    String -> Process (Maybe ProcessId)
whereis String
"ping" Process (Maybe ProcessId)
-> (Maybe 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ())
-> (Maybe ProcessId -> IO ()) -> Maybe ProcessId -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Unexpected ping" (Bool -> IO ())
-> (Maybe ProcessId -> Bool) -> Maybe ProcessId -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe ProcessId -> Maybe ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId -> Maybe ProcessId
forall a. a -> Maybe a
Just ProcessId
pingServer)
    ProcessId
us <- Process ProcessId
getSelfPid
    String -> Pong -> Process ()
forall a. Serializable a => String -> a -> Process ()
nsend String
"ping" (ProcessId -> Pong
Pong ProcessId
us)
    [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [
        (Ping -> Bool) -> (Ping -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(Ping ProcessId
pid') -> ProcessId
pingServer ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid')
                (Process () -> Ping -> Process ()
forall a b. a -> b -> a
const (Process () -> Ping -> Process ())
-> Process () -> Ping -> Process ()
forall a b. (a -> b) -> a -> 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
$ MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ())
      ]

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

testRemoteRegistry :: TestTransport -> Assertion
testRemoteRegistry :: TestTransport -> IO ()
testRemoteRegistry TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
node1 <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  LocalNode
node2 <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable

  ProcessId
pingServer <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node1 Process ()
ping
  ProcessId
deadProcess <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node1 (() -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

  LocalNode -> Process () -> IO ()
runProcess LocalNode
node2 (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let nid1 :: NodeId
nid1 = LocalNode -> NodeId
localNodeId LocalNode
node1
    NodeId -> String -> ProcessId -> Process ()
registerRemoteAsync NodeId
nid1 String
"ping" ProcessId
pingServer
    [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [
       (RegisterReply -> Bool)
-> (RegisterReply -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(RegisterReply String
label' Bool
_ (Just ProcessId
pid)) ->
                    String
"ping" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
label' Bool -> Bool -> Bool
&& ProcessId
pid ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pingServer)
               (\(RegisterReply String
_ Bool
_ Maybe ProcessId
_) -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ]

    ProcessId
pid <- NodeId -> String -> Process ProcessId
verifyWhereIsRemote NodeId
nid1 String
"ping"
    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
$ HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected pindServer to match pid" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ ProcessId
pingServer ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid

    ProcessId
us <- Process ProcessId
getSelfPid
    NodeId -> String -> Pong -> Process ()
forall a. Serializable a => NodeId -> String -> a -> Process ()
nsendRemote NodeId
nid1 String
"ping" (ProcessId -> Pong
Pong ProcessId
us)
    [Match Bool] -> Process Bool
forall b. [Match b] -> Process b
receiveWait [
        (Ping -> Process Bool) -> Match Bool
forall a b. Serializable a => (a -> Process b) -> Match b
match (\(Ping ProcessId
pid') -> Bool -> Process Bool
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Process Bool) -> Bool -> Process Bool
forall a b. (a -> b) -> a -> b
$ ProcessId
pingServer ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid')
      ] Process Bool -> (Bool -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (Bool -> IO ()) -> Bool -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected Ping with ping server's ProcessId"

    -- test that if process was not registered Nothing is returned
    -- in owner field.
    NodeId -> String -> ProcessId -> Process ()
registerRemoteAsync NodeId
nid1 String
"dead" ProcessId
deadProcess
    [Match Bool] -> Process Bool
forall b. [Match b] -> Process b
receiveWait [ (RegisterReply -> Bool)
-> (RegisterReply -> Process Bool) -> Match Bool
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(RegisterReply String
label' Bool
_ Maybe ProcessId
_) -> String
"dead" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
label')
                          (\(RegisterReply String
_ Bool
f Maybe ProcessId
mPid) -> Bool -> Process Bool
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
f Bool -> Bool -> Bool
&& Maybe ProcessId -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ProcessId
mPid))
                ] Process Bool -> (Bool -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (Bool -> IO ()) -> Bool -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected False Nothing in RegisterReply"

    NodeId -> String -> ProcessId -> Process ()
registerRemoteAsync NodeId
nid1 String
"ping" ProcessId
deadProcess
    [Match Bool] -> Process Bool
forall b. [Match b] -> Process b
receiveWait [
        (RegisterReply -> Bool)
-> (RegisterReply -> Process Bool) -> Match Bool
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(RegisterReply String
label' Bool
False Maybe ProcessId
mPid) ->
                     String
"ping" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
label' Bool -> Bool -> Bool
&& Maybe ProcessId -> Bool
forall a. Maybe a -> Bool
isJust Maybe ProcessId
mPid)
                (\(RegisterReply String
_ Bool
f (Just ProcessId
pid'')) -> Bool -> Process Bool
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
f Bool -> Bool -> Bool
&& ProcessId
pid'' ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pingServer))
      ] Process Bool -> (Bool -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (Bool -> IO ()) -> Bool -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected False and (Just alreadyRegisteredPid) in RegisterReply"

    NodeId -> String -> Process ()
unregisterRemoteAsync NodeId
nid1 String
"dead"
    [Match Bool] -> Process Bool
forall b. [Match b] -> Process b
receiveWait [
        (RegisterReply -> Bool)
-> (RegisterReply -> Process Bool) -> Match Bool
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(RegisterReply String
label' Bool
_ Maybe ProcessId
_) -> String
"dead" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
label')
                (\(RegisterReply String
_ Bool
f Maybe ProcessId
mPid) -> Bool -> Process Bool
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
f Bool -> Bool -> Bool
&& Maybe ProcessId -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ProcessId
mPid))
      ] Process Bool -> (Bool -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (Bool -> IO ()) -> Bool -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected False and Nothing in RegisterReply"

testRemoteRegistryRemoteProcess :: TestTransport -> Assertion
testRemoteRegistryRemoteProcess :: TestTransport -> IO ()
testRemoteRegistryRemoteProcess TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
node1 <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  LocalNode
node2 <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  MVar Bool
done <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar

  ProcessId
pingServer <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node2 Process ()
ping

  LocalNode -> Process () -> IO ()
runProcess LocalNode
node2 (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    let nid1 :: NodeId
nid1 = LocalNode -> NodeId
localNodeId LocalNode
node1
    NodeId -> String -> ProcessId -> Process ()
registerRemoteAsync NodeId
nid1 String
"ping" ProcessId
pingServer
    [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [
       (RegisterReply -> Bool)
-> (RegisterReply -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(RegisterReply String
label' Bool
_ Maybe ProcessId
_) -> String
"ping" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
label')
               (\(RegisterReply String
_ Bool
_ Maybe ProcessId
_) -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ]
    ProcessId
pid <- NodeId -> String -> Process ProcessId
verifyWhereIsRemote NodeId
nid1 String
"ping"
    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
$ HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected pingServer to match remote name" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ ProcessId
pingServer ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid
    ProcessId
us <- Process ProcessId
getSelfPid
    NodeId -> String -> Pong -> Process ()
forall a. Serializable a => NodeId -> String -> a -> Process ()
nsendRemote NodeId
nid1 String
"ping" (ProcessId -> Pong
Pong ProcessId
us)
    [Match Bool] -> Process Bool
forall b. [Match b] -> Process b
receiveWait [
        (Ping -> Process Bool) -> Match Bool
forall a b. Serializable a => (a -> Process b) -> Match b
match (\(Ping ProcessId
pid') -> Bool -> Process Bool
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Process Bool) -> Bool -> Process Bool
forall a b. (a -> b) -> a -> b
$ ProcessId
pingServer ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid')
      ] Process Bool -> (Bool -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (Bool -> IO ()) -> Bool -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
done

  String -> MVar Bool -> IO ()
verifyClient String
"Expected Ping with ping server's ProcessId" MVar Bool
done

testSpawnLocal :: TestTransport -> Assertion
testSpawnLocal :: TestTransport -> IO ()
testSpawnLocal TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  MVar Int
done <- IO (MVar Int)
forall a. IO (MVar a)
newEmptyMVar

  LocalNode -> Process () -> IO ()
runProcess LocalNode
node (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
us <- Process ProcessId
getSelfPid

    ProcessId
pid <- Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ do
      SendPort Int
sport <- Process (SendPort Int)
forall a. Serializable a => Process a
expect
      SendPort Int -> Int -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort Int
sport (Int
1234 :: Int)

    SendPort Int
sport <- (ReceivePort Int -> Process ()) -> Process (SendPort Int)
forall a.
Serializable a =>
(ReceivePort a -> Process ()) -> Process (SendPort a)
spawnChannelLocal ((ReceivePort Int -> Process ()) -> Process (SendPort Int))
-> (ReceivePort Int -> Process ()) -> Process (SendPort Int)
forall a b. (a -> b) -> a -> b
$
      \ReceivePort Int
rport -> (ReceivePort Int -> Process Int
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort Int
rport :: Process Int) Process Int -> (Int -> 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 -> Int -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
us

    ProcessId -> SendPort Int -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid SendPort Int
sport
    Process Int
forall a. Serializable a => Process a
expect Process Int -> (Int -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (Int -> IO ()) -> Int -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar Int -> Int -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Int
done

  Int
res <- MVar Int -> IO Int
forall a. MVar a -> IO a
takeMVar MVar Int
done
  HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected 1234 :: Int" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
res Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
1234 :: Int)

testSpawnAsyncStrictness :: TestTransport -> Assertion
testSpawnAsyncStrictness :: TestTransport -> IO ()
testSpawnAsyncStrictness TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  MVar (IO ())
done <- IO (MVar (IO ()))
forall a. IO (MVar a)
newEmptyMVar

  LocalNode -> Process () -> IO ()
runProcess LocalNode
node (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    NodeId
here <-Process NodeId
getSelfNode

    Either SomeException SpawnRef
ev <- Process SpawnRef -> Process (Either SomeException SpawnRef)
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (Process SpawnRef -> Process (Either SomeException SpawnRef))
-> Process SpawnRef -> Process (Either SomeException SpawnRef)
forall a b. (a -> b) -> a -> b
$ NodeId -> Closure (Process ()) -> Process SpawnRef
spawnAsync NodeId
here (String -> Closure (Process ())
forall a. HasCallStack => String -> a
error String
"boom")
    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
$ case Either SomeException SpawnRef
ev of
      Right SpawnRef
_ -> MVar (IO ()) -> IO () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (IO ())
done (String -> IO ()
forall a. HasCallStack => String -> a
error String
"Exception didn't fire")
      Left (SomeException
_::SomeException) -> MVar (IO ()) -> IO () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (IO ())
done (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

  IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar (IO ()) -> IO (IO ())
forall a. MVar a -> IO a
takeMVar MVar (IO ())
done

testReconnect :: TestTransport -> Assertion
testReconnect :: TestTransport -> IO ()
testReconnect TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  [LocalNode
node1, LocalNode
node2] <- Int -> IO LocalNode -> IO [LocalNode]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 (IO LocalNode -> IO [LocalNode]) -> IO LocalNode -> IO [LocalNode]
forall a b. (a -> b) -> a -> b
$ Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  let nid1 :: NodeId
nid1 = LocalNode -> NodeId
localNodeId LocalNode
node1
  MVar ProcessId
processA <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  [MVar ()
sendTestOk, MVar ()
registerTestOk] <- Int -> IO (MVar ()) -> IO [MVar ()]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node1 (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
us <- Process ProcessId
getSelfPid
    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
processA ProcessId
us
    String
msg1 <- Process String
forall a. Serializable a => Process a
expect
    String
msg2 <- Process String
forall a. Serializable a => Process a
expect
    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
$ do
      HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"messages did not match" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ String
msg1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"message 1" Bool -> Bool -> Bool
&& String
msg2 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"message 3"
      MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
sendTestOk ()

  LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node2 (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    {-
     - Make sure there is no implicit reconnect on normal message sending
     -}

    ProcessId
them <- 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
readMVar MVar ProcessId
processA
    ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
them String
"message 1" 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 (Int -> IO ()
threadDelay Int
100000)

    -- Simulate network failure
    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
$ (EndPointAddress -> EndPointAddress -> IO ())
-> LocalNode -> LocalNode -> IO ()
syncBreakConnection EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection LocalNode
node1 LocalNode
node2


    -- Should not arrive
    ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
them String
"message 2"

    -- Should arrive
    ProcessId -> Process ()
reconnect ProcessId
them
    ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
them String
"message 3"

    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 () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
sendTestOk

    {-
     - Test that there *is* implicit reconnect on node controller messages
     -}

    ProcessId
us <- Process ProcessId
getSelfPid
    NodeId -> String -> ProcessId -> Process ()
registerRemoteAsync NodeId
nid1 String
"a" ProcessId
us -- registerRemote is asynchronous
    [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [
        (RegisterReply -> Bool)
-> (RegisterReply -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(RegisterReply String
label' Bool
_ Maybe ProcessId
_) -> String
"a" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
label')
                (\(RegisterReply String
_ Bool
_ Maybe ProcessId
_) -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ]

    Maybe ProcessId
_  <- NodeId -> String -> Process (Maybe ProcessId)
whereisRemote NodeId
nid1 String
"a"


    -- Simulate network failure
    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
$ (EndPointAddress -> EndPointAddress -> IO ())
-> LocalNode -> LocalNode -> IO ()
syncBreakConnection EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection LocalNode
node1 LocalNode
node2

    -- This will happen due to implicit reconnect
    NodeId -> String -> ProcessId -> Process ()
registerRemoteAsync NodeId
nid1 String
"b" ProcessId
us
    [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [
        (RegisterReply -> Bool)
-> (RegisterReply -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(RegisterReply String
label' Bool
_ Maybe ProcessId
_) -> String
"b" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
label')
                (\(RegisterReply String
_ Bool
_ Maybe ProcessId
_) -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ]

    -- Should happen
    NodeId -> String -> ProcessId -> Process ()
registerRemoteAsync NodeId
nid1 String
"c" ProcessId
us
    [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [
        (RegisterReply -> Bool)
-> (RegisterReply -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(RegisterReply String
label' Bool
_ Maybe ProcessId
_) -> String
"c" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
label')
                (\(RegisterReply String
_ Bool
_ Maybe ProcessId
_) -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ]

    -- Check
    Maybe ProcessId
mPid <- NodeId -> String -> Process (Maybe ProcessId)
whereisRemote NodeId
nid1 String
"a"  -- this will fail because the name is removed when the node is disconnected
    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
$ HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected remote name to be lost" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe ProcessId
mPid Maybe ProcessId -> Maybe ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ProcessId
forall a. Maybe a
Nothing
    NodeId -> String -> Process ProcessId
verifyWhereIsRemote NodeId
nid1 String
"b"  -- this will suceed because the value is set after thereconnect
    NodeId -> String -> Process ProcessId
verifyWhereIsRemote NodeId
nid1 String
"c"

    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 () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
registerTestOk ()

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
registerTestOk

-- | Tests that unreliable messages arrive sorted even when there are connection
-- failures.
testUSend :: (ProcessId -> Int -> Process ())
          -> TestTransport -> Int -> Assertion
testUSend :: (ProcessId -> Int -> Process ()) -> TestTransport -> Int -> IO ()
testUSend ProcessId -> Int -> Process ()
usendPrim TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} Int
numMessages = do
  [LocalNode
node1, LocalNode
node2] <- Int -> IO LocalNode -> IO [LocalNode]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 (IO LocalNode -> IO [LocalNode]) -> IO LocalNode -> IO [LocalNode]
forall a b. (a -> b) -> a -> b
$ Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  let nid1 :: NodeId
nid1 = LocalNode -> NodeId
localNodeId LocalNode
node1
      nid2 :: NodeId
nid2 = LocalNode -> NodeId
localNodeId LocalNode
node2
  MVar ProcessId
processA <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar Bool
usendTestOk <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar

  LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node1 (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ (Process () -> (SomeException -> Process ()) -> Process ())
-> (SomeException -> Process ()) -> Process () -> Process ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Process () -> (SomeException -> Process ()) -> Process ()
forall e a.
(HasCallStack, Exception e) =>
Process a -> (e -> Process a) -> Process a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch (\SomeException
e -> 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
$ SomeException -> IO ()
forall a. Show a => a -> IO ()
print (SomeException
e :: SomeException) ) (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
us <- Process ProcessId
getSelfPid
    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
processA ProcessId
us
    ProcessId
them <- Process ProcessId
forall a. Serializable a => Process a
expect
    ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
them ()
    MonitorRef
_ <- ProcessId -> Process MonitorRef
monitor ProcessId
them
    let -- Collects messages from 'them' until the sender dies.
        -- Disconnection notifications are ignored.
        receiveMessages :: Process [Int]
        receiveMessages :: Process [Int]
receiveMessages = [Match [Int]] -> Process [Int]
forall b. [Match b] -> Process b
receiveWait
              [ (ProcessMonitorNotification -> Process [Int]) -> Match [Int]
forall a b. Serializable a => (a -> Process b) -> Match b
match ((ProcessMonitorNotification -> Process [Int]) -> Match [Int])
-> (ProcessMonitorNotification -> Process [Int]) -> Match [Int]
forall a b. (a -> b) -> a -> b
$ \ProcessMonitorNotification
mn -> case ProcessMonitorNotification
mn of
                  ProcessMonitorNotification MonitorRef
_ ProcessId
_ DiedReason
DiedDisconnect -> do
                    ProcessId -> Process MonitorRef
monitor ProcessId
them
                    Process [Int]
receiveMessages
                  ProcessMonitorNotification
_ -> [Int] -> Process [Int]
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return []
              , (Int -> Process [Int]) -> Match [Int]
forall a b. Serializable a => (a -> Process b) -> Match b
match ((Int -> Process [Int]) -> Match [Int])
-> (Int -> Process [Int]) -> Match [Int]
forall a b. (a -> b) -> a -> b
$ \Int
i -> ([Int] -> [Int]) -> Process [Int] -> Process [Int]
forall a b. (a -> b) -> Process a -> Process b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int
i Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) Process [Int]
receiveMessages
              ]
    [Int]
msgs <- Process [Int]
receiveMessages
    let -- Checks that the input list is sorted.
        isSorted :: [Int] -> Bool
        isSorted :: [Int] -> Bool
isSorted (Int
x : xs :: [Int]
xs@(Int
y : [Int]
_)) = Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
y Bool -> Bool -> Bool
&& [Int] -> Bool
isSorted [Int]
xs
        isSorted [Int]
_                = Bool
True
    -- The list can't be null since there are no failures after sending
    -- the last 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
$ MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
usendTestOk (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ [Int] -> Bool
isSorted [Int]
msgs Bool -> Bool -> Bool
&& Bool -> Bool
not ([Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
msgs)

  LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node2 (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
them <- 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
readMVar MVar ProcessId
processA
    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 -> ProcessId -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
them
    Process ()
forall a. Serializable a => Process a
expect :: Process ()
    [Int] -> (Int -> Process ()) -> Process ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
numMessages] ((Int -> Process ()) -> Process ())
-> (Int -> Process ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
      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
$ EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection (NodeId -> EndPointAddress
nodeAddress NodeId
nid1) (NodeId -> EndPointAddress
nodeAddress NodeId
nid2)
      ProcessId -> Int -> Process ()
usendPrim ProcessId
them Int
i
      IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO ()
threadDelay Int
30000)

  Bool
res <- MVar Bool -> IO Bool
forall a. MVar a -> IO a
takeMVar MVar Bool
usendTestOk
  HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Unexpected failure after sending last msg" Bool
res

-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
-- in between
testMatchAny :: TestTransport -> Assertion
testMatchAny :: TestTransport -> IO ()
testMatchAny TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  MVar ProcessId
proxyAddr <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar (Double, Double, DivByZero)
clientDone <- IO (MVar (Double, Double, DivByZero))
forall a. IO (MVar a)
newEmptyMVar

  -- Math server
  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
mathServer <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode Process ()
math
    ProcessId
proxyServer <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ Process () -> Process ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ do
      Message
msg <- [Match Message] -> Process Message
forall b. [Match b] -> Process b
receiveWait [ (Message -> Process Message) -> Match Message
forall b. (Message -> Process b) -> Match b
matchAny Message -> Process Message
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ]
      Message -> ProcessId -> Process ()
forward Message
msg ProcessId
mathServer
    MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
proxyAddr ProcessId
proxyServer

  -- Client
  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
mathServer <- MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar MVar ProcessId
proxyAddr

    LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ProcessId
pid <- Process ProcessId
getSelfPid
      ProcessId -> Add -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
mathServer (ProcessId -> Double -> Double -> Add
Add ProcessId
pid Double
1 Double
2)
      Double
three <- Process Double
forall a. Serializable a => Process a
expect :: Process Double
      ProcessId -> Divide -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
mathServer (ProcessId -> Double -> Double -> Divide
Divide ProcessId
pid Double
8 Double
2)
      Double
four <- Process Double
forall a. Serializable a => Process a
expect :: Process Double
      ProcessId -> Divide -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
mathServer (ProcessId -> Double -> Double -> Divide
Divide ProcessId
pid Double
8 Double
0)
      DivByZero
divByZ <- Process DivByZero
forall a. Serializable a => Process a
expect
      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 (Double, Double, DivByZero)
-> (Double, Double, DivByZero) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Double, Double, DivByZero)
clientDone (Double
three, Double
four, DivByZero
divByZ)

  (Double, Double, DivByZero)
res <- MVar (Double, Double, DivByZero) -> IO (Double, Double, DivByZero)
forall a. MVar a -> IO a
takeMVar MVar (Double, Double, DivByZero)
clientDone
  case (Double, Double, DivByZero)
res of
    (Double
3, Double
4, DivByZero
DivByZero) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    (Double, Double, DivByZero)
_                 -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"Unexpected result"

-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
-- in between, however we block 'Divide' requests ....
testMatchAnyHandle :: TestTransport -> Assertion
testMatchAnyHandle :: TestTransport -> IO ()
testMatchAnyHandle TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  MVar ProcessId
proxyAddr <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar Bool
clientDone <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar

  -- Math server
  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
mathServer <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode Process ()
math
    ProcessId
proxyServer <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ Process (Maybe ()) -> Process ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Process (Maybe ()) -> Process ())
-> Process (Maybe ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ do
        [Match (Maybe ())] -> Process (Maybe ())
forall b. [Match b] -> Process b
receiveWait [
            (Message -> Process (Maybe ())) -> Match (Maybe ())
forall b. (Message -> Process b) -> Match b
matchAny (ProcessId -> Message -> Process (Maybe ())
maybeForward ProcessId
mathServer)
          ]
    MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
proxyAddr ProcessId
proxyServer

  -- Client
  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
mathServer <- MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar MVar ProcessId
proxyAddr

    LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ProcessId
pid <- Process ProcessId
getSelfPid
      ProcessId -> Add -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
mathServer (ProcessId -> Double -> Double -> Add
Add ProcessId
pid Double
1 Double
2)
      Double
three <- Process Double
forall a. Serializable a => Process a
expect :: Process Double
      ProcessId -> Divide -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
mathServer (ProcessId -> Double -> Double -> Divide
Divide ProcessId
pid Double
8 Double
2)
      Maybe Double
res <- (Int -> Process (Maybe Double)
forall a. Serializable a => Int -> Process (Maybe a)
expectTimeout Int
100000) :: Process (Maybe Double)
      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 Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
clientDone (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Double
three Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
3 Bool -> Bool -> Bool
&& Maybe Double
res Maybe Double -> Maybe Double -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Double
forall a. Maybe a
Nothing

  String -> MVar Bool -> IO ()
verifyClient String
"Expected Nothing (i.e. timeout)" MVar Bool
clientDone

  where maybeForward :: ProcessId -> Message -> Process (Maybe ())
        maybeForward :: ProcessId -> Message -> Process (Maybe ())
maybeForward ProcessId
s Message
msg =
            Message -> (Add -> Process ()) -> Process (Maybe ())
forall (m :: * -> *) a b.
(Monad m, Serializable a) =>
Message -> (a -> m b) -> m (Maybe b)
handleMessage Message
msg (\m :: Add
m@(Add ProcessId
_ Double
_ Double
_) -> ProcessId -> Add -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
s Add
m)

testMatchAnyNoHandle :: TestTransport -> Assertion
testMatchAnyNoHandle :: TestTransport -> IO ()
testMatchAnyNoHandle TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  MVar ProcessId
addr <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
clientDone <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
serverDone <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  -- Math server
  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
server <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ Process () -> Process ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ do
        [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [
          (Add -> Bool) -> (Message -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (Message -> Process b) -> Match b
matchAnyIf
            -- the condition has type `Add -> Bool`
            (\(Add ProcessId
_ Double
_ Double
_) -> Bool
True)
            -- the match `AbstractMessage -> Process ()` will succeed!
            (\Message
m -> do
              -- `String -> Process ()` does *not* match the input types however
              Maybe Any
r <- (Message -> (String -> Process Any) -> Process (Maybe Any)
forall (m :: * -> *) a b.
(Monad m, Serializable a) =>
Message -> (a -> m b) -> m (Maybe b)
handleMessage Message
m (\(String
_ :: String) -> String -> Process Any
forall a b. Serializable a => a -> Process b
die String
"NONSENSE" ))
              case Maybe Any
r of
                Maybe Any
Nothing -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just Any
_  -> String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"NONSENSE")
          ]
        -- we *must* have removed the message from our mailbox though!!!
        Maybe ()
res <- Int -> [Match ()] -> Process (Maybe ())
forall b. Int -> [Match b] -> Process (Maybe b)
receiveTimeout Int
100000 [ (Add -> Process ()) -> Match ()
forall a b. Serializable a => (a -> Process b) -> Match b
match (\(Add ProcessId
_ Double
_ Double
_) -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ]
        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
$ do
          HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected timeout!" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe ()
res Maybe () -> Maybe () -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ()
forall a. Maybe a
Nothing
          MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
serverDone ()
    MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
addr ProcessId
server

  -- Client
  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
server <- MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar MVar ProcessId
addr

    LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ProcessId
pid <- Process ProcessId
getSelfPid
      ProcessId -> Add -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
server (ProcessId -> Double -> Double -> Add
Add ProcessId
pid Double
1 Double
2)
      -- we only care about the client having sent a message, so we're done
      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 () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
clientDone ()

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
clientDone
  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
serverDone

-- | Test 'matchAnyIf'. We provide an /echo/ server, but it ignores requests
-- unless the text body @/= "bar"@ - this case should time out rather than
-- removing the message from the process mailbox.
testMatchAnyIf :: TestTransport -> Assertion
testMatchAnyIf :: TestTransport -> IO ()
testMatchAnyIf TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  MVar ProcessId
echoAddr <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar (String, Maybe String, String)
clientDone <- IO (MVar (String, Maybe String, String))
forall a. IO (MVar a)
newEmptyMVar

  -- echo server
  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
echoServer <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ Process (Maybe ()) -> Process ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Process (Maybe ()) -> Process ())
-> Process (Maybe ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ do
        [Match (Maybe ())] -> Process (Maybe ())
forall b. [Match b] -> Process b
receiveWait [
            ((ProcessId, String) -> Bool)
-> (Message -> Process (Maybe ())) -> Match (Maybe ())
forall a b.
Serializable a =>
(a -> Bool) -> (Message -> Process b) -> Match b
matchAnyIf (\(ProcessId
_ :: ProcessId, (String
s :: String)) -> String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"bar")
                       Message -> Process (Maybe ())
tryHandleMessage
          ]
    MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
echoAddr ProcessId
echoServer

  -- Client
  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
server <- MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar MVar ProcessId
echoAddr

    LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ProcessId
pid <- Process ProcessId
getSelfPid
      ProcessId -> (ProcessId, String) -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
server (ProcessId
pid, String
"foo")
      String
foo <- Process String
forall a. Serializable a => Process a
expect
      -- provoking what would be the wrong ordering is informative here...

      ProcessId -> (ProcessId, String) -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
server (ProcessId
pid, String
"bar")
      Maybe String
bar <- (Int -> Process (Maybe String)
forall a. Serializable a => Int -> Process (Maybe a)
expectTimeout Int
100000) :: Process (Maybe String) -- was Double o_O !?

      ProcessId -> (ProcessId, String) -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
server (ProcessId
pid, String
"baz")
      String
baz <- Process String
forall a. Serializable a => Process a
expect

      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 (String, Maybe String, String)
-> (String, Maybe String, String) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (String, Maybe String, String)
clientDone (String
foo, Maybe String
bar, String
baz)

  (String, Maybe String, String)
res <- MVar (String, Maybe String, String)
-> IO (String, Maybe String, String)
forall a. MVar a -> IO a
takeMVar MVar (String, Maybe String, String)
clientDone
  let res' :: Bool
res' = (String, Maybe String, String)
res (String, Maybe String, String)
-> (String, Maybe String, String) -> Bool
forall a. Eq a => a -> a -> Bool
== (String
"foo", Maybe String
forall a. Maybe a
Nothing, String
"baz")
  HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected timeout due to type mismatch" Bool
res'

  where tryHandleMessage :: Message -> Process (Maybe ())
        tryHandleMessage :: Message -> Process (Maybe ())
tryHandleMessage Message
msg =
          Message
-> ((ProcessId, String) -> Process ()) -> Process (Maybe ())
forall (m :: * -> *) a b.
(Monad m, Serializable a) =>
Message -> (a -> m b) -> m (Maybe b)
handleMessage Message
msg (\(ProcessId
pid :: ProcessId, (String
m :: String))
                                  -> do { ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid String
m; () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return () })

testMatchMessageWithUnwrap :: TestTransport -> Assertion
testMatchMessageWithUnwrap :: TestTransport -> IO ()
testMatchMessageWithUnwrap TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  MVar ProcessId
echoAddr <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar (String, String)
clientDone <- IO (MVar (String, String))
forall a. IO (MVar a)
newEmptyMVar

    -- echo server
  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
echoServer <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ Process () -> Process ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ do
        Message
msg <- [Match Message] -> Process Message
forall b. [Match b] -> Process b
receiveWait [
            (Message -> Process Message) -> Match Message
matchMessage (\(Message
m :: Message) -> do
                            Message -> Process Message
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return Message
m)
          ]
        Maybe (ProcessId, Message)
unwrapped <- Message -> Process (Maybe (ProcessId, Message))
forall (m :: * -> *) a.
(Monad m, Serializable a) =>
Message -> m (Maybe a)
unwrapMessage Message
msg :: Process (Maybe (ProcessId, Message))
        case Maybe (ProcessId, Message)
unwrapped of
          (Just (ProcessId
p, Message
msg')) -> Message -> ProcessId -> Process ()
forward Message
msg' ProcessId
p
          Maybe (ProcessId, Message)
Nothing -> String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"unable to unwrap the message"
    MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
echoAddr ProcessId
echoServer

  -- Client
  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    ProcessId
server <- MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar MVar ProcessId
echoAddr

    LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ProcessId
pid <- Process ProcessId
getSelfPid
      ProcessId -> (ProcessId, Message) -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
server (ProcessId
pid, String -> Message
forall a. Serializable a => a -> Message
wrapMessage (String
"foo" :: String))
      String
foo <- Process String
forall a. Serializable a => Process a
expect
      ProcessId -> (ProcessId, Message) -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
server (ProcessId
pid, String -> Message
forall a. Serializable a => a -> Message
wrapMessage (String
"baz" :: String))
      String
baz <- Process String
forall a. Serializable a => Process a
expect
      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 (String, String) -> (String, String) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (String, String)
clientDone (String
foo, String
baz)

  (String, String)
res <- MVar (String, String) -> IO (String, String)
forall a. MVar a -> IO a
takeMVar MVar (String, String)
clientDone
  HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Unexpected unwrapped results" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, String)
res (String, String) -> (String, String) -> Bool
forall a. Eq a => a -> a -> Bool
== (String
"foo", String
"baz")

-- Test 'receiveChanTimeout'
testReceiveChanTimeout :: TestTransport -> Assertion
testReceiveChanTimeout :: TestTransport -> IO ()
testReceiveChanTimeout TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
mvSender <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  MVar (SendPort Bool)
sendPort <- IO (MVar (SendPort Bool))
forall a. IO (MVar a)
newEmptyMVar

  IO () -> IO ThreadId
forkTry (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      -- Create a typed channel
      (SendPort Bool
sp, ReceivePort Bool
rp) <- Process (SendPort Bool, ReceivePort Bool)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan :: Process (SendPort Bool, ReceivePort Bool)
      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 (SendPort Bool) -> SendPort Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (SendPort Bool)
sendPort SendPort Bool
sp

      -- Wait for a message with a delay. No message arrives, we should get
      -- Nothing after the delay.
      Int -> ReceivePort Bool -> Process (Maybe Bool)
forall a.
Serializable a =>
Int -> ReceivePort a -> Process (Maybe a)
receiveChanTimeout Int
100000 ReceivePort Bool
rp Process (Maybe Bool) -> (Maybe Bool -> 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
>>= Process () -> (Bool -> Process ()) -> Maybe Bool -> Process ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Process () -> Bool -> Process ()
forall a b. a -> b -> a
const (Process () -> Bool -> Process ())
-> Process () -> Bool -> Process ()
forall a b. (a -> b) -> a -> b
$ String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"Expected Timeout")

      -- Let the sender know that it can send a 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
$ MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvSender ()

      -- Wait for a message with a delay again. Now a message arrives after
      -- 0.1 seconds
      Bool
res <- Int -> ReceivePort Bool -> Process (Maybe Bool)
forall a.
Serializable a =>
Int -> ReceivePort a -> Process (Maybe a)
receiveChanTimeout Int
20000000 ReceivePort Bool
rp Process (Maybe Bool)
-> (Maybe Bool -> Process Bool) -> Process Bool
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Process Bool
-> (Bool -> Process Bool) -> Maybe Bool -> Process Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Process Bool
forall a b. Serializable a => a -> Process b
die String
"Timeout") Bool -> Process Bool
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return
      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
$ HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected result to be 'True'" Bool
res

      -- Wait for a message with zero timeout: non-blocking check. No message is
      -- available, we get Nothing
      Int -> ReceivePort Bool -> Process (Maybe Bool)
forall a.
Serializable a =>
Int -> ReceivePort a -> Process (Maybe a)
receiveChanTimeout Int
0 ReceivePort Bool
rp Process (Maybe Bool) -> (Maybe Bool -> 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
>>= Process () -> (Bool -> Process ()) -> Maybe Bool -> Process ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Process () -> Bool -> Process ()
forall a b. a -> b -> a
const (Process () -> Bool -> Process ())
-> Process () -> Bool -> Process ()
forall a b. (a -> b) -> a -> b
$ String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"Expected Timeout")

      -- Let the sender know that it can send a 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
$ MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvSender ()

      -- Again, but now there is a message available
      (Process () -> Process ()) -> Process ()
forall a. (a -> a) -> a
fix ((Process () -> Process ()) -> Process ())
-> (Process () -> Process ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ \Process ()
loop -> do
        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
100000
        Maybe Bool
mb <- Int -> ReceivePort Bool -> Process (Maybe Bool)
forall a.
Serializable a =>
Int -> ReceivePort a -> Process (Maybe a)
receiveChanTimeout Int
0 ReceivePort Bool
rp
        case Maybe Bool
mb of
          Just Bool
b -> do 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
$ HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Unexpected Message" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
b
          Maybe Bool
_      -> Process ()
loop

      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 () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ()

  IO () -> IO ThreadId
forkTry (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      SendPort Bool
sp <- IO (SendPort Bool) -> Process (SendPort Bool)
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SendPort Bool) -> Process (SendPort Bool))
-> IO (SendPort Bool) -> Process (SendPort Bool)
forall a b. (a -> b) -> a -> b
$ MVar (SendPort Bool) -> IO (SendPort Bool)
forall a. MVar a -> IO a
readMVar MVar (SendPort Bool)
sendPort

      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 () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
mvSender
      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
100000
      SendPort Bool -> Bool -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort Bool
sp Bool
True

      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 () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
mvSender
      SendPort Bool -> Bool -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort Bool
sp Bool
False

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

-- | Test Functor, Applicative, Alternative and Monad instances for ReceiveChan
testReceiveChanFeatures :: TestTransport -> Assertion
testReceiveChanFeatures :: TestTransport -> IO ()
testReceiveChanFeatures TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  IO () -> IO ThreadId
forkTry (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
    LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (SendPort Int
spInt,  ReceivePort Int
rpInt)  <- Process (SendPort Int, ReceivePort Int)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan :: Process (SendPort Int, ReceivePort Int)
      (SendPort Bool
spBool, ReceivePort Bool
rpBool) <- Process (SendPort Bool, ReceivePort Bool)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan :: Process (SendPort Bool, ReceivePort Bool)

      -- Test Functor instance

      SendPort Int -> Int -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort Int
spInt Int
2
      SendPort Bool -> Bool -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort Bool
spBool Bool
False

      ReceivePort Bool
rp1 <- [ReceivePort Bool] -> Process (ReceivePort Bool)
forall a.
Serializable a =>
[ReceivePort a] -> Process (ReceivePort a)
mergePortsBiased [Int -> Bool
forall a. Integral a => a -> Bool
even (Int -> Bool) -> ReceivePort Int -> ReceivePort Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReceivePort Int
rpInt, ReceivePort Bool
rpBool]

      ReceivePort Bool -> Process Bool
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort Bool
rp1 Process Bool -> (Bool -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (Bool -> IO ()) -> Bool -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected True"
      ReceivePort Bool -> Process Bool
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort Bool
rp1 Process Bool -> (Bool -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (Bool -> IO ()) -> Bool -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected False" (Bool -> IO ()) -> (Bool -> Bool) -> Bool -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not

      -- Test Applicative instance

      SendPort Int -> Int -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort Int
spInt Int
3
      SendPort Int -> Int -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort Int
spInt Int
4

      let rp2 :: ReceivePort Int
rp2 = (Int -> Int -> Int) -> ReceivePort (Int -> Int -> Int)
forall a. a -> ReceivePort a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) ReceivePort (Int -> Int -> Int)
-> ReceivePort Int -> ReceivePort (Int -> Int)
forall a b. ReceivePort (a -> b) -> ReceivePort a -> ReceivePort b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReceivePort Int
rpInt ReceivePort (Int -> Int) -> ReceivePort Int -> ReceivePort Int
forall a b. ReceivePort (a -> b) -> ReceivePort a -> ReceivePort b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReceivePort Int
rpInt

      ReceivePort Int -> Process Int
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort Int
rp2 Process Int -> (Int -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (Int -> IO ()) -> Int -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected 7" (Bool -> IO ()) -> (Int -> Bool) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
7)

      -- Test Alternative instance

      SendPort Int -> Int -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort Int
spInt Int
3
      SendPort Bool -> Bool -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort Bool
spBool Bool
True

      let rp3 :: ReceivePort Bool
rp3 = (Int -> Bool
forall a. Integral a => a -> Bool
even (Int -> Bool) -> ReceivePort Int -> ReceivePort Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReceivePort Int
rpInt) ReceivePort Bool -> ReceivePort Bool -> ReceivePort Bool
forall a. ReceivePort a -> ReceivePort a -> ReceivePort a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReceivePort Bool
rpBool

      ReceivePort Bool -> Process Bool
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort Bool
rp3 Process Bool -> (Bool -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (Bool -> IO ()) -> Bool -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected False" (Bool -> IO ()) -> (Bool -> Bool) -> Bool -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not
      ReceivePort Bool -> Process Bool
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort Bool
rp3 Process Bool -> (Bool -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (Bool -> IO ()) -> Bool -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected True"

      -- Test Monad instance

      SendPort Bool -> Bool -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort Bool
spBool Bool
True
      SendPort Bool -> Bool -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort Bool
spBool Bool
False
      SendPort Int -> Int -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort Int
spInt Int
5

      let rp4 :: ReceivePort Int
          rp4 :: ReceivePort Int
rp4 = do Bool
b <- ReceivePort Bool
rpBool
                   if Bool
b
                     then ReceivePort Int
rpInt
                     else Int -> ReceivePort Int
forall a. a -> ReceivePort a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
7

      ReceivePort Int -> Process Int
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort Int
rp4 Process Int -> (Int -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (Int -> IO ()) -> Int -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected 5" (Bool -> IO ()) -> (Int -> Bool) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5)
      ReceivePort Int -> Process Int
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort Int
rp4 Process Int -> (Int -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (Int -> IO ()) -> Int -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected 7" (Bool -> IO ()) -> (Int -> Bool) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
7)

      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 () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ()

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

testChanLifecycle :: TestTransport -> Assertion
testChanLifecycle :: TestTransport -> IO ()
testChanLifecycle TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = let delay :: Int
delay = Int
3000000 in do
  MVar Bool
result <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar
  MVar (SendPort (), ReceivePort ())
tchMV <- IO (MVar (SendPort (), ReceivePort ()))
forall a. IO (MVar a)
newEmptyMVar
  LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do

    ProcessId
pid <- Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ do (SendPort (), ReceivePort ())
tCh  <- Process (SendPort (), ReceivePort ())
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan :: Process (SendPort (), ReceivePort ())
                           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 (SendPort (), ReceivePort ())
-> (SendPort (), ReceivePort ()) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (SendPort (), ReceivePort ())
tchMV (SendPort (), ReceivePort ())
tCh
                           Process ()
forall a. Serializable a => Process a
expect :: Process ()
                           let (SendPort ()
sp, ReceivePort ()
_) = (SendPort (), ReceivePort ())
tCh
                           SendPort () -> () -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort ()
sp ()
                           Process ()
forall a. Serializable a => Process a
expect :: Process ()

    MonitorRef
mRefPid <- ProcessId -> Process MonitorRef
monitor ProcessId
pid

    ProcessId
cPid <- Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ do
      (SendPort ()
sp', ReceivePort ()
rp) <- IO (SendPort (), ReceivePort ())
-> Process (SendPort (), ReceivePort ())
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SendPort (), ReceivePort ())
 -> Process (SendPort (), ReceivePort ()))
-> IO (SendPort (), ReceivePort ())
-> Process (SendPort (), ReceivePort ())
forall a b. (a -> b) -> a -> b
$ MVar (SendPort (), ReceivePort ())
-> IO (SendPort (), ReceivePort ())
forall a. MVar a -> IO a
takeMVar MVar (SendPort (), ReceivePort ())
tchMV
      -- say "picked up our test channel"
      ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid ()
      -- say "told pid to continue"
      Maybe ()
res <- Int -> ReceivePort () -> Process (Maybe ())
forall a.
Serializable a =>
Int -> ReceivePort a -> Process (Maybe a)
receiveChanTimeout Int
delay ReceivePort ()
rp
      case Maybe ()
res of
        Maybe ()
Nothing -> String -> Process ()
say String
"initial chan () missing!" 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
$ MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
result Bool
False)
        Just () -> do MonitorRef
_ <- ProcessId -> Process MonitorRef
monitor ProcessId
pid
                      Int -> Process ()
pause Int
10000
                      -- say "sending pid a second () will cause it to exit"
                      ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid ()

                      -- say "make sure we see a DOWN notification for pid having stopped"
                      [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [ (ProcessMonitorNotification -> Process ()) -> Match ()
forall a b. Serializable a => (a -> Process b) -> Match b
match (\(ProcessMonitorNotification
_ :: ProcessMonitorNotification) -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ]

                      -- now that pid has died, the send port should be useless...
                      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 (SendPort (), ReceivePort ())
-> (SendPort (), ReceivePort ()) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (SendPort (), ReceivePort ())
tchMV (SendPort ()
sp', ReceivePort ()
rp)

                      -- let's verify that we do not see the message from our
                      -- parent process on the channel, once pid has died...
                      Maybe ()
recv <- Int -> ReceivePort () -> Process (Maybe ())
forall a.
Serializable a =>
Int -> ReceivePort a -> Process (Maybe a)
receiveChanTimeout Int
delay ReceivePort ()
rp
                      -- say $ "finished waiting for second (), writing result" ++ (show 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
$ MVar Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
result (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe () -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ()
recv

    MonitorRef
mRefCPid <- ProcessId -> Process MonitorRef
monitor ProcessId
cPid

    [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
r ProcessId
_ DiedReason
_) -> MonitorRef
r MonitorRef -> MonitorRef -> Bool
forall a. Eq a => a -> a -> Bool
== MonitorRef
mRefPid)
                  (\ProcessMonitorNotification
_ -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        ]

    -- say "seen first pid die..."

    (SendPort ()
sendPort, ReceivePort ()
_) <- IO (SendPort (), ReceivePort ())
-> Process (SendPort (), ReceivePort ())
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SendPort (), ReceivePort ())
 -> Process (SendPort (), ReceivePort ()))
-> IO (SendPort (), ReceivePort ())
-> Process (SendPort (), ReceivePort ())
forall a b. (a -> b) -> a -> b
$ MVar (SendPort (), ReceivePort ())
-> IO (SendPort (), ReceivePort ())
forall a. MVar a -> IO a
takeMVar MVar (SendPort (), ReceivePort ())
tchMV
    SendPort () -> () -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort ()
sendPort ()
    -- say "sent () after owning pid died"

    -- let cPid know we've written to the channel...
    ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
cPid ()

    [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
r ProcessId
_ DiedReason
_) -> MonitorRef
r MonitorRef -> MonitorRef -> Bool
forall a. Eq a => a -> a -> Bool
== MonitorRef
mRefCPid)
                  (\ProcessMonitorNotification
_ -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        ]

    -- say "seen both pids die now..."

  -- and wait on the result back in IO land...
  Bool
testRes <- MVar Bool -> IO Bool
forall a. MVar a -> IO a
takeMVar MVar Bool
result
  -- runProcess localNode $ say "got result..."
  HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected sending on the channel to fail, but received data!" Bool
testRes


testKillLocal :: TestTransport -> Assertion
testKillLocal :: TestTransport -> IO ()
testKillLocal TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable

  ProcessId
pid <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    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

  LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    MonitorRef
ref <- ProcessId -> Process MonitorRef
monitor ProcessId
pid
    ProcessId
us <- Process ProcessId
getSelfPid
    ProcessId -> String -> Process ()
kill ProcessId
pid String
"TestKill"
    ProcessMonitorNotification
mn <- Process ProcessMonitorNotification
forall a. Serializable a => Process a
expect
    case ProcessMonitorNotification
mn of
      ProcessMonitorNotification MonitorRef
ref' ProcessId
pid' (DiedException String
ex) ->
        case MonitorRef
ref MonitorRef -> MonitorRef -> Bool
forall a. Eq a => a -> a -> Bool
== MonitorRef
ref' Bool -> Bool -> Bool
&& ProcessId
pid ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid' Bool -> Bool -> Bool
&& String
ex String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"killed-by=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ProcessId -> String
forall a. Show a => a -> String
show ProcessId
us String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
",reason=TestKill" of
          Bool
True  -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Bool
False -> String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"Invalid ProcessMonitorNotification received"
      ProcessMonitorNotification
_ -> String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"Something went horribly wrong"

testKillRemote :: TestTransport -> Assertion
testKillRemote :: TestTransport -> IO ()
testKillRemote TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
node1 <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  LocalNode
node2 <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable

  ProcessId
pid <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node1 (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    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

  LocalNode -> Process () -> IO ()
runProcess LocalNode
node2 (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    MonitorRef
ref <- ProcessId -> Process MonitorRef
monitor ProcessId
pid
    ProcessId
us <- Process ProcessId
getSelfPid
    ProcessId -> String -> Process ()
kill ProcessId
pid String
"TestKill"
    ProcessMonitorNotification
mn <- Process ProcessMonitorNotification
forall a. Serializable a => Process a
expect
    case ProcessMonitorNotification
mn of
      ProcessMonitorNotification MonitorRef
ref' ProcessId
pid' (DiedException String
reason) ->
        case (MonitorRef
ref MonitorRef -> MonitorRef -> Bool
forall a. Eq a => a -> a -> Bool
== MonitorRef
ref', ProcessId
pid ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid', String
reason String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"killed-by=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ProcessId -> String
forall a. Show a => a -> String
show ProcessId
us String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
",reason=TestKill") of
          (Bool
True, Bool
True, Bool
True) -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          (Bool
a, Bool
b, Bool
c) -> do
            let a' :: String
a' = if Bool
a then String
"" else String
"Invalid ref"
            let b' :: String
b' = if Bool
b then String
"" else String
"Invalid pid"
            let c' :: String
c' = if Bool
c then String
"" else String
"Invalid message"
            String -> Process ()
forall a b. Serializable a => a -> Process b
die (String -> Process ()) -> String -> Process ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
a', String
b', String
c']
      ProcessMonitorNotification
_ -> String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"Received unexpected message"

testCatchesExit :: TestTransport -> Assertion
testCatchesExit :: TestTransport -> IO ()
testCatchesExit TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  ProcessId
_ <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
      ((String, Int) -> Process ()
forall a b. Serializable a => a -> Process b
die (String
"foobar", Int
123 :: Int))
      Process ()
-> [ProcessId -> Message -> Process (Maybe ())] -> Process ()
forall b.
Process b
-> [ProcessId -> Message -> Process (Maybe b)] -> Process b
`catchesExit` [
           (\ProcessId
_ Message
m -> Message -> (String -> Process ()) -> Process (Maybe ())
forall (m :: * -> *) a b.
(Monad m, Serializable a) =>
Message -> (a -> m b) -> m (Maybe b)
handleMessage Message
m (\(String
_ :: String) -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()))
         , (\ProcessId
_ Message
m -> Message -> (Maybe Int -> Process ()) -> Process (Maybe ())
forall (m :: * -> *) a b.
(Monad m, Serializable a) =>
Message -> (a -> m b) -> m (Maybe b)
handleMessage Message
m (\(Maybe Int
_ :: Maybe Int) -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()))
         , (\ProcessId
_ Message
m -> Message -> ((String, Int) -> Process ()) -> Process (Maybe ())
forall (m :: * -> *) a b.
(Monad m, Serializable a) =>
Message -> (a -> m b) -> m (Maybe b)
handleMessage Message
m (\(String
_ :: String, Int
_ :: Int)
                    -> (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 () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ()) 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. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()))
         ]

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

testHandleMessageIf :: TestTransport -> Assertion
testHandleMessageIf :: TestTransport -> IO ()
testHandleMessageIf TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  MVar (Integer, Integer)
done <- IO (MVar (Integer, Integer))
forall a. IO (MVar a)
newEmptyMVar
  ProcessId
_ <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
self <- Process ProcessId
getSelfPid
    ProcessId -> (Integer, Integer) -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
self (Integer
5 :: Integer, Integer
10 :: Integer)
    Message
msg <- [Match Message] -> Process Message
forall b. [Match b] -> Process b
receiveWait [ (Message -> Process Message) -> Match Message
matchMessage Message -> Process Message
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ]
    Message
-> (() -> Bool) -> (() -> Process Any) -> Process (Maybe Any)
forall (m :: * -> *) a b.
(Monad m, Serializable a) =>
Message -> (a -> Bool) -> (a -> m b) -> m (Maybe b)
handleMessageIf Message
msg
                    (\() -> Bool
True)
                    (\() -> String -> Process Any
forall a b. Serializable a => a -> Process b
die String
"whoops") Process (Maybe Any) -> (Maybe Any -> 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
>>= Process () -> (Any -> Process ()) -> Maybe Any -> Process ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                                                    (Process () -> Any -> Process ()
forall a b. a -> b -> a
const (Process () -> Any -> Process ())
-> Process () -> Any -> Process ()
forall a b. (a -> b) -> a -> b
$ String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"Expected Mismatch")
    Message
-> ((Integer, Integer) -> Bool)
-> ((Integer, Integer) -> Process ())
-> Process (Maybe ())
forall (m :: * -> *) a b.
(Monad m, Serializable a) =>
Message -> (a -> Bool) -> (a -> m b) -> m (Maybe b)
handleMessageIf Message
msg (\(Integer
x :: Integer, Integer
y :: Integer) -> Integer
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
5 Bool -> Bool -> Bool
&& Integer
y Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
10)
                        (\(Integer, Integer)
input -> 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 (Integer, Integer) -> (Integer, Integer) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Integer, Integer)
done (Integer, Integer)
input)
    () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  (Integer, Integer)
result <- MVar (Integer, Integer) -> IO (Integer, Integer)
forall a. MVar a -> IO a
takeMVar MVar (Integer, Integer)
done
  String -> (Integer, Integer) -> (Integer, Integer) -> IO ()
forall a. (HasCallStack, Eq a, Show a) => String -> a -> a -> IO ()
assertEqual String
forall a. Monoid a => a
mempty (Integer
5, Integer
10) (Integer, Integer)
result

testCatches :: TestTransport -> Assertion
testCatches :: TestTransport -> IO ()
testCatches TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  ProcessId
_ <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    NodeId
node <- Process NodeId
getSelfNode
    (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
$ ProcessLinkException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (ProcessId -> DiedReason -> ProcessLinkException
ProcessLinkException (NodeId -> ProcessId
nullProcessId NodeId
node) DiedReason
DiedNormal))
    Process () -> [Handler ()] -> Process ()
forall a. Process a -> [Handler a] -> Process a
`catches` [
        (ProcessLinkException -> Process ()) -> Handler ()
forall a e. Exception e => (e -> Process a) -> Handler a
Handler (\(ProcessLinkException 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
$ MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ())
      ]

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

testMaskRestoreScope :: TestTransport -> Assertion
testMaskRestoreScope :: TestTransport -> IO ()
testMaskRestoreScope TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  MVar ProcessId
parentPid <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar :: IO (MVar ProcessId)
  MVar ProcessId
spawnedPid <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar :: IO (MVar ProcessId)

  IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ ((forall a. Process a -> Process a) -> Process ()) -> Process ()
forall b.
HasCallStack =>
((forall a. Process a -> Process a) -> Process b) -> Process b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. Process a -> Process a) -> Process ()) -> Process ())
-> ((forall a. Process a -> Process a) -> Process ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ \forall a. Process a -> Process a
unmask -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ())
-> (ProcessId -> IO ()) -> ProcessId -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
parentPid
    Process ProcessId -> Process ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Process ProcessId -> Process ())
-> Process ProcessId -> Process ()
forall a b. (a -> b) -> a -> b
$ Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ Process () -> Process ()
forall a. Process a -> Process a
unmask (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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ())
-> (ProcessId -> IO ()) -> ProcessId -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
spawnedPid)

  ProcessId
parent <- IO ProcessId -> IO ProcessId
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessId -> IO ProcessId) -> IO ProcessId -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
takeMVar MVar ProcessId
parentPid
  ProcessId
child <- IO ProcessId -> IO ProcessId
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessId -> IO ProcessId) -> IO ProcessId -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
takeMVar MVar ProcessId
spawnedPid
  HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
forall a. Monoid a => a
mempty (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ProcessId
parent ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
child)

testDie :: TestTransport -> Assertion
testDie :: TestTransport -> IO ()
testDie TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  ProcessId
_ <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
      ((String, Int) -> Process ()
forall a b. Serializable a => a -> Process b
die (String
"foobar", Int
123 :: Int))
      Process ()
-> (ProcessId -> (String, Int) -> Process ()) -> Process ()
forall a b.
(Show a, Serializable a) =>
Process b -> (ProcessId -> a -> Process b) -> Process b
`catchExit` \ProcessId
_from (String, Int)
reason -> do
        -- TODO: should verify that 'from' has the right value
        let res :: Bool
res = (String, Int)
reason (String, Int) -> (String, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== (String
"foobar", Int
123 :: Int)
        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 () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ()
        if Bool
res
          then () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"Something went horribly wrong"

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

testPrettyExit :: TestTransport -> Assertion
testPrettyExit :: TestTransport -> IO ()
testPrettyExit TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  ProcessId
_ <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
      (String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"timeout")
      Process () -> (ProcessExitException -> Process ()) -> Process ()
forall e a.
(HasCallStack, Exception e) =>
Process a -> (e -> Process a) -> Process a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \ex :: ProcessExitException
ex@(ProcessExitException ProcessId
from Message
_) ->
        let expected :: String
expected = String
"exit-from=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (ProcessId -> String
forall a. Show a => a -> String
show ProcessId
from)
        in do
          let res :: Bool
res = (ProcessExitException -> String
forall a. Show a => a -> String
show ProcessExitException
ex) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
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
$ MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ()
          if Bool
res
            then () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            else String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"Something went horribly wrong"

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

testExitLocal :: TestTransport -> Assertion
testExitLocal :: TestTransport -> IO ()
testExitLocal TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  MVar ()
supervisedDone <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
supervisorDone <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  -- XXX: we guarantee that exception handler will be set up
  -- regardless if forkProcess preserve masking state or not.
  MVar ()
handlerSetUp <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  ProcessId
pid <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    (IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
handlerSetUp ()) 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 () -> (ProcessId -> String -> Process ()) -> Process ()
forall a b.
(Show a, Serializable a) =>
Process b -> (ProcessId -> a -> Process b) -> Process b
`catchExit` \ProcessId
_from String
reason -> do
        -- TODO: should verify that 'from' has the right value
        Bool
res <- Bool -> Process Bool
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Process Bool) -> Bool -> Process Bool
forall a b. (a -> b) -> a -> b
$ String
reason String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"TestExit"
        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 () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
supervisedDone ()
        if Bool
res
          then () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"Something went horribly wrong"

  LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    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 () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
handlerSetUp
    MonitorRef
ref <- ProcessId -> Process MonitorRef
monitor ProcessId
pid
    ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
exit ProcessId
pid String
"TestExit"
    -- This time the client catches the exception, so it dies normally
    ProcessMonitorNotification
mn <- Process ProcessMonitorNotification
forall a. Serializable a => Process a
expect
    case ProcessMonitorNotification
mn of
      ProcessMonitorNotification MonitorRef
ref' ProcessId
pid' DiedReason
DiedNormal -> do
        let res :: Bool
res = MonitorRef
ref MonitorRef -> MonitorRef -> Bool
forall a. Eq a => a -> a -> Bool
== MonitorRef
ref' Bool -> Bool -> Bool
&& ProcessId
pid ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid'
        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 () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
supervisorDone ()
        if Bool
res
          then () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"Something went horribly wrong"
      ProcessMonitorNotification
_ -> String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"Something went horribly wrong"

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
supervisedDone
  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
supervisorDone

testExitRemote :: TestTransport -> Assertion
testExitRemote :: TestTransport -> IO ()
testExitRemote TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
node1 <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  LocalNode
node2 <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  MVar ()
supervisedDone <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
supervisorDone <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  ProcessId
pid <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node1 (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    ([Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [] :: Process ()) -- block forever
      Process () -> (ProcessId -> String -> Process ()) -> Process ()
forall a b.
(Show a, Serializable a) =>
Process b -> (ProcessId -> a -> Process b) -> Process b
`catchExit` \ProcessId
_from String
reason -> do
        -- TODO: should verify that 'from' has the right value
        Bool
res <- Bool -> Process Bool
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Process Bool) -> Bool -> Process Bool
forall a b. (a -> b) -> a -> b
$ String
reason String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"TestExit"
        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 () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
supervisedDone ()
        if Bool
res
          then () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"Something went horribly wrong"

  LocalNode -> Process () -> IO ()
runProcess LocalNode
node2 (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    MonitorRef
ref <- ProcessId -> Process MonitorRef
monitor ProcessId
pid
    ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
exit ProcessId
pid String
"TestExit"
    ProcessMonitorNotification
mn <- Process ProcessMonitorNotification
forall a. Serializable a => Process a
expect
    case ProcessMonitorNotification
mn of
      ProcessMonitorNotification MonitorRef
ref' ProcessId
pid' DiedReason
DiedNormal -> do
        Bool
res' <- Bool -> Process Bool
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Process Bool) -> Bool -> Process Bool
forall a b. (a -> b) -> a -> b
$ MonitorRef
ref MonitorRef -> MonitorRef -> Bool
forall a. Eq a => a -> a -> Bool
== MonitorRef
ref' Bool -> Bool -> Bool
&& ProcessId
pid ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid'
        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 () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
supervisorDone ()
        if Bool
res'
          then () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"Something went horribly wrong"
      ProcessMonitorNotification
_ -> String -> Process ()
forall a b. Serializable a => a -> Process b
die String
"Something went horribly wrong"

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
supervisedDone
  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
supervisorDone

testRegistryMonitoring :: TestTransport -> Assertion
testRegistryMonitoring :: TestTransport -> IO ()
testRegistryMonitoring TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
node1 <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  LocalNode
node2 <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable

  let nid :: NodeId
nid = LocalNode -> NodeId
localNodeId LocalNode
node2
  ProcessId
pid <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node1 (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
self <- Process ProcessId
getSelfPid
    NodeId -> ProcessId -> Process ()
runUntilRegistered NodeId
nid ProcessId
self
    String -> Process ()
say (String -> Process ()) -> String -> Process ()
forall a b. (a -> b) -> a -> b
$ (ProcessId -> String
forall a. Show a => a -> String
show ProcessId
self) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" registered as " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
regName
    Process ()
forall a. Serializable a => Process a
expect :: Process ()
    String -> Process ()
say (String -> Process ()) -> String -> Process ()
forall a b. (a -> b) -> a -> b
$ (ProcessId -> String
forall a. Show a => a -> String
show ProcessId
self) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" exiting normally"

  LocalNode -> Process () -> IO ()
runProcess LocalNode
node2 (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> ProcessId -> Process ()
register String
regName ProcessId
pid
    String -> Process ()
say (String -> Process ()) -> String -> Process ()
forall a b. (a -> b) -> a -> b
$ String
regName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" registered to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ProcessId -> String
forall a. Show a => a -> String
show ProcessId
pid
    Maybe ProcessId
res <- String -> Process (Maybe ProcessId)
whereis String
regName
    ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid ()
    String -> Process ()
say (String -> Process ()) -> String -> Process ()
forall a b. (a -> b) -> a -> b
$ String
" sent finish signal to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ProcessId -> String
forall a. Show a => a -> String
show ProcessId
pid
    ProcessId
_ <- Process ProcessId
getSelfPid
    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
$ HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"expected (Just pid)" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe ProcessId
res Maybe ProcessId -> Maybe ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== (ProcessId -> Maybe ProcessId
forall a. a -> Maybe a
Just ProcessId
pid)


    -- This delay isn't essential!
    -- The test case passes perfectly fine without it (feel free to comment out
    -- and see), however waiting a few seconds here, makes it much more likely
    -- that in delayUntilMaybeUnregistered we will hit the match case right
    -- away, and thus not be subjected to a 20 second delay. The value of 4
    -- seconds appears to work optimally on osx and across several linux distros
    -- running in virtual machines (which is essentially what we do in CI)
    Process (Maybe Message) -> Process ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Process (Maybe Message) -> Process ())
-> Process (Maybe Message) -> Process ()
forall a b. (a -> b) -> a -> b
$ Int -> [Match Message] -> Process (Maybe Message)
forall b. Int -> [Match b] -> Process (Maybe b)
receiveTimeout Int
4000000 [ (Message -> Process Message) -> Match Message
forall b. (Message -> Process b) -> Match b
matchAny Message -> Process Message
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ]

  -- This delay doesn't serve much purpose in the happy path, however if some
  -- future patch breaks the cooperative behaviour of node controllers viz
  -- remote process registration and notification taking place via ncEffectDied,
  -- there would be the possibility of a race in the test case should we attempt
  -- to evaluate `whereis regName` on node2 right away. In case the name is still
  -- erroneously registered, observing the 20 second delay (or lack of), could at
  -- least give a hint that something is wrong, and we give up our time slice
  -- so that there's a higher change the registrations have been cleaned up
  -- in either case.
  LocalNode -> Process () -> IO ()
runProcess LocalNode
node2 (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ NodeId -> ProcessId -> Process ()
forall {t}. NodeId -> t -> Process ()
delayUntilMaybeUnregistered NodeId
nid ProcessId
pid

  MVar (Maybe ProcessId)
regHere <- IO (MVar (Maybe ProcessId))
forall a. IO (MVar a)
newEmptyMVar
  LocalNode -> Process () -> IO ()
runProcess LocalNode
node2 (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Process (Maybe ProcessId)
whereis String
regName Process (Maybe ProcessId)
-> (Maybe 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ())
-> (Maybe ProcessId -> IO ()) -> Maybe ProcessId -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar (Maybe ProcessId) -> Maybe ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Maybe ProcessId)
regHere
  Maybe ProcessId
res <- MVar (Maybe ProcessId) -> IO (Maybe ProcessId)
forall a. MVar a -> IO a
takeMVar MVar (Maybe ProcessId)
regHere
  case Maybe ProcessId
res of
    Maybe ProcessId
Nothing  -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe ProcessId
_        -> HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool (String
"expected Nothing, but got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ProcessId -> String
forall a. Show a => a -> String
show ProcessId
pid) Bool
False

  where
    runUntilRegistered :: NodeId -> ProcessId -> Process ()
runUntilRegistered NodeId
nid ProcessId
us = do
      NodeId -> String -> Process ()
whereisRemoteAsync NodeId
nid String
regName
      [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [
          (WhereIsReply -> Bool) -> (WhereIsReply -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(WhereIsReply String
n (Just ProcessId
p)) -> String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
regName Bool -> Bool -> Bool
&& ProcessId
p ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
us)
                  (Process () -> WhereIsReply -> Process ()
forall a b. a -> b -> a
const (Process () -> WhereIsReply -> Process ())
-> Process () -> WhereIsReply -> Process ()
forall a b. (a -> b) -> a -> b
$ () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        ]

    delayUntilMaybeUnregistered :: NodeId -> t -> Process ()
delayUntilMaybeUnregistered NodeId
nid t
p = do
      NodeId -> String -> Process ()
whereisRemoteAsync NodeId
nid String
regName
      Maybe ()
res <- Int -> [Match ()] -> Process (Maybe ())
forall b. Int -> [Match b] -> Process (Maybe b)
receiveTimeout Int
20000000 {- 20 sec delay -} [
          (WhereIsReply -> Bool) -> (WhereIsReply -> Process ()) -> Match ()
forall a b.
Serializable a =>
(a -> Bool) -> (a -> Process b) -> Match b
matchIf (\(WhereIsReply String
n Maybe ProcessId
p') -> String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
regName Bool -> Bool -> Bool
&& Maybe ProcessId -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ProcessId
p')
                  (Process () -> WhereIsReply -> Process ()
forall a b. a -> b -> a
const (Process () -> WhereIsReply -> Process ())
-> Process () -> WhereIsReply -> 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 ()
res of
        Just () -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Maybe ()
Nothing -> NodeId -> t -> Process ()
delayUntilMaybeUnregistered NodeId
nid t
p

    regName :: String
regName = String
"testRegisterRemote"

testUnsafeSend :: TestTransport -> Assertion
testUnsafeSend :: TestTransport -> IO ()
testUnsafeSend TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  MVar ProcessId
serverAddr <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
clientDone <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  IO ProcessId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ProcessId -> IO ()) -> IO ProcessId -> IO ()
forall a b. (a -> b) -> a -> b
$ LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
self <- Process ProcessId
getSelfPid
    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
serverAddr ProcessId
self
    ProcessId
clientAddr <- Process ProcessId
forall a. Serializable a => Process a
expect
    ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
unsafeSend ProcessId
clientAddr ()

  IO ProcessId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ProcessId -> IO ()) -> IO ProcessId -> IO ()
forall a b. (a -> b) -> a -> b
$ LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
serverPid <- 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
serverAddr
    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 -> ProcessId -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
unsafeSend ProcessId
serverPid
    Process ()
forall a. Serializable a => Process a
expect Process () -> (() -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (() -> IO ()) -> () -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
clientDone

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
clientDone

testUnsafeUSend :: TestTransport -> Assertion
testUnsafeUSend :: TestTransport -> IO ()
testUnsafeUSend TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  MVar ProcessId
serverAddr <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
clientDone <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  IO ProcessId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ProcessId -> IO ()) -> IO ProcessId -> IO ()
forall a b. (a -> b) -> a -> b
$ LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
self <- Process ProcessId
getSelfPid
    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
serverAddr ProcessId
self
    ProcessId
clientAddr <- Process ProcessId
forall a. Serializable a => Process a
expect
    ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
unsafeUSend ProcessId
clientAddr ()

  IO ProcessId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ProcessId -> IO ()) -> IO ProcessId -> IO ()
forall a b. (a -> b) -> a -> b
$ LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
serverPid <- 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
serverAddr
    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 -> ProcessId -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
unsafeUSend ProcessId
serverPid
    Process ()
forall a. Serializable a => Process a
expect Process () -> (() -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (() -> IO ()) -> () -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
clientDone

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
clientDone

testUnsafeNSend :: TestTransport -> Assertion
testUnsafeNSend :: TestTransport -> IO ()
testUnsafeNSend TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  MVar ()
clientDone <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable

  ProcessId
pid <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    Process ()
forall a. Serializable a => Process a
expect Process () -> (() -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (() -> IO ()) -> () -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
clientDone

  IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> ProcessId -> Process ()
register String
"foobar" ProcessId
pid
    String -> () -> Process ()
forall a. Serializable a => String -> a -> Process ()
unsafeNSend String
"foobar" ()

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
clientDone

testUnsafeNSendRemote :: TestTransport -> Assertion
testUnsafeNSendRemote :: TestTransport -> IO ()
testUnsafeNSendRemote TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  MVar ()
clientDone <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  LocalNode
localNode1 <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  LocalNode
localNode2 <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable

  ProcessId
_ <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode1 (Process () -> IO ProcessId) -> Process () -> IO 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"
    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 () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
clientDone ()
    Process ()
forall a. Serializable a => Process a
expect Process () -> (() -> 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
>>= IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Process ()) -> (() -> IO ()) -> () -> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
clientDone

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
clientDone
  IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LocalNode -> Process () -> IO ()
runProcess LocalNode
localNode2 (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    NodeId -> String -> () -> Process ()
forall a. Serializable a => NodeId -> String -> a -> Process ()
unsafeNSendRemote (LocalNode -> NodeId
localNodeId LocalNode
localNode1) String
"foobar" ()

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
clientDone

testUnsafeSendChan :: TestTransport -> Assertion
testUnsafeSendChan :: TestTransport -> IO ()
testUnsafeSendChan TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  MVar ProcessId
serverAddr <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
clientDone <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  LocalNode
localNode <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable
  IO ProcessId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ProcessId -> IO ()) -> IO ProcessId -> IO ()
forall a b. (a -> b) -> a -> b
$ LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
self <- Process ProcessId
getSelfPid
    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
serverAddr ProcessId
self
    SendPort ()
sp <- Process (SendPort ())
forall a. Serializable a => Process a
expect
    SendPort () -> () -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
unsafeSendChan SendPort ()
sp ()

  IO ProcessId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ProcessId -> IO ()) -> IO ProcessId -> IO ()
forall a b. (a -> b) -> a -> b
$ LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
serverPid <- 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
serverAddr
    (SendPort ()
sp, ReceivePort ()
rp) <- Process (SendPort (), ReceivePort ())
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
    ProcessId -> SendPort () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
unsafeSend ProcessId
serverPid SendPort ()
sp
    ReceivePort () -> Process ()
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort ()
rp :: Process ()
    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 () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
clientDone ()

  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
clientDone

testCallLocal :: TestTransport -> Assertion
testCallLocal :: TestTransport -> IO ()
testCallLocal TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} = do
  LocalNode
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
initRemoteTable

  -- Testing that (/=) <$> getSelfPid <*> callLocal getSelfPid.
  MVar Bool
result <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar
  LocalNode -> Process () -> IO ()
runProcess LocalNode
node (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Bool
r <- ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
(/=) (ProcessId -> ProcessId -> Bool)
-> Process ProcessId -> Process (ProcessId -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Process ProcessId
getSelfPid Process (ProcessId -> Bool) -> Process ProcessId -> Process Bool
forall a b. Process (a -> b) -> Process a -> Process b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Process ProcessId -> Process ProcessId
forall a. Process a -> Process a
callLocal Process ProcessId
getSelfPid
    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 Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
result Bool
r

  MVar Bool -> IO Bool
forall a. MVar a -> IO a
takeMVar MVar Bool
result IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected 'True'"

  -- Testing that when callLocal is interrupted, the worker is interrupted.
  IORef Bool
ibox <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
  LocalNode -> Process () -> IO ()
runProcess LocalNode
node (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
keeper <- Process ProcessId
getSelfPid
    Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ do
        ProcessId
caller <- Process ProcessId
getSelfPid
        ProcessId -> ProcessId -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
keeper ProcessId
caller
        Process () -> Process () -> Process ()
forall (m :: * -> *) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
onException
          (Process () -> Process ()
forall a. Process a -> Process a
callLocal (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ do
                Process () -> Process () -> Process ()
forall (m :: * -> *) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
onException (do ProcessId -> ProcessId -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
keeper ProcessId
caller
                                Process ()
forall a. Serializable a => Process a
expect)
                            (do 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
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
ibox Bool
True))
          (ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
keeper ())
    ProcessId
caller <- Process ProcessId
forall a. Serializable a => Process a
expect
    ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
exit ProcessId
caller String
"test"
    Process ()
forall a. Serializable a => Process a
expect :: Process ()

  IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
ibox IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected 'True'"

  -- Testing that when the worker raises an exception, the exception is propagated to the parent.
  IORef Bool
ibox2 <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
  LocalNode -> Process () -> IO ()
runProcess LocalNode
node (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Either ErrorCall ()
r <- Process () -> Process (Either ErrorCall ())
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (Process () -> Process ()
forall a. Process a -> Process a
callLocal (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ String -> Process Any
forall a. HasCallStack => String -> a
error String
"e" Process Any -> 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 ())
    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
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
ibox2 (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ case Either ErrorCall ()
r of
      Left (ErrorCall String
"e") -> Bool
True
      Either ErrorCall ()
_ -> Bool
False

  IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
ibox IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected 'True'"

  -- Test that caller waits for the worker in correct situation
  IORef Bool
ibox3 <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
  MVar Bool
result3 <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar
  LocalNode -> Process () -> IO ()
runProcess LocalNode
node (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
keeper <- Process ProcessId
getSelfPid
    Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ do
        Process () -> Process ()
forall a. Process a -> Process a
callLocal (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$
            (do ProcessId
us <- Process ProcessId
getSelfPid
                ProcessId -> ProcessId -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
keeper ProcessId
us
                () <- Process ()
forall a. Serializable a => Process a
expect
                IO () -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
yield)
            Process () -> Process () -> Process ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` (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
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
ibox3 Bool
True)
        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 Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
result3 (Bool -> IO ()) -> IO Bool -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
ibox3
    ProcessId
worker <- Process ProcessId
forall a. Serializable a => Process a
expect
    ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
worker ()

  MVar Bool -> IO Bool
forall a. MVar a -> IO a
takeMVar MVar Bool
result3 IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected 'True'"

  -- Test that caller waits for the worker in case when caller gets an exception
  IORef Bool
ibox4 <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
  MVar Bool
result4 <- IO (MVar Bool)
forall a. IO (MVar a)
newEmptyMVar
  LocalNode -> Process () -> IO ()
runProcess LocalNode
node (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
keeper <- Process ProcessId
getSelfPid
    Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ do
        ProcessId
caller <- Process ProcessId
getSelfPid
        Process () -> Process ()
forall a. Process a -> Process a
callLocal
            ((do ProcessId -> ProcessId -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
keeper ProcessId
caller
                 Process ()
forall a. Serializable a => Process a
expect)
               Process () -> Process () -> Process ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` (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
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
ibox4 Bool
True))
            Process () -> Process () -> Process ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` (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 Bool -> Bool -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Bool
result4 (Bool -> IO ()) -> IO Bool -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
ibox4)
    ProcessId
caller <- Process ProcessId
forall a. Serializable a => Process a
expect
    ProcessId -> String -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
exit ProcessId
caller String
"hi!"

  MVar Bool -> IO Bool
forall a. MVar a -> IO a
takeMVar MVar Bool
result4 IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => String -> Bool -> IO ()
String -> Bool -> IO ()
assertBool String
"Expected 'True'"
  -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.

tests :: TestTransport -> IO [Test]
tests :: TestTransport -> IO [Test]
tests TestTransport
testtrans = [Test] -> IO [Test]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [
     String -> [Test] -> Test
testGroup String
"Basic features" [
        String -> IO () -> Test
testCase String
"Ping"                (TestTransport -> IO ()
testPing                TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"Math"                (TestTransport -> IO ()
testMath                TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"Timeout"             (TestTransport -> IO ()
testTimeout             TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"Timeout0"            (TestTransport -> IO ()
testTimeout0            TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"SendToTerminated"    (TestTransport -> IO ()
testSendToTerminated    TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"TypedChannnels"      (TestTransport -> IO ()
testTypedChannels       TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"Terminate"           (TestTransport -> IO ()
testTerminate           TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"RegistryRemoteProcess" (TestTransport -> IO ()
testRegistryRemoteProcess      TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"RemoteRegistry"      (TestTransport -> IO ()
testRemoteRegistry      TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"RemoteRegistryRemoteProcess" (TestTransport -> IO ()
testRemoteRegistryRemoteProcess      TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"SpawnLocal"          (TestTransport -> IO ()
testSpawnLocal          TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"SpawnAsyncStrictness" (TestTransport -> IO ()
testSpawnAsyncStrictness TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"HandleMessageIf"     (TestTransport -> IO ()
testHandleMessageIf     TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"MatchAny"            (TestTransport -> IO ()
testMatchAny            TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"MatchAnyHandle"      (TestTransport -> IO ()
testMatchAnyHandle      TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"MatchAnyNoHandle"    (TestTransport -> IO ()
testMatchAnyNoHandle    TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"MatchAnyIf"          (TestTransport -> IO ()
testMatchAnyIf          TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"MatchMessageUnwrap"  (TestTransport -> IO ()
testMatchMessageWithUnwrap TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"ReceiveChanTimeout"  (TestTransport -> IO ()
testReceiveChanTimeout  TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"ReceiveChanFeatures" (TestTransport -> IO ()
testReceiveChanFeatures TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"ChanLifecycle"       (TestTransport -> IO ()
testChanLifecycle       TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"KillLocal"           (TestTransport -> IO ()
testKillLocal           TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"KillRemote"          (TestTransport -> IO ()
testKillRemote          TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"Die"                 (TestTransport -> IO ()
testDie                 TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"PrettyExit"          (TestTransport -> IO ()
testPrettyExit          TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"CatchesExit"         (TestTransport -> IO ()
testCatchesExit         TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"Catches"             (TestTransport -> IO ()
testCatches             TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"MaskRestoreScope"    (TestTransport -> IO ()
testMaskRestoreScope    TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"ExitLocal"           (TestTransport -> IO ()
testExitLocal           TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"ExitRemote"          (TestTransport -> IO ()
testExitRemote          TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"RegistryMonitoring"  (TestTransport -> IO ()
testRegistryMonitoring  TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"TextCallLocal"       (TestTransport -> IO ()
testCallLocal           TestTransport
testtrans)
      -- Unsafe Primitives
      , String -> IO () -> Test
testCase String
"TestUnsafeSend"      (TestTransport -> IO ()
testUnsafeSend          TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"TestUnsafeUSend"     (TestTransport -> IO ()
testUnsafeUSend         TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"TestUnsafeNSend"     (TestTransport -> IO ()
testUnsafeNSend         TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"TestUnsafeNSendRemote" (TestTransport -> IO ()
testUnsafeNSendRemote TestTransport
testtrans)
      , String -> IO () -> Test
testCase String
"TestUnsafeSendChan"  (TestTransport -> IO ()
testUnsafeSendChan      TestTransport
testtrans)
      -- usend
      , String -> IO () -> Test
testCase String
"USend"               ((ProcessId -> Int -> Process ()) -> TestTransport -> Int -> IO ()
testUSend ProcessId -> Int -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
usend         TestTransport
testtrans Int
50)
      , String -> IO () -> Test
testCase String
"UForward"
                 ((ProcessId -> Int -> Process ()) -> TestTransport -> Int -> IO ()
testUSend (\ProcessId
p Int
m -> Message -> ProcessId -> Process ()
uforward (Int -> Message
forall a. Serializable a => a -> Message
createUnencodedMessage Int
m) ProcessId
p)
                            TestTransport
testtrans Int
50
                 )
      ]
    , String -> [Test] -> Test
testGroup String
"Monitoring and Linking" [
      -- Monitoring processes
      --
      -- The "missing" combinations in the list below don't make much sense, as
      -- we cannot guarantee that the monitor reply or link exception will not
      -- happen before the unmonitor or unlink
      String -> IO () -> Test
testCase String
"MonitorNormalTermination"     (TestTransport -> Bool -> Bool -> IO ()
testMonitorNormalTermination   TestTransport
testtrans Bool
True  Bool
False)
    , String -> IO () -> Test
testCase String
"MonitorAbnormalTermination"   (TestTransport -> Bool -> Bool -> IO ()
testMonitorAbnormalTermination TestTransport
testtrans Bool
True  Bool
False)
    , String -> IO () -> Test
testCase String
"MonitorLocalDeadProcess"      (TestTransport -> Bool -> Bool -> IO ()
testMonitorLocalDeadProcess    TestTransport
testtrans Bool
True  Bool
False)
    , String -> IO () -> Test
testCase String
"MonitorRemoteDeadProcess"     (TestTransport -> Bool -> Bool -> IO ()
testMonitorRemoteDeadProcess   TestTransport
testtrans Bool
True  Bool
False)
    , String -> IO () -> Test
testCase String
"MonitorDisconnect"            (TestTransport -> Bool -> Bool -> IO ()
testMonitorDisconnect          TestTransport
testtrans Bool
True  Bool
False)
    , String -> IO () -> Test
testCase String
"LinkUnreachable"              (TestTransport -> Bool -> Bool -> IO ()
testMonitorUnreachable         TestTransport
testtrans Bool
False Bool
False)
    , String -> IO () -> Test
testCase String
"LinkNormalTermination"        (TestTransport -> Bool -> Bool -> IO ()
testMonitorNormalTermination   TestTransport
testtrans Bool
False Bool
False)
    , String -> IO () -> Test
testCase String
"LinkAbnormalTermination"      (TestTransport -> Bool -> Bool -> IO ()
testMonitorAbnormalTermination TestTransport
testtrans Bool
False Bool
False)
    , String -> IO () -> Test
testCase String
"LinkLocalDeadProcess"         (TestTransport -> Bool -> Bool -> IO ()
testMonitorLocalDeadProcess    TestTransport
testtrans Bool
False Bool
False)
    , String -> IO () -> Test
testCase String
"LinkRemoteDeadProcess"        (TestTransport -> Bool -> Bool -> IO ()
testMonitorRemoteDeadProcess   TestTransport
testtrans Bool
False Bool
False)
    , String -> IO () -> Test
testCase String
"LinkDisconnect"               (TestTransport -> Bool -> Bool -> IO ()
testMonitorDisconnect          TestTransport
testtrans Bool
False Bool
False)
    , String -> IO () -> Test
testCase String
"UnmonitorNormalTermination"   (TestTransport -> Bool -> Bool -> IO ()
testMonitorNormalTermination   TestTransport
testtrans Bool
True  Bool
True)
    , String -> IO () -> Test
testCase String
"UnmonitorAbnormalTermination" (TestTransport -> Bool -> Bool -> IO ()
testMonitorAbnormalTermination TestTransport
testtrans Bool
True  Bool
True)
    , String -> IO () -> Test
testCase String
"UnmonitorDisconnect"          (TestTransport -> Bool -> Bool -> IO ()
testMonitorDisconnect          TestTransport
testtrans Bool
True  Bool
True)
    , String -> IO () -> Test
testCase String
"UnlinkNormalTermination"      (TestTransport -> Bool -> Bool -> IO ()
testMonitorNormalTermination   TestTransport
testtrans Bool
False Bool
True)
    , String -> IO () -> Test
testCase String
"UnlinkAbnormalTermination"    (TestTransport -> Bool -> Bool -> IO ()
testMonitorAbnormalTermination TestTransport
testtrans Bool
False Bool
True)
    , String -> IO () -> Test
testCase String
"UnlinkDisconnect"             (TestTransport -> Bool -> Bool -> IO ()
testMonitorDisconnect          TestTransport
testtrans Bool
False Bool
True)
      -- Monitoring nodes and channels
    , String -> IO () -> Test
testCase String
"MonitorNode"                  (TestTransport -> IO ()
testMonitorNode                TestTransport
testtrans)
    , String -> IO () -> Test
testCase String
"MonitorLiveNode"              (TestTransport -> IO ()
testMonitorLiveNode            TestTransport
testtrans)
    , String -> IO () -> Test
testCase String
"MonitorChannel"               (TestTransport -> IO ()
testMonitorChannel             TestTransport
testtrans)
      -- Reconnect
    ]

      -- Tests that fail occasionally and should be revised
    -- , testGroup "Flaky" [
    --   testCase "Reconnect"          (testReconnect           testtrans)
    -- , testCase "Registry"           (testRegistry            testtrans)
    -- , testCase "MergeChannels"      (testMergeChannels       testtrans)
    -- , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False)
    -- ]
  ]