Internal.hs

module Coquina.Internal where

import Control.Concurrent (MVar, newEmptyMVar, forkIO, putMVar, takeMVar, killThread)
import Control.DeepSeq (rnf)
import Control.Exception (SomeException, evaluate, mask, try, throwIO, onException)
import Data.ByteString (hGetContents)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8)
import System.Process
import System.Exit
import System.IO (hClose)

-- | The code below is taken from System.Process which unfortunately does not export this function
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

-- | Like readCreateProcess, but ignores stdin and decodes bytes, assuming utf-8
readAndDecodeCreateProcess :: CreateProcess -> IO (ExitCode, Text, Text)
readAndDecodeCreateProcess cp =
  withCreateProcess (cp { std_out = CreatePipe, std_err = CreatePipe }) $ \_ mouth merrh ph -> case (mouth, merrh) of
    (Just outh, Just errh) -> do
      out <- fmap decodeUtf8 $ hGetContents outh
      err <- fmap decodeUtf8 $ hGetContents errh
      withForkWait (evaluate $ rnf out) $ \waitOut ->
        withForkWait (evaluate $ rnf err) $ \waitErr -> do
          waitOut
          waitErr
          hClose outh
          hClose errh
      exitCode <- waitForProcess ph
      return (exitCode, out, err)
    (Nothing, _) -> error "readAndDecodeCreateProcess: Failed to get std_out handle"
    (Just _, Nothing) -> error "readAndDecodeCreateProcess: Failed to get std_err handle"