Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

unix-process-conduit

  • Loading branch information...
commit b95fdec7e1ccfeb73d9f821f1565ce8c68477f2e 1 parent d36a0c3
@snoyberg authored
View
112 unix-process-conduit/Data/Conduit/Process/Unix.hs
@@ -0,0 +1,112 @@
+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)
+
+-- | Kill a process by sending it the KILL (9) signal.
+--
+-- Since 0.1.0
+killProcess :: ProcessID -> IO ()
+killProcess = signalProcess sigKILL
+
+-- | Fork a new process and execute the given command.
+--
+-- This is a wrapper around with fork() and exec*() syscalls, set up to work
+-- with @conduit@ datatypes for standard input, output, and error. If @Nothing@
+-- is provided for any of those arguments, then the original file handles will
+-- remain open to the child process.
+--
+-- If you would like to simply discard data provided by the child process,
+-- provide @sinkNull@ for stdout and/or stderr. To provide an empty input
+-- stream, use @return ()@.
+--
+-- Since 0.1.0
+forkExecuteFile :: ByteString -- ^ command
+ -> Bool -- ^ search on PATH?
+ -> [ByteString] -- ^ args
+ -> Maybe [(ByteString, ByteString)] -- ^ environment
+ -> Maybe ByteString -- ^ working directory
+ -> Maybe (Source IO ByteString) -- ^ stdin
+ -> Maybe (Sink ByteString IO ()) -- ^ stdout
+ -> Maybe (Sink ByteString IO ()) -- ^ stderr
+ -> 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)
+
+-- | Wait until the given process has died, and return its @ProcessStatus@.
+--
+-- Since 0.1.0
+waitForProcess :: ProcessID -> IO ProcessStatus
+waitForProcess pid =
+ loop
+ where
+ loop = getProcessStatus True False pid >>= maybe loop return
View
30 unix-process-conduit/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c)2011, Michael Snoyman
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Michael Snoyman nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
View
2  unix-process-conduit/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
View
59 unix-process-conduit/test/Data/Conduit/Process/UnixSpec.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings, BangPatterns #-}
+module Data.Conduit.Process.UnixSpec where
+
+import Test.Hspec (describe, it, shouldBe, Spec)
+import Data.Conduit.Process.Unix
+import Data.Conduit
+import qualified Data.ByteString.Lazy as L
+import Data.ByteString (ByteString)
+import qualified Data.IORef as I
+import qualified Data.Conduit.List as CL
+import System.Exit (ExitCode (ExitSuccess))
+import Control.Monad.Trans.Class (lift)
+import Control.Concurrent (threadDelay)
+
+iorefSink :: IO (Sink ByteString IO (), IO L.ByteString)
+iorefSink = do
+ ref <- I.newIORef id
+ let sink = CL.mapM_ $ \bs -> do
+ !() <- I.atomicModifyIORef ref $ \front -> (front . (bs:), ())
+ return ()
+ getLBS = do
+ front <- I.readIORef ref
+ return $ L.fromChunks $ front []
+ return (sink, getLBS)
+
+spec :: Spec
+spec = describe "unix-process-conduit" $ do
+ it "stdin/stdout work" $ do
+ let content = ["hello\n", "there\n", "world\n"]
+ src = mapM_ yield content
+ expected = L.fromChunks content
+ (sink, getLBS) <- iorefSink
+ pid <- forkExecuteFile
+ "cat"
+ True
+ []
+ Nothing
+ Nothing
+ (Just src)
+ (Just sink)
+ Nothing
+ res <- waitForProcess pid
+ lbs <- getLBS
+ res `shouldBe` Exited ExitSuccess
+ lbs `shouldBe` expected
+ it "killProcess works" $ do
+ let src = lift (threadDelay 1000000) >> src
+ pid <- forkExecuteFile
+ "cat"
+ True
+ []
+ Nothing
+ Nothing
+ (Just src)
+ Nothing
+ Nothing
+ killProcess pid
+ res <- waitForProcess pid
+ res `shouldBe` Terminated 9
View
1  unix-process-conduit/test/Spec.hs
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
View
40 unix-process-conduit/unix-process-conduit.cabal
@@ -0,0 +1,40 @@
+-- Initial unix-process-conduit.cabal generated by cabal init. For further
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name: unix-process-conduit
+version: 0.1.0
+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
+license: MIT
+license-file: LICENSE
+author: Michael Snoyman
+maintainer: michael@snoyman.com
+category: System
+build-type: Simple
+cabal-version: >=1.8
+
+library
+ exposed-modules: Data.Conduit.Process.Unix
+ build-depends: base >= 4 && < 5
+ , transformers
+ , bytestring
+ , conduit >= 0.5 && < 0.6
+ , unix >= 2.5
+
+test-suite test
+ hs-source-dirs: test
+ main-is: Spec.hs
+ other-modules: Data.Conduit.Process.UnixSpec
+ type: exitcode-stdio-1.0
+ build-depends: base
+ , unix-process-conduit
+ , transformers
+ , conduit
+ , bytestring
+ , hspec >= 1.3
+ ghc-options: -Wall -threaded
+
+source-repository head
+ type: git
+ location: git://github.com/snoyberg/conduit.git
Please sign in to comment.
Something went wrong with that request. Please try again.