Commit 06eb3c9f authored by refold's avatar refold
Browse files

Support for the extended index format in D.C.IndexUtils.

Build tree refs are now correctly loaded by `getSourcePackages`; `cabal index
--list` now benefits from package index caching.
parent ea9a2a35
......@@ -13,7 +13,12 @@ module Distribution.Client.Index (index)
where
import qualified Distribution.Client.Tar as Tar
import Distribution.Client.IndexUtils ( getSourcePackages )
import Distribution.Client.PackageIndex ( allPackages )
import Distribution.Client.Setup ( IndexFlags(..) )
import Distribution.Client.Types ( Repo(..), LocalRepo(..)
, SourcePackageDb(..)
, SourcePackage(..), PackageLocation(..) )
import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString
, makeAbsoluteToCwd )
......@@ -29,7 +34,7 @@ import Data.Maybe ( catMaybes )
import System.Directory ( canonicalizePath,
doesDirectoryExist, doesFileExist,
renameFile )
import System.FilePath ( (</>), (<.>), takeExtension )
import System.FilePath ( (</>), (<.>), takeDirectory, takeExtension )
import System.IO ( IOMode(..), SeekMode(..)
, hSeek, withBinaryFile )
......@@ -38,10 +43,6 @@ newtype LocalBuildTree = LocalBuildTree {
localBuildTreePath :: FilePath
}
-- | Type code of the corresponding tar entry type.
localBuildTreeTypeCode :: Tar.TypeCode
localBuildTreeTypeCode = 'C'
-- | Entry point for the 'cabal index' command.
index :: Verbosity -> IndexFlags -> FilePath -> IO ()
index verbosity indexFlags path' = do
......@@ -89,7 +90,7 @@ localBuildTreeFromPath dir = do
readLocalBuildTreePath :: Tar.Entry -> Maybe FilePath
readLocalBuildTreePath entry = case Tar.entryContent entry of
(Tar.OtherEntryType typeCode bs size)
| (typeCode == localBuildTreeTypeCode)
| (typeCode == Tar.localBuildTreeTypeCode)
&& (size == BS.length bs) -> Just $ byteStringToFilePath bs
| otherwise -> Nothing
_ -> Nothing
......@@ -117,7 +118,7 @@ writeLocalBuildTree lbt = Tar.simpleEntry tarPath content
tarPath = fromRight $ Tar.toTarPath True tarPath'
-- Provide a filename for tools that treat custom entries as ordinary files.
tarPath' = "local-build-tree-reference"
content = Tar.OtherEntryType localBuildTreeTypeCode bs (BS.length bs)
content = Tar.OtherEntryType Tar.localBuildTreeTypeCode bs (BS.length bs)
-- TODO: Move this to D.C.Utils?
fromRight (Left err) = error err
......@@ -176,6 +177,7 @@ doRemoveSource verbosity path l' = do
-- much smaller.
BS.writeFile tmpFile . Tar.writeEntries . Tar.filterEntries (p l) . Tar.read
=<< BS.readFile path
-- This invalidates the cache, so we don't have to update it explicitly.
renameFile tmpFile path
debug verbosity $ "Successfully renamed '" ++ tmpFile
++ "' to '" ++ path ++ "'"
......@@ -187,7 +189,11 @@ doRemoveSource verbosity path l' = do
-- | List the local build trees that are referred to from the index.
doList :: Verbosity -> FilePath -> IO ()
doList verbosity path = do
localTrees <- readLocalBuildTreePathsFromFile path
let repo = Repo { repoKind = Right LocalRepo
, repoLocalDir = takeDirectory path }
pkgIndex <- fmap packageIndex . getSourcePackages verbosity $ [repo]
let localTrees = [ pkgPath | (LocalUnpackedPackage pkgPath) <-
map packageSource . allPackages $ pkgIndex ]
when (null localTrees) $ do
notice verbosity $ "Index file '" ++ path
++ "' has no references to local build trees."
......
......@@ -32,6 +32,7 @@ import Distribution.Client.PackageIndex (PackageIndex)
import qualified Distribution.Client.PackageIndex as PackageIndex
import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
import qualified Distribution.PackageDescription.Parse as PackageDesc.Parse
import Distribution.PackageDescription
( GenericPackageDescription )
import Distribution.PackageDescription.Parse
......@@ -49,9 +50,9 @@ import Distribution.Version
import Distribution.Text
( display, simpleParse )
import Distribution.Verbosity
( Verbosity, lessVerbose )
( Verbosity, normal, lessVerbose )
import Distribution.Simple.Utils
( die, warn, info, fromUTF8 )
( die, warn, info, fromUTF8, findPackageDesc )
import Data.Char (isAlphaNum)
import Data.Maybe (catMaybes, fromMaybe)
......@@ -65,11 +66,12 @@ import qualified Data.ByteString.Lazy.Char8 as BS.Char8
import qualified Data.ByteString.Char8 as BSS
import Data.ByteString.Lazy (ByteString)
import Distribution.Client.GZipUtils (maybeDecompress)
import Distribution.Client.Utils (byteStringToFilePath)
import System.FilePath ((</>), takeExtension, splitDirectories, normalise)
import System.FilePath.Posix as FilePath.Posix
( takeFileName )
import System.IO
import System.IO.Unsafe (unsafeInterleaveIO)
import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO)
import System.IO.Error (isDoesNotExistError)
import Distribution.Compat.Exception (catchIO)
import System.Directory
......@@ -149,6 +151,8 @@ getSourcePackages verbosity repos = do
packagePreferences = prefs'
}
-- | An index entry is either a normal package, or a local build tree reference.
data PackageEntryType = NormalPackage | BuildTreeRef FilePath
-- | Read a repository index from disk, from the local file specified by
-- the 'Repo'.
......@@ -170,11 +174,13 @@ readRepoIndex verbosity repo =
readPackageIndexCacheFile mkAvailablePackage indexFile cacheFile
where
mkAvailablePackage pkgid pkg =
mkAvailablePackage pkgid pkgtype pkg =
SourcePackage {
packageInfoId = pkgid,
packageDescription = pkg,
packageSource = RepoTarballPackage repo pkgid Nothing
packageSource = case pkgtype of
NormalPackage -> RepoTarballPackage repo pkgid Nothing
BuildTreeRef path -> LocalUnpackedPackage path
}
handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e
......@@ -238,7 +244,8 @@ whenCacheOutOfDate origFile cacheFile action = do
-- case you can just use @\_ p -> p@ here.
--
readPackageIndexFile :: Package pkg
=> (PackageId -> GenericPackageDescription -> pkg)
=> (PackageId -> PackageEntryType
-> GenericPackageDescription -> pkg)
-> FilePath
-> IO (PackageIndex pkg, [Dependency])
readPackageIndexFile mkPkg indexFile = do
......@@ -248,7 +255,7 @@ readPackageIndexFile mkPkg indexFile = do
=<< BS.readFile indexFile
pkgs' <- evaluate $ PackageIndex.fromList
[ mkPkg pkgid pkg | (pkgid, pkg, _) <- pkgs]
[ mkPkg pkgid pkgtype pkg | (pkgid, pkgtype, pkg, _) <- pkgs]
return (pkgs', prefs)
-- | Parse an uncompressed \"00-index.tar\" repository index file represented
......@@ -256,7 +263,8 @@ readPackageIndexFile mkPkg indexFile = do
--
parsePackageIndex :: ByteString
-> Either String
( [(PackageId, GenericPackageDescription, BlockNo)]
( [(PackageId, PackageEntryType,
GenericPackageDescription, BlockNo)]
, [Dependency] )
parsePackageIndex = accum 0 [] [] . Tar.read
where
......@@ -274,20 +282,21 @@ parsePackageIndex = accum 0 [] [] . Tar.read
`mplus` tryExtractPrefs
where
tryExtractPkg = do
(pkgid, pkg) <- extractPkg entry
return ((pkgid, pkg, blockNo):pkgs, prefs)
(pkgid, pkgtype, pkg) <- extractPkg entry
return ((pkgid, pkgtype, pkg, blockNo):pkgs, prefs)
tryExtractPrefs = do
prefs' <- extractPrefs entry
return (pkgs, prefs'++prefs)
extractPkg :: Tar.Entry -> Maybe (PackageId, GenericPackageDescription)
extractPkg :: Tar.Entry -> Maybe (PackageId, PackageEntryType
, GenericPackageDescription)
extractPkg entry = case Tar.entryContent entry of
Tar.NormalFile content _
| takeExtension fileName == ".cabal"
-> case splitDirectories (normalise fileName) of
[pkgname,vers,_] -> case simpleParse vers of
Just ver -> Just (pkgid, descr)
Just ver -> Just (pkgid, NormalPackage, descr)
where
pkgid = PackageIdentifier (PackageName pkgname) ver
parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack
......@@ -298,6 +307,18 @@ extractPkg entry = case Tar.entryContent entry of
++ show fileName
_ -> Nothing
_ -> Nothing
Tar.OtherEntryType typeCode content _
| typeCode == Tar.localBuildTreeTypeCode -> Just (pkgid, pkgtype, descr)
where
path = byteStringToFilePath content
pkgid = packageId descr
pkgtype = BuildTreeRef path
-- TODO: get rid of unsafePerformIO
descr = unsafePerformIO $ do
cabalFile <- findPackageDesc path
PackageDesc.Parse.readPackageDescription normal cabalFile
_ -> Nothing
where
fileName = Tar.entryPath entry
......@@ -331,10 +352,14 @@ updatePackageIndexCacheFile indexFile cacheFile = do
where
mkCache pkgs prefs =
[ CachePreference pref | pref <- prefs ]
++ [ CachePackageId pkgid blockNo | (pkgid, _, blockNo) <- pkgs ]
++ [ CachePackageId pkgid blockNo
| (pkgid, NormalPackage, _, blockNo) <- pkgs ]
++ [ CacheBuildTreeRef blockNo
| (_, (BuildTreeRef _), _, blockNo) <- pkgs]
readPackageIndexCacheFile :: Package pkg
=> (PackageId -> GenericPackageDescription -> pkg)
=> (PackageId -> PackageEntryType
-> GenericPackageDescription -> pkg)
-> FilePath
-> FilePath
-> IO (PackageIndex pkg, [Dependency])
......@@ -345,7 +370,8 @@ readPackageIndexCacheFile mkPkg indexFile cacheFile = do
packageIndexFromCache :: Package pkg
=> (PackageId -> GenericPackageDescription -> pkg)
=> (PackageId -> PackageEntryType
-> GenericPackageDescription -> pkg)
-> Handle
-> [IndexCacheEntry]
-> IO (PackageIndex pkg, [Dependency])
......@@ -364,8 +390,18 @@ packageIndexFromCache mkPkg hnd = accum mempty []
-- from the index tarball if it turns out that we need it.
-- Most of the time we only need the package id.
pkg <- unsafeInterleaveIO $ do
getPackageDescription blockno
let srcpkg = mkPkg pkgid pkg
getPackageDescription blockno
let srcpkg = mkPkg pkgid NormalPackage pkg
accum (srcpkg:srcpkgs) prefs entries
accum srcpkgs prefs (CacheBuildTreeRef blockno : entries) = do
-- We have to read the .cabal file eagerly here because we can't cache the
-- package id for build tree references - the user might edit the .cabal
-- file after the reference was added to the index.
path <- getBuildTreeRef blockno
pkg <- do cabalFile <- findPackageDesc path
PackageDesc.Parse.readPackageDescription normal cabalFile
let srcpkg = mkPkg (packageId pkg) (BuildTreeRef path) pkg
accum (srcpkg:srcpkgs) prefs entries
accum srcpkgs prefs (CachePreference pref : entries) =
......@@ -378,11 +414,21 @@ packageIndexFromCache mkPkg hnd = accum mempty []
content <- BS.hGet hnd (fromIntegral size)
readPackageDescription content
getBuildTreeRef blockno = do
hSeek hnd AbsoluteSeek (fromIntegral (blockno * 512))
header <- BS.hGet hnd 512
size <- getEntrySize header
content <- BS.hGet hnd (fromIntegral size)
return $ byteStringToFilePath content
getEntrySize header =
case Tar.read header of
Tar.Next e _ ->
case Tar.entryContent e of
Tar.NormalFile _ size -> return size
Tar.OtherEntryType typecode _ size
| typecode == Tar.localBuildTreeTypeCode
-> return size
_ -> interror "unexpected tar entry type"
_ -> interror "could not read tar file entry"
......@@ -405,6 +451,7 @@ packageIndexFromCache mkPkg hnd = accum mempty []
type BlockNo = Int
data IndexCacheEntry = CachePackageId PackageId BlockNo
| CacheBuildTreeRef BlockNo
| CachePreference Dependency
deriving (Eq, Show)
......@@ -418,12 +465,17 @@ readIndexCacheEntry = \line ->
(Just pkgname, Just pkgver, Just blockno)
-> Just (CachePackageId (PackageIdentifier pkgname pkgver) blockno)
_ -> Nothing
[key, blocknostr] | key == buildTreeRefKey ->
case parseBlockNo blocknostr of
Just blockno -> Just (CacheBuildTreeRef blockno)
_ -> Nothing
(key: remainder) | key == preferredVersionKey ->
fmap CachePreference (simpleParse (BSS.unpack (BSS.unwords remainder)))
_ -> Nothing
where
packageKey = BSS.pack "pkg:"
blocknoKey = BSS.pack "b#"
buildTreeRefKey = BSS.pack "build-tree-ref:"
preferredVersionKey = BSS.pack "pref-ver:"
parseName str
......@@ -449,7 +501,8 @@ showIndexCacheEntry entry = case entry of
CachePackageId pkgid b -> "pkg: " ++ display (packageName pkgid)
++ " " ++ display (packageVersion pkgid)
++ " b# " ++ show b
CachePreference dep -> "pref-ver: " ++ display dep
CacheBuildTreeRef b -> "build-tree-ref: " ++ show b
CachePreference dep -> "pref-ver: " ++ display dep
readIndexCache :: BSS.ByteString -> [IndexCacheEntry]
readIndexCache = catMaybes . map readIndexCacheEntry . BSS.lines
......
......@@ -39,6 +39,7 @@ module Distribution.Client.Tar (
DevMinor,
TypeCode,
Format(..),
localBuildTreeTypeCode,
entrySizeInBlocks,
entrySizeInBytes,
......@@ -154,6 +155,12 @@ data Entry = Entry {
entryFormat :: !Format
}
-- | Type code for the local build tree reference entry type. We don't use the
-- symbolic link entry type because it allows only 100 ASCII characters for the
-- path.
localBuildTreeTypeCode :: TypeCode
localBuildTreeTypeCode = 'C'
-- | Native 'FilePath' of the file or directory within the archive.
--
entryPath :: Entry -> FilePath
......
Supports Markdown
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