Install.hs 63.2 KB
Newer Older
1
{-# LANGUAGE CPP #-}
2

3 4
-----------------------------------------------------------------------------
-- |
5
-- Module      :  Distribution.Client.Install
6 7 8
-- Copyright   :  (c) 2005 David Himmelstrup
--                    2007 Bjorn Bringert
--                    2007-2010 Duncan Coutts
9 10
-- License     :  BSD-like
--
11
-- Maintainer  :  cabal-devel@haskell.org
12 13 14 15 16
-- Stability   :  provisional
-- Portability :  portable
--
-- High level interface to package installation.
-----------------------------------------------------------------------------
17
module Distribution.Client.Install (
18 19 20 21 22 23 24 25 26 27 28 29
    -- * 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
30
  ) where
31

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

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

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

154 155 156 157 158 159 160 161 162 163 164
--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
165

166 167 168 169 170 171
-- ------------------------------------------------------------
-- * Top level user actions
-- ------------------------------------------------------------

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

192
    installContext <- makeInstallContext verbosity args (Just userTargets0)
193
    planResult     <- foldProgress logMsg (return . Left) (return . Right) =<<
194 195
                      makeInstallPlan verbosity args installContext

196 197
    case planResult of
        Left message -> do
198
            reportPlanningFailure verbosity args installContext message
199 200 201
            die' message
        Right installPlan ->
            processInstallPlan verbosity args installContext installPlan
202 203
  where
    args :: InstallArgs
204
    args = (packageDBs, repos, comp, platform, conf, useSandbox, mSandboxPkgInfo,
205 206 207
            globalFlags, configFlags, configExFlags, installFlags,
            haddockFlags)

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
208 209 210 211
    die' message = die (message ++ if isUseSandbox useSandbox
                                   then installFailedInSandbox else [])
    -- TODO: use a better error message, remove duplication.
    installFailedInSandbox =
212 213 214 215
      "\nNote: when using a sandbox, all packages are required to have "
      ++ "consistent dependencies. "
      ++ "Try reinstalling/unregistering the offending packages or "
      ++ "recreating the sandbox."
216 217
    logMsg message rest = debugNoWrap verbosity message >> rest

Ian D. Bollinger's avatar
Ian D. Bollinger committed
218
-- TODO: Make InstallContext a proper data type with documented fields.
219
-- | Common context for makeInstallPlan and processInstallPlan.
220
type InstallContext = ( InstalledPackageIndex, SourcePackageDb
221 222
                      , [UserTarget], [PackageSpecifier SourcePackage] )

Ian D. Bollinger's avatar
Ian D. Bollinger committed
223
-- TODO: Make InstallArgs a proper data type with documented fields or just get
refold's avatar
refold committed
224
-- rid of it completely.
225 226 227 228
-- | Initial arguments given to 'install' or 'makeInstallContext'.
type InstallArgs = ( PackageDBStack
                   , [Repo]
                   , Compiler
229
                   , Platform
230
                   , ProgramConfiguration
231
                   , UseSandbox
232
                   , Maybe SandboxPackageInfo
233 234 235 236 237 238 239
                   , GlobalFlags
                   , ConfigFlags
                   , ConfigExFlags
                   , InstallFlags
                   , HaddockFlags )

-- | Make an install context given install arguments.
240
makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]
241 242
                      -> IO InstallContext
makeInstallContext verbosity
243
  (packageDBs, repos, comp, _, conf,_,_,
244
   globalFlags, _, _, _, _) mUserTargets = do
245

246 247
    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
    sourcePkgDb       <- getSourcePackages    verbosity repos
248

249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265
    (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)
266 267

    return (installedPkgIndex, sourcePkgDb, userTargets, pkgSpecifiers)
268

269 270 271 272
-- | Make an install plan given install context and install arguments.
makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext
                -> IO (Progress String String InstallPlan)
makeInstallPlan verbosity
273
  (_, _, comp, platform, _, _, mSandboxPkgInfo,
274 275 276 277 278 279 280
   _, configFlags, configExFlags, installFlags,
   _)
  (installedPkgIndex, sourcePkgDb,
   _, pkgSpecifiers) = do

    solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags))
              (compilerId comp)
281
    notice verbosity "Resolving dependencies..."
282 283 284
    return $ planPackages comp platform mSandboxPkgInfo solver
      configFlags configExFlags installFlags
      installedPkgIndex sourcePkgDb pkgSpecifiers
285

