{-#LANGUAGE ScopedTypeVariables#-}
{- |
   Module    : Test.Sandbox
   Maintainer: Benjamin Surma <benjamin.surma@gmail.com>

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
  , withSandbox

  -- * Calling sandbox on IO
  , runSandbox
  , runSandbox'

  -- * 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
  , checkVariable
  , getVariable
  , setVariable
  , unsetVariable
  , withVariable

  -- * Sandbox exception handling
  , bracket
  , catchError
  , finally
  , throwError

  -- * Sandbox I/O handling
  , liftIO
  ) where

import Control.Concurrent (threadDelay)
import Control.Exception.Lifted
import Control.Monad
import Control.Monad.Trans (liftIO)
import Control.Monad.Reader (ask)
import Control.Monad.Error.Class (catchError, throwError)
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 Prelude hiding (error)
import System.Exit
import System.IO
import System.IO.Temp
import System.Posix hiding (release)
import System.Environment

import Test.Sandbox.Internals

cleanUp :: Sandbox ()
cleanUp :: Sandbox ()
cleanUp = do
  Sandbox ()
stopAll
  ExceptT String (ReaderT SandboxStateRef IO) Bool
-> Sandbox () -> Sandbox ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ExceptT String (ReaderT SandboxStateRef IO) Bool
isCleanUp (Sandbox () -> Sandbox ()) -> Sandbox () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ do
    Sandbox ()
cleanUpProcesses

-- | 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 :: String -> Sandbox a -> IO a
sandbox String
name Sandbox a
actions = String -> (String -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory (String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_") ((String -> IO a) -> IO a) -> (String -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
  SandboxStateRef
env <- String -> String -> IO SandboxStateRef
newSandboxState String
name String
dir
  Sandbox a -> SandboxStateRef -> IO (Either String a)
forall a. Sandbox a -> SandboxStateRef -> IO (Either String a)
runSandbox (Sandbox a
actions Sandbox a -> Sandbox () -> Sandbox a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
m a -> m b -> m a
`finally` Sandbox ()
cleanUp) SandboxStateRef
env IO (Either String a) -> (Either String a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO a) -> (a -> IO a) -> Either String a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    (\String
error -> do Handle -> String -> IO ()
hPutStrLn Handle
stderr String
error
                  IOError -> IO a
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (IOError -> IO a) -> IOError -> IO a
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
error)
    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return

withSandbox :: (SandboxStateRef -> IO a) -> IO a
withSandbox :: (SandboxStateRef -> IO a) -> IO a
withSandbox SandboxStateRef -> IO a
actions = do
  String
name <- IO String
getProgName
  String -> Sandbox a -> IO a
forall a. String -> Sandbox a -> IO a
sandbox String
name (Sandbox a -> IO a) -> Sandbox a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    SandboxStateRef
ref <- ExceptT String (ReaderT SandboxStateRef IO) SandboxStateRef
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO a -> Sandbox a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Sandbox a) -> IO a -> Sandbox a
forall a b. (a -> b) -> a -> b
$ SandboxStateRef -> IO a
actions SandboxStateRef
ref

-- | Optional parameters when registering a process in the Sandbox monad.
data ProcessSettings =
  ProcessSettings {
    ProcessSettings -> Maybe Int
psWait :: Maybe Int        -- ^ Time to wait (in s.) before checking that the process is still up
  , ProcessSettings -> Maybe Capture
psCapture :: Maybe Capture -- ^ Which outputs to capture (if any)
  } |
  ProcessSettings2 {
    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)
  , ProcessSettings -> Maybe [(String, String)]
psEnv :: Maybe [(String,String)] -- ^ Environment variables
  , ProcessSettings -> Maybe String
psCwd :: Maybe FilePath          -- ^ Working directory for the new process
  }

instance Default ProcessSettings where
  def :: ProcessSettings
def = Maybe Int
-> Maybe Capture
-> Maybe [(String, String)]
-> Maybe String
-> ProcessSettings
ProcessSettings2 (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) Maybe Capture
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
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 :: String -> String -> [String] -> ProcessSettings -> Sandbox String
register String
name String
bin [String]
args (ProcessSettings Maybe Int
wait Maybe Capture
capture) =
  String
-> String
-> [String]
-> Maybe Int
-> Maybe Capture
-> Maybe [(String, String)]
-> Maybe String
-> Sandbox SandboxedProcess
registerProcess String
name String
bin [String]
args Maybe Int
wait Maybe Capture
capture Maybe [(String, String)]
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing Sandbox SandboxedProcess -> Sandbox String -> Sandbox String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Sandbox String
forall (m :: * -> *) a. Monad m => a -> m a
return String
name
register String
name String
bin [String]
args (ProcessSettings2 Maybe Int
wait Maybe Capture
capture Maybe [(String, String)]
env Maybe String
cwd) =
  String
-> String
-> [String]
-> Maybe Int
-> Maybe Capture
-> Maybe [(String, String)]
-> Maybe String
-> Sandbox SandboxedProcess
registerProcess String
name String
bin [String]
args Maybe Int
wait Maybe Capture
capture Maybe [(String, String)]
env Maybe String
cwd Sandbox SandboxedProcess -> Sandbox String -> Sandbox String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Sandbox String
forall (m :: * -> *) a. Monad m => a -> m a
return String
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 :: String -> String -> Int -> Sandbox String
sendTo = String -> String -> Int -> Sandbox String
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 :: String -> Sandbox a -> Sandbox a
withProcess String
name Sandbox a
action = Sandbox () -> (() -> Sandbox ()) -> (() -> Sandbox a) -> Sandbox a
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (String -> Sandbox ()
start String
name) (Sandbox () -> () -> Sandbox ()
forall a b. a -> b -> a
const (Sandbox () -> () -> Sandbox ()) -> Sandbox () -> () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ String -> Sandbox ()
stop String
name) (Sandbox a -> () -> Sandbox a
forall a b. a -> b -> a
const Sandbox a
action)

-- | Helper function: starts a process, wait for it to terminate and return its captured output.
run :: String -> Int -> Sandbox (ExitCode, Maybe String)
run :: String -> Int -> Sandbox (ExitCode, Maybe String)
run String
name Int
timeout = do
  Sandbox () -> Sandbox ()
forall a. Sandbox a -> Sandbox a
silently (Sandbox () -> Sandbox ()) -> Sandbox () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ String -> Sandbox ()
start String
name
  String -> Int -> Sandbox (ExitCode, Maybe String)
waitFor String
name Int
timeout Sandbox (ExitCode, Maybe String)
-> (String -> Sandbox (ExitCode, Maybe String))
-> Sandbox (ExitCode, Maybe String)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (\String
e -> Sandbox () -> Sandbox ()
forall a. Sandbox a -> Sandbox a
silently (String -> Sandbox ()
stop String
name) Sandbox ()
-> Sandbox (ExitCode, Maybe String)
-> Sandbox (ExitCode, Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Sandbox (ExitCode, Maybe String)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
e)

-- | Starts a previously registered process (verbose)
start :: String     -- ^ Process name
      -> Sandbox ()
start :: String -> Sandbox ()
start String
process = Sandbox () -> Sandbox ()
forall (m :: * -> *) a. MonadBaseControl IO m => m a -> m a
uninterruptibleMask_ (Sandbox () -> Sandbox ()) -> Sandbox () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ do
  Sandbox ()
installSignalHandlers
  Sandbox ()
displayBanner
  SandboxedProcess
sp <- String -> Sandbox SandboxedProcess
getProcess String
process
  ExceptT String (ReaderT SandboxStateRef IO) Bool
-> Sandbox () -> Sandbox ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ExceptT String (ReaderT SandboxStateRef IO) Bool
isVerbose (Sandbox () -> Sandbox ()) -> Sandbox () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ IO () -> Sandbox ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Sandbox ()) -> IO () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr (String
"Starting process " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
process String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"... ") IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
  SandboxedProcess
_ <- SandboxedProcess -> Sandbox SandboxedProcess
updateProcess (SandboxedProcess -> Sandbox SandboxedProcess)
-> Sandbox SandboxedProcess -> Sandbox SandboxedProcess
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SandboxedProcess -> Sandbox SandboxedProcess
startProcess SandboxedProcess
sp
  ExceptT String (ReaderT SandboxStateRef IO) Bool
-> Sandbox () -> Sandbox ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ExceptT String (ReaderT SandboxStateRef IO) Bool
isVerbose (Sandbox () -> Sandbox ()) -> Sandbox () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ IO () -> Sandbox ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Sandbox ()) -> IO () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Done."

