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 @@ -67,6 +67,7 @@ #ifdef TESTS prop_lookup, prop_valid, + prop_index_matches_tar #endif ) where @@ -102,10 +103,16 @@ #ifdef TESTS import qualified Prelude -import Test.QuickCheck +import Test.QuickCheck hiding (Result) +import Test.QuickCheck.Property (Result, exception, succeeded) import Control.Applicative ((<$>), (<*>)) +import Control.Monad (unless) import Data.List (nub, sort, stripPrefix, isPrefixOf) import Data.Maybe +import System.IO.Unsafe (unsafePerformIO) +import Control.Exception (SomeException, try) +import Codec.Archive.Tar.Write as Tar +import qualified Data.ByteString.Handle as HBS #endif @@ -170,7 +177,7 @@ -- the list of files within that directory. -- -- Given the 'TarEntryOffset' you can then use one of the I\/O operations: --- +-- -- * 'hReadEntry' to read the whole entry; -- -- * 'hReadEntryHeader' to read just the file metadata (e.g. its length); @@ -301,6 +308,9 @@ 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) @@ -495,7 +505,7 @@ 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 @@ -612,10 +622,88 @@ where Right path = toTarPath False name +-- | Simple tar archive containing regular files only +data SimpleTarArchive = SimpleTarArchive { + simpleTarEntries :: Tar.Entries () + , simpleTarRaw :: [(FilePath, LBS.ByteString)] + , simpleTarBS :: LBS.ByteString + } + +instance Show SimpleTarArchive where + show = show . simpleTarRaw + +prop_index_matches_tar :: SimpleTarArchive -> Result +prop_index_matches_tar sta = + case unsafePerformIO (try go) of + Left ex -> exception "" ex + Right () -> succeeded + where + go :: IO () + go = do + h <- HBS.readHandle True (simpleTarBS sta) + goEntries h 0 (simpleTarEntries sta) + + goEntries :: Handle -> TarEntryOffset -> Tar.Entries () -> IO () + goEntries _ _ Tar.Done = + return () + goEntries _ _ (Tar.Fail _) = + throwIO (userError "Fail entry in SimpleTarArchive") + goEntries h offset (Tar.Next e es) = do + goEntry h offset e + goEntries h (nextEntryOffset e offset) es + + goEntry :: Handle -> TarEntryOffset -> Tar.Entry -> IO () + goEntry h offset e = do + e' <- hReadEntry h offset + case (Tar.entryContent e, Tar.entryContent e') of + (Tar.NormalFile bs sz, Tar.NormalFile bs' sz') -> + unless (sz == sz' && bs == bs') $ + throwIO $ userError "Entry mismatch" + _otherwise -> + throwIO $ userError "unexpected entry types" + +instance Arbitrary SimpleTarArchive where + arbitrary = do + numEntries <- sized $ \n -> choose (0, n) + rawEntries <- mkRaw numEntries + let entries = mkList rawEntries + return SimpleTarArchive { + simpleTarEntries = mkEntries entries + , simpleTarRaw = rawEntries + , simpleTarBS = Tar.write entries + } + where + mkRaw :: Int -> Gen [(FilePath, LBS.ByteString)] + mkRaw 0 = return [] + mkRaw n = do + -- Pick a size around 0, 1, or 2 block boundaries + sz <- sized $ \n -> elements (take n fileSizes) + bs <- LBS.pack `fmap` vectorOf sz arbitrary + es <- mkRaw (n - 1) + return $ ("file" ++ show n, bs) : es + + mkList :: [(FilePath, LBS.ByteString)] -> [Tar.Entry] + mkList [] = [] + mkList ((fp, bs):es) = entry : mkList es + where + Right path = toTarPath False fp + entry = simpleEntry path content + content = NormalFile bs (LBS.length bs) + + mkEntries :: [Tar.Entry] -> Tar.Entries () + mkEntries [] = Tar.Done + mkEntries (e:es) = Tar.Next e (mkEntries es) + + -- Sizes around 0, 1, and 2 block boundaries + fileSizes :: [Int] + fileSizes = [ + 0 , 1 , 2 + , 510 , 511 , 512 , 513 , 514 + , 1022 , 1023 , 1024 , 1025 , 1026 + ] #endif #if !(MIN_VERSION_base(4,5,0)) (<>) :: Monoid m => m -> m -> m (<>) = mappend #endif - diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,7 @@ +0.4.2.2 Edsko de Vries October 2015 + + * Fix bug in Index + 0.4.2.1 Duncan Coutts July 2015 * Fix tests for the Index modules (the code was right) diff --git a/tar.cabal b/tar.cabal --- a/tar.cabal +++ b/tar.cabal @@ -1,5 +1,5 @@ name: tar -version: 0.4.2.1 +version: 0.4.2.2 license: BSD3 license-file: LICENSE author: Bjorn Bringert @@ -19,6 +19,7 @@ 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.* source-repository head type: darcs @@ -65,8 +66,9 @@ filepath, directory, old-time, time, array, + bytestring-handle, QuickCheck == 2.*, - tasty == 0.10.*, + tasty >= 0.10 && <0.12, tasty-quickcheck == 0.8.* hs-source-dirs: . test @@ -82,4 +84,3 @@ other-extensions: CPP, BangPatterns, DeriveDataTypeable, ScopedTypeVariables - diff --git a/test/Properties.hs b/test/Properties.hs --- a/test/Properties.hs +++ b/test/Properties.hs @@ -22,8 +22,8 @@ testProperty "completions" IntTrie.prop_completions_mono ] , testGroup "index" [ - testProperty "lookup" Index.prop_lookup - , testProperty "valid" Index.prop_valid + testProperty "lookup" Index.prop_lookup + , testProperty "valid" Index.prop_valid + , testProperty "matches tar" Index.prop_index_matches_tar ] ] -