{- | Module : Test.Framework.Providers.Sandbox Copyright : Copyright (C) 2013 GREE, Benjamin Surma License : GNU LGPL, version 2.1 or above Maintainer: Benjamin Surma 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 > ] > ] -}