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

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

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

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

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

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

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

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

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

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

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

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

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

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

    return (installedPkgIndex, sourcePkgDb, userTargets, pkgSpecifiers)
260

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

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

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

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

296
297
298
-- ------------------------------------------------------------
-- * Installation planning
-- ------------------------------------------------------------
299

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

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

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

322
323
324
  where
    resolverParams =

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

328
329
      . setIndependentGoals independentGoals

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

      . setAvoidReinstalls avoidReinstalls
333

334
335
      . setShadowPkgs shadowPkgs

336
      . setPreferenceDefault (if upgradeDeps then PreferAllLatest
337
338
                                             else PreferLatestForSelected)

339
      . removeUpperBounds allowNewer
340

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

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

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

362
363
      . maybe id applySandboxInstallPolicy mSandboxPkgInfo

364
365
      . (if reinstall then reinstallTargets else id)

366
      $ standardInstallPolicy
367
        installedPkgIndex sourcePkgDb pkgSpecifiers
368

369
370
371
372
    stanzas = concat
        [ if testsEnabled then [TestStanzas] else []
        , if benchmarksEnabled then [BenchStanzas] else []
        ]
373
    testsEnabled = fromFlagOrDefault False $ configTests configFlags
374
    benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags
375

376
377
378
379
    reinstall        = fromFlag (installReinstall        installFlags)
    reorderGoals     = fromFlag (installReorderGoals     installFlags)
    independentGoals = fromFlag (installIndependentGoals installFlags)
    avoidReinstalls  = fromFlag (installAvoidReinstalls  installFlags)
380
    shadowPkgs       = fromFlag (installShadowPkgs       installFlags)
381
382
383
    maxBackjumps     = fromFlag (installMaxBackjumps     installFlags)
    upgradeDeps      = fromFlag (installUpgradeDeps      installFlags)
    onlyDeps         = fromFlag (installOnlyDeps         installFlags)
384
    allowNewer       = fromFlag (configAllowNewer        configExFlags)
385

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

414
415
416
417
-- ------------------------------------------------------------
-- * Informational messages
-- ------------------------------------------------------------

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

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

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

  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) $
470
471
    printPlan (dryRun || breaksPkgs && not overrideReinstall)
      adaptedVerbosity lPlan sourcePkgDb
472

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

  where
    nothingToInstall = null (InstallPlan.ready installPlan)
492
493

    dryRun            = fromFlag (installDryRun            installFlags)
494
    overrideReinstall = fromFlag (installOverrideReinstall installFlags)
495

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

516
517
data PackageStatus = NewPackage
                   | NewVersion [Version]
518
                   | Reinstall  [InstalledPackageId] [PackageChange]
519
520
521

type PackageChange = MergeResult PackageIdentifier PackageIdentifier

522
523
524
extractReinstalls :: PackageStatus -> [InstalledPackageId]
extractReinstalls (Reinstall ipids _) = ipids
extractReinstalls _                   = []
525

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

  where

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

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

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

576
577
578
    showPkg (pkg, _) = display (packageId pkg) ++
                       showLatest (pkg)

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

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

606
607
608
    toFlagAssignment :: [Flag] -> FlagAssignment
    toFlagAssignment = map (\ f -> (flagName f, flagDefault f))

609
610
    nonDefaultFlags :: ReadyPackage -> FlagAssignment
    nonDefaultFlags (ReadyPackage spkg fa _ _) =
611
612
613
614
615
      let defaultAssignment =
            toFlagAssignment
             (genPackageFlags (Source.packageDescription spkg))
      in  fa \\ defaultAssignment

616
617
    stanzas :: ReadyPackage -> [OptionalStanza]
    stanzas (ReadyPackage _ _ sts _) = sts
618
619
620
621
622
623

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

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

