tar 0.4.1.0 → 0.4.2.0
raw patch · 11 files changed
+1251/−6 lines, 11 filesdep +QuickCheckdep +arraydep +tastydep ~basedep ~bytestringdep ~directory
Dependencies added: QuickCheck, array, tasty, tasty-quickcheck
Dependency ranges changed: base, bytestring, directory
Files
- Codec/Archive/Tar.hs +19/−0
- Codec/Archive/Tar/Check.hs +1/−0
- Codec/Archive/Tar/Index.hs +603/−0
- Codec/Archive/Tar/Index/IntTrie.hs +430/−0
- Codec/Archive/Tar/Index/StringTable.hs +102/−0
- Codec/Archive/Tar/Read.hs +1/−0
- Codec/Archive/Tar/Types.hs +2/−0
- LICENSE +1/−1
- changelog.md +22/−0
- tar.cabal +39/−5
- test/Properties.hs +31/−0
Codec/Archive/Tar.hs view
@@ -47,6 +47,7 @@ -- * High level \"all in one\" operations create, extract,+ append, -- * Notes -- ** Compressed tar archives@@ -146,11 +147,13 @@ import Codec.Archive.Tar.Pack import Codec.Archive.Tar.Unpack+import Codec.Archive.Tar.Index (hSeekEndEntryOffset) import Codec.Archive.Tar.Check import Control.Exception (Exception, throw, catch) import qualified Data.ByteString.Lazy as BS+import System.IO (withFile, IOMode(..)) import Prelude hiding (read) -- | Create a new @\".tar\"@ file from a directory of files.@@ -222,3 +225,19 @@ -> FilePath -- ^ Tarball -> IO () extract dir tar = unpack dir . read =<< BS.readFile tar++-- | Append new entries to a @\".tar\"@ file from a directory of files.+--+-- This is much like 'create', except that all the entries are added to the+-- end of an existing tar file. Or if the file does not already exists then+-- it behaves the same as 'create'.+--+append :: FilePath -- ^ Path of the \".tar\" file to write.+ -> FilePath -- ^ Base directory+ -> [FilePath] -- ^ Files and directories to archive, relative to base dir+ -> IO ()+append tar base paths =+ withFile tar ReadWriteMode $ \hnd -> do+ _ <- hSeekEndEntryOffset hnd Nothing+ BS.hPut hnd . write =<< pack base paths+
Codec/Archive/Tar/Check.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Codec.Archive.Tar
+ Codec/Archive/Tar/Index.hs view
@@ -0,0 +1,603 @@+{-# LANGUAGE CPP, BangPatterns, PatternGuards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}++-----------------------------------------------------------------------------+-- |+-- Module : Codec.Archive.Tar.Index+-- Copyright : (c) 2010-2015 Duncan Coutts+-- License : BSD3+--+-- Maintainer : duncan@community.haskell.org+-- Portability : portable+--+-- Random access to the content of a @.tar@ archive.+--+-- This module uses common names and so is designed to be imported qualified:+--+-- > import qualified Codec.Archive.Tar.Index as Tar+--+-----------------------------------------------------------------------------+module Codec.Archive.Tar.Index (++ -- | The @tar@ format does not contain an index of files within the+ -- archive. Normally, @tar@ file have to be processed linearly. It is+ -- sometimes useful however to be able to get random access to files+ -- within the archive.+ --+ -- This module provides an index of a @tar@ file. A linear pass of the+ -- @tar@ file is needed to 'build' the 'TarIndex', but thereafter you can+ -- 'lookup' paths in the @tar@ file, and then use 'hReadEntry' to+ -- seek to the right part of the file and read the entry.++ -- * Index type+ TarIndex,++ -- * Index lookup+ lookup,+ TarIndexEntry(..),++ -- ** I\/O operations+ TarEntryOffset,+ hReadEntry,+ hReadEntryHeader,++ -- * Index construction+ build,+ -- ** Incremental construction+ -- $incremental-construction+ IndexBuilder,+ emptyIndex,+ addNextEntry,+ skipNextEntry,+ finaliseIndex,++ -- * Serialising indexes+ serialise,+ deserialise,++ -- * Lower level operations with offsets and I\/O on tar files+ hReadEntryHeaderOrEof,+ hSeekEntryOffset,+ hSeekEntryContentOffset,+ hSeekEndEntryOffset,+ nextEntryOffset,+ indexEndEntryOffset,+ indexNextEntryOffset,++#ifdef TESTS+ prop_lookup,+ prop_valid,+#endif+ ) where++import Data.Typeable (Typeable)++import Codec.Archive.Tar.Types as Tar+import Codec.Archive.Tar.Read as Tar+import qualified Codec.Archive.Tar.Index.StringTable as StringTable+import Codec.Archive.Tar.Index.StringTable (StringTable(..))+import qualified Codec.Archive.Tar.Index.IntTrie as IntTrie+import Codec.Archive.Tar.Index.IntTrie (IntTrie(..))++import qualified System.FilePath.Posix as FilePath+import Data.Monoid (Monoid(..))+#if (MIN_VERSION_base(4,5,0))+import Data.Monoid ((<>))+#endif+import Data.Word+import Data.Int+import Data.Bits+import qualified Data.Array.Unboxed as A+import Prelude hiding (lookup)+import System.IO+import Control.Exception (throwIO)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+#if MIN_VERSION_bytestring(0,10,2)+import Data.ByteString.Builder as BS+#else+import Data.ByteString.Lazy.Builder as BS+#endif++#ifdef TESTS+import qualified Prelude+import Test.QuickCheck+import Control.Applicative ((<$>), (<*>))+#endif+++-- | An index of the entries in a tar file.+--+-- This index type is designed to be quite compact and suitable to store either+-- on disk or in memory.+--+data TarIndex = TarIndex++ -- As an example of how the mapping works, consider these example files:+ -- "foo/bar.hs" at offset 0+ -- "foo/baz.hs" at offset 1024+ --+ -- We split the paths into components and enumerate them.+ -- { "foo" -> TokenId 0, "bar.hs" -> TokenId 1, "baz.hs" -> TokenId 2 }+ --+ -- We convert paths into sequences of 'TokenId's, i.e.+ -- "foo/bar.hs" becomes [PathComponentId 0, PathComponentId 1]+ -- "foo/baz.hs" becomes [PathComponentId 0, PathComponentId 2]+ --+ -- We use a trie mapping sequences of 'PathComponentId's to the entry offset:+ -- { [PathComponentId 0, PathComponentId 1] -> offset 0+ -- , [PathComponentId 0, PathComponentId 2] -> offset 1024 }++ -- The mapping of filepath components as strings to ids.+ {-# UNPACK #-} !(StringTable PathComponentId)++ -- Mapping of sequences of filepath component ids to tar entry offsets.+ {-# UNPACK #-} !(IntTrie PathComponentId TarEntryOffset)++ -- The offset immediatly after the last entry, where we would append any+ -- additional entries.+ {-# UNPACK #-} !TarEntryOffset++ deriving (Eq, Show, Typeable)++-- | The result of 'lookup' in a 'TarIndex'. It can either be a file directly,+-- or a directory entry containing further entries (and all subdirectories+-- recursively). Note that the subtrees are constructed lazily, so it's+-- cheaper if you don't look at them.+--+data TarIndexEntry = TarFileEntry {-# UNPACK #-} !TarEntryOffset+ | TarDir [(FilePath, TarIndexEntry)]+ deriving (Show, Typeable)+++newtype PathComponentId = PathComponentId Int+ deriving (Eq, Ord, Enum, Show, Typeable)++-- | An offset within a tar file. Use 'hReadEntry', 'hReadEntryHeader' or+-- 'hSeekEntryOffset'.+--+-- This is actually a tar \"record\" number, not a byte offset.+--+type TarEntryOffset = Word32+++-- | Look up a given filepath in the 'TarIndex'. It may return a 'TarFileEntry'+-- containing the 'TarEntryOffset' of the file within the tar file, or if+-- the filepath identifies a directory then it returns a 'TarDir' containing+-- the list of files within that directory.+--+-- Given the 'TarEntryOffset' you can then use one of the I\/O operations:+-- +-- * 'hReadEntry' to read the whole entry;+--+-- * 'hReadEntryHeader' to read just the file metadata (e.g. its length);+--+lookup :: TarIndex -> FilePath -> Maybe TarIndexEntry+lookup (TarIndex pathTable pathTrie _) path = do+ fpath <- toComponentIds pathTable path+ tentry <- IntTrie.lookup pathTrie fpath+ return (mkIndexEntry tentry)+ where+ mkIndexEntry (IntTrie.Entry offset) = TarFileEntry offset+ mkIndexEntry (IntTrie.Completions entries) =+ TarDir [ (fromComponentId pathTable key, mkIndexEntry entry)+ | (key, entry) <- entries ]+++toComponentIds :: StringTable PathComponentId -> FilePath -> Maybe [PathComponentId]+toComponentIds table =+ lookupComponents []+ . filter (/= ".")+ . FilePath.splitDirectories+ where+ lookupComponents cs' [] = Just (reverse cs')+ lookupComponents cs' (c:cs) = case StringTable.lookup table c of+ Nothing -> Nothing+ Just cid -> lookupComponents (cid:cs') cs++fromComponentId :: StringTable PathComponentId -> PathComponentId -> FilePath+fromComponentId table = StringTable.index table+++-- | Build a 'TarIndex' from a sequence of tar 'Entries'. The 'Entries' are+-- assumed to start at offset @0@ within a file.+--+build :: Entries e -> Either e TarIndex+build = go emptyIndex+ where+ go !builder (Next e es) = go (addNextEntry e builder) es+ go !builder Done = Right $! finaliseIndex builder+ go !_ (Fail err) = Left err+++-- $incremental-construction+-- If you need more control than 'build' then you can construct the index+-- in an acumulator style using the 'IndexBuilder' and operations.+--+-- Start with the 'emptyIndex' and use 'addNextEntry' (or 'skipNextEntry') for+-- each 'Entry' in the tar file in order. Every entry must added or skipped in+-- order, otherwise the resulting 'TarIndex' will report the wrong+-- 'TarEntryOffset's. At the end use 'finaliseIndex' to get the 'TarIndex'.+--+-- For example, 'build' is simply:+--+-- > build = go emptyIndex+-- > where+-- > go !builder (Next e es) = go (addNextEntry e builder) es+-- > go !builder Done = Right $! finaliseIndex builder+-- > go !_ (Fail err) = Left err+++-- | The intermediate type used for incremental construction of a 'TarIndex'.+--+data IndexBuilder = IndexBuilder [(FilePath, TarEntryOffset)]+ {-# UNPACK #-} !TarEntryOffset++-- | The initial empty 'IndexBuilder'.+--+emptyIndex :: IndexBuilder+emptyIndex = IndexBuilder [] 0++-- | Add the next 'Entry' into the 'IndexBuilder'.+--+addNextEntry :: Entry -> IndexBuilder -> IndexBuilder+addNextEntry entry (IndexBuilder acc nextOffset) =+ IndexBuilder ((entrypath, nextOffset):acc)+ (nextEntryOffset entry nextOffset)+ where+ !entrypath = entryPath entry++-- | Use this function if you want to skip some entries and not add them to the+-- final 'TarIndex'.+--+skipNextEntry :: Entry -> IndexBuilder -> IndexBuilder+skipNextEntry entry (IndexBuilder acc nextOffset) =+ IndexBuilder acc (nextEntryOffset entry nextOffset)++-- | Finish accumulating 'Entry' information and build the compact 'TarIndex'+-- lookup structure.+--+finaliseIndex :: IndexBuilder -> TarIndex+finaliseIndex (IndexBuilder pathsOffsets finalOffset) =+ TarIndex pathTable pathTrie finalOffset+ where+ pathComponents = concatMap (FilePath.splitDirectories . fst) pathsOffsets+ pathTable = StringTable.construct pathComponents+ pathTrie = IntTrie.construct+ [ (cids, offset)+ | (path, offset) <- pathsOffsets+ , let Just cids = toComponentIds pathTable path ]++-- | This is the offset immediately following the entry most recently added+-- to the 'IndexBuilder'. You might use this if you need to know the offsets+-- but don't want to use the 'TarIndex' lookup structure.+-- Use with 'hSeekEntryOffset'. See also 'nextEntryOffset'.+--+indexNextEntryOffset :: IndexBuilder -> TarEntryOffset+indexNextEntryOffset (IndexBuilder _ off) = off++-- | This is the offset immediately following the last entry in the tar file.+-- This can be useful to append further entries into the tar file.+-- Use with 'hSeekEntryOffset', or just use 'hSeekEndEntryOffset' directly.+--+indexEndEntryOffset :: TarIndex -> TarEntryOffset+indexEndEntryOffset (TarIndex _ _ off) = off++-- | Calculate the 'TarEntryOffset' of the next entry, given the size and+-- offset of the current entry.+--+-- This is much like using 'skipNextEntry' and 'indexNextEntryOffset', but without+-- using an 'IndexBuilder'.+--+nextEntryOffset :: Entry -> TarEntryOffset -> TarEntryOffset+nextEntryOffset entry offset =+ offset+ + 1+ + case entryContent entry of+ NormalFile _ size -> blocks size+ OtherEntryType _ _ size -> blocks size+ _ -> 0+ where+ blocks size = 1 + ((fromIntegral size - 1) `div` 512)+++-------------------------+-- I/O operations+--++-- | Reads an entire 'Entry' at the given 'TarEntryOffset' in the tar file.+-- The 'Handle' must be open for reading and be seekable.+--+-- This reads the whole entry into memory strictly, not incrementally. For more+-- control, use 'hReadEntryHeader' and then read the entry content manually.+--+hReadEntry :: Handle -> TarEntryOffset -> IO Entry+hReadEntry hnd off = do+ entry <- hReadEntryHeader hnd off+ case entryContent entry of+ NormalFile _ size -> do body <- LBS.hGet hnd (fromIntegral size)+ return entry {+ entryContent = NormalFile body size+ }+ OtherEntryType c _ size -> do body <- LBS.hGet hnd (fromIntegral size)+ return entry {+ entryContent = OtherEntryType c body size+ }+ _ -> return entry++-- | Read the header for a 'Entry' at the given 'TarEntryOffset' in the tar+-- file. The 'entryContent' will contain the correct metadata but an empty file+-- content. The 'Handle' must be open for reading and be seekable.+--+-- The 'Handle' position is advanced to the beginning of the entry content (if+-- any). You must check the 'entryContent' to see if the entry is of type+-- 'NormalFile'. If it is, the 'NormalFile' gives the content length and you+-- are free to read this much data from the 'Handle'.+--+-- > entry <- Tar.hReadEntryHeader hnd+-- > case Tar.entryContent entry of+-- > Tar.NormalFile _ size -> do content <- BS.hGet hnd size+-- > ...+--+-- Of course you don't have to read it all in one go (as 'hReadEntry' does),+-- you can use any appropriate method to read it incrementally.+--+-- In addition to I\/O errors, this can throw a 'FormatError' if the offset is+-- wrong, or if the file is not valid tar format.+--+-- There is also the lower level operation 'hSeekEntryOffset'.+--+hReadEntryHeader :: Handle -> TarEntryOffset -> IO Entry+hReadEntryHeader hnd blockOff = do+ hSeekEntryOffset hnd blockOff+ header <- LBS.hGet hnd 512+ case Tar.read header of+ Tar.Next entry _ -> return entry+ Tar.Fail e -> throwIO e+ Tar.Done -> fail "hReadEntryHeader: impossible"++-- | Set the 'Handle' position to the position corresponding to the given+-- 'TarEntryOffset'.+--+-- This position is where the entry metadata can be read. If you already know+-- the entry has a body (and perhaps know it's length), you may wish to seek to+-- the body content directly using 'hSeekEntryContentOffset'.+--+hSeekEntryOffset :: Handle -> TarEntryOffset -> IO ()+hSeekEntryOffset hnd blockOff =+ hSeek hnd AbsoluteSeek (fromIntegral blockOff * 512)++-- | Set the 'Handle' position to the entry content position corresponding to+-- the given 'TarEntryOffset'.+--+-- This position is where the entry content can be read using ordinary I\/O+-- operations (though you have to know in advance how big the entry content+-- is). This is /only valid/ if you /already know/ the entry has a body (i.e.+-- is a normal file).+--+hSeekEntryContentOffset :: Handle -> TarEntryOffset -> IO ()+hSeekEntryContentOffset hnd blockOff =+ hSeekEntryOffset hnd (blockOff + 1)++-- | This is a low level variant on 'hReadEntryHeader', that can be used to+-- iterate through a tar file, entry by entry.+--+-- It has a few differences compared to 'hReadEntryHeader':+--+-- * It returns an indication when the end of the tar file is reached.+--+-- * It /does not/ move the 'Handle' position to the beginning of the entry+-- content.+--+-- * It returns the 'TarEntryOffset' of the next entry.+--+-- After this action, the 'Handle' position is not in any useful place. If+-- you want to skip to the next entry, take the 'TarEntryOffset' returned and+-- use 'hReadEntryHeaderOrEof' again. Or if having inspected the 'Entry'+-- header you want to read the entry content (if it has one) then use+-- 'hSeekEntryContentOffset' on the original input 'TarEntryOffset'.+--+hReadEntryHeaderOrEof :: Handle -> TarEntryOffset+ -> IO (Maybe (Entry, TarEntryOffset))+hReadEntryHeaderOrEof hnd blockOff = do+ hSeekEntryOffset hnd blockOff+ header <- LBS.hGet hnd 1024+ case Tar.read header of+ Tar.Next entry _ -> let !blockOff' = nextEntryOffset entry blockOff+ in return (Just (entry, blockOff'))+ Tar.Done -> return Nothing+ Tar.Fail e -> throwIO e++-- | Seek to the end of a tar file, to the position where new entries can+-- be appended, and return that 'TarEntryOffset'.+--+-- If you have a valid 'TarIndex' for this tar file then you should supply it+-- because it allows seeking directly to the correct location.+--+-- If you do not have an index, then this becomes an expensive linear+-- operation because we have to read each tar entry header from the beginning+-- to find the location immediately after the last entry (this is because tar+-- files have a variable length trailer and we cannot reliably find that by+-- starting at the end). In this mode, it will fail with an exception if the+-- file is not in fact in the tar format.+--+hSeekEndEntryOffset :: Handle -> Maybe TarIndex -> IO TarEntryOffset+hSeekEndEntryOffset hnd (Just index) = do+ let offset = indexEndEntryOffset index+ hSeekEntryOffset hnd offset+ return offset++hSeekEndEntryOffset hnd Nothing = do+ size <- hFileSize hnd+ if size == 0+ then return 0+ else seekToEnd 0+ where+ seekToEnd offset = do+ mbe <- hReadEntryHeaderOrEof hnd offset+ case mbe of+ Nothing -> do hSeekEntryOffset hnd offset+ return offset+ Just (_, offset') -> seekToEnd offset'++-------------------------+-- (de)serialisation+--++-- | The 'TarIndex' is compact in memory, and it has a similarly compact+-- external representation.+--+serialise :: TarIndex -> BS.Builder+serialise (TarIndex stringTable intTrie finalOffset) =+ BS.word32BE 1 -- format version+ <> BS.word32BE finalOffset+ <> serialiseStringTable stringTable+ <> serialiseIntTrie intTrie++-- | Read the external representation back into a 'TarIndex'.+--+deserialise :: BS.ByteString -> Maybe (TarIndex, BS.ByteString)+deserialise bs+ | BS.length bs >= 8+ , let ver = readWord32BE bs 0+ , ver == 1+ = do let !finalOffset = readWord32BE bs 4+ (stringTable, bs') <- deserialiseStringTable (BS.drop 8 bs)+ (intTrie, bs'') <- deserialiseIntTrie bs'+ return (TarIndex stringTable intTrie finalOffset, bs'')++ | otherwise = Nothing++serialiseIntTrie :: IntTrie k v -> BS.Builder+serialiseIntTrie (IntTrie arr) =+ let (_, !ixEnd) = A.bounds arr in+ BS.word32BE (ixEnd+1)+ <> foldr (\n r -> BS.word32BE n <> r) mempty (A.elems arr)++deserialiseIntTrie :: BS.ByteString -> Maybe (IntTrie k v, BS.ByteString)+deserialiseIntTrie bs+ | BS.length bs >= 4+ , let lenArr = readWord32BE bs 0+ lenTotal = 4 + 4 * fromIntegral lenArr+ , BS.length bs >= 4 + 4 * fromIntegral lenArr+ , let !arr = A.array (0, lenArr-1)+ [ (i, readWord32BE bs off)+ | (i, off) <- zip [0..lenArr-1] [4,8 .. lenTotal - 4] ]+ !bs' = BS.drop lenTotal bs+ = Just (IntTrie arr, bs')++ | otherwise+ = Nothing++serialiseStringTable :: StringTable id -> BS.Builder+serialiseStringTable (StringTable strs arr) =+ let (_, !ixEnd) = A.bounds arr in+ + BS.word32BE (fromIntegral (BS.length strs))+ <> BS.word32BE (fromIntegral ixEnd + 1)+ <> BS.byteString strs+ <> foldr (\n r -> BS.word32BE n <> r) mempty (A.elems arr)++deserialiseStringTable :: BS.ByteString -> Maybe (StringTable id, BS.ByteString)+deserialiseStringTable bs+ | BS.length bs >= 8+ , let lenStrs = fromIntegral (readWord32BE bs 0)+ lenArr = fromIntegral (readWord32BE bs 4)+ lenTotal= 8 + lenStrs + 4 * lenArr+ , BS.length bs >= lenTotal+ , let strs = BS.take lenStrs (BS.drop 8 bs)+ arr = A.array (0, lenArr-1)+ [ (i, readWord32BE bs off)+ | (i, off) <- zip [0..lenArr-1]+ [offArrS,offArrS+4 .. offArrE]+ ]+ offArrS = 8 + lenStrs+ offArrE = offArrS + 4 * lenArr - 1+ !stringTable = StringTable strs arr+ !bs' = BS.drop lenTotal bs+ = Just (stringTable, bs')++ | otherwise+ = Nothing++readWord32BE :: BS.ByteString -> Int -> Word32+readWord32BE bs i =+ fromIntegral (BS.index bs (i + 0)) `shiftL` 24+ + fromIntegral (BS.index bs (i + 1)) `shiftL` 16+ + fromIntegral (BS.index bs (i + 2)) `shiftL` 8+ + fromIntegral (BS.index bs (i + 3))+++-------------------------+-- Test properties+--++#ifdef TESTS++-- properties of a finite mapping...++prop_lookup :: [(NonEmptyFilePath, TarEntryOffset)] -> NonEmptyFilePath -> Bool+prop_lookup paths (NonEmptyFilePath p) =+ case (lookup index p, Prelude.lookup p paths') of+ (Nothing, Nothing) -> True+ (Just (TarFileEntry offset), Just offset') -> offset == offset'+ _ -> False+ where+ paths' = [ (p, off) | (NonEmptyFilePath p, off) <- paths ]++ index@(TarIndex pathTable _ _) =+ finaliseIndex (IndexBuilder paths' 0)++prop_valid :: [(NonEmptyFilePath, TarEntryOffset)] -> Bool+prop_valid paths+ | not $ StringTable.prop_valid pathbits = error "TarIndex: bad string table"+ | not $ IntTrie.prop_lookup intpaths = error "TarIndex: bad int trie"+ | not $ IntTrie.prop_completions intpaths = error "TarIndex: bad int trie"+ | not $ prop' = error "TarIndex: bad prop"+ | otherwise = True++ where+ paths' = [ (p, off) | (NonEmptyFilePath p, off) <- paths ]++ index@(TarIndex pathTable _ _) =+ finaliseIndex (IndexBuilder paths' 0)++ pathbits = concatMap (FilePath.splitDirectories . fst) paths'+ intpaths = [ (cids, offset)+ | (path, offset) <- paths'+ , let Just cids = toComponentIds pathTable path ]+ prop' = flip all paths' $ \(file, offset) ->+ case lookup index file of+ Just (TarFileEntry offset') -> offset' == offset+ _ -> False++newtype NonEmptyFilePath = NonEmptyFilePath FilePath deriving Show++instance Arbitrary NonEmptyFilePath where+ arbitrary = NonEmptyFilePath . FilePath.joinPath+ <$> listOf1 (elements ["a", "b", "c", "d"])++example0 :: Entries ()+example0 =+ testEntry "foo-1.0/foo-1.0.cabal" 1500 -- at block 0+ `Next` testEntry "foo-1.0/LICENSE" 2000 -- at block 4+ `Next` testEntry "foo-1.0/Data/Foo.hs" 1000 -- at block 9+ `Next` Done++example1 :: Entries ()+example1 =+ Next (testEntry "./" 1500) Done <> example0++testEntry :: FilePath -> Int64 -> Entry+testEntry name size = simpleEntry path (NormalFile mempty size)+ where+ Right path = toTarPath False name++#endif++#if !(MIN_VERSION_base(4,5,0))+(<>) :: Monoid m => m -> m -> m+(<>) = mappend+#endif+
+ Codec/Archive/Tar/Index/IntTrie.hs view
@@ -0,0 +1,430 @@+{-# LANGUAGE CPP, BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}++module Codec.Archive.Tar.Index.IntTrie (++ IntTrie(..),+ construct,++ lookup,+ TrieLookup(..),++#ifdef TESTS+ test1, test2, test3,+ ValidPaths(..),+ prop_lookup,+ prop_completions,+ prop_lookup_mono,+ prop_completions_mono,+#endif+ ) where++import Prelude hiding (lookup)++import Data.Typeable (Typeable)++import qualified Data.Array.Unboxed as A+import Data.Array.IArray ((!))+import qualified Data.Bits as Bits+import Data.Word (Word32)++import Data.List hiding (lookup)+import Data.Function (on)++#ifdef TESTS+import Test.QuickCheck+import Control.Applicative ((<$>), (<*>))+#endif+++-- | A compact mapping from sequences of small nats to nats.+--+newtype IntTrie k v = IntTrie (A.UArray Word32 Word32)+ deriving (Eq, Show, Typeable)+++-- Compact, read-only implementation of a trie. It's intended for use with file+-- paths, but we do that via string ids.++#ifdef TESTS+-- Example mapping:+--+example0 :: [(FilePath, Int)]+example0 =+ [("foo-1.0/foo-1.0.cabal", 512) -- tar block 1+ ,("foo-1.0/LICENSE", 2048) -- tar block 4+ ,("foo-1.0/Data/Foo.hs", 4096)] -- tar block 8++-- After converting path components to integers this becomes:+--+example1 :: Paths Word32 Word32+example1 =+ [([1,2], 512)+ ,([1,3], 2048)+ ,([1,4,5], 4096)]++-- As a trie this looks like:++-- [ (1, *) ]+-- |+-- [ (2, 512), (3, 1024), (4, *) ]+-- |+-- [ (5, 4096) ]++-- We use an intermediate trie representation++example2 :: Trie Word32 Word32+example2 = Trie [ Node 1 t1 ]+ where+ t1 = Trie [ Leaf 2 512, Leaf 3 2048, Node 4 t2 ]+ t2 = Trie [ Leaf 5 4096 ]+++example2' :: Trie Word32 Word32+example2' = Trie [ Node 0 t1 ]+ where+ t1 = Trie [ Node 3 t2 ]+ t2 = Trie [ Node 1 t3, Node 2 t4 ]+ t3 = Trie [ Leaf 4 10608 ]+ t4 = Trie [ Leaf 4 10612 ]+{-+0: [1,N0,3]++ 3: [1,N3,6]++ 6: [2,N1,N2,11,12]++ 11: [1,4,10608]+ 14: [1,4,10612]+-}++example2'' :: Trie Word32 Word32+example2'' = Trie [ Node 1 t1, Node 2 t2 ]+ where+ t1 = Trie [ Leaf 4 10608 ]+ t2 = Trie [ Leaf 4 10612 ]++example2''' :: Trie Word32 Word32+example2''' = Trie [ Node 0 t3 ]+ where+ t3 = Trie [ Node 4 t8, Node 6 t11 ]+ t8 = Trie [ Node 1 t14 ]+ t11 = Trie [ Leaf 5 10605 ]+ t14 = Trie [ Node 2 t19, Node 3 t22 ]+ t19 = Trie [ Leaf 7 10608 ]+ t22 = Trie [ Leaf 7 10612 ]+{-+ 0: [1,N0,3]+ 3: [2,N4,N6,8,11]+ 8: [1,N1,11]+11: [1,5,10605]+14: [2,N2,N3,16,19]+19: [1,7,10608]+22: [1,7,10612]+-}++-- We convert from the 'Paths' to the 'Trie' using 'mkTrie':+--+test1 = example2 == mkTrie example1+#endif++-- Each node has a size and a sequence of keys followed by an equal length+-- sequnce of corresponding entries. Since we're going to flatten this into+-- a single array then we will need to replace the trie structure with pointers+-- represented as array offsets.++-- Each node is a pair of arrays, one of keys and one of Either value pointer.+-- We need to distinguish values from internal pointers. We use a tag bit:+--+tagLeaf, tagNode, untag :: Word32 -> Word32+tagLeaf = id+tagNode = flip Bits.setBit 31+untag = flip Bits.clearBit 31++isNode :: Word32 -> Bool+isNode = flip Bits.testBit 31++-- So the overall array form of the above trie is:+--+-- offset: 0 1 2 3 4 5 6 7 8 9 10 11 12+-- array: [ 1 | N1 | 3 ][ 3 | 2, 3, N4 | 512, 2048, 10 ][ 1 | 5 | 4096 ]+-- \__/ \___/++#ifdef TESTS+example3 :: [Word32]+example3 =+ [1, tagNode 1,+ 3,+ 3, tagLeaf 2, tagLeaf 3, tagNode 4,+ 512, 2048, 10,+ 1, tagLeaf 5,+ 4096+ ]++-- We get the array form by using flattenTrie:++test2 = example3 == flattenTrie example2++example4 :: IntTrie Int Int+example4 = IntTrie (mkArray example3)++test3 = case lookup example4 [1] of+ Just (Completions [(2,_),(3,_),(4,_)]) -> True+ _ -> False++test1, test2, test3 :: Bool+#endif++-------------------------------------+-- Decoding the trie array form+--++completionsFrom :: (Enum k, Enum v) => IntTrie k v -> Word32 -> Completions k v+completionsFrom trie@(IntTrie arr) nodeOff =+ [ (word32ToEnum (untag key), next)+ | keyOff <- [keysStart..keysEnd]+ , let key = arr ! keyOff+ entry = arr ! (keyOff + nodeSize)+ next | isNode key = Completions (completionsFrom trie entry)+ | otherwise = Entry (word32ToEnum entry)+ ]+ where+ nodeSize = arr ! nodeOff+ keysStart = nodeOff + 1+ keysEnd = nodeOff + nodeSize++-------------------------------------+-- Toplevel trie array construction+--++-- So constructing the 'IntTrie' as a whole is just a matter of stringing+-- together all the bits++-- | Build an 'IntTrie' from a bunch of (key, value) pairs, where the keys+-- are sequences.+--+construct :: (Ord k, Enum k, Enum v) => [([k], v)] -> IntTrie k v+construct = IntTrie . mkArray . flattenTrie . mkTrie++mkArray :: [Word32] -> A.UArray Word32 Word32+mkArray xs = A.listArray (0, fromIntegral (length xs) - 1) xs+++---------------------------------+-- Looking up in the trie array+--++data TrieLookup k v = Entry !v | Completions (Completions k v) deriving Show+type Completions k v = [(k, TrieLookup k v)]++lookup :: forall k v. (Enum k, Enum v) => IntTrie k v -> [k] -> Maybe (TrieLookup k v)+lookup trie@(IntTrie arr) = go 0+ where+ go :: Word32 -> [k] -> Maybe (TrieLookup k v)+ go nodeOff [] = Just (completions nodeOff)+ go nodeOff (k:ks) = case search nodeOff (tagLeaf k') of+ Just entryOff+ | null ks -> Just (entry entryOff)+ | otherwise -> Nothing+ Nothing -> case search nodeOff (tagNode k') of+ Nothing -> Nothing+ Just entryOff -> go (arr ! entryOff) ks+ where+ k' = enumToWord32 k++ entry entryOff = Entry (word32ToEnum (arr ! entryOff))+ completions nodeOff = Completions (completionsFrom trie nodeOff)++ search :: Word32 -> Word32 -> Maybe Word32+ search nodeOff key = fmap (+nodeSize) (bsearch keysStart keysEnd key)+ where+ nodeSize = arr ! nodeOff+ keysStart = nodeOff + 1+ keysEnd = nodeOff + nodeSize++ bsearch :: Word32 -> Word32 -> Word32 -> Maybe Word32+ bsearch a b key+ | a > b = Nothing+ | otherwise = case compare key (arr ! mid) of+ LT -> bsearch a (mid-1) key+ EQ -> Just mid+ GT -> bsearch (mid+1) b key+ where mid = (a + b) `div` 2+++enumToWord32 :: Enum n => n -> Word32+enumToWord32 = fromIntegral . fromEnum++word32ToEnum :: Enum n => Word32 -> n+word32ToEnum = toEnum . fromIntegral+++-------------------------+-- Intermediate Trie type+--++-- The trie node functor+data TrieNodeF k v x = Leaf k v | Node k x deriving (Eq, Show)++instance Functor (TrieNodeF k v) where+ fmap _ (Leaf k v) = Leaf k v+ fmap f (Node k x) = Node k (f x)++-- The trie functor+type TrieF k v x = [TrieNodeF k v x]++-- Trie is the fixpoint of the 'TrieF' functor+newtype Trie k v = Trie (TrieF k v (Trie k v)) deriving (Eq, Show)+++unfoldTrieNode :: (s -> TrieNodeF k v [s]) -> s -> TrieNodeF k v (Trie k v)+unfoldTrieNode f = fmap (unfoldTrie f) . f++unfoldTrie :: (s -> TrieNodeF k v [s]) -> [s] -> Trie k v+unfoldTrie f = Trie . map (unfoldTrieNode f)++{-+trieSize :: Trie k v -> Int+trieSize (Trie ts) = 1 + sum (map trieNodeSize ts)++trieNodeSize :: TrieNodeF k v (Trie k v) -> Int+trieNodeSize (Leaf _ _) = 2+trieNodeSize (Node _ t) = 2 + trieSize t+-}++---------------------------------+-- Building and flattening Tries+--++-- | A list of key value pairs. The keys must be distinct and non-empty.+type Paths k v = [([k], v)]+++mkTrie :: Ord k => Paths k v -> Trie k v+mkTrie = unfoldTrie (fmap split) . split+ . sortBy (compare `on` fst)+ . filter (not . null . fst)+ where+ split :: Eq k => Paths k v -> TrieF k v (Paths k v)+ split = map mkGroup . groupBy ((==) `on` (head . fst))+ where+ mkGroup = \ksvs@((k0:_,v0):_) ->+ case [ (ks, v) | (_:ks, v) <- ksvs, not (null ks) ] of+ [] -> Leaf k0 v0+ ksvs' -> Node k0 ksvs'++type Offset = Int++-- This is a breadth-first traversal. We keep a list of the tries that we are+-- to write out next. Each of these have an offset allocated to them at the+-- time we put them into the list. We keep a running offset so we know where+-- to allocate next.+--+flattenTrie :: (Enum k, Enum v) => Trie k v -> [Word32]+flattenTrie trie = go (queue [trie]) (size trie)+ where+ size (Trie tns) = 1 + 2 * length tns++ go :: (Enum k, Enum v) => Q (Trie k v) -> Offset -> [Word32]+ go todo !offset =+ case dequeue todo of+ Nothing -> []+ Just (Trie tnodes, tries) ->+ flat ++ go (tries `enqueue` tries') offset'+ where+ !count = length tnodes+ flat = fromIntegral count : keys ++ values+ (keys, values) = unzip (sortBy (compare `on` fst) keysValues)+ (!keysValues, !tries', !offset') = doNodes offset [] [] tnodes++ doNodes off kvs ts' [] = (kvs, reverse ts', off)+ doNodes off kvs ts' (tn:tns) = case tn of+ Leaf k v -> doNodes off (leafKV k v :kvs) ts' tns+ Node k t -> doNodes (off + size t) (nodeKV k off:kvs) (t:ts') tns++ leafKV k v = (tagLeaf (enum2Word32 k), enum2Word32 v)+ nodeKV k o = (tagNode (enum2Word32 k), int2Word32 o)++data Q a = Q [a] [[a]]++queue :: [a] -> Q a+queue xs = Q xs []++enqueue :: Q a -> [a] -> Q a+enqueue (Q front back) [] = Q front back+enqueue (Q front back) xs = Q front (xs : back)++dequeue :: Q a -> Maybe (a, Q a)+dequeue (Q (x:xs) back) = Just (x, Q xs back)+dequeue (Q [] back) = case concat (reverse back) of+ x:xs -> Just (x, Q xs [])+ [] -> Nothing++int2Word32 :: Int -> Word32+int2Word32 = fromIntegral++enum2Word32 :: Enum n => n -> Word32+enum2Word32 = int2Word32 . fromEnum+++-------------------------+-- Correctness property+--++#ifdef TESTS++prop_lookup :: (Ord k, Enum k, Eq v, Enum v, Show k, Show v)+ => [([k], v)] -> Bool+prop_lookup paths =+ flip all paths $ \(key, value) ->+ case lookup trie key of+ Just (Entry value') | value' == value -> True+ Just (Entry value') -> error $ "IntTrie: " ++ show (key, value, value')+ Nothing -> error $ "IntTrie: didn't find " ++ show key+ Just (Completions xs) -> error $ "IntTrie: " ++ show xs++ where+ trie = construct paths++prop_completions :: forall k v. (Ord k, Enum k, Eq v, Enum v) => [([k], v)] -> Bool+prop_completions paths =+ mkTrie paths == convertCompletions (completionsFrom (construct paths) 0)+ where+ convertCompletions :: Ord k => Completions k v -> Trie k v+ convertCompletions kls =+ Trie [ case l of+ Entry v -> Leaf k v+ Completions kls' -> Node k (convertCompletions kls')+ | (k, l) <- sortBy (compare `on` fst) kls ]+++prop_lookup_mono :: ValidPaths -> Bool+prop_lookup_mono (ValidPaths paths) = prop_lookup paths++prop_completions_mono :: ValidPaths -> Bool+prop_completions_mono (ValidPaths paths) = prop_completions paths+++newtype ValidPaths = ValidPaths (Paths Char Char) deriving Show++instance Arbitrary ValidPaths where+ arbitrary =+ ValidPaths . makeNoPrefix <$> listOf ((,) <$> listOf1 arbitrary <*> arbitrary)+ where+ makeNoPrefix [] = []+ makeNoPrefix ((k,v):kvs)+ | all (\(k', _) -> not (isPrefixOfOther k k')) kvs+ = (k,v) : makeNoPrefix kvs+ | otherwise = makeNoPrefix kvs++ shrink (ValidPaths kvs) =+ map ValidPaths . filter noPrefix . filter nonEmpty . shrink $ kvs+ where+ noPrefix [] = True+ noPrefix ((k,_):kvs) = all (\(k', _) -> not (isPrefixOfOther k k')) kvs+ && noPrefix kvs+ nonEmpty = all (not . null . fst)++isPrefixOfOther a b = a `isPrefixOf` b || b `isPrefixOf` a++#endif
+ Codec/Archive/Tar/Index/StringTable.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE CPP, BangPatterns, DeriveDataTypeable #-}++module Codec.Archive.Tar.Index.StringTable (++ StringTable(..),+ lookup,+ index,+ construct,++#ifdef TESTS+ prop_valid,+#endif+ ) where++import Data.Typeable (Typeable)++import Prelude hiding (lookup)+import qualified Data.List as List+import qualified Data.Array.Unboxed as A+import Data.Array.Unboxed ((!))+import qualified Data.ByteString.Char8 as BS+import Data.Word (Word32)++++-- | An effecient mapping from strings to a dense set of integers.+--+data StringTable id = StringTable+ {-# UNPACK #-} !BS.ByteString -- all the strings concatenated+ {-# UNPACK #-} !(A.UArray Int Word32) -- offset table+ deriving (Eq, Show, Typeable)++-- | Look up a string in the token table. If the string is present, return+-- its corresponding index.+--+lookup :: Enum id => StringTable id -> String -> Maybe id+lookup (StringTable bs tbl) str =+ binarySearch 0 (topBound-1) (BS.pack str)+ where+ (0, topBound) = A.bounds tbl++ binarySearch !a !b !key+ | a > b = Nothing+ | otherwise = case compare key (index' bs tbl mid) of+ LT -> binarySearch a (mid-1) key+ EQ -> Just (toEnum mid)+ GT -> binarySearch (mid+1) b key+ where mid = (a + b) `div` 2++index' :: BS.ByteString -> A.UArray Int Word32 -> Int -> BS.ByteString+index' bs tbl i = BS.take len . BS.drop start $ bs+ where+ start, end, len :: Int+ start = fromIntegral (tbl ! i)+ end = fromIntegral (tbl ! (i+1))+ len = end - start+++-- | Given the index of a string in the table, return the string.+--+index :: Enum id => StringTable id -> id -> String+index (StringTable bs tbl) = BS.unpack . index' bs tbl . fromEnum+++-- | Given a list of strings, construct a 'StringTable' mapping those strings+-- to a dense set of integers.+--+construct :: Enum id => [String] -> StringTable id+construct strs = StringTable bs tbl+ where+ bs = BS.pack (concat strs')+ tbl = A.array (0, length strs') (zip [0..] offsets)+ offsets = scanl (\off str -> off + fromIntegral (length str)) 0 strs'+ strs' = map head . List.group . List.sort $ strs+++#ifdef TESTS++prop_valid :: [String] -> Bool+prop_valid strs =+ all lookupIndex (enumStrings tbl)+ && all indexLookup (enumIds tbl)++ where+ tbl :: StringTable Int+ tbl = construct strs++ lookupIndex str = index tbl ident == str+ where Just ident = lookup tbl str++ indexLookup ident = lookup tbl str == Just ident+ where str = index tbl ident++enumStrings :: Enum id => StringTable id -> [String]+enumStrings (StringTable bs tbl) = map (BS.unpack . index' bs tbl) [0..h-1]+ where (0,h) = A.bounds tbl++enumIds :: Enum id => StringTable id -> [id]+enumIds (StringTable _ tbl) = map toEnum [0..h-1]+ where (0,h) = A.bounds tbl++#endif
Codec/Archive/Tar/Read.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Codec.Archive.Tar.Read
Codec/Archive/Tar/Types.hs view
@@ -418,6 +418,8 @@ | Done | Fail e +infixr 5 `Next`+ -- | This is like the standard 'unfoldr' function on lists, but for 'Entries'. -- It includes failure as an extra possibility that the stepper function may -- return.
LICENSE view
@@ -1,5 +1,5 @@ Copyright (c) 2007 Björn Bringert,- 2008-2012 Duncan Coutts,+ 2008-2015 Duncan Coutts, 2011 Max Bolingbroke All rights reserved.
+ changelog.md view
@@ -0,0 +1,22 @@+0.4.2.0 Duncan Coutts <duncan@community.haskell.org> July 2015++ * New Index module for random access to tar file contents+ * New lower level tar file I/O actions+ * New tarball file 'append' action++0.4.1.0 Duncan Coutts <duncan@community.haskell.org> January 2015++ * Build with GHC 7.10+ * Switch from old-time to time package+ * Added more instance for Entries type++0.4.0.1 Duncan Coutts <duncan@community.haskell.org> October 2012++ * fixes to work with directory 1.2+ * More Eq/Ord instances++0.4.0.0 Duncan Coutts <duncan@community.haskell.org> February 2012++ * More explicit error types and error handling+ * Support star base-256 number format+ * Improved API documentation
tar.cabal view
@@ -1,5 +1,5 @@ name: tar-version: 0.4.1.0+version: 0.4.2.0 license: BSD3 license-file: LICENSE author: Bjorn Bringert <bjorn@bringert.net>@@ -18,6 +18,7 @@ preserved. build-type: Simple cabal-version: >=1.8+extra-source-files: changelog.md source-repository head type: darcs@@ -26,8 +27,11 @@ flag old-time library- build-depends: base == 4.*, filepath,- bytestring, directory+ build-depends: base == 4.*,+ bytestring >= 0.10,+ filepath,+ directory,+ array if flag(old-time) build-depends: directory < 1.2, old-time else@@ -37,6 +41,7 @@ Codec.Archive.Tar Codec.Archive.Tar.Entry Codec.Archive.Tar.Check+ Codec.Archive.Tar.Index other-modules: Codec.Archive.Tar.Types@@ -44,8 +49,37 @@ Codec.Archive.Tar.Write Codec.Archive.Tar.Pack Codec.Archive.Tar.Unpack+ Codec.Archive.Tar.Index.StringTable+ Codec.Archive.Tar.Index.IntTrie - extensions:- DeriveDataTypeable+ other-extensions:+ CPP, BangPatterns,+ DeriveDataTypeable, ScopedTypeVariables ghc-options: -Wall -fno-warn-unused-imports++test-suite properties+ type: exitcode-stdio-1.0+ build-depends: base,+ bytestring,+ filepath, directory,+ old-time, time,+ array,+ QuickCheck == 2.*,+ tasty == 0.10.*,+ tasty-quickcheck == 0.8.*++ hs-source-dirs: . test++ main-is: test/Properties.hs+ cpp-options: -DTESTS++ other-modules:+ Codec.Archive.Tar.Index+ Codec.Archive.Tar.Index.StringTable+ Codec.Archive.Tar.Index.IntTrie++ other-extensions:+ CPP, BangPatterns,+ DeriveDataTypeable, ScopedTypeVariables+
+ test/Properties.hs view
@@ -0,0 +1,31 @@+module Main where++import qualified Codec.Archive.Tar.Index as Index+import qualified Codec.Archive.Tar.Index.IntTrie as IntTrie+import qualified Codec.Archive.Tar.Index.StringTable as StringTable++import qualified Data.ByteString.Lazy.Char8 as BS+import Test.QuickCheck+import Test.Tasty+import Test.Tasty.QuickCheck++main :: IO ()+main =+ defaultMain $+ testGroup "tar tests" [+ testGroup "string table" [+ testProperty "construction and lookup" StringTable.prop_valid+ ]+ , testGroup "int trie" [+ testProperty "unit 1" IntTrie.test1,+ testProperty "unit 2" IntTrie.test2,+ testProperty "unit 3" IntTrie.test3,+ testProperty "lookups" IntTrie.prop_lookup_mono,+ testProperty "completions" IntTrie.prop_completions_mono+ ]+ , testGroup "index" [+ testProperty "lookup" Index.prop_lookup+ , testProperty "valid" Index.prop_valid+ ]+ ]+