Commits

David Lazar committed b71812b Merge

Merge pull request #1 from basvandijk/master

Fixed asynchronous exception bugs & Add System.Process.Text.Lazy

  • Participants
  • Parent commits ca78e0b, d736464

Comments (0)

Files changed (6)

process-extras.cabal

     System.Process.ByteString
     System.Process.ByteString.Lazy
     System.Process.Text
+    System.Process.Text.Lazy
+
+  Other-modules:
+    Utils
 
   Build-depends:
     base >= 4 && < 5,
     process,
     bytestring,
-    text
+    text,
+    deepseq

src/System/Process/ByteString.hs

 module System.Process.ByteString where
 
-import Control.Concurrent
+import Control.Exception
 import Control.Monad
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as B
 import System.Process
 import System.Exit (ExitCode)
 import System.IO
+import Utils (forkWait)
 
 -- | Like 'System.Process.readProcessWithExitCode', but using 'ByteString'
 readProcessWithExitCode
     -> [String]                 -- ^ any arguments
     -> ByteString               -- ^ standard input
     -> IO (ExitCode, ByteString, ByteString) -- ^ exitcode, stdout, stderr
-readProcessWithExitCode cmd args input = do
+readProcessWithExitCode cmd args input = mask $ \restore -> do
     (Just inh, Just outh, Just errh, pid) <-
         createProcess (proc cmd args){ std_in  = CreatePipe,
                                        std_out = CreatePipe,
                                        std_err = CreatePipe }
-    outMVar <- newEmptyMVar
-    outM <- newEmptyMVar
-    errM <- newEmptyMVar
+    flip onException
+      (do hClose inh; hClose outh; hClose errh;
+          terminateProcess pid; waitForProcess pid) $ restore $ do
 
-    -- fork off a thread to start consuming stdout
-    _ <- forkIO $ do
-        out <- B.hGetContents outh
-        putMVar outM out
-        putMVar outMVar ()
+        -- fork off a thread to start consuming stdout
+      waitOut <- forkWait $ B.hGetContents outh
 
-    -- fork off a thread to start consuming stderr
-    _ <- forkIO $ do
-        err  <- B.hGetContents errh
-        putMVar errM err
-        putMVar outMVar ()
+        -- fork off a thread to start consuming stderr
+      waitErr <- forkWait $ B.hGetContents errh
 
-    -- now write and flush any input
-    when (not (B.null input)) $ do B.hPutStr inh input; hFlush inh
-    hClose inh -- done with stdin
+      -- now write and flush any input
+      unless (B.null input) $ do B.hPutStr inh input; hFlush inh
+      hClose inh -- done with stdin
 
-    -- wait on the output
-    takeMVar outMVar
-    takeMVar outMVar
-    hClose outh
-    hClose errh
+      -- wait on the output
+      out <- waitOut
+      err <- waitErr
 
-    -- wait on the process
-    ex <- waitForProcess pid
-    out <- readMVar outM
-    err <- readMVar errM
+      hClose outh
+      hClose errh
 
-    return (ex, out, err)
+      -- wait on the process
+      ex <- waitForProcess pid
+
+      return (ex, out, err)

src/System/Process/ByteString/Lazy.hs

 module System.Process.ByteString.Lazy where
 
-import Control.Concurrent
-import qualified Control.Exception as C
+import Control.Exception
+import qualified Control.Exception as C (evaluate)
 import Control.Monad
 import Data.ByteString.Lazy (ByteString)
 import qualified Data.ByteString.Lazy as B
 import System.Process
 import System.Exit (ExitCode)
 import System.IO
+import Utils (forkWait)
 
 -- | Like 'System.Process.readProcessWithExitCode', but using 'ByteString'
 readProcessWithExitCode
     -> [String]                 -- ^ any arguments
     -> ByteString               -- ^ standard input
     -> IO (ExitCode, ByteString, ByteString) -- ^ exitcode, stdout, stderr
-readProcessWithExitCode cmd args input = do
+readProcessWithExitCode cmd args input = mask $ \restore -> do
     (Just inh, Just outh, Just errh, pid) <-
         createProcess (proc cmd args){ std_in  = CreatePipe,
                                        std_out = CreatePipe,
                                        std_err = CreatePipe }
-    outMVar <- newEmptyMVar
+    flip onException
+      (do hClose inh; hClose outh; hClose errh;
+            terminateProcess pid; waitForProcess pid) $ restore $ do
 
-    -- fork off a thread to start consuming stdout
-    out  <- B.hGetContents outh
-    _ <- forkIO $ C.evaluate (B.length out) >> putMVar outMVar ()
+      -- fork off a thread to start consuming stdout
+      out <- B.hGetContents outh
+      waitOut <- forkWait $ void $ C.evaluate $ B.length out
 
-    -- fork off a thread to start consuming stderr
-    err  <- B.hGetContents errh
-    _ <- forkIO $ C.evaluate (B.length err) >> putMVar outMVar ()
+      -- fork off a thread to start consuming stderr
+      err <- B.hGetContents errh
+      waitErr <- forkWait $ void $ C.evaluate $ B.length err
 
-    -- now write and flush any input
-    when (not (B.null input)) $ do B.hPutStr inh input; hFlush inh
-    hClose inh -- done with stdin
+      -- now write and flush any input
+      unless (B.null input) $ do B.hPutStr inh input; hFlush inh
+      hClose inh -- done with stdin
 
