{-# OPTIONS_GHC -Wno-unused-top-binds #-}
{-# LANGUAGE TemplateHaskell, KindSignatures #-}
module Control.Distributed.Process.Tests.Closure (tests) where

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

import Data.ByteString.Lazy (empty)
import Data.IORef
import Data.Typeable (Typeable)
import Data.Maybe
import Control.Monad (join, replicateM, forever, replicateM_, void, when, unless)
import Control.Exception (IOException, throw)
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar
  ( MVar
  , newEmptyMVar
  , readMVar
  , takeMVar
  , putMVar
  , modifyMVar_
  , newMVar
  )
import System.Random (randomIO)
import Control.Distributed.Process
import Control.Distributed.Process.Closure
import Control.Distributed.Process.Node
import Control.Distributed.Process.Internal.Types
  ( createMessage
  , messageToPayload
  )
import Control.Distributed.Static (staticLabel, staticClosure)
import qualified Network.Transport as NT

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

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

quintuple :: a -> b -> c -> d -> e -> (a, b, c, d, e)
quintuple :: forall a b c d e. a -> b -> c -> d -> e -> (a, b, c, d, e)
quintuple a
a b
b c
c d
d e
e = (a
a, b
b, c
c, d
d, e
e)

sdictInt :: SerializableDict Int
sdictInt :: SerializableDict Int
sdictInt = SerializableDict Int
forall a. Serializable a => SerializableDict a
SerializableDict

factorial :: Int -> Process Int
factorial :: Int -> Process Int
factorial Int
0 = Int -> Process Int
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
1
factorial Int
n = (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
*) (Int -> Int) -> Process Int -> Process Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Process Int
factorial (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

addInt :: Int -> Int -> Int
addInt :: Int -> Int -> Int
addInt Int
x Int
y = Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y

putInt :: Int -> MVar Int -> IO ()
putInt :: Int -> MVar Int -> IO ()
putInt = (MVar Int -> Int -> IO ()) -> Int -> MVar Int -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip MVar Int -> Int -> IO ()
forall a. MVar a -> a -> IO ()
putMVar

sendPid :: ProcessId -> Process ()
sendPid :: ProcessId -> Process ()
sendPid ProcessId
toPid = do
  ProcessId
fromPid <- Process ProcessId
getSelfPid
  ProcessId -> ProcessId -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
toPid ProcessId
fromPid

wait :: Int -> Process ()
wait :: Int -> Process ()
wait = 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
. Int -> IO ()
threadDelay

expectUnit :: Process ()
expectUnit :: Process ()
expectUnit = Process ()
forall a. Serializable a => Process a
expect

isPrime :: Integer -> Process Bool
isPrime :: Integer -> Process Bool
isPrime Integer
n = Bool -> Process Bool
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Process Bool)
-> ([Integer] -> Bool) -> [Integer] -> Process Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer
n Integer -> [Integer] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) ([Integer] -> Bool)
-> ([Integer] -> [Integer]) -> [Integer] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Bool) -> [Integer] -> [Integer]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n) ([Integer] -> [Integer])
-> ([Integer] -> [Integer]) -> [Integer] -> [Integer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Integer] -> [Integer]
sieve ([Integer] -> Process Bool) -> [Integer] -> Process Bool
forall a b. (a -> b) -> a -> b
$ [Integer
2..]
  where
    sieve :: [Integer] -> [Integer]
    sieve :: [Integer] -> [Integer]
sieve (Integer
p : [Integer]
xs) = Integer
p Integer -> [Integer] -> [Integer]
forall a. a -> [a] -> [a]
: [Integer] -> [Integer]
sieve [Integer
x | Integer
x <- [Integer]
xs, Integer
x Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
p Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0]
    sieve [] = String -> [Integer]
forall a. HasCallStack => String -> a
error String
"Uh oh -- we've run out of primes"

-- | First argument indicates empty closure environment
typedPingServer :: () -> ReceivePort (SendPort ()) -> Process ()
typedPingServer :: () -> ReceivePort (SendPort ()) -> Process ()
typedPingServer () ReceivePort (SendPort ())
rport = 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
  SendPort ()
sport <- ReceivePort (SendPort ()) -> Process (SendPort ())
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort (SendPort ())
rport
  SendPort () -> () -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort ()
sport ()

signal :: ProcessId -> Process ()
signal :: ProcessId -> Process ()
signal ProcessId
pid = ProcessId -> () -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid ()

remotable [ 'factorial
          , 'addInt
          , 'putInt
          , 'sendPid
          , 'sdictInt
          , 'wait
          , 'expectUnit
          , 'typedPingServer
          , 'isPrime
          , 'quintuple
          , 'signal
          ]

randomElement :: [a] -> IO a
randomElement :: forall a. [a] -> IO a
randomElement [a]
xs = do
  Int
ix <- IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
  a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
xs [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! (Int
ix Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs))

