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 '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
  , lookupEnvFromContext
  , withWorkingDir
    -- ** Lenses
  , workingDirL
  , envVarsL
  , envVarsStringsL
  , exeSearchPathL
    -- ** Actions
  , resetExeCache
    -- * Configuring
  , proc
    -- * Spawning (run child process)
  , withProcess
  , withProcess_
  , withProcessWait
  , withProcessWait_
  , withProcessTerm
  , withProcessTerm_
    -- * Exec (replacing current process)
  , exec
  , execSpawn
    -- * Environment helper
  , LoggedProcessContext (..)
  , withProcessContextNoLogging
    -- * Exceptions
  , ProcessException (..)
    -- * Utilities
  , doesExecutableExist
  , findExecutable
  , exeExtensions
  , 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_,
                     withProcessWait, withProcessWait_,
                     withProcessTerm, withProcessTerm_,
                     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

-- Don't use CPP so that the Windows code path is at least type checked
-- regularly
isWindows :: Bool
isWindows = case currentEnvVarFormat of
              EVFWindows -> True
              EVFNotWindows -> False

-- | 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 defaultPATHEXT
                                             (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'
    -- Default value for PATHTEXT on Windows versions after Windows XP. (The
    -- documentation of the default at
    -- https://docs.microsoft.com/en-us/windows-server/administration/windows-commands/start
    -- is incomplete.)
    defaultPATHEXT = ".COM;.EXE;.BAT;.CMD;.VBS;.VBE;.JS;.JSE;.WSF;.WSH;.MSC"


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

-- | Same as 'mkProcessContext' but uses the system environment (from
-- 'System.Environment.getEnvironment').
--
-- @since 0.0.3.0
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 not
-- change 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 'modifyEnvVars' 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

-- | Look into the `ProcessContext` and return the specified environmet variable if one is
-- available.
--
-- @since 0.1.14.0
lookupEnvFromContext :: (MonadReader env m, HasProcessContext env) => Text -> m (Maybe Text)
lookupEnvFromContext envName = Map.lookup envName <$> view envVarsL

-- | 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.withProcessTerm pc (run . f)
{-# DEPRECATED withProcess "Please consider using withProcessWait, or instead use withProcessTerm" #-}

-- | 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.withProcessTerm_ pc (run . f)
{-# DEPRECATED withProcess_ "Please consider using withProcessWait, or instead use withProcessTerm" #-}

-- | Same as 'P.withProcessWait', but generalized to 'MonadUnliftIO'.
--
-- @since 0.1.10.0
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)

-- | Same as 'P.withProcessWait_', but generalized to 'MonadUnliftIO'.
--
-- @since 0.1.10.0
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)

-- | Same as 'P.withProcessTerm', but generalized to 'MonadUnliftIO'.
--
-- @since 0.1.10.0
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)

-- | Same as 'P.withProcessTerm_', but generalized to 'MonadUnliftIO'.
--
-- @since 0.1.10.0
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)

-- | 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 given executable name.
--
-- On POSIX systems, filenames that match but are not exectuables are excluded.
--
-- On Windows systems, the executable names tried, in turn, are the supplied
-- name (only if it has an extension) and that name extended by each of the
-- 'exeExtensions'. Also, this function may behave differently from
-- 'RIO.Directory.findExecutable'. The latter excludes as executables filenames
-- without a @.bat@, @.cmd@, @.com@ or @.exe@ extension (case-insensitive).
--
-- @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 name | any FP.isPathSeparator name = do
  names <- addPcExeExtensions name
  testFPs (pure $ Left $ ExecutableNotFoundAt name) D.makeAbsolute 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

-- | A helper function to add the executable extensions of the process context
-- to a file path. On Windows, the original file path is included, if it has an
-- existing extension.
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))

-- | A helper function to test whether file paths are to an executable
testFPs
  :: (MonadIO m, MonadReader env m, HasProcessContext env)
  => m (Either ProcessException FilePath)
  -- ^ Default if no executable exists at any file path
  -> (FilePath -> IO FilePath)
  -- ^ Modification to apply to a file path, if an executable exists there
  -> [FilePath]
  -- ^ File paths to test, in turn
  -> 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

-- | Get the filename extensions for executable files, including the dot (if
-- any).
--
-- On POSIX systems, this is @[""]@.
--
-- On Windows systems, the list is determined by the value of the @PATHEXT@
-- environment variable, if it present in the environment. If the variable is
-- absent, this is its default value on a Windows system. This function may,
-- therefore, behave differently from 'RIO.Directory.exeExtension',
-- which returns only @".exe"@.
--
-- @since 0.1.13.0
exeExtensions :: (MonadIO m, MonadReader env m, HasProcessContext env)
              => m [String]
exeExtensions = do
  pc <- view processContextL
  return $ pcExeExtensions pc

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