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

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

151 152 153 154 155 156 157 158 159 160 161
--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
162

163 164 165 166 167 168
-- ------------------------------------------------------------
-- * Top level user actions
-- ------------------------------------------------------------

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

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

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

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

Ian D. Bollinger's avatar
Ian D. Bollinger committed
210
-- TODO: Make InstallContext a proper data type with documented fields.
211 212 213 214
-- | Common context for makeInstallPlan and processInstallPlan.
type InstallContext = ( PackageIndex, SourcePackageDb
                      , [UserTarget], [PackageSpecifier SourcePackage] )

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

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

238 239
    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
    sourcePkgDb       <- getSourcePackages    verbosity repos
240

241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257
    (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)
258 259

    return (installedPkgIndex, sourcePkgDb, userTargets, pkgSpecifiers)
260

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

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

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

289
    unless (dryRun || nothingToInstall) $ do
290
      installPlan' <- performInstallations verbosity
291 292
                      args installedPkgIndex installPlan
      postInstallActions verbosity args userTargets installPlan'
293
  where
294
    dryRun = fromFlag (installDryRun installFlags)
295
    nothingToInstall = null (InstallPlan.ready installPlan)
296

297 298 299
-- ------------------------------------------------------------
-- * Installation planning
-- ------------------------------------------------------------
300

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

316
        resolveDependencies
317
          platform (compilerId comp)
318
          solver
319
          resolverParams
320

321
    >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return
322

323 324 325
  where
    resolverParams =

Andres Löh's avatar
Andres Löh committed
326 327 328
        setMaxBackjumps (if maxBackjumps < 0 then Nothing
                                             else Just maxBackjumps)

329 330
      . setIndependentGoals independentGoals

Andres Löh's avatar
Andres Löh committed
331
      . setReorderGoals reorderGoals
Andres Löh's avatar
Andres Löh committed
332 333

      . setAvoidReinstalls avoidReinstalls
334

335 336
      . setShadowPkgs shadowPkgs

Andres Löh's avatar
Andres Löh committed
337 338
      . setStrongFlags strongFlags

339
      . setPreferenceDefault (if upgradeDeps then PreferAllLatest
340 341
                                             else PreferLatestForSelected)

342
      . removeUpperBounds allowNewer
343

344 345 346 347 348 349 350
      . 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
351
            (map userToPackageConstraint (configExConstraints configExFlags))
352 353 354 355

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

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

365 366
      . maybe id applySandboxInstallPolicy mSandboxPkgInfo

367 368
      . (if reinstall then reinstallTargets else id)

369
      $ standardInstallPolicy
370
        installedPkgIndex sourcePkgDb pkgSpecifiers
371

372 373 374 375
    stanzas = concat
        [ if testsEnabled then [TestStanzas] else []
        , if benchmarksEnabled then [BenchStanzas] else []
        ]
376
    testsEnabled = fromFlagOrDefault False $ configTests configFlags
377
    benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags
378

379 380 381 382
    reinstall        = fromFlag (installReinstall        installFlags)
    reorderGoals     = fromFlag (installReorderGoals     installFlags)
    independentGoals = fromFlag (installIndependentGoals installFlags)
    avoidReinstalls  = fromFlag (installAvoidReinstalls  installFlags)
383
    shadowPkgs       = fromFlag (installShadowPkgs       installFlags)
Andres Löh's avatar
Andres Löh committed
384
    strongFlags      = fromFlag (installStrongFlags      installFlags)
385 386 387
    maxBackjumps     = fromFlag (installMaxBackjumps     installFlags)
    upgradeDeps      = fromFlag (installUpgradeDeps      installFlags)
    onlyDeps         = fromFlag (installOnlyDeps         installFlags)
388
    allowNewer       = fromFlag (configAllowNewer        configExFlags)
389

390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417
-- | 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

418 419 420 421
-- ------------------------------------------------------------
-- * Informational messages
-- ------------------------------------------------------------

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

434 435 436 437 438 439 440 441
  -- 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.
442
  when nothingToInstall $
443 444 445 446
    notice verbosity $ unlines $
         "All the requested packages are already installed:"
       : map (display . packageId) preExistingTargets
      ++ ["Use --reinstall if you want to reinstall anyway."]
