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

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

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

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

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

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

142
143
144
145
146
147
148
149
150
151
152
--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
153

154
155
156
157
158
159
-- ------------------------------------------------------------
-- * Top level user actions
-- ------------------------------------------------------------

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

180
    installContext <- makeInstallContext verbosity args (Just userTargets0)
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
181
    installPlan    <- foldProgress logMsg die' return =<<
182
183
184
185
186
                      makeInstallPlan verbosity args installContext

    processInstallPlan verbosity args installContext installPlan
  where
    args :: InstallArgs
187
    args = (packageDBs, repos, comp, platform, conf, useSandbox, mSandboxPkgInfo,
188
189
190
            globalFlags, configFlags, configExFlags, installFlags,
            haddockFlags)

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

refold's avatar
refold committed
201
-- TODO: Make InstallContext a proper datatype with documented fields.
202
203
204
205
-- | Common context for makeInstallPlan and processInstallPlan.
type InstallContext = ( PackageIndex, SourcePackageDb
                      , [UserTarget], [PackageSpecifier SourcePackage] )

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

-- | Make an install context given install arguments.
223
makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]
224
225
                      -> IO InstallContext
makeInstallContext verbosity
226
  (packageDBs, repos, comp, _, conf,_,_,
227
   globalFlags, _, _, _, _) mUserTargets = do
228

229
230
    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
    sourcePkgDb       <- getSourcePackages    verbosity repos
231

232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
    (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)
249
250

    return (installedPkgIndex, sourcePkgDb, userTargets, pkgSpecifiers)
251

252
253
254
255
-- | Make an install plan given install context and install arguments.
makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext
                -> IO (Progress String String InstallPlan)
makeInstallPlan verbosity
256
  (_, _, comp, platform, _, _, mSandboxPkgInfo,
257
258
259
260
261
262
263
   _, configFlags, configExFlags, installFlags,
   _)
  (installedPkgIndex, sourcePkgDb,
   _, pkgSpecifiers) = do

    solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags))
              (compilerId comp)
264
    notice verbosity "Resolving dependencies..."
265
266
267
    return $ planPackages comp platform mSandboxPkgInfo solver
      configFlags configExFlags installFlags
      installedPkgIndex sourcePkgDb pkgSpecifiers
268

269
270
271
272
273
-- | Given an install plan, perform the actual installations.
processInstallPlan :: Verbosity -> InstallArgs -> InstallContext
                   -> InstallPlan
                   -> IO ()
processInstallPlan verbosity
274
  args@(_,_, _, _, _, _, _, _, _, _, installFlags, _)
275
276
  (installedPkgIndex, sourcePkgDb,
   userTargets, pkgSpecifiers) installPlan = do
277
278
    checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb
      installFlags pkgSpecifiers
279

280
281
    unless dryRun $ do
      installPlan' <- performInstallations verbosity
282
283
                      args installedPkgIndex installPlan
      postInstallActions verbosity args userTargets installPlan'
284
  where
285
    dryRun = fromFlag (installDryRun installFlags)
286

287
288
289
-- ------------------------------------------------------------
-- * Installation planning
-- ------------------------------------------------------------
290

291
planPackages :: Compiler
292
             -> Platform
293
             -> Maybe SandboxPackageInfo
294
             -> Solver
295
296
297
             -> ConfigFlags
             -> ConfigExFlags
             -> InstallFlags
298
             -> PackageIndex
299
300
             -> SourcePackageDb
             -> [PackageSpecifier SourcePackage]
301
             -> Progress String String InstallPlan
302
303
planPackages comp platform mSandboxPkgInfo solver
             configFlags configExFlags installFlags
304
             installedPkgIndex sourcePkgDb pkgSpecifiers =
305

306
        resolveDependencies
307
          platform (compilerId comp)
308
          solver
309
          resolverParams
310

311
    >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return
312

313
314
315
  where
    resolverParams =

Andres Löh's avatar
Andres Löh committed
316
317
318
        setMaxBackjumps (if maxBackjumps < 0 then Nothing
                                             else Just maxBackjumps)

319
320
      . setIndependentGoals independentGoals

Andres Löh's avatar
Andres Löh committed
321
      . setReorderGoals reorderGoals
Andres Löh's avatar
Andres Löh committed
322
323

      . setAvoidReinstalls avoidReinstalls
