tar 0.6.2.0 → 0.6.3.0
raw patch · 9 files changed
+154/−75 lines, 9 filesdep ~tasty-quickcheckdep ~time
Dependency ranges changed: tasty-quickcheck, time
Files
- Codec/Archive/Tar.hs +1/−1
- Codec/Archive/Tar/Index/IntTrie.hs +9/−12
- Codec/Archive/Tar/Index/Internal.hs +5/−12
- Codec/Archive/Tar/Index/StringTable.hs +26/−30
- Codec/Archive/Tar/Index/Utils.hs +84/−0
- Codec/Archive/Tar/Write.hs +18/−17
- bench/Main.hs +3/−0
- changelog.md +4/−0
- tar.cabal +4/−3
Codec/Archive/Tar.hs view
@@ -71,7 +71,7 @@ -- on the 'extract' function where we use decompression in the pipeline: -- -- > import qualified Data.ByteString.Lazy as BL- -- > import qualified Codec.Compression.Zlib as GZip+ -- > import qualified Codec.Compression.GZip as GZip -- > -- > Tar.unpack dir . Tar.read . GZip.decompress =<< BL.readFile tar --
Codec/Archive/Tar/Index/IntTrie.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP, BangPatterns, PatternGuards #-} {-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} module Codec.Archive.Tar.Index.IntTrie (@@ -55,7 +57,10 @@ import Data.List hiding (lookup, insert) import Data.Function (on)+import GHC.IO +import Codec.Archive.Tar.Index.Utils+ -- | A compact mapping from sequences of nats to nats. -- -- NOTE: The tries in this module have values /only/ at the leaves (which@@ -338,19 +343,11 @@ , 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')+ , let !bs_without_len = BS.unsafeDrop 4 bs+ !bs_remaining = BS.unsafeDrop lenTotal bs+ !arr = unsafePerformIO $ beToLe lenArr bs_without_len+ = Just (IntTrie arr, bs_remaining) | 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))
Codec/Archive/Tar/Index/Internal.hs view
@@ -63,6 +63,7 @@ import qualified Codec.Archive.Tar.Index.StringTable as StringTable import Codec.Archive.Tar.Index.StringTable (StringTable, StringTableBuilder) import qualified Codec.Archive.Tar.Index.IntTrie as IntTrie+import Codec.Archive.Tar.Index.Utils (readWord32BE) import Codec.Archive.Tar.Index.IntTrie (IntTrie, IntTrieBuilder) import Codec.Archive.Tar.PackAscii @@ -496,27 +497,19 @@ | let ver = readWord32BE bs 0 , ver == 1- = do let !finalOffset = readWord32BE bs 4- (stringTable, bs') <- StringTable.deserialiseV1 (BS.drop 8 bs)+ = do let !finalOffset = readWord32BE bs 1+ (stringTable, bs') <- StringTable.deserialiseV1 (BS.unsafeDrop 8 bs) (intTrie, bs'') <- IntTrie.deserialise bs' return (TarIndex stringTable intTrie finalOffset, bs'') | let ver = readWord32BE bs 0 , ver == 2- = do let !finalOffset = readWord32BE bs 4- (stringTable, bs') <- StringTable.deserialiseV2 (BS.drop 8 bs)+ = do let !finalOffset = readWord32BE bs 1+ (stringTable, bs') <- StringTable.deserialiseV2 (BS.unsafeDrop 8 bs) (intTrie, bs'') <- IntTrie.deserialise bs' return (TarIndex stringTable intTrie finalOffset, 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)) toStrict :: LBS.ByteString -> BS.ByteString toStrict = LBS.toStrict
Codec/Archive/Tar/Index/StringTable.hs view
@@ -37,6 +37,7 @@ import Control.Exception (assert) import qualified Data.Array.Unboxed as A+import qualified Data.Array.Base as A import Data.Array.Unboxed ((!)) import qualified Data.Map.Strict as Map import Data.Map.Strict (Map)@@ -45,7 +46,11 @@ import qualified Data.ByteString.Lazy as LBS import Data.ByteString.Builder as BS import Data.ByteString.Builder.Extra as BS (byteStringCopy)+import GHC.IO (unsafePerformIO) +import Unsafe.Coerce (unsafeCoerce)+import Codec.Archive.Tar.Index.Utils+ -- | An efficient mapping from strings to a dense set of integers. -- data StringTable id = StringTable@@ -169,10 +174,10 @@ deserialiseV1 bs | BS.length bs >= 8 , let lenStrs = fromIntegral (readWord32BE bs 0)- lenArr = fromIntegral (readWord32BE bs 4)+ lenArr = fromIntegral (readWord32BE bs 1) lenTotal= 8 + lenStrs + 4 * lenArr , BS.length bs >= lenTotal- , let strs = BS.take lenStrs (BS.drop 8 bs)+ , let strs = BS.unsafeTake lenStrs (BS.unsafeDrop 8 bs) arr = A.array (0, fromIntegral lenArr - 1) [ (i, readWord32BE bs off) | (i, off) <- zip [0 .. fromIntegral lenArr - 1]@@ -194,41 +199,32 @@ deserialiseV2 bs | BS.length bs >= 8 , let lenStrs = fromIntegral (readWord32BE bs 0)- lenArr = fromIntegral (readWord32BE bs 4)+ lenArr = fromIntegral (readWord32BE bs 1) 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)]+ , let strs = BS.unsafeTake lenStrs (BS.unsafeDrop 8 bs)+ offs_bs = BS.unsafeDrop (8 + lenStrs) bs+ ids_bs = BS.unsafeDrop (lenArr * 4) offs_bs+ ixs_bs = BS.unsafeDrop ((lenArr - 1) * 4) ids_bs++ castArray :: A.UArray i Word32 -> A.UArray i Int32+ castArray (A.UArray a b c d) = (A.UArray a b c d)++ -- Bangs are crucial for this to work in spite of unsafePerformIO!+ (offs, ids, ixs) = unsafePerformIO $ do+ !r1 <- beToLe (fromIntegral lenArr) offs_bs+ !r2 <- castArray <$> beToLe (fromIntegral lenArr - 1) ids_bs+ !r3 <- castArray <$> beToLe (fromIntegral lenArr - 1) ixs_bs+ return (r1, r2, r3)++ !stringTable = StringTable strs offs ids ixs- !bs' = BS.drop lenTotal bs- = Just (stringTable, bs')+ !bs_left = BS.drop lenTotal bs+ = Just (stringTable, bs_left) | 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))
+ Codec/Archive/Tar/Index/Utils.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, CPP #-}+module Codec.Archive.Tar.Index.Utils where++import Data.ByteString as BS+import Control.Exception (assert)++import Data.ByteString.Internal (ByteString(..), unsafeWithForeignPtr, accursedUnutterablePerformIO)+import GHC.Int (Int(..), Int32)+import GHC.Word (Word32(..), byteSwap32)+import Foreign.Storable (peek)+import GHC.Ptr (castPtr, plusPtr, Ptr)+import GHC.Exts+import GHC.IO (IO(..), unsafePerformIO)+import Data.Array.Base+import Data.Array.IO.Internals (unsafeFreezeIOUArray)+import Control.DeepSeq (NFData(..))+import GHC.Storable+import GHC.ByteOrder++#include <MachDeps.h>++-- | Construct a `UArray Word32 Word32` from a ByteString of 32bit big endian+-- words.+--+-- Note: If using `unsafePerformIO`, be sure to force the result of running the+-- IO action right away... (e.g. see calls to beToLe in StringTable)+beToLe :: (Integral i, Num i) => i+ -- ^ The total array length (the number of 32bit words in the array)+ -> BS.ByteString+ -- ^ The bytestring from which the UArray is constructed.+ -- The content must start in the first byte! (i.e. the meta-data words+ -- that shouldn't be part of the array, must have been dropped already)+ -> IO (UArray i Word32)+beToLe lenArr (BS fptr _) = do+ unsafeWithForeignPtr fptr $ \ptr -> do+ let ptr' = castPtr ptr :: Ptr Word32+ !(I# lenBytes#) = fromIntegral (lenArr * 4)++ -- In spirit, the following does this, but we can't use `newGenArray`+ -- because it only has been introduced in later versions of array:+ -- @@+ -- unsafeFreezeIOUArray =<<+ -- newGenArray (0, lenArr - 1) (\offset -> do+ -- byteSwap32 <$> peek (ptr' `plusPtr` (fromIntegral offset * 4)))+ -- @@+ IO $ \rw0 ->+ case newByteArray# lenBytes# rw0 of+ (# rw1, mba# #) ->++ let loop :: Int -> State# RealWorld -> State# RealWorld+ loop !offset st+ | offset < fromIntegral lenArr+ = let IO getV = readWord32OffPtrBE ptr' offset+ !(I# o#) = offset+ in case getV st of+ (# st', W32# v# #) ->+ loop (offset + 1) (writeWord32Array# mba# o# v# st')+ | otherwise = st++ in case unsafeFreezeByteArray# mba# (loop 0 rw1) of+ (# rw2, ba# #) -> (# rw2, UArray 0 (lenArr - 1) (fromIntegral lenArr) ba# #)++{-# SPECIALISE beToLe :: Word32 -> BS.ByteString -> IO (UArray Word32 Word32) #-}+{-# SPECIALISE beToLe :: Int32 -> BS.ByteString -> IO (UArray Int32 Word32) #-}++readInt32BE :: BS.ByteString -> Int -> Int32+readInt32BE bs i = fromIntegral (readWord32BE bs i)+{-# INLINE readInt32BE #-}++readWord32OffPtrBE :: Ptr Word32 -> Int -> IO Word32+readWord32OffPtrBE ptr i = do+#if defined(WORDS_BIGENDIAN)+ readWord32OffPtr ptr i+#else+ byteSwap32 <$> readWord32OffPtr ptr i+#endif++readWord32BE :: BS.ByteString -> Int -> Word32+readWord32BE (BS fptr len) i =+ assert (i >= 0 && i+3 <= len - 1) $+ accursedUnutterablePerformIO $+ unsafeWithForeignPtr fptr $ \ptr -> do+ readWord32OffPtrBE (castPtr ptr) i+{-# INLINE readWord32BE #-}
Codec/Archive/Tar/Write.hs view
@@ -64,10 +64,11 @@ LBS.fromStrict $ BS.take 148 block <> putOct 7 checksum- <> BS.Char8.cons ' ' (BS.drop 156 block)+ <> BS.cons 0x20 (BS.drop 156 block) where block = putHeaderNoChkSum entry- checksum = BS.Char8.foldl' (\x y -> x + ord y) 0 block+ checksum :: Int+ checksum = BS.foldl' (\x y -> x + fromIntegral y) 0 block putHeaderNoChkSum :: Entry -> BS.ByteString putHeaderNoChkSum Entry {@@ -86,33 +87,33 @@ , putOct 8 $ groupId ownership , numField 12 contentSize , putOct 12 modTime- , BS.Char8.replicate 8 ' ' -- dummy checksum+ , BS.replicate 8 0x20 -- dummy checksum , putChar8 typeCode , putPosixString 100 linkTarget ] <> case format of V7Format ->- BS.Char8.replicate 255 '\NUL'- UstarFormat -> BS.Char8.concat+ BS.replicate 255 0x00+ UstarFormat -> BS.concat [ putBString 8 ustarMagic , putString 32 $ ownerName ownership , putString 32 $ groupName ownership , putOct 8 deviceMajor , putOct 8 deviceMinor , putPosixString 155 prefix- , BS.Char8.replicate 12 '\NUL'+ , BS.replicate 12 0x00 ]- GnuFormat -> BS.Char8.concat+ GnuFormat -> BS.concat [ putBString 8 gnuMagic , putString 32 $ ownerName ownership , putString 32 $ groupName ownership , putGnuDev 8 deviceMajor , putGnuDev 8 deviceMinor , putPosixString 155 prefix- , BS.Char8.replicate 12 '\NUL'+ , BS.replicate 12 0x00 ] where- numField :: FieldWidth -> Int64 -> BS.Char8.ByteString+ numField :: FieldWidth -> Int64 -> BS.ByteString numField w n | n >= 0 && n < 1 `shiftL` (3 * (w - 1)) = putOct w n@@ -133,24 +134,24 @@ putGnuDev w n = case content of CharacterDevice _ _ -> putOct w n BlockDevice _ _ -> putOct w n- _ -> BS.Char8.replicate w '\NUL'+ _ -> BS.replicate w 0x00 ustarMagic, gnuMagic :: BS.ByteString-ustarMagic = BS.Char8.pack "ustar\NUL00"-gnuMagic = BS.Char8.pack "ustar \NUL"+ustarMagic = BS.pack [0x75, 0x73, 0x74, 0x61, 0x72, 0x00, 0x30, 0x30] -- ustar\NUL00+gnuMagic = BS.pack [0x75, 0x73, 0x74, 0x61, 0x72, 0x20, 0x20, 0x00] -- ustar \NUL -- * TAR format primitive output type FieldWidth = Int putBString :: FieldWidth -> BS.ByteString -> BS.ByteString-putBString n s = BS.take n s <> BS.Char8.replicate (n - BS.length s) '\NUL'+putBString n s = BS.take n s <> BS.replicate (n - BS.length s) 0x00 putPosixString :: FieldWidth -> PosixString -> BS.ByteString-putPosixString n s = posixToByteString (PS.take n s) <> BS.Char8.replicate (n - PS.length s) '\NUL'+putPosixString n s = posixToByteString (PS.take n s) <> BS.replicate (n - PS.length s) 0x00 putString :: FieldWidth -> String -> BS.ByteString-putString n s = BS.take n (packAscii s) <> BS.Char8.replicate (n - length s) '\NUL'+putString n s = BS.take n (packAscii s) <> BS.replicate (n - length s) 0x00 {-# SPECIALISE putLarge :: FieldWidth -> Int64 -> BS.ByteString #-} putLarge :: (Bits a, Integral a) => FieldWidth -> a -> BS.ByteString@@ -161,9 +162,9 @@ putOct :: (Integral a, Show a) => FieldWidth -> a -> BS.ByteString putOct n x = let octStr = BS.take (n-1) $ BS.Char8.pack $ showOct x ""- in BS.Char8.replicate (n - BS.length octStr - 1) '0'+ in BS.replicate (n - BS.length octStr - 1) 0x30 <> octStr- <> putChar8 '\NUL'+ <> BS.singleton 0x00 putChar8 :: Char -> BS.ByteString putChar8 = BS.Char8.singleton
bench/Main.hs view
@@ -30,6 +30,9 @@ , env loadTarEntries $ \entries -> bench "unpack" (nfIO $ withSystemTempDirectory "tar-bench" $ \baseDir -> Tar.unpack baseDir entries)++ , env (fmap TarIndex.serialise loadTarIndex) $ \tarfile ->+ bench "deserialise index" (nf TarIndex.deserialise tarfile) ] loadTarFile :: IO BS.ByteString
changelog.md view
@@ -1,3 +1,7 @@+## 0.6.3.0 Bodigrim <andrew.lelechenko@gmail.com> June 2024++ * [Speed up `deserialize`](https://github.com/haskell/tar/pull/95).+ ## 0.6.2.0 Bodigrim <andrew.lelechenko@gmail.com> March 2024 * Fix issues with Unicode support in filenames.
tar.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: tar-version: 0.6.2.0+version: 0.6.3.0 license: BSD-3-Clause license-file: LICENSE author: Duncan Coutts <duncan@community.haskell.org>@@ -29,7 +29,7 @@ test/data/symlink.tar extra-doc-files: changelog.md README.md-tested-with: GHC==9.8.1, GHC==9.6.3, GHC==9.4.8, GHC==9.2.8, GHC==9.0.2,+tested-with: GHC==9.10.1, GHC==9.8.2, GHC==9.6.5, GHC==9.4.8, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4 source-repository head@@ -56,7 +56,7 @@ directory >= 1.3.1 && < 1.4, filepath < 1.6, os-string >= 2.0 && < 2.1,- time < 1.13,+ time < 1.15, transformers < 0.7, exposed-modules:@@ -75,6 +75,7 @@ Codec.Archive.Tar.Index.StringTable Codec.Archive.Tar.Index.IntTrie Codec.Archive.Tar.Index.Internal+ Codec.Archive.Tar.Index.Utils other-extensions: BangPatterns