tar 0.6.1.0 → 0.6.2.0
raw patch · 7 files changed
+65/−33 lines, 7 files
Files
- Codec/Archive/Tar/PackAscii.hs +9/−0
- Codec/Archive/Tar/Types.hs +2/−0
- Codec/Archive/Tar/Write.hs +32/−32
- changelog.md +4/−0
- tar.cabal +1/−1
- test/Codec/Archive/Tar/Pack/Tests.hs +16/−0
- test/Properties.hs +1/−0
Codec/Archive/Tar/PackAscii.hs view
@@ -6,10 +6,14 @@ , fromPosixString , posixToByteString , byteToPosixString+ , packAscii ) where import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS.Char8 import qualified Data.ByteString.Short as Sh+import Data.Char+import GHC.Stack import System.IO.Unsafe (unsafePerformIO) import "os-string" System.OsString.Posix (PosixString) import qualified "os-string" System.OsString.Posix as PS@@ -26,3 +30,8 @@ byteToPosixString :: ByteString -> PosixString byteToPosixString = PS.PosixString . Sh.toShort++packAscii :: HasCallStack => FilePath -> BS.Char8.ByteString+packAscii xs+ | all isAscii xs = BS.Char8.pack xs+ | otherwise = error $ "packAscii: only ASCII inputs are supported, but got " ++ xs
Codec/Archive/Tar/Types.hs view
@@ -187,9 +187,11 @@ -- | Ownership information for 'GenEntry'. data Ownership = Ownership { -- | The owner user name. Should be set to @\"\"@ if unknown.+ -- Must not contain non-ASCII characters. ownerName :: String, -- | The owner group name. Should be set to @\"\"@ if unknown.+ -- Must not contain non-ASCII characters. groupName :: String, -- | Numeric owner user id. Should be set to @0@ if unknown.
Codec/Archive/Tar/Write.hs view
@@ -61,15 +61,15 @@ putHeader :: Entry -> LBS.ByteString putHeader entry =- LBS.Char8.pack- $ take 148 block- ++ putOct 7 checksum- ++ ' ' : drop 156 block+ LBS.fromStrict+ $ BS.take 148 block+ <> putOct 7 checksum+ <> BS.Char8.cons ' ' (BS.drop 156 block) where block = putHeaderNoChkSum entry- checksum = foldl' (\x y -> x + ord y) 0 block+ checksum = BS.Char8.foldl' (\x y -> x + ord y) 0 block -putHeaderNoChkSum :: Entry -> String+putHeaderNoChkSum :: Entry -> BS.ByteString putHeaderNoChkSum Entry { entryTarPath = TarPath name prefix, entryContent = content,@@ -79,40 +79,40 @@ entryFormat = format } = - concat+ BS.concat [ putPosixString 100 name , putOct 8 permissions , putOct 8 $ ownerId ownership , putOct 8 $ groupId ownership , numField 12 contentSize , putOct 12 modTime- , replicate 8 ' ' -- dummy checksum+ , BS.Char8.replicate 8 ' ' -- dummy checksum , putChar8 typeCode , putPosixString 100 linkTarget- ] +++ ] <> case format of V7Format ->- replicate 255 '\NUL'- UstarFormat -> concat+ BS.Char8.replicate 255 '\NUL'+ UstarFormat -> BS.Char8.concat [ putBString 8 ustarMagic , putString 32 $ ownerName ownership , putString 32 $ groupName ownership , putOct 8 deviceMajor , putOct 8 deviceMinor , putPosixString 155 prefix- , replicate 12 '\NUL'+ , BS.Char8.replicate 12 '\NUL' ]- GnuFormat -> concat+ GnuFormat -> BS.Char8.concat [ putBString 8 gnuMagic , putString 32 $ ownerName ownership , putString 32 $ groupName ownership , putGnuDev 8 deviceMajor , putGnuDev 8 deviceMinor , putPosixString 155 prefix- , replicate 12 '\NUL'+ , BS.Char8.replicate 12 '\NUL' ] where- numField :: FieldWidth -> Int64 -> String+ numField :: FieldWidth -> Int64 -> BS.Char8.ByteString numField w n | n >= 0 && n < 1 `shiftL` (3 * (w - 1)) = putOct w n@@ -133,7 +133,7 @@ putGnuDev w n = case content of CharacterDevice _ _ -> putOct w n BlockDevice _ _ -> putOct w n- _ -> replicate w '\NUL'+ _ -> BS.Char8.replicate w '\NUL' ustarMagic, gnuMagic :: BS.ByteString ustarMagic = BS.Char8.pack "ustar\NUL00"@@ -143,27 +143,27 @@ type FieldWidth = Int -putBString :: FieldWidth -> BS.ByteString -> String-putBString n s = BS.Char8.unpack (BS.take n s) ++ replicate (n - BS.length s) '\NUL'+putBString :: FieldWidth -> BS.ByteString -> BS.ByteString+putBString n s = BS.take n s <> BS.Char8.replicate (n - BS.length s) '\NUL' -putPosixString :: FieldWidth -> PosixString -> String-putPosixString n s = fromPosixString (PS.take n s) ++ replicate (n - PS.length s) '\NUL'+putPosixString :: FieldWidth -> PosixString -> BS.ByteString+putPosixString n s = posixToByteString (PS.take n s) <> BS.Char8.replicate (n - PS.length s) '\NUL' -putString :: FieldWidth -> String -> String-putString n s = take n s ++ replicate (n - length s) '\NUL'+putString :: FieldWidth -> String -> BS.ByteString+putString n s = BS.take n (packAscii s) <> BS.Char8.replicate (n - length s) '\NUL' -{-# SPECIALISE putLarge :: FieldWidth -> Int64 -> String #-}-putLarge :: (Bits a, Integral a) => FieldWidth -> a -> String-putLarge n0 x0 = '\x80' : reverse (go (n0-1) x0)+{-# SPECIALISE putLarge :: FieldWidth -> Int64 -> BS.ByteString #-}+putLarge :: (Bits a, Integral a) => FieldWidth -> a -> BS.ByteString+putLarge n0 x0 = BS.Char8.pack $ '\x80' : reverse (go (n0-1) x0) where go 0 _ = [] go n x = chr (fromIntegral (x .&. 0xff)) : go (n-1) (x `shiftR` 8) -putOct :: (Integral a, Show a) => FieldWidth -> a -> String+putOct :: (Integral a, Show a) => FieldWidth -> a -> BS.ByteString putOct n x =- let octStr = take (n-1) $ showOct x ""- in replicate (n - length octStr - 1) '0'- ++ octStr- ++ putChar8 '\NUL'+ let octStr = BS.take (n-1) $ BS.Char8.pack $ showOct x ""+ in BS.Char8.replicate (n - BS.length octStr - 1) '0'+ <> octStr+ <> putChar8 '\NUL' -putChar8 :: Char -> String-putChar8 c = [c]+putChar8 :: Char -> BS.ByteString+putChar8 = BS.Char8.singleton
changelog.md view
@@ -1,3 +1,7 @@+## 0.6.2.0 Bodigrim <andrew.lelechenko@gmail.com> March 2024++ * Fix issues with Unicode support in filenames.+ ## 0.6.1.0 Bodigrim <andrew.lelechenko@gmail.com> January 2024 * Support Unicode in filenames (encoded as UTF-8).
tar.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: tar-version: 0.6.1.0+version: 0.6.2.0 license: BSD-3-Clause license-file: LICENSE author: Duncan Coutts <duncan@community.haskell.org>
test/Codec/Archive/Tar/Pack/Tests.hs view
@@ -5,6 +5,7 @@ module Codec.Archive.Tar.Pack.Tests ( prop_roundtrip+ , unit_roundtrip_unicode , unit_roundtrip_symlink , unit_roundtrip_long_symlink , unit_roundtrip_long_filepath@@ -17,6 +18,7 @@ import Data.FileEmbed import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Pack as Pack+import qualified Codec.Archive.Tar.Read as Read import Codec.Archive.Tar.Types (GenEntries(..), Entries, simpleEntry, toTarPath, GenEntry (entryTarPath)) import qualified Codec.Archive.Tar.Unpack as Unpack import qualified Codec.Archive.Tar.Write as Write@@ -153,3 +155,17 @@ let tar :: BL.ByteString = BL.fromStrict $(embedFile "test/data/long-symlink.tar") entries = Tar.foldEntries (:) [] (const []) (Tar.read tar) in Tar.write entries === tar++unit_roundtrip_unicode :: Property+unit_roundtrip_unicode = do+ ioProperty $ withSystemTempDirectory "tar-test" $ \baseDir -> do+ let relFile = "TModula𐐀bA.hs"++ canWriteFile <- try (writeFile (baseDir </> relFile) "foo")+ case canWriteFile of+ Left (e :: IOException) -> pure $ property True+ Right () -> do+ entries <- Pack.pack baseDir [relFile]+ pure $ case Tar.foldlEntries (flip seq) () (Read.read (Write.write entries)) of+ Right{} -> property True+ Left (err, _) -> counterexample (show err) $ property False
test/Properties.hs view
@@ -66,6 +66,7 @@ , testGroup "pack" [ adjustOption (\(QuickCheckMaxRatio n) -> QuickCheckMaxRatio (max n 100)) $ testProperty "roundtrip" Pack.prop_roundtrip,+ testProperty "unicode" Pack.unit_roundtrip_unicode, testProperty "symlink" Pack.unit_roundtrip_symlink, testProperty "long filepath" Pack.unit_roundtrip_long_filepath, testProperty "long symlink" Pack.unit_roundtrip_long_symlink