Merge pull request #4729 from commercialhaskell/1681-check-recent-ver…

…sion

Recommend Stack upgrade when appropriate (fixes #1681)

ChangeLog.md

@@ -119,6 +119,12 @@ Behavior changes:
   means that Stack will no longer have to force reconfigures as often. See
   [#3554](https://github.com/commercialhaskell/stack/issues/3554).
 
+* 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

@@ -1090,4 +1090,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/Build/ConstructPlan.hs

@@ -426,7 +426,7 @@ addDep name = do
                             -- names. This code does not feel right.
                             let version = installedVersion installed
                                 askPkgLoc = liftRIO $ do
-                                  mrev <- getLatestHackageRevision name version
+                                  mrev <- getLatestHackageRevision YesRequireHackageIndex name version
                                   case mrev of
                                     Nothing -> do
                                       -- this could happen for GHC boot libraries missing from Hackage
@@ -662,7 +662,7 @@ addPackageDeps package = do
         eres <- addDep depname
         let getLatestApplicableVersionAndRev :: M (Maybe (Version, BlobKey))
             getLatestApplicableVersionAndRev = do
-              vsAndRevs <- runRIO ctx $ getHackagePackageVersions UsePreferredVersions depname
+              vsAndRevs <- runRIO ctx $ getHackagePackageVersions YesRequireHackageIndex UsePreferredVersions depname
               pure $ do
                 lappVer <- latestApplicableVersion range $ Map.keysSet vsAndRevs
                 revs <- Map.lookup lappVer vsAndRevs

src/Stack/Build/Target.hs

@@ -343,7 +343,7 @@ resolveRawTarget sma allLocs (ri, rt) =
               ]
             -- Not present at all, add it from Hackage
             Nothing -> do
-              mrev <- getLatestHackageRevision name version
+              mrev <- getLatestHackageRevision YesRequireHackageIndex name version
               pure $ case mrev of
                 Nothing -> deferToConstructPlan name
                 Just (_rev, cfKey, treeKey) -> Right ResolveResult
@@ -355,7 +355,7 @@ resolveRawTarget sma allLocs (ri, rt) =
                   }
 
     hackageLatest name = do
-        mloc <- getLatestHackageLocation name UsePreferredVersions
+        mloc <- getLatestHackageLocation YesRequireHackageIndex name UsePreferredVersions
         pure $ case mloc of
           Nothing -> deferToConstructPlan name
           Just loc -> do
@@ -368,7 +368,7 @@ resolveRawTarget sma allLocs (ri, rt) =
                   }
 
     hackageLatestRevision name version = do
-        mrev <- getLatestHackageRevision name version
+        mrev <- getLatestHackageRevision YesRequireHackageIndex name version
         pure $ case mrev of
           Nothing -> deferToConstructPlan name
           Just (_rev, cfKey, treeKey) -> Right ResolveResult

src/Stack/Config.hs

@@ -311,6 +311,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/Hoogle.hs

@@ -78,7 +78,7 @@ hoogleCmd (args,setup,rebuild,startServer) =
     installHoogle :: RIO EnvConfig ()
     installHoogle = do
         hooglePackageIdentifier <- do
-          mversion <- getLatestHackageVersion hooglePackageName UsePreferredVersions
+          mversion <- getLatestHackageVersion YesRequireHackageIndex hooglePackageName UsePreferredVersions
 
           -- FIXME For a while, we've been following the logic of
           -- taking the latest Hoogle version available. However, we

src/Stack/Runners.hs

@@ -21,16 +21,19 @@ module Stack.Runners
 
 import           Stack.Prelude
 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)
+import           Stack.Types.Version (stackMinorVersion, stackVersion, minorVersion)
 import           System.Console.ANSI (hSupportsANSIWithoutEmulation)
 import           System.Terminal (getTerminalWidth)
 