-- | Starts all registered processes (in their registration order)
startAll :: Sandbox ()
startAll :: Sandbox ()
startAll = Sandbox () -> Sandbox ()
forall (m :: * -> *) a. MonadBaseControl IO m => m a -> m a
uninterruptibleMask_ (Sandbox () -> Sandbox ()) -> Sandbox () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ do
  Sandbox ()
displayBanner
  ExceptT String (ReaderT SandboxStateRef IO) Bool
-> Sandbox () -> Sandbox ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ExceptT String (ReaderT SandboxStateRef IO) Bool
isVerbose (Sandbox () -> Sandbox ()) -> Sandbox () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ IO () -> Sandbox ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Sandbox ()) -> IO () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Starting all sandbox processes... " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
  Sandbox () -> Sandbox ()
forall a. Sandbox a -> Sandbox a
silently (Sandbox () -> Sandbox ()) -> Sandbox () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ do SandboxState
env <- Sandbox SandboxState
get
                (String -> Sandbox ()) -> [String] -> Sandbox ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Sandbox ()
start (SandboxState -> [String]
ssProcessOrder SandboxState
env)
  ExceptT String (ReaderT SandboxStateRef IO) Bool
-> Sandbox () -> Sandbox ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ExceptT String (ReaderT SandboxStateRef IO) Bool
isVerbose (Sandbox () -> Sandbox ()) -> Sandbox () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ IO () -> Sandbox ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Sandbox ()) -> IO () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Done."

