Recommend Stack upgrade when appropriate (fixes #1681)

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

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

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

src/Stack/Runners.hs

@@ -20,14 +20,18 @@ 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
 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

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

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