module System.Process.ListLike (
ListLikePlus(..),
readProcessInterleaved,
readInterleaved,
readCreateProcessWithExitCode,
readCreateProcess,
readProcessWithExitCode,
readProcess,
Output(..),
readProcessChunks
) where
import Control.Concurrent
import Control.DeepSeq (NFData)
import Control.Exception as E (SomeException, onException, evaluate, catch, try, throwIO, mask, throw)
import Control.Monad
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.Int (Int64)
import Data.List as List (map)
import Data.ListLike (ListLike(..), ListLikeIO(..))
import Data.ListLike.Text.Text ()
import Data.ListLike.Text.TextLazy ()
import Data.Monoid (Monoid(mempty, mappend), (<>))
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Data.Word (Word8)
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 (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
toChunks :: a -> [a]
readProcessInterleaved :: (ListLikePlus a c, Monoid b) =>
(ExitCode -> b) -> (a -> b) -> (a -> b)
-> CreateProcess -> a -> IO b
readProcessInterleaved codef outf errf p input = mask $ \ restore -> do
(Just inh, Just outh, Just errh, pid) <-
createProcess (p {std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe })
binary input [inh, outh, errh]
flip onException
(do hClose inh; hClose outh; hClose errh;
terminateProcess pid; waitForProcess pid) $ restore $ do
waitOut <- forkWait $ readInterleaved [(outf, outh), (errf, errh)] $ waitForProcess pid >>= return . codef
writeInput inh input
waitOut
readInterleaved :: forall a b c. (ListLikePlus a c, Monoid b) => [(a -> b, Handle)] -> IO b -> IO b
readInterleaved pairs finish = newEmptyMVar >>= readInterleaved' pairs finish
readInterleaved' :: forall a b c. (ListLikePlus a c, Monoid 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 f h = do
cs <- hGetContents h
when (lazy (undefined :: a)) (void $ force' cs)
mapM_ (\ c -> putMVar res (Right (f c))) (toChunks 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 (\ 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
(Just inh, Just outh, _, pid) <-
createProcess (p {std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit })
binary input [inh, outh]
flip onException
(do hClose inh; hClose outh;
terminateProcess pid; waitForProcess pid) $ restore $ do
waitOut <- forkWait $ readInterleaved [(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 ())
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
instance ListLikePlus String Char where
type LengthType String = Int
binary _ = mapM_ (\ h -> hSetBinaryMode h True)
lazy _ = True
length' = length
toChunks = (: [])
instance ListLikePlus B.ByteString Word8 where
type LengthType B.ByteString = Int
binary _ = mapM_ (\ h -> hSetBinaryMode h True)
lazy _ = False
length' = B.length
toChunks = (: [])
instance ListLikePlus L.ByteString Word8 where
type LengthType L.ByteString = Int64
binary _ = mapM_ (\ h -> hSetBinaryMode h True)
lazy _ = True
length' = L.length
toChunks = List.map (L.fromChunks . (: [])) . L.toChunks
instance ListLikePlus T.Text Char where
type LengthType T.Text = Int
binary _ _ = return ()
lazy _ = False
length' = T.length
toChunks = (: [])
instance ListLikePlus LT.Text Char where
type LengthType LT.Text = Int64
binary _ _ = return ()
lazy _ = True
length' = LT.length
toChunks = List.map (LT.fromChunks . (: [])) . LT.toChunks
instance Monoid ExitCode where
mempty = ExitFailure 0
mappend x (ExitFailure 0) = x
mappend _ x = x
instance NFData ExitCode
data Output a = Stdout a | Stderr a | Result ExitCode | Exception IOError deriving (Eq, Show)
readProcessChunks :: (ListLikePlus a c) => CreateProcess -> a -> IO [Output a]
readProcessChunks p input =
readProcessInterleaved (\ x -> [Result x]) (\ x -> [Stdout x]) (\ x -> [Stderr x]) p input