-- author: Benjamin Surma <benjamin.surma@gmail.com>

{-# 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
header :: SandboxState -> String
header 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
footer :: String
footer =
  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]
      -- Ephemeral port is used by operating system which allocates it for tcp-client.
      -- The port area is below.
      -- IANN(freebsd and win7): [49152.. 65535],Linux: [32768..61000],WinXP: [1025..5000]
      -- Do not use these area for "userPorts" to avoid conflict.
  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                  -- ^ Process Name
                -> FilePath                -- ^ Path to the application binary
                -> [String]                -- ^ Arguments to pass on the command-line
                -> Maybe Int               -- ^ Time to wait (in s.) before checking that the process is still up
                -> Maybe Capture           -- ^ Which outputs to capture (if any)
                -> Maybe [(String,String)] -- ^ Evironment variables
                -> Maybe FilePath          -- ^ Working directory for the new process
                -> 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
  -- Validate process name
  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
"."
  -- Register into the environment
  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 -- Process is dead; update the environment
              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' -- TODO: Rewrite as terminal recursive
    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         -- Hostname
          -> PortID             -- Port Identifier
          -> IO Handle          -- Connected Socket
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)  -- only done if there's an error
        (\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
(>>=)

-- | Sets a custom variable in the sandbox monad.
setVariable :: Serialize a
            => String    -- ^ Variable key for future reference
            -> a         -- ^ Variable value
            -> 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

-- | Checks that a custom sandbox variable is set.
checkVariable :: String       -- ^ Variable key
              -> 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

-- | Returns the value of a previously set sandbox variable (or a provided default value if unset)
getVariable :: Serialize a
            => String    -- ^ Variable key
            -> a         -- ^ Default value if not found
            -> Sandbox a
getVariable :: 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

-- | Unsets a custom variable.
unsetVariable :: String     -- ^ Variable key
              -> 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

-- Structures to store Sandbox options for future use.
-- Not expected to be used directly by the user.

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__"