@@ -94,7 +97,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 +176,34 @@ 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 NoRequireHackageIndex "stack" UsePreferredVersions
+      case mversion of
+        -- Compare the minor version so we avoid patch-level, Hackage-only releases.
+        -- See: https://github.com/commercialhaskell/stack/pull/4729#pullrequestreview-227176315
+        Just (PackageIdentifierRevision _ version _) | minorVersion version > stackMinorVersion -> do
+          logWarn "<<<<<<<<<<<<<<<<<<"
+          logWarn $
+            "You are currently using Stack version " <>
+            fromString (versionString stackVersion) <>
+            ", 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
@@ -151,6 +153,12 @@ CompilerCache
   globalDump Text
 
   UniqueCompilerInfo ghcPath
+
+-- Last time certain actions were performed
+LastPerformed
+  action Action
+  timestamp UTCTime
+  UniqueAction action
 |]
 
 -- | Initialize the database.
@@ -544,3 +552,16 @@ 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
+  [ LastPerformedAction ==. UpgradeCheck
+  , LastPerformedTimestamp >=. since
+  ]
+
+-- | Log in the database that an upgrade check occurred at the given time.
+logUpgradeCheck :: HasConfig env => UTCTime -> RIO env ()
+logUpgradeCheck time = withStorage $ void $ upsert
+  (LastPerformed UpgradeCheck time)
+  [LastPerformedTimestamp =. time]

src/Stack/Types/Cache.hs

@@ -3,6 +3,7 @@
 
 module Stack.Types.Cache
     ( ConfigCacheType(..)
+    , Action(..)
     ) where
 
 import qualified Data.Text as T
@@ -43,3 +44,13 @@ instance PersistField ConfigCacheType where
 
 instance PersistFieldSql ConfigCacheType where
     sqlType _ = SqlString
+
+data Action
+  = UpgradeCheck
+  deriving (Show, Eq, Ord)
+instance PersistField Action where
+    toPersistValue UpgradeCheck = PersistInt64 1
+    fromPersistValue (PersistInt64 1) = Right UpgradeCheck
+    fromPersistValue x = Left $ T.pack $ "Invalid Action: " ++ show x
+instance PersistFieldSql Action where
+    sqlType _ = SqlInt64

src/Stack/Types/Config.hs

@@ -366,6 +366,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.
@@ -795,6 +797,8 @@ data ConfigMonoid =
     , configMonoidStyles             :: !StylesUpdate
     , configMonoidHideSourcePaths    :: !FirstTrue
     -- ^ See 'configHideSourcePaths'
+    , configMonoidRecommendUpgrade   :: !FirstTrue
+    -- ^ See 'configRecommendUpgrade'
     }
   deriving (Show, Generic)
 
@@ -914,6 +918,7 @@ parseConfigMonoidObject rootDir obj = do
                                               <|> configMonoidStylesGB
 
     configMonoidHideSourcePaths <- FirstTrue <$> obj ..:? configMonoidHideSourcePathsName
+    configMonoidRecommendUpgrade <- FirstTrue <$> obj ..:? configMonoidRecommendUpgradeName
 
     return ConfigMonoid {..}
   where
@@ -1068,6 +1073,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

src/Stack/Unpack.hs

@@ -69,14 +69,14 @@ unpackPackages mSnapshot dest input = do
 
     toLocNoSnapshot :: PackageName -> RIO env (Either String (PackageLocationImmutable, PackageIdentifier))
     toLocNoSnapshot name = do
-      mloc1 <- getLatestHackageLocation name UsePreferredVersions
+      mloc1 <- getLatestHackageLocation YesRequireHackageIndex name UsePreferredVersions
       mloc <-
         case mloc1 of
           Just _ -> pure mloc1
           Nothing -> do
             updated <- updateHackageIndex $ Just $ "Could not find package " <> fromString (packageNameString name) <> ", updating"
             case updated of
-              UpdateOccurred -> getLatestHackageLocation name UsePreferredVersions
+              UpdateOccurred -> getLatestHackageLocation YesRequireHackageIndex name UsePreferredVersions
               NoUpdateOccurred -> pure Nothing
       case mloc of
         Nothing -> do

src/Stack/Upgrade.hs

@@ -210,7 +210,7 @@ sourceUpgrade builtHash (SourceOpts gitRepo) =
       Nothing -> withConfig NoReexec $ do
         void $ updateHackageIndex
              $ Just "Updating index to make sure we find the latest Stack version"
