{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
module System.Command.QQ.Eval
( Eval(..)
) where
import Control.Concurrent
import Control.Exception (evaluate, mask, onException)
import Control.Monad
import Data.Foldable (traverse_)
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as Text
import qualified Data.Text.Lazy.IO as Text
import System.Exit (ExitCode)
import qualified System.Process as P
import System.IO (hFlush, hClose)
class Eval r where
eval :: String -> [String] -> r
instance Eval (IO ()) where
eval command = void . P.rawSystem command
instance Eval (IO ExitCode) where
eval command args = do
(s, _, _) <- eval command args Text.empty
return s
instance Eval (IO Text) where
eval command args = do
(_, o, _) <- eval command args
return o
instance Eval (IO String) where
eval command = fmap Text.unpack . eval command
instance
( s ~ ExitCode
, o ~ Text
, e ~ Text
) => Eval (IO (s, o, e)) where
eval command args = eval command args Text.empty
instance
( i ~ Text
, o ~ (ExitCode, Text, Text)
) => Eval (i -> IO o) where
eval = readProcessWithExitCode
readProcessWithExitCode :: String -> [String] -> Text -> IO (ExitCode, Text, Text)
readProcessWithExitCode cmd args input =
mask $ \restore -> do
(Just inh, Just outh, Just errh, pid) <-
P.createProcess (P.proc cmd args)
{ P.std_in = P.CreatePipe
, P.std_out = P.CreatePipe
, P.std_err = P.CreatePipe
}
onException
(restore $ do
var <- newEmptyMVar
out <- Text.hGetContents outh
err <- Text.hGetContents errh
forkFinally (evaluate (Text.length out)) (\_ -> putMVar var ())
forkFinally (evaluate (Text.length err)) (\_ -> putMVar var ())
unless (Text.null input) $
Text.hPutStr inh input >> hFlush inh
hClose inh
takeMVar var
takeMVar var
hClose outh
hClose errh
s <- P.waitForProcess pid
return (s, out, err))
(do P.terminateProcess pid
traverse_ hClose [inh, outh, errh]
P.waitForProcess pid)