cabal-install/src/Distribution/Client/CmdOutdated.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE RecordWildCards #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 -----------------------------------------------------------------------------
   5 -- |
   6 -- Module      :  Distribution.Client.CmdOutdated
   7 -- Maintainer  :  cabal-devel@haskell.org
   8 -- Portability :  portable
   9 --
  10 -- Implementation of the 'outdated' command. Checks for outdated
  11 -- dependencies in the package description file or freeze file.
  12 -----------------------------------------------------------------------------
  13
  14 module Distribution.Client.CmdOutdated
  15     ( outdatedCommand, outdatedAction
  16     , ListOutdatedSettings(..), listOutdated )
  17 where
  18
  19 import Distribution.Client.Compat.Prelude
  20 import Distribution.Compat.Lens
  21     ( _1, _2 )
  22 import Prelude ()
  23
  24 import Distribution.Client.Config
  25     ( SavedConfig(savedGlobalFlags, savedConfigureFlags
  26                  , savedConfigureExFlags) )
  27 import Distribution.Client.IndexUtils as IndexUtils
  28 import Distribution.Client.DistDirLayout
  29     ( defaultDistDirLayout
  30     , DistDirLayout(distProjectRootDirectory, distProjectFile) )
  31 import Distribution.Client.ProjectConfig
  32 import Distribution.Client.ProjectConfig.Legacy
  33     ( instantiateProjectConfigSkeletonWithCompiler )
  34 import Distribution.Client.ProjectFlags
  35     ( projectFlagsOptions, ProjectFlags(..), defaultProjectFlags
  36     , removeIgnoreProjectOption )
  37 import Distribution.Client.RebuildMonad
  38     ( runRebuild )
  39 import Distribution.Client.Sandbox
  40     ( loadConfigOrSandboxConfig )
  41 import Distribution.Client.Setup
  42 import Distribution.Client.Targets
  43     ( userToPackageConstraint, UserConstraint )
  44 import Distribution.Client.Types.SourcePackageDb as SourcePackageDb
  45 import Distribution.Solver.Types.PackageConstraint
  46     ( packageConstraintToDependency )
  47 import Distribution.Client.Sandbox.PackageEnvironment
  48     ( loadUserConfig )
  49 import Distribution.Utils.Generic
  50     ( safeLast, wrapText )
  51
  52 import Distribution.Package
  53     ( PackageName, packageVersion )
  54 import Distribution.PackageDescription
  55     ( allBuildDepends )
  56 import Distribution.PackageDescription.Configuration
  57     ( finalizePD )
  58 import Distribution.Simple.Compiler
  59     ( Compiler, compilerInfo )
  60 import Distribution.Simple.Setup
  61     ( optionVerbosity, trueArg )
  62 import Distribution.Simple.Utils
  63     ( die', notice, debug, tryFindPackageDesc )
  64 import Distribution.System
  65     ( Platform (..) )
  66 import Distribution.Types.ComponentRequestedSpec
  67     ( ComponentRequestedSpec(..) )
  68 import Distribution.Types.Dependency
  69     ( Dependency(..) )
  70 import Distribution.Verbosity
  71     ( silent, normal )
  72 import Distribution.Version
  73     ( Version, VersionInterval (..), VersionRange, LowerBound(..)
  74     , UpperBound(..) , asVersionIntervals, majorBoundVersion )
  75 import Distribution.Types.PackageVersionConstraint
  76     ( PackageVersionConstraint (..), simplifyPackageVersionConstraint )
  77 import Distribution.Simple.Flag
  78     ( Flag(..), flagToMaybe, fromFlagOrDefault, toFlag )
  79 import Distribution.Simple.Command
  80     ( ShowOrParseArgs, OptionField, CommandUI(..), optArg, option, reqArg, liftOptionL )
  81 import Distribution.Simple.PackageDescription
  82     ( readGenericPackageDescription )
  83 import qualified Distribution.Compat.CharParsing as P
  84 import Distribution.ReadE
  85     ( parsecToReadE )
  86 import Distribution.Client.HttpUtils
  87 import Distribution.Utils.NubList
  88          ( fromNubList )
  89
  90 import qualified Data.Set as S
  91 import System.Directory
  92     ( getCurrentDirectory, doesFileExist )
  93
  94 -------------------------------------------------------------------------------
  95 -- Command
  96 -------------------------------------------------------------------------------
  97
  98 outdatedCommand :: CommandUI (ProjectFlags, OutdatedFlags)
  99 outdatedCommand = CommandUI
 100   { commandName = "outdated"
 101   , commandSynopsis = "Check for outdated dependencies."
 102   , commandDescription  = Just $ \_ -> wrapText $
 103       "Checks for outdated dependencies in the package description file "
 104       ++ "or freeze file"
 105   , commandNotes = Nothing
 106   , commandUsage = \pname ->
 107       "Usage: " ++ pname ++ " outdated [FLAGS] [PACKAGES]\n"
 108   , commandDefaultFlags = (defaultProjectFlags, defaultOutdatedFlags)
 109   , commandOptions      = \showOrParseArgs ->
 110         map (liftOptionL _1)
 111             (removeIgnoreProjectOption (projectFlagsOptions showOrParseArgs)) ++
 112         map (liftOptionL _2) (outdatedOptions showOrParseArgs)
 113   }
 114
 115 -------------------------------------------------------------------------------
 116 -- Flags
 117 -------------------------------------------------------------------------------
 118
 119 data IgnoreMajorVersionBumps = IgnoreMajorVersionBumpsNone
 120                              | IgnoreMajorVersionBumpsAll
 121                              | IgnoreMajorVersionBumpsSome [PackageName]
 122
 123 instance Monoid IgnoreMajorVersionBumps where
 124   mempty  = IgnoreMajorVersionBumpsNone
 125   mappend = (<>)
 126
 127 instance Semigroup IgnoreMajorVersionBumps where
 128   IgnoreMajorVersionBumpsNone       <> r                               = r
 129   l@IgnoreMajorVersionBumpsAll      <> _                               = l
 130   l@(IgnoreMajorVersionBumpsSome _) <> IgnoreMajorVersionBumpsNone     = l
 131   (IgnoreMajorVersionBumpsSome   _) <> r@IgnoreMajorVersionBumpsAll    = r
 132   (IgnoreMajorVersionBumpsSome   a) <> (IgnoreMajorVersionBumpsSome b) =
 133     IgnoreMajorVersionBumpsSome (a ++ b)
 134
 135 data OutdatedFlags = OutdatedFlags
 136   { outdatedVerbosity     :: Flag Verbosity
 137   , outdatedFreezeFile    :: Flag Bool
 138   , outdatedNewFreezeFile :: Flag Bool
 139   , outdatedSimpleOutput  :: Flag Bool
 140   , outdatedExitCode      :: Flag Bool
 141   , outdatedQuiet         :: Flag Bool
 142   , outdatedIgnore        :: [PackageName]
 143   , outdatedMinor         :: Maybe IgnoreMajorVersionBumps
 144   }
 145
 146 defaultOutdatedFlags :: OutdatedFlags
 147 defaultOutdatedFlags = OutdatedFlags
 148   { outdatedVerbosity     = toFlag normal
 149   , outdatedFreezeFile    = mempty
 150   , outdatedNewFreezeFile = mempty
 151   , outdatedSimpleOutput  = mempty
 152   , outdatedExitCode      = mempty
 153   , outdatedQuiet         = mempty
 154   , outdatedIgnore        = mempty
 155   , outdatedMinor         = mempty
 156   }
 157
 158 outdatedOptions :: ShowOrParseArgs -> [OptionField OutdatedFlags]
 159 outdatedOptions _showOrParseArgs =
 160   [ optionVerbosity
 161       outdatedVerbosity
 162       (\v flags -> flags {outdatedVerbosity = v})
 163   , option [] ["freeze-file", "v1-freeze-file"]
 164       "Act on the freeze file"
 165       outdatedFreezeFile (\v flags -> flags {outdatedFreezeFile = v})
 166       trueArg
 167   , option [] ["v2-freeze-file", "new-freeze-file"]
 168       "Act on the new-style freeze file (default: cabal.project.freeze)"
 169       outdatedNewFreezeFile (\v flags -> flags {outdatedNewFreezeFile = v})
 170       trueArg
 171   , option [] ["simple-output"]
 172       "Only print names of outdated dependencies, one per line"
 173       outdatedSimpleOutput (\v flags -> flags {outdatedSimpleOutput = v})
 174       trueArg
 175   , option [] ["exit-code"]
 176       "Exit with non-zero when there are outdated dependencies"
 177       outdatedExitCode (\v flags -> flags {outdatedExitCode = v})
 178       trueArg
 179   , option ['q'] ["quiet"]
 180       "Don't print any output. Implies '--exit-code' and '-v0'"
 181       outdatedQuiet (\v flags -> flags {outdatedQuiet = v})
 182       trueArg
 183   , option [] ["ignore"]
 184       "Packages to ignore"
 185       outdatedIgnore (\v flags -> flags {outdatedIgnore = v})
 186       (reqArg "PKGS" pkgNameListParser (map prettyShow))
 187   , option [] ["minor"]
 188       "Ignore major version bumps for these packages"
 189       outdatedMinor (\v flags -> flags {outdatedMinor = v})
 190       ( optArg
 191           "PKGS"
 192           ignoreMajorVersionBumpsParser
 193           (Just IgnoreMajorVersionBumpsAll)
 194           ignoreMajorVersionBumpsPrinter
 195       )
 196   ]
 197   where
 198     ignoreMajorVersionBumpsPrinter :: Maybe IgnoreMajorVersionBumps
 199                                    -> [Maybe String]
 200     ignoreMajorVersionBumpsPrinter Nothing = []
 201     ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone)= []
 202     ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsAll) = [Nothing]
 203     ignoreMajorVersionBumpsPrinter (Just (IgnoreMajorVersionBumpsSome pkgs)) =
 204       map (Just . prettyShow) pkgs
 205
 206     ignoreMajorVersionBumpsParser  =
 207       (Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser
 208
 209     pkgNameListParser = parsecToReadE
 210       ("Couldn't parse the list of package names: " ++)
 211       (fmap toList (P.sepByNonEmpty parsec (P.char ',')))
 212
 213 -------------------------------------------------------------------------------
 214 -- Action
 215 -------------------------------------------------------------------------------
 216
 217 -- | Entry point for the 'outdated' command.
 218 outdatedAction :: (ProjectFlags, OutdatedFlags) -> [String] -> GlobalFlags -> IO ()
 219 outdatedAction (ProjectFlags{flagProjectFileName}, OutdatedFlags{..}) _targetStrings globalFlags = do
 220   config <- loadConfigOrSandboxConfig verbosity globalFlags
 221   let globalFlags' = savedGlobalFlags config `mappend` globalFlags
 222       configFlags  = savedConfigureFlags config
 223   withRepoContext verbosity globalFlags' $ \repoContext -> do
 224     when (not newFreezeFile && isJust mprojectFile) $
 225       die' verbosity $
 226         "--project-file must only be used with --v2-freeze-file."
 227
 228     sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext
 229     (comp, platform, _progdb) <- configCompilerAux' configFlags
 230     deps <- if freezeFile
 231             then depsFromFreezeFile verbosity
 232             else if newFreezeFile
 233                 then do
 234                        httpTransport <- configureTransport verbosity
 235                          (fromNubList . globalProgPathExtra $ globalFlags)
 236                          (flagToMaybe . globalHttpTransport $ globalFlags)
 237                        depsFromNewFreezeFile verbosity httpTransport comp platform mprojectFile
 238                 else do
 239                   depsFromPkgDesc verbosity comp platform
 240     debug verbosity $ "Dependencies loaded: "
 241       ++ intercalate ", " (map prettyShow deps)
 242     let outdatedDeps = listOutdated deps sourcePkgDb
 243                       (ListOutdatedSettings ignorePred minorPred)
 244     when (not quiet) $
 245       showResult verbosity outdatedDeps simpleOutput
 246     if exitCode && (not . null $ outdatedDeps)
 247       then exitFailure
 248       else return ()
 249   where
 250     verbosity     = if quiet
 251                       then silent
 252                       else fromFlagOrDefault normal outdatedVerbosity
 253     freezeFile    = fromFlagOrDefault False outdatedFreezeFile
 254     newFreezeFile = fromFlagOrDefault False outdatedNewFreezeFile
 255     mprojectFile  = flagToMaybe flagProjectFileName
 256     simpleOutput  = fromFlagOrDefault False outdatedSimpleOutput
 257     quiet         = fromFlagOrDefault False outdatedQuiet
 258     exitCode      = fromFlagOrDefault quiet outdatedExitCode
 259     ignorePred    = let ignoreSet = S.fromList outdatedIgnore
 260                     in \pkgname -> pkgname `S.member` ignoreSet
 261     minorPred     = case outdatedMinor of
 262                       Nothing -> const False
 263                       Just IgnoreMajorVersionBumpsNone -> const False
 264                       Just IgnoreMajorVersionBumpsAll  -> const True
 265                       Just (IgnoreMajorVersionBumpsSome pkgs) ->
 266                         let minorSet = S.fromList pkgs
 267                         in \pkgname -> pkgname `S.member` minorSet
 268
 269
 270 -- | Print either the list of all outdated dependencies, or a message
 271 -- that there are none.
 272 showResult :: Verbosity -> [(PackageVersionConstraint,Version)] -> Bool -> IO ()
 273 showResult verbosity outdatedDeps simpleOutput =
 274   if not . null $ outdatedDeps
 275     then
 276     do when (not simpleOutput) $
 277          notice verbosity "Outdated dependencies:"
 278        for_ outdatedDeps $ \(d@(PackageVersionConstraint pn _), v) ->
 279          let outdatedDep = if simpleOutput then prettyShow pn
 280                            else prettyShow d ++ " (latest: " ++ prettyShow v ++ ")"
 281          in notice verbosity outdatedDep
 282     else notice verbosity "All dependencies are up to date."
 283
 284 -- | Convert a list of 'UserConstraint's to a 'Dependency' list.
 285 userConstraintsToDependencies :: [UserConstraint] -> [PackageVersionConstraint]
 286 userConstraintsToDependencies ucnstrs =
 287   mapMaybe (packageConstraintToDependency . userToPackageConstraint) ucnstrs
 288
 289 -- | Read the list of dependencies from the freeze file.
 290 depsFromFreezeFile :: Verbosity -> IO [PackageVersionConstraint]
 291 depsFromFreezeFile verbosity = do
 292   cwd        <- getCurrentDirectory
 293   userConfig <- loadUserConfig verbosity cwd Nothing
 294   let ucnstrs = map fst . configExConstraints . savedConfigureExFlags $
 295                 userConfig
 296       deps    = userConstraintsToDependencies ucnstrs
 297   debug verbosity "Reading the list of dependencies from the freeze file"
 298   return deps
 299
 300 -- | Read the list of dependencies from the new-style freeze file.
 301 depsFromNewFreezeFile :: Verbosity -> HttpTransport -> Compiler -> Platform -> Maybe FilePath -> IO [PackageVersionConstraint]
 302 depsFromNewFreezeFile verbosity httpTransport compiler (Platform arch os) mprojectFile = do
 303   projectRoot <- either throwIO return =<<
 304                  findProjectRoot Nothing mprojectFile
 305   let distDirLayout = defaultDistDirLayout projectRoot
 306                       {- TODO: Support dist dir override -} Nothing
 307   projectConfig <- runRebuild (distProjectRootDirectory distDirLayout) $ do
 308                       pcs <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout
 309                       pure $ instantiateProjectConfigSkeletonWithCompiler os arch (compilerInfo compiler) mempty pcs
 310   let ucnstrs = map fst . projectConfigConstraints . projectConfigShared
 311                 $ projectConfig
 312       deps    = userConstraintsToDependencies ucnstrs
 313       freezeFile = distProjectFile distDirLayout "freeze"
 314   freezeFileExists <- doesFileExist freezeFile
 315
 316   unless freezeFileExists $
 317     die' verbosity $
 318       "Couldn't find a freeze file expected at: " ++ freezeFile ++ "\n\n"
 319       ++ "We are looking for this file because you supplied '--project-file' or '--v2-freeze-file'. "
 320       ++ "When one of these flags is given, we try to read the dependencies from a freeze file. "
 321       ++ "If it is undesired behaviour, you should not use these flags, otherwise please generate "
 322       ++ "a freeze file via 'cabal freeze'."
 323   debug verbosity $
 324     "Reading the list of dependencies from the new-style freeze file " ++ freezeFile
 325   return deps
 326
 327 -- | Read the list of dependencies from the package description.
 328 depsFromPkgDesc :: Verbosity -> Compiler  -> Platform -> IO [PackageVersionConstraint]
 329 depsFromPkgDesc verbosity comp platform = do
 330   cwd  <- getCurrentDirectory
 331   path <- tryFindPackageDesc verbosity cwd
 332   gpd  <- readGenericPackageDescription verbosity path
 333   let cinfo = compilerInfo comp
 334       epd = finalizePD mempty (ComponentRequestedSpec True True)
 335             (const True) platform cinfo [] gpd
 336   case epd of
 337     Left _        -> die' verbosity "finalizePD failed"
 338     Right (pd, _) -> do
 339       let bd = allBuildDepends pd
 340       debug verbosity
 341         "Reading the list of dependencies from the package description"
 342       return $ map toPVC bd
 343   where
 344     toPVC (Dependency pn vr _) = PackageVersionConstraint pn vr
 345
 346 -- | Various knobs for customising the behaviour of 'listOutdated'.
 347 data ListOutdatedSettings = ListOutdatedSettings
 348   { -- | Should this package be ignored?
 349     listOutdatedIgnorePred :: PackageName -> Bool
 350   , -- | Should major version bumps be ignored for this package?
 351     listOutdatedMinorPred  :: PackageName -> Bool
 352   }
 353
 354 -- | Find all outdated dependencies.
 355 listOutdated :: [PackageVersionConstraint]
 356              -> SourcePackageDb
 357              -> ListOutdatedSettings
 358              -> [(PackageVersionConstraint, Version)]
 359 listOutdated deps sourceDb (ListOutdatedSettings ignorePred minorPred) =
 360   mapMaybe isOutdated $ map simplifyPackageVersionConstraint deps
 361   where
 362     isOutdated :: PackageVersionConstraint -> Maybe (PackageVersionConstraint, Version)
 363     isOutdated dep@(PackageVersionConstraint pname vr)
 364       | ignorePred pname = Nothing
 365       | otherwise =
 366           let this   = map packageVersion $ SourcePackageDb.lookupDependency sourceDb pname vr
 367               latest = lookupLatest dep
 368           in (\v -> (dep, v)) `fmap` isOutdated' this latest
 369
 370     isOutdated' :: [Version] -> [Version] -> Maybe Version
 371     isOutdated' [] _  = Nothing
 372     isOutdated' _  [] = Nothing
 373     isOutdated' this latest =
 374       let this'   = maximum this
 375           latest' = maximum latest
 376       in if this' < latest' then Just latest' else Nothing
 377
 378     lookupLatest :: PackageVersionConstraint -> [Version]
 379     lookupLatest (PackageVersionConstraint pname vr)
 380       | minorPred pname =
 381         map packageVersion $ SourcePackageDb.lookupDependency sourceDb  pname (relaxMinor vr)
 382       | otherwise =
 383         map packageVersion $ SourcePackageDb.lookupPackageName sourceDb pname
 384
 385     relaxMinor :: VersionRange -> VersionRange
 386     relaxMinor vr =
 387       let vis = asVersionIntervals vr
 388       in maybe vr relax (safeLast vis)
 389       where relax (VersionInterval (LowerBound v0 _) upper) =
 390               case upper of
 391                 NoUpperBound     -> vr
 392                 UpperBound _v1 _ -> majorBoundVersion v0