waitFor :: String -> Int -> Sandbox (ExitCode, Maybe String)
waitFor :: String -> Int -> Sandbox (ExitCode, Maybe String)
waitFor String
name Int
timeout = Int -> Sandbox (ExitCode, Maybe String)
waitFor' Int
0
  where waitFor' :: Int -> Sandbox (ExitCode, Maybe String)
waitFor' Int
tick = do
          SandboxedProcess
sp <- String -> Sandbox SandboxedProcess
getProcess String
name
          case SandboxedProcess -> Maybe SandboxedProcessInstance
spInstance SandboxedProcess
sp of
            Just (StoppedInstance ExitCode
ec Maybe String
o) -> (ExitCode, Maybe String) -> Sandbox (ExitCode, Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ec, Maybe String
o)
            Maybe SandboxedProcessInstance
_ -> if Int
tick Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
timeout then String -> Sandbox (ExitCode, Maybe String)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Sandbox (ExitCode, Maybe String))
-> String -> Sandbox (ExitCode, Maybe String)
forall a b. (a -> b) -> a -> b
$ String
"Process " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" still running after " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
timeout String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"s timeout."
                   else do IO () -> Sandbox ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Sandbox ()) -> IO () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
secondInµs
                           Int -> Sandbox (ExitCode, Maybe String)
waitFor' (Int -> Sandbox (ExitCode, Maybe String))
-> Int -> Sandbox (ExitCode, Maybe String)
forall a b. (a -> b) -> a -> b
$! Int
tick Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

-- | Gracefully stops a previously started process (verbose)
stop :: String     -- ^ Process name
     -> Sandbox ()