447

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

  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) $
474 475
    printPlan (dryRun || breaksPkgs && not overrideReinstall)
      adaptedVerbosity lPlan sourcePkgDb
476

477 478 479 480 481 482 483 484
  -- 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:"
485
          : map (display . Installed.sourcePackageId) newBrokenPkgs
486 487 488 489 490 491 492
          ++ 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..."
493 494 495

  where
    nothingToInstall = null (InstallPlan.ready installPlan)
496 497

    dryRun            = fromFlag (installDryRun            installFlags)
498
    overrideReinstall = fromFlag (installOverrideReinstall installFlags)
499

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

520 521
data PackageStatus = NewPackage
                   | NewVersion [Version]
522
                   | Reinstall  [InstalledPackageId] [PackageChange]
523 524 525

type PackageChange = MergeResult PackageIdentifier PackageIdentifier

526 527 528
extractReinstalls :: PackageStatus -> [InstalledPackageId]
extractReinstalls (Reinstall ipids _) = ipids
extractReinstalls _                   = []
529

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

  where

    changes :: Installed.InstalledPackageInfo
544
            -> ReadyPackage
545
            -> [MergeResult PackageIdentifier PackageIdentifier]
refold's avatar
refold committed
546 547 548 549 550 551 552 553 554 555 556
    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')
557 558 559 560

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

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

580 581 582
    showPkg (pkg, _) = display (packageId pkg) ++
                       showLatest (pkg)

583
    showPkgAndReason (pkg', pr) = display (packageId pkg') ++
584
          showLatest pkg' ++
