{-# 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 'System.Process.Typed.proc' function from -- "System.Process.Typed" for creating a 'ProcessConfig', use the -- locally defined '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.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_, 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 useColor <- view logFuncUseColorL logDebug ("Process finished in " <> (if useColor then "\ESC[92m" else "") <> -- green timeSpecMilliSecondText diff <> (if useColor then "\ESC[0m" else "") <> -- reset ": " <> display cmdText) return x timeSpecMilliSecondText :: Double -> Utf8Builder 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 -- (). -- -- 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