remotableDecl [
    [d| dfib :: ([NodeId], SendPort Integer, Integer) -> Process () ;
        dfib (_, reply, 0) = sendChan reply 0
        dfib (_, reply, 1) = sendChan reply 1
        dfib (nids, reply, n) = do
          nid1 <- liftIO $ randomElement nids
          nid2 <- liftIO $ randomElement nids
          (sport, rport) <- newChan
          spawn nid1 $ $(mkClosure 'dfib) (nids, sport, n - 2)
          spawn nid2 $ $(mkClosure 'dfib) (nids, sport, n - 1)
          n1 <- receiveChan rport
          n2 <- receiveChan rport
          sendChan reply $ n1 + n2
      |]
  ]

-- Just try creating a static polymorphic value
staticQuintuple :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e)
                => Static (a -> b -> c -> d -> e -> (a, b, c, d, e))
staticQuintuple :: forall a b c d e.
(Typeable a, Typeable b, Typeable c, Typeable d, Typeable e) =>
Static (a -> b -> c -> d -> e -> (a, b, c, d, e))
staticQuintuple = $(mkStatic 'quintuple)

factorialClosure :: Int -> Closure (Process Int)
factorialClosure :: Int -> Closure (Process Int)
factorialClosure = $(mkClosure 'factorial)

addIntClosure :: Int -> Closure (Int -> Int)
addIntClosure :: Int -> Closure (Int -> Int)
addIntClosure = $(mkClosure 'addInt)

putIntClosure :: Int -> Closure (MVar Int -> IO ())
putIntClosure :: Int -> Closure (MVar Int -> IO ())
putIntClosure = $(mkClosure 'putInt)

sendPidClosure :: ProcessId -> Closure (Process ())
sendPidClosure :: ProcessId -> Closure (Process ())
sendPidClosure = $(mkClosure 'sendPid)

sendFac :: Int -> ProcessId -> Closure (Process ())
sendFac :: Int -> ProcessId -> Closure (Process ())
sendFac Int
n ProcessId
pid = Int -> Closure (Process Int)
factorialClosure Int
n Closure (Process Int)
-> Closure (Int -> Process ()) -> Closure (Process ())
forall a b.
(Typeable a, Typeable b) =>
Closure (Process a) -> CP a b -> Closure (Process b)
`bindCP` Static (SerializableDict Int)
-> ProcessId -> Closure (Int -> Process ())
forall a.
Typeable a =>
Static (SerializableDict a) -> ProcessId -> CP a ()
cpSend $(mkStatic 'sdictInt) ProcessId
pid

factorialOf :: Closure (Int -> Process Int)
factorialOf :: Closure (Int -> Process Int)
factorialOf = Static (Int -> Process Int) -> Closure (Int -> Process Int)
forall a. Static a -> Closure a
staticClosure $(mkStatic 'factorial)

factorial' :: Int -> Closure (Process Int)
factorial' :: Int -> Closure (Process Int)
factorial' Int
n = Static (SerializableDict Int) -> Int -> Closure (Process Int)
forall a.
Serializable a =>
Static (SerializableDict a) -> a -> Closure (Process a)
returnCP $(mkStatic 'sdictInt) Int
n Closure (Process Int)
-> Closure (Int -> Process Int) -> Closure (Process Int)
forall a b.
(Typeable a, Typeable b) =>
Closure (Process a) -> CP a b -> Closure (Process b)
`bindCP` Closure (Int -> Process Int)
factorialOf

waitClosure :: Int -> Closure (Process ())
waitClosure :: Int -> Closure (Process ())
waitClosure = $(mkClosure 'wait)

simulateNetworkFailure :: TestTransport -> LocalNode -> LocalNode -> Process ()
simulateNetworkFailure :: TestTransport -> LocalNode -> LocalNode -> Process ()
simulateNetworkFailure TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
..} LocalNode
from LocalNode
to = 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
  MVar ProcessId
m <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  ProcessId
_ <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
to (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
from (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
to)
    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 -> EndPointAddress) -> NodeId -> EndPointAddress
forall a b. (a -> b) -> a -> b
$ LocalNode -> NodeId
localNodeId LocalNode
from)
                                 (NodeId -> EndPointAddress
nodeAddress (NodeId -> EndPointAddress) -> NodeId -> EndPointAddress
forall a b. (a -> b) -> a -> b
$ LocalNode -> NodeId
localNodeId LocalNode
to)
    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 ()

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

testUnclosure :: TestTransport -> RemoteTable -> Assertion
testUnclosure :: TestTransport -> RemoteTable -> IO ()
testUnclosure TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} RemoteTable
rtable = do
  LocalNode
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    Int
i <- Process (Process Int) -> Process Int
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Process (Process Int) -> Process Int)
-> (Closure (Process Int) -> Process (Process Int))
-> Closure (Process Int)
-> Process Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure (Process Int) -> Process (Process Int)
forall a. Typeable a => Closure a -> Process a
unClosure (Closure (Process Int) -> Process Int)
-> Closure (Process Int) -> Process Int
forall a b. (a -> b) -> a -> b
$ Int -> Closure (Process Int)
factorialClosure Int
5
    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 Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
720
      then () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      else String -> Process ()
forall a. HasCallStack => String -> a
error String
"Something went horribly wrong"
  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

testBind :: TestTransport -> RemoteTable -> Assertion
testBind :: TestTransport -> RemoteTable -> IO ()
testBind TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} RemoteTable
rtable = do
  LocalNode
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
  MVar ()
done <- IO (MVar ())
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
    Process (Process ()) -> Process ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Process (Process ()) -> Process ())
-> (Closure (Process ()) -> Process (Process ()))
-> Closure (Process ())
-> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure (Process ()) -> Process (Process ())
forall a. Typeable a => Closure a -> Process a
unClosure (Closure (Process ()) -> Process ())
-> Closure (Process ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ Int -> ProcessId -> Closure (Process ())
sendFac Int
6 ProcessId
us
    (Int
i :: Int) <- Process Int
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 () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
done ()
    if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
720
      then () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      else String -> Process ()
forall a. HasCallStack => String -> a
error String
"Something went horribly wrong"
  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

testSendPureClosure :: TestTransport -> RemoteTable -> Assertion
testSendPureClosure :: TestTransport -> RemoteTable -> IO ()
testSendPureClosure TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} RemoteTable
rtable = do
  MVar ProcessId
serverAddr <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
serverDone <- 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
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
    ProcessId
addr <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
      Closure (Int -> Int)
cl <- Process (Closure (Int -> Int))
forall a. Serializable a => Process a
expect
      Int -> Int
fn <- Closure (Int -> Int) -> Process (Int -> Int)
forall a. Typeable a => Closure a -> Process a
unClosure Closure (Int -> Int)
cl :: Process (Int -> Int)
      (Int
_ :: Int) <- Int -> Process Int
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Process Int) -> Int -> Process Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
fn Int
6
      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 ()
serverDone ()
    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
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
    ProcessId
theirAddr <- MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar MVar ProcessId
serverAddr
    LocalNode -> Process () -> IO ()
runProcess LocalNode
node (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ ProcessId -> Closure (Int -> Int) -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
theirAddr (Int -> Closure (Int -> Int)
addIntClosure Int
7)

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

testSendIOClosure :: TestTransport -> RemoteTable -> Assertion
testSendIOClosure :: TestTransport -> RemoteTable -> IO ()
testSendIOClosure TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} RemoteTable
rtable = do
  MVar ProcessId
serverAddr <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
serverDone <- 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
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
    ProcessId
addr <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
      Closure (MVar Int -> IO ())
cl <- Process (Closure (MVar Int -> IO ()))
forall a. Serializable a => Process a
expect
      MVar Int -> IO ()
io <- Closure (MVar Int -> IO ()) -> Process (MVar Int -> IO ())
forall a. Typeable a => Closure a -> Process a
unClosure Closure (MVar Int -> IO ())
cl :: Process (MVar Int -> IO ())
      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
        MVar Int
someMVar <- IO (MVar Int)
forall a. IO (MVar a)
newEmptyMVar
        MVar Int -> IO ()
io MVar Int
someMVar
        Int
i <- MVar Int -> IO Int
forall a. MVar a -> IO a
readMVar MVar Int
someMVar
        MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
serverDone ()
        if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5
          then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          else String -> IO ()
forall a. HasCallStack => String -> a
error String
"Something went horribly wrong"
    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
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
    ProcessId
theirAddr <- MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar MVar ProcessId
serverAddr
    LocalNode -> Process () -> IO ()
runProcess LocalNode
node (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ ProcessId -> Closure (MVar Int -> IO ()) -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
theirAddr (Int -> Closure (MVar Int -> IO ())
putIntClosure Int
5)

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

testSendProcClosure :: TestTransport -> RemoteTable -> Assertion
testSendProcClosure :: TestTransport -> RemoteTable -> IO ()
testSendProcClosure TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} RemoteTable
rtable = do
  MVar ProcessId
serverAddr <- IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
clientDone <- 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
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
    ProcessId
addr <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
      Closure (Int -> Process ())
cl <- Process (Closure (Int -> Process ()))
forall a. Serializable a => Process a
expect
      Int -> Process ()
pr <- Closure (Int -> Process ()) -> Process (Int -> Process ())
forall a. Typeable a => Closure a -> Process a
unClosure Closure (Int -> Process ())
cl :: Process (Int -> Process ())
      Int -> Process ()
pr Int
5
    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
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
    ProcessId
theirAddr <- MVar ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar MVar ProcessId
serverAddr
    LocalNode -> Process () -> IO ()
runProcess LocalNode
node (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ProcessId
pid <- Process ProcessId
getSelfPid
      ProcessId -> Closure (Int -> Process ()) -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
theirAddr (Static (SerializableDict Int)
-> ProcessId -> Closure (Int -> Process ())
forall a.
Typeable a =>
Static (SerializableDict a) -> ProcessId -> CP a ()
cpSend $(mkStatic 'sdictInt) ProcessId
pid)
      Int
i <- Process Int
forall a. Serializable a => Process a
expect :: Process Int
      if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5
        then 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 ()
        else String -> Process ()
forall a. HasCallStack => String -> a
error String
"Something went horribly wrong"

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

testSpawn :: TestTransport -> RemoteTable -> Assertion
testSpawn :: TestTransport -> RemoteTable -> IO ()
testSpawn TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} RemoteTable
rtable = do
  MVar NodeId
serverNodeAddr <- IO (MVar NodeId)
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
clientDone <- 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
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
    MVar NodeId -> NodeId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar NodeId
serverNodeAddr (LocalNode -> NodeId
localNodeId LocalNode
node)

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
    NodeId
nid <- MVar NodeId -> IO NodeId
forall a. MVar a -> IO a
readMVar MVar NodeId
serverNodeAddr
    LocalNode -> Process () -> IO ()
runProcess LocalNode
node (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ProcessId
pid   <- Process ProcessId
getSelfPid
      ProcessId
pid'  <- NodeId -> Closure (Process ()) -> Process ProcessId
spawn NodeId
nid (ProcessId -> Closure (Process ())
sendPidClosure ProcessId
pid)
      ProcessId
pid'' <- Process ProcessId
forall a. Serializable a => Process a
expect
      if ProcessId
pid' ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid''
        then 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 ()
        else String -> Process ()
forall a. HasCallStack => String -> a
error String
"Something went horribly wrong"

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

-- | Tests that spawn executes the supplied closure even if the caller dies
-- immediately after calling spawn.
--
-- This situation is of interest because the implementation of spawn has the
-- remote peer monitor the caller. See DP-99.
--
-- The condition is tested by using a transport which refuses to send to the
-- remote peer the message that it is waiting to stop monitoring the caller,
-- namely @()@.
--
testSpawnRace :: TestTransport -> RemoteTable -> Assertion
testSpawnRace :: TestTransport -> RemoteTable -> IO ()
testSpawnRace TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} RemoteTable
rtable = do
    LocalNode
node1 <- Transport -> RemoteTable -> IO LocalNode
newLocalNode (Transport -> Transport
wrapTransport Transport
testTransport) RemoteTable
rtable
    LocalNode
node2 <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable

    LocalNode -> Process () -> IO ()
runProcess LocalNode
node1 (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ProcessId
pid <- Process ProcessId
getSelfPid
      Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ NodeId -> Closure (Process ()) -> Process ProcessId
spawn (LocalNode -> NodeId
localNodeId LocalNode
node2) (ProcessId -> Closure (Process ())
sendPidClosure ProcessId
pid) 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
pid
      ProcessId
pid'  <- Process ProcessId
forall a. Serializable a => Process a
expect :: Process ProcessId
      ProcessId
pid'' <- Process ProcessId
forall a. Serializable a => Process a
expect :: Process ProcessId
      if ProcessId
pid' ProcessId -> ProcessId -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessId
pid''
        then () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else String -> Process ()
forall a. HasCallStack => String -> a
error String
"Something went horribly wrong"

  where

    wrapTransport :: Transport -> Transport
wrapTransport (NT.Transport IO (Either (TransportError NewEndPointErrorCode) EndPoint)
ne IO ()
ct) = IO (Either (TransportError NewEndPointErrorCode) EndPoint)
-> IO () -> Transport
NT.Transport ((Either (TransportError NewEndPointErrorCode) EndPoint
 -> Either (TransportError NewEndPointErrorCode) EndPoint)
-> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
-> IO (Either (TransportError NewEndPointErrorCode) EndPoint)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((EndPoint -> EndPoint)
-> Either (TransportError NewEndPointErrorCode) EndPoint
-> Either (TransportError NewEndPointErrorCode) EndPoint
forall a b.
(a -> b)
-> Either (TransportError NewEndPointErrorCode) a
-> Either (TransportError NewEndPointErrorCode) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap EndPoint -> EndPoint
wrapEP) IO (Either (TransportError NewEndPointErrorCode) EndPoint)
ne) IO ()
ct

    wrapEP :: NT.EndPoint -> NT.EndPoint
    wrapEP :: EndPoint -> EndPoint
wrapEP EndPoint
e =
      EndPoint
e { NT.connect = \EndPointAddress
x Reliability
y ConnectHints
z -> do
            IORef Bool
healthy <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True
            (Either (TransportError ConnectErrorCode) Connection
 -> Either (TransportError ConnectErrorCode) Connection)
-> IO (Either (TransportError ConnectErrorCode) Connection)
-> IO (Either (TransportError ConnectErrorCode) Connection)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Connection -> Connection)
-> Either (TransportError ConnectErrorCode) Connection
-> Either (TransportError ConnectErrorCode) Connection
forall a b.
(a -> b)
-> Either (TransportError ConnectErrorCode) a
-> Either (TransportError ConnectErrorCode) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Connection -> Connection)
 -> Either (TransportError ConnectErrorCode) Connection
 -> Either (TransportError ConnectErrorCode) Connection)
-> (Connection -> Connection)
-> Either (TransportError ConnectErrorCode) Connection
-> Either (TransportError ConnectErrorCode) Connection
forall a b. (a -> b) -> a -> b
$ IORef Bool
-> EndPoint -> EndPointAddress -> Connection -> Connection
wrapConnection IORef Bool
healthy EndPoint
e EndPointAddress
x) (IO (Either (TransportError ConnectErrorCode) Connection)
 -> IO (Either (TransportError ConnectErrorCode) Connection))
-> IO (Either (TransportError ConnectErrorCode) Connection)
-> IO (Either (TransportError ConnectErrorCode) Connection)
forall a b. (a -> b) -> a -> b
$ EndPoint
-> EndPointAddress
-> Reliability
-> ConnectHints
-> IO (Either (TransportError ConnectErrorCode) Connection)
NT.connect EndPoint
e EndPointAddress
x Reliability
y ConnectHints
z
        }

    wrapConnection :: IORef Bool -> NT.EndPoint -> NT.EndPointAddress
                   -> NT.Connection -> NT.Connection
    wrapConnection :: IORef Bool
-> EndPoint -> EndPointAddress -> Connection -> Connection
wrapConnection IORef Bool
healthy EndPoint
e EndPointAddress
remoteAddr (NT.Connection [ByteString] -> IO (Either (TransportError SendErrorCode) ())
s IO ()
closeC) =
      (([ByteString] -> IO (Either (TransportError SendErrorCode) ()))
 -> IO () -> Connection)
-> IO ()
-> ([ByteString] -> IO (Either (TransportError SendErrorCode) ()))
-> Connection
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([ByteString] -> IO (Either (TransportError SendErrorCode) ()))
-> IO () -> Connection
NT.Connection IO ()
closeC (([ByteString] -> IO (Either (TransportError SendErrorCode) ()))
 -> Connection)
-> ([ByteString] -> IO (Either (TransportError SendErrorCode) ()))
-> Connection
forall a b. (a -> b) -> a -> b
$ \[ByteString]
msg -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ByteString]
msg [ByteString] -> [ByteString] -> Bool
forall a. Eq a => a -> a -> Bool
== Message -> [ByteString]
messageToPayload (() -> Message
forall a. Serializable a => a -> Message
createMessage ())) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
healthy Bool
False
          EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection (EndPoint -> EndPointAddress
NT.address EndPoint
e) EndPointAddress
remoteAddr
        Bool
