tar 0.7.0.0 → 0.7.1.0
raw patch · 5 files changed
+108/−41 lines, 5 filesdep ~file-iodep ~tasty-benchdep ~time
Dependency ranges changed: file-io, tasty-bench, time
Files
- Codec/Archive/Tar.hs +4/−1
- Codec/Archive/Tar/LongNames.hs +65/−25
- Codec/Archive/Tar/Write.hs +30/−11
- changelog.md +5/−0
- tar.cabal +4/−4
Codec/Archive/Tar.hs view
@@ -112,7 +112,10 @@ -- produces the standard format. read, write,+ writeEntry, write',+ writeEntry',+ writeTrailer, -- * Packing and unpacking files to\/from internal representation -- | These functions are for packing and unpacking portable archives. They@@ -174,7 +177,7 @@ import Codec.Archive.Tar.Read (read, FormatError(..)) import Codec.Archive.Tar.Types (unfoldEntries, foldlEntries, foldEntries, mapEntriesNoFail, mapEntries, Entries, GenEntries(..)) import Codec.Archive.Tar.Unpack (unpack, unpackAndCheck)-import Codec.Archive.Tar.Write (write, write')+import Codec.Archive.Tar.Write (write, writeEntry, write', writeEntry', writeTrailer) import Control.Applicative ((<|>)) import Control.Exception (Exception, throw, catch, SomeException(..))
Codec/Archive/Tar/LongNames.hs view
@@ -94,30 +94,51 @@ -> GenEntries BL.ByteString FilePath FilePath (Either e DecodeLongNamesError) decodeLongNames = go Nothing Nothing where+ isKEntry :: GenEntryContent content linkTarget -> Maybe FilePath+ isKEntry = \case+ OtherEntryType 'K' fn _ ->+ Just $ otherEntryKLPayloadToFilePath fn+ OtherEntryType 'x' fn _+ | Just fp <- lookup (B.pack "linkpath") (parsePaxExtendedHeader fn) ->+ Just $ B.unpack fp+ _ -> Nothing++ isLEntry :: GenEntryContent content linkTarget -> Maybe FilePath+ isLEntry = \case+ OtherEntryType 'L' fn _ ->+ Just $ otherEntryKLPayloadToFilePath fn+ OtherEntryType 'x' fn _+ | Just fp <- lookup (B.pack "path") (parsePaxExtendedHeader fn) ->+ Just $ B.unpack fp+ _ -> Nothing+ go :: Maybe FilePath -> Maybe FilePath -> Entries e -> GenEntries BL.ByteString FilePath FilePath (Either e DecodeLongNamesError) go _ _ (Fail err) = Fail (Left err) go _ _ Done = Done - go Nothing Nothing (Next e rest) = case entryContent e of- OtherEntryType 'K' fn _ ->- go (Just (otherEntryPayloadToFilePath fn)) Nothing rest- OtherEntryType 'L' fn _ ->- go Nothing (Just (otherEntryPayloadToFilePath fn)) rest- _ ->- Next (castEntry e) (go Nothing Nothing rest)+ go Nothing Nothing (Next e rest)+ | Just link <- isKEntry (entryContent e)+ = go (Just link) Nothing rest+ | Just path <- isLEntry (entryContent e)+ = go Nothing (Just path) rest+ | otherwise+ = Next (castEntry e) (go Nothing Nothing rest) - go Nothing (Just path) (Next e rest) = case entryContent e of- OtherEntryType 'K' fn _ ->- go (Just (otherEntryPayloadToFilePath fn)) (Just path) rest- OtherEntryType 'L' _ _ ->- Fail $ Right TwoTypeLEntries- _ -> Next ((castEntry e) { entryTarPath = path }) (go Nothing Nothing rest)+ go Nothing (Just path) (Next e rest)+ | Just link <- isKEntry (entryContent e)+ = go (Just link) (Just path) rest+ | Just{} <- isLEntry (entryContent e)+ = Fail $ Right TwoTypeLEntries+ | otherwise+ = Next ((castEntry e) { entryTarPath = path }) (go Nothing Nothing rest) - go (Just link) Nothing (Next e rest) = case entryContent e of- OtherEntryType 'K' _ _ ->- Fail $ Right TwoTypeKEntries- OtherEntryType 'L' fn _ ->- go (Just link) (Just (otherEntryPayloadToFilePath fn)) rest+ go (Just link) Nothing (Next e rest)+ | Just{} <- isKEntry (entryContent e)+ = Fail $ Right TwoTypeKEntries+ | Just path <- isLEntry (entryContent e)+ = go (Just link) (Just path) rest+ | otherwise+ = case entryContent e of SymbolicLink{} -> Next ((castEntry e) { entryContent = SymbolicLink link }) (go Nothing Nothing rest) HardLink{} ->@@ -125,11 +146,13 @@ _ -> Fail $ Right NoLinkEntryAfterTypeKEntry - go (Just link) (Just path) (Next e rest) = case entryContent e of- OtherEntryType 'K' _ _ ->- Fail $ Right TwoTypeKEntries- OtherEntryType 'L' _ _ ->- Fail $ Right TwoTypeLEntries+ go (Just link) (Just path) (Next e rest)+ | Just{} <- isKEntry (entryContent e)+ = Fail $ Right TwoTypeKEntries+ | Just{} <- isLEntry (entryContent e)+ = Fail $ Right TwoTypeLEntries+ | otherwise+ = case entryContent e of SymbolicLink{} -> Next ((castEntry e) { entryTarPath = path, entryContent = SymbolicLink link }) (go Nothing Nothing rest) HardLink{} ->@@ -137,9 +160,26 @@ _ -> Fail $ Right NoLinkEntryAfterTypeKEntry -otherEntryPayloadToFilePath :: BL.ByteString -> FilePath-otherEntryPayloadToFilePath =+otherEntryKLPayloadToFilePath :: BL.ByteString -> FilePath+otherEntryKLPayloadToFilePath = fromPosixString . byteToPosixString . B.takeWhile (/= '\0') . BL.toStrict++parsePaxExtendedHeader :: BL.ByteString -> [(B.ByteString, B.ByteString)]+parsePaxExtendedHeader xs+ | BL.null xs = []+ | otherwise = case BL.readInt xs of+ Nothing -> corrupted+ Just (n, ys) -> let (zs, xs') = BL.splitAt (fromIntegral (n - length (show n))) ys in+ case B.uncons (BL.toStrict zs) of+ Just (' ', us) -> case B.unsnoc us of+ Just (vs, '\n') -> let (key, value') = B.span (/= '=') vs in+ case B.uncons value' of+ Just ('=', value) -> (key, value) : parsePaxExtendedHeader xs'+ _ -> corrupted+ _ -> corrupted+ _ -> corrupted+ where+ corrupted = [] -- let's be permissive castEntry :: Entry -> GenEntry BL.ByteString FilePath FilePath castEntry e = e
Codec/Archive/Tar/Write.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE PackageImports #-} {-# OPTIONS_HADDOCK hide #-}+{- HLINT ignore "Avoid restricted function" -} ----------------------------------------------------------------------------- -- | -- Module : Codec.Archive.Tar.Write@@ -12,7 +13,13 @@ -- Portability : portable -- ------------------------------------------------------------------------------module Codec.Archive.Tar.Write (write, write') where+module Codec.Archive.Tar.Write+ ( write+ , writeEntry+ , write'+ , writeEntry'+ , writeTrailer+ ) where import Codec.Archive.Tar.PackAscii import Codec.Archive.Tar.Types@@ -41,14 +48,20 @@ -- * The conversion is done lazily. -- write :: [Entry] -> LBS.ByteString-write es = LBS.concat $ map putEntry es ++ [LBS.replicate (512*2) 0]+write es = LBS.concat $ map writeEntry es ++ [writeTrailer] -- | Like 'write' but for 'GenEntry' with 'OsPath' as contents. -- -- @since 0.7.0.0 write' :: [GenEntry OsPath TarPath LinkTarget] -> IO LBS.ByteString-write' es = interleavedByteStringConcat $ map putEntry' es ++ [pure $ LBS.replicate (512*2) 0]+write' es = interleavedByteStringConcat $ map writeEntry' es ++ [pure writeTrailer] +-- | Standard TAR trailer of two empty blocks, put it at the end of any archive.+--+-- @since 0.7.1.0+writeTrailer :: LBS.ByteString+writeTrailer = LBS.replicate (512*2) 0+ interleavedByteStringConcat :: [IO LBS.ByteString] -> IO LBS.ByteString interleavedByteStringConcat [] = return LBS.empty interleavedByteStringConcat (x:xs) = do@@ -56,19 +69,22 @@ ys <- unsafeInterleaveIO (interleavedByteStringConcat xs) return (LBS.append y ys) -putEntry :: Entry -> LBS.ByteString-putEntry entry = case entryContent entry of+-- | Convert an entry to its representation in TAR format.+--+-- @since 0.7.1.0+writeEntry :: Entry -> LBS.ByteString+writeEntry entry = case entryContent entry of NormalFile content size -- size field is 12 bytes long, so in octal format (see 'putOct') -- it can hold numbers up to 8Gb | size >= 1 `shiftL` (3 * (12 -1)) , entryFormat entry == V7Format- -> error "putEntry: support for files over 8Gb is a Ustar extension"+ -> error "writeEntry: support for files over 8Gb is a Ustar extension" | otherwise -> LBS.concat [ header, content, padding size ] OtherEntryType 'K' _ _- | entryFormat entry /= GnuFormat -> error "putEntry: long symlink support is a GNU extension"+ | entryFormat entry /= GnuFormat -> error "writeEntry: long symlink support is a GNU extension" OtherEntryType 'L' _ _- | entryFormat entry /= GnuFormat -> error "putEntry: long filename support is a GNU extension"+ | entryFormat entry /= GnuFormat -> error "writeEntry: long filename support is a GNU extension" OtherEntryType _ content size -> LBS.concat [ header, content, padding size ] _ -> header where@@ -76,8 +92,11 @@ padding size = LBS.replicate paddingSize 0 where paddingSize = fromIntegral (negate size `mod` 512) -putEntry' :: GenEntry OsPath TarPath LinkTarget -> IO LBS.ByteString-putEntry' entry' = do+-- | Convert an entry to its representation in TAR format.+--+-- @since 0.7.1.0+writeEntry' :: GenEntry OsPath TarPath LinkTarget -> IO LBS.ByteString+writeEntry' entry' = do entryContent' <- case entryContent entry' of NormalFile path size -> do content <- defaultRead size path@@ -91,7 +110,7 @@ NamedPipe -> return NamedPipe OtherEntryType typeCode lbs fileSize -> return (OtherEntryType typeCode lbs fileSize) - return (putEntry entry' { entryContent = entryContent' })+ return (writeEntry entry' { entryContent = entryContent' }) putHeader :: Entry -> LBS.ByteString putHeader entry =
changelog.md view
@@ -1,3 +1,8 @@+## 0.7.1.0 Bodigrim <andrew.lelechenko@gmail.com> April 2026++ * Support long file paths and symlinks in PAX format.+ * Export `writeEntry`, `writeEntry'` and `writeTrailer`.+ ## 0.7.0.0 Bodigrim <andrew.lelechenko@gmail.com> September 2025 This release fixes a long-standing issue with exhaustion of file handles
tar.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: tar-version: 0.7.0.0+version: 0.7.1.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.14.1, GHC==9.12.2, GHC==9.10.2, GHC==9.8.4,+tested-with: GHC ==9.14.1, GHC==9.12.4, GHC==9.10.3, GHC==9.8.4, GHC==9.6.7, GHC==9.4.8, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5 @@ -54,8 +54,8 @@ bytestring >= 0.10 && < 0.13, containers >= 0.2 && < 0.9, deepseq >= 1.1 && < 1.6,- directory >= 1.3.1 && < 1.4,- directory-ospath-streaming >= 0.2.1 && < 0.3,+ directory >= 1.3.8.0 && < 1.4,+ directory-ospath-streaming >= 0.2.1 && < 0.4, file-io < 0.2, filepath >= 1.4.100 && < 1.6, os-string >= 2.0 && < 2.1,