631
632
633
634
635
    change (OnlyInLeft pkgid)        = display pkgid ++ " removed"
    change (InBoth     pkgid pkgid') = display pkgid ++ " -> "
                                    ++ display (packageVersion pkgid')
    change (OnlyInRight      pkgid') = display pkgid' ++ " added"

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

659
  unless oneShot $
660
    World.insert verbosity worldFile
661
662
663
      --FIXME: does not handle flags
      [ World.WorldPkgInfo dep []
      | UserTargetNamed dep <- targets ]
664

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

673
  regenerateHaddockIndex verbosity packageDBs comp platform conf
674
675
676
677
678
679
                         configFlags installFlags installPlan

  symlinkBinaries verbosity configFlags installFlags installPlan

  printBuildFailures installPlan

680
681
682
  updateSandboxTimestampsFile useSandbox mSandboxPkgInfo
                              comp platform installPlan

683
684
  where
    reportingLevel = fromFlag (installBuildReports installFlags)
685
    logsDir        = fromFlag (globalLogsDir globalFlags)
686
687
    oneShot        = fromFlag (installOneShot installFlags)
    worldFile      = fromFlag $ globalWorldFile globalFlags
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
719
720
721
722
723
724

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

  | 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

765
        installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _ _)) = True
766
767
768
769
770
771
772
773
774
        installedDocs _                                            = False
        isSpecificPackageDB (SpecificPackageDB _) = True
        isSpecificPackageDB _                     = False

    substHaddockIndexFileName defaultDirs = fromPathTemplate
                                          . substPathTemplate env
      where
        env  = env0 ++ installDirsTemplateEnv absoluteDirs
        env0 = InstallDirs.compilerTemplateEnv (compilerId comp)
775
            ++ InstallDirs.platformTemplateEnv platform
776
777
778
779
780
781
        absoluteDirs = InstallDirs.substituteInstallDirTemplates
                         env0 templateDirs
        templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault
                         defaultDirs (configInstallDirs configFlags)


782
symlinkBinaries :: Verbosity
783
                -> ConfigFlags
784
                -> InstallFlags
785
                -> InstallPlan -> IO ()
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
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
806
    bindir = fromFlag (installSymlinkBinDir installFlags)
807

808

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

845

846
847
848
-- | 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
849
850
                            -> Compiler -> Platform -> InstallPlan
                            -> IO ()
851
852
853
854
855
856
updateSandboxTimestampsFile (UseSandbox sandboxDir)
                            (Just (SandboxPackageInfo _ _ _ allAddSourceDeps))
                            comp platform installPlan =
  withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do
    let allInstalled = [ pkg | InstallPlan.Installed pkg _
                            <- InstallPlan.toList installPlan ]
857
        allSrcPkgs   = [ pkg | ReadyPackage pkg _ _ _ <- allInstalled ]
858
859
860
861
862
863
        allPaths     = [ pth | LocalUnpackedPackage pth
                            <- map packageSource allSrcPkgs]
    allPathsCanonical <- mapM tryCanonicalizePath allPaths
    return $! filter (`S.member` allAddSourceDeps) allPathsCanonical

updateSandboxTimestampsFile _ _ _ _ _ = return ()
864
865
866
867
868
869
870
871
872
873

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

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

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

878
performInstallations :: Verbosity
879
                     -> InstallArgs
880
                     -> PackageIndex
881
882
883
                     -> InstallPlan
                     -> IO InstallPlan
performInstallations verbosity
884
  (packageDBs, _, comp, _, conf, useSandbox, _,
885
   globalFlags, configFlags, configExFlags, installFlags, haddockFlags)
886
  installedPkgIndex installPlan = do
887

888
889
  -- With 'install -j' it can be a bit hard to tell whether a sandbox is used.
  whenUsingSandbox useSandbox $ \sandboxDir ->
890
    when parallelInstall $
891
892
893
      notice verbosity $ "Notice: installing into a sandbox located at "
                         ++ sandboxDir

894
895
  jobControl   <- if parallelInstall then newParallelJobControl
                                     else newSerialJobControl
896
897
  buildLimit   <- newJobLimit numJobs
  fetchLimit   <- newJobLimit (min numJobs numFetchJobs)
refold's avatar
refold committed
898
899
  installLock  <- newLock -- serialise installation
  cacheLock    <- newLock -- serialise access to setup exe cache
900

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

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

916
917
    numJobs         = determineNumJobs (installNumJobs installFlags)
    numFetchJobs    = 2
918
    parallelInstall = numJobs >= 2
919
920
    distPref        = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)
                      (configDistPref configFlags)
921

refold's avatar
refold committed
922
    setupScriptOptions index lock = SetupScriptOptions {
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
923
924
      useCabalVersion  = chooseCabalVersion configExFlags
                         (libVersion miscOptions),
925
      useCompiler      = Just comp,
926
      usePlatform      = Just platform,
927
928
929
930
931
932
933
934
935
936
937
938
939
      -- 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,
940
      useDistPref      = distPref,
941
      useLoggingHandle = Nothing,
942
      useWorkingDir    = Nothing,
943
      forceExternalSetupMethod = parallelInstall,
refold's avatar
refold committed
944
      setupCacheLock   = Just lock
945
946
    }
    reportingLevel = fromFlag (installBuildReports installFlags)
947
    logsDir        = fromFlag (globalLogsDir globalFlags)
refold's avatar
refold committed
948
949
950
951
952

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