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

  -- * Operations on 'InstallPlan's
Duncan Coutts's avatar
Duncan Coutts committed
20
21
22
23
24
  new,
  toList,
  done,
  next,
  completed,
25
26
27
28
  failed,

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

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

import Hackage.Types
44
         ( AvailablePackage(packageDescription) )
Duncan Coutts's avatar
Duncan Coutts committed
45
import Distribution.Package
46
47
48
49
         ( PackageIdentifier(..), Package(..), PackageFixedDeps(..)
         , packageName, Dependency(..) )
import Distribution.Version
         ( Version, withinRange )
Duncan Coutts's avatar
Duncan Coutts committed
50
51
52
53
54
import Distribution.InstalledPackageInfo
         ( InstalledPackageInfo )
import Distribution.PackageDescription
         ( GenericPackageDescription(genPackageFlags)
         , PackageDescription(buildDepends)
55
         , Flag(flagName), FlagName(..), FlagAssignment )
Duncan Coutts's avatar
Duncan Coutts committed
56
57
58
import Distribution.PackageDescription.Configuration
         ( finalizePackageDescription )
import Distribution.Simple.PackageIndex
59
         ( PackageIndex )
Duncan Coutts's avatar
Duncan Coutts committed
60
61
62
63
64
65
66
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Text
         ( display )
import Distribution.System
         ( OS, Arch )
import Distribution.Compiler
         ( CompilerId(..) )
67
68
69
70
import Hackage.Utils
         ( duplicates, duplicatesBy, mergeBy, MergeResult(..) )
import Distribution.Simple.Utils
         ( comparing, intercalate )
Duncan Coutts's avatar
Duncan Coutts committed
71
72

import Data.List
73
         ( sort, sortBy )
74
75
76
77
import Data.Maybe
         ( fromMaybe )
import qualified Data.Graph as Graph
import Data.Graph (Graph)
Duncan Coutts's avatar
Duncan Coutts committed
78
79
80
81
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
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.
--
107
108
-- 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
109
110
111
112
--
-- 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
113
-- is closed if for every package in the set, all of its dependencies are
Duncan Coutts's avatar
Duncan Coutts committed
114
115
116
-- also in the set. It is consistent if for every package in the set, all
-- dependencies which target that package have the same version.

117
118
119
-- | A 'ConfiguredPackage' is a not-yet-installed package along with the
-- total configuration information. The configuration information is total in
-- the sense that it provides all the configuration information and so the
120
-- final configure process will be independent of the environment.
121
--
Duncan Coutts's avatar
Duncan Coutts committed
122
data ConfiguredPackage = ConfiguredPackage
123
       AvailablePackage    -- ^ package info, including repo
Duncan Coutts's avatar
Duncan Coutts committed
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
       FlagAssignment      -- ^ complete flag assignment for the package
       [PackageIdentifier] -- ^ exact dependencies, must be consistent with the
                           -- version constraints in the package info
  deriving Show

instance Package ConfiguredPackage where
  packageId (ConfiguredPackage pkg _ _) = packageId pkg

instance PackageFixedDeps ConfiguredPackage where
  depends (ConfiguredPackage _ _ deps) = deps

data PlanPackage buildResult = PreExisting InstalledPackageInfo
                             | Configured  ConfiguredPackage
                             | Installed   ConfiguredPackage
                             | Failed      ConfiguredPackage buildResult
  deriving Show

instance Package (PlanPackage buildResult) where
  packageId (PreExisting pkg) = packageId pkg
  packageId (Configured pkg)  = packageId pkg
  packageId (Installed pkg)   = packageId pkg
  packageId (Failed pkg _)    = packageId pkg

instance PackageFixedDeps (PlanPackage buildResult) where
  depends (PreExisting pkg) = depends pkg
  depends (Configured pkg)  = depends pkg
  depends (Installed pkg)   = depends pkg
  depends (Failed pkg _)    = depends pkg

data InstallPlan buildResult = InstallPlan {
    planIndex    :: PackageIndex (PlanPackage buildResult),
155
156
157
158
    planGraph    :: Graph,
    planGraphRev :: Graph,
    planPkgIdOf  :: Graph.Vertex -> PackageIdentifier,
    planVertexOf :: PackageIdentifier -> Graph.Vertex,
Duncan Coutts's avatar
Duncan Coutts committed
159
160
161
    planOS       :: OS,
    planArch     :: Arch,
    planCompiler :: CompilerId
162
  }