-    -- wait on the output
-    takeMVar outMVar
-    takeMVar outMVar
-    hClose outh
-    hClose errh
+      -- wait on the output
+      waitOut
+      waitErr
 
-    -- wait on the process
-    ex <- waitForProcess pid
+      hClose outh
+      hClose errh
 
-    return (ex, out, err)
+      -- wait on the process
+      ex <- waitForProcess pid
+
+      return (ex, out, err)

src/System/Process/Text.hs

 module System.Process.Text where
 
-import Control.Concurrent
+import Control.Exception
 import Control.Monad
 import Data.Text (Text)
 import qualified Data.Text as T
 import System.Process
 import System.Exit (ExitCode)
 import System.IO
+import Utils (forkWait)
 
 -- | Like 'System.Process.readProcessWithExitCode', but using 'Text'
 readProcessWithExitCode
     -> [String]                 -- ^ any arguments
     -> Text                     -- ^ standard input
     -> IO (ExitCode, Text, Text) -- ^ exitcode, stdout, stderr
-readProcessWithExitCode cmd args input = do
+readProcessWithExitCode cmd args input = mask $ \restore -> do
     (Just inh, Just outh, Just errh, pid) <-
         createProcess (proc cmd args){ std_in  = CreatePipe,
                                        std_out = CreatePipe,
                                        std_err = CreatePipe }
-    outMVar <- newEmptyMVar
-    outM <- newEmptyMVar
-    errM <- newEmptyMVar
+    flip onException
+      (do hClose inh; hClose outh; hClose errh;
+          terminateProcess pid; waitForProcess pid) $ restore $ do
 
-    -- fork off a thread to start consuming stdout
-    _ <- forkIO $ do
-        out <- T.hGetContents outh
-        putMVar outM out
-        putMVar outMVar ()
+        -- fork off a thread to start consuming stdout
+      waitOut <- forkWait $ T.hGetContents outh
 
-    -- fork off a thread to start consuming stderr
-    _ <- forkIO $ do
-        err  <- T.hGetContents errh
-        putMVar errM err
-        putMVar outMVar ()
+        -- fork off a thread to start consuming stderr
+      waitErr <- forkWait $ T.hGetContents errh
 
-    -- now write and flush any input
-    when (not (T.null input)) $ do T.hPutStr inh input; hFlush inh
-    hClose inh -- done with stdin
+      -- now write and flush any input
+      unless (T.null input) $ do T.hPutStr inh input; hFlush inh
+      hClose inh -- done with stdin
 
-    -- wait on the output
-    takeMVar outMVar
-    takeMVar outMVar
-    hClose outh
-    hClose errh
+      -- wait on the output
+      out <- waitOut
+      err <- waitErr
 
-    -- wait on the process
-    ex <- waitForProcess pid
-    out <- readMVar outM
-    err <- readMVar errM
+      hClose outh
+      hClose errh
 
-    return (ex, out, err)
+      -- wait on the process
+      ex <- waitForProcess pid
+
+      return (ex, out, err)

src/System/Process/Text/Lazy.hs

+module System.Process.Text.Lazy where
+
+import Control.DeepSeq (rnf)
+import Control.Exception
+import qualified Control.Exception as C (evaluate)
+import Control.Monad
+import Data.Text.Lazy (Text)
+import qualified Data.Text.Lazy as T
+import qualified Data.Text.Lazy.IO as T
+import System.Process
+import System.Exit (ExitCode)
+import System.IO
+import Utils (forkWait)
+
+-- | Like 'System.Process.readProcessWithExitCode', but using 'Text'
+readProcessWithExitCode
+    :: FilePath                  -- ^ command to run
+    -> [String]                  -- ^ any arguments
+    -> Text                      -- ^ standard input
+    -> IO (ExitCode, Text, Text) -- ^ exitcode, stdout, stderr
+readProcessWithExitCode cmd args input = mask $ \restore -> do
+    (Just inh, Just outh, Just errh, pid) <-
+        createProcess (proc cmd args){ std_in  = CreatePipe,
+                                       std_out = CreatePipe,
+                                       std_err = CreatePipe }
+    flip onException
+      (do hClose inh; hClose outh; hClose errh;
+            terminateProcess pid; waitForProcess pid) $ restore $ do
+
+      -- fork off a thread to start consuming stdout
+      out <- T.hGetContents outh
+      waitOut <- forkWait $ C.evaluate $ rnf out
+
+      -- fork off a thread to start consuming stderr
+      err <- T.hGetContents errh
+      waitErr <- forkWait $ C.evaluate $ rnf err
+
+      -- now write and flush any input
+      unless (T.null input) $ do T.hPutStr inh input; hFlush inh
+      hClose inh -- done with stdin
+
+      -- wait on the output
+      waitOut
+      waitErr
+
+      hClose outh
+      hClose errh
+
+      -- wait on the process
+      ex <- waitForProcess pid
+
+      return (ex, out, err)
+module Utils where
+
+import Control.Concurrent
+import Control.Exception
+
+forkWait :: IO a -> IO (IO a)
+forkWait a = do
+  res <- newEmptyMVar
+  _ <- mask $ \restore -> forkIO $ try (restore a) >>= putMVar res
+  return (takeMVar res >>= either (\ex -> throwIO (ex :: SomeException)) return)