git.iko.soy/distributed-process
on 6dfd5b1 help sign in
distributed-process/distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs
232 lines 6.7 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 , shouldBe
24 , shouldMatch
25 , shouldContain
26 , shouldNotContain
27 , expectThat
28 , synchronisedAssertion
29 -- test process utilities
30 , TestProcessControl
31 , startTestProcess
32 , runTestProcess
33 , testProcessGo
34 , testProcessStop
35 , testProcessReport
36 , delayedAssertion
37 , assertComplete
38 -- logging
39 , Logger()
40 , newLogger
41 , putLogMsg
42 , stopLogger
43 -- runners
44 , tryRunProcess
45 , tryForkProcess
46 , noop
47 , stash
48 ) where
50#if ! MIN_VERSION_base(4,6,0)
51import Prelude hiding (catch)
52#endif
53import Control.Concurrent
54 ( ThreadId
55 , myThreadId
56 , forkIO
57 )
58import Control.Concurrent.STM
59 ( TQueue
60 , newTQueueIO
61 , readTQueue
62 , writeTQueue
63 )
64import Control.Concurrent.MVar
65 ( MVar
66 , newEmptyMVar
67 , takeMVar
68 )
70import Control.Concurrent
71 ( throwTo
72 )
73import Control.Concurrent.MVar
74 ( putMVar
75 )
76import Control.Distributed.Process
77import Control.Distributed.Process.Node
78import Control.Distributed.Process.Serializable()
80import Control.Exception (AsyncException(ThreadKilled), SomeException)
81import Control.Monad (forever)
82import Control.Monad.STM (atomically)
83import Control.Rematch hiding (match)
84import Control.Rematch.Run
85import Data.Binary
86import Data.Typeable (Typeable)
88import Test.HUnit (Assertion, assertFailure)
89import Test.HUnit.Base (assertBool)
91import GHC.Generics
93-- | A mutable cell containing a test result.
94type TestResult a = MVar a
96-- | A simple @Ping@ signal
97data Ping = Ping
98 deriving (Typeable, Generic, Eq, Show)
99instance Binary Ping where
101ping :: ProcessId -> Process ()
102ping pid = send pid Ping
104-- | Control signals used to manage /test processes/
105data TestProcessControl = Stop | Go | Report ProcessId
106 deriving (Typeable, Generic)
108instance Binary TestProcessControl where
110-- | Does exactly what it says on the tin, doing so in the @Process@ monad.
111noop :: Process ()
112noop = return ()
114synchronisedAssertion :: Eq a
115 => String
116 -> LocalNode
117 -> a
118 -> (TestResult a -> Process ())
119 -> MVar ()
120 -> Assertion
121synchronisedAssertion note localNode expected testProc lock = do
122 result <- newEmptyMVar
123 _ <- forkProcess localNode $ do
124 acquire lock
125 finally (testProc result)
126 (release lock)
127 assertComplete note result expected
128 where acquire lock' = liftIO $ takeMVar lock'
129 release lock' = liftIO $ putMVar lock' ()
131stash :: TestResult a -> a -> Process ()
132stash mvar x = liftIO $ putMVar mvar x
134expectThat :: a -> Matcher a -> Process ()
135expectThat a matcher = case res of
136 MatchSuccess -> return ()
137 (MatchFailure msg) -> liftIO $ assertFailure msg
138 where res = runMatch matcher a
140shouldBe :: a -> Matcher a -> Process ()
141shouldBe = expectThat
143shouldContain :: (Show a, Eq a) => [a] -> a -> Process ()
144shouldContain xs x = expectThat xs $ hasItem (equalTo x)
146shouldNotContain :: (Show a, Eq a) => [a] -> a -> Process ()
147shouldNotContain xs x = expectThat xs $ isNot (hasItem (equalTo x))
149shouldMatch :: a -> Matcher a -> Process ()
150shouldMatch = expectThat
152-- | Run the supplied @testProc@ using an @MVar@ to collect and assert
153-- against its result. Uses the supplied @note@ if the assertion fails.
154delayedAssertion :: (Eq a) => String -> LocalNode -> a ->
155 (TestResult a -> Process ()) -> Assertion
156delayedAssertion note localNode expected testProc = do
157 result <- newEmptyMVar
158 _ <- forkProcess localNode $ testProc result
159 assertComplete note result expected
161-- | Takes the value of @mv@ (using @takeMVar@) and asserts that it matches @a@
162assertComplete :: (Eq a) => String -> MVar a -> a -> IO ()
163assertComplete msg mv a = do
164 b <- takeMVar mv
165 assertBool msg (a == b)
167-- synchronised logging
169data Logger = Logger { _tid :: ThreadId, msgs :: TQueue String }
171-- | Create a new Logger.
172-- Logger uses a 'TQueue' to receive and process messages on a worker thread.
173newLogger :: IO Logger
174newLogger = do
175 tid <- liftIO $ myThreadId
176 q <- liftIO $ newTQueueIO
177 _ <- forkIO $ logger q
178 return $ Logger tid q
179 where logger q' = forever $ do
180 msg <- atomically $ readTQueue q'
181 putStrLn msg
183-- | Send a message to the Logger
184putLogMsg :: Logger -> String -> Process ()
185putLogMsg logger msg = liftIO $ atomically $ writeTQueue (msgs logger) msg
187-- | Stop the worker thread for the given Logger
188stopLogger :: Logger -> IO ()
189stopLogger = (flip throwTo) ThreadKilled . _tid
191-- | Starts a test process on the local node.
192startTestProcess :: Process () -> Process ProcessId
193startTestProcess proc =
194 spawnLocal $ do
195 getSelfPid >>= register "test-process"
196 runTestProcess proc
198-- | Runs a /test process/ around the supplied @proc@, which is executed
199-- whenever the outer process loop receives a 'Go' signal.
200runTestProcess :: Process () -> Process ()
201runTestProcess proc = do
202 ctl <- expect
203 case ctl of
204 Stop -> return ()
205 Go -> proc >> runTestProcess proc
206 Report p -> receiveWait [matchAny (\m -> forward m p)] >> runTestProcess proc
208-- | Tell a /test process/ to continue executing
209testProcessGo :: ProcessId -> Process ()
210testProcessGo pid = send pid Go
212-- | Tell a /test process/ to stop (i.e., 'terminate')
213testProcessStop :: ProcessId -> Process ()
214testProcessStop pid = send pid Stop
216-- | Tell a /test process/ to send a report (message)
217-- back to the calling process
218testProcessReport :: ProcessId -> Process ()
219testProcessReport pid = do
220 self <- getSelfPid
221 send pid $ Report self
223tryRunProcess :: LocalNode -> Process () -> IO ()
224tryRunProcess node p = do
225 tid <- liftIO myThreadId
226 runProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))
228tryForkProcess :: LocalNode -> Process () -> IO ProcessId
229tryForkProcess node p = do
230 tid <- liftIO myThreadId
231 forkProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))