286 287 288 289 290
-- | Given an install plan, perform the actual installations.
processInstallPlan :: Verbosity -> InstallArgs -> InstallContext
                   -> InstallPlan
                   -> IO ()
processInstallPlan verbosity
291
  args@(_,_, comp, _, _, _, _, _, _, _, installFlags, _)
292 293
  (installedPkgIndex, sourcePkgDb,
   userTargets, pkgSpecifiers) installPlan = do
294
    checkPrintPlan verbosity comp installedPkgIndex installPlan sourcePkgDb
295
      installFlags pkgSpecifiers
296

297
    unless (dryRun || nothingToInstall) $ do
298
      installPlan' <- performInstallations verbosity
299 300
                      args installedPkgIndex installPlan
      postInstallActions verbosity args userTargets installPlan'
301
  where
302
    dryRun = fromFlag (installDryRun installFlags)
303
    nothingToInstall = null (InstallPlan.ready installPlan)
304

305 306 307
-- ------------------------------------------------------------
-- * Installation planning
-- ------------------------------------------------------------
308

309
planPackages :: Compiler
310
             -> Platform
311
             -> Maybe SandboxPackageInfo
312
             -> Solver
313 314 315
             -> ConfigFlags
             -> ConfigExFlags
             -> InstallFlags
316
             -> InstalledPackageIndex
317 318
             -> SourcePackageDb
             -> [PackageSpecifier SourcePackage]
319
             -> Progress String String InstallPlan
320 321
planPackages comp platform mSandboxPkgInfo solver
             configFlags configExFlags installFlags
322
             installedPkgIndex sourcePkgDb pkgSpecifiers =
323

324
        resolveDependencies
325
          platform (compilerId comp)
326
          solver
327
          resolverParams
328

329
    >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return
330

331 332 333
  where
    resolverParams =

Andres Löh's avatar
Andres Löh committed
334 335 336
        setMaxBackjumps (if maxBackjumps < 0 then Nothing
                                             else Just maxBackjumps)

337 338
      . setIndependentGoals independentGoals

Andres Löh's avatar
Andres Löh committed
339
      . setReorderGoals reorderGoals
Andres Löh's avatar
Andres Löh committed
340 341

      . setAvoidReinstalls avoidReinstalls
342

343 344
      . setShadowPkgs shadowPkgs

Andres Löh's avatar
Andres Löh committed
345 346
      . setStrongFlags strongFlags

347
      . setPreferenceDefault (if upgradeDeps then PreferAllLatest
348 349
                                             else PreferLatestForSelected)

350
      . removeUpperBounds allowNewer
351

352 353 354 355 356 357 358
      . 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
359
            (map userToPackageConstraint (configExConstraints configExFlags))
360 361 362 363

      . addConstraints
          --FIXME: this just applies all flags to all targets which
          -- is silly. We should check if the flags are appropriate
364
          [ PackageConstraintFlags (pkgSpecifierTarget pkgSpecifier) flags
365 366
          | let flags = configConfigurationsFlags configFlags
          , not (null flags)
367 368 369 370 371
          , pkgSpecifier <- pkgSpecifiers ]

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

373 374
      . maybe id applySandboxInstallPolicy mSandboxPkgInfo

375 376
      . (if reinstall then reinstallTargets else id)

377
      $ standardInstallPolicy
378
        installedPkgIndex sourcePkgDb pkgSpecifiers
379

380 381 382 383
    stanzas = concat
        [ if testsEnabled then [TestStanzas] else []
        , if benchmarksEnabled then [BenchStanzas] else []
        ]
384
    testsEnabled = fromFlagOrDefault False $ configTests configFlags
385
    benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags
386

387 388 389 390
    reinstall        = fromFlag (installReinstall        installFlags)
    reorderGoals     = fromFlag (installReorderGoals     installFlags)
    independentGoals = fromFlag (installIndependentGoals installFlags)
    avoidReinstalls  = fromFlag (installAvoidReinstalls  installFlags)
391
    shadowPkgs       = fromFlag (installShadowPkgs       installFlags)
Andres Löh's avatar
Andres Löh committed
392
    strongFlags      = fromFlag (installStrongFlags      installFlags)
393 394 395
    maxBackjumps     = fromFlag (installMaxBackjumps     installFlags)
    upgradeDeps      = fromFlag (installUpgradeDeps      installFlags)
    onlyDeps         = fromFlag (installOnlyDeps         installFlags)
396
    allowNewer       = fromFlag (configAllowNewer        configExFlags)
397

398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425
-- | 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

