Install.hs 61.6 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, mapMaybe, 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 48
import Control.Applicative
         ( (<$>) )
49
import Control.Monad
50
         ( when, unless )
51
import System.Directory
52 53
         ( getTemporaryDirectory, doesDirectoryExist, doesFileExist,
           createDirectoryIfMissing, removeFile, renameDirectory )
Duncan Coutts's avatar
Duncan Coutts committed
54
import System.FilePath
55
         ( (</>), (<.>), equalFilePath, takeDirectory )
Duncan Coutts's avatar
Duncan Coutts committed
56
import System.IO
57
         ( openFile, IOMode(AppendMode), hClose )
58 59
import System.IO.Error
         ( isDoesNotExistError, ioeGetFileName )
bjorn@bringert.net's avatar
bjorn@bringert.net committed
60

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

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

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

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

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

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

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

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

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

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

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

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

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

    return (installedPkgIndex, sourcePkgDb, userTargets, pkgSpecifiers)
267

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

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

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

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

304 305 306
-- ------------------------------------------------------------
-- * Installation planning
-- ------------------------------------------------------------
307

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

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

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

330 331 332
  where
    resolverParams =

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

336 337
      . setIndependentGoals independentGoals

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

      . setAvoidReinstalls avoidReinstalls
341

342 343
      . setShadowPkgs shadowPkgs

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

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

349
      . removeUpperBounds allowNewer
350

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

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

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

372 373
      . maybe id applySandboxInstallPolicy mSandboxPkgInfo

374 375
      . (if reinstall then reinstallTargets else id)

376
      $ standardInstallPolicy
377
        installedPkgIndex sourcePkgDb pkgSpecifiers
378

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

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

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
-- | 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

425 426 427 428
-- ------------------------------------------------------------
-- * Informational messages
-- ------------------------------------------------------------

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

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

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

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

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

  where
    nothingToInstall = null (InstallPlan.ready installPlan)
503 504

    dryRun            = fromFlag (installDryRun            installFlags)
505
    overrideReinstall = fromFlag (installOverrideReinstall installFlags)
506

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

527 528
data PackageStatus = NewPackage
                   | NewVersion [Version]
529
                   | Reinstall  [InstalledPackageId] [PackageChange]
530 531 532

type PackageChange = MergeResult PackageIdentifier PackageIdentifier

533 534 535
extractReinstalls :: PackageStatus -> [InstalledPackageId]
extractReinstalls (Reinstall ipids _) = ipids
extractReinstalls _                   = []
536

537
packageStatus :: PackageIndex -> ReadyPackage -> PackageStatus
538 539 540 541
packageStatus installedPkgIndex cpkg =
  case PackageIndex.lookupPackageName installedPkgIndex
                                      (packageName cpkg) of
    [] -> NewPackage
refold's avatar
refold committed
542 543
    ps ->  case filter ((==packageId cpkg)
                        . Installed.sourcePackageId) (concatMap snd ps) of
544 545 546
      []           -> NewVersion (map fst ps)
      pkgs@(pkg:_) -> Reinstall (map Installed.installedPackageId pkgs)
                                (changes pkg cpkg)
547 548 549 550

  where

    changes :: Installed.InstalledPackageInfo
551
            -> ReadyPackage
552
            -> [MergeResult PackageIdentifier PackageIdentifier]
refold's avatar
refold committed
553 554 555 556 557 558 559 560 561 562 563
    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')
564 565 566 567

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

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

587 588 589
    showPkg (pkg, _) = display (packageId pkg) ++
                       showLatest (pkg)

590
    showPkgAndReason (pkg', pr) = display (packageId pkg') ++
591
          showLatest pkg' ++
