CmdInstall.hs 38.2 KB
Newer Older
1 2 3
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RecordWildCards     #-}
4
{-# LANGUAGE ScopedTypeVariables #-}
5
{-# LANGUAGE ViewPatterns        #-}
6 7 8 9 10 11 12 13 14 15

-- | cabal-install CLI command: build
--
module Distribution.Client.CmdInstall (
    -- * The @build@ CLI and action
    installCommand,
    installAction,

    -- * Internals exposed for testing
    selectPackageTargets,
16
    selectComponentTarget,
17 18
    -- * Internals exposed for CmdRepl + CmdRun
    establishDummyDistDirLayout,
19
    establishDummyProjectBaseContext
20 21
  ) where

22
import Prelude ()
23
import Distribution.Client.Compat.Prelude
24 25
import Distribution.Compat.Directory
         ( doesPathExist )
26 27 28

import Distribution.Client.ProjectOrchestration
import Distribution.Client.CmdErrorMessages
Alexis Williams's avatar
Alexis Williams committed
29
import Distribution.Client.CmdSdist
30 31
import Distribution.Client.TargetProblem
         ( TargetProblem', TargetProblem (..) )
32

33
import Distribution.Client.CmdInstall.ClientInstallFlags
34
import Distribution.Client.CmdInstall.ClientInstallTargetSelector
35

36
import Distribution.Client.Setup
37
         ( GlobalFlags(..), ConfigFlags(..) )
38
import Distribution.Client.Types
39 40
         ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage
         , SourcePackageDb(..) )
41 42
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Package
43
         ( Package(..), PackageName, mkPackageName, unPackageName )
44 45
import Distribution.Types.PackageId
         ( PackageIdentifier(..) )
46 47 48 49
import Distribution.Client.ProjectConfig
         ( ProjectPackageLocation(..)
         , fetchAndReadSourcePackages
         )
Oleg Grenrus's avatar
Oleg Grenrus committed
50
import Distribution.Client.NixStyleOptions
51
         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
52
import Distribution.Client.ProjectFlags (ProjectFlags (..))
53
import Distribution.Client.ProjectConfig.Types
Alexis Williams's avatar
Alexis Williams committed
54 55 56 57
         ( ProjectConfig(..), ProjectConfigShared(..)
         , ProjectConfigBuildOnly(..), PackageConfig(..)
         , getMapLast, getMapMappend, projectConfigLogsDir
         , projectConfigStoreDir, projectConfigBuildOnly
58
         , projectConfigConfigFile )
59 60
import Distribution.Simple.Program.Db
         ( userSpecifyPaths, userSpecifyArgss, defaultProgramDb
61
         , modifyProgramSearchPath, ProgramDb )
62 63
import Distribution.Simple.BuildPaths
         ( exeExtension )
64
import Distribution.Simple.Program.Find
Alexis Williams's avatar
Alexis Williams committed
65
         ( ProgramSearchPathEntry(..) )
66
import Distribution.Client.Config
67
         ( defaultInstallPath, getCabalDir, loadConfig, SavedConfig(..) )
68 69
import qualified Distribution.Simple.PackageIndex as PI
import Distribution.Solver.Types.PackageIndex
70
         ( lookupPackageName, searchByName )
71
import Distribution.Types.InstalledPackageInfo
Alexis Williams's avatar
Alexis Williams committed
72
         ( InstalledPackageInfo(..) )
73
import Distribution.Types.Version
74
         ( Version, nullVersion )
Alexis Williams's avatar
Alexis Williams committed
75 76 77 78
import Distribution.Types.VersionRange
         ( thisVersion )
import Distribution.Solver.Types.PackageConstraint
         ( PackageProperty(..) )
79
import Distribution.Client.IndexUtils
80
         ( getSourcePackages, getInstalledPackages )
81
import Distribution.Client.ProjectConfig
82
         ( projectConfigWithBuilderRepoContext
83
         , resolveBuildTimeSettings, withProjectOrGlobalConfig )
84 85
import Distribution.Client.ProjectPlanning
         ( storePackageInstallDirs' )
86 87
import Distribution.Client.ProjectPlanning.Types
         ( ElaboratedInstallPlan )
88
import qualified Distribution.Simple.InstallDirs as InstallDirs
89
import Distribution.Client.DistDirLayout
90
         ( DistDirLayout(..), mkCabalDirLayout
91
         , cabalStoreDirLayout
92
         , CabalDirLayout(..), StoreDirLayout(..) )
93 94 95
import Distribution.Client.RebuildMonad
         ( runRebuild )
import Distribution.Client.InstallSymlink
96 97 98
         ( symlinkBinary, trySymlink )
import Distribution.Client.Types.OverwritePolicy
         ( OverwritePolicy (..) )
99 100
import Distribution.Simple.Flag
         ( fromFlagOrDefault, flagToMaybe, flagElim )
101
import Distribution.Simple.Setup
102
         ( Flag(..) )
Alexis Williams's avatar
Alexis Williams committed
103 104
import Distribution.Solver.Types.SourcePackage
         ( SourcePackage(..) )
105
import Distribution.Simple.Command
Oleg Grenrus's avatar
Oleg Grenrus committed
106
         ( CommandUI(..), usageAlternatives )
107 108
import Distribution.Simple.Configure
         ( configCompilerEx )
109
import Distribution.Simple.Compiler
110 111
         ( Compiler(..), CompilerId(..), CompilerFlavor(..)
         , PackageDBStack )
112
import Distribution.Simple.GHC
113
         ( ghcPlatformAndVersionString, getGhcAppDir
114
         , GhcImplInfo(..), getImplInfo
Alexis Williams's avatar
Alexis Williams committed
115
         , GhcEnvironmentFileEntry(..)
116
         , renderGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc )
117
import Distribution.System
118
         ( Platform , buildOS, OS (Windows) )
119 120 121
import Distribution.Types.UnitId
         ( UnitId )
import Distribution.Types.UnqualComponentName
fendor's avatar
fendor committed
122
         ( UnqualComponentName, unUnqualComponentName )
123
import Distribution.Verbosity
124
         ( normal, lessVerbose )
125
import Distribution.Simple.Utils
126
         ( wrapText, die', notice, warn
127 128
         , withTempDirectory, createDirectoryIfMissingVerbose
         , ordNub )
129
import Distribution.Utils.Generic
130
         ( safeHead, writeFileAtomic )
131

132
import qualified Data.ByteString.Lazy.Char8 as BS
133
import Data.Ord
134
         ( Down(..) )
135
import qualified Data.Map as Map
136 137
import Distribution.Utils.NubList
         ( fromNubList )
138
import Network.URI (URI)
139
import System.Directory
140
         ( doesFileExist, createDirectoryIfMissing
141 142
         , getTemporaryDirectory, makeAbsolute, doesDirectoryExist
         , removeFile, removeDirectory, copyFile )
143
import System.FilePath
144
         ( (</>), (<.>), takeDirectory, takeBaseName )
Alexis Williams's avatar
Alexis Williams committed
145

Oleg Grenrus's avatar
Oleg Grenrus committed
146
installCommand :: CommandUI (NixStyleFlags ClientInstallFlags)
147
installCommand = CommandUI
148
  { commandName         = "v2-install"
149
  , commandSynopsis     = "Install packages."
150
  , commandUsage        = usageAlternatives
151
                          "v2-install" [ "[TARGETS] [FLAGS]" ]
152
  , commandDescription  = Just $ \_ -> wrapText $
153
    "Installs one or more packages. This is done by installing them "
154 155
    ++ "in the store and symlinking/copying the executables in the directory "
    ++ "specified by the --installdir flag (`~/.cabal/bin/` by default). "
156 157 158 159 160 161
    ++ "If you want the installed executables to be available globally, "
    ++ "make sure that the PATH environment variable contains that directory. "
    ++ "\n\n"
    ++ "If TARGET is a library, it will be added to the global environment. "
    ++ "When doing this, cabal will try to build a plan that includes all "
    ++ "the previously installed libraries. This is currently not implemented."
162
  , commandNotes        = Just $ \pname ->
163
      "Examples:\n"
164
      ++ "  " ++ pname ++ " v2-install\n"
165
      ++ "    Install the package in the current directory\n"
166
      ++ "  " ++ pname ++ " v2-install pkgname\n"
167 168
      ++ "    Install the package named pkgname"
      ++ " (fetching it from hackage if necessary)\n"
169
      ++ "  " ++ pname ++ " v2-install ./pkgfoo\n"
170 171 172
      ++ "    Install the package in the ./pkgfoo directory\n"

      ++ cmdCommonHelpTextNewBuildBeta
Oleg Grenrus's avatar
Oleg Grenrus committed
173 174
  , commandOptions      = nixStyleOptions clientInstallOptions
  , commandDefaultFlags = defaultNixStyleFlags defaultClientInstallFlags
175 176 177
  }

-- | The @install@ command actually serves four different needs. It installs:
Alexis Williams's avatar
Alexis Williams committed
178
-- * exes:
179 180 181 182
--   For example a program from hackage. The behavior is similar to the old
--   install command, except that now conflicts between separate runs of the
--   command are impossible thanks to the store.
--   Exes are installed in the store like a normal dependency, then they are
183
--   symlinked/copied in the directory specified by --installdir.
184 185
--   To do this we need a dummy projectBaseContext containing the targets as
--   estra packages and using a temporary dist directory.
Alexis Williams's avatar
Alexis Williams committed
186 187
-- * libraries
--   Libraries install through a similar process, but using GHC environment
188
--   files instead of symlinks. This means that 'v2-install'ing libraries
Alexis Williams's avatar
Alexis Williams committed
189
--   only works on GHC >= 8.0.
190 191 192 193
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
--
194
installAction :: NixStyleFlags ClientInstallFlags -> [String] -> GlobalFlags -> IO ()
195
installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targetStrings globalFlags = do
196 197
  -- Ensure there were no invalid configuration options specified.
  verifyPreconditionsOrDie verbosity configFlags'
198

199 200 201
  -- We cannot use establishDummyProjectBaseContext to get these flags, since
  -- it requires one of them as an argument. Normal establishProjectBaseContext
  -- does not, and this is why this is done only for the install command
202
  clientInstallFlags <- getClientInstallFlags verbosity globalFlags clientInstallFlags'
203

204
  let
205 206
    installLibs    = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags)
    targetFilter   = if installLibs then Just LibKind else Just ExeKind
207
    targetStrings' = if null targetStrings then ["."] else targetStrings
208

209
    withProject :: IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig)
210
    withProject = do
211
      let reducedVerbosity = lessVerbose verbosity
212 213

      -- First, we need to learn about what's available to be installed.
214 215
      localBaseCtx <-
        establishProjectBaseContext reducedVerbosity cliConfig InstallCommand
216
      let localDistDirLayout = distDirLayout localBaseCtx
217
      pkgDb <- projectConfigWithBuilderRepoContext reducedVerbosity
218
               (buildSettings localBaseCtx) (getSourcePackages verbosity)
219 220

      let
221 222 223
        (targetStrings'', packageIds) =
          partitionEithers .
          flip fmap targetStrings' $
Oleg Grenrus's avatar
Oleg Grenrus committed
224
          \str -> case simpleParsec str of
225
            Just (pkgId :: PackageId)
226
              | pkgVersion pkgId /= nullVersion -> Right pkgId
227
            _                                   -> Left str
228 229
        packageSpecifiers =
          flip fmap packageIds $ \case
Alexis Williams's avatar
Alexis Williams committed
230 231
          PackageIdentifier{..}
            | pkgVersion == nullVersion -> NamedPackage pkgName []
232 233 234
            | otherwise                 -> NamedPackage pkgName
                                           [PackagePropertyVersion
                                            (thisVersion pkgVersion)]
235 236
        packageTargets =
          flip TargetPackageNamed targetFilter . pkgName <$> packageIds
237

238
      if null targetStrings'
239
        then return (packageSpecifiers, [], packageTargets, projectConfig localBaseCtx)
240
        else do
241 242 243 244
          targetSelectors <-
            either (reportTargetSelectorProblems verbosity) return
            =<< readTargetSelectors (localPackages localBaseCtx)
                                    Nothing targetStrings''
245

246
          (specs, selectors) <-
247 248
            getSpecsAndTargetSelectors
              verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter
249

250
          return ( specs ++ packageSpecifiers
251
                 , []
252 253
                 , selectors ++ packageTargets
                 , projectConfig localBaseCtx )
254

255
    withoutProject :: ProjectConfig -> IO ([PackageSpecifier pkg], [URI], [TargetSelector], ProjectConfig)
256
    withoutProject globalConfig = do
257
      tss <- traverse (parseWithoutProjectTargetSelector verbosity) targetStrings'
258

259
      cabalDir <- getCabalDir
260
      let
261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279
        projectConfig = globalConfig <> cliConfig

        ProjectConfigBuildOnly {
          projectConfigLogsDir
        } = projectConfigBuildOnly projectConfig

        ProjectConfigShared {
          projectConfigStoreDir
        } = projectConfigShared projectConfig

        mlogsDir = flagToMaybe projectConfigLogsDir
        mstoreDir = flagToMaybe projectConfigStoreDir
        cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir

        buildSettings = resolveBuildTimeSettings
                          verbosity cabalDirLayout
                          projectConfig

      SourcePackageDb { packageIndex } <- projectConfigWithBuilderRepoContext
280
                                            verbosity buildSettings
281 282
                                            (getSourcePackages verbosity)

283 284 285 286 287 288 289 290 291 292 293
      for_ (concatMap woPackageNames tss) $ \name -> do
        when (null (lookupPackageName packageIndex name)) $ do
          let xs = searchByName packageIndex (unPackageName name)
          let emptyIf True  _  = []
              emptyIf False zs = zs
          die' verbosity $ concat $
            [ "Unknown package \"", unPackageName name, "\". "
            ] ++ emptyIf (null xs)
            [ "Did you mean any of the following?\n"
            , unlines (("- " ++) . unPackageName . fst <$> xs)
            ]
294

295
      let
296 297 298 299
        (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss
        packageTargets            = map woPackageTargets tss

      return (packageSpecifiers, uris, packageTargets, projectConfig)
300

301
  (specs, uris, targetSelectors, config) <-
302
     withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject
303 304 305

  let
    ProjectConfig {
306 307 308
      projectConfigBuildOnly = ProjectConfigBuildOnly {
        projectConfigLogsDir
      },
309 310 311
      projectConfigShared = ProjectConfigShared {
        projectConfigHcFlavor,
        projectConfigHcPath,
312 313
        projectConfigHcPkg,
        projectConfigStoreDir
314 315 316 317 318 319 320 321 322 323 324 325
      },
      projectConfigLocalPackages = PackageConfig {
        packageConfigProgramPaths,
        packageConfigProgramArgs,
        packageConfigProgramPathExtra
      }
    } = config

    hcFlavor = flagToMaybe projectConfigHcFlavor
    hcPath   = flagToMaybe projectConfigHcPath
    hcPkg    = flagToMaybe projectConfigHcPkg

326 327
    -- ProgramDb with directly user specified paths
    preProgDb =
328 329 330 331 332 333
        userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths))
      . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs))
      . modifyProgramSearchPath
          (++ [ ProgramSearchPathDir dir
              | dir <- fromNubList packageConfigProgramPathExtra ])
      $ defaultProgramDb
