module BDCS.Utils.Process(callProcessLogged)
where
import qualified Control.Exception.Lifted as CEL
import Control.Monad(unless)
import Control.Monad.IO.Class(liftIO)
import Control.Monad.Logger(MonadLoggerIO, logInfoN, logErrorN)
import Control.Monad.Trans.Control(MonadBaseControl)
import Data.String.Conversions(cs)
import qualified Data.Text as T
import GHC.IO.Exception(IOErrorType(..))
import System.IO.Error(mkIOError)
import System.Process.Typed(ExitCodeException(..), proc, readProcess_)
callProcessLogged :: (MonadBaseControl IO m, MonadLoggerIO m) => String -> [String] -> m ()
callProcessLogged cmd args =
doit `CEL.catches` [CEL.Handler (\(e :: ExitCodeException) -> handleProcessFailed e),
CEL.Handler (\(e :: CEL.SomeException) -> handleOtherErrors e)]
where
handleProcessFailed :: (MonadBaseControl IO m, MonadLoggerIO m) => ExitCodeException -> m ()
handleProcessFailed ExitCodeException{..} = do
logErrorN $ cs eceStderr
liftIO $ ioError (mkIOError OtherError (cmd ++ unwords args ++ " (" ++ show eceExitCode ++ ")")
Nothing Nothing)
handleOtherErrors :: (MonadBaseControl IO m, MonadLoggerIO m, CEL.Exception e) => e -> m ()
handleOtherErrors e = do
logErrorN $ cs $ show e
liftIO $ ioError (mkIOError OtherError (cmd ++ unwords args ++ " (" ++ show e ++ ")")
Nothing Nothing)
doit :: (MonadBaseControl IO m, MonadLoggerIO m) => m ()
doit = do
logInfoN $ T.intercalate " " $ T.pack cmd : map T.pack args
(stdout, _) <- liftIO $ readProcess_ (proc cmd args)
unless (T.null $ T.strip $ cs stdout) $
logInfoN $ cs stdout