cabal-install/src/Distribution/Client/CmdExec.hs

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