hsenv-0.3: src/Process.hs

module Process ( outsideProcess
               , outsideProcess'
               , insideProcess
               , ghcPkgDbPathLocation
               ) where

import           MyMonad
import           Paths
import           Types

import           Util.IO            (Environment, readProcessWithExitCodeInEnv, which)

import           Data.Maybe         (fromMaybe)
import           System.Environment (getEnvironment)
import           System.Exit        (ExitCode(..))
import           System.FilePath    ((</>))
import           System.Process     (readProcessWithExitCode)

runProcess :: Maybe Environment -> FilePath -> [String] -> Maybe String -> MyMonad String
runProcess env prog args input = do
  case input of
    Nothing  -> return ()
    Just inp -> do
      trace "Using the following input:"
      indentMessages $ mapM_ trace $ lines inp

  let execProcess = case env of
         Nothing   -> readProcessWithExitCode prog args (fromMaybe "" input)
         Just env' -> readProcessWithExitCodeInEnv env' prog args input

  (exitCode, output, errors) <- liftIO execProcess

  debug $ case exitCode of
    ExitSuccess         -> "Process exited successfully"
    ExitFailure errCode -> "Process failed with exit code " ++ show errCode

  case output of
    "" -> trace "Empty process output"
    _  -> do
      trace "Process output:"
      indentMessages $ mapM_ trace $ lines output

  case errors of
    "" -> trace "Empty process error output"
    _  -> do
      trace "Process error output:"
      indentMessages $ mapM_ trace $ lines errors

  case exitCode of
    ExitSuccess         -> return output
    ExitFailure errCode -> throwError $ MyException $ prog ++ " process failed with status " ++ show errCode

-- run regular process, takes:
-- * program name, looks for it in $PATH,
-- * list of arguments
-- * maybe standard input
-- returns standard output
outsideProcess :: String -> [String] -> Maybe String -> MyMonad String
outsideProcess progName args input = do
  debug $ unwords $ ["Running outside process:", progName] ++ args
  indentMessages $ do
    trace $ unwords ["Looking for", progName, "in $PATH"]
    program <- liftIO $ which Nothing progName
    case program of
      Nothing -> throwError $ MyException $ unwords ["No", progName, "in $PATH"]
      Just programPath -> do
        trace $ unwords [progName, "->", programPath]
        runProcess Nothing programPath args input

outsideProcess' :: String -> [String] -> MyMonad String
outsideProcess' progName args = outsideProcess progName args Nothing

-- returns path to GHC (installed from tarball) builtin package database
externalGhcPkgDb :: MyMonad FilePath
externalGhcPkgDb = do
  trace "Checking where GHC (installed from tarball) keeps its package database"
  indentMessages $ do
    dirStructure <- hseDirStructure
    let ghcPkg = ghcDir dirStructure </> "bin" </> "ghc-pkg"
    trace $ unwords ["Running process:", ghcPkg, "list"]
    ghcPkgOutput <- indentMessages $ runProcess Nothing ghcPkg ["list"] Nothing
    debug "Trying to parse ghc-pkg's output"
    case lines ghcPkgOutput of
      []             -> throwError $ MyException "ghc-pkg returned empty output"
      lineWithPath:_ ->
          case lineWithPath of
            "" -> throwError $ MyException "ghc-pkg's first line of output is empty"
            _  -> do
              -- ghc-pkg ends pkg db path with trailing colon
              -- but only when not run from the terminal
              let path = init lineWithPath
              debug $ "Found: " ++ path
              return path

-- returns value of GHC_PACKAGE_PATH that should be used inside virtual environment
-- defined in this module, because insideProcess needs it
ghcPkgDbPathLocation :: MyMonad String
ghcPkgDbPathLocation = do
  trace "Determining value of GHC_PACKAGE_PATH to be used inside virtual environment"
  dirStructure <- hseDirStructure
  ghc <- asks ghcSource
  case ghc of
    System    -> return $ ghcPackagePath dirStructure
    Tarball _ -> do
             externalGhcPkgDbPath <- indentMessages externalGhcPkgDb
             return $ ghcPackagePath dirStructure ++ ":" ++ externalGhcPkgDbPath

virtualEnvironment :: MyMonad Environment
virtualEnvironment = do
  debug "Calculating unix env dictionary used inside virtual environment"
  indentMessages $ do
    env <- liftIO getEnvironment
    ghcPkgDb <- ghcPkgDbPathLocation
    debug $ "$GHC_PACKAGE_PATH=" ++ ghcPkgDb
    pathVar <- insidePathVar
    debug $ "$PATH=" ++ pathVar
    let varToBeOverridden var = var `elem` ["GHC_PACKAGE_PATH", "PATH"]
        strippedEnv = filter (not . varToBeOverridden . fst) env
    return $ [("GHC_PACKAGE_PATH", ghcPkgDb), ("PATH", pathVar)] ++ strippedEnv

-- run process from inside the virtual environment, takes:
-- * program name, looks for it in (in order):
--    - cabal bin dir (e.g. .hsenv*/cabal/bin)
--    - ghc bin dir (e.g. .hsenv*/ghc/bin), only when using ghc from tarball
--    - $PATH
-- * list of arguments
-- * maybe standard input
-- returns standard output
-- process is run in altered environment (new $GHC_PACKAGE_PATH env var,
-- adjusted $PATH var)
insideProcess :: String -> [String] -> Maybe String -> MyMonad String
insideProcess progName args input = do
  debug $ unwords $ ["Running inside process:", progName] ++ args
  indentMessages $ do
    pathVar <- insidePathVar
    trace $ unwords ["Looking for", progName, "in", pathVar]
    program <- liftIO $ which (Just pathVar) progName
    case program of
      Nothing -> throwError $ MyException $ unwords ["No", progName, "in", pathVar]
      Just programPath -> do
        trace $ unwords [progName, "->", programPath]
        env <- virtualEnvironment
        runProcess (Just env) programPath args input