334

335
  -- progDb is a program database with compiler tools configured properly
336
  (compiler@Compiler { compilerId =
337 338
    compilerId@(CompilerId compilerFlavor compilerVersion) }, platform, progDb) <-
      configCompilerEx hcFlavor hcPath hcPkg preProgDb verbosity
339

340
  let
341
    GhcImplInfo{ supportsPkgEnvFiles } = getImplInfo compiler
342

343 344 345 346
  envFile <- getEnvFile clientInstallFlags platform compilerVersion
  existingEnvEntries <-
    getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile
  packageDbs <- getPackageDbStack compilerId projectConfigStoreDir projectConfigLogsDir
347
  installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb
348

349 350 351
  let
    (envSpecs, nonGlobalEnvEntries) =
      getEnvSpecsAndNonGlobalEntries installedIndex existingEnvEntries installLibs
Alexis Williams's avatar
Alexis Williams committed
352

353 354 355
  -- Second, we need to use a fake project to let Cabal build the
  -- installables correctly. For that, we need a place to put a
  -- temporary dist directory.
356
  globalTmp <- getTemporaryDirectory
Oleg Grenrus's avatar
Oleg Grenrus committed
357

358 359 360 361 362 363 364 365 366 367
  withTempDirectory verbosity globalTmp "cabal-install." $ \tmpDir -> do
    distDirLayout <- establishDummyDistDirLayout verbosity config tmpDir

    uriSpecs <- runRebuild tmpDir $ fetchAndReadSourcePackages
      verbosity
      distDirLayout
      (projectConfigShared config)
      (projectConfigBuildOnly config)
      [ ProjectPackageRemoteTarball uri | uri <- uris ]