592 593
          showFlagAssignment (nonDefaultFlags pkg') ++
          showStanzas (stanzas pkg') ++ " " ++
594
          case pr of
595 596 597
            NewPackage     -> "(new package)"
            NewVersion _   -> "(new version)"
            Reinstall _ cs -> "(reinstall)" ++ case cs of
598 599 600
                []   -> ""
                diff -> " changes: "  ++ intercalate ", " (map change diff)

601
    showLatest :: ReadyPackage -> String
602 603
    showLatest pkg = case mLatestVersion of
        Just latestVersion ->
604
            if pkgVersion < latestVersion
605 606 607
            then (" (latest: " ++ display latestVersion ++ ")")
            else ""
        Nothing -> ""
608 609
      where
        pkgVersion    = packageVersion pkg
610 611 612 613 614 615
        mLatestVersion :: Maybe Version
        mLatestVersion = case SourcePackageIndex.lookupPackageName
                                (packageIndex sourcePkgDb)
                                (packageName pkg) of
            [] -> Nothing
            x -> Just $ packageVersion $ last x
616

617 618 619
    toFlagAssignment :: [Flag] -> FlagAssignment
    toFlagAssignment = map (\ f -> (flagName f, flagDefault f))

620 621
    nonDefaultFlags :: ReadyPackage -> FlagAssignment
    nonDefaultFlags (ReadyPackage spkg fa _ _) =
622 623 624 625 626
      let defaultAssignment =
            toFlagAssignment
             (genPackageFlags (Source.packageDescription spkg))
      in  fa \\ defaultAssignment

627 628
    stanzas :: ReadyPackage -> [OptionalStanza]
    stanzas (ReadyPackage _ _ sts _) = sts
629 630 631 632 633 634

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

635
    -- FIXME: this should be a proper function in a proper place
636
    showFlagAssignment :: FlagAssignment -> String
637 638 639 640 641
    showFlagAssignment = concatMap ((' ' :) . showFlagValue)
    showFlagValue (f, True)   = '+' : showFlagName f
    showFlagValue (f, False)  = '-' : showFlagName f
    showFlagName (FlagName f) = f

642 643 644 645 646
    change (OnlyInLeft pkgid)        = display pkgid ++ " removed"
    change (InBoth     pkgid pkgid') = display pkgid ++ " -> "
                                    ++ display (packageVersion pkgid')
    change (OnlyInRight      pkgid') = display pkgid' ++ " added"

647 648 649 650
-- ------------------------------------------------------------
-- * Post installation stuff
-- ------------------------------------------------------------

651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698
-- | Report a solver failure. This works slightly differently to
-- 'postInstallActions', as (by definition) we don't have an install plan.
reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> IO ()
reportPlanningFailure verbosity
  (_, repos, comp, platform, _, _, _
  ,_, configFlags, _, installFlags, _)
  (_, sourcePkgDb, _, pkgSpecifiers) = do

  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)
          pkgids (configConfigurationsFlags configFlags) repos

    when (not (null buildReports)) $
      notice verbosity $
        "Notice: this solver failure will be reported for "
        ++ intercalate "," (map display pkgids)

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

  where
    reportFailure = fromFlag (installReportPlanningFailure installFlags)

-- | 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)

699 700 701 702 703 704
-- | Various stuff we do after successful or unsuccessfully installing a bunch
-- of packages. This includes:
--
--  * build reporting, local and remote
--  * symlinking binaries
--  * updating indexes
705
--  * updating world file
706 707 708
--  * error reporting
--
postInstallActions :: Verbosity
709
                   -> InstallArgs
710
                   -> [UserTarget]
711 712 713
                   -> InstallPlan
                   -> IO ()
postInstallActions verbosity
714 715
  (packageDBs, _, comp, platform, conf, useSandbox, mSandboxPkgInfo
  ,globalFlags, configFlags, _, installFlags, _)
716
  targets installPlan = do
717

718
  unless oneShot $
719
    World.insert verbosity worldFile
720 721 722
      --FIXME: does not handle flags
      [ World.WorldPkgInfo dep []
      | UserTargetNamed dep <- targets ]
723

724
  let buildReports = BuildReports.fromInstallPlan installPlan
refold's avatar
refold committed
725 726
  BuildReports.storeLocal (installSummaryFile installFlags) buildReports
    (InstallPlan.planPlatform installPlan)
727 728 729 730 731
  when (reportingLevel >= AnonymousReports) $
    BuildReports.storeAnonymous buildReports
  when (reportingLevel == DetailedReports) $
    storeDetailedBuildReports verbosity logsDir buildReports

732
  regenerateHaddockIndex verbosity packageDBs comp platform conf
733 734 735 736 737 738
                         configFlags installFlags installPlan

  symlinkBinaries verbosity configFlags installFlags installPlan

  printBuildFailures installPlan

739 740 741
  updateSandboxTimestampsFile useSandbox mSandboxPkgInfo
                              comp platform installPlan

742 743
  where
    reportingLevel = fromFlag (installBuildReports installFlags)
744
    logsDir        = fromFlag (globalLogsDir globalFlags)
745 746
    oneShot        = fromFlag (installOneShot installFlags)
    worldFile      = fromFlag $ globalWorldFile globalFlags
747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783

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
784
                       -> Platform
785 786 787 788 789
                       -> ProgramConfiguration
                       -> ConfigFlags
                       -> InstallFlags
                       -> InstallPlan
                       -> IO ()
790
regenerateHaddockIndex verbosity packageDBs comp platform conf
791 792 793 794 795 796 797 798 799 800 801 802 803 804
                       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
805 806
  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
  Haddock.regenerateHaddockIndex verbosity installedPkgIndex conf indexFile
807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823

  | 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

824
        installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _ _)) = True
825 826 827 828 829 830 831 832 833
        installedDocs _                                            = False
        isSpecificPackageDB (SpecificPackageDB _) = True
        isSpecificPackageDB _                     = False

    substHaddockIndexFileName defaultDirs = fromPathTemplate
                                          . substPathTemplate env
      where
        env  = env0 ++ installDirsTemplateEnv absoluteDirs
        env0 = InstallDirs.compilerTemplateEnv (compilerId comp)
834
            ++ InstallDirs.platformTemplateEnv platform
835 836 837 838 839 840
        absoluteDirs = InstallDirs.substituteInstallDirTemplates
                         env0 templateDirs
        templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault
                         defaultDirs (configInstallDirs configFlags)


841
symlinkBinaries :: Verbosity
842
                -> ConfigFlags
843
                -> InstallFlags
844
                -> InstallPlan -> IO ()
845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864
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
865
    bindir = fromFlag (installSymlinkBinDir installFlags)
866

867

868
printBuildFailures :: InstallPlan -> IO ()
869 870 871 872 873 874 875 876 877 878 879 880
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."
Duncan Coutts's avatar