{-# LANGUAGE BangPatterns #-}

{-# LANGUAGE DeriveDataTypeable #-}

{-# LANGUAGE KindSignatures #-}

{-# LANGUAGE RankNTypes #-}

{-# LANGUAGE TemplateHaskell #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE FlexibleContexts #-}

-- | Reading from external processes.

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 -- Fix AMP warning

import System.Exit (exitWith, ExitCode (..))

import qualified System.Process

import System.Process.Read

-- | Run the given command in the given directory, inheriting stdout

-- and stderr. If it exits with anything but success, prints an error

-- and then calls 'exitWith' to exit the program.

runIn :: forall (m :: * -> *).

(MonadLogger m,MonadIO m,MonadBaseControl IO m)

=> Path Abs Dir -- ^ directory to run in

-> FilePath -- ^ command to run

-> EnvOverride

-> [String] -- ^ command line arguments

-> 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 ()

-- | Like as @System.Process.callProcess@, but takes an optional working directory and

-- environment override, and throws ProcessExitedUnsuccessfully if the

-- process exits unsuccessfully. Inherits stdout and stderr.

callProcess :: (MonadIO m, MonadLogger m)

=> Maybe (Path Abs Dir)

-> EnvOverride

-> String

-> [String]

-> m ()

callProcess =

callProcess' id

-- | Like as @System.Process.callProcess@, but takes an optional working directory and

-- environment override, and throws ProcessExitedUnsuccessfully if the

-- process exits unsuccessfully. Inherits stdout and stderr.

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)