{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
module Control.Distributed.Process.Tests.Internal.Utils
( TestResult
, Ping(Ping)
, ping
, pause
, shouldBe
, shouldMatch
, shouldContain
, shouldNotContain
, expectThat
, synchronisedAssertion
, TestProcessControl
, startTestProcess
, runTestProcess
, testProcessGo
, testProcessStop
, testProcessReport
, delayedAssertion
, assertComplete
, Logger()
, newLogger
, putLogMsg
, stopLogger
, tryRunProcess
, tryForkProcess
, noop
, stash
) where
#if ! MIN_VERSION_base(4,6,0)
import Prelude hiding (catch)
#endif
import Control.Concurrent
( ThreadId
, myThreadId
, forkIO
)
import Control.Concurrent.STM
( TQueue
, newTQueueIO
, readTQueue
, writeTQueue
)
import Control.Concurrent.MVar
( MVar
, newEmptyMVar
, takeMVar
)
import Control.Concurrent
( throwTo
)
import Control.Concurrent.MVar
( putMVar
)
import Control.Distributed.Process hiding (finally, catch)
import Control.Distributed.Process.Node
import Control.Distributed.Process.Serializable()
import Control.Exception (AsyncException(ThreadKilled), SomeException)
import Control.Monad (forever, void)
import Control.Monad.Catch (finally, catch)
import Control.Monad.STM (atomically)
import Control.Rematch hiding (match)
import Control.Rematch.Run
import Data.Binary
import Data.Typeable (Typeable)
import Test.HUnit (Assertion, assertFailure)
import Test.HUnit.Base (assertBool)
import GHC.Generics
import System.Timeout (timeout)
type TestResult a = MVar a
data Ping = Ping
deriving (Typeable, (forall x. Ping -> Rep Ping x)
-> (forall x. Rep Ping x -> Ping) -> Generic Ping
forall x. Rep Ping x -> Ping
forall x. Ping -> Rep Ping x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Ping -> Rep Ping x
from :: forall x. Ping -> Rep Ping x
$cto :: forall x. Rep Ping x -> Ping
to :: forall x. Rep Ping x -> Ping
Generic, Ping -> Ping -> Bool
(Ping -> Ping -> Bool) -> (Ping -> Ping -> Bool) -> Eq Ping
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Ping -> Ping -> Bool
== :: Ping -> Ping -> Bool
$c/= :: Ping -> Ping -> Bool
/= :: Ping -> Ping -> Bool
Eq, Int -> Ping -> ShowS
[Ping] -> ShowS
Ping -> String
(Int -> Ping -> ShowS)
-> (Ping -> String) -> ([Ping] -> ShowS) -> Show Ping
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Ping -> ShowS
showsPrec :: Int -> Ping -> ShowS
$cshow :: Ping -> String
show :: Ping -> String
$cshowList :: [Ping] -> ShowS
showList :: [Ping] -> ShowS
Show)
instance Binary Ping where
ping :: ProcessId -> Process ()
ping :: ProcessId -> Process ()
ping ProcessId
pid = ProcessId -> Ping -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid Ping
Ping
data TestProcessControl = Stop | Go | Report ProcessId
deriving (Typeable, (forall x. TestProcessControl -> Rep TestProcessControl x)
-> (forall x. Rep TestProcessControl x -> TestProcessControl)
-> Generic TestProcessControl
forall x. Rep TestProcessControl x -> TestProcessControl
forall x. TestProcessControl -> Rep TestProcessControl x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TestProcessControl -> Rep TestProcessControl x
from :: forall x. TestProcessControl -> Rep TestProcessControl x
$cto :: forall x. Rep TestProcessControl x -> TestProcessControl
to :: forall x. Rep TestProcessControl x -> TestProcessControl
Generic)
instance Binary TestProcessControl where
data Private = Private
deriving (Typeable, (forall x. Private -> Rep Private x)
-> (forall x. Rep Private x -> Private) -> Generic Private
forall x. Rep Private x -> Private
forall x. Private -> Rep Private x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Private -> Rep Private x
from :: forall x. Private -> Rep Private x
$cto :: forall x. Rep Private x -> Private
to :: forall x. Rep Private x -> Private
Generic)
instance Binary Private where
noop :: Process ()
noop :: Process ()
noop = () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
pause :: Int -> Process ()
pause :: Int -> Process ()
pause Int
delay =
Process (Maybe ()) -> Process ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Process (Maybe ()) -> Process ())
-> Process (Maybe ()) -> Process ()
forall a b. (a -> b) -> a -> b
$ Int -> [Match ()] -> Process (Maybe ())
forall b. Int -> [Match b] -> Process (Maybe b)
receiveTimeout Int
delay [ (Private -> Process ()) -> Match ()
forall a b. Serializable a => (a -> Process b) -> Match b
match (\Private
Private -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ]
synchronisedAssertion :: Eq a
=> String
-> LocalNode
-> a
-> (TestResult a -> Process ())
-> MVar ()
-> Assertion
synchronisedAssertion :: forall a.
Eq a =>
String
-> LocalNode
-> a
-> (TestResult a -> Process ())
-> MVar ()
-> Assertion
synchronisedAssertion String
note LocalNode
localNode a
expected TestResult a -> Process ()
testProc MVar ()
lock = do
TestResult a
result <- IO (TestResult a)
forall a. IO (MVar a)
newEmptyMVar
ProcessId
_ <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ do
MVar () -> Process ()
forall {m :: * -> *} {a}. MonadIO m => MVar a -> m a
acquire MVar ()
lock
Process () -> Process () -> Process ()
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
finally (TestResult a -> Process ()
testProc TestResult a
result)
(MVar () -> Process ()
forall {m :: * -> *}. MonadIO m => MVar () -> m ()
release MVar ()
lock)
String -> TestResult a -> a -> Assertion
forall a. Eq a => String -> MVar a -> a -> Assertion
assertComplete String
note TestResult a
result a
expected
where acquire :: MVar a -> m a
acquire MVar a
lock' = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
lock'
release :: MVar () -> m ()
release MVar ()
lock' = Assertion -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Assertion -> m ()) -> Assertion -> m ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> Assertion
forall a. MVar a -> a -> Assertion
putMVar MVar ()
lock' ()
stash :: TestResult a -> a -> Process ()
stash :: forall a. TestResult a -> a -> Process ()
stash TestResult a
mvar a
x = Assertion -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Assertion -> Process ()) -> Assertion -> Process ()
forall a b. (a -> b) -> a -> b
$ TestResult a -> a -> Assertion
forall a. MVar a -> a -> Assertion
putMVar TestResult a
mvar a
x
expectThat :: a -> Matcher a -> Process ()
expectThat :: forall a. a -> Matcher a -> Process ()
expectThat a
a Matcher a
matcher = case Match
res of
Match
MatchSuccess -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(MatchFailure String
msg) -> Assertion -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Assertion -> Process ()) -> Assertion -> Process ()
forall a b. (a -> b) -> a -> b
$ String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure String
msg
where res :: Match
res = Matcher a -> a -> Match
forall a. Matcher a -> a -> Match
runMatch Matcher a
matcher a
a
shouldBe :: a -> Matcher a -> Process ()
shouldBe :: forall a. a -> Matcher a -> Process ()
shouldBe = a -> Matcher a -> Process ()
forall a. a -> Matcher a -> Process ()
expectThat
shouldContain :: (Show a, Eq a) => [a] -> a -> Process ()
shouldContain :: forall a. (Show a, Eq a) => [a] -> a -> Process ()
shouldContain [a]
xs a
x = [a] -> Matcher [a] -> Process ()
forall a. a -> Matcher a -> Process ()
expectThat [a]
xs (Matcher [a] -> Process ()) -> Matcher [a] -> Process ()
forall a b. (a -> b) -> a -> b
$ Matcher a -> Matcher [a]
forall a. Matcher a -> Matcher [a]
hasItem (a -> Matcher a
forall a. (Show a, Eq a) => a -> Matcher a
equalTo a
x)
shouldNotContain :: (Show a, Eq a) => [a] -> a -> Process ()
shouldNotContain :: forall a. (Show a, Eq a) => [a] -> a -> Process ()
shouldNotContain [a]
xs a
x = [a] -> Matcher [a] -> Process ()
forall a. a -> Matcher a -> Process ()
expectThat [a]
xs (Matcher [a] -> Process ()) -> Matcher [a] -> Process ()
forall a b. (a -> b) -> a -> b
$ Matcher [a] -> Matcher [a]
forall a. Matcher a -> Matcher a
isNot (Matcher a -> Matcher [a]
forall a. Matcher a -> Matcher [a]
hasItem (a -> Matcher a
forall a. (Show a, Eq a) => a -> Matcher a
equalTo a
x))
shouldMatch :: a -> Matcher a -> Process ()
shouldMatch :: forall a. a -> Matcher a -> Process ()
shouldMatch = a -> Matcher a -> Process ()
forall a. a -> Matcher a -> Process ()
expectThat
delayedAssertion :: (Eq a) => String -> LocalNode -> a ->
(TestResult a -> Process ()) -> Assertion
delayedAssertion :: forall a.
Eq a =>
String
-> LocalNode -> a -> (TestResult a -> Process ()) -> Assertion
delayedAssertion String
note LocalNode
localNode a
expected TestResult a -> Process ()
testProc = do
TestResult a
result <- IO (TestResult a)
forall a. IO (MVar a)
newEmptyMVar
ProcessId
_ <- LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
localNode (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ TestResult a -> Process ()
testProc TestResult a
result
String -> TestResult a -> a -> Assertion
forall a. Eq a => String -> MVar a -> a -> Assertion
assertComplete String
note TestResult a
result a
expected
assertComplete :: (Eq a) => String -> MVar a -> a -> IO ()
assertComplete :: forall a. Eq a => String -> MVar a -> a -> Assertion
assertComplete String
msg MVar a
mv a
a = do
a
b <- MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
mv
HasCallStack => String -> Bool -> Assertion
String -> Bool -> Assertion
assertBool String
msg (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b)
data Logger = Logger { Logger -> ThreadId
_tid :: ThreadId, Logger -> TQueue String
msgs :: TQueue String }
newLogger :: IO Logger
newLogger :: IO Logger
newLogger = do
ThreadId
tid <- IO ThreadId -> IO ThreadId
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> IO ThreadId) -> IO ThreadId -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO ThreadId
myThreadId
TQueue String
q <- IO (TQueue String) -> IO (TQueue String)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TQueue String) -> IO (TQueue String))
-> IO (TQueue String) -> IO (TQueue String)
forall a b. (a -> b) -> a -> b
$ IO (TQueue String)
forall a. IO (TQueue a)
newTQueueIO
ThreadId
_ <- Assertion -> IO ThreadId
forkIO (Assertion -> IO ThreadId) -> Assertion -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ TQueue String -> Assertion
forall {b}. TQueue String -> IO b
logger TQueue String
q
Logger -> IO Logger
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Logger -> IO Logger) -> Logger -> IO Logger
forall a b. (a -> b) -> a -> b
$ ThreadId -> TQueue String -> Logger
Logger ThreadId
tid TQueue String
q
where logger :: TQueue String -> IO b
logger TQueue String
q' = Assertion -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Assertion -> IO b) -> Assertion -> IO b
forall a b. (a -> b) -> a -> b
$ do
String
msg <- STM String -> IO String
forall a. STM a -> IO a
atomically (STM String -> IO String) -> STM String -> IO String
forall a b. (a -> b) -> a -> b
$ TQueue String -> STM String
forall a. TQueue a -> STM a
readTQueue TQueue String
q'
String -> Assertion
putStrLn String
msg
putLogMsg :: Logger -> String -> Process ()
putLogMsg :: Logger -> String -> Process ()
putLogMsg Logger
logger String
msg = Assertion -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Assertion -> Process ()) -> Assertion -> Process ()
forall a b. (a -> b) -> a -> b
$ STM () -> Assertion
forall a. STM a -> IO a
atomically (STM () -> Assertion) -> STM () -> Assertion
forall a b. (a -> b) -> a -> b
$ TQueue String -> String -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue (Logger -> TQueue String
msgs Logger
logger) String
msg
stopLogger :: Logger -> IO ()
stopLogger :: Logger -> Assertion
stopLogger = ((ThreadId -> AsyncException -> Assertion)
-> AsyncException -> ThreadId -> Assertion
forall a b c. (a -> b -> c) -> b -> a -> c
flip ThreadId -> AsyncException -> Assertion
forall e. Exception e => ThreadId -> e -> Assertion
throwTo) AsyncException
ThreadKilled (ThreadId -> Assertion)
-> (Logger -> ThreadId) -> Logger -> Assertion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger -> ThreadId
_tid
startTestProcess :: Process () -> Process ProcessId
startTestProcess :: Process () -> Process ProcessId
startTestProcess Process ()
proc =
Process () -> Process ProcessId
spawnLocal (Process () -> Process ProcessId)
-> Process () -> Process ProcessId
forall a b. (a -> b) -> a -> b
$ do
Process ProcessId
getSelfPid Process ProcessId -> (ProcessId -> Process ()) -> Process ()
forall a b. Process a -> (a -> Process b) -> Process b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ProcessId -> Process ()
register String
"test-process"
Process () -> Process ()
runTestProcess Process ()
proc
runTestProcess :: Process () -> Process ()
runTestProcess :: Process () -> Process ()
runTestProcess Process ()
proc = do
TestProcessControl
ctl <- Process TestProcessControl
forall a. Serializable a => Process a
expect
case TestProcessControl
ctl of
TestProcessControl
Stop -> () -> Process ()
forall a. a -> Process a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
TestProcessControl
Go -> Process ()
proc Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Process () -> Process ()
runTestProcess Process ()
proc
Report ProcessId
p -> [Match ()] -> Process ()
forall b. [Match b] -> Process b
receiveWait [(Message -> Process ()) -> Match ()
forall b. (Message -> Process b) -> Match b
matchAny (\Message
m -> Message -> ProcessId -> Process ()
forward Message
m ProcessId
p)] Process () -> Process () -> Process ()
forall a b. Process a -> Process b -> Process b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Process () -> Process ()
runTestProcess Process ()
proc
testProcessGo :: ProcessId -> Process ()
testProcessGo :: ProcessId -> Process ()
testProcessGo ProcessId
pid = ProcessId -> TestProcessControl -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid TestProcessControl
Go
testProcessStop :: ProcessId -> Process ()
testProcessStop :: ProcessId -> Process ()
testProcessStop ProcessId
pid = ProcessId -> TestProcessControl -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid TestProcessControl
Stop
testProcessReport :: ProcessId -> Process ()
testProcessReport :: ProcessId -> Process ()
testProcessReport ProcessId
pid = do
ProcessId
self <- Process ProcessId
getSelfPid
ProcessId -> TestProcessControl -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid (TestProcessControl -> Process ())
-> TestProcessControl -> Process ()
forall a b. (a -> b) -> a -> b
$ ProcessId -> TestProcessControl
Report ProcessId
self
tryRunProcess :: LocalNode -> Process () -> IO ()
tryRunProcess :: LocalNode -> Process () -> Assertion
tryRunProcess LocalNode
node Process ()
p = do
ThreadId
tid <- IO ThreadId -> IO ThreadId
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ThreadId
myThreadId
IO (Maybe ()) -> Assertion
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> Assertion) -> IO (Maybe ()) -> Assertion
forall a b. (a -> b) -> a -> b
$ Int -> Assertion -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
timeout (Int
1000000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
60 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
5 :: Int) (Assertion -> IO (Maybe ())) -> Assertion -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$
LocalNode -> Process () -> Assertion
runProcess LocalNode
node (Process () -> Assertion) -> Process () -> Assertion
forall a b. (a -> b) -> a -> b
$ Process () -> (SomeException -> Process ()) -> Process ()
forall e a.
(HasCallStack, Exception e) =>
Process a -> (e -> Process a) -> Process a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch Process ()
p (\SomeException
e -> Assertion -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Assertion -> Process ()) -> Assertion -> Process ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> SomeException -> Assertion
forall e. Exception e => ThreadId -> e -> Assertion
throwTo ThreadId
tid (SomeException
e::SomeException))
tryForkProcess :: LocalNode -> Process () -> IO ProcessId
tryForkProcess :: LocalNode -> Process () -> IO ProcessId
tryForkProcess LocalNode
node Process ()
p = do
ThreadId
tid <- IO ThreadId -> IO ThreadId
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ThreadId
myThreadId
LocalNode -> Process () -> IO ProcessId
forkProcess LocalNode
node (Process () -> IO ProcessId) -> Process () -> IO ProcessId
forall a b. (a -> b) -> a -> b
$ Process () -> (SomeException -> Process ()) -> Process ()
forall e a.
(HasCallStack, Exception e) =>
Process a -> (e -> Process a) -> Process a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch Process ()
p (\SomeException
e -> Assertion -> Process ()
forall a. IO a -> Process a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Assertion -> Process ()) -> Assertion -> Process ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> SomeException -> Assertion
forall e. Exception e => ThreadId -> e -> Assertion
throwTo ThreadId
tid (SomeException
e::SomeException))