module System.Unix.Process
(
Process
, Output(Stdout, Stderr, Result)
, lazyRun
, lazyCommand
, lazyProcess
, stdoutOnly
, stderrOnly
, outputOnly
, checkResult
, discardStdout
, discardStderr
, discardOutput
, mergeToStderr
, mergeToStdout
, collectStdout
, collectStderr
, collectOutput
, collectOutputUnpacked
, collectResult
, ExitCode(ExitSuccess, ExitFailure)
, exitCodeOnly
, hPutNonBlocking
, killByCwd
) where
import Control.Concurrent (threadDelay)
import Control.Monad (liftM, filterM)
import Control.Monad.Trans (MonadIO(liftIO))
import Data.Char (isDigit)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as C
import Data.ByteString.Internal(toForeignPtr)
import Data.List (isPrefixOf, partition)
import Data.Int (Int64)
import qualified GHC.IO.Exception as E
import System.Process (ProcessHandle, waitForProcess, runInteractiveProcess, runInteractiveCommand)
import System.IO (Handle, hSetBinaryMode, hReady, hPutBufNonBlocking, hClose )
import System.IO.Unsafe (unsafeInterleaveIO)
import System.Directory (getDirectoryContents)
import System.Exit (ExitCode(ExitFailure, ExitSuccess))
import System.Posix.Files (readSymbolicLink)
import System.Posix.Signals (signalProcess, sigTERM)
import Foreign.Ptr (plusPtr)
import Foreign.ForeignPtr (withForeignPtr)
killByCwd :: FilePath -> IO [(String, Maybe String)]
killByCwd path =
do pids <- liftM (filter (all isDigit)) (getDirectoryContents "/proc")
cwdPids <- filterM (isCwd path) pids
exePaths <- mapM exePath cwdPids
mapM_ kill cwdPids
return (zip cwdPids exePaths)
where
isCwd :: FilePath -> String -> IO Bool
isCwd cwd pid =
catch (liftM (isPrefixOf cwd) (readSymbolicLink ("/proc/" ++ pid ++"/cwd"))) (const (return False))
exePath :: String -> IO (Maybe String)
exePath pid = catch (readSymbolicLink ("/proc/" ++ pid ++"/exe") >>= return . Just) (const (return Nothing))
kill :: String -> IO ()
kill pidStr = signalProcess sigTERM (read pidStr)
type Process = (Handle, Handle, Handle, ProcessHandle)
data Output
= Stdout B.ByteString
| Stderr B.ByteString
| Result ExitCode
deriving Show
type Outputs = [Output]
bufSize = 65536
uSecs = 8
maxUSecs = 100000
lazyCommand :: MonadIO m => String -> L.ByteString -> m Outputs
lazyCommand cmd input = liftIO (runInteractiveCommand cmd) >>= lazyRun input
lazyProcess :: MonadIO m =>
FilePath
-> [String]
-> Maybe FilePath
-> Maybe [(String, String)]
-> L.ByteString
-> m Outputs
lazyProcess exec args cwd env input =
liftIO (runInteractiveProcess exec args cwd env) >>= lazyRun input
lazyRun :: MonadIO m => L.ByteString -> Process -> m Outputs
lazyRun input (inh, outh, errh, pid) =
liftIO (hSetBinaryMode inh True >>
hSetBinaryMode outh True >>
hSetBinaryMode errh True >>
elements (L.toChunks input, Just inh, Just outh, Just errh, []))
where
elements :: ([B.ByteString], Maybe Handle, Maybe Handle, Maybe Handle, Outputs) -> IO Outputs
elements (_, _, Nothing, Nothing, elems) =
do result <- waitForProcess pid
return $ Result result : elems
elements tl@(_, _, _, _, []) = ready uSecs tl >>= elements
elements (input, inh, outh, errh, elems) =
do
etc <- unsafeInterleaveIO (elements (input, inh, outh, errh, []))
return $ elems ++ etc
data Readyness = Ready | Unready | EndOfFile
hReady' :: Handle -> IO Readyness
hReady' h = (hReady h >>= (\ flag -> return (if flag then Ready else Unready))) `catch` (\ (e :: IOError) ->
case E.ioe_type e of
E.EOF -> return EndOfFile
_ -> error (show e))
ready :: Int -> ([B.ByteString], Maybe Handle, Maybe Handle, Maybe Handle, Outputs)
-> IO ([B.ByteString], Maybe Handle, Maybe Handle, Maybe Handle, Outputs)
ready waitUSecs (input, inh, outh, errh, elems) =
do
outReady <- maybe (return Unready) hReady' outh
errReady <- maybe (return Unready) hReady' errh
case (input, inh, outReady, errReady) of
([], Just handle, Unready, Unready) ->
do hClose handle
ready waitUSecs ([], Nothing, outh, errh, elems)
([], Nothing, Unready, Unready) ->
do threadDelay waitUSecs
ready (min maxUSecs (2 * waitUSecs)) (input, inh, outh, errh, elems)
(input : etc, Just handle, Unready, Unready)
| input == B.empty -> ready waitUSecs (etc, inh, outh, errh, elems)
| True ->
do count' <- hPutNonBlocking handle input >>= return . fromInteger . toInteger
case count' of
0 -> do threadDelay uSecs
ready (min maxUSecs (2 * waitUSecs)) (input : etc, inh, outh, errh, elems)
_n -> do let input' = B.drop count' input : etc
return (input', Just handle, outh, errh, elems)
_ ->
do (out1, errh') <- nextOut errh errReady Stderr
(out2, outh') <- nextOut outh outReady Stdout
return (input, inh, outh', errh', elems ++ out1 ++ out2)
nextOut :: (Maybe Handle) -> Readyness -> (B.ByteString -> Output) -> IO (Outputs, Maybe Handle)
nextOut Nothing _ _ = return ([], Nothing)
nextOut _ EndOfFile _ = return ([], Nothing)
nextOut handle Unready _ = return ([], handle)
nextOut (Just handle) Ready constructor =
do
a <- B.hGetNonBlocking handle bufSize
case B.length a of
0 -> do hClose handle
return ([], Nothing)
_n -> return ([constructor a], Just handle)
stdoutOnly :: Outputs -> L.ByteString
stdoutOnly out =
L.fromChunks $ f out
where
f (Stdout s : etc) = s : f etc
f (_ : etc) = f etc
f [] = []
stderrOnly :: Outputs -> L.ByteString
stderrOnly out =
L.fromChunks $ f out
where
f (Stderr s : etc) = s : f etc
f (_ : etc) = f etc
f [] = []
outputOnly :: Outputs -> L.ByteString
outputOnly out =
L.fromChunks $ f out
where
f (Stderr s : etc) = s : f etc
f (Stdout s : etc) = s : f etc
f (_ : etc) = f etc
f [] = []
exitCodeOnly :: Outputs -> ExitCode
exitCodeOnly (Result code : _) = code
exitCodeOnly (_ : etc) = exitCodeOnly etc
exitCodeOnly [] = error "exitCodeOnly - no Result found"
hPutNonBlocking :: Handle -> B.ByteString -> IO Int64
hPutNonBlocking h b =
case toForeignPtr b of
(_, _, 0) -> return 0
(ps, s, l) -> withForeignPtr ps $ \ p-> hPutBufNonBlocking h (p `plusPtr` s) l >>= return . fromInteger . toInteger
checkResult :: (Int -> a) -> a -> Outputs -> a
checkResult _ _ [] = error $ "*** FAILURE: Missing exit code"
checkResult _ onSuccess (Result ExitSuccess : _) = onSuccess
checkResult onFailure _ (Result (ExitFailure n) : _) = onFailure n
checkResult onFailure onSuccess (_ : more) = checkResult onFailure onSuccess more
discardStdout :: Outputs -> Outputs
discardStdout (Stdout _ : more) = discardStdout more
discardStdout (x : more) = x : discardStdout more
discardStdout [] = []
discardStderr :: Outputs -> Outputs
discardStderr (Stderr _ : more) = discardStderr more
discardStderr (x : more) = x : discardStderr more
discardStderr [] = []
discardOutput :: Outputs -> Outputs
discardOutput = discardStdout . discardStderr
mergeToStderr :: Outputs -> Outputs
mergeToStderr output =
map merge output
where
merge (Stdout s) = Stderr s
merge x = x
mergeToStdout :: Outputs -> Outputs
mergeToStdout output =
map merge output
where
merge (Stderr s) = Stdout s
merge x = x
collectStdout :: Outputs -> (L.ByteString, Outputs)
collectStdout output =
(L.fromChunks out, other)
where
(out, other) = foldr collect ([], []) output
collect (Stdout s) (text, result) = (s : text, result)
collect x (text, result) = (text, x : result)
collectStderr :: Outputs -> (L.ByteString, Outputs)
collectStderr output =
(L.fromChunks err, other)
where
(err, other) = foldr collect ([], []) output
collect (Stderr s) (text, result) = (s : text, result)
collect x (text, result) = (text, x : result)
collectOutput :: Outputs -> (L.ByteString, L.ByteString, ExitCode)
collectOutput output =
(L.fromChunks out, L.fromChunks err, code)
where
(out, err, code) = foldr collect ([], [], ExitFailure 666) output
collect (Stdout s) (out, err, result) = (s : out, err, result)
collect (Stderr s) (out, err, result) = (out, s : err, result)
collect (Result result) (out, err, _) = (out, err, result)
collectOutputUnpacked :: Outputs -> (String, String, ExitCode)
collectOutputUnpacked =
unpack . collectOutput
where unpack (out, err, result) = (C.unpack out, C.unpack err, result)
collectResult :: Outputs -> (ExitCode, Outputs)
collectResult output =
unResult (partition isResult output)
where
isResult (Result _) = True
isResult _ = False
unResult ([Result x], out) = (x, out)
unResult _ = error $ "Internal error - wrong number of results"