distributed-process-systest (empty) → 0.1.0

raw patch · 4 files changed

+310/−0 lines, 4 filesdep +HUnitdep +ansi-terminaldep +basesetup-changed

Dependencies added: HUnit, ansi-terminal, base, binary, bytestring, distributed-process, distributed-static, network, network-transport, random, rematch, stm, test-framework, test-framework-hunit

Files

LICENSE +31/−0
Setup.hs +2/−0
distributed-process-systest.cabal +45/−0
src/Control/Distributed/Process/SysTest/Utils.hs +232/−0

+ LICENSE view

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

+ Setup.hs view

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

+ distributed-process-systest.cabal view

@@ -0,0 +1,45 @@+name:          distributed-process-systest+version:       0.1.0+synopsis:      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.8++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 && < 0.7,+                     binary >= 0.5 && < 0.9,+                     bytestring >= 0.9 && < 0.11,+                     distributed-process >= 0.6.1 && < 0.7,+                     distributed-static,+                     HUnit >= 1.2 && < 1.4,+                     network-transport >= 0.4.1.0 && < 0.5,+                     network >= 2.5 && < 2.7,+                     random >= 1.0 && < 1.2,+                     rematch >= 0.1.2.1,+                     test-framework >= 0.6 && < 0.9,+                     test-framework-hunit >= 0.2.0 && < 0.4,+                     stm+  hs-source-dirs:    src+  ghc-options:       -Wall -fno-warn-unused-do-bind+  extensions:        CPP,+                     ExistentialQuantification,+                     FlexibleInstances,+                     DeriveDataTypeable,+                     DeriveGeneric,+                     GeneralizedNewtypeDeriving,+                     OverlappingInstances,+                     RankNTypes,+                     RecordWildCards,+                     ScopedTypeVariables

+ src/Control/Distributed/Process/SysTest/Utils.hs view

@@ -0,0 +1,232 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE CPP                #-}++-----------------------------------------------------------------------------+-- |+-- 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++#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+  )++import Control.Concurrent+  ( throwTo+  )+import Control.Concurrent.MVar+  ( putMVar+  )+import Control.Distributed.Process+import Control.Distributed.Process.Node+import Control.Distributed.Process.Serializable()++import Control.Exception (AsyncException(ThreadKilled), SomeException)+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))+