Merge branch 'monorepo-structure' of https://github.com/haskell-distr…

…ibuted/distributed-process-systest into monorepo-structure

packages/distributed-process-systest/ChangeLog

@@ -0,0 +1,18 @@
+2024-03-26 David Simmons-Duffin <[email protected]> 0.3.1
+
+* Relaxed upper bounds to build with ghc-9.8
+* Fixed syntax errors with Haskell2010
+
+2018-11-10 Tim Watson <[email protected]> 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 <[email protected]> 0.1.1
+
+* Bugfix: relax upper bounds for HUnit
+
+2017-02-04 Tim Watson <[email protected]> 0.1.0
+
+* Initial Release

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.
+

packages/distributed-process-systest/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

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:    [email protected]
+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

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))
+