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

  -- * Operations on 'InstallPlan's
Duncan Coutts's avatar
Duncan Coutts committed
23
24
  new,
  toList,
Duncan Coutts's avatar
Duncan Coutts committed
25
26
  mapPreservingGraph,

27
  ready,
28
  processing,
Duncan Coutts's avatar
Duncan Coutts committed
29
  completed,
30
  failed,
31
  remove,
Duncan Coutts's avatar
Duncan Coutts committed
32
  preexisting,
33
  preinstalled,
Duncan Coutts's avatar
Duncan Coutts committed
34

35
36
  showPlanIndex,
  showInstallPlan,
37

refold's avatar
refold committed
38
  -- * Checking validity of plans
39
  valid,
40
  closed,
41
42
  consistent,
  acyclic,
43
44
45
46
47

  -- ** Details on invalid plans
  PlanProblem(..),
  showPlanProblem,
  problems,
48
49
50

  -- ** Querying the install plan
  dependencyClosure,
51
52
53
  reverseDependencyClosure,
  topologicalOrder,
  reverseTopologicalOrder,
Duncan Coutts's avatar
Duncan Coutts committed
54
55
  ) where

56
57
import Distribution.InstalledPackageInfo
         ( InstalledPackageInfo )
Duncan Coutts's avatar
Duncan Coutts committed
58
import Distribution.Package
59
         ( PackageIdentifier(..), PackageName(..), Package(..)
60
         , HasUnitId(..), UnitId(..) )
61
import Distribution.Client.Types
62
63
         ( BuildSuccess, BuildFailure
         , PackageFixedDeps(..), ConfiguredPackage
64
         , GenericReadyPackage(..), fakeUnitId )
65
import Distribution.Version
66
         ( Version )
67
68
import Distribution.Client.ComponentDeps (ComponentDeps)
import qualified Distribution.Client.ComponentDeps as CD
69
import Distribution.Simple.PackageIndex
70
         ( PackageIndex )
71
import qualified Distribution.Simple.PackageIndex as PackageIndex
72
73
import Distribution.Client.PlanIndex
         ( FakeMap )
74
import qualified Distribution.Client.PlanIndex as PlanIndex
Duncan Coutts's avatar
Duncan Coutts committed
75
76
77
import Distribution.Text
         ( display )