585 586
          showFlagAssignment (nonDefaultFlags pkg') ++
          showStanzas (stanzas pkg') ++ " " ++
587
          case pr of
588 589 590
            NewPackage     -> "(new package)"
            NewVersion _   -> "(new version)"
            Reinstall _ cs -> "(reinstall)" ++ case cs of
591 592 593
                []   -> ""
                diff -> " changes: "  ++ intercalate ", " (map change diff)

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

610 611 612
    toFlagAssignment :: [Flag] -> FlagAssignment
    toFlagAssignment = map (\ f -> (flagName f, flagDefault f))

613 614
    nonDefaultFlags :: ReadyPackage -> FlagAssignment
    nonDefaultFlags (ReadyPackage spkg fa _ _) =
615 616 617 618 619
      let defaultAssignment =
            toFlagAssignment
             (genPackageFlags (Source.packageDescription spkg))
      in  fa \\ defaultAssignment

620 621
    stanzas :: ReadyPackage -> [OptionalStanza]
    stanzas (ReadyPackage _ _ sts _) = sts
622 623 624 625 626 627

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

628
    -- FIXME: this should be a proper function in a proper place
629
    showFlagAssignment :: FlagAssignment -> String
630 631 632 633 634
    showFlagAssignment = concatMap ((' ' :) . showFlagValue)
    showFlagValue (f, True)   = '+' : showFlagName f
    showFlagValue (f, False)  = '-' : showFlagName f
    showFlagName (FlagName f) = f

635 636 637 638 639
    change (OnlyInLeft pkgid)        = display pkgid ++ " removed"
    change (InBoth     pkgid pkgid') = display pkgid ++ " -> "
                                    ++ display (packageVersion pkgid')
    change (OnlyInRight      pkgid') = display pkgid' ++ " added"

640 641 642 643 644 645 646 647 648 649
-- ------------------------------------------------------------
-- * 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
650
--  * updating world file
651 652 653
--  * error reporting
--
postInstallActions :: Verbosity
654
                   -> InstallArgs
655
                   -> [UserTarget]
656 657 658
                   -> InstallPlan
                   -> IO ()
postInstallActions verbosity
659 660
  (packageDBs, _, comp, platform, conf, useSandbox, mSandboxPkgInfo
  ,globalFlags, configFlags, _, installFlags, _)
661
  targets installPlan = do
662

663
  unless oneShot $
664
    World.insert verbosity worldFile
665 666 667
      --FIXME: does not handle flags
      [ World.WorldPkgInfo dep []
      | UserTargetNamed dep <- targets ]
668

669
  let buildReports = BuildReports.fromInstallPlan installPlan
refold's avatar
refold committed
670 671
  BuildReports.storeLocal (installSummaryFile installFlags) buildReports
    (InstallPlan.planPlatform installPlan)
672 673 674 675 676
  when (reportingLevel >= AnonymousReports) $
    BuildReports.storeAnonymous buildReports
  when (reportingLevel == DetailedReports) $
    storeDetailedBuildReports verbosity logsDir buildReports

677
  regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox
678 679 680 681 682 683
                         configFlags installFlags installPlan

  symlinkBinaries verbosity configFlags installFlags installPlan

  printBuildFailures installPlan

684 685 686
  updateSandboxTimestampsFile useSandbox mSandboxPkgInfo
                              comp platform installPlan

687 688
  where
    reportingLevel = fromFlag (installBuildReports installFlags)
689
    logsDir        = fromFlag (globalLogsDir globalFlags)
690 691
    oneShot        = fromFlag (installOneShot installFlags)
    worldFile      = fromFlag $ globalWorldFile globalFlags
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 723 724 725 726 727 728

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
729
                       -> Platform
730
                       -> ProgramConfiguration
731
                       -> UseSandbox
732 733 734 735
                       -> ConfigFlags
                       -> InstallFlags
                       -> InstallPlan
                       -> IO ()
736
regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox
737 738 739 740 741 742 743 744 745 746 747 748 749 750
                       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
751 752
  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
  Haddock.regenerateHaddockIndex verbosity installedPkgIndex conf indexFile
753 754 755 756 757 758 759 760

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

    -- We want to regenerate the index if some new documentation was actually
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
761 762 763 764
    -- installed. Since the index can be only per-user or per-sandbox (see
    -- #1337), we don't do it for global installs or special cases where we're
    -- installing into a specific db.
    shouldRegenerateHaddockIndex = (isUseSandbox useSandbox || normalUserInstall)
765 766 767 768 769 770
                                && someDocsWereInstalled installPlan
      where
        someDocsWereInstalled = any installedDocs . InstallPlan.toList
        normalUserInstall     = (UserPackageDB `elem` packageDBs)
                             && all (not . isSpecificPackageDB) packageDBs

771
        installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _ _)) = True
772 773 774 775 776 777 778 779 780
        installedDocs _                                            = False
        isSpecificPackageDB (SpecificPackageDB _) = True
        isSpecificPackageDB _                     = False

    substHaddockIndexFileName defaultDirs = fromPathTemplate
                                          . substPathTemplate env
      where
        env  = env0 ++ installDirsTemplateEnv absoluteDirs
        env0 = InstallDirs.compilerTemplateEnv (compilerId comp)
781
            ++ InstallDirs.platformTemplateEnv platform
782 783 784 785 786 787
        absoluteDirs = InstallDirs.substituteInstallDirTemplates
                         env0 templateDirs
        templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault
                         defaultDirs (configInstallDirs configFlags)


788
symlinkBinaries :: Verbosity
789
                -> ConfigFlags
790
                -> InstallFlags
791
                -> InstallPlan -> IO ()
792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811
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
812
    bindir = fromFlag (installSymlinkBinDir installFlags)
813

814

815
printBuildFailures :: InstallPlan -> IO ()
816 817 818 819 820 821 822 823 824 825 826 827
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."
828
      DownloadFailed  e -> " failed while downloading the package."
829
                        ++ showException e
830
      UnpackFailed    e -> " failed while unpacking the package."
831
                        ++ showException e
832
      ConfigureFailed e -> " failed during the configure step."
833
                        ++ showException e
834
      BuildFailed     e -> " failed during the building phase."
835
                        ++ showException e
836
      TestsFailed     e -> " failed during the tests phase."
837
                        ++ showException e
838
      InstallFailed   e -> " failed during the final install step."
839 840 841 842 843 844 845
                        ++ showException e

    showException e   =  " The exception was:\n  " ++ show e ++ maybeOOM e
#ifdef mingw32_HOST_OS
    maybeOOM _        = ""
#else
    maybeOOM e                    = maybe "" onExitFailure (fromException e)