1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
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
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
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
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
|
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Freeze
-- Copyright : (c) David Himmelstrup 2005
-- Duncan Coutts 2011
-- License : BSD-like
--
-- Maintainer : cabal-devel@gmail.com
-- Stability : provisional
-- Portability : portable
--
-- The cabal freeze command
-----------------------------------------------------------------------------
module Distribution.Client.Freeze (
freeze,
) where
import Distribution.Client.Config ( SavedConfig(..) )
import Distribution.Client.Types
import Distribution.Client.Targets
import Distribution.Client.Dependency hiding ( addConstraints )
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackages, getInstalledPackages )
import Distribution.Client.InstallPlan
( PlanPackage )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.Setup
( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..) )
import Distribution.Client.Sandbox.PackageEnvironment
( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment,
userPackageEnvironmentFile )
import Distribution.Client.Sandbox.Types
( SandboxPackageInfo(..) )
import Distribution.Package
( Package, PackageIdentifier, packageId, packageName, packageVersion )
import Distribution.Simple.Compiler
( Compiler(compilerId), PackageDBStack )
import Distribution.Simple.PackageIndex (PackageIndex)
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Simple.Program
( ProgramConfiguration )
import Distribution.Simple.Setup
( fromFlag )
import Distribution.Simple.Utils
( die, notice, debug, writeFileAtomic )
import Distribution.System
( Platform )
import Distribution.Text
( display )
import Distribution.Verbosity
( Verbosity )
import Control.Monad
( when )
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
import Data.Monoid
( mempty )
import Data.Version
( showVersion )
import Distribution.Version
( thisVersion )
-- ------------------------------------------------------------
-- * The freeze command
-- ------------------------------------------------------------
--TODO:
-- * Don't overwrite all of `cabal.config`, just the constraints section.
-- * Should the package represented by `UserTargetLocalDir "."` be
-- constrained too? What about `base`?
-- | Freeze all of the dependencies by writing a constraints section
-- constraining each dependency to an exact version.
--
freeze :: Verbosity
-> PackageDBStack
-> [Repo]
-> Compiler
-> Platform
-> ProgramConfiguration
-> Maybe SandboxPackageInfo
-> GlobalFlags
-> FreezeFlags
-> IO ()
freeze verbosity packageDBs repos comp platform conf mSandboxPkgInfo
globalFlags freezeFlags = do
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
sourcePkgDb <- getSourcePackages verbosity repos
pkgSpecifiers <- resolveUserTargets verbosity
(fromFlag $ globalWorldFile globalFlags)
(packageIndex sourcePkgDb)
[UserTargetLocalDir "."]
sanityCheck pkgSpecifiers
pkgs <- planPackages
verbosity comp platform mSandboxPkgInfo freezeFlags
installedPkgIndex sourcePkgDb pkgSpecifiers
if null pkgs
then notice verbosity $ "No packages to be frozen. "
++ "As this package has no dependencies."
else if dryRun
then notice verbosity $ unlines $
"The following packages would be frozen:"
: formatPkgs pkgs
else freezePackages verbosity pkgs
where
dryRun = fromFlag (freezeDryRun freezeFlags)
sanityCheck pkgSpecifiers =
when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $
die $ "internal error: 'resolveUserTargets' returned "
++ "unexpected named package specifiers!"
planPackages :: Verbosity
-> Compiler
-> Platform
-> Maybe SandboxPackageInfo
-> FreezeFlags
-> PackageIndex
-> SourcePackageDb
-> [PackageSpecifier SourcePackage]
-> IO [PlanPackage]
planPackages verbosity comp platform mSandboxPkgInfo freezeFlags
installedPkgIndex sourcePkgDb pkgSpecifiers = do
solver <- chooseSolver verbosity
(fromFlag (freezeSolver freezeFlags)) (compilerId comp)
notice verbosity "Resolving dependencies..."
installPlan <- foldProgress logMsg die return $
resolveDependencies
platform (compilerId comp)
solver
resolverParams
return $ either id
(error "planPackages: installPlan contains broken packages")
(pruneInstallPlan installPlan pkgSpecifiers)
where
resolverParams =
setMaxBackjumps (if maxBackjumps < 0 then Nothing
else Just maxBackjumps)
. setIndependentGoals independentGoals
. setReorderGoals reorderGoals
. setShadowPkgs shadowPkgs
. setStrongFlags strongFlags
. maybe id applySandboxInstallPolicy mSandboxPkgInfo
$ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
logMsg message rest = debug verbosity message >> rest
reorderGoals = fromFlag (freezeReorderGoals freezeFlags)
independentGoals = fromFlag (freezeIndependentGoals freezeFlags)
shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags)
strongFlags = fromFlag (freezeStrongFlags freezeFlags)
maxBackjumps = fromFlag (freezeMaxBackjumps freezeFlags)
-- | Remove all unneeded packages from an install plan.
--
-- A package is unneeded if it is not a dependency (directly or
-- transitively) of any of the 'PackageSpecifier SourcePackage's. This is
-- useful for removing previously installed packages which are no longer
-- required from the install plan.
pruneInstallPlan :: InstallPlan.InstallPlan
-> [PackageSpecifier SourcePackage]
-> Either [PlanPackage] [(PlanPackage, [PackageIdentifier])]
pruneInstallPlan installPlan pkgSpecifiers =
mapLeft PackageIndex.allPackages $
PackageIndex.dependencyClosure pkgIdx pkgIds
where
pkgIdx = PackageIndex.fromList $ InstallPlan.toList installPlan
pkgIds = [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]
mapLeft f (Left v) = Left $ f v
mapLeft _ (Right v) = Right v
freezePackages :: Package pkg => Verbosity -> [pkg] -> IO ()
freezePackages verbosity pkgs = do
pkgEnv <- fmap (createPkgEnv . addConstraints) $ loadUserConfig verbosity ""
writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv
where
addConstraints config =
config {
savedConfigureExFlags = (savedConfigureExFlags config) {
configExConstraints = constraints pkgs
}
}
constraints = map $ pkgIdToConstraint . packageId
where
pkgIdToConstraint pkg =
UserConstraintVersion (packageName pkg)
(thisVersion $ packageVersion pkg)
createPkgEnv config = mempty { pkgEnvSavedConfig = config }
showPkgEnv = BS.Char8.pack . showPackageEnvironment
formatPkgs :: Package pkg => [pkg] -> [String]
formatPkgs = map $ showPkg . packageId
where
showPkg pid = name pid ++ " == " ++ version pid
name = display . packageName
version = showVersion . packageVersion
|
