Commit 0fce6383 authored by Oleg Grenrus's avatar Oleg Grenrus

Allow specify index-state per repository

parent c52fdf78
......@@ -102,7 +102,7 @@ updateCommand = Client.installCommand {
data UpdateRequest = UpdateRequest
{ _updateRequestRepoName :: RepoName
, _updateRequestRepoState :: IndexState
, _updateRequestRepoState :: RepoIndexState
} deriving (Show)
instance Pretty UpdateRequest where
......@@ -146,7 +146,7 @@ updateAction ( configFlags, configExFlags, installFlags
++ "\" can not be found in known remote repo(s): "
++ intercalate ", " (map unRepoName remoteRepoNames)
let reposToUpdate :: [(Repo, IndexState)]
let reposToUpdate :: [(Repo, RepoIndexState)]
reposToUpdate = case updateRepoRequests of
-- If we are not given any specific repository, update all
-- repositories to HEAD.
......@@ -179,7 +179,7 @@ updateAction ( configFlags, configExFlags, installFlags
haddockFlags testFlags benchmarkFlags
globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, IndexState)
updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, RepoIndexState)
-> IO ()
updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do
transport <- repoContextGetTransport repoCtxt
......
......@@ -52,7 +52,7 @@ import Distribution.Client.VCS
import Distribution.Client.FetchUtils
import qualified Distribution.Client.Tar as Tar (extractTarGzFile)
import Distribution.Client.IndexUtils as IndexUtils
( getSourcePackagesAtIndexState )
( getSourcePackagesAtIndexState, TotalIndexState )
import Distribution.Solver.Types.SourcePackage
import Control.Exception
......@@ -86,7 +86,8 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do
unless useSourceRepo $
mapM_ (checkTarget verbosity) userTargets
let idxState = flagToMaybe $ getIndexState getFlags
let idxState :: Maybe TotalIndexState
idxState = flagToMaybe $ getIndexState getFlags
sourcePkgDb <- getSourcePackagesAtIndexState verbosity repoCtxt idxState
......
......@@ -26,10 +26,11 @@ module Distribution.Client.IndexUtils (
getSourcePackages,
getSourcePackagesMonitorFiles,
IndexState(..),
TotalIndexState,
getSourcePackagesAtIndexState,
Index(..),
RepoIndexState (..),
PackageEntry(..),
parsePackageIndex,
updateRepoIndexCache,
......@@ -177,7 +178,7 @@ emptyStateInfo = IndexStateInfo nullTimestamp nullTimestamp
-- resulting index cache.
--
-- Note: 'filterCache' is idempotent in the 'Cache' value
filterCache :: IndexState -> Cache -> (Cache, IndexStateInfo)
filterCache :: RepoIndexState -> Cache -> (Cache, IndexStateInfo)
filterCache IndexStateHead cache = (cache, IndexStateInfo{..})
where
isiMaxTime = cacheHeadTs cache
......@@ -209,8 +210,11 @@ getSourcePackages verbosity repoCtxt =
-- TODO: Enhance to allow specifying per-repo 'IndexState's and also
-- report back per-repo 'IndexStateInfo's (in order for @v2-freeze@
-- to access it)
getSourcePackagesAtIndexState :: Verbosity -> RepoContext -> Maybe IndexState
-> IO SourcePackageDb
getSourcePackagesAtIndexState
:: Verbosity
-> RepoContext
-> Maybe TotalIndexState
-> IO SourcePackageDb -- TODO: return TotalIndexState
getSourcePackagesAtIndexState verbosity repoCtxt _
| null (repoContextRepos repoCtxt) = do
-- In the test suite, we routinely don't have any remote package
......@@ -227,16 +231,18 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do
describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time
pkgss <- forM (repoContextRepos repoCtxt) $ \r -> do
let rname = case r of
RepoRemote remote _ -> unRepoName $ remoteRepoName remote
RepoSecure remote _ -> unRepoName $ remoteRepoName remote
RepoLocalNoIndex local _ -> unRepoName $ localRepoName local
RepoLocal _ -> ""
let rname :: RepoName
rname = case r of
RepoRemote remote _ -> remoteRepoName remote
RepoSecure remote _ -> remoteRepoName remote
RepoLocalNoIndex local _ -> localRepoName local
RepoLocal _ -> RepoName "__local-repository" -- TODO...
info verbosity ("Reading available packages of " ++ rname ++ "...")
info verbosity ("Reading available packages of " ++ unRepoName rname ++ "...")
idxState <- case mb_idxState of
Just idxState -> do
Just totalIdxState -> do
let idxState = lookupIndexState rname totalIdxState
info verbosity $ "Using " ++ describeState idxState ++
" as explicitly requested (via command line / project configuration)"
return idxState
......@@ -255,7 +261,7 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do
case r of
RepoLocal path -> warn verbosity ("index-state ignored for old-format repositories (local repository '" ++ path ++ "')")
RepoLocalNoIndex {} -> warn verbosity "index-state ignored for file+noindex repositories"
RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ rname ++ "')")
RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ unRepoName rname ++ "')")
RepoSecure {} -> pure ()
let idxState' = case r of
......@@ -266,22 +272,22 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do
case idxState' of
IndexStateHead -> do
info verbosity ("index-state("++rname++") = " ++ prettyShow (isiHeadTime isi))
info verbosity ("index-state("++ unRepoName rname ++") = " ++ prettyShow (isiHeadTime isi))
return ()
IndexStateTime ts0 -> do
when (isiMaxTime isi /= ts0) $
if ts0 > isiMaxTime isi
then warn verbosity $
"Requested index-state " ++ prettyShow ts0
++ " is newer than '" ++ rname ++ "'!"
++ " is newer than '" ++ unRepoName rname ++ "'!"
++ " Falling back to older state ("
++ prettyShow (isiMaxTime isi) ++ ")."
else info verbosity $
"Requested index-state " ++ prettyShow ts0
++ " does not exist in '"++rname++"'!"
++ " does not exist in '"++ unRepoName rname ++"'!"
++ " Falling back to older state ("
++ prettyShow (isiMaxTime isi) ++ ")."
info verbosity ("index-state("++rname++") = " ++
info verbosity ("index-state("++ unRepoName rname ++") = " ++
prettyShow (isiMaxTime isi) ++ " (HEAD = " ++
prettyShow (isiHeadTime isi) ++ ")")
......@@ -311,7 +317,7 @@ readCacheStrict verbosity index mkPkg = do
--
-- This is a higher level wrapper used internally in cabal-install.
--
readRepoIndex :: Verbosity -> RepoContext -> Repo -> IndexState
readRepoIndex :: Verbosity -> RepoContext -> Repo -> RepoIndexState
-> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo)
readRepoIndex verbosity repoCtxt repo idxState =
handleNotFound $ do
......@@ -729,7 +735,7 @@ readPackageIndexCacheFile :: Package pkg
=> Verbosity
-> (PackageEntry -> pkg)
-> Index
-> IndexState
-> RepoIndexState
-> IO (PackageIndex pkg, [Dependency], IndexStateInfo)
readPackageIndexCacheFile verbosity mkPkg index idxState
| localNoIndex index = do
......@@ -922,7 +928,7 @@ writeNoIndexCache verbosity index cache = do
structuredEncodeFile path cache
-- | Write the 'IndexState' to the filesystem
writeIndexTimestamp :: Index -> IndexState -> IO ()
writeIndexTimestamp :: Index -> RepoIndexState -> IO ()
writeIndexTimestamp index st
= writeFile (timestampFile index) (prettyShow st)
......@@ -938,7 +944,7 @@ currentIndexTimestamp verbosity repoCtxt r = do
return (isiHeadTime isi)
-- | Read the 'IndexState' from the filesystem
readIndexTimestamp :: Index -> IO (Maybe IndexState)
readIndexTimestamp :: Index -> IO (Maybe RepoIndexState)
readIndexTimestamp index
= fmap simpleParsec (readFile (timestampFile index))
`catchIO` \e ->
......
......@@ -6,41 +6,130 @@
-- Copyright : (c) 2016 Herbert Valerio Riedel
-- License : BSD3
--
-- Timestamp type used in package indexes
-- Package repositories index state.
--
module Distribution.Client.IndexUtils.IndexState (
IndexState(..),
RepoIndexState(..),
TotalIndexState,
headTotalIndexState,
makeTotalIndexState,
lookupIndexState,
) where
import Distribution.Client.Compat.Prelude
import Distribution.Client.IndexUtils.Timestamp (Timestamp)
import Distribution.Client.Types (RepoName (..))
import Distribution.FieldGrammar.Described
import Distribution.Parsec (Parsec (..))
import Distribution.Pretty (Pretty (..))
import qualified Distribution.Compat.CharParsing as P
import qualified Data.Map.Strict as Map
import qualified Text.PrettyPrint as Disp
-------------------------------------------------------------------------------
-- Total index state
-------------------------------------------------------------------------------
-- | Index state of multiple repositories
data TotalIndexState = TIS RepoIndexState (Map RepoName RepoIndexState)
deriving (Eq, Show, Generic)
instance Binary TotalIndexState
instance Structured TotalIndexState
instance NFData TotalIndexState
instance Pretty TotalIndexState where
pretty (TIS IndexStateHead m)
| not (Map.null m)
= Disp.hsep
[ pretty rn <<>> Disp.colon <<>> pretty idx
| (rn, idx) <- Map.toList m
]
pretty (TIS def m) = foldl' go (pretty def) (Map.toList m) where
go doc (rn, idx) = doc Disp.<+> pretty rn <<>> Disp.colon <<>> pretty idx
instance Parsec TotalIndexState where
parsec = normalise . foldl' add headTotalIndexState <$> some (single0 <* P.spaces) where
-- hard to do without try
-- 2020-03-21T11:22:33Z looks like it begins with
-- repository name 2020-03-21T11
--
-- To make this easy, we could forbid repository names starting with digit
--
single0 = P.try single1 <|> TokTimestamp <$> parsec
single1 = do
token <- P.munch1 (\c -> isAlphaNum c || c == '_' || c == '-' || c == '.')
single2 token <|> single3 token
single2 token = do
_ <- P.char ':'
idx <- parsec
return (TokRepo (RepoName token) idx)
single3 "HEAD" = return TokHead
single3 token = P.unexpected ("Repository " ++ token ++ " without index state (after comma)")
add :: TotalIndexState -> Tok -> TotalIndexState
add _ TokHead = headTotalIndexState
add _ (TokTimestamp ts) = TIS (IndexStateTime ts) Map.empty
add (TIS def m) (TokRepo rn idx) = TIS def (Map.insert rn idx m)
instance Described TotalIndexState where
describe _ = REMunch1 RESpaces1 $ REUnion
[ describe (Proxy :: Proxy RepoName) <> reChar ':' <> ris
, ris
]
where
ris = describe (Proxy :: Proxy RepoIndexState)
-- used in Parsec TotalIndexState implementation
data Tok
= TokRepo RepoName RepoIndexState
| TokTimestamp Timestamp
| TokHead
-- | Remove non-default values from 'TotalIndexState'.
normalise :: TotalIndexState -> TotalIndexState
normalise (TIS def m) = TIS def (Map.filter (/= def) m)
-- | 'TotalIndexState' where all repositories are at @HEAD@ index state.
headTotalIndexState :: TotalIndexState
headTotalIndexState = TIS IndexStateHead Map.empty
-- | Create 'TotalIndexState'.
makeTotalIndexState :: RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState
makeTotalIndexState def m = normalise (TIS def m)
-- | Lookup a 'RepoIndexState' for an individual repository from 'TotalIndexState'.
lookupIndexState :: RepoName -> TotalIndexState -> RepoIndexState
lookupIndexState rn (TIS def m) = Map.findWithDefault def rn m
-------------------------------------------------------------------------------
-- Repository index state
-------------------------------------------------------------------------------
-- | Specification of the state of a specific repo package index
data IndexState = IndexStateHead -- ^ Use all available entries
| IndexStateTime !Timestamp -- ^ Use all entries that existed at
-- the specified time
deriving (Eq,Generic,Show)
data RepoIndexState
= IndexStateHead -- ^ Use all available entries
| IndexStateTime !Timestamp -- ^ Use all entries that existed at the specified time
deriving (Eq,Generic,Show)
instance Binary IndexState
instance Structured IndexState
instance NFData IndexState
instance Binary RepoIndexState
instance Structured RepoIndexState
instance NFData RepoIndexState
instance Pretty IndexState where
instance Pretty RepoIndexState where
pretty IndexStateHead = Disp.text "HEAD"
pretty (IndexStateTime ts) = pretty ts
instance Parsec IndexState where
instance Parsec RepoIndexState where
parsec = parseHead <|> parseTime where
parseHead = IndexStateHead <$ P.string "HEAD"
parseTime = IndexStateTime <$> parsec
instance Described IndexState where
instance Described RepoIndexState where
describe _ = REUnion
[ "HEAD"
, RENamed "timestamp" (describe (Proxy :: Proxy Timestamp))
......
......@@ -35,7 +35,7 @@ import Distribution.Client.BuildReports.Types
import Distribution.Client.SourceRepo (SourceRepoList)
import Distribution.Client.IndexUtils.IndexState
( IndexState )
( TotalIndexState )
import Distribution.Client.CmdInstall.ClientInstallFlags
( ClientInstallFlags(..) )
......@@ -180,7 +180,7 @@ data ProjectConfigShared
projectConfigRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers.
projectConfigLocalRepos :: NubList FilePath,
projectConfigLocalNoIndexRepos :: NubList LocalRepo,
projectConfigIndexState :: Flag IndexState,
projectConfigIndexState :: Flag TotalIndexState,
projectConfigStoreDir :: Flag FilePath,
-- solver configuration
......@@ -406,7 +406,7 @@ data SolverSettings
solverSettingStrongFlags :: StrongFlags,
solverSettingAllowBootLibInstalls :: AllowBootLibInstalls,
solverSettingOnlyConstrained :: OnlyConstrained,
solverSettingIndexState :: Maybe IndexState,
solverSettingIndexState :: Maybe TotalIndexState,
solverSettingIndependentGoals :: IndependentGoals
-- Things that only make sense for manual mode, not --local mode
-- too much control!
......
......@@ -758,7 +758,7 @@ getPackageDBContents verbosity compiler progdb platform packagedb = do
-}
getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a)
-> Maybe IndexUtils.IndexState -> Rebuild SourcePackageDb
-> Maybe IndexUtils.TotalIndexState -> Rebuild SourcePackageDb
getSourcePackages verbosity withRepoCtx idxState = do
(sourcePkgDb, repos) <-
liftIO $
......
......@@ -78,7 +78,7 @@ import Distribution.Client.BuildReports.Types
import Distribution.Client.Dependency.Types
( PreSolver(..) )
import Distribution.Client.IndexUtils.IndexState
( IndexState(..) )
( TotalIndexState, headTotalIndexState )
import qualified Distribution.Client.Init.Types as IT
( InitFlags(..), PackageType(..) )
import Distribution.Client.Targets
......@@ -1334,14 +1334,14 @@ outdatedCommand = CommandUI {
data UpdateFlags
= UpdateFlags {
updateVerbosity :: Flag Verbosity,
updateIndexState :: Flag IndexState
updateIndexState :: Flag TotalIndexState
} deriving Generic
defaultUpdateFlags :: UpdateFlags
defaultUpdateFlags
= UpdateFlags {
updateVerbosity = toFlag normal,
updateIndexState = toFlag IndexStateHead
updateIndexState = toFlag headTotalIndexState
}
updateCommand :: CommandUI UpdateFlags
......@@ -1534,7 +1534,7 @@ instance Semigroup ReportFlags where
data GetFlags = GetFlags {
getDestDir :: Flag FilePath,
getPristine :: Flag Bool,
getIndexState :: Flag IndexState,
getIndexState :: Flag TotalIndexState,
getSourceRepository :: Flag (Maybe RepoKind),
getVerbosity :: Flag Verbosity
} deriving Generic
......@@ -1765,7 +1765,7 @@ data InstallFlags = InstallFlags {
installUpgradeDeps :: Flag Bool,
installOnly :: Flag Bool,
installOnlyDeps :: Flag Bool,
installIndexState :: Flag IndexState,
installIndexState :: Flag TotalIndexState,
installRootCmd :: Flag String,
installSummaryFile :: NubList PathTemplate,
installLogFile :: Flag PathTemplate,
......
......@@ -285,6 +285,7 @@ unRepoName (RepoName n) = n
instance Binary RepoName
instance Structured RepoName
instance NFData RepoName
instance Pretty RepoName where
pretty = Disp.text . unRepoName
......
......@@ -20,12 +20,13 @@ import Distribution.Simple.Setup
import Distribution.Client.Compat.Directory
( setModificationTime )
import Distribution.Client.Types
( Repo(..), RemoteRepo(..), maybeRepoRemote, unRepoName )
( Repo(..), RepoName (..), RemoteRepo(..), maybeRepoRemote, unRepoName )
import Distribution.Client.HttpUtils
( DownloadResult(..) )
import Distribution.Client.FetchUtils
( downloadIndex )
import Distribution.Client.IndexUtils.Timestamp
import Distribution.Client.IndexUtils.IndexState
import Distribution.Client.IndexUtils
( updateRepoIndexCache, Index(..), writeIndexTimestamp
, currentIndexTimestamp, indexBaseName )
......@@ -84,13 +85,20 @@ updateRepo verbosity updateFlags repoCtxt repo = do
writeFileAtomic (dropExtension indexPath) . maybeDecompress
=<< BS.readFile indexPath
updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)
RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do
RepoSecure remote _ -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do
let index = RepoIndex repoCtxt repo
-- NB: This may be a nullTimestamp if we've never updated before
current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo
-- NB: always update the timestamp, even if we didn't actually
-- download anything
writeIndexTimestamp index (fromFlag (updateIndexState updateFlags))
let rname :: RepoName
rname = remoteRepoName remote
let repoIndexState :: RepoIndexState
repoIndexState = lookupIndexState rname (fromFlag (updateIndexState updateFlags))
writeIndexTimestamp index repoIndexState
ce <- if repoContextIgnoreExpiry repoCtxt
then Just `fmap` getCurrentTime
else return Nothing
......
......@@ -23,7 +23,7 @@ import Distribution.Utils.NubList
import Distribution.Client.BuildReports.Types (ReportLevel (..))
import Distribution.Client.CmdInstall.ClientInstallFlags (InstallMethod)
import Distribution.Client.IndexUtils.IndexState (IndexState (..))
import Distribution.Client.IndexUtils.IndexState (RepoIndexState (..), TotalIndexState, makeTotalIndexState)
import Distribution.Client.IndexUtils.Timestamp (Timestamp, epochTimeToTimestamp)
import Distribution.Client.InstallSymlink (OverwritePolicy)
import Distribution.Client.Types (RepoName (..), WriteGhcEnvironmentFilesPolicy)
......@@ -137,11 +137,14 @@ instance Arbitrary Timestamp where
--
arbitrary = maybe (toEnum 0) id . epochTimeToTimestamp . (`mod` 3093527980800) . abs <$> arbitrary
instance Arbitrary IndexState where
instance Arbitrary RepoIndexState where
arbitrary = frequency [ (1, pure IndexStateHead)
, (50, IndexStateTime <$> arbitrary)
]
instance Arbitrary TotalIndexState where
arbitrary = makeTotalIndexState <$> arbitrary <*> arbitrary
instance Arbitrary WriteGhcEnvironmentFilesPolicy where
arbitrary = arbitraryBoundedEnum
......
......@@ -17,7 +17,7 @@ import Distribution.Pretty (prettyShow)
import qualified Distribution.Utils.CharSet as CS
import Distribution.Client.IndexUtils.IndexState (IndexState)
import Distribution.Client.IndexUtils.IndexState (RepoIndexState, TotalIndexState)
import Distribution.Client.IndexUtils.Timestamp (Timestamp)
import Distribution.Client.Types (RepoName)
......@@ -30,7 +30,8 @@ import Test.QuickCheck.Instances.Cabal ()
tests :: TestTree
tests = testGroup "Described"
[ testDescribed (Proxy :: Proxy Timestamp)
, testDescribed (Proxy :: Proxy IndexState)
, testDescribed (Proxy :: Proxy RepoIndexState)
, testDescribed (Proxy :: Proxy TotalIndexState)
, testDescribed (Proxy :: Proxy RepoName)
]
......
......@@ -48,6 +48,8 @@ instance (ToExpr k, ToExpr v) => ToExpr (MapLast k v)
instance (ToExpr a) => ToExpr (NubList a)
instance (ToExpr a) => ToExpr (Flag a)
instance ToExpr (f FilePath) => ToExpr (SourceRepositoryPackage f)
instance ToExpr AllowBootLibInstalls
instance ToExpr AllowNewer
instance ToExpr AllowOlder
......@@ -61,7 +63,6 @@ instance ToExpr FlagAssignment
instance ToExpr FlagName where toExpr = defaultExprViaShow
instance ToExpr HaddockTarget
instance ToExpr IndependentGoals
instance ToExpr IndexState
instance ToExpr InstallMethod
instance ToExpr LocalRepo
instance ToExpr MinimizeConflictSet
......@@ -84,22 +85,23 @@ instance ToExpr ProjectConfigBuildOnly
instance ToExpr ProjectConfigProvenance
instance ToExpr ProjectConfigShared
instance ToExpr RelaxDepMod
instance ToExpr RelaxDeps
instance ToExpr RelaxDepScope
instance ToExpr RelaxDepSubject
instance ToExpr RelaxDeps
instance ToExpr RelaxedDep
instance ToExpr RemoteRepo
instance ToExpr ReorderGoals
instance ToExpr RepoIndexState
instance ToExpr RepoKind
instance ToExpr RepoName
instance ToExpr RepoType
instance ToExpr ReportLevel
instance ToExpr RepoType
instance ToExpr ShortText
instance ToExpr SourceRepo
instance ToExpr (f FilePath) => ToExpr (SourceRepositoryPackage f)
instance ToExpr StrongFlags
instance ToExpr TestShowDetails
instance ToExpr Timestamp
instance ToExpr TotalIndexState
instance ToExpr URI
instance ToExpr URIAuth
instance ToExpr UserConstraint
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment