module System.Process.ListLike.Read
( readCreateProcess,
readCreateProcess',
readInterleaved,
readCreateProcessWithExitCode,
readProcessWithExitCode,
StdoutWrapper(..),
readProcess
) where
import Control.Applicative ((<$>), (<*>), pure)
import Control.Concurrent
import Control.Exception as E (SomeException, onException, catch, mask, throw)
import Control.Monad
import Data.ListLike (ListLike(..), ListLikeIO(..))
import Data.ListLike.Text.Text ()
import Data.ListLike.Text.TextLazy ()
import Data.Maybe (maybeToList)
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))
import System.IO hiding (hPutStr, hGetContents)
import qualified System.IO.Error as IO
import System.IO.Unsafe (unsafeInterleaveIO)
import System.Process (CreateProcess(..), StdStream(CreatePipe, Inherit), proc,
createProcess, waitForProcess, terminateProcess)
import System.Process.ListLike.Classes (ListLikeLazyIO(..), ProcessOutput(..))
import System.Process.ListLike.Instances ()
import Utils (forkWait)
readCreateProcess :: (ListLikeLazyIO a c, ProcessOutput a b) => CreateProcess -> a -> IO b
readCreateProcess p input =
readCreateProcess' (p {std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }) input
readCreateProcess' :: (ListLikeLazyIO a c, ProcessOutput a b) => CreateProcess -> a -> IO b
readCreateProcess' p input = mask $ \ restore -> do
(Just inh, maybe_outh, maybe_errh, pid) <- createProcess p
onException
(restore $
do
waitOut <- forkWait $ (<>) <$> pure (pidf pid)
<*> unsafeInterleaveIO (readInterleaved (maybeToList (fmap (outf,) maybe_outh) <> maybeToList (fmap (errf,) maybe_errh))
(codef <$> waitForProcess pid))
writeInput inh input
waitOut)
(do terminateProcess pid
hClose inh
maybe (return ()) hClose maybe_outh
maybe (return ()) hClose maybe_errh
waitForProcess pid)
readInterleaved :: forall a b c. (ListLikeLazyIO a c, ProcessOutput a b) =>
[(a -> b, Handle)] -> IO b -> IO b
readInterleaved pairs finish = newEmptyMVar >>= readInterleaved' pairs finish
readInterleaved' :: forall a b c. (ListLikeLazyIO a c, ProcessOutput a b) =>
[(a -> b, Handle)] -> IO b -> MVar (Either Handle b) -> IO b
readInterleaved' pairs finish res = do
mapM_ (forkIO . uncurry readHandle) pairs
takeChunks (length pairs)
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 = takeChunk >>= takeMore openCount
takeMore :: Int -> Either Handle b -> IO b
takeMore openCount (Left h) = hClose h >> takeChunks (openCount 1)
takeMore openCount (Right x) =
do xs <- unsafeInterleaveIO $ takeChunks openCount
return (x <> xs)
takeChunk = takeMVar res `catch` (\ (e :: SomeException) -> return $ Right $ intf e)
readCreateProcessWithExitCode :: ListLikeLazyIO a c =>
CreateProcess
-> a
-> IO (ExitCode, a, a)
readCreateProcessWithExitCode p input = readCreateProcess p input
readProcessWithExitCode :: ListLikeLazyIO a c =>
FilePath
-> [String]
-> a
-> IO (ExitCode, a, a)
readProcessWithExitCode cmd args input = readCreateProcessWithExitCode (proc cmd args) input
readProcess :: ListLikeLazyIO a c =>
FilePath
-> [String]
-> a
-> IO a
readProcess cmd args input =
unStdoutWrapper <$> readCreateProcess' ((proc cmd args) {std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit}) input
newtype StdoutWrapper a = StdoutWrapper {unStdoutWrapper :: a}
instance Monoid a => Monoid (StdoutWrapper a) where
mempty = StdoutWrapper mempty
mappend (StdoutWrapper a) (StdoutWrapper b) = StdoutWrapper (a <> b)
instance (ListLikeLazyIO a c, Monoid a) => ProcessOutput a (StdoutWrapper a) where
pidf _ = mempty
codef ExitSuccess = mempty
codef failure = throw $ IO.mkIOError OtherError ("Process exited with " ++ show failure) Nothing Nothing
outf x = StdoutWrapper x
errf _ = mempty
intf e = throw e
writeInput :: ListLikeLazyIO 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