Install.hs 59.3 KB
Newer Older
1
{-# LANGUAGE CPP #-}
2 3
-----------------------------------------------------------------------------
-- |
4
-- Module      :  Distribution.Client.Install
5 6 7
-- Copyright   :  (c) 2005 David Himmelstrup
--                    2007 Bjorn Bringert
--                    2007-2010 Duncan Coutts
8 9
-- License     :  BSD-like
--
10
-- Maintainer  :  cabal-devel@haskell.org
11 12 13 14 15
-- Stability   :  provisional
-- Portability :  portable
--
-- High level interface to package installation.
-----------------------------------------------------------------------------
16
module Distribution.Client.Install (
17 18 19 20 21 22 23 24 25 26 27 28
    -- * High-level interface
    install,

    -- * Lower-level interface that allows to manipulate the install plan
    makeInstallContext,
    makeInstallPlan,
    processInstallPlan,
    InstallArgs,
    InstallContext,

    -- * Prune certain packages from the install plan
    pruneInstallPlan
29
  ) where
30

31
import Data.List
32
         ( unfoldr, nub, sort, (\\) )
33
import qualified Data.Set as S
Duncan Coutts's avatar
Duncan Coutts committed
34
import Data.Maybe
35
         ( isJust, fromMaybe, maybeToList )
36
import Control.Exception as Exception
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
37
         ( Exception(toException), bracket, catches
38
         , Handler(Handler), handleJust, IOException, SomeException )
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
39 40 41 42
#ifndef mingw32_HOST_OS
import Control.Exception as Exception
         ( Exception(fromException) )
#endif
Duncan Coutts's avatar
Duncan Coutts committed
43
import System.Exit
44
         ( ExitCode(..) )
45
import Distribution.Compat.Exception
46
         ( catchIO, catchExit )
47
import Control.Monad
48
         ( when, unless )
49
import System.Directory
50 51
         ( getTemporaryDirectory, doesDirectoryExist, doesFileExist,
           createDirectoryIfMissing, removeFile, renameDirectory )
Duncan Coutts's avatar
Duncan Coutts committed
52
import System.FilePath
Duncan Coutts's avatar
Duncan Coutts committed
53
         ( (</>), (<.>), takeDirectory )
Duncan Coutts's avatar
Duncan Coutts committed
54
import System.IO
55
         ( openFile, IOMode(AppendMode), hClose )
56 57
import System.IO.Error
         ( isDoesNotExistError, ioeGetFileName )
bjorn@bringert.net's avatar
bjorn@bringert.net committed
58

59
import Distribution.Client.Targets
60
import Distribution.Client.Dependency
61
import Distribution.Client.Dependency.Types
62
         ( AllowNewer, Solver(..), isAllowNewer )
Duncan Coutts's avatar
Duncan Coutts committed
63
import Distribution.Client.FetchUtils
64
import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)
65
import Distribution.Client.IndexUtils as IndexUtils
66
         ( getSourcePackages, getInstalledPackages )
67 68 69
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
import Distribution.Client.Setup
70 71
         ( GlobalFlags(..)
         , ConfigFlags(..), configureCommand, filterConfigureFlags
72
         , ConfigExFlags(..), InstallFlags(..) )
Duncan Coutts's avatar
Duncan Coutts committed
73
import Distribution.Client.Config
74
         ( defaultCabalDir, defaultUserInstall )
75 76 77
import Distribution.Client.Sandbox.Timestamp
         ( withUpdateTimestamps )
import Distribution.Client.Sandbox.Types
78 79
         ( SandboxPackageInfo(..), UseSandbox(..), isUseSandbox
         , whenUsingSandbox )
80
import Distribution.Client.Tar (extractTarGzFile)
81
import Distribution.Client.Types as Source
82 83
import Distribution.Client.BuildReports.Types
         ( ReportLevel(..) )
84
import Distribution.Client.SetupWrapper
Duncan Coutts's avatar
Duncan Coutts committed
85
         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
David Himmelstrup's avatar
David Himmelstrup committed
86
import qualified Distribution.Client.BuildReports.Anonymous as BuildReports
Duncan Coutts's avatar
Duncan Coutts committed
87 88
import qualified Distribution.Client.BuildReports.Storage as BuildReports
         ( storeAnonymous, storeLocal, fromInstallPlan )
89
import qualified Distribution.Client.InstallSymlink as InstallSymlink
90
         ( symlinkBinaries )
91
import qualified Distribution.Client.PackageIndex as SourcePackageIndex
92
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
93
import qualified Distribution.Client.World as World
94
import qualified Distribution.InstalledPackageInfo as Installed
95
import Distribution.Client.Compat.ExecutablePath
96
import Distribution.Client.JobControl
97

98
import Distribution.Simple.Compiler
99
         ( CompilerId(..), Compiler(compilerId), compilerFlavor
100
         , PackageDB(..), PackageDBStack )