isHealthy <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
healthy
        if Bool
isHealthy then [ByteString] -> IO (Either (TransportError SendErrorCode) ())
s [ByteString]
msg
          else Either (TransportError SendErrorCode) ()
-> IO (Either (TransportError SendErrorCode) ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (TransportError SendErrorCode) ()
 -> IO (Either (TransportError SendErrorCode) ()))
-> Either (TransportError SendErrorCode) ()
-> IO (Either (TransportError SendErrorCode) ())
forall a b. (a -> b) -> a -> b
$ TransportError SendErrorCode
-> Either (TransportError SendErrorCode) ()
forall a b. a -> Either a b
Left (TransportError SendErrorCode
 -> Either (TransportError SendErrorCode) ())
-> TransportError SendErrorCode
-> Either (TransportError SendErrorCode) ()
forall a b. (a -> b) -> a -> b
$ SendErrorCode -> String -> TransportError SendErrorCode
forall error. error -> String -> TransportError error
NT.TransportError SendErrorCode
NT.SendFailed String
""

testCall :: TestTransport -> RemoteTable -> Assertion
testCall :: TestTransport -> RemoteTable -> IO ()
testCall TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} RemoteTable
rtable = do
  MVar NodeId
serverNodeAddr <- IO (MVar NodeId)
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
clientDone <- 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
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
    MVar NodeId -> NodeId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar NodeId
