diff --git a/Codec/Archive/Tar.hs b/Codec/Archive/Tar.hs --- a/Codec/Archive/Tar.hs +++ b/Codec/Archive/Tar.hs @@ -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(..)) diff --git a/Codec/Archive/Tar/LongNames.hs b/Codec/Archive/Tar/LongNames.hs --- a/Codec/Archive/Tar/LongNames.hs +++ b/Codec/Archive/Tar/LongNames.hs @@ -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 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 @@ -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 = diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +## 0.7.1.0 Bodigrim April 2026 + + * Support long file paths and symlinks in PAX format. + * Export `writeEntry`, `writeEntry'` and `writeTrailer`. + ## 0.7.0.0 Bodigrim September 2025 This release fixes a long-standing issue with exhaustion of file handles diff --git a/tar.cabal b/tar.cabal --- a/tar.cabal +++ b/tar.cabal @@ -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 @@ -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,