426 427 428 429
-- ------------------------------------------------------------
-- * Informational messages
-- ------------------------------------------------------------

430 431
-- | Perform post-solver checks of the install plan and print it if
-- either requested or needed.
432
checkPrintPlan :: Verbosity
433
               -> Compiler
434
               -> InstalledPackageIndex
435
               -> InstallPlan
436
               -> SourcePackageDb
437
               -> InstallFlags
438
               -> [PackageSpecifier SourcePackage]
439
               -> IO ()
440
checkPrintPlan verbosity comp installed installPlan sourcePkgDb
441
  installFlags pkgSpecifiers = do
442

443 444 445 446 447 448 449 450
  -- 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.
451
  when nothingToInstall $
452 453 454 455
    notice verbosity $ unlines $
         "All the requested packages are already installed:"
       : map (display . packageId) preExistingTargets
      ++ ["Use --reinstall if you want to reinstall anyway."]
456

457
  let lPlan = linearizeInstallPlan comp installed installPlan
458 459
  -- Are any packages classified as reinstalls?
  let reinstalledPkgs = concatMap (extractReinstalls . snd) lPlan
460 461 462 463 464 465 466 467
  -- Packages that are already broken.
  let oldBrokenPkgs =
          map Installed.installedPackageId
        . PackageIndex.reverseDependencyClosure installed
        . map (Installed.installedPackageId . fst)
        . PackageIndex.brokenPackages
        $ installed
  let excluded = reinstalledPkgs ++ oldBrokenPkgs
468
  -- Packages that are reverse dependencies of replaced packages are very
469 470 471
  -- likely to be broken. We exclude packages that are already broken.
  let newBrokenPkgs =
        filter (\ p -> not (Installed.installedPackageId p `elem` excluded))
472 473
               (PackageIndex.reverseDependencyClosure installed reinstalledPkgs)
  let containsReinstalls = not (null reinstalledPkgs)
474
  let breaksPkgs         = not (null newBrokenPkgs)
475 476 477 478 479 480 481 482

  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) $
483 484
    printPlan (dryRun || breaksPkgs && not overrideReinstall)
      adaptedVerbosity lPlan sourcePkgDb
485

486 487 488 489 490 491 492 493
  -- 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:"
494
          : map (display . Installed.sourcePackageId) newBrokenPkgs
495 496 497 498 499 500 501
          ++ 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..."
502 503 504

  where
    nothingToInstall = null (InstallPlan.ready installPlan)
505 506

    dryRun            = fromFlag (installDryRun            installFlags)
507
    overrideReinstall = fromFlag (installOverrideReinstall installFlags)
508

509
linearizeInstallPlan :: Compiler
510
                     -> InstalledPackageIndex
511
                     -> InstallPlan
512
                     -> [(ReadyPackage, PackageStatus)]
513
linearizeInstallPlan comp installedPkgIndex plan =
514
    unfoldr next plan
515 516 517
  where
    next plan' = case InstallPlan.ready plan' of
      []      -> Nothing
518
      (pkg:_) -> Just ((pkg, status), plan'')
519
        where
520
          pkgid  = installedPackageId pkg
521
          status = packageStatus comp installedPkgIndex pkg
522
          plan'' = InstallPlan.completed pkgid
523 524
                     (BuildOk DocsNotTried TestsNotTried
                              (Just $ Installed.emptyInstalledPackageInfo
525 526
                              { Installed.sourcePackageId = packageId pkg
                              , Installed.installedPackageId = pkgid }))
