From 5a37bd3ccf2ad7cce24b65ba1531fb5e06b11eee Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 8 Aug 2022 16:25:06 +0530 Subject: [PATCH 1/7] Add more warning options --- src/Streamly/Internal/System/Process/Posix.hs | 1 + streamly-process.cabal | 20 +++++++++++-------- test/Streamly/System/Process.hs | 16 +++++---------- 3 files changed, 18 insertions(+), 19 deletions(-) diff --git a/src/Streamly/Internal/System/Process/Posix.hs b/src/Streamly/Internal/System/Process/Posix.hs index 4903a545..b5c7271e 100644 --- a/src/Streamly/Internal/System/Process/Posix.hs +++ b/src/Streamly/Internal/System/Process/Posix.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} -- | -- Module : Streamly.Internal.System.Process.Posix -- Copyright : (c) 2020 Composewell Technologies diff --git a/streamly-process.cabal b/streamly-process.cabal index ca5529df..c1782188 100644 --- a/streamly-process.cabal +++ b/streamly-process.cabal @@ -51,14 +51,18 @@ flag use-gauge common compile-options default-language: Haskell2010 ghc-options: - -Wall - -Wcompat - -Wunrecognised-warning-flags - -Widentities - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wredundant-constraints - -Wnoncanonical-monad-instances + -Weverything + -Wno-implicit-prelude + -Wno-missing-deriving-strategies + -Wno-missing-exported-signatures + -Wno-missing-import-lists + -Wno-missing-local-signatures + -Wno-missing-safe-haskell-mode + -Wno-missed-specialisations + -Wno-all-missed-specialisations + -Wno-monomorphism-restriction + -Wno-prepositive-qualified-module + -Wno-unsafe common optimization-options ghc-options: diff --git a/test/Streamly/System/Process.hs b/test/Streamly/System/Process.hs index a7440978..01d7d6c5 100644 --- a/test/Streamly/System/Process.hs +++ b/test/Streamly/System/Process.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -module Main where +module Main (main) where import Data.Function ((&)) import Data.List ((\\)) @@ -71,18 +71,12 @@ minBlockCount = 1 maxBlockCount :: Int maxBlockCount = 100 -minNumChar :: Int -minNumChar = 1 - -maxNumChar :: Int -maxNumChar = 100 * 1024 - arrayChunkSize :: Int arrayChunkSize = 100 interpreterFile :: FilePath interpreterArg :: String -#if mingw32_HOST_OS == 1 +#ifdef mingw32_HOST_OS interpreterFile = "cmd.exe" interpreterArg = "/c" #else @@ -91,21 +85,21 @@ interpreterArg = "sh" #endif executableFile :: FilePath -#if mingw32_HOST_OS == 1 +#ifdef mingw32_HOST_OS executableFile = "./test/data/writeTrToError.bat" #else executableFile = "./test/data/writeTrToError.sh" #endif executableFileFail :: FilePath -#if mingw32_HOST_OS == 1 +#ifdef mingw32_HOST_OS executableFileFail = "./test/data/failExec.bat" #else executableFileFail = "./test/data/failExec.sh" #endif executableFilePass :: FilePath -#if mingw32_HOST_OS == 1 +#ifdef mingw32_HOST_OS executableFilePass = "./test/data/passExec.bat" #else executableFilePass = "./test/data/passExec.sh" From 02e4794474786cab5ee3c933c08582ad6236b56d Mon Sep 17 00:00:00 2001 From: Ishan Bhanuka Date: Wed, 8 Jun 2022 23:38:50 +0530 Subject: [PATCH 2/7] Compile with USE_NATIVE flag on --- src/Streamly/Internal/System/Process.hs | 15 +++++++++++++-- src/Streamly/Internal/System/Process/Posix.hs | 5 +++++ 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/src/Streamly/Internal/System/Process.hs b/src/Streamly/Internal/System/Process.hs index 1d305655..5228b030 100644 --- a/src/Streamly/Internal/System/Process.hs +++ b/src/Streamly/Internal/System/Process.hs @@ -109,6 +109,7 @@ import System.IO (hClose, Handle) import Control.Exception (Exception(..), catch, throwIO, SomeException) import System.Posix.Process (ProcessStatus(..)) import Streamly.Internal.System.Process.Posix +import Control.Concurrent (forkIO) #else import Control.Concurrent (forkIO) import Control.Exception (Exception(..), catch, throwIO) @@ -141,6 +142,9 @@ import qualified Streamly.Internal.Data.Unfold as Unfold (either) import qualified Streamly.Internal.FileSystem.Handle as Handle (getChunks, putChunks) import qualified Streamly.Internal.Unicode.Stream as Unicode +import GHC.IO.Exception (IOException(..), IOErrorType (ResourceVanished)) +import Foreign.C (ePIPE, Errno (..)) +import Control.Monad (unless, void) -- $setup -- >>> :set -XFlexibleContexts @@ -185,6 +189,13 @@ mkConfig _ _ = Config False pipeStdErr :: Config -> Config pipeStdErr (Config _) = Config True + +inheritStdin :: Config -> Config +inheritStdin (Config _) = Config True + +inheritStdout :: Config -> Config +inheritStdout (Config _) = Config True + #else newtype Config = Config CreateProcess @@ -288,7 +299,7 @@ cleanupException :: MonadIO m => (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> m () cleanupException (Just stdinH, Just stdoutH, stderrMaybe, ph) = liftIO $ do -- Send a SIGTERM to the process - terminateProcess ph + terminate ph -- Ideally we should be closing the handle without flushing the buffers so -- that we cannot get a SIGPIPE. But there seems to be no way to do that as @@ -298,7 +309,7 @@ cleanupException (Just stdinH, Just stdoutH, stderrMaybe, ph) = liftIO $ do whenJust hClose stderrMaybe -- Non-blocking wait for the process to go away - void $ forkIO (void $ waitForProcess ph) + void $ forkIO (void $ wait ph) where diff --git a/src/Streamly/Internal/System/Process/Posix.hs b/src/Streamly/Internal/System/Process/Posix.hs index b5c7271e..edff2707 100644 --- a/src/Streamly/Internal/System/Process/Posix.hs +++ b/src/Streamly/Internal/System/Process/Posix.hs @@ -18,6 +18,7 @@ module Streamly.Internal.System.Process.Posix , newProcess , wait , getStatus + , terminate -- * IPC , mkPipe @@ -39,6 +40,7 @@ import System.IO.Error (isDoesNotExistError) import System.Posix.IO (createPipe, dupTo, closeFd) import System.Posix.Process (forkProcess, executeFile, ProcessStatus) import System.Posix.Types (ProcessID, Fd(..), CDev, CIno) +import System.Posix.Signals (signalProcess, sigTERM) import System.Posix.Internals (fdGetMode) import qualified GHC.IO.FD as FD @@ -316,3 +318,6 @@ getStatus proc@(Process pid _ procStatus) = do if isDoesNotExistError e then return (Nothing, Nothing) else throwIO e + +terminate :: Process -> IO () +terminate (Process pid _ _) = signalProcess sigTERM pid From 02dd00c4e02200e0177f8e9a9555dfd7315d7a2a Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 8 Aug 2022 16:51:50 +0530 Subject: [PATCH 3/7] Fix imports, compilation for non-native case --- src/Streamly/Internal/System/Process.hs | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/src/Streamly/Internal/System/Process.hs b/src/Streamly/Internal/System/Process.hs index 5228b030..7b83f29c 100644 --- a/src/Streamly/Internal/System/Process.hs +++ b/src/Streamly/Internal/System/Process.hs @@ -95,10 +95,15 @@ where -- #define USE_NATIVE +import Control.Exception (Exception(..), catch, throwIO) +import Control.Monad (void, unless) import Control.Monad.Catch (MonadCatch, throwM) import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Concurrent (forkIO) import Data.Function ((&)) import Data.Word (Word8) +import Foreign.C.Error (Errno(..), ePIPE) +import GHC.IO.Exception (IOException(..), IOErrorType(..)) import Streamly.Data.Array.Foreign (Array) import Streamly.Data.Fold (Fold) import Streamly.Prelude (MonadAsync, parallel, IsStream, adapt, SerialT) @@ -106,16 +111,10 @@ import System.Exit (ExitCode(..)) import System.IO (hClose, Handle) #ifdef USE_NATIVE -import Control.Exception (Exception(..), catch, throwIO, SomeException) +import Control.Exception (SomeException) import System.Posix.Process (ProcessStatus(..)) import Streamly.Internal.System.Process.Posix -import Control.Concurrent (forkIO) #else -import Control.Concurrent (forkIO) -import Control.Exception (Exception(..), catch, throwIO) -import Control.Monad (void, unless) -import Foreign.C.Error (Errno(..), ePIPE) -import GHC.IO.Exception (IOException(..), IOErrorType(..)) import System.Process ( ProcessHandle , CreateProcess(..) @@ -142,9 +141,6 @@ import qualified Streamly.Internal.Data.Unfold as Unfold (either) import qualified Streamly.Internal.FileSystem.Handle as Handle (getChunks, putChunks) import qualified Streamly.Internal.Unicode.Stream as Unicode -import GHC.IO.Exception (IOException(..), IOErrorType (ResourceVanished)) -import Foreign.C (ePIPE, Errno (..)) -import Control.Monad (unless, void) -- $setup -- >>> :set -XFlexibleContexts @@ -299,7 +295,11 @@ cleanupException :: MonadIO m => (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> m () cleanupException (Just stdinH, Just stdoutH, stderrMaybe, ph) = liftIO $ do -- Send a SIGTERM to the process +#ifdef USE_NATIVE terminate ph +#else + terminateProcess ph +#endif -- Ideally we should be closing the handle without flushing the buffers so -- that we cannot get a SIGPIPE. But there seems to be no way to do that as @@ -309,7 +309,11 @@ cleanupException (Just stdinH, Just stdoutH, stderrMaybe, ph) = liftIO $ do whenJust hClose stderrMaybe -- Non-blocking wait for the process to go away +#ifdef USE_NATIVE void $ forkIO (void $ wait ph) +#else + void $ forkIO (void $ waitForProcess ph) +#endif where From d66c7eb07056c84b0c7700b7210f7806bcba553f Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 18 Jul 2022 14:49:27 +0530 Subject: [PATCH 4/7] Update streamly commit for nix, stack --- default.nix | 4 ++-- src/Streamly/Internal/System/Command.hs | 2 +- src/Streamly/Internal/System/Process.hs | 4 ++-- src/Streamly/System/Process.hs | 2 +- stack.yaml | 4 ++-- 5 files changed, 8 insertions(+), 8 deletions(-) diff --git a/default.nix b/default.nix index 550cba8d..f6dcc745 100644 --- a/default.nix +++ b/default.nix @@ -47,7 +47,7 @@ let haskellPackages = # } {}) (let src = fetchGit { url = "git@github.com:composewell/streamly.git"; - rev = "1ee11e87ec920df66e6bb1299ab000948df90ae5"; + rev = "4bb8b7c950ffeee9d5c9c3ca23c65be93ca34f0b"; }; in super.callCabal2nix "streamly" src {}) (old: { librarySystemDepends = @@ -62,7 +62,7 @@ let haskellPackages = nixpkgs.haskell.lib.overrideCabal (let src = fetchGit { url = "git@github.com:composewell/streamly.git"; - rev = "cbccb7777792cb4bf8dd8716929f4e28ea6cf718"; + rev = "4bb8b7c950ffeee9d5c9c3ca23c65be93ca34f0b"; }; in super.callCabal2nix "streamly-core" "${src}/core" {}) (old: { librarySystemDepends = diff --git a/src/Streamly/Internal/System/Command.hs b/src/Streamly/Internal/System/Command.hs index cd8af967..b45900fe 100644 --- a/src/Streamly/Internal/System/Command.hs +++ b/src/Streamly/Internal/System/Command.hs @@ -61,7 +61,7 @@ where import Control.Monad.Catch (MonadCatch) import Data.Char (isSpace) import Data.Word (Word8) -import Streamly.Data.Array.Foreign (Array) +import Streamly.Data.Array.Unboxed (Array) import Streamly.Data.Fold (Fold) import Streamly.Internal.Data.Parser (Parser) import Streamly.Prelude (MonadAsync, SerialT) diff --git a/src/Streamly/Internal/System/Process.hs b/src/Streamly/Internal/System/Process.hs index 7b83f29c..a923d44d 100644 --- a/src/Streamly/Internal/System/Process.hs +++ b/src/Streamly/Internal/System/Process.hs @@ -104,7 +104,7 @@ import Data.Function ((&)) import Data.Word (Word8) import Foreign.C.Error (Errno(..), ePIPE) import GHC.IO.Exception (IOException(..), IOErrorType(..)) -import Streamly.Data.Array.Foreign (Array) +import Streamly.Data.Array.Unboxed (Array) import Streamly.Data.Fold (Fold) import Streamly.Prelude (MonadAsync, parallel, IsStream, adapt, SerialT) import System.Exit (ExitCode(..)) @@ -126,7 +126,7 @@ import System.Process ) #endif -import qualified Streamly.Data.Array.Foreign as Array +import qualified Streamly.Data.Array.Unboxed as Array import qualified Streamly.Data.Fold as Fold import qualified Streamly.Prelude as Stream diff --git a/src/Streamly/System/Process.hs b/src/Streamly/System/Process.hs index e022ad3d..92c09eeb 100644 --- a/src/Streamly/System/Process.hs +++ b/src/Streamly/System/Process.hs @@ -134,7 +134,7 @@ import Streamly.Internal.System.Process -- >>> import Data.Char (toUpper) -- >>> import Data.Function ((&)) -- >>> import qualified Streamly.Console.Stdio as Stdio --- >>> import qualified Streamly.Data.Array.Foreign as Array +-- >>> import qualified Streamly.Data.Array.Unboxed as Array -- >>> import qualified Streamly.Data.Fold as Fold -- >>> import qualified Streamly.Prelude as Stream -- >>> import qualified Streamly.System.Process as Process diff --git a/stack.yaml b/stack.yaml index ecfb9263..be790b09 100644 --- a/stack.yaml +++ b/stack.yaml @@ -5,9 +5,9 @@ packages: extra-deps: - unicode-data-0.3.0 - git: https://github.com/composewell/streamly - commit: "1ee11e87ec920df66e6bb1299ab000948df90ae5" + commit: "4bb8b7c950ffeee9d5c9c3ca23c65be93ca34f0b" - git: https://github.com/composewell/streamly - commit: "1ee11e87ec920df66e6bb1299ab000948df90ae5" + commit: "4bb8b7c950ffeee9d5c9c3ca23c65be93ca34f0b" subdirs: - core From 38454ec272535b816973f181dd37caea87bd4347 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 8 Aug 2022 17:30:42 +0530 Subject: [PATCH 5/7] Remove benchmark and test dependency on process package --- Benchmark/System/Process.hs | 20 ++++++++------------ streamly-process.cabal | 2 -- 2 files changed, 8 insertions(+), 14 deletions(-) diff --git a/Benchmark/System/Process.hs b/Benchmark/System/Process.hs index 64a6bc08..945289ea 100644 --- a/Benchmark/System/Process.hs +++ b/Benchmark/System/Process.hs @@ -13,12 +13,12 @@ import System.IO , openFile , hClose ) -import System.Process (proc, createProcess, waitForProcess, callCommand) import qualified Streamly.Data.Fold as FL import qualified Streamly.FileSystem.Handle as FH import qualified Streamly.Prelude as S import qualified Streamly.System.Process as Proc +import qualified Streamly.Internal.System.Command as Cmd -- Internal imports import qualified Streamly.Internal.FileSystem.Handle @@ -71,16 +71,12 @@ largeByteFile = "./largeByteFile" generateByteFile :: IO () generateByteFile = do ddPath <- which "dd" - let procObj = proc ddPath [ - "if=" ++ devRandom, - "of=" ++ largeByteFile, - "count=" ++ show ddBlockCount, - "bs=" ++ show ddBlockSize - ] - - (_, _, _, procHandle) <- createProcess procObj - _ <- waitForProcess procHandle - return () + Cmd.toStdout + $ ddPath + ++ " if=" ++ devRandom + ++ " of=" ++ largeByteFile + ++ " count=" ++ show ddBlockCount + ++ " bs=" ++ show ddBlockSize ------------------------------------------------------------------------------- -- Create a file filled with ascii chars @@ -112,7 +108,7 @@ trToStderrContent = createExecutable :: IO () createExecutable = do writeFile trToStderr trToStderrContent - callCommand ("chmod +x " ++ trToStderr) + Cmd.toStdout ("chmod +x " ++ trToStderr) ------------------------------------------------------------------------------- -- Create and delete the temp data/exec files diff --git a/streamly-process.cabal b/streamly-process.cabal index c1782188..e2c0c097 100644 --- a/streamly-process.cabal +++ b/streamly-process.cabal @@ -110,7 +110,6 @@ benchmark Benchmark.System.Process streamly-process , base >= 4.8 && < 5 , directory >= 1.2.2 && < 1.4 - , process >= 1.0 && < 1.7 -- Uses internal APIs , streamly == 0.9.0.* @@ -140,7 +139,6 @@ test-suite Test.System.Process , directory >= 1.2.2 && < 1.4 , exceptions >= 0.8 && < 0.11 , hspec >= 2.0 && < 3 - , process >= 1.0 && < 1.7 , QuickCheck >= 2.10 && < 2.15 -- Uses internal APIs , streamly == 0.9.0.* From 31b80abcc6ccda2e94d8ffb3bf08582fc38a3f4c Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Mon, 8 Aug 2022 18:04:51 +0530 Subject: [PATCH 6/7] Add use-native build flag --- src/Streamly/Internal/System/Process.hs | 2 -- streamly-process.cabal | 19 ++++++++++++++----- 2 files changed, 14 insertions(+), 7 deletions(-) diff --git a/src/Streamly/Internal/System/Process.hs b/src/Streamly/Internal/System/Process.hs index a923d44d..cc9ac8af 100644 --- a/src/Streamly/Internal/System/Process.hs +++ b/src/Streamly/Internal/System/Process.hs @@ -93,8 +93,6 @@ module Streamly.Internal.System.Process ) where --- #define USE_NATIVE - import Control.Exception (Exception(..), catch, throwIO) import Control.Monad (void, unless) import Control.Monad.Catch (MonadCatch, throwM) diff --git a/streamly-process.cabal b/streamly-process.cabal index e2c0c097..7c9ae4cf 100644 --- a/streamly-process.cabal +++ b/streamly-process.cabal @@ -48,6 +48,11 @@ flag use-gauge manual: True default: False +flag use-native + description: Do not depend on the process package + manual: True + default: False + common compile-options default-language: Haskell2010 ghc-options: @@ -70,6 +75,8 @@ common optimization-options -fdicts-strict -fspec-constr-recursive=16 -fmax-worker-args=16 + if flag(use-native) + cpp-options: -DUSE_NATIVE library import: compile-options, optimization-options @@ -78,18 +85,20 @@ library Streamly.System.Process Streamly.Internal.System.Process Streamly.Internal.System.Command - if !os(windows) + if flag (use-native) && !os(windows) exposed-modules: Streamly.Internal.System.Process.Posix build-depends: base >= 4.8 && < 5 , exceptions >= 0.8 && < 0.11 - , process >= 1.0 && < 1.7 -- Uses internal APIs , streamly == 0.9.0.* - if !os(windows) - build-depends: - unix >= 2.5 && < 2.8 + if !flag(use-native) + build-depends: process >= 1.0 && < 1.7 + else + if !os(windows) + build-depends: + unix >= 2.5 && < 2.8 ------------------------------------------------------------------------------- -- Benchmarks From ec530568574d9b9b5acd3198df6ca3591457e6e6 Mon Sep 17 00:00:00 2001 From: Ishan Bhanuka Date: Sat, 13 Aug 2022 18:03:18 +0530 Subject: [PATCH 7/7] Add debug logging --- src/Streamly/Internal/System/Process.hs | 11 +++- src/Streamly/Internal/System/Process/Posix.hs | 50 ++++++++++++++----- 2 files changed, 48 insertions(+), 13 deletions(-) diff --git a/src/Streamly/Internal/System/Process.hs b/src/Streamly/Internal/System/Process.hs index cc9ac8af..51077d03 100644 --- a/src/Streamly/Internal/System/Process.hs +++ b/src/Streamly/Internal/System/Process.hs @@ -97,7 +97,8 @@ import Control.Exception (Exception(..), catch, throwIO) import Control.Monad (void, unless) import Control.Monad.Catch (MonadCatch, throwM) import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Concurrent (forkIO) +import Control.Concurrent (forkIO, forkOS, runInBoundThread) +import Control.Concurrent.MVar import Data.Function ((&)) import Data.Word (Word8) import Foreign.C.Error (Errno(..), ePIPE) @@ -356,6 +357,14 @@ createProc' modCfg path args = do Config cfg = modCfg $ mkConfig path args +createProc'' :: + (Config -> Config) -- ^ Process attribute modifier + -> FilePath -- ^ Executable path + -> [String] -- ^ Arguments + -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +createProc'' modCfg path args = + runInBoundThread $ createProc' modCfg path args + {-# INLINE putChunksClose #-} putChunksClose :: (MonadIO m, IsStream t) => Handle -> t m (Array Word8) -> t m a diff --git a/src/Streamly/Internal/System/Process/Posix.hs b/src/Streamly/Internal/System/Process/Posix.hs index edff2707..fe87360a 100644 --- a/src/Streamly/Internal/System/Process/Posix.hs +++ b/src/Streamly/Internal/System/Process/Posix.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE Safe #-} +-- {-# LANGUAGE Safe #-} -- | -- Module : Streamly.Internal.System.Process.Posix -- Copyright : (c) 2020 Composewell Technologies @@ -35,16 +35,19 @@ import Data.Tuple (swap) import GHC.IO.Device (IODeviceType(..)) import GHC.IO.Encoding (getLocaleEncoding) import GHC.IO.Handle.FD (mkHandleFromFD) -import System.IO (IOMode(..), Handle) +import System.IO (IOMode(..), Handle, hPutStrLn, stderr) import System.IO.Error (isDoesNotExistError) import System.Posix.IO (createPipe, dupTo, closeFd) -import System.Posix.Process (forkProcess, executeFile, ProcessStatus) +import System.Posix.Process (forkProcess, executeFile, ProcessStatus, getProcessID) import System.Posix.Types (ProcessID, Fd(..), CDev, CIno) import System.Posix.Signals (signalProcess, sigTERM) import System.Posix.Internals (fdGetMode) +import qualified Streamly.Internal.FileSystem.Dir as Dir +import qualified Streamly.Prelude as Stream import qualified GHC.IO.FD as FD import qualified System.Posix.Process as Posix +import Data.List (intercalate) ------------------------------------------------------------------------------- -- Utilities to create stdio handles @@ -54,13 +57,13 @@ import qualified System.Posix.Process as Posix -- We have to put the FDs into binary mode on Windows to avoid the newline -- translation that the CRT IO library does. setBinaryMode :: FD.FD -> IO () -#if defined(mingw32_HOST_OS) -setBinaryMode fd = do - _ <- setmode (FD.fdFD fd) True - return () -#else + + + + + setBinaryMode _ = return () -#endif + -- See Posix.fdToHandle and GHC.IO.Handle.FD.fdToHandle -- See stdin, stdout, stderr in module GHC.IO.Handle.FD @@ -112,9 +115,18 @@ mkPipeDupChild :: Direction -> Fd -> IO (Fd, (IO (), IO (), IO ())) mkPipeDupChild direction childFd = do let setDirection = if direction == ParentToChild then id else swap (child, parent) <- fmap setDirection createPipe + pid <- getProcessID let parentAction = closeFd child childAction = - closeFd parent >> void (dupTo child childFd) >> closeFd child + hPutStrLn stderr ("closing parent fd" ++ show parent) >> + closeFd parent >> + hPutStrLn stderr ("closed parent fd" ++ show parent) >> + hPutStrLn stderr ("duplicating child to fd" ++ show (child, childFd)) >> + void (dupTo child childFd) >> + hPutStrLn stderr ("duplicated child to fd" ++ show (child, childFd)) >> + hPutStrLn stderr ("closing child" ++ show child) >> + closeFd child >> + hPutStrLn stderr ("closed child" ++ show child) failureAction = closeFd child >> closeFd parent return (parent, (parentAction, childAction, failureAction)) @@ -144,7 +156,15 @@ mkStdioPipes pipeStdErr = do -} let parentAction = inpParent >> outParent >> errParent -- >> excParent - childAction = inpChild >> outChild >> errChild -- >> excChild + childAction = + hPutStrLn stderr "child input action doing" + >> inpChild + >> hPutStrLn stderr "child input action done" + >> hPutStrLn stderr "child output action doing" + >> outChild + >> hPutStrLn stderr "child output action done" + >> errChild -- >> excChild + -- childAction = inpChild >> outChild >> errChild -- >> excChild failureAction = inpFail >> outFail >> errFail -- >> excFail inpH <- toHandle WriteMode inp @@ -238,6 +258,7 @@ newProcess :: -> IO Process newProcess action path args env = do pid <- forkProcess exec + hPutStrLn stderr ("parent process " ++ show pid) pidToProcess pid Nothing where @@ -246,7 +267,12 @@ newProcess action path args env = do -- to the parent and clean up the parent fds. We can send the exceptions -- via a pipe like we do for threads. -- - exec = action >> executeFile path True args env + exec = do + pid <- getProcessID + hPutStrLn stderr ("child process " ++ show pid) + fds <- Stream.toList . Stream.unfold Dir.readFiles $ ("/proc/" ++ show pid ++ "/fd") + hPutStrLn stderr (intercalate ", " fds) + action >> executeFile path True args env newtype ProcessDoesNotExist = ProcessDoesNotExist ProcessID deriving Show