refold's avatar
refold committed
101 102
import Distribution.Simple.Program (ProgramConfiguration,
                                    defaultProgramConfiguration)
103
import qualified Distribution.Simple.InstallDirs as InstallDirs
104 105
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (PackageIndex)
106
import Distribution.Simple.Setup
107
         ( haddockCommand, HaddockFlags(..)
108
         , buildCommand, BuildFlags(..), emptyBuildFlags
109
         , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref )
110
import qualified Distribution.Simple.Setup as Cabal
TillmannRendel's avatar
TillmannRendel committed
111
         ( Flag(..)
112 113
         , copyCommand, CopyFlags(..), emptyCopyFlags
         , registerCommand, RegisterFlags(..), emptyRegisterFlags
TillmannRendel's avatar
TillmannRendel committed
114
         , testCommand, TestFlags(..), emptyTestFlags )
115
import Distribution.Simple.Utils
116 117
         ( createDirectoryIfMissingVerbose, rawSystemExit, comparing
         , writeFileAtomic, withTempFile , withFileContents )
118 119
import Distribution.Simple.InstallDirs as InstallDirs
         ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate
120
         , initialPathTemplateEnv, installDirsTemplateEnv )
121
import Distribution.Package
122
         ( PackageIdentifier, PackageId, packageName, packageVersion
123
         , Package(..), PackageFixedDeps(..)
124
         , Dependency(..), thisPackageVersion, InstalledPackageId )
125 126
import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription
127 128
         ( PackageDescription, GenericPackageDescription(..), Flag(..)
         , FlagName(..), FlagAssignment )
129
import Distribution.PackageDescription.Configuration
130
         ( finalizePackageDescription )
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
131 132
import Distribution.ParseUtils
         ( showPWarning )
133
import Distribution.Version
134
         ( Version(..), anyVersion, orLaterVersion, thisVersion )
135
import Distribution.Simple.Utils as Utils
136 137
         ( notice, info, warn, debug, debugNoWrap, die
         , intercalate, withTempDirectory )
138
import Distribution.Client.Utils
139
         ( determineNumJobs, inDir, mergeBy, MergeResult(..)
140
         , tryCanonicalizePath )
141
import Distribution.System
142
         ( Platform, OS(Windows), buildOS )
143 144
import Distribution.Text
         ( display )
Duncan Coutts's avatar
Duncan Coutts committed
145
import Distribution.Verbosity as Verbosity
146
         ( Verbosity, showForCabal, normal, verbose )
147
import Distribution.Simple.BuildPaths ( exeExtension )
bjorn@bringert.net's avatar
bjorn@bringert.net committed
148

149 150 151 152 153 154 155 156 157 158 159
--TODO:
-- * assign flags to packages individually
--   * complain about flags that do not apply to any package given as target
--     so flags do not apply to dependencies, only listed, can use flag
--     constraints for dependencies
--   * only record applicable flags in world file
-- * allow flag constraints
-- * allow installed constraints
-- * allow flag and installed preferences
-- * change world file to use cabal section syntax
--   * allow persistent configure flags for each package individually
160

161 162 163 164 165 166
-- ------------------------------------------------------------
-- * Top level user actions
-- ------------------------------------------------------------

-- | Installs the packages needed to satisfy a list of dependencies.
--
167
install
168
  :: Verbosity
169
  -> PackageDBStack
170 171
  -> [Repo]
  -> Compiler
172
  -> Platform
173
  -> ProgramConfiguration
174
  -> UseSandbox
175
  -> Maybe SandboxPackageInfo
176
  -> GlobalFlags
177
  -> ConfigFlags
178
  -> ConfigExFlags
179
  -> InstallFlags
180
  -> HaddockFlags
181
  -> [UserTarget]
182
  -> IO ()
183
install verbosity packageDBs repos comp platform conf useSandbox mSandboxPkgInfo
refold's avatar
refold committed
184 185
  globalFlags configFlags configExFlags installFlags haddockFlags
  userTargets0 = do
186

187
    installContext <- makeInstallContext verbosity args (Just userTargets0)
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
188
    installPlan    <- foldProgress logMsg die' return =<<
189 190 191 192 193
                      makeInstallPlan verbosity args installContext

    processInstallPlan verbosity args installContext installPlan
  where
    args :: InstallArgs
194
    args = (packageDBs, repos, comp, platform, conf, useSandbox, mSandboxPkgInfo,
195 196 197
            globalFlags, configFlags, configExFlags, installFlags,
            haddockFlags)

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
198 199 200 201
    die' message = die (message ++ if isUseSandbox useSandbox
                                   then installFailedInSandbox else [])
    -- TODO: use a better error message, remove duplication.
    installFailedInSandbox =
