CmdFreeze.hs

{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}

-- | cabal-install CLI command: freeze
--
module Distribution.Client.CmdFreeze (
    freezeCommand,
    freezeAction,
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.Client.NixStyleOptions
         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning
import Distribution.Client.ProjectConfig
         ( ProjectConfig(..), ProjectConfigShared(..)
         , writeProjectLocalFreezeConfig )
import Distribution.Client.IndexUtils (TotalIndexState, ActiveRepos, filterSkippedActiveRepos)
import Distribution.Client.Targets
         ( UserQualifier(..), UserConstraintScope(..), UserConstraint(..) )
import Distribution.Solver.Types.PackageConstraint
         ( PackageProperty(..) )
import Distribution.Solver.Types.ConstraintSource
         ( ConstraintSource(..) )
import Distribution.Client.DistDirLayout
         ( DistDirLayout(distProjectFile) )
import qualified Distribution.Client.InstallPlan as InstallPlan


import Distribution.Package
         ( PackageName, packageName, packageVersion )
import Distribution.Version
         ( VersionRange, thisVersion
         , unionVersionRanges, simplifyVersionRange )
import Distribution.PackageDescription
         ( FlagAssignment, nullFlagAssignment )
import Distribution.Client.Setup
         ( GlobalFlags, ConfigFlags(..) )
import Distribution.Simple.Flag
         ( fromFlagOrDefault )
import Distribution.Simple.Flag (Flag (..))
import Distribution.Simple.Utils
         ( die', notice, wrapText )
import Distribution.Verbosity
         ( normal )

import qualified Data.Map as Map

import Distribution.Simple.Command
         ( CommandUI(..), usageAlternatives )

freezeCommand :: CommandUI (NixStyleFlags ())
freezeCommand = CommandUI {
  commandName         = "v2-freeze",
  commandSynopsis     = "Freeze dependencies.",
  commandUsage        = usageAlternatives "v2-freeze" [ "[FLAGS]" ],
  commandDescription  = Just $ \_ -> wrapText $
        "The project configuration is frozen so that it will be reproducible "
     ++ "in future.\n\n"

     ++ "The precise dependency configuration for the project is written to "
     ++ "the 'cabal.project.freeze' file (or '$project_file.freeze' if "
     ++ "'--project-file' is specified). This file extends the configuration "
     ++ "from the 'cabal.project' file and thus is used as the project "
     ++ "configuration for all other commands (such as 'v2-build', "
     ++ "'v2-repl' etc).\n\n"

     ++ "The freeze file can be kept in source control. To make small "
     ++ "adjustments it may be edited manually, or to make bigger changes "
     ++ "you may wish to delete the file and re-freeze. For more control, "
     ++ "one approach is to try variations using 'v2-build --dry-run' with "
     ++ "solver flags such as '--constraint=\"pkg < 1.2\"' and once you have "
     ++ "a satisfactory solution to freeze it using the 'v2-freeze' command "
     ++ "with the same set of flags.",

  commandNotes        = Just $ \pname ->
        "Examples:\n"
     ++ "  " ++ pname ++ " v2-freeze\n"
     ++ "    Freeze the configuration of the current project\n\n"
     ++ "  " ++ pname ++ " v2-build --dry-run --constraint=\"aeson < 1\"\n"
     ++ "    Check what a solution with the given constraints would look like\n"
     ++ "  " ++ pname ++ " v2-freeze --constraint=\"aeson < 1\"\n"
     ++ "    Freeze a solution using the given constraints\n"

   , commandDefaultFlags = defaultNixStyleFlags ()
   , commandOptions      = nixStyleOptions (const [])
   }

-- | To a first approximation, the @freeze@ command runs the first phase of
-- the @build@ command where we bring the install plan up to date, and then
-- based on the install plan we write out a @cabal.project.freeze@ config file.
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
--
freezeAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
freezeAction flags@NixStyleFlags {..} extraArgs globalFlags = do

    unless (null extraArgs) $
      die' verbosity $ "'freeze' doesn't take any extra arguments: "
         ++ unwords extraArgs

    ProjectBaseContext {
      distDirLayout,
      cabalDirLayout,
      projectConfig,
      localPackages
    } <- establishProjectBaseContext verbosity cliConfig OtherCommand

    (_, elaboratedPlan, _, totalIndexState, activeRepos) <-
      rebuildInstallPlan verbosity
                         distDirLayout cabalDirLayout
                         projectConfig
                         localPackages

    let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState activeRepos
    writeProjectLocalFreezeConfig distDirLayout freezeConfig
    notice verbosity $
      "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze"

  where
    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
    cliConfig = commandLineFlagsToProjectConfig globalFlags flags
                  mempty -- ClientInstallFlags, not needed here



-- | Given the install plan, produce a config value with constraints that
-- freezes the versions of packages used in the plan.
--
projectFreezeConfig
    :: ElaboratedInstallPlan
    -> TotalIndexState
    -> ActiveRepos
    -> ProjectConfig
projectFreezeConfig elaboratedPlan totalIndexState activeRepos0 = mempty
    { projectConfigShared = mempty
        { projectConfigConstraints =
          concat (Map.elems (projectFreezeConstraints elaboratedPlan))
        , projectConfigIndexState  = Flag totalIndexState
        , projectConfigActiveRepos = Flag activeRepos
        }
    }
  where
    activeRepos :: ActiveRepos
    activeRepos = filterSkippedActiveRepos activeRepos0

-- | Given the install plan, produce solver constraints that will ensure the
-- solver picks the same solution again in future in different environments.
--
projectFreezeConstraints :: ElaboratedInstallPlan
                         -> Map PackageName [(UserConstraint, ConstraintSource)]
projectFreezeConstraints plan =
    --
    -- TODO: [required eventually] this is currently an underapproximation
    -- since the constraints language is not expressive enough to specify the
    -- precise solution. See https://github.com/haskell/cabal/issues/3502.
    --
    -- For the moment we deal with multiple versions in the solution by using
    -- constraints that allow either version. Also, we do not include any
    -- /version/ constraints for packages that are local to the project (e.g.
    -- if the solution has two instances of Cabal, one from the local project
    -- and one pulled in as a setup deps then we exclude all constraints on
    -- Cabal, not just the constraint for the local instance since any
    -- constraint would apply to both instances). We do however keep flag
    -- constraints of local packages.
    --
    deleteLocalPackagesVersionConstraints
      (Map.unionWith (++) versionConstraints flagConstraints)
  where
    versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
    versionConstraints =
      Map.mapWithKey
        (\p v -> [(UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v),
                   ConstraintSourceFreeze)])
        versionRanges

    versionRanges :: Map PackageName VersionRange
    versionRanges =
      Map.map simplifyVersionRange $
      Map.fromListWith unionVersionRanges $
          [ (packageName pkg, thisVersion (packageVersion pkg))
          | InstallPlan.PreExisting pkg <- InstallPlan.toList plan
          ]
       ++ [ (packageName pkg, thisVersion (packageVersion pkg))
          | InstallPlan.Configured pkg <- InstallPlan.toList plan
          ]

    flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
    flagConstraints =
      Map.mapWithKey
        (\p f -> [(UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f),
                   ConstraintSourceFreeze)])
        flagAssignments

    flagAssignments :: Map PackageName FlagAssignment
    flagAssignments =
      Map.fromList
        [ (pkgname, flags)
        | InstallPlan.Configured elab <- InstallPlan.toList plan
        , let flags   = elabFlagAssignment elab
              pkgname = packageName elab
        , not (nullFlagAssignment flags) ]

    -- As described above, remove the version constraints on local packages,
    -- but leave any flag constraints.
    deleteLocalPackagesVersionConstraints
      :: Map PackageName [(UserConstraint, ConstraintSource)]
      -> Map PackageName [(UserConstraint, ConstraintSource)]
    deleteLocalPackagesVersionConstraints =
      Map.mergeWithKey
        (\_pkgname () constraints ->
            case filter (not . isVersionConstraint . fst) constraints of
              []           -> Nothing
              constraints' -> Just constraints')
        (const Map.empty) id
        localPackages

    isVersionConstraint (UserConstraint _ (PackagePropertyVersion _)) = True
    isVersionConstraint _                                             = False

    localPackages :: Map PackageName ()
    localPackages =
      Map.fromList
        [ (packageName elab, ())
        | InstallPlan.Configured elab <- InstallPlan.toList plan
        , elabLocalToProject elab
        ]