module Data.Conduit.Process.Unix
( forkExecuteFile
, killProcess
, waitForProcess
, ProcessStatus (..)
) where
import Control.Concurrent (forkIO)
import Control.Exception (finally, mask, onException)
import Control.Monad (unless, void)
import Control.Monad.Trans.Class (lift)
import Data.ByteString (ByteString, null)
import Data.ByteString.Unsafe (unsafePackCStringFinalizer,
unsafeUseAsCStringLen)
import Data.Conduit (Sink, Source, yield, ($$))
import Data.Conduit.List (mapM_)
import Foreign.Marshal.Alloc (free, mallocBytes)
import Foreign.Ptr (castPtr)
import Prelude (Bool (..), IO, Maybe (..),
Monad (..), flip,
fromIntegral, fst, maybe,
snd, ($), (.))
import System.Posix.Directory.ByteString (changeWorkingDirectory)
import System.Posix.IO.ByteString (closeFd, createPipe, dupTo,
fdReadBuf, fdWriteBuf,
stdError, stdInput,
stdOutput)
import System.Posix.Process.ByteString (ProcessStatus (..),
executeFile, forkProcess,
getProcessStatus)
import System.Posix.Signals (sigKILL, signalProcess)
import System.Posix.Types (ProcessID)
killProcess :: ProcessID -> IO ()
killProcess = signalProcess sigKILL
forkExecuteFile :: ByteString
-> Bool
-> [ByteString]
-> Maybe [(ByteString, ByteString)]
-> Maybe ByteString
-> Maybe (Source IO ByteString)
-> Maybe (Sink ByteString IO ())
-> Maybe (Sink ByteString IO ())
-> IO ProcessID
forkExecuteFile cmd path args menv mwdir mstdin mstdout mstderr = do
min <- withIn mstdin
mout <- withOut mstdout
merr <- withOut mstderr
pid <- forkProcess $ do
maybe (return ()) changeWorkingDirectory mwdir
case min of
Nothing -> return ()
Just (fdRead, fdWrite) -> do
closeFd fdWrite
void $ dupTo fdRead stdInput
let goOut Nothing _ = return ()
goOut (Just (fdRead, fdWrite)) dest = do
closeFd fdRead
void $ dupTo fdWrite dest
goOut mout stdOutput
goOut merr stdError
executeFile cmd path args menv
maybe (return ()) (closeFd . fst) min
maybe (return ()) (closeFd . snd) mout
maybe (return ()) (closeFd . snd) merr
return pid
where
withIn Nothing = return Nothing
withIn (Just src) = do
(fdRead, fdWrite) <- createPipe
let sink = mapM_ $ flip unsafeUseAsCStringLen $ \(ptr, size) -> void $ fdWriteBuf fdWrite (castPtr ptr) (fromIntegral size)
void $ forkIO $ (src $$ sink) `finally` closeFd fdWrite
return $ Just (fdRead, fdWrite)
withOut Nothing = return Nothing
withOut (Just sink) = do
(fdRead, fdWrite) <- createPipe
let buffSize = 4096
let src = do
bs <- lift $ mask $ \restore -> do
ptr <- mallocBytes buffSize
bytesRead <- restore (fdReadBuf fdRead ptr $ fromIntegral buffSize) `onException` free ptr
unsafePackCStringFinalizer ptr (fromIntegral bytesRead) (free ptr)
unless (null bs) $ do
yield bs
src
void $ forkIO $ (src $$ sink) `finally` closeFd fdRead
return $ Just (fdRead, fdWrite)
waitForProcess :: ProcessID -> IO ProcessStatus
waitForProcess pid =
loop
where
loop = getProcessStatus True False pid >>= maybe loop return