Duncan Coutts's avatar
Duncan Coutts committed
163

164
165
166
167
invariant :: InstallPlan a -> Bool
invariant plan =
  valid (planOS plan) (planArch plan) (planCompiler plan) (planIndex plan)

168
169
170
internalError :: String -> a
internalError msg = error $ "InstallPlan: internal error: " ++ msg

Duncan Coutts's avatar
Duncan Coutts committed
171
172
-- | Build an installation plan from a valid set of resolved packages.
--
173
174
new :: OS -> Arch -> CompilerId -> PackageIndex (PlanPackage a)
    -> Either (InstallPlan a) [PlanProblem a]
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
new os arch compiler index =
  case problems os arch compiler index of
    [] -> Left InstallPlan {
            planIndex    = index,
            planGraph    = graph,
            planGraphRev = Graph.transposeG graph,
            planPkgIdOf  = vertexToPkgId,
            planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex,
            planOS       = os,
            planArch     = arch,
            planCompiler = compiler
          }
      where (graph, vertexToPkgId, pkgIdToVertex) =
              PackageIndex.dependencyGraph index
            noSuchPkgId = internalError "package is not in the graph"
    probs -> Right probs
191
192
193

toList :: InstallPlan buildResult -> [PlanPackage buildResult]
toList = PackageIndex.allPackages . planIndex
Duncan Coutts's avatar
Duncan Coutts committed
194
195
196
197
198
199
200

-- | Is the plan completed?
--
done :: InstallPlan buildResult -> Bool
done (InstallPlan { planIndex = index}) =
  null [ () | Configured _ <- PackageIndex.allPackages index ]

201
202
-- | The next package, meaning a package which has all its dependencies
-- installed already.
Duncan Coutts's avatar
Duncan Coutts committed
203
204
205
206
--
-- * The graph must not be 'done'.
--
next :: InstallPlan buildResult -> ConfiguredPackage
207
next plan@(InstallPlan { planIndex = index }) = assert (invariant plan) $
Duncan Coutts's avatar
Duncan Coutts committed
208
209
210
211
212
213
  let allReadyPackages =
        [ pkg
        | Configured pkg <- PackageIndex.allPackages index
        , flip all (depends pkg) $ \dep ->
            case PackageIndex.lookupPackageId index dep of
              Just (Configured  _) -> False
214
              Just (Failed    _ _) -> internalError depOnFailed
Duncan Coutts's avatar
Duncan Coutts committed
215
216
              Just (PreExisting _) -> True
              Just (Installed   _) -> True
217
              Nothing -> internalError incomplete ]
Duncan Coutts's avatar
Duncan Coutts committed
218
  in case allReadyPackages of
219
    []      -> internalError noNextPkg
Duncan Coutts's avatar
Duncan Coutts committed
220
    (pkg:_) -> pkg
221
222
223
224
  where
    incomplete  = "install plan is not closed"
    noNextPkg   = "no configured pkg with all installed deps"
    depOnFailed = "configured package depends on failed package"
Duncan Coutts's avatar
Duncan Coutts committed
225
226
227
228
229
230
231
232
233
234
235

-- | 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
          -> InstallPlan buildResult -> InstallPlan buildResult
completed pkgid plan =
  case PackageIndex.lookupPackageId index pkgid of
236
    Just (Configured cp) -> plan { planIndex = PackageIndex.insert (Installed cp) index }
Duncan Coutts's avatar
Duncan Coutts committed
237
238
239
240
    _ -> error "InstallPlan.completed: internal error; cannot mark package as completed"
  where index = planIndex plan

-- | Marks a package in the graph as having failed. It also marks all the
241
-- packages that depended on it as having failed.
Duncan Coutts's avatar
Duncan Coutts committed
242
--
243
-- * The package must exist in the graph and be in the configured state.
Duncan Coutts's avatar
Duncan Coutts committed
244
--
245
246
247
248
249
250
251
252
failed :: PackageIdentifier -- ^ The id of the package that failed to install
       -> buildResult       -- ^ The build result to use for the failed package
       -> buildResult       -- ^ The build result to use for its dependencies
       -> InstallPlan buildResult
       -> InstallPlan buildResult
failed pkgid buildResult dependentBuildResult
       plan@(InstallPlan { planIndex = index }) =
  case PackageIndex.lookupPackageId index pkgid of
