Commit 0db3b216 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Switch to the tar package, drop builtin code

The current incarnation of the tar package originated as code inside
cabal-install. That external tar package is now quite mature, with more
features and is much faster. In particular the tar index features will
be very useful for cabal-install, which currently has to maintain its
own custom-format index/cache.
parent dca1c96a
......@@ -28,6 +28,9 @@ module Distribution.Client.IndexUtils (
BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType
) where
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Archive.Tar.Index as Tar
import qualified Distribution.Client.Tar as Tar
import Distribution.Client.Types
......@@ -284,12 +287,12 @@ parsePackageIndex = concatMap (uncurry extract) . tarEntriesList . Tar.read
--
-- NOTE: This preserves the lazy nature of 'Entries': the tar file is only read
-- as far as the list is evaluated.
tarEntriesList :: Tar.Entries -> [(BlockNo, Tar.Entry)]
tarEntriesList :: Show e => Tar.Entries e -> [(BlockNo, Tar.Entry)]
tarEntriesList = go 0
where
go !_ Tar.Done = []
go !_ (Tar.Fail e) = error ("tarEntriesList: " ++ e)
go !n (Tar.Next e es') = (n, e) : go (n + Tar.entrySizeInBlocks e) es'
go !_ (Tar.Fail e) = error ("tarEntriesList: " ++ show e)
go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es'
extractPkg :: Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry))
extractPkg entry blockNo = case Tar.entryContent entry of
......@@ -470,22 +473,13 @@ packageIndexFromCache mkPkg hnd Cache{..} mode = accum mempty [] cacheEntries
getEntryContent :: BlockNo -> IO ByteString
getEntryContent blockno = do
hSeek hnd AbsoluteSeek (fromIntegral (blockno * 512))
header <- BS.hGet hnd 512
size <- getEntrySize header
BS.hGet hnd (fromIntegral size)
getEntrySize :: ByteString -> IO Tar.FileSize
getEntrySize header =
case Tar.read header of
Tar.Next e _ ->
case Tar.entryContent e of
Tar.NormalFile _ size -> return size
Tar.OtherEntryType typecode _ size
| Tar.isBuildTreeRefTypeCode typecode
-> return size
_ -> interror "unexpected tar entry type"
_ -> interror "could not read tar file entry"
entry <- Tar.hReadEntry hnd blockno
case Tar.entryContent entry of
Tar.NormalFile content _size -> return content
Tar.OtherEntryType typecode content _size
| Tar.isBuildTreeRefTypeCode typecode
-> return content
_ -> interror "unexpected tar entry type"
readPackageDescription :: ByteString -> IO GenericPackageDescription
readPackageDescription content =
......@@ -504,7 +498,7 @@ packageIndexFromCache mkPkg hnd Cache{..} mode = accum mempty [] cacheEntries
-- | Tar files are block structured with 512 byte blocks. Every header and file
-- content starts on a block boundary.
--
type BlockNo = Int
type BlockNo = Tar.TarEntryOffset
data IndexCacheEntry = CachePackageId PackageId BlockNo
| CacheBuildTreeRef BuildTreeRefType BlockNo
......@@ -552,8 +546,9 @@ readIndexCacheEntry = \line ->
parseBlockNo str =
case BSS.readInt str of
Just (blockno, remainder) | BSS.null remainder -> Just blockno
_ -> Nothing
Just (blockno, remainder)
| BSS.null remainder -> Just (fromIntegral blockno)
_ -> Nothing
parseRefType str =
case BSS.uncons str of
......
......@@ -19,6 +19,9 @@ module Distribution.Client.Sandbox.Index (
defaultIndexFileName
) where
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Archive.Tar.Index as Tar
import qualified Distribution.Client.Tar as Tar
import Distribution.Client.IndexUtils ( BuildTreeRefType(..)
, refTypeFromTypeCode
......@@ -39,7 +42,7 @@ import Distribution.Compat.Exception ( tryIO )
import Distribution.Verbosity ( Verbosity )
import qualified Data.ByteString.Lazy as BS
import Control.Exception ( evaluate )
import Control.Exception ( evaluate, throw, Exception )
import Control.Monad ( liftM, unless )
import Control.Monad.Writer.Lazy (WriterT(..), runWriterT, tell)
import Data.List ( (\\), intersect, nub, find )
......@@ -49,8 +52,7 @@ import System.Directory ( createDirectoryIfMissing,
doesDirectoryExist, doesFileExist,
renameFile, canonicalizePath)
import System.FilePath ( (</>), (<.>), takeDirectory, takeExtension )
import System.IO ( IOMode(..), SeekMode(..)
, hSeek, withBinaryFile )
import System.IO ( IOMode(..), withBinaryFile )
-- | A reference to a local build tree.
data BuildTreeRef = BuildTreeRef {
......@@ -83,11 +85,11 @@ readBuildTreeRef entry = case Tar.entryContent entry of
-- | Given a sequence of tar archive entries, extract all references to local
-- build trees.
readBuildTreeRefs :: Tar.Entries -> [BuildTreeRef]
readBuildTreeRefs :: Exception e => Tar.Entries e -> [BuildTreeRef]
readBuildTreeRefs =
catMaybes
. Tar.foldrEntries (\e r -> readBuildTreeRef e : r)
[] error
. Tar.foldEntries (\e r -> readBuildTreeRef e : r)
[] throw
-- | Given a path to a tar archive, extract all references to local build trees.
readBuildTreeRefsFromFile :: FilePath -> IO [BuildTreeRef]
......@@ -146,13 +148,9 @@ addBuildTreeRefs verbosity path l' refType = do
treesToAdd <- mapM (buildTreeRefFromPath refType) (l \\ treesInIndex)
let entries = map writeBuildTreeRef (catMaybes treesToAdd)
unless (null entries) $ do
offset <-
fmap (Tar.foldrEntries (\e acc -> Tar.entrySizeInBytes e + acc) 0 error
. Tar.read) $ BS.readFile path
_ <- evaluate offset
debug verbosity $ "Writing at offset: " ++ show offset
withBinaryFile path ReadWriteMode $ \h -> do
hSeek h AbsoluteSeek (fromIntegral offset)
block <- Tar.hSeekEndEntryOffset h Nothing
debug verbosity $ "Writing at tar block: " ++ show block
BS.hPut h (Tar.write entries)
debug verbosity $ "Successfully appended to '" ++ path ++ "'"
updatePackageIndexCacheFile verbosity $ SandboxIndex path
......@@ -205,7 +203,7 @@ removeBuildTreeRefs verbosity indexPath l = do
(newIdx, changedPaths) <-
Tar.read `fmap` BS.readFile indexPath
>>= runWriterT . Tar.filterEntriesM (p $ fmap snd srcRefs)
BS.writeFile tmpFile $ Tar.writeEntries newIdx
BS.writeFile tmpFile . Tar.write . Tar.entriesToList $ newIdx
return changedPaths
p :: [FilePath] -> Tar.Entry -> WriterT [FilePath] IO Bool
......
This diff is collapsed.
{-# LANGUAGE CPP #-}
{-# LANGUAGE CPP, BangPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Targets
......@@ -59,6 +59,8 @@ import Distribution.Client.Dependency.Types
import qualified Distribution.Client.World as World
import Distribution.Client.PackageIndex (PackageIndex)
import qualified Distribution.Client.PackageIndex as PackageIndex
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Distribution.Client.Tar as Tar
import Distribution.Client.FetchUtils
import Distribution.Client.HttpUtils ( HttpTransport(..) )
......@@ -524,7 +526,7 @@ readPackageTarget verbosity target = case target of
extractTarballPackageCabalFile tarballFile tarballOriginalLoc =
either (die . formatErr) return
. check
. Tar.entriesIndex
. accumEntryMap Map.empty
. Tar.filterEntries isCabalFile
. Tar.read
. GZipUtils.maybeDecompress
......@@ -532,7 +534,13 @@ readPackageTarget verbosity target = case target of
where
formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg
check (Left e) = Left e
accumEntryMap !m Tar.Done = Right m
accumEntryMap !_ (Tar.Fail err) = Left err
accumEntryMap !m (Tar.Next e es) = accumEntryMap m' es
where
m' = Map.insert (Tar.entryTarPath e) e m
check (Left e) = Left (show e)
check (Right m) = case Map.elems m of
[] -> Left noCabalFile
[file] -> case Tar.entryContent file of
......
......@@ -171,6 +171,7 @@ executable cabal
pretty >= 1.1 && < 1.2,
random >= 1 && < 1.2,
stm >= 2.0 && < 3,
tar >= 0.4.2 && < 0.5,
time >= 1.4 && < 1.6,
zlib >= 0.5.3 && < 0.7
......
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