rio-0.0.3.0: src/RIO/Process.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Interacting with external processes.
--
-- This module provides a layer on top of "System.Process.Typed", with
-- the following additions:
--
-- * For efficiency, it will cache @PATH@ lookups.
--
-- * For convenience, you can set the working directory and env vars
-- overrides in a 'RIO' environment instead of on the individual
-- calls to the process.
--
-- * Built-in support for logging at the debug level.
--
-- In order to switch over to this API, the main idea is:
--
-- * Like most of the rio library, you need to create an environment
-- value (this time 'ProcessContext'), and include it in your 'RIO'
-- environment. See 'mkProcessContext'.
--
-- * Instead of using the 'proc' function for creating a
-- 'ProcessConfig', use the 'proc' function, which will handle
-- overriding environment variables, looking up paths, performing
-- logging, etc.
--
-- Once you have your 'ProcessConfig', use the standard functions from
-- 'System.Process.Typed' (reexported here for convenient) for running
-- the 'ProcessConfig'.
--
-- @since 0.0.3.0
module RIO.Process
( -- * Process context
ProcessContext
, HasProcessContext (..)
, EnvVars
, mkProcessContext
, mkDefaultProcessContext
, modifyEnvVars
, withModifyEnvVars
, withWorkingDir
-- ** Lenses
, workingDirL
, envVarsL
, envVarsStringsL
, exeSearchPathL
-- ** Actions
, resetExeCache
-- * Configuring
, proc
-- * Spawning (run child process)
, withProcess
, withProcess_
-- * Exec (replacing current process)
, exec
, execSpawn
-- * Environment helper
, LoggedProcessContext (..)
, withProcessContextNoLogging
-- * Exceptions
, ProcessException (..)
-- * Utilities
, doesExecutableExist
, findExecutable
, augmentPath
, augmentPathMap
, showProcessArgDebug
-- * Reexports
, P.ProcessConfig
, P.StreamSpec
, P.StreamType (..)
, P.Process
, P.setStdin
, P.setStdout
, P.setStderr
, P.setCloseFds
, P.setCreateGroup
, P.setDelegateCtlc
#if MIN_VERSION_process(1, 3, 0)
, P.setDetachConsole
, P.setCreateNewConsole
, P.setNewSession
#endif
#if MIN_VERSION_process(1, 4, 0) && !WINDOWS
, P.setChildGroup
, P.setChildUser
#endif
, P.mkStreamSpec
, P.inherit
, P.closed
, P.byteStringInput
, P.byteStringOutput
, P.createPipe
, P.useHandleOpen
, P.useHandleClose
, P.startProcess
, P.stopProcess
, P.readProcess
, P.readProcess_
, P.runProcess
, P.runProcess_
, P.readProcessStdout
, P.readProcessStdout_
, P.readProcessStderr
, P.readProcessStderr_
, P.waitExitCode
, P.waitExitCodeSTM
, P.getExitCode
, P.getExitCodeSTM
, P.checkExitCode
, P.checkExitCodeSTM
, P.getStdin
, P.getStdout
, P.getStderr
, P.ExitCodeException (..)
, P.ByteStringOutputException (..)
, P.unsafeProcessHandle
) where
import RIO
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified System.Directory as D
import System.Environment (getEnvironment)
import System.Exit (exitWith)
import qualified System.FilePath as FP
import qualified System.Process.Typed as P
import System.Process.Typed hiding (withProcess, withProcess_, proc)
#ifndef WINDOWS
import System.Directory (setCurrentDirectory)
import System.Posix.Process (executeFile)
#endif
-- | The environment variable map
--
-- @since 0.0.3.0
type EnvVars = Map Text Text
-- | Context in which to run processes.
--
-- @since 0.0.3.0
data ProcessContext = ProcessContext
{ pcTextMap :: !EnvVars
-- ^ Environment variables as map
, pcStringList :: ![(String, String)]
-- ^ Environment variables as association list
, pcPath :: ![FilePath]
-- ^ List of directories searched for executables (@PATH@)
, pcExeCache :: !(IORef (Map FilePath (Either ProcessException FilePath)))
-- ^ Cache of already looked up executable paths.
, pcExeExtensions :: [String]
-- ^ @[""]@ on non-Windows systems, @["", ".exe", ".bat"]@ on Windows
, pcWorkingDir :: !(Maybe FilePath)
-- ^ Override the working directory.
}
-- | Exception type which may be generated in this module.
--
-- /NOTE/ Other exceptions may be thrown by underlying libraries!
--
-- @since 0.0.3.0
data ProcessException
= NoPathFound
| ExecutableNotFound String [FilePath]
| ExecutableNotFoundAt FilePath
| PathsInvalidInPath [FilePath]
deriving Typeable
instance Show ProcessException where
show NoPathFound = "PATH not found in ProcessContext"
show (ExecutableNotFound name path) = concat
[ "Executable named "
, name
, " not found on path: "
, show path
]
show (ExecutableNotFoundAt name) =
"Did not find executable at specified path: " ++ name
show (PathsInvalidInPath paths) = unlines $
[ "Would need to add some paths to the PATH environment variable \
\to continue, but they would be invalid because they contain a "
++ show FP.searchPathSeparator ++ "."
, "Please fix the following paths and try again:"
] ++ paths
instance Exception ProcessException
-- | Get the 'ProcessContext' from the environment.
--
-- @since 0.0.3.0
class HasProcessContext env where
processContextL :: Lens' env ProcessContext
instance HasProcessContext ProcessContext where
processContextL = id
data EnvVarFormat = EVFWindows | EVFNotWindows
currentEnvVarFormat :: EnvVarFormat
currentEnvVarFormat =
#if WINDOWS
EVFWindows
#else
EVFNotWindows
#endif
-- | Override the working directory processes run in. @Nothing@ means
-- the current process's working directory.
--
-- @since 0.0.3.0
workingDirL :: HasProcessContext env => Lens' env (Maybe FilePath)
workingDirL = processContextL.lens pcWorkingDir (\x y -> x { pcWorkingDir = y })
-- | Get the environment variables. We cannot provide a @Lens@ here,
-- since updating the environment variables requires an @IO@ action to
-- allocate a new @IORef@ for holding the executable path cache.
--
-- @since 0.0.3.0
envVarsL :: HasProcessContext env => SimpleGetter env EnvVars
envVarsL = processContextL.to pcTextMap
-- | Get the 'EnvVars' as an associated list of 'String's.
--
-- Useful for interacting with other libraries.
--
-- @since 0.0.3.0
envVarsStringsL :: HasProcessContext env => SimpleGetter env [(String, String)]
envVarsStringsL = processContextL.to pcStringList
-- | Get the list of directories searched for executables (the @PATH@).
--
-- Similar to 'envVarMapL', this cannot be a full @Lens@.
--
-- @since 0.0.3.0
exeSearchPathL :: HasProcessContext env => SimpleGetter env [FilePath]
exeSearchPathL = processContextL.to pcPath
-- | Create a new 'ProcessContext' from the given environment variable map.
--
-- @since 0.0.3.0
mkProcessContext :: MonadIO m => EnvVars -> m ProcessContext
mkProcessContext tm' = do
ref <- newIORef Map.empty
return ProcessContext
{ pcTextMap = tm
, pcStringList = map (T.unpack *** T.unpack) $ Map.toList tm
, pcPath =
(if isWindows then (".":) else id)
(maybe [] (FP.splitSearchPath . T.unpack) (Map.lookup "PATH" tm))
, pcExeCache = ref
, pcExeExtensions =
if isWindows
then let pathext = fromMaybe
".COM;.EXE;.BAT;.CMD;.VBS;.VBE;.JS;.JSE;.WSF;.WSH;.MSC"
(Map.lookup "PATHEXT" tm)
in map T.unpack $ "" : T.splitOn ";" pathext
else [""]
, pcWorkingDir = Nothing
}
where
-- Fix case insensitivity of the PATH environment variable on Windows.
tm
| isWindows = Map.fromList $ map (first T.toUpper) $ Map.toList tm'
| otherwise = tm'
-- Don't use CPP so that the Windows code path is at least type checked
-- regularly
isWindows =
case currentEnvVarFormat of
EVFWindows -> True
EVFNotWindows -> False
-- | Reset the executable cache.
--
-- @since 0.0.3.0
resetExeCache :: (MonadIO m, MonadReader env m, HasProcessContext env) => m ()
resetExeCache = do
pc <- view processContextL
atomicModifyIORef (pcExeCache pc) (const mempty)
-- | Load up an 'EnvOverride' from the standard environment.
mkDefaultProcessContext :: MonadIO m => m ProcessContext
mkDefaultProcessContext =
liftIO $
getEnvironment >>=
mkProcessContext
. Map.fromList . map (T.pack *** T.pack)
-- | Modify the environment variables of a 'ProcessContext'.
--
-- This will keep other settings unchanged, in particular the working
-- directory.
--
-- Note that this requires 'MonadIO', as it will create a new 'IORef'
-- for the cache.
--
-- @since 0.0.3.0
modifyEnvVars
:: MonadIO m
=> ProcessContext
-> (EnvVars -> EnvVars)
-> m ProcessContext
modifyEnvVars pc f = do
pc' <- mkProcessContext (f $ pcTextMap pc)
return pc' { pcWorkingDir = pcWorkingDir pc }
-- | Use 'modifyEnvVarMap' to create a new 'ProcessContext', and then
-- use it in the provided action.
--
-- @since 0.0.3.0
withModifyEnvVars
:: (HasProcessContext env, MonadReader env m, MonadIO m)
=> (EnvVars -> EnvVars)
-> m a
-> m a
withModifyEnvVars f inner = do
pc <- view processContextL
pc' <- modifyEnvVars pc f
local (set processContextL pc') inner
-- | Set the working directory to be used by child processes.
--
-- @since 0.0.3.0
withWorkingDir
:: (HasProcessContext env, MonadReader env m, MonadIO m)
=> FilePath
-> m a
-> m a
withWorkingDir = local . set workingDirL . Just
-- | Perform pre-call-process tasks. Ensure the working directory exists and find the
-- executable path.
--
-- Throws a 'ProcessException' if unsuccessful.
--
-- NOT CURRENTLY EXPORTED
preProcess
:: (HasProcessContext env, MonadReader env m, MonadIO m)
=> String -- ^ Command name
-> m FilePath
preProcess name = do
name' <- findExecutable name >>= either throwIO return
wd <- view workingDirL
liftIO $ maybe (return ()) (D.createDirectoryIfMissing True) wd
return name'
-- | Log running a process with its arguments, for debugging (-v).
--
-- This logs one message before running the process and one message after.
--
-- NOT CURRENTLY EXPORTED
withProcessTimeLog
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> Maybe FilePath -- ^ working dirj
-> String -- ^ executable
-> [String] -- ^ arguments
-> m a
-> m a
withProcessTimeLog mdir name args proc' = do
let cmdText =
T.intercalate
" "
(T.pack name : map showProcessArgDebug args)
dirMsg =
case mdir of
Nothing -> ""
Just dir -> " within " <> T.pack dir
logDebug ("Run process" <> display dirMsg <> ": " <> display cmdText)
start <- getMonotonicTime
x <- proc'
end <- getMonotonicTime
let diff = end - start
-- useAnsi <- asks getAnsiTerminal FIXME
let useAnsi = True
logDebug
("Process finished in " <>
(if useAnsi then "\ESC[92m" else "") <> -- green
timeSpecMilliSecondText diff <>
(if useAnsi then "\ESC[0m" else "") <> -- reset
": " <> display cmdText)
return x
timeSpecMilliSecondText :: Double -> DisplayBuilder
timeSpecMilliSecondText d = display (round (d * 1000) :: Int) <> "ms"
-- | Provide a 'ProcessConfig' based on the 'ProcessContext' in
-- scope. Deals with resolving the full path, setting the child
-- process's environment variables, setting the working directory, and
-- wrapping the call with 'withProcessTimeLog' for debugging output.
--
-- This is intended to be analogous to the @proc@ function provided by
-- the @System.Process.Typed@ module, but has a different type
-- signature to (1) allow it to perform @IO@ actions for looking up
-- paths, and (2) allow logging and timing of the running action.
--
-- @since 0.0.3.0
proc
:: (HasProcessContext env, HasLogFunc env, MonadReader env m, MonadIO m, HasCallStack)
=> FilePath -- ^ command to run
-> [String] -- ^ command line arguments
-> (ProcessConfig () () () -> m a)
-> m a
proc name0 args inner = do
name <- preProcess name0
wd <- view workingDirL
envStrings <- view envVarsStringsL
withProcessTimeLog wd name args
$ inner
$ setEnv envStrings
$ maybe id setWorkingDir wd
$ P.proc name args
-- | Same as 'P.withProcess', but generalized to 'MonadUnliftIO'.
--
-- @since 0.0.3.0
withProcess
:: MonadUnliftIO m
=> ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a)
-> m a
withProcess pc f = withRunInIO $ \run -> P.withProcess pc (run . f)
-- | Same as 'P.withProcess_', but generalized to 'MonadUnliftIO'.
--
-- @since 0.0.3.0
withProcess_
:: MonadUnliftIO m
=> ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a)
-> m a
withProcess_ pc f = withRunInIO $ \run -> P.withProcess_ pc (run . f)
-- | A convenience environment combining a 'LogFunc' and a 'ProcessContext'
--
-- @since 0.0.3.0
data LoggedProcessContext = LoggedProcessContext ProcessContext LogFunc
instance HasLogFunc LoggedProcessContext where
logFuncL = lens (\(LoggedProcessContext _ lf) -> lf) (\(LoggedProcessContext pc _) lf -> LoggedProcessContext pc lf)
instance HasProcessContext LoggedProcessContext where
processContextL = lens (\(LoggedProcessContext x _) -> x) (\(LoggedProcessContext _ lf) pc -> LoggedProcessContext pc lf)
-- | Run an action using a 'LoggedProcessContext' with default
-- settings and no logging.
--
-- @since 0.0.3.0
withProcessContextNoLogging :: MonadIO m => RIO LoggedProcessContext a -> m a
withProcessContextNoLogging inner = do
pc <- mkDefaultProcessContext
runRIO (LoggedProcessContext pc mempty) inner
-- | Execute a process within the configured environment.
--
-- Execution will not return, because either:
--
-- 1) On non-windows, execution is taken over by execv of the
-- sub-process. This allows signals to be propagated (#527)
--
-- 2) On windows, an 'ExitCode' exception will be thrown.
--
-- @since 0.0.3.0
exec :: (HasProcessContext env, HasLogFunc env) => String -> [String] -> RIO env b
#ifdef WINDOWS
exec = execSpawn
#else
exec cmd0 args = do
wd <- view workingDirL
envStringsL <- view envVarsStringsL
cmd <- preProcess cmd0
withProcessTimeLog wd cmd args $ liftIO $ do
for_ wd setCurrentDirectory
executeFile cmd True args $ Just envStringsL
#endif
-- | Like 'exec', but does not use 'execv' on non-windows. This way,
-- there is a sub-process, which is helpful in some cases
-- (<https://github.com/commercialhaskell/stack/issues/1306>).
--
-- This function only exits by throwing 'ExitCode'.
--
-- @since 0.0.3.0
execSpawn :: (HasProcessContext env, HasLogFunc env) => String -> [String] -> RIO env a
execSpawn cmd args = proc cmd args (runProcess . setStdin inherit) >>= liftIO . exitWith
-- | Check if the given executable exists on the given PATH.
--
-- @since 0.0.3.0
doesExecutableExist
:: (MonadIO m, MonadReader env m, HasProcessContext env)
=> String -- ^ Name of executable
-> m Bool
doesExecutableExist = liftM isRight . findExecutable
-- | Find the complete path for the executable.
--
-- @since 0.0.3.0
findExecutable
:: (MonadIO m, MonadReader env m, HasProcessContext env)
=> String -- ^ Name of executable
-> m (Either ProcessException FilePath) -- ^ Full path to that executable on success
findExecutable name0 | any FP.isPathSeparator name0 = do
pc <- view processContextL
let names0 = map (name0 ++) (pcExeExtensions pc)
testNames [] = return $ Left $ ExecutableNotFoundAt name0
testNames (name:names) = do
exists <- liftIO $ D.doesFileExist name
if exists
then do
path <- liftIO $ D.canonicalizePath name
return $ return path
else testNames names
testNames names0
findExecutable name = do
pc <- view processContextL
m <- readIORef $ pcExeCache pc
epath <- case Map.lookup name m of
Just epath -> return epath
Nothing -> do
let loop [] = return $ Left $ ExecutableNotFound name (pcPath pc)
loop (dir:dirs) = do
let fp0 = dir FP.</> name
fps0 = map (fp0 ++) (pcExeExtensions pc)
testFPs [] = loop dirs
testFPs (fp:fps) = do
exists <- D.doesFileExist fp
existsExec <- if exists then liftM D.executable $ D.getPermissions fp else return False
if existsExec
then do
fp' <- D.makeAbsolute fp
return $ return fp'
else testFPs fps
testFPs fps0
epath <- liftIO $ loop $ pcPath pc
() <- atomicModifyIORef (pcExeCache pc) $ \m' ->
(Map.insert name epath m', ())
return epath
return epath
-- | Augment the PATH environment variable with the given extra paths.
--
-- @since 0.0.3.0
augmentPath :: [FilePath] -> Maybe Text -> Either ProcessException Text
augmentPath dirs mpath =
case filter (FP.searchPathSeparator `elem`) dirs of
[] -> Right
$ T.intercalate (T.singleton FP.searchPathSeparator)
$ map (T.pack . FP.dropTrailingPathSeparator) dirs
++ maybeToList mpath
illegal -> Left $ PathsInvalidInPath illegal
-- | Apply 'augmentPath' on the PATH value in the given 'EnvVars'.
--
-- @since 0.0.3.0
augmentPathMap :: [FilePath] -> EnvVars -> Either ProcessException EnvVars
augmentPathMap dirs origEnv =
do path <- augmentPath dirs mpath
return $ Map.insert "PATH" path origEnv
where
mpath = Map.lookup "PATH" origEnv
-- | Show a process arg including speechmarks when necessary. Just for
-- debugging purposes, not functionally important.
--
-- @since 0.0.3.0
showProcessArgDebug :: String -> Text
showProcessArgDebug x
| any special x || null x = T.pack (show x)
| otherwise = T.pack x
where special '"' = True
special ' ' = True
special _ = False