hackport-0.5.5: cabal/cabal-install/Distribution/Client/Exec.hs
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Exec
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- Implementation of the 'exec' command. Runs an arbitrary executable in an
-- environment suitable for making use of the sandbox.
-----------------------------------------------------------------------------
module Distribution.Client.Exec ( exec
) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.GHCJS as GHCJS
import Distribution.Client.Sandbox (getSandboxConfigFilePath)
import Distribution.Client.Sandbox.PackageEnvironment (sandboxPackageDBPath)
import Distribution.Client.Sandbox.Types (UseSandbox (..))
import Distribution.Simple.Compiler (Compiler, CompilerFlavor(..), compilerFlavor)
import Distribution.Simple.Program (ghcProgram, ghcjsProgram, lookupProgram)
import Distribution.Simple.Program.Db (ProgramDb, requireProgram, modifyProgramSearchPath)
import Distribution.Simple.Program.Find (ProgramSearchPathEntry(..))
import Distribution.Simple.Program.Run (programInvocation, runProgramInvocation)
import Distribution.Simple.Program.Types ( simpleProgram, ConfiguredProgram(..) )
import Distribution.Simple.Utils (die', warn)
import Distribution.System (Platform(..), OS(..), buildOS)
import Distribution.Verbosity (Verbosity)
import System.Directory ( doesDirectoryExist )
import System.Environment (lookupEnv)
import System.FilePath (searchPathSeparator, (</>))
-- | Execute the given command in the package's environment.
--
-- The given command is executed with GHC configured to use the correct
-- package database and with the sandbox bin directory added to the PATH.
exec :: Verbosity
-> UseSandbox
-> Compiler
-> Platform
-> ProgramDb
-> [String]
-> IO ()
exec verbosity useSandbox comp platform programDb extraArgs =
case extraArgs of
(exe:args) -> do
program <- requireProgram' verbosity useSandbox programDb exe
env <- environmentOverrides (programOverrideEnv program)
let invocation = programInvocation
program { programOverrideEnv = env }
args
runProgramInvocation verbosity invocation
[] -> die' verbosity "Please specify an executable to run"
where
environmentOverrides env =
case useSandbox of
NoSandbox -> return env
(UseSandbox sandboxDir) ->
sandboxEnvironment verbosity sandboxDir comp platform programDb env
-- | Return the package's sandbox environment.
--
-- The environment sets GHC_PACKAGE_PATH so that GHC will use the sandbox.
sandboxEnvironment :: Verbosity
-> FilePath
-> Compiler
-> Platform
-> ProgramDb
-> [(String, Maybe String)] -- environment overrides so far
-> IO [(String, Maybe String)]
sandboxEnvironment verbosity sandboxDir comp platform programDb iEnv =
case compilerFlavor comp of
GHC -> env GHC.getGlobalPackageDB ghcProgram "GHC_PACKAGE_PATH"
GHCJS -> env GHCJS.getGlobalPackageDB ghcjsProgram "GHCJS_PACKAGE_PATH"
_ -> die' verbosity "exec only works with GHC and GHCJS"
where
(Platform _ os) = platform
ldPath = case os of
OSX -> "DYLD_LIBRARY_PATH"
Windows -> "PATH"
_ -> "LD_LIBRARY_PATH"
env getGlobalPackageDB hcProgram packagePathEnvVar = do
let Just program = lookupProgram hcProgram programDb
gDb <- getGlobalPackageDB verbosity program
sandboxConfigFilePath <- getSandboxConfigFilePath mempty
let sandboxPackagePath = sandboxPackageDBPath sandboxDir comp platform
compilerPackagePaths = prependToSearchPath gDb sandboxPackagePath
-- Packages database must exist, otherwise things will start
-- failing in mysterious ways.
exists <- doesDirectoryExist sandboxPackagePath
unless exists $ warn verbosity $ "Package database is not a directory: "
++ sandboxPackagePath
-- MASSIVE HACK. We need this to be synchronized with installLibDir
-- in defaultInstallDirs' in Distribution.Simple.InstallDirs,
-- which has a special case for Windows (WHY? Who knows; it's been
-- around as long as Windows exists.) The sane thing to do here
-- would be to read out the actual install dirs that were associated
-- with the package in question, but that's not a well-formed question
-- here because there is not actually install directory for the
-- "entire" sandbox. Since we want to kill this code in favor of
-- new-build, I decided it wasn't worth fixing this "properly."
-- Also, this doesn't handle LHC correctly but I don't care -- ezyang
let extraLibPath =
case buildOS of
Windows -> sandboxDir
_ -> sandboxDir </> "lib"
-- 2016-11-26 Apologies for the spaghetti code here.
-- Essentially we just want to add the sandbox's lib/ dir to
-- whatever the library search path environment variable is:
-- this allows running existing executables against foreign
-- libraries (meaning Haskell code with a bunch of foreign
-- exports). However, on Windows this variable is equal to the
-- executable search path env var. And we try to keep not only
-- what was already set in the environment, but also the
-- additional directories we add below in requireProgram'. So
-- the strategy is that we first take the environment
-- overrides from requireProgram' below. If the library search
-- path env is overridden (e.g. because we're on windows), we
-- prepend the lib/ dir to the relevant override. If not, we
-- want to avoid wiping the user's own settings, so we first
-- read the env var's current value, and then prefix ours if
-- the user had any set.
iEnv' <-
if any ((==ldPath) . fst) iEnv
then return $ updateLdPath extraLibPath iEnv
else do
currentLibraryPath <- lookupEnv ldPath
let updatedLdPath =
case currentLibraryPath of
Nothing -> Just extraLibPath
Just paths ->
Just $ extraLibPath ++ [searchPathSeparator] ++ paths
return $ (ldPath, updatedLdPath) : iEnv
-- Build the environment
return $ [ (packagePathEnvVar, Just compilerPackagePaths)
, ("CABAL_SANDBOX_PACKAGE_PATH", Just compilerPackagePaths)
, ("CABAL_SANDBOX_CONFIG", Just sandboxConfigFilePath)
] ++ iEnv'
prependToSearchPath path newValue =
newValue ++ [searchPathSeparator] ++ path
updateLdPath path = map update
where
update (name, Just current)
| name == ldPath = (ldPath, Just $ path ++ [searchPathSeparator] ++ current)
update (name, Nothing)
| name == ldPath = (ldPath, Just path)
update x = x
-- | Check that a program is configured and available to be run. If
-- a sandbox is available check in the sandbox's directory.
requireProgram' :: Verbosity
-> UseSandbox
-> ProgramDb
-> String
-> IO ConfiguredProgram
requireProgram' verbosity useSandbox programDb exe = do
(program, _) <- requireProgram
verbosity
(simpleProgram exe)
updateSearchPath
return program
where
updateSearchPath =
flip modifyProgramSearchPath programDb $ \searchPath ->
case useSandbox of
NoSandbox -> searchPath
UseSandbox sandboxDir ->
ProgramSearchPathDir (sandboxDir </> "bin") : searchPath