diff --git a/Data/Conduit/Process/Unix.hs b/Data/Conduit/Process/Unix.hs --- a/Data/Conduit/Process/Unix.hs +++ b/Data/Conduit/Process/Unix.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-} module Data.Conduit.Process.Unix ( forkExecuteFile , killProcess @@ -7,29 +8,32 @@ import Control.Concurrent (forkIO) import Control.Exception (finally, mask, onException) -import Control.Monad (unless, void) +import Control.Monad (unless, void, zipWithM_, when) import Control.Monad.Trans.Class (lift) -import Data.ByteString (ByteString, null) +import Data.ByteString (ByteString, null, concat, append, singleton) import Data.ByteString.Unsafe (unsafePackCStringFinalizer, - unsafeUseAsCStringLen) + unsafeUseAsCStringLen, + unsafeUseAsCString) import Data.Conduit (Sink, Source, yield, ($$)) import Data.Conduit.List (mapM_) -import Foreign.Marshal.Alloc (free, mallocBytes) -import Foreign.Ptr (castPtr) +import Foreign.Marshal.Alloc (free, mallocBytes, allocaBytes) +import Foreign.Ptr (castPtr, Ptr, nullPtr) +import Foreign.Storable (sizeOf, pokeElemOff) 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, + snd, ($), (.), (==), error, id, length, (*), + head, map) +import System.Posix.Types (Fd) +import System.Posix.IO.ByteString (closeFd, createPipe, fdReadBuf, fdWriteBuf, - stdError, stdInput, - stdOutput) + setFdOption, FdOption (CloseOnExec)) import System.Posix.Process.ByteString (ProcessStatus (..), - executeFile, forkProcess, getProcessStatus) import System.Posix.Signals (sigKILL, signalProcess) import System.Posix.Types (ProcessID) +import Foreign.C.Types +import Foreign.C.String -- | Kill a process by sending it the KILL (9) signal. -- @@ -37,6 +41,16 @@ killProcess :: ProcessID -> IO () killProcess = signalProcess sigKILL +foreign import ccall "forkExecuteFile" + c_forkExecuteFile :: Ptr CString + -> CInt + -> CString + -> Ptr CString + -> CInt + -> CInt + -> CInt + -> IO CInt + -- | Fork a new process and execute the given command. -- -- This is a wrapper around with fork() and exec*() syscalls, set up to work @@ -62,24 +76,27 @@ 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 ()) (closeOnExec . snd) min + maybe (return ()) (closeOnExec . fst) mout + maybe (return ()) (closeOnExec . fst) merr + + pid <- withArgs (cmd : args) $ \args' -> + withMString mwdir $ \mwdir' -> + withEnv menv $ \menv' -> + c_forkExecuteFile + args' + (if path then 1 else 0) + mwdir' + menv' + (maybe (-1) (fromIntegral . fst) min) + (maybe (-1) (fromIntegral . snd) mout) + (maybe (-1) (fromIntegral . snd) merr) + when (pid == -1) $ error "Failure with forkExecuteFile" maybe (return ()) (closeFd . fst) min maybe (return ()) (closeFd . snd) mout maybe (return ()) (closeFd . snd) merr - return pid + return $ fromIntegral pid where withIn Nothing = return Nothing withIn (Just src) = do @@ -101,6 +118,32 @@ src void $ forkIO $ (src $$ sink) `finally` closeFd fdRead return $ Just (fdRead, fdWrite) + +closeOnExec :: Fd -> IO () +closeOnExec fd = setFdOption fd CloseOnExec True + +withMString :: Maybe ByteString -> (CString -> IO a) -> IO a +withMString Nothing f = f nullPtr +withMString (Just bs) f = unsafeUseAsCString (bs `append` singleton 0) f + +withEnv :: Maybe [(ByteString, ByteString)] -> (Ptr CString -> IO a) -> IO a +withEnv Nothing f = f nullPtr +withEnv (Just pairs) f = + withArgs (map toBS pairs) f + where + toBS (x, y) = concat [x, "=", y] + +withArgs :: [ByteString] -> (Ptr CString -> IO a) -> IO a +withArgs bss0 f = + loop bss0 id + where + loop [] front = run (front [nullPtr]) + loop (bs:bss) front = + unsafeUseAsCString (bs `append` singleton 0) $ \ptr -> + loop bss (front . (ptr:)) + + run ptrs = allocaBytes (length ptrs * sizeOf (head ptrs)) $ \res -> + zipWithM_ (pokeElemOff res) [0..] ptrs >> f res -- | Wait until the given process has died, and return its @ProcessStatus@. -- diff --git a/cbits/forkExecute.c b/cbits/forkExecute.c new file mode 100644 --- /dev/null +++ b/cbits/forkExecute.c @@ -0,0 +1,67 @@ +#define _GNU_SOURCE + +#include + +extern void blockUserSignals(void); +extern void unblockUserSignals(void); +extern void stopTimer(void); +extern void startTimer(void); + +int forkExecuteFile + ( char *const args[] + , int path + , char *workingDirectory + , char **environment + , int fdStdIn + , int fdStdOut + , int fdStdErr + ) +{ + int pid; + + blockUserSignals(); + stopTimer(); + + switch (pid = fork()) { + case -1: + unblockUserSignals(); + startTimer(); + if (fdStdIn != -1) close(fdStdIn); + if (fdStdOut != -1) close(fdStdOut); + if (fdStdErr != -1) close(fdStdErr); + return -1; + case 0: + unblockUserSignals(); + if (workingDirectory) { + if (chdir (workingDirectory) < 0) { + _exit(126); + } + } + if (fdStdIn != -1) { + dup2(fdStdIn, 0); + close(fdStdIn); + } + if (fdStdOut != -1) { + dup2(fdStdOut, 1); + close(fdStdOut); + } + if (fdStdErr != -1) { + dup2(fdStdErr, 2); + close(fdStdErr); + } + + // FIXME close file descriptors + if (environment) { + if (path) execvpe(args[0], args, environment); + else execve (args[0], args, environment); + } else { + if (path) execvp(args[0], args); + else execv (args[0], args); + } + _exit(127); + default: break; + } + unblockUserSignals(); + startTimer(); + return pid; +} diff --git a/test/Data/Conduit/Process/UnixSpec.hs b/test/Data/Conduit/Process/UnixSpec.hs --- a/test/Data/Conduit/Process/UnixSpec.hs +++ b/test/Data/Conduit/Process/UnixSpec.hs @@ -4,6 +4,7 @@ import Test.Hspec (describe, it, shouldBe, Spec) import Data.Conduit.Process.Unix import Data.Conduit +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.ByteString (ByteString) import qualified Data.IORef as I @@ -57,3 +58,18 @@ killProcess pid res <- waitForProcess pid res `shouldBe` Terminated 9 + it "environment is set" $ do + (sink, getLBS) <- iorefSink + pid <- forkExecuteFile + "env" + True + [] + (Just [("foo", S.take (read "3") $ "barbarbar")]) + Nothing + Nothing + (Just sink) + Nothing + res <- waitForProcess pid + lbs <- getLBS + res `shouldBe` Exited ExitSuccess + lbs `shouldBe` L.fromChunks ["foo=bar\n"] diff --git a/unix-process-conduit.cabal b/unix-process-conduit.cabal --- a/unix-process-conduit.cabal +++ b/unix-process-conduit.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: unix-process-conduit -version: 0.1.0 +version: 0.1.0.1 synopsis: Run processes on Unix systems, with a conduit interface description: This library allows you to provide @conduit@ datatypes for the input and output streams. Note that you must compile your programs with @-threaded@. homepage: https://github.com/snoyberg/conduit @@ -21,6 +21,7 @@ , bytestring , conduit >= 0.5 && < 0.6 , unix >= 2.5 + c-sources: cbits/forkExecute.c test-suite test hs-source-dirs: test