packages feed

tar 0.6.4.0 → 0.7.0.0

raw patch · 17 files changed

+285/−178 lines, 17 filesdep ~arraydep ~containersdep ~deepseq

Dependency ranges changed: array, containers, deepseq, filepath, time

Files

Codec/Archive/Tar.hs view
@@ -65,7 +65,7 @@   -- > import qualified Data.ByteString.Lazy as BL   -- > import qualified Codec.Compression.GZip as GZip   -- >-  -- > BL.writeFile tar . GZip.compress . Tar.write =<< Tar.pack base dir+  -- > BL.writeFile tar . GZip.compress =<< Tar.write' =<< Tar.pack' base dir   --   -- Similarly, extracting a compressed @.tar.gz@ is just a minor variation   -- on the 'extract' function where we use decompression in the pipeline:@@ -112,6 +112,7 @@   -- produces the standard format.   read,   write,+  write',    -- * Packing and unpacking files to\/from internal representation   -- | These functions are for packing and unpacking portable archives. They@@ -119,6 +120,7 @@   -- and permissions or to archive special files like named pipes and Unix   -- device files.   pack,+  pack',   packAndCheck,   unpack,   unpackAndCheck,@@ -168,11 +170,11 @@ import Codec.Archive.Tar.Entry import Codec.Archive.Tar.Index (hSeekEndEntryOffset) import Codec.Archive.Tar.LongNames (decodeLongNames, encodeLongNames, DecodeLongNamesError(..))-import Codec.Archive.Tar.Pack (pack, packAndCheck)+import Codec.Archive.Tar.Pack (pack, pack', packAndCheck) import Codec.Archive.Tar.Read (read, FormatError(..)) import Codec.Archive.Tar.Types (unfoldEntries, foldlEntries, foldEntries, mapEntriesNoFail, mapEntries, Entries, GenEntries(..)) import Codec.Archive.Tar.Unpack (unpack, unpackAndCheck)-import Codec.Archive.Tar.Write (write)+import Codec.Archive.Tar.Write (write, write')  import Control.Applicative ((<|>)) import Control.Exception (Exception, throw, catch, SomeException(..))@@ -190,12 +192,7 @@ -- @.\/base\/dir\/foo.txt@. The file names inside the resulting tar file will be -- relative to @dir@, eg @dir\/foo.txt@. ----- This is a high level \"all in one\" operation. Since you may need variations--- on this function it is instructive to see how it is written. It is just:------ > import qualified Data.ByteString.Lazy as BL--- >--- > BL.writeFile tar . Tar.write =<< Tar.pack base paths+-- This is a high level \"all in one\" operation, combining 'pack'' and 'write''. -- -- Notes: --@@ -217,7 +214,7 @@        -> FilePath   -- ^ Base directory        -> [FilePath] -- ^ Files and directories to archive, relative to base dir        -> IO ()-create tar base paths = BL.writeFile tar . write =<< pack base paths+create tar base paths = BL.writeFile tar =<< write' =<< pack' base paths  -- | Extract all the files contained in a @\".tar\"@ file. --@@ -228,12 +225,7 @@ -- So for example if the @tarball.tar@ file contains @foo\/bar.txt@ then this -- will extract it to @dir\/foo\/bar.txt@. ----- This is a high level \"all in one\" operation. Since you may need variations--- on this function it is instructive to see how it is written. It is just:------ > import qualified Data.ByteString.Lazy as BL--- >--- > Tar.unpack dir . Tar.read =<< BL.readFile tar+-- This is a high level \"all in one\" operation, combining 'unpack' and 'read'. -- -- Notes: --@@ -267,4 +259,4 @@ append tar base paths =     withFile tar ReadWriteMode $ \hnd -> do       _ <- hSeekEndEntryOffset hnd Nothing-      BL.hPut hnd . write =<< pack base paths+      BL.hPut hnd =<< write' =<< pack' base paths
Codec/Archive/Tar/Check/Internal.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -42,7 +41,6 @@ import Control.Applicative ((<|>)) import qualified Data.ByteString.Lazy.Char8 as Char8 import Data.Maybe (fromMaybe)-import Data.Typeable (Typeable) import Control.Exception (Exception(..)) import qualified System.FilePath as FilePath.Native          ( splitDirectories, isAbsolute, isValid, (</>), takeDirectory, hasDrive )@@ -78,13 +76,13 @@ -- such as exhaustion of file handlers. checkSecurity   :: Entries e-  -> GenEntries FilePath FilePath (Either (Either e DecodeLongNamesError) FileNameError)+  -> GenEntries Char8.ByteString FilePath FilePath (Either (Either e DecodeLongNamesError) FileNameError) checkSecurity = checkEntries checkEntrySecurity . decodeLongNames  -- | Worker of 'Codec.Archive.Tar.Check.checkSecurity'. -- -- @since 0.6.0.0-checkEntrySecurity :: GenEntry FilePath FilePath -> Maybe FileNameError+checkEntrySecurity :: GenEntry Char8.ByteString FilePath FilePath -> Maybe FileNameError checkEntrySecurity e =   check (entryTarPath e) <|>   case entryContent e of@@ -130,7 +128,6 @@   | AbsoluteFileName FilePath   | UnsafeLinkTarget FilePath   -- ^ @since 0.6.0.0-  deriving (Typeable)  instance Show FileNameError where   show = showFileNameError Nothing@@ -169,7 +166,7 @@ checkTarbomb   :: FilePath   -> Entries e-  -> GenEntries FilePath FilePath (Either (Either e DecodeLongNamesError) TarBombError)+  -> GenEntries Char8.ByteString FilePath FilePath (Either (Either e DecodeLongNamesError) TarBombError) checkTarbomb expectedTopDir   = checkEntries (checkEntryTarbomb expectedTopDir)   . decodeLongNames@@ -177,7 +174,7 @@ -- | Worker of 'checkTarbomb'. -- -- @since 0.6.0.0-checkEntryTarbomb :: FilePath -> GenEntry FilePath linkTarget -> Maybe TarBombError+checkEntryTarbomb :: FilePath -> GenEntry Char8.ByteString FilePath linkTarget -> Maybe TarBombError checkEntryTarbomb expectedTopDir entry = do   case entryContent entry of     -- Global extended header aka XGLTYPE aka pax_global_header@@ -198,7 +195,6 @@              --              -- @since 0.6.0.0     FilePath -- ^ Expected top directory.-  deriving (Typeable)  instance Exception TarBombError @@ -236,13 +232,13 @@ -- such as exhaustion of file handlers. checkPortability   :: Entries e-  -> GenEntries FilePath FilePath (Either (Either e DecodeLongNamesError) PortabilityError)+  -> GenEntries Char8.ByteString FilePath FilePath (Either (Either e DecodeLongNamesError) PortabilityError) checkPortability = checkEntries checkEntryPortability . decodeLongNames  -- | Worker of 'checkPortability'. -- -- @since 0.6.0.0-checkEntryPortability :: GenEntry FilePath linkTarget -> Maybe PortabilityError+checkEntryPortability :: GenEntry Char8.ByteString FilePath linkTarget -> Maybe PortabilityError checkEntryPortability entry   | entryFormat entry `elem` [V7Format, GnuFormat]   = Just $ NonPortableFormat (entryFormat entry)@@ -289,7 +285,6 @@   | NonPortableFileType   | NonPortableEntryNameChar FilePath   | NonPortableFileName PortabilityPlatform FileNameError-  deriving (Typeable)  -- | The name of a platform that portability issues arise from type PortabilityPlatform = String@@ -311,8 +306,8 @@ -- Utils  checkEntries-  :: (GenEntry tarPath linkTarget -> Maybe e')-  -> GenEntries tarPath linkTarget e-  -> GenEntries tarPath linkTarget (Either e e')+  :: (GenEntry content tarPath linkTarget -> Maybe e')+  -> GenEntries content tarPath linkTarget e+  -> GenEntries content tarPath linkTarget (Either e e') checkEntries checkEntry =   mapEntries (\entry -> maybe (Right entry) Left (checkEntry entry))
Codec/Archive/Tar/Index/IntTrie.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP, BangPatterns, PatternGuards #-}-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-}@@ -37,8 +37,6 @@  import Prelude hiding (lookup) -import Data.Typeable (Typeable)- import qualified Data.Array.Unboxed as A import Data.Array.IArray  ((!)) import qualified Data.Bits as Bits@@ -67,7 +65,7 @@ -- correspond to files), they do not have values at the branch points (which -- correspond to directories). newtype IntTrie = IntTrie (A.UArray Word32 Word32)-    deriving (Eq, Show, Typeable)+    deriving (Eq, Show)  -- | The most significant bit is used for tagging, -- see 'tagLeaf' / 'tagNode' below, so morally it's Word31 only.
Codec/Archive/Tar/Index/Internal.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP, BangPatterns, PatternGuards #-}-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_HADDOCK hide #-}  -----------------------------------------------------------------------------@@ -56,8 +56,6 @@     serialiseSize,   ) where -import Data.Typeable (Typeable)- import Codec.Archive.Tar.Types as Tar import Codec.Archive.Tar.Read  as Tar import qualified Codec.Archive.Tar.Index.StringTable as StringTable@@ -119,7 +117,7 @@   -- additional entries.   {-# UNPACK #-} !TarEntryOffset -  deriving (Eq, Show, Typeable)+  deriving (Eq, Show)  instance NFData TarIndex where   rnf (TarIndex _ _ _) = () -- fully strict by construction@@ -131,11 +129,10 @@ -- data TarIndexEntry = TarFileEntry {-# UNPACK #-} !TarEntryOffset                    | TarDir [(FilePath, TarIndexEntry)]-  deriving (Show, Typeable)-+  deriving (Show)  newtype PathComponentId = PathComponentId Int-  deriving (Eq, Ord, Enum, Show, Typeable)+  deriving (Eq, Ord, Enum, Show)  -- | An offset within a tar file. Use 'hReadEntry', 'hReadEntryHeader' or -- 'hSeekEntryOffset'.@@ -143,7 +140,6 @@ -- This is actually a tar \"record\" number, not a byte offset. -- type TarEntryOffset = Word32-  -- | Look up a given filepath in the t'TarIndex'. It may return a 'TarFileEntry' -- containing the 'TarEntryOffset' of the file within the tar file, or if
Codec/Archive/Tar/Index/StringTable.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, BangPatterns, PatternGuards, DeriveDataTypeable #-}+{-# LANGUAGE CPP, BangPatterns, PatternGuards #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_HADDOCK hide #-} @@ -24,8 +24,6 @@     index'  ) where -import Data.Typeable (Typeable)- import Prelude   hiding (lookup, id) import Data.List hiding (lookup, insert) import Data.Function (on)@@ -58,7 +56,7 @@          {-# UNPACK #-} !(A.UArray Int32 Word32) -- string offset table          {-# UNPACK #-} !(A.UArray Int32 Int32)  -- string index to id table          {-# UNPACK #-} !(A.UArray Int32 Int32)  -- string id to index table-  deriving (Show, Typeable)+  deriving (Show)  instance (Eq id, Enum id) => Eq (StringTable id) where   tbl1 == tbl2 = unfinalise tbl1 == unfinalise tbl2@@ -107,7 +105,7 @@ data StringTableBuilder id = StringTableBuilder                                               !(Map BS.ByteString id)                                {-# UNPACK #-} !Word32-  deriving (Eq, Show, Typeable)+  deriving (Eq, Show)  empty :: StringTableBuilder id empty = StringTableBuilder Map.empty 0
Codec/Archive/Tar/LongNames.hs view
@@ -38,16 +38,16 @@ -- -- @since 0.6.0.0 encodeLongNames-  :: GenEntry FilePath FilePath-  -> [Entry]+  :: GenEntry content FilePath FilePath+  -> [GenEntry content TarPath LinkTarget] encodeLongNames e = maybe id (:) mEntry $ maybe id (:) mEntry' [e'']   where     (mEntry, e') = encodeLinkTarget e     (mEntry', e'') = encodeTarPath e'  encodeTarPath-  :: GenEntry FilePath linkTarget-  -> (Maybe (GenEntry TarPath whatever), GenEntry TarPath linkTarget)+  :: GenEntry content FilePath linkTarget+  -> (Maybe (GenEntry content TarPath whatever), GenEntry content TarPath linkTarget)   -- ^ (LongLink entry, actual entry) encodeTarPath e = case toTarPath' (entryTarPath e) of   FileNameEmpty -> (Nothing, e { entryTarPath = TarPath mempty mempty })@@ -55,8 +55,8 @@   FileNameTooLong tarPath -> (Just $ longLinkEntry $ entryTarPath e, e { entryTarPath = tarPath })  encodeLinkTarget-  :: GenEntry tarPath FilePath-  -> (Maybe (GenEntry TarPath LinkTarget), GenEntry tarPath LinkTarget)+  :: GenEntry content tarPath FilePath+  -> (Maybe (GenEntry content TarPath LinkTarget), GenEntry content tarPath LinkTarget)   -- ^ (LongLink symlink entry, actual entry) encodeLinkTarget e = case entryContent e of   NormalFile x y -> (Nothing, e { entryContent = NormalFile x y })@@ -72,7 +72,7 @@  encodeLinkPath   :: FilePath-  -> (Maybe (GenEntry TarPath LinkTarget), LinkTarget)+  -> (Maybe (GenEntry content TarPath LinkTarget), LinkTarget) encodeLinkPath lnk = case toTarPath' lnk of   FileNameEmpty -> (Nothing, LinkTarget mempty)   FileNameOK (TarPath name prefix)@@ -91,10 +91,10 @@ -- @since 0.6.0.0 decodeLongNames   :: Entries e-  -> GenEntries FilePath FilePath (Either e DecodeLongNamesError)+  -> GenEntries BL.ByteString FilePath FilePath (Either e DecodeLongNamesError) decodeLongNames = go Nothing Nothing   where-    go :: Maybe FilePath -> Maybe FilePath -> Entries e -> GenEntries FilePath FilePath (Either e DecodeLongNamesError)+    go :: Maybe FilePath -> Maybe FilePath -> Entries e -> GenEntries BL.ByteString FilePath FilePath (Either e DecodeLongNamesError)     go _ _ (Fail err) = Fail (Left err)     go _ _ Done = Done @@ -141,13 +141,13 @@ otherEntryPayloadToFilePath =   fromPosixString . byteToPosixString . B.takeWhile (/= '\0') . BL.toStrict -castEntry :: Entry -> GenEntry FilePath FilePath+castEntry :: Entry -> GenEntry BL.ByteString FilePath FilePath castEntry e = e   { entryTarPath = fromTarPathToPosixPath (entryTarPath e)   , entryContent = castEntryContent (entryContent e)   } -castEntryContent :: EntryContent -> GenEntryContent FilePath+castEntryContent :: EntryContent -> GenEntryContent BL.ByteString FilePath castEntryContent = \case   NormalFile x y -> NormalFile x y   Directory -> Directory
Codec/Archive/Tar/Pack.hs view
@@ -20,6 +20,8 @@ ----------------------------------------------------------------------------- module Codec.Archive.Tar.Pack (     pack,+    pack',+    defaultRead,     packAndCheck,     packFileEntry,     packDirectoryEntry,@@ -31,6 +33,9 @@ import Codec.Archive.Tar.PackAscii (filePathToOsPath, osPathToFilePath) import Codec.Archive.Tar.Types +import Data.Int (Int64)+import Control.Applicative+import Prelude hiding (Applicative(..)) import Data.Bifunctor (bimap) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL@@ -49,9 +54,10 @@ import Data.Time.Clock.POSIX          ( utcTimeToPOSIXSeconds ) import System.IO-         ( IOMode(ReadMode), hFileSize )+         ( IOMode(ReadMode), hFileSize, hClose ) import System.IO.Unsafe (unsafeInterleaveIO) import Control.Exception (throwIO, SomeException)+import System.IO.Error (annotateIOError)  -- | Creates a tar archive from a list of directory or files. Any directories -- specified will have their contents included recursively. Paths in the@@ -72,6 +78,16 @@   -> IO [Entry] pack = packAndCheck (const Nothing) +-- | 'pack'' is like 'pack', but doesn't read the contents of files,+-- only creating entries with 'OsPath' as contents.+--+-- @since 0.7.0.0+pack'+  :: FilePath+  -> [FilePath]+  -> IO [GenEntry OsPath TarPath LinkTarget]+pack' = packAndCheckWithRead (\_ -> return) (const Nothing)+ -- | Like 'Codec.Archive.Tar.pack', but allows to specify additional sanity/security -- checks on the input filenames. This is useful if you know which -- check will be used on client side@@ -79,19 +95,27 @@ -- -- @since 0.6.0.0 packAndCheck-  :: (GenEntry FilePath FilePath -> Maybe SomeException)+  :: (GenEntry BL.ByteString FilePath FilePath -> Maybe SomeException)   -> FilePath   -- ^ Base directory   -> [FilePath] -- ^ Files and directories to pack, relative to the base dir   -> IO [Entry]-packAndCheck secCB (filePathToOsPath -> baseDir) (map filePathToOsPath -> relpaths) = do+packAndCheck = packAndCheckWithRead defaultRead++packAndCheckWithRead+  :: (Int64 -> OsPath -> IO content)+  -> (GenEntry content FilePath FilePath -> Maybe SomeException)+  -> FilePath+  -> [FilePath]+  -> IO [GenEntry content TarPath LinkTarget]+packAndCheckWithRead r secCB (filePathToOsPath -> baseDir) (map filePathToOsPath -> relpaths) = do   paths <- preparePaths baseDir relpaths-  entries' <- packPaths baseDir paths+  entries' <- packPathsWithRead r baseDir paths   let entries = map (bimap osPathToFilePath osPathToFilePath) entries'   traverse_ (maybe (pure ()) throwIO . secCB) entries   pure $ concatMap encodeLongNames entries  preparePaths :: OsPath -> [OsPath] -> IO [OsPath]-preparePaths baseDir = fmap concat . interleave . map go+preparePaths baseDir = fmap concat . interleavedSequence . map go   where     go :: OsPath -> IO [OsPath]     go relpath = do@@ -111,28 +135,25 @@       _ -> fn  -- | Pack paths while accounting for overlong filepaths.-packPaths-  :: OsPath+packPathsWithRead+  :: (Int64 -> OsPath -> IO content)+  -> OsPath   -> [OsPath]-  -> IO [GenEntry OsPath OsPath]-packPaths baseDir paths = interleave $ flip map paths $ \relpath -> do+  -> IO [GenEntry content OsPath OsPath]+packPathsWithRead r baseDir paths = interleavedSequence $ 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'+        | otherwise = packFileEntryWithRead' r   mkEntry abspath relpath -interleave :: [IO a] -> IO [a]-interleave = unsafeInterleaveIO . go-  where-    go []     = return []-    go (x:xs) = do-      x'  <- x-      xs' <- interleave xs-      return (x':xs')+-- | As a normal 'sequence', but interleaving IO actions.+interleavedSequence :: [IO a] -> IO [a]+interleavedSequence =+  foldr ((unsafeInterleaveIO .) . liftA2 (:)) (pure [])  -- | Construct a tar entry based on a local file. --@@ -145,13 +166,13 @@ packFileEntry   :: 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)+  -> IO (GenEntry BL.ByteString tarPath linkTarget) 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)+  -> IO (GenEntry BL.ByteString tarPath linkTarget) packFileEntry' filepath tarpath = do   mtime   <- getModTime filepath   perms   <- getPermissions filepath@@ -183,6 +204,64 @@     , entryTime = mtime     } +-- |+--+-- @since 0.7.0.0+defaultRead+  :: Int64 -- ^ expected size+  -> OsPath+  -> IO BL.ByteString+defaultRead approxSize filepath = do+  if approxSize < 131072+    -- If file is short enough, just read it strictly+    -- so that no file handle dangles around indefinitely.+    then do+      cnt <- readFile' filepath+      let sz = fromIntegral (B.length cnt) :: Int64+      if sz /= approxSize+      then throwWrongSize sz+      else pure (BL.fromStrict cnt)+    else do+      hndl <- openBinaryFile filepath ReadMode+      -- File size could have changed between measuring approxSize+      -- and here. Measuring again.+      sz <- fromInteger <$> hFileSize hndl+      if sz /= approxSize+      then do+        hClose hndl+        throwWrongSize sz+      else do+        -- Lazy I/O at its best: once cnt is forced in full,+        -- BL.hGetContents will close the handle.+        cnt <- BL.hGetContents hndl+        -- It would be wrong to return (cnt, BL.length sz):+        -- NormalFile constructor below forces size which in turn+        -- allocates entire cnt in memory at once.+        pure cnt+  where+    throwWrongSize :: Int64 -> IO a+    throwWrongSize sz = do+        let msg = "File size changed, expecting " ++ show approxSize ++ "; got " ++ show sz+        ioError (annotateIOError (userError msg) "defaultRead" Nothing (Just (osPathToFilePath filepath)))++packFileEntryWithRead'+  :: (Int64 -> OsPath -> IO content)+  -> OsPath  -- ^ Full path to find the file on the local disk+  -> tarPath -- ^ Path to use for the tar 'GenEntry' in the archive+  -> IO (GenEntry content tarPath linkTarget)+packFileEntryWithRead' r filepath tarpath = do+  mtime   <- getModTime filepath+  perms   <- getPermissions filepath+  -- Get file size without opening it.+  size <- fromInteger <$> getFileSize filepath+  content <- r size filepath++  pure (simpleEntry tarpath (NormalFile content size))+    { entryPermissions =+      if executable perms then executableFilePermissions else ordinaryFilePermissions+    , entryTime = mtime+    }+ -- | Construct a tar entry based on a local directory (but not its contents). -- -- The only attribute of the directory that is used is its modification time.@@ -191,13 +270,13 @@ packDirectoryEntry   :: 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)+  -> IO (GenEntry content tarPath linkTarget) 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)+  -> IO (GenEntry content tarPath linkTarget) packDirectoryEntry' filepath tarpath = do   mtime   <- getModTime filepath   return (directoryEntry tarpath) {@@ -210,13 +289,13 @@ 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)+  -> IO (GenEntry content tarPath FilePath) 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)+  -> IO (GenEntry content tarPath OsPath) packSymlinkEntry' filepath tarpath = do   linkTarget <- getSymbolicLinkTarget filepath   pure $ symlinkEntry tarpath linkTarget
Codec/Archive/Tar/Read.hs view
@@ -26,7 +26,6 @@ import Data.Int      (Int64) import Data.Bits     (Bits(shiftL, (.&.), complement)) import Control.Exception (Exception(..))-import Data.Typeable (Typeable) import Control.Applicative import Control.Monad import Control.DeepSeq@@ -52,7 +51,7 @@   | NotTarFormat   | UnrecognisedTarFormat   | HeaderBadNumericEncoding-  deriving (Eq, Show, Typeable)+  deriving (Eq, Show)  instance Exception FormatError where   displayException TruncatedArchive         = "truncated tar archive"
Codec/Archive/Tar/Types.hs view
@@ -81,7 +81,6 @@ import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid   (Monoid(..)) import Data.Semigroup as Sem-import Data.Typeable import qualified Data.ByteString       as BS import qualified Data.ByteString.Char8 as BS.Char8 import qualified Data.ByteString.Lazy  as LBS@@ -125,14 +124,14 @@ -- while low-level ones use 'GenEntry' t'TarPath' t'LinkTarget'. -- -- @since 0.6.0.0-data GenEntry tarPath linkTarget = Entry {+data GenEntry content tarPath linkTarget = Entry {      -- | The path of the file or directory within the archive.     entryTarPath :: !tarPath,      -- | The real content of the entry. For 'NormalFile' this includes the     -- file data. An entry usually contains a 'NormalFile' or a 'Directory'.-    entryContent :: !(GenEntryContent linkTarget),+    entryContent :: !(GenEntryContent content linkTarget),      -- | File permissions (Unix style file mode).     entryPermissions :: {-# UNPACK #-} !Permissions,@@ -153,7 +152,7 @@   )  -- | @since 0.6.4.0-instance Bifunctor GenEntry where+instance Bifunctor (GenEntry content) where   bimap f g e = e     { entryTarPath = f (entryTarPath e)     , entryContent = fmap g (entryContent e)@@ -161,14 +160,14 @@  -- | Monomorphic tar archive entry, ready for serialization / deserialization. ---type Entry = GenEntry TarPath LinkTarget+type Entry = GenEntry LBS.ByteString TarPath LinkTarget  -- | Low-level function to get a native 'FilePath' of the file or directory -- within the archive, not accounting for long names. It's likely -- that you want to apply 'Codec.Archive.Tar.decodeLongNames' -- and use 'Codec.Archive.Tar.Entry.entryTarPath' afterwards instead of 'entryPath'. ---entryPath :: GenEntry TarPath linkTarget -> FilePath+entryPath :: GenEntry content TarPath linkTarget -> FilePath entryPath = fromTarPath . entryTarPath  -- | Polymorphic content of a tar archive entry. High-level interfaces@@ -178,8 +177,8 @@ -- Portable archives should contain only 'NormalFile' and 'Directory'. -- -- @since 0.6.0.0-data GenEntryContent linkTarget-  = NormalFile      LBS.ByteString {-# UNPACK #-} !FileSize+data GenEntryContent content linkTarget+  = NormalFile      content {-# UNPACK #-} !FileSize   | Directory   | SymbolicLink    !linkTarget   | HardLink        !linkTarget@@ -199,7 +198,7 @@  -- | Monomorphic content of a tar archive entry, -- ready for serialization / deserialization.-type EntryContent = GenEntryContent LinkTarget+type EntryContent = GenEntryContent LBS.ByteString LinkTarget  -- | Ownership information for 'GenEntry'. data Ownership = Ownership {@@ -240,10 +239,10 @@    | GnuFormat   deriving (Eq, Ord, Show) -instance (NFData tarPath, NFData linkTarget) => NFData (GenEntry tarPath linkTarget) where+instance (NFData tarPath, NFData content, NFData linkTarget) => NFData (GenEntry content tarPath linkTarget) where   rnf (Entry p c _ _ _ _) = rnf p `seq` rnf c -instance NFData linkTarget => NFData (GenEntryContent linkTarget) where+instance (NFData linkTarget, NFData content) => NFData (GenEntryContent content linkTarget) where   rnf x = case x of       NormalFile       c _  -> rnf c       SymbolicLink lnk      -> rnf lnk@@ -279,9 +278,9 @@ -- -- > (emptyEntry name HardLink) { linkTarget = target } ---simpleEntry :: tarPath -> GenEntryContent linkTarget -> GenEntry tarPath linkTarget-simpleEntry tarpath content = Entry {-    entryTarPath     = tarpath,+simpleEntry :: tarPath -> GenEntryContent content linkTarget -> GenEntry content tarPath linkTarget+simpleEntry tarPath content = Entry {+    entryTarPath     = tarPath,     entryContent     = content,     entryPermissions = case content of                          Directory -> directoryPermissions@@ -301,12 +300,12 @@ -- -- > (fileEntry name content) { fileMode = executableFileMode } ---fileEntry :: tarPath -> LBS.ByteString -> GenEntry tarPath linkTarget+fileEntry :: tarPath -> LBS.ByteString -> GenEntry LBS.ByteString tarPath linkTarget fileEntry name fileContent =   simpleEntry name (NormalFile fileContent (LBS.length fileContent))  -- | A tar entry for a symbolic link.-symlinkEntry :: tarPath -> linkTarget -> GenEntry tarPath linkTarget+symlinkEntry :: tarPath -> linkTarget -> GenEntry content tarPath linkTarget symlinkEntry name targetLink =   simpleEntry name (SymbolicLink targetLink) @@ -319,7 +318,7 @@ -- See [What exactly is the GNU tar ././@LongLink "trick"?](https://stackoverflow.com/questions/2078778/what-exactly-is-the-gnu-tar-longlink-trick) -- -- @since 0.6.0.0-longLinkEntry :: FilePath -> GenEntry TarPath linkTarget+longLinkEntry :: FilePath -> GenEntry content TarPath linkTarget longLinkEntry tarpath = Entry {     entryTarPath     = TarPath [PS.pstr|././@LongLink|] mempty,     entryContent     = OtherEntryType 'L' (LBS.fromStrict $ posixToByteString $ toPosixString tarpath) (fromIntegral $ length tarpath),@@ -336,7 +335,7 @@ -- data with truncated 'Codec.Archive.Tar.Entry.entryTarPath'. -- -- @since 0.6.0.0-longSymLinkEntry :: FilePath -> GenEntry TarPath linkTarget+longSymLinkEntry :: FilePath -> GenEntry content TarPath linkTarget longSymLinkEntry linkTarget = Entry {     entryTarPath     = TarPath [PS.pstr|././@LongLink|] mempty,     entryContent     = OtherEntryType 'K' (LBS.fromStrict $ posixToByteString $ toPosixString $ linkTarget) (fromIntegral $ length linkTarget),@@ -350,7 +349,7 @@ -- -- Entry fields such as file permissions and ownership have default values. ---directoryEntry :: tarPath -> GenEntry tarPath linkTarget+directoryEntry :: tarPath -> GenEntry content tarPath linkTarget directoryEntry name = simpleEntry name Directory  --@@ -546,7 +545,7 @@  data LinkTargetException = IsAbsolute FilePath                          | TooLong FilePath-  deriving (Show,Typeable)+  deriving (Show)  instance Exception LinkTargetException where   displayException (IsAbsolute fp) = "Link target \"" <> fp <> "\" is unexpectedly absolute"@@ -614,8 +613,8 @@ -- archive. -- -- @since 0.6.0.0-data GenEntries tarPath linkTarget e-  = Next (GenEntry tarPath linkTarget) (GenEntries tarPath linkTarget e)+data GenEntries content tarPath linkTarget e+  = Next (GenEntry content tarPath linkTarget) (GenEntries content tarPath linkTarget e)   | Done   | Fail e   deriving@@ -630,7 +629,7 @@  -- | Monomorphic sequence of archive entries, -- ready for serialization / deserialization.-type Entries e = GenEntries TarPath LinkTarget e+type Entries e = GenEntries LBS.ByteString TarPath LinkTarget e  -- | This is like the standard 'Data.List.unfoldr' function on lists, but for 'Entries'. -- It includes failure as an extra possibility that the stepper function may@@ -640,9 +639,9 @@ -- used internally to lazily unfold entries from a 'LBS.ByteString'. -- unfoldEntries-  :: (a -> Either e (Maybe (GenEntry tarPath linkTarget, a)))+  :: (a -> Either e (Maybe (GenEntry content tarPath linkTarget, a)))   -> a-  -> GenEntries tarPath linkTarget e+  -> GenEntries content tarPath linkTarget e unfoldEntries f = unfold   where     unfold x = case f x of@@ -654,8 +653,8 @@   :: Monad m   => (forall a. m a -> m a)   -- ^ id or unsafeInterleaveIO-  -> m (Either e (Maybe (GenEntry tarPath linkTarget)))-  -> m (GenEntries tarPath linkTarget e)+  -> m (Either e (Maybe (GenEntry content tarPath linkTarget)))+  -> m (GenEntries content tarPath linkTarget e) unfoldEntriesM interleave f = unfold   where     unfold = do@@ -673,10 +672,10 @@ -- to scan a tarball for problems or to collect an index of the contents. -- foldEntries-  :: (GenEntry tarPath linkTarget -> a -> a)+  :: (GenEntry content tarPath linkTarget -> a -> a)   -> a   -> (e -> a)-  -> GenEntries tarPath linkTarget e -> a+  -> GenEntries content tarPath linkTarget e -> a foldEntries next done fail' = fold   where     fold (Next e es) = next e (fold es)@@ -688,9 +687,9 @@ -- value. -- foldlEntries-  :: (a -> GenEntry tarPath linkTarget -> a)+  :: (a -> GenEntry content tarPath linkTarget -> a)   -> a-  -> GenEntries tarPath linkTarget e+  -> GenEntries content tarPath linkTarget e   -> Either (e, a) a foldlEntries f = go   where@@ -704,32 +703,32 @@ -- If your mapping function cannot fail it may be more convenient to use -- 'mapEntriesNoFail' mapEntries-  :: (GenEntry tarPath linkTarget -> Either e' (GenEntry tarPath linkTarget))+  :: (GenEntry content tarPath linkTarget -> Either e' (GenEntry content tarPath linkTarget))   -- ^ Function to apply to each entry-  -> GenEntries tarPath linkTarget e+  -> GenEntries content tarPath linkTarget e   -- ^ Input sequence-  -> GenEntries tarPath linkTarget (Either e e')+  -> GenEntries content tarPath linkTarget (Either e e') mapEntries f =   foldEntries (\entry rest -> either (Fail . Right) (`Next` rest) (f entry)) Done (Fail . Left)  -- | Like 'mapEntries' but the mapping function itself cannot fail. -- mapEntriesNoFail-  :: (GenEntry tarPath linkTarget -> GenEntry tarPath linkTarget)-  -> GenEntries tarPath linkTarget e-  -> GenEntries tarPath linkTarget e+  :: (GenEntry content tarPath linkTarget -> GenEntry content tarPath linkTarget)+  -> GenEntries content tarPath linkTarget e+  -> GenEntries content tarPath linkTarget e mapEntriesNoFail f =   foldEntries (Next . f) Done Fail  -- | @since 0.5.1.0-instance Sem.Semigroup (GenEntries tarPath linkTarget e) where+instance Sem.Semigroup (GenEntries content tarPath linkTarget e) where   a <> b = foldEntries Next b Fail a -instance Monoid (GenEntries tarPath linkTarget e) where+instance Monoid (GenEntries content tarPath linkTarget e) where   mempty  = Done   mappend = (Sem.<>) -instance (NFData tarPath, NFData linkTarget, NFData e) => NFData (GenEntries tarPath linkTarget e) where+instance (NFData tarPath, NFData content, NFData linkTarget, NFData e) => NFData (GenEntries content tarPath linkTarget e) where   rnf (Next e es) = rnf e `seq` rnf es   rnf  Done       = ()   rnf (Fail e)    = rnf e
Codec/Archive/Tar/Unpack.hs view
@@ -67,6 +67,7 @@          ( posixSecondsToUTCTime ) import Control.Exception as Exception          ( catch, SomeException(..) )+import qualified Data.ByteString.Lazy as BL  -- | Create local files and directories based on the entries of a tar archive. --@@ -107,7 +108,7 @@ -- @since 0.6.0.0 unpackAndCheck   :: Exception e-  => (GenEntry FilePath FilePath -> Maybe SomeException)+  => (GenEntry BL.ByteString FilePath FilePath -> Maybe SomeException)   -- ^ Checks to run on each entry before unpacking   -> FilePath   -- ^ Base directory@@ -129,7 +130,7 @@     unpackEntries :: Exception e                   => [(OsPath, OsPath, Bool)]                   -- ^ links (path, link, isHardLink)-                  -> GenEntries FilePath FilePath (Either e DecodeLongNamesError)+                  -> GenEntries BL.ByteString FilePath FilePath (Either e DecodeLongNamesError)                   -- ^ entries                   -> IO [(OsPath, OsPath, Bool)]     unpackEntries _     (Fail err)      = either throwIO throwIO err
Codec/Archive/Tar/Write.hs view
@@ -12,10 +12,11 @@ -- Portability :  portable -- ------------------------------------------------------------------------------module Codec.Archive.Tar.Write (write) where+module Codec.Archive.Tar.Write (write, write') where  import Codec.Archive.Tar.PackAscii import Codec.Archive.Tar.Types+import Codec.Archive.Tar.Pack (defaultRead)  import Data.Bits import Data.Char     (chr,ord)@@ -23,6 +24,9 @@ import Data.List     (foldl') import Data.Monoid   (mempty) import Numeric       (showOct)+import System.IO.Unsafe (unsafeInterleaveIO)+import System.OsPath+         ( OsPath )  import qualified Data.ByteString             as BS import qualified Data.ByteString.Char8       as BS.Char8@@ -39,6 +43,19 @@ write :: [Entry] -> LBS.ByteString write es = LBS.concat $ map putEntry es ++ [LBS.replicate (512*2) 0] +-- | Like 'write' but for 'GenEntry' with 'OsPath' as contents.+--+-- @since 0.7.0.0+write' :: [GenEntry OsPath TarPath LinkTarget] -> IO LBS.ByteString+write' es = interleavedByteStringConcat $ map putEntry' es ++ [pure $ LBS.replicate (512*2) 0]++interleavedByteStringConcat :: [IO LBS.ByteString] -> IO LBS.ByteString+interleavedByteStringConcat [] = return LBS.empty+interleavedByteStringConcat (x:xs) = do+  y <- x+  ys <- unsafeInterleaveIO (interleavedByteStringConcat xs)+  return (LBS.append y ys)+ putEntry :: Entry -> LBS.ByteString putEntry entry = case entryContent entry of   NormalFile       content size@@ -58,6 +75,23 @@     header       = putHeader entry     padding size = LBS.replicate paddingSize 0       where paddingSize = fromIntegral (negate size `mod` 512)++putEntry' :: GenEntry OsPath TarPath LinkTarget -> IO LBS.ByteString+putEntry' entry' = do+  entryContent' <- case entryContent entry' of+    NormalFile path size -> do+      content <- defaultRead size path+      return $ NormalFile content size++    Directory -> return Directory+    SymbolicLink linkTarget -> return (SymbolicLink linkTarget)+    HardLink linkTarget -> return (HardLink linkTarget)+    CharacterDevice devMajor devMinor -> return (CharacterDevice devMajor devMinor)+    BlockDevice devMajor devMinor -> return (BlockDevice devMajor devMinor)+    NamedPipe -> return NamedPipe+    OtherEntryType typeCode lbs fileSize -> return (OtherEntryType typeCode lbs fileSize)++  return (putEntry entry' { entryContent = entryContent' })  putHeader :: Entry -> LBS.ByteString putHeader entry =
changelog.md view
@@ -1,3 +1,12 @@+## 0.7.0.0 Bodigrim <andrew.lelechenko@gmail.com> September 2025++  This release fixes a long-standing issue with exhaustion of file handles+  (thanks to Oleg Grenrus).++  * Extend `GenEntries` with yet another type argument for file contents.+  * Add `write' :: [GenEntry OsPath TarPath LinkTarget] -> IO LazyByteString`.+  * Add `pack' :: FilePath -> [FilePath] -> IO [GenEntry OsPath TarPath LinkTarget]`.+ ## 0.6.4.0 Bodigrim <andrew.lelechenko@gmail.com> January 2025    * Migrate internals of packing / unpacking to `OsPath`.
tar.cabal view
@@ -1,6 +1,6 @@ cabal-version:   2.2 name:            tar-version:         0.6.4.0+version:         0.7.0.0 license:         BSD-3-Clause license-file:    LICENSE author:          Duncan Coutts <duncan@community.haskell.org>@@ -29,8 +29,8 @@                  test/data/symlink.tar extra-doc-files: changelog.md                  README.md-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,+tested-with:     GHC ==9.14.1, GHC==9.12.2, GHC==9.10.2, GHC==9.8.4,+                 GHC==9.6.7, 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@@ -52,14 +52,14 @@   build-depends: base       >= 4.12  && < 5,                  array                 < 0.6,                  bytestring >= 0.10 && < 0.13,-                 containers >= 0.2  && < 0.8,+                 containers >= 0.2  && < 0.9,                  deepseq    >= 1.1  && < 1.6,                  directory  >= 1.3.1 && < 1.4,                  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,+                 time                  < 1.16,                  transformers          < 0.7,    exposed-modules:@@ -83,7 +83,6 @@   other-extensions:     BangPatterns     CPP-    DeriveDataTypeable     GeneralizedNewtypeDeriving     PatternGuards     ScopedTypeVariables@@ -127,7 +126,6 @@   other-extensions:     CPP     BangPatterns,-    DeriveDataTypeable     ScopedTypeVariables    ghc-options: -fno-ignore-asserts@@ -140,11 +138,6 @@   build-depends: base < 5,                  tar,                  bytestring >= 0.10,-                 filepath,                  directory >= 1.2,-                 array,-                 containers,-                 deepseq,                  temporary < 1.4,-                 time,                  tasty-bench >= 0.4 && < 0.5
test/Codec/Archive/Tar/Index/StringTable/Tests.hs view
@@ -34,8 +34,9 @@     tbl = construct strs      lookupIndex :: BS.ByteString -> Property-    lookupIndex str = index tbl ident === str-      where Just ident = lookup tbl str+    lookupIndex str = case lookup tbl str of+      Nothing -> property False+      Just ident -> index tbl ident === str      indexLookup :: Int -> Property     indexLookup ident = lookup tbl str === Just ident@@ -76,9 +77,13 @@     strtable = construct strs  enumStrings :: Enum id => StringTable id -> [BS.ByteString]-enumStrings (StringTable bs offsets _ _) = map (index' bs offsets) [0..h-1]-  where (0,h) = A.bounds offsets+enumStrings (StringTable bs offsets _ _) =+  map (index' bs offsets) [lo .. hi - 1]+  where+    (lo, hi) = A.bounds offsets  enumIds :: Enum id => StringTable id -> [id]-enumIds (StringTable _ offsets _ _) = [toEnum 0 .. toEnum (fromIntegral (h-1))]-  where (0,h) = A.bounds offsets+enumIds (StringTable _ offsets _ _) =+  [toEnum (fromIntegral lo) .. toEnum (fromIntegral (hi - 1))]+  where+    (lo, hi) = A.bounds offsets
test/Codec/Archive/Tar/Index/Tests.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module      :  Codec.Archive.Tar.Index.Tests@@ -36,9 +37,7 @@ import qualified Data.ByteString.Char8  as BS.Char8 import qualified Data.ByteString.Lazy   as LBS import Data.Int-#if (MIN_VERSION_base(4,5,0)) import Data.Monoid ((<>))-#endif import qualified System.FilePath.Posix as FilePath import System.IO @@ -48,7 +47,9 @@ import Test.QuickCheck.Property (ioProperty) import Control.Applicative ((<$>), (<*>)) import Control.Monad (unless)-import Data.List (nub, sort, sortBy, stripPrefix, isPrefixOf)+import Data.Bifunctor (first)+import Data.List (nub, sort, sortBy, stripPrefix, isPrefixOf, uncons)+import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Function (on) import Control.Exception (SomeException, try, throwIO)@@ -65,15 +66,15 @@   case (Tar.lookup index p, Prelude.lookup p paths) of     (Nothing,                    Nothing)          -> property True     (Just (TarFileEntry offset), Just (_,offset')) -> offset === offset'-    (Just (TarDir entries),      Nothing)          -> sort (nub (map fst entries))-                                                   === sort (nub completions)+    (Just (TarDir entries),      Nothing)          ->+      fmap NE.head (NE.group (sort (map fst entries))) ===+        fmap NE.head (NE.group (sort completions))     _                                              -> property False   where-    index       = construct paths-    completions = [ hd-                  | (path,_) <- paths-                  , completion <- maybeToList $ stripPrefix (p ++ "/") path-                  , let hd : _ = FilePath.splitDirectories completion ]+    index = construct paths+    completions = map fst $+      mapMaybe (uncons . FilePath.splitDirectories) $+        mapMaybe (stripPrefix (p ++ "/") . fst) paths  prop_toList :: ValidPaths -> Property prop_toList (ValidPaths paths) =@@ -94,10 +95,12 @@      pathbits = concatMap (map BS.Char8.pack . FilePath.splitDirectories . fst)                          paths+     intpaths :: [([IntTrie.Key], IntTrie.Value)]-    intpaths = [ (map (\(Tar.PathComponentId n) -> IntTrie.Key (fromIntegral n)) cids, IntTrie.Value offset)-               | (path, (_size, offset)) <- paths-               , let Just cids = Tar.toComponentIds pathTable path ]+    intpaths =+      map (first (map (\(Tar.PathComponentId n) -> IntTrie.Key (fromIntegral n)))) $+        mapMaybe (\(path, (_size, offset)) -> (, IntTrie.Value offset) <$> Tar.toComponentIds pathTable path) paths+     prop' = conjoin $ flip map paths $ \(file, (_size, offset)) ->       case Tar.lookup index file of         Just (TarFileEntry offset') -> offset' === offset@@ -164,9 +167,9 @@   Next (testEntry "./" 1500) Done <> example0  testEntry :: FilePath -> Int64 -> Entry-testEntry name size = Tar.simpleEntry path (NormalFile mempty size)-  where-    Right path = Tar.toTarPath False name+testEntry name size = case Tar.toTarPath False name of+  Left err -> error err+  Right path -> Tar.simpleEntry path (NormalFile mempty size)  -- | Simple tar archive containing regular files only data SimpleTarArchive = SimpleTarArchive {@@ -231,11 +234,12 @@        mkList :: [(FilePath, LBS.ByteString)] -> [Tar.Entry]       mkList []            = []-      mkList ((fp, bs):es) = entry : mkList es-        where-          Right path = Tar.toTarPath False fp-          entry   = Tar.simpleEntry path content-          content = NormalFile bs (LBS.length bs)+      mkList ((fp, bs):es) = case Tar.toTarPath False fp of+        Left err -> error err+        Right path -> entry : mkList es+          where+            entry   = Tar.simpleEntry path content+            content = NormalFile bs (LBS.length bs)        mkEntries :: [Tar.Entry] -> Tar.Entries ()       mkEntries []     = Tar.Done
test/Codec/Archive/Tar/Tests.hs view
@@ -44,12 +44,15 @@     entries' = map limitToV7FormatCompat $ filter ((== V7Format) . entryFormat) entries  prop_large_filesize :: Word -> Property-prop_large_filesize n = sz === sz'-  where-    sz = fromIntegral $ n * 1024 * 1024 * 128-    Right fn = toTarPath False "Large.file"-    entry = simpleEntry fn (NormalFile (BL.replicate sz 42) sz)-    -- Trim the tail so it does not blow up RAM-    tar = BL.take 2048 $ write [entry]-    Next entry' _ = read tar-    NormalFile _ sz' = entryContent entry'+prop_large_filesize n = case toTarPath False "Large.file" of+  Left{} -> property False+  Right fn -> case read tar of+    Next entry' _ -> case entryContent entry' of+      NormalFile _ sz' -> sz === sz'+      _ -> property False+    _ -> property False+    where+      sz = fromIntegral $ n * 1024 * 1024 * 128+      entry = simpleEntry fn (NormalFile (BL.replicate sz 42) sz)+      -- Trim the tail so it does not blow up RAM+      tar = BL.take 2048 $ write [entry]
test/Codec/Archive/Tar/Types/Tests.hs view
@@ -8,7 +8,9 @@ -- License     :  BSD3 -- -----------------------------------------------------------------------------+{-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}  module Codec.Archive.Tar.Types.Tests   ( limitToV7FormatCompat@@ -78,7 +80,7 @@                     = FilePath.Windows.addTrailingPathSeparator                     | otherwise = id -instance (Arbitrary tarPath, Arbitrary linkTarget) => Arbitrary (GenEntry tarPath linkTarget) where+instance (Arbitrary tarPath, Arbitrary linkTarget, content ~ LBS.ByteString) => Arbitrary (GenEntry content tarPath linkTarget) where   arbitrary = do     entryTarPath <- arbitrary     entryContent <- arbitrary@@ -137,7 +139,7 @@     n <- choose (0, min n sz)     vectorOf n g -instance Arbitrary linkTarget => Arbitrary (GenEntryContent linkTarget) where+instance (Arbitrary linkTarget, content ~ LBS.ByteString) => Arbitrary (GenEntryContent content linkTarget) where   arbitrary =     frequency       [ (16, do bs <- arbitrary;