324

325
326
      . setShadowPkgs shadowPkgs

327
      . setPreferenceDefault (if upgradeDeps then PreferAllLatest
328
329
330
331
332
333
334
335
336
                                             else PreferLatestForSelected)

      . 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
337
            (map userToPackageConstraint (configExConstraints configExFlags))
338
339
340
341

      . addConstraints
          --FIXME: this just applies all flags to all targets which
          -- is silly. We should check if the flags are appropriate
342
          [ PackageConstraintFlags (pkgSpecifierTarget pkgSpecifier) flags
343
344
          | let flags = configConfigurationsFlags configFlags
          , not (null flags)
345
346
347
348
349
          , pkgSpecifier <- pkgSpecifiers ]

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

351
352
      . maybe id applySandboxInstallPolicy mSandboxPkgInfo

353
354
      . (if reinstall then reinstallTargets else id)

355
      $ standardInstallPolicy
356
        installedPkgIndex sourcePkgDb pkgSpecifiers
357

358
359
360
361
    stanzas = concat
        [ if testsEnabled then [TestStanzas] else []
        , if benchmarksEnabled then [BenchStanzas] else []
        ]
362
    testsEnabled = fromFlagOrDefault False $ configTests configFlags
363
    benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags
364

365
366
367
368
    reinstall        = fromFlag (installReinstall        installFlags)
    reorderGoals     = fromFlag (installReorderGoals     installFlags)
    independentGoals = fromFlag (installIndependentGoals installFlags)
    avoidReinstalls  = fromFlag (installAvoidReinstalls  installFlags)
369
    shadowPkgs       = fromFlag (installShadowPkgs       installFlags)
370
371
372
    maxBackjumps     = fromFlag (installMaxBackjumps     installFlags)
    upgradeDeps      = fromFlag (installUpgradeDeps      installFlags)
    onlyDeps         = fromFlag (installOnlyDeps         installFlags)
373

374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
-- | 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

402
403
404
405
-- ------------------------------------------------------------
-- * Informational messages
-- ------------------------------------------------------------

406
407
-- | Perform post-solver checks of the install plan and print it if
-- either requested or needed.
408
409
410
checkPrintPlan :: Verbosity
               -> PackageIndex
               -> InstallPlan
411
               -> SourcePackageDb
412
               -> InstallFlags
413
               -> [PackageSpecifier SourcePackage]
414
               -> IO ()
415
416
checkPrintPlan verbosity installed installPlan sourcePkgDb
  installFlags pkgSpecifiers = do
417

418
419
420
421
422
423
424
425
  -- 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.
426
  when nothingToInstall $
427
428
429
430
    notice verbosity $ unlines $
         "All the requested packages are already installed:"
       : map (display . packageId) preExistingTargets
      ++ ["Use --reinstall if you want to reinstall anyway."]
431

432
  let lPlan = linearizeInstallPlan installed installPlan
433
434
  -- Are any packages classified as reinstalls?
  let reinstalledPkgs = concatMap (extractReinstalls . snd) lPlan
435
436
437
438
439
440
441
442
  -- Packages that are already broken.
  let oldBrokenPkgs =
          map Installed.installedPackageId
        . PackageIndex.reverseDependencyClosure installed
        . map (Installed.installedPackageId . fst)
        . PackageIndex.brokenPackages
        $ installed
  let excluded = reinstalledPkgs ++ oldBrokenPkgs
443
  -- Packages that are reverse dependencies of replaced packages are very
444
445
446
  -- likely to be broken. We exclude packages that are already broken.
  let newBrokenPkgs =
        filter (\ p -> not (Installed.installedPackageId p `elem` excluded))
447
448
               (PackageIndex.reverseDependencyClosure installed reinstalledPkgs)
  let containsReinstalls = not (null reinstalledPkgs)
449
  let breaksPkgs         = not (null newBrokenPkgs)
450
451
452
453
454
455
456
457

  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) $
458
459
    printPlan (dryRun || breaksPkgs && not overrideReinstall)
      adaptedVerbosity lPlan sourcePkgDb
460

461
462
463
464
465
466
467
468
  -- 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:"
469
          : map (display . Installed.sourcePackageId) newBrokenPkgs
