1-----------------------------------------------------------------------------
2-- |
3-- Module      :  Distribution.Client.Freeze
4-- Copyright   :  (c) David Himmelstrup 2005
5--                    Duncan Coutts 2011
6-- License     :  BSD-like
7--
8-- Maintainer  :  cabal-devel@gmail.com
9-- Stability   :  provisional
10-- Portability :  portable
11--
12-- The cabal freeze command
13-----------------------------------------------------------------------------
14module Distribution.Client.Freeze (
15    freeze, getFreezePkgs
16  ) where
17
18import Prelude ()
19import Distribution.Client.Compat.Prelude
20
21import Distribution.Client.Config ( SavedConfig(..) )
22import Distribution.Client.Types
23import Distribution.Client.Targets
24import Distribution.Client.Dependency
25import Distribution.Client.IndexUtils as IndexUtils
26         ( getSourcePackages, getInstalledPackages )
27import Distribution.Client.SolverInstallPlan
28         ( SolverInstallPlan, SolverPlanPackage )
29import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
30import Distribution.Client.Setup
31         ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..)
32         , RepoContext(..) )
33import Distribution.Client.Sandbox.PackageEnvironment
34         ( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment,
35           userPackageEnvironmentFile )
36import Distribution.Client.Sandbox.Types
37         ( SandboxPackageInfo(..) )
38
39import Distribution.Solver.Types.ConstraintSource
40import Distribution.Solver.Types.LabeledPackageConstraint
41import Distribution.Solver.Types.OptionalStanza
42import Distribution.Solver.Types.PkgConfigDb
43import Distribution.Solver.Types.SolverId
44
45import Distribution.Package
46         ( Package, packageId, packageName, packageVersion )
47import Distribution.Simple.Compiler
48         ( Compiler, compilerInfo, PackageDBStack )
49import Distribution.Simple.PackageIndex (InstalledPackageIndex)
50import Distribution.Simple.Program
51         ( ProgramDb )
52import Distribution.Simple.Setup
53         ( fromFlag, fromFlagOrDefault, flagToMaybe )
54import Distribution.Simple.Utils
55         ( die', notice, debug, writeFileAtomic )
56import Distribution.System
57         ( Platform )
58import Distribution.Deprecated.Text
59         ( display )
60import Distribution.Verbosity
61         ( Verbosity )
62
63import qualified Data.ByteString.Lazy.Char8 as BS.Char8
64import Distribution.Version
65         ( thisVersion )
66
67-- ------------------------------------------------------------
68-- * The freeze command
69-- ------------------------------------------------------------
70
71-- | Freeze all of the dependencies by writing a constraints section
72-- constraining each dependency to an exact version.
73--
74freeze :: Verbosity
75       -> PackageDBStack
76       -> RepoContext
77       -> Compiler
78       -> Platform
79       -> ProgramDb
80       -> Maybe SandboxPackageInfo
81       -> GlobalFlags
82       -> FreezeFlags
83       -> IO ()
84freeze verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo
85      globalFlags freezeFlags = do
86
87    pkgs  <- getFreezePkgs
88               verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo
89               globalFlags freezeFlags
90
91    if null pkgs
92      then notice verbosity $ "No packages to be frozen. "
93                           ++ "As this package has no dependencies."
94      else if dryRun
95             then notice verbosity $ unlines $
96                     "The following packages would be frozen:"
97                   : formatPkgs pkgs
98
99             else freezePackages verbosity globalFlags pkgs
100
101  where
102    dryRun = fromFlag (freezeDryRun freezeFlags)
103
104-- | Get the list of packages whose versions would be frozen by the @freeze@
105-- command.
106getFreezePkgs :: Verbosity
107              -> PackageDBStack
108              -> RepoContext
109              -> Compiler
110              -> Platform
111              -> ProgramDb
112              -> Maybe SandboxPackageInfo
113              -> GlobalFlags
114              -> FreezeFlags
115              -> IO [SolverPlanPackage]
116getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo
117      globalFlags freezeFlags = do
118
119    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
120    sourcePkgDb       <- getSourcePackages    verbosity repoCtxt
121    pkgConfigDb       <- readPkgConfigDb      verbosity progdb
122
123    pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
124                       (fromFlag $ globalWorldFile globalFlags)
125                       (packageIndex sourcePkgDb)
126                       [UserTargetLocalDir "."]
127
128    sanityCheck pkgSpecifiers
129    planPackages
130               verbosity comp platform mSandboxPkgInfo freezeFlags
131               installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers
132  where
133    sanityCheck pkgSpecifiers = do
134      when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $
135        die' verbosity $ "internal error: 'resolveUserTargets' returned "
136           ++ "unexpected named package specifiers!"
137      when (length pkgSpecifiers /= 1) $
138        die' verbosity $ "internal error: 'resolveUserTargets' returned "
139           ++ "unexpected source package specifiers!"
140
141planPackages :: Verbosity
142             -> Compiler
143             -> Platform
144             -> Maybe SandboxPackageInfo
145             -> FreezeFlags
146             -> InstalledPackageIndex
147             -> SourcePackageDb
148             -> PkgConfigDb
149             -> [PackageSpecifier UnresolvedSourcePackage]
150             -> IO [SolverPlanPackage]
151planPackages verbosity comp platform mSandboxPkgInfo freezeFlags
152             installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = do
153
154  solver <- chooseSolver verbosity
155            (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp)
156  notice verbosity "Resolving dependencies..."
157
158  installPlan <- foldProgress logMsg (die' verbosity) return $
159                   resolveDependencies
160                     platform (compilerInfo comp) pkgConfigDb
161                     solver
162                     resolverParams
163
164  return $ pruneInstallPlan installPlan pkgSpecifiers
165
166  where
167    resolverParams =
168
169        setMaxBackjumps (if maxBackjumps < 0 then Nothing
170                                             else Just maxBackjumps)
171
172      . setIndependentGoals independentGoals
173
174      . setReorderGoals reorderGoals
175
176      . setCountConflicts countConflicts
177
178      . setFineGrainedConflicts fineGrainedConflicts
179
180      . setMinimizeConflictSet minimizeConflictSet
181
182      . setShadowPkgs shadowPkgs
183
184      . setStrongFlags strongFlags
185
186      . setAllowBootLibInstalls allowBootLibInstalls
187
188      . setOnlyConstrained onlyConstrained
189
190      . setSolverVerbosity verbosity
191
192      . addConstraints
193          [ let pkg = pkgSpecifierTarget pkgSpecifier
194                pc = PackageConstraint (scopeToplevel pkg)
195                                       (PackagePropertyStanzas stanzas)
196            in LabeledPackageConstraint pc ConstraintSourceFreeze
197          | pkgSpecifier <- pkgSpecifiers ]
198
199      . maybe id applySandboxInstallPolicy mSandboxPkgInfo
200
201      $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
202
203    logMsg message rest = debug verbosity message >> rest
204
205    stanzas = [ TestStanzas | testsEnabled ]
206           ++ [ BenchStanzas | benchmarksEnabled ]
207    testsEnabled      = fromFlagOrDefault False $ freezeTests freezeFlags
208    benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags
209
210    reorderGoals     = fromFlag (freezeReorderGoals     freezeFlags)
211    countConflicts   = fromFlag (freezeCountConflicts   freezeFlags)
212    fineGrainedConflicts = fromFlag (freezeFineGrainedConflicts freezeFlags)
213    minimizeConflictSet = fromFlag (freezeMinimizeConflictSet freezeFlags)
214    independentGoals = fromFlag (freezeIndependentGoals freezeFlags)
215    shadowPkgs       = fromFlag (freezeShadowPkgs       freezeFlags)
216    strongFlags      = fromFlag (freezeStrongFlags      freezeFlags)
217    maxBackjumps     = fromFlag (freezeMaxBackjumps     freezeFlags)
218    allowBootLibInstalls = fromFlag (freezeAllowBootLibInstalls freezeFlags)
219    onlyConstrained  = fromFlag (freezeOnlyConstrained  freezeFlags)
220
221
222-- | Remove all unneeded packages from an install plan.
223--
224-- A package is unneeded if it is either
225--
226-- 1) the package that we are freezing, or
227--
228-- 2) not a dependency (directly or transitively) of the package we are
229--    freezing.  This is useful for removing previously installed packages
230--    which are no longer required from the install plan.
231--
232-- Invariant: @pkgSpecifiers@ must refer to packages which are not
233-- 'PreExisting' in the 'SolverInstallPlan'.
234pruneInstallPlan :: SolverInstallPlan
235                 -> [PackageSpecifier UnresolvedSourcePackage]
236                 -> [SolverPlanPackage]
237pruneInstallPlan installPlan pkgSpecifiers =
238    removeSelf pkgIds $
239    SolverInstallPlan.dependencyClosure installPlan pkgIds
240  where
241    pkgIds = [ PlannedId (packageId pkg)
242             | SpecificSourcePackage pkg <- pkgSpecifiers ]
243    removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg)
244    removeSelf _  = error $ "internal error: 'pruneInstallPlan' given "
245                         ++ "unexpected package specifiers!"
246
247
248freezePackages :: Package pkg => Verbosity -> GlobalFlags -> [pkg] -> IO ()
249freezePackages verbosity globalFlags pkgs = do
250
251    pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $
252                   loadUserConfig verbosity ""
253                   (flagToMaybe . globalConstraintsFile $ globalFlags)
254    writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv
255  where
256    addFrozenConstraints config =
257        config {
258            savedConfigureExFlags = (savedConfigureExFlags config) {
259                configExConstraints = map constraint pkgs
260            }
261        }
262    constraint pkg =
263        (pkgIdToConstraint $ packageId pkg
264        ,ConstraintSourceUserConfig userPackageEnvironmentFile)
265      where
266        pkgIdToConstraint pkgId =
267            UserConstraint (UserQualified UserQualToplevel (packageName pkgId))
268                           (PackagePropertyVersion $ thisVersion (packageVersion pkgId))
269    createPkgEnv config = mempty { pkgEnvSavedConfig = config }
270    showPkgEnv = BS.Char8.pack . showPackageEnvironment
271
272
273formatPkgs :: Package pkg => [pkg] -> [String]
274formatPkgs = map $ showPkg . packageId
275  where
276    showPkg pid = name pid ++ " == " ++ version pid
277    name = display . packageName
278    version = display . packageVersion
279