{-# 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)
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"
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
|]
]
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 ()
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
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
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
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 ()
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
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
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
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
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)
]