Duncan Coutts's avatar
Duncan Coutts committed
253
    Just (Configured cp) ->
254
255
256
257
258
259
260
               plan {
                 planIndex = markDepsAsFailed pkgid
                           . PackageIndex.insert (Failed cp buildResult)
                           $ index
               }
    Just _  -> error $ "InstallPlan.failed: not configured " ++ display pkgid
    Nothing -> error $ "InstallPlan.failed: no such package " ++ display pkgid
Duncan Coutts's avatar
Duncan Coutts committed
261
262
  where
  --markDepsAsFailed :: PackageIdentifier -> PackageIndex br -> PackageIndex br
263
264
  markDepsAsFailed pkgid' index' =
    case PackageIndex.lookupPackageId index' pkgid' of
Duncan Coutts's avatar
Duncan Coutts committed
265
      Just (Configured cp) ->
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
        let index'' = PackageIndex.insert (Failed cp dependentBuildResult) index'
            deps    = depends cp
        in foldr markDepsAsFailed index'' deps
      _ -> index'

-- ------------------------------------------------------------
-- * 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.
--
valid :: OS -> Arch -> CompilerId -> PackageIndex (PlanPackage a) -> Bool
valid os arch comp index = null (problems os arch comp index)

data PlanProblem a =
     PackageInvalid       ConfiguredPackage [PackageProblem]
   | PackageMissingDeps   (PlanPackage a) [PackageIdentifier]
   | PackageCycle         [PlanPackage a]
   | PackageInconsistency String [(PackageIdentifier, Version)]
289
   | PackageStateInvalid  (PlanPackage a) (PlanPackage a)
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314

showPlanProblem :: PlanProblem a -> String
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) =
     "Package " ++ name
  ++ " is required by several packages,"
  ++ " but they require inconsistent versions:\n"
  ++ unlines [ "  package " ++ display pkg ++ " requires "
                            ++ display (PackageIdentifier name ver)
             | (pkg, ver) <- inconsistencies ]

315
316
317
318
319
320
321
322
323
324
325
326
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"
    showPlanState (Installed   _) = "installed"
    showPlanState (Failed    _ _) = "failed"

327
328
329
330
331
332
333
-- | 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.
--
problems :: OS -> Arch -> CompilerId
         -> PackageIndex (PlanPackage a) -> [PlanProblem a]
problems os arch comp index =
334
335
336
337
     [ PackageInvalid pkg packageProblems
     | Configured pkg <- PackageIndex.allPackages index
     , let packageProblems = configuredPackageProblems os arch comp pkg
     , not (null packageProblems) ]
338
339
340
341
342
343
344
345
346
347

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

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

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

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

353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
-- | 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.
--
acyclic :: PackageIndex (PlanPackage a) -> Bool
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.
--
closed :: PackageIndex (PlanPackage a) -> Bool
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.
--
consistent :: PackageIndex (PlanPackage a) -> Bool
consistent = null . PackageIndex.dependencyInconsistencies

390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
-- | 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@.
--
stateDependencyRelation :: PlanPackage a -> PlanPackage a -> Bool
stateDependencyRelation (PreExisting _) (PreExisting _) = True

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

stateDependencyRelation (Installed   _) (PreExisting _) = True
stateDependencyRelation (Installed   _) (Installed   _) = True

stateDependencyRelation (Failed    _ _) (PreExisting _) = True
stateDependencyRelation (Failed    _ _) (Installed   _) = True
stateDependencyRelation (Failed    _ _) (Failed    _ _) = True

stateDependencyRelation _               _               = False

410
411
412
413
-- | 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.
--
414
415
416
417
418
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
456
457
458
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
490
491
configuredPackageValid :: OS -> Arch -> CompilerId -> ConfiguredPackage -> Bool
configuredPackageValid os arch comp pkg =
  null (configuredPackageProblems os arch comp pkg)

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

configuredPackageProblems :: OS -> Arch -> CompilerId
                          -> ConfiguredPackage -> [PackageProblem]
configuredPackageProblems os arch comp
  (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
         (Nothing :: Maybe (PackageIndex PackageIdentifier)) os arch comp []
         (packageDescription pkg) of
        Right (resolvedPkg, _) -> buildDepends resolvedPkg
        Left  _ -> error "configuredPackageInvalidDeps internal error"