packages feed

test-framework-sandbox (empty) → 0.0.1

raw patch · 5 files changed

+333/−0 lines, 5 filesdep +ansi-terminaldep +basedep +lifted-basesetup-changed

Dependencies added: ansi-terminal, base, lifted-base, mtl, temporary, test-framework, test-sandbox, transformers

Files

+ LICENSE view
@@ -0,0 +1,25 @@+The BSD 3-Clause License+========================++Copyright (c) 2013, GREE+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 GREE, 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.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ src/Test/Framework/Providers/Sandbox.hs view
@@ -0,0 +1,165 @@+{- |+   Module    : Test.Framework.Providers.Sandbox+   Copyright : Copyright (C) 2013 GREE, Benjamin Surma+   License   : GNU LGPL, version 2.1 or above+   Maintainer: Benjamin Surma <benjamin.surma@gree.net>++test-framework interface for test-sandbox++Copyright (C) 2013 GREE, Benjamin Surma, benjamin.surma@gree.net+-}++{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Test.Framework.Providers.Sandbox (+  -- * Introduction+  -- $introduction++  -- * Usage example+  -- $usage++  -- * Initialization+    sandboxTests+  -- * Test declaration+  , sandboxTest+  , sandboxTestGroup+  , sandboxTestGroup'+  , yieldProgress+  ) where++import Control.Concurrent+import Control.Exception.Lifted+import Control.Monad hiding (fail)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Error (runErrorT)+import Control.Monad.Trans.State.Strict+import Data.Either+import Prelude hiding (error, fail)+import qualified Prelude (error)+import System.Console.ANSI+import System.Environment+import System.Exit+import System.IO+import System.IO.Temp++import Test.Framework+import Test.Framework.Providers.API (Test (..))++import Test.Sandbox+import Test.Sandbox.Internals hiding (putOptions)++import Test.Framework.Providers.Sandbox.Internals++-- | Executes tests in the Sandbox monad.+sandboxTests :: String       -- ^ Name of the sandbox environment+             -> Sandbox Test -- ^ Test to perform+             -> Test+sandboxTests name test = buildTest $ do+  options <- interpretArgs =<< getArgs+  mvar <- newEmptyMVar :: IO (MVar Int)+  return $ mutuallyExclusive $ testGroup name [+      buildTestBracketed $+        withSystemTempDirectory (name ++ "_") $ \dir -> do+          env <- newSandboxState name dir+          (result, env') <- (runStateT . runErrorT . runSandbox) (putOptions options >> test) env+          let cleanup = (evalStateT . runErrorT . runSandbox) (silently stopAll) env'+                          >>= either putStrLn return+                          >> putMVar mvar 0+          case result of+            Left error -> return (Test name (SandboxTest (Failure error)), cleanup)+            Right x -> return (x, cleanup)+    , Test "cleaning" (SandboxCleaning mvar) ]++-- | Groups tests in the Sandbox monad.+sandboxTestGroup :: String         -- ^ Test group name+                 -> [Sandbox Test] -- ^ Tests to perform+                 -> Sandbox Test+sandboxTestGroup name tests = withTest name $ do+  liftIO $ putStrLn ""+  liftM (testGroup name) (sequence tests)++-- | Variant of sandboxTestGroup: tests will be skipped if the condition is not verified.+sandboxTestGroup' :: String         -- ^ Test group name+                  -> Sandbox Bool   -- ^ Condition for group to be evaluated+                  -> [Sandbox Test] -- ^ Tests to perform if condition stands+                  -> Sandbox Test+sandboxTestGroup' name condition tests = do+  result <- condition+  if result then+    sandboxTestGroup name tests+    else return $ Test (name ++ " (disabled)") (SandboxTest Skipped)++-- | Creates a test from a Sandbox action.+-- Any exception (or error thrown with throwError) will mark the test as failed.+sandboxTest :: String       -- ^ Test name+            -> Sandbox ()   -- ^ Action to perform+            -> Sandbox Test+sandboxTest name test = withTest name $ do+  res <- Sandbox $ do+    env <- lift get+    (res, env') <- liftIO $ flip (runStateT . runErrorT . runSandbox) env $ test `catches` handlers+    lift $ put env'+    return res+  liftIO $ printTestResult res+  case res of+    Left error -> return $ Test name (SandboxTest (Failure error))+    Right _ -> return $ Test name (SandboxTest Passed)+  where handlers = [ Handler exitHandler+                   , Handler interruptHandler+                   , Handler otherHandler ]+        exitHandler :: ExitCode -> Sandbox a+        exitHandler e = stopAll >> throw e+        interruptHandler :: AsyncException -> Sandbox a+        interruptHandler UserInterrupt = stopAll >> liftIO exitFailure+        interruptHandler e = Sandbox . throwError . show $ e+        otherHandler :: SomeException -> Sandbox a+        otherHandler = Sandbox . throwError . show++-- | Displays a progress update during a test.+yieldProgress :: String     -- ^ Text to display+              -> Sandbox ()+yieldProgress p = do+  pl <- getVariable prettyPrintVariable []+  unless (null pl) $ liftIO $ putStr " / "+  setVariable prettyPrintVariable (p : pl)+  liftIO $ putStrColor Dull Blue p >> hFlush stdout++----------------------------------------------------------------------+-- Docs+----------------------------------------------------------------------++{- $introduction++This module interfaces the Test.Sandbox monad with the test-framework+popular Haskell package for a unified test experience.++Tests share the same sandboxed environment: processes started in one+test can be addressed in another. Variables can and should be used+to pass information between test cases.+-}++{- $usage++The following example describes how the "sed" example from+the Test.Sandbox would be crammed into the Test.Framework model.++Initialization of the Sandbox is performed by the @sandboxTests@+function. Tests are then individually declared by @sandboxTest@ and+grouped by @sandboxTestGroup@.++> import Test.Framework+> import Test.Framework.Providers.Sandbox+> import Test.Sandbox+> import Test.Sandbox.HUnit+> +> setup :: Sandbox ()+> setup = start =<< register "sed_s/a/b/" "sed" [ "-u", "s/a/b/" ] def { psCapture = CaptureStdout }+> +> main = defaultMain [+>     sandboxTests "sed_tests" $ setup >> sandboxTestGroup "all" [+>         sandboxTest "sed a->b" $ assertEqual "a->b" "b\n" =<< interactWith "sed_s/a/b/" "a\n" 5+>       , sandboxTest "sed aa->ba" $ assertEqual "aa->ba" "ba\n" =<< interactWith "sed_s/a/b/" "aa\n" 5+>     ]+>   ]+-}
+ src/Test/Framework/Providers/Sandbox/Internals.hs view
@@ -0,0 +1,113 @@+-- author: Benjamin Surma <benjamin.surma@gree.net>++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Test.Framework.Providers.Sandbox.Internals where++import Control.Concurrent+import Control.Monad hiding (fail)+import Data.Either+import Data.Typeable+import Prelude hiding (error, fail)+import qualified Prelude (error)+import System.Console.ANSI+import System.IO++import Test.Framework+import Test.Framework.Providers.API (Testlike (..), TestResultlike (..), runImprovingIO)+import qualified Test.Framework.Providers.API as TF (liftIO)++import Test.Sandbox+import Test.Sandbox.Internals++data SandboxTestResult = Passed+                       | Skipped+                       | Failure String+  deriving (Typeable)++data SandboxTestRunning = Running+  deriving (Typeable)++data SandboxTest = SandboxTest SandboxTestResult+                 | SandboxCleaning (MVar Int)+  deriving (Typeable)++instance Show SandboxTestResult where+  show Passed = "OK"+  show Skipped = "Skipped"+  show (Failure s) = "Failure: " ++ s+instance Show SandboxTestRunning where+  show Running = "Running"++instance TestResultlike SandboxTestRunning SandboxTestResult where+  testSucceeded x = case x of+                      Passed -> True+                      Skipped -> True+                      _ -> False++instance Testlike SandboxTestRunning SandboxTestResult SandboxTest where+  testTypeName _ = "Sandbox tests"+  runTest _ (SandboxTest res) = runImprovingIO $ return res+  runTest _ (SandboxCleaning mvar) = runImprovingIO $ do TF.liftIO $ takeMVar mvar+                                                         return Passed++withTest :: String -> Sandbox b -> Sandbox b+withTest name action = withVariable testVariable name $+  bracket (do level <- getVariable testLevelVariable 0+              liftIO $ printTestName level name+              setVariable testLevelVariable $! level + 1+              return level)+          (setVariable testLevelVariable)+          (const action)++prettyPrintVariable :: String -- Pretty-print variable name+prettyPrintVariable = "__PPRINT__"++testVariable :: String -- Test-list variable name+testVariable = "__TEST__"++testLevelVariable :: String+testLevelVariable = "__TEST_LEVEL__"++indent :: String+indent = "  "++printTestName :: Int -> String -> IO ()+printTestName l t =+  replicateM_ l (putStr indent) >> putStr "[" >> putStrColor Vivid Blue t >> putStr "] " >> hFlush stdout++printTestResult :: Either String a -> IO ()+printTestResult r =+  case r of+    Left error -> putStr " [" >> putStrColor Vivid Red "Fail" >> putStrLn ("] " ++ error)+    _ -> putStr " [" >> putStrColor Vivid Green "OK" >> putStrLn "]"++putStrColor :: ColorIntensity -> Color -> String -> IO ()+putStrColor i c s = do+  setSGR [SetColor Foreground i c]+  putStr s+  setSGR []++-- Wrapper to store the test-framework options+-- for future use by other test-sandbox modules++sandboxSeed :: Maybe Seed -> Maybe SandboxSeed+sandboxSeed s = case s of+  Nothing -> Nothing+  Just (FixedSeed i) -> Just (SandboxFixedSeed i)+  Just RandomSeed -> Just SandboxRandomSeed++sandboxTestOptions :: TestOptions -> SandboxTestOptions+sandboxTestOptions options = SandboxTestOptions (sandboxSeed $ topt_seed options)+                                                (topt_maximum_generated_tests options)+                                                (topt_maximum_unsuitable_generated_tests options)+                                                (topt_maximum_test_size options)++putOptions :: Either String (RunnerOptions, [String]) -> Sandbox ()+putOptions =+  either (const $ return ())+         (\r -> maybe (return ()) (void . Test.Sandbox.Internals.putOptions . sandboxTestOptions) (ropt_test_options $ fst r))
+ test-framework-sandbox.cabal view
@@ -0,0 +1,26 @@+Name:           test-framework-sandbox+Version:        0.0.1+Cabal-Version:  >= 1.14+Category:       Testing+Synopsis:       test-sandbox support for the test-framework package+Description:    Interfaces the test-sandbox the test-framework packages to allow writing system tests+                in Haskell in a standard fashion.+                The environment is preserved between test cases, enabling the user, for instance, to start+                a process in one test and stop it in another.+License:        BSD3+License-File:   LICENSE+Author:         Benjamin Surma <benjamin.surma@gree.net>+Maintainer:     Benjamin Surma <benjamin.surma@gree.net>+Build-Type:     Simple++Library+    Exposed-modules:    Test.Framework.Providers.Sandbox+                        Test.Framework.Providers.Sandbox.Internals++    Build-Depends:      base >=4 && <5, ansi-terminal, lifted-base, mtl,+                        temporary, test-framework, test-sandbox == 0.0.1.*,+                        transformers++    Hs-source-dirs:     src++    Default-Language:   Haskell2010