{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
module RIO.Process
(
ProcessContext
, HasProcessContext (..)
, EnvVars
, mkProcessContext
, mkDefaultProcessContext
, modifyEnvVars
, withModifyEnvVars
, lookupEnvFromContext
, withWorkingDir
, workingDirL
, envVarsL
, envVarsStringsL
, exeSearchPathL
, resetExeCache
, proc
, withProcess
, withProcess_
, withProcessWait
, withProcessWait_
, withProcessTerm
, withProcessTerm_
, exec
, execSpawn
, LoggedProcessContext (..)
, withProcessContextNoLogging
, ProcessException (..)
, doesExecutableExist
, findExecutable
, exeExtensions
, augmentPath
, augmentPathMap
, showProcessArgDebug
, 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.Prelude.Display
import RIO.Prelude.Reexports
import RIO.Prelude.Logger
import RIO.Prelude.RIO
import RIO.Prelude.Lens
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_,
withProcessWait, withProcessWait_,
withProcessTerm, withProcessTerm_,
proc)
#ifndef WINDOWS
import System.Directory (setCurrentDirectory)
import System.Posix.Process (executeFile)
#endif
type EnvVars = Map Text Text
data ProcessContext = ProcessContext
{ pcTextMap :: !EnvVars
, pcStringList :: ![(String, String)]
, pcPath :: ![FilePath]
, pcExeCache :: !(IORef (Map FilePath (Either ProcessException FilePath)))
, pcExeExtensions :: [String]
, pcWorkingDir :: !(Maybe FilePath)
}
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
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
isWindows :: Bool
isWindows = case currentEnvVarFormat of
EVFWindows -> True
EVFNotWindows -> False
workingDirL :: HasProcessContext env => Lens' env (Maybe FilePath)
workingDirL = processContextL.lens pcWorkingDir (\x y -> x { pcWorkingDir = y })
envVarsL :: HasProcessContext env => SimpleGetter env EnvVars
envVarsL = processContextL.to pcTextMap
envVarsStringsL :: HasProcessContext env => SimpleGetter env [(String, String)]
envVarsStringsL = processContextL.to pcStringList
exeSearchPathL :: HasProcessContext env => SimpleGetter env [FilePath]
exeSearchPathL = processContextL.to pcPath
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 defaultPATHEXT
(Map.lookup "PATHEXT" tm)
in map T.unpack $ T.splitOn ";" pathext
else [""]
, pcWorkingDir = Nothing
}
where
tm
| isWindows = Map.fromList $ map (first T.toUpper) $ Map.toList tm'
| otherwise = tm'
defaultPATHEXT = ".COM;.EXE;.BAT;.CMD;.VBS;.VBE;.JS;.JSE;.WSF;.WSH;.MSC"
resetExeCache :: (MonadIO m, MonadReader env m, HasProcessContext env) => m ()
resetExeCache = do
pc <- view processContextL
atomicModifyIORef (pcExeCache pc) (const mempty)
mkDefaultProcessContext :: MonadIO m => m ProcessContext
mkDefaultProcessContext =
liftIO $
getEnvironment >>=
mkProcessContext
. Map.fromList . map (T.pack *** T.pack)
modifyEnvVars
:: MonadIO m
=> ProcessContext
-> (EnvVars -> EnvVars)
-> m ProcessContext
modifyEnvVars pc f = do
pc' <- mkProcessContext (f $ pcTextMap pc)
return pc' { pcWorkingDir = pcWorkingDir pc }
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
lookupEnvFromContext :: (MonadReader env m, HasProcessContext env) => Text -> m (Maybe Text)
lookupEnvFromContext envName = Map.lookup envName <$> view envVarsL
withWorkingDir
:: (HasProcessContext env, MonadReader env m, MonadIO m)
=> FilePath
-> m a
-> m a
withWorkingDir = local . set workingDirL . Just
preProcess
:: (HasProcessContext env, MonadReader env m, MonadIO m)
=> String
-> m FilePath
preProcess name = do
name' <- findExecutable name >>= either throwIO return
wd <- view workingDirL
liftIO $ maybe (return ()) (D.createDirectoryIfMissing True) wd
return name'
withProcessTimeLog
:: (MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack)
=> Maybe FilePath
-> String
-> [String]
-> 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
useColor <- view logFuncUseColorL
logDebug
("Process finished in " <>
(if useColor then "\ESC[92m" else "") <>
timeSpecMilliSecondText diff <>
(if useColor then "\ESC[0m" else "") <>
": " <> display cmdText)
return x
timeSpecMilliSecondText :: Double -> Utf8Builder
timeSpecMilliSecondText d = display (round (d * 1000) :: Int) <> "ms"
proc
:: (HasProcessContext env, HasLogFunc env, MonadReader env m, MonadIO m, HasCallStack)
=> FilePath
-> [String]
-> (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
withProcess
:: MonadUnliftIO m
=> ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a)
-> m a
withProcess pc f = withRunInIO $ \run -> P.withProcessTerm pc (run . f)
{-# DEPRECATED withProcess "Please consider using withProcessWait, or instead use withProcessTerm" #-}
withProcess_
:: MonadUnliftIO m
=> ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a)
-> m a
withProcess_ pc f = withRunInIO $ \run -> P.withProcessTerm_ pc (run . f)
{-# DEPRECATED withProcess_ "Please consider using withProcessWait, or instead use withProcessTerm" #-}
withProcessWait
:: MonadUnliftIO m
=> ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a)
-> m a
withProcessWait pc f = withRunInIO $ \run -> P.withProcessWait pc (run . f)
withProcessWait_
:: MonadUnliftIO m
=> ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a)
-> m a
withProcessWait_ pc f = withRunInIO $ \run -> P.withProcessWait_ pc (run . f)
withProcessTerm
:: MonadUnliftIO m
=> ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a)
-> m a
withProcessTerm pc f = withRunInIO $ \run -> P.withProcessTerm pc (run . f)
withProcessTerm_
:: MonadUnliftIO m
=> ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a)
-> m a
withProcessTerm_ pc f = withRunInIO $ \run -> P.withProcessTerm_ pc (run . f)
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)
withProcessContextNoLogging :: MonadIO m => RIO LoggedProcessContext a -> m a
withProcessContextNoLogging inner = do
pc <- mkDefaultProcessContext
runRIO (LoggedProcessContext pc mempty) inner
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
execSpawn :: (HasProcessContext env, HasLogFunc env) => String -> [String] -> RIO env a
execSpawn cmd args = proc cmd args (runProcess . setStdin inherit) >>= liftIO . exitWith
doesExecutableExist
:: (MonadIO m, MonadReader env m, HasProcessContext env)
=> String
-> m Bool
doesExecutableExist = liftM isRight . findExecutable
findExecutable
:: (MonadIO m, MonadReader env m, HasProcessContext env)
=> String
-> m (Either ProcessException FilePath)
findExecutable name | any FP.isPathSeparator name = do
names <- addPcExeExtensions name
testFPs (pure $ Left $ ExecutableNotFoundAt name) D.canonicalizePath names
findExecutable name = do
pc <- view processContextL
m <- readIORef $ pcExeCache pc
case Map.lookup name m of
Just epath -> pure epath
Nothing -> do
let loop [] = pure $ Left $ ExecutableNotFound name (pcPath pc)
loop (dir:dirs) = do
fps <- addPcExeExtensions $ dir FP.</> name
testFPs (loop dirs) D.makeAbsolute fps
epath <- loop $ pcPath pc
() <- atomicModifyIORef (pcExeCache pc) $ \m' ->
(Map.insert name epath m', ())
pure epath
addPcExeExtensions
:: (MonadIO m, MonadReader env m, HasProcessContext env)
=> FilePath -> m [FilePath]
addPcExeExtensions fp = do
pc <- view processContextL
pure $ (if isWindows && FP.hasExtension fp then (fp:) else id)
(map (fp ++) (pcExeExtensions pc))
testFPs
:: (MonadIO m, MonadReader env m, HasProcessContext env)
=> m (Either ProcessException FilePath)
-> (FilePath -> IO FilePath)
-> [FilePath]
-> m (Either ProcessException FilePath)
testFPs ifNone _ [] = ifNone
testFPs ifNone modify (fp:fps) = do
exists <- liftIO $ D.doesFileExist fp
existsExec <- liftIO $ if exists
then if isWindows then pure True else isExecutable
else pure False
if existsExec then liftIO $ Right <$> modify fp else testFPs ifNone modify fps
where
isExecutable = D.executable <$> D.getPermissions fp
exeExtensions :: (MonadIO m, MonadReader env m, HasProcessContext env)
=> m [String]
exeExtensions = do
pc <- view processContextL
return $ pcExeExtensions pc
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
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
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