Clear index cache if it is old #3033

ChangeLog.md

@@ -98,6 +98,10 @@ Bug fixes:
 * Modified the flag parser within Stack to match the behavior of
  Cabal's flag parser, which allows multiple sequential dashes. See
  [#3345](https:/commercialhaskell/stack/issues/3345)
+* Now clears the hackage index cache if it is older than the
+ downloaded index. Fixes potential issue if stack was interrupted when
+ updating index.
+ See [#3033](https:/commercialhaskell/stack/issues/3033)
 
 ## 1.5.1
 

src/Path/Extra.hs

@@ -14,17 +14,20 @@ module Path.Extra
  ,pathToByteString
  ,pathToLazyByteString
  ,pathToText
+ ,tryGetModificationTime
  ) where
 
-import qualified Data.ByteString.Lazy.Char8 as BSL
-import qualified Data.ByteString.Char8 as BS
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import Stack.Prelude
 import Data.Bool (bool)
+import Data.Time (UTCTime)
 import Path
 import Path.IO
 import Path.Internal (Path(..))
+import Stack.Prelude
+import System.IO.Error (isDoesNotExistError)
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy.Char8 as BSL
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
 import qualified System.FilePath as FP
 
 -- | Convert to FilePath but don't add a trailing slash.
@@ -116,3 +119,6 @@ pathToByteString = T.encodeUtf8 . pathToText
 
 pathToText :: Path b t -> T.Text
 pathToText = T.pack . toFilePath
+
+tryGetModificationTime :: MonadIO m => Path Abs File -> m (Either () UTCTime)
+tryGetModificationTime = liftIO . tryJust (guard . isDoesNotExistError) . getModificationTime

src/Stack/Build/Haddock.hs

@@ -39,7 +39,6 @@ import Stack.Types.PackageIdentifier
 import Stack.Types.PackageName
 import Stack.Types.Runner
 import qualified System.FilePath as FP
-import System.IO.Error (isDoesNotExistError)
 import System.Process.Read
 import Web.Browser (openBrowser)
 
@@ -261,8 +260,6 @@ generateHaddockIndex descr envOverride wc bco dumpPackages docRelFP destDir = do
  , srcInterfaceModTime
  , srcInterfaceAbsFile
  , destInterfaceAbsFile )
- tryGetModificationTime :: Path Abs File -> IO (Either () UTCTime)
- tryGetModificationTime = tryJust (guard . isDoesNotExistError) . getModificationTime
  copyPkgDocs :: (a, UTCTime, Path Abs File, Path Abs File) -> IO ()
  copyPkgDocs (_,srcInterfaceModTime,srcInterfaceAbsFile,destInterfaceAbsFile) = do
  -- Copy dependencies' haddocks to documentation directory. This way, relative @../$pkg-$ver@

src/Stack/PackageIndex.hs

@@ -50,6 +50,7 @@ import Network.HTTP.Client.TLS (getGlobalManager)
 import Network.HTTP.Download
 import Network.URI (parseURI)
 import Path (toFilePath, parseAbsFile)
+import Path.Extra (tryGetModificationTime)
 import Path.IO
 import Stack.Types.Config
 import Stack.Types.PackageIdentifier
@@ -267,24 +268,26 @@ updateIndexHTTP indexName' url = do
  gz <- configPackageIndexGz indexName'
  tar <- configPackageIndex indexName'
  wasDownloaded <- redownload req gz
- toUnpack <-
+ shouldUnpack <-
  if wasDownloaded
  then return True
  else not `liftM` doesFileExist tar
 
- when toUnpack $ do
- let tmp = toFilePath tar <.> "tmp"
- tmpPath <- parseAbsFile tmp
+ if not shouldUnpack
+ then packageIndexNotUpdated indexName'
+ else do
+ let tmp = toFilePath tar <.> "tmp"
+ tmpPath <- parseAbsFile tmp
 
- deleteCache indexName'
+  deleteCache indexName'
 
- liftIO $ do
- withBinaryFile (toFilePath gz) ReadMode $ \input ->
- withBinaryFile tmp WriteMode $ \output -> runConduit
- $ sourceHandle input
- .| ungzip
- .| sinkHandle output
- renameFile tmpPath tar
+  liftIO $ do
+  withBinaryFile (toFilePath gz) ReadMode $ \input ->
+  withBinaryFile tmp WriteMode $ \output -> runConduit
+  $ sourceHandle input
+  .| ungzip
+  .| sinkHandle output
+  renameFile tmpPath tar
 
 -- | Update the index tarball via Hackage Security
 updateIndexHackageSecurity
@@ -329,15 +332,34 @@ updateIndexHackageSecurity indexName' url (HackageSecurity keyIds threshold) = d
  HS.checkForUpdates repo (Just now)
 
  case didUpdate of
+ HS.NoUpdates -> packageIndexNotUpdated indexName'
  HS.HasUpdates -> do
  -- The index actually updated. Delete the old cache, and
  -- then move the temporary unpacked file to its real
  -- location
  tar <- configPackageIndex indexName'
  deleteCache indexName'
  liftIO $ D.renameFile (toFilePath tar ++ "-tmp") (toFilePath tar)
- $logInfo "Updated package list downloaded"
- HS.NoUpdates -> $logInfo "No updates to your package list were found"
+ $logInfo "Updated package index downloaded"
+
+-- If the index is newer than the cache, delete it so that
+-- the next 'getPackageCaches' call recomputes it. This
+-- could happen if a prior run of stack updated the index,
+-- but exited before deleting the cache.
+--
+-- See https:/commercialhaskell/stack/issues/3033
+packageIndexNotUpdated :: HasConfig env => IndexName -> RIO env ()
+packageIndexNotUpdated indexName' = do
+ mindexModTime <- tryGetModificationTime =<< configPackageIndex indexName'
+ mcacheModTime <- tryGetModificationTime =<< configPackageIndexCache indexName'
+ case (mindexModTime, mcacheModTime) of
+ (Right indexModTime, Right cacheModTime) | cacheModTime < indexModTime -> do
+ deleteCache indexName'
+ $logInfo "No updates to your package index were found, but clearing the index cache as it is older than the index."
+ (Left _, _) -> do
+ deleteCache indexName'
+ $logError "Error: No updates to your package index were found, but downloaded index is missing."
+ _ -> $logInfo "No updates to your package index were found"
 
 -- | Delete the package index cache
 deleteCache :: HasConfig env => IndexName -> RIO env ()