{-# 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 <- IO (TMVar (IO ()))
forall a. IO (TMVar a)
newEmptyTMVarIO
  let f :: IO () -> IO ()
f IO ()
act = STM () -> IO ()
forall a. STM a -> IO a
atomically (TMVar (IO ()) -> IO () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (IO ())
req IO ()
act)
      m1 :: IO ()
m1 = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Handle -> IO FilePath
hGetLine Handle
outh IO FilePath -> (FilePath -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FilePath
s -> IO () -> IO ()
f (FilePath -> IO ()
putMsg FilePath
s))
           IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (\IOError
e -> if IOError -> Bool
isEOFError IOError
e then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else IOError -> IO ()
forall a. IOError -> IO a
ioError IOError
e)
      m2 :: IO ()
m2 = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Handle -> IO FilePath
hGetLine Handle
errh IO FilePath -> (FilePath -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FilePath
s -> IO () -> IO ()
f (FilePath -> IO ()
putErr FilePath
s))
           IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (\IOError
e -> if IOError -> Bool
isEOFError IOError
e then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else IOError -> IO ()
forall a. IOError -> IO a
ioError IOError
e)
  IO () -> (STM () -> IO ()) -> IO ()
forall a. IO () -> (STM () -> IO a) -> IO a
withForkWait IO ()
m1 ((STM () -> IO ()) -> IO ()) -> (STM () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \STM ()
waitOut -> do
    IO () -> (STM () -> IO ()) -> IO ()
forall a. IO () -> (STM () -> IO a) -> IO a
withForkWait IO ()
m2 ((STM () -> IO ()) -> IO ()) -> (STM () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \STM ()
waitErr -> do
      -- now write any input
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
input) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        IO () -> IO ()
ignoreSigPipe (IO () -> IO ()) -> IO () -> IO ()
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 (IO () -> IO ()) -> IO () -> IO ()
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 = IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ [STM (IO ())] -> STM (IO ())
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([STM (IO ())] -> STM (IO ())) -> [STM (IO ())] -> STM (IO ())
forall a b. (a -> b) -> a -> b
$
            [ do IO ()
act <- TMVar (IO ()) -> STM (IO ())
forall a. TMVar a -> STM a
takeTMVar TMVar (IO ())
req
                 IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ IO ()
act IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loop
            , do Bool -> STM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> STM ()) -> STM Bool -> STM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TMVar (IO ()) -> STM Bool
forall a. TMVar a -> STM Bool
isEmptyTMVar TMVar (IO ())
req
                 STM ()
waitOut
                 STM ()
waitErr
                 IO () -> STM (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
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 :: IO () -> (STM () -> IO a) -> IO a
withForkWait IO ()
async STM () -> IO a
body = do
  TMVar (Either SomeException ())
waitVar <- IO (TMVar (Either SomeException ()))
forall a. IO (TMVar a)
newEmptyTMVarIO :: IO (TMVar (Either SomeException ()))
  ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    ThreadId
tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO ()
forall a. IO a -> IO a
restore IO ()
async) IO (Either SomeException ())
-> (Either SomeException () -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either SomeException ()
v -> STM () -> IO ()
forall a. STM a -> IO a
atomically (TMVar (Either SomeException ())
-> Either SomeException () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either SomeException ())
waitVar Either SomeException ()
v)
    let wait :: STM ()
wait = TMVar (Either SomeException ()) -> STM (Either SomeException ())
forall a. TMVar a -> STM a
takeTMVar TMVar (Either SomeException ())
waitVar STM (Either SomeException ())
-> (Either SomeException () -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> STM ())
-> (() -> STM ()) -> Either SomeException () -> STM ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> STM ()
forall e a. Exception e => e -> STM a
throwSTM () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return
    IO a -> IO a
forall a. IO a -> IO a
restore (STM () -> IO a
body STM ()
wait) IO a -> IO () -> IO a
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 = (IOError -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
C.handle ((IOError -> IO ()) -> IO () -> IO ())
-> (IOError -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ \IOError
e -> case IOError
e of
                                   IOError { ioe_type :: IOError -> IOErrorType
ioe_type  = IOErrorType
ResourceVanished
                                           , ioe_errno :: IOError -> Maybe CInt
ioe_errno = Just CInt
ioe }
                                     | CInt -> Errno
Errno CInt
ioe Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
ePIPE -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                   IOError
_ -> IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOError
e
#else
ignoreSigPipe = id
#endif