Commit c6138e81 authored by barmston's avatar barmston

Top-level `freeze` command freezes dependency versions

Add new top-level `freeze` command, which resolves the dependencies to exact
versions and writes a `constraints` section to `cabal.config`. This causes
future builds to use the same fully constrained dependencies.

The command takes a number of options related to resolving dependencies,
namely, `--solver`, `--max-backjumps`, `reorder-goals` and
`--shadow-installed-packages`. These are used to create an `InstallPlan` in
much the same way that `install` does so. The `InstallPlan` is converted to a
list and all `PlanPackage`s are inspected to determine their exact version.
These versions are then either written to `cabal.config` or to standard output
depending on the presence of `--dry-run`.

Limitations in resolving dependencies
-------------------------------------

In order to keep the initial implementation of this new command simpler, a
number of options are not yet supported.  There should be no great difficulty
in supporting the options `--flags`, `--enable-{tests,benchmarks}`,
`--constraint` and `--preference`.  However, the options concerned with
compilers may prove more difficult.

Different versions of GHC ship with different library versions, the
constraints that are written currently include all dependencies, including
`base`. This prevents the constraints, as written, from being used with
alternate versions of GHC.

There are three solutions to this problem: 1) have the user edit the
constraints section, 2) exclude certain packages from the list of constraints,
3) develop a mechanism for per-arch-os-compiler constraining. As neither (2)
nor (3) have been developed we default to (1).

The lack of a good story for per-compiler constraints has lead to the options
`--with-compiler`, `--ghc`, `--uhc` et al, not being supported.

Further limitations:
--------------------

 - The `cabal.config` file is completely overwritten. Just the `constraints`
   section should be overwritten.
