git.iko.soy/distributed-process
on mx-fix2 help sign in
distributed-process/distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs
243 lines 7.0 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE TemplateHaskell #-}
4{-# LANGUAGE CPP #-}
6-----------------------------------------------------------------------------
7-- |
8-- Module : Control.Distributed.Process.Tests.Internal.Utils
9-- Copyright : (c) Tim Watson, Jeff Epstein 2013
10-- License : BSD3 (see the file LICENSE)
11--
12-- Maintainer : Tim Watson
13-- Stability : experimental
14-- Portability : non-portable (requires concurrency)
15--
16-- This module provides basic building blocks for testing Cloud Haskell programs.
17-----------------------------------------------------------------------------
18module Control.Distributed.Process.Tests.Internal.Utils
19 ( TestResult
20 -- ping !
21 , Ping(Ping)
22 , ping
23 , pause
24 , shouldBe
25 , shouldMatch
26 , shouldContain
27 , shouldNotContain
28 , expectThat
29 , synchronisedAssertion
30 -- test process utilities
31 , TestProcessControl
32 , startTestProcess
33 , runTestProcess
34 , testProcessGo
35 , testProcessStop
36 , testProcessReport
37 , delayedAssertion
38 , assertComplete
39 -- logging
40 , Logger()
41 , newLogger
42 , putLogMsg
43 , stopLogger
44 -- runners
45 , tryRunProcess
46 , tryForkProcess
47 , noop
48 , stash
49 ) where
51#if ! MIN_VERSION_base(4,6,0)
52import Prelude hiding (catch)
53#endif
54import Control.Concurrent
55 ( ThreadId
56 , myThreadId
57 , forkIO
58 )
59import Control.Concurrent.STM
60 ( TQueue
61 , newTQueueIO
62 , readTQueue
63 , writeTQueue
64 )
65import Control.Concurrent.MVar
66 ( MVar
67 , newEmptyMVar
68 , takeMVar
69 )
71import Control.Concurrent
72 ( throwTo
73 )
74import Control.Concurrent.MVar
75 ( putMVar
76 )
77import Control.Distributed.Process hiding (finally, catch)
78import Control.Distributed.Process.Node
79import Control.Distributed.Process.Serializable()
81import Control.Exception (AsyncException(ThreadKilled), SomeException)
82import Control.Monad (forever, void)
83import Control.Monad.Catch (finally, catch)
84import Control.Monad.STM (atomically)
85import Control.Rematch hiding (match)
86import Control.Rematch.Run
87import Data.Binary
88import Data.Typeable (Typeable)
90import Test.HUnit (Assertion, assertFailure)
91import Test.HUnit.Base (assertBool)
93import GHC.Generics
94import System.Timeout (timeout)
96-- | A mutable cell containing a test result.
97type TestResult a = MVar a
99-- | A simple @Ping@ signal
100data Ping = Ping
101 deriving (Typeable, Generic, Eq, Show)
102instance Binary Ping where
104ping :: ProcessId -> Process ()
105ping pid = send pid Ping
107-- | Control signals used to manage /test processes/
108data TestProcessControl = Stop | Go | Report ProcessId
109 deriving (Typeable, Generic)
111instance Binary TestProcessControl where
113data Private = Private
114 deriving (Typeable, Generic)
115instance Binary Private where
117-- | Does exactly what it says on the tin, doing so in the @Process@ monad.
118noop :: Process ()
119noop = return ()
121pause :: Int -> Process ()
122pause delay =
123 void $ receiveTimeout delay [ match (\Private -> return ()) ]
125synchronisedAssertion :: Eq a
126 => String
127 -> LocalNode
128 -> a
129 -> (TestResult a -> Process ())
130 -> MVar ()
131 -> Assertion
132synchronisedAssertion note localNode expected testProc lock = do
133 result <- newEmptyMVar
134 _ <- forkProcess localNode $ do
135 acquire lock
136 finally (testProc result)
137 (release lock)
138 assertComplete note result expected
139 where acquire lock' = liftIO $ takeMVar lock'
140 release lock' = liftIO $ putMVar lock' ()
142stash :: TestResult a -> a -> Process ()
143stash mvar x = liftIO $ putMVar mvar x
145expectThat :: a -> Matcher a -> Process ()
146expectThat a matcher = case res of
147 MatchSuccess -> return ()
148 (MatchFailure msg) -> liftIO $ assertFailure msg
149 where res = runMatch matcher a
151shouldBe :: a -> Matcher a -> Process ()
152shouldBe = expectThat
154shouldContain :: (Show a, Eq a) => [a] -> a -> Process ()
155shouldContain xs x = expectThat xs $ hasItem (equalTo x)
157shouldNotContain :: (Show a, Eq a) => [a] -> a -> Process ()
158shouldNotContain xs x = expectThat xs $ isNot (hasItem (equalTo x))
160shouldMatch :: a -> Matcher a -> Process ()
161shouldMatch = expectThat
163-- | Run the supplied @testProc@ using an @MVar@ to collect and assert
164-- against its result. Uses the supplied @note@ if the assertion fails.
165delayedAssertion :: (Eq a) => String -> LocalNode -> a ->
166 (TestResult a -> Process ()) -> Assertion
167delayedAssertion note localNode expected testProc = do
168 result <- newEmptyMVar
169 _ <- forkProcess localNode $ testProc result
170 assertComplete note result expected
172-- | Takes the value of @mv@ (using @takeMVar@) and asserts that it matches @a@
173assertComplete :: (Eq a) => String -> MVar a -> a -> IO ()
174assertComplete msg mv a = do
175 b <- takeMVar mv
176 assertBool msg (a == b)
178-- synchronised logging
180data Logger = Logger { _tid :: ThreadId, msgs :: TQueue String }
182-- | Create a new Logger.
183-- Logger uses a 'TQueue' to receive and process messages on a worker thread.
184newLogger :: IO Logger
185newLogger = do
186 tid <- liftIO $ myThreadId
187 q <- liftIO $ newTQueueIO
188 _ <- forkIO $ logger q
189 return $ Logger tid q
190 where logger q' = forever $ do
191 msg <- atomically $ readTQueue q'
192 putStrLn msg
194-- | Send a message to the Logger
195putLogMsg :: Logger -> String -> Process ()
196putLogMsg logger msg = liftIO $ atomically $ writeTQueue (msgs logger) msg
198-- | Stop the worker thread for the given Logger
199stopLogger :: Logger -> IO ()
200stopLogger = (flip throwTo) ThreadKilled . _tid
202-- | Starts a test process on the local node.
203startTestProcess :: Process () -> Process ProcessId
204startTestProcess proc =
205 spawnLocal $ do
206 getSelfPid >>= register "test-process"
207 runTestProcess proc
209-- | Runs a /test process/ around the supplied @proc@, which is executed
210-- whenever the outer process loop receives a 'Go' signal.
211runTestProcess :: Process () -> Process ()
212runTestProcess proc = do
213 ctl <- expect
214 case ctl of
215 Stop -> return ()
216 Go -> proc >> runTestProcess proc
217 Report p -> receiveWait [matchAny (\m -> forward m p)] >> runTestProcess proc
219-- | Tell a /test process/ to continue executing
220testProcessGo :: ProcessId -> Process ()
221testProcessGo pid = send pid Go
223-- | Tell a /test process/ to stop (i.e., 'terminate')
224testProcessStop :: ProcessId -> Process ()
225testProcessStop pid = send pid Stop
227-- | Tell a /test process/ to send a report (message)
228-- back to the calling process
229testProcessReport :: ProcessId -> Process ()
230testProcessReport pid = do
231 self <- getSelfPid
232 send pid $ Report self
234tryRunProcess :: LocalNode -> Process () -> IO ()
235tryRunProcess node p = do
236 tid <- liftIO myThreadId
237 void $ timeout (1000000 * 60 * 5 :: Int) $
238 runProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))
240tryForkProcess :: LocalNode -> Process () -> IO ProcessId
241tryForkProcess node p = do
242 tid <- liftIO myThreadId
243 forkProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))