InstallPlan.hs 19.6 KB
Newer Older
Duncan Coutts's avatar
Duncan Coutts committed
1
2
-----------------------------------------------------------------------------
-- |
3
-- Module      :  Distribution.Client.InstallPlan
Duncan Coutts's avatar
Duncan Coutts committed
4
5
6
7
8
9
10
11
12
13
-- Copyright   :  (c) Duncan Coutts 2008
-- License     :  BSD-like
--
-- Maintainer  :  duncan@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Package installation plan
--
-----------------------------------------------------------------------------
14
module Distribution.Client.InstallPlan (
Duncan Coutts's avatar
Duncan Coutts committed
15
16
17
  InstallPlan,
  ConfiguredPackage(..),
  PlanPackage(..),
18
19

  -- * Operations on 'InstallPlan's
Duncan Coutts's avatar
Duncan Coutts committed
20
21
  new,
  toList,
22
  ready,
Duncan Coutts's avatar
Duncan Coutts committed
23
  completed,
24
25
  failed,

26
  -- ** Query functions
27
  planPlatform,
28
29
  planCompiler,

30
31
  -- * Checking valididy of plans
  valid,
32
  closed,
33
34
  consistent,
  acyclic,
35
36
37
38
39
40
41
42
43
  configuredPackageValid,

  -- ** Details on invalid plans
  PlanProblem(..),
  showPlanProblem,
  PackageProblem(..),
  showPackageProblem,
  problems,
  configuredPackageProblems
Duncan Coutts's avatar
Duncan Coutts committed
44
45
  ) where

46
import Distribution.Client.Types
47
         ( AvailablePackage(packageDescription), ConfiguredPackage(..)
48
         , InstalledPackage
49
         , BuildFailure, BuildSuccess )
Duncan Coutts's avatar
Duncan Coutts committed
50
import Distribution.Package
51
52
         ( PackageIdentifier(..), PackageName(..), Package(..), packageName
         , PackageFixedDeps(..), Dependency(..) )
53
54
import Distribution.Version
         ( Version, withinRange )
Duncan Coutts's avatar
Duncan Coutts committed
55
56
import Distribution.PackageDescription
         ( GenericPackageDescription(genPackageFlags)
57
         , Flag(flagName), FlagName(..) )
58
59
import Distribution.Client.PackageUtils
         ( externalBuildDepends )
Duncan Coutts's avatar
Duncan Coutts committed
60
61
import Distribution.PackageDescription.Configuration
         ( finalizePackageDescription )
62
import Distribution.Client.PackageIndex
63
         ( PackageIndex )
64
import qualified Distribution.Client.PackageIndex as PackageIndex
Duncan Coutts's avatar
Duncan Coutts committed
65
66
67
import Distribution.Text
         ( display )
import Distribution.System
68
         ( Platform )
Duncan Coutts's avatar
Duncan Coutts committed
69
70
import Distribution.Compiler
         ( CompilerId(..) )
71
import Distribution.Client.Utils
72
73
74
         ( duplicates, duplicatesBy, mergeBy, MergeResult(..) )
import Distribution.Simple.Utils
         ( comparing, intercalate )
Duncan Coutts's avatar
Duncan Coutts committed
75
76

import Data.List
77
         ( sort, sortBy )
78
79
80
81
import Data.Maybe
         ( fromMaybe )
import qualified Data.Graph as Graph
import Data.Graph (Graph)
Duncan Coutts's avatar
Duncan Coutts committed
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
import Control.Exception
         ( assert )

-- When cabal tries to install a number of packages, including all their
-- dependencies it has a non-trivial problem to solve.
--
-- The Problem:
--
-- In general we start with a set of installed packages and a set of available
-- packages.
--
-- Installed packages have fixed dependencies. They have already been built and
-- we know exactly what packages they were built against, including their exact
-- versions. 
--
-- Available package have somewhat flexible dependencies. They are specified as
-- version ranges, though really they're predicates. To make matters worse they
-- have conditional flexible dependencies. Configuration flags can affect which
-- packages are required and can place additional constraints on their
-- versions.
--
-- These two sets of package can and usually do overlap. There can be installed
-- packages that are also available which means they could be re-installed if
-- required, though there will also be packages which are not available and
-- cannot be re-installed. Very often there will be extra versions available
-- than are installed. Sometimes we may like to prefer installed packages over
-- available ones or perhaps always prefer the latest available version whether
-- installed or not.
--
111
112
-- The goal is to calculate an installation plan that is closed, acyclic and
-- consistent and where every configured package is valid.
Duncan Coutts's avatar
Duncan Coutts committed
113
114
115
116
--
-- An installation plan is a set of packages that are going to be used
-- together. It will consist of a mixture of installed packages and available
-- packages along with their exact version dependencies. An installation plan
117
-- is closed if for every package in the set, all of its dependencies are
Duncan Coutts's avatar
Duncan Coutts committed
118
119
120
-- also in the set. It is consistent if for every package in the set, all
-- dependencies which target that package have the same version.