470
471
472
473
474
475
476
          ++ 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..."
477
478
479

  where
    nothingToInstall = null (InstallPlan.ready installPlan)
480
481

    dryRun            = fromFlag (installDryRun            installFlags)
482
    overrideReinstall = fromFlag (installOverrideReinstall installFlags)
483

484
485
486
linearizeInstallPlan :: PackageIndex
                     -> InstallPlan
                     -> [(ConfiguredPackage, PackageStatus)]
487
488
linearizeInstallPlan installedPkgIndex plan =
    unfoldr next plan
489
490
491
  where
    next plan' = case InstallPlan.ready plan' of
      []      -> Nothing
492
493
494
495
496
497
498
499
500
      (pkg:_) -> Just ((pkg, status), plan'')
        where
          pkgid  = packageId pkg
          status = packageStatus installedPkgIndex pkg
          plan'' = InstallPlan.completed pkgid
                     (BuildOk DocsNotTried TestsNotTried)
                     (InstallPlan.processing [pkg] plan')
          --FIXME: This is a bit of a hack,
          -- pretending that each package is installed
501

502
503
data PackageStatus = NewPackage
                   | NewVersion [Version]
504
                   | Reinstall  [InstalledPackageId] [PackageChange]
505
506
507

type PackageChange = MergeResult PackageIdentifier PackageIdentifier

508
509
510
extractReinstalls :: PackageStatus -> [InstalledPackageId]
extractReinstalls (Reinstall ipids _) = ipids
extractReinstalls _                   = []
511
512
513
514
515
516

packageStatus :: PackageIndex -> ConfiguredPackage -> PackageStatus
packageStatus installedPkgIndex cpkg =
  case PackageIndex.lookupPackageName installedPkgIndex
                                      (packageName cpkg) of
    [] -> NewPackage
refold's avatar
refold committed
517
518
    ps ->  case filter ((==packageId cpkg)
                        . Installed.sourcePackageId) (concatMap snd ps) of
519
520
521
      []           -> NewVersion (map fst ps)
      pkgs@(pkg:_) -> Reinstall (map Installed.installedPackageId pkgs)
                                (changes pkg cpkg)
522
523
524
525
526
527

  where

    changes :: Installed.InstalledPackageInfo
            -> ConfiguredPackage
            -> [MergeResult PackageIdentifier PackageIdentifier]
refold's avatar
refold committed
528
529
530
531
532
533
534
535
536
537
538
    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')
539
540
541
542

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

543
544
545
printPlan :: Bool -- is dry run
          -> Verbosity
          -> [(ConfiguredPackage, PackageStatus)]
546
          -> SourcePackageDb
547
          -> IO ()
548
printPlan dryRun verbosity plan sourcePkgDb = case plan of
549
550
551
  []   -> return ()
  pkgs
    | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $
552
        ("In order, the following " ++ wouldWill ++ " be installed:")
553
554
      : map showPkgAndReason pkgs
    | otherwise -> notice verbosity $ unlines $
refold's avatar
refold committed
555
556
        ("In order, the following " ++ wouldWill
         ++ " be installed (use -v for more details):")
557
      : map showPkg pkgs
558
  where
559
560
561
    wouldWill | dryRun    = "would"
              | otherwise = "will"

562
563
564
    showPkg (pkg, _) = display (packageId pkg) ++
                       showLatest (pkg)

565
    showPkgAndReason (pkg', pr) = display (packageId pkg') ++
566
          showLatest pkg' ++
567
568
          showFlagAssignment (nonDefaultFlags pkg') ++
          showStanzas (stanzas pkg') ++ " " ++
569
          case pr of
570
571
572
            NewPackage     -> "(new package)"
            NewVersion _   -> "(new version)"
            Reinstall _ cs -> "(reinstall)" ++ case cs of
573
574
575
                []   -> ""
                diff -> " changes: "  ++ intercalate ", " (map change diff)

576
    showLatest :: ConfiguredPackage -> String
577
578
579
580
581
582
    showLatest pkg = case mLatestVersion of
        Just latestVersion ->
            if pkgVersion /= latestVersion
            then (" (latest: " ++ display latestVersion ++ ")")
            else ""
        Nothing -> ""
583
584
      where
        pkgVersion    = packageVersion pkg
585
586
587
588
589
590
        mLatestVersion :: Maybe Version
        mLatestVersion = case SourcePackageIndex.lookupPackageName
                                (packageIndex sourcePkgDb)
                                (packageName pkg) of
            [] -> Nothing
            x -> Just $ packageVersion $ last x
591

592
593
594
595
    toFlagAssignment :: [Flag] -> FlagAssignment
    toFlagAssignment = map (\ f -> (flagName f, flagDefault f))

    nonDefaultFlags :: ConfiguredPackage -> FlagAssignment
596
    nonDefaultFlags (ConfiguredPackage spkg fa _ _) =
597
598
599
600
601
      let defaultAssignment =
            toFlagAssignment
             (genPackageFlags (Source.packageDescription spkg))
      in  fa \\ defaultAssignment

602
603
604
605
606
607
608
609
    stanzas :: ConfiguredPackage -> [OptionalStanza]
    stanzas (ConfiguredPackage _ _ sts _) = sts

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

610
    -- FIXME: this should be a proper function in a proper place
611
    showFlagAssignment :: FlagAssignment -> String
612
613
614
615
616
    showFlagAssignment = concatMap ((' ' :) . showFlagValue)
    showFlagValue (f, True)   = '+' : showFlagName f
    showFlagValue (f, False)  = '-' : showFlagName f
    showFlagName (FlagName f) = f

617
618
619
620
621
    change (OnlyInLeft pkgid)        = display pkgid ++ " removed"
    change (InBoth     pkgid pkgid') = display pkgid ++ " -> "
                                    ++ display (packageVersion pkgid')
    change (OnlyInRight      pkgid') = display pkgid' ++ " added"

622
623
624
625
626
627
628
629
630
631
-- ------------------------------------------------------------
-- * 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
632
--  * updating world file
633
634
635
--  * error reporting
--
postInstallActions :: Verbosity
636
                   -> InstallArgs
637
                   -> [UserTarget]
638
639
640
                   -> InstallPlan
                   -> IO ()
postInstallActions verbosity
641
642
  (packageDBs, _, comp, platform, conf, useSandbox, mSandboxPkgInfo
  ,globalFlags, configFlags, _, installFlags, _)
643
  targets installPlan = do
644

645
  unless oneShot $
646
    World.insert verbosity worldFile
647
648
649
      --FIXME: does not handle flags
      [ World.WorldPkgInfo dep []
      | UserTargetNamed dep <- targets ]
650

651
  let buildReports = BuildReports.fromInstallPlan installPlan
refold's avatar
refold committed
652
653
  BuildReports.storeLocal (installSummaryFile installFlags) buildReports
    (InstallPlan.planPlatform installPlan)
654
655
656
657
658
  when (reportingLevel >= AnonymousReports) $
    BuildReports.storeAnonymous buildReports
  when (reportingLevel == DetailedReports) $
    storeDetailedBuildReports verbosity logsDir buildReports

659
  regenerateHaddockIndex verbosity packageDBs comp platform conf
660
661
662
663
664
665
                         configFlags installFlags installPlan

  symlinkBinaries verbosity configFlags installFlags installPlan

  printBuildFailures installPlan

666
667
668
  updateSandboxTimestampsFile useSandbox mSandboxPkgInfo
                              comp platform installPlan

669
670
  where
    reportingLevel = fromFlag (installBuildReports installFlags)
671
    logsDir        = fromFlag (globalLogsDir globalFlags)
672
673
    oneShot        = fromFlag (installOneShot installFlags)
    worldFile      = fromFlag $ globalWorldFile globalFlags
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
699
700
701
702
703
704
705
706
707
708
709
710

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
711
                       -> Platform
712
713
714
715
716
                       -> ProgramConfiguration
                       -> ConfigFlags
                       -> InstallFlags
                       -> InstallPlan
                       -> IO ()
717
regenerateHaddockIndex verbosity packageDBs comp platform conf
718
719
720
721
722
723
724
725
726
727
728
729
730
731
                       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
732
733
  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
  Haddock.regenerateHaddockIndex verbosity installedPkgIndex conf indexFile
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
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
    -- 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

        installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _)) = True
        installedDocs _                                            = False
        isSpecificPackageDB (SpecificPackageDB _) = True
        isSpecificPackageDB _                     = False

    substHaddockIndexFileName defaultDirs = fromPathTemplate
                                          . substPathTemplate env
      where
        env  = env0 ++ installDirsTemplateEnv absoluteDirs
        env0 = InstallDirs.compilerTemplateEnv (compilerId comp)
761
            ++ InstallDirs.platformTemplateEnv platform
762
763
764
765
766
767
        absoluteDirs = InstallDirs.substituteInstallDirTemplates
                         env0 templateDirs
        templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault
                         defaultDirs (configInstallDirs configFlags)


768
symlinkBinaries :: Verbosity
769
                -> ConfigFlags
770
                -> InstallFlags
771
                -> InstallPlan -> IO ()
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
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
792
    bindir = fromFlag (installSymlinkBinDir installFlags)
793

794

795
printBuildFailures :: InstallPlan -> IO ()
796
797
798
799
800
801
802
803
804
805
806
807
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."
808
      DownloadFailed  e -> " failed while downloading the package."
809
                        ++ showException e
810
      UnpackFailed    e -> " failed while unpacking the package."
811
                        ++ showException e
812
      ConfigureFailed e -> " failed during the configure step."
813
                        ++ showException e
814
      BuildFailed     e -> " failed during the building phase."
815
                        ++ showException e
816
      TestsFailed     e -> " failed during the tests phase."
817
                        ++ showException e
818
      InstallFailed   e -> " failed during the final install step."
819
820
821
822
823
824
825
826
827
828
829
830
                        ++ showException e

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

831

832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
-- | If we're working inside a sandbox and some add-source deps were installed,
-- update the timestamps of those deps.
updateSandboxTimestampsFile :: UseSandbox -> Maybe SandboxPackageInfo
                        -> Compiler -> Platform -> InstallPlan
                        -> IO ()
updateSandboxTimestampsFile (UseSandbox sandboxDir)
                            (Just (SandboxPackageInfo _ _ _ allAddSourceDeps))
                            comp platform installPlan =
  withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do
    let allInstalled = [ pkg | InstallPlan.Installed pkg _
                            <- InstallPlan.toList installPlan ]
        allSrcPkgs   = [ pkg | ConfiguredPackage pkg _ _ _ <- allInstalled ]
        allPaths     = [ pth | LocalUnpackedPackage pth
                            <- map packageSource allSrcPkgs]
    allPathsCanonical <- mapM tryCanonicalizePath allPaths
    return $! filter (`S.member` allAddSourceDeps) allPathsCanonical

updateSandboxTimestampsFile _ _ _ _ _ = return ()
850
851
852
853
854
855
856
857
858
859

-- ------------------------------------------------------------
-- * Actually do the installations
-- ------------------------------------------------------------

data InstallMisc = InstallMisc {
    rootCmd    :: Maybe FilePath,
    libVersion :: Maybe Version
  }

refold's avatar
refold committed
860
861
862
863
-- | If logging is enabled, contains location of the log file and the verbosity
-- level for logging.
type UseLogFile = Maybe (PackageIdentifier -> FilePath, Verbosity)

864
performInstallations :: Verbosity
865
                     -> InstallArgs
866
                     -> PackageIndex
867
868
869
                     -> InstallPlan
                     -> IO InstallPlan
performInstallations verbosity
870
  (packageDBs, _, comp, _, conf, useSandbox, _,
871
   globalFlags, configFlags, configExFlags, installFlags, haddockFlags)
872
  installedPkgIndex installPlan = do
873

874
875
876
877
878
879
  -- With 'install -j' it can be a bit hard to tell whether a sandbox is used.
  whenUsingSandbox useSandbox $ \sandboxDir ->
    when parallelBuild $
      notice verbosity $ "Notice: installing into a sandbox located at "
                         ++ sandboxDir

880
881
882
883
  jobControl   <- if parallelBuild then newParallelJobControl
                                   else newSerialJobControl
  buildLimit   <- newJobLimit numJobs
  fetchLimit   <- newJobLimit (min numJobs numFetchJobs)
refold's avatar
refold committed
884
885
  installLock  <- newLock -- serialise installation
  cacheLock    <- newLock -- serialise access to setup exe cache
886

refold's avatar
refold committed
887
  executeInstallPlan verbosity jobControl useLogFile installPlan $ \cpkg ->
888
    installConfiguredPackage platform compid configFlags
889
                             cpkg $ \configFlags' src pkg pkgoverride ->
890
891
      fetchSourcePackage verbosity fetchLimit src $ \src' ->
        installLocalPackage verbosity buildLimit (packageId pkg) src' $ \mpath ->
refold's avatar
refold committed
892
          installUnpackedPackage verbosity buildLimit installLock numJobs
refold's avatar
refold committed
893
                                 (setupScriptOptions installedPkgIndex cacheLock)
894
                                 miscOptions configFlags' installFlags haddockFlags
895
                                 compid platform pkg pkgoverride mpath useLogFile
896
897
898
899
900

  where
    platform = InstallPlan.planPlatform installPlan
    compid   = InstallPlan.planCompiler installPlan

901
902
903
904
    numJobs  = case installNumJobs installFlags of
      Cabal.NoFlag        -> 1
      Cabal.Flag Nothing  -> numberOfProcessors
      Cabal.Flag (Just n) -> n
refold's avatar
refold committed
905
    numFetchJobs  = 2
906
907
    parallelBuild = numJobs >= 2

refold's avatar
refold committed
908
    setupScriptOptions index lock = SetupScriptOptions {
909
910
      useCabalVersion  = maybe anyVersion thisVersion (libVersion miscOptions),
      useCompiler      = Just comp,
911
      usePlatform      = Just platform,
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
      -- Hack: we typically want to allow the UserPackageDB for finding the
      -- Cabal lib when compiling any Setup.hs even if we're doing a global
      -- install. However we also allow looking in a specific package db.
      usePackageDB     = if UserPackageDB `elem` packageDBs
                           then packageDBs
                           else let (db@GlobalPackageDB:dbs) = packageDBs
                                 in db : UserPackageDB : dbs,
                                --TODO: use Ord instance:
                                -- insert UserPackageDB packageDBs
      usePackageIndex  = if UserPackageDB `elem` packageDBs
                           then Just index
                           else Nothing,
      useProgramConfig = conf,
      useDistPref      = fromFlagOrDefault
                           (useDistPref defaultSetupScriptOptions)
                           (configDistPref configFlags),
      useLoggingHandle = Nothing,
929
      useWorkingDir    = Nothing,
refold's avatar
refold committed
930
      forceExternalSetupMethod = parallelBuild,
refold's avatar
refold committed
931
      setupCacheLock   = Just lock
932
933
    }
    reportingLevel = fromFlag (installBuildReports installFlags)
934
    logsDir        = fromFlag (globalLogsDir globalFlags)
refold's avatar
refold committed
935
936
937
938
939

    -- Should the build output be written to a log file instead of stdout?
    useLogFile :: UseLogFile
    useLogFile = fmap ((\f -> (f, loggingVerbosity)) . substLogFileName)
                 logFileTemplate
940
      where
refold's avatar
refold committed
941
942
943
944
945
946
947
        installLogFile' = flagToMaybe $ installLogFile installFlags
        defaultTemplate = toPathTemplate $ logsDir </> "$pkgid" <.> "log"

        -- If the user has specified --remote-build-reporting=detailed, use the
        -- default log file location. If the --build-log option is set, use the
        -- provided location. Otherwise don't use logging, unless building in
        -- parallel (in which case the default location is used).
948
        logFileTemplate :: Maybe PathTemplate
refold's avatar
refold committed
949
950
951
952
953
954
955
956
957
958
959
960
961
962
        logFileTemplate
          | useDefaultTemplate = Just defaultTemplate
          | otherwise          = installLogFile'

        -- If the user has specified --remote-build-reporting=detailed or
        -- --build-log, use more verbose logging.
        loggingVerbosity :: Verbosity
        loggingVerbosity | overrideVerbosity = max Verbosity.verbose verbosity
                         | otherwise         = verbosity

        useDefaultTemplate :: Bool
        useDefaultTemplate
          | reportingLevel == DetailedReports = True
          | isJust installLogFile'            = False
963
          | parallelBuild                     = True
refold's avatar
refold committed
964
965
966
967
968
969
          | otherwise                         = False

        overrideVerbosity :: Bool
        overrideVerbosity
          | reportingLevel == DetailedReports = True
          | isJust installLogFile'            = True
970
          | parallelBuild                     = False
refold's avatar
refold committed
971
          | otherwise                         = False
972
973

    substLogFileName :: PathTemplate -> PackageIdentifier -> FilePath
974
975
976
    substLogFileName template pkg = fromPathTemplate
                                  . substPathTemplate env
                                  $ template
refold's avatar
refold committed
977
978
      where env = initialPathTemplateEnv (packageId pkg)
                  (compilerId comp) platform
refold's avatar
refold committed
979

980
981
    miscOptions  = InstallMisc {
      rootCmd    = if fromFlag (configUserInstall configFlags)
982
                      || (isUseSandbox useSandbox)
983
984
                     then Nothing      -- ignore --root-cmd if --user
                                       -- or working inside a sandbox.
985
986
987
988
989
                     else flagToMaybe (installRootCmd installFlags),
      libVersion = flagToMaybe (configCabalVersion configExFlags)
    }


990
991
executeInstallPlan :: Verbosity
                   -> JobControl IO (PackageId, BuildResult)
refold's avatar
refold committed
992
                   -> UseLogFile
993
994
995
                   -> InstallPlan
                   -> (ConfiguredPackage -> IO BuildResult)
                   -> IO InstallPlan
refold's avatar
refold committed
996
executeInstallPlan verbosity jobCtl useLogFile plan0 installPkg =
997
    tryNewTasks 0 plan0
998
  where
999
1000
1001
1002
1003
1004
    tryNewTasks taskCount plan = do
      case InstallPlan.ready plan of
        [] | taskCount == 0 -> return plan
           | otherwise      -> waitForTasks taskCount plan
        pkgs                -> do
          sequence_
refold's avatar
refold committed
1005
            [ do info verbosity $ "Ready to install " ++ display pkgid
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
                 spawnJob jobCtl $ do
                   buildResult <- installPkg pkg
                   return (packageId pkg, buildResult)
            | pkg <- pkgs
            , let pkgid = packageId pkg]

          let taskCount' = taskCount + length pkgs
              plan'      = InstallPlan.processing pkgs plan
          waitForTasks taskCount' plan'

    waitForTasks taskCount plan = do
refold's avatar
refold committed
1017
      info verbosity $ "Waiting for install task to finish..."
1018
      (pkgid, buildResult) <- collectJob jobCtl
refold's avatar
refold committed
1019
      printBuildResult pkgid buildResult
1020
1021
1022
1023
      let taskCount' = taskCount-1
          plan'      = updatePlan pkgid buildResult plan
      tryNewTasks taskCount' plan'

refold's avatar
refold committed
1024
    updatePlan :: PackageIdentifier -> BuildResult -> InstallPlan -> InstallPlan
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
    updatePlan pkgid (Right buildSuccess) =
      InstallPlan.completed pkgid buildSuccess

    updatePlan pkgid (Left buildFailure) =
      InstallPlan.failed    pkgid buildFailure depsFailure
      where
        depsFailure = DependentFailed pkgid
        -- So this first pkgid failed for whatever reason (buildFailure).
        -- All the other packages that depended on this pkgid, which we
        -- now cannot build, we mark as failing due to 'DependentFailed'
        -- which kind of means it was not their fault.
1036

refold's avatar
refold committed
1037
1038
1039
1040
1041
1042
1043
    -- Print last 10 lines of the build log if something went wrong, and
    -- 'Installed $PKGID' otherwise.
    printBuildResult :: PackageId -> BuildResult -> IO ()
    printBuildResult pkgid buildResult = case buildResult of
        (Right _) -> notice verbosity $ "Installed " ++ display pkgid
        (Left _)  -> do
          notice verbosity $ "Failed to install " ++ display pkgid
1044
1045
1046
1047
          when (verbosity >= normal) $
            case useLogFile of
              Nothing                 -> return ()
              Just (mkLogFileName, _) -> do
1048
1049
                let logName = mkLogFileName pkgid
                    n       = 10
1050
                putStr $ "Last " ++ (show n)
1051
                  ++ " lines of the build log ( " ++ logName ++ " ):\n"
1052
                printLastNLines logName n
refold's avatar
refold committed
1053
1054
1055
1056
1057

    printLastNLines :: FilePath -> Int -> IO ()
    printLastNLines path n = do
      lns <- fmap lines $ readFile path
      let len = length lns