Fix regression in local+noindex repository handling

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

@@ -4,6 +4,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -269,84 +270,11 @@ getSourcePackagesAtIndexState verbosity repoCtxt _ _
         , ActiveRepos []
         )
 getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do
-  let describeState IndexStateHead = "most recent state"
-      describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time
-
   pkgss <- for (repoContextRepos repoCtxt) $ \r -> do
-    let rname :: RepoName
-        rname = repoName r
-
-    info verbosity ("Reading available packages of " ++ unRepoName rname ++ "...")
-
-    idxState <- case mb_idxState of
-      Just totalIdxState -> do
-        let idxState = lookupIndexState rname totalIdxState
-        info verbosity $
-          "Using "
-            ++ describeState idxState
-            ++ " as explicitly requested (via command line / project configuration)"
-        return idxState
-      Nothing -> do
-        mb_idxState' <- readIndexTimestamp verbosity (RepoIndex repoCtxt r)
-        case mb_idxState' of
-          Nothing -> do
-            info verbosity "Using most recent state (could not read timestamp file)"
-            return IndexStateHead
-          Just idxState -> do
-            info verbosity $
-              "Using "
-                ++ describeState idxState
-                ++ " specified from most recent cabal update"
-            return idxState
-
-    unless (idxState == IndexStateHead) $
-      case r of
-        RepoLocalNoIndex{} -> warn verbosity "index-state ignored for file+noindex repositories"
-        RepoRemote{} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ unRepoName rname ++ "')")
-        RepoSecure{} -> pure ()
-
-    let idxState' = case r of
-          RepoSecure{} -> idxState
-          _ -> IndexStateHead
-
-    (pis, deps, isi) <- readRepoIndex verbosity repoCtxt r idxState'
-
-    case idxState' of
-      IndexStateHead -> do
-        info verbosity ("index-state(" ++ unRepoName rname ++ ") = " ++ prettyShow (isiHeadTime isi))
-        return ()
-      IndexStateTime ts0 ->
-        -- isiMaxTime is the latest timestamp in the filtered view returned by
-        -- `readRepoIndex` above. It is always true that isiMaxTime is less or
-        -- equal to a requested IndexStateTime. When `isiMaxTime isi /= ts0` (or
-        -- equivalently `isiMaxTime isi < ts0`) it means that ts0 falls between
-        -- two timestamps in the index.
-        when (isiMaxTime isi /= ts0) $
-          let commonMsg =
-                "There is no index-state for '"
-                  ++ unRepoName rname
-                  ++ "' exactly at the requested timestamp ("
-                  ++ prettyShow ts0
-                  ++ "). "
-           in if isNothing $ timestampToUTCTime (isiMaxTime isi)
-                then
-                  warn verbosity $
-                    commonMsg
-                      ++ "Also, there are no index-states before the one requested, so the repository '"
-                      ++ unRepoName rname
-                      ++ "' will be empty."
-                else
-                  info verbosity $
-                    commonMsg
-                      ++ "Falling back to the previous index-state that exists: "
-                      ++ prettyShow (isiMaxTime isi)
-    pure
-      RepoData
-        { rdRepoName = rname
-        , rdTimeStamp = isiMaxTime isi
-        , rdIndex = pis
-        , rdPreferences = deps
-        }
+    let rname = repoName r
+    info verbosity $ "Reading available packages of " ++ prettyShow rname ++ "..."
+    let mb_repoIdxState = lookupIndexState rname <$> mb_idxState
+    getRepoIndexState verbosity repoCtxt r mb_repoIdxState
 
   let activeRepos :: ActiveRepos
       activeRepos = fromMaybe defaultActiveRepos mb_activeRepos
@@ -396,6 +324,7 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do
   _ <- evaluate pkgs
   _ <- evaluate prefs
   _ <- evaluate totalIndexState
