module RIO.Process
(withProcess
,withProcess_
,EnvOverride(..)
,unEnvOverride
,mkEnvOverride
,modifyEnvOverride
,envHelper
,doesExecutableExist
,findExecutable
,getEnvOverride
,envSearchPath
,preProcess
,readProcessNull
,ReadProcessException (..)
,augmentPath
,augmentPathMap
,resetExeCache
,HasEnvOverride (..)
,workingDirL
,withProc
,withEnvOverride
,withModifyEnvOverride
,withWorkingDir
,runEnvNoLogging
,withProcessTimeLog
,showProcessArgDebug
,exec
,execSpawn
,execObserve
,module System.Process.Typed
)
where
import RIO.Prelude
import RIO.Logger
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Text.Encoding.Error (lenientDecode)
import Lens.Micro (set, to)
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_)
#ifndef WINDOWS
import System.Directory (setCurrentDirectory)
import System.Posix.Process (executeFile)
#endif
class HasLogFunc env => HasEnvOverride env where
envOverrideL :: Lens' env EnvOverride
data EnvVarFormat = EVFWindows | EVFNotWindows
currentEnvVarFormat :: EnvVarFormat
currentEnvVarFormat =
#if WINDOWS
EVFWindows
#else
EVFNotWindows
#endif
data EnvOverride = EnvOverride
{ eoTextMap :: Map Text Text
, eoStringList :: [(String, String)]
, eoPath :: [FilePath]
, eoExeCache :: IORef (Map FilePath (Either ReadProcessException FilePath))
, eoExeExtensions :: [String]
, eoWorkingDir :: !(Maybe FilePath)
}
workingDirL :: HasEnvOverride env => Lens' env (Maybe FilePath)
workingDirL = envOverrideL.lens eoWorkingDir (\x y -> x { eoWorkingDir = y })
unEnvOverride :: EnvOverride -> Map Text Text
unEnvOverride = eoTextMap
envSearchPath :: EnvOverride -> [FilePath]
envSearchPath = eoPath
modifyEnvOverride :: MonadIO m
=> EnvOverride
-> (Map Text Text -> Map Text Text)
-> m EnvOverride
modifyEnvOverride eo f = mkEnvOverride (f $ eoTextMap eo)
mkEnvOverride :: MonadIO m
=> Map Text Text
-> m EnvOverride
mkEnvOverride tm' = do
ref <- liftIO $ newIORef Map.empty
return EnvOverride
{ eoTextMap = tm
, eoStringList = map (T.unpack *** T.unpack) $ Map.toList tm
, eoPath =
(if isWindows then (".":) else id)
(maybe [] (FP.splitSearchPath . T.unpack) (Map.lookup "PATH" tm))
, eoExeCache = ref
, eoExeExtensions =
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 [""]
, eoWorkingDir = Nothing
}
where
tm
| isWindows = Map.fromList $ map (first T.toUpper) $ Map.toList tm'
| otherwise = tm'
isWindows =
case currentEnvVarFormat of
EVFWindows -> True
EVFNotWindows -> False
envHelper :: EnvOverride -> [(String, String)]
envHelper = eoStringList
readProcessNull :: HasEnvOverride env
=> String
-> [String]
-> RIO env ()
readProcessNull name args =
void $ withProc name args readProcessStdout_
data ReadProcessException
= NoPathFound
| ExecutableNotFound String [FilePath]
| ExecutableNotFoundAt FilePath
deriving Typeable
instance Show ReadProcessException where
show NoPathFound = "PATH not found in EnvOverride"
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
instance Exception ReadProcessException
withProc
:: HasEnvOverride env
=> FilePath
-> [String]
-> (ProcessConfig () () () -> RIO env a)
-> RIO env a
withProc name0 args inner = do
menv <- view envOverrideL
name <- preProcess name0
withProcessTimeLog (eoWorkingDir menv) name args
$ inner
$ setEnv (envHelper menv)
$ maybe id setWorkingDir (eoWorkingDir menv)
$ proc name args
withModifyEnvOverride :: HasEnvOverride env => (Map Text Text -> Map Text Text) -> RIO env a -> RIO env a
withModifyEnvOverride f inner = do
menv <- view envOverrideL
menv' <- modifyEnvOverride menv f
withEnvOverride menv' inner
withEnvOverride :: HasEnvOverride env => EnvOverride -> RIO env a -> RIO env a
withEnvOverride newEnv = local $ \r ->
let newEnv' = newEnv { eoWorkingDir = eoWorkingDir $ view envOverrideL r }
in set envOverrideL newEnv' r
withWorkingDir :: HasEnvOverride env => FilePath -> RIO env a -> RIO env a
withWorkingDir = local . set workingDirL . Just
preProcess
:: HasEnvOverride env
=> String
-> RIO env FilePath
preProcess name = do
menv <- view envOverrideL
let wd = eoWorkingDir menv
name' <- liftIO $ join $ findExecutable menv name
liftIO $ maybe (return ()) (D.createDirectoryIfMissing True) wd
return name'
doesExecutableExist :: (MonadIO m)
=> EnvOverride
-> String
-> m Bool
doesExecutableExist menv name = liftM isJust $ findExecutable menv name
findExecutable :: (MonadIO m, MonadThrow n)
=> EnvOverride
-> String
-> m (n FilePath)
findExecutable eo name0 | any FP.isPathSeparator name0 = do
let names0 = map (name0 ++) (eoExeExtensions eo)
testNames [] = return $ throwM $ 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 eo name = liftIO $ do
m <- readIORef $ eoExeCache eo
epath <- case Map.lookup name m of
Just epath -> return epath
Nothing -> do
let loop [] = return $ Left $ ExecutableNotFound name (eoPath eo)
loop (dir:dirs) = do
let fp0 = dir FP.</> name
fps0 = map (fp0 ++) (eoExeExtensions eo)
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 <- loop $ eoPath eo
() <- atomicModifyIORef (eoExeCache eo) $ \m' ->
(Map.insert name epath m', ())
return epath
return $ either throwM return epath
resetExeCache :: MonadIO m => EnvOverride -> m ()
resetExeCache eo = liftIO (atomicModifyIORef (eoExeCache eo) (const mempty))
getEnvOverride :: MonadIO m => m EnvOverride
getEnvOverride =
liftIO $
getEnvironment >>=
mkEnvOverride
. Map.fromList . map (T.pack *** T.pack)
newtype InvalidPathException = PathsInvalidInPath [FilePath]
deriving Typeable
instance Exception InvalidPathException
instance Show InvalidPathException where
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
augmentPath :: MonadThrow m => [FilePath] -> Maybe Text -> m Text
augmentPath dirs mpath =
do let illegal = filter (FP.searchPathSeparator `elem`) dirs
unless (null illegal) (throwM $ PathsInvalidInPath illegal)
return $ T.intercalate (T.singleton FP.searchPathSeparator)
$ map (T.pack . FP.dropTrailingPathSeparator) dirs
++ maybeToList mpath
augmentPathMap :: MonadThrow m => [FilePath] -> Map Text Text -> m (Map Text Text)
augmentPathMap dirs origEnv =
do path <- augmentPath dirs mpath
return $ Map.insert "PATH" path origEnv
where
mpath = Map.lookup "PATH" origEnv
runEnvNoLogging :: RIO EnvNoLogging a -> IO a
runEnvNoLogging inner = do
menv <- getEnvOverride
runRIO (EnvNoLogging menv) inner
newtype EnvNoLogging = EnvNoLogging EnvOverride
instance HasLogFunc EnvNoLogging where
logFuncL = to (\_ _ _ _ _ -> return ())
instance HasEnvOverride EnvNoLogging where
envOverrideL = lens (\(EnvNoLogging x) -> x) (const EnvNoLogging)
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
let useAnsi = True
logDebug
("Process finished in " <>
(if useAnsi then "\ESC[92m" else "") <>
timeSpecMilliSecondText diff <>
(if useAnsi then "\ESC[0m" else "") <>
": " <> display cmdText)
return x
timeSpecMilliSecondText :: Double -> DisplayBuilder
timeSpecMilliSecondText d = display (round (d * 1000) :: Int) <> "ms"
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
exec :: HasEnvOverride env => String -> [String] -> RIO env b
#ifdef WINDOWS
exec = execSpawn
#else
exec cmd0 args = do
menv <- view envOverrideL
cmd <- preProcess cmd0
withProcessTimeLog Nothing cmd args $ liftIO $ do
for_ (eoWorkingDir menv) setCurrentDirectory
executeFile cmd True args $ Just $ envHelper menv
#endif
execSpawn :: HasEnvOverride env => String -> [String] -> RIO env a
execSpawn cmd args = withProc cmd args (runProcess . setStdin inherit) >>= liftIO . exitWith
execObserve :: HasEnvOverride env => String -> [String] -> RIO env String
execObserve cmd0 args =
withProc cmd0 args $ \pc -> do
(out, _err) <- readProcess_ pc
return
$ TL.unpack
$ TL.filter (/= '\r')
$ TL.concat
$ take 1
$ TL.lines
$ TLE.decodeUtf8With lenientDecode out
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)
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)