tar 0.4.2.2 → 0.4.3.0
raw patch · 11 files changed
+1164/−383 lines, 11 filesdep +containersdep +criteriondep +deepseqdep ~basedep ~bytestringdep ~directory
Dependencies added: containers, criterion, deepseq
Dependency ranges changed: base, bytestring, directory
Files
- Codec/Archive/Tar.hs +34/−0
- Codec/Archive/Tar/Index.hs +188/−129
- Codec/Archive/Tar/Index/IntTrie.hs +250/−102
- Codec/Archive/Tar/Index/StringTable.hs +231/−35
- Codec/Archive/Tar/Read.hs +87/−44
- Codec/Archive/Tar/Types.hs +231/−35
- Codec/Archive/Tar/Write.hs +30/−23
- bench/Main.hs +45/−0
- changelog.md +11/−0
- tar.cabal +30/−9
- test/Properties.hs +27/−6
Codec/Archive/Tar.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Codec.Archive.Tar@@ -138,6 +139,13 @@ -- ** Errors from reading tar files FormatError(..),+++#ifdef TESTS+ prop_write_read_ustar,+ prop_write_read_gnu,+ prop_write_read_v7,+#endif ) where import Codec.Archive.Tar.Types@@ -241,3 +249,29 @@ _ <- hSeekEndEntryOffset hnd Nothing BS.hPut hnd . write =<< pack base paths +-------------------------+-- Correctness properties+--++#ifdef TESTS++prop_write_read_ustar :: [Entry] -> Bool+prop_write_read_ustar entries =+ foldr Next Done entries' == read (write entries')+ where+ entries' = [ e { entryFormat = UstarFormat } | e <- entries ]++prop_write_read_gnu :: [Entry] -> Bool+prop_write_read_gnu entries =+ foldr Next Done entries' == read (write entries')+ where+ entries' = [ e { entryFormat = GnuFormat } | e <- entries ]++prop_write_read_v7 :: [Entry] -> Bool+prop_write_read_v7 entries =+ foldr Next Done entries' == read (write entries')+ where+ entries' = [ limitToV7FormatCompat e { entryFormat = V7Format }+ | e <- entries ]++#endif
Codec/Archive/Tar/Index.hs view
@@ -14,7 +14,7 @@ -- -- This module uses common names and so is designed to be imported qualified: ----- > import qualified Codec.Archive.Tar.Index as Tar+-- > import qualified Codec.Archive.Tar.Index as TarIndex -- ----------------------------------------------------------------------------- module Codec.Archive.Tar.Index (@@ -28,6 +28,10 @@ -- @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.+ --+ -- An index cannot be used to lookup 'Directory' entries in a tar file;+ -- instead, you will get 'TarDir' entry listing all the entries in the+ -- directory. -- * Index type TarIndex,@@ -46,10 +50,11 @@ -- ** Incremental construction -- $incremental-construction IndexBuilder,- emptyIndex,+ empty, addNextEntry, skipNextEntry,- finaliseIndex,+ finalise,+ unfinalise, -- * Serialising indexes serialise,@@ -64,10 +69,16 @@ indexEndEntryOffset, indexNextEntryOffset, + -- * Deprecated aliases+ emptyIndex,+ finaliseIndex,+ #ifdef TESTS prop_lookup, prop_valid,- prop_index_matches_tar+ prop_serialise_deserialise,+ prop_index_matches_tar,+ prop_finalise_unfinalise, #endif ) where @@ -76,9 +87,9 @@ 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 Codec.Archive.Tar.Index.StringTable (StringTable, StringTableBuilder) import qualified Codec.Archive.Tar.Index.IntTrie as IntTrie-import Codec.Archive.Tar.Index.IntTrie (IntTrie(..))+import Codec.Archive.Tar.Index.IntTrie (IntTrie, IntTrieBuilder) import qualified System.FilePath.Posix as FilePath import Data.Monoid (Monoid(..))@@ -91,25 +102,28 @@ import qualified Data.Array.Unboxed as A import Prelude hiding (lookup) import System.IO-import Control.Exception (throwIO)+import Control.Exception (assert, throwIO)+import Control.DeepSeq -import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS.Char8+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Unsafe as BS #if MIN_VERSION_bytestring(0,10,2)-import Data.ByteString.Builder as BS+import Data.ByteString.Builder as BS #else-import Data.ByteString.Lazy.Builder as BS+import Data.ByteString.Lazy.Builder as BS #endif #ifdef TESTS import qualified Prelude-import Test.QuickCheck hiding (Result)-import Test.QuickCheck.Property (Result, exception, succeeded)+import Test.QuickCheck+import Test.QuickCheck.Property (ioProperty) import Control.Applicative ((<$>), (<*>)) import Control.Monad (unless)-import Data.List (nub, sort, stripPrefix, isPrefixOf)+import Data.List (nub, sort, sortBy, stripPrefix, isPrefixOf) import Data.Maybe-import System.IO.Unsafe (unsafePerformIO)+import Data.Function (on) import Control.Exception (SomeException, try) import Codec.Archive.Tar.Write as Tar import qualified Data.ByteString.Handle as HBS@@ -150,6 +164,8 @@ deriving (Eq, Show, Typeable) +instance NFData TarIndex -- fully strict by construction+ -- | 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@@ -197,8 +213,9 @@ toComponentIds :: StringTable PathComponentId -> FilePath -> Maybe [PathComponentId] toComponentIds table = lookupComponents []- . filter (/= ".")- . FilePath.splitDirectories+ . filter (/= BS.Char8.singleton '.')+ . splitDirectories+ . BS.Char8.pack where lookupComponents cs' [] = Just (reverse cs') lookupComponents cs' (c:cs) = case StringTable.lookup table c of@@ -206,17 +223,17 @@ Just cid -> lookupComponents (cid:cs') cs fromComponentId :: StringTable PathComponentId -> PathComponentId -> FilePath-fromComponentId table = StringTable.index table+fromComponentId table = BS.Char8.unpack . 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+build = go empty where go !builder (Next e es) = go (addNextEntry e builder) es- go !builder Done = Right $! finaliseIndex builder+ go !builder Done = Right $! finalise builder go !_ (Fail err) = Left err @@ -224,67 +241,78 @@ -- 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+-- Start with 'empty' 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'.+-- 'TarEntryOffset's. At the end use 'finalise' to get the 'TarIndex'. -- -- For example, 'build' is simply: ----- > build = go emptyIndex+-- > build = go empty -- > where -- > go !builder (Next e es) = go (addNextEntry e builder) es--- > go !builder Done = Right $! finaliseIndex builder+-- > go !builder Done = Right $! finalise builder -- > go !_ (Fail err) = Left err -- | The intermediate type used for incremental construction of a 'TarIndex'. ---data IndexBuilder = IndexBuilder [(FilePath, TarEntryOffset)]- {-# UNPACK #-} !TarEntryOffset+data IndexBuilder+ = IndexBuilder !(StringTableBuilder PathComponentId)+ !(IntTrieBuilder PathComponentId TarEntryOffset)+ {-# UNPACK #-} !TarEntryOffset+ deriving (Eq, Show) +instance NFData IndexBuilder -- fully strict by construction+ -- | The initial empty 'IndexBuilder'. --+empty :: IndexBuilder+empty = IndexBuilder StringTable.empty IntTrie.empty 0+ emptyIndex :: IndexBuilder-emptyIndex = IndexBuilder [] 0+emptyIndex = empty+{-# DEPRECATED emptyIndex "Use TarIndex.empty" #-} -- | Add the next 'Entry' into the 'IndexBuilder'. -- addNextEntry :: Entry -> IndexBuilder -> IndexBuilder-addNextEntry entry (IndexBuilder acc nextOffset) =- IndexBuilder ((entrypath, nextOffset):acc)+addNextEntry entry (IndexBuilder stbl itrie nextOffset) =+ IndexBuilder stbl' itrie' (nextEntryOffset entry nextOffset) where- !entrypath = entryPath entry+ !entrypath = splitTarPath (entryTarPath entry)+ (stbl', cids) = StringTable.inserts entrypath stbl+ itrie' = IntTrie.insert cids nextOffset itrie -- | 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)+skipNextEntry entry (IndexBuilder stbl itrie nextOffset) =+ IndexBuilder stbl itrie (nextEntryOffset entry nextOffset) -- | Finish accumulating 'Entry' information and build the compact 'TarIndex' -- lookup structure. ---finaliseIndex :: IndexBuilder -> TarIndex-finaliseIndex (IndexBuilder pathsOffsets finalOffset) =+finalise :: IndexBuilder -> TarIndex+finalise (IndexBuilder stbl itrie 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 ]+ pathTable = StringTable.finalise stbl+ pathTrie = IntTrie.finalise itrie +finaliseIndex :: IndexBuilder -> TarIndex+finaliseIndex = finalise+{-# DEPRECATED finaliseIndex "Use TarIndex.finalise" #-}+ -- | 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+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.@@ -308,13 +336,46 @@ OtherEntryType _ _ size -> blocks size _ -> 0 where- -- NOTE: The special case for 0 is important to avoid underflow,- -- because we are computing an unsigned TarEntryOffset (aka Word32) value- blocks 0 = 0- blocks size = 1 + ((fromIntegral size - 1) `div` 512)+ -- NOTE: to avoid underflow, do the (fromIntegral :: Int64 -> Word32) last+ blocks :: Int64 -> TarEntryOffset+ blocks size = fromIntegral (1 + (size - 1) `div` 512) +type FilePathBS = BS.ByteString +splitTarPath :: TarPath -> [FilePathBS]+splitTarPath (TarPath name prefix) =+ splitDirectories prefix ++ splitDirectories name++splitDirectories :: FilePathBS -> [FilePathBS]+splitDirectories bs =+ case BS.Char8.split '/' bs of+ c:cs | BS.null c -> BS.Char8.singleton '/' : filter (not . BS.null) cs+ cs -> filter (not . BS.null) cs++ -------------------------+-- Resume building an existing index+--++-- | Resume building an existing index+--+-- A 'TarIndex' is optimized for a highly compact and efficient in-memory+-- representation. This, however, makes it read-only. If you have an existing+-- 'TarIndex' for a large file, and want to add to it, you can translate the+-- 'TarIndex' back to an 'IndexBuilder'. Be aware that this is a relatively+-- costly operation (linear in the size of the 'TarIndex'), though still+-- faster than starting again from scratch.+--+-- This is the left inverse to 'finalise' (modulo ordering).+--+unfinalise :: TarIndex -> IndexBuilder+unfinalise (TarIndex pathTable pathTrie finalOffset) =+ IndexBuilder (StringTable.unfinalise pathTable)+ (IntTrie.unfinalise pathTrie)+ finalOffset+++------------------------- -- I/O operations -- @@ -462,83 +523,41 @@ -- serialise :: TarIndex -> BS.Builder serialise (TarIndex stringTable intTrie finalOffset) =- BS.word32BE 1 -- format version+ BS.word32BE 2 -- format version <> BS.word32BE finalOffset- <> serialiseStringTable stringTable- <> serialiseIntTrie intTrie+ <> StringTable.serialise stringTable+ <> IntTrie.serialise 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+ | BS.length bs < 8+ = Nothing++ | let ver = readWord32BE bs 0 , ver == 1 = do let !finalOffset = readWord32BE bs 4- (stringTable, bs') <- deserialiseStringTable (BS.drop 8 bs)- (intTrie, bs'') <- deserialiseIntTrie bs'+ (stringTable, bs') <- StringTable.deserialiseV1 (BS.drop 8 bs)+ (intTrie, bs'') <- IntTrie.deserialise 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')+ | let ver = readWord32BE bs 0+ , ver == 2+ = do let !finalOffset = readWord32BE bs 4+ (stringTable, bs') <- StringTable.deserialiseV2 (BS.drop 8 bs)+ (intTrie, bs'') <- IntTrie.deserialise bs'+ return (TarIndex stringTable intTrie finalOffset, bs'') - | otherwise- = Nothing+ | 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))+ assert (i >= 0 && i+3 <= BS.length bs - 1) $+ fromIntegral (BS.unsafeIndex bs (i + 0)) `shiftL` 24+ + fromIntegral (BS.unsafeIndex bs (i + 1)) `shiftL` 16+ + fromIntegral (BS.unsafeIndex bs (i + 2)) `shiftL` 8+ + fromIntegral (BS.unsafeIndex bs (i + 3)) -------------------------@@ -553,13 +572,13 @@ prop_lookup :: ValidPaths -> NonEmptyFilePath -> Bool prop_lookup (ValidPaths paths) (NonEmptyFilePath p) = case (lookup index p, Prelude.lookup p paths) of- (Nothing, Nothing) -> True- (Just (TarFileEntry offset), Just offset') -> offset == offset'- (Just (TarDir entries), Nothing) -> sort (nub (map fst entries))- == sort (nub completions)- _ -> False+ (Nothing, Nothing) -> True+ (Just (TarFileEntry offset), Just (_,offset')) -> offset == offset'+ (Just (TarDir entries), Nothing) -> sort (nub (map fst entries))+ == sort (nub completions)+ _ -> False where- index = finaliseIndex (IndexBuilder paths 0)+ index = construct paths completions = [ head (FilePath.splitDirectories completion) | (path,_) <- paths , completion <- maybeToList $ stripPrefix (p ++ "/") path ]@@ -573,39 +592,61 @@ | otherwise = True where- index@(TarIndex pathTable _ _) = finaliseIndex (IndexBuilder paths 0)+ index@(TarIndex pathTable _ _) = construct paths - pathbits = concatMap (FilePath.splitDirectories . fst) paths+ pathbits = concatMap (map BS.Char8.pack . FilePath.splitDirectories . fst)+ paths intpaths = [ (cids, offset)- | (path, offset) <- paths+ | (path, (_size, offset)) <- paths , let Just cids = toComponentIds pathTable path ]- prop' = flip all paths $ \(file, offset) ->+ prop' = flip all paths $ \(file, (_size, offset)) -> case lookup index file of Just (TarFileEntry offset') -> offset' == offset _ -> False +prop_serialise_deserialise :: ValidPaths -> Bool+prop_serialise_deserialise (ValidPaths paths) =+ Just (index, BS.empty) == (deserialise+ . LBS.toStrict . BS.toLazyByteString+ . serialise) index+ where+ index = construct paths+ newtype NonEmptyFilePath = NonEmptyFilePath FilePath deriving Show instance Arbitrary NonEmptyFilePath where arbitrary = NonEmptyFilePath . FilePath.joinPath <$> listOf1 (elements ["a", "b", "c", "d"]) -newtype ValidPaths = ValidPaths [(FilePath, TarEntryOffset)] deriving Show+newtype ValidPaths = ValidPaths [(FilePath, (Int64, TarEntryOffset))] deriving Show instance Arbitrary ValidPaths where- arbitrary =- ValidPaths . makeNoPrefix <$> listOf ((,) <$> arbitraryPath <*> arbitrary)+ arbitrary = do+ paths <- makeNoPrefix <$> listOf arbitraryPath+ sizes <- vectorOf (length paths) (getNonNegative <$> arbitrary)+ let offsets = scanl (\o sz -> o + 1 + blocks sz) 0 sizes+ return (ValidPaths (zip paths (zip sizes offsets))) where arbitraryPath = FilePath.joinPath <$> listOf1 (elements ["a", "b", "c", "d"]) makeNoPrefix [] = []- makeNoPrefix ((k,v):kvs)- | all (\(k', _) -> not (isPrefixOfOther k k')) kvs- = (k,v) : makeNoPrefix kvs- | otherwise = makeNoPrefix kvs+ makeNoPrefix (k:ks)+ | all (not . isPrefixOfOther k) ks+ = k : makeNoPrefix ks+ | otherwise = makeNoPrefix ks isPrefixOfOther a b = a `isPrefixOf` b || b `isPrefixOf` a + blocks :: Int64 -> TarEntryOffset+ blocks size = fromIntegral (1 + ((size - 1) `div` 512))++-- Helper for bulk construction.+construct :: [(FilePath, (Int64, TarEntryOffset))] -> TarIndex+construct =+ either (\_ -> undefined) id+ . build+ . foldr (\(path, (size, _off)) es -> Next (testEntry path size) es) Done+ example0 :: Entries () example0 = testEntry "foo-1.0/foo-1.0.cabal" 1500 -- at block 0@@ -632,11 +673,10 @@ instance Show SimpleTarArchive where show = show . simpleTarRaw -prop_index_matches_tar :: SimpleTarArchive -> Result+prop_index_matches_tar :: SimpleTarArchive -> Property prop_index_matches_tar sta =- case unsafePerformIO (try go) of- Left ex -> exception "" ex- Right () -> succeeded+ ioProperty (try go >>= either (\e -> throwIO (e :: SomeException))+ (\_ -> return True)) where go :: IO () go = do@@ -701,6 +741,25 @@ , 510 , 511 , 512 , 513 , 514 , 1022 , 1023 , 1024 , 1025 , 1026 ]++-- | 'IndexBuilder' constructed from a 'SimpleIndex'+newtype SimpleIndexBuilder = SimpleIndexBuilder IndexBuilder+ deriving Show++instance Arbitrary SimpleIndexBuilder where+ arbitrary = SimpleIndexBuilder . build' . simpleTarEntries <$> arbitrary+ where+ -- like 'build', but don't finalize+ build' :: Show e => Entries e -> IndexBuilder+ build' = go empty+ where+ go !builder (Next e es) = go (addNextEntry e builder) es+ go !builder Done = builder+ go !_ (Fail err) = error (show err)++prop_finalise_unfinalise :: SimpleIndexBuilder -> Bool+prop_finalise_unfinalise (SimpleIndexBuilder index) =+ unfinalise (finalise index) == index #endif #if !(MIN_VERSION_base(4,5,0))
Codec/Archive/Tar/Index/IntTrie.hs view
@@ -1,14 +1,24 @@-{-# LANGUAGE CPP, BangPatterns #-}+{-# LANGUAGE CPP, BangPatterns, PatternGuards #-} {-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} module Codec.Archive.Tar.Index.IntTrie ( - IntTrie(..),+ IntTrie, construct,+ toList, + IntTrieBuilder,+ empty,+ insert,+ finalise,+ unfinalise,+ lookup, TrieLookup(..), + serialise,+ deserialise,+ #ifdef TESTS test1, test2, test3, ValidPaths(..),@@ -16,6 +26,9 @@ prop_completions, prop_lookup_mono, prop_completions_mono,+ prop_construct_toList,+ prop_finalise_unfinalise,+ prop_serialise_deserialise, #endif ) where @@ -27,8 +40,31 @@ import Data.Array.IArray ((!)) import qualified Data.Bits as Bits import Data.Word (Word32)+import Data.Bits+import Data.Monoid (Monoid(..))+#if (MIN_VERSION_base(4,5,0))+import Data.Monoid ((<>))+#endif+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Unsafe as BS+#if MIN_VERSION_bytestring(0,10,2)+import Data.ByteString.Builder as BS+#else+import Data.ByteString.Lazy.Builder as BS+#endif+import Control.Exception (assert)+#if MIN_VERSION_containers(0,5,0)+import qualified Data.Map.Strict as Map+import qualified Data.IntMap.Strict as IntMap+import Data.IntMap.Strict (IntMap)+#else+import qualified Data.Map as Map+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)+#endif -import Data.List hiding (lookup)+import Data.List hiding (lookup, insert) import Data.Function (on) #ifdef TESTS@@ -37,8 +73,11 @@ #endif --- | A compact mapping from sequences of small nats to nats.+-- | A compact mapping from sequences of nats to nats. --+-- NOTE: The tries in this module have values /only/ at the leaves (which+-- correspond to files), they do not have values at the branch points (which+-- correspond to directories). newtype IntTrie k v = IntTrie (A.UArray Word32 Word32) deriving (Eq, Show, Typeable) @@ -57,7 +96,7 @@ -- After converting path components to integers this becomes: ---example1 :: Paths Word32 Word32+example1 :: [([Word32], Word32)] example1 = [([1,2], 512) ,([1,3], 2048)@@ -73,20 +112,28 @@ -- We use an intermediate trie representation -example2 :: Trie Word32 Word32-example2 = Trie [ Node 1 t1 ]+mktrie :: [(Int, TrieNode k v)] -> IntTrieBuilder k v+mkleaf :: (Enum k, Enum v) => k -> v -> (Int, TrieNode k v)+mknode :: Enum k => k -> IntTrieBuilder k v -> (Int, TrieNode k v)++mktrie = IntTrieBuilder . IntMap.fromList+mkleaf k v = (fromEnum k, TrieLeaf (enumToWord32 v))+mknode k t = (fromEnum k, TrieNode t) ++example2 :: IntTrieBuilder Word32 Word32+example2 = mktrie [ mknode 1 t1 ] where- t1 = Trie [ Leaf 2 512, Leaf 3 2048, Node 4 t2 ]- t2 = Trie [ Leaf 5 4096 ]+ t1 = mktrie [ mkleaf 2 512, mkleaf 3 2048, mknode 4 t2 ]+ t2 = mktrie [ mkleaf 5 4096 ] -example2' :: Trie Word32 Word32-example2' = Trie [ Node 0 t1 ]+example2' :: IntTrieBuilder Word32 Word32+example2' = mktrie [ mknode 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 ]+ t1 = mktrie [ mknode 3 t2 ]+ t2 = mktrie [ mknode 1 t3, mknode 2 t4 ]+ t3 = mktrie [ mkleaf 4 10608 ]+ t4 = mktrie [ mkleaf 4 10612 ] {- 0: [1,N0,3] @@ -98,21 +145,21 @@ 14: [1,4,10612] -} -example2'' :: Trie Word32 Word32-example2'' = Trie [ Node 1 t1, Node 2 t2 ]+example2'' :: IntTrieBuilder Word32 Word32+example2'' = mktrie [ mknode 1 t1, mknode 2 t2 ] where- t1 = Trie [ Leaf 4 10608 ]- t2 = Trie [ Leaf 4 10612 ]+ t1 = mktrie [ mkleaf 4 10608 ]+ t2 = mktrie [ mkleaf 4 10612 ] -example2''' :: Trie Word32 Word32-example2''' = Trie [ Node 0 t3 ]+example2''' :: IntTrieBuilder Word32 Word32+example2''' = mktrie [ mknode 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 ]+ t3 = mktrie [ mknode 4 t8, mknode 6 t11 ]+ t8 = mktrie [ mknode 1 t14 ]+ t11 = mktrie [ mkleaf 5 10605 ]+ t14 = mktrie [ mknode 2 t19, mknode 3 t22 ]+ t19 = mktrie [ mkleaf 7 10608 ]+ t22 = mktrie [ mkleaf 7 10612 ] {- 0: [1,N0,3] 3: [2,N4,N6,8,11]@@ -123,9 +170,9 @@ 22: [1,7,10612] -} --- We convert from the 'Paths' to the 'Trie' using 'mkTrie':+-- We convert from the 'Paths' to the 'IntTrieBuilder' using 'inserts': ---test1 = example2 == mkTrie example1+test1 = example2 == inserts example1 empty #endif -- Each node has a size and a sequence of keys followed by an equal length@@ -168,6 +215,9 @@ example4 :: IntTrie Int Int example4 = IntTrie (mkArray example3) +mkArray :: [Word32] -> A.UArray Word32 Word32+mkArray xs = A.listArray (0, fromIntegral (length xs) - 1) xs+ test3 = case lookup example4 [1] of Just (Completions [(2,_),(3,_),(4,_)]) -> True _ -> False@@ -193,6 +243,16 @@ keysStart = nodeOff + 1 keysEnd = nodeOff + nodeSize +-- | Convert the trie to a list+--+-- This is the left inverse to 'construct' (modulo ordering).+toList :: forall k v. (Enum k, Enum v) => IntTrie k v -> [([k], v)]+toList = concatMap (aux []) . (`completionsFrom` 0)+ where+ aux :: [k] -> (k, TrieLookup k v) -> [([k], v)]+ aux ks (k, Entry v) = [(reverse (k:ks), v)]+ aux ks (k, Completions cs) = concatMap (aux (k:ks)) cs+ ------------------------------------- -- Toplevel trie array construction --@@ -203,11 +263,8 @@ -- | 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+construct :: (Enum k, Enum v) => [([k], v)] -> IntTrie k v+construct = finalise . flip inserts empty ---------------------------------@@ -260,113 +317,175 @@ ---------------------------- Intermediate Trie type+-- Building Tries -- --- 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]+newtype IntTrieBuilder k v = IntTrieBuilder (IntMap (TrieNode k v))+ deriving (Show, Eq) --- Trie is the fixpoint of the 'TrieF' functor-newtype Trie k v = Trie (TrieF k v (Trie k v)) deriving (Eq, Show)+data TrieNode k v = TrieLeaf {-# UNPACK #-} !Word32+ | TrieNode !(IntTrieBuilder k v)+ deriving (Show, Eq) +empty :: IntTrieBuilder k v+empty = IntTrieBuilder IntMap.empty -unfoldTrieNode :: (s -> TrieNodeF k v [s]) -> s -> TrieNodeF k v (Trie k v)-unfoldTrieNode f = fmap (unfoldTrie f) . f+insert :: (Enum k, Enum v) => [k] -> v+ -> IntTrieBuilder k v -> IntTrieBuilder k v+insert [] _v t = t+insert (k:ks) v t = insertTrie (fromEnum k) (map fromEnum ks) (enumToWord32 v) t -unfoldTrie :: (s -> TrieNodeF k v [s]) -> [s] -> Trie k v-unfoldTrie f = Trie . map (unfoldTrieNode f)+insertTrie :: Int -> [Int] -> Word32+ -> IntTrieBuilder k v -> IntTrieBuilder k v+insertTrie k ks v (IntTrieBuilder t) =+ IntTrieBuilder $+ IntMap.alter (\t' -> Just $! maybe (freshTrieNode ks v)+ (insertTrieNode ks v) t')+ k t -{--trieSize :: Trie k v -> Int-trieSize (Trie ts) = 1 + sum (map trieNodeSize ts)+insertTrieNode :: [Int] -> Word32 -> TrieNode k v -> TrieNode k v+insertTrieNode [] v _ = TrieLeaf v+insertTrieNode (k:ks) v (TrieLeaf _) = TrieNode (freshTrie k ks v)+insertTrieNode (k:ks) v (TrieNode t) = TrieNode (insertTrie k ks v t) -trieNodeSize :: TrieNodeF k v (Trie k v) -> Int-trieNodeSize (Leaf _ _) = 2-trieNodeSize (Node _ t) = 2 + trieSize t--}+freshTrie :: Int -> [Int] -> Word32 -> IntTrieBuilder k v+freshTrie k [] v =+ IntTrieBuilder (IntMap.singleton k (TrieLeaf v))+freshTrie k (k':ks) v =+ IntTrieBuilder (IntMap.singleton k (TrieNode (freshTrie k' ks v))) ------------------------------------- Building and flattening Tries---+freshTrieNode :: [Int] -> Word32 -> TrieNode k v+freshTrieNode [] v = TrieLeaf v+freshTrieNode (k:ks) v = TrieNode (freshTrie k ks v) --- | A list of key value pairs. The keys must be distinct and non-empty.-type Paths k v = [([k], v)]+inserts :: (Enum k, Enum v) => [([k], v)]+ -> IntTrieBuilder k v -> IntTrieBuilder k v+inserts kvs t = foldl' (\t' (ks, v) -> insert ks v t') t kvs +finalise :: (Enum k, Enum v) => IntTrieBuilder k v -> IntTrie k v+finalise trie =+ IntTrie $+ A.listArray (0, fromIntegral (flatTrieLength trie) - 1)+ (flattenTrie trie) -mkTrie :: Ord k => Paths k v -> Trie k v-mkTrie = unfoldTrie (fmap split) . split- . sortBy (compare `on` fst)- . filter (not . null . fst)+unfinalise :: (Enum k, Enum v) => IntTrie k v -> IntTrieBuilder k v+unfinalise trie =+ go (completionsFrom trie 0) 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'+ go kns =+ IntTrieBuilder $+ IntMap.fromList+ [ (fromEnum k, t)+ | (k, n) <- kns+ , let t = case n of+ Entry v -> TrieLeaf (enumToWord32 v)+ Completions kns' -> TrieNode (go kns')+ ] +---------------------------------+-- Flattening Tries+--+ type Offset = Int +flatTrieLength :: IntTrieBuilder k v -> Int+flatTrieLength (IntTrieBuilder tns) =+ 1+ + 2 * IntMap.size tns+ + sum [ flatTrieLength n | TrieNode n <- IntMap.elems tns ]+ -- 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 :: IntTrieBuilder k v -> [Word32] flattenTrie trie = go (queue [trie]) (size trie) where- size (Trie tns) = 1 + 2 * length tns+ size (IntTrieBuilder tns) = 1 + 2 * IntMap.size tns - go :: (Enum k, Enum v) => Q (Trie k v) -> Offset -> [Word32]+ go :: Q (IntTrieBuilder k v) -> Offset -> [Word32] go todo !offset = case dequeue todo of Nothing -> []- Just (Trie tnodes, tries) ->- flat ++ go (tries `enqueue` tries') offset'+ Just (IntTrieBuilder tnodes, tries) ->+ flat ++ go 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+ !count = IntMap.size tnodes+ flat = fromIntegral count+ : Map.keys keysValues+ ++ Map.elems keysValues+ (!offset', !keysValues, !tries') =+ IntMap.foldlWithKey' accumNodes+ (offset, Map.empty, tries)+ 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+ accumNodes :: (Offset, Map.Map Word32 Word32, Q (IntTrieBuilder k v))+ -> Int -> TrieNode k v+ -> (Offset, Map.Map Word32 Word32, Q (IntTrieBuilder k v))+ accumNodes (!off, !kvs, !tries) !k (TrieLeaf v) =+ (off, kvs', tries)+ where+ kvs' = Map.insert (tagLeaf (int2Word32 k)) v kvs - leafKV k v = (tagLeaf (enum2Word32 k), enum2Word32 v)- nodeKV k o = (tagNode (enum2Word32 k), int2Word32 o)+ accumNodes (!off, !kvs, !tries) !k (TrieNode t) =+ (off + size t, kvs', tries')+ where+ kvs' = Map.insert (tagNode (int2Word32 k)) (int2Word32 off) kvs+ tries' = enqueue tries t -data Q a = Q [a] [[a]]+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)+enqueue :: Q a -> a -> Q a+enqueue (Q front back) x = Q front (x : 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+dequeue (Q [] back) = case reverse back of x:xs -> Just (x, Q xs []) [] -> Nothing int2Word32 :: Int -> Word32 int2Word32 = fromIntegral -enum2Word32 :: Enum n => n -> Word32-enum2Word32 = int2Word32 . fromEnum +-------------------------+-- (de)serialisation+-- +serialise :: IntTrie k v -> BS.Builder+serialise (IntTrie arr) =+ let (_, !ixEnd) = A.bounds arr in+ BS.word32BE (ixEnd+1)+ <> foldr (\n r -> BS.word32BE n <> r) mempty (A.elems arr)++deserialise :: BS.ByteString -> Maybe (IntTrie k v, BS.ByteString)+deserialise 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++readWord32BE :: BS.ByteString -> Int -> Word32+readWord32BE bs i =+ assert (i >= 0 && i+3 <= BS.length bs - 1) $+ fromIntegral (BS.unsafeIndex bs (i + 0)) `shiftL` 24+ + fromIntegral (BS.unsafeIndex bs (i + 1)) `shiftL` 16+ + fromIntegral (BS.unsafeIndex bs (i + 2)) `shiftL` 8+ + fromIntegral (BS.unsafeIndex bs (i + 3))++ ------------------------- -- Correctness property --@@ -388,14 +507,17 @@ 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)+ inserts paths empty + == convertCompletions (completionsFrom (construct paths) 0) where- convertCompletions :: Ord k => Completions k v -> Trie k v+ convertCompletions :: Ord k => Completions k v -> IntTrieBuilder 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 ]+ IntTrieBuilder $+ IntMap.fromList+ [ case l of+ Entry v -> mkleaf k v+ Completions kls' -> mknode k (convertCompletions kls')+ | (k, l) <- sortBy (compare `on` fst) kls ] prop_lookup_mono :: ValidPaths -> Bool@@ -404,9 +526,29 @@ prop_completions_mono :: ValidPaths -> Bool prop_completions_mono (ValidPaths paths) = prop_completions paths +prop_construct_toList :: ValidPaths -> Bool+prop_construct_toList (ValidPaths paths) =+ sortBy (compare `on` fst) (toList (construct paths))+ == sortBy (compare `on` fst) paths -newtype ValidPaths = ValidPaths (Paths Char Char) deriving Show+prop_finalise_unfinalise :: ValidPaths -> Bool+prop_finalise_unfinalise (ValidPaths paths) =+ builder == unfinalise (finalise builder)+ where+ builder :: IntTrieBuilder Char Char+ builder = inserts paths empty +prop_serialise_deserialise :: ValidPaths -> Bool+prop_serialise_deserialise (ValidPaths paths) =+ Just (trie, BS.empty) == (deserialise+ . LBS.toStrict . BS.toLazyByteString+ . serialise) trie+ where+ trie :: IntTrie Char Char+ trie = construct paths++newtype ValidPaths = ValidPaths [([Char], Char)] deriving Show+ instance Arbitrary ValidPaths where arbitrary = ValidPaths . makeNoPrefix <$> listOf ((,) <$> listOf1 arbitrary <*> arbitrary)@@ -428,3 +570,9 @@ isPrefixOfOther a b = a `isPrefixOf` b || b `isPrefixOf` a #endif++#if !(MIN_VERSION_base(4,5,0))+(<>) :: Monoid m => m -> m -> m+(<>) = mappend+#endif+
Codec/Archive/Tar/Index/StringTable.hs view
@@ -1,82 +1,247 @@-{-# LANGUAGE CPP, BangPatterns, DeriveDataTypeable #-}+{-# LANGUAGE CPP, BangPatterns, PatternGuards, DeriveDataTypeable #-} module Codec.Archive.Tar.Index.StringTable ( - StringTable(..),+ StringTable, lookup, index, construct, + StringTableBuilder,+ empty,+ insert,+ inserts,+ finalise,+ unfinalise,++ serialise,+ deserialiseV1,+ deserialiseV2,+ #ifdef TESTS prop_valid,+ prop_sorted,+ prop_finalise_unfinalise,+ prop_serialise_deserialise, #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 Prelude hiding (lookup, id)+import Data.List hiding (lookup, insert)+import Data.Function (on) import Data.Word (Word32)+import Data.Int (Int32)+import Data.Bits+import Data.Monoid (Monoid(..))+#if (MIN_VERSION_base(4,5,0))+import Data.Monoid ((<>))+#endif+import Control.Exception (assert) +import qualified Data.Array.Unboxed as A+import Data.Array.Unboxed ((!))+#if MIN_VERSION_containers(0,5,0)+import qualified Data.Map.Strict as Map+import Data.Map.Strict (Map)+#else+import qualified Data.Map as Map+import Data.Map (Map)+#endif+import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe 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 + -- | 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)+ {-# UNPACK #-} !BS.ByteString -- all strings concatenated+ {-# UNPACK #-} !(A.UArray Int32 Word32) -- string offset table+ {-# UNPACK #-} !(A.UArray Int32 Int32) -- string index to id table+ {-# UNPACK #-} !(A.UArray Int32 Int32) -- string id to index table+ deriving (Show, Typeable) +instance (Eq id, Enum id) => Eq (StringTable id) where+ tbl1 == tbl2 = unfinalise tbl1 == unfinalise tbl2+ -- | 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)+lookup :: Enum id => StringTable id -> BS.ByteString -> Maybe id+lookup (StringTable bs offsets ids _ixs) str =+ binarySearch 0 (topBound-1) str where- (0, topBound) = A.bounds tbl+ (0, topBound) = A.bounds offsets binarySearch !a !b !key | a > b = Nothing- | otherwise = case compare key (index' bs tbl mid) of+ | otherwise = case compare key (index' bs offsets mid) of LT -> binarySearch a (mid-1) key- EQ -> Just (toEnum mid)+ EQ -> Just $! toEnum (fromIntegral (ids ! 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+index' :: BS.ByteString -> A.UArray Int32 Word32 -> Int32 -> BS.ByteString+index' bs offsets i = BS.unsafeTake len . BS.unsafeDrop start $ bs where start, end, len :: Int- start = fromIntegral (tbl ! i)- end = fromIntegral (tbl ! (i+1))+ start = fromIntegral (offsets ! i)+ end = fromIntegral (offsets ! (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+index :: Enum id => StringTable id -> id -> BS.ByteString+index (StringTable bs offsets _ids ixs) =+ index' bs offsets . (ixs !) . fromIntegral . fromEnum -- | Given a list of strings, construct a 'StringTable' mapping those strings--- to a dense set of integers.+-- to a dense set of integers. Also return the ids for all the strings used+-- in the construction. ---construct :: Enum id => [String] -> StringTable id-construct strs = StringTable bs tbl+construct :: Enum id => [BS.ByteString] -> StringTable id+construct = finalise . foldl' (\tbl s -> fst (insert s tbl)) empty+++data StringTableBuilder id = StringTableBuilder+ !(Map BS.ByteString id)+ {-# UNPACK #-} !Word32+ deriving (Eq, Show, Typeable)++empty :: StringTableBuilder id+empty = StringTableBuilder Map.empty 0++insert :: Enum id => BS.ByteString -> StringTableBuilder id -> (StringTableBuilder id, id)+insert str builder@(StringTableBuilder smap nextid) =+ case Map.lookup str smap of+ Just id -> (builder, id)+ Nothing -> let !id = toEnum (fromIntegral nextid)+ !smap' = Map.insert str id smap+ in (StringTableBuilder smap' (nextid+1), id)++inserts :: Enum id => [BS.ByteString] -> StringTableBuilder id -> (StringTableBuilder id, [id])+inserts bss builder = mapAccumL (flip insert) builder bss++finalise :: Enum id => StringTableBuilder id -> StringTable id+finalise (StringTableBuilder smap _) =+ (StringTable strs offsets ids ixs) 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+ strs = BS.concat (Map.keys smap)+ offsets = A.listArray (0, fromIntegral (Map.size smap))+ . scanl (\off str -> off + fromIntegral (BS.length str)) 0+ $ Map.keys smap+ ids = A.listArray (0, fromIntegral (Map.size smap) - 1)+ . map (fromIntegral . fromEnum)+ $ Map.elems smap+ ixs = A.array (A.bounds ids) [ (id,ix) | (ix,id) <- A.assocs ids ] +unfinalise :: Enum id => StringTable id -> StringTableBuilder id+unfinalise (StringTable strs offsets ids _) =+ StringTableBuilder smap nextid+ where+ smap = Map.fromAscList+ [ (index' strs offsets ix, toEnum (fromIntegral (ids ! ix)))+ | ix <- [0..h] ]+ (0,h) = A.bounds ids+ nextid = fromIntegral (h+1) ++-------------------------+-- (de)serialisation+--++serialise :: StringTable id -> BS.Builder+serialise (StringTable strs offs ids ixs) =+ let (_, !ixEnd) = A.bounds offs 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 offs)+ <> foldr (\n r -> BS.int32BE n <> r) mempty (A.elems ids)+ <> foldr (\n r -> BS.int32BE n <> r) mempty (A.elems ixs)++deserialiseV1 :: BS.ByteString -> Maybe (StringTable id, BS.ByteString)+deserialiseV1 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, fromIntegral lenArr - 1)+ [ (i, readWord32BE bs off)+ | (i, off) <- zip [0 .. fromIntegral lenArr - 1]+ [offArrS,offArrS+4 .. offArrE]+ ]+ ids = A.array (0, fromIntegral lenArr - 1)+ [ (i,i) | i <- [0 .. fromIntegral lenArr - 1] ]+ ixs = ids -- two identity mappings+ offArrS = 8 + lenStrs+ offArrE = offArrS + 4 * lenArr - 1+ !stringTable = StringTable strs arr ids ixs+ !bs' = BS.drop lenTotal bs+ = Just (stringTable, bs')++ | otherwise+ = Nothing++deserialiseV2 :: BS.ByteString -> Maybe (StringTable id, BS.ByteString)+deserialiseV2 bs+ | BS.length bs >= 8+ , let lenStrs = fromIntegral (readWord32BE bs 0)+ lenArr = fromIntegral (readWord32BE bs 4)+ lenTotal= 8 -- the two length prefixes+ + lenStrs+ + 4 * lenArr+ +(4 * (lenArr - 1)) * 2 -- offsets array is 1 longer+ , BS.length bs >= lenTotal+ , let strs = BS.take lenStrs (BS.drop 8 bs)+ offs = A.listArray (0, fromIntegral lenArr - 1)+ [ readWord32BE bs off+ | off <- offsets offsOff ]+ -- the second two arrays are 1 shorter+ ids = A.listArray (0, fromIntegral lenArr - 2)+ [ readInt32BE bs off+ | off <- offsets idsOff ]+ ixs = A.listArray (0, fromIntegral lenArr - 2)+ [ readInt32BE bs off+ | off <- offsets ixsOff ]+ offsOff = 8 + lenStrs+ idsOff = offsOff + 4 * lenArr+ ixsOff = idsOff + 4 * (lenArr-1)+ offsets from = [from,from+4 .. from + 4 * (lenArr - 1)]+ !stringTable = StringTable strs offs ids ixs+ !bs' = BS.drop lenTotal bs+ = Just (stringTable, bs')++ | otherwise+ = Nothing++readInt32BE :: BS.ByteString -> Int -> Int32+readInt32BE bs i = fromIntegral (readWord32BE bs i)++readWord32BE :: BS.ByteString -> Int -> Word32+readWord32BE bs i =+ assert (i >= 0 && i+3 <= BS.length bs - 1) $+ fromIntegral (BS.unsafeIndex bs (i + 0)) `shiftL` 24+ + fromIntegral (BS.unsafeIndex bs (i + 1)) `shiftL` 16+ + fromIntegral (BS.unsafeIndex bs (i + 2)) `shiftL` 8+ + fromIntegral (BS.unsafeIndex bs (i + 3))+ #ifdef TESTS -prop_valid :: [String] -> Bool+prop_valid :: [BS.ByteString] -> Bool prop_valid strs = all lookupIndex (enumStrings tbl) && all indexLookup (enumIds tbl)@@ -91,12 +256,43 @@ 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+-- this is important so we can use Map.fromAscList+prop_sorted :: [BS.ByteString] -> Bool+prop_sorted strings =+ isSorted [ index' strs offsets ix+ | ix <- A.range (A.bounds ids) ]+ where+ _tbl :: StringTable Int+ _tbl@(StringTable strs offsets ids _ixs) = construct strings+ isSorted xs = and (zipWith (<) xs (tail xs)) +prop_finalise_unfinalise :: [BS.ByteString] -> Bool+prop_finalise_unfinalise strs =+ builder == unfinalise (finalise builder)+ where+ builder :: StringTableBuilder Int+ builder = foldl' (\tbl s -> fst (insert s tbl)) empty strs++prop_serialise_deserialise :: [BS.ByteString] -> Bool+prop_serialise_deserialise strs =+ Just (strtable, BS.empty) == (deserialiseV2+ . LBS.toStrict . BS.toLazyByteString+ . serialise) strtable+ where+ strtable :: StringTable Int+ strtable = construct strs++enumStrings :: Enum id => StringTable id -> [BS.ByteString]+enumStrings (StringTable bs offsets _ _) = map (index' bs offsets) [0..h-1]+ where (0,h) = A.bounds offsets+ enumIds :: Enum id => StringTable id -> [id]-enumIds (StringTable _ tbl) = map toEnum [0..h-1]- where (0,h) = A.bounds tbl+enumIds (StringTable _ offsets _ _) = [toEnum 0 .. toEnum (fromIntegral (h-1))]+ where (0,h) = A.bounds offsets +#endif++#if !(MIN_VERSION_base(4,5,0))+(<>) :: Monoid m => m -> m -> m+(<>) = mappend #endif
Codec/Archive/Tar/Read.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP, DeriveDataTypeable, BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Codec.Archive.Tar.Read@@ -18,15 +18,17 @@ import Data.Char (ord) import Data.Int (Int64)-import Numeric (readOct)+import Data.Bits (Bits(shiftL)) import Control.Exception (Exception) import Data.Typeable (Typeable) import Control.Applicative import Control.Monad+import Control.DeepSeq -import qualified Data.ByteString.Lazy as BS-import qualified Data.ByteString.Lazy.Char8 as BS.Char8-import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS.Char8+import qualified Data.ByteString.Unsafe as BS+import qualified Data.ByteString.Lazy as LBS import Prelude hiding (read) @@ -41,8 +43,21 @@ | NotTarFormat | UnrecognisedTarFormat | HeaderBadNumericEncoding- deriving (Typeable)+#if MIN_VERSION_base(4,8,0)+ deriving (Eq, Show, Typeable) +instance Exception FormatError where+ displayException TruncatedArchive = "truncated tar archive"+ displayException ShortTrailer = "short tar trailer"+ displayException BadTrailer = "bad tar trailer"+ displayException TrailingJunk = "tar file has trailing junk"+ displayException ChecksumIncorrect = "tar checksum error"+ displayException NotTarFormat = "data is not in tar format"+ displayException UnrecognisedTarFormat = "tar entry not in a recognised format"+ displayException HeaderBadNumericEncoding = "tar header is malformed (bad numeric encoding)"+#else+ deriving (Eq, Typeable)+ instance Show FormatError where show TruncatedArchive = "truncated tar archive" show ShortTrailer = "short tar trailer"@@ -54,30 +69,33 @@ show HeaderBadNumericEncoding = "tar header is malformed (bad numeric encoding)" instance Exception FormatError+#endif +instance NFData FormatError + -- | Convert a data stream in the tar file format into an internal data -- structure. Decoding errors are reported by the 'Fail' constructor of the -- 'Entries' type. -- -- * The conversion is done lazily. ---read :: ByteString -> Entries FormatError+read :: LBS.ByteString -> Entries FormatError read = unfoldEntries getEntry -getEntry :: ByteString -> Either FormatError (Maybe (Entry, ByteString))+getEntry :: LBS.ByteString -> Either FormatError (Maybe (Entry, LBS.ByteString)) getEntry bs | BS.length header < 512 = Left TruncatedArchive -- Tar files end with at least two blocks of all '0'. Checking this serves -- two purposes. It checks the format but also forces the tail of the data -- which is necessary to close the file if it came from a lazily read file.- | BS.head bs == 0 = case BS.splitAt 1024 bs of+ | LBS.head bs == 0 = case LBS.splitAt 1024 bs of (end, trailing)- | BS.length end /= 1024 -> Left ShortTrailer- | not (BS.all (== 0) end) -> Left BadTrailer- | not (BS.all (== 0) trailing) -> Left TrailingJunk- | otherwise -> Right Nothing+ | LBS.length end /= 1024 -> Left ShortTrailer+ | not (LBS.all (== 0) end) -> Left BadTrailer+ | not (LBS.all (== 0) trailing) -> Left TrailingJunk+ | otherwise -> Right Nothing | otherwise = partial $ do @@ -92,9 +110,9 @@ size <- size_; mtime <- mtime_; devmajor <- devmajor_; devminor <- devminor_; - let content = BS.take size (BS.drop 512 bs)+ let content = LBS.take size (LBS.drop 512 bs) padding = (512 - size) `mod` 512- bs' = BS.drop (512 + size + padding) bs+ bs' = LBS.drop (512 + size + padding) bs entry = Entry { entryTarPath = TarPath name prefix,@@ -103,6 +121,8 @@ '0' -> NormalFile content size '1' -> HardLink (LinkTarget linkname) '2' -> SymbolicLink (LinkTarget linkname)+ _ | format == V7Format+ -> OtherEntryType typecode content size '3' -> CharacterDevice devmajor devminor '4' -> BlockDevice devmajor devminor '5' -> Directory@@ -118,7 +138,7 @@ return (Just (entry, bs')) where- header = BS.take 512 bs+ header = LBS.toStrict (LBS.take 512 bs) name = getString 0 100 header mode_ = getOct 100 8 header@@ -137,33 +157,39 @@ prefix = getString 345 155 header -- trailing = getBytes 500 12 header - format_ = case magic of- "\0\0\0\0\0\0\0\0" -> return V7Format- "ustar\NUL00" -> return UstarFormat- "ustar \NUL" -> return GnuFormat- _ -> Error UnrecognisedTarFormat+ format_+ | magic == ustarMagic = return UstarFormat+ | magic == gnuMagic = return GnuFormat+ | magic == v7Magic = return V7Format+ | otherwise = Error UnrecognisedTarFormat -correctChecksum :: ByteString -> Int -> Bool+v7Magic, ustarMagic, gnuMagic :: BS.ByteString+v7Magic = BS.Char8.pack "\0\0\0\0\0\0\0\0"+ustarMagic = BS.Char8.pack "ustar\NUL00"+gnuMagic = BS.Char8.pack "ustar \NUL"++correctChecksum :: BS.ByteString -> Int -> Bool correctChecksum header checksum = checksum == checksum' where -- sum of all 512 bytes in the header block, -- treating each byte as an 8-bit unsigned value- checksum' = BS.Char8.foldl' (\x y -> x + ord y) 0 header'+ sumchars = BS.foldl' (\x y -> x + fromIntegral y) 0 -- treating the 8 bytes of chksum as blank characters.- header' = BS.concat [BS.take 148 header,- BS.Char8.replicate 8 ' ',- BS.drop 156 header]+ checksum' = sumchars (BS.take 148 header)+ + 256 -- 256 = sumchars (BS.Char8.replicate 8 ' ')+ + sumchars (BS.drop 156 header) -- * TAR format primitive input -getOct :: Integral a => Int64 -> Int64 -> ByteString -> Partial FormatError a+{-# SPECIALISE getOct :: Int -> Int -> BS.ByteString -> Partial FormatError Int #-}+{-# SPECIALISE getOct :: Int -> Int -> BS.ByteString -> Partial FormatError Int64 #-}+getOct :: (Integral a, Bits a) => Int -> Int -> BS.ByteString -> Partial FormatError a getOct off len = parseOct- . BS.Char8.unpack . BS.Char8.takeWhile (\c -> c /= '\NUL' && c /= ' ') . BS.Char8.dropWhile (== ' ') . getBytes off len where- parseOct "" = return 0+ parseOct s | BS.null s = return 0 -- As a star extension, octal fields can hold a base-256 value if the high -- bit of the initial character is set. The initial character can be: -- 0x80 ==> trailing characters hold a positive base-256 value@@ -175,27 +201,26 @@ -- extra bits in the first character, but I don't think it works and the -- docs I can find on star seem to suggest that these will always be 0, -- which is what I will assume.- parseOct ('\128':xs) = return (readBytes xs)- parseOct ('\255':xs) = return (negate (readBytes xs))+ parseOct s | BS.head s == 128 = return (readBytes (BS.tail s))+ | BS.head s == 255 = return (negate (readBytes (BS.tail s))) parseOct s = case readOct s of- [(x,[])] -> return x- _ -> Error HeaderBadNumericEncoding+ Just x -> return x+ Nothing -> Error HeaderBadNumericEncoding - readBytes = go 0- where go acc [] = acc- go acc (x:xs) = go (acc * 256 + fromIntegral (ord x)) xs+ readBytes :: (Integral a, Bits a) => BS.ByteString -> a+ readBytes = BS.foldl' (\acc x -> acc `shiftL` 8 + fromIntegral x) 0 -getBytes :: Int64 -> Int64 -> ByteString -> ByteString+getBytes :: Int -> Int -> BS.ByteString -> BS.ByteString getBytes off len = BS.take len . BS.drop off -getByte :: Int64 -> ByteString -> Char+getByte :: Int -> BS.ByteString -> Char getByte off bs = BS.Char8.index bs off -getChars :: Int64 -> Int64 -> ByteString -> String-getChars off len = BS.Char8.unpack . getBytes off len+getChars :: Int -> Int -> BS.ByteString -> BS.ByteString+getChars off len = getBytes off len -getString :: Int64 -> Int64 -> ByteString -> String-getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') . getBytes off len+getString :: Int -> Int -> BS.ByteString -> BS.ByteString+getString off len = BS.copy . BS.Char8.takeWhile (/='\0') . getBytes off len -- These days we'd just use Either, but in older versions of base there was no -- Monad instance for Either, it was in mtl with an anoying Error constraint.@@ -210,11 +235,29 @@ fmap = liftM instance Applicative (Partial e) where- pure = return+ pure = Ok (<*>) = ap instance Monad (Partial e) where- return = Ok+ return = pure Error m >>= _ = Error m Ok x >>= k = k x fail = error "fail @(Partial e)"++{-# SPECIALISE readOct :: BS.ByteString -> Maybe Int #-}+{-# SPECIALISE readOct :: BS.ByteString -> Maybe Int64 #-}+readOct :: Integral n => BS.ByteString -> Maybe n+readOct bs0 = case go 0 0 bs0 of+ -1 -> Nothing+ n -> Just n+ where+ go :: Integral n => Int -> n -> BS.ByteString -> n+ go !i !n !bs+ | BS.null bs = if i == 0 then -1 else n+ | otherwise =+ case BS.unsafeHead bs of+ w | w >= 0x30+ && w <= 0x39 -> go (i+1)+ (n * 8 + (fromIntegral w - 0x30))+ (BS.unsafeTail bs)+ | otherwise -> -1
Codec/Archive/Tar/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- -- | -- Module : Codec.Archive.Tar.Types@@ -53,12 +54,17 @@ foldEntries, unfoldEntries, +#ifdef TESTS+ limitToV7FormatCompat+#endif ) where import Data.Int (Int64) import Data.Monoid (Monoid(..))-import qualified Data.ByteString.Lazy as BS-import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS.Char8+import qualified Data.ByteString.Lazy as LBS+import Control.DeepSeq import qualified System.FilePath as FilePath.Native ( joinPath, splitDirectories, addTrailingPathSeparator )@@ -70,6 +76,12 @@ import System.Posix.Types ( FileMode ) +#ifdef TESTS+import Test.QuickCheck+import Control.Applicative ((<$>), pure, (<*>))+#endif++ type FileSize = Int64 -- | The number of seconds since the UNIX epoch type EpochTime = Int64@@ -84,24 +96,25 @@ -- | The path of the file or directory within the archive. This is in a -- tar-specific form. Use 'entryPath' to get a native 'FilePath'.- entryTarPath :: !TarPath,+ entryTarPath :: {-# UNPACK #-} !TarPath, -- | The real content of the entry. For 'NormalFile' this includes the -- file data. An entry usually contains a 'NormalFile' or a 'Directory'. entryContent :: !EntryContent, -- | File permissions (Unix style file mode).- entryPermissions :: !Permissions,+ entryPermissions :: {-# UNPACK #-} !Permissions, -- | The user and group to which this file belongs.- entryOwnership :: !Ownership,+ entryOwnership :: {-# UNPACK #-} !Ownership, -- | The time the file was last modified.- entryTime :: !EpochTime,+ entryTime :: {-# UNPACK #-} !EpochTime, -- | The tar format the archive is using. entryFormat :: !Format }+ deriving (Eq, Show) -- | Native 'FilePath' of the file or directory within the archive. --@@ -112,30 +125,33 @@ -- -- Portable archives should contain only 'NormalFile' and 'Directory'. ---data EntryContent = NormalFile ByteString !FileSize+data EntryContent = NormalFile LBS.ByteString {-# UNPACK #-} !FileSize | Directory | SymbolicLink !LinkTarget | HardLink !LinkTarget- | CharacterDevice !DevMajor !DevMinor- | BlockDevice !DevMajor !DevMinor+ | CharacterDevice {-# UNPACK #-} !DevMajor+ {-# UNPACK #-} !DevMinor+ | BlockDevice {-# UNPACK #-} !DevMajor+ {-# UNPACK #-} !DevMinor | NamedPipe- | OtherEntryType !TypeCode ByteString !FileSize- deriving (Eq, Ord)+ | OtherEntryType {-# UNPACK #-} !TypeCode LBS.ByteString+ {-# UNPACK #-} !FileSize+ deriving (Eq, Ord, Show) data Ownership = Ownership { -- | The owner user name. Should be set to @\"\"@ if unknown.- ownerName :: String,+ ownerName :: !BS.ByteString, -- | The owner group name. Should be set to @\"\"@ if unknown.- groupName :: String,+ groupName :: !BS.ByteString, -- | Numeric owner user id. Should be set to @0@ if unknown.- ownerId :: !Int,+ ownerId :: {-# UNPACK #-} !Int, -- | Numeric owner group id. Should be set to @0@ if unknown.- groupId :: !Int+ groupId :: {-# UNPACK #-} !Int }- deriving (Eq, Ord)+ deriving (Eq, Ord, Show) -- | There have been a number of extensions to the tar file format over the -- years. They all share the basic entry fields and put more meta-data in@@ -158,8 +174,18 @@ -- archives the standard USTAR/POSIX should be used. -- | GnuFormat- deriving (Eq, Ord)+ deriving (Eq, Ord, Show) +instance NFData Entry where+ rnf (Entry _ c _ _ _ _) = rnf c++instance NFData EntryContent where+ rnf (NormalFile c _) = rnf c+ rnf (OtherEntryType _ c _) = rnf c+ rnf x = seq x ()++instance NFData Ownership+ -- | @rw-r--r--@ for normal files ordinaryFilePermissions :: Permissions ordinaryFilePermissions = 0o0644@@ -186,7 +212,7 @@ entryPermissions = case content of Directory -> directoryPermissions _ -> ordinaryFilePermissions,- entryOwnership = Ownership "" "" 0 0,+ entryOwnership = Ownership BS.empty BS.empty 0 0, entryTime = 0, entryFormat = UstarFormat }@@ -200,9 +226,9 @@ -- -- > (fileEntry name content) { fileMode = executableFileMode } ---fileEntry :: TarPath -> ByteString -> Entry+fileEntry :: TarPath -> LBS.ByteString -> Entry fileEntry name fileContent =- simpleEntry name (NormalFile fileContent (BS.length fileContent))+ simpleEntry name (NormalFile fileContent (LBS.length fileContent)) -- | A tar 'Entry' for a directory. --@@ -239,10 +265,15 @@ -- -- * The directory separator between the prefix and name is /not/ stored. ---data TarPath = TarPath FilePath -- path name, 100 characters max.- FilePath -- path prefix, 155 characters max.+data TarPath = TarPath {-# UNPACK #-} !BS.ByteString -- path name, 100 characters max.+ {-# UNPACK #-} !BS.ByteString -- path prefix, 155 characters max. deriving (Eq, Ord) +instance NFData TarPath++instance Show TarPath where+ show = show . fromTarPath+ -- | Convert a 'TarPath' to a native 'FilePath'. -- -- The native 'FilePath' will use the native directory separator but it is not@@ -256,15 +287,17 @@ -- responsibility to check for these conditions (eg using 'checkSecurity'). -- fromTarPath :: TarPath -> FilePath-fromTarPath (TarPath name prefix) = adjustDirectory $+fromTarPath (TarPath namebs prefixbs) = adjustDirectory $ FilePath.Native.joinPath $ FilePath.Posix.splitDirectories prefix ++ FilePath.Posix.splitDirectories name where+ name = BS.Char8.unpack namebs+ prefix = BS.Char8.unpack prefixbs adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name = FilePath.Native.addTrailingPathSeparator | otherwise = id --- | Convert a 'TarPath' to a Unix/Posix 'FilePath'.+-- | Convert a 'TarPath' to a Unix\/Posix 'FilePath'. -- -- The difference compared to 'fromTarPath' is that it always returns a Unix -- style path irrespective of the current operating system.@@ -273,10 +306,12 @@ -- operating system, eg to perform portability checks. -- fromTarPathToPosixPath :: TarPath -> FilePath-fromTarPathToPosixPath (TarPath name prefix) = adjustDirectory $+fromTarPathToPosixPath (TarPath namebs prefixbs) = adjustDirectory $ FilePath.Posix.joinPath $ FilePath.Posix.splitDirectories prefix ++ FilePath.Posix.splitDirectories name where+ name = BS.Char8.unpack namebs+ prefix = BS.Char8.unpack prefixbs adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name = FilePath.Posix.addTrailingPathSeparator | otherwise = id@@ -290,10 +325,12 @@ -- operating system, eg to perform portability checks. -- fromTarPathToWindowsPath :: TarPath -> FilePath-fromTarPathToWindowsPath (TarPath name prefix) = adjustDirectory $+fromTarPathToWindowsPath (TarPath namebs prefixbs) = adjustDirectory $ FilePath.Windows.joinPath $ FilePath.Posix.splitDirectories prefix ++ FilePath.Posix.splitDirectories name where+ name = BS.Char8.unpack namebs+ prefix = BS.Char8.unpack prefixbs adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name = FilePath.Windows.addTrailingPathSeparator | otherwise = id@@ -325,11 +362,13 @@ splitLongPath path = case packName nameMax (reverse (FilePath.Posix.splitPath path)) of Left err -> Left err- Right (name, []) -> Right (TarPath name "")+ Right (name, []) -> Right $! TarPath (BS.Char8.pack name)+ BS.empty Right (name, first:rest) -> case packName prefixMax remainder of Left err -> Left err Right (_ , (_:_)) -> Left "File name too long (cannot split)"- Right (prefix, []) -> Right (TarPath name prefix)+ Right (prefix, []) -> Right $! TarPath (BS.Char8.pack name)+ (BS.Char8.pack prefix) where -- drop the '/' between the name and prefix: remainder = init first : rest@@ -353,23 +392,24 @@ -- | The tar format allows just 100 ASCII characters for the 'SymbolicLink' and -- 'HardLink' entry types. ---newtype LinkTarget = LinkTarget FilePath- deriving (Eq, Ord)+newtype LinkTarget = LinkTarget BS.ByteString+ deriving (Eq, Ord, Show, NFData) -- | Convert a native 'FilePath' to a tar 'LinkTarget'. This may fail if the -- string is longer than 100 characters or if it contains non-portable -- characters. -- toLinkTarget :: FilePath -> Maybe LinkTarget-toLinkTarget path | length path <= 100 = Just (LinkTarget path)+toLinkTarget path | length path <= 100 = Just $! LinkTarget (BS.Char8.pack path) | otherwise = Nothing -- | Convert a tar 'LinkTarget' to a native 'FilePath'. -- fromLinkTarget :: LinkTarget -> FilePath-fromLinkTarget (LinkTarget path) = adjustDirectory $+fromLinkTarget (LinkTarget pathbs) = adjustDirectory $ FilePath.Native.joinPath $ FilePath.Posix.splitDirectories path where+ path = BS.Char8.unpack pathbs adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path = FilePath.Native.addTrailingPathSeparator | otherwise = id@@ -377,9 +417,10 @@ -- | Convert a tar 'LinkTarget' to a Unix/Posix 'FilePath'. -- fromLinkTargetToPosixPath :: LinkTarget -> FilePath-fromLinkTargetToPosixPath (LinkTarget path) = adjustDirectory $+fromLinkTargetToPosixPath (LinkTarget pathbs) = adjustDirectory $ FilePath.Posix.joinPath $ FilePath.Posix.splitDirectories path where+ path = BS.Char8.unpack pathbs adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path = FilePath.Native.addTrailingPathSeparator | otherwise = id@@ -387,9 +428,10 @@ -- | Convert a tar 'LinkTarget' to a Windows 'FilePath'. -- fromLinkTargetToWindowsPath :: LinkTarget -> FilePath-fromLinkTargetToWindowsPath (LinkTarget path) = adjustDirectory $+fromLinkTargetToWindowsPath (LinkTarget pathbs) = adjustDirectory $ FilePath.Windows.joinPath $ FilePath.Posix.splitDirectories path where+ path = BS.Char8.unpack pathbs adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path = FilePath.Windows.addTrailingPathSeparator | otherwise = id@@ -417,6 +459,7 @@ data Entries e = Next Entry (Entries e) | Done | Fail e+ deriving (Eq, Show) infixr 5 `Next` @@ -425,7 +468,7 @@ -- return. -- -- It can be used to generate 'Entries' from some other type. For example it is--- used internally to lazily unfold entries from a 'ByteString'.+-- used internally to lazily unfold entries from a 'LBS.ByteString'. -- unfoldEntries :: (a -> Either e (Maybe (Entry, a))) -> a -> Entries e unfoldEntries f = unfold@@ -470,4 +513,157 @@ instance Functor Entries where fmap f = foldEntries Next Done (Fail . f)++instance NFData e => NFData (Entries e) where+ rnf (Next e es) = rnf e `seq` rnf es+ rnf Done = ()+ rnf (Fail e) = rnf e+++-------------------------+-- QuickCheck instances+--++#ifdef TESTS++instance Arbitrary Entry where+ arbitrary = Entry <$> arbitrary <*> arbitrary <*> arbitraryPermissions+ <*> arbitrary <*> arbitraryEpochTime <*> arbitrary+ where+ arbitraryPermissions :: Gen Permissions+ arbitraryPermissions = fromIntegral <$> (arbitraryOctal 7 :: Gen Int)++ arbitraryEpochTime :: Gen EpochTime+ arbitraryEpochTime = fromIntegral <$> (arbitraryOctal 11 :: Gen Int)++ shrink (Entry path content perms author time format) =+ [ Entry path' content' perms author' time' format + | (path', content', author', time') <-+ shrink (path, content, author, time) ]+ ++ [ Entry path content perms' author time format+ | perms' <- shrinkIntegral perms ]++instance Arbitrary TarPath where+ arbitrary = either error id+ . toTarPath False+ . FilePath.Posix.joinPath+ <$> listOf1ToN (255 `div` 5)+ (elements (map (replicate 4) "abcd"))++ shrink = map (either error id . toTarPath False)+ . map FilePath.Posix.joinPath+ . filter (not . null)+ . shrinkList shrinkNothing+ . FilePath.Posix.splitPath+ . fromTarPathToPosixPath++instance Arbitrary LinkTarget where+ arbitrary = maybe (error "link target too large") id+ . toLinkTarget+ . FilePath.Native.joinPath+ <$> listOf1ToN (100 `div` 5)+ (elements (map (replicate 4) "abcd"))++ shrink = map (maybe (error "link target too large") id . toLinkTarget)+ . map FilePath.Posix.joinPath+ . filter (not . null)+ . shrinkList shrinkNothing+ . FilePath.Posix.splitPath+ . fromLinkTargetToPosixPath+++listOf1ToN :: Int -> Gen a -> Gen [a]+listOf1ToN n g = sized $ \sz -> do+ n <- choose (1, min n (max 1 sz))+ vectorOf n g++listOf0ToN :: Int -> Gen a -> Gen [a]+listOf0ToN n g = sized $ \sz -> do+ n <- choose (0, min n sz)+ vectorOf n g++instance Arbitrary EntryContent where+ arbitrary =+ frequency+ [ (16, do bs <- arbitrary;+ return (NormalFile bs (LBS.length bs)))+ , (2, pure Directory)+ , (1, SymbolicLink <$> arbitrary)+ , (1, HardLink <$> arbitrary)+ , (1, CharacterDevice <$> arbitraryOctal 7 <*> arbitraryOctal 7)+ , (1, BlockDevice <$> arbitraryOctal 7 <*> arbitraryOctal 7)+ , (1, pure NamedPipe)+ , (1, do c <- elements (['A'..'Z']++['a'..'z'])+ bs <- arbitrary;+ return (OtherEntryType c bs (LBS.length bs)))+ ]++ shrink (NormalFile bs _) = [ NormalFile bs' (LBS.length bs') + | bs' <- shrink bs ]+ shrink Directory = []+ shrink (SymbolicLink link) = [ SymbolicLink link' | link' <- shrink link ]+ shrink (HardLink link) = [ HardLink link' | link' <- shrink link ]+ shrink (CharacterDevice ma mi) = [ CharacterDevice ma' mi'+ | (ma', mi') <- shrink (ma, mi) ]+ shrink (BlockDevice ma mi) = [ BlockDevice ma' mi'+ | (ma', mi') <- shrink (ma, mi) ]+ shrink NamedPipe = []+ shrink (OtherEntryType c bs _) = [ OtherEntryType c bs' (LBS.length bs') + | bs' <- shrink bs ]++instance Arbitrary LBS.ByteString where+ arbitrary = fmap LBS.pack arbitrary+ shrink = map LBS.pack . shrink . LBS.unpack++instance Arbitrary BS.ByteString where+ arbitrary = fmap BS.pack arbitrary+ shrink = map BS.pack . shrink . BS.unpack++instance Arbitrary Ownership where+ arbitrary = Ownership <$> name <*> name+ <*> idno <*> idno+ where+ name = BS.pack <$> listOf0ToN 32 (arbitrary `suchThat` (/= 0))+ idno = arbitraryOctal 7++ shrink (Ownership oname gname oid gid) =+ [ Ownership oname' gname' oid' gid'+ | (oname', gname', oid', gid') <- shrink (oname, gname, oid, gid) ]++instance Arbitrary Format where+ arbitrary = elements [V7Format, UstarFormat, GnuFormat]+++--arbitraryOctal :: (Integral n, Random n) => Int -> Gen n+arbitraryOctal n =+ oneof [ pure 0+ , choose (0, upperBound)+ , pure upperBound+ ]+ where+ upperBound = 8^n-1++-- For QC tests it's useful to have a way to limit the info to that which can+-- be expressed in the old V7 format+limitToV7FormatCompat :: Entry -> Entry+limitToV7FormatCompat entry@Entry { entryFormat = V7Format } =+ entry {+ entryContent = case entryContent entry of+ CharacterDevice _ _ -> OtherEntryType '3' LBS.empty 0+ BlockDevice _ _ -> OtherEntryType '4' LBS.empty 0+ Directory -> OtherEntryType '5' LBS.empty 0+ NamedPipe -> OtherEntryType '6' LBS.empty 0+ other -> other,++ entryOwnership = (entryOwnership entry) {+ groupName = BS.empty,+ ownerName = BS.empty+ },++ entryTarPath = let TarPath name _prefix = entryTarPath entry+ in TarPath name BS.empty+ }+limitToV7FormatCompat entry = entry++#endif
Codec/Archive/Tar/Write.hs view
@@ -16,11 +16,13 @@ import Data.Char (ord) import Data.List (foldl')+import Data.Monoid (mempty) import Numeric (showOct) -import qualified Data.ByteString.Lazy as BS-import qualified Data.ByteString.Lazy.Char8 as BS.Char8-import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS.Char8+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as LBS.Char8 -- | Create the external representation of a tar archive by serialising a list@@ -28,22 +30,23 @@ -- -- * The conversion is done lazily. ---write :: [Entry] -> ByteString-write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0]+write :: [Entry] -> LBS.ByteString+write es = LBS.concat $ map putEntry es ++ [LBS.replicate (512*2) 0] -putEntry :: Entry -> ByteString+putEntry :: Entry -> LBS.ByteString putEntry entry = case entryContent entry of- NormalFile content size -> BS.concat [ header, content, padding size ]- OtherEntryType _ content size -> BS.concat [ header, content, padding size ]+ NormalFile content size -> LBS.concat [ header, content, padding size ]+ OtherEntryType _ content size -> LBS.concat [ header, content, padding size ] _ -> header where header = putHeader entry- padding size = BS.replicate paddingSize 0+ padding size = LBS.replicate paddingSize 0 where paddingSize = fromIntegral (negate size `mod` 512) -putHeader :: Entry -> ByteString+putHeader :: Entry -> LBS.ByteString putHeader entry =- BS.Char8.pack $ take 148 block+ LBS.Char8.pack+ $ take 148 block ++ putOct 7 checksum ++ ' ' : drop 156 block -- ++ putOct 8 checksum@@ -77,7 +80,7 @@ V7Format -> fill 255 '\NUL' UstarFormat -> concat- [ putString 8 $ "ustar\NUL00"+ [ putString 8 $ ustarMagic , putString 32 $ ownerName ownership , putString 32 $ groupName ownership , putOct 8 $ deviceMajor@@ -86,7 +89,7 @@ , fill 12 $ '\NUL' ] GnuFormat -> concat- [ putString 8 $ "ustar \NUL"+ [ putString 8 $ gnuMagic , putString 32 $ ownerName ownership , putString 32 $ groupName ownership , putGnuDev 8 $ deviceMajor@@ -97,26 +100,30 @@ where (typeCode, contentSize, linkTarget, deviceMajor, deviceMinor) = case content of- NormalFile _ size -> ('0' , size, [], 0, 0)- Directory -> ('5' , 0, [], 0, 0)- SymbolicLink (LinkTarget link) -> ('2' , 0, link, 0, 0)- HardLink (LinkTarget link) -> ('1' , 0, link, 0, 0)- CharacterDevice major minor -> ('3' , 0, [], major, minor)- BlockDevice major minor -> ('4' , 0, [], major, minor)- NamedPipe -> ('6' , 0, [], 0, 0)- OtherEntryType code _ size -> (code, size, [], 0, 0)+ NormalFile _ size -> ('0' , size, mempty, 0, 0)+ Directory -> ('5' , 0, mempty, 0, 0)+ SymbolicLink (LinkTarget link) -> ('2' , 0, link, 0, 0)+ HardLink (LinkTarget link) -> ('1' , 0, link, 0, 0)+ CharacterDevice major minor -> ('3' , 0, mempty, major, minor)+ BlockDevice major minor -> ('4' , 0, mempty, major, minor)+ NamedPipe -> ('6' , 0, mempty, 0, 0)+ OtherEntryType code _ size -> (code, size, mempty, 0, 0) putGnuDev w n = case content of CharacterDevice _ _ -> putOct w n BlockDevice _ _ -> putOct w n _ -> replicate w '\NUL' +ustarMagic, gnuMagic :: BS.ByteString+ustarMagic = BS.Char8.pack "ustar\NUL00"+gnuMagic = BS.Char8.pack "ustar \NUL"+ -- * TAR format primitive output type FieldWidth = Int -putString :: FieldWidth -> String -> String-putString n s = take n s ++ fill (n - length s) '\NUL'+putString :: FieldWidth -> BS.ByteString -> String+putString n s = BS.Char8.unpack (BS.take n s) ++ fill (n - BS.length s) '\NUL' --TODO: check integer widths, eg for large file sizes putOct :: (Integral a, Show a) => FieldWidth -> a -> String
+ bench/Main.hs view
@@ -0,0 +1,45 @@+module Main where++import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Index as TarIndex++import qualified Data.ByteString.Lazy as BS+import Control.Exception++import Criterion+import Criterion.Main++main = defaultMain benchmarks++benchmarks :: [Benchmark]+benchmarks =+ [ env loadTarFile $ \tarfile ->+ bench "read" (nf Tar.read tarfile)++ , env loadTarEntriesList $ \entries ->+ bench "write" (nf Tar.write entries)++ , env loadTarEntries $ \entries ->+ bench "index build" (nf TarIndex.build entries)++ , env loadTarIndex $ \entries ->+ bench "index rebuild" (nf (TarIndex.finalise . TarIndex.unfinalise) entries)+ ]++loadTarFile :: IO BS.ByteString+loadTarFile =+ BS.readFile "01-index.tar"++loadTarEntries :: IO (Tar.Entries Tar.FormatError)+loadTarEntries =+ fmap Tar.read loadTarFile++loadTarEntriesList :: IO [Tar.Entry]+loadTarEntriesList =+ fmap (Tar.foldEntries (:) [] throw) loadTarEntries++loadTarIndex :: IO TarIndex.TarIndex+loadTarIndex =+ fmap (either throw id . TarIndex.build)+ loadTarEntries+
changelog.md view
@@ -1,3 +1,14 @@+0.4.3.0 Duncan Coutts <duncan@community.haskell.org> January 2016++ * New Index function `unfinalise` to extend existing index+ * 9x faster reading+ * 9x faster index construction+ * 24x faster index extension+ * More compact entry types, using ByteStrings+ * More Eq and Show instances+ * Greater QC test coverage+ * Fix minor bug in reading non-standard v7 format entries+ 0.4.2.2 Edsko de Vries <edsko@well-typed.com> October 2015 * Fix bug in Index
tar.cabal view
@@ -1,12 +1,13 @@ name: tar-version: 0.4.2.2+version: 0.4.3.0 license: BSD3 license-file: LICENSE-author: Bjorn Bringert <bjorn@bringert.net>- Duncan Coutts <duncan@community.haskell.org>+author: Duncan Coutts <duncan@community.haskell.org>+ Bjorn Bringert <bjorn@bringert.net> maintainer: Duncan Coutts <duncan@community.haskell.org>+bug-reports: https://github.com/haskell/tar/issues copyright: 2007 Bjorn Bringert <bjorn@bringert.net>- 2008-2015 Duncan Coutts <duncan@community.haskell.org>+ 2008-2016 Duncan Coutts <duncan@community.haskell.org> category: Codec synopsis: Reading, writing and manipulating ".tar" archive files. description: This library is for working with \"@.tar@\" archive files. It@@ -19,11 +20,11 @@ build-type: Simple cabal-version: >=1.8 extra-source-files: changelog.md-tested-with: GHC ==7.0.4, GHC ==7.2.2, GHC ==7.4.2, GHC ==7.6.3, GHC ==7.8.4, GHC ==7.10.2, GHC ==7.11.*+tested-with: GHC ==7.4.2, GHC ==7.6.3, GHC ==7.8.4, GHC ==7.10.2 source-repository head- type: darcs- location: http://code.haskell.org/tar/+ type: git+ location: https://github.com/haskell/tar.git flag old-time @@ -32,7 +33,9 @@ bytestring >= 0.10, filepath, directory,- array+ array,+ containers >= 0.4.2,+ deepseq if flag(old-time) build-depends: directory < 1.2, old-time else@@ -64,8 +67,10 @@ build-depends: base, bytestring, filepath, directory,- old-time, time, array,+ containers,+ deepseq,+ old-time, time, bytestring-handle, QuickCheck == 2.*, tasty >= 0.10 && <0.12,@@ -84,3 +89,19 @@ other-extensions: CPP, BangPatterns, DeriveDataTypeable, ScopedTypeVariables++ ghc-options: -fno-ignore-asserts++benchmark bench+ type: exitcode-stdio-1.0+ hs-source-dirs: . bench+ main-is: bench/Main.hs+ build-depends: base,+ bytestring,+ filepath, directory,+ array,+ containers,+ deepseq,+ old-time, time,+ criterion >= 1.0+
test/Properties.hs view
@@ -3,7 +3,10 @@ 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 Codec.Archive.Tar as Tar +import qualified Data.ByteString as BS+ import Test.Tasty import Test.Tasty.QuickCheck @@ -11,19 +14,37 @@ main = defaultMain $ testGroup "tar tests" [- testGroup "string table" [- testProperty "construction and lookup" StringTable.prop_valid++ testGroup "write/read" [+ testProperty "ustar format" Tar.prop_write_read_ustar,+ testProperty "gnu format" Tar.prop_write_read_gnu,+ testProperty "v7 format" Tar.prop_write_read_v7 ]++ , testGroup "string table" [+ testProperty "construction" StringTable.prop_valid,+ testProperty "sorted" StringTable.prop_sorted,+ testProperty "serialise" StringTable.prop_serialise_deserialise,+ testProperty "unfinalise" StringTable.prop_finalise_unfinalise+ ]+ , 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+ testProperty "completions" IntTrie.prop_completions_mono,+ testProperty "toList" IntTrie.prop_construct_toList,+ testProperty "serialise" IntTrie.prop_serialise_deserialise,+ testProperty "unfinalise" IntTrie.prop_finalise_unfinalise ]+ , testGroup "index" [- testProperty "lookup" Index.prop_lookup- , testProperty "valid" Index.prop_valid- , testProperty "matches tar" Index.prop_index_matches_tar+ testProperty "lookup" Index.prop_lookup,+ testProperty "valid" Index.prop_valid,+ testProperty "serialise" Index.prop_serialise_deserialise,+ testProperty "matches tar" Index.prop_index_matches_tar,+ testProperty "resume" Index.prop_finalise_unfinalise ] ]+