{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  ToySolver.Internal.ProcessUtil
-- Copyright   :  (c) Masahiro Sakai 2014
-- License     :  BSD-style
--
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  non-portable
--
-----------------------------------------------------------------------------
module ToySolver.Internal.ProcessUtil
  ( runProcessWithOutputCallback
  ) where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception (SomeException, try, mask, throwIO)
import qualified Control.Exception as C
import Control.Monad
import Foreign.C
import System.Exit
import System.IO
import System.IO.Error
import System.Process

#ifdef __GLASGOW_HASKELL__
import GHC.IO.Exception ( IOErrorType(..), IOException(..) )
#endif

runProcessWithOutputCallback
  :: FilePath -- ^ Filename of the executable (see 'proc' for details)
  -> [String] -- ^ any arguments
  -> String   -- ^ standard input
  -> (String -> IO ()) -- ^ callback function which is called when a line is read from stdout
  -> (String -> IO ()) -- ^ callback function which is called when a line is read from stderr
  -> IO ExitCode
runProcessWithOutputCallback :: FilePath
-> [FilePath]
-> FilePath
-> (FilePath -> IO ())
-> (FilePath -> IO ())
-> IO ExitCode
runProcessWithOutputCallback FilePath
cmd [FilePath]
args FilePath
input FilePath -> IO ()
putMsg FilePath -> IO ()
putErr = do
  (Just Handle
inh, Just Handle
outh, Just Handle
errh, ProcessHandle
processh) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess
    (FilePath -> [FilePath] -> CreateProcess
proc FilePath
cmd [FilePath]
args)
    { std_in :: StdStream
std_in  = StdStream
CreatePipe
    , std_out :: StdStream
std_out = StdStream
CreatePipe
    , std_err :: StdStream
std_err = StdStream
CreatePipe
    }
  TMVar (IO ())
req <- forall a. IO (TMVar a)
newEmptyTMVarIO
  let f :: IO () -> IO ()
f IO ()
act = forall a. STM a -> IO a
atomically (forall a. TMVar a -> a -> STM ()
putTMVar TMVar (IO ())
req IO ()
act)
      m1 :: IO ()
m1 = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Handle -> IO FilePath
hGetLine Handle
outh forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FilePath
s -> IO () -> IO ()
f (FilePath -> IO ()
putMsg FilePath
s))
           forall a. IO a -> (IOException -> IO a) -> IO a
`catchIOError` (\IOException
e -> if IOException -> Bool
isEOFError IOException
e then forall (m :: * -> *) a. Monad m => a -> m a
return () else forall a. IOException -> IO a
ioError IOException
e)
      m2 :: IO ()
m2 = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Handle -> IO FilePath
hGetLine Handle
errh forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FilePath
s -> IO () -> IO ()
f (FilePath -> IO ()
putErr FilePath
s))
           forall a. IO a -> (IOException -> IO a) -> IO a
`catchIOError` (\IOException
e -> if IOException -> Bool
isEOFError IOException
e then forall (m :: * -> *) a. Monad m => a -> m a
return () else forall a. IOException -> IO a
ioError IOException
e)
  forall a. IO () -> (STM () -> IO a) -> IO a
withForkWait IO ()
m1 forall a b. (a -> b) -> a -> b
$ \STM ()
waitOut -> do
    forall a. IO () -> (STM () -> IO a) -> IO a
withForkWait IO ()
m2 forall a b. (a -> b) -> a -> b
$ \STM ()
waitErr -> do
      -- now write any input
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
input) forall a b. (a -> b) -> a -> b
$
        IO () -> IO ()
ignoreSigPipe forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStr Handle
inh FilePath
input
      -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
      IO () -> IO ()
ignoreSigPipe forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
inh

      Handle -> BufferMode -> IO ()
hSetBuffering Handle
outh BufferMode
LineBuffering
      Handle -> BufferMode -> IO ()
hSetBuffering Handle
errh BufferMode
LineBuffering
      let loop :: IO ()
loop = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$
            [ do IO ()
act <- forall a. TMVar a -> STM a
takeTMVar TMVar (IO ())
req
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ IO ()
act forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loop
            , do forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. TMVar a -> STM Bool
isEmptyTMVar TMVar (IO ())
req
                 STM ()
waitOut
                 STM ()
waitErr
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
            ]
      IO ()
loop
      Handle -> IO ()
hClose Handle
outh
      Handle -> IO ()
hClose Handle
errh
  ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
processh

withForkWait :: IO () -> (STM () ->  IO a) -> IO a
withForkWait :: forall a. IO () -> (STM () -> IO a) -> IO a
withForkWait IO ()
async STM () -> IO a
body = do
  TMVar (Either SomeException ())
waitVar <- forall a. IO (TMVar a)
newEmptyTMVarIO :: IO (TMVar (Either SomeException ()))
  forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    ThreadId
tid <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try (forall a. IO a -> IO a
restore IO ()
async) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either SomeException ()
v -> forall a. STM a -> IO a
atomically (forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either SomeException ())
waitVar Either SomeException ()
v)
    let wait :: STM ()
wait = forall a. TMVar a -> STM a
takeTMVar TMVar (Either SomeException ())
waitVar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> STM a
throwSTM forall (m :: * -> *) a. Monad m => a -> m a
return
    forall a. IO a -> IO a
restore (STM () -> IO a
body STM ()
wait) forall a b. IO a -> IO b -> IO a
`C.onException` ThreadId -> IO ()
killThread ThreadId
tid

ignoreSigPipe :: IO () -> IO ()
#if defined(__GLASGOW_HASKELL__)
ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
C.handle forall a b. (a -> b) -> a -> b
$ \IOException
e -> case IOException
e of
                                   IOError { ioe_type :: IOException -> IOErrorType
ioe_type  = IOErrorType
ResourceVanished
                                           , ioe_errno :: IOException -> Maybe CInt
ioe_errno = Just CInt
ioe }
                                     | CInt -> Errno
Errno CInt
ioe forall a. Eq a => a -> a -> Bool
== Errno
ePIPE -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                   IOException
_ -> forall e a. Exception e => e -> IO a
throwIO IOException
e
#else
ignoreSigPipe = id
#endif