121
122
123
124
125
126
-- Note that plans do not necessarily compose. You might have a valid plan for
-- package A and a valid plan for package B. That does not mean the composition
-- is simultaniously valid for A and B. In particular you're most likely to
-- have problems with inconsistent dependencies.
-- On the other hand it is true that every closed sub plan is valid.

127
data PlanPackage = PreExisting InstalledPackage
128
129
130
                 | Configured  ConfiguredPackage
                 | Installed   ConfiguredPackage BuildSuccess
                 | Failed      ConfiguredPackage BuildFailure
Duncan Coutts's avatar
Duncan Coutts committed
131

132
instance Package PlanPackage where
Duncan Coutts's avatar
Duncan Coutts committed
133
  packageId (PreExisting pkg) = packageId pkg
134
135
136
  packageId (Configured  pkg) = packageId pkg
  packageId (Installed pkg _) = packageId pkg
  packageId (Failed    pkg _) = packageId pkg
Duncan Coutts's avatar
Duncan Coutts committed
137

138
instance PackageFixedDeps PlanPackage where
Duncan Coutts's avatar
Duncan Coutts committed
139
  depends (PreExisting pkg) = depends pkg
140
141
142
  depends (Configured  pkg) = depends pkg
  depends (Installed pkg _) = depends pkg
  depends (Failed    pkg _) = depends pkg
Duncan Coutts's avatar
Duncan Coutts committed
143

144
145
data InstallPlan = InstallPlan {
    planIndex    :: PackageIndex PlanPackage,
146
147
    planGraph    :: Graph,
    planGraphRev :: Graph,
148
    planPkgOf    :: Graph.Vertex -> PlanPackage,
149
    planVertexOf :: PackageIdentifier -> Graph.Vertex,
150
    planPlatform :: Platform,
Duncan Coutts's avatar
Duncan Coutts committed
151
    planCompiler :: CompilerId
152
  }
Duncan Coutts's avatar
Duncan Coutts committed
153

154
invariant :: InstallPlan -> Bool
155
invariant plan =
156
  valid (planPlatform plan) (planCompiler plan) (planIndex plan)
157

158
159
160
internalError :: String -> a
internalError msg = error $ "InstallPlan: internal error: " ++ msg

Duncan Coutts's avatar
Duncan Coutts committed
161
162
-- | Build an installation plan from a valid set of resolved packages.
--
163
new :: Platform -> CompilerId -> PackageIndex PlanPackage
164
    -> Either [PlanProblem] InstallPlan
165
166
new platform compiler index =
  case problems platform compiler index of
167
    [] -> Right InstallPlan {
168
169
170
            planIndex    = index,
            planGraph    = graph,
            planGraphRev = Graph.transposeG graph,
171
            planPkgOf    = vertexToPkgId,
172
            planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex,
173
            planPlatform = platform,
174
175
176
177
178
            planCompiler = compiler
          }
      where (graph, vertexToPkgId, pkgIdToVertex) =
              PackageIndex.dependencyGraph index
            noSuchPkgId = internalError "package is not in the graph"
179
    probs -> Left probs
180

181
toList :: InstallPlan -> [PlanPackage]
182
toList = PackageIndex.allPackages . planIndex
Duncan Coutts's avatar
Duncan Coutts committed
183

184
185
186
-- | The packages that are ready to be installed. That is they are in the
-- configured state and have all their dependencies installed already.
-- The plan is complete if the result is @[]@.
Duncan Coutts's avatar
Duncan Coutts committed
187
--
188
ready :: InstallPlan -> [ConfiguredPackage]
189
ready plan = assert check readyPackages
190
  where
191
    check = if null readyPackages then null configuredPackages else True
192
193
194
195
196
197
198
199
    configuredPackages =
      [ pkg | Configured pkg <- PackageIndex.allPackages (planIndex plan) ]
    readyPackages = filter (all isInstalled . depends) configuredPackages
    isInstalled pkg =
      case PackageIndex.lookupPackageId (planIndex plan) pkg of
        Just (Configured  _) -> False
        Just (Failed    _ _) -> internalError depOnFailed
        Just (PreExisting _) -> True
