1------------------------------------------------------------------------------- 2-- | 3-- Module : Distribution.Client.Exec 4-- Maintainer : cabal-devel@haskell.org 5-- Portability : portable 6-- 7-- Implementation of the 'v2-exec' command for running an arbitrary executable 8-- in an environment suited to the part of the store built for a project. 9------------------------------------------------------------------------------- 10 11{-# LANGUAGE RecordWildCards #-} 12module Distribution.Client.CmdExec 13 ( execAction 14 , execCommand 15 ) where 16 17import Distribution.Client.DistDirLayout 18 ( DistDirLayout(..) 19 ) 20import Distribution.Client.InstallPlan 21 ( GenericPlanPackage(..) 22 , toGraph 23 ) 24import Distribution.Client.Setup 25 ( ConfigExFlags 26 , ConfigFlags(configVerbosity) 27 , GlobalFlags 28 , InstallFlags 29 ) 30import qualified Distribution.Client.Setup as Client 31import Distribution.Client.ProjectOrchestration 32 ( ProjectBuildContext(..) 33 , runProjectPreBuildPhase 34 , CurrentCommand(..) 35 , establishProjectBaseContext 36 , distDirLayout 37 , commandLineFlagsToProjectConfig 38 , ProjectBaseContext(..) 39 ) 40import Distribution.Client.ProjectPlanOutput 41 ( updatePostBuildProjectStatus 42 , createPackageEnvironment 43 , argsEquivalentOfGhcEnvironmentFile 44 , PostBuildProjectStatus 45 ) 46import qualified Distribution.Client.ProjectPlanning as Planning 47import Distribution.Client.ProjectPlanning 48 ( ElaboratedInstallPlan 49 , ElaboratedSharedConfig(..) 50 ) 51import Distribution.Simple.Command 52 ( CommandUI(..) 53 ) 54import Distribution.Simple.Program.Db 55 ( modifyProgramSearchPath 56 , requireProgram 57 , configuredPrograms 58 ) 59import Distribution.Simple.Program.Find 60 ( ProgramSearchPathEntry(..) 61 ) 62import Distribution.Simple.Program.Run 63 ( programInvocation 64 , runProgramInvocation 65 ) 66import Distribution.Simple.Program.Types 67 ( programOverrideEnv 68 , programDefaultArgs 69 , programPath 70 , simpleProgram 71 , ConfiguredProgram 72 ) 73import Distribution.Simple.GHC 74 ( getImplInfo 75 , GhcImplInfo(supportsPkgEnvFiles) ) 76import Distribution.Simple.Setup 77 ( HaddockFlags 78 , TestFlags 79 , BenchmarkFlags 80 , fromFlagOrDefault 81 ) 82import Distribution.Simple.Utils 83 ( die' 84 , info 85 , createDirectoryIfMissingVerbose 86 , withTempDirectory 87 , wrapText 88 ) 89import Distribution.Verbosity 90 ( Verbosity 91 , normal 92 ) 93 94import Prelude () 95import Distribution.Client.Compat.Prelude 96 97import qualified Data.Set as S 98import qualified Data.Map as M 99 100execCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags 101 , HaddockFlags, TestFlags, BenchmarkFlags 102 ) 103execCommand = CommandUI 104 { commandName = "v2-exec" 105 , commandSynopsis = "Give a command access to the store." 106 , commandUsage = \pname -> 107 "Usage: " ++ pname ++ " v2-exec [FLAGS] [--] COMMAND [--] [ARGS]\n" 108 , commandDescription = Just $ \pname -> wrapText $ 109 "During development it is often useful to run build tasks and perform" 110 ++ " one-off program executions to experiment with the behavior of build" 111 ++ " tools. It is convenient to run these tools in the same way " ++ pname 112 ++ " itself would. The `" ++ pname ++ " v2-exec` command provides a way to" 113 ++ " do so.\n" 114 ++ "\n" 115 ++ "Compiler tools will be configured to see the same subset of the store" 116 ++ " that builds would see. The PATH is modified to make all executables in" 117 ++ " the dependency tree available (provided they have been built already)." 118 ++ " Commands are also rewritten in the way cabal itself would. For" 119 ++ " example, `" ++ pname ++ " v2-exec ghc` will consult the configuration" 120 ++ " to choose an appropriate version of ghc and to include any" 121 ++ " ghc-specific flags requested." 122 , commandNotes = Nothing 123 , commandOptions = commandOptions Client.installCommand 124 , commandDefaultFlags = commandDefaultFlags Client.installCommand 125 } 126 127execAction :: ( ConfigFlags, ConfigExFlags, InstallFlags 128 , HaddockFlags, TestFlags, BenchmarkFlags ) 129 -> [String] -> GlobalFlags -> IO () 130execAction ( configFlags, configExFlags, installFlags 131 , haddockFlags, testFlags, benchmarkFlags ) 132 extraArgs globalFlags = do 133 134 baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand 135 136 -- To set up the environment, we'd like to select the libraries in our 137 -- dependency tree that we've already built. So first we set up an install 138 -- plan, but we walk the dependency tree without first executing the plan. 139 buildCtx <- runProjectPreBuildPhase 140 verbosity 141 baseCtx 142 (\plan -> return (plan, M.empty)) 143 144 -- We use the build status below to decide what libraries to include in the 145 -- compiler environment, but we don't want to actually build anything. So we 146 -- pass mempty to indicate that nothing happened and we just want the current 147 -- status. 148 buildStatus <- updatePostBuildProjectStatus 149 verbosity 150 (distDirLayout baseCtx) 151 (elaboratedPlanOriginal buildCtx) 152 (pkgsBuildStatus buildCtx) 153 mempty 154 155 -- Some dependencies may have executables. Let's put those on the PATH. 156 extraPaths <- pathAdditions verbosity baseCtx buildCtx 157 let programDb = modifyProgramSearchPath 158 (map ProgramSearchPathDir extraPaths ++) 159 . pkgConfigCompilerProgs 160 . elaboratedShared 161 $ buildCtx 162 163 -- Now that we have the packages, set up the environment. We accomplish this 164 -- by creating an environment file that selects the databases and packages we 165 -- computed in the previous step, and setting an environment variable to 166 -- point at the file. 167 -- In case ghc is too old to support environment files, 168 -- we pass the same info as arguments 169 let compiler = pkgConfigCompiler $ elaboratedShared buildCtx 170 envFilesSupported = supportsPkgEnvFiles (getImplInfo compiler) 171 case extraArgs of 172 [] -> die' verbosity "Please specify an executable to run" 173 exe:args -> do 174 (program, _) <- requireProgram verbosity (simpleProgram exe) programDb 175 let argOverrides = 176 argsEquivalentOfGhcEnvironmentFile 177 compiler 178 (distDirLayout baseCtx) 179 (elaboratedPlanOriginal buildCtx) 180 buildStatus 181 programIsConfiguredCompiler = matchCompilerPath 182 (elaboratedShared buildCtx) 183 program 184 argOverrides' = 185 if envFilesSupported 186 || not programIsConfiguredCompiler 187 then [] 188 else argOverrides 189 190 (if envFilesSupported 191 then withTempEnvFile verbosity baseCtx buildCtx buildStatus 192 else \f -> f []) $ \envOverrides -> do 193 let program' = withOverrides 194 envOverrides 195 argOverrides' 196 program 197 invocation = programInvocation program' args 198 runProgramInvocation verbosity invocation 199 where 200 verbosity = fromFlagOrDefault normal (configVerbosity configFlags) 201 cliConfig = commandLineFlagsToProjectConfig 202 globalFlags configFlags configExFlags 203 installFlags 204 mempty -- ClientInstallFlags, not needed here 205 haddockFlags testFlags benchmarkFlags 206 withOverrides env args program = program 207 { programOverrideEnv = programOverrideEnv program ++ env 208 , programDefaultArgs = programDefaultArgs program ++ args} 209 210matchCompilerPath :: ElaboratedSharedConfig -> ConfiguredProgram -> Bool 211matchCompilerPath elaboratedShared program = 212 programPath program 213 `elem` 214 (programPath <$> configuredCompilers) 215 where 216 configuredCompilers = configuredPrograms $ pkgConfigCompilerProgs elaboratedShared 217 218-- | Execute an action with a temporary .ghc.environment file reflecting the 219-- current environment. The action takes an environment containing the env 220-- variable which points ghc to the file. 221withTempEnvFile :: Verbosity 222 -> ProjectBaseContext 223 -> ProjectBuildContext 224 -> PostBuildProjectStatus 225 -> ([(String, Maybe String)] -> IO a) 226 -> IO a 227withTempEnvFile verbosity baseCtx buildCtx buildStatus action = do 228 createDirectoryIfMissingVerbose verbosity True (distTempDirectory (distDirLayout baseCtx)) 229 withTempDirectory 230 verbosity 231 (distTempDirectory (distDirLayout baseCtx)) 232 "environment." 233 (\tmpDir -> do 234 envOverrides <- createPackageEnvironment 235 verbosity 236 tmpDir 237 (elaboratedPlanToExecute buildCtx) 238 (elaboratedShared buildCtx) 239 buildStatus 240 action envOverrides) 241 242pathAdditions :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO [FilePath] 243pathAdditions verbosity ProjectBaseContext{..}ProjectBuildContext{..} = do 244 info verbosity . unlines $ "Including the following directories in PATH:" 245 : paths 246 return paths 247 where 248 paths = S.toList 249 $ binDirectories distDirLayout elaboratedShared elaboratedPlanToExecute 250 251binDirectories 252 :: DistDirLayout 253 -> ElaboratedSharedConfig 254 -> ElaboratedInstallPlan 255 -> Set FilePath 256binDirectories layout config = fromElaboratedInstallPlan where 257 fromElaboratedInstallPlan = fromGraph . toGraph 258 fromGraph = foldMap fromPlan 259 fromSrcPkg = S.fromList . Planning.binDirectories layout config 260 261 fromPlan (PreExisting _) = mempty 262 fromPlan (Configured pkg) = fromSrcPkg pkg 263 fromPlan (Installed pkg) = fromSrcPkg pkg 264 265