Install.hs 58.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
50
51
         ( getTemporaryDirectory, doesDirectoryExist, doesFileExist,
           createDirectoryIfMissing, removeFile, renameDirectory )
Duncan Coutts's avatar
Duncan Coutts committed
52
import System.FilePath
Duncan Coutts's avatar
Duncan Coutts committed
53
         ( (</>), (<.>), takeDirectory )
Duncan Coutts's avatar
Duncan Coutts committed
54
import System.IO
55
         ( openFile, IOMode(AppendMode), hClose )
56
57
import System.IO.Error
         ( isDoesNotExistError, ioeGetFileName )
bjorn@bringert.net's avatar
bjorn@bringert.net committed
58

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    return (installedPkgIndex, sourcePkgDb, userTargets, pkgSpecifiers)
258

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

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

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

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

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

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

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

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

320
321
322
  where
    resolverParams =

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

326
327
      . setIndependentGoals independentGoals

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

      . setAvoidReinstalls avoidReinstalls
331

332
333
      . setShadowPkgs shadowPkgs

334
      . setPreferenceDefault (if upgradeDeps then PreferAllLatest
335
336
337
338
339
340
341
342
343
                                             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
344
            (map userToPackageConstraint (configExConstraints configExFlags))
345
346
347
348

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

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

358
359
      . maybe id applySandboxInstallPolicy mSandboxPkgInfo

360
361
      . (if reinstall then reinstallTargets else id)

362
      $ standardInstallPolicy
363
        installedPkgIndex sourcePkgDb pkgSpecifiers
364

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

372
373
374
375
    reinstall        = fromFlag (installReinstall        installFlags)
    reorderGoals     = fromFlag (installReorderGoals     installFlags)
    independentGoals = fromFlag (installIndependentGoals installFlags)
    avoidReinstalls  = fromFlag (installAvoidReinstalls  installFlags)
376
    shadowPkgs       = fromFlag (installShadowPkgs       installFlags)
377
378
379
    maxBackjumps     = fromFlag (installMaxBackjumps     installFlags)
    upgradeDeps      = fromFlag (installUpgradeDeps      installFlags)
    onlyDeps         = fromFlag (installOnlyDeps         installFlags)
380

381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
-- | 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

409
410
411
412
-- ------------------------------------------------------------
-- * Informational messages
-- ------------------------------------------------------------

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

425
426
427
428
429
430
431
432
  -- 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.
433
  when nothingToInstall $
434
435
436
437
    notice verbosity $ unlines $
         "All the requested packages are already installed:"
       : map (display . packageId) preExistingTargets
      ++ ["Use --reinstall if you want to reinstall anyway."]
438

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

  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) $
465
466
    printPlan (dryRun || breaksPkgs && not overrideReinstall)
      adaptedVerbosity lPlan sourcePkgDb
467

468
469
470
471
472
473
474
475
  -- 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:"
476
          : map (display . Installed.sourcePackageId) newBrokenPkgs
477
478
479
480
481
482
483
          ++ 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..."
484
485
486

  where
    nothingToInstall = null (InstallPlan.ready installPlan)
487
488

    dryRun            = fromFlag (installDryRun            installFlags)
489
    overrideReinstall = fromFlag (installOverrideReinstall installFlags)
490

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

510
511
data PackageStatus = NewPackage
                   | NewVersion [Version]
512
                   | Reinstall  [InstalledPackageId] [PackageChange]
513
514
515

type PackageChange = MergeResult PackageIdentifier PackageIdentifier

516
517
518
extractReinstalls :: PackageStatus -> [InstalledPackageId]
extractReinstalls (Reinstall ipids _) = ipids
extractReinstalls _                   = []
519

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

  where

    changes :: Installed.InstalledPackageInfo
534
            -> ReadyPackage
535
            -> [MergeResult PackageIdentifier PackageIdentifier]
refold's avatar
refold committed
536
537
538
539
540
541
542
543
544
545
546
    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')
547
548
549
550

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

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

570
571
572
    showPkg (pkg, _) = display (packageId pkg) ++
                       showLatest (pkg)

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

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

600
601
602
    toFlagAssignment :: [Flag] -> FlagAssignment
    toFlagAssignment = map (\ f -> (flagName f, flagDefault f))