200
        Just (Installed _ _) -> True
201
        Nothing              -> internalError incomplete
202
203
    incomplete  = "install plan is not closed"
    depOnFailed = "configured package depends on failed package"
Duncan Coutts's avatar
Duncan Coutts committed
204
205
206
207
208
209
210
211

-- | Marks a package in the graph as completed. Also saves the build result for
-- the completed package in the plan.
--
-- * The package must exist in the graph.
-- * The package must have had no uninstalled dependent packages.
--
completed :: PackageIdentifier
212
213
214
          -> BuildSuccess
          -> InstallPlan -> InstallPlan
completed pkgid buildResult plan = assert (invariant plan') plan'
215
  where
216
217
218
    plan'     = plan {
                  planIndex = PackageIndex.insert installed (planIndex plan)
                }
219
    installed = Installed (lookupConfiguredPackage plan pkgid) buildResult
Duncan Coutts's avatar
Duncan Coutts committed
220
221

-- | Marks a package in the graph as having failed. It also marks all the
222
-- packages that depended on it as having failed.
Duncan Coutts's avatar
Duncan Coutts committed
223
--
224
-- * The package must exist in the graph and be in the configured state.
Duncan Coutts's avatar
Duncan Coutts committed
225
--
226
failed :: PackageIdentifier -- ^ The id of the package that failed to install
227
228
229
230
       -> BuildFailure      -- ^ The build result to use for the failed package
       -> BuildFailure      -- ^ The build result to use for its dependencies
       -> InstallPlan
       -> InstallPlan
231
failed pkgid buildResult buildResult' plan = assert (invariant plan') plan'
Duncan Coutts's avatar
Duncan Coutts committed
232
  where
233
234
235
236
    plan'    = plan {
                 planIndex = PackageIndex.merge (planIndex plan) failures
               }
    pkg      = lookupConfiguredPackage plan pkgid
237
238
    failures = PackageIndex.fromList
             $ Failed pkg buildResult
239
             : [ Failed pkg' buildResult'
240
               | Just pkg' <- map checkConfiguredPackage
241
                            $ packagesThatDependOn plan pkgid ]
242
243
244

-- | lookup the reachable packages in the reverse dependency graph
--
245
packagesThatDependOn :: InstallPlan
246
247
                     -> PackageIdentifier -> [PlanPackage]
packagesThatDependOn plan = map (planPkgOf plan)
248
                          . tail
249
250
                          . Graph.reachable (planGraphRev plan)
                          . planVertexOf plan
251

252
253
-- | lookup a package that we expect to be in the configured state
--
254
lookupConfiguredPackage :: InstallPlan
255
256
257
258
                        -> PackageIdentifier -> ConfiguredPackage
lookupConfiguredPackage plan pkgid =
  case PackageIndex.lookupPackageId (planIndex plan) pkgid of
    Just (Configured pkg) -> pkg
259
260
    _  -> internalError $ "not configured or no such pkg " ++ display pkgid

261
-- | check a package that we expect to be in the configured or failed state
262
--
263
264
265
266
267
checkConfiguredPackage :: PlanPackage -> Maybe ConfiguredPackage
checkConfiguredPackage (Configured pkg) = Just pkg
checkConfiguredPackage (Failed     _ _) = Nothing
checkConfiguredPackage pkg                =
  internalError $ "not configured or no such pkg " ++ display (packageId pkg)
268

269
270
271
272
273
274
275
276
277
278
-- ------------------------------------------------------------
-- * Checking valididy of plans
-- ------------------------------------------------------------

-- | A valid installation plan is a set of packages that is 'acyclic',
-- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the
-- plan has to have a valid configuration (see 'configuredPackageValid').
--
-- * if the result is @False@ use 'problems' to get a detailed list.
--
279
280
valid :: Platform -> CompilerId -> PackageIndex PlanPackage -> Bool
valid platform comp index = null (problems platform comp index)
281

282
data PlanProblem =
283
     PackageInvalid       ConfiguredPackage [PackageProblem]
284
285
   | PackageMissingDeps   PlanPackage [PackageIdentifier]
   | PackageCycle         [PlanPackage]
286
   | PackageInconsistency PackageName [(PackageIdentifier, Version)]
287
   | PackageStateInvalid  PlanPackage PlanPackage
288

289
showPlanProblem :: PlanProblem -> String
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
showPlanProblem (PackageInvalid pkg packageProblems) =
     "Package " ++ display (packageId pkg)
  ++ " has an invalid configuration, in particular:\n"
  ++ unlines [ "  " ++ showPackageProblem problem
             | problem <- packageProblems ]