202 203 204 205
      "\nNote: when using a sandbox, all packages are required to have "
      ++ "consistent dependencies. "
      ++ "Try reinstalling/unregistering the offending packages or "
      ++ "recreating the sandbox."
206 207
    logMsg message rest = debugNoWrap verbosity message >> rest

refold's avatar
refold committed
208
-- TODO: Make InstallContext a proper datatype with documented fields.
209 210 211 212
-- | Common context for makeInstallPlan and processInstallPlan.
type InstallContext = ( PackageIndex, SourcePackageDb
                      , [UserTarget], [PackageSpecifier SourcePackage] )

refold's avatar
refold committed
213 214
-- TODO: Make InstallArgs a proper datatype with documented fields or just get
-- rid of it completely.
215 216 217 218
-- | Initial arguments given to 'install' or 'makeInstallContext'.
type InstallArgs = ( PackageDBStack
                   , [Repo]
                   , Compiler
219
                   , Platform
220
                   , ProgramConfiguration
221
                   , UseSandbox
222
                   , Maybe SandboxPackageInfo
223 224 225 226 227 228 229
                   , GlobalFlags
                   , ConfigFlags
                   , ConfigExFlags
                   , InstallFlags
                   , HaddockFlags )

-- | Make an install context given install arguments.
230
makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]
231 232
                      -> IO InstallContext
makeInstallContext verbosity
233
  (packageDBs, repos, comp, _, conf,_,_,
234
   globalFlags, _, _, _, _) mUserTargets = do
235

236 237
    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
    sourcePkgDb       <- getSourcePackages    verbosity repos
238

239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255
    (userTargets, pkgSpecifiers) <- case mUserTargets of
      Nothing           ->
        -- We want to distinguish between the case where the user has given an
        -- empty list of targets on the command-line and the case where we
        -- specifically want to have an empty list of targets.
        return ([], [])
      Just userTargets0 -> do
        -- For install, if no target is given it means we use the current
        -- directory as the single target.
        let userTargets | null userTargets0 = [UserTargetLocalDir "."]
                        | otherwise         = userTargets0

        pkgSpecifiers <- resolveUserTargets verbosity
                         (fromFlag $ globalWorldFile globalFlags)
                         (packageIndex sourcePkgDb)
                         userTargets
        return (userTargets, pkgSpecifiers)
256 257

    return (installedPkgIndex, sourcePkgDb, userTargets, pkgSpecifiers)
258

259 260 261 262
-- | Make an install plan given install context and install arguments.
makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext
                -> IO (Progress String String InstallPlan)
makeInstallPlan verbosity
263
  (_, _, comp, platform, _, _, mSandboxPkgInfo,
264 265 266 267 268 269 270
   _, configFlags, configExFlags, installFlags,
   _)
  (installedPkgIndex, sourcePkgDb,
   _, pkgSpecifiers) = do

    solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags))
              (compilerId comp)
271
    notice verbosity "Resolving dependencies..."
272 273 274
    return $ planPackages comp platform mSandboxPkgInfo solver
      configFlags configExFlags installFlags
      installedPkgIndex sourcePkgDb pkgSpecifiers
275

276 277 278 279 280
-- | Given an install plan, perform the actual installations.
processInstallPlan :: Verbosity -> InstallArgs -> InstallContext
                   -> InstallPlan
                   -> IO ()
processInstallPlan verbosity
281
  args@(_,_, _, _, _, _, _, _, _, _, installFlags, _)
282 283
  (installedPkgIndex, sourcePkgDb,
   userTargets, pkgSpecifiers) installPlan = do
284 285
    checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb
      installFlags pkgSpecifiers
286

287 288
    unless dryRun $ do
      installPlan' <- performInstallations verbosity
289 290
                      args installedPkgIndex installPlan
      postInstallActions verbosity args userTargets installPlan'
291
  where
292
    dryRun = fromFlag (installDryRun installFlags)
293

294 295 296
-- ------------------------------------------------------------
-- * Installation planning
-- ------------------------------------------------------------
297

298
planPackages :: Compiler
299
             -> Platform
300
             -> Maybe SandboxPackageInfo
301
             -> Solver
302 303 304
             -> ConfigFlags
             -> ConfigExFlags
             -> InstallFlags
305
             -> PackageIndex
306 307
             -> SourcePackageDb
             -> [PackageSpecifier SourcePackage]
308
             -> Progress String String InstallPlan
309 310
planPackages comp platform mSandboxPkgInfo solver
             configFlags configExFlags installFlags
311
             installedPkgIndex sourcePkgDb pkgSpecifiers =
312

313
        resolveDependencies
314
          platform (compilerId comp)
315
          solver
316
          resolverParams
317

318
    >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return
319

320 321 322
  where
    resolverParams =

Andres Löh's avatar
Andres Löh committed
323 324 325
        setMaxBackjumps (if maxBackjumps < 0 then Nothing
                                             else Just maxBackjumps)

