module System.Process.Pipe
( pipe, pipe'
, pipeString
, handlePipe
, filePipe, filePipe'
) where
import Control.Concurrent (forkIO)
import Control.Monad (mplus)
import Data.Maybe (fromJust)
import System.FilePath (dropFileName)
import System.IO ( withBinaryFile, IOMode (ReadMode, WriteMode)
, Handle, hGetContents, hPutStr)
import System.Process ( CreateProcess(..), createProcess
, CmdSpec (RawCommand)
, StdStream (CreatePipe, Inherit, UseHandle)
, ProcessHandle, waitForProcess)
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',o,pid) <- createProc wdir i CreatePipe p
f (pid:pids) (firstI `mplus` i') (UseHandle . fromJust $ o) ps
pipe :: (Handle -> a -> IO ()) -> (Handle -> IO b)
-> FilePath -> [(FilePath,[String])]
-> a -> IO b
pipe writer reader wdir progs i = do
(inp, out, pids) <- pipeline wdir CreatePipe CreatePipe progs
forkIO (writer (fromJust inp) i >> mapM_ waitForProcess pids)
reader (fromJust 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