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

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