326 327
      . setIndependentGoals independentGoals

Andres Löh's avatar
Andres Löh committed
328
      . setReorderGoals reorderGoals
Andres Löh's avatar
Andres Löh committed
329 330

      . setAvoidReinstalls avoidReinstalls
331

332 333
      . setShadowPkgs shadowPkgs

334
      . setPreferenceDefault (if upgradeDeps then PreferAllLatest
335 336
                                             else PreferLatestForSelected)

337
      . removeUpperBounds allowNewer
338

339 340 341 342 343 344 345
      . addPreferences
          -- preferences from the config file or command line
          [ PackageVersionPreference name ver
          | Dependency name ver <- configPreferences configExFlags ]

      . addConstraints
          -- version constraints from the config file or command line
346
            (map userToPackageConstraint (configExConstraints configExFlags))
347 348 349 350

      . addConstraints
          --FIXME: this just applies all flags to all targets which
          -- is silly. We should check if the flags are appropriate
351
          [ PackageConstraintFlags (pkgSpecifierTarget pkgSpecifier) flags
352 353
          | let flags = configConfigurationsFlags configFlags
          , not (null flags)
354 355 356 357 358
          , pkgSpecifier <- pkgSpecifiers ]

      . addConstraints
          [ PackageConstraintStanzas (pkgSpecifierTarget pkgSpecifier) stanzas
          | pkgSpecifier <- pkgSpecifiers ]
359

360 361
      . maybe id applySandboxInstallPolicy mSandboxPkgInfo

362 363
      . (if reinstall then reinstallTargets else id)

364
      $ standardInstallPolicy
365
        installedPkgIndex sourcePkgDb pkgSpecifiers
366

367 368 369 370
    stanzas = concat
        [ if testsEnabled then [TestStanzas] else []
        , if benchmarksEnabled then [BenchStanzas] else []
        ]
371
    testsEnabled = fromFlagOrDefault False $ configTests configFlags
372
    benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags
373

374 375 376 377
    reinstall        = fromFlag (installReinstall        installFlags)
    reorderGoals     = fromFlag (installReorderGoals     installFlags)
    independentGoals = fromFlag (installIndependentGoals installFlags)
    avoidReinstalls  = fromFlag (installAvoidReinstalls  installFlags)
378
    shadowPkgs       = fromFlag (installShadowPkgs       installFlags)
379 380 381
    maxBackjumps     = fromFlag (installMaxBackjumps     installFlags)
    upgradeDeps      = fromFlag (installUpgradeDeps      installFlags)
    onlyDeps         = fromFlag (installOnlyDeps         installFlags)
382
    allowNewer       = fromFlag (configAllowNewer        configExFlags)
383

384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411
-- | Remove the provided targets from the install plan.
pruneInstallPlan :: Package pkg => [PackageSpecifier pkg] -> InstallPlan
                    -> Progress String String InstallPlan
pruneInstallPlan pkgSpecifiers =
  -- TODO: this is a general feature and should be moved to D.C.Dependency
  -- Also, the InstallPlan.remove should return info more precise to the
  -- problem, rather than the very general PlanProblem type.
  either (Fail . explain) Done
  . InstallPlan.remove (\pkg -> packageName pkg `elem` targetnames)
  where
    explain :: [InstallPlan.PlanProblem] -> String
    explain problems =
      "Cannot select only the dependencies (as requested by the "
      ++ "'--only-dependencies' flag), "
      ++ (case pkgids of
             [pkgid] -> "the package " ++ display pkgid ++ " is "
             _       -> "the packages "
                        ++ intercalate ", " (map display pkgids) ++ " are ")
      ++ "required by a dependency of one of the other targets."
      where
        pkgids =
          nub [ depid
              | InstallPlan.PackageMissingDeps _ depids <- problems
              , depid <- depids
              , packageName depid `elem` targetnames ]

    targetnames  = map pkgSpecifierTarget pkgSpecifiers

412 413 414 415
-- ------------------------------------------------------------
-- * Informational messages
-- ------------------------------------------------------------

416 417
-- | Perform post-solver checks of the install plan and print it if
-- either requested or needed.
418 419 420
checkPrintPlan :: Verbosity
               -> PackageIndex
               -> InstallPlan
421
               -> SourcePackageDb
422
               -> InstallFlags
423
               -> [PackageSpecifier SourcePackage]
424
               -> IO ()
425 426
checkPrintPlan verbosity installed installPlan sourcePkgDb
  installFlags pkgSpecifiers = do
427

428 429 430 431 432 433 434 435
  -- User targets that are already installed.
  let preExistingTargets =
        [ p | let tgts = map pkgSpecifierTarget pkgSpecifiers,
              InstallPlan.PreExisting p <- InstallPlan.toList installPlan,
              packageName p `elem` tgts ]

  -- If there's nothing to install, we print the already existing
  -- target packages as an explanation.
