diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,14 @@ +2015-06-15 Facundo Domínguez 0.1.2 + +* Add compatibility with ghc-7.10. +* Fix dependency bounds. +* Reuse test modules from distributed-proces-tests. + +# HEAD + +* Added initial GenServer module +* Added Timer Module +* Moved time functions into Time.hs +* Added Async API +* Added GenProcess API (subsumes lower level GenServer API) + diff --git a/distributed-process-execution.cabal b/distributed-process-execution.cabal --- a/distributed-process-execution.cabal +++ b/distributed-process-execution.cabal @@ -1,5 +1,5 @@ name: distributed-process-execution -version: 0.1.1 +version: 0.1.2.1 cabal-version: >=1.8 build-type: Simple license: BSD3 @@ -7,27 +7,24 @@ stability: experimental Copyright: Tim Watson 2012 - 2013 Author: Tim Watson -Maintainer: watson.timothy@gmail.com +Maintainer: Facundo Domínguez Stability: experimental Homepage: http://github.com/haskell-distributed/distributed-process-execution Bug-Reports: http://github.com/haskell-distributed/distributed-process-execution/issues synopsis: Execution Framework for The Cloud Haskell Application Platform -description: - The Execution Framework provides tools for load regulation, workload shedding and remote hand-off. - The currently implementation provides only a subset of the plumbing required, comprising tools - for event management, mailbox buffering and message routing. +description: + The Execution Framework provides tools for load regulation, workload shedding and remote hand-off. + The currently implementation provides only a subset of the plumbing required, comprising tools + for event management, mailbox buffering and message routing. category: Control tested-with: GHC == 7.4.2 GHC == 7.6.2 data-dir: "" +extra-source-files: ChangeLog source-repository head type: git location: https://github.com/haskell-distributed/distributed-process-execution -flag perf - description: Build with profiling enabled - default: False - library build-depends: base >= 4.4 && < 5, @@ -37,14 +34,14 @@ 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, @@ -77,19 +74,20 @@ 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, 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, @@ -102,7 +100,6 @@ 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,19 +114,20 @@ 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, 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, @@ -143,4 +141,3 @@ extensions: CPP main-is: TestMailbox.hs other-modules: MailboxTestFilters - TestUtils diff --git a/tests/TestExchange.hs b/tests/TestExchange.hs --- a/tests/TestExchange.hs +++ b/tests/TestExchange.hs @@ -15,6 +15,7 @@ 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 @@ #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 @@ 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 --- a/tests/TestMailbox.hs +++ b/tests/TestMailbox.hs @@ -7,11 +7,12 @@ 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) #if ! MIN_VERSION_base(4,6,0) @@ -22,12 +23,13 @@ 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 @@ 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 --- 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