module System.Process.ListLike (
ListLikePlus(..),
readProcessInterleaved,
readInterleaved,
readCreateProcessWithExitCode,
readCreateProcess,
readProcessWithExitCode,
readProcess,
showCmdSpecForUser
) where
import Control.Concurrent
import Control.Exception as E (SomeException, onException, catch, try, throwIO, mask, throw)
import Control.Monad
import Data.ListLike (ListLike(..), ListLikeIO(..))
import Data.ListLike.Text.Text ()
import Data.ListLike.Text.TextLazy ()
import Data.Monoid (Monoid(mempty, mappend), (<>))
import GHC.IO.Exception (IOErrorType(OtherError, ResourceVanished), IOException(ioe_type))
import Prelude hiding (null, length, rem)
import System.Exit (ExitCode(ExitSuccess, ExitFailure))
import System.IO hiding (hPutStr, hGetContents)
import qualified System.IO.Error as IO
import System.IO.Unsafe (unsafeInterleaveIO)
import System.Process (ProcessHandle, CreateProcess(..), StdStream(CreatePipe, Inherit), proc,
CmdSpec(RawCommand, ShellCommand), showCommandForUser,
createProcess, waitForProcess, terminateProcess)
class ListLikeIO a c => ListLikePlus a c where
setModes :: a -> (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
readChunks :: Handle -> IO [a]
readProcessInterleaved :: (ListLikePlus a c, Monoid b) =>
(ProcessHandle -> b) -> (ExitCode -> b) -> (a -> b) -> (a -> b)
-> CreateProcess -> a -> IO b
readProcessInterleaved pidf codef outf errf p input = mask $ \ restore -> do
hs@(Just inh, Just outh, Just errh, pid) <-
createProcess (p {std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe })
setModes input hs
flip onException
(do hClose inh; hClose outh; hClose errh;
terminateProcess pid; waitForProcess pid) $ restore $ do
waitOut <- forkWait $ readInterleaved (pidf pid) [(outf, outh), (errf, errh)] $ waitForProcess pid >>= return . codef
writeInput inh input
waitOut
readInterleaved :: forall a b c. (ListLikePlus a c, Monoid b) => b -> [(a -> b, Handle)] -> IO b -> IO b
readInterleaved start pairs finish = newEmptyMVar >>= readInterleaved' start pairs finish
readInterleaved' :: forall a b c. (ListLikePlus a c, Monoid b) =>
b -> [(a -> b, Handle)] -> IO b -> MVar (Either Handle b) -> IO b
readInterleaved' start pairs finish res = do
mapM_ (forkIO . uncurry readHandle) pairs
r <- takeChunks (length pairs)
return $ start <> r
where
readHandle :: (a -> b) -> Handle -> IO ()
readHandle f h = do
cs <- readChunks h
mapM_ (\ c -> putMVar res (Right (f c))) cs
hClose h
putMVar res (Left h)
takeChunks :: Int -> IO b
takeChunks 0 = finish
takeChunks openCount = takeMVar res >>= takeChunk openCount
takeChunk :: Int -> Either Handle b -> IO b
takeChunk openCount (Left h) = hClose h >> takeChunks (openCount 1)
takeChunk openCount (Right x) =
do xs <- unsafeInterleaveIO $ takeChunks openCount
return (x <> xs)
readCreateProcessWithExitCode
:: forall a c.
ListLikePlus a c =>
CreateProcess
-> a
-> IO (ExitCode, a, a)
readCreateProcessWithExitCode p input =
readProcessInterleaved (\ _ -> mempty)
(\ c -> (c, mempty, mempty))
(\ x -> (mempty, x, mempty))
(\ x -> (mempty, mempty, x))
p input
readProcessWithExitCode
:: ListLikePlus a c =>
FilePath
-> [String]
-> a
-> IO (ExitCode, a, a)
readProcessWithExitCode cmd args input = readCreateProcessWithExitCode (proc cmd args) input
readProcess
:: ListLikePlus a c =>
FilePath
-> [String]
-> a
-> IO a
readProcess cmd args = readCreateProcess (proc cmd args)
readCreateProcess
:: ListLikePlus a c =>
CreateProcess
-> a
-> IO a
readCreateProcess p input = mask $ \restore -> do
hs@(Just inh, Just outh, _, pid) <-
createProcess (p {std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit })
setModes input hs
flip onException
(do hClose inh; hClose outh;
terminateProcess pid; waitForProcess pid) $ restore $ do
waitOut <- forkWait $ readInterleaved mempty [(id, outh)] $ waitForProcess pid >>= codef
writeInput inh input
waitOut
where
codef (ExitFailure r) = throw (mkError "readCreateProcess: " (cmdspec p) r)
codef ExitSuccess = return mempty
writeInput :: ListLikePlus a c => Handle -> a -> IO ()
writeInput inh input = do
(do unless (null input) (hPutStr inh input >> hFlush inh)
hClose inh) `E.catch` resourceVanished (\ _ -> return ())
resourceVanished :: (IOError -> IO a) -> IOError -> IO a
resourceVanished epipe e = if ioe_type e == ResourceVanished then epipe e else ioError e
forkWait :: IO a -> IO (IO a)
forkWait a = do
res <- newEmptyMVar
_ <- mask $ \restore -> forkIO $ try (restore a) >>= putMVar res
return (takeMVar res >>= either (\ex -> throwIO (ex :: SomeException)) return)
mkError :: String -> CmdSpec -> Int -> IOError
mkError prefix (RawCommand cmd args) r =
IO.mkIOError OtherError (prefix ++ showCommandForUser cmd args ++ " (exit " ++ show r ++ ")")
Nothing Nothing
mkError prefix (ShellCommand cmd) r =
IO.mkIOError OtherError (prefix ++ cmd ++ " (exit " ++ show r ++ ")")
Nothing Nothing
instance Monoid ExitCode where
mempty = ExitFailure 0
mappend x (ExitFailure 0) = x
mappend _ x = x
showCmdSpecForUser :: CmdSpec -> String
showCmdSpecForUser (ShellCommand s) = s
showCmdSpecForUser (RawCommand p args) = showCommandForUser p args