git.iko.soy/distributed-process
on 7930062 help sign in
distributed-process/distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs
240 lines 6.9 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
78import Control.Distributed.Process.Node
79import Control.Distributed.Process.Serializable()
81import Control.Exception (AsyncException(ThreadKilled), SomeException)
82import Control.Monad (forever, void)
83import Control.Monad.STM (atomically)
84import Control.Rematch hiding (match)
85import Control.Rematch.Run
86import Data.Binary
87import Data.Typeable (Typeable)
89import Test.HUnit (Assertion, assertFailure)
90import Test.HUnit.Base (assertBool)
92import GHC.Generics
94-- | A mutable cell containing a test result.
95type TestResult a = MVar a
97-- | A simple @Ping@ signal
98data Ping = Ping
99 deriving (Typeable, Generic, Eq, Show)
100instance Binary Ping where
102ping :: ProcessId -> Process ()
103ping pid = send pid Ping
105-- | Control signals used to manage /test processes/
106data TestProcessControl = Stop | Go | Report ProcessId
107 deriving (Typeable, Generic)
109instance Binary TestProcessControl where
111data Private = Private
112 deriving (Typeable, Generic)
113instance Binary Private where
115-- | Does exactly what it says on the tin, doing so in the @Process@ monad.
116noop :: Process ()
117noop = return ()
119pause :: Int -> Process ()
120pause delay =
121 void $ receiveTimeout delay [ match (\Private -> return ()) ]
123synchronisedAssertion :: Eq a
124 => String
125 -> LocalNode
126 -> a
127 -> (TestResult a -> Process ())
128 -> MVar ()
129 -> Assertion
130synchronisedAssertion note localNode expected testProc lock = do
131 result <- newEmptyMVar
132 _ <- forkProcess localNode $ do
133 acquire lock
134 finally (testProc result)
135 (release lock)
136 assertComplete note result expected
137 where acquire lock' = liftIO $ takeMVar lock'
138 release lock' = liftIO $ putMVar lock' ()
140stash :: TestResult a -> a -> Process ()
141stash mvar x = liftIO $ putMVar mvar x
143expectThat :: a -> Matcher a -> Process ()
144expectThat a matcher = case res of
145 MatchSuccess -> return ()
146 (MatchFailure msg) -> liftIO $ assertFailure msg
147 where res = runMatch matcher a
149shouldBe :: a -> Matcher a -> Process ()
150shouldBe = expectThat
152shouldContain :: (Show a, Eq a) => [a] -> a -> Process ()
153shouldContain xs x = expectThat xs $ hasItem (equalTo x)
155shouldNotContain :: (Show a, Eq a) => [a] -> a -> Process ()
156shouldNotContain xs x = expectThat xs $ isNot (hasItem (equalTo x))
158shouldMatch :: a -> Matcher a -> Process ()
159shouldMatch = expectThat
161-- | Run the supplied @testProc@ using an @MVar@ to collect and assert
162-- against its result. Uses the supplied @note@ if the assertion fails.
163delayedAssertion :: (Eq a) => String -> LocalNode -> a ->
164 (TestResult a -> Process ()) -> Assertion
165delayedAssertion note localNode expected testProc = do
166 result <- newEmptyMVar
167 _ <- forkProcess localNode $ testProc result
168 assertComplete note result expected
170-- | Takes the value of @mv@ (using @takeMVar@) and asserts that it matches @a@
171assertComplete :: (Eq a) => String -> MVar a -> a -> IO ()
172assertComplete msg mv a = do
173 b <- takeMVar mv
174 assertBool msg (a == b)
176-- synchronised logging
178data Logger = Logger { _tid :: ThreadId, msgs :: TQueue String }
180-- | Create a new Logger.
181-- Logger uses a 'TQueue' to receive and process messages on a worker thread.
182newLogger :: IO Logger
183newLogger = do
184 tid <- liftIO $ myThreadId
185 q <- liftIO $ newTQueueIO
186 _ <- forkIO $ logger q
187 return $ Logger tid q
188 where logger q' = forever $ do
189 msg <- atomically $ readTQueue q'
190 putStrLn msg
192-- | Send a message to the Logger
193putLogMsg :: Logger -> String -> Process ()
194putLogMsg logger msg = liftIO $ atomically $ writeTQueue (msgs logger) msg
196-- | Stop the worker thread for the given Logger
197stopLogger :: Logger -> IO ()
198stopLogger = (flip throwTo) ThreadKilled . _tid
200-- | Starts a test process on the local node.
201startTestProcess :: Process () -> Process ProcessId
202startTestProcess proc =
203 spawnLocal $ do
204 getSelfPid >>= register "test-process"
205 runTestProcess proc
207-- | Runs a /test process/ around the supplied @proc@, which is executed
208-- whenever the outer process loop receives a 'Go' signal.
209runTestProcess :: Process () -> Process ()
210runTestProcess proc = do
211 ctl <- expect
212 case ctl of
213 Stop -> return ()
214 Go -> proc >> runTestProcess proc
215 Report p -> receiveWait [matchAny (\m -> forward m p)] >> runTestProcess proc
217-- | Tell a /test process/ to continue executing
218testProcessGo :: ProcessId -> Process ()
219testProcessGo pid = send pid Go
221-- | Tell a /test process/ to stop (i.e., 'terminate')
222testProcessStop :: ProcessId -> Process ()
223testProcessStop pid = send pid Stop
225-- | Tell a /test process/ to send a report (message)
226-- back to the calling process
227testProcessReport :: ProcessId -> Process ()
228testProcessReport pid = do
229 self <- getSelfPid
230 send pid $ Report self
232tryRunProcess :: LocalNode -> Process () -> IO ()
233tryRunProcess node p = do
234 tid <- liftIO myThreadId
235 runProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))
237tryForkProcess :: LocalNode -> Process () -> IO ProcessId
238tryForkProcess node p = do
239 tid <- liftIO myThreadId
240 forkProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))