78
import Data.List
Duncan Coutts's avatar
Duncan Coutts committed
79
         ( foldl', intercalate )
80
import Data.Maybe
81
         ( fromMaybe, catMaybes )
82
83
import qualified Data.Graph as Graph
import Data.Graph (Graph)
84
import qualified Data.Tree as Tree
85
import Distribution.Compat.Binary (Binary(..))
86
import GHC.Generics
Duncan Coutts's avatar
Duncan Coutts committed
87
88
import Control.Exception
         ( assert )
89
import qualified Data.Map as Map
90
import qualified Data.Traversable as T
91

Duncan Coutts's avatar
Duncan Coutts committed
92
93
94
95
96
97

-- When cabal tries to install a number of packages, including all their
-- dependencies it has a non-trivial problem to solve.
--
-- The Problem:
--
98
-- In general we start with a set of installed packages and a set of source
Duncan Coutts's avatar
Duncan Coutts committed
99
100
101
102
-- packages.
--
-- Installed packages have fixed dependencies. They have already been built and
-- we know exactly what packages they were built against, including their exact
Andres Löh's avatar
Andres Löh committed
103
-- versions.
Duncan Coutts's avatar
Duncan Coutts committed
104
--
105
-- Source package have somewhat flexible dependencies. They are specified as
Duncan Coutts's avatar
Duncan Coutts committed
106
107
108
109
110
111
-- 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
112
113
114
115
116
117
-- packages that are also available as source packages which means they could
-- be re-installed if required, though there will also be packages which are
-- not available as source 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 source ones or perhaps always prefer the latest
-- available version whether installed or not.
Duncan Coutts's avatar
Duncan Coutts committed
118
--
119
120
-- 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
121
122
--
-- An installation plan is a set of packages that are going to be used
123
-- together. It will consist of a mixture of installed packages and source
Duncan Coutts's avatar
Duncan Coutts committed
124
-- packages along with their exact version dependencies. An installation plan
125
-- is closed if for every package in the set, all of its dependencies are
Duncan Coutts's avatar
Duncan Coutts committed
126
127
128
-- also in the set. It is consistent if for every package in the set, all
-- dependencies which target that package have the same version.

129
130
-- 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
refold's avatar
refold committed
131
-- is simultaneously valid for A and B. In particular you're most likely to
132
133
134
-- have problems with inconsistent dependencies.
-- On the other hand it is true that every closed sub plan is valid.

Edsko de Vries's avatar
Edsko de Vries committed
135
136
-- | Packages in an install plan
--
137
138
139
140
141
142
143
144
145
146
-- NOTE: 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage'
-- intentionally have no 'PackageInstalled' instance. `This is important:
-- PackageInstalled returns only library dependencies, but for package that
-- aren't yet installed we know many more kinds of dependencies (setup
-- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on
-- dependencies in cabal-install should consider what to do with these
-- dependencies; if we give a 'PackageInstalled' instance it would be too easy
-- to get this wrong (and, for instance, call graph traversal functions from
-- Cabal rather than from cabal-install). Instead, see 'PackageFixedDeps'.
data GenericPlanPackage ipkg srcpkg iresult ifailure
147
148
   = PreExisting ipkg
   | Configured  srcpkg
149
150
   | Processing  (GenericReadyPackage srcpkg ipkg)
   | Installed   (GenericReadyPackage srcpkg ipkg) (Maybe ipkg) iresult
151
   | Failed      srcpkg ifailure
152
153
154
155
  deriving (Eq, Show, Generic)

instance (Binary ipkg, Binary srcpkg, Binary  iresult, Binary  ifailure)
      => Binary (GenericPlanPackage ipkg srcpkg iresult ifailure)
156

157
158
159
160
type PlanPackage = GenericPlanPackage
                   InstalledPackageInfo ConfiguredPackage
                   BuildSuccess BuildFailure

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
161
instance (Package ipkg, Package srcpkg) =>
162
         Package (GenericPlanPackage ipkg srcpkg iresult ifailure) where
163
164
165
166
167
168
169
  packageId (PreExisting ipkg)     = packageId ipkg
  packageId (Configured  spkg)     = packageId spkg
  packageId (Processing  rpkg)     = packageId rpkg
  packageId (Installed   rpkg _ _) = packageId rpkg
  packageId (Failed      spkg   _) = packageId spkg

instance (PackageFixedDeps srcpkg,
170
          PackageFixedDeps ipkg, HasUnitId ipkg) =>
171
         PackageFixedDeps (GenericPlanPackage ipkg srcpkg iresult ifailure) where
172
173
174
175
176
177
  depends (PreExisting pkg)     = depends pkg
  depends (Configured  pkg)     = depends pkg
  depends (Processing  pkg)     = depends pkg
  depends (Installed   pkg _ _) = depends pkg
  depends (Failed      pkg   _) = depends pkg

178
179
instance (HasUnitId ipkg, HasUnitId srcpkg) =>
         HasUnitId
180
         (GenericPlanPackage ipkg srcpkg iresult ifailure) where
181
182
183
  installedUnitId (PreExisting ipkg ) = installedUnitId ipkg
  installedUnitId (Configured  spkg)  = installedUnitId spkg
  installedUnitId (Processing  rpkg)  = installedUnitId rpkg
184
  -- NB: defer to the actual installed package info in this case
185
186
187
  installedUnitId (Installed _ (Just ipkg) _) = installedUnitId ipkg
  installedUnitId (Installed rpkg _        _) = installedUnitId rpkg
  installedUnitId (Failed      spkg        _) = installedUnitId spkg
188

189

190
data GenericInstallPlan ipkg srcpkg iresult ifailure = GenericInstallPlan {
191
192
193
194
    planIndex      :: !(PlanIndex ipkg srcpkg iresult ifailure),
    planFakeMap    :: !FakeMap,
    planIndepGoals :: !Bool,

195
196
197
198
199
200
    -- | Cached (lazily) graph
    --
    -- The 'Graph' representaion works in terms of integer node ids, so we
    -- have to keep mapping to and from our meaningful nodes, which of course
    -- are package ids.
    --
201
    planGraph      :: Graph,
202
203
204
    planGraphRev   :: Graph,  -- ^ Reverse deps, transposed
    planPkgIdOf    :: Graph.Vertex -> UnitId, -- ^ mapping back to package ids
    planVertexOf   :: UnitId -> Graph.Vertex  -- ^ mapping into node ids
205
  }
Duncan Coutts's avatar
Duncan Coutts committed
206

207
-- | Much like 'planPkgIdOf', but mapping back to full packages.
208
209
210
211
212
213
214
215
216
217
planPkgOf :: GenericInstallPlan ipkg srcpkg iresult ifailure
          -> Graph.Vertex
          -> GenericPlanPackage ipkg srcpkg iresult ifailure
planPkgOf plan v =
    case PackageIndex.lookupUnitId (planIndex plan)
                                   (planPkgIdOf plan v) of
      Just pkg -> pkg
      Nothing  -> error "InstallPlan: internal error: planPkgOf lookup failed"


218
219
220
221
222
-- | 'GenericInstallPlan' specialised to most commonly used types.
type InstallPlan = GenericInstallPlan
                   InstalledPackageInfo ConfiguredPackage
                   BuildSuccess BuildFailure

223
type PlanIndex ipkg srcpkg iresult ifailure =
224
     PackageIndex (GenericPlanPackage ipkg srcpkg iresult ifailure)
225

226
227
invariant :: (HasUnitId ipkg,   PackageFixedDeps ipkg,
              HasUnitId srcpkg, PackageFixedDeps srcpkg)
228
          => GenericInstallPlan ipkg srcpkg iresult ifailure -> Bool
229
invariant plan =
230
    valid (planFakeMap plan)
231
232
          (planIndepGoals plan)
          (planIndex plan)
233

234
235
-- | Smart constructor that deals with caching the 'Graph' representation.
--
236
237
238
239
240
241
242
243
244
245
246
247
mkInstallPlan :: (HasUnitId ipkg,   PackageFixedDeps ipkg,
                  HasUnitId srcpkg, PackageFixedDeps srcpkg)
              => PlanIndex ipkg srcpkg iresult ifailure
              -> FakeMap
              -> Bool
              -> GenericInstallPlan ipkg srcpkg iresult ifailure
mkInstallPlan index fakeMap indepGoals =
    GenericInstallPlan {
      planIndex      = index,
      planFakeMap    = fakeMap,
      planIndepGoals = indepGoals,

248
      -- lazily cache the graph stuff:
249
250
      planGraph      = graph,
      planGraphRev   = Graph.transposeG graph,
251
      planPkgIdOf    = vertexToPkgId,
252
253
254
255
256
257
258
      planVertexOf   = fromMaybe noSuchPkgId . pkgIdToVertex
    }
  where
    (graph, vertexToPkgId, pkgIdToVertex) =
      PlanIndex.dependencyGraph fakeMap index
    noSuchPkgId = internalError "package is not in the graph"

259
260
261
internalError :: String -> a
internalError msg = error $ "InstallPlan: internal error: " ++ msg

262
263
264
265
266
267
268
269
270
271
272
273
274
275
instance (HasUnitId ipkg,   PackageFixedDeps ipkg,
          HasUnitId srcpkg, PackageFixedDeps srcpkg,
          Binary ipkg, Binary srcpkg, Binary iresult, Binary ifailure)
       => Binary (GenericInstallPlan ipkg srcpkg iresult ifailure) where
    put GenericInstallPlan {
              planIndex      = index,
              planFakeMap    = fakeMap,
              planIndepGoals = indepGoals
        } = put (index, fakeMap, indepGoals)

    get = do
      (index, fakeMap, indepGoals) <- get
      return $! mkInstallPlan index fakeMap indepGoals

276
showPlanIndex :: (HasUnitId ipkg, HasUnitId srcpkg)
277
              => PlanIndex ipkg srcpkg iresult ifailure -> String
278
279
280
281
282
showPlanIndex index =
    intercalate "\n" (map showPlanPackage (PackageIndex.allPackages index))
  where showPlanPackage p =
            showPlanPackageTag p ++ " "
                ++ display (packageId p) ++ " ("
283
                ++ display (installedUnitId p) ++ ")"
284

285
showInstallPlan :: (HasUnitId ipkg, HasUnitId srcpkg)
286
                => GenericInstallPlan ipkg srcpkg iresult ifailure -> String
287
288
showInstallPlan plan =
    showPlanIndex (planIndex plan) ++ "\n" ++
289
290
    "fake map:\n  " ++
    intercalate "\n  " (map showKV (Map.toList (planFakeMap plan)))
291
292
  where showKV (k,v) = display k ++ " -> " ++ display v

293
showPlanPackageTag :: GenericPlanPackage ipkg srcpkg iresult ifailure -> String
294
295
296
297
298
showPlanPackageTag (PreExisting _)   = "PreExisting"
showPlanPackageTag (Configured  _)   = "Configured"
showPlanPackageTag (Processing  _)   = "Processing"
showPlanPackageTag (Installed _ _ _) = "Installed"
showPlanPackageTag (Failed    _   _) = "Failed"
299

Duncan Coutts's avatar
Duncan Coutts committed
300
301
-- | Build an installation plan from a valid set of resolved packages.
--
302
303
new :: (HasUnitId ipkg,   PackageFixedDeps ipkg,
        HasUnitId srcpkg, PackageFixedDeps srcpkg)
304
    => Bool
305
306
    -> PlanIndex ipkg srcpkg iresult ifailure
    -> Either [PlanProblem ipkg srcpkg iresult ifailure]
307
              (GenericInstallPlan ipkg srcpkg iresult ifailure)
308
new indepGoals index =
309
310
311
312
313
  -- NB: Need to pre-initialize the fake-map with pre-existing
  -- packages
  let isPreExisting (PreExisting _) = True
      isPreExisting _ = False
      fakeMap = Map.fromList
314
315
              . map (\p -> (fakeUnitId (packageId p)
                           ,installedUnitId p))
316
317
              . filter isPreExisting
              $ PackageIndex.allPackages index in
318
  case problems fakeMap indepGoals index of
319
    []    -> Right (mkInstallPlan index fakeMap indepGoals)
320
    probs -> Left probs
321

322
323
toList :: GenericInstallPlan ipkg srcpkg iresult ifailure
       -> [GenericPlanPackage ipkg srcpkg iresult ifailure]
324
toList = PackageIndex.allPackages . planIndex
Duncan Coutts's avatar
Duncan Coutts committed
325

326
327
328
329
330
331
-- | Remove packages from the install plan. This will result in an
-- error if there are remaining packages that depend on any matching
-- package. This is primarily useful for obtaining an install plan for
-- the dependencies of a package or set of packages without actually
-- installing the package itself, as when doing development.
--
332
333
remove :: (HasUnitId ipkg,   PackageFixedDeps ipkg,
           HasUnitId srcpkg, PackageFixedDeps srcpkg)
334
335
       => (GenericPlanPackage ipkg srcpkg iresult ifailure -> Bool)
       -> GenericInstallPlan ipkg srcpkg iresult ifailure
336
       -> Either [PlanProblem ipkg srcpkg iresult ifailure]
337
                 (GenericInstallPlan ipkg srcpkg iresult ifailure)
338
remove shouldRemove plan =
339
    new (planIndepGoals plan) newIndex
340
341
342
  where
    newIndex = PackageIndex.fromList $
                 filter (not . shouldRemove) (toList plan)
343

344
345
346
-- | 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
347
--
348
ready :: forall ipkg srcpkg iresult ifailure. PackageFixedDeps srcpkg
349
350
      => GenericInstallPlan ipkg srcpkg iresult ifailure
      -> [GenericReadyPackage srcpkg ipkg]
351
ready plan = assert check readyPackages
352
  where
353
    check = if null readyPackages && null processingPackages
354
355
356
357
              then null configuredPackages
              else True
    configuredPackages = [ pkg | Configured pkg <- toList plan ]
    processingPackages = [ pkg | Processing pkg <- toList plan]
358

359
    readyPackages :: [GenericReadyPackage srcpkg ipkg]
360
361
362
363
364
365
366
367
368
369
370
    readyPackages = catMaybes (map (lookupReadyPackage plan) configuredPackages)

lookupReadyPackage :: forall ipkg srcpkg iresult ifailure.
                      PackageFixedDeps srcpkg
                   => GenericInstallPlan ipkg srcpkg iresult ifailure
                   -> srcpkg
                   -> Maybe (GenericReadyPackage srcpkg ipkg)
lookupReadyPackage plan pkg = do
    deps <- hasAllInstalledDeps pkg
    return (ReadyPackage pkg deps)
  where
371

372
    hasAllInstalledDeps :: srcpkg -> Maybe (ComponentDeps [ipkg])
373
    hasAllInstalledDeps = T.mapM (mapM isInstalledDep) . depends
374

375
    isInstalledDep :: UnitId -> Maybe ipkg
376
    isInstalledDep pkgid =
377
378
      -- NB: Need to check if the ID has been updated in planFakeMap, in which
      -- case we might be dealing with an old pointer
379
      case PlanIndex.fakeLookupUnitId
380
381
           (planFakeMap plan) (planIndex plan) pkgid
      of
382
383
384
385
386
387
388
        Just (PreExisting ipkg)            -> Just ipkg
        Just (Configured  _)               -> Nothing
        Just (Processing  _)               -> Nothing
        Just (Installed   _ (Just ipkg) _) -> Just ipkg
        Just (Installed   _ Nothing     _) -> internalError depOnNonLib
        Just (Failed      _             _) -> internalError depOnFailed
        Nothing                            -> internalError incomplete
389
390
    incomplete  = "install plan is not closed"
    depOnFailed = "configured package depends on failed package"
391
    depOnNonLib = "configured package depends on a non-library package"
Duncan Coutts's avatar
Duncan Coutts committed
392

393
394
395
396
-- | Marks packages in the graph as currently processing (e.g. building).
--
-- * The package must exist in the graph and be in the configured state.
--
397
398
processing :: (HasUnitId ipkg,   PackageFixedDeps ipkg,
               HasUnitId srcpkg, PackageFixedDeps srcpkg)
399
400
401
           => [GenericReadyPackage srcpkg ipkg]
           -> GenericInstallPlan ipkg srcpkg iresult ifailure
           -> GenericInstallPlan ipkg srcpkg iresult ifailure
402
403
404
405
406
407
408
processing pkgs plan = assert (invariant plan') plan'
  where
    plan' = plan {
              planIndex = PackageIndex.merge (planIndex plan) processingPkgs
            }
    processingPkgs = PackageIndex.fromList [Processing pkg | pkg <- pkgs]

Duncan Coutts's avatar
Duncan Coutts committed
409
410
411
-- | Marks a package in the graph as completed. Also saves the build result for
-- the completed package in the plan.
--
412
-- * The package must exist in the graph and be in the processing state.
Duncan Coutts's avatar
Duncan Coutts committed
413
414
-- * The package must have had no uninstalled dependent packages.
--
415
416
417
completed :: (HasUnitId ipkg,   PackageFixedDeps ipkg,
              HasUnitId srcpkg, PackageFixedDeps srcpkg)
          => UnitId
418
          -> Maybe ipkg -> iresult
419
420
          -> GenericInstallPlan ipkg srcpkg iresult ifailure
          -> GenericInstallPlan ipkg srcpkg iresult ifailure
421
completed pkgid mipkg buildResult plan = assert (invariant plan') plan'
422
  where
423
    plan'     = plan {
424
425
                  -- NB: installation can change the IPID, so better
                  -- record it in the fake mapping...
426
                  planFakeMap = insert_fake_mapping mipkg
427
428
                              $ planFakeMap plan,
                  planIndex = PackageIndex.insert installed
429
                            . PackageIndex.deleteUnitId pkgid
430
                            $ planIndex plan
431
                }
432
433
    -- ...but be sure to use the *old* IPID for the lookup for the
    -- preexisting record
434
    installed = Installed (lookupProcessingPackage plan pkgid) mipkg buildResult
435
    insert_fake_mapping (Just ipkg) = Map.insert pkgid (installedUnitId ipkg)
436
    insert_fake_mapping  _          = id
Duncan Coutts's avatar
Duncan Coutts committed
437
438

-- | Marks a package in the graph as having failed. It also marks all the
439
-- packages that depended on it as having failed.
Duncan Coutts's avatar
Duncan Coutts committed
440
--
441
442
-- * The package must exist in the graph and be in the processing
-- state.
Duncan Coutts's avatar
Duncan Coutts committed
443
--
444
445
446
failed :: (HasUnitId ipkg,   PackageFixedDeps ipkg,
           HasUnitId srcpkg, PackageFixedDeps srcpkg)
       => UnitId         -- ^ The id of the package that failed to install
447
448
       -> ifailure           -- ^ The build result to use for the failed package
       -> ifailure           -- ^ The build result to use for its dependencies
449
450
       -> GenericInstallPlan ipkg srcpkg iresult ifailure
       -> GenericInstallPlan ipkg srcpkg iresult ifailure
451
failed pkgid buildResult buildResult' plan = assert (invariant plan') plan'
Duncan Coutts's avatar
Duncan Coutts committed
452
  where
453
    -- NB: failures don't update IPIDs
454
455
456
    plan'    = plan {
                 planIndex = PackageIndex.merge (planIndex plan) failures
               }
457
    ReadyPackage srcpkg _deps = lookupProcessingPackage plan pkgid
458
    failures = PackageIndex.fromList
459
             $ Failed srcpkg buildResult
460
             : [ Failed pkg' buildResult'
461
               | Just pkg' <- map checkConfiguredPackage
462
                            $ packagesThatDependOn plan pkgid ]
463

464
-- | Lookup the reachable packages in the reverse dependency graph.
465
--
466
packagesThatDependOn :: GenericInstallPlan ipkg srcpkg iresult ifailure
467
                     -> UnitId
468
                     -> [GenericPlanPackage ipkg srcpkg iresult ifailure]
469
packagesThatDependOn plan pkgid = map (planPkgOf plan)
470
                          . tail
471
472
                          . Graph.reachable (planGraphRev plan)
                          . planVertexOf plan
473
                          $ Map.findWithDefault pkgid pkgid (planFakeMap plan)
474

475
-- | Lookup a package that we expect to be in the processing state.
476
--
477
lookupProcessingPackage :: GenericInstallPlan ipkg srcpkg iresult ifailure
478
                        -> UnitId
479
                        -> GenericReadyPackage srcpkg ipkg
480
lookupProcessingPackage plan pkgid =
481
482
  -- NB: processing packages are guaranteed to not indirect through
  -- planFakeMap
483
  case PackageIndex.lookupUnitId (planIndex plan) pkgid of
484
    Just (Processing pkg) -> pkg
485
486
    _  -> internalError $ "not in processing state or no such pkg " ++
                          display pkgid
487

488
-- | Check a package that we expect to be in the configured or failed state.
489
--
490
checkConfiguredPackage :: (Package srcpkg, Package ipkg)
491
                       => GenericPlanPackage ipkg srcpkg iresult ifailure
492
                       -> Maybe srcpkg
493
494
495
496
checkConfiguredPackage (Configured pkg) = Just pkg
checkConfiguredPackage (Failed     _ _) = Nothing
checkConfiguredPackage pkg                =
  internalError $ "not configured or no such pkg " ++ display (packageId pkg)
497

Duncan Coutts's avatar
Duncan Coutts committed
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
-- | Replace a ready package with a pre-existing one. The pre-existing one
-- must have exactly the same dependencies as the source one was configured
-- with.
--
preexisting :: (HasUnitId ipkg,   PackageFixedDeps ipkg,
                HasUnitId srcpkg, PackageFixedDeps srcpkg)
            => UnitId
            -> ipkg
            -> GenericInstallPlan ipkg srcpkg iresult ifailure
            -> GenericInstallPlan ipkg srcpkg iresult ifailure
preexisting pkgid ipkg plan = assert (invariant plan') plan'
  where
    plan' = plan {
                    -- NB: installation can change the IPID, so better
                    -- record it in the fake mapping...
      planFakeMap = Map.insert pkgid
                               (installedUnitId ipkg)
                               (planFakeMap plan),
      planIndex   = PackageIndex.insert (PreExisting ipkg)
                    -- ...but be sure to use the *old* IPID for the lookup for
                    -- the preexisting record
                  . PackageIndex.deleteUnitId pkgid
                  $ planIndex plan
    }

523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
-- | Replace a ready package with an installed one. The installed one
-- must have exactly the same dependencies as the source one was configured
-- with.
--
preinstalled :: (HasUnitId ipkg,   PackageFixedDeps ipkg,
                 HasUnitId srcpkg, PackageFixedDeps srcpkg)
             => UnitId
             -> Maybe ipkg -> iresult
             -> GenericInstallPlan ipkg srcpkg iresult ifailure
             -> GenericInstallPlan ipkg srcpkg iresult ifailure
preinstalled pkgid mipkg buildResult plan = assert (invariant plan') plan'
  where
    plan' = plan { planIndex = PackageIndex.insert installed (planIndex plan) }
    Just installed = do
      Configured pkg <- PackageIndex.lookupUnitId (planIndex plan) pkgid
      rpkg <- lookupReadyPackage plan pkg
      return (Installed rpkg mipkg buildResult)

Duncan Coutts's avatar
Duncan Coutts committed
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
-- | Transform an install plan by mapping a function over all the packages in
-- the plan. It can consistently change the 'UnitId' of all the packages,
-- while preserving the same overall graph structure.
--
-- The mapping function has a few constraints on it for correct operation.
-- The mapping function /may/ change the 'UnitId' of the package, but it
-- /must/ also remap the 'UnitId's of its dependencies using ths supplied
-- remapping function. Apart from this consistent remapping it /may not/
-- change the structure of the dependencies.
--
mapPreservingGraph :: (HasUnitId ipkg,
                       HasUnitId srcpkg,
                       HasUnitId ipkg',   PackageFixedDeps ipkg',
                       HasUnitId srcpkg', PackageFixedDeps srcpkg')
                   => (  (UnitId -> UnitId)
                      -> GenericPlanPackage ipkg  srcpkg  iresult  ifailure
                      -> GenericPlanPackage ipkg' srcpkg' iresult' ifailure')
                   -> GenericInstallPlan ipkg  srcpkg  iresult  ifailure
                   -> GenericInstallPlan ipkg' srcpkg' iresult' ifailure'
mapPreservingGraph f plan =
    mkInstallPlan (PackageIndex.fromList pkgs')
                  Map.empty -- empty fakeMap
                  (planIndepGoals plan)
  where
    -- The package mapping function may change the UnitId. So we
    -- walk over the packages in dependency order keeping track of these
    -- package id changes and use it to supply the correct set of package
    -- dependencies as an extra input to the package mapping function.
    --
    -- Having fully remapped all the deps this also means we can use an empty
    -- FakeMap for the resulting install plan.

    (_, pkgs') = foldl' f' (Map.empty, []) (reverseTopologicalOrder plan)

    f' (ipkgidMap, pkgs) pkg = (ipkgidMap', pkg' : pkgs)
      where
       pkg' = f (mapDep ipkgidMap) pkg

       ipkgidMap'
         | ipkgid /= ipkgid' = Map.insert ipkgid ipkgid' ipkgidMap
         | otherwise         =                           ipkgidMap
         where
           ipkgid  = installedUnitId pkg
           ipkgid' = installedUnitId pkg'

    mapDep ipkgidMap ipkgid = Map.findWithDefault ipkgid ipkgid ipkgidMap


589
-- ------------------------------------------------------------
Ian D. Bollinger's avatar
Ian D. Bollinger committed
590
-- * Checking validity of plans
591
592
593
594
595
596
597
598
-- ------------------------------------------------------------

-- | 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.
--
599
600
valid :: (HasUnitId ipkg,   PackageFixedDeps ipkg,
          HasUnitId srcpkg, PackageFixedDeps srcpkg)
601
602
603
      => FakeMap -> Bool
      -> PlanIndex ipkg srcpkg iresult ifailure
      -> Bool
604
605
valid fakeMap indepGoals index =
    null $ problems fakeMap indepGoals index
606

607
data PlanProblem ipkg srcpkg iresult ifailure =
608
     PackageMissingDeps   (GenericPlanPackage ipkg srcpkg iresult ifailure)
609
                          [PackageIdentifier]
610
   | PackageCycle         [GenericPlanPackage ipkg srcpkg iresult ifailure]
611
   | PackageInconsistency PackageName [(PackageIdentifier, Version)]
612
613
   | PackageStateInvalid  (GenericPlanPackage ipkg srcpkg iresult ifailure)
                          (GenericPlanPackage ipkg srcpkg iresult ifailure)
614

615
616
showPlanProblem :: (Package ipkg, Package srcpkg)
                => PlanProblem ipkg srcpkg iresult ifailure -> String
617
618
showPlanProblem (PackageMissingDeps pkg missingDeps) =
     "Package " ++ display (packageId pkg)
619
  ++ " depends on the following packages which are missing from the plan: "
620
621
622
623
624
625
626
  ++ 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) =
627
     "Package " ++ display name
628
629
630
631
632
633
  ++ " is required by several packages,"
  ++ " but they require inconsistent versions:\n"
  ++ unlines [ "  package " ++ display pkg ++ " requires "
                            ++ display (PackageIdentifier name ver)
             | (pkg, ver) <- inconsistencies ]

634
635
636
637
638
639
640
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
641
642
643
644
645
    showPlanState (PreExisting _)   = "pre-existing"
    showPlanState (Configured  _)   = "configured"
    showPlanState (Processing  _)   = "processing"
    showPlanState (Installed _ _ _) = "installed"
    showPlanState (Failed    _   _) = "failed"
646

647
648
649
650
-- | 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.
--
651
652
problems :: (HasUnitId ipkg,   PackageFixedDeps ipkg,
             HasUnitId srcpkg, PackageFixedDeps srcpkg)
653
654
655
         => FakeMap -> Bool
         -> PlanIndex ipkg srcpkg iresult ifailure
         -> [PlanProblem ipkg srcpkg iresult ifailure]
656
problems fakeMap indepGoals index =
657

658
659
660
     [ PackageMissingDeps pkg
       (catMaybes
        (map
661
         (fmap packageId . PlanIndex.fakeLookupUnitId fakeMap index)
662
         missingDeps))
663
     | (pkg, missingDeps) <- PlanIndex.brokenPackages fakeMap index ]
664
665

  ++ [ PackageCycle cycleGroup
666
     | cycleGroup <- PlanIndex.dependencyCycles fakeMap index ]
667
668

  ++ [ PackageInconsistency name inconsistencies
669
670
     | (name, inconsistencies) <-
       PlanIndex.dependencyInconsistencies fakeMap indepGoals index ]
671

672
673
  ++ [ PackageStateInvalid pkg pkg'
     | pkg <- PackageIndex.allPackages index
674
     , Just pkg' <- map (PlanIndex.fakeLookupUnitId fakeMap index)
675
                    (CD.flatDeps (depends pkg))
676
677
     , not (stateDependencyRelation pkg pkg') ]

678
679
680
681
682
-- | 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.
--
683
684
acyclic :: (HasUnitId ipkg,   PackageFixedDeps ipkg,
            HasUnitId srcpkg, PackageFixedDeps srcpkg)
685
        => FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool
686
acyclic fakeMap = null . PlanIndex.dependencyCycles fakeMap
687
688
689
690
691
692
693
694

-- | 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.
--
695
closed :: (HasUnitId ipkg, PackageFixedDeps ipkg,
696
697
           PackageFixedDeps srcpkg)
       => FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool
698
closed fakeMap = null . PlanIndex.brokenPackages fakeMap
699
700
701
702
703
704
705
706

-- | 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
Ian D. Bollinger's avatar
Ian D. Bollinger committed
707
-- versions are OK so long as they are not both in the transitive closure of
708
709
710
-- 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
Ian D. Bollinger's avatar
Ian D. Bollinger committed
711
-- current definition is just a safe approximation of that.
712
713
714
715
--
-- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to
--   find out which packages are.
--
716
717
consistent :: (HasUnitId ipkg,   PackageFixedDeps ipkg,
               HasUnitId srcpkg, PackageFixedDeps srcpkg)
718
           => FakeMap -> PlanIndex ipkg srcpkg iresult ifailure -> Bool
719
consistent fakeMap = null . PlanIndex.dependencyInconsistencies fakeMap False
720

721
722
723
724
-- | 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@.
--
725
726
stateDependencyRelation :: GenericPlanPackage ipkg srcpkg iresult ifailure
                        -> GenericPlanPackage ipkg srcpkg iresult ifailure
727
728
                        -> Bool
stateDependencyRelation (PreExisting _) (PreExisting _)   = True
729

730
731
732
733
stateDependencyRelation (Configured  _) (PreExisting _)   = True
stateDependencyRelation (Configured  _) (Configured  _)   = True
stateDependencyRelation (Configured  _) (Processing  _)   = True
stateDependencyRelation (Configured  _) (Installed _ _ _) = True
734

735
736
stateDependencyRelation (Processing  _) (PreExisting _)   = True
stateDependencyRelation (Processing  _) (Installed _ _ _) = True
737

738
739
stateDependencyRelation (Installed _ _ _) (PreExisting _)   = True
stateDependencyRelation (Installed _ _ _) (Installed _ _ _) = True
740

741
stateDependencyRelation (Failed    _ _) (PreExisting _)   = True
742
743
744
-- 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:
745
746
747
748
stateDependencyRelation (Failed    _ _) (Configured  _)   = True
stateDependencyRelation (Failed    _ _) (Processing  _)   = True
stateDependencyRelation (Failed    _ _) (Installed _ _ _) = True
stateDependencyRelation (Failed    _ _) (Failed    _   _) = True
749

750
stateDependencyRelation _               _                 = False
751

752

753
754
755
-- | Compute the dependency closure of a package in a install plan
--
dependencyClosure :: GenericInstallPlan ipkg srcpkg iresult ifailure
756
                  -> [UnitId]
757
758
759
760
761
762
763
                  -> [GenericPlanPackage ipkg srcpkg iresult ifailure]
dependencyClosure plan =
    map (planPkgOf plan)
  . concatMap Tree.flatten
  . Graph.dfs (planGraph plan)
  . map (planVertexOf plan)

764
765

reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg iresult ifailure
766
                         -> [UnitId]
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
                         -> [GenericPlanPackage ipkg srcpkg iresult ifailure]
reverseDependencyClosure plan =
    map (planPkgOf plan)
  . concatMap Tree.flatten
  . Graph.dfs (planGraphRev plan)
  . map (planVertexOf plan)


topologicalOrder :: GenericInstallPlan ipkg srcpkg iresult ifailure
                 -> [GenericPlanPackage ipkg srcpkg iresult ifailure]
topologicalOrder plan =
    map (planPkgOf plan)
  . Graph.topSort
  $ planGraph plan


reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg iresult ifailure
                        -> [GenericPlanPackage ipkg srcpkg iresult ifailure]
reverseTopologicalOrder plan =
    map (planPkgOf plan)
  . Graph.topSort
  $ planGraphRev plan