{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module System.Process.Run
(runIn
,callProcess
,callProcess'
,ProcessExitedUnsuccessfully)
where
import Control.Exception.Lifted
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger (MonadLogger, logError)
import Data.Conduit.Process hiding (callProcess)
import Data.Foldable (forM_)
import Data.Text (Text)
import qualified Data.Text as T
import Path (Path, Abs, Dir, toFilePath)
import Prelude
import System.Exit (exitWith, ExitCode (..))
import qualified System.Process
import System.Process.Read
runIn :: forall (m :: * -> *).
(MonadLogger m,MonadIO m,MonadBaseControl IO m)
=> Path Abs Dir
-> FilePath
-> EnvOverride
-> [String]
-> Maybe Text
-> m ()
runIn wd cmd menv args errMsg = do
result <- try (callProcess (Just wd) menv cmd args)
case result of
Left (ProcessExitedUnsuccessfully _ ec) -> do
$logError $
T.pack $
concat
[ "Exit code "
, show ec
, " while running "
, show (cmd : args)
, " in "
, toFilePath wd]
forM_ errMsg $logError
liftIO (exitWith ec)
Right () -> return ()
callProcess :: (MonadIO m, MonadLogger m)
=> Maybe (Path Abs Dir)
-> EnvOverride
-> String
-> [String]
-> m ()
callProcess =
callProcess' id
callProcess' :: (MonadIO m, MonadLogger m)
=> (CreateProcess -> CreateProcess)
-> Maybe (Path Abs Dir)
-> EnvOverride
-> String
-> [String]
-> m ()
callProcess' modCP wd menv cmd0 args = do
cmd <- preProcess wd menv cmd0
let c = modCP $ (proc cmd args) { delegate_ctlc = True
, cwd = fmap toFilePath wd
, env = envHelper menv }
action (_, _, _, p) = do
exit_code <- waitForProcess p
case exit_code of
ExitSuccess -> return ()
ExitFailure _ -> throwIO (ProcessExitedUnsuccessfully c exit_code)
$logProcessRun cmd args
liftIO (System.Process.createProcess c >>= action)