603
604
    nonDefaultFlags :: ReadyPackage -> FlagAssignment
    nonDefaultFlags (ReadyPackage spkg fa _ _) =
605
606
607
608
609
      let defaultAssignment =
            toFlagAssignment
             (genPackageFlags (Source.packageDescription spkg))
      in  fa \\ defaultAssignment

610
611
    stanzas :: ReadyPackage -> [OptionalStanza]
    stanzas (ReadyPackage _ _ sts _) = sts
612
613
614
615
616
617

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

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

625
626
627
628
629
    change (OnlyInLeft pkgid)        = display pkgid ++ " removed"
    change (InBoth     pkgid pkgid') = display pkgid ++ " -> "
                                    ++ display (packageVersion pkgid')
    change (OnlyInRight      pkgid') = display pkgid' ++ " added"

630
631
632
633
634
635
636
637
638
639
-- ------------------------------------------------------------
-- * 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
640
--  * updating world file
641
642
643
--  * error reporting
--
postInstallActions :: Verbosity
644
                   -> InstallArgs
645
                   -> [UserTarget]
646
647
648
                   -> InstallPlan
                   -> IO ()
postInstallActions verbosity
649
650
  (packageDBs, _, comp, platform, conf, useSandbox, mSandboxPkgInfo
  ,globalFlags, configFlags, _, installFlags, _)
651
  targets installPlan = do
652

653
  unless oneShot $
654
    World.insert verbosity worldFile
655
656
657
      --FIXME: does not handle flags
      [ World.WorldPkgInfo dep []
      | UserTargetNamed dep <- targets ]
658

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

667
  regenerateHaddockIndex verbosity packageDBs comp platform conf
668
669
670
671
672
673
                         configFlags installFlags installPlan

  symlinkBinaries verbosity configFlags installFlags installPlan

  printBuildFailures installPlan

674
675
676
  updateSandboxTimestampsFile useSandbox mSandboxPkgInfo
                              comp platform installPlan

677
678
  where
    reportingLevel = fromFlag (installBuildReports installFlags)
679
    logsDir        = fromFlag (globalLogsDir globalFlags)
680
681
    oneShot        = fromFlag (installOneShot installFlags)
    worldFile      = fromFlag $ globalWorldFile globalFlags
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
711
712
713
714
715
716
717
718

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

  | 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

759
        installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _ _)) = True
760
761
762
763
764
765
766
767
768
        installedDocs _                                            = False
        isSpecificPackageDB (SpecificPackageDB _) = True
        isSpecificPackageDB _                     = False

    substHaddockIndexFileName defaultDirs = fromPathTemplate
                                          . substPathTemplate env
      where
        env  = env0 ++ installDirsTemplateEnv absoluteDirs
        env0 = InstallDirs.compilerTemplateEnv (compilerId comp)
769
            ++ InstallDirs.platformTemplateEnv platform
770
771
772
773
774
775
        absoluteDirs = InstallDirs.substituteInstallDirTemplates
                         env0 templateDirs
        templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault
                         defaultDirs (configInstallDirs configFlags)


776
symlinkBinaries :: Verbosity
777
                -> ConfigFlags
778
                -> InstallFlags
779
                -> InstallPlan -> IO ()
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
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
800
    bindir = fromFlag (installSymlinkBinDir installFlags)
801

802

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

839

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

updateSandboxTimestampsFile _ _ _ _ _ = return ()
858
859
860
861
862
863
864
865
866
867

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

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

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

872
performInstallations :: Verbosity
873
                     -> InstallArgs
874
                     -> PackageIndex
875
876
877
                     -> InstallPlan
                     -> IO InstallPlan
performInstallations verbosity
878
  (packageDBs, _, comp, _, conf, useSandbox, _,
879
   globalFlags, configFlags, configExFlags, installFlags, haddockFlags)
880
  installedPkgIndex installPlan = do
881

882
883
  -- With 'install -j' it can be a bit hard to tell whether a sandbox is used.
  whenUsingSandbox useSandbox $ \sandboxDir ->
884
    when parallelInstall $
885
886
887
      notice verbosity $ "Notice: installing into a sandbox located at "
                         ++ sandboxDir

888
889
  jobControl   <- if parallelInstall then newParallelJobControl
                                     else newSerialJobControl
890
891
  buildLimit   <- newJobLimit numJobs
  fetchLimit   <- newJobLimit (min numJobs numFetchJobs)
refold's avatar
refold committed
892
893
  installLock  <- newLock -- serialise installation
  cacheLock    <- newLock -- serialise access to setup exe cache
894

895
896
897
  executeInstallPlan verbosity jobControl useLogFile installPlan $ \rpkg ->
    installReadyPackage platform compid configFlags
                        rpkg $ \configFlags' src pkg pkgoverride ->
898
      fetchSourcePackage verbosity fetchLimit src $ \src' ->
899
900
        installLocalPackage verbosity buildLimit
                            (packageId pkg) src' distPref $ \mpath ->
refold's avatar
refold committed
901
          installUnpackedPackage verbosity buildLimit installLock numJobs
refold's avatar
refold committed
902
                                 (setupScriptOptions installedPkgIndex cacheLock)
903
                                 miscOptions configFlags' installFlags haddockFlags
904
                                 compid platform pkg pkgoverride mpath useLogFile
905
906
907
908
909

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

910
911
    numJobs         = determineNumJobs (installNumJobs installFlags)
    numFetchJobs    = 2
912
    parallelInstall = numJobs >= 2
913
914
    distPref        = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)
                      (configDistPref configFlags)
