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