tar 0.6.3.0 → 0.6.4.0
raw patch · 9 files changed
+179/−121 lines, 9 filesdep +directory-ospath-streamingdep +file-iodep ~basedep ~containersdep ~directory
Dependencies added: directory-ospath-streaming, file-io
Dependency ranges changed: base, containers, directory, filepath, tasty-bench, time
Files
- Codec/Archive/Tar/Entry.hs +7/−0
- Codec/Archive/Tar/Index/Utils.hs +2/−0
- Codec/Archive/Tar/Pack.hs +58/−75
- Codec/Archive/Tar/PackAscii.hs +13/−0
- Codec/Archive/Tar/Types.hs +20/−3
- Codec/Archive/Tar/Unpack.hs +39/−25
- changelog.md +6/−0
- tar.cabal +11/−7
- test/Codec/Archive/Tar/Pack/Tests.hs +23/−11
Codec/Archive/Tar/Entry.hs view
@@ -22,6 +22,9 @@ -- > import qualified Codec.Archive.Tar.Entry as Tar -- -----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+ module Codec.Archive.Tar.Entry ( -- * Tar entry and associated types@@ -58,6 +61,9 @@ packFileEntry, packDirectoryEntry, packSymlinkEntry,+#if __GLASGOW_HASKELL__ >= 908+ {-# DEPRECATED "The re-export will be removed in future releases of tar, use directory-ospath-streaming package directly " #-}+#endif getDirectoryContentsRecursive, -- * TarPath type@@ -77,3 +83,4 @@ import Codec.Archive.Tar.Types import Codec.Archive.Tar.Pack+import System.Directory.OsPath.Streaming (getDirectoryContentsRecursive)
Codec/Archive/Tar/Index/Utils.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, CPP #-}+{-# OPTIONS_HADDOCK hide #-}+ module Codec.Archive.Tar.Index.Utils where import Data.ByteString as BS
Codec/Archive/Tar/Pack.hs view
@@ -1,9 +1,11 @@-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+ {-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Avoid restricted function" #-}+ ----------------------------------------------------------------------------- -- | -- Module : Codec.Archive.Tar@@ -23,33 +25,33 @@ packDirectoryEntry, packSymlinkEntry, longLinkEntry,-- getDirectoryContentsRecursive, ) where import Codec.Archive.Tar.LongNames+import Codec.Archive.Tar.PackAscii (filePathToOsPath, osPathToFilePath) import Codec.Archive.Tar.Types-import Control.Monad (join, when, forM, (>=>))++import Data.Bifunctor (bimap) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Foldable-import System.FilePath- ( (</>) )-import qualified System.FilePath as FilePath.Native- ( addTrailingPathSeparator, hasTrailingPathSeparator, splitDirectories )-import System.Directory- ( listDirectory, doesDirectoryExist, getModificationTime+import System.File.OsPath+import System.OsPath+ ( OsPath, (</>) )+import qualified System.OsPath as FilePath.Native+ ( addTrailingPathSeparator, hasTrailingPathSeparator )+import System.Directory.OsPath+ ( doesDirectoryExist, getModificationTime , pathIsSymbolicLink, getSymbolicLinkTarget , Permissions(..), getPermissions, getFileSize )-import Data.Time.Clock- ( UTCTime )+import qualified System.Directory.OsPath.Types as FT+import System.Directory.OsPath.Streaming (getDirectoryContentsRecursive) import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds ) import System.IO- ( IOMode(ReadMode), openBinaryFile, hFileSize )+ ( IOMode(ReadMode), hFileSize ) import System.IO.Unsafe (unsafeInterleaveIO) import Control.Exception (throwIO, SomeException)-import Codec.Archive.Tar.Check.Internal (checkEntrySecurity) -- | Creates a tar archive from a list of directory or files. Any directories -- specified will have their contents included recursively. Paths in the@@ -81,40 +83,46 @@ -> FilePath -- ^ Base directory -> [FilePath] -- ^ Files and directories to pack, relative to the base dir -> IO [Entry]-packAndCheck secCB baseDir relpaths = do+packAndCheck secCB (filePathToOsPath -> baseDir) (map filePathToOsPath -> relpaths) = do paths <- preparePaths baseDir relpaths- entries <- packPaths baseDir paths+ entries' <- packPaths baseDir paths+ let entries = map (bimap osPathToFilePath osPathToFilePath) entries' traverse_ (maybe (pure ()) throwIO . secCB) entries pure $ concatMap encodeLongNames entries -preparePaths :: FilePath -> [FilePath] -> IO [FilePath]+preparePaths :: OsPath -> [OsPath] -> IO [OsPath] preparePaths baseDir = fmap concat . interleave . map go where+ go :: OsPath -> IO [OsPath] go relpath = do let abspath = baseDir </> relpath isDir <- doesDirectoryExist abspath isSymlink <- pathIsSymbolicLink abspath if isDir && not isSymlink then do entries <- getDirectoryContentsRecursive abspath- let entries' = map (relpath </>) entries- return $ if null relpath+ let entries' = map ((relpath </>) . addSeparatorIfDir) entries+ return $ if relpath == mempty then entries' else FilePath.Native.addTrailingPathSeparator relpath : entries' else return [relpath] + addSeparatorIfDir (fn, ty) = case ty of+ FT.Directory{} -> FilePath.Native.addTrailingPathSeparator fn+ _ -> fn+ -- | Pack paths while accounting for overlong filepaths. packPaths- :: FilePath- -> [FilePath]- -> IO [GenEntry FilePath FilePath]+ :: OsPath+ -> [OsPath]+ -> IO [GenEntry OsPath OsPath] packPaths baseDir paths = interleave $ flip map paths $ \relpath -> do let isDir = FilePath.Native.hasTrailingPathSeparator abspath abspath = baseDir </> relpath isSymlink <- pathIsSymbolicLink abspath let mkEntry- | isSymlink = packSymlinkEntry- | isDir = packDirectoryEntry- | otherwise = packFileEntry+ | isSymlink = packSymlinkEntry'+ | isDir = packDirectoryEntry'+ | otherwise = packFileEntry' mkEntry abspath relpath interleave :: [IO a] -> IO [a]@@ -138,7 +146,13 @@ :: FilePath -- ^ Full path to find the file on the local disk -> tarPath -- ^ Path to use for the tar 'GenEntry' in the archive -> IO (GenEntry tarPath linkTarget)-packFileEntry filepath tarpath = do+packFileEntry = packFileEntry' . filePathToOsPath++packFileEntry'+ :: OsPath -- ^ Full path to find the file on the local disk+ -> tarPath -- ^ Path to use for the tar 'GenEntry' in the archive+ -> IO (GenEntry tarPath linkTarget)+packFileEntry' filepath tarpath = do mtime <- getModTime filepath perms <- getPermissions filepath -- Get file size without opening it.@@ -148,7 +162,7 @@ -- If file is short enough, just read it strictly -- so that no file handle dangles around indefinitely. then do- cnt <- B.readFile filepath+ cnt <- readFile' filepath pure (BL.fromStrict cnt, fromIntegral $ B.length cnt) else do hndl <- openBinaryFile filepath ReadMode@@ -178,7 +192,13 @@ :: FilePath -- ^ Full path to find the file on the local disk -> tarPath -- ^ Path to use for the tar 'GenEntry' in the archive -> IO (GenEntry tarPath linkTarget)-packDirectoryEntry filepath tarpath = do+packDirectoryEntry = packDirectoryEntry' . filePathToOsPath++packDirectoryEntry'+ :: OsPath -- ^ Full path to find the file on the local disk+ -> tarPath -- ^ Path to use for the tar 'GenEntry' in the archive+ -> IO (GenEntry tarPath linkTarget)+packDirectoryEntry' filepath tarpath = do mtime <- getModTime filepath return (directoryEntry tarpath) { entryTime = mtime@@ -186,59 +206,22 @@ -- | Construct a tar entry based on a local symlink. ----- This automatically checks symlink safety via 'checkEntrySecurity'.--- -- @since 0.6.0.0 packSymlinkEntry :: FilePath -- ^ Full path to find the file on the local disk -> tarPath -- ^ Path to use for the tar 'GenEntry' in the archive -> IO (GenEntry tarPath FilePath)-packSymlinkEntry filepath tarpath = do+packSymlinkEntry = ((fmap (fmap osPathToFilePath) .) . packSymlinkEntry') . filePathToOsPath++packSymlinkEntry'+ :: OsPath -- ^ Full path to find the file on the local disk+ -> tarPath -- ^ Path to use for the tar 'GenEntry' in the archive+ -> IO (GenEntry tarPath OsPath)+packSymlinkEntry' filepath tarpath = do linkTarget <- getSymbolicLinkTarget filepath pure $ symlinkEntry tarpath linkTarget --- | This is a utility function, much like 'listDirectory'. The--- difference is that it includes the contents of subdirectories.------ The paths returned are all relative to the top directory. Directory paths--- are distinguishable by having a trailing path separator--- (see 'FilePath.Native.hasTrailingPathSeparator').------ All directories are listed before the files that they contain. Amongst the--- contents of a directory, subdirectories are listed after normal files. The--- overall result is that files within a directory will be together in a single--- contiguous group. This tends to improve file layout and IO performance when--- creating or extracting tar archives.------ * This function returns results lazily. Subdirectories are not scanned--- until the files entries in the parent directory have been consumed.--- If the source directory structure changes before the result is used in full,--- the behaviour is undefined.----getDirectoryContentsRecursive :: FilePath -> IO [FilePath]-getDirectoryContentsRecursive dir0 =- fmap (drop 1) (recurseDirectories dir0 [""])--recurseDirectories :: FilePath -> [FilePath] -> IO [FilePath]-recurseDirectories _ [] = return []-recurseDirectories base (dir:dirs) = unsafeInterleaveIO $ do- (files, dirs') <- collect [] [] =<< listDirectory (base </> dir)-- files' <- recurseDirectories base (dirs' ++ dirs)- return (dir : files ++ files')-- where- collect files dirs' [] = return (reverse files, reverse dirs')- collect files dirs' (entry:entries) = do- let dirEntry = dir </> entry- dirEntry' = FilePath.Native.addTrailingPathSeparator dirEntry- isDirectory <- doesDirectoryExist (base </> dirEntry)- isSymlink <- pathIsSymbolicLink (base </> dirEntry)- if isDirectory && not isSymlink- then collect files (dirEntry':dirs') entries- else collect (dirEntry:files) dirs' entries--getModTime :: FilePath -> IO EpochTime+getModTime :: OsPath -> IO EpochTime getModTime path = do -- The directory package switched to the new time package t <- getModificationTime path
Codec/Archive/Tar/PackAscii.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE PackageImports #-}+ {-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS_GHC -Wno-deprecations #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Avoid restricted function" #-} module Codec.Archive.Tar.PackAscii ( toPosixString@@ -7,6 +11,8 @@ , posixToByteString , byteToPosixString , packAscii+ , filePathToOsPath+ , osPathToFilePath ) where import Data.ByteString (ByteString)@@ -16,6 +22,7 @@ import GHC.Stack import System.IO.Unsafe (unsafePerformIO) import "os-string" System.OsString.Posix (PosixString)+import qualified "filepath" System.OsPath as OS import qualified "os-string" System.OsString.Posix as PS import qualified "os-string" System.OsString.Internal.Types as PS @@ -35,3 +42,9 @@ packAscii xs | all isAscii xs = BS.Char8.pack xs | otherwise = error $ "packAscii: only ASCII inputs are supported, but got " ++ xs++filePathToOsPath :: FilePath -> OS.OsPath+filePathToOsPath = unsafePerformIO . OS.encodeFS++osPathToFilePath :: OS.OsPath -> FilePath+osPathToFilePath = unsafePerformIO . OS.decodeFS
Codec/Archive/Tar/Types.hs view
@@ -76,6 +76,7 @@ unfoldEntriesM, ) where +import Data.Bifunctor (Bifunctor, bimap) import Data.Int (Int64) import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid (Monoid(..))@@ -145,8 +146,19 @@ -- | The tar format the archive is using. entryFormat :: !Format }- deriving (Eq, Show)+ deriving+ ( Eq+ , Show+ , Functor -- ^ @since 0.6.4.0+ ) +-- | @since 0.6.4.0+instance Bifunctor GenEntry where+ bimap f g e = e+ { entryTarPath = f (entryTarPath e)+ , entryContent = fmap g (entryContent e)+ }+ -- | Monomorphic tar archive entry, ready for serialization / deserialization. -- type Entry = GenEntry TarPath LinkTarget@@ -178,7 +190,12 @@ | NamedPipe | OtherEntryType {-# UNPACK #-} !TypeCode LBS.ByteString {-# UNPACK #-} !FileSize- deriving (Eq, Ord, Show)+ deriving+ ( Eq+ , Ord+ , Show+ , Functor -- ^ @since 0.6.4.0+ ) -- | Monomorphic content of a tar archive entry, -- ready for serialization / deserialization.@@ -437,7 +454,7 @@ toTarPath isDir path = case toTarPath' path' of FileNameEmpty -> Left "File name empty" FileNameOK tarPath -> Right tarPath- FileNameTooLong{} -> Left "File name too long"+ FileNameTooLong{} -> Left $ "File name too long: " ++ path' where path' = if isDir && not (FilePath.Native.hasTrailingPathSeparator path) then path <> [FilePath.Native.pathSeparator]
Codec/Archive/Tar/Unpack.hs view
@@ -3,9 +3,10 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use for_" #-}+{-# HLINT ignore "Avoid restricted function" #-} ----------------------------------------------------------------------------- -- |@@ -27,6 +28,7 @@ import Codec.Archive.Tar.Types import Codec.Archive.Tar.Check import Codec.Archive.Tar.LongNames+import Codec.Archive.Tar.PackAscii (filePathToOsPath) import Data.Bits ( testBit )@@ -34,11 +36,13 @@ import Data.Maybe ( fromMaybe ) import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString.Lazy as BS-import System.FilePath- ( (</>) )-import qualified System.FilePath as FilePath.Native+import Prelude hiding (writeFile)+import System.File.OsPath+import System.OsPath+ ( OsPath, (</>) )+import qualified System.OsPath as FilePath.Native ( takeDirectory )-import System.Directory+import System.Directory.OsPath ( createDirectoryIfMissing, copyFile, setPermissions,@@ -110,7 +114,7 @@ -> Entries e -- ^ Entries to upack -> IO ()-unpackAndCheck secCB baseDir entries = do+unpackAndCheck secCB (filePathToOsPath -> baseDir) entries = do let resolvedEntries = decodeLongNames entries uEntries <- unpackEntries [] resolvedEntries let (hardlinks, symlinks) = partition (\(_, _, x) -> x) uEntries@@ -123,11 +127,11 @@ -- files all over the place. unpackEntries :: Exception e- => [(FilePath, FilePath, Bool)]+ => [(OsPath, OsPath, Bool)] -- ^ links (path, link, isHardLink) -> GenEntries FilePath FilePath (Either e DecodeLongNamesError) -- ^ entries- -> IO [(FilePath, FilePath, Bool)]+ -> IO [(OsPath, OsPath, Bool)] unpackEntries _ (Fail err) = either throwIO throwIO err unpackEntries links Done = return links unpackEntries links (Next entry es) = do@@ -154,31 +158,37 @@ BlockDevice{} -> unpackEntries links es NamedPipe -> unpackEntries links es - extractFile permissions (fromFilePathToNative -> path) content mtime = do+ extractFile :: Permissions -> FilePath -> BS.ByteString -> EpochTime -> IO ()+ extractFile permissions (filePathToNativeOsPath -> 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+ writeFile absPath content setOwnerPermissions absPath permissions setModTime absPath mtime where absDir = baseDir </> FilePath.Native.takeDirectory path absPath = baseDir </> path - extractDir (fromFilePathToNative -> path) mtime = do+ extractDir :: FilePath -> EpochTime -> IO ()+ extractDir (filePathToNativeOsPath -> path) mtime = do createDirectoryIfMissing True absPath setModTime absPath mtime where absPath = baseDir </> path - saveLink isHardLink (fromFilePathToNative -> path) (fromFilePathToNative -> link) links- = seq (length path)- $ seq (length link)- $ (path, link, isHardLink):links-+ saveLink+ :: t+ -> FilePath+ -> FilePath+ -> [(OsPath, OsPath, t)]+ -> [(OsPath, OsPath, t)]+ saveLink isHardLink (filePathToNativeOsPath -> path) (filePathToNativeOsPath -> link) =+ path `seq` link `seq` ((path, link, isHardLink) :) -- for hardlinks, we just copy+ handleHardLinks :: [(OsPath, OsPath, t)] -> IO () handleHardLinks = mapM_ $ \(relPath, relLinkTarget, _) -> let absPath = baseDir </> relPath -- hard links link targets are always "absolute" paths in@@ -197,6 +207,7 @@ -- This error handling isn't too fine grained and maybe should be -- platform specific, but this way it might catch erros on unix even on -- FAT32 fuse mounted volumes.+ handleSymlinks :: [(OsPath, OsPath, c)] -> IO () handleSymlinks = mapM_ $ \(relPath, relLinkTarget, _) -> let absPath = baseDir </> relPath -- hard links link targets are always "absolute" paths in@@ -220,10 +231,13 @@ else throwIO e ) +filePathToNativeOsPath :: FilePath -> OsPath+filePathToNativeOsPath = filePathToOsPath . fromFilePathToNative+ -- | Recursively copy the contents of one directory to another path. -- -- This is a rip-off of Cabal library.-copyDirectoryRecursive :: FilePath -> FilePath -> IO ()+copyDirectoryRecursive :: OsPath -> OsPath -> IO () copyDirectoryRecursive srcDir destDir = do srcFiles <- getDirectoryContentsRecursive srcDir copyFilesWith copyFile destDir [ (srcDir, f)@@ -231,8 +245,8 @@ where -- | Common implementation of 'copyFiles', 'installOrdinaryFiles', -- 'installExecutableFiles' and 'installMaybeExecutableFiles'.- copyFilesWith :: (FilePath -> FilePath -> IO ())- -> FilePath -> [(FilePath, FilePath)] -> IO ()+ copyFilesWith :: (OsPath -> OsPath -> IO ())+ -> OsPath -> [(OsPath, OsPath)] -> IO () copyFilesWith doCopy targetDir srcFiles = do -- Create parent directories for everything@@ -251,10 +265,10 @@ -- parent directories. The list is generated lazily so is not well defined if -- the source directory structure changes before the list is used. --- getDirectoryContentsRecursive :: FilePath -> IO [FilePath]- getDirectoryContentsRecursive topdir = recurseDirectories [""]+ getDirectoryContentsRecursive :: OsPath -> IO [OsPath]+ getDirectoryContentsRecursive topdir = recurseDirectories [mempty] where- recurseDirectories :: [FilePath] -> IO [FilePath]+ recurseDirectories :: [OsPath] -> IO [OsPath] recurseDirectories [] = return [] recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do (files, dirs') <- collect [] [] =<< listDirectory (topdir </> dir)@@ -271,7 +285,7 @@ then collect files (dirEntry:dirs') entries else collect (dirEntry:files) dirs' entries -setModTime :: FilePath -> EpochTime -> IO ()+setModTime :: OsPath -> EpochTime -> IO () setModTime path t = setModificationTime path (posixSecondsToUTCTime (fromIntegral t)) `Exception.catch` \e -> case ioeGetErrorType e of@@ -281,7 +295,7 @@ InvalidArgument -> return () _ -> throwIO e -setOwnerPermissions :: FilePath -> Permissions -> IO ()+setOwnerPermissions :: OsPath -> Permissions -> IO () setOwnerPermissions path permissions = setPermissions path ownerPermissions where@@ -291,5 +305,5 @@ setOwnerReadable (testBit permissions 8) $ setOwnerWritable (testBit permissions 7) $ setOwnerExecutable (testBit permissions 6) $- setOwnerSearchable (testBit permissions 6) $+ setOwnerSearchable (testBit permissions 6) emptyPermissions
changelog.md view
@@ -1,3 +1,8 @@+## 0.6.4.0 Bodigrim <andrew.lelechenko@gmail.com> January 2025++ * Migrate internals of packing / unpacking to `OsPath`.+ * Use `getDirectoryContentsRecursive` from `directory-ospath-streaming`.+ ## 0.6.3.0 Bodigrim <andrew.lelechenko@gmail.com> June 2024 * [Speed up `deserialize`](https://github.com/haskell/tar/pull/95).@@ -40,6 +45,7 @@ * [`cabal-install`](https://github.com/haskell/cabal/commit/51e6483f95ecb4f395dce36e47af296902a75143) * [`ghcup`](https://github.com/haskell/ghcup-hs/commit/6ae312c1f9dd054546e4afe4c969c37cd54b09a9) * [`hackage-server`](https://github.com/haskell/hackage-server/commit/6b71d1659500aba50b6a1e48aa53039046720af8)+ * [`hedgehog-extras`](https://github.com/input-output-hk/hedgehog-extras/commit/1d4468ce4e74e7a4b3c1fec5c1b21360051a3e72) Bug fixes:
tar.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: tar-version: 0.6.3.0+version: 0.6.4.0 license: BSD-3-Clause license-file: LICENSE author: Duncan Coutts <duncan@community.haskell.org>@@ -29,8 +29,9 @@ test/data/symlink.tar extra-doc-files: changelog.md README.md-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+tested-with: GHC==9.12.1, GHC==9.10.1, GHC==9.8.4,+ 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 source-repository head type: git@@ -48,13 +49,15 @@ library tar-internal default-language: Haskell2010- build-depends: base >= 4.11 && < 5,+ build-depends: base >= 4.12 && < 5, array < 0.6, bytestring >= 0.10 && < 0.13, containers >= 0.2 && < 0.8, deepseq >= 1.1 && < 1.6, directory >= 1.3.1 && < 1.4,- filepath < 1.6,+ directory-ospath-streaming >= 0.2.1 && < 0.3,+ file-io < 0.2,+ filepath >= 1.4.100 && < 1.6, os-string >= 2.0 && < 2.1, time < 1.15, transformers < 0.7,@@ -96,12 +99,13 @@ containers, deepseq, directory >= 1.2,+ directory-ospath-streaming, file-embed, filepath, QuickCheck == 2.*, tar-internal, tasty >= 0.10 && <1.6,- tasty-quickcheck >= 0.8 && <0.11,+ tasty-quickcheck >= 0.8 && <1, temporary < 1.4, time if impl(ghc < 9.0)@@ -143,4 +147,4 @@ deepseq, temporary < 1.4, time,- tasty-bench < 0.4+ tasty-bench >= 0.4 && < 0.5
test/Codec/Archive/Tar/Pack/Tests.hs view
@@ -3,6 +3,9 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Avoid restricted function" #-}+ module Codec.Archive.Tar.Pack.Tests ( prop_roundtrip , unit_roundtrip_unicode@@ -18,14 +21,17 @@ import Data.FileEmbed import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Pack as Pack+import Codec.Archive.Tar.PackAscii (filePathToOsPath) 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 import Control.Exception+import qualified Data.List as L import Data.List.NonEmpty (NonEmpty(..)) import GHC.IO.Encoding import System.Directory+import System.Directory.OsPath.Streaming (getDirectoryContentsRecursive) import System.FilePath import qualified System.FilePath.Posix as Posix import qualified System.Info@@ -46,8 +52,8 @@ -- | Write a single file, deeply buried within nested folders; -- pack and unpack; read back and compare results.-prop_roundtrip :: [String] -> String -> Property-prop_roundtrip xss cnt+prop_roundtrip :: Int -> [String] -> String -> Property+prop_roundtrip n' xss cnt | x : xs <- filter (not . null) $ map mkFilePath xss = ioProperty $ withSystemTempDirectory "tar-test" $ \baseDir -> do file : dirs <- pure $ trimUpToMaxPathLength baseDir (x : xs)@@ -56,10 +62,17 @@ absDir = baseDir </> relDir relFile = relDir </> file absFile = absDir </> file- errMsg = "relDir = " ++ relDir ++- "\nabsDir = " ++ absDir ++- "\nrelFile = " ++ relFile ++- "\nabsFile = " ++ absFile+ n = n' `mod` (length dirs + 1)+ (target, expectedFileNames) = case n of+ 0 -> (relFile, [relFile])+ _ -> (joinPath $ take (n - 1) dirs,+ map (addTrailingPathSeparator . joinPath)+ (drop (max 1 (n - 1)) $ L.inits dirs) ++ [relFile])+ errMsg = "relDir = '" ++ relDir ++ "'" +++ "\nabsDir = '" ++ absDir ++ "'" +++ "\nrelFile = '" ++ relFile ++ "'" +++ "\nabsFile = '" ++ absFile ++ "'" +++ "\ntarget = '" ++ target ++ "'" -- Not all filesystems allow paths to contain arbitrary Unicode. -- E. g., at the moment of writing Apple FS does not support characters@@ -72,9 +85,8 @@ case canWriteFile of Left (e :: IOException) -> discard Right () -> counterexample errMsg <$> do- -- Forcing the result, otherwise lazy IO misbehaves.- !entries <- Pack.pack baseDir [relFile] >>= evaluate . force+ !entries <- Pack.pack baseDir [target] >>= evaluate . force let fileNames = map (map (\c -> if c == Posix.pathSeparator then pathSeparator else c))@@ -82,7 +94,7 @@ -- decodeLongNames produces FilePath with POSIX path separators $ Tar.decodeLongNames $ foldr Next Done entries - if [relFile] /= fileNames then pure ([relFile] === fileNames) else do+ if expectedFileNames /= fileNames then pure (expectedFileNames === fileNames) else do -- Try hard to clean up removeFile absFile@@ -99,8 +111,8 @@ pure $ cnt === cnt' else do -- Forcing the result, otherwise lazy IO misbehaves.- recFiles <- Pack.getDirectoryContentsRecursive baseDir >>= evaluate . force- pure $ counterexample ("File " ++ absFile ++ " does not exist; instead found\n" ++ unlines recFiles) False+ recFiles <- getDirectoryContentsRecursive (filePathToOsPath baseDir) >>= evaluate . force+ pure $ counterexample ("File " ++ absFile ++ " does not exist; instead found\n" ++ unlines (map show recFiles)) False | otherwise = discard