368 369
    baseCtx <- establishDummyProjectBaseContext
                 verbosity
370
                 config
371
                 distDirLayout
372
                 (envSpecs ++ specs ++ uriSpecs)
373
                 InstallCommand
374

375
    buildCtx <- constructProjectBuildContext verbosity baseCtx targetSelectors
376 377 378 379

    printPlan verbosity baseCtx buildCtx

    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
380
    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
381

382 383
    -- Now that we built everything we can do the installation part.
    -- First, figure out if / what parts we want to install:
384
    let
385
      dryRun = buildSettingDryRun $ buildSettings baseCtx
Alexis Williams's avatar
Alexis Williams committed
386

387 388 389
    -- Then, install!
    when (not dryRun) $
      if installLibs
390
      then installLibraries verbosity
391
           buildCtx compiler packageDbs progDb envFile nonGlobalEnvEntries
392
      else installExes verbosity
fendor's avatar
fendor committed
393
           baseCtx buildCtx platform compiler configFlags clientInstallFlags
394
  where
395 396
    configFlags' = disableTestsBenchsByDefault configFlags
    verbosity = fromFlagOrDefault normal (configVerbosity configFlags')
397
    ignoreProject = flagIgnoreProject projectFlags
398
    cliConfig = commandLineFlagsToProjectConfig
399 400 401
                  globalFlags
                  flags { configFlags = configFlags' }
                  clientInstallFlags'
402
    globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
403

404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445
-- | Verify that invalid config options were not passed to the install command.
--
-- If an invalid configuration is found the command will @die'@.
verifyPreconditionsOrDie :: Verbosity -> ConfigFlags -> IO ()
verifyPreconditionsOrDie verbosity configFlags = do
  -- We never try to build tests/benchmarks for remote packages.
  -- So we set them as disabled by default and error if they are explicitly
  -- enabled.
  when (configTests configFlags == Flag True) $
    die' verbosity $ "--enable-tests was specified, but tests can't "
                  ++ "be enabled in a remote package"
  when (configBenchmarks configFlags == Flag True) $
    die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't "
                  ++ "be enabled in a remote package"

getClientInstallFlags :: Verbosity -> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags
getClientInstallFlags verbosity globalFlags existingClientInstallFlags = do
  let configFileFlag = globalConfigFile globalFlags
  savedConfig <- loadConfig verbosity configFileFlag
  pure $ savedClientInstallFlags savedConfig `mappend` existingClientInstallFlags


getSpecsAndTargetSelectors
  :: Verbosity
  -> Verbosity
  -> SourcePackageDb
  -> [TargetSelector]
  -> DistDirLayout
  -> ProjectBaseContext
  -> Maybe ComponentKindFilter
  -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter =
  withInstallPlan reducedVerbosity localBaseCtx $ \elaboratedPlan _ -> do
  -- Split into known targets and hackage packages.
  (targets, hackageNames) <-
    partitionToKnownTargetsAndHackagePackages
      verbosity pkgDb elaboratedPlan targetSelectors

  let
    planMap = InstallPlan.toMap elaboratedPlan
    targetIds = Map.keys targets

446
    sdistize (SpecificSourcePackage spkg) =
447 448
      SpecificSourcePackage spkg'
      where
449 450
        sdistPath = distSdistFile localDistDirLayout (packageId spkg)
        spkg' = spkg { srcpkgSource = LocalTarballPackage sdistPath }
451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471
    sdistize named = named

    local = sdistize <$> localPackages localBaseCtx

    gatherTargets :: UnitId -> TargetSelector
    gatherTargets targetId = TargetPackageNamed pkgName targetFilter
      where
        targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap
        PackageIdentifier{..} = packageId targetUnit

    targets' = fmap gatherTargets targetIds

    hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage]
    hackagePkgs = flip NamedPackage [] <$> hackageNames

    hackageTargets :: [TargetSelector]
    hackageTargets =
      flip TargetPackageNamed targetFilter <$> hackageNames

  createDirectoryIfMissing True (distSdistDirectory localDistDirLayout)

472
  unless (Map.null targets) $ for_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of
473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503
      SpecificSourcePackage pkg -> packageToSdist verbosity
        (distProjectRootDirectory localDistDirLayout) TarGzArchive
        (distSdistFile localDistDirLayout (packageId pkg)) pkg
      NamedPackage pkgName _ -> error $ "Got NamedPackage " ++ prettyShow pkgName

  if null targets
    then return (hackagePkgs, hackageTargets)
    else return (local ++ hackagePkgs, targets' ++ hackageTargets)

-- | Partitions the target selectors into known local targets and hackage packages.
partitionToKnownTargetsAndHackagePackages
  :: Verbosity
  -> SourcePackageDb
  -> ElaboratedInstallPlan
  -> [TargetSelector]
  -> IO (Map UnitId [(ComponentTarget,[TargetSelector])], [PackageName])
partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do
  let mTargets = resolveTargets
        selectPackageTargets
        selectComponentTarget
        elaboratedPlan
        (Just pkgDb)
        targetSelectors
  case mTargets of
    Right targets ->
      -- Everything is a local dependency.
      return (targets, [])
    Left errs     -> do
      -- Not everything is local.
      let
        (errs', hackageNames) = partitionEithers . flip fmap errs $ \case
504 505
          TargetAvailableInIndex name -> Right name
          err                         -> Left err
506 507 508

      -- report incorrect case for known package.
      for_ errs' $ \case
509
        TargetNotInProject hn ->
510 511 512 513 514 515 516 517 518
          case searchByName (packageIndex pkgDb) (unPackageName hn) of
            [] -> return ()
            xs -> die' verbosity . concat $
              [ "Unknown package \"", unPackageName hn, "\". "
              , "Did you mean any of the following?\n"
              , unlines (("- " ++) . unPackageName . fst <$> xs)
              ]
        _ -> return ()

519
      when (not . null $ errs') $ reportBuildTargetProblems verbosity errs'
520 521 522 523 524 525 526 527 528 529 530 531

      let
        targetSelectors' = flip filter targetSelectors $ \case
          TargetComponentUnknown name _ _
            | name `elem` hackageNames -> False
          TargetPackageNamed name _
            | name `elem` hackageNames -> False
          _                            -> True

      -- This can't fail, because all of the errors are
      -- removed (or we've given up).
      targets <-
532
        either (reportBuildTargetProblems verbosity) return $
533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552
        resolveTargets
          selectPackageTargets
          selectComponentTarget
          elaboratedPlan
          Nothing
          targetSelectors'

      return (targets, hackageNames)



constructProjectBuildContext
  :: Verbosity
  -> ProjectBaseContext
     -- ^ The synthetic base context to use to produce the full build context.
  -> [TargetSelector]
  -> IO ProjectBuildContext
constructProjectBuildContext verbosity baseCtx targetSelectors = do
  runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
    -- Interpret the targets on the command line as build targets
553
    targets <- either (reportBuildTargetProblems verbosity) return $
554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572
      resolveTargets
        selectPackageTargets
        selectComponentTarget
        elaboratedPlan
        Nothing
        targetSelectors

    let prunedToTargetsElaboratedPlan =
          pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan
    prunedElaboratedPlan <-
      if buildSettingOnlyDeps (buildSettings baseCtx)
      then either (reportCannotPruneDependencies verbosity) return $
           pruneInstallPlanToDependencies (Map.keysSet targets)
                                          prunedToTargetsElaboratedPlan
      else return prunedToTargetsElaboratedPlan

    return (prunedElaboratedPlan, targets)


573
-- | Install any built exe by symlinking/copying it
574
-- we don't use BuildOutcomes because we also need the component names
575 576 577 578 579 580
installExes
  :: Verbosity
  -> ProjectBaseContext
  -> ProjectBuildContext
  -> Platform
  -> Compiler
fendor's avatar
fendor committed
581
  -> ConfigFlags
582 583
  -> ClientInstallFlags
  -> IO ()
584
installExes verbosity baseCtx buildCtx platform compiler
fendor's avatar
fendor committed
585
            configFlags clientInstallFlags = do
586
  installPath <- defaultInstallPath
587
  let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx
588

fendor's avatar
fendor committed
589 590 591
      prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix configFlags))
      suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix configFlags))

592 593 594 595 596
      mkUnitBinDir :: UnitId -> FilePath
      mkUnitBinDir =
        InstallDirs.bindir .
        storePackageInstallDirs' storeDirLayout (compilerId compiler)

597 598
      mkExeName :: UnqualComponentName -> FilePath
      mkExeName exe = unUnqualComponentName exe <.> exeExtension platform
fendor's avatar
fendor committed
599 600 601

      mkFinalExeName :: UnqualComponentName -> FilePath
      mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension platform
602 603
      installdirUnknown =
        "installdir is not defined. Set it in your cabal config file "
604
        ++ "or use --installdir=<path>. Using default installdir: " ++ show installPath
605

606 607
  installdir <- fromFlagOrDefault
                (warn verbosity installdirUnknown >> pure installPath) $
608
                pure <$> cinstInstalldir clientInstallFlags
609
  createDirectoryIfMissingVerbose verbosity False installdir
610
  warnIfNoExes verbosity buildCtx
611 612 613 614

  installMethod <- flagElim defaultMethod return $
    cinstInstallMethod clientInstallFlags

615
  let
616
    doInstall = installUnitExes
617 618
                  verbosity
                  overwritePolicy
fendor's avatar
fendor committed
619
                  mkUnitBinDir mkExeName mkFinalExeName
620
                  installdir installMethod
621
    in traverse_ doInstall $ Map.toList $ targetsMap buildCtx
622
  where
623 624
    overwritePolicy = fromFlagOrDefault NeverOverwrite $
                      cinstOverwritePolicy clientInstallFlags
625 626 627 628 629
    isWindows = buildOS == Windows

    -- This is in IO as we will make environment checks,
    -- to decide which method is best
    defaultMethod :: IO InstallMethod
630
    defaultMethod
631 632 633 634 635 636
      -- Try symlinking in temporary directory, if it works default to
      -- symlinking even on windows
      | isWindows = do
        symlinks <- trySymlink verbosity
        return $ if symlinks then InstallMethodSymlink else InstallMethodCopy
      | otherwise = return InstallMethodSymlink
637

638
-- | Install any built library by adding it to the default ghc environment
639 640 641 642 643 644 645 646 647
installLibraries
  :: Verbosity
  -> ProjectBuildContext
  -> Compiler
  -> PackageDBStack
  -> ProgramDb
  -> FilePath -- ^ Environment file
  -> [GhcEnvironmentFileEntry]
  -> IO ()
648 649 650 651 652 653 654 655
installLibraries verbosity buildCtx compiler
                 packageDbs programDb envFile envEntries = do
  -- Why do we get it again? If we updated a globalPackage then we need
  -- the new version.
  installedIndex <- getInstalledPackages verbosity compiler packageDbs programDb
  if supportsPkgEnvFiles $ getImplInfo compiler
    then do
      let
656 657
        getLatest :: PackageName -> [InstalledPackageInfo]
        getLatest = (=<<) (maybeToList . safeHead . snd) . take 1 . sortBy (comparing (Down . fst))
658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676
                  . PI.lookupPackageName installedIndex
        globalLatest = concat (getLatest <$> globalPackages)

        baseEntries =
          GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs
        globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest
        pkgEntries = ordNub $
              globalEntries
          ++ envEntries
          ++ entriesForLibraryComponents (targetsMap buildCtx)
        contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries)
      createDirectoryIfMissing True (takeDirectory envFile)
      writeFileAtomic envFile (BS.pack contents')
    else
      warn verbosity $
          "The current compiler doesn't support safely installing libraries, "
        ++ "so only executables will be available. (Library installation is "
        ++ "supported on GHC 8.0+ only)"

677 678 679
warnIfNoExes :: Verbosity -> ProjectBuildContext -> IO ()
warnIfNoExes verbosity buildCtx =
  when noExes $
680
    warn verbosity $
681 682 683 684 685 686 687 688
    "\n" <>
    "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <>
    "@ WARNING: Installation might not be completed as desired! @\n" <>
    "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <>
    "Without flags, the command \"cabal install\" doesn't expose" <>
    " libraries in a usable manner.  You might have wanted to run" <>
    " \"cabal install --lib " <>
    unwords (showTargetSelector <$> selectors) <> "\". "
689
  where
690
    targets    = concat $ Map.elems $ targetsMap buildCtx
691
    components = fst <$> targets
692 693 694
    selectors  = concatMap snd targets
    noExes     = null $ catMaybes $ exeMaybe <$> components

695
    exeMaybe (ComponentTarget (CExeName exe) _) = Just exe
696
    exeMaybe _                                  = Nothing
697

698 699 700 701 702 703 704 705 706
globalPackages :: [PackageName]
globalPackages = mkPackageName <$>
  [ "ghc", "hoopl", "bytestring", "unix", "base", "time", "hpc", "filepath"
  , "process", "array", "integer-gmp", "containers", "ghc-boot", "binary"
  , "ghc-prim", "ghci", "rts", "terminfo", "transformers", "deepseq"
  , "ghc-boot-th", "pretty", "template-haskell", "directory", "text"
  , "bin-package-db"
  ]

707 708 709 710 711 712 713 714 715 716 717 718 719
-- | Return the package specifiers and non-global environment file entries.
getEnvSpecsAndNonGlobalEntries
  :: PI.InstalledPackageIndex
  -> [GhcEnvironmentFileEntry]
  -> Bool
  -> ([PackageSpecifier a], [GhcEnvironmentFileEntry])
getEnvSpecsAndNonGlobalEntries installedIndex entries installLibs =
  if installLibs
  then (envSpecs, envEntries')
  else ([], envEntries')
  where
    (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex entries

720 721 722
environmentFileToSpecifiers
  :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry]
  -> ([PackageSpecifier a], [GhcEnvironmentFileEntry])
723
environmentFileToSpecifiers ipi = foldMap $ \case
724
    (GhcEnvFilePackageId unitId)
725 726
        | Just InstalledPackageInfo
          { sourcePackageId = PackageIdentifier{..}, installedUnitId }
727
          <- PI.lookupUnitId ipi unitId
728 729
        , let pkgSpec = NamedPackage pkgName
                        [PackagePropertyVersion (thisVersion pkgVersion)]
730 731 732 733 734
        -> if pkgName `elem` globalPackages
          then ([pkgSpec], [])
          else ([pkgSpec], [GhcEnvFilePackageId installedUnitId])
    _ -> ([], [])

735

736 737 738 739 740 741
-- | Disables tests and benchmarks if they weren't explicitly enabled.
disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags
disableTestsBenchsByDefault configFlags =
  configFlags { configTests = Flag False <> configTests configFlags
              , configBenchmarks = Flag False <> configBenchmarks configFlags }

742
-- | Symlink/copy every exe from a package from the store to a given location
743 744 745 746 747 748 749
installUnitExes
  :: Verbosity
  -> OverwritePolicy -- ^ Whether to overwrite existing files
  -> (UnitId -> FilePath) -- ^ A function to get an UnitId's
                          -- ^ store directory
  -> (UnqualComponentName -> FilePath) -- ^ A function to get an
                                       -- ^ exe's filename
fendor's avatar
fendor committed
750 751 752
  -> (UnqualComponentName -> FilePath) -- ^ A function to get an
                                       -- ^ exe's final possibly
                                       -- ^ different to the name in the store.
753 754 755 756 757
  -> FilePath
  -> InstallMethod
  -> ( UnitId
     , [(ComponentTarget, [TargetSelector])] )
  -> IO ()
758
installUnitExes verbosity overwritePolicy
fendor's avatar
fendor committed
759
                mkSourceBinDir mkExeName mkFinalExeName
760 761
                installdir installMethod
                (unit, components) =
762
  traverse_ installAndWarn exes
763 764 765 766
  where
    exes = catMaybes $ (exeMaybe . fst) <$> components
    exeMaybe (ComponentTarget (CExeName exe) _) = Just exe
    exeMaybe _ = Nothing
767 768
    installAndWarn exe = do
      success <- installBuiltExe
769
                   verbosity overwritePolicy
770
                   (mkSourceBinDir unit) (mkExeName exe)
fendor's avatar
fendor committed
771
                   (mkFinalExeName exe)
772
                   installdir installMethod
773
      let errorMessage = case overwritePolicy of
774 775 776 777 778 779 780 781 782 783
            NeverOverwrite ->
              "Path '" <> (installdir </> prettyShow exe) <> "' already exists. "
              <> "Use --overwrite-policy=always to overwrite."
            -- This shouldn't even be possible, but we keep it in case
            -- symlinking/copying logic changes
            AlwaysOverwrite ->
              case installMethod of
                InstallMethodSymlink -> "Symlinking"
                InstallMethodCopy    ->
                  "Copying" <> " '" <> prettyShow exe <> "' failed."
784
      unless success $ die' verbosity errorMessage
785

786
-- | Install a specific exe.
787 788 789 790
installBuiltExe
  :: Verbosity -> OverwritePolicy
  -> FilePath -- ^ The directory where the built exe is located
  -> FilePath -- ^ The exe's filename
fendor's avatar
fendor committed
791
  -> FilePath -- ^ The exe's filename in the public install directory
792 793 794
  -> FilePath -- ^ the directory where it should be installed
  -> InstallMethod
  -> IO Bool -- ^ Whether the installation was successful
795
installBuiltExe verbosity overwritePolicy
fendor's avatar
fendor committed
796
                sourceDir exeName finalExeName
797
                installdir InstallMethodSymlink = do
798
  notice verbosity $ "Symlinking '" <> exeName <> "' to '" <> destination <> "'"
799
  symlinkBinary
800
    overwritePolicy
801
    installdir
802
    sourceDir
fendor's avatar
fendor committed
803
    finalExeName
804
    exeName
805 806
  where
    destination = installdir </> finalExeName
807
installBuiltExe verbosity overwritePolicy
fendor's avatar
fendor committed
808
                sourceDir exeName finalExeName
809
                installdir InstallMethodCopy = do
810
  notice verbosity $ "Copying '" <> exeName <> "' to '" <> destination <> "'"
811 812 813 814 815 816
  exists <- doesPathExist destination
  case (exists, overwritePolicy) of
    (True , NeverOverwrite ) -> pure False
    (True , AlwaysOverwrite) -> remove >> copy
    (False, _              ) -> copy
  where
817
    source      = sourceDir </> exeName
fendor's avatar
fendor committed
818
    destination = installdir </> finalExeName
819 820 821 822 823 824
    remove = do
      isDir <- doesDirectoryExist destination
      if isDir
      then removeDirectory destination
      else removeFile      destination
    copy = copyFile source destination >> pure True
825

826 827 828 829 830
-- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries.
entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry]
entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) []
  where
    hasLib :: (ComponentTarget, [TargetSelector]) -> Bool
831 832
    hasLib (ComponentTarget (CLibName _) _, _) = True
    hasLib _                                   = False
833

834 835 836
    go :: UnitId
       -> [(ComponentTarget, [TargetSelector])]
       -> [GhcEnvironmentFileEntry]
837 838 839 840
    go unitId targets
      | any hasLib targets = [GhcEnvFilePackageId unitId]
      | otherwise          = []

841

Jan Hrček's avatar
Jan Hrček committed
842
-- | Gets the file path to the request environment file.
843 844
getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO FilePath
getEnvFile clientInstallFlags platform compilerVersion = do
845
  appDir <- getGhcAppDir
846 847 848 849 850
  case flagToMaybe (cinstEnvironmentPath clientInstallFlags) of
    Just spec
      -- Is spec a bare word without any "pathy" content, then it refers to
      -- a named global environment.
      | takeBaseName spec == spec ->
851
          return (getGlobalEnv appDir platform compilerVersion spec)
852 853 854 855 856 857 858 859 860 861
      | otherwise                 -> do
        spec' <- makeAbsolute spec
        isDir <- doesDirectoryExist spec'
        if isDir
          -- If spec is a directory, then make an ambient environment inside
          -- that directory.
          then return (getLocalEnv spec' platform compilerVersion)
          -- Otherwise, treat it like a literal file path.
          else return spec'
    Nothing                       ->
862
      return (getGlobalEnv appDir platform compilerVersion "default")
863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885

-- | Returns the list of @GhcEnvFilePackageIj@ values already existing in the
--   environment being operated on.
getExistingEnvEntries :: Verbosity -> CompilerFlavor -> Bool -> FilePath -> IO [GhcEnvironmentFileEntry]
getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile = do
  envFileExists <- doesFileExist envFile
  filterEnvEntries <$> if
    (compilerFlavor == GHC || compilerFlavor == GHCJS)
      && supportsPkgEnvFiles && envFileExists
    then catch (readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) ->
      warn verbosity ("The environment file " ++ envFile ++
        " is unparsable. Libraries cannot be installed.") >> return []
    else return []
  where
    -- Why? We know what the first part will be, we only care about the packages.
    filterEnvEntries = filter $ \case
      GhcEnvFilePackageId _ -> True
      _                     -> False

-- | Constructs the path to the global GHC environment file.
--
-- TODO(m-renaud): Create PkgEnvName newtype wrapper.
getGlobalEnv :: FilePath -> Platform -> Version -> String -> FilePath
886 887
getGlobalEnv appDir platform compilerVersion name =
  appDir </> ghcPlatformAndVersionString platform compilerVersion
888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908
  </> "environments" </> name

-- | Constructs the path to a local GHC environment file.
getLocalEnv :: FilePath -> Platform -> Version -> FilePath
getLocalEnv dir platform compilerVersion  =
  dir </>
  ".ghc.environment." <> ghcPlatformAndVersionString platform compilerVersion

getPackageDbStack
  :: CompilerId
  -> Flag FilePath
  -> Flag FilePath
  -> IO PackageDBStack
getPackageDbStack compilerId storeDirFlag logsDirFlag = do
  cabalDir <- getCabalDir
  mstoreDir <- traverse makeAbsolute $ flagToMaybe storeDirFlag
  let
    mlogsDir    = flagToMaybe logsDirFlag
    cabalLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir
  pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId

909 910 911 912
-- | This defines what a 'TargetSelector' means for the @bench@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
-- or otherwise classifies the problem.
--
913 914 915
-- For the @build@ command select all components except non-buildable
-- and disabled tests\/benchmarks, fail if there are no such
-- components
916
--
917 918
selectPackageTargets
  :: TargetSelector
919
  -> [AvailableTarget k] -> Either TargetProblem' [k]
920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950
selectPackageTargets targetSelector targets

    -- If there are any buildable targets then we select those
  | not (null targetsBuildable)
  = Right targetsBuildable

    -- If there are targets but none are buildable then we report those
  | not (null targets)
  = Left (TargetProblemNoneEnabled targetSelector targets')

    -- If there are no targets at all then we report that
  | otherwise
  = Left (TargetProblemNoTargets targetSelector)
  where
    targets'         = forgetTargetsDetail targets
    targetsBuildable = selectBuildableTargetsWith
                         (buildable targetSelector)
                         targets

    -- When there's a target filter like "pkg:tests" then we do select tests,
    -- but if it's just a target like "pkg" then we don't build tests unless
    -- they are requested by default (i.e. by using --enable-tests)
    buildable (TargetPackage _ _  Nothing) TargetNotRequestedByDefault = False
    buildable (TargetAllPackages  Nothing) TargetNotRequestedByDefault = False
    buildable _ _ = True

-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
-- selected.
--
-- For the @build@ command we just need the basic checks on being buildable etc.
--
951 952
selectComponentTarget
  :: SubComponentTarget
953 954
  -> AvailableTarget k -> Either TargetProblem' k
selectComponentTarget = selectComponentTargetBasic
955

956 957
reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a
reportBuildTargetProblems verbosity problems = reportTargetProblems verbosity "build" problems
958 959 960 961

reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a
reportCannotPruneDependencies verbosity =
    die' verbosity . renderCannotPruneDependencies