module Coquina.Internal where

import Control.Concurrent (MVar, forkIO, killThread, newEmptyMVar, putMVar, takeMVar)
import Control.DeepSeq (rnf)
import Control.Exception (SomeException, evaluate, mask, onException, throwIO, try)
import qualified Control.Exception as C
import Control.Monad
import Data.ByteString (hGetContents)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text.IO as T
import Foreign.C.Error (Errno(..), ePIPE)
import GHC.IO.Exception (IOErrorType(..), IOException(..))
import System.Exit
import System.IO (hClose)
import System.Process

-- | Like readCreateProcess
readAndDecodeCreateProcess :: CreateProcess -> Text -> IO (ExitCode, Text, Text)
readAndDecodeCreateProcess :: CreateProcess -> Text -> IO (ExitCode, Text, Text)
readAndDecodeCreateProcess CreateProcess
cp Text
input =
  CreateProcess
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> IO (ExitCode, Text, Text))
-> IO (ExitCode, Text, Text)
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess (CreateProcess
cp { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }) ((Maybe Handle
  -> Maybe Handle
  -> Maybe Handle
  -> ProcessHandle
  -> IO (ExitCode, Text, Text))
 -> IO (ExitCode, Text, Text))
-> (Maybe Handle
    -> Maybe Handle
    -> Maybe Handle
    -> ProcessHandle
    -> IO (ExitCode, Text, Text))
-> IO (ExitCode, Text, Text)
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
mstdin Maybe Handle
mouth Maybe Handle
merrh ProcessHandle
ph -> case (Maybe Handle
mstdin, Maybe Handle
mouth, Maybe Handle
merrh) of
    (Just Handle
inh, Just Handle
outh, Just Handle
errh) -> do
      -- Write stdin
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
input) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        IO () -> IO ()
ignoreSigPipe (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
T.hPutStr Handle
inh Text
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
      Text
out <- (ByteString -> Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decodeUtf8 (IO ByteString -> IO Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> a -> b
$ Handle -> IO ByteString
hGetContents Handle
outh
      Text
err <- (ByteString -> Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decodeUtf8 (IO ByteString -> IO Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> a -> b
$ Handle -> IO ByteString
hGetContents Handle
errh
      IO () -> (IO () -> IO ()) -> IO ()
forall a. IO () -> (IO () -> IO a) -> IO a
withForkWait (() -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> ()
forall a. NFData a => a -> ()
rnf Text
out) ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
waitOut ->
        IO () -> (IO () -> IO ()) -> IO ()
forall a. IO () -> (IO () -> IO a) -> IO a
withForkWait (() -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> ()
forall a. NFData a => a -> ()
rnf Text
err) ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
waitErr -> do
          IO ()
waitOut
          IO ()
waitErr
          Handle -> IO ()
hClose Handle
outh
          Handle -> IO ()
hClose Handle
errh
      ExitCode
exitCode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
      (ExitCode, Text, Text) -> IO (ExitCode, Text, Text)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
exitCode, Text
out, Text
err)
    (Maybe Handle
Nothing, Maybe Handle
_, Maybe Handle
_) -> [Char] -> IO (ExitCode, Text, Text)
forall a. HasCallStack => [Char] -> a
error [Char]
"readAndDecodeCreateProcess: Failed to get std_in handle"
    (Maybe Handle
_, Maybe Handle
Nothing, Maybe Handle
_) -> [Char] -> IO (ExitCode, Text, Text)
forall a. HasCallStack => [Char] -> a
error [Char]
"readAndDecodeCreateProcess: Failed to get std_out handle"
    (Maybe Handle
_, Maybe Handle
_, Maybe Handle
Nothing) -> [Char] -> IO (ExitCode, Text, Text)
forall a. HasCallStack => [Char] -> a
error [Char]
"readAndDecodeCreateProcess: Failed to get std_err handle"

-- * The code below is taken from System.Process which unfortunately does not export these functions

-- | From System.Process
withForkWait :: IO () -> (IO () ->  IO a) -> IO a
withForkWait :: forall a. IO () -> (IO () -> IO a) -> IO a
withForkWait IO ()
async IO () -> IO a
body = do
  MVar (Either SomeException ())
waitVar <- IO (MVar (Either SomeException ()))
forall a. IO (MVar a)
newEmptyMVar :: IO (MVar (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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar (Either SomeException ()) -> Either SomeException () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Either SomeException ())
waitVar
    let wait :: IO ()
wait = MVar (Either SomeException ()) -> IO (Either SomeException ())
forall a. MVar a -> IO a
takeMVar MVar (Either SomeException ())
waitVar IO (Either SomeException ())
-> (Either SomeException () -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> IO ())
-> (() -> IO ()) -> Either SomeException () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    IO a -> IO a
forall a. IO a -> IO a
restore (IO () -> IO a
body IO ()
wait) IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`onException` ThreadId -> IO ()
killThread ThreadId
tid

-- | From System.Process
ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
C.handle ((IOException -> IO ()) -> IO () -> IO ())
-> (IOException -> IO ()) -> IO () -> IO ()
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 Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
ePIPE -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  IOException
_ -> IOException -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOException
e