diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/src/Test/Framework/Providers/Sandbox.hs b/src/Test/Framework/Providers/Sandbox.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Providers/Sandbox.hs @@ -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 + +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 +> ] +> ] +-} diff --git a/src/Test/Framework/Providers/Sandbox/Internals.hs b/src/Test/Framework/Providers/Sandbox/Internals.hs new file mode 100644 --- /dev/null +++ b/src/Test/Framework/Providers/Sandbox/Internals.hs @@ -0,0 +1,113 @@ +-- author: Benjamin Surma + +{-# 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)) diff --git a/test-framework-sandbox.cabal b/test-framework-sandbox.cabal new file mode 100644 --- /dev/null +++ b/test-framework-sandbox.cabal @@ -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 +Maintainer: Benjamin Surma +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