serverNodeAddr (LocalNode -> NodeId
localNodeId LocalNode
node)

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
    NodeId
nid <- MVar NodeId -> IO NodeId
forall a. MVar a -> IO a
readMVar MVar NodeId
serverNodeAddr
    LocalNode -> Process () -> IO ()
runProcess LocalNode
node (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (Int
a :: Int) <- Static (SerializableDict Int)
-> NodeId -> Closure (Process Int) -> Process Int
forall a.
Serializable a =>
Static (SerializableDict a)
-> NodeId -> Closure (Process a) -> Process a
call $(mkStatic 'sdictInt) NodeId
nid (Int -> Closure (Process Int)
factorialClosure Int
5)
      if Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
120
        then 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 ()
        else String -> Process ()
forall a. HasCallStack => String -> a
error String
"something went horribly wrong"

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

testCallBind :: TestTransport -> RemoteTable -> Assertion
testCallBind :: TestTransport -> RemoteTable -> IO ()
testCallBind TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} RemoteTable
rtable = do
  MVar NodeId
serverNodeAddr <- IO (MVar NodeId)
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
clientDone <- 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
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
    MVar NodeId -> NodeId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar NodeId
serverNodeAddr (LocalNode -> NodeId
localNodeId LocalNode
node)

  IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    LocalNode
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
    NodeId
nid <- MVar NodeId -> IO NodeId
forall a. MVar a -> IO a
readMVar MVar NodeId
serverNodeAddr
    LocalNode -> Process () -> IO ()
runProcess LocalNode
node (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (Int
a :: Int) <- Static (SerializableDict Int)
-> NodeId -> Closure (Process Int) -> Process Int
forall a.
Serializable a =>
Static (SerializableDict a)
-> NodeId -> Closure (Process a) -> Process a
call $(mkStatic 'sdictInt) NodeId
nid (Int -> Closure (Process Int)
factorial' Int
5)
      if Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
120
        then 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 ()
        else String -> Process ()
forall a. HasCallStack => String -> a
error String
"Something went horribly wrong"

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

testSeq :: TestTransport -> RemoteTable -> Assertion
testSeq :: TestTransport -> RemoteTable -> IO ()
testSeq TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} RemoteTable
rtable = do
  LocalNode
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
  MVar ()
done <- IO (MVar ())
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
    Process (Process ()) -> Process ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Process (Process ()) -> Process ())
-> (Closure (Process ()) -> Process (Process ()))
-> Closure (Process ())
-> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure (Process ()) -> Process (Process ())
forall a. Typeable a => Closure a -> Process a
unClosure (Closure (Process ()) -> Process ())
-> Closure (Process ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ Int -> ProcessId -> Closure (Process ())
sendFac Int
5 ProcessId
us Closure (Process ())
-> Closure (Process ()) -> Closure (Process ())
forall a b.
(Typeable a, Typeable b) =>
Closure (Process a) -> Closure (Process b) -> Closure (Process b)
`seqCP` Int -> ProcessId -> Closure (Process ())
sendFac Int
6 ProcessId
us
    Int
a :: Int <- Process Int
forall a. Serializable a => Process a
expect
    Int
b :: Int <- Process Int
forall a. Serializable a => Process a
expect
    if Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
120 Bool -> Bool -> Bool
&& Int
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
720
      then 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 ()
      else String -> Process ()
forall a. HasCallStack => String -> a
error String
"Something went horribly wrong"
  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

-- Test 'spawnSupervised'
--
-- Set up a supervisor, spawn a child, then have a third process monitor the
-- child. The supervisor then throws an exception, the child dies because it
-- was linked to the supervisor, and the third process notices that the child
-- dies.
testSpawnSupervised :: TestTransport -> RemoteTable -> Assertion
testSpawnSupervised :: TestTransport -> RemoteTable -> IO ()
testSpawnSupervised TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} RemoteTable
rtable = 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
rtable
    [MVar ProcessId
superPid, MVar ProcessId
childPid] <- Int -> IO (MVar ProcessId) -> IO [MVar ProcessId]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 (IO (MVar ProcessId) -> IO [MVar ProcessId])
-> IO (MVar ProcessId) -> IO [MVar ProcessId]
forall a b. (a -> b) -> a -> b
$ IO (MVar ProcessId)
forall a. IO (MVar a)
newEmptyMVar
    MVar ()
thirdProcessDone     <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    MVar ()
linkUp               <- 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
superPid ProcessId
us
      (ProcessId
child, MonitorRef
_ref) <- NodeId -> Closure (Process ()) -> Process (ProcessId, MonitorRef)
spawnSupervised (LocalNode -> NodeId
localNodeId LocalNode
node2)
                                       (ProcessId -> Closure (Process ())
sendPidClosure ProcessId
us Closure (Process ())
-> Closure (Process ()) -> Closure (Process ())
forall a b.
(Typeable a, Typeable b) =>
Closure (Process a) -> Closure (Process b) -> Closure (Process b)
`seqCP` $(mkStaticClosure 'expectUnit))
      ProcessId
_ <- Process ProcessId
forall a. Serializable a => Process a
expect :: Process ProcessId

      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 MVar ProcessId -> ProcessId -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ProcessId
childPid ProcessId
child
                  -- Give the child a chance to link to us
                  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
linkUp
      IOException -> Process ()
forall a e. Exception e => e -> a
throw IOException
supervisorDeath

    LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node2 (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
      [ProcessId]
res <- 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)
-> [MVar ProcessId] -> IO [ProcessId]
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 ProcessId -> IO ProcessId
forall a. MVar a -> IO a
readMVar [MVar ProcessId
superPid, MVar ProcessId
childPid]
      case [ProcessId]
res of
        [ProcessId
super, ProcessId
child] -> do
          MonitorRef
ref <- ProcessId -> Process MonitorRef
monitor ProcessId
child
          ProcessId
self <- Process ProcessId
getSelfPid
          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
10000
                Maybe ProcessInfo
mpinfo <- ProcessId -> Process (Maybe ProcessInfo)
getProcessInfo ProcessId
child
                case Maybe ProcessInfo
mpinfo of
                  Maybe ProcessInfo
Nothing -> Process ()
waitForMOrL
                  Just ProcessInfo
pinfo ->
                     Bool -> Process () -> Process ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe MonitorRef -> Bool
forall a. Maybe a -> Bool
isJust (Maybe MonitorRef -> Bool) -> Maybe MonitorRef -> Bool
forall a b. (a -> b) -> a -> b
$ 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
          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 ()
linkUp ()
          -- because monitor message was sent before message to process
          -- we hope that it will be processed before
          ProcessMonitorNotification
res' <- Process ProcessMonitorNotification
forall a. Serializable a => Process a
expect
          case ProcessMonitorNotification
res' of
              (ProcessMonitorNotification MonitorRef
ref' ProcessId
pid' (DiedException String
e)) ->
                if (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
child Bool -> Bool -> Bool
&&
                  String
e String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessLinkException -> String
forall a. Show a => a -> String
show (ProcessId -> DiedReason -> ProcessLinkException
ProcessLinkException ProcessId
super
                            (String -> DiedReason
DiedException (IOException -> String
forall a. Show a => a -> String
show IOException
supervisorDeath))))
                  then 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 ()
thirdProcessDone ()
                  else String -> Process ()
forall a. HasCallStack => String -> a
error String
"Something went horribly wrong"
              ProcessMonitorNotification
_ -> String -> Process ()
forall a. HasCallStack => String -> a
error String
"Something went horribly wrong"

        [ProcessId]
_ -> String -> Process ()
forall a b. Serializable a => a -> Process b
die (String -> Process ()) -> String -> Process ()
forall a b. (a -> b) -> a -> b
$ String
"Something went horribly wrong"

    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
thirdProcessDone
  where
    supervisorDeath :: IOException
    supervisorDeath :: IOException
supervisorDeath = String -> IOException
userError String
"Supervisor died"

testSpawnInvalid :: TestTransport -> RemoteTable -> Assertion
testSpawnInvalid :: TestTransport -> RemoteTable -> IO ()
testSpawnInvalid TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} RemoteTable
rtable = do
  LocalNode
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    (ProcessId
pid, MonitorRef
ref) <- NodeId -> Closure (Process ()) -> Process (ProcessId, MonitorRef)
spawnMonitor (LocalNode -> NodeId
localNodeId LocalNode
node) (Static (ByteString -> Process ())
-> ByteString -> Closure (Process ())
forall a. Static (ByteString -> a) -> ByteString -> Closure a
closure (String -> Static (ByteString -> Process ())
forall a. String -> Static a
staticLabel String
"ThisDoesNotExist") ByteString
empty)
    ProcessMonitorNotification MonitorRef
ref' ProcessId
pid' DiedReason
_reason <- Process ProcessMonitorNotification
forall a. Serializable a => Process a
expect
    -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure
    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'
    if Bool
res Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
True
      then 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 ()
      else String -> Process ()
forall a. HasCallStack => String -> a
error String
"Something went horribly wrong"
  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

testClosureExpect :: TestTransport -> RemoteTable -> Assertion
testClosureExpect :: TestTransport -> RemoteTable -> IO ()
testClosureExpect TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} RemoteTable
rtable = do
  LocalNode
