{-# LANGUAGE CPP #-}
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
{
RunOptions -> Maybe [(String, String)]
runEnv :: Maybe [(String, String)]
, RunOptions -> Maybe String
runUser :: Maybe String
, RunOptions -> Maybe String
runGroup :: Maybe String
, RunOptions -> Maybe String
runWorkDir :: Maybe FilePath
, RunOptions -> Int
runExitTimeoutSec :: Int
} deriving Int -> RunOptions -> ShowS
[RunOptions] -> ShowS
RunOptions -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RunOptions] -> ShowS
$cshowList :: [RunOptions] -> ShowS
show :: RunOptions -> String
$cshow :: RunOptions -> String
showsPrec :: Int -> RunOptions -> ShowS
$cshowsPrec :: Int -> RunOptions -> ShowS
Show
defaultRunOptions :: RunOptions
defaultRunOptions :: RunOptions
defaultRunOptions = RunOptions
{ runEnv :: Maybe [(String, String)]
runEnv = forall a. Maybe a
Nothing
, runUser :: Maybe String
runUser = forall a. Maybe a
Nothing
, runGroup :: Maybe String
runGroup = forall a. Maybe a
Nothing
, runWorkDir :: Maybe String
runWorkDir = forall a. Maybe a
Nothing
, runExitTimeoutSec :: Int
runExitTimeoutSec = Int
5 }
getRunEnv :: RunOptions -> Maybe [(String, String)]
getRunEnv :: RunOptions -> Maybe [(String, String)]
getRunEnv = RunOptions -> Maybe [(String, String)]
runEnv
setRunEnv :: [(String, String)] -> RunOptions -> RunOptions
setRunEnv :: [(String, String)] -> RunOptions -> RunOptions
setRunEnv [(String, String)]
env' RunOptions
opts = RunOptions
opts { runEnv :: Maybe [(String, String)]
runEnv = forall a. a -> Maybe a
Just [(String, String)]
env' }
getRunUser :: RunOptions -> Maybe String
getRunUser :: RunOptions -> Maybe String
getRunUser = RunOptions -> Maybe String
runUser
setRunUser :: String -> RunOptions -> RunOptions
setRunUser :: String -> RunOptions -> RunOptions
setRunUser String
user RunOptions
opts = RunOptions
opts { runUser :: Maybe String
runUser = forall a. a -> Maybe a
Just String
user }
getRunGroup :: RunOptions -> Maybe String
getRunGroup :: RunOptions -> Maybe String
getRunGroup = RunOptions -> Maybe String
runGroup
setRunGroup :: String -> RunOptions -> RunOptions
setRunGroup :: String -> RunOptions -> RunOptions
setRunGroup String
group RunOptions
opts = RunOptions
opts { runGroup :: Maybe String
runGroup = forall a. a -> Maybe a
Just String
group }
getRunWorkDir :: RunOptions -> Maybe FilePath
getRunWorkDir :: RunOptions -> Maybe String
getRunWorkDir = RunOptions -> Maybe String
runWorkDir
setRunWorkDir :: FilePath -> RunOptions -> RunOptions
setRunWorkDir :: String -> RunOptions -> RunOptions
setRunWorkDir String
dir RunOptions
opts = RunOptions
opts { runWorkDir :: Maybe String
runWorkDir = forall a. a -> Maybe a
Just String
dir }
getRunExitTimeoutSec :: RunOptions -> Int
getRunExitTimeoutSec :: RunOptions -> Int
getRunExitTimeoutSec = RunOptions -> Int
runExitTimeoutSec
setRunExitTimeoutSec :: Int -> RunOptions -> RunOptions
setRunExitTimeoutSec :: Int -> RunOptions -> RunOptions
setRunExitTimeoutSec Int
sec RunOptions
opts = RunOptions
opts { runExitTimeoutSec :: Int
runExitTimeoutSec = Int
sec }
run :: FilePath
-> [String]
-> Maybe [(String, String)]
-> IO a
run :: forall a. String -> [String] -> Maybe [(String, String)] -> IO a
run String
cmd [String]
args Maybe [(String, String)]
env' = forall a. RunOptions -> String -> [String] -> IO a
runWithOptions (RunOptions
defaultRunOptions {runEnv :: Maybe [(String, String)]
runEnv = Maybe [(String, String)]
env'}) String
cmd [String]
args
runWithOptions :: RunOptions
-> FilePath
-> [String]
-> IO a
runWithOptions :: forall a. RunOptions -> String -> [String] -> IO a
runWithOptions RunOptions
opts String
cmd [String]
args = do
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (RunOptions -> Maybe String
runGroup RunOptions
opts) forall a b. (a -> b) -> a -> b
$ \String
name -> do
GroupEntry
entry <- String -> IO GroupEntry
getGroupEntryForName String
name
GroupID -> IO ()
setGroupID forall a b. (a -> b) -> a -> b
$ GroupEntry -> GroupID
groupID GroupEntry
entry
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (RunOptions -> Maybe String
runUser RunOptions
opts) forall a b. (a -> b) -> a -> b
$ \String
name -> do
UserEntry
entry <- String -> IO UserEntry
getUserEntryForName String
name
UserID -> IO ()
setUserID forall a b. (a -> b) -> a -> b
$ UserEntry -> UserID
userID UserEntry
entry
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (RunOptions -> Maybe String
runWorkDir RunOptions
opts) String -> IO ()
setCurrentDirectory
let env' :: Maybe [(String, String)]
env' = RunOptions -> Maybe [(String, String)]
runEnv RunOptions
opts
timeout :: Int
timeout = RunOptions -> Int
runExitTimeoutSec RunOptions
opts
ProcessID
myID <- IO ProcessID
getProcessID
if ProcessID
myID forall a. Eq a => a -> a -> Bool
== ProcessID
1
then forall a.
String -> [String] -> Maybe [(String, String)] -> Int -> IO a
runAsPID1 String
cmd [String]
args Maybe [(String, String)]
env' Int
timeout
else forall a.
String -> Bool -> [String] -> Maybe [(String, String)] -> IO a
executeFile String
cmd Bool
True [String]
args Maybe [(String, String)]
env'
runAsPID1 :: FilePath -> [String] -> Maybe [(String, String)] -> Int -> IO a
runAsPID1 :: forall a.
String -> [String] -> Maybe [(String, String)] -> Int -> IO a
runAsPID1 String
cmd [String]
args Maybe [(String, String)]
env' Int
timeout = do
MVar ()
killChildrenVar <- forall a. IO (MVar a)
newEmptyMVar
let startKilling :: IO ()
startKilling = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
killChildrenVar ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigTERM (IO () -> Handler
Catch IO ()
startKilling) forall a. Maybe a
Nothing
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigINT (IO () -> Handler
Catch IO ()
startKilling) forall a. Maybe a
Nothing
(Maybe Handle
Nothing, Maybe Handle
Nothing, Maybe Handle
Nothing, ProcessHandle
ph) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (String -> [String] -> CreateProcess
proc String
cmd [String]
args)
{ env :: Maybe [(String, String)]
env = Maybe [(String, String)]
env'
}
ProcessHandle__
p_ <- forall a.
ProcessHandle
-> (ProcessHandle__ -> IO (ProcessHandle__, a)) -> IO a
modifyProcessHandle ProcessHandle
ph forall a b. (a -> b) -> a -> b
$ \ProcessHandle__
p_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessHandle__
p_, ProcessHandle__
p_)
ProcessID
child <-
case ProcessHandle__
p_ of
ClosedHandle ExitCode
e -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False (forall a. ExitCode -> IO a
exitWith ExitCode
e)
OpenHandle ProcessID
pid -> forall (m :: * -> *) a. Monad m => a -> m a
return ProcessID
pid
OpenExtHandle ProcessID
pid ProcessID
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ProcessID
pid
ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
forall a. MVar a -> IO a
takeMVar MVar ()
killChildrenVar
ProcessID -> Int -> IO ()
killAllChildren ProcessID
child Int
timeout
forall a. IO () -> ProcessID -> IO a
reap IO ()
startKilling ProcessID
child
reap :: IO () -> CPid -> IO a
reap :: forall a. IO () -> ProcessID -> IO a
reap IO ()
startKilling ProcessID
child = do
MVar ProcessStatus
childStatus <- forall a. IO (MVar a)
newEmptyMVar
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (MVar ProcessStatus -> IO ()
reapOne MVar ProcessStatus
childStatus) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOError
e ->
if IOError -> Bool
isDoesNotExistError IOError
e
then do
forall a. MVar a -> IO a
takeMVar MVar ProcessStatus
childStatus forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExitCode -> IO ()
exitImmediately forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessStatus -> ExitCode
toExitCode
forall a. (?callStack::CallStack) => String -> a
error String
"This can never be reached"
else forall e a. Exception e => e -> IO a
throwIO IOError
e
where
reapOne :: MVar ProcessStatus -> IO ()
reapOne MVar ProcessStatus
childStatus = do
Maybe (ProcessID, ProcessStatus)
mres <- Bool -> Bool -> IO (Maybe (ProcessID, ProcessStatus))
getAnyProcessStatus Bool
True Bool
False
case Maybe (ProcessID, ProcessStatus)
mres of
Maybe (ProcessID, ProcessStatus)
Nothing -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False (forall (m :: * -> *) a. Monad m => a -> m a
return ())
Just (ProcessID
pid, ProcessStatus
status)
| ProcessID
pid forall a. Eq a => a -> a -> Bool
== ProcessID
child -> do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ProcessStatus
childStatus ProcessStatus
status
IO ()
startKilling
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
killAllChildren :: CPid -> Int -> IO ()
killAllChildren :: ProcessID -> Int -> IO ()
killAllChildren ProcessID
cid Int
timeout = do
Signal -> ProcessID -> IO ()
signalProcess Signal
sigTERM ProcessID
cid forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOError
e ->
if IOError -> Bool
isDoesNotExistError IOError
e
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else forall e a. Exception e => e -> IO a
throwIO IOError
e
Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ Int
timeout forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000
Signal -> ProcessID -> IO ()
signalProcess Signal
sigTERM (-ProcessID
1) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOError
e ->
if IOError -> Bool
isDoesNotExistError IOError
e
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else forall e a. Exception e => e -> IO a
throwIO IOError
e
Int -> IO ()
threadDelay forall a b. (a -> b) -> a -> b
$ Int
timeout forall a. Num a => a -> a -> a
* Int
1000 forall a. Num a => a -> a -> a
* Int
1000
Signal -> ProcessID -> IO ()
signalProcess Signal
sigKILL (-ProcessID
1) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOError
e ->
if IOError -> Bool
isDoesNotExistError IOError
e
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else forall e a. Exception e => e -> IO a
throwIO IOError
e
toExitCode :: ProcessStatus -> ExitCode
toExitCode :: ProcessStatus -> ExitCode
toExitCode (Exited ExitCode
ec) = ExitCode
ec
#if MIN_VERSION_unix(2, 7, 0)
toExitCode (Terminated Signal
sig Bool
_) = Signal -> ExitCode
signalToEC Signal
sig
#else
toExitCode (Terminated sig) = signalToEC sig
#endif
toExitCode (Stopped Signal
sig) = Signal -> ExitCode
signalToEC Signal
sig
signalToEC :: Signal -> ExitCode
signalToEC :: Signal -> ExitCode
signalToEC Signal
sig = Int -> ExitCode
ExitFailure (forall a b. (Integral a, Num b) => a -> b
fromIntegral Signal
sig forall a. Num a => a -> a -> a
+ Int
128)