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 @@ -79,6 +79,7 @@ prop_toList, prop_valid, prop_serialise_deserialise, + prop_serialiseSize, prop_index_matches_tar, prop_finalise_unfinalise, #endif @@ -111,10 +112,14 @@ 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) +#if MIN_VERSION_bytestring(0,10,2) || defined(MIN_VERSION_bytestring_builder) import Data.ByteString.Builder as BS +import Data.ByteString.Builder.Extra as BS (toLazyByteStringWith, + untrimmedStrategy) #else import Data.ByteString.Lazy.Builder as BS +import Data.ByteString.Lazy.Builder.Extras as BS (toLazyByteStringWith, + untrimmedStrategy) #endif #ifdef TESTS @@ -536,8 +541,24 @@ -- | The 'TarIndex' is compact in memory, and it has a similarly compact -- external representation. -- -serialise :: TarIndex -> BS.Builder -serialise (TarIndex stringTable intTrie finalOffset) = +serialise :: TarIndex -> BS.ByteString +serialise = toStrict . serialiseLBS + +-- we keep this version around just so we can check we got the size right. +serialiseLBS :: TarIndex -> LBS.ByteString +serialiseLBS index = + BS.toLazyByteStringWith + (BS.untrimmedStrategy (serialiseSize index) 512) LBS.empty + (serialiseBuilder index) + +serialiseSize :: TarIndex -> Int +serialiseSize (TarIndex stringTable intTrie _) = + StringTable.serialiseSize stringTable + + IntTrie.serialiseSize intTrie + + 8 + +serialiseBuilder :: TarIndex -> BS.Builder +serialiseBuilder (TarIndex stringTable intTrie finalOffset) = BS.word32BE 2 -- format version <> BS.word32BE finalOffset <> StringTable.serialise stringTable @@ -628,12 +649,18 @@ prop_serialise_deserialise :: ValidPaths -> Bool prop_serialise_deserialise (ValidPaths paths) = - Just (index, BS.empty) == (deserialise - . LBS.toStrict . BS.toLazyByteString - . serialise) index + Just (index, BS.empty) == (deserialise . serialise) index where index = construct paths +prop_serialiseSize :: ValidPaths -> Bool +prop_serialiseSize (ValidPaths paths) = + case (LBS.toChunks . serialiseLBS) index of + [c1] -> BS.length c1 == serialiseSize index + _ -> False + where + index = construct paths + newtype NonEmptyFilePath = NonEmptyFilePath FilePath deriving Show instance Arbitrary NonEmptyFilePath where @@ -782,6 +809,14 @@ prop_finalise_unfinalise :: SimpleIndexBuilder -> Bool prop_finalise_unfinalise (SimpleIndexBuilder index) = unfinalise (finalise index) == index + +#endif + +toStrict :: LBS.ByteString -> BS.ByteString +#if MIN_VERSION_bytestring(0,10,0) +toStrict = LBS.toStrict +#else +toStrict = BS.concat . LBS.toChunks #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 @@ -17,6 +17,7 @@ TrieLookup(..), serialise, + serialiseSize, deserialise, #ifdef TESTS @@ -29,6 +30,7 @@ prop_construct_toList, prop_finalise_unfinalise, prop_serialise_deserialise, + prop_serialiseSize, #endif ) where @@ -48,7 +50,7 @@ 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) +#if MIN_VERSION_bytestring(0,10,2) || defined(MIN_VERSION_bytestring_builder) import Data.ByteString.Builder as BS #else import Data.ByteString.Lazy.Builder as BS @@ -416,9 +418,15 @@ : Map.keys keysValues ++ Map.elems keysValues (!offset', !keysValues, !tries') = +#if MIN_VERSION_containers(0,4,2) IntMap.foldlWithKey' accumNodes (offset, Map.empty, tries) tnodes +#else + foldl' (\a (k,v) -> accumNodes a k v) + (offset, Map.empty, tries) + (IntMap.toList tnodes) +#endif accumNodes :: (Offset, Map.Map Word32 Word32, Q (IntTrieBuilder k v)) -> Int -> TrieNode k v @@ -462,6 +470,12 @@ BS.word32BE (ixEnd+1) <> foldr (\n r -> BS.word32BE n <> r) mempty (A.elems arr) +serialiseSize :: IntTrie k v -> Int +serialiseSize (IntTrie arr) = + let (_, ixEnd) = A.bounds arr in + 4 + + 4 * (fromIntegral ixEnd + 1) + deserialise :: BS.ByteString -> Maybe (IntTrie k v, BS.ByteString) deserialise bs | BS.length bs >= 4 @@ -541,12 +555,20 @@ prop_serialise_deserialise :: ValidPaths -> Bool prop_serialise_deserialise (ValidPaths paths) = Just (trie, BS.empty) == (deserialise - . LBS.toStrict . BS.toLazyByteString + . toStrict . BS.toLazyByteString . serialise) trie where trie :: IntTrie Char Char trie = construct paths +prop_serialiseSize :: ValidPaths -> Bool +prop_serialiseSize (ValidPaths paths) = + (fromIntegral . LBS.length . BS.toLazyByteString . serialise) trie + == serialiseSize trie + where + trie :: IntTrie Char Char + trie = construct paths + newtype ValidPaths = ValidPaths [([Char], Char)] deriving Show instance Arbitrary ValidPaths where @@ -568,6 +590,13 @@ nonEmpty = all (not . null . fst) isPrefixOfOther a b = a `isPrefixOf` b || b `isPrefixOf` a + +toStrict :: LBS.ByteString -> BS.ByteString +#if MIN_VERSION_bytestring(0,10,0) +toStrict = LBS.toStrict +#else +toStrict = BS.concat . LBS.toChunks +#endif #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 @@ -15,6 +15,7 @@ unfinalise, serialise, + serialiseSize, deserialiseV1, deserialiseV2, @@ -23,6 +24,7 @@ prop_sorted, prop_finalise_unfinalise, prop_serialise_deserialise, + prop_serialiseSize, #endif ) where @@ -51,15 +53,16 @@ #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 +import qualified Data.ByteString.Lazy as LBS +#if MIN_VERSION_bytestring(0,10,2) || defined(MIN_VERSION_bytestring_builder) +import Data.ByteString.Builder as BS +import Data.ByteString.Builder.Extra as BS (byteStringCopy) #else -import Data.ByteString.Lazy.Builder as BS +import Data.ByteString.Lazy.Builder as BS +import Data.ByteString.Lazy.Builder.Extras as BS (byteStringCopy) #endif - -- | An effecient mapping from strings to a dense set of integers. -- data StringTable id = StringTable @@ -166,11 +169,19 @@ BS.word32BE (fromIntegral (BS.length strs)) <> BS.word32BE (fromIntegral ixEnd + 1) - <> BS.byteString strs + <> BS.byteStringCopy 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) +serialiseSize :: StringTable id -> Int +serialiseSize (StringTable strs offs _ids _ixs) = + let (_, !ixEnd) = A.bounds offs + in 4 * 2 + + BS.length strs + + 4 * (fromIntegral ixEnd + 1) + + 8 * fromIntegral ixEnd + deserialiseV1 :: BS.ByteString -> Maybe (StringTable id, BS.ByteString) deserialiseV1 bs | BS.length bs >= 8 @@ -276,12 +287,20 @@ prop_serialise_deserialise :: [BS.ByteString] -> Bool prop_serialise_deserialise strs = Just (strtable, BS.empty) == (deserialiseV2 - . LBS.toStrict . BS.toLazyByteString + . toStrict . BS.toLazyByteString . serialise) strtable where strtable :: StringTable Int strtable = construct strs +prop_serialiseSize :: [BS.ByteString] -> Bool +prop_serialiseSize strs = + (fromIntegral . LBS.length . BS.toLazyByteString . serialise) strtable + == serialiseSize 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 @@ -289,6 +308,13 @@ enumIds :: Enum id => StringTable id -> [id] enumIds (StringTable _ offsets _ _) = [toEnum 0 .. toEnum (fromIntegral (h-1))] where (0,h) = A.bounds offsets + +toStrict :: LBS.ByteString -> BS.ByteString +#if MIN_VERSION_bytestring(0,10,0) +toStrict = LBS.toStrict +#else +toStrict = BS.concat . LBS.toChunks +#endif #endif diff --git a/Codec/Archive/Tar/Pack.hs b/Codec/Archive/Tar/Pack.hs --- a/Codec/Archive/Tar/Pack.hs +++ b/Codec/Archive/Tar/Pack.hs @@ -4,7 +4,7 @@ -- Module : Codec.Archive.Tar -- Copyright : (c) 2007 Bjorn Bringert, -- 2008 Andrea Vezzosi, --- 2008-2009 Duncan Coutts +-- 2008-2009, 2012, 2016 Duncan Coutts -- License : BSD3 -- -- Maintainer : duncan@community.haskell.org 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 @@ -32,6 +32,10 @@ import Prelude hiding (read) +#if !MIN_VERSION_bytestring(0,10,0) +import Data.Monoid (Monoid(..)) +import qualified Data.ByteString.Lazy.Internal as LBS +#endif -- | Errors that can be encountered when parsing a Tar archive. data FormatError @@ -139,7 +143,12 @@ return (Just (entry, bs')) where +#if MIN_VERSION_bytestring(0,10,0) header = LBS.toStrict (LBS.take 512 bs) +#else + header = toStrict (LBS.take 512 bs) + toStrict = LBS.foldrChunks mappend mempty +#endif name = getString 0 100 header mode_ = getOct 100 8 header 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 @@ -181,9 +181,16 @@ rnf (Entry _ c _ _ _ _) = rnf c instance NFData EntryContent where - rnf (NormalFile c _) = rnf c - rnf (OtherEntryType _ c _) = rnf c - rnf x = seq x () + rnf x = case x of + NormalFile c _ -> rnflbs c + OtherEntryType _ c _ -> rnflbs c + _ -> seq x () + where +#if MIN_VERSION_bytestring(0,10,0) + rnflbs = rnf +#else + rnflbs = foldr (\ !_bs r -> r) () . LBS.toChunks +#endif instance NFData Ownership where rnf (Ownership o g _ _) = rnf o `seq` rnf g @@ -396,7 +403,14 @@ -- 'HardLink' entry types. -- newtype LinkTarget = LinkTarget BS.ByteString - deriving (Eq, Ord, Show, NFData) + deriving (Eq, Ord, Show) + +instance NFData LinkTarget where +#if MIN_VERSION_bytestring(0,10,0) + rnf (LinkTarget bs) = rnf bs +#else + rnf (LinkTarget !_bs) = () +#endif -- | 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 diff --git a/Codec/Archive/Tar/Unpack.hs b/Codec/Archive/Tar/Unpack.hs --- a/Codec/Archive/Tar/Unpack.hs +++ b/Codec/Archive/Tar/Unpack.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Codec.Archive.Tar -- Copyright : (c) 2007 Bjorn Bringert, -- 2008 Andrea Vezzosi, --- 2008-2009 Duncan Coutts +-- 2008-2009, 2012, 2016 Duncan Coutts -- License : BSD3 -- -- Maintainer : duncan@community.haskell.org @@ -25,7 +26,7 @@ import System.Directory ( createDirectoryIfMissing, copyFile ) import Control.Exception - ( Exception, throwIO ) + ( Exception, throwIO, catch ) -- | Create local files and directories based on the entries of a tar archive. -- @@ -62,27 +63,33 @@ unpackEntries _ (Fail err) = either throwIO throwIO err unpackEntries links Done = return links unpackEntries links (Next entry es) = case entryContent entry of - NormalFile file _ -> extractFile path file + NormalFile file _ -> extractFile path file mtime >> unpackEntries links es - Directory -> extractDir path + Directory -> extractDir path mtime >> unpackEntries links es HardLink link -> (unpackEntries $! saveLink path link links) es SymbolicLink link -> (unpackEntries $! saveLink path link links) es _ -> unpackEntries links es --ignore other file types where - path = entryPath entry + path = entryPath entry + mtime = entryTime entry - extractFile path content = do + extractFile path content mtime = do -- Note that tar archives do not make sure each directory is created -- before files they contain, indeed we may have to create several -- levels of directory. createDirectoryIfMissing True absDir BS.writeFile absPath content + setModTime absPath mtime where absDir = baseDir FilePath.Native.takeDirectory path absPath = baseDir path - extractDir path = createDirectoryIfMissing True (baseDir path) + extractDir path mtime = do + createDirectoryIfMissing True absPath + setModTime absPath mtime + where + absPath = baseDir path saveLink path link links = seq (length path) $ seq (length link') @@ -93,3 +100,13 @@ let absPath = baseDir relPath absTarget = FilePath.Native.takeDirectory absPath relLinkTarget in copyFile absTarget absPath + +setModTime :: FilePath -> EpochTime -> IO () +#if MIN_VERSION_directory(1,2,3) +-- functionality only supported as of directory-1.2.3.x +setModTime path t = + setModificationTime path (posixSecondsToUTCTime t) + `catch` \e -> if isPermissionError e then return () else throwIO e +#else +setModTime _path _t = return () +#endif diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,10 @@ +0.5.0.0 Duncan Coutts January 2016 + + * Work with old version of bytestring (using bytestring-builder package). + * Builds with GHC 6.10 -- 8.0. + * Change type of Index.serialise to be simply strict bytestring. + * Preserve file timestamps on unpack (with directory-1.2.3+) + 0.4.5.0 Duncan Coutts January 2016 * Revert accidental minor API change in 0.4.x series (the type of the diff --git a/tar.cabal b/tar.cabal --- a/tar.cabal +++ b/tar.cabal @@ -1,5 +1,5 @@ name: tar -version: 0.4.5.0 +version: 0.5.0.0 license: BSD3 license-file: LICENSE author: Duncan Coutts @@ -12,11 +12,15 @@ synopsis: Reading, writing and manipulating ".tar" archive files. description: This library is for working with \"@.tar@\" archive files. It can read and write a range of common variations of archive - format including V7, USTAR, POSIX and GNU formats. It provides - support for packing and unpacking portable archives. This - makes it suitable for distribution but not backup because - details like file ownership and exact permissions are not - preserved. + format including V7, POSIX USTAR and GNU formats. + . + It provides support for packing and unpacking portable + archives. This makes it suitable for distribution but not + backup because details like file ownership and exact + permissions are not preserved. + . + It also provides features for random access to archive + content using an index. build-type: Simple cabal-version: >=1.8 extra-source-files: changelog.md @@ -29,19 +33,26 @@ flag old-time default: False +flag old-bytestring + default: False + library build-depends: base == 4.*, - bytestring >= 0.10, filepath, directory, array, - containers >= 0.4.2, + containers >= 0.2, deepseq >= 1.1 && < 1.5 if flag(old-time) build-depends: directory < 1.2, old-time else build-depends: directory >= 1.2, time + if flag(old-bytestring) + build-depends: bytestring-builder, bytestring >= 0.9 && <0.10 + else + build-depends: bytestring >= 0.10 + exposed-modules: Codec.Archive.Tar Codec.Archive.Tar.Entry @@ -66,16 +77,24 @@ test-suite properties type: exitcode-stdio-1.0 build-depends: base, - bytestring, - filepath, directory, + filepath, array, containers, deepseq, - old-time, time, bytestring-handle, QuickCheck == 2.*, tasty >= 0.10 && <0.12, tasty-quickcheck == 0.8.* + + if flag(old-time) + build-depends: directory < 1.2, old-time + else + build-depends: directory >= 1.2, time + + if flag(old-bytestring) + build-depends: bytestring-builder, bytestring >= 0.9 && <0.10 + else + build-depends: bytestring >= 0.10 hs-source-dirs: . test diff --git a/test/Properties.hs b/test/Properties.hs --- a/test/Properties.hs +++ b/test/Properties.hs @@ -25,6 +25,7 @@ testProperty "construction" StringTable.prop_valid, testProperty "sorted" StringTable.prop_sorted, testProperty "serialise" StringTable.prop_serialise_deserialise, + testProperty "size" StringTable.prop_serialiseSize, testProperty "unfinalise" StringTable.prop_finalise_unfinalise ] @@ -36,6 +37,7 @@ testProperty "completions" IntTrie.prop_completions_mono, testProperty "toList" IntTrie.prop_construct_toList, testProperty "serialise" IntTrie.prop_serialise_deserialise, + testProperty "size" IntTrie.prop_serialiseSize, testProperty "unfinalise" IntTrie.prop_finalise_unfinalise ] @@ -44,6 +46,7 @@ testProperty "valid" Index.prop_valid, testProperty "toList" Index.prop_toList, testProperty "serialise" Index.prop_serialise_deserialise, + testProperty "size" Index.prop_serialiseSize, testProperty "matches tar" Index.prop_index_matches_tar, testProperty "unfinalise" Index.prop_finalise_unfinalise ]