stop :: String -> Sandbox ()
stop String
process = Sandbox () -> Sandbox ()
forall (m :: * -> *) a. MonadBaseControl IO m => m a -> m a
uninterruptibleMask_ (Sandbox () -> Sandbox ()) -> Sandbox () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ do
  SandboxedProcess
sp <- String -> Sandbox SandboxedProcess
getProcess String
process
  ExceptT String (ReaderT SandboxStateRef IO) Bool
-> Sandbox () -> Sandbox ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ExceptT String (ReaderT SandboxStateRef IO) Bool
isVerbose (Sandbox () -> Sandbox ()) -> Sandbox () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ IO () -> Sandbox ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Sandbox ()) -> IO () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String
"Stopping process " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
process String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"("String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe ProcessID -> String
forall a. Show a => a -> String
show (SandboxedProcess -> Maybe ProcessID
spPid SandboxedProcess
sp) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")... ") IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
  SandboxedProcess
_ <- SandboxedProcess -> Sandbox SandboxedProcess
updateProcess (SandboxedProcess -> Sandbox SandboxedProcess)
-> Sandbox SandboxedProcess -> Sandbox SandboxedProcess
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SandboxedProcess -> Sandbox SandboxedProcess
stopProcess SandboxedProcess
sp
  ExceptT String (ReaderT SandboxStateRef IO) Bool
-> Sandbox () -> Sandbox ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ExceptT String (ReaderT SandboxStateRef IO) Bool
isVerbose (Sandbox () -> Sandbox ()) -> Sandbox () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ IO () -> Sandbox ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Sandbox ()) -> IO () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Done." IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout

-- | Sends a POSIX signal to a process
signal :: String     -- ^ Process name
       -> Signal     -- ^ Signal to send
       -> Sandbox ()
signal :: String -> Signal -> Sandbox ()
signal String
process Signal
sig = Sandbox () -> Sandbox ()
forall (m :: * -> *) a. MonadBaseControl IO m => m a -> m a
uninterruptibleMask_ (Sandbox () -> Sandbox ()) -> Sandbox () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ do
  SandboxedProcess
sp <- String -> Sandbox SandboxedProcess
getProcess String
process
  case SandboxedProcess -> Maybe SandboxedProcessInstance
spInstance SandboxedProcess
sp of
    Just (RunningInstance ProcessHandle
ph Handle
_ Maybe Handle
_ [Handle]
_) -> IO () -> Sandbox ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Sandbox ()) -> IO () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ Signal -> ProcessHandle -> IO ()
hSignalProcess Signal
sig ProcessHandle
ph
    Maybe SandboxedProcessInstance
_ -> String -> Sandbox ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Sandbox ()) -> String -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ String
"Process " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
process String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not running."

-- | Gracefully stops all registered processes (in their reverse registration order)
stopAll :: Sandbox ()
stopAll :: Sandbox ()
stopAll = Sandbox () -> Sandbox ()
forall (m :: * -> *) a. MonadBaseControl IO m => m a -> m a
uninterruptibleMask_ (Sandbox () -> Sandbox ()) -> Sandbox () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ do
  ExceptT String (ReaderT SandboxStateRef IO) Bool
-> Sandbox () -> Sandbox ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ExceptT String (ReaderT SandboxStateRef IO) Bool
isVerbose (Sandbox () -> Sandbox ()) -> Sandbox () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ IO () -> Sandbox ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Sandbox ()) -> IO () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
"Stopping all sandbox processes... " IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
  SandboxState
env <- Sandbox SandboxState
get
  (String -> Sandbox ()) -> [String] -> Sandbox ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Sandbox ()
stop ([String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ SandboxState -> [String]
ssProcessOrder SandboxState
env)
  ExceptT String (ReaderT SandboxStateRef IO) Bool
-> Sandbox () -> Sandbox ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ExceptT String (ReaderT SandboxStateRef IO) Bool
isVerbose (Sandbox () -> Sandbox ()) -> Sandbox () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ IO () -> Sandbox ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Sandbox ()) -> IO () -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Done."

