diff --git a/packages/distributed-process-systest/ChangeLog b/packages/distributed-process-systest/ChangeLog new file mode 100644 index 00000000..10603f9f --- /dev/null +++ b/packages/distributed-process-systest/ChangeLog @@ -0,0 +1,18 @@ +2024-03-26 David Simmons-Duffin 0.3.1 + +* Relaxed upper bounds to build with ghc-9.8 +* Fixed syntax errors with Haskell2010 + +2018-11-10 Tim Watson 0.3.0 + +* Relaxed upper bounds to allow for newer versions of exceptions +* Support for GHC 8.2 (thanks agentm) +* further relax upper bounds for HUnit (thanks Alexander Vershilov) + +2017-02-05 Tim Watson 0.1.1 + +* Bugfix: relax upper bounds for HUnit + +2017-02-04 Tim Watson 0.1.0 + +* Initial Release diff --git a/packages/distributed-process-systest/LICENSE b/packages/distributed-process-systest/LICENSE new file mode 100644 index 00000000..03cf3717 --- /dev/null +++ b/packages/distributed-process-systest/LICENSE @@ -0,0 +1,31 @@ +Copyright Tim Watson, 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the owner nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/packages/distributed-process-systest/Setup.hs b/packages/distributed-process-systest/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/packages/distributed-process-systest/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/packages/distributed-process-systest/distributed-process-systest.cabal b/packages/distributed-process-systest/distributed-process-systest.cabal new file mode 100644 index 00000000..84d02bf5 --- /dev/null +++ b/packages/distributed-process-systest/distributed-process-systest.cabal @@ -0,0 +1,47 @@ +name: distributed-process-systest +version: 0.3.1 +synopsis: Cloud Haskell Test Support +description: Testing Frameworks and Capabilities for programs built on Cloud Haskell +homepage: http://github.com/haskell-distributed/distributed-process-systest +license: BSD3 +license-file: LICENSE +Author: Tim Watson +Maintainer: watson.timothy@gmail.com +copyright: Tim Watson +category: Control, Cloud Haskell +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/haskell-distributed/distributed-process-systest + +library + exposed-modules: Control.Distributed.Process.SysTest.Utils + Build-Depends: base >= 4.4 && < 5, + ansi-terminal >= 0.5 && < 1.1, + binary >= 0.5 && < 1.0, + bytestring >= 0.9 && < 0.13, + distributed-process >= 0.6.1 && < 0.8, + distributed-static < 0.4, + HUnit >= 1.2 && < 2, + network-transport >= 0.4.1.0 && < 0.6, + network >= 2.5 && < 3.2, + random >= 1.0 && < 1.3, + rematch >= 0.1.2.1 && < 0.3, + test-framework >= 0.6 && < 0.9, + test-framework-hunit >= 0.2.0 && < 0.4, + exceptions < 0.11, + stm < 2.6 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-unused-do-bind + default-extensions: CPP, + ExistentialQuantification, + FlexibleInstances, + DeriveDataTypeable, + DeriveGeneric, + GeneralizedNewtypeDeriving, + RankNTypes, + RecordWildCards, + ScopedTypeVariables diff --git a/packages/distributed-process-systest/src/Control/Distributed/Process/SysTest/Utils.hs b/packages/distributed-process-systest/src/Control/Distributed/Process/SysTest/Utils.hs new file mode 100644 index 00000000..435a5fae --- /dev/null +++ b/packages/distributed-process-systest/src/Control/Distributed/Process/SysTest/Utils.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.SysTest.Utils +-- Copyright : (c) Tim Watson 2014 - 2016 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- This module provides basic building blocks for testing Cloud Haskell programs. +----------------------------------------------------------------------------- +module Control.Distributed.Process.SysTest.Utils + ( TestResult + -- ping ! + , Ping(Ping) + , ping + , shouldBe + , shouldMatch + , shouldContain + , shouldNotContain + , expectThat + , synchronisedAssertion + -- test process utilities + , TestProcessControl + , startTestProcess + , runTestProcess + , testProcessGo + , testProcessStop + , testProcessReport + , delayedAssertion + , assertComplete + -- logging + , Logger() + , newLogger + , putLogMsg + , stopLogger + -- runners + , tryRunProcess + , tryForkProcess + , noop + , stash + ) where + +import Control.Concurrent + ( ThreadId + , myThreadId + , forkIO + ) +import Control.Concurrent.STM + ( TQueue + , newTQueueIO + , readTQueue + , writeTQueue + ) +import Control.Concurrent.MVar + ( MVar + , newEmptyMVar + , takeMVar + ) + +import Control.Concurrent + ( throwTo + ) +import Control.Concurrent.MVar + ( putMVar + ) +import Control.Distributed.Process hiding (catch, finally) +import Control.Distributed.Process.Node +import Control.Distributed.Process.Serializable() +import Control.Monad.Catch + +import Control.Exception (AsyncException(ThreadKilled)) +import Control.Monad (forever) +import Control.Monad.STM (atomically) +import Control.Rematch hiding (match) +import Control.Rematch.Run +import Data.Binary +import Data.Typeable (Typeable) + +import Test.HUnit (Assertion, assertFailure) +import Test.HUnit.Base (assertBool) + +import GHC.Generics + +-- | A mutable cell containing a test result. +type TestResult a = MVar a + +-- | A simple @Ping@ signal +data Ping = Ping + deriving (Typeable, Generic, Eq, Show) +instance Binary Ping where + +ping :: ProcessId -> Process () +ping pid = send pid Ping + +-- | Control signals used to manage /test processes/ +data TestProcessControl = Stop | Go | Report ProcessId + deriving (Typeable, Generic) + +instance Binary TestProcessControl where + +-- | Does exactly what it says on the tin, doing so in the @Process@ monad. +noop :: Process () +noop = return () + +synchronisedAssertion :: Eq a + => String + -> LocalNode + -> a + -> (TestResult a -> Process ()) + -> MVar () + -> Assertion +synchronisedAssertion note localNode expected testProc lock = do + result <- newEmptyMVar + _ <- forkProcess localNode $ do + acquire lock + finally (testProc result) + (release lock) + assertComplete note result expected + where acquire lock' = liftIO $ takeMVar lock' + release lock' = liftIO $ putMVar lock' () + +stash :: TestResult a -> a -> Process () +stash mvar x = liftIO $ putMVar mvar x + +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 + +-- | 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 throwTo) ThreadKilled . _tid + +-- | Starts a test process on the local node. +startTestProcess :: Process () -> Process ProcessId +startTestProcess proc = + spawnLocal $ do + getSelfPid >>= register "test-process" + runTestProcess proc + +-- | 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 + +-- | Tell a /test process/ to continue executing +testProcessGo :: ProcessId -> Process () +testProcessGo pid = send pid Go + +-- | Tell a /test process/ to stop (i.e., 'terminate') +testProcessStop :: ProcessId -> Process () +testProcessStop pid = send pid Stop + +-- | 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 + +tryRunProcess :: LocalNode -> Process () -> IO () +tryRunProcess node p = do + tid <- liftIO myThreadId + runProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException)) + +tryForkProcess :: LocalNode -> Process () -> IO ProcessId +tryForkProcess node p = do + tid <- liftIO myThreadId + forkProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException)) +