Commit 99454f73 authored by Edsko de Vries's avatar Edsko de Vries
Browse files

Introduce structured type for specifying index

In particular, distinguish between the repo-global index and a (sandbox-)local
index.
parent 4e33454f
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.IndexUtils
......@@ -17,6 +18,7 @@ module Distribution.Client.IndexUtils (
getSourcePackages,
getSourcePackagesStrict,
Index(..),
parsePackageIndex,
readRepoIndex,
updateRepoIndexCache,
......@@ -149,13 +151,10 @@ getSourcePackages' verbosity repos mode = do
readRepoIndex :: Verbosity -> Repo -> ReadPackageIndexMode
-> IO (PackageIndex SourcePackage, [Dependency])
readRepoIndex verbosity repo mode =
let indexFile = repoLocalDir repo </> "00-index.tar"
cacheFile = repoLocalDir repo </> "00-index.cache"
in handleNotFound $ do
handleNotFound $ do
warnIfIndexIsOld =<< getIndexFileAge repo
whenCacheOutOfDate indexFile cacheFile $ do
updatePackageIndexCacheFile verbosity indexFile cacheFile
readPackageIndexCacheFile mkAvailablePackage indexFile cacheFile mode
updateRepoIndexCache verbosity (GlobalIndex repo)
readPackageIndexCacheFile mkAvailablePackage (GlobalIndex repo) mode
where
mkAvailablePackage pkgEntry =
......@@ -202,23 +201,20 @@ getIndexFileAge repo = getFileAge $ repoLocalDir repo </> "00-index.tar"
-- | It is not necessary to call this, as the cache will be updated when the
-- index is read normally. However you can do the work earlier if you like.
--
updateRepoIndexCache :: Verbosity -> Repo -> IO ()
updateRepoIndexCache verbosity repo =
whenCacheOutOfDate indexFile cacheFile $ do
updatePackageIndexCacheFile verbosity indexFile cacheFile
where
indexFile = repoLocalDir repo </> "00-index.tar"
cacheFile = repoLocalDir repo </> "00-index.cache"
whenCacheOutOfDate :: FilePath -> FilePath -> IO () -> IO ()
whenCacheOutOfDate origFile cacheFile action = do
exists <- doesFileExist cacheFile
updateRepoIndexCache :: Verbosity -> Index -> IO ()
updateRepoIndexCache verbosity index =
whenCacheOutOfDate index $ do
updatePackageIndexCacheFile verbosity index
whenCacheOutOfDate :: Index -> IO () -> IO ()
whenCacheOutOfDate index action = do
exists <- doesFileExist $ cacheFile index
if not exists
then action
else do
origTime <- getModTime origFile
cacheTime <- getModTime cacheFile
when (origTime > cacheTime) action
indexTime <- getModTime $ indexFile index
cacheTime <- getModTime $ cacheFile index
when (indexTime > cacheTime) action
------------------------------------------------------------------------
-- Reading the index file
......@@ -348,17 +344,34 @@ lazySequence (x:xs) = unsafeInterleaveIO $ do
xs' <- lazySequence xs
return (x':xs')
updatePackageIndexCacheFile :: Verbosity -> FilePath -> FilePath -> IO ()
updatePackageIndexCacheFile verbosity indexFile cacheFile = do
info verbosity ("Updating index cache file " ++ cacheFile)
-- | Which index do we mean?
data Index =
-- | The global index for the specified repository
GlobalIndex Repo
-- | A (sandbox) local repository
| LocalIndex { localIndexFile :: FilePath, localCacheFile :: FilePath }
indexFile :: Index -> FilePath
indexFile (GlobalIndex repo) = repoLocalDir repo </> "00-index.tar"
indexFile (LocalIndex{..}) = localIndexFile
cacheFile :: Index -> FilePath
cacheFile (GlobalIndex repo) = repoLocalDir repo </> "00-index.cache"
cacheFile (LocalIndex{..}) = localCacheFile
updatePackageIndexCacheFile :: Verbosity -> Index -> IO ()
updatePackageIndexCacheFile verbosity index = do
info verbosity ("Updating index cache file " ++ cacheFile index)
pkgsOrPrefs <- return
. parsePackageIndex
. maybeDecompress
=<< BS.readFile indexFile
=<< BS.readFile (indexFile index)
entries <- lazySequence pkgsOrPrefs
let cache = map toCache $ catMaybes entries
writeFile cacheFile (showIndexCache cache)
writeFile (cacheFile index) (showIndexCache cache)
where
toCache :: PackageOrDep -> IndexCacheEntry
toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo
toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo
toCache (Dep d) = CachePreference d
......@@ -368,13 +381,12 @@ data ReadPackageIndexMode = ReadPackageIndexStrict
readPackageIndexCacheFile :: Package pkg
=> (PackageEntry -> pkg)
-> FilePath
-> FilePath
-> Index
-> ReadPackageIndexMode
-> IO (PackageIndex pkg, [Dependency])
readPackageIndexCacheFile mkPkg indexFile cacheFile mode = do
cache <- liftM readIndexCache (BSS.readFile cacheFile)
myWithFile indexFile ReadMode $ \indexHnd ->
readPackageIndexCacheFile mkPkg index mode = do
cache <- liftM readIndexCache $ BSS.readFile (cacheFile index)
myWithFile (indexFile index) ReadMode $ \indexHnd ->
packageIndexFromCache mkPkg indexHnd cache mode
where
myWithFile f m act = case mode of
......
......@@ -24,7 +24,8 @@ import Distribution.Client.IndexUtils ( BuildTreeRefType(..)
, refTypeFromTypeCode
, typeCodeFromRefType
, updatePackageIndexCacheFile
, getSourcePackagesStrict )
, getSourcePackagesStrict
, Index(..) )
import Distribution.Client.PackageIndex ( allPackages )
import Distribution.Client.Types ( Repo(..), LocalRepo(..)
, SourcePackageDb(..)
......@@ -155,8 +156,10 @@ addBuildTreeRefs verbosity path l' refType = do
hSeek h AbsoluteSeek (fromIntegral offset)
BS.hPut h (Tar.write entries)
debug verbosity $ "Successfully appended to '" ++ path ++ "'"
updatePackageIndexCacheFile verbosity path
(path `replaceExtension` "cache")
updatePackageIndexCacheFile verbosity $ LocalIndex {
localIndexFile = path
, localCacheFile = path `replaceExtension` "cache"
}
data DeleteSourceError = ErrNonregisteredSource { nrPath :: FilePath }
| ErrNonexistentSource { nePath :: FilePath } deriving Show
......@@ -191,7 +194,10 @@ removeBuildTreeRefs verbosity indexPath l = do
++ "' to '" ++ indexPath ++ "'"
unless (null removedRefs) $
updatePackageIndexCacheFile verbosity indexPath (indexPath `replaceExtension` "cache")
updatePackageIndexCacheFile verbosity LocalIndex {
localIndexFile = indexPath
, localCacheFile = indexPath `replaceExtension` "cache"
}
let results = fmap Right removedRefs
++ fmap Left failures
......
......@@ -21,7 +21,7 @@ import Distribution.Client.HttpUtils
import Distribution.Client.FetchUtils
( downloadIndex )
import Distribution.Client.IndexUtils
( updateRepoIndexCache )
( updateRepoIndexCache, Index(..) )
import Distribution.Client.JobControl
( newParallelJobControl, spawnJob, collectJob )
......@@ -64,4 +64,4 @@ updateRepo transport verbosity repo = case repoKind repo of
FileDownloaded indexPath -> do
writeFileAtomic (dropExtension indexPath) . maybeDecompress
=<< BS.readFile indexPath
updateRepoIndexCache verbosity repo
updateRepoIndexCache verbosity (GlobalIndex repo)
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