-- | Returns the effective binary path of a registered process.
getBinary :: String           -- ^ Process name
          -> Sandbox FilePath
getBinary :: String -> Sandbox String
getBinary String
process = String -> Sandbox SandboxedProcess
getProcess String
process Sandbox SandboxedProcess
-> (SandboxedProcess -> Sandbox String) -> Sandbox String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SandboxedProcess -> Sandbox String
getProcessBinary

-- | Returns the handles used to communicate with a registered process using standard I/O.
getHandles :: String                   -- ^ Process name
           -> Sandbox (Handle, Handle)
getHandles :: String -> Sandbox (Handle, Handle)
getHandles String
process = do
  SandboxedProcess
sp <- String -> Sandbox SandboxedProcess
getProcess String
process
  Handle
input <- SandboxedProcess -> Sandbox Handle
getProcessInputHandle SandboxedProcess
sp
  Handle
output <- SandboxedProcess -> Sandbox Handle
getProcessCapturedOutputHandle SandboxedProcess
sp
  (Handle, Handle) -> Sandbox (Handle, Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
input, Handle
output)

-- | Returns the last captured output of a started process.
readLastCapturedOutput :: String         -- ^ Process name
                       -> Sandbox String
readLastCapturedOutput :: String -> Sandbox String
readLastCapturedOutput String
process = do
  SandboxedProcess
sp <- String -> Sandbox SandboxedProcess
getProcess String
process
  Handle
h <- SandboxedProcess -> Sandbox Handle
getProcessCapturedOutputHandle SandboxedProcess
sp
  ByteString
b <- Handle -> Int -> Sandbox ByteString
hReadWithTimeout Handle
h Int
0
  String -> Sandbox String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Sandbox String) -> String -> Sandbox String
forall a b. (a -> b) -> a -> b
$! ByteString -> String
B.unpack ByteString
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 :: String -> String -> Int -> Sandbox String
interactWith String
process String
input Int
timeout = do
  SandboxedProcess
sp <- String -> Sandbox SandboxedProcess
getProcess String
process
  SandboxedProcess -> String -> Int -> Sandbox String
interactWithProcess SandboxedProcess
sp String
input Int
timeout

-- | Returns an unbound user TCP port and stores it for future reference.
getPort :: String             -- ^ Port name for future reference
        -> Sandbox Port
getPort :: String -> Sandbox Int
getPort String
name = do
  SandboxState
env <- Sandbox SandboxState
get
  case String -> Map String Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
name (Map String Int -> Maybe Int) -> Map String Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ SandboxState -> Map String Int
ssAllocatedPorts SandboxState
env of
    Just Int
port -> Int -> Sandbox Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
port
    Maybe Int
Nothing -> String -> Sandbox Int
getNewPort String
name

-- | Explicitely sets a port to be returned by getPort.
setPort :: String             -- ^ Port name for future reference
        -> Int                -- ^ TCP port number
        -> Sandbox Port
setPort :: String -> Int -> Sandbox Int
setPort String
name Int
port = do
  let port' :: Int
port' = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port
  Bool
bindable <- IO Bool -> ExceptT String (ReaderT SandboxStateRef IO) Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT String (ReaderT SandboxStateRef IO) Bool)
-> IO Bool -> ExceptT String (ReaderT SandboxStateRef IO) Bool
forall a b. (a -> b) -> a -> b
$ Int -> IO Bool
isBindable (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port)
  if Bool
bindable then do SandboxState
env <- Sandbox SandboxState
get
                      SandboxState
_ <- SandboxState -> Sandbox SandboxState
put (SandboxState
env { ssAllocatedPorts :: Map String Int
ssAllocatedPorts = String -> Int -> Map String Int -> Map String Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
name Int
port' (Map String Int -> Map String Int)
-> Map String Int -> Map String Int
forall a b. (a -> b) -> a -> b
$ SandboxState -> Map String Int
ssAllocatedPorts SandboxState
env })
                      Int -> Sandbox Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
