From faaf4e42ef8987c3ce5d44c4482df7b207ea2727 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 14 Apr 2019 09:37:44 +0300 Subject: [PATCH] Recommend Stack upgrade when appropriate (fixes #1681) --- ChangeLog.md | 6 ++++++ doc/yaml_configuration.md | 8 ++++++++ src/Stack/Config.hs | 1 + src/Stack/Runners.hs | 39 ++++++++++++++++++++++++++++++++++++++- src/Stack/Storage.hs | 14 ++++++++++++++ src/Stack/Types/Config.hs | 8 ++++++++ 6 files changed, 75 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index a55e5e1e8e..d1f115fc5e 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -105,6 +105,12 @@ Behavior changes: can be disabled via the `hide-source-paths` configuration option in `stack.yaml`. See [#3784](https://github.com/commercialhaskell/stack/issues/3784) +* Stack will check occassionally if there is a new version available and prompt + the user to upgrade. This will not incur any additional network traffic, as + it will piggy-back on the existing Hackage index updates. You can set + `recommend-stack-upgrade: false` to bypass this. See + [#1681](https://github.com/commercialhaskell/stack/issues/1681). + Other enhancements: * Defer loading up of files for local packages. This allows us to get diff --git a/doc/yaml_configuration.md b/doc/yaml_configuration.md index 1743e4a0a0..cc93124453 100644 --- a/doc/yaml_configuration.md +++ b/doc/yaml_configuration.md @@ -1072,4 +1072,12 @@ Build output when disabled: ... ``` +### recommend-stack-upgrade + +When Stack notices that a new version of Stack is available, should it notify the user? + +```yaml +recommend-stack-upgrade: true +``` + Since 2.0 diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 1b69107aec..a3f1e93eb1 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -310,6 +310,7 @@ configFromConfigMonoid configSaveHackageCreds = fromFirst True configMonoidSaveHackageCreds configHackageBaseUrl = fromFirst "https://hackage.haskell.org/" configMonoidHackageBaseUrl configHideSourcePaths = fromFirstTrue configMonoidHideSourcePaths + configRecommendUpgrade = fromFirstTrue configMonoidRecommendUpgrade configAllowDifferentUser <- case getFirst configMonoidAllowDifferentUser of diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs index bb16383948..d0f08c50cd 100644 --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -20,7 +20,10 @@ module Stack.Runners ) where import Stack.Prelude +import Distribution.Version (mkVersion') +import qualified Paths_stack import RIO.Process (mkDefaultProcessContext) +import RIO.Time (addUTCTime, getCurrentTime) import Stack.Build.Target(NeedTargets(..)) import Stack.Config import Stack.Constants @@ -28,6 +31,7 @@ import Stack.DefaultColorWhen (defaultColorWhen) import qualified Stack.Docker as Docker import qualified Stack.Nix as Nix import Stack.Setup +import Stack.Storage (upgradeChecksSince, logUpgradeCheck) import Stack.Types.Config import Stack.Types.Docker (dockerEnable) import Stack.Types.Nix (nixEnable) @@ -94,7 +98,11 @@ withConfig shouldReexec inner = -- happen ASAP but needs a configuration. view (globalOptsL.to globalDockerEntrypoint) >>= traverse_ (Docker.entrypoint config) - runRIO config $ + runRIO config $ do + -- Catching all exceptions here, since we don't want this + -- check to ever cause Stack to stop working + shouldUpgradeCheck `catchAny` \e -> + logError ("Error when running shouldUpgradeCheck: " <> displayShow e) case shouldReexec of YesReexec -> reexec inner NoReexec -> inner @@ -169,3 +177,32 @@ withRunnerGlobal go inner = do | w < minTerminalWidth = minTerminalWidth | w > maxTerminalWidth = maxTerminalWidth | otherwise = w + +-- | Check if we should recommend upgrading Stack and, if so, recommend it. +shouldUpgradeCheck :: RIO Config () +shouldUpgradeCheck = do + config <- ask + when (configRecommendUpgrade config) $ do + now <- getCurrentTime + let yesterday = addUTCTime (-24 * 60 * 60) now + checks <- upgradeChecksSince yesterday + when (checks == 0) $ do + mversion <- getLatestHackageVersion "stack" UsePreferredVersions -- FIXME ensure it doesn't force an update ever + case mversion of + Just (PackageIdentifierRevision _ version _) | version > mkVersion' Paths_stack.version -> do + logWarn "<<<<<<<<<<<<<<<<<<" + logWarn $ + "You are currently using Stack version " <> + fromString (versionString (mkVersion' Paths_stack.version)) <> + ", but version " <> + fromString (versionString version) <> + " is available" + logWarn "You can try to upgrade by running 'stack upgrade'" + logWarn $ + "Tired of seeing this? Add 'recommend-stack-upgrade: false' to " <> + fromString (toFilePath (configUserConfigPath config)) + logWarn ">>>>>>>>>>>>>>>>>>" + logWarn "" + logWarn "" + _ -> pure () + logUpgradeCheck now diff --git a/src/Stack/Storage.hs b/src/Stack/Storage.hs index 5554fcfa97..8d5502f276 100644 --- a/src/Stack/Storage.hs +++ b/src/Stack/Storage.hs @@ -28,6 +28,8 @@ module Stack.Storage , saveDockerImageExeCache , loadCompilerPaths , saveCompilerPaths + , upgradeChecksSince + , logUpgradeCheck ) where import qualified Data.ByteString as S @@ -150,6 +152,10 @@ CompilerCache globalDump Text UniqueCompilerInfo ghcPath + +-- History of checks for whether we should upgrade Stack +UpgradeCheck + timestamp UTCTime |] -- | Initialize the database. @@ -540,3 +546,11 @@ saveCompilerPaths CompilerPaths {..} = withStorage $ do , compilerCacheGlobalDump = tshow cpGlobalDump , compilerCacheArch = T.pack $ Distribution.Text.display cpArch } + +-- | How many upgrade checks have occurred since the given timestamp? +upgradeChecksSince :: HasConfig env => UTCTime -> RIO env Int +upgradeChecksSince since = withStorage $ count [UpgradeCheckTimestamp >=. since] + +-- | Log in the database that an upgrade check occurred at the given time. +logUpgradeCheck :: HasConfig env => UTCTime -> RIO env () +logUpgradeCheck = withStorage . insert_ . UpgradeCheck diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 68df7e9bdc..f51ce74bd4 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -362,6 +362,8 @@ data Config = -- ^ Database connection pool for Stack database ,configHideSourcePaths :: !Bool -- ^ Enable GHC hiding source paths? + ,configRecommendUpgrade :: !Bool + -- ^ Recommend a Stack upgrade? } -- | The project root directory, if in a project. @@ -768,6 +770,8 @@ data ConfigMonoid = , configMonoidStyles :: !StylesUpdate , configMonoidHideSourcePaths :: !FirstTrue -- ^ See 'configHideSourcePaths' + , configMonoidRecommendUpgrade :: !FirstTrue + -- ^ See 'configRecommendUpgrade' } deriving (Show, Generic) @@ -884,6 +888,7 @@ parseConfigMonoidObject rootDir obj = do <|> configMonoidStylesGB configMonoidHideSourcePaths <- FirstTrue <$> obj ..:? configMonoidHideSourcePathsName + configMonoidRecommendUpgrade <- FirstTrue <$> obj ..:? configMonoidRecommendUpgradeName return ConfigMonoid {..} where @@ -1038,6 +1043,9 @@ configMonoidStylesGBName = "stack-colours" configMonoidHideSourcePathsName :: Text configMonoidHideSourcePathsName = "hide-source-paths" +configMonoidRecommendUpgradeName :: Text +configMonoidRecommendUpgradeName = "recommend-stack-upgrade" + data ConfigException = ParseConfigFileException (Path Abs File) ParseException | ParseCustomSnapshotException Text ParseException