436
  when nothingToInstall $
437 438 439 440
    notice verbosity $ unlines $
         "All the requested packages are already installed:"
       : map (display . packageId) preExistingTargets
      ++ ["Use --reinstall if you want to reinstall anyway."]
441

442
  let lPlan = linearizeInstallPlan installed installPlan
443 444
  -- Are any packages classified as reinstalls?
  let reinstalledPkgs = concatMap (extractReinstalls . snd) lPlan
445 446 447 448 449 450 451 452
  -- Packages that are already broken.
  let oldBrokenPkgs =
          map Installed.installedPackageId
        . PackageIndex.reverseDependencyClosure installed
        . map (Installed.installedPackageId . fst)
        . PackageIndex.brokenPackages
        $ installed
  let excluded = reinstalledPkgs ++ oldBrokenPkgs
453
  -- Packages that are reverse dependencies of replaced packages are very
454 455 456
  -- likely to be broken. We exclude packages that are already broken.
  let newBrokenPkgs =
        filter (\ p -> not (Installed.installedPackageId p `elem` excluded))
457 458
               (PackageIndex.reverseDependencyClosure installed reinstalledPkgs)
  let containsReinstalls = not (null reinstalledPkgs)
459
  let breaksPkgs         = not (null newBrokenPkgs)
460 461 462 463 464 465 466 467

  let adaptedVerbosity
        | containsReinstalls && not overrideReinstall = verbosity `max` verbose
        | otherwise                                   = verbosity

  -- We print the install plan if we are in a dry-run or if we are confronted
  -- with a dangerous install plan.
  when (dryRun || containsReinstalls && not overrideReinstall) $
468 469
    printPlan (dryRun || breaksPkgs && not overrideReinstall)
      adaptedVerbosity lPlan sourcePkgDb
470

471 472 473 474 475 476 477 478
  -- If the install plan is dangerous, we print various warning messages. In
  -- particular, if we can see that packages are likely to be broken, we even
  -- bail out (unless installation has been forced with --force-reinstalls).
  when containsReinstalls $ do
    if breaksPkgs
      then do
        (if dryRun || overrideReinstall then warn verbosity else die) $ unlines $
            "The following packages are likely to be broken by the reinstalls:"
479
          : map (display . Installed.sourcePackageId) newBrokenPkgs
480 481 482 483 484 485 486
          ++ if overrideReinstall
               then if dryRun then [] else
                 ["Continuing even though the plan contains dangerous reinstalls."]
               else
                 ["Use --force-reinstalls if you want to install anyway."]
      else unless dryRun $ warn verbosity
             "Note that reinstalls are always dangerous. Continuing anyway..."
487 488 489

  where
    nothingToInstall = null (InstallPlan.ready installPlan)
490 491

    dryRun            = fromFlag (installDryRun            installFlags)
492
    overrideReinstall = fromFlag (installOverrideReinstall installFlags)
493

494 495
linearizeInstallPlan :: PackageIndex
                     -> InstallPlan
496
                     -> [(ReadyPackage, PackageStatus)]
497 498
linearizeInstallPlan installedPkgIndex plan =
    unfoldr next plan
499 500 501
  where
    next plan' = case InstallPlan.ready plan' of
      []      -> Nothing
502
      (pkg:_) -> Just ((pkg, status), plan'')
503 504 505 506
        where
          pkgid  = packageId pkg
          status = packageStatus installedPkgIndex pkg
          plan'' = InstallPlan.completed pkgid
507
                     (BuildOk DocsNotTried TestsNotTried
508 509
                              (Just $ Installed.emptyInstalledPackageInfo
                              { Installed.sourcePackageId = pkgid }))
