{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Sandbox.Internals where
#if __GLASGOW_HASKELL__ <= 708
import Control.Applicative (Applicative)
#endif
import Control.Concurrent
import Control.Exception.Lifted hiding (throwTo)
import Control.Monad
#if MIN_VERSION_mtl(2,2,1)
import Control.Monad.Except (catchError, throwError)
import Control.Monad.Trans.Except (ExceptT, runExceptT)
#else
import Control.Monad.Error (catchError, throwError)
import Control.Monad.Trans.Error (ErrorT, runErrorT)
#endif
import Control.Monad.Loops
import Control.Monad.Reader (ask)
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char
import Data.IORef
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.Socket as N
import qualified Network.BSD as BSD
import qualified System.Directory as D
import System.Exit
import System.FilePath
import System.IO
import System.IO.Error (isEOFError, tryIOError)
import System.Posix hiding (killProcess)
#if MIN_VERSION_process(1,2,1)
import System.Process hiding (env, waitForProcess, createPipe)
#else
import System.Process hiding (env, waitForProcess)
#endif
import qualified System.Process as P
import System.Process.Internals (withProcessHandle, ProcessHandle__(OpenHandle))
import System.Random
import System.Random.Shuffle
import Test.Sandbox.Process
type Port = Int
type SandboxStateRef = IORef SandboxState
type Sandbox = ExceptT String (ReaderT SandboxStateRef IO)
data PortID = PortNumber N.PortNumber
runSandbox :: Sandbox a -> SandboxStateRef -> IO (Either String a)
runSandbox :: Sandbox a -> SandboxStateRef -> IO (Either String a)
runSandbox = ReaderT SandboxStateRef IO (Either String a)
-> SandboxStateRef -> IO (Either String a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT SandboxStateRef IO (Either String a)
-> SandboxStateRef -> IO (Either String a))
-> (Sandbox a -> ReaderT SandboxStateRef IO (Either String a))
-> Sandbox a
-> SandboxStateRef
-> IO (Either String a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sandbox a -> ReaderT SandboxStateRef IO (Either String a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
errorHandler :: String -> IO a
errorHandler :: String -> IO a
errorHandler 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'
runSandbox' :: SandboxStateRef -> Sandbox a -> IO a
runSandbox' :: SandboxStateRef -> Sandbox a -> IO a
runSandbox' SandboxStateRef
env' Sandbox a
action = do
Either String a
val <- Sandbox a -> SandboxStateRef -> IO (Either String a)
forall a. Sandbox a -> SandboxStateRef -> IO (Either String a)
runSandbox Sandbox a
action SandboxStateRef
env'
(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 -> IO a
forall a. String -> IO a
errorHandler a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Either String a
val
data SandboxState = SandboxState {
SandboxState -> String
ssName :: String
, SandboxState -> String
ssDataDir :: FilePath
, SandboxState -> Map String SandboxedProcess
ssProcesses :: Map String SandboxedProcess
, SandboxState -> [String]
ssProcessOrder :: [String]
, SandboxState -> Map String Port
ssAllocatedPorts :: Map String Port
, SandboxState -> [Port]
ssAvailablePorts :: [Port]
, SandboxState -> Map String String
ssFiles :: Map String FilePath
, SandboxState -> Map String ByteString
ssVariables :: Map String ByteString
}
data SandboxedProcess = SandboxedProcess {
SandboxedProcess -> String
spName :: String
, SandboxedProcess -> String
spBinary :: FilePath
, SandboxedProcess -> [String]
spArgs :: [String]
, SandboxedProcess -> Maybe Port
spWait :: Maybe Int
, SandboxedProcess -> Maybe Capture
spCapture :: Maybe Capture
, SandboxedProcess -> Maybe SandboxedProcessInstance
spInstance :: Maybe SandboxedProcessInstance
, SandboxedProcess -> Maybe ProcessID
spPid :: Maybe ProcessID
, SandboxedProcess -> Maybe ProcessID
spPGid :: Maybe ProcessGroupID
, SandboxedProcess -> [Handle]
spHandles :: [Handle]
, SandboxedProcess -> Maybe [(String, String)]
spEnvs :: Maybe [(String,String)]
, SandboxedProcess -> Maybe String
spCwd :: Maybe FilePath
}
data Capture =
CaptureStdout
| CaptureStderr
| CaptureBoth
| CaptureStdoutWithFile FilePath
| CaptureStderrWithFile FilePath
| CaptureBothWithFile FilePath FilePath
data SandboxedProcessInstance = RunningInstance ProcessHandle Handle (Maybe Handle) [Handle]
| StoppedInstance ExitCode (Maybe String)
get :: Sandbox SandboxState
get :: Sandbox SandboxState
get = ExceptT String (ReaderT SandboxStateRef IO) SandboxStateRef
forall r (m :: * -> *). MonadReader r m => m r
ask ExceptT String (ReaderT SandboxStateRef IO) SandboxStateRef
-> (SandboxStateRef -> Sandbox SandboxState)
-> Sandbox SandboxState
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO SandboxState -> Sandbox SandboxState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SandboxState -> Sandbox SandboxState)
-> (SandboxStateRef -> IO SandboxState)
-> SandboxStateRef
-> Sandbox SandboxState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SandboxStateRef -> IO SandboxState
forall a. IORef a -> IO a
readIORef
put :: SandboxState -> Sandbox SandboxState
put :: SandboxState -> Sandbox SandboxState
put SandboxState
state = do
SandboxStateRef
ref <- ExceptT String (ReaderT SandboxStateRef IO) SandboxStateRef
forall r (m :: * -> *). MonadReader r m => m r
ask
IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String (ReaderT SandboxStateRef IO) ())
-> IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ SandboxStateRef -> SandboxState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef SandboxStateRef
ref SandboxState
state
SandboxState -> Sandbox SandboxState
forall (m :: * -> *) a. Monad m => a -> m a
return SandboxState
state
pretty :: SandboxState -> String
pretty :: SandboxState -> String
pretty SandboxState
env =
SandboxState -> String
header SandboxState
env
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-- Data directory: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SandboxState -> String
ssDataDir SandboxState
env String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-- Allocated ports: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (((String, Port) -> String) -> [(String, Port)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Port) -> String
forall a. Show a => a -> String
show ([(String, Port)] -> [String]) -> [(String, Port)] -> [String]
forall a b. (a -> b) -> a -> b
$ Map String Port -> [(String, Port)]
forall k a. Map k a -> [(k, a)]
M.assocs (Map String Port -> [(String, Port)])
-> Map String Port -> [(String, Port)]
forall a b. (a -> b) -> a -> b
$ SandboxState -> Map String Port
ssAllocatedPorts SandboxState
env) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-- Configuration files: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (Map String String -> [String]
forall k a. Map k a -> [a]
M.elems (Map String String -> [String]) -> Map String String -> [String]
forall a b. (a -> b) -> a -> b
$ SandboxState -> Map String String
ssFiles SandboxState
env) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-- Registered processes: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (SandboxState -> [String]
ssProcessOrder SandboxState
env)
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
footer
header :: SandboxState -> String
SandboxState
te =
String
"\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"##------------------------------------------------------------------------------\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ## " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
title String -> String -> String
forall a. [a] -> [a] -> [a]
++ Port -> Char -> String
forall a. Port -> a -> [a]
replicate (Port
72 Port -> Port -> Port
forall a. Num a => a -> a -> a
- String -> Port
forall (t :: * -> *) a. Foldable t => t a -> Port
length String
title) Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" --\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"## ##---------------------------------------------------------------------------\n"
where title :: String
title = SandboxState -> String
ssName SandboxState
te String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" system test environment"
footer :: String
=
String
"\n--------------------------------------------------------------------------------\n"
newSandboxState :: String -> FilePath -> IO SandboxStateRef
newSandboxState :: String -> String -> IO SandboxStateRef
newSandboxState String
name String
dir = do
StdGen
gen <- IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
let availablePorts :: [Port]
availablePorts = [Port] -> Port -> StdGen -> [Port]
forall gen a. RandomGen gen => [a] -> Port -> gen -> [a]
shuffle' [Port]
userPorts ([Port] -> Port
forall (t :: * -> *) a. Foldable t => t a -> Port
length [Port]
userPorts) StdGen
gen
where userPorts :: [Port]
userPorts = [Port
5001..Port
32767]
SandboxState -> IO SandboxStateRef
forall a. a -> IO (IORef a)
newIORef (SandboxState -> IO SandboxStateRef)
-> SandboxState -> IO SandboxStateRef
forall a b. (a -> b) -> a -> b
$ String
-> String
-> Map String SandboxedProcess
-> [String]
-> Map String Port
-> [Port]
-> Map String String
-> Map String ByteString
-> SandboxState
SandboxState String
name String
dir Map String SandboxedProcess
forall k a. Map k a
M.empty [] Map String Port
forall k a. Map k a
M.empty [Port]
availablePorts Map String String
forall k a. Map k a
M.empty Map String ByteString
forall k a. Map k a
M.empty
registerProcess :: String
-> FilePath
-> [String]
-> Maybe Int
-> Maybe Capture
-> Maybe [(String,String)]
-> Maybe FilePath
-> Sandbox SandboxedProcess
registerProcess :: String
-> String
-> [String]
-> Maybe Port
-> Maybe Capture
-> Maybe [(String, String)]
-> Maybe String
-> Sandbox SandboxedProcess
registerProcess String
name String
bin [String]
args Maybe Port
wait Maybe Capture
capture Maybe [(String, String)]
process_env Maybe String
process_cwd = do
Bool
-> ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
isValidProcessName String
name) (ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ())
-> ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$
String -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ExceptT String (ReaderT SandboxStateRef IO) ())
-> String -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid process name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
SandboxState
env <- Sandbox SandboxState
get
if Maybe SandboxedProcess -> Bool
forall a. Maybe a -> Bool
isJust (String -> Map String SandboxedProcess -> Maybe SandboxedProcess
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
name (SandboxState -> Map String SandboxedProcess
ssProcesses SandboxState
env)) then
String -> Sandbox SandboxedProcess
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Sandbox SandboxedProcess)
-> String -> Sandbox SandboxedProcess
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
" is already registered in the test environment."
else do let sp :: SandboxedProcess
sp = String
-> String
-> [String]
-> Maybe Port
-> Maybe Capture
-> Maybe SandboxedProcessInstance
-> Maybe ProcessID
-> Maybe ProcessID
-> [Handle]
-> Maybe [(String, String)]
-> Maybe String
-> SandboxedProcess
SandboxedProcess String
name String
bin [String]
args Maybe Port
wait Maybe Capture
capture Maybe SandboxedProcessInstance
forall a. Maybe a
Nothing Maybe ProcessID
forall a. Maybe a
Nothing Maybe ProcessID
forall a. Maybe a
Nothing [] Maybe [(String, String)]
process_env Maybe String
process_cwd
SandboxState
_ <- SandboxState -> Sandbox SandboxState
put SandboxState
env { ssProcesses :: Map String SandboxedProcess
ssProcesses = String
-> SandboxedProcess
-> Map String SandboxedProcess
-> Map String SandboxedProcess
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
name SandboxedProcess
sp (SandboxState -> Map String SandboxedProcess
ssProcesses SandboxState
env)
, ssProcessOrder :: [String]
ssProcessOrder = SandboxState -> [String]
ssProcessOrder SandboxState
env [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
name]
}
SandboxedProcess -> Sandbox SandboxedProcess
forall (m :: * -> *) a. Monad m => a -> m a
return SandboxedProcess
sp
isValidProcessName :: String -> Bool
isValidProcessName :: String -> Bool
isValidProcessName String
s = Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s)
Bool -> Bool -> Bool
&& Char -> Bool
isAlpha (String -> Char
forall a. [a] -> a
head String
s)
Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isAllowed (String -> String
forall a. [a] -> [a]
tail String
s)
where isAllowed :: Char -> Bool
isAllowed Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| ( Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'_',Char
'-',Char
'.'] )
getProcess :: String -> Sandbox SandboxedProcess
getProcess :: String -> Sandbox SandboxedProcess
getProcess String
name = do
SandboxState
env <- Sandbox SandboxState
get
case String -> Map String SandboxedProcess -> Maybe SandboxedProcess
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
name (SandboxState -> Map String SandboxedProcess
ssProcesses SandboxState
env) of
Just SandboxedProcess
sp -> let spi :: Maybe SandboxedProcessInstance
spi = SandboxedProcess -> Maybe SandboxedProcessInstance
spInstance SandboxedProcess
sp in
case Maybe SandboxedProcessInstance
spi of
Just (RunningInstance ProcessHandle
ph Handle
_ Maybe Handle
oh [Handle]
_) -> do
Maybe ExitCode
ec <- IO (Maybe ExitCode)
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe ExitCode)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ExitCode)
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe ExitCode))
-> IO (Maybe ExitCode)
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe ExitCode)
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO (Maybe ExitCode)
getProcessExitCode ProcessHandle
ph
case Maybe ExitCode
ec of
Just ExitCode
ec' -> do
Maybe String
o <- case Maybe Handle
oh of
Just Handle
oh' -> (String -> Maybe String)
-> ExceptT String (ReaderT SandboxStateRef IO) String
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM String -> Maybe String
forall a. a -> Maybe a
Just (ExceptT String (ReaderT SandboxStateRef IO) String
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe String))
-> ExceptT String (ReaderT SandboxStateRef IO) String
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe String)
forall a b. (a -> b) -> a -> b
$ IO String -> ExceptT String (ReaderT SandboxStateRef IO) String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT String (ReaderT SandboxStateRef IO) String)
-> IO String -> ExceptT String (ReaderT SandboxStateRef IO) String
forall a b. (a -> b) -> a -> b
$ Handle -> IO String
hGetContents Handle
oh'
Maybe Handle
Nothing -> Maybe String
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
let sp' :: SandboxedProcess
sp' = SandboxedProcess
sp { spInstance :: Maybe SandboxedProcessInstance
spInstance = SandboxedProcessInstance -> Maybe SandboxedProcessInstance
forall a. a -> Maybe a
Just (SandboxedProcessInstance -> Maybe SandboxedProcessInstance)
-> SandboxedProcessInstance -> Maybe SandboxedProcessInstance
forall a b. (a -> b) -> a -> b
$ ExitCode -> Maybe String -> SandboxedProcessInstance
StoppedInstance ExitCode
ec' Maybe String
o }
SandboxedProcess
_ <- SandboxedProcess -> Sandbox SandboxedProcess
updateProcess SandboxedProcess
sp'
SandboxedProcess -> Sandbox SandboxedProcess
forall (m :: * -> *) a. Monad m => a -> m a
return SandboxedProcess
sp'
Maybe ExitCode
Nothing -> SandboxedProcess -> Sandbox SandboxedProcess
forall (m :: * -> *) a. Monad m => a -> m a
return SandboxedProcess
sp
Maybe SandboxedProcessInstance
_ -> SandboxedProcess -> Sandbox SandboxedProcess
forall (m :: * -> *) a. Monad m => a -> m a
return SandboxedProcess
sp
Maybe SandboxedProcess
_ -> String -> Sandbox SandboxedProcess
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Sandbox SandboxedProcess)
-> String -> Sandbox SandboxedProcess
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
" is not registered in the test environment."
updateProcess :: SandboxedProcess -> Sandbox SandboxedProcess
updateProcess :: SandboxedProcess -> Sandbox SandboxedProcess
updateProcess SandboxedProcess
sp = do
SandboxState
env <- Sandbox SandboxState
get
SandboxState
_ <- SandboxState -> Sandbox SandboxState
put SandboxState
env { ssProcesses :: Map String SandboxedProcess
ssProcesses = String
-> SandboxedProcess
-> Map String SandboxedProcess
-> Map String SandboxedProcess
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (SandboxedProcess -> String
spName SandboxedProcess
sp) SandboxedProcess
sp (SandboxState -> Map String SandboxedProcess
ssProcesses SandboxState
env) }
SandboxedProcess -> Sandbox SandboxedProcess
forall (m :: * -> *) a. Monad m => a -> m a
return SandboxedProcess
sp
secondInµs :: Int
secondInµs :: Port
secondInµs = Port
1000000
setFile' :: String -> String -> SandboxState -> IO (FilePath, SandboxState)
setFile' :: String -> String -> SandboxState -> IO (String, SandboxState)
setFile' String
name String
contents SandboxState
env = do
(String
f, Handle
h) <- String -> String -> IO (String, Handle)
openTempFile (SandboxState -> String
ssDataDir SandboxState
env) String
name
Handle -> String -> IO ()
hPutStr Handle
h String
contents
Handle -> IO ()
hClose Handle
h
(String, SandboxState) -> IO (String, SandboxState)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
f, SandboxState
env { ssFiles :: Map String String
ssFiles = String -> String -> Map String String -> Map String String
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
name String
f (SandboxState -> Map String String
ssFiles SandboxState
env) })
bufferSize :: Int
bufferSize :: Port
bufferSize = Port
4096
hReadWithTimeout :: Handle -> Int -> Sandbox ByteString
hReadWithTimeout :: Handle -> Port -> Sandbox ByteString
hReadWithTimeout Handle
h Port
timeout = do
Bool
dataAvailable <- 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
$ Handle -> Port -> IO Bool
hWaitForInput Handle
h Port
timeout IO Bool -> (IOError -> IO Bool) -> IO Bool
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` IOError -> IO Bool
checkEOF
if Bool
dataAvailable then do ByteString
b <- IO ByteString -> Sandbox ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Sandbox ByteString)
-> IO ByteString -> Sandbox ByteString
forall a b. (a -> b) -> a -> b
$ Handle -> Port -> IO ByteString
B.hGetNonBlocking Handle
h Port
bufferSize
ByteString
b' <- Handle -> Port -> Sandbox ByteString
hReadWithTimeout Handle
h Port
timeout Sandbox ByteString
-> (String -> Sandbox ByteString) -> Sandbox ByteString
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (\String
_ -> ByteString -> Sandbox ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Sandbox ByteString)
-> ByteString -> Sandbox ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
B.pack [])
ByteString -> Sandbox ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Sandbox ByteString)
-> ByteString -> Sandbox ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString
B.append ByteString
b ByteString
b'
else String -> Sandbox ByteString
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Sandbox ByteString) -> String -> Sandbox ByteString
forall a b. (a -> b) -> a -> b
$ String
"No data after " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Port -> String
forall a. Show a => a -> String
show Port
timeout String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"ms timeout."
where
checkEOF :: IOError -> IO Bool
checkEOF :: IOError -> IO Bool
checkEOF IOError
e = if IOError -> Bool
isEOFError IOError
e then do Port -> IO ()
threadDelay (Port -> IO ()) -> Port -> IO ()
forall a b. (a -> b) -> a -> b
$ Port
timeout Port -> Port -> Port
forall a. Num a => a -> a -> a
* Port
1000
(Bool -> Bool) -> IO Bool -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Bool
not (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
hIsEOF Handle
h
else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
connectTo :: N.HostName
-> PortID
-> IO Handle
connectTo :: String -> PortID -> IO Handle
connectTo String
hostname (PortNumber PortNumber
port) = do
ProtocolNumber
proto <- String -> IO ProtocolNumber
BSD.getProtocolNumber String
"tcp"
IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Handle) -> IO Handle
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError
(Family -> SocketType -> ProtocolNumber -> IO Socket
N.socket Family
N.AF_INET SocketType
N.Stream ProtocolNumber
proto)
(Socket -> IO ()
N.close)
(\Socket
sock -> do
HostEntry
he <- String -> IO HostEntry
BSD.getHostByName String
hostname
Socket -> SockAddr -> IO ()
N.connect Socket
sock (PortNumber -> HostAddress -> SockAddr
N.SockAddrInet PortNumber
port (HostEntry -> HostAddress
BSD.hostAddress HostEntry
he))
Socket -> IOMode -> IO Handle
N.socketToHandle Socket
sock IOMode
ReadWriteMode
)
inet_addr :: N.HostName -> IO HostAddress
inet_addr :: String -> IO HostAddress
inet_addr String
hostname = do
let hints :: AddrInfo
hints = AddrInfo
defaultHints { addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_NUMERICHOST], addrSocketType :: SocketType
addrSocketType = SocketType
Stream }
AddrInfo
addr:[AddrInfo]
_ <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (String -> Maybe String
forall a. a -> Maybe a
Just String
hostname) Maybe String
forall a. Maybe a
Nothing
let SockAddrInet PortNumber
_ HostAddress
address = AddrInfo -> SockAddr
addrAddress AddrInfo
addr
HostAddress -> IO HostAddress
forall (m :: * -> *) a. Monad m => a -> m a
return HostAddress
address
sendToPort :: String -> String -> Int -> Sandbox String
sendToPort :: String
-> String
-> Port
-> ExceptT String (ReaderT SandboxStateRef IO) String
sendToPort String
name String
input Port
timeout = do
SandboxState
env <- Sandbox SandboxState
get
case String -> Map String Port -> Maybe Port
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
name (SandboxState -> Map String Port
ssAllocatedPorts SandboxState
env) of
Maybe Port
Nothing -> String -> ExceptT String (ReaderT SandboxStateRef IO) String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ExceptT String (ReaderT SandboxStateRef IO) String)
-> String -> ExceptT String (ReaderT SandboxStateRef IO) String
forall a b. (a -> b) -> a -> b
$ String
"No such allocated port: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
Just Port
port -> do Handle
h <- IO Handle -> ExceptT String (ReaderT SandboxStateRef IO) Handle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> ExceptT String (ReaderT SandboxStateRef IO) Handle)
-> (IO Handle -> IO Handle)
-> IO Handle
-> ExceptT String (ReaderT SandboxStateRef IO) Handle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Handle -> IO Handle
forall a. IO a -> IO a
withSocketsDo (IO Handle -> ExceptT String (ReaderT SandboxStateRef IO) Handle)
-> IO Handle -> ExceptT String (ReaderT SandboxStateRef IO) Handle
forall a b. (a -> b) -> a -> b
$ String -> PortID -> IO Handle
connectTo String
"localhost" (PortID -> IO Handle) -> PortID -> IO Handle
forall a b. (a -> b) -> a -> b
$ PortNumber -> PortID
PortNumber (PortNumber -> PortID) -> PortNumber -> PortID
forall a b. (a -> b) -> a -> b
$ Port -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Port
port
IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String (ReaderT SandboxStateRef IO) ())
-> IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ do Handle -> ByteString -> IO ()
B.hPutStr Handle
h (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString
B.pack String
input
Handle -> IO ()
hFlush Handle
h
ByteString
b <- Handle -> Port -> Sandbox ByteString
hReadWithTimeout Handle
h Port
timeout
IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String (ReaderT SandboxStateRef IO) ())
-> IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
h
String -> ExceptT String (ReaderT SandboxStateRef IO) String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ExceptT String (ReaderT SandboxStateRef IO) String)
-> String -> ExceptT String (ReaderT SandboxStateRef IO) String
forall a b. (a -> b) -> a -> b
$! ByteString -> String
B.unpack ByteString
b
getNewPort :: String -> Sandbox Port
getNewPort :: String -> Sandbox Port
getNewPort String
name = do
SandboxState
env <- Sandbox SandboxState
get
case SandboxState -> [Port]
ssAvailablePorts SandboxState
env of
[] -> String -> Sandbox Port
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"No user ports left."
[Port]
ports -> do (Port
port, [Port]
ports') <- IO (Port, [Port])
-> ExceptT String (ReaderT SandboxStateRef IO) (Port, [Port])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Port, [Port])
-> ExceptT String (ReaderT SandboxStateRef IO) (Port, [Port]))
-> IO (Port, [Port])
-> ExceptT String (ReaderT SandboxStateRef IO) (Port, [Port])
forall a b. (a -> b) -> a -> b
$ [Port] -> IO (Port, [Port])
takeBindablePort' [Port]
ports
SandboxState
_ <- SandboxState -> Sandbox SandboxState
put SandboxState
env { ssAllocatedPorts :: Map String Port
ssAllocatedPorts = String -> Port -> Map String Port -> Map String Port
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
name Port
port (Map String Port -> Map String Port)
-> Map String Port -> Map String Port
forall a b. (a -> b) -> a -> b
$ SandboxState -> Map String Port
ssAllocatedPorts SandboxState
env
, ssAvailablePorts :: [Port]
ssAvailablePorts = [Port]
ports' }
Port -> Sandbox Port
forall (m :: * -> *) a. Monad m => a -> m a
return Port
port
where takeBindablePort' :: [Port] -> IO (Port, [Port])
takeBindablePort' [Port]
pl = do
[Port]
pl' <- (Port -> IO Bool) -> [Port] -> IO [Port]
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m [a]
dropWhileM ((Bool -> Bool) -> IO Bool -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Bool
not (IO Bool -> IO Bool) -> (Port -> IO Bool) -> Port -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Port -> IO Bool
isBindable) [Port]
pl
(Port, [Port]) -> IO (Port, [Port])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Port] -> Port
forall a. [a] -> a
head [Port]
pl', [Port] -> [Port]
forall a. [a] -> [a]
tail [Port]
pl')
isBindable' :: Port -> IO Bool
isBindable' :: Port -> IO Bool
isBindable' Port
p = IO Bool -> IO Bool
forall a. IO a -> IO a
withSocketsDo (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
Socket
s <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
AF_INET SocketType
Stream ProtocolNumber
defaultProtocol
Socket -> SocketOption -> Port -> IO ()
setSocketOption Socket
s SocketOption
ReuseAddr Port
1
HostAddress
localhost <- String -> IO HostAddress
inet_addr String
"127.0.0.1"
let sa :: SockAddr
sa = PortNumber -> HostAddress -> SockAddr
SockAddrInet (Port -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Port
p) HostAddress
localhost
Bool
r <- (Socket -> SockAddr -> IO ()
bind Socket
s SockAddr
sa IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
IO Bool -> (SomeException -> IO Bool) -> IO Bool
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` ((\SomeException
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) :: SomeException -> IO Bool)
Socket -> IO ()
close Socket
s
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! Bool
r
#if defined __LINUX__
isBindable :: Port -> IO Bool
isBindable port = do
ports <- getPorts
return $ not $ S.member (fromIntegral port) $ S.unions $ (map S.singleton $ ports)
where
getPort :: String -> Maybe Int
getPort v =
if v =~ pattern
then
case (v =~ pattern) of
[[_str,port']] ->
case readHex port' of
[(port'',_)] -> Just port''
_ -> Nothing
_ -> Nothing
else Nothing
where
pattern = "^ *[0-9]+: [0-9A-F]+:([0-9A-F]+) .*"
getPorts :: IO [Int]
getPorts = do
let files = [
"/proc/net/tcp",
"/proc/net/tcp6",
"/proc/net/udp",
"/proc/net/udp6"]
list <- forM files $ \file -> do {
v <- readFile file ;
v `seq` return $ catMaybes $ map getPort $ lines v
} `catch` (\(_ :: SomeException) -> return [])
return $ flatten list
where
flatten :: [[a]] -> [a]
flatten [] = []
flatten (x:xs) = x ++ flatten xs
#else
isBindable :: Port -> IO Bool
isBindable :: Port -> IO Bool
isBindable = Port -> IO Bool
isBindable'
#endif
startProcess :: SandboxedProcess -> Sandbox SandboxedProcess
startProcess :: SandboxedProcess -> Sandbox SandboxedProcess
startProcess SandboxedProcess
sp =
case SandboxedProcess -> Maybe SandboxedProcessInstance
spInstance SandboxedProcess
sp of
Maybe SandboxedProcessInstance
Nothing -> Sandbox SandboxedProcess
startProcess'
Just (RunningInstance {}) -> SandboxedProcess -> Sandbox SandboxedProcess
forall (m :: * -> *) a. Monad m => a -> m a
return SandboxedProcess
sp
Just (StoppedInstance {}) -> Sandbox SandboxedProcess
startProcess'
where
startProcess' :: Sandbox SandboxedProcess
startProcess' :: Sandbox SandboxedProcess
startProcess' = do
String
bin <- SandboxedProcess
-> ExceptT String (ReaderT SandboxStateRef IO) String
getProcessBinary SandboxedProcess
sp
[String]
args <- (String -> ExceptT String (ReaderT SandboxStateRef IO) String)
-> [String] -> ExceptT String (ReaderT SandboxStateRef IO) [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO String -> ExceptT String (ReaderT SandboxStateRef IO) String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT String (ReaderT SandboxStateRef IO) String)
-> (String -> IO String)
-> String
-> ExceptT String (ReaderT SandboxStateRef IO) String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
expand) ([String] -> ExceptT String (ReaderT SandboxStateRef IO) [String])
-> [String] -> ExceptT String (ReaderT SandboxStateRef IO) [String]
forall a b. (a -> b) -> a -> b
$ SandboxedProcess -> [String]
spArgs SandboxedProcess
sp
(Maybe Handle
hOutRO, StdStream
hOutRW, StdStream
hErrRW, [Handle]
handles) <- case SandboxedProcess -> Maybe Capture
spCapture SandboxedProcess
sp of
Just Capture
co -> IO (Maybe Handle, StdStream, StdStream, [Handle])
-> ExceptT
String
(ReaderT SandboxStateRef IO)
(Maybe Handle, StdStream, StdStream, [Handle])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Handle, StdStream, StdStream, [Handle])
-> ExceptT
String
(ReaderT SandboxStateRef IO)
(Maybe Handle, StdStream, StdStream, [Handle]))
-> IO (Maybe Handle, StdStream, StdStream, [Handle])
-> ExceptT
String
(ReaderT SandboxStateRef IO)
(Maybe Handle, StdStream, StdStream, [Handle])
forall a b. (a -> b) -> a -> b
$ do
(Fd
pRO, Fd
pRW) <- IO (Fd, Fd)
createPipe
Handle
hRO <- Fd -> IO Handle
fdToHandle Fd
pRO
Handle
hRW <- Fd -> IO Handle
fdToHandle Fd
pRW
case Capture
co of
Capture
CaptureStdout -> (Maybe Handle, StdStream, StdStream, [Handle])
-> IO (Maybe Handle, StdStream, StdStream, [Handle])
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
hRO, Handle -> StdStream
UseHandle Handle
hRW, StdStream
Inherit, [])
Capture
CaptureStderr -> (Maybe Handle, StdStream, StdStream, [Handle])
-> IO (Maybe Handle, StdStream, StdStream, [Handle])
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
hRO, StdStream
Inherit, Handle -> StdStream
UseHandle Handle
hRW, [])
Capture
CaptureBoth -> (Maybe Handle, StdStream, StdStream, [Handle])
-> IO (Maybe Handle, StdStream, StdStream, [Handle])
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
hRO, Handle -> StdStream
UseHandle Handle
hRW, Handle -> StdStream
UseHandle Handle
hRW, [])
CaptureStdoutWithFile String
filepath_o -> do
Handle
hd <- String -> IOMode -> IO Handle
openFile String
filepath_o IOMode
WriteMode
(Maybe Handle, StdStream, StdStream, [Handle])
-> IO (Maybe Handle, StdStream, StdStream, [Handle])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Handle
forall a. Maybe a
Nothing, Handle -> StdStream
UseHandle Handle
hd, StdStream
Inherit, [Handle
hd])
CaptureStderrWithFile String
filepath_e -> do
Handle
hd <- String -> IOMode -> IO Handle
openFile String
filepath_e IOMode
WriteMode
(Maybe Handle, StdStream, StdStream, [Handle])
-> IO (Maybe Handle, StdStream, StdStream, [Handle])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Handle
forall a. Maybe a
Nothing, StdStream
Inherit, Handle -> StdStream
UseHandle Handle
hd, [Handle
hd])
CaptureBothWithFile String
filepath_o String
filepath_e-> do
Handle
hdo <- String -> IOMode -> IO Handle
openFile String
filepath_o IOMode
WriteMode
Handle
hde <- String -> IOMode -> IO Handle
openFile String
filepath_e IOMode
WriteMode
(Maybe Handle, StdStream, StdStream, [Handle])
-> IO (Maybe Handle, StdStream, StdStream, [Handle])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Handle
forall a. Maybe a
Nothing, Handle -> StdStream
UseHandle Handle
hdo, Handle -> StdStream
UseHandle Handle
hde, [Handle
hdo,Handle
hde])
Maybe Capture
Nothing -> (Maybe Handle, StdStream, StdStream, [Handle])
-> ExceptT
String
(ReaderT SandboxStateRef IO)
(Maybe Handle, StdStream, StdStream, [Handle])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Handle
forall a. Maybe a
Nothing, StdStream
Inherit, StdStream
Inherit, [])
(Just Handle
ih, Maybe Handle
_, Maybe Handle
_, ProcessHandle
ph) <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ExceptT
String
(ReaderT SandboxStateRef IO)
(Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ExceptT
String
(ReaderT SandboxStateRef IO)
(Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ExceptT
String
(ReaderT SandboxStateRef IO)
(Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ (String -> [String] -> CreateProcess
proc String
bin [String]
args) { create_group :: Bool
create_group = Bool
True
, std_in :: StdStream
std_in = StdStream
CreatePipe
, std_out :: StdStream
std_out = StdStream
hOutRW
, std_err :: StdStream
std_err = StdStream
hErrRW
, cwd :: Maybe String
cwd = SandboxedProcess -> Maybe String
spCwd SandboxedProcess
sp
, env :: Maybe [(String, String)]
P.env = SandboxedProcess -> Maybe [(String, String)]
spEnvs SandboxedProcess
sp
}
Bool
-> ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Port -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Port -> Bool) -> Maybe Port -> Bool
forall a b. (a -> b) -> a -> b
$ SandboxedProcess -> Maybe Port
spWait SandboxedProcess
sp) (ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ())
-> ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ do
IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String (ReaderT SandboxStateRef IO) ())
-> (Port -> IO ())
-> Port
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Port -> IO ()
threadDelay (Port -> ExceptT String (ReaderT SandboxStateRef IO) ())
-> Port -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ Maybe Port -> Port
forall a. HasCallStack => Maybe a -> a
fromJust (SandboxedProcess -> Maybe Port
spWait SandboxedProcess
sp) Port -> Port -> Port
forall a. Num a => a -> a -> a
* Port
secondInµs
Maybe ExitCode
errno <- IO (Maybe ExitCode)
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe ExitCode)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ExitCode)
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe ExitCode))
-> IO (Maybe ExitCode)
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe ExitCode)
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO (Maybe ExitCode)
getProcessExitCode ProcessHandle
ph
case Maybe ExitCode
errno of
Maybe ExitCode
Nothing -> do
ProcessID
pid <- IO ProcessID
-> ExceptT String (ReaderT SandboxStateRef IO) ProcessID
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessID
-> ExceptT String (ReaderT SandboxStateRef IO) ProcessID)
-> IO ProcessID
-> ExceptT String (ReaderT SandboxStateRef IO) ProcessID
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ProcessID
hGetProcessID ProcessHandle
ph
ProcessID
pgid <- IO ProcessID
-> ExceptT String (ReaderT SandboxStateRef IO) ProcessID
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessID
-> ExceptT String (ReaderT SandboxStateRef IO) ProcessID)
-> IO ProcessID
-> ExceptT String (ReaderT SandboxStateRef IO) ProcessID
forall a b. (a -> b) -> a -> b
$ ProcessID -> IO ProcessID
getProcessGroupIDOf ProcessID
pid
SandboxedProcess -> Sandbox SandboxedProcess
updateProcess SandboxedProcess
sp {
spInstance :: Maybe SandboxedProcessInstance
spInstance = SandboxedProcessInstance -> Maybe SandboxedProcessInstance
forall a. a -> Maybe a
Just (SandboxedProcessInstance -> Maybe SandboxedProcessInstance)
-> SandboxedProcessInstance -> Maybe SandboxedProcessInstance
forall a b. (a -> b) -> a -> b
$ ProcessHandle
-> Handle -> Maybe Handle -> [Handle] -> SandboxedProcessInstance
RunningInstance ProcessHandle
ph Handle
ih Maybe Handle
hOutRO [Handle]
handles
, spPid :: Maybe ProcessID
spPid = ProcessID -> Maybe ProcessID
forall a. a -> Maybe a
Just ProcessID
pid
, spPGid :: Maybe ProcessID
spPGid = ProcessID -> Maybe ProcessID
forall a. a -> Maybe a
Just ProcessID
pgid
}
Just ExitCode
ExitSuccess -> do
Maybe String
mStr <- case Maybe Handle
hOutRO of
Just Handle
h -> (String -> Maybe String)
-> ExceptT String (ReaderT SandboxStateRef IO) String
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM String -> Maybe String
forall a. a -> Maybe a
Just (ExceptT String (ReaderT SandboxStateRef IO) String
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe String))
-> ExceptT String (ReaderT SandboxStateRef IO) String
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe String)
forall a b. (a -> b) -> a -> b
$ IO String -> ExceptT String (ReaderT SandboxStateRef IO) String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ExceptT String (ReaderT SandboxStateRef IO) String)
-> IO String -> ExceptT String (ReaderT SandboxStateRef IO) String
forall a b. (a -> b) -> a -> b
$ Handle -> IO String
hGetContents Handle
h
Maybe Handle
Nothing -> Maybe String
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
SandboxedProcess -> Sandbox SandboxedProcess
updateProcess SandboxedProcess
sp {
spInstance :: Maybe SandboxedProcessInstance
spInstance = SandboxedProcessInstance -> Maybe SandboxedProcessInstance
forall a. a -> Maybe a
Just (SandboxedProcessInstance -> Maybe SandboxedProcessInstance)
-> SandboxedProcessInstance -> Maybe SandboxedProcessInstance
forall a b. (a -> b) -> a -> b
$ ExitCode -> Maybe String -> SandboxedProcessInstance
StoppedInstance ExitCode
ExitSuccess Maybe String
mStr
}
Just ExitCode
errno' -> String -> Sandbox SandboxedProcess
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Sandbox SandboxedProcess)
-> String -> Sandbox SandboxedProcess
forall a b. (a -> b) -> a -> b
$ String
"Process " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SandboxedProcess -> String
spName SandboxedProcess
sp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not running.\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" - command-line: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
formatCommandLine String
bin [String]
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" - exit code: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
errno'
formatCommandLine :: String -> [String] -> String
formatCommandLine :: String -> [String] -> String
formatCommandLine String
bin [String]
args = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
bin String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args
stopProcess :: SandboxedProcess -> Sandbox SandboxedProcess
stopProcess :: SandboxedProcess -> Sandbox SandboxedProcess
stopProcess SandboxedProcess
sp =
case SandboxedProcess -> Maybe SandboxedProcessInstance
spInstance SandboxedProcess
sp of
Just (RunningInstance ProcessHandle
ph Handle
_ Maybe Handle
_ [Handle]
handles) -> do
let wait :: Port
wait = if Maybe Port -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Port -> Bool) -> Maybe Port -> Bool
forall a b. (a -> b) -> a -> b
$ SandboxedProcess -> Maybe Port
spWait SandboxedProcess
sp then Port
50000 else Maybe Port -> Port
forall a. HasCallStack => Maybe a -> a
fromJust (SandboxedProcess -> Maybe Port
spWait SandboxedProcess
sp) Port -> Port -> Port
forall a. Num a => a -> a -> a
* Port
secondInµs Port -> Port -> Port
forall a. Integral a => a -> a -> a
`div` Port
5
ExceptT String (ReaderT SandboxStateRef IO) Bool
-> ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ExceptT String (ReaderT SandboxStateRef IO) Bool
isVerbose (ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ())
-> ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String (ReaderT SandboxStateRef IO) ())
-> IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String
"sending sigterm : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SandboxedProcess -> String
spName SandboxedProcess
sp)
IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String (ReaderT SandboxStateRef IO) ())
-> IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ do ProcessHandle -> IO ()
terminateProcess ProcessHandle
ph
Port -> IO ()
threadDelay Port
wait
Bool
stillRunning <- (Maybe ExitCode -> Bool)
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe ExitCode)
-> ExceptT String (ReaderT SandboxStateRef IO) Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Maybe ExitCode -> Bool
forall a. Maybe a -> Bool
isNothing (ExceptT String (ReaderT SandboxStateRef IO) (Maybe ExitCode)
-> ExceptT String (ReaderT SandboxStateRef IO) Bool)
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe ExitCode)
-> ExceptT String (ReaderT SandboxStateRef IO) Bool
forall a b. (a -> b) -> a -> b
$ IO (Maybe ExitCode)
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe ExitCode)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ExitCode)
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe ExitCode))
-> IO (Maybe ExitCode)
-> ExceptT String (ReaderT SandboxStateRef IO) (Maybe ExitCode)
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO (Maybe ExitCode)
getProcessExitCode ProcessHandle
ph
Bool
-> ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
stillRunning (ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ())
-> ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ do
ExceptT String (ReaderT SandboxStateRef IO) Bool
-> ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ExceptT String (ReaderT SandboxStateRef IO) Bool
isVerbose (ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ())
-> ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$
IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String (ReaderT SandboxStateRef IO) ())
-> IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String
"sending sigkill : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SandboxedProcess -> String
spName SandboxedProcess
sp)
IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String (ReaderT SandboxStateRef IO) ())
-> IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ do
ProcessHandle -> IO ()
killProcess ProcessHandle
ph
[Handle] -> (Handle -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Handle]
handles Handle -> IO ()
hClose
SandboxedProcess -> Sandbox SandboxedProcess
stopProcess (SandboxedProcess -> Sandbox SandboxedProcess)
-> Sandbox SandboxedProcess -> Sandbox SandboxedProcess
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Sandbox SandboxedProcess
getProcess (SandboxedProcess -> String
spName SandboxedProcess
sp)
Maybe SandboxedProcessInstance
_ -> SandboxedProcess -> Sandbox SandboxedProcess
forall (m :: * -> *) a. Monad m => a -> m a
return SandboxedProcess
sp
#if defined(__MACOSX__) || defined(__WIN32__)
#else
getAvailablePids :: Sandbox [ProcessID]
getAvailablePids :: Sandbox [ProcessID]
getAvailablePids = do
SandboxState
stat <- Sandbox SandboxState
get
let pgids :: [ProcessID]
pgids = [Maybe ProcessID] -> [ProcessID]
forall a. [Maybe a] -> [a]
catMaybes (((String, SandboxedProcess) -> Maybe ProcessID)
-> [(String, SandboxedProcess)] -> [Maybe ProcessID]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
_k,SandboxedProcess
v) -> SandboxedProcess -> Maybe ProcessID
spPGid SandboxedProcess
v) (Map String SandboxedProcess -> [(String, SandboxedProcess)]
forall k a. Map k a -> [(k, a)]
M.toList (SandboxState -> Map String SandboxedProcess
ssProcesses SandboxState
stat)))
[ProcessID]
pids <- IO [ProcessID] -> Sandbox [ProcessID]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ProcessID] -> Sandbox [ProcessID])
-> IO [ProcessID] -> Sandbox [ProcessID]
forall a b. (a -> b) -> a -> b
$ [ProcessID] -> IO [ProcessID]
getProcessIDs [ProcessID]
pgids
[ProcessID] -> Sandbox [ProcessID]
forall (m :: * -> *) a. Monad m => a -> m a
return [ProcessID]
pids
#endif
cleanUpProcesses :: Sandbox ()
cleanUpProcesses :: ExceptT String (ReaderT SandboxStateRef IO) ()
cleanUpProcesses = do
SandboxState
stat <- Sandbox SandboxState
get
let pgids :: [ProcessID]
pgids = [Maybe ProcessID] -> [ProcessID]
forall a. [Maybe a] -> [a]
catMaybes (((String, SandboxedProcess) -> Maybe ProcessID)
-> [(String, SandboxedProcess)] -> [Maybe ProcessID]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
_k,SandboxedProcess
v) -> SandboxedProcess -> Maybe ProcessID
spPGid SandboxedProcess
v) (Map String SandboxedProcess -> [(String, SandboxedProcess)]
forall k a. Map k a -> [(k, a)]
M.toList (SandboxState -> Map String SandboxedProcess
ssProcesses SandboxState
stat)))
ExceptT String (ReaderT SandboxStateRef IO) Bool
-> ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ExceptT String (ReaderT SandboxStateRef IO) Bool
isVerbose (ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ())
-> ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String (ReaderT SandboxStateRef IO) ())
-> IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String
"Starting to kill process groups " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [ProcessID] -> String
forall a. Show a => a -> String
show [ProcessID]
pgids)
IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String (ReaderT SandboxStateRef IO) ())
-> IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ [ProcessID] -> IO ()
cleanUpProcessGroupIDs [ProcessID]
pgids
hSignalProcess :: Signal -> ProcessHandle -> IO ()
hSignalProcess :: ProtocolNumber -> ProcessHandle -> IO ()
hSignalProcess ProtocolNumber
s ProcessHandle
h = do
ProcessID
pid <- ProcessHandle -> IO ProcessID
hGetProcessID ProcessHandle
h
ProtocolNumber -> ProcessID -> IO ()
signalProcess ProtocolNumber
s ProcessID
pid
killProcess :: ProcessHandle -> IO ()
killProcess :: ProcessHandle -> IO ()
killProcess = ProtocolNumber -> ProcessHandle -> IO ()
hSignalProcess ProtocolNumber
sigKILL
hGetProcessID :: ProcessHandle -> IO ProcessID
hGetProcessID :: ProcessHandle -> IO ProcessID
hGetProcessID ProcessHandle
h = ProcessHandle -> (ProcessHandle__ -> IO ProcessID) -> IO ProcessID
forall a. ProcessHandle -> (ProcessHandle__ -> IO a) -> IO a
withProcessHandle ProcessHandle
h ((ProcessHandle__ -> IO ProcessID) -> IO ProcessID)
-> (ProcessHandle__ -> IO ProcessID) -> IO ProcessID
forall a b. (a -> b) -> a -> b
$ \ProcessHandle__
x ->
case ProcessHandle__
x of
#if MIN_VERSION_process(1,2,0)
OpenHandle ProcessID
pid -> ProcessID -> IO ProcessID
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessID
pid
#else
OpenHandle pid -> return (x, pid)
#endif
ProcessHandle__
_ -> IOError -> IO ProcessID
forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
throwIO (IOError -> IO ProcessID) -> IOError -> IO ProcessID
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"Unable to retrieve child process ID."
interactWithProcess :: SandboxedProcess -> String -> Int -> Sandbox String
interactWithProcess :: SandboxedProcess
-> String
-> Port
-> ExceptT String (ReaderT SandboxStateRef IO) String
interactWithProcess SandboxedProcess
sp String
input Port
timeout = do
Handle
hIn <- SandboxedProcess
-> ExceptT String (ReaderT SandboxStateRef IO) Handle
getProcessInputHandle SandboxedProcess
sp
Handle
hOut <- SandboxedProcess
-> ExceptT String (ReaderT SandboxStateRef IO) Handle
getProcessCapturedOutputHandle SandboxedProcess
sp
IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String (ReaderT SandboxStateRef IO) ())
-> IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ do Handle -> ByteString -> IO ()
B.hPutStr Handle
hIn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString
B.pack String
input
Handle -> IO ()
hFlush Handle
hIn
ByteString
b <- Handle -> Port -> Sandbox ByteString
hReadWithTimeout Handle
hOut Port
timeout
String -> ExceptT String (ReaderT SandboxStateRef IO) String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ExceptT String (ReaderT SandboxStateRef IO) String)
-> String -> ExceptT String (ReaderT SandboxStateRef IO) String
forall a b. (a -> b) -> a -> b
$! ByteString -> String
B.unpack ByteString
b
getProcessInputHandle :: SandboxedProcess -> Sandbox Handle
getProcessInputHandle :: SandboxedProcess
-> ExceptT String (ReaderT SandboxStateRef IO) Handle
getProcessInputHandle SandboxedProcess
sp =
case SandboxedProcess -> Maybe SandboxedProcessInstance
spInstance SandboxedProcess
sp of
Just (RunningInstance ProcessHandle
_ Handle
ih Maybe Handle
_ [Handle]
_) -> Handle -> ExceptT String (ReaderT SandboxStateRef IO) Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
ih
Maybe SandboxedProcessInstance
_ -> String -> ExceptT String (ReaderT SandboxStateRef IO) Handle
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ExceptT String (ReaderT SandboxStateRef IO) Handle)
-> String -> ExceptT String (ReaderT SandboxStateRef IO) Handle
forall a b. (a -> b) -> a -> b
$ String
"No such handle for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SandboxedProcess -> String
spName SandboxedProcess
sp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Is the process started?"
getProcessCapturedOutputHandle :: SandboxedProcess -> Sandbox Handle
getProcessCapturedOutputHandle :: SandboxedProcess
-> ExceptT String (ReaderT SandboxStateRef IO) Handle
getProcessCapturedOutputHandle SandboxedProcess
sp =
case SandboxedProcess -> Maybe SandboxedProcessInstance
spInstance SandboxedProcess
sp of
Just (RunningInstance ProcessHandle
_ Handle
_ (Just Handle
oh) [Handle]
_) -> Handle -> ExceptT String (ReaderT SandboxStateRef IO) Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
oh
Maybe SandboxedProcessInstance
_ -> String -> ExceptT String (ReaderT SandboxStateRef IO) Handle
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ExceptT String (ReaderT SandboxStateRef IO) Handle)
-> String -> ExceptT String (ReaderT SandboxStateRef IO) Handle
forall a b. (a -> b) -> a -> b
$ String
"No captured output handle for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SandboxedProcess -> String
spName SandboxedProcess
sp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Is capture activated?"
getProcessBinary :: SandboxedProcess -> Sandbox FilePath
getProcessBinary :: SandboxedProcess
-> ExceptT String (ReaderT SandboxStateRef IO) String
getProcessBinary SandboxedProcess
sp = do
[String]
existing <- IO [String] -> ExceptT String (ReaderT SandboxStateRef IO) [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String]
-> ExceptT String (ReaderT SandboxStateRef IO) [String])
-> IO [String]
-> ExceptT String (ReaderT SandboxStateRef IO) [String]
forall a b. (a -> b) -> a -> b
$ [String] -> IO [String]
findExecutables [String]
bins
case [String]
existing of
String
exBin:[String]
_ -> String -> ExceptT String (ReaderT SandboxStateRef IO) String
forall (m :: * -> *) a. Monad m => a -> m a
return String
exBin
[] -> String -> ExceptT String (ReaderT SandboxStateRef IO) String
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ExceptT String (ReaderT SandboxStateRef IO) String)
-> String -> ExceptT String (ReaderT SandboxStateRef IO) String
forall a b. (a -> b) -> a -> b
$ String
"Unable to find the executable for the test process \""
String -> String -> String
forall a. [a] -> [a] -> [a]
++ SandboxedProcess -> String
spName SandboxedProcess
sp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"\r\n"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Considered paths were: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
bins
where bins :: [String]
bins = SandboxedProcess -> [String]
getProcessCandidateBinaries SandboxedProcess
sp
findExecutables :: [FilePath] -> IO [FilePath]
findExecutables :: [String] -> IO [String]
findExecutables [String]
paths =
([Maybe String] -> [String]) -> IO [Maybe String] -> IO [String]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe String] -> IO [String])
-> IO [Maybe String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> IO (Maybe String)) -> [String] -> IO [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Maybe String)
tryBinary [String]
paths
tryBinary :: FilePath -> IO (Maybe FilePath)
tryBinary :: String -> IO (Maybe String)
tryBinary String
path = do
String
expandedPath <- String -> IO String
expand String
path
Maybe String
mexe <- String -> IO (Maybe String)
D.findExecutable String
expandedPath
case Maybe String
mexe of
Maybe String
Nothing -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
Just String
path' -> do
Either IOError String
canonicalizedPath <- IO String -> IO (Either IOError String)
forall a. IO a -> IO (Either IOError a)
tryIOError (IO String -> IO (Either IOError String))
-> IO String -> IO (Either IOError String)
forall a b. (a -> b) -> a -> b
$ String -> IO String
D.canonicalizePath String
path'
case Either IOError String
canonicalizedPath of
Left IOError
_ -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
Right String
realPath -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
realPath
getProcessCandidateBinaries :: SandboxedProcess -> [FilePath]
getProcessCandidateBinaries :: SandboxedProcess -> [String]
getProcessCandidateBinaries SandboxedProcess
sp =
[ String
userBinary, String
binary, String
cwdBinary, String
pathBinary ]
where binary :: String
binary = SandboxedProcess -> String
spBinary SandboxedProcess
sp
pathBinary :: String
pathBinary = String -> String
takeFileName String
binary
cwdBinary :: String
cwdBinary = String
"." String -> String -> String
</> String
pathBinary
userBinary :: String
userBinary = String
"${" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (SandboxedProcess -> String
spName SandboxedProcess
sp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_bin") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}"
expand :: String -> IO String
expand :: String -> IO String
expand String
s =
if Char
'$' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
s then String -> IO String
expandShell String
s
else String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
s
where
expandShell :: String -> IO String
expandShell :: String -> IO String
expandShell String
p = do
(Maybe Handle
_, Just Handle
outH, Maybe Handle
_, ProcessHandle
_) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$
(String -> CreateProcess
shell (String -> CreateProcess) -> String -> CreateProcess
forall a b. (a -> b) -> a -> b
$ String
"echo " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p) { std_out :: StdStream
std_out = StdStream
CreatePipe }
(String -> String) -> IO String -> IO String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"\r\n")) (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ Handle -> IO String
hGetContents Handle
outH
whenM :: Monad m => m Bool -> m () -> m ()
whenM :: m Bool -> m () -> m ()
whenM = (((Bool -> m ()) -> m ()) -> (m () -> Bool -> m ()) -> m () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> m () -> m ()) -> m () -> Bool -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when) (((Bool -> m ()) -> m ()) -> m () -> m ())
-> (m Bool -> (Bool -> m ()) -> m ()) -> m Bool -> m () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=)
setVariable :: Serialize a
=> String
-> a
-> Sandbox a
setVariable :: String -> a -> Sandbox a
setVariable String
name a
new = do
SandboxState
env <- Sandbox SandboxState
get
SandboxState
_ <- SandboxState -> Sandbox SandboxState
put (SandboxState -> Sandbox SandboxState)
-> SandboxState -> Sandbox SandboxState
forall a b. (a -> b) -> a -> b
$ SandboxState
env { ssVariables :: Map String ByteString
ssVariables = String
-> ByteString -> Map String ByteString -> Map String ByteString
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
name (a -> ByteString
forall a. Serialize a => a -> ByteString
encode a
new) (SandboxState -> Map String ByteString
ssVariables SandboxState
env) }
a -> Sandbox a
forall (m :: * -> *) a. Monad m => a -> m a
return a
new
checkVariable :: String
-> Sandbox Bool
checkVariable :: String -> ExceptT String (ReaderT SandboxStateRef IO) Bool
checkVariable String
name = do
SandboxState
env <- Sandbox SandboxState
get
Bool -> ExceptT String (ReaderT SandboxStateRef IO) Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ExceptT String (ReaderT SandboxStateRef IO) Bool)
-> Bool -> ExceptT String (ReaderT SandboxStateRef IO) Bool
forall a b. (a -> b) -> a -> b
$ String -> Map String ByteString -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member String
name (Map String ByteString -> Bool) -> Map String ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ SandboxState -> Map String ByteString
ssVariables SandboxState
env
getVariable :: Serialize a
=> String
-> a
-> Sandbox a
getVariable :: String -> a -> Sandbox a
getVariable String
name a
defval = do
SandboxState
env <- Sandbox SandboxState
get
let var :: Either String a
var = case String -> Map String ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
name (Map String ByteString -> Maybe ByteString)
-> Map String ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ SandboxState -> Map String ByteString
ssVariables SandboxState
env of
Maybe ByteString
Nothing -> a -> Either String a
forall a b. b -> Either a b
Right a
defval
Just ByteString
var' -> ByteString -> Either String a
forall a. Serialize a => ByteString -> Either String a
decode ByteString
var'
(String -> Sandbox a)
-> (a -> Sandbox a) -> Either String a -> Sandbox a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Sandbox a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError a -> Sandbox a
forall (m :: * -> *) a. Monad m => a -> m a
return Either String a
var
unsetVariable :: String
-> Sandbox ()
unsetVariable :: String -> ExceptT String (ReaderT SandboxStateRef IO) ()
unsetVariable String
name = do
SandboxState
env <- Sandbox SandboxState
get
Sandbox SandboxState
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sandbox SandboxState
-> ExceptT String (ReaderT SandboxStateRef IO) ())
-> Sandbox SandboxState
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ SandboxState -> Sandbox SandboxState
put SandboxState
env { ssVariables :: Map String ByteString
ssVariables = String -> Map String ByteString -> Map String ByteString
forall k a. Ord k => k -> Map k a -> Map k a
M.delete String
name (Map String ByteString -> Map String ByteString)
-> Map String ByteString -> Map String ByteString
forall a b. (a -> b) -> a -> b
$ SandboxState -> Map String ByteString
ssVariables SandboxState
env }
isVerbose :: Sandbox Bool
isVerbose :: ExceptT String (ReaderT SandboxStateRef IO) Bool
isVerbose = String -> Bool -> ExceptT String (ReaderT SandboxStateRef IO) Bool
forall a. Serialize a => String -> a -> Sandbox a
getVariable String
verbosityKey Bool
True
verbosityKey :: String
verbosityKey :: String
verbosityKey = String
"__VERBOSITY__"
isCleanUp :: Sandbox Bool
isCleanUp :: ExceptT String (ReaderT SandboxStateRef IO) Bool
isCleanUp = String -> Bool -> ExceptT String (ReaderT SandboxStateRef IO) Bool
forall a. Serialize a => String -> a -> Sandbox a
getVariable String
cleanUpKey Bool
True
cleanUpKey :: String
cleanUpKey :: String
cleanUpKey = String
"__CLEANUP__"
displayBanner :: Sandbox ()
displayBanner :: ExceptT String (ReaderT SandboxStateRef IO) ()
displayBanner = do
Bool
displayed <- String -> ExceptT String (ReaderT SandboxStateRef IO) Bool
checkVariable String
var
Bool
-> ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
displayed (ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ())
-> ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ Sandbox SandboxState
get Sandbox SandboxState
-> (SandboxState -> ExceptT String (ReaderT SandboxStateRef IO) ())
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String (ReaderT SandboxStateRef IO) ())
-> (SandboxState -> IO ())
-> SandboxState
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> IO ())
-> (SandboxState -> String) -> SandboxState -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SandboxState -> String
pretty
ExceptT String (ReaderT SandboxStateRef IO) Bool
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT String (ReaderT SandboxStateRef IO) Bool
-> ExceptT String (ReaderT SandboxStateRef IO) ())
-> ExceptT String (ReaderT SandboxStateRef IO) Bool
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ String -> Bool -> ExceptT String (ReaderT SandboxStateRef IO) Bool
forall a. Serialize a => String -> a -> Sandbox a
setVariable String
var Bool
True
where var :: String
var = String
"__BANNER__DISPLAYED__"
installSignalHandlers :: Sandbox ()
installSignalHandlers :: ExceptT String (ReaderT SandboxStateRef IO) ()
installSignalHandlers = do
Bool
installed <- String -> ExceptT String (ReaderT SandboxStateRef IO) Bool
checkVariable String
var
Bool
-> ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
installed (ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ())
-> ExceptT String (ReaderT SandboxStateRef IO) ()
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT String (ReaderT SandboxStateRef IO) ())
-> (IO () -> IO ())
-> IO ()
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> ExceptT String (ReaderT SandboxStateRef IO) ())
-> IO () -> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ do Handler
_ <- ProtocolNumber -> Handler -> Maybe SignalSet -> IO Handler
installHandler ProtocolNumber
sigTERM Handler
handler Maybe SignalSet
forall a. Maybe a
Nothing
Handler
_ <- ProtocolNumber -> Handler -> Maybe SignalSet -> IO Handler
installHandler ProtocolNumber
sigQUIT Handler
handler Maybe SignalSet
forall a. Maybe a
Nothing
Handler
_ <- ProtocolNumber -> Handler -> Maybe SignalSet -> IO Handler
installHandler ProtocolNumber
sigABRT Handler
handler Maybe SignalSet
forall a. Maybe a
Nothing
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ExceptT String (ReaderT SandboxStateRef IO) Bool
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT String (ReaderT SandboxStateRef IO) Bool
-> ExceptT String (ReaderT SandboxStateRef IO) ())
-> ExceptT String (ReaderT SandboxStateRef IO) Bool
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall a b. (a -> b) -> a -> b
$ String -> Bool -> ExceptT String (ReaderT SandboxStateRef IO) Bool
forall a. Serialize a => String -> a -> Sandbox a
setVariable String
var Bool
True
where var :: String
var = String
"__HANDLERS_INSTALLED__"
handler :: Handler
handler = IO () -> Handler
Catch (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ ProtocolNumber -> ProcessID -> IO ()
signalProcess ProtocolNumber
sigINT (ProcessID -> IO ()) -> IO ProcessID -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ProcessID
getProcessID
data SandboxSeed = SandboxFixedSeed Int
| SandboxRandomSeed
deriving ((forall x. SandboxSeed -> Rep SandboxSeed x)
-> (forall x. Rep SandboxSeed x -> SandboxSeed)
-> Generic SandboxSeed
forall x. Rep SandboxSeed x -> SandboxSeed
forall x. SandboxSeed -> Rep SandboxSeed x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SandboxSeed x -> SandboxSeed
$cfrom :: forall x. SandboxSeed -> Rep SandboxSeed x
Generic)
instance Serialize (SandboxSeed)
data SandboxTestOptions = SandboxTestOptions {
SandboxTestOptions -> Maybe SandboxSeed
stoSeed :: Maybe SandboxSeed
, SandboxTestOptions -> Maybe Port
stoMaximumGeneratedTests :: Maybe Int
, SandboxTestOptions -> Maybe Port
stoMaximumUnsuitableGeneratedTests :: Maybe Int
, SandboxTestOptions -> Maybe Port
stoMaximumTestSize :: Maybe Int
} deriving ((forall x. SandboxTestOptions -> Rep SandboxTestOptions x)
-> (forall x. Rep SandboxTestOptions x -> SandboxTestOptions)
-> Generic SandboxTestOptions
forall x. Rep SandboxTestOptions x -> SandboxTestOptions
forall x. SandboxTestOptions -> Rep SandboxTestOptions x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SandboxTestOptions x -> SandboxTestOptions
$cfrom :: forall x. SandboxTestOptions -> Rep SandboxTestOptions x
Generic)
instance Serialize (SandboxTestOptions)
putOptions :: SandboxTestOptions -> Sandbox ()
putOptions :: SandboxTestOptions
-> ExceptT String (ReaderT SandboxStateRef IO) ()
putOptions = ExceptT
String (ReaderT SandboxStateRef IO) (Maybe SandboxTestOptions)
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT
String (ReaderT SandboxStateRef IO) (Maybe SandboxTestOptions)
-> ExceptT String (ReaderT SandboxStateRef IO) ())
-> (SandboxTestOptions
-> ExceptT
String (ReaderT SandboxStateRef IO) (Maybe SandboxTestOptions))
-> SandboxTestOptions
-> ExceptT String (ReaderT SandboxStateRef IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> Maybe SandboxTestOptions
-> ExceptT
String (ReaderT SandboxStateRef IO) (Maybe SandboxTestOptions)
forall a. Serialize a => String -> a -> Sandbox a
setVariable String
optionsVariable (Maybe SandboxTestOptions
-> ExceptT
String (ReaderT SandboxStateRef IO) (Maybe SandboxTestOptions))
-> (SandboxTestOptions -> Maybe SandboxTestOptions)
-> SandboxTestOptions
-> ExceptT
String (ReaderT SandboxStateRef IO) (Maybe SandboxTestOptions)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SandboxTestOptions -> Maybe SandboxTestOptions
forall a. a -> Maybe a
Just
getOptions :: Sandbox (Maybe SandboxTestOptions)
getOptions :: ExceptT
String (ReaderT SandboxStateRef IO) (Maybe SandboxTestOptions)
getOptions = String
-> Maybe SandboxTestOptions
-> ExceptT
String (ReaderT SandboxStateRef IO) (Maybe SandboxTestOptions)
forall a. Serialize a => String -> a -> Sandbox a
getVariable String
optionsVariable Maybe SandboxTestOptions
forall a. Maybe a
Nothing
optionsVariable :: String
optionsVariable :: String
optionsVariable = String
"__TEST_OPTIONS__"