diff --git a/Codec/Archive/Tar.hs b/Codec/Archive/Tar.hs --- a/Codec/Archive/Tar.hs +++ b/Codec/Archive/Tar.hs @@ -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 diff --git a/Codec/Archive/Tar/Index.hs b/Codec/Archive/Tar/Index.hs --- a/Codec/Archive/Tar/Index.hs +++ b/Codec/Archive/Tar/Index.hs @@ -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)) diff --git a/Codec/Archive/Tar/Index/IntTrie.hs b/Codec/Archive/Tar/Index/IntTrie.hs --- a/Codec/Archive/Tar/Index/IntTrie.hs +++ b/Codec/Archive/Tar/Index/IntTrie.hs @@ -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 + diff --git a/Codec/Archive/Tar/Index/StringTable.hs b/Codec/Archive/Tar/Index/StringTable.hs --- a/Codec/Archive/Tar/Index/StringTable.hs +++ b/Codec/Archive/Tar/Index/StringTable.hs @@ -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 diff --git a/Codec/Archive/Tar/Read.hs b/Codec/Archive/Tar/Read.hs --- a/Codec/Archive/Tar/Read.hs +++ b/Codec/Archive/Tar/Read.hs @@ -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 diff --git a/Codec/Archive/Tar/Types.hs b/Codec/Archive/Tar/Types.hs --- a/Codec/Archive/Tar/Types.hs +++ b/Codec/Archive/Tar/Types.hs @@ -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 diff --git a/Codec/Archive/Tar/Write.hs b/Codec/Archive/Tar/Write.hs --- a/Codec/Archive/Tar/Write.hs +++ b/Codec/Archive/Tar/Write.hs @@ -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 diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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 + diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,14 @@ +0.4.3.0 Duncan Coutts 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 October 2015 * Fix bug in Index diff --git a/tar.cabal b/tar.cabal --- a/tar.cabal +++ b/tar.cabal @@ -1,12 +1,13 @@ name: tar -version: 0.4.2.2 +version: 0.4.3.0 license: BSD3 license-file: LICENSE -author: Bjorn Bringert - Duncan Coutts +author: Duncan Coutts + Bjorn Bringert maintainer: Duncan Coutts +bug-reports: https://github.com/haskell/tar/issues copyright: 2007 Bjorn Bringert - 2008-2015 Duncan Coutts + 2008-2016 Duncan Coutts 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 + diff --git a/test/Properties.hs b/test/Properties.hs --- a/test/Properties.hs +++ b/test/Properties.hs @@ -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 ] ] +