port'
    else String -> Sandbox Int
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Sandbox Int) -> String -> Sandbox Int
forall a b. (a -> b) -> a -> b
$ String
"Unable to bind port " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
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 :: String -> String -> Sandbox String
setFile String
name String
contents = do
  SandboxState
env <- Sandbox SandboxState
get
  (String
file, SandboxState
env') <- IO (String, SandboxState)
-> ExceptT
     String (ReaderT SandboxStateRef IO) (String, SandboxState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (String, SandboxState)
 -> ExceptT
      String (ReaderT SandboxStateRef IO) (String, SandboxState))
-> IO (String, SandboxState)
-> ExceptT
     String (ReaderT SandboxStateRef IO) (String, SandboxState)
forall a b. (a -> b) -> a -> b
$ String -> String -> SandboxState -> IO (String, SandboxState)
setFile' String
name String
contents SandboxState
env
  SandboxState
_ <- SandboxState -> Sandbox SandboxState
put SandboxState
env'
  String -> Sandbox String
forall (m :: * -> *) a. Monad m => a -> m a
return String
file

-- | Returns the path of a file previously created by setFile.
getFile :: String           -- ^ File name used during setFile
        -> Sandbox FilePath
getFile :: String -> Sandbox String
getFile String
name = do
  SandboxState
env <- Sandbox SandboxState
get
  case String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
name (Map String String -> Maybe String)
-> Map String String -> Maybe String
forall a b. (a -> b) -> a -> b
$ SandboxState -> Map String String
ssFiles SandboxState
env of
    Just String
file -> String -> Sandbox String
forall (m :: * -> *) a. Monad m => a -> m a
return String
file
    Maybe String
Nothing -> String -> Sandbox String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Sandbox String) -> String -> Sandbox String
forall a b. (a -> b) -> a -> b
$ String
"Config file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not exist."

-- | 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 :: String -> a -> Sandbox b -> Sandbox b
withVariable String
key a
value Sandbox b
action = ExceptT String (ReaderT SandboxStateRef IO) (Maybe ByteString)
-> (Maybe ByteString -> Sandbox ())
-> (Maybe ByteString -> Sandbox b)
-> Sandbox b
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (do SandboxState
env <- Sandbox SandboxState
get
                                            let old :: Maybe ByteString
old = String -> Map String ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
key (Map String ByteString -> Maybe ByteString)
-> Map String ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ SandboxState -> Map String ByteString
ssVariables SandboxState
env
                                            a
_ <- String -> a -> Sandbox a
forall a. Serialize a => String -> a -> Sandbox a
setVariable String
key a
value
                                            Maybe ByteString
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
old)
                                        (\Maybe ByteString
old -> case Maybe ByteString
old of
                                                   Maybe ByteString
Nothing -> String -> Sandbox ()
unsetVariable String
key
                                                   Just ByteString
old' -> Sandbox ByteString -> Sandbox ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sandbox ByteString -> Sandbox ())
-> Sandbox ByteString -> Sandbox ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> Sandbox ByteString
forall a. Serialize a => String -> a -> Sandbox a
setVariable String
key ByteString
old')
                                        (Sandbox b -> Maybe ByteString -> Sandbox b
forall a b. a -> b -> a
const Sandbox b
action)

-- | Returns the temporary directory used to host the sandbox environment.
getDataDir :: Sandbox FilePath
getDataDir :: Sandbox String
getDataDir = (SandboxState -> String) -> Sandbox SandboxState -> Sandbox String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM SandboxState -> String
ssDataDir Sandbox SandboxState
get

-- | Executes the given action silently.
silently :: Sandbox a -- ^ Action to execute
       -> Sandbox a
silently :: Sandbox a -> Sandbox a
silently = String -> Bool -> Sandbox a -> Sandbox a
forall a b. Serialize a => String -> a -> Sandbox b -> Sandbox b
withVariable String
verbosityKey Bool
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
-}