915

refold's avatar
refold committed
916
    setupScriptOptions index lock = SetupScriptOptions {
917
918
      useCabalVersion  = maybe anyVersion thisVersion (libVersion miscOptions),
      useCompiler      = Just comp,
919
      usePlatform      = Just platform,
920
921
922
923
924
925
926
927
928
929
930
931
932
      -- 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,
933
      useDistPref      = distPref,
934
      useLoggingHandle = Nothing,
935
      useWorkingDir    = Nothing,
936
      forceExternalSetupMethod = parallelInstall,
refold's avatar
refold committed
937
      setupCacheLock   = Just lock
938
939
    }
    reportingLevel = fromFlag (installBuildReports installFlags)
940
    logsDir        = fromFlag (globalLogsDir globalFlags)
refold's avatar
refold committed
941
942
943
944
945

    -- Should the build output be written to a log file instead of stdout?
    useLogFile :: UseLogFile
    useLogFile = fmap ((\f -> (f, loggingVerbosity)) . substLogFileName)
                 logFileTemplate
946
      where
refold's avatar
refold committed
947
948
949
950
951
952
953
        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).
954
        logFileTemplate :: Maybe PathTemplate
refold's avatar
refold committed
955
956
957
958
959
960
961
962
963
964
965
966
967
968
        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
969
          | parallelInstall                   = True
refold's avatar
refold committed
970
971
972
973
974
975
          | otherwise                         = False

        overrideVerbosity :: Bool
        overrideVerbosity
          | reportingLevel == DetailedReports = True
          | isJust installLogFile'            = True
976
          | parallelInstall                   = False
refold's avatar
refold committed
977
          | otherwise                         = False
978
979

    substLogFileName :: PathTemplate -> PackageIdentifier -> FilePath
980
981
982
    substLogFileName template pkg = fromPathTemplate
                                  . substPathTemplate env
                                  $ template
refold's avatar
refold committed
983
984
      where env = initialPathTemplateEnv (packageId pkg)
                  (compilerId comp) platform
refold's avatar
refold committed
985

986
987
    miscOptions  = InstallMisc {
      rootCmd    = if fromFlag (configUserInstall configFlags)
988
                      || (isUseSandbox useSandbox)
989
990
                     then Nothing      -- ignore --root-cmd if --user
                                       -- or working inside a sandbox.
991
992
993
994
995
                     else flagToMaybe (installRootCmd installFlags),
      libVersion = flagToMaybe (configCabalVersion configExFlags)
    }


996
997
executeInstallPlan :: Verbosity
                   -> JobControl IO (PackageId, BuildResult)
refold's avatar
refold committed
998
                   -> UseLogFile
999
                   -> InstallPlan
1000
                   -> (ReadyPackage -> IO BuildResult)
1001
                   -> IO InstallPlan
refold's avatar
refold committed
1002
executeInstallPlan verbosity jobCtl useLogFile plan0 installPkg =
1003
    tryNewTasks 0 plan0
1004
  where<