node <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
  MVar ()
done <- IO (MVar ())
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
nodeId <- Process NodeId
getSelfNode
    ProcessId
us     <- Process ProcessId
getSelfPid
    ProcessId
them   <- NodeId -> Closure (Process ()) -> Process ProcessId
spawn NodeId
nodeId (Closure (Process ()) -> Process ProcessId)
-> Closure (Process ()) -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ Static (SerializableDict Int) -> Closure (Process Int)
forall a.
Typeable a =>
Static (SerializableDict a) -> Closure (Process a)
cpExpect $(mkStatic 'sdictInt) Closure (Process Int)
-> Closure (Int -> Process ()) -> Closure (Process ())
forall a b.
(Typeable a, Typeable b) =>
Closure (Process a) -> CP a b -> Closure (Process b)
`bindCP` Static (SerializableDict Int)
-> ProcessId -> Closure (Int -> Process ())
forall a.
Typeable a =>
Static (SerializableDict a) -> ProcessId -> CP a ()
cpSend $(mkStatic 'sdictInt) ProcessId
us
    ProcessId -> Int -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
them (Int
1234 :: Int)
    (Int
res :: Int) <- Process Int
forall a. Serializable a => Process a
expect
    if Int
res Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1234
      then 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 ()
      else String -> Process ()
forall a. HasCallStack => String -> a
error String
"Something went horribly wrong"
  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

testSpawnChannel :: TestTransport -> RemoteTable -> Assertion
testSpawnChannel :: TestTransport -> RemoteTable -> IO ()
testSpawnChannel TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} RemoteTable
rtable = do
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  [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
rtable

  LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node1 (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    SendPort (SendPort ())
pingServer <- Static (SerializableDict (SendPort ()))
-> NodeId
-> Closure (ReceivePort (SendPort ()) -> Process ())
-> Process (SendPort (SendPort ()))
forall a.
Serializable a =>
Static (SerializableDict a)
-> NodeId
-> Closure (ReceivePort a -> Process ())
-> Process (SendPort a)
spawnChannel
                    (Static (SerializableDict ())
-> Static (SerializableDict (SendPort ()))
forall a.
Typeable a =>
Static (SerializableDict a)
-> Static (SerializableDict (SendPort a))
sdictSendPort Static (SerializableDict ())
sdictUnit)
                    (LocalNode -> NodeId
localNodeId LocalNode
node2)
                    ($(mkClosure 'typedPingServer) ())
    (SendPort ()
sendReply, ReceivePort ()
receiveReply) <- Process (SendPort (), ReceivePort ())
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
    SendPort (SendPort ()) -> SendPort () -> Process ()
forall a. Serializable a => SendPort a -> a -> Process ()
sendChan SendPort (SendPort ())
pingServer SendPort ()
sendReply
    ReceivePort () -> Process ()
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort ()
receiveReply
    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

testTDict :: TestTransport -> RemoteTable -> Assertion
testTDict :: TestTransport -> RemoteTable -> IO ()
testTDict TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} RemoteTable
rtable = do
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  [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
rtable
  LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node1 (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    Bool
res <- Static (SerializableDict Bool)
-> NodeId -> Closure (Process Bool) -> Process Bool
forall a.
Serializable a =>
Static (SerializableDict a)
-> NodeId -> Closure (Process a) -> Process a
call $(functionTDict 'isPrime) (LocalNode -> NodeId
localNodeId LocalNode
node2) ($(mkClosure 'isPrime) (Integer
79 :: Integer))
    if Bool
res Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
True
      then 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 ()
      else String -> Process ()
forall a. HasCallStack => String -> a
error String
"Something went horribly wrong..."
  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
done

testFib :: TestTransport -> RemoteTable -> Assertion
testFib :: TestTransport -> RemoteTable -> IO ()
testFib TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} RemoteTable
rtable = do
  [LocalNode]
nodes <- Int -> IO LocalNode -> IO [LocalNode]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
4 (IO LocalNode -> IO [LocalNode]) -> IO LocalNode -> IO [LocalNode]
forall a b. (a -> b) -> a -> b
$ Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  LocalNode -> Process () -> IO ProcessId
forkProcess ([LocalNode] -> LocalNode
forall a. HasCallStack => [a] -> a
head [LocalNode]
nodes) (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    (SendPort Integer
sport, ReceivePort Integer
rport) <- Process (SendPort Integer, ReceivePort Integer)
forall a. Serializable a => Process (SendPort a, ReceivePort a)
newChan
    Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ ([NodeId], SendPort Integer, Integer) -> Process ()
dfib ((LocalNode -> NodeId) -> [LocalNode] -> [NodeId]
forall a b. (a -> b) -> [a] -> [b]
map LocalNode -> NodeId
localNodeId [LocalNode]
nodes, SendPort Integer
sport, Integer
10)
    Integer
ff <- ReceivePort Integer -> Process Integer
forall a. Serializable a => ReceivePort a -> Process a
receiveChan ReceivePort Integer
rport :: Process Integer
    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 Integer
ff Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
55
      then String -> Process ()
forall a b. Serializable a => a -> Process b
die (String -> Process ()) -> String -> Process ()
forall a b. (a -> b) -> a -> b
$ String
"Something went horribly wrong"
      else () -> 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

testSpawnReconnect :: TestTransport -> RemoteTable -> Assertion
testSpawnReconnect :: TestTransport -> RemoteTable -> IO ()
testSpawnReconnect testtrans :: TestTransport
testtrans@TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} RemoteTable
rtable = 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
rtable
  let nid1 :: NodeId
nid1 = LocalNode -> NodeId
localNodeId LocalNode
node1
      -- nid2 = localNodeId node2
  MVar ()
done <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  MVar Int
iv <- Int -> IO (MVar Int)
forall a. a -> IO (MVar a)
newMVar (Int
0 :: Int)

  ProcessId
incr <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node1 (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
    () <- 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 () -> Process ()) -> IO () -> Process ()
forall a b. (a -> b) -> a -> b
$ MVar Int -> (Int -> IO Int) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Int
iv (Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> (Int -> Int) -> Int -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))

  LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node2 (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
_pid1 <- NodeId -> Closure (Process ()) -> Process ProcessId
spawn NodeId
nid1 ($(mkClosure 'signal) ProcessId
incr)
    TestTransport -> LocalNode -> LocalNode -> Process ()
simulateNetworkFailure TestTransport
testtrans LocalNode
node2 LocalNode
node1
    ProcessId
_pid2 <- NodeId -> Closure (Process ()) -> Process ProcessId
spawn NodeId
nid1 ($(mkClosure 'signal) ProcessId
incr)
    ProcessId
_pid3 <- NodeId -> Closure (Process ()) -> Process ProcessId
spawn NodeId
nid1 ($(mkClosure 'signal) ProcessId
incr)

    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

    Int
count <- IO Int -> Process Int
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> Process Int) -> IO Int -> Process Int
forall a b. (a -> b) -> a -> b
$ MVar Int -> IO Int
forall a. MVar a -> IO a
takeMVar MVar Int
iv
    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
$ Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 Bool -> Bool -> Bool
|| Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 -- It depends on which message we get first in 'spawn'

    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 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
True
      then String -> Process ()
forall a. HasCallStack => String -> a
error String
"Something went horribly wrong"
      else () -> 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

-- | 'spawn' used to ave a race condition which would be triggered if the
-- spawning process terminates immediately after spawning
testSpawnTerminate :: TestTransport -> RemoteTable -> Assertion
testSpawnTerminate :: TestTransport -> RemoteTable -> IO ()
testSpawnTerminate TestTransport{Transport
EndPointAddress -> EndPointAddress -> IO ()
testBreakConnection :: TestTransport -> EndPointAddress -> EndPointAddress -> IO ()
testTransport :: TestTransport -> Transport
testTransport :: Transport
testBreakConnection :: EndPointAddress -> EndPointAddress -> IO ()
..} RemoteTable
rtable = do
  LocalNode
slave  <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
  LocalNode
master <- Transport -> RemoteTable -> IO LocalNode
newLocalNode Transport
testTransport RemoteTable
rtable
  MVar ()
masterDone <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar

  LocalNode -> Process () -> IO ()
runProcess LocalNode
master (Process () -> IO ()) -> Process () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ProcessId
us <- Process ProcessId
getSelfPid
    Int -> Process ProcessId -> Process ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
1000 (Process ProcessId -> Process ())
-> (Closure (Process ()) -> Process ProcessId)
-> Closure (Process ())
-> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> (Closure (Process ()) -> Process ())
-> Closure (Process ())
-> Process ProcessId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Process ProcessId -> Process ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Process ProcessId -> Process ())
-> (Closure (Process ()) -> Process ProcessId)
-> Closure (Process ())
-> Process ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeId -> Closure (Process ()) -> Process ProcessId
spawn (LocalNode -> NodeId
localNodeId LocalNode
slave) (Closure (Process ()) -> Process ())
-> Closure (Process ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ $(mkClosure 'signal) ProcessId
us
    Int -> Process () -> Process ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
1000 (Process () -> Process ()) -> Process () -> Process ()
forall a b. (a -> b) -> a -> b
$ (Process ()
forall a. Serializable a => Process a
expect :: 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 ()
masterDone ()

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

tests :: TestTransport -> IO [Test]
tests :: TestTransport -> IO [Test]
tests TestTransport
testtrans = do
    let rtable :: RemoteTable
rtable = RemoteTable -> RemoteTable
__remoteTable (RemoteTable -> RemoteTable)
-> (RemoteTable -> RemoteTable) -> RemoteTable -> RemoteTable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteTable -> RemoteTable
__remoteTableDecl (RemoteTable -> RemoteTable) -> RemoteTable -> RemoteTable
forall a b. (a -> b) -> a -> b
$ RemoteTable
initRemoteTable
    [Test] -> IO [Test]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ String -> IO () -> Test
testCase String
"Unclosure"       (TestTransport -> RemoteTable -> IO ()
testUnclosure       TestTransport
testtrans RemoteTable
rtable)
        , String -> IO () -> Test
testCase String
"Bind"            (TestTransport -> RemoteTable -> IO ()
testBind            TestTransport
testtrans RemoteTable
rtable)
        , String -> IO () -> Test
testCase String
"SendPureClosure" (TestTransport -> RemoteTable -> IO ()
testSendPureClosure TestTransport
testtrans RemoteTable
rtable)
        , String -> IO () -> Test
testCase String
"SendIOClosure"   (TestTransport -> RemoteTable -> IO ()
testSendIOClosure   TestTransport
testtrans RemoteTable
rtable)
        , String -> IO () -> Test
testCase String
"SendProcClosure" (TestTransport -> RemoteTable -> IO ()
testSendProcClosure TestTransport
testtrans RemoteTable
rtable)
        , String -> IO () -> Test
testCase String
"Spawn"           (TestTransport -> RemoteTable -> IO ()
testSpawn           TestTransport
testtrans RemoteTable
rtable)
        , String -> IO () -> Test
testCase String
"SpawnRace"       (TestTransport -> RemoteTable -> IO ()
testSpawnRace       TestTransport
testtrans RemoteTable
rtable)
        , String -> IO () -> Test
testCase String
"Call"            (TestTransport -> RemoteTable -> IO ()
testCall            TestTransport
testtrans RemoteTable
rtable)
        , String -> IO () -> Test
testCase String
"CallBind"        (TestTransport -> RemoteTable -> IO ()
testCallBind        TestTransport
testtrans RemoteTable
rtable)
        , String -> IO () -> Test
testCase String
"Seq"             (TestTransport -> RemoteTable -> IO ()
testSeq             TestTransport
testtrans RemoteTable
rtable)
        , String -> IO () -> Test
testCase String
"SpawnSupervised" (TestTransport -> RemoteTable -> IO ()
testSpawnSupervised TestTransport
testtrans RemoteTable
rtable)
        , String -> IO () -> Test
testCase String
"SpawnInvalid"    (TestTransport -> RemoteTable -> IO ()
testSpawnInvalid    TestTransport
testtrans RemoteTable
rtable)
        , String -> IO () -> Test
testCase String
"ClosureExpect"   (TestTransport -> RemoteTable -> IO ()
testClosureExpect   TestTransport
testtrans RemoteTable
rtable)
        , String -> IO () -> Test
testCase String
"SpawnChannel"    (TestTransport -> RemoteTable -> IO ()
testSpawnChannel    TestTransport
testtrans RemoteTable
rtable)
        , String -> IO () -> Test
testCase String
"TDict"           (TestTransport -> RemoteTable -> IO ()
testTDict           TestTransport
testtrans RemoteTable
rtable)
        , String -> IO () -> Test
testCase String
"Fib"             (TestTransport -> RemoteTable -> IO ()
testFib             TestTransport
testtrans RemoteTable
rtable)
        , String -> IO () -> Test
testCase String
"SpawnTerminate"  (TestTransport -> RemoteTable -> IO ()
testSpawnTerminate  TestTransport
testtrans RemoteTable
rtable)
        , String -> IO () -> Test
testCase String
"SpawnReconnect"  (TestTransport -> RemoteTable -> IO ()
testSpawnReconnect  TestTransport
testtrans RemoteTable
rtable)
        ]