diff --git a/Codec/Archive/Tar/Entry.hs b/Codec/Archive/Tar/Entry.hs --- a/Codec/Archive/Tar/Entry.hs +++ b/Codec/Archive/Tar/Entry.hs @@ -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) diff --git a/Codec/Archive/Tar/Index/Utils.hs b/Codec/Archive/Tar/Index/Utils.hs --- a/Codec/Archive/Tar/Index/Utils.hs +++ b/Codec/Archive/Tar/Index/Utils.hs @@ -1,4 +1,6 @@ {-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, CPP #-} +{-# OPTIONS_HADDOCK hide #-} + module Codec.Archive.Tar.Index.Utils where import Data.ByteString as BS diff --git a/Codec/Archive/Tar/Pack.hs b/Codec/Archive/Tar/Pack.hs --- a/Codec/Archive/Tar/Pack.hs +++ b/Codec/Archive/Tar/Pack.hs @@ -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 diff --git a/Codec/Archive/Tar/PackAscii.hs b/Codec/Archive/Tar/PackAscii.hs --- a/Codec/Archive/Tar/PackAscii.hs +++ b/Codec/Archive/Tar/PackAscii.hs @@ -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 diff --git a/Codec/Archive/Tar/Types.hs b/Codec/Archive/Tar/Types.hs --- a/Codec/Archive/Tar/Types.hs +++ b/Codec/Archive/Tar/Types.hs @@ -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] diff --git a/Codec/Archive/Tar/Unpack.hs b/Codec/Archive/Tar/Unpack.hs --- a/Codec/Archive/Tar/Unpack.hs +++ b/Codec/Archive/Tar/Unpack.hs @@ -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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +## 0.6.4.0 Bodigrim January 2025 + + * Migrate internals of packing / unpacking to `OsPath`. + * Use `getDirectoryContentsRecursive` from `directory-ospath-streaming`. + ## 0.6.3.0 Bodigrim 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: 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.6.3.0 +version: 0.6.4.0 license: BSD-3-Clause license-file: LICENSE author: Duncan Coutts @@ -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 diff --git a/test/Codec/Archive/Tar/Pack/Tests.hs b/test/Codec/Archive/Tar/Pack/Tests.hs --- a/test/Codec/Archive/Tar/Pack/Tests.hs +++ b/test/Codec/Archive/Tar/Pack/Tests.hs @@ -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