527 528 529
                     (InstallPlan.processing [pkg] plan')
          --FIXME: This is a bit of a hack,
          -- pretending that each package is installed
530 531
          -- It's doubly a hack because the installed package ID
          -- didn't get updated...
532

533 534
data PackageStatus = NewPackage
                   | NewVersion [Version]
535
                   | Reinstall  [InstalledPackageId] [PackageChange]
536 537 538

type PackageChange = MergeResult PackageIdentifier PackageIdentifier

539 540 541
extractReinstalls :: PackageStatus -> [InstalledPackageId]
extractReinstalls (Reinstall ipids _) = ipids
extractReinstalls _                   = []
542

543
packageStatus :: Compiler -> InstalledPackageIndex -> ReadyPackage -> PackageStatus
544
packageStatus _comp installedPkgIndex cpkg =
545 546 547
  case PackageIndex.lookupPackageName installedPkgIndex
                                      (packageName cpkg) of
    [] -> NewPackage
548
    ps ->  case filter ((== packageId cpkg)
refold's avatar
refold committed
549
                        . Installed.sourcePackageId) (concatMap snd ps) of
550 551 552
      []           -> NewVersion (map fst ps)
      pkgs@(pkg:_) -> Reinstall (map Installed.installedPackageId pkgs)
                                (changes pkg cpkg)
553 554 555 556

  where

    changes :: Installed.InstalledPackageInfo
557
            -> ReadyPackage
558
            -> [MergeResult PackageIdentifier PackageIdentifier]
refold's avatar
refold committed
559 560 561 562 563 564 565 566 567 568 569
    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')
570 571 572 573

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

574 575
printPlan :: Bool -- is dry run
          -> Verbosity
576
          -> [(ReadyPackage, PackageStatus)]
577
          -> SourcePackageDb
578
          -> IO ()
579
printPlan dryRun verbosity plan sourcePkgDb = case plan of
580 581 582
  []   -> return ()
  pkgs
    | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $
583
        ("In order, the following " ++ wouldWill ++ " be installed:")
584 585
      : map showPkgAndReason pkgs
    | otherwise -> notice verbosity $ unlines $
refold's avatar
refold committed
586 587
        ("In order, the following " ++ wouldWill
         ++ " be installed (use -v for more details):")
588
      : map showPkg pkgs
589
  where
590 591 592
    wouldWill | dryRun    = "would"
              | otherwise = "will"

593 594 595
    showPkg (pkg, _) = display (packageId pkg) ++
                       showLatest (pkg)

596
    showPkgAndReason (pkg', pr) = display (packageId pkg') ++
597
          showLatest pkg' ++
598 599
          showFlagAssignment (nonDefaultFlags pkg') ++
          showStanzas (stanzas pkg') ++ " " ++
600
          case pr of
601 602 603
            NewPackage     -> "(new package)"
            NewVersion _   -> "(new version)"
            Reinstall _ cs -> "(reinstall)" ++ case cs of
604 605 606
                []   -> ""
                diff -> " changes: "  ++ intercalate ", " (map change diff)

607
    showLatest :: ReadyPackage -> String
608 609
    showLatest pkg = case mLatestVersion of
        Just latestVersion ->
Chris Wong's avatar
Chris Wong committed
610
            if packageVersion pkg < latestVersion
611 612 613
            then (" (latest: " ++ display latestVersion ++ ")")
            else ""
        Nothing -> ""
614
      where
615 616 617 618 619 620
        mLatestVersion :: Maybe Version
        mLatestVersion = case SourcePackageIndex.lookupPackageName
                                (packageIndex sourcePkgDb)
                                (packageName pkg) of
            [] -> Nothing
            x -> Just $ packageVersion $ last x
621

622 623 624
    toFlagAssignment :: [Flag] -> FlagAssignment
    toFlagAssignment = map (\ f -> (flagName f, flagDefault f))

625 626
    nonDefaultFlags :: ReadyPackage -> FlagAssignment
    nonDefaultFlags (ReadyPackage spkg fa _ _) =
627 628 629 630 631
      let defaultAssignment =
            toFlagAssignment
             (genPackageFlags (Source.packageDescription spkg))
      in  fa \\ defaultAssignment

632 633
    stanzas :: ReadyPackage -> [OptionalStanza]
    stanzas (ReadyPackage _ _ sts _) = sts
634 635 636 637 638 639

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

640
    -- FIXME: this should be a proper function in a proper place
641
    showFlagAssignment :: FlagAssignment -> String
642 643 644 645 646
    showFlagAssignment = concatMap ((' ' :) . showFlagValue)
    showFlagValue (f, True)   = '+' : showFlagName f
    showFlagValue (f, False)  = '-' : showFlagName f
    showFlagName (FlagName f) = f

647 648 649 650 651
    change (OnlyInLeft pkgid)        = display pkgid ++ " removed"
    change (InBoth     pkgid pkgid') = display pkgid ++ " -> "
                                    ++ display (packageVersion pkgid')
    change (OnlyInRight      pkgid') = display pkgid' ++ " added"

652 653 654 655
-- ------------------------------------------------------------
-- * Post installation stuff
-- ------------------------------------------------------------

656 657
-- | Report a solver failure. This works slightly differently to
-- 'postInstallActions', as (by definition) we don't have an install plan.
658
reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String -> IO ()
659
reportPlanningFailure verbosity
660
  (_, _, comp, platform, _, _, _
661
  ,_, configFlags, _, installFlags, _)
662 663
  (_, sourcePkgDb, _, pkgSpecifiers)
  message = do
664 665 666 667 668 669 670 671 672

  when reportFailure $ do

    -- Only create reports for explicitly named packages
    let pkgids =
          filter (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb)) $
          mapMaybe theSpecifiedPackage pkgSpecifiers

        buildReports = BuildReports.fromPlanningFailure platform (compilerId comp)
673
          pkgids (configConfigurationsFlags configFlags)
674 675

    when (not (null buildReports)) $
676 677
      info verbosity $
        "Solver failure will be reported for "
678 679 680 681 682
        ++ intercalate "," (map display pkgids)

    -- Save reports
    BuildReports.storeLocal (installSummaryFile installFlags) buildReports platform

683 684 685 686
    -- Save solver log
    case logFile of
      Nothing -> return ()
      Just template -> forM_ pkgids $ \pkgid ->
687 688
        let env = initialPathTemplateEnv pkgid dummyPackageKey
                    (compilerId comp) platform
689 690 691
            path = fromPathTemplate $ substPathTemplate env template
        in  writeFile path message

692 693
  where
    reportFailure = fromFlag (installReportPlanningFailure installFlags)
694
    logFile = flagToMaybe (installLogFile installFlags)
695

696 697 698 699 700
    -- A PackageKey is calculated from the transitive closure of
    -- dependencies, but when the solver fails we don't have that.
    -- So we fail.
    dummyPackageKey = error "reportPlanningFailure: package key not available"

701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719
-- | If a 'PackageSpecifier' refers to a single package, return Just that package.
theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId
theSpecifiedPackage pkgSpec =
  case pkgSpec of
    NamedPackage name [PackageConstraintVersion name' version]
      | name == name' -> PackageIdentifier name <$> trivialRange version
    NamedPackage _ _ -> Nothing
    SpecificSourcePackage pkg -> Just $ packageId pkg
  where
    -- | If a range includes only a single version, return Just that version.
    trivialRange :: VersionRange -> Maybe Version
    trivialRange = foldVersionRange
        Nothing
        Just     -- "== v"
        (\_ -> Nothing)
        (\_ -> Nothing)
        (\_ _ -> Nothing)
        (\_ _ -> Nothing)

720 721 722 723 724 725
-- | Various stuff we do after successful or unsuccessfully installing a bunch
-- of packages. This includes:
--
--  * build reporting, local and remote
--  * symlinking binaries
--  * updating indexes
726
--  * updating world file
727 728 729
--  * error reporting
--
postInstallActions :: Verbosity
730
                   -> InstallArgs
731
                   -> [UserTarget]
732 733 734
                   -> InstallPlan
                   -> IO ()
postInstallActions verbosity
735 736
  (packageDBs, _, comp, platform, conf, useSandbox, mSandboxPkgInfo
  ,globalFlags, configFlags, _, installFlags, _)
737
  targets installPlan = do
738

739
  unless oneShot $
740
    World.insert verbosity worldFile
741 742 743
      --FIXME: does not handle flags
      [ World.WorldPkgInfo dep []
      | UserTargetNamed dep <- targets ]
744

745
  let buildReports = BuildReports.fromInstallPlan installPlan
refold's avatar
refold committed
746 747
  BuildReports.storeLocal (installSummaryFile installFlags) buildReports
    (InstallPlan.planPlatform installPlan)
748 749 750 751 752
  when (reportingLevel >= AnonymousReports) $
    BuildReports.storeAnonymous buildReports
  when (reportingLevel == DetailedReports) $
    storeDetailedBuildReports verbosity logsDir buildReports

753
  regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox
754 755
                         configFlags installFlags installPlan

756
  symlinkBinaries verbosity comp configFlags installFlags installPlan
757 758 759

  printBuildFailures installPlan

760 761 762
  updateSandboxTimestampsFile useSandbox mSandboxPkgInfo
                              comp platform installPlan

763 764
  where
    reportingLevel = fromFlag (installBuildReports installFlags)
765
    logsDir        = fromFlag (globalLogsDir globalFlags)
766 767
    oneShot        = fromFlag (installOneShot installFlags)
    worldFile      = fromFlag $ globalWorldFile globalFlags
768 769

storeDetailedBuildReports :: Verbosity -> FilePath
770
                          -> [(BuildReports.BuildReport, Maybe Repo)] -> IO ()
771 772 773 774 775 776 777 778 779 780 781 782
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))

783
  | (report, Just Repo { repoKind = Left remoteRepo }) <- reports
784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804
  , 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