{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module System.Process.Common
( ProcessMaker(process, showProcessMakerForUser)
, ListLikeProcessIO(forceOutput, readChunks)
, ProcessText
, ProcessResult(pidf, outf, errf, intf, codef)
, readProcessWithExitCode
, readCreateProcessWithExitCode
, readCreateProcessStrict
, readCreateProcessLazy
, showCmdSpecForUser
, showCreateProcessForUser
) where
import Control.Concurrent
import Control.Exception as E (SomeException, onException, catch, mask, throw)
import Control.Monad
import Data.ListLike as ListLike (ListLike, null)
import Data.ListLike.IO (ListLikeIO, hGetContents, hPutStr)
import Data.Monoid ((<>))
import Data.String (IsString)
import Generics.Deriving.Instances ()
import GHC.IO.Exception (IOErrorType(ResourceVanished), IOException(ioe_type))
import Prelude hiding (null)
import System.Exit (ExitCode(..))
import System.IO (Handle, hClose, hFlush, BufferMode, hSetBuffering)
import System.IO.Unsafe (unsafeInterleaveIO)
import System.Process (CmdSpec(..), CreateProcess(cmdspec, cwd, std_err, std_in, std_out), StdStream(CreatePipe), ProcessHandle, createProcess, proc, showCommandForUser, waitForProcess, terminateProcess)
import Utils (forkWait)
#if __GLASGOW_HASKELL__ <= 709
import Control.Applicative ((<$>), (<*>))
import Data.Monoid (Monoid(mempty, mappend))
#endif
#if !MIN_VERSION_deepseq(1,4,2)
import Control.DeepSeq (NFData)
instance NFData ExitCode
#endif
class ProcessMaker a where
process :: a -> IO (Handle, Handle, Handle, ProcessHandle)
showProcessMakerForUser :: a -> String
instance ProcessMaker CreateProcess where
process :: CreateProcess -> IO (Handle, Handle, Handle, ProcessHandle)
process CreateProcess
p = do
(Just Handle
inh, Just Handle
outh, Just Handle
errh, ProcessHandle
pid) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
p { std_in :: StdStream
std_in = StdStream
CreatePipe, std_out :: StdStream
std_out = StdStream
CreatePipe, std_err :: StdStream
std_err = StdStream
CreatePipe }
(Handle, Handle, Handle, ProcessHandle)
-> IO (Handle, Handle, Handle, ProcessHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
inh, Handle
outh, Handle
errh, ProcessHandle
pid)
showProcessMakerForUser :: CreateProcess -> String
showProcessMakerForUser = CreateProcess -> String
showCreateProcessForUser
instance ProcessMaker (CreateProcess, BufferMode, BufferMode) where
process :: (CreateProcess, BufferMode, BufferMode)
-> IO (Handle, Handle, Handle, ProcessHandle)
process (CreateProcess
p, BufferMode
outmode, BufferMode
errmode) = do
(Just Handle
inh, Just Handle
outh, Just Handle
errh, ProcessHandle
pid) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
p { std_in :: StdStream
std_in = StdStream
CreatePipe, std_out :: StdStream
std_out = StdStream
CreatePipe, std_err :: StdStream
std_err = StdStream
CreatePipe }
Handle -> BufferMode -> IO ()
hSetBuffering Handle
outh BufferMode
outmode
Handle -> BufferMode -> IO ()
hSetBuffering Handle
errh BufferMode
errmode
(Handle, Handle, Handle, ProcessHandle)
-> IO (Handle, Handle, Handle, ProcessHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
inh, Handle
outh, Handle
errh, ProcessHandle
pid)
showProcessMakerForUser :: (CreateProcess, BufferMode, BufferMode) -> String
showProcessMakerForUser (CreateProcess
p, BufferMode
outmode, BufferMode
errmode) =
CreateProcess -> String
showCreateProcessForUser CreateProcess
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" outmode=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ BufferMode -> String
forall a. Show a => a -> String
show BufferMode
outmode String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", errmode=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ BufferMode -> String
forall a. Show a => a -> String
show BufferMode
errmode
class (IsString text, Monoid text, ListLike text char) => ProcessText text char
class Monoid result => ProcessResult text result | result -> text where
pidf :: ProcessHandle -> result
outf :: text -> result
errf :: text -> result
intf :: SomeException -> result
codef :: ExitCode -> result
instance ListLikeProcessIO text char => ProcessResult text (ExitCode, text, text) where
pidf :: ProcessHandle -> (ExitCode, text, text)
pidf ProcessHandle
_ = (ExitCode, text, text)
forall a. Monoid a => a
mempty
codef :: ExitCode -> (ExitCode, text, text)
codef ExitCode
c = (ExitCode
c, text
forall a. Monoid a => a
mempty, text
forall a. Monoid a => a
mempty)
outf :: text -> (ExitCode, text, text)
outf text
x = (ExitCode
forall a. Monoid a => a
mempty, text
x, text
forall a. Monoid a => a
mempty)
errf :: text -> (ExitCode, text, text)
errf text
x = (ExitCode
forall a. Monoid a => a
mempty, text
forall a. Monoid a => a
mempty, text
x)
intf :: SomeException -> (ExitCode, text, text)
intf SomeException
e = SomeException -> (ExitCode, text, text)
forall a e. Exception e => e -> a
throw SomeException
e
instance Monoid ExitCode where
mempty :: ExitCode
mempty = Int -> ExitCode
ExitFailure Int
0
mappend :: ExitCode -> ExitCode -> ExitCode
mappend ExitCode
x (ExitFailure Int
0) = ExitCode
x
mappend ExitCode
_ ExitCode
x = ExitCode
x
#if MIN_VERSION_base(4,11,0)
instance Semigroup ExitCode where
<> :: ExitCode -> ExitCode -> ExitCode
(<>) = ExitCode -> ExitCode -> ExitCode
forall a. Monoid a => a -> a -> a
mappend
#endif
class ListLikeIO text char => ListLikeProcessIO text char where
forceOutput :: text -> IO text
readChunks :: Handle -> IO [text]
readProcessWithExitCode
:: ListLikeProcessIO text char =>
FilePath
-> [String]
-> text
-> IO (ExitCode, text, text)
readProcessWithExitCode :: String -> [String] -> text -> IO (ExitCode, text, text)
readProcessWithExitCode String
cmd [String]
args text
input = CreateProcess -> text -> IO (ExitCode, text, text)
forall maker text char.
(ProcessMaker maker, ListLikeProcessIO text char) =>
maker -> text -> IO (ExitCode, text, text)
readCreateProcessWithExitCode (String -> [String] -> CreateProcess
proc String
cmd [String]
args) text
input
readCreateProcessWithExitCode
:: (ProcessMaker maker, ListLikeProcessIO text char) =>
maker
-> text
-> IO (ExitCode, text, text)
readCreateProcessWithExitCode :: maker -> text -> IO (ExitCode, text, text)
readCreateProcessWithExitCode = maker -> text -> IO (ExitCode, text, text)
forall maker text result char.
(ProcessMaker maker, ProcessResult text result,
ListLikeProcessIO text char) =>
maker -> text -> IO result
readCreateProcessStrict
readCreateProcessStrict :: (ProcessMaker maker, ProcessResult text result, ListLikeProcessIO text char) =>
maker -> text -> IO result
readCreateProcessStrict :: maker -> text -> IO result
readCreateProcessStrict maker
maker text
input = ((forall a. IO a -> IO a) -> IO result) -> IO result
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO result) -> IO result)
-> ((forall a. IO a -> IO a) -> IO result) -> IO result
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
(Handle
inh, Handle
outh, Handle
errh, ProcessHandle
pid) <- maker -> IO (Handle, Handle, Handle, ProcessHandle)
forall a.
ProcessMaker a =>
a -> IO (Handle, Handle, Handle, ProcessHandle)
process maker
maker
(IO result -> IO ExitCode -> IO result)
-> IO ExitCode -> IO result -> IO result
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO result -> IO ExitCode -> IO result
forall a b. IO a -> IO b -> IO a
onException
(do ProcessHandle -> IO ()
terminateProcess ProcessHandle
pid; Handle -> IO ()
hClose Handle
inh; Handle -> IO ()
hClose Handle
outh; Handle -> IO ()
hClose Handle
errh;
ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid) (IO result -> IO result) -> IO result -> IO result
forall a b. (a -> b) -> a -> b
$ IO result -> IO result
forall a. IO a -> IO a
restore (IO result -> IO result) -> IO result -> IO result
forall a b. (a -> b) -> a -> b
$ do
IO result
waitOut <- IO result -> IO (IO result)
forall a. IO a -> IO (IO a)
forkWait (IO result -> IO (IO result)) -> IO result -> IO (IO result)
forall a b. (a -> b) -> a -> b
$ text -> result
forall text result. ProcessResult text result => text -> result
outf (text -> result) -> IO text -> IO result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Handle -> IO text
forall full item. ListLikeIO full item => Handle -> IO full
hGetContents Handle
outh IO text -> (text -> IO text) -> IO text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= text -> IO text
forall text char. ListLikeProcessIO text char => text -> IO text
forceOutput)
IO result
waitErr <- IO result -> IO (IO result)
forall a. IO a -> IO (IO a)
forkWait (IO result -> IO (IO result)) -> IO result -> IO (IO result)
forall a b. (a -> b) -> a -> b
$ text -> result
forall text result. ProcessResult text result => text -> result
errf (text -> result) -> IO text -> IO result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Handle -> IO text
forall full item. ListLikeIO full item => Handle -> IO full
hGetContents Handle
errh IO text -> (text -> IO text) -> IO text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= text -> IO text
forall text char. ListLikeProcessIO text char => text -> IO text
forceOutput)
Handle -> text -> IO ()
forall a c. ListLikeProcessIO a c => Handle -> a -> IO ()
writeInput Handle
inh text
input
result
out <- IO result
waitOut
result
err <- IO result
waitErr
Handle -> IO ()
hClose Handle
outh
Handle -> IO ()
hClose Handle
errh
result
ex <- ExitCode -> result
forall text result. ProcessResult text result => ExitCode -> result
codef (ExitCode -> result) -> IO ExitCode -> IO result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid
result -> IO result
forall (m :: * -> *) a. Monad m => a -> m a
return (result -> IO result) -> result -> IO result
forall a b. (a -> b) -> a -> b
$ result
out result -> result -> result
forall a. Semigroup a => a -> a -> a
<> result
err result -> result -> result
forall a. Semigroup a => a -> a -> a
<> result
ex
readCreateProcessLazy :: (ProcessMaker maker, ProcessResult a b, ListLikeProcessIO a c) => maker -> a -> IO b
readCreateProcessLazy :: maker -> a -> IO b
readCreateProcessLazy maker
maker a
input = ((forall a. IO a -> IO a) -> IO b) -> IO b
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO b) -> IO b)
-> ((forall a. IO a -> IO a) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
(Handle
inh, Handle
outh, Handle
errh, ProcessHandle
pid) <- maker -> IO (Handle, Handle, Handle, ProcessHandle)
forall a.
ProcessMaker a =>
a -> IO (Handle, Handle, Handle, ProcessHandle)
process maker
maker
IO b -> IO ExitCode -> IO b
forall a b. IO a -> IO b -> IO a
onException
(IO b -> IO b
forall a. IO a -> IO a
restore (IO b -> IO b) -> IO b -> IO b
forall a b. (a -> b) -> a -> b
$
do
IO b
waitOut <- IO b -> IO (IO b)
forall a. IO a -> IO (IO a)
forkWait (IO b -> IO (IO b)) -> IO b -> IO (IO b)
forall a b. (a -> b) -> a -> b
$ b -> b -> b
forall a. Semigroup a => a -> a -> a
(<>) (b -> b -> b) -> IO b -> IO (b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessHandle -> b
forall text result.
ProcessResult text result =>
ProcessHandle -> result
pidf ProcessHandle
pid)
IO (b -> b) -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO b -> IO b
forall a. IO a -> IO a
unsafeInterleaveIO ([(a -> b, Handle)] -> IO b -> IO b
forall a c b.
(ListLikeProcessIO a c, ProcessResult a b) =>
[(a -> b, Handle)] -> IO b -> IO b
readInterleaved [(a -> b
forall text result. ProcessResult text result => text -> result
outf, Handle
outh), (a -> b
forall text result. ProcessResult text result => text -> result
errf, Handle
errh)] (ExitCode -> b
forall text result. ProcessResult text result => ExitCode -> result
codef (ExitCode -> b) -> IO ExitCode -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid))
Handle -> a -> IO ()
forall a c. ListLikeProcessIO a c => Handle -> a -> IO ()
writeInput Handle
inh a
input
IO b
waitOut)
(do ProcessHandle -> IO ()
terminateProcess ProcessHandle
pid; Handle -> IO ()
hClose Handle
inh; Handle -> IO ()
hClose Handle
outh; Handle -> IO ()
hClose Handle
errh;
ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid)
readInterleaved :: (ListLikeProcessIO a c, ProcessResult a b) =>
[(a -> b, Handle)] -> IO b -> IO b
readInterleaved :: [(a -> b, Handle)] -> IO b -> IO b
readInterleaved [(a -> b, Handle)]
pairs IO b
finish = IO (MVar (Either Handle b))
forall a. IO (MVar a)
newEmptyMVar IO (MVar (Either Handle b))
-> (MVar (Either Handle b) -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(a -> b, Handle)] -> IO b -> MVar (Either Handle b) -> IO b
forall a b c.
(ListLikeProcessIO a c, ProcessResult a b) =>
[(a -> b, Handle)] -> IO b -> MVar (Either Handle b) -> IO b
readInterleaved' [(a -> b, Handle)]
pairs IO b
finish
readInterleaved' :: forall a b c. (ListLikeProcessIO a c, ProcessResult a b) =>
[(a -> b, Handle)] -> IO b -> MVar (Either Handle b) -> IO b
readInterleaved' :: [(a -> b, Handle)] -> IO b -> MVar (Either Handle b) -> IO b
readInterleaved' [(a -> b, Handle)]
pairs IO b
finish MVar (Either Handle b)
res = do
((a -> b, Handle) -> IO ThreadId) -> [(a -> b, Handle)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId)
-> ((a -> b, Handle) -> IO ()) -> (a -> b, Handle) -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> b) -> Handle -> IO ()) -> (a -> b, Handle) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (a -> b) -> Handle -> IO ()
readHandle) [(a -> b, Handle)]
pairs
Int -> IO b
takeChunks ([(a -> b, Handle)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a -> b, Handle)]
pairs)
where
readHandle :: (a -> b) -> Handle -> IO ()
readHandle :: (a -> b) -> Handle -> IO ()
readHandle a -> b
f Handle
h = do
[a]
cs <- Handle -> IO [a]
forall text char.
ListLikeProcessIO text char =>
Handle -> IO [text]
readChunks Handle
h
(a -> IO ()) -> [a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ a
c -> MVar (Either Handle b) -> Either Handle b -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either Handle b)
res (b -> Either Handle b
forall a b. b -> Either a b
Right (a -> b
f a
c))) [a]
cs
Handle -> IO ()
hClose Handle
h
MVar (Either Handle b) -> Either Handle b -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either Handle b)
res (Handle -> Either Handle b
forall a b. a -> Either a b
Left Handle
h)
takeChunks :: Int -> IO b
takeChunks :: Int -> IO b
takeChunks Int
0 = IO b
finish
takeChunks Int
openCount = IO (Either Handle b)
takeChunk IO (Either Handle b) -> (Either Handle b -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Either Handle b -> IO b
takeMore Int
openCount
takeMore :: Int -> Either Handle b -> IO b
takeMore :: Int -> Either Handle b -> IO b
takeMore Int
openCount (Left Handle
h) = Handle -> IO ()
hClose Handle
h IO () -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO b
takeChunks (Int
openCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
takeMore Int
openCount (Right b
x) =
do b
xs <- IO b -> IO b
forall a. IO a -> IO a
unsafeInterleaveIO (IO b -> IO b) -> IO b -> IO b
forall a b. (a -> b) -> a -> b
$ Int -> IO b
takeChunks Int
openCount
b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return (b
x b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
xs)
takeChunk :: IO (Either Handle b)
takeChunk = MVar (Either Handle b) -> IO (Either Handle b)
forall a. MVar a -> IO a
takeMVar MVar (Either Handle b)
res IO (Either Handle b)
-> (SomeException -> IO (Either Handle b)) -> IO (Either Handle b)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (\ (SomeException
e :: SomeException) -> Either Handle b -> IO (Either Handle b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Handle b -> IO (Either Handle b))
-> Either Handle b -> IO (Either Handle b)
forall a b. (a -> b) -> a -> b
$ b -> Either Handle b
forall a b. b -> Either a b
Right (b -> Either Handle b) -> b -> Either Handle b
forall a b. (a -> b) -> a -> b
$ SomeException -> b
forall text result.
ProcessResult text result =>
SomeException -> result
intf SomeException
e)
writeInput :: ListLikeProcessIO a c => Handle -> a -> IO ()
writeInput :: Handle -> a -> IO ()
writeInput Handle
inh a
input =
IO () -> IO ()
ignoreResourceVanished (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (a -> Bool
forall full item. ListLike full item => full -> Bool
ListLike.null a
input) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Handle -> a -> IO ()
forall full item. ListLikeIO full item => Handle -> full -> IO ()
hPutStr Handle
inh a
input
Handle -> IO ()
hFlush Handle
inh
Handle -> IO ()
hClose Handle
inh
ignoreResourceVanished :: IO () -> IO ()
ignoreResourceVanished :: IO () -> IO ()
ignoreResourceVanished IO ()
action =
IO ()
action IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (\IOException
e -> if IOException -> IOErrorType
ioe_type IOException
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
ResourceVanished then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else IOException -> IO ()
forall a. IOException -> IO a
ioError IOException
e)
showCreateProcessForUser :: CreateProcess -> String
showCreateProcessForUser :: CreateProcess -> String
showCreateProcessForUser CreateProcess
p =
CmdSpec -> String
showCmdSpecForUser (CreateProcess -> CmdSpec
cmdspec CreateProcess
p) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\ String
d -> String
" (in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
d String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") (CreateProcess -> Maybe String
cwd CreateProcess
p)
showCmdSpecForUser :: CmdSpec -> String
showCmdSpecForUser :: CmdSpec -> String
showCmdSpecForUser (ShellCommand String
s) = String
s
showCmdSpecForUser (RawCommand String
p [String]
args) = String -> [String] -> String
showCommandForUser String
p [String]
args