module System.Process.Pipe
( pipe, pipe'
, pipeString
, handlePipe
, filePipe, filePipe'
) where
import Control.Concurrent (forkIO)
import Control.Exception (try, IOException)
import Control.Monad (mplus)
import System.FilePath (dropFileName)
import System.IO ( withBinaryFile, IOMode (ReadMode, WriteMode)
, Handle, hGetContents, hPutStr, hClose)
import System.Process ( CreateProcess(..), createProcess
, CmdSpec (RawCommand)
, StdStream (CreatePipe, Inherit, UseHandle)
, ProcessHandle, waitForProcess)
#if !mingw32_HOST_OS
import Control.Exception (bracket)
import System.Posix.Signals (installHandler, sigPIPE, Handler(Ignore))
#endif
createProc :: FilePath -> StdStream -> StdStream -> (FilePath,[String])
-> IO (Maybe Handle, Maybe Handle, ProcessHandle)
createProc wdir inp out (p,args) = do
let proc = CreateProcess
{ cmdspec = undefined
, cwd = Just wdir
, env = Nothing
, std_in = inp
, std_out = out
, std_err = Inherit
, close_fds = True }
(i,o,_,pid) <-
createProcess proc { cmdspec = RawCommand p args }
#if mingw32_HOST_OS
`catch` const (createProcess proc
{ cmdspec = RawCommand (p ++ ".exe") args })
#endif
return (i,o,pid)
pipeline :: FilePath -> StdStream -> StdStream -> [(FilePath,[String])]
-> IO (Maybe Handle, Maybe Handle, [ProcessHandle])
pipeline _ _ _ [] = ioError.userError$ "Pipe :: null pipeline"
pipeline wdir inp out progs = f [] Nothing inp progs
where
f pids firstI i [p] = do
(i',o,pid) <- createProc wdir i out p
return (firstI `mplus` i', o, reverse (pid:pids))
f pids firstI i (p:ps) = do
(i',Just o,pid) <- createProc wdir i CreatePipe p
f (pid:pids) (firstI `mplus` i') (UseHandle o) ps
pipe :: (Handle -> a -> IO ()) -> (Handle -> IO b)
-> FilePath -> [(FilePath,[String])]
-> a -> IO b
pipe writer reader wdir progs dat = do
(Just inp, Just out, pids) <- pipeline wdir CreatePipe CreatePipe progs
forkIO $ do
#if !mingw32_HOST_OS
bracket
( installHandler sigPIPE Ignore Nothing)
(\orig -> installHandler sigPIPE orig Nothing)
$ \_ -> do
#endif
try (writer inp dat) :: IO (Either IOException ())
hClose inp `catch` const (return ())
mapM_ waitForProcess pids
reader out
pipe' :: (Handle -> a -> IO ()) -> (Handle -> IO b)
-> [(FilePath,[String])]
-> a -> IO b
pipe' r w = pipe r w "."
pipeString :: [(FilePath, [String])] -> String -> IO String
pipeString = pipe' hPutStr hGetContents
handlePipe :: FilePath -> [(FilePath,[String])] -> Handle -> Handle -> IO ()
handlePipe _ [] inhdl outhdl = hGetContents inhdl >>= hPutStr outhdl
handlePipe wdir progs inhdl outhdl = do
(_, _, pids) <- pipeline wdir (UseHandle inhdl) (UseHandle outhdl) progs
mapM_ waitForProcess pids
filePipe :: FilePath -> [(FilePath,[String])] -> FilePath -> FilePath -> IO ()
filePipe wdir progs infile outfile = do
withBinaryFile outfile WriteMode $ \outhdl ->
withBinaryFile infile ReadMode $ \inhdl ->
handlePipe wdir progs inhdl outhdl
filePipe' :: [(FilePath,[String])] -> FilePath -> FilePath -> IO ()
filePipe' progs infile = filePipe (dropFileName infile) progs infile