510 511 512
                     (InstallPlan.processing [pkg] plan')
          --FIXME: This is a bit of a hack,
          -- pretending that each package is installed
513

514 515
data PackageStatus = NewPackage
                   | NewVersion [Version]
516
                   | Reinstall  [InstalledPackageId] [PackageChange]
517 518 519

type PackageChange = MergeResult PackageIdentifier PackageIdentifier

520 521 522
extractReinstalls :: PackageStatus -> [InstalledPackageId]
extractReinstalls (Reinstall ipids _) = ipids
extractReinstalls _                   = []
523

524
packageStatus :: PackageIndex -> ReadyPackage -> PackageStatus
525 526 527 528
packageStatus installedPkgIndex cpkg =
  case PackageIndex.lookupPackageName installedPkgIndex
                                      (packageName cpkg) of
    [] -> NewPackage
refold's avatar
refold committed
529 530
    ps ->  case filter ((==packageId cpkg)
                        . Installed.sourcePackageId) (concatMap snd ps) of
531 532 533
      []           -> NewVersion (map fst ps)
      pkgs@(pkg:_) -> Reinstall (map Installed.installedPackageId pkgs)
                                (changes pkg cpkg)
534 535 536 537

  where

    changes :: Installed.InstalledPackageInfo
538
            -> ReadyPackage
539
            -> [MergeResult PackageIdentifier PackageIdentifier]
refold's avatar
refold committed
540 541 542 543 544 545 546 547 548 549 550
    changes pkg pkg' =
      filter changed
      $ mergeBy (comparing packageName)
        -- get dependencies of installed package (convert to source pkg ids via
        -- index)
        (nub . sort . concatMap
         (maybeToList . fmap Installed.sourcePackageId .
          PackageIndex.lookupInstalledPackageId installedPkgIndex) .
         Installed.depends $ pkg)
        -- get dependencies of configured package
        (nub . sort . depends $ pkg')
551 552 553 554

    changed (InBoth    pkgid pkgid') = pkgid /= pkgid'
    changed _                        = True

555 556
printPlan :: Bool -- is dry run
          -> Verbosity
557
          -> [(ReadyPackage, PackageStatus)]
558
          -> SourcePackageDb
559
          -> IO ()
560
printPlan dryRun verbosity plan sourcePkgDb = case plan of
561 562 563
  []   -> return ()
  pkgs
    | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $
564
        ("In order, the following " ++ wouldWill ++ " be installed:")
565 566
      : map showPkgAndReason pkgs
    | otherwise -> notice verbosity $ unlines $
refold's avatar
refold committed
567 568
        ("In order, the following " ++ wouldWill
         ++ " be installed (use -v for more details):")
569
      : map showPkg pkgs
570
  where
571 572 573
    wouldWill | dryRun    = "would"
              | otherwise = "will"

574 575 576
    showPkg (pkg, _) = display (packageId pkg) ++
                       showLatest (pkg)

577
    showPkgAndReason (pkg', pr) = display (packageId pkg') ++
578
          showLatest pkg' ++
579 580
          showFlagAssignment (nonDefaultFlags pkg') ++
          showStanzas (stanzas pkg') ++ " " ++
581
          case pr of
582 583 584
            NewPackage     -> "(new package)"
            NewVersion _   -> "(new version)"
            Reinstall _ cs -> "(reinstall)" ++ case cs of
585 586 587
                []   -> ""
                diff -> " changes: "  ++ intercalate ", " (map change diff)

588
    showLatest :: ReadyPackage -> String
589 590
    showLatest pkg = case mLatestVersion of
        Just latestVersion ->
591
            if pkgVersion < latestVersion
592 593 594
            then (" (latest: " ++ display latestVersion ++ ")")
            else ""
        Nothing -> ""
595 596
      where
        pkgVersion    = packageVersion pkg
597 598 599 600 601 602
        mLatestVersion :: Maybe Version
        mLatestVersion = case SourcePackageIndex.lookupPackageName
                                (packageIndex sourcePkgDb)
                                (packageName pkg) of
            [] -> Nothing
            x -> Just $ packageVersion $ last x
603

604 605 606
    toFlagAssignment :: [Flag] -> FlagAssignment
    toFlagAssignment = map (\ f -> (flagName f, flagDefault f))

607 608
    nonDefaultFlags :: ReadyPackage -> FlagAssignment
    nonDefaultFlags (ReadyPackage spkg fa _ _) =
609 610 611 612 613
      let defaultAssignment =
            toFlagAssignment
             (genPackageFlags (Source.packageDescription spkg))
      in  fa \\ defaultAssignment

614 615
    stanzas :: ReadyPackage -> [OptionalStanza]
    stanzas (ReadyPackage _ _ sts _) = sts
616 617 618 619 620 621

    showStanzas :: [OptionalStanza] -> String
    showStanzas = concatMap ((' ' :) . showStanza)
    showStanza TestStanzas  = "*test"
    showStanza BenchStanzas = "*bench"

622
    -- FIXME: this should be a proper function in a proper place
623
    showFlagAssignment :: FlagAssignment -> String
624 625 626 627 628
    showFlagAssignment = concatMap ((' ' :) . showFlagValue)
    showFlagValue (f, True)   = '+' : showFlagName f
    showFlagValue (f, False)  = '-' : showFlagName f
    showFlagName (FlagName f) = f

629 630 631 632 633
    change (OnlyInLeft pkgid)        = display pkgid ++ " removed"
    change (InBoth     pkgid pkgid') = display pkgid ++ " -> "
                                    ++ display (packageVersion pkgid')
    change (OnlyInRight      pkgid') = display pkgid' ++ " added"

634 635 636 637 638 639 640 641 642 643
-- ------------------------------------------------------------
-- * Post installation stuff
-- ------------------------------------------------------------

-- | Various stuff we do after successful or unsuccessfully installing a bunch
-- of packages. This includes:
--
--  * build reporting, local and remote
--  * symlinking binaries
--  * updating indexes
644
--  * updating world file
645 646 647
--  * error reporting
--
postInstallActions :: Verbosity
648
                   -> InstallArgs
649
                   -> [UserTarget]
650 651 652
                   -> InstallPlan
                   -> IO ()
postInstallActions verbosity
653 654
  (packageDBs, _, comp, platform, conf, useSandbox, mSandboxPkgInfo
  ,globalFlags, configFlags, _, installFlags, _)
655
  targets installPlan = do
656

657
  unless oneShot $
658
    World.insert verbosity worldFile
659 660 661
      --FIXME: does not handle flags
      [ World.WorldPkgInfo dep []
      | UserTargetNamed dep <- targets ]
662

663
  let buildReports = BuildReports.fromInstallPlan installPlan
refold's avatar
refold committed
664 665
  BuildReports.storeLocal (installSummaryFile installFlags) buildReports
    (InstallPlan.planPlatform installPlan)
666 667 668 669 670
  when (reportingLevel >= AnonymousReports) $
    BuildReports.storeAnonymous buildReports
  when (reportingLevel == DetailedReports) $
    storeDetailedBuildReports verbosity logsDir buildReports

671
  regenerateHaddockIndex verbosity packageDBs comp platform conf
672 673 674 675 676 677
                         configFlags installFlags installPlan

  symlinkBinaries verbosity configFlags installFlags installPlan

  printBuildFailures installPlan

678 679 680
  updateSandboxTimestampsFile useSandbox mSandboxPkgInfo
                              comp platform installPlan

681 682
  where
    reportingLevel = fromFlag (installBuildReports installFlags)
683
    logsDir        = fromFlag (globalLogsDir globalFlags)
684 685
    oneShot        = fromFlag (installOneShot installFlags)
    worldFile      = fromFlag $ globalWorldFile globalFlags
686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722

storeDetailedBuildReports :: Verbosity -> FilePath
                          -> [(BuildReports.BuildReport, Repo)] -> IO ()
storeDetailedBuildReports verbosity logsDir reports = sequence_
  [ do dotCabal <- defaultCabalDir
       let logFileName = display (BuildReports.package report) <.> "log"
           logFile     = logsDir </> logFileName
           reportsDir  = dotCabal </> "reports" </> remoteRepoName remoteRepo
           reportFile  = reportsDir </> logFileName

       handleMissingLogFile $ do
         buildLog <- readFile logFile
         createDirectoryIfMissing True reportsDir -- FIXME
         writeFile reportFile (show (BuildReports.show report, buildLog))

  | (report, Repo { repoKind = Left remoteRepo }) <- reports
  , isLikelyToHaveLogFile (BuildReports.installOutcome report) ]

  where
    isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True
    isLikelyToHaveLogFile BuildReports.BuildFailed     {} = True
    isLikelyToHaveLogFile BuildReports.InstallFailed   {} = True
    isLikelyToHaveLogFile BuildReports.InstallOk       {} = True
    isLikelyToHaveLogFile _                               = False

    handleMissingLogFile = Exception.handleJust missingFile $ \ioe ->
      warn verbosity $ "Missing log file for build report: "
                    ++ fromMaybe ""  (ioeGetFileName ioe)

    missingFile ioe
      | isDoesNotExistError ioe  = Just ioe
    missingFile _                = Nothing


regenerateHaddockIndex :: Verbosity
                       -> [PackageDB]
                       -> Compiler
723
                       -> Platform
724 725 726 727 728
                       -> ProgramConfiguration
                       -> ConfigFlags
                       -> InstallFlags
                       -> InstallPlan
                       -> IO ()
729
regenerateHaddockIndex verbosity packageDBs comp platform conf
730 731 732 733 734 735 736 737 738 739 740 741 742 743
                       configFlags installFlags installPlan
  | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do

  defaultDirs <- InstallDirs.defaultInstallDirs
                   (compilerFlavor comp)
                   (fromFlag (configUserInstall configFlags))
                   True
  let indexFileTemplate = fromFlag (installHaddockIndex installFlags)
      indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate

  notice verbosity $
     "Updating documentation index " ++ indexFile

  --TODO: might be nice if the install plan gave us the new InstalledPackageInfo
744 745
  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
  Haddock.regenerateHaddockIndex verbosity installedPkgIndex conf indexFile
746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762

  | otherwise = return ()
  where
    haddockIndexFileIsRequested =
         fromFlag (installDocumentation installFlags)
      && isJust (flagToMaybe (installHaddockIndex installFlags))

    -- We want to regenerate the index if some new documentation was actually
    -- installed. Since the index is per-user, we don't do it for global
    -- installs or special cases where we're installing into a specific db.
    shouldRegenerateHaddockIndex = normalUserInstall
                                && someDocsWereInstalled installPlan
      where
        someDocsWereInstalled = any installedDocs . InstallPlan.toList
        normalUserInstall     = (UserPackageDB `elem` packageDBs)
                             && all (not . isSpecificPackageDB) packageDBs

763
        installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _ _)) = True
764 765 766 767 768 769 770 771 772
        installedDocs _                                            = False
        isSpecificPackageDB (SpecificPackageDB _) = True
        isSpecificPackageDB _                     = False

    substHaddockIndexFileName defaultDirs = fromPathTemplate
                                          . substPathTemplate env
      where
        env  = env0 ++ installDirsTemplateEnv absoluteDirs
        env0 = InstallDirs.compilerTemplateEnv (compilerId comp)
773
            ++ InstallDirs.platformTemplateEnv platform
774 775 776 777 778 779
        absoluteDirs = InstallDirs.substituteInstallDirTemplates
                         env0 templateDirs
        templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault
                         defaultDirs (configInstallDirs configFlags)


780
symlinkBinaries :: Verbosity
781
                -> ConfigFlags
782
                -> InstallFlags
783
                -> InstallPlan -> IO ()
784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803
symlinkBinaries verbosity configFlags installFlags plan = do
  failed <- InstallSymlink.symlinkBinaries configFlags installFlags plan
  case failed of
    [] -> return ()
    [(_, exe, path)] ->
      warn verbosity $
           "could not create a symlink in " ++ bindir ++ " for "
        ++ exe ++ " because the file exists there already but is not "
        ++ "managed by cabal. You can create a symlink for this executable "
        ++ "manually if you wish. The executable file has been installed at "
        ++ path
    exes ->
      warn verbosity $
           "could not create symlinks in " ++ bindir ++ " for "
        ++ intercalate ", " [ exe | (_, exe, _) <- exes ]
        ++ " because the files exist there already and are not "
        ++ "managed by cabal. You can create symlinks for these executables "
        ++ "manually if you wish. The executable files have been installed at "
        ++ intercalate ", " [ path | (_, _, path) <- exes ]
  where
804
    bindir = fromFlag (installSymlinkBinDir installFlags)
805

806

807
printBuildFailures :: InstallPlan -> IO ()
808 809 810 811 812 813 814 815 816 817 818 819
printBuildFailures plan =
  case [ (pkg, reason)
       | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of
    []     -> return ()
    failed -> die . unlines
            $ "Error: some packages failed to install:"
            : [ display (packageId pkg) ++ printFailureReason reason
              | (pkg, reason) <- failed ]
  where
    printFailureReason reason = case reason of
      DependentFailed pkgid -> " depends on " ++ display pkgid
                            ++ " which failed to install."
820
      DownloadFailed  e -> " failed while downloading the package."
821
                        ++ showException e
822
      UnpackFailed    e -> " failed while unpacking the package."
823
                        ++ showException e
824
      ConfigureFailed e -> " failed during the configure step."
825
                        ++ showException e
826
      BuildFailed     e -> " failed during the building phase."
827
                        ++ showException e
828
      TestsFailed     e -> " failed during the tests phase."
829
                        ++ showException e
830
      InstallFailed   e -> " failed during the final install step."
831 832 833 834 835 836 837 838 839 840 841 842
                        ++ showException e

    showException e   =  " The exception was:\n  " ++ show e ++ maybeOOM e
#ifdef mingw32_HOST_OS
    maybeOOM _        = ""
#else
    maybeOOM e                    = maybe "" onExitFailure (fromException e)
    onExitFailure (ExitFailure 9) =
      "\nThis may be due to an out-of-memory condition."
    onExitFailure _               = ""
#endif

843

844 845 846
-- | If we're working inside a sandbox and some add-source deps were installed,
-- update the timestamps of those deps.
updateSandboxTimestampsFile :: UseSandbox -> Maybe SandboxPackageInfo
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
847 848
                            -> Compiler -> Platform -> InstallPlan
                            -> IO ()
849 850 851 852 853 854
updateSandboxTimestampsFile (UseSandbox sandboxDir)
                            (Just (SandboxPackageInfo _ _ _ allAddSourceDeps))
                            comp platform installPlan =
  withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do
    let allInstalled = [ pkg | InstallPlan.Installed pkg _
                            <- InstallPlan.toList installPlan ]
855
        allSrcPkgs   = [ pkg | ReadyPackage pkg _ _ _ <- allInstalled ]
856 857 858 859 860 861
        allPaths     = [ pth | LocalUnpackedPackage pth
                            <- map packageSource allSrcPkgs]
    allPathsCanonical <- mapM tryCanonicalizePath allPaths
    return $! filter (`S.member` allAddSourceDeps) allPathsCanonical

updateSandboxTimestampsFile _ _ _ _ _ = return ()
Duncan Coutts's avatar