-        mversion <- getLatestHackageVersion "stack" UsePreferredVersions
+        mversion <- getLatestHackageVersion YesRequireHackageIndex "stack" UsePreferredVersions
         (PackageIdentifierRevision _ version _) <-
           case mversion of
             Nothing -> throwString "No stack found in package indices"
@@ -223,7 +223,7 @@ sourceUpgrade builtHash (SourceOpts gitRepo) =
             else do
                 suffix <- parseRelDir $ "stack-" ++ versionString version
                 let dir = tmp </> suffix
-                mrev <- getLatestHackageRevision "stack" version
+                mrev <- getLatestHackageRevision YesRequireHackageIndex "stack" version
                 case mrev of
                   Nothing -> throwString "Latest version with no revision"
                   Just (_rev, cfKey, treeKey) -> do

subs/curator/src/Curator/Snapshot.hs

@@ -75,7 +75,7 @@ toLoc
 toLoc name pc =
   case pcSource pc of
     PSHackage (HackageSource mrange mrequiredLatest revisions) -> do
-      versions <- getHackagePackageVersions IgnorePreferredVersions name -- don't follow the preferred versions on Hackage, give curators more control
+      versions <- getHackagePackageVersions YesRequireHackageIndex IgnorePreferredVersions name -- don't follow the preferred versions on Hackage, give curators more control
       when (Map.null versions) $ error $ "Package not found on Hackage: " ++ packageNameString name
       for_ mrequiredLatest $ \required ->
         case Map.maxViewWithKey versions of

subs/pantry/src/Pantry.hs

@@ -154,6 +154,7 @@ module Pantry
     -- * Hackage index
   , updateHackageIndex
   , DidUpdateOccur (..)
+  , RequireHackageIndex (..)
   , hackageIndexTarballL
   , getHackagePackageVersions
   , getLatestHackageVersion
@@ -267,11 +268,12 @@ defaultHackageSecurityConfig = HackageSecurityConfig
 -- @since 0.1.0.0
 getLatestHackageVersion
   :: (HasPantryConfig env, HasLogFunc env)
-  => PackageName -- ^ package name
+  => RequireHackageIndex
+  -> PackageName -- ^ package name
   -> UsePreferredVersions
   -> RIO env (Maybe PackageIdentifierRevision)
-getLatestHackageVersion name preferred =
-  ((fmap fst . Map.maxViewWithKey) >=> go) <$> getHackagePackageVersions preferred name
+getLatestHackageVersion req name preferred =
+  ((fmap fst . Map.maxViewWithKey) >=> go) <$> getHackagePackageVersions req preferred name
   where
     go (version, m) = do
       (_rev, BlobKey sha size) <- fst <$> Map.maxViewWithKey m
@@ -283,12 +285,13 @@ getLatestHackageVersion name preferred =
 -- @since 0.1.0.0
 getLatestHackageLocation
   :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
-  => PackageName -- ^ package name
+  => RequireHackageIndex
+  -> PackageName -- ^ package name
   -> UsePreferredVersions
   -> RIO env (Maybe PackageLocationImmutable)
-getLatestHackageLocation name preferred = do
+getLatestHackageLocation req name preferred = do
   mversion <-
-    fmap fst . Map.maxViewWithKey <$> getHackagePackageVersions preferred name
+    fmap fst . Map.maxViewWithKey <$> getHackagePackageVersions req preferred name
   let mVerCfKey = do
         (version, revisions) <- mversion
         (_rev, cfKey) <- fst <$> Map.maxViewWithKey revisions
@@ -305,11 +308,12 @@ getLatestHackageLocation name preferred = do
 -- @since 0.1.0.0
 getLatestHackageRevision
   :: (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
-  => PackageName -- ^ package name
+  => RequireHackageIndex
+  -> PackageName -- ^ package name
   -> Version
   -> RIO env (Maybe (Revision, BlobKey, TreeKey))
-getLatestHackageRevision name version = do
-  revisions <- getHackagePackageVersionRevisions name version
+getLatestHackageRevision req name version = do
+  revisions <- getHackagePackageVersionRevisions req name version
   case fmap fst $ Map.maxViewWithKey revisions of
     Nothing -> pure Nothing
     Just (revision, cfKey@(BlobKey sha size)) -> do