module System.Process.PID1
( RunOptions
, defaultRunOptions
, getRunEnv
, getRunExitTimeoutSec
, getRunGroup
, getRunUser
, getRunWorkDir
, run
, runWithOptions
, setRunEnv
, setRunExitTimeoutSec
, setRunGroup
, setRunUser
, setRunWorkDir
) where
import Control.Concurrent (forkIO, newEmptyMVar, takeMVar,
threadDelay, tryPutMVar)
import Control.Exception (assert, catch, throwIO)
import Control.Monad (forever, void)
import Data.Foldable (for_)
import System.Directory (setCurrentDirectory)
import System.Exit (ExitCode (ExitFailure), exitWith)
import System.IO.Error (isDoesNotExistError)
import System.Posix.Process (ProcessStatus (..), executeFile,
exitImmediately, getAnyProcessStatus,
getProcessID)
import System.Posix.Signals (Handler (Catch), Signal,
installHandler, sigINT, sigKILL,
sigTERM, signalProcess)
import System.Posix.Types (CPid)
import System.Posix.User (getGroupEntryForName,
getUserEntryForName,
groupID, setGroupID,
setUserID, userID)
import System.Process (createProcess, proc, env)
import System.Process.Internals (ProcessHandle__ (..),
modifyProcessHandle)
data RunOptions = RunOptions
{
runEnv :: Maybe [(String, String)]
, runUser :: Maybe String
, runGroup :: Maybe String
, runWorkDir :: Maybe FilePath
, runExitTimeoutSec :: Int
} deriving Show
defaultRunOptions :: RunOptions
defaultRunOptions = RunOptions
{ runEnv = Nothing
, runUser = Nothing
, runGroup = Nothing
, runWorkDir = Nothing
, runExitTimeoutSec = 5 }
getRunEnv :: RunOptions -> Maybe [(String, String)]
getRunEnv = runEnv
setRunEnv :: [(String, String)] -> RunOptions -> RunOptions
setRunEnv env' opts = opts { runEnv = Just env' }
getRunUser :: RunOptions -> Maybe String
getRunUser = runUser
setRunUser :: String -> RunOptions -> RunOptions
setRunUser user opts = opts { runUser = Just user }
getRunGroup :: RunOptions -> Maybe String
getRunGroup = runGroup
setRunGroup :: String -> RunOptions -> RunOptions
setRunGroup group opts = opts { runGroup = Just group }
getRunWorkDir :: RunOptions -> Maybe FilePath
getRunWorkDir = runWorkDir
setRunWorkDir :: FilePath -> RunOptions -> RunOptions
setRunWorkDir dir opts = opts { runWorkDir = Just dir }
getRunExitTimeoutSec :: RunOptions -> Int
getRunExitTimeoutSec = runExitTimeoutSec
setRunExitTimeoutSec :: Int -> RunOptions -> RunOptions
setRunExitTimeoutSec sec opts = opts { runExitTimeoutSec = sec }
run :: FilePath
-> [String]
-> Maybe [(String, String)]
-> IO a
run cmd args env' = runWithOptions (defaultRunOptions {runEnv = env'}) cmd args
runWithOptions :: RunOptions
-> FilePath
-> [String]
-> IO a
runWithOptions opts cmd args = do
for_ (runGroup opts) $ \name -> do
entry <- getGroupEntryForName name
setGroupID $ groupID entry
for_ (runUser opts) $ \name -> do
entry <- getUserEntryForName name
setUserID $ userID entry
for_ (runWorkDir opts) setCurrentDirectory
let env' = runEnv opts
timeout = runExitTimeoutSec opts
myID <- getProcessID
if myID == 1
then runAsPID1 cmd args env' timeout
else executeFile cmd True args env'
runAsPID1 :: FilePath -> [String] -> Maybe [(String, String)] -> Int -> IO a
runAsPID1 cmd args env' timeout = do
killChildrenVar <- newEmptyMVar
_ <- forkIO $ do
takeMVar killChildrenVar
killAllChildren timeout
let startKilling = void $ tryPutMVar killChildrenVar ()
void $ installHandler sigTERM (Catch startKilling) Nothing
void $ installHandler sigINT (Catch startKilling) Nothing
(Nothing, Nothing, Nothing, ph) <- createProcess (proc cmd args)
{ env = env'
}
p_ <- modifyProcessHandle ph $ \p_ -> return (p_, p_)
child <-
case p_ of
ClosedHandle e -> assert False (exitWith e)
OpenHandle pid -> return pid
reap startKilling child
reap :: IO () -> CPid -> IO a
reap startKilling child = do
childStatus <- newEmptyMVar
forever (reapOne childStatus) `catch` \e ->
if isDoesNotExistError e
then do
takeMVar childStatus >>= exitImmediately . toExitCode
error "This can never be reached"
else throwIO e
where
reapOne childStatus = do
mres <- getAnyProcessStatus True False
case mres of
Nothing -> assert False (return ())
Just (pid, status)
| pid == child -> do
void $ tryPutMVar childStatus status
startKilling
| otherwise -> return ()
killAllChildren :: Int -> IO ()
killAllChildren timeout = do
signalProcess sigTERM (1) `catch` \e ->
if isDoesNotExistError e
then return ()
else throwIO e
threadDelay $ timeout * 1000 * 1000
signalProcess sigKILL (1) `catch` \e ->
if isDoesNotExistError e
then return ()
else throwIO e
toExitCode :: ProcessStatus -> ExitCode
toExitCode (Exited ec) = ec
#if MIN_VERSION_unix(2, 7, 0)
toExitCode (Terminated sig _) = signalToEC sig
#else
toExitCode (Terminated sig) = signalToEC sig
#endif
toExitCode (Stopped sig) = signalToEC sig
signalToEC :: Signal -> ExitCode
signalToEC sig = ExitFailure (fromIntegral sig + 128)