test-sandbox (empty) → 0.0.1
raw patch · 5 files changed
+918/−0 lines, 5 filesdep +basedep +bytestringdep +cerealsetup-changed
Dependencies added: base, bytestring, cereal, containers, data-default, directory, filepath, lifted-base, monad-control, monad-loops, mtl, network, process, random, random-shuffle, temporary, transformers, transformers-base, unix
Files
- LICENSE +25/−0
- Setup.lhs +4/−0
- src/Test/Sandbox.hs +454/−0
- src/Test/Sandbox/Internals.hs +408/−0
- test-sandbox.cabal +27/−0
+ 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/Sandbox.hs view
@@ -0,0 +1,454 @@+{- |+ Module : Test.Sandbox+ Maintainer: Benjamin Surma <benjamin.surma@gree.net>++Configuration and management of processes in a sandboxed environment for system testing.++This module contains extensive documentation. Please scroll down to the Introduction section to continue reading.+-}+module Test.Sandbox (+ -- * Introduction+ -- $introduction++ -- ** Features+ -- $features++ -- ** History+ -- $history++ -- * Usage examples+ -- $usage++ -- ** Communication via TCP+ -- $usage_tcp++ -- ** Communication via standard I/O+ -- $usage_io++ -- Types+ Sandbox+ , ProcessSettings (..)+ , def+ , Capture (..)++ -- * Initialization+ , sandbox++ -- * Registering processes+ , register++ -- * Managing sandboxed processes+ , run+ , withProcess+ , start+ , startAll+ , stop+ , stopAll+ , signal+ , silently++ -- * Communication+ , interactWith+ , sendTo+ , readLastCapturedOutput+ , getHandles+ , getPort++ -- * Sandbox state management+ , getBinary+ , setPort+ , getFile+ , setFile+ , getDataDir+ , bracket+ , checkVariable+ , getVariable+ , setVariable+ , unsetVariable+ , withVariable++ -- * Sandbox exception handling+ , catchError+ , throwError++ -- * Sandbox I/O handling+ , liftIO+ ) where++import Control.Concurrent (threadDelay)+import Control.Exception.Lifted hiding (bracket)+import Control.Monad+import Control.Monad.Trans (lift, liftIO)+import Control.Monad.Trans.Error (runErrorT)+import Control.Monad.Error.Class (catchError, throwError)+import Control.Monad.Trans.State.Strict+import qualified Data.ByteString.Char8 as B+import Data.Default+import Data.Either+import qualified Data.Map as M+import Data.Maybe+import Data.Serialize (Serialize)+import Network hiding (sendTo)+import Prelude hiding (error)+import qualified Prelude (error)+import System.Exit+import System.IO+import System.IO.Temp+import System.Posix hiding (release)++import Test.Sandbox.Internals++-- | Creates a sandbox and execute the given actions in the IO monad.+sandbox :: String -- ^ Name of the sandbox environment+ -> Sandbox a -- ^ Action to perform+ -> IO a+sandbox name actions = withSystemTempDirectory (name ++ "_") $ \dir -> do+ env <- newSandboxState name dir+ (evalStateT . runErrorT . runSandbox) (actions `catches` handlers `finally` stopAll) env >>= either+ (\error -> do hPutStrLn stderr error+ throwIO $ userError error)+ return+ where handlers = [ Handler exitHandler+ , Handler otherHandler ]+ exitHandler :: ExitCode -> Sandbox a+ exitHandler e = stopAll >> throw e+ otherHandler :: SomeException -> Sandbox a+ otherHandler _ = stopAll >> liftIO exitFailure++-- | Optional parameters when registering a process in the Sandbox monad.+data ProcessSettings = ProcessSettings {+ psWait :: Maybe Int -- ^ Time to wait (in s.) before checking that the process is still up+ , psCapture :: Maybe Capture -- ^ Which outputs to capture (if any)+ }++instance Default ProcessSettings where+ def = ProcessSettings (Just 1) Nothing++-- | Registers a process in the Sandbox monad.+register :: String -- ^ Process name+ -> FilePath -- ^ Path to the application binary+ -> [String] -- ^ Arguments to pass on the command-line+ -> ProcessSettings -- ^ Process settings+ -> Sandbox String+register name bin args params = registerProcess name bin args (psWait params) (psCapture params) >> return name++-- | Communicates with a sandboxed process via TCP and returns the answered message as a string.+sendTo :: String -- ^ Name of the registered port + -> String -- ^ Input string+ -> Int -- ^ Time to wait before timeout (in milli-seconds)+ -> Sandbox String+sendTo = sendToPort++-- | Starts the given process, runs the action, then stops the process.+-- The process is managed by the functions start and stop respectively.+withProcess :: String -- ^ Process name+ -> Sandbox a -- ^ Action to run+ -> Sandbox a+withProcess name action = bracket (start name) (const $ stop name) (const action)++-- | Helper function: starts a process, wait for it to terminate and return its captured output.+run :: String -> Int -> Sandbox (ExitCode, Maybe String)+run name timeout = do+ silently $ start name+ waitFor name timeout `catchError` (\e -> silently (stop name) >> throwError e)++-- | Starts a previously registered process (verbose)+start :: String -- ^ Process name+ -> Sandbox ()+start process = uninterruptibleMask_ $ do+ displayBanner+ sp <- getProcess process+ whenM isVerbose $ liftIO $ putStr ("Starting process " ++ process ++ "... ") >> hFlush stdout+ updateProcess =<< startProcess sp+ whenM isVerbose $ liftIO $ putStrLn "Done."++-- | Starts all registered processes (in their registration order)+startAll :: Sandbox ()+startAll = uninterruptibleMask_ $ do+ displayBanner+ whenM isVerbose $ liftIO $ putStr "Starting all sandbox processes... " >> hFlush stdout+ silently $ Sandbox $ do env <- lift get+ mapM_ (runSandbox . start) (ssProcessOrder env)+ lift get >>= lift . put+ whenM isVerbose $ liftIO $ putStrLn "Done."++waitFor :: String -> Int -> Sandbox (ExitCode, Maybe String)+waitFor name timeout = waitFor' 0+ where waitFor' tick = do+ sp <- getProcess name+ case spInstance sp of+ Just (StoppedInstance ec o) -> return (ec, o)+ _ -> if tick > timeout then throwError $ "Process " ++ name ++ " still running after " ++ show timeout ++ "s timeout."+ else do liftIO $ threadDelay secondInµs+ waitFor' $! tick + 1++-- | Gracefully stops a previously started process (verbose)+stop :: String -- ^ Process name+ -> Sandbox ()+stop process = uninterruptibleMask_ $ do+ sp <- getProcess process+ whenM isVerbose $ liftIO $ putStr ("Stopping process " ++ process ++ "... ") >> hFlush stdout+ updateProcess =<< stopProcess sp+ whenM isVerbose $ liftIO $ putStrLn "Done."++-- | Sends a POSIX signal to a process+signal :: String -- ^ Process name+ -> Signal -- ^ Signal to send+ -> Sandbox ()+signal process sig = uninterruptibleMask_ $ do+ sp <- getProcess process+ case spInstance sp of+ Just (RunningInstance ph _ _) -> liftIO $ hSignalProcess sig ph+ _ -> throwError $ "Process " ++ process ++ " is not running."++-- | Gracefully stops all registered processes (in their reverse registration order)+stopAll :: Sandbox ()+stopAll = uninterruptibleMask_ $ do+ whenM isVerbose $ liftIO $ putStr "Stopping all sandbox processes... " >> hFlush stdout+ silently $ Sandbox $ do env <- lift get+ mapM_ (runSandbox . stop) (reverse $ ssProcessOrder env)+ lift get >>= lift . put+ whenM isVerbose $ liftIO $ putStrLn "Done."++-- | Returns the effective binary path of a registered process.+getBinary :: String -- ^ Process name+ -> Sandbox FilePath+getBinary process = getProcess process >>= getProcessBinary++-- | Returns the handles used to communicate with a registered process using standard I/O.+getHandles :: String -- ^ Process name+ -> Sandbox (Handle, Handle)+getHandles process = do+ sp <- getProcess process+ input <- getProcessInputHandle sp+ output <- getProcessCapturedOutputHandle sp+ return (input, output)++-- | Returns the last captured output of a started process.+readLastCapturedOutput :: String -- ^ Process name+ -> Sandbox String+readLastCapturedOutput process = do+ sp <- getProcess process+ h <- getProcessCapturedOutputHandle sp+ b <- hReadWithTimeout h 0+ return $! B.unpack b++-- | Interacts with a sandboxed process via standard I/O.+interactWith :: String -- ^ Process name+ -> String -- ^ Input string+ -> Int -- ^ Time to wait before timeout (in milli-seconds)+ -> Sandbox String+interactWith process input timeout = do+ sp <- getProcess process+ interactWithProcess sp input timeout++-- | Returns an unbound user TCP port and stores it for future reference.+getPort :: String -- ^ Port name for future reference+ -> Sandbox PortNumber+getPort name = do+ env <- Sandbox $ lift get+ case M.lookup name $ ssAllocatedPorts env of+ Just port -> return port+ Nothing -> getNewPort name++-- | Explicitely sets a port to be returned by getPort.+setPort :: String -- ^ Port name for future reference+ -> Int -- ^ TCP port number+ -> Sandbox PortNumber+setPort name port = Sandbox $ do+ let port' = fromIntegral port+ bindable <- liftIO $ isBindable (fromIntegral port)+ if bindable then do env <- lift get+ lift $ put (env { ssAllocatedPorts = M.insert name port' $ ssAllocatedPorts env })+ return port'+ else throwError $ "Unable to bind port " ++ show port++-- | Creates a temporary file in the sandbox and returns its path.+setFile :: String -- ^ File name for future reference+ -> String -- ^ File contents+ -> Sandbox FilePath+setFile name contents = Sandbox $ do+ env <- lift get+ (file, env') <- liftIO $ setFile' name contents env+ lift $ put env'+ return file++-- | Returns the path of a file previously created by setFile.+getFile :: String -- ^ File name used during setFile+ -> Sandbox FilePath+getFile name = Sandbox $ do+ env <- lift get+ case M.lookup name $ ssFiles env of+ Just file -> return file+ Nothing -> throwError $ "Config file " ++ name ++ " does not exist."++-- | A variant of bracket from Control.Exception which works in the Sandbox monad.+bracket :: Sandbox a -- ^ Computation to run first ("acquire resource")+ -> (a -> Sandbox b) -- ^ Computation to run last ("release resource")+ -> (a -> Sandbox c) -- ^ Computation to run in-between+ -> Sandbox c+bracket acquire release between = do+ stuff <- acquire+ result <- between stuff `catchError` (\e -> release stuff >> throwError e)+ release stuff+ return result++-- | Temporarily sets a variable for the execution of the given action.+withVariable :: (Serialize a)+ => String -- ^ Variable key+ -> a -- ^ Variable value+ -> Sandbox b -- ^ Action to run+ -> Sandbox b+withVariable key value action = bracket (do env <- Sandbox $ lift get+ let old = M.lookup key $ ssVariables env+ setVariable key value+ return old)+ (\old -> case old of+ Nothing -> unsetVariable key+ Just old' -> void $ setVariable key old')+ (const action)++-- | Returns the temporary directory used to host the sandbox environment.+getDataDir :: Sandbox FilePath+getDataDir = Sandbox $ liftM ssDataDir (lift get)++-- | Executes the given action silently.+silently :: Sandbox a -- ^ Action to execute+ -> Sandbox a+silently = withVariable verbosityKey False++----------------------------------------------------------------------+-- Docs+----------------------------------------------------------------------++{- $introduction++test-sandbox is a framework to manage external applications+and communicate with them via TCP or standard I/O for system testing+in a sandboxed environment. The Test.Sandbox monad can either be used+stand-alone or in conjunction with HUnit, QuickCheck and the+test-framework packages to build a complete test suite.++The API is meant to be simple to understand yet flexible enough+to meet most of the needs of application testers.+-}++{- $features++ * Register, start and stop programs in a sandboxed environment.++ * Automatic cleaning at shutdown: started processes are shutdown,+ temporary files are deleted.++ * Ask the framework to provide you with random,+ guaranteed not bound TCP ports for your tests:+ no more collisions when running 2 sets of tests at the same time.++ * Generate your temporary configuration files programatically+ in a secure manner.++ * Easily share variables between your tests and modify them+ at runtime.++ * Combine with the test-framework package for standardized output+ and XML test result generation.++ * Use the QuickCheck library to write property tests and generate+ automatic test cases for your external application;+ enjoy the full power of the Haskell test harness, even if+ the application to test is written in a different language!+-}++{- $history++At GREE, we spend lots of time meticulously testing+our internally-developed middleware.+We have solutions not only developed in Haskell, but also C+++and PHP, but wanted a simple and robust test framework to perform+end-to-end testing, and this is how test-sandbox is born.+-}++{- $usage++A basic test-sandbox usecase would be as follows:++ 1. Initialize a Test.Sandbox monad++ 2. Register one or several processes to test+ a. Ask the Sandbox to provide you with some free TCP ports+ if needed+ a. Prepare temporary configuration files if required+ by your application++ 3. Start some processes++ 4. Communicate with them via TCP or standard IO++ 5. Analyze the received answers and check whether they match+ an expected pattern++ 6. Error handling is done via the @throwError@ and @catchError@+ functions.++Once all tests are done, the started processes are automatically+killed, and all temporary files are deleted.+-}++{- $usage_tcp++The following example shows a simple test for the "memcached"+NoSQL key-value store.++First, the sandbox is initialized with the @sandbox@ function;+then, it is asked to provide a free TCP port, which will be used+by the memcached process.+Once the program is registered with the @register@ function,+it is started with the @start@ function.+Please note that the Sandbox monad keeps an internal state: processes+registered in a function can be referenced in another without issues.++Communication via TCP is performed with the @sendTo@ function:+its arguments are the port name (given at the time of @getPort@),+the input string, and a timeout in milli-seconds. The function+returns the received TCP answer, if one was received in the correct+timeframe, or fails by throwing an error (which can be caught by+@catchError@).++The test is performed with the @assertEqual@ function from the HUnit+package. In case of matching failure, it will throw an exception,+which, if uncaught (like it is) will cause the Sandbox to perform+cleaning and rethrow the exception.++> import Test.Sandbox+> import Test.Sandbox.HUnit+> +> setup :: Sandbox ()+> setup = do+> port <- getPort "memcached"+> register "memcached" "memcached" [ "-p", show port ] def+> +> main :: IO ()+> main = sandbox $ do+> setup+> start "memcached"+> output <- sendTo "memcached" "set key 0 0 5\r\nvalue\r\n" 1+> assertEqual "item is stored" "STORED\r\n" output+-}++{- $usage_io+The next example is a hypothetic system test for the popular "sed",+the popular Unix stream editor.++Please note that at registration time, the @psCapture@ parameter is+set to @CaptureStdout@. This is required by the @interactWith@+function, used for communication on the standard input, which will+return the captured output on each request.++> import Test.Sandbox+> import Test.Sandbox.HUnit+> +> main :: IO ()+> main = sandbox $ do+> start =<< register "sed_regex" "sed" [ "-u", "s/a/b/" ] def { psCapture = CaptureStdout }+> assertEqual "a->b" "b\n" =<< interactWith "sed_regex_ "a\n" 5+-}
+ src/Test/Sandbox/Internals.hs view
@@ -0,0 +1,408 @@+-- author: Benjamin Surma <benjamin.surma@gree.net>++{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++module Test.Sandbox.Internals where++import Control.Applicative (Applicative)+import Control.Concurrent+import Control.Exception.Lifted+import Control.Monad+import Control.Monad.Base (MonadBase)+import Control.Monad.Error (MonadError, catchError, throwError)+import Control.Monad.Loops+import Control.Monad.State (MonadState, get, put)+import Control.Monad.Trans (MonadIO, lift, liftIO)+import Control.Monad.Trans.Control (MonadBaseControl (..))+import Control.Monad.Trans.Error (ErrorT)+import Control.Monad.Trans.State.Strict (StateT)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.Char+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Serialize (Serialize, decode, encode)+import GHC.Generics (Generic)+import GHC.IO.Handle+import Network+import Network.Socket+import Prelude hiding (error)+import qualified Prelude (error)+import System.Directory+import System.Exit+import System.FilePath+import System.IO+import System.IO.Error (isEOFError, tryIOError)+import System.Posix hiding (killProcess)+import System.Process hiding (env, waitForProcess)+import System.Process.Internals (withProcessHandle, ProcessHandle__(OpenHandle))+import System.Random+import System.Random.Shuffle++newtype Sandbox a = Sandbox {+ runSandbox :: ErrorT String (StateT SandboxState IO) a+ } deriving (Applicative, Functor, Monad, MonadBase IO, MonadError String, MonadState SandboxState, MonadIO)++instance MonadBaseControl IO Sandbox where+ newtype StM Sandbox a = StMSandbox { runStMSandbox :: StM (ErrorT String (StateT SandboxState IO)) a }+ liftBaseWith f = Sandbox . liftBaseWith $ \run -> f (liftM StMSandbox . run . runSandbox)+ restoreM = Sandbox . restoreM . runStMSandbox++data SandboxState = SandboxState {+ ssName :: String+ , ssDataDir :: FilePath+ , ssProcesses :: Map String SandboxedProcess+ , ssProcessOrder :: [String]+ , ssAllocatedPorts :: Map String PortNumber+ , ssAvailablePorts :: [PortNumber]+ , ssFiles :: Map String FilePath+ , ssVariables :: Map String ByteString+ }++data SandboxedProcess = SandboxedProcess {+ spName :: String+ , spBinary :: FilePath+ , spArgs :: [String]+ , spWait :: Maybe Int+ , spCapture :: Maybe Capture+ , spInstance :: Maybe SandboxedProcessInstance+ }++data Capture = CaptureStdout+ | CaptureStderr+ | CaptureBoth++data SandboxedProcessInstance = RunningInstance ProcessHandle Handle (Maybe Handle)+ | StoppedInstance ExitCode (Maybe String)++pretty :: SandboxState -> String+pretty env =+ header env +++ "-- Data directory: " ++ ssDataDir env ++ "\n\+ \-- Allocated ports: " ++ unwords (map show $ M.assocs $ ssAllocatedPorts env) ++ "\n\+ \-- Configuration files: " ++ unwords (M.elems $ ssFiles env) ++ "\n\+ \-- Registered processes: " ++ unwords (ssProcessOrder env)+ ++ footer++header :: SandboxState -> String+header te =+ "##------------------------------------------------------------------------------\n\+ \ ## " ++ title ++ replicate (72 - length title) ' ' ++ " --\n\+ \## ##---------------------------------------------------------------------------\n"+ where title = ssName te ++ " end-to-end test environment"++footer :: String+footer =+ "\n--------------------------------------------------------------------------------\n"++newSandboxState :: String -> FilePath -> IO SandboxState+newSandboxState name dir = do+ gen <- newStdGen+ let availablePorts = shuffle' userPorts (length userPorts) gen+ where userPorts = [49152..65535]+ return $ SandboxState name dir M.empty [] M.empty availablePorts M.empty M.empty++registerProcess ::+ String -> FilePath -> [String] -> Maybe Int -> Maybe Capture+ -> Sandbox SandboxedProcess+registerProcess name bin args wait capture = do+ env <- get+ if isJust (M.lookup name (ssProcesses env)) then+ throwError $ "Process " ++ name ++ " is already registered in the test environment."+ else do let sp = SandboxedProcess name bin args wait capture Nothing+ put env { ssProcesses = M.insert name sp (ssProcesses env)+ , ssProcessOrder = ssProcessOrder env ++ [name] }+ return sp++getProcess :: String -> Sandbox SandboxedProcess+getProcess name = do+ env <- Sandbox get+ case M.lookup name (ssProcesses env) of+ Just sp -> let spi = spInstance sp in+ case spi of+ Just (RunningInstance ph _ oh) -> do+ ec <- liftIO $ getProcessExitCode ph+ case ec of+ Just ec' -> do -- Process is dead; update the environment+ o <- case oh of+ Just oh' -> liftM Just $ liftIO $ hGetContents oh'+ Nothing -> return Nothing+ let sp' = sp { spInstance = Just $ StoppedInstance ec' o }+ updateProcess sp'+ return sp'+ Nothing -> return sp+ _ -> return sp+ _ -> throwError $ "Process " ++ name ++ " is not registered in the test environment."++updateProcess :: SandboxedProcess -> Sandbox SandboxedProcess+updateProcess sp = do+ env <- get+ put env { ssProcesses = M.insert (spName sp) sp (ssProcesses env) }+ return sp++secondInµs :: Int+secondInµs = 1000000++setFile' :: String -> String -> SandboxState -> IO (FilePath, SandboxState)+setFile' name contents env = do+ (f, h) <- openTempFile (ssDataDir env) name+ hPutStr h contents+ hClose h+ return (f, env { ssFiles = M.insert name f (ssFiles env) })++bufferSize :: Int+bufferSize = 4096++hReadWithTimeout :: Handle -> Int -> Sandbox ByteString+hReadWithTimeout h timeout = do+ dataAvailable <- liftIO $ hWaitForInput h timeout `catch` checkEOF+ if dataAvailable then do b <- liftIO $ B.hGetNonBlocking h bufferSize+ b' <- hReadWithTimeout h timeout `catchError` (\_ -> return $ B.pack [])+ return $ B.append b b' -- TODO: Rewrite as terminal recursive+ else throwError $ "No data after " ++ show timeout ++ "ms timeout."+ where+ checkEOF :: IOError -> IO Bool+ checkEOF e = if isEOFError e then do threadDelay $ timeout * 1000+ liftM not $ hIsEOF h+ else return True++sendToPort :: String -> String -> Int -> Sandbox String+sendToPort name input timeout = do+ env <- get+ case M.lookup name (ssAllocatedPorts env) of+ Nothing -> throwError $ "No such allocated port: " ++ name+ Just port -> do h <- liftIO . withSocketsDo $ connectTo "localhost" $ PortNumber port+ liftIO $ do B.hPutStr h $ B.pack input+ hFlush h+ b <- hReadWithTimeout h timeout+ liftIO $ hClose h+ return $! B.unpack b++getNewPort :: String -> Sandbox PortNumber+getNewPort name = do+ env <- get+ case ssAvailablePorts env of+ [] -> throwError "No user ports left."+ ports -> do (port, ports') <- liftIO $ takeBindablePort' ports+ put env { ssAllocatedPorts = M.insert name port $ ssAllocatedPorts env+ , ssAvailablePorts = ports' }+ return port+ where takeBindablePort' pl = do+ pl' <- dropWhileM (liftM not . isBindable) pl+ return (head pl', tail pl')++isBindable :: PortNumber -> IO Bool+isBindable p = withSocketsDo $ do+ s <- socket AF_INET Stream defaultProtocol+ localhost <- inet_addr "127.0.0.1"+ let sa = SockAddrInet p localhost+ r <- (bind s sa >> isBound s)+ `catch` ((\_ -> return False) :: SomeException -> IO Bool)+ close s+ return $! r++startProcess :: SandboxedProcess -> Sandbox SandboxedProcess+startProcess sp =+ case spInstance sp of+ Nothing -> startProcess'+ Just (RunningInstance {}) -> return sp+ Just (StoppedInstance {}) -> startProcess'+ where+ startProcess' :: Sandbox SandboxedProcess+ startProcess' = do+ bin <- getProcessBinary sp+ args <- mapM (liftIO . expand) $ spArgs sp+ (hOutRO, hOutRW, hErrRW) <- case spCapture sp of+ Just co -> liftIO $ do (pRO, pRW) <- createPipe+ hRO <- fdToHandle pRO+ hRW <- fdToHandle pRW+ case co of+ CaptureStdout -> return (Just hRO, UseHandle hRW, Inherit)+ CaptureStderr -> return (Just hRO, Inherit, UseHandle hRW)+ CaptureBoth -> return (Just hRO, UseHandle hRW, UseHandle hRW)+ Nothing -> return (Nothing, Inherit, Inherit)+ (Just ih, _, _, ph) <- liftIO $ createProcess $ (proc bin args) { std_in = CreatePipe+ , std_out = hOutRW+ , std_err = hErrRW }+ when (isJust $ spWait sp) $ liftIO . threadDelay $ fromJust (spWait sp) * secondInµs+ errno <- liftIO $ getProcessExitCode ph+ case errno of+ Nothing -> updateProcess sp { spInstance = Just $ RunningInstance ph ih hOutRO }+ Just errno' -> throwError $ "Process " ++ spName sp ++ " not running.\n\+ \ - command-line: " ++ formatCommandLine bin args ++ "\n\+ \ - exit code: " ++ show errno' ++formatCommandLine :: String -> [String] -> String+formatCommandLine bin args = unwords $ bin : args++stopProcess :: SandboxedProcess -> Sandbox SandboxedProcess+stopProcess sp =+ case spInstance sp of+ Just (RunningInstance ph _ _) -> do+ let wait = if isNothing $ spWait sp then 50000 else fromJust (spWait sp) * secondInµs `div` 5+ liftIO $ do terminateProcess ph+ threadDelay wait+ stillRunning <- liftM isNothing $ liftIO $ getProcessExitCode ph+ when stillRunning $ liftIO $ killProcess ph+ stopProcess =<< getProcess (spName sp)+ _ -> return sp++hSignalProcess :: Signal -> ProcessHandle -> IO ()+hSignalProcess s h = do+ pid <- hGetProcessID h+ signalProcess s pid++killProcess :: ProcessHandle -> IO ()+killProcess = hSignalProcess sigKILL++hGetProcessID :: ProcessHandle -> IO ProcessID+hGetProcessID h = withProcessHandle h $ \x ->+ case x of+ OpenHandle pid -> return (x, pid)+ _ -> throwIO $ userError "Unable to retrieve child process ID."++interactWithProcess :: SandboxedProcess -> String -> Int -> Sandbox String+interactWithProcess sp input timeout = do+ hIn <- getProcessInputHandle sp+ hOut <- getProcessCapturedOutputHandle sp+ liftIO $ do B.hPutStr hIn $ B.pack input+ hFlush hIn+ b <- hReadWithTimeout hOut timeout+ return $! B.unpack b++getProcessInputHandle :: SandboxedProcess -> Sandbox Handle+getProcessInputHandle sp =+ case spInstance sp of+ Just (RunningInstance _ ih _) -> return ih+ _ -> throwError $ "No such handle for " ++ spName sp ++ ". \+ \Is the process started?"++getProcessCapturedOutputHandle :: SandboxedProcess -> Sandbox Handle+getProcessCapturedOutputHandle sp =+ case spInstance sp of+ Just (RunningInstance _ _ (Just oh)) -> return oh+ _ -> throwError $ "No captured output handle for " ++ spName sp ++ ". \+ \Is capture activated?"++getProcessBinary :: SandboxedProcess -> Sandbox FilePath+getProcessBinary sp = do+ existing <- liftIO $ findExecutables bins+ case existing of+ exBin:_ -> return exBin+ [] -> throwError $ "Unable to find the executable for the test process \""+ ++ spName sp ++ "\"\r\n\+ \Considered paths were: " ++ show bins+ where bins = getProcessCandidateBinaries sp++findExecutables :: [FilePath] -> IO [FilePath]+findExecutables paths =+ liftM catMaybes $ join $ liftM (mapM tryBinary) $ mapM expand paths++tryBinary :: FilePath -> IO (Maybe FilePath)+tryBinary bin = do+ bin' <- tryIOError . canonicalizePath =<< expand bin+ case bin' of+ Left _ -> findExecutable bin+ Right bin'' -> findExecutable bin''++getProcessCandidateBinaries :: SandboxedProcess -> [FilePath]+getProcessCandidateBinaries sp =+ [ userBinary, binary, cwdBinary, pathBinary ]+ where binary = spBinary sp+ pathBinary = takeFileName binary+ cwdBinary = "." </> pathBinary+ userBinary = '$' : map toUpper (spName sp ++ "_bin")++expand :: String -> IO String+expand s =+ if '$' `elem` s then expandShell s+ else return s+ where+ expandShell :: String -> IO String+ expandShell p = do+ (_, Just outH, _, _) <- createProcess $+ (shell $ "echo " ++ p) { std_out = CreatePipe }+ liftM (takeWhile (`notElem` "\r\n")) $ hGetContents outH++whenM :: Monad m => m Bool -> m () -> m ()+whenM = (. flip when) . (>>=)++-- | Sets a custom variable in the sandbox monad.+setVariable :: Serialize a+ => String -- ^ Variable key for future reference+ -> a -- ^ Variable value+ -> Sandbox a+setVariable name new = Sandbox $ do+ env <- lift get+ lift . put $ env { ssVariables = M.insert name (encode new) (ssVariables env) }+ return new++-- | Checks that a custom sandbox variable is set.+checkVariable :: String -- ^ Variable key+ -> Sandbox Bool+checkVariable name = Sandbox $ do+ env <- lift get+ return $ M.member name $ ssVariables env++-- | Returns the value of a previously set sandbox variable (or a provided default value if unset)+getVariable :: Serialize a+ => String -- ^ Variable key+ -> a -- ^ Default value if not found+ -> Sandbox a+getVariable name defval = Sandbox $ do+ env <- lift get+ let var = case M.lookup name $ ssVariables env of+ Nothing -> Right defval+ Just var' -> decode var'+ either throwError return var++-- | Unsets a custom variable.+unsetVariable :: String -- ^ Variable key+ -> Sandbox ()+unsetVariable name = Sandbox $ do+ env <- lift get+ lift . put $ env { ssVariables = M.delete name $ ssVariables env }++isVerbose :: Sandbox Bool+isVerbose = getVariable verbosityKey True++verbosityKey :: String+verbosityKey = "__VERBOSITY__"++displayBanner :: Sandbox ()+displayBanner = do+ displayed <- checkVariable var+ unless displayed $ Sandbox $ lift get >>= liftIO . putStrLn . pretty+ void $ setVariable var True+ where var = "__BANNER__DISPLAYED__"++-- Structures to store Sandbox options for future use.+-- Not expected to be used directly by the user.++data SandboxSeed = SandboxFixedSeed Int+ | SandboxRandomSeed+ deriving (Generic)++instance Serialize (SandboxSeed)++data SandboxTestOptions = SandboxTestOptions {+ stoSeed :: Maybe SandboxSeed+ , stoMaximumGeneratedTests :: Maybe Int+ , stoMaximumUnsuitableGeneratedTests :: Maybe Int+ , stoMaximumTestSize :: Maybe Int+ } deriving (Generic)++instance Serialize (SandboxTestOptions)++putOptions :: SandboxTestOptions -> Sandbox ()+putOptions = void . setVariable optionsVariable . Just++getOptions :: Sandbox (Maybe SandboxTestOptions)+getOptions = getVariable optionsVariable Nothing++optionsVariable :: String+optionsVariable = "__TEST_OPTIONS__"
+ test-sandbox.cabal view
@@ -0,0 +1,27 @@+Name: test-sandbox+Version: 0.0.1+Cabal-Version: >= 1.14+Category: Testing+Synopsis: Sandbox for system tests+Description: Allows starting and stopping previously registered programs in a sandboxed environment.+ This package provides functions to easily communicate with the aforementioned processes+ via TCP or standard input/output.+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.Sandbox+ Test.Sandbox.Internals++ Build-Depends: base >=4 && <5, bytestring, cereal, containers,+ data-default, directory, filepath, lifted-base,+ monad-control, monad-loops, mtl, network, process,+ random, random-shuffle, temporary, transformers,+ transformers-base, unix++ Hs-source-dirs: src++ Default-Language: Haskell2010