Fix pack/unpack roundtrip test on Windows

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

@@ -8,6 +8,7 @@ module Codec.Archive.Tar.Pack.Tests
   , unit_roundtrip
   ) where
 
+import Control.DeepSeq
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
 import Data.FileEmbed
@@ -16,29 +17,29 @@ 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 Data.List.NonEmpty (NonEmpty(..))
 import System.Directory
 import System.FilePath
+import qualified System.Info
 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] -> ASCIIString -> Property
 prop_roundtrip xss (ASCIIString 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
+  | x : xs <- filter (not . null) $ map mkFilePath xss
   = ioProperty $ withSystemTempDirectory "tar-test" $ \baseDir -> do
+    file : dirs <- pure $ trimUpToMaxPathLength baseDir (x : xs)
+
     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]
+    !entries <- Pack.pack baseDir [relFile] >>= evaluate . force
 
     -- Try hard to clean up
     removeFile absFile
@@ -58,9 +59,23 @@ mkFilePath :: ASCIIString -> FilePath
 mkFilePath (ASCIIString xs) = makeValid $
   filter (\c -> not $ isPathSeparator c || c == '.') xs
 
+trimUpToMaxPathLength :: FilePath -> [FilePath] -> [FilePath]
+trimUpToMaxPathLength baseDir = go (maxPathLength - length baseDir - 1)
+  where
+    go :: Int -> [FilePath] -> [FilePath]
+    go cnt [] = []
+    go cnt (x : xs)
+      | cnt <= 0 = []
+      | cnt <= length x = [take cnt x]
+      | otherwise = x : go (cnt - length x - 1) xs
+
+maxPathLength :: Int
+maxPathLength = case System.Info.os of
+  "mingw32" -> 255
+  _ -> 1023 -- macOS does not like longer names
+
 unit_roundtrip :: Property
 unit_roundtrip =
   let tar :: BL.ByteString = BL.fromStrict $(embedFile "test/data/long.tar")
       entries = Tar.foldEntries (:) [] (const []) (Tar.read tar)
   in Tar.write entries === tar
-