module System.Unix.Process
(
simpleProcess
, processResult
, processOutput
, simpleCommand
, commandResult
, commandOutput
, Process
, Output(Stdout, Stderr, Result)
, lazyRun
, lazyCommand
, lazyProcess
, stdoutOnly
, stderrOnly
, outputOnly
, checkResult
, discardStdout
, discardStderr
, discardOutput
, mergeToStderr
, mergeToStdout
, collectStdout
, collectStderr
, collectOutput
, collectOutputUnpacked
, ExitCode(ExitSuccess, ExitFailure)
, exitCodeOnly
, hPutNonBlocking
, killByCwd
) where
import Control.Monad
import Control.Exception hiding (catch)
import Control.Parallel.Strategies
import Data.Char
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy.Char8 as L
import Data.ByteString.Internal(toForeignPtr)
import Data.List
import Data.Word
import Data.Int
import System.Process
import System.IO
import System.IO.Unsafe
import System.Directory
import System.Exit
import System.Posix.Files
import System.Posix.Signals
import System.Posix.Unistd (usleep)
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Marshal.Array (peekArray, pokeArray)
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)
simpleProcess :: FilePath -> [String] -> IO (String, String, ExitCode)
simpleProcess exec args =
do (inp,out,err,pid) <- runInteractiveProcess exec args Nothing Nothing
hClose inp
outStr <- hGetContents out
errStr <- hGetContents err
evaluate (rnf outStr)
evaluate (rnf errStr)
ec <- waitForProcess pid
return (outStr, errStr, ec)
processResult :: FilePath -> [String] -> IO (Either Int (String, String))
processResult exec args =
simpleProcess exec args >>= return . resultOrCode
where
resultOrCode (_, _, ExitFailure n) = Left n
resultOrCode (out, err, ExitSuccess) = Right (out, err)
processOutput :: FilePath -> [String] -> IO (Either Int String)
processOutput exec args =
simpleProcess exec args >>= return . outputOrCode
where
outputOrCode (_, _, ExitFailure n) = Left n
outputOrCode (out, _, ExitSuccess) = Right out
simpleCommand :: String -> IO (String, String, ExitCode)
simpleCommand cmd =
do (inp,out,err,pid) <- runInteractiveCommand cmd
hClose inp
outStr <- hGetContents out
errStr <- hGetContents err
evaluate (rnf outStr)
evaluate (rnf errStr)
ec <- waitForProcess pid
return (outStr, errStr, ec)
commandResult :: String -> IO (Either Int (String, String))
commandResult cmd =
simpleCommand cmd >>= return . resultOrCode
where
resultOrCode (_, _, ExitFailure n) = Left n
resultOrCode (out, err, ExitSuccess) = Right (out, err)
commandOutput :: String -> IO (Either Int String)
commandOutput cmd =
simpleCommand cmd >>= return . outputOrCode
where
outputOrCode (_, _, ExitFailure n) = Left n
outputOrCode (out, _, ExitSuccess) = Right out
type Process = (Handle, Handle, Handle, ProcessHandle)
data Output
= Stdout B.ByteString
| Stderr B.ByteString
| Result ExitCode
deriving Show
showBrief :: B.ByteString -> String
showBrief s =
let l = B.length s in
show (B.take (min 30 l) s) ++
if l > 30 then " ... (" ++ show (l 30) ++ " additional bytes)" else ""
bufSize = 65536
uSecs = 8
maxUSecs = 100000
ePut :: Int -> String -> IO ()
ePut minv s = if curv >= minv then hPutStr stderr s else return ()
ePut0 = ePut 0
ePut1 = ePut 1
ePut2 = ePut 2
curv = 0
lazyCommand :: String -> L.ByteString -> IO [Output]
lazyCommand cmd input = runInteractiveCommand cmd >>= lazyRun input
lazyProcess :: FilePath -> [String] -> Maybe FilePath
-> Maybe [(String, String)] -> L.ByteString -> IO [Output]
lazyProcess exec args cwd env input =
runInteractiveProcess exec args cwd env >>= lazyRun input
lazyRun :: L.ByteString -> Process -> IO [Output]
lazyRun input (inh, outh, errh, pid) =
elements (L.toChunks input, Just inh, Just outh, Just errh, [])
where
elements :: ([B.ByteString], Maybe Handle, Maybe Handle, Maybe Handle, [Output]) -> IO [Output]
elements (_, _, Nothing, Nothing, elems) =
do result <- waitForProcess pid
return $ elems ++ [Result result]
elements tl@(_, _, _, _, []) = ready uSecs tl >>= elements
elements (input, inh, outh, errh, elems) =
do
etc <- unsafeInterleaveIO (elements (input, inh, outh, errh, []))
return $ elems ++ etc
ready :: Int -> ([B.ByteString], Maybe Handle, Maybe Handle, Maybe Handle, [Output])
-> IO ([B.ByteString], Maybe Handle, Maybe Handle, Maybe Handle, [Output])
ready waitUSecs (input, inh, outh, errh, elems) =
do
outReady <- maybe (return False) hReady outh
errReady <- maybe (return False) hReady errh
case (input, inh, outReady, errReady) of
([], Just handle, False, False) ->
do hClose handle
ready waitUSecs ([], Nothing, outh, errh, elems)
([], Nothing, False, False) ->
do usleep uSecs
ready (min maxUSecs (2 * waitUSecs)) (input, inh, outh, errh, elems)
(input : etc, Just handle, False, False)
| input == B.empty -> ready waitUSecs (etc, inh, outh, errh, elems)
| True ->
do count' <- hPutNonBlocking handle input >>= return . fromInteger . toInteger
case count' of
0 -> do usleep 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) -> Bool -> (B.ByteString -> Output) -> IO ([Output], Maybe Handle)
nextOut Nothing _ _ = return ([], Nothing)
nextOut handle False _ = return ([], handle)
nextOut (Just handle) True 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 :: [Output] -> L.ByteString
stdoutOnly out =
L.fromChunks $ f out
where
f (Stdout s : etc) = s : f etc
f (_ : etc) = f etc
f [] = []
stderrOnly :: [Output] -> L.ByteString
stderrOnly out =
L.fromChunks $ f out
where
f (Stderr s : etc) = s : f etc
f (_ : etc) = f etc
f [] = []
outputOnly :: [Output] -> 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 :: [Output] -> [ExitCode]
exitCodeOnly (Result code : etc) = code : exitCodeOnly etc
exitCodeOnly (_ : etc) = exitCodeOnly etc
exitCodeOnly [] = []
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 -> [Output] -> 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 :: [Output] -> [Output]
discardStdout (Stdout _ : more) = discardStdout more
discardStdout (x : more) = x : discardStdout more
discardStdout [] = []
discardStderr :: [Output] -> [Output]
discardStderr (Stderr _ : more) = discardStderr more
discardStderr (x : more) = x : discardStderr more
discardStderr [] = []
discardOutput :: [Output] -> [Output]
discardOutput = discardStdout . discardStderr
mergeToStderr :: [Output] -> [Output]
mergeToStderr output =
map merge output
where
merge (Stdout s) = Stderr s
merge x = x
mergeToStdout :: [Output] -> [Output]
mergeToStdout output =
map merge output
where
merge (Stderr s) = Stdout s
merge x = x
collectStdout :: [Output] -> (L.ByteString, [Output])
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 :: [Output] -> (L.ByteString, [Output])
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 :: [Output] -> (L.ByteString, L.ByteString, [ExitCode])
collectOutput output =
(L.fromChunks out, L.fromChunks err, code)
where
(out, err, code) = foldr collect ([], [], []) output
collect (Stdout s) (out, err, result) = (s : out, err, result)
collect (Stderr s) (out, err, result) = (out, s : err, result)
collect (Result r) (out, err, result) = (out, err, r : result)
collectOutputUnpacked :: [Output] -> (String, String, [ExitCode])
collectOutputUnpacked =
unpack . collectOutput
where unpack (out, err, result) = (L.unpack out, L.unpack err, result)