module System.Process.Read.Chars (
ListLikePlus(..),
readCreateProcessWithExitCode,
readCreateProcess,
readProcessWithExitCode,
readProcess,
) where
import Control.Concurrent
import Control.Exception as E (SomeException, onException, evaluate, catch, try, throwIO, mask)
import Control.Monad
import Data.ListLike (ListLike(..), ListLikeIO(..))
import Data.ListLike.Text.Text ()
import Data.ListLike.Text.TextLazy ()
import GHC.IO.Exception (IOErrorType(OtherError, ResourceVanished), IOException(ioe_type))
import Prelude hiding (null, length)
import System.Exit (ExitCode(ExitSuccess, ExitFailure))
import System.IO hiding (hPutStr, hGetContents)
import qualified System.IO.Error as IO
import System.Process (CreateProcess(..), StdStream(CreatePipe, Inherit), proc,
CmdSpec(RawCommand, ShellCommand), showCommandForUser,
createProcess, waitForProcess, terminateProcess)
class (Integral (LengthType a), ListLikeIO a c) => ListLikePlus a c where
type LengthType a
binary :: a -> [Handle] -> IO ()
lazy :: a -> Bool
length' :: a -> LengthType a
readCreateProcessWithExitCode
:: forall a c.
ListLikePlus a c =>
CreateProcess
-> a
-> IO (ExitCode, a, a)
readCreateProcessWithExitCode p input = mask $ \restore -> do
(Just inh, Just outh, Just errh, pid) <-
createProcess (p {std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe })
flip onException
(do hClose inh; hClose outh; hClose errh;
terminateProcess pid; waitForProcess pid) $ restore $ do
(out, err) <- (if lazy input then readLazy else readStrict) inh outh errh
hClose outh
hClose errh
ex <- waitForProcess pid
return (ex, out, err)
where
readLazy :: Handle -> Handle -> Handle -> IO (a, a)
readLazy inh outh errh =
do out <- hGetContents outh
waitOut <- forkWait $ void $ force $ out
err <- hGetContents errh
waitErr <- forkWait $ void $ force $ err
writeInput inh
waitOut
waitErr
return (out, err)
readStrict :: Handle -> Handle -> Handle -> IO (a, a)
readStrict inh outh errh =
do
waitOut <- forkWait $ hGetContents outh
waitErr <- forkWait $ hGetContents errh
writeInput inh
out <- waitOut
err <- waitErr
return (out, err)
writeInput :: Handle -> IO ()
writeInput inh = do
(do unless (null input) (hPutStr inh input >> hFlush inh)
hClose inh) `E.catch` resourceVanished (\ _ -> return ())
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
(Just inh, Just outh, _, pid) <-
createProcess (p {std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit })
flip onException
(do hClose inh; hClose outh;
terminateProcess pid; waitForProcess pid) $ restore $ do
out <- (if lazy input then readLazy else readStrict) inh outh
hClose outh
ex <- waitForProcess pid
case ex of
ExitSuccess -> return out
ExitFailure r -> ioError (mkError "readCreateProcess: " (cmdspec p) r)
where
readLazy inh outh =
do
out <- hGetContents outh
waitOut <- forkWait $ void $ force $ out
writeInput inh
waitOut
return out
readStrict inh outh =
do waitOut <- forkWait $ hGetContents outh
writeInput inh
waitOut
writeInput inh = do
(do unless (null input) (hPutStr inh input >> hFlush inh)
hClose inh) `E.catch` resourceVanished (\ _ -> return ())
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)
resourceVanished :: (IOError -> IO a) -> IOError -> IO a
resourceVanished epipe e = if ioe_type e == ResourceVanished then epipe e else ioError e
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
force :: forall a c. ListLikePlus a c => a -> IO (LengthType a)
force x = evaluate $ length' $ x