{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE CPP                #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Distributed.Process.Tests.Internal.Utils
-- Copyright   :  (c) Tim Watson, Jeff Epstein 2013
-- License     :  BSD3 (see the file LICENSE)
--
-- Maintainer  :  Tim Watson
-- Stability   :  experimental
-- Portability :  non-portable (requires concurrency)
--
-- This module provides basic building blocks for testing Cloud Haskell programs.
-----------------------------------------------------------------------------
module Control.Distributed.Process.Tests.Internal.Utils
  ( TestResult
  -- ping !
  , Ping(Ping)
  , ping
  , pause
  , shouldBe
  , shouldMatch
  , shouldContain
  , shouldNotContain
  , expectThat
  , synchronisedAssertion
  -- test process utilities
  , TestProcessControl
  , startTestProcess
  , runTestProcess
  , testProcessGo
  , testProcessStop
  , testProcessReport
  , delayedAssertion
  , assertComplete
  -- logging
  , Logger()
  , newLogger
  , putLogMsg
  , stopLogger
  -- runners
  , 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)

-- | A mutable cell containing a test result.
type TestResult a = MVar a

-- | A simple @Ping@ signal
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

-- | Control signals used to manage /test processes/
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

-- | Does exactly what it says on the tin, doing so in the @Process@ monad.
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

-- | Run the supplied @testProc@ using an @MVar@ to collect and assert
-- against its result. Uses the supplied @note@ if the assertion fails.
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

-- | Takes the value of @mv@ (using @takeMVar@) and asserts that it matches @a@
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)

-- synchronised logging

data Logger = Logger { Logger -> ThreadId
_tid :: ThreadId, Logger -> TQueue String
msgs :: TQueue String }

-- | Create a new Logger.
-- Logger uses a 'TQueue' to receive and process messages on a worker thread.
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

-- | Send a message to the Logger
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

-- | Stop the worker thread for the given Logger
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

-- | Starts a test process on the local node.
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

-- | Runs a /test process/ around the supplied @proc@, which is executed
-- whenever the outer process loop receives a 'Go' signal.
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

-- | Tell a /test process/ to continue executing
testProcessGo :: ProcessId -> Process ()
testProcessGo :: ProcessId -> Process ()
testProcessGo ProcessId
pid = ProcessId -> TestProcessControl -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid TestProcessControl
Go

-- | Tell a /test process/ to stop (i.e., 'terminate')
testProcessStop :: ProcessId -> Process ()
testProcessStop :: ProcessId -> Process ()
testProcessStop ProcessId
pid = ProcessId -> TestProcessControl -> Process ()
forall a. Serializable a => ProcessId -> a -> Process ()
send ProcessId
pid TestProcessControl
Stop

-- | Tell a /test process/ to send a report (message)
-- back to the calling process
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))