parent 16f1796d
-----------------------------------------------------------------------------
-- |
-- 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.Types
import Distribution.Client.Targets
import Distribution.Client.Dependency
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(..) )
import Distribution.Client.Sandbox.PackageEnvironment
( userPackageEnvironmentFile )
import Distribution.Client.Sandbox.Types
( SandboxPackageInfo(..) )
import Distribution.Package
( packageId, packageName, packageVersion )
import Distribution.Simple.Compiler
( Compiler(compilerId), PackageDBStack )
import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.Simple.Program
( ProgramConfiguration )
import Distribution.Simple.Setup
( fromFlag )
import Distribution.Simple.Utils
( die, notice, debug, intercalate, writeFileAtomic )
import Distribution.System
( Platform )
import Distribution.Text
( display )
import Distribution.Verbosity
( Verbosity )
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
import Data.Version
( showVersion )
-- ------------------------------------------------------------
-- * The freeze command
-- ------------------------------------------------------------
--TODO:
-- * Don't overwrite all of `cabal.config`, just the constaints 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 "."]
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 pkgs
where
dryRun = fromFlag (freezeDryRun freezeFlags)
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 $ InstallPlan.toList installPlan
where
resolverParams =
setMaxBackjumps (if maxBackjumps < 0 then Nothing
else Just maxBackjumps)
. setIndependentGoals independentGoals
. setReorderGoals reorderGoals
. setShadowPkgs shadowPkgs
. 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)
maxBackjumps = fromFlag (freezeMaxBackjumps freezeFlags)
freezePackages :: [PlanPackage] -> IO ()
freezePackages pkgs =
writeFileAtomic userPackageEnvironmentFile $ constraints pkgs
where
constraints = BS.Char8.pack
. (++ "\n")
. (prefix' ++)
. intercalate separator
. formatPkgs
prefix' = "constraints: "
separator = "\n" ++ (replicate (length prefix' - 2) ' ') ++ ", "
formatPkgs :: [PlanPackage] -> [String]
formatPkgs = map $ showPkg . packageId
where
showPkg pid = name pid ++ " == " ++ version pid
name = display . packageName
version = showVersion . packageVersion
......@@ -23,6 +23,7 @@ module Distribution.Client.Setup
, upgradeCommand
, infoCommand, InfoFlags(..)
, fetchCommand, FetchFlags(..)
, freezeCommand, FreezeFlags(..)
, getCommand, unpackCommand, GetFlags(..)
, checkCommand
, uploadCommand, UploadFlags(..)
......@@ -502,6 +503,57 @@ fetchCommand = CommandUI {
}
-- ------------------------------------------------------------
-- * Freeze command
-- ------------------------------------------------------------
data FreezeFlags = FreezeFlags {
freezeDryRun :: Flag Bool,
freezeSolver :: Flag PreSolver,
freezeMaxBackjumps :: Flag Int,
freezeReorderGoals :: Flag Bool,
freezeIndependentGoals :: Flag Bool,
freezeShadowPkgs :: Flag Bool,
freezeVerbosity :: Flag Verbosity
}
defaultFreezeFlags :: FreezeFlags
defaultFreezeFlags = FreezeFlags {
freezeDryRun = toFlag False,
freezeSolver = Flag defaultSolver,
freezeMaxBackjumps = Flag defaultMaxBackjumps,
freezeReorderGoals = Flag False,
freezeIndependentGoals = Flag False,
freezeShadowPkgs = Flag False,
freezeVerbosity = toFlag normal
}
freezeCommand :: CommandUI FreezeFlags
freezeCommand = CommandUI {
commandName = "freeze",
commandSynopsis = "Freeze dependencies.",
commandDescription = Nothing,
commandUsage = usagePackages "freeze",
commandDefaultFlags = defaultFreezeFlags,
commandOptions = \ showOrParseArgs -> [
optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v })
, option [] ["dry-run"]
"Do not freeze anything, only print what would be frozen"
freezeDryRun (\v flags -> flags { freezeDryRun = v })
trueArg
] ++
optionSolver freezeSolver (\v flags -> flags { freezeSolver = v }) :
optionSolverFlags showOrParseArgs
freezeMaxBackjumps (\v flags -> flags { freezeMaxBackjumps = v })
freezeReorderGoals (\v flags -> flags { freezeReorderGoals = v })
freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v })
freezeShadowPkgs (\v flags -> flags { freezeShadowPkgs = v })
}
-- ------------------------------------------------------------
-- * Other commands
-- ------------------------------------------------------------
......
......@@ -22,6 +22,7 @@ import Distribution.Client.Setup
, InstallFlags(..), defaultInstallFlags
, installCommand, upgradeCommand
, FetchFlags(..), fetchCommand
, FreezeFlags(..), freezeCommand
, GetFlags(..), getCommand, unpackCommand
, checkCommand
, updateCommand
......@@ -61,6 +62,7 @@ import Distribution.Client.Install (install)
import Distribution.Client.Configure (configure)
import Distribution.Client.Update (update)
import Distribution.Client.Fetch (fetch)
import Distribution.Client.Freeze (freeze)
import Distribution.Client.Check as Check (check)
--import Distribution.Client.Clean (clean)
import Distribution.Client.Upload as Upload (upload, check, report)
......@@ -184,6 +186,7 @@ mainWorker args = topHandler $
,listCommand `commandAddAction` listAction
,infoCommand `commandAddAction` infoAction
,fetchCommand `commandAddAction` fetchAction
,freezeCommand `commandAddAction` freezeAction
,getCommand `commandAddAction` getAction
,hiddenCommand $
unpackCommand `commandAddAction` unpackAction
......@@ -772,6 +775,24 @@ fetchAction fetchFlags extraArgs globalFlags = do
comp platform conf globalFlags' fetchFlags
targets
freezeAction :: FreezeFlags -> [String] -> GlobalFlags -> IO ()
freezeAction freezeFlags _extraArgs globalFlags = do
let verbosity = fromFlag (freezeVerbosity freezeFlags)
(useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty
let configFlags = savedConfigureFlags config
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, platform, conf) <- configCompilerAux' configFlags
maybeWithSandboxPackageInfo verbosity configFlags globalFlags'
comp platform conf useSandbox $ \mSandboxPkgInfo ->
maybeWithSandboxDirOnSearchPath useSandbox $
freeze verbosity
(configPackageDB' configFlags)
(globalRepos globalFlags')
comp platform conf
mSandboxPkgInfo
globalFlags' freezeFlags
uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO ()
uploadAction uploadFlags extraArgs globalFlags = do
let verbosity = fromFlag (uploadVerbosity uploadFlags)
......
......@@ -71,6 +71,7 @@ executable cabal
Distribution.Client.Dependency.Modular.Version
Distribution.Client.Fetch
Distribution.Client.FetchUtils
Distribution.Client.Freeze
Distribution.Client.Get
Distribution.Client.GZipUtils
Distribution.Client.Haddock
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment