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/Sandbox.hs b/src/Test/Sandbox.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandbox.hs @@ -0,0 +1,454 @@ +{- | + Module : Test.Sandbox + Maintainer: Benjamin Surma + +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 +-} diff --git a/src/Test/Sandbox/Internals.hs b/src/Test/Sandbox/Internals.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandbox/Internals.hs @@ -0,0 +1,408 @@ +-- author: Benjamin Surma + +{-# 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__" diff --git a/test-sandbox.cabal b/test-sandbox.cabal new file mode 100644 --- /dev/null +++ b/test-sandbox.cabal @@ -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 +Maintainer: Benjamin Surma +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