showPlanProblem (PackageMissingDeps pkg missingDeps) =
     "Package " ++ display (packageId pkg)
  ++ " depends on the following packages which are missing from the plan "
  ++ intercalate ", " (map display missingDeps)

showPlanProblem (PackageCycle cycleGroup) =
     "The following packages are involved in a dependency cycle "
  ++ intercalate ", " (map (display.packageId) cycleGroup)

showPlanProblem (PackageInconsistency name inconsistencies) =
306
     "Package " ++ display name
307
308
309
310
311
312
  ++ " is required by several packages,"
  ++ " but they require inconsistent versions:\n"
  ++ unlines [ "  package " ++ display pkg ++ " requires "
                            ++ display (PackageIdentifier name ver)
             | (pkg, ver) <- inconsistencies ]

313
314
315
316
317
318
319
320
321
showPlanProblem (PackageStateInvalid pkg pkg') =
     "Package " ++ display (packageId pkg)
  ++ " is in the " ++ showPlanState pkg
  ++ " state but it depends on package " ++ display (packageId pkg')
  ++ " which is in the " ++ showPlanState pkg'
  ++ " state"
  where
    showPlanState (PreExisting _) = "pre-existing"
    showPlanState (Configured  _) = "configured"
322
    showPlanState (Installed _ _) = "installed"
323
324
    showPlanState (Failed    _ _) = "failed"

325
326
327
328
-- | For an invalid plan, produce a detailed list of problems as human readable
-- error messages. This is mainly intended for debugging purposes.
-- Use 'showPlanProblem' for a human readable explanation.
--
329
problems :: Platform -> CompilerId
330
         -> PackageIndex PlanPackage -> [PlanProblem]
331
problems platform comp index =
332
333
     [ PackageInvalid pkg packageProblems
     | Configured pkg <- PackageIndex.allPackages index
334
     , let packageProblems = configuredPackageProblems platform comp pkg
335
     , not (null packageProblems) ]
336
337
338
339
340
341
342
343
344
345

  ++ [ PackageMissingDeps pkg missingDeps
     | (pkg, missingDeps) <- PackageIndex.brokenPackages index ]

  ++ [ PackageCycle cycleGroup
     | cycleGroup <- PackageIndex.dependencyCycles index ]

  ++ [ PackageInconsistency name inconsistencies
     | (name, inconsistencies) <- PackageIndex.dependencyInconsistencies index ]

346
347
348
349
350
  ++ [ PackageStateInvalid pkg pkg'
     | pkg <- PackageIndex.allPackages index
     , Just pkg' <- map (PackageIndex.lookupPackageId index) (depends pkg)
     , not (stateDependencyRelation pkg pkg') ]

351
352
353
354
355
-- | The graph of packages (nodes) and dependencies (edges) must be acyclic.
--
-- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out
--   which packages are involved in dependency cycles.
--
356
acyclic :: PackageIndex PlanPackage -> Bool
357
358
359
360
361
362
363
364
365
acyclic = null . PackageIndex.dependencyCycles

-- | An installation plan is closed if for every package in the set, all of
-- its dependencies are also in the set. That is, the set is closed under the
-- dependency relation.
--
-- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out
--   which packages depend on packages not in the index.
--
366
closed :: PackageIndex PlanPackage -> Bool
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
closed = null . PackageIndex.brokenPackages

-- | An installation plan is consistent if all dependencies that target a
-- single package name, target the same version.
--
-- This is slightly subtle. It is not the same as requiring that there be at
-- most one version of any package in the set. It only requires that of
-- packages which have more than one other package depending on them. We could
-- actually make the condition even more precise and say that different
-- versions are ok so long as they are not both in the transative closure of
-- any other package (or equivalently that their inverse closures do not
-- intersect). The point is we do not want to have any packages depending
-- directly or indirectly on two different versions of the same package. The
-- current definition is just a safe aproximation of that.
--
-- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to
--   find out which packages are.
--
385
consistent :: PackageIndex PlanPackage -> Bool
386
387
consistent = null . PackageIndex.dependencyInconsistencies

388
389
390
391
-- | The states of packages have that depend on each other must respect
-- this relation. That is for very case where package @a@ depends on
-- package @b@ we require that @dependencyStatesOk a b = True@.
--
392
stateDependencyRelation :: PlanPackage -> PlanPackage -> Bool
393
394
395
396
stateDependencyRelation (PreExisting _) (PreExisting _) = True

stateDependencyRelation (Configured  _) (PreExisting _) = True
stateDependencyRelation (Configured  _) (Configured  _) = True
397
stateDependencyRelation (Configured  _) (Installed _ _) = True
398

399
400
stateDependencyRelation (Installed _ _) (PreExisting _) = True
stateDependencyRelation (Installed _ _) (Installed _ _) = True
401
402

stateDependencyRelation (Failed    _ _) (PreExisting _) = True
403
404
405
406
-- failed can depends on configured because a package can depend on
-- several other packages and if one of the deps fail then we fail
-- but we still depend on the other ones that did not fail:
stateDependencyRelation (Failed    _ _) (Configured  _) = True
407
stateDependencyRelation (Failed    _ _) (Installed _ _) = True
408
409
410
411
stateDependencyRelation (Failed    _ _) (Failed    _ _) = True

stateDependencyRelation _               _               = False

412
413
414
415
-- | A 'ConfiguredPackage' is valid if the flag assignment is total and if
-- in the configuration given by the flag assignment, all the package
-- dependencies are satisfied by the specified packages.
--
416
417
418
configuredPackageValid :: Platform -> CompilerId -> ConfiguredPackage -> Bool
configuredPackageValid platform comp pkg =
  null (configuredPackageProblems platform comp pkg)
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455

data PackageProblem = DuplicateFlag FlagName
                    | MissingFlag   FlagName
                    | ExtraFlag     FlagName
                    | DuplicateDeps [PackageIdentifier]
                    | MissingDep    Dependency
                    | ExtraDep      PackageIdentifier
                    | InvalidDep    Dependency PackageIdentifier

showPackageProblem :: PackageProblem -> String
showPackageProblem (DuplicateFlag (FlagName flag)) =
  "duplicate flag in the flag assignment: " ++ flag

showPackageProblem (MissingFlag (FlagName flag)) =
  "missing an assignment for the flag: " ++ flag

showPackageProblem (ExtraFlag (FlagName flag)) =
  "extra flag given that is not used by the package: " ++ flag

showPackageProblem (DuplicateDeps pkgids) =
     "duplicate packages specified as selected dependencies: "
  ++ intercalate ", " (map display pkgids)

showPackageProblem (MissingDep dep) =
     "the package has a dependency " ++ display dep
  ++ " but no package has been selected to satisfy it."

showPackageProblem (ExtraDep pkgid) =
     "the package configuration specifies " ++ display pkgid
  ++ " but (with the given flag assignment) the package does not actually"
  ++ " depend on any version of that package."

showPackageProblem (InvalidDep dep pkgid) =
     "the package depends on " ++ display dep
  ++ " but the configuration specifies " ++ display pkgid
  ++ " which does not satisfy the dependency."

456
configuredPackageProblems :: Platform -> CompilerId
457
                          -> ConfiguredPackage -> [PackageProblem]
458
configuredPackageProblems platform comp
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
  (ConfiguredPackage pkg specifiedFlags specifiedDeps) =
     [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]
  ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]
  ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]
  ++ [ DuplicateDeps pkgs
     | pkgs <- duplicatesBy (comparing packageName) specifiedDeps ]
  ++ [ MissingDep dep       | OnlyInLeft  dep       <- mergedDeps ]
  ++ [ ExtraDep       pkgid | OnlyInRight     pkgid <- mergedDeps ]
  ++ [ InvalidDep dep pkgid | InBoth      dep pkgid <- mergedDeps
                            , not (packageSatisfiesDependency pkgid dep) ]
  where
    mergedFlags = mergeBy compare
      (sort $ map flagName (genPackageFlags (packageDescription pkg)))
      (sort $ map fst specifiedFlags)

    mergedDeps = mergeBy
      (\dep pkgid -> dependencyName dep `compare` packageName pkgid)
      (sortBy (comparing dependencyName) requiredDeps)
      (sortBy (comparing packageName)    specifiedDeps)

    packageSatisfiesDependency
      (PackageIdentifier name  version)
      (Dependency        name' versionRange) = assert (name == name') $
        version `withinRange` versionRange

    dependencyName (Dependency name _) = name

    requiredDeps :: [Dependency]
    requiredDeps =
      --TODO: use something lower level than finalizePackageDescription
      case finalizePackageDescription specifiedFlags
490
491
492
         (const True)
         platform comp
         []
493
         (packageDescription pkg) of
494
        Right (resolvedPkg, _) -> externalBuildDepends resolvedPkg
495
        Left  _ -> error "configuredPackageInvalidDeps internal error"