Test pack-unpack with long file names

tar.cabal

@@ -92,6 +92,7 @@ test-suite properties
                  tar-internal,
                  tasty            >= 0.10 && <1.6,
                  tasty-quickcheck >= 0.8  && <0.11,
+                 temporary < 1.4,
                  time
   if impl(ghc < 9.0)
     build-depends: bytestring-handle < 0.2
@@ -105,6 +106,7 @@ test-suite properties
     Codec.Archive.Tar.Index.Tests
     Codec.Archive.Tar.Index.IntTrie.Tests
     Codec.Archive.Tar.Index.StringTable.Tests
+    Codec.Archive.Tar.Pack.Tests
     Codec.Archive.Tar.Types.Tests
 
   other-extensions:

test/Codec/Archive/Tar/Pack/Tests.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE BangPatterns #-}
+
+module Codec.Archive.Tar.Pack.Tests
+  ( prop_roundtrip
+  ) where
+
+import qualified Codec.Archive.Tar.Pack as Pack
+import Codec.Archive.Tar.Types (Entries(..))
+import qualified Codec.Archive.Tar.Unpack as Unpack
+import Control.Exception
+import System.Directory
+import System.FilePath
+import System.IO.Temp
+import Test.Tasty.QuickCheck
+
+-- | Write a single file, deeply buried within nested folders;
+-- pack and unpack; read back and compare results.
+prop_roundtrip :: [ASCIIString] -> String -> Property
+prop_roundtrip xss cnt
+  | file : dirs <- filter (not . null) $ map mkFilePath xss
+  -- Filenames longer than 1024 characters throw
+  -- "withFile: invalid argument (File name too long)",
+  -- at least on Mac OS
+  , length (joinPath dirs </> file) < 900
+  = ioProperty $ withSystemTempDirectory "tar-test" $ \baseDir -> do
+    let relDir = joinPath dirs
+        absDir = baseDir </> relDir
+        relFile = relDir </> file
+        absFile = absDir </> file
+    createDirectoryIfMissing True absDir
+    writeFile absFile cnt
+    -- Forcing the result, otherwise lazy IO misbehaves.
+    !entries <- Pack.pack baseDir [relFile]
+
+    -- Try hard to clean up
+    removeFile absFile
+    writeFile absFile "<should be overwritten>"
+    case dirs of
+      [] -> pure ()
+      d : _ -> removeDirectoryRecursive (baseDir </> d)
+
+    -- Unpack back
+    Unpack.unpack baseDir (foldr Next Done entries :: Entries IOException)
+    cnt' <- readFile absFile
+    pure $ cnt === cnt'
+
+  | otherwise = discard
+
+mkFilePath :: ASCIIString -> FilePath
+mkFilePath (ASCIIString xs) = makeValid $
+  filter (\c -> not $ isPathSeparator c || c == '.') xs

test/Properties.hs

@@ -5,6 +5,7 @@ module Main where
 import qualified Codec.Archive.Tar.Index.Tests as Index
 import qualified Codec.Archive.Tar.Index.IntTrie.Tests as IntTrie
 import qualified Codec.Archive.Tar.Index.StringTable.Tests as StringTable
+import qualified Codec.Archive.Tar.Pack.Tests  as Pack
 import qualified Codec.Archive.Tar.Tests       as Tar
 
 import Test.Tasty
@@ -52,5 +53,9 @@ main =
 #endif
         testProperty "unfinalise"  Index.prop_finalise_unfinalise
       ]
+
+    , testGroup "pack" [
+      testProperty "roundtrip" Pack.prop_roundtrip
+      ]
     ]