+
   return
     ( SourcePackageDb
         { packageIndex = pkgs
@@ -405,6 +334,117 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do
     , activeRepos'
     )
 
+-- | Read the repository data corresponding at a particular repository
+-- index-state.
+getRepoIndexState
+  :: Verbosity
+  -> RepoContext
+  -> Repo
+  -> Maybe RepoIndexState
+  -- ^ The index-state specified by the user. 'Nothing' if not specified.
+  -> IO RepoData
+getRepoIndexState verbosity repoCtxt r mb_idxState = do
+  let rname = repoName r
+
+  -- Determine the index state to use
+  repoIdxState <- resolveRepoIndexState verbosity repoCtxt r mb_idxState
+
+  -- Read the repository
+  (pis, deps, isi) <- readRepoIndex verbosity repoCtxt r repoIdxState
+  info verbosity $ "index-state(" ++ prettyShow rname ++ ") = " ++ prettyShow (isiHeadTime isi)
+
+  -- Compare the requested and the effective index state and warn the user if necessary
+  repoIndexStateWarnings verbosity r repoIdxState isi
+
+  pure
+    RepoData
+      { rdRepoName = rname
+      , rdTimeStamp = isiMaxTime isi
+      , rdIndex = pis
+      , rdPreferences = deps
+      }
+
+-- | Determine what index-state to use for a repository, taking into
+-- account the one specified by the user and the timestamp file written by
+-- cabal update.
+resolveRepoIndexState
+  :: Verbosity
+  -> RepoContext
+  -> Repo
+  -> Maybe RepoIndexState
+  -- ^ The index-state specified by the user. 'Nothing' if not specified.
+  -> IO RepoIndexState
+--
+-- Secure repositories.
+--
+-- If the user specified an index-state, we use it. Otherwise, we try
+-- to read one from the timestamp file. Lastly, we fall back to the most
+-- recent state.
+--
+resolveRepoIndexState verbosity _repoCtxt RepoSecure{} (Just idxState) = do
+  info verbosity $ "Using " ++ describeState idxState ++ " as explicitly requested (via command line / project configuration)"
+  return idxState
+resolveRepoIndexState verbosity repoCtxt r@RepoSecure{} Nothing = do
+  mb_idxState' <- readIndexTimestamp verbosity (RepoIndex repoCtxt r)
+  case mb_idxState' of
+    Just idxState -> do
+      info verbosity $ "Using " ++ describeState idxState ++ " specified from most recent cabal update"
+      return idxState
+    Nothing -> do
+      info verbosity "Using most recent state (could not read timestamp file)"
+      return IndexStateHead
+--
+-- Legacy and local+noindex repositories do not support index-state. We
+-- always use the most recent state.
+--
+resolveRepoIndexState _verbosity _repoCtxt _r _mb_idxState = do
+  return IndexStateHead
+
+describeState :: RepoIndexState -> String
+describeState IndexStateHead = "most recent state"
+describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time
+
+repoIndexStateWarnings
+  :: Verbosity
+  -> Repo
+  -> RepoIndexState
+  -- ^ The index-state specified by the user. 'Nothing' if not specified.
+  -> IndexStateInfo
+  -- ^ The index-state information as reported by the repository.
+  -> IO ()
+repoIndexStateWarnings verbosity r@RepoSecure{} (IndexStateTime ts) isi = do
+  -- isiMaxTime is the latest timestamp in the filtered view returned by
+  -- `readRepoIndex` above. It is always true that isiMaxTime is less or
+  -- equal to a requested IndexStateTime. When `isiMaxTime isi /= ts0` (or
+  -- equivalently `isiMaxTime isi < ts0`) it means that ts0 falls between
+  -- two timestamps in the index.
+  when (isiMaxTime isi /= ts) $
+    let commonMsg =
+          "There is no index-state for '"
+            ++ prettyShow (repoName r)
+            ++ "' exactly at the requested timestamp ("
+            ++ prettyShow ts
+            ++ "). "
+     in if isNothing $ timestampToUTCTime (isiMaxTime isi)
+          then
+            warn verbosity $
+              commonMsg
+                ++ "Also, there are no index-states before the one requested, so the repository '"
+                ++ prettyShow (repoName r)
+                ++ "' will be empty."
+          else
+            info verbosity $
+              commonMsg
+                ++ "Falling back to the previous index-state that exists: "
+                ++ prettyShow (isiMaxTime isi)
+repoIndexStateWarnings verbosity r@RepoRemote{} (IndexStateTime _) _ =
+  warn verbosity $
+    "index-state ignored for old-format (remote repository '" ++ prettyShow (repoName r) ++ "')"
+repoIndexStateWarnings verbosity r@RepoLocalNoIndex{} (IndexStateTime _) _ =
+  warn verbosity $
+    "index-state ignored for file+noindex repositories (remote repository '" ++ prettyShow (repoName r) ++ "')"
+repoIndexStateWarnings _verbosity _r _repoIdxState _isi = return ()
+
 -- auxiliary data used in getSourcePackagesAtIndexState
 data RepoData = RepoData
   { rdRepoName :: RepoName

cabal-testsuite/PackageTests/IndexUtils/T9891/cabal.project

@@ -0,0 +1,3 @@
+packages: pkg
+repository local
+    url: file+noindex://repo

cabal-testsuite/PackageTests/IndexUtils/T9891/cabal.test.hs

@@ -0,0 +1,33 @@
+import Control.Monad.Trans.Reader (asks)
+import Data.List (isPrefixOf)
+import Test.Cabal.Prelude
+
+main = cabalTest $ do
+  workdir <- asks testCurrentDir
+
+  writeSourceFile "cabal.project" $
+    unlines
+      [ "packages: pkg"
+      , "repository repo"
+      , "  url: file+noindex://" <> workdir </> "repo"
+      ]
+
+  cabal "build" ["pkg"]
+
+-- withProjectFile "cabal.project" $ withRemoteRepo "repo" $ do
+
+--   output <- last
+--           . words
+--           . head
+--           . filter ("Index cache updated to index-state " `isPrefixOf`)
+--           . lines
+--           . resultOutput
+--         <$> recordMode DoNotRecord (cabal' "update" [])
+--   -- update golden output with actual timestamp
+--   shell "cp" ["cabal.out.in", "cabal.out"]
+--   shell "sed" [ "-i" ++ if not isWindows then "''" else "", "-e", "s/REPLACEME/" <> output <> "/g", "cabal.out"]
+--   -- This shall fail with an error message as specified in `cabal.out`
+--   fails $ cabal "build" ["--index-state=4000-01-01T00:00:00Z", "fake-pkg"]
+--   -- This shall fail by not finding the package, what indicates that it
+--   -- accepted an older index-state.
+--   fails $ cabal "build" ["--index-state=2023-01-01T00:00:00Z", "fake-pkg"]

cabal-testsuite/PackageTests/IndexUtils/T9891/pkg/CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for pkg
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

cabal-testsuite/PackageTests/IndexUtils/T9891/pkg/pkg.cabal

@@ -0,0 +1,18 @@
+cabal-version:   3.12
+name:            pkg
+version:         0.1.0.0
+license:         NONE
+author:          Andrea Bedini
+maintainer:      andrea@andreabedini.com
+build-type:      Simple
+extra-doc-files: CHANGELOG.md
+
+common warnings
+    ghc-options: -Wall
+
+library
+    import:           warnings
+    exposed-modules:  MyLib
+    build-depends:    base ^>=4.19.1.0
+    hs-source-dirs:   src
+    default-language: Haskell2010

cabal-testsuite/PackageTests/IndexUtils/T9891/pkg/src/MyLib.hs

@@ -0,0 +1,4 @@
+module MyLib (someFunc) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"