unix-process-conduit 0.1.0 → 0.1.0.1
raw patch · 4 files changed
+154/−27 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- Data/Conduit/Process/Unix.hs +69/−26
- cbits/forkExecute.c +67/−0
- test/Data/Conduit/Process/UnixSpec.hs +16/−0
- unix-process-conduit.cabal +2/−1
Data/Conduit/Process/Unix.hs view
@@ -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@. --
+ cbits/forkExecute.c view
@@ -0,0 +1,67 @@+#define _GNU_SOURCE++#include <unistd.h>++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;+}
test/Data/Conduit/Process/UnixSpec.hs view
@@ -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"]
unix-process-conduit.cabal view
@@ -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