From 45569669750cac5fd34b1d9acf49887f00a0bdd1 Mon Sep 17 00:00:00 2001 From: Alexander Vershilov Date: Tue, 30 Dec 2014 13:00:12 +0300 Subject: [PATCH 1/2] Reuse test modules from distributed-proces-tests. --- distributed-process-execution.cabal | 4 +- tests/TestExchange.hs | 12 +- tests/TestMailbox.hs | 15 +- tests/TestUtils.hs | 234 ---------------------------- 4 files changed, 24 insertions(+), 241 deletions(-) delete mode 100644 tests/TestUtils.hs diff --git a/distributed-process-execution.cabal b/distributed-process-execution.cabal index 00c5260..e1c401a 100644 --- a/distributed-process-execution.cabal +++ b/distributed-process-execution.cabal @@ -77,6 +77,7 @@ test-suite ExchangeTests distributed-process >= 0.5.3 && < 0.6, distributed-process-execution, distributed-process-extras >= 0.2.0 && < 0.3, + distributed-process-tests >= 0.4.1 && < 0.5, distributed-static, bytestring, data-accessor, @@ -102,7 +103,6 @@ test-suite ExchangeTests ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind -eventlog extensions: CPP main-is: TestExchange.hs - other-modules: TestUtils test-suite MailboxTests @@ -117,6 +117,7 @@ test-suite MailboxTests distributed-process >= 0.5.3 && < 0.6, distributed-process-execution, distributed-process-extras >= 0.2.0 && < 0.3, + distributed-process-tests >= 0.4.1 && < 0.5, distributed-static, bytestring, data-accessor, @@ -143,4 +144,3 @@ test-suite MailboxTests extensions: CPP main-is: TestMailbox.hs other-modules: MailboxTestFilters - TestUtils diff --git a/tests/TestExchange.hs b/tests/TestExchange.hs index deb4550..7418c6c 100644 --- a/tests/TestExchange.hs +++ b/tests/TestExchange.hs @@ -15,6 +15,7 @@ import Control.Distributed.Process.Extras.Internal.Primitives import qualified Control.Distributed.Process.Execution.EventManager as EventManager ( start ) +import Control.Distributed.Process.Tests.Internal.Utils import Control.Monad (void, forM, forever) import Control.Rematch (equalTo) @@ -23,10 +24,10 @@ import Prelude hiding (catch, drop) #else import Prelude hiding (drop) #endif +import Network.Transport.TCP import qualified Network.Transport as NT -import Test.Framework as TF (testGroup, Test) +import Test.Framework as TF (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit -import TestUtils testKeyBasedRouting :: TestResult Bool -> Process () testKeyBasedRouting result = do @@ -184,3 +185,10 @@ tests transport = do main :: IO () main = testMain $ tests +-- | Given a @builder@ function, make and run a test suite on a single transport +testMain :: (NT.Transport -> IO [Test]) -> IO () +testMain builder = do + Right (transport, _) <- createTransportExposeInternals + "127.0.0.1" "10501" defaultTCPParameters + testData <- builder transport + defaultMain testData diff --git a/tests/TestMailbox.hs b/tests/TestMailbox.hs index f09e69a..94d2a78 100644 --- a/tests/TestMailbox.hs +++ b/tests/TestMailbox.hs @@ -7,10 +7,11 @@ module Main where import Control.Distributed.Process import Control.Distributed.Process.Node import qualified Control.Distributed.Process.Extras (__remoteTable) -import qualified Control.Distributed.Process.Execution.Mailbox (__remoteTable) import Control.Distributed.Process.Execution.Mailbox import Control.Distributed.Process.Extras.Time import Control.Distributed.Process.Extras.Timer +import Control.Distributed.Process.Tests.Internal.Utils + import Control.Rematch (equalTo) @@ -22,12 +23,13 @@ import Prelude hiding (drop) import Data.Maybe (catMaybes) -import Test.Framework as TF (testGroup, Test) +import Test.Framework as TF (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit -import TestUtils + import qualified MailboxTestFilters (__remoteTable) import MailboxTestFilters (myFilter, intFilter) +import Network.Transport.TCP import qualified Network.Transport as NT -- TODO: This whole test suite would be much better off using QuickCheck. @@ -254,3 +256,10 @@ tests transport = do main :: IO () main = testMain $ tests +-- | Given a @builder@ function, make and run a test suite on a single transport +testMain :: (NT.Transport -> IO [Test]) -> IO () +testMain builder = do + Right (transport, _) <- createTransportExposeInternals + "127.0.0.1" "10501" defaultTCPParameters + testData <- builder transport + defaultMain testData diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs deleted file mode 100644 index 7948b88..0000000 --- a/tests/TestUtils.hs +++ /dev/null @@ -1,234 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveGeneric #-} - -module TestUtils - ( TestResult - -- ping ! - , Ping(Ping) - , ping - , shouldBe - , shouldMatch - , shouldContain - , shouldNotContain - , shouldExitWith - , expectThat - -- test process utilities - , TestProcessControl - , startTestProcess - , runTestProcess - , testProcessGo - , testProcessStop - , testProcessReport - , delayedAssertion - , assertComplete - , waitForExit - -- logging - , Logger() - , newLogger - , putLogMsg - , stopLogger - -- runners - , mkNode - , tryRunProcess - , testMain - , 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 - , putMVar - ) - -import Control.Distributed.Process -import Control.Distributed.Process.Node -import Control.Distributed.Process.Serializable() -import Control.Distributed.Process.Extras.Time -import Control.Distributed.Process.Extras.Timer -import Control.Distributed.Process.Extras.Internal.Types -import Control.Exception (SomeException) -import qualified Control.Exception as Exception -import Control.Monad (forever) -import Control.Monad.STM (atomically) -import Control.Rematch hiding (match) -import Control.Rematch.Run -import Test.HUnit (Assertion, assertFailure) -import Test.HUnit.Base (assertBool) -import Test.Framework (Test, defaultMain) -import Control.DeepSeq - -import Network.Transport.TCP -import qualified Network.Transport as NT - -import Data.Binary -import Data.Typeable -import GHC.Generics - ---expect :: a -> Matcher a -> Process () ---expect a m = liftIO $ Rematch.expect a m - -expectThat :: a -> Matcher a -> Process () -expectThat a matcher = case res of - MatchSuccess -> return () - (MatchFailure msg) -> liftIO $ assertFailure msg - where res = runMatch matcher a - -shouldBe :: a -> Matcher a -> Process () -shouldBe = expectThat - -shouldContain :: (Show a, Eq a) => [a] -> a -> Process () -shouldContain xs x = expectThat xs $ hasItem (equalTo x) - -shouldNotContain :: (Show a, Eq a) => [a] -> a -> Process () -shouldNotContain xs x = expectThat xs $ isNot (hasItem (equalTo x)) - -shouldMatch :: a -> Matcher a -> Process () -shouldMatch = expectThat - -shouldExitWith :: (Addressable a) => a -> DiedReason -> Process () -shouldExitWith a r = do - _ <- resolve a - d <- receiveWait [ match (\(ProcessMonitorNotification _ _ r') -> return r') ] - d `shouldBe` equalTo r - -waitForExit :: MVar ExitReason - -> Process (Maybe ExitReason) -waitForExit exitReason = do - -- we *might* end up blocked here, so ensure the test doesn't jam up! - self <- getSelfPid - tref <- killAfter (within 10 Seconds) self "testcast timed out" - tr <- liftIO $ takeMVar exitReason - cancelTimer tref - case tr of - ExitNormal -> return Nothing - other -> return $ Just other - -mkNode :: String -> IO LocalNode -mkNode port = do - Right (transport1, _) <- createTransportExposeInternals - "127.0.0.1" port defaultTCPParameters - newLocalNode transport1 initRemoteTable - --- | 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 note localNode expected testProc = do - result <- newEmptyMVar - _ <- forkProcess localNode $ testProc result - assertComplete note result expected - --- | Takes the value of @mv@ (using @takeMVar@) and asserts that it matches @a@ -assertComplete :: (Eq a) => String -> MVar a -> a -> IO () -assertComplete msg mv a = do - b <- takeMVar mv - assertBool msg (a == b) - --- synchronised logging - -data Logger = Logger { _tid :: ThreadId, msgs :: TQueue String } - --- | Create a new Logger. --- Logger uses a 'TQueue' to receive and process messages on a worker thread. -newLogger :: IO Logger -newLogger = do - tid <- liftIO $ myThreadId - q <- liftIO $ newTQueueIO - _ <- forkIO $ logger q - return $ Logger tid q - where logger q' = forever $ do - msg <- atomically $ readTQueue q' - putStrLn msg - --- | Send a message to the Logger -putLogMsg :: Logger -> String -> Process () -putLogMsg logger msg = liftIO $ atomically $ writeTQueue (msgs logger) msg - --- | Stop the worker thread for the given Logger -stopLogger :: Logger -> IO () -stopLogger = (flip Exception.throwTo) Exception.ThreadKilled . _tid - --- | Given a @builder@ function, make and run a test suite on a single transport -testMain :: (NT.Transport -> IO [Test]) -> IO () -testMain builder = do - Right (transport, _) <- createTransportExposeInternals - "127.0.0.1" "10501" defaultTCPParameters - testData <- builder transport - defaultMain testData - --- | Runs a /test process/ around the supplied @proc@, which is executed --- whenever the outer process loop receives a 'Go' signal. -runTestProcess :: Process () -> Process () -runTestProcess proc = do - ctl <- expect - case ctl of - Stop -> return () - Go -> proc >> runTestProcess proc - Report p -> receiveWait [matchAny (\m -> forward m p)] >> runTestProcess proc - --- | Starts a test process on the local node. -startTestProcess :: Process () -> Process ProcessId -startTestProcess proc = - spawnLocal $ do - getSelfPid >>= register "test-process" - runTestProcess proc - --- | Control signals used to manage /test processes/ -data TestProcessControl = Stop | Go | Report ProcessId - deriving (Typeable, Generic) - -instance Binary TestProcessControl where - --- | A mutable cell containing a test result. -type TestResult a = MVar a - --- | Stashes a value in our 'TestResult' using @putMVar@ -stash :: TestResult a -> a -> Process () -stash mvar x = liftIO $ putMVar mvar x - --- | Tell a /test process/ to stop (i.e., 'terminate') -testProcessStop :: ProcessId -> Process () -testProcessStop pid = send pid Stop - --- | Tell a /test process/ to continue executing -testProcessGo :: ProcessId -> Process () -testProcessGo pid = send pid Go - --- | A simple @Ping@ signal -data Ping = Ping - deriving (Typeable, Generic, Eq, Show) - -instance Binary Ping where -instance NFData Ping where - -ping :: ProcessId -> Process () -ping pid = send pid Ping - - -tryRunProcess :: LocalNode -> Process () -> IO () -tryRunProcess node p = do - tid <- liftIO myThreadId - runProcess node $ catch p (\e -> liftIO $ Exception.throwTo tid (e::SomeException)) - --- | Tell a /test process/ to send a report (message) --- back to the calling process -testProcessReport :: ProcessId -> Process () -testProcessReport pid = do - self <- getSelfPid - send pid $ Report self From abd9371e732f044c87458a61005007e4e9150628 Mon Sep 17 00:00:00 2001 From: Alexander Vershilov Date: Wed, 18 Mar 2015 22:56:04 +0300 Subject: [PATCH 2/2] Add compatibility with ghc-7.10 --- distributed-process-execution.cabal | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/distributed-process-execution.cabal b/distributed-process-execution.cabal index e1c401a..235343d 100644 --- a/distributed-process-execution.cabal +++ b/distributed-process-execution.cabal @@ -37,14 +37,14 @@ library distributed-process-supervisor >= 0.1.2 && < 0.2, distributed-process-client-server >= 0.1.2 && < 0.2, binary >= 0.6.3.0 && < 0.8, - deepseq >= 1.3.0.1 && < 1.4, + deepseq >= 1.3.0.1 && < 1.5, mtl, containers >= 0.4 && < 0.6, hashable >= 1.2.0.5 && < 1.3, unordered-containers >= 0.2.3.0 && < 0.3, fingertree < 0.2, stm >= 2.4 && < 2.5, - time > 1.4 && < 1.5, + time > 1.4 && < 1.6, transformers if impl(ghc <= 7.5) Build-Depends: template-haskell == 2.7.0.0, @@ -83,14 +83,14 @@ test-suite ExchangeTests data-accessor, fingertree < 0.2, network-transport >= 0.4 && < 0.5, - deepseq >= 1.3.0.1 && < 1.4, + deepseq >= 1.3.0.1 && < 1.5, mtl, network-transport-tcp >= 0.4 && < 0.5, binary >= 0.6.3.0 && < 0.8, network >= 2.3 && < 2.7, HUnit >= 1.2 && < 2, stm >= 2.3 && < 2.5, - time > 1.4 && < 1.5, + time > 1.4 && < 1.6, test-framework >= 0.6 && < 0.9, test-framework-hunit, QuickCheck >= 2.4, @@ -123,14 +123,14 @@ test-suite MailboxTests data-accessor, fingertree < 0.2, network-transport >= 0.4 && < 0.5, - deepseq >= 1.3.0.1 && < 1.4, + deepseq >= 1.3.0.1 && < 1.5, mtl, network-transport-tcp >= 0.4 && < 0.5, binary >= 0.6.3.0 && < 0.8, network >= 2.3 && < 2.7, HUnit >= 1.2 && < 2, stm >= 2.3 && < 2.5, - time > 1.4 && < 1.5, + time > 1.4 && < 1.6, test-framework >= 0.6 && < 0.9, test-framework-hunit, QuickCheck >= 2.4,