diff --git a/cabal-install/src/Distribution/Client/IndexUtils.hs b/cabal-install/src/Distribution/Client/IndexUtils.hs index 6027f5e53f3..cd87bd3b9c8 100644 --- a/cabal-install/src/Distribution/Client/IndexUtils.hs +++ b/cabal-install/src/Distribution/Client/IndexUtils.hs @@ -3,6 +3,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 diff --git a/cabal-testsuite/PackageTests/IndexUtils/T9891/cabal.out b/cabal-testsuite/PackageTests/IndexUtils/T9891/cabal.out new file mode 100644 index 00000000000..cbad5944b1f --- /dev/null +++ b/cabal-testsuite/PackageTests/IndexUtils/T9891/cabal.out @@ -0,0 +1,13 @@ +# cabal build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - pkg-b-0.1.0.0 (lib) (requires build) + - pkg-a-0.1.0.0 (exe:pkg-a) (first run) +Configuring library for pkg-b-0.1.0.0.. +Preprocessing library for pkg-b-0.1.0.0.. +Building library for pkg-b-0.1.0.0.. +Installing library in +Configuring executable 'pkg-a' for pkg-a-0.1.0.0.. +Preprocessing executable 'pkg-a' for pkg-a-0.1.0.0.. +Building executable 'pkg-a' for pkg-a-0.1.0.0.. diff --git a/cabal-testsuite/PackageTests/IndexUtils/T9891/cabal.test.hs b/cabal-testsuite/PackageTests/IndexUtils/T9891/cabal.test.hs new file mode 100644 index 00000000000..9bf69c75f2f --- /dev/null +++ b/cabal-testsuite/PackageTests/IndexUtils/T9891/cabal.test.hs @@ -0,0 +1,13 @@ +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-a" + , "repository repo" + , " url: file+noindex://" <> workdir "repo" + ] + cabal "build" ["pkg-a"] diff --git a/cabal-testsuite/PackageTests/IndexUtils/T9891/pkg-a/app/Main.hs b/cabal-testsuite/PackageTests/IndexUtils/T9891/pkg-a/app/Main.hs new file mode 100644 index 00000000000..65ae4a05d5d --- /dev/null +++ b/cabal-testsuite/PackageTests/IndexUtils/T9891/pkg-a/app/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "Hello, Haskell!" diff --git a/cabal-testsuite/PackageTests/IndexUtils/T9891/pkg-a/pkg-a.cabal b/cabal-testsuite/PackageTests/IndexUtils/T9891/pkg-a/pkg-a.cabal new file mode 100644 index 00000000000..b38b2d9b7ae --- /dev/null +++ b/cabal-testsuite/PackageTests/IndexUtils/T9891/pkg-a/pkg-a.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.8 +name: pkg-a +version: 0.1.0.0 +license: NONE +author: Andrea Bedini +maintainer: andrea@andreabedini.com +build-type: Simple + +common warnings + ghc-options: -Wall + +executable pkg-a + import: warnings + main-is: Main.hs + build-depends: base + , pkg-b + hs-source-dirs: app + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/IndexUtils/T9891/repo/.gitkeep b/cabal-testsuite/PackageTests/IndexUtils/T9891/repo/.gitkeep new file mode 100644 index 00000000000..e69de29bb2d diff --git a/cabal-testsuite/PackageTests/IndexUtils/T9891/repo/pkg-b-0.1.0.0.tar.gz b/cabal-testsuite/PackageTests/IndexUtils/T9891/repo/pkg-b-0.1.0.0.tar.gz new file mode 100644 index 00000000000..b43022c2f81 Binary files /dev/null and b/cabal-testsuite/PackageTests/IndexUtils/T9891/repo/pkg-b-0.1.0.0.tar.gz differ