{-#LANGUAGE ScopedTypeVariables#-}
module Test.Sandbox (
Sandbox
, ProcessSettings (..)
, def
, Capture (..)
, sandbox
, withSandbox
, runSandbox
, runSandbox'
, register
, run
, withProcess
, start
, startAll
, stop
, stopAll
, signal
, silently
, interactWith
, sendTo
, readLastCapturedOutput
, getHandles
, getPort
, getBinary
, setPort
, getFile
, setFile
, getDataDir
, checkVariable
, getVariable
, setVariable
, unsetVariable
, withVariable
, bracket
, catchError
, finally
, throwError
, 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
sandbox :: String
-> Sandbox a
-> 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
data ProcessSettings =
ProcessSettings {
ProcessSettings -> Maybe Int
psWait :: Maybe Int
, ProcessSettings -> Maybe Capture
psCapture :: Maybe Capture
} |
ProcessSettings2 {
psWait :: Maybe Int
, psCapture :: Maybe Capture
, ProcessSettings -> Maybe [(String, String)]
psEnv :: Maybe [(String,String)]
, ProcessSettings -> Maybe String
psCwd :: Maybe FilePath
}
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
register :: String
-> FilePath
-> [String]
-> ProcessSettings
-> 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
sendTo :: String
-> String
-> Int
-> Sandbox String
sendTo :: String -> String -> Int -> Sandbox String
sendTo = String -> String -> Int -> Sandbox String
sendToPort
withProcess :: String
-> Sandbox a
-> 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)
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)
start :: String
-> 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."
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
stop :: String
-> 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
signal :: String
-> Signal
-> 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."
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."
getBinary :: String
-> 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
getHandles :: String
-> 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)
readLastCapturedOutput :: String
-> 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
interactWith :: String
-> String
-> Int
-> 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
getPort :: String
-> 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
setPort :: String
-> Int
-> 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
setFile :: String
-> String
-> 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
getFile :: String
-> 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."
withVariable :: (Serialize a)
=> String
-> a
-> Sandbox b
-> 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)
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
silently :: Sandbox a
-> 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