use process-extras

2 files changed, 6 insertions, 115 deletions

diff --git a/much.cabal b/much.cabal
index fb33c6d..fc301e5 100644
--- a/much.cabal
+++ b/much.cabal
@@ -89,6 +89,7 @@ library
                  , old-locale
                  , optparse-applicative
                  , process
+                 , process-extras
                  , random
                  , rosezipper
                  , safe
diff --git a/src/Notmuch.hs b/src/Notmuch.hs
index 080df1e..310657a 100644
--- a/src/Notmuch.hs
+++ b/src/Notmuch.hs
@@ -7,9 +7,6 @@ import qualified Data.ByteString.Lazy.Char8 as LBS8
 import qualified Data.Text.Lazy as LT
 import qualified Data.Text.Lazy.Encoding as LT
 import qualified Network.Mail.Mime as M
-import Control.Concurrent
-import Control.DeepSeq (rnf)
-import Control.Exception
 import Data.Aeson.Extends
 import Data.Either.Combinators (mapRight)
 import Data.Functor ((<&>))
@@ -19,126 +16,19 @@ import Notmuch.Message
 import Notmuch.SearchResult
 import Much.ParseMail (readMail)
 import System.Exit
-import System.IO
-import System.Process
+import System.Process.ByteString.Lazy (readProcessWithExitCode)
 import Much.TagUtils
 
 
--- | Fork a thread while doing something else, but kill it if there's an
--- exception.
---
--- This is important in the cases above because we want to kill the thread
--- that is holding the Handle lock, because when we clean up the process we
--- try to close that handle, which could otherwise deadlock.
---
-withForkWait :: IO () -> (IO () ->  IO a) -> IO a
-withForkWait async body = do
-  waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
-  mask $ \restore -> do
-    tid <- forkIO $ try (restore async) >>= putMVar waitVar
-    let wait = takeMVar waitVar >>= either throwIO return
-    restore (body wait) `onException` killThread tid
-
-
-
-
 notmuch :: [String] -> IO LBS.ByteString
 notmuch args = do
-    (_, Just hout, _, ph) <- createProcess (proc "notmuch" args)
-                                          { std_out = CreatePipe }
-    output <- LBS.hGetContents hout
-
-
-    withForkWait (evaluate $ rnf output) $ \waitOut -> do
-
-      ---- now write any input
-      --unless (null input) $
-      --  ignoreSigPipe $ hPutStr inh input
-      -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
-      --ignoreSigPipe $ hClose inh
-
-      -- wait on the output
-      waitOut
-      hClose hout
-
-    -- wait on the process
-    _ex <- waitForProcess ph
-    --return (ex, output)
-
-    --case ex of
-    --    ExitSuccess   -> return output
-    --    ExitFailure r -> processFailedException "readProcess" cmd args r
-
-    return output
+    (_exitCode, out, _err) <- notmuch' args
+    return out
 
 
 notmuch' :: [String] -> IO (ExitCode, LBS.ByteString, LBS.ByteString)
-notmuch' args = do
-    (_, Just hout, Just herr, ph) <-
-        createProcess (proc "notmuch" args)
-            { std_out = CreatePipe
-            , std_err = CreatePipe
-            }
-    out <- LBS.hGetContents hout
-    err <- LBS.hGetContents herr
-
-    withForkWait (evaluate $ rnf out) $ \waitOut -> do
-        withForkWait (evaluate $ rnf err) $ \waitErr -> do
-
-          ---- now write any input
-          --unless (null input) $
-          --  ignoreSigPipe $ hPutStr inh input
-          -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
-          --ignoreSigPipe $ hClose inh
-
-          -- wait on the output
-          waitOut
-          waitErr
-          hClose hout
-          hClose herr
-
-    -- wait on the process
-    exitCode <- waitForProcess ph
-
-    return (exitCode, out, err)
-
-
-notmuchWithInput
-    :: [String]
-    -> LBS.ByteString
-    -> IO (ExitCode, LBS.ByteString, LBS.ByteString)
-notmuchWithInput args input = do
-    (Just hin, Just hout, Just herr, ph) <-
-        createProcess (proc "notmuch" args)
-            { std_in = CreatePipe
-            , std_out = CreatePipe
-            , std_err = CreatePipe
-            }
-    LBS.hPut hin input
-    hClose hin
-
-    out <- LBS.hGetContents hout
-    err <- LBS.hGetContents herr
-
-    withForkWait (evaluate $ rnf out) $ \waitOut -> do
-        withForkWait (evaluate $ rnf err) $ \waitErr -> do
-
-          ---- now write any input
-          --unless (null input) $
-          --  ignoreSigPipe $ hPutStr inh input
-          -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
-          --ignoreSigPipe $ hClose inh
-
-          -- wait on the output
-          waitOut
-          waitErr
-          hClose hout
-          hClose herr
-
-    -- wait on the process
-    exitCode <- waitForProcess ph
-
-    return (exitCode, out, err)
+notmuch' args =
+    readProcessWithExitCode "notmuch" args ""
 
 
 search :: [String] -> IO (Either String [SearchResult])