tar 0.5.1.1 → 0.6.0.0

raw patch · 30 files changed

+2998/−2087 lines, 30 filesdep +file-embeddep +tardep +tasty-benchdep −bytestring-builderdep −criteriondep −old-timedep ~basedep ~bytestringdep ~bytestring-handlenew-uploaderbinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: file-embed, tar, tasty-bench, temporary

Dependencies removed: bytestring-builder, criterion, old-time, semigroups

Dependency ranges changed: base, bytestring, bytestring-handle, containers, directory, time

API changes (from Hackage documentation)

Files

• Codec/Archive/Tar.hs +13/−36
• Codec/Archive/Tar/Check.hs +5/−219
• Codec/Archive/Tar/Check/Internal.hs +301/−0
• Codec/Archive/Tar/Entry.hs +7/−8
• Codec/Archive/Tar/Index.hs +3/−739
• Codec/Archive/Tar/Index/IntTrie.hs +66/−318
• Codec/Archive/Tar/Index/Internal.hs +530/−0
• Codec/Archive/Tar/Index/StringTable.hs +4/−95
• Codec/Archive/Tar/LongNames.hs +153/−0
• Codec/Archive/Tar/Pack.hs +125/−68
• Codec/Archive/Tar/PackAscii.hs +14/−0
• Codec/Archive/Tar/Read.hs +36/−81
• Codec/Archive/Tar/Types.hs +287/−320
• Codec/Archive/Tar/Unpack.hs +214/−47
• Codec/Archive/Tar/Write.hs +48/−29
• README.md +13/−0
• bench/Main.hs +17/−4
• changelog.md +58/−16
• tar.cabal +61/−98
• test/Codec/Archive/Tar/Index/IntTrie/Tests.hs +252/−0
• test/Codec/Archive/Tar/Index/StringTable/Tests.hs +84/−0
• test/Codec/Archive/Tar/Index/Tests.hs +273/−0
• test/Codec/Archive/Tar/Pack/Tests.hs +96/−0
• test/Codec/Archive/Tar/Tests.hs +55/−0
• test/Codec/Archive/Tar/Types/Tests.hs +225/−0
• test/Codec/Archive/Tar/Unpack/Tests.hs +27/−0
• test/Properties.hs +31/−9
• test/data/long-filepath.tar binary
• test/data/long-symlink.tar binary
• test/data/symlink.tar binary

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Codec.Archive.Tar@@ -107,26 +106,36 @@   -- and permissions or to archive special files like named pipes and Unix   -- device files.   pack,+  packAndCheck,   unpack,+  unpackAndCheck,    -- * Types   -- ** Tar entry type   -- | This module provides only very simple and limited read-only access to   -- the 'Entry' type. If you need access to the details or if you need to   -- construct your own entries then also import "Codec.Archive.Tar.Entry".+  GenEntry,   Entry,   entryPath,   entryContent,-  EntryContent(..),+  GenEntryContent(..),+  EntryContent,    -- ** Sequences of tar entries-  Entries(..),+  GenEntries(..),+  Entries,   mapEntries,   mapEntriesNoFail,   foldEntries,   foldlEntries,   unfoldEntries, +  -- ** Long file names+  encodeLongNames,+  decodeLongNames,+  DecodeLongNamesError(..),+   -- * Error handling   -- | Reading tar files can fail if the data does not match the tar file   -- format correctly.@@ -140,14 +149,9 @@    -- ** Errors from reading tar files   FormatError(..),--#ifdef TESTS-  prop_write_read_ustar,-  prop_write_read_gnu,-  prop_write_read_v7,-#endif   ) where +import Codec.Archive.Tar.LongNames import Codec.Archive.Tar.Types  import Codec.Archive.Tar.Read@@ -248,30 +252,3 @@     withFile tar ReadWriteMode $ \hnd -> do       _ <- hSeekEndEntryOffset hnd Nothing       BS.hPut hnd . write =<< pack base paths------------------------------ Correctness properties-----#ifdef TESTS--prop_write_read_ustar :: [Entry] -> Bool-prop_write_read_ustar entries =-    foldr Next Done entries' == read (write entries')-  where-    entries' = [ e { entryFormat = UstarFormat } | e <- entries ]--prop_write_read_gnu :: [Entry] -> Bool-prop_write_read_gnu entries =-    foldr Next Done entries' == read (write entries')-  where-    entries' = [ e { entryFormat = GnuFormat } | e <- entries ]--prop_write_read_v7 :: [Entry] -> Bool-prop_write_read_v7 entries =-    foldr Next Done entries' == read (write entries')-  where-    entries' = [ limitToV7FormatCompat e { entryFormat = V7Format }-               | e <- entries ]--#endif

@@ -1,7 +1,6 @@-{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- |--- Module      :  Codec.Archive.Tar+-- Module      :  Codec.Archive.Tar.Check -- Copyright   :  (c) 2008-2012 Duncan Coutts --                    2011 Max Bolingbroke -- License     :  BSD3@@ -16,232 +15,19 @@    -- * Security   checkSecurity,+  checkEntrySecurity,   FileNameError(..),    -- * Tarbombs   checkTarbomb,+  checkEntryTarbomb,   TarBombError(..),    -- * Portability   checkPortability,+  checkEntryPortability,   PortabilityError(..),   PortabilityPlatform,   ) where -import Codec.Archive.Tar.Types--import Data.Typeable (Typeable)-import Control.Exception (Exception)-import Control.Monad (MonadPlus(mplus))-import qualified System.FilePath as FilePath.Native-         ( splitDirectories, isAbsolute, isValid )--import qualified System.FilePath.Windows as FilePath.Windows-import qualified System.FilePath.Posix   as FilePath.Posix-------------------------------- Security------- | This function checks a sequence of tar entries for file name security--- problems. It checks that:------ * file paths are not absolute------ * file paths do not contain any path components that are \"@..@\"------ * file names are valid------ These checks are from the perspective of the current OS. That means we check--- for \"@C:\blah@\" files on Windows and \"\/blah\" files on Unix. For archive--- entry types 'HardLink' and 'SymbolicLink' the same checks are done for the--- link target. A failure in any entry terminates the sequence of entries with--- an error.----checkSecurity :: Entries e -> Entries (Either e FileNameError)-checkSecurity = checkEntries checkEntrySecurity--checkEntrySecurity :: Entry -> Maybe FileNameError-checkEntrySecurity entry = case entryContent entry of-    HardLink     link -> check (entryPath entry)-                 `mplus` check (fromLinkTarget link)-    SymbolicLink link -> check (entryPath entry)-                 `mplus` check (fromLinkTarget link)-    _                 -> check (entryPath entry)--  where-    check name-      | FilePath.Native.isAbsolute name-      = Just $ AbsoluteFileName name--      | not (FilePath.Native.isValid name)-      = Just $ InvalidFileName name--      | any (=="..") (FilePath.Native.splitDirectories name)-      = Just $ InvalidFileName name--      | otherwise = Nothing---- | Errors arising from tar file names being in some way invalid or dangerous-data FileNameError-  = InvalidFileName FilePath-  | AbsoluteFileName FilePath-  deriving (Typeable)--instance Show FileNameError where-  show = showFileNameError Nothing--instance Exception FileNameError--showFileNameError :: Maybe PortabilityPlatform -> FileNameError -> String-showFileNameError mb_plat err = case err of-    InvalidFileName  path -> "Invalid"  ++ plat ++ " file name in tar archive: " ++ show path-    AbsoluteFileName path -> "Absolute" ++ plat ++ " file name in tar archive: " ++ show path-  where plat = maybe "" (' ':) mb_plat-------------------------------- Tarbombs------- | This function checks a sequence of tar entries for being a \"tar bomb\".--- This means that the tar file does not follow the standard convention that--- all entries are within a single subdirectory, e.g. a file \"foo.tar\" would--- usually have all entries within the \"foo/\" subdirectory.------ Given the expected subdirectory, this function checks all entries are within--- that subdirectroy.------ Note: This check must be used in conjunction with 'checkSecurity'--- (or 'checkPortability').----checkTarbomb :: FilePath -> Entries e -> Entries (Either e TarBombError)-checkTarbomb expectedTopDir = checkEntries (checkEntryTarbomb expectedTopDir)--checkEntryTarbomb :: FilePath -> Entry -> Maybe TarBombError-checkEntryTarbomb _ entry | nonFilesystemEntry = Nothing-  where-    -- Ignore some special entries we will not unpack anyway-    nonFilesystemEntry =-      case entryContent entry of-        OtherEntryType 'g' _ _ -> True --PAX global header-        OtherEntryType 'x' _ _ -> True --PAX individual header-        _                      -> False--checkEntryTarbomb expectedTopDir entry =-  case FilePath.Native.splitDirectories (entryPath entry) of-    (topDir:_) | topDir == expectedTopDir -> Nothing-    _ -> Just $ TarBombError expectedTopDir---- | An error that occurs if a tar file is a \"tar bomb\" that would extract--- files outside of the intended directory.-data TarBombError = TarBombError FilePath-                  deriving (Typeable)--instance Exception TarBombError--instance Show TarBombError where-  show (TarBombError expectedTopDir)-    = "File in tar archive is not in the expected directory " ++ show expectedTopDir-------------------------------- Portability------- | This function checks a sequence of tar entries for a number of portability--- issues. It will complain if:------ * The old \"Unix V7\" or \"gnu\" formats are used. For maximum portability---   only the POSIX standard \"ustar\" format should be used.------ * A non-portable entry type is used. Only ordinary files, hard links,---   symlinks and directories are portable. Device files, pipes and others are---   not portable between all common operating systems.------ * Non-ASCII characters are used in file names. There is no agreed portable---   convention for Unicode or other extended character sets in file names in---   tar archives.------ * File names that would not be portable to both Unix and Windows. This check---   includes characters that are valid in both systems and the \'/\' vs \'\\\'---   directory separator conventions.----checkPortability :: Entries e -> Entries (Either e PortabilityError)-checkPortability = checkEntries checkEntryPortability--checkEntryPortability :: Entry -> Maybe PortabilityError-checkEntryPortability entry-  | entryFormat entry `elem` [V7Format, GnuFormat]-  = Just $ NonPortableFormat (entryFormat entry)--  | not (portableFileType (entryContent entry))-  = Just NonPortableFileType--  | not (all portableChar posixPath)-  = Just $ NonPortableEntryNameChar posixPath--  | not (FilePath.Posix.isValid posixPath)-  = Just $ NonPortableFileName "unix"    (InvalidFileName posixPath)-  | not (FilePath.Windows.isValid windowsPath)-  = Just $ NonPortableFileName "windows" (InvalidFileName windowsPath)--  | FilePath.Posix.isAbsolute posixPath-  = Just $ NonPortableFileName "unix"    (AbsoluteFileName posixPath)-  | FilePath.Windows.isAbsolute windowsPath-  = Just $ NonPortableFileName "windows" (AbsoluteFileName windowsPath)--  | any (=="..") (FilePath.Posix.splitDirectories posixPath)-  = Just $ NonPortableFileName "unix"    (InvalidFileName posixPath)-  | any (=="..") (FilePath.Windows.splitDirectories windowsPath)-  = Just $ NonPortableFileName "windows" (InvalidFileName windowsPath)--  | otherwise = Nothing--  where-    tarPath     = entryTarPath entry-    posixPath   = fromTarPathToPosixPath   tarPath-    windowsPath = fromTarPathToWindowsPath tarPath--    portableFileType ftype = case ftype of-      NormalFile   {} -> True-      HardLink     {} -> True-      SymbolicLink {} -> True-      Directory       -> True-      _               -> False--    portableChar c = c <= '\127'---- | Portability problems in a tar archive-data PortabilityError-  = NonPortableFormat Format-  | NonPortableFileType-  | NonPortableEntryNameChar FilePath-  | NonPortableFileName PortabilityPlatform FileNameError-  deriving (Typeable)---- | The name of a platform that portability issues arise from-type PortabilityPlatform = String--instance Exception PortabilityError--instance Show PortabilityError where-  show (NonPortableFormat format) = "Archive is in the " ++ fmt ++ " format"-    where fmt = case format of V7Format    -> "old Unix V7 tar"-                               UstarFormat -> "ustar" -- I never generate this but a user might-                               GnuFormat   -> "GNU tar"-  show NonPortableFileType        = "Non-portable file type in archive"-  show (NonPortableEntryNameChar posixPath)-    = "Non-portable character in archive entry name: " ++ show posixPath-  show (NonPortableFileName platform err)-    = showFileNameError (Just platform) err-------------------------------- Utils-----checkEntries :: (Entry -> Maybe e') -> Entries e -> Entries (Either e e')-checkEntries checkEntry =-  mapEntries (\entry -> maybe (Right entry) Left (checkEntry entry))+import Codec.Archive.Tar.Check.Internal

@@ -0,0 +1,301 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Codec.Archive.Tar.Check.Internal+-- Copyright   :  (c) 2008-2012 Duncan Coutts+--                    2011 Max Bolingbroke+-- License     :  BSD3+--+-- Maintainer  :  duncan@community.haskell.org+-- Portability :  portable+--+-- Perform various checks on tar file entries.+--+-----------------------------------------------------------------------------+module Codec.Archive.Tar.Check.Internal (++  -- * Security+  checkSecurity,+  checkEntrySecurity,+  FileNameError(..),++  -- * Tarbombs+  checkTarbomb,+  checkEntryTarbomb,+  TarBombError(..),++  -- * Portability+  checkPortability,+  checkEntryPortability,+  PortabilityError(..),+  PortabilityPlatform,+  ) where++import Codec.Archive.Tar.LongNames+import Codec.Archive.Tar.Types+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 )++import qualified System.FilePath.Windows as FilePath.Windows+import qualified System.FilePath.Posix   as FilePath.Posix+++--------------------------+-- Security+--++-- | This function checks a sequence of tar entries for file name security+-- problems. It checks that:+--+-- * file paths are not absolute+--+-- * file paths do not refer outside of the archive+--+-- * file names are valid+--+-- These checks are from the perspective of the current OS. That means we check+-- for \"@C:\blah@\" files on Windows and \"\/blah\" files on Unix. For archive+-- entry types 'HardLink' and 'SymbolicLink' the same checks are done for the+-- link target. A failure in any entry terminates the sequence of entries with+-- an error.+--+checkSecurity+  :: Entries e+  -> GenEntries FilePath FilePath (Either (Either e DecodeLongNamesError) FileNameError)+checkSecurity = checkEntries checkEntrySecurity . decodeLongNames++-- | Worker of 'checkSecurity'.+--+-- @since 0.6.0.0+checkEntrySecurity :: GenEntry FilePath FilePath -> Maybe FileNameError+checkEntrySecurity e =+  check (entryTarPath e) <|>+  case entryContent e of+    HardLink     link ->+      check link+    SymbolicLink link ->+      check (FilePath.Posix.takeDirectory (entryTarPath e) FilePath.Posix.</> link)+    _ -> Nothing+  where+    checkPosix name+      | FilePath.Posix.isAbsolute name+      = Just $ AbsoluteFileName name+      | not (FilePath.Posix.isValid name)+      = Just $ InvalidFileName name+      | not (isInsideBaseDir (FilePath.Posix.splitDirectories name))+      = Just $ UnsafeLinkTarget name+      | otherwise = Nothing++    checkNative (fromFilePathToNative -> name)+      | FilePath.Native.isAbsolute name || FilePath.Native.hasDrive name+      = Just $ AbsoluteFileName name+      | not (FilePath.Native.isValid name)+      = Just $ InvalidFileName name+      | not (isInsideBaseDir (FilePath.Native.splitDirectories name))+      = Just $ UnsafeLinkTarget name+      | otherwise = Nothing++    check name = checkPosix name <|> checkNative (fromFilePathToNative name)++isInsideBaseDir :: [FilePath] -> Bool+isInsideBaseDir = go 0+  where+    go :: Word -> [FilePath] -> Bool+    go !_ [] = True+    go 0 (".." : _) = False+    go lvl (".." : xs) = go (lvl - 1) xs+    go lvl ("." : xs) = go lvl xs+    go lvl (_ : xs) = go (lvl + 1) xs++-- | Errors arising from tar file names being in some way invalid or dangerous+data FileNameError+  = InvalidFileName FilePath+  | AbsoluteFileName FilePath+  | UnsafeLinkTarget FilePath+  -- ^ @since 0.6.0.0+  deriving (Typeable)++instance Show FileNameError where+  show = showFileNameError Nothing++instance Exception FileNameError++showFileNameError :: Maybe PortabilityPlatform -> FileNameError -> String+showFileNameError mb_plat err = case err of+    InvalidFileName  path -> "Invalid"  ++ plat ++ " file name in tar archive: " ++ show path+    AbsoluteFileName path -> "Absolute" ++ plat ++ " file name in tar archive: " ++ show path+    UnsafeLinkTarget path -> "Unsafe"   ++ plat ++ " link target in tar archive: " ++ show path+  where plat = maybe "" (' ':) mb_plat+++--------------------------+-- Tarbombs+--++-- | This function checks a sequence of tar entries for being a \"tar bomb\".+-- This means that the tar file does not follow the standard convention that+-- all entries are within a single subdirectory, e.g. a file \"foo.tar\" would+-- usually have all entries within the \"foo/\" subdirectory.+--+-- Given the expected subdirectory, this function checks all entries are within+-- that subdirectroy.+--+-- Note: This check must be used in conjunction with 'checkSecurity'+-- (or 'checkPortability').+--+checkTarbomb+  :: FilePath+  -> Entries e+  -> GenEntries FilePath FilePath (Either (Either e DecodeLongNamesError) TarBombError)+checkTarbomb expectedTopDir+  = checkEntries (checkEntryTarbomb expectedTopDir)+  . decodeLongNames++-- | Worker of 'checkTarbomb'.+--+-- @since 0.6.0.0+checkEntryTarbomb :: FilePath -> GenEntry FilePath linkTarget -> Maybe TarBombError+checkEntryTarbomb expectedTopDir entry = do+  case entryContent entry of+    -- Global extended header aka XGLTYPE aka pax_global_header+    -- https://pubs.opengroup.org/onlinepubs/9699919799/utilities/pax.html#tag_20_92_13_02+    OtherEntryType 'g' _ _ -> Nothing+    -- Extended header referring to the next file in the archive aka XHDTYPE+    OtherEntryType 'x' _ _ -> Nothing+    _                      ->+      case FilePath.Posix.splitDirectories (entryTarPath entry) of+        (topDir:_) | topDir == expectedTopDir -> Nothing+        _ -> Just $ TarBombError expectedTopDir (entryTarPath entry)++-- | An error that occurs if a tar file is a \"tar bomb\" that would extract+-- files outside of the intended directory.+data TarBombError+  = TarBombError+    FilePath -- ^ Path inside archive.+             --+             -- @since 0.6.0.0+    FilePath -- ^ Expected top directory.+  deriving (Typeable)++instance Exception TarBombError++instance Show TarBombError where+  show (TarBombError expectedTopDir tarBombPath)+    = "File in tar archive, " ++ show tarBombPath +++    ", is not in the expected directory " ++ show expectedTopDir++--------------------------+-- Portability+--++-- | This function checks a sequence of tar entries for a number of portability+-- issues. It will complain if:+--+-- * The old \"Unix V7\" or \"gnu\" formats are used. For maximum portability+--   only the POSIX standard \"ustar\" format should be used.+--+-- * A non-portable entry type is used. Only ordinary files, hard links,+--   symlinks and directories are portable. Device files, pipes and others are+--   not portable between all common operating systems.+--+-- * Non-ASCII characters are used in file names. There is no agreed portable+--   convention for Unicode or other extended character sets in file names in+--   tar archives.+--+-- * File names that would not be portable to both Unix and Windows. This check+--   includes characters that are valid in both systems and the \'/\' vs \'\\\'+--   directory separator conventions.+--+checkPortability+  :: Entries e+  -> GenEntries 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 entry+  | entryFormat entry `elem` [V7Format, GnuFormat]+  = Just $ NonPortableFormat (entryFormat entry)++  | not (portableFileType (entryContent entry))+  = Just NonPortableFileType++  | not (all portableChar posixPath)+  = Just $ NonPortableEntryNameChar posixPath++  | not (FilePath.Posix.isValid posixPath)+  = Just $ NonPortableFileName "unix"    (InvalidFileName posixPath)+  | not (FilePath.Windows.isValid windowsPath)+  = Just $ NonPortableFileName "windows" (InvalidFileName windowsPath)++  | FilePath.Posix.isAbsolute posixPath+  = Just $ NonPortableFileName "unix"    (AbsoluteFileName posixPath)+  | FilePath.Windows.isAbsolute windowsPath+  = Just $ NonPortableFileName "windows" (AbsoluteFileName windowsPath)++  | any (=="..") (FilePath.Posix.splitDirectories posixPath)+  = Just $ NonPortableFileName "unix"    (InvalidFileName posixPath)+  | any (=="..") (FilePath.Windows.splitDirectories windowsPath)+  = Just $ NonPortableFileName "windows" (InvalidFileName windowsPath)++  | otherwise = Nothing++  where+    posixPath   = entryTarPath entry+    windowsPath = fromFilePathToWindowsPath posixPath++    portableFileType ftype = case ftype of+      NormalFile   {} -> True+      HardLink     {} -> True+      SymbolicLink {} -> True+      Directory       -> True+      _               -> False++    portableChar c = c <= '\127'++-- | Portability problems in a tar archive+data PortabilityError+  = NonPortableFormat Format+  | NonPortableFileType+  | NonPortableEntryNameChar FilePath+  | NonPortableFileName PortabilityPlatform FileNameError+  deriving (Typeable)++-- | The name of a platform that portability issues arise from+type PortabilityPlatform = String++instance Exception PortabilityError++instance Show PortabilityError where+  show (NonPortableFormat format) = "Archive is in the " ++ fmt ++ " format"+    where fmt = case format of V7Format    -> "old Unix V7 tar"+                               UstarFormat -> "ustar" -- I never generate this but a user might+                               GnuFormat   -> "GNU tar"+  show NonPortableFileType        = "Non-portable file type in archive"+  show (NonPortableEntryNameChar posixPath)+    = "Non-portable character in archive entry name: " ++ show posixPath+  show (NonPortableFileName platform err)+    = showFileNameError (Just platform) err++--------------------------+-- Utils++checkEntries+  :: (GenEntry tarPath linkTarget -> Maybe e')+  -> GenEntries tarPath linkTarget e+  -> GenEntries tarPath linkTarget (Either e e')+checkEntries checkEntry =+  mapEntries (\entry -> maybe (Right entry) Left (checkEntry entry))

@@ -25,14 +25,11 @@ module Codec.Archive.Tar.Entry (    -- * Tar entry and associated types-  Entry(..),-  --TODO: should be the following with the Entry constructor not exported,-  --      but haddock cannot document that properly-  --      see http://trac.haskell.org/haddock/ticket/3-  --Entry(filePath, fileMode, ownerId, groupId, fileSize, modTime,-  --      fileType, linkTarget, headerExt, fileContent),+  GenEntry(..),+  Entry,   entryPath,-  EntryContent(..),+  GenEntryContent(..),+  EntryContent,   Ownership(..),    FileSize,@@ -47,6 +44,8 @@   simpleEntry,   fileEntry,   directoryEntry,+  longLinkEntry,+  longSymLinkEntry,    -- * Standard file permissions   -- | For maximum portability when constructing archives use only these file@@ -58,6 +57,7 @@   -- * Constructing entries from disk files   packFileEntry,   packDirectoryEntry,+  packSymlinkEntry,   getDirectoryContentsRecursive,    -- * TarPath type@@ -73,7 +73,6 @@   fromLinkTarget,   fromLinkTargetToPosixPath,   fromLinkTargetToWindowsPath,-   ) where  import Codec.Archive.Tar.Types

@@ -1,6 +1,3 @@-{-# LANGUAGE CPP, BangPatterns, PatternGuards #-}-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}- ----------------------------------------------------------------------------- -- | -- Module      :  Codec.Archive.Tar.Index@@ -69,199 +66,17 @@     nextEntryOffset,     indexEndEntryOffset,     indexNextEntryOffset,--    -- * Deprecated aliases-    emptyIndex,-    finaliseIndex,--#ifdef TESTS-    prop_lookup,-    prop_toList,-    prop_valid,-    prop_serialise_deserialise,-    prop_serialiseSize,-    prop_index_matches_tar,-    prop_finalise_unfinalise,-#endif   ) 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-import Codec.Archive.Tar.Index.StringTable (StringTable, StringTableBuilder)-import qualified Codec.Archive.Tar.Index.IntTrie as IntTrie-import Codec.Archive.Tar.Index.IntTrie (IntTrie, IntTrieBuilder)--import qualified System.FilePath.Posix as FilePath-import Data.Monoid (Monoid(..))-#if (MIN_VERSION_base(4,5,0))-import Data.Monoid ((<>))-#endif-import Data.Word-import Data.Int-import Data.Bits-import qualified Data.Array.Unboxed as A import Prelude hiding (lookup)-import System.IO-import Control.Exception (assert, throwIO)-import Control.DeepSeq--import qualified Data.ByteString        as BS-import qualified Data.ByteString.Char8  as BS.Char8-import qualified Data.ByteString.Lazy   as LBS-import qualified Data.ByteString.Unsafe as BS-#if MIN_VERSION_bytestring(0,10,2) || defined(MIN_VERSION_bytestring_builder)-import Data.ByteString.Builder          as BS-import Data.ByteString.Builder.Extra    as BS (toLazyByteStringWith,-                                               untrimmedStrategy)-#else-import Data.ByteString.Lazy.Builder     as BS-import Data.ByteString.Lazy.Builder.Extras as BS (toLazyByteStringWith,-                                                  untrimmedStrategy)-#endif--#ifdef TESTS-import qualified Prelude-import Test.QuickCheck-import Test.QuickCheck.Property (ioProperty)-import Control.Applicative ((<$>), (<*>))-import Control.Monad (unless)-import Data.List (nub, sort, sortBy, stripPrefix, isPrefixOf)-import Data.Maybe-import Data.Function (on)-import Control.Exception (SomeException, try)-import Codec.Archive.Tar.Write          as Tar-import qualified Data.ByteString.Handle as HBS-#endif----- | An index of the entries in a tar file.------ This index type is designed to be quite compact and suitable to store either--- on disk or in memory.----data TarIndex = TarIndex--  -- As an example of how the mapping works, consider these example files:-  --   "foo/bar.hs" at offset 0-  --   "foo/baz.hs" at offset 1024-  ---  -- We split the paths into components and enumerate them.-  --   { "foo" -> TokenId 0, "bar.hs" -> TokenId 1,  "baz.hs" -> TokenId 2 }-  ---  -- We convert paths into sequences of 'TokenId's, i.e.-  --   "foo/bar.hs" becomes [PathComponentId 0, PathComponentId 1]-  --   "foo/baz.hs" becomes [PathComponentId 0, PathComponentId 2]-  ---  -- We use a trie mapping sequences of 'PathComponentId's to the entry offset:-  --  { [PathComponentId 0, PathComponentId 1] -> offset 0-  --  , [PathComponentId 0, PathComponentId 2] -> offset 1024 }--  -- The mapping of filepath components as strings to ids.-  {-# UNPACK #-} !(StringTable PathComponentId)--  -- Mapping of sequences of filepath component ids to tar entry offsets.-  {-# UNPACK #-} !(IntTrie PathComponentId TarEntryOffset)--  -- The offset immediatly after the last entry, where we would append any-  -- additional entries.-  {-# UNPACK #-} !TarEntryOffset--  deriving (Eq, Show, Typeable)--instance NFData TarIndex where-  rnf (TarIndex _ _ _) = () -- fully strict by construction---- | The result of 'lookup' in a 'TarIndex'. It can either be a file directly,--- or a directory entry containing further entries (and all subdirectories--- recursively). Note that the subtrees are constructed lazily, so it's--- cheaper if you don't look at them.----data TarIndexEntry = TarFileEntry {-# UNPACK #-} !TarEntryOffset-                   | TarDir [(FilePath, TarIndexEntry)]-  deriving (Show, Typeable)---newtype PathComponentId = PathComponentId Int-  deriving (Eq, Ord, Enum, Show, Typeable)---- | An offset within a tar file. Use 'hReadEntry', 'hReadEntryHeader' or--- 'hSeekEntryOffset'.------ This is actually a tar \"record\" number, not a byte offset.----type TarEntryOffset = Word32----- | Look up a given filepath in the 'TarIndex'. It may return a 'TarFileEntry'--- containing the 'TarEntryOffset' of the file within the tar file, or if--- the filepath identifies a directory then it returns a 'TarDir' containing--- the list of files within that directory.------ Given the 'TarEntryOffset' you can then use one of the I\/O operations:------ * 'hReadEntry' to read the whole entry;------ * 'hReadEntryHeader' to read just the file metadata (e.g. its length);----lookup :: TarIndex -> FilePath -> Maybe TarIndexEntry-lookup (TarIndex pathTable pathTrie _) path = do-    fpath  <- toComponentIds pathTable path-    tentry <- IntTrie.lookup pathTrie fpath-    return (mkIndexEntry tentry)-  where-    mkIndexEntry (IntTrie.Entry offset)        = TarFileEntry offset-    mkIndexEntry (IntTrie.Completions entries) =-      TarDir [ (fromComponentId pathTable key, mkIndexEntry entry)-             | (key, entry) <- entries ]---toComponentIds :: StringTable PathComponentId -> FilePath -> Maybe [PathComponentId]-toComponentIds table =-    lookupComponents []-  . filter (/= BS.Char8.singleton '.')-  . splitDirectories-  . BS.Char8.pack-  where-    lookupComponents cs' []     = Just (reverse cs')-    lookupComponents cs' (c:cs) = case StringTable.lookup table c of-      Nothing  -> Nothing-      Just cid -> lookupComponents (cid:cs') cs--fromComponentId :: StringTable PathComponentId -> PathComponentId -> FilePath-fromComponentId table = BS.Char8.unpack . StringTable.index table---- | All the files in the index with their corresponding 'TarEntryOffset's.------ Note that the files are in no special order. If you intend to read all or--- most files then is is recommended to sort by the 'TarEntryOffset'.----toList :: TarIndex -> [(FilePath, TarEntryOffset)]-toList (TarIndex pathTable pathTrie _) =-    [ (path, off)-    | (cids, off) <- IntTrie.toList pathTrie-    , let path = FilePath.joinPath (map (fromComponentId pathTable) cids) ]----- | Build a 'TarIndex' from a sequence of tar 'Entries'. The 'Entries' are--- assumed to start at offset @0@ within a file.----build :: Entries e -> Either e TarIndex-build = go empty-  where-    go !builder (Next e es) = go (addNextEntry e builder) es-    go !builder  Done       = Right $! finalise builder-    go !_       (Fail err)  = Left err-+import Codec.Archive.Tar.Index.Internal  -- $incremental-construction -- If you need more control than 'build' then you can construct the index--- in an acumulator style using the 'IndexBuilder' and operations.+-- in an accumulator style using the 'IndexBuilder' and operations. -- -- Start with 'empty' and use 'addNextEntry' (or 'skipNextEntry') for--- each 'Entry' in the tar file in order. Every entry must added or skipped in+-- each 'Codec.Archive.Tar.Entry.Entry' in the tar file in order. Every entry must added or skipped in -- order, otherwise the resulting 'TarIndex' will report the wrong -- 'TarEntryOffset's. At the end use 'finalise' to get the 'TarIndex'. --@@ -272,554 +87,3 @@ -- >     go !builder (Next e es) = go (addNextEntry e builder) es -- >     go !builder  Done       = Right $! finalise builder -- >     go !_       (Fail err)  = Left err----- | The intermediate type used for incremental construction of a 'TarIndex'.----data IndexBuilder-   = IndexBuilder !(StringTableBuilder PathComponentId)-                  !(IntTrieBuilder PathComponentId TarEntryOffset)-   {-# UNPACK #-} !TarEntryOffset-  deriving (Eq, Show)--instance NFData IndexBuilder where-  rnf (IndexBuilder _ _ _) = () -- fully strict by construction---- | The initial empty 'IndexBuilder'.----empty :: IndexBuilder-empty = IndexBuilder StringTable.empty IntTrie.empty 0--emptyIndex :: IndexBuilder-emptyIndex = empty-{-# DEPRECATED emptyIndex "Use TarIndex.empty" #-}---- | Add the next 'Entry' into the 'IndexBuilder'.----addNextEntry :: Entry -> IndexBuilder -> IndexBuilder-addNextEntry entry (IndexBuilder stbl itrie nextOffset) =-    IndexBuilder stbl' itrie'-                 (nextEntryOffset entry nextOffset)-  where-    !entrypath    = splitTarPath (entryTarPath entry)-    (stbl', cids) = StringTable.inserts entrypath stbl-    itrie'        = IntTrie.insert cids nextOffset itrie---- | Use this function if you want to skip some entries and not add them to the--- final 'TarIndex'.----skipNextEntry :: Entry -> IndexBuilder -> IndexBuilder-skipNextEntry entry (IndexBuilder stbl itrie nextOffset) =-    IndexBuilder stbl itrie (nextEntryOffset entry nextOffset)---- | Finish accumulating 'Entry' information and build the compact 'TarIndex'--- lookup structure.----finalise :: IndexBuilder -> TarIndex-finalise (IndexBuilder stbl itrie finalOffset) =-    TarIndex pathTable pathTrie finalOffset-  where-    pathTable = StringTable.finalise stbl-    pathTrie  = IntTrie.finalise itrie--finaliseIndex :: IndexBuilder -> TarIndex-finaliseIndex = finalise-{-# DEPRECATED finaliseIndex "Use TarIndex.finalise" #-}---- | This is the offset immediately following the entry most recently added--- to the 'IndexBuilder'. You might use this if you need to know the offsets--- but don't want to use the 'TarIndex' lookup structure.--- Use with 'hSeekEntryOffset'. See also 'nextEntryOffset'.----indexNextEntryOffset :: IndexBuilder -> TarEntryOffset-indexNextEntryOffset (IndexBuilder _ _ off) = off---- | This is the offset immediately following the last entry in the tar file.--- This can be useful to append further entries into the tar file.--- Use with 'hSeekEntryOffset', or just use 'hSeekEndEntryOffset' directly.----indexEndEntryOffset :: TarIndex -> TarEntryOffset-indexEndEntryOffset (TarIndex _ _ off) = off---- | Calculate the 'TarEntryOffset' of the next entry, given the size and--- offset of the current entry.------ This is much like using 'skipNextEntry' and 'indexNextEntryOffset', but without--- using an 'IndexBuilder'.----nextEntryOffset :: Entry -> TarEntryOffset -> TarEntryOffset-nextEntryOffset entry offset =-    offset-  + 1-  + case entryContent entry of-      NormalFile     _   size -> blocks size-      OtherEntryType _ _ size -> blocks size-      _                       -> 0-  where-    -- NOTE: to avoid underflow, do the (fromIntegral :: Int64 -> Word32) last-    blocks :: Int64 -> TarEntryOffset-    blocks size = fromIntegral (1 + (size - 1) `div` 512)--type FilePathBS = BS.ByteString--splitTarPath :: TarPath -> [FilePathBS]-splitTarPath (TarPath name prefix) =-    splitDirectories prefix ++ splitDirectories name--splitDirectories :: FilePathBS -> [FilePathBS]-splitDirectories bs =-    case BS.Char8.split '/' bs of-      c:cs | BS.null c -> BS.Char8.singleton '/' : filter (not . BS.null) cs-      cs               ->                          filter (not . BS.null) cs------------------------------- Resume building an existing index------- | Resume building an existing index------ A 'TarIndex' is optimized for a highly compact and efficient in-memory--- representation. This, however, makes it read-only. If you have an existing--- 'TarIndex' for a large file, and want to add to it, you can translate the--- 'TarIndex' back to an 'IndexBuilder'. Be aware that this is a relatively--- costly operation (linear in the size of the 'TarIndex'), though still--- faster than starting again from scratch.------ This is the left inverse to 'finalise' (modulo ordering).----unfinalise :: TarIndex -> IndexBuilder-unfinalise (TarIndex pathTable pathTrie finalOffset) =-    IndexBuilder (StringTable.unfinalise pathTable)-                 (IntTrie.unfinalise pathTrie)-                 finalOffset------------------------------- I/O operations------- | Reads an entire 'Entry' at the given 'TarEntryOffset' in the tar file.--- The 'Handle' must be open for reading and be seekable.------ This reads the whole entry into memory strictly, not incrementally. For more--- control, use 'hReadEntryHeader' and then read the entry content manually.----hReadEntry :: Handle -> TarEntryOffset -> IO Entry-hReadEntry hnd off = do-    entry <- hReadEntryHeader hnd off-    case entryContent entry of-      NormalFile       _ size -> do body <- LBS.hGet hnd (fromIntegral size)-                                    return entry {-                                      entryContent = NormalFile body size-                                    }-      OtherEntryType c _ size -> do body <- LBS.hGet hnd (fromIntegral size)-                                    return entry {-                                      entryContent = OtherEntryType c body size-                                    }-      _                       -> return entry---- | Read the header for a 'Entry' at the given 'TarEntryOffset' in the tar--- file. The 'entryContent' will contain the correct metadata but an empty file--- content. The 'Handle' must be open for reading and be seekable.------ The 'Handle' position is advanced to the beginning of the entry content (if--- any). You must check the 'entryContent' to see if the entry is of type--- 'NormalFile'. If it is, the 'NormalFile' gives the content length and you--- are free to read this much data from the 'Handle'.------ > entry <- Tar.hReadEntryHeader hnd--- > case Tar.entryContent entry of--- >   Tar.NormalFile _ size -> do content <- BS.hGet hnd size--- >                               ...------ Of course you don't have to read it all in one go (as 'hReadEntry' does),--- you can use any appropriate method to read it incrementally.------ In addition to I\/O errors, this can throw a 'FormatError' if the offset is--- wrong, or if the file is not valid tar format.------ There is also the lower level operation 'hSeekEntryOffset'.----hReadEntryHeader :: Handle -> TarEntryOffset -> IO Entry-hReadEntryHeader hnd blockOff = do-    hSeekEntryOffset hnd blockOff-    header <- LBS.hGet hnd 512-    case Tar.read header of-      Tar.Next entry _ -> return entry-      Tar.Fail e       -> throwIO e-      Tar.Done         -> fail "hReadEntryHeader: impossible"---- | Set the 'Handle' position to the position corresponding to the given--- 'TarEntryOffset'.------ This position is where the entry metadata can be read. If you already know--- the entry has a body (and perhaps know it's length), you may wish to seek to--- the body content directly using 'hSeekEntryContentOffset'.----hSeekEntryOffset :: Handle -> TarEntryOffset -> IO ()-hSeekEntryOffset hnd blockOff =-    hSeek hnd AbsoluteSeek (fromIntegral blockOff * 512)---- | Set the 'Handle' position to the entry content position corresponding to--- the given 'TarEntryOffset'.------ This position is where the entry content can be read using ordinary I\/O--- operations (though you have to know in advance how big the entry content--- is). This is /only valid/ if you /already know/ the entry has a body (i.e.--- is a normal file).----hSeekEntryContentOffset :: Handle -> TarEntryOffset -> IO ()-hSeekEntryContentOffset hnd blockOff =-    hSeekEntryOffset hnd (blockOff + 1)---- | This is a low level variant on 'hReadEntryHeader', that can be used to--- iterate through a tar file, entry by entry.------ It has a few differences compared to 'hReadEntryHeader':------ * It returns an indication when the end of the tar file is reached.------ * It /does not/ move the 'Handle' position to the beginning of the entry---   content.------ * It returns the 'TarEntryOffset' of the next entry.------ After this action, the 'Handle' position is not in any useful place. If--- you want to skip to the next entry, take the 'TarEntryOffset' returned and--- use 'hReadEntryHeaderOrEof' again. Or if having inspected the 'Entry'--- header you want to read the entry content (if it has one) then use--- 'hSeekEntryContentOffset' on the original input 'TarEntryOffset'.----hReadEntryHeaderOrEof :: Handle -> TarEntryOffset-                      -> IO (Maybe (Entry, TarEntryOffset))-hReadEntryHeaderOrEof hnd blockOff = do-    hSeekEntryOffset hnd blockOff-    header <- LBS.hGet hnd 1024-    case Tar.read header of-      Tar.Next entry _ -> let !blockOff' = nextEntryOffset entry blockOff-                           in return (Just (entry, blockOff'))-      Tar.Done         -> return Nothing-      Tar.Fail e       -> throwIO e---- | Seek to the end of a tar file, to the position where new entries can--- be appended, and return that 'TarEntryOffset'.------ If you have a valid 'TarIndex' for this tar file then you should supply it--- because it allows seeking directly to the correct location.------ If you do not have an index, then this becomes an expensive linear--- operation because we have to read each tar entry header from the beginning--- to find the location immediately after the last entry (this is because tar--- files have a variable length trailer and we cannot reliably find that by--- starting at the end). In this mode, it will fail with an exception if the--- file is not in fact in the tar format.----hSeekEndEntryOffset :: Handle -> Maybe TarIndex -> IO TarEntryOffset-hSeekEndEntryOffset hnd (Just index) = do-    let offset = indexEndEntryOffset index-    hSeekEntryOffset hnd offset-    return offset--hSeekEndEntryOffset hnd Nothing = do-    size <- hFileSize hnd-    if size == 0-      then return 0-      else seekToEnd 0-  where-    seekToEnd offset = do-      mbe <- hReadEntryHeaderOrEof hnd offset-      case mbe of-        Nothing -> do hSeekEntryOffset hnd offset-                      return offset-        Just (_, offset') -> seekToEnd offset'------------------------------ (de)serialisation------- | The 'TarIndex' is compact in memory, and it has a similarly compact--- external representation.----serialise :: TarIndex -> BS.ByteString-serialise = toStrict . serialiseLBS---- we keep this version around just so we can check we got the size right.-serialiseLBS :: TarIndex -> LBS.ByteString-serialiseLBS index =-    BS.toLazyByteStringWith-      (BS.untrimmedStrategy (serialiseSize index) 512) LBS.empty-      (serialiseBuilder index)--serialiseSize :: TarIndex -> Int-serialiseSize (TarIndex stringTable intTrie _) =-    StringTable.serialiseSize stringTable-  + IntTrie.serialiseSize intTrie-  + 8--serialiseBuilder :: TarIndex -> BS.Builder-serialiseBuilder (TarIndex stringTable intTrie finalOffset) =-     BS.word32BE 2 -- format version-  <> BS.word32BE finalOffset-  <> StringTable.serialise stringTable-  <> IntTrie.serialise intTrie---- | Read the external representation back into a 'TarIndex'.----deserialise :: BS.ByteString -> Maybe (TarIndex, BS.ByteString)-deserialise bs-  | BS.length bs < 8-  = Nothing--  | let ver = readWord32BE bs 0-  , ver == 1-  = do let !finalOffset = readWord32BE bs 4-       (stringTable, bs')  <- StringTable.deserialiseV1 (BS.drop 8 bs)-       (intTrie,     bs'') <- IntTrie.deserialise bs'-       return (TarIndex stringTable intTrie finalOffset, bs'')--  | let ver = readWord32BE bs 0-  , ver == 2-  = do let !finalOffset = readWord32BE bs 4-       (stringTable, bs')  <- StringTable.deserialiseV2 (BS.drop 8 bs)-       (intTrie,     bs'') <- IntTrie.deserialise bs'-       return (TarIndex stringTable intTrie finalOffset, bs'')--  | otherwise = Nothing--readWord32BE :: BS.ByteString -> Int -> Word32-readWord32BE bs i =-    assert (i >= 0 && i+3 <= BS.length bs - 1) $-    fromIntegral (BS.unsafeIndex bs (i + 0)) `shiftL` 24-  + fromIntegral (BS.unsafeIndex bs (i + 1)) `shiftL` 16-  + fromIntegral (BS.unsafeIndex bs (i + 2)) `shiftL` 8-  + fromIntegral (BS.unsafeIndex bs (i + 3))------------------------------- Test properties-----#ifdef TESTS---- Not quite the properties of a finite mapping because we also have lookups--- that result in completions.--prop_lookup :: ValidPaths -> NonEmptyFilePath -> Bool-prop_lookup (ValidPaths paths) (NonEmptyFilePath p) =-  case (lookup index p, Prelude.lookup p paths) of-    (Nothing,                    Nothing)          -> True-    (Just (TarFileEntry offset), Just (_,offset')) -> offset == offset'-    (Just (TarDir entries),      Nothing)          -> sort (nub (map fst entries))-                                                   == sort (nub completions)-    _                                              -> False-  where-    index       = construct paths-    completions = [ head (FilePath.splitDirectories completion)-                  | (path,_) <- paths-                  , completion <- maybeToList $ stripPrefix (p ++ "/") path ]--prop_toList :: ValidPaths -> Bool-prop_toList (ValidPaths paths) =-    sort (toList index)- == sort [ (path, off) | (path, (_sz, off)) <- paths ]-  where-    index = construct paths--prop_valid :: ValidPaths -> Bool-prop_valid (ValidPaths paths)-  | not $ StringTable.prop_valid   pathbits = error "TarIndex: bad string table"-  | not $ IntTrie.prop_lookup      intpaths = error "TarIndex: bad int trie"-  | not $ IntTrie.prop_completions intpaths = error "TarIndex: bad int trie"-  | not $ prop'                             = error "TarIndex: bad prop"-  | otherwise                               = True--  where-    index@(TarIndex pathTable _ _) = construct paths--    pathbits = concatMap (map BS.Char8.pack . FilePath.splitDirectories . fst)-                         paths-    intpaths = [ (cids, offset)-               | (path, (_size, offset)) <- paths-               , let Just cids = toComponentIds pathTable path ]-    prop' = flip all paths $ \(file, (_size, offset)) ->-      case lookup index file of-        Just (TarFileEntry offset') -> offset' == offset-        _                           -> False--prop_serialise_deserialise :: ValidPaths -> Bool-prop_serialise_deserialise (ValidPaths paths) =-    Just (index, BS.empty) == (deserialise . serialise) index-  where-    index = construct paths--prop_serialiseSize :: ValidPaths -> Bool-prop_serialiseSize (ValidPaths paths) =-    case (LBS.toChunks . serialiseLBS) index of-      [c1] -> BS.length c1 == serialiseSize index-      _    -> False-  where-    index = construct paths--newtype NonEmptyFilePath = NonEmptyFilePath FilePath deriving Show--instance Arbitrary NonEmptyFilePath where-  arbitrary = NonEmptyFilePath . FilePath.joinPath-                <$> listOf1 (elements ["a", "b", "c", "d"])--newtype ValidPaths = ValidPaths [(FilePath, (Int64, TarEntryOffset))] deriving Show--instance Arbitrary ValidPaths where-  arbitrary = do-      paths <- makeNoPrefix <$> listOf arbitraryPath-      sizes <- vectorOf (length paths) (getNonNegative <$> arbitrary)-      let offsets = scanl (\o sz -> o + 1 + blocks sz) 0 sizes-      return (ValidPaths (zip paths (zip sizes offsets)))-    where-      arbitraryPath   = FilePath.joinPath-                         <$> listOf1 (elements ["a", "b", "c", "d"])-      makeNoPrefix [] = []-      makeNoPrefix (k:ks)-        | all (not . isPrefixOfOther k) ks-                     = k : makeNoPrefix ks-        | otherwise  =     makeNoPrefix ks--      isPrefixOfOther a b = a `isPrefixOf` b || b `isPrefixOf` a--      blocks :: Int64 -> TarEntryOffset-      blocks size = fromIntegral (1 + ((size - 1) `div` 512))---- Helper for bulk construction.-construct :: [(FilePath, (Int64, TarEntryOffset))] -> TarIndex-construct =-    either (\_ -> undefined) id-  . build-  . foldr (\(path, (size, _off)) es -> Next (testEntry path size) es) Done--example0 :: Entries ()-example0 =-         testEntry "foo-1.0/foo-1.0.cabal" 1500 -- at block 0-  `Next` testEntry "foo-1.0/LICENSE"       2000 -- at block 4-  `Next` testEntry "foo-1.0/Data/Foo.hs"   1000 -- at block 9-  `Next` Done--example1 :: Entries ()-example1 =-  Next (testEntry "./" 1500) Done <> example0--testEntry :: FilePath -> Int64 -> Entry-testEntry name size = simpleEntry path (NormalFile mempty size)-  where-    Right path = toTarPath False name---- | Simple tar archive containing regular files only-data SimpleTarArchive = SimpleTarArchive {-    simpleTarEntries :: Tar.Entries ()-  , simpleTarRaw     :: [(FilePath, LBS.ByteString)]-  , simpleTarBS      :: LBS.ByteString-  }--instance Show SimpleTarArchive where-  show = show . simpleTarRaw--prop_index_matches_tar :: SimpleTarArchive -> Property-prop_index_matches_tar sta =-    ioProperty (try go >>= either (\e -> throwIO (e :: SomeException))-                                  (\_ -> return True))-  where-    go :: IO ()-    go = do-      h <- HBS.readHandle True (simpleTarBS sta)-      goEntries h 0 (simpleTarEntries sta)--    goEntries :: Handle -> TarEntryOffset -> Tar.Entries () -> IO ()-    goEntries _ _ Tar.Done =-      return ()-    goEntries _ _ (Tar.Fail _) =-      throwIO (userError "Fail entry in SimpleTarArchive")-    goEntries h offset (Tar.Next e es) = do-      goEntry h offset e-      goEntries h (nextEntryOffset e offset) es--    goEntry :: Handle -> TarEntryOffset -> Tar.Entry -> IO ()-    goEntry h offset e = do-      e' <- hReadEntry h offset-      case (Tar.entryContent e, Tar.entryContent e') of-        (Tar.NormalFile bs sz, Tar.NormalFile bs' sz') ->-          unless (sz == sz' && bs == bs') $-            throwIO $ userError "Entry mismatch"-        _otherwise ->-          throwIO $ userError "unexpected entry types"--instance Arbitrary SimpleTarArchive where-  arbitrary = do-      numEntries <- sized $ \n -> choose (0, n)-      rawEntries <- mkRaw numEntries-      let entries = mkList rawEntries-      return SimpleTarArchive {-          simpleTarEntries = mkEntries entries-        , simpleTarRaw     = rawEntries-        , simpleTarBS      = Tar.write entries-        }-    where-      mkRaw :: Int -> Gen [(FilePath, LBS.ByteString)]-      mkRaw 0 = return []-      mkRaw n = do-         -- Pick a size around 0, 1, or 2 block boundaries-         sz <- sized $ \n -> elements (take n fileSizes)-         bs <- LBS.pack `fmap` vectorOf sz arbitrary-         es <- mkRaw (n - 1)-         return $ ("file" ++ show n, bs) : es--      mkList :: [(FilePath, LBS.ByteString)] -> [Tar.Entry]-      mkList []            = []-      mkList ((fp, bs):es) = entry : mkList es-        where-          Right path = toTarPath False fp-          entry   = simpleEntry path content-          content = NormalFile bs (LBS.length bs)--      mkEntries :: [Tar.Entry] -> Tar.Entries ()-      mkEntries []     = Tar.Done-      mkEntries (e:es) = Tar.Next e (mkEntries es)--      -- Sizes around 0, 1, and 2 block boundaries-      fileSizes :: [Int]-      fileSizes = [-                           0 ,    1 ,    2-        ,  510 ,  511 ,  512 ,  513 ,  514-        , 1022 , 1023 , 1024 , 1025 , 1026-        ]---- | 'IndexBuilder' constructed from a 'SimpleIndex'-newtype SimpleIndexBuilder = SimpleIndexBuilder IndexBuilder-  deriving Show--instance Arbitrary SimpleIndexBuilder where-  arbitrary = SimpleIndexBuilder . build' . simpleTarEntries <$> arbitrary-    where-      -- like 'build', but don't finalize-      build' :: Show e => Entries e -> IndexBuilder-      build' = go empty-        where-          go !builder (Next e es) = go (addNextEntry e builder) es-          go !builder  Done       = builder-          go !_       (Fail err)  = error (show err)--prop_finalise_unfinalise :: SimpleIndexBuilder -> Bool-prop_finalise_unfinalise (SimpleIndexBuilder index) =-    unfinalise (finalise index) == index--#endif--toStrict :: LBS.ByteString -> BS.ByteString-#if MIN_VERSION_bytestring(0,10,0)-toStrict = LBS.toStrict-#else-toStrict = BS.concat . LBS.toChunks-#endif--#if !(MIN_VERSION_base(4,5,0))-(<>) :: Monoid m => m -> m -> m-(<>) = mappend-#endif

@@ -3,11 +3,11 @@  module Codec.Archive.Tar.Index.IntTrie ( -  IntTrie,+  IntTrie(..),   construct,   toList, -  IntTrieBuilder,+  IntTrieBuilder(..),   empty,   insert,   finalise,@@ -20,20 +20,18 @@   serialiseSize,   deserialise, -#ifdef TESTS-  test1, test2, test3,-  ValidPaths(..),-  prop_lookup,-  prop_completions,-  prop_lookup_mono,-  prop_completions_mono,-  prop_construct_toList,-  prop_finalise_unfinalise,-  prop_serialise_deserialise,-  prop_serialiseSize,-#endif- ) where+  TrieNode(..),+  Completions,+  inserts,+  completionsFrom,+  flattenTrie,+  tagLeaf,+  tagNode, +  Key(..),+  Value(..),+  ) where+ import Prelude hiding (lookup)  import Data.Typeable (Typeable)@@ -44,141 +42,40 @@ import Data.Word (Word32) import Data.Bits import Data.Monoid (Monoid(..))-#if (MIN_VERSION_base(4,5,0)) import Data.Monoid ((<>))-#endif import qualified Data.ByteString        as BS import qualified Data.ByteString.Lazy   as LBS import qualified Data.ByteString.Unsafe as BS-#if MIN_VERSION_bytestring(0,10,2) || defined(MIN_VERSION_bytestring_builder) import Data.ByteString.Builder          as BS-#else-import Data.ByteString.Lazy.Builder     as BS-#endif import Control.Exception (assert)-#if MIN_VERSION_containers(0,5,0) import qualified Data.Map.Strict        as Map import qualified Data.IntMap.Strict     as IntMap import Data.IntMap.Strict (IntMap)-#else-import qualified Data.Map               as Map-import qualified Data.IntMap            as IntMap-import Data.IntMap (IntMap)-#endif  import Data.List hiding (lookup, insert) import Data.Function (on) -#ifdef TESTS-import Test.QuickCheck-import Control.Applicative ((<$>), (<*>))-#endif-- -- | A compact mapping from sequences of nats to nats. -- -- NOTE: The tries in this module have values /only/ at the leaves (which -- correspond to files), they do not have values at the branch points (which -- correspond to directories).-newtype IntTrie k v = IntTrie (A.UArray Word32 Word32)+newtype IntTrie = IntTrie (A.UArray Word32 Word32)     deriving (Eq, Show, Typeable) +-- | The most significant bit is used for tagging,+-- see 'tagLeaf' / 'tagNode' below, so morally it's Word31 only.+newtype Key = Key { unKey :: Word32 }+  deriving (Eq, Ord, Show) +newtype Value = Value { unValue :: Word32 }+  deriving (Eq, Ord, Show)+ -- Compact, read-only implementation of a trie. It's intended for use with file -- paths, but we do that via string ids. -#ifdef TESTS--- Example mapping:----example0 :: [(FilePath, Int)]-example0 =-  [("foo-1.0/foo-1.0.cabal", 512)   -- tar block 1-  ,("foo-1.0/LICENSE",       2048)  -- tar block 4-  ,("foo-1.0/Data/Foo.hs",   4096)] -- tar block 8---- After converting path components to integers this becomes:----example1 :: [([Word32], Word32)]-example1 =-  [([1,2],   512)-  ,([1,3],   2048)-  ,([1,4,5], 4096)]---- As a trie this looks like:----  [ (1, *) ]---        |---        [ (2, 512), (3, 1024), (4, *) ]---                                   |---                                   [ (5, 4096) ]---- We use an intermediate trie representation--mktrie :: [(Int, TrieNode k v)] -> IntTrieBuilder k v-mkleaf :: (Enum k, Enum v) => k -> v                  -> (Int, TrieNode k v)-mknode ::  Enum k          => k -> IntTrieBuilder k v -> (Int, TrieNode k v)--mktrie = IntTrieBuilder . IntMap.fromList-mkleaf k v = (fromEnum k, TrieLeaf (enumToWord32 v))-mknode k t = (fromEnum k, TrieNode t) --example2 :: IntTrieBuilder Word32 Word32-example2 = mktrie [ mknode 1 t1 ]-  where-    t1   = mktrie [ mkleaf 2 512, mkleaf 3 2048, mknode 4 t2 ]-    t2   = mktrie [ mkleaf 5 4096 ]---example2' :: IntTrieBuilder Word32 Word32-example2' = mktrie [ mknode 0 t1 ]-  where-    t1   = mktrie [ mknode 3 t2 ]-    t2   = mktrie [ mknode 1 t3, mknode 2 t4 ]-    t3   = mktrie [ mkleaf 4 10608 ]-    t4   = mktrie [ mkleaf 4 10612 ]-{--0: [1,N0,3]--  3: [1,N3,6]--   6: [2,N1,N2,11,12]--     11: [1,4,10608]-     14: [1,4,10612]--}--example2'' :: IntTrieBuilder Word32 Word32-example2'' = mktrie [ mknode 1 t1, mknode 2 t2 ]-  where-    t1   = mktrie [ mkleaf 4 10608 ]-    t2   = mktrie [ mkleaf 4 10612 ]--example2''' :: IntTrieBuilder Word32 Word32-example2''' = mktrie [ mknode 0 t3 ]-  where-    t3  = mktrie [ mknode 4 t8, mknode 6 t11 ]-    t8  = mktrie [ mknode 1 t14 ]-    t11 = mktrie [ mkleaf 5 10605 ]-    t14 = mktrie [ mknode 2 t19, mknode 3 t22 ]-    t19 = mktrie [ mkleaf 7 10608 ]-    t22 = mktrie [ mkleaf 7 10612 ]-{-- 0: [1,N0,3]- 3: [2,N4,N6,8,11]- 8: [1,N1,11]-11: [1,5,10605]-14: [2,N2,N3,16,19]-19: [1,7,10608]-22: [1,7,10612]--}---- We convert from the 'Paths' to the 'IntTrieBuilder' using 'inserts':----test1 = example2 == inserts example1 empty-#endif- -- Each node has a size and a sequence of keys followed by an equal length--- sequnce of corresponding entries. Since we're going to flatten this into+-- sequence of corresponding entries. Since we're going to flatten this into -- a single array then we will need to replace the trie structure with pointers -- represented as array offsets. @@ -193,52 +90,18 @@ isNode :: Word32 -> Bool isNode = flip Bits.testBit 31 --- So the overall array form of the above trie is:------ offset:   0   1    2    3   4  5  6    7    8     9     10  11  12--- array:  [ 1 | N1 | 3 ][ 3 | 2, 3, N4 | 512, 2048, 10 ][ 1 | 5 | 4096 ]---                     \__/                           \___/--#ifdef TESTS-example3 :: [Word32]-example3 =- [1, tagNode 1,-     3,-  3, tagLeaf 2, tagLeaf 3, tagNode 4,-     512,       2048,      10,-  1, tagLeaf 5,-     4096- ]---- We get the array form by using flattenTrie:--test2 = example3 == flattenTrie example2--example4 :: IntTrie Int Int-example4 = IntTrie (mkArray example3)--mkArray :: [Word32] -> A.UArray Word32 Word32-mkArray xs = A.listArray (0, fromIntegral (length xs) - 1) xs--test3 = case lookup example4 [1] of-          Just (Completions [(2,_),(3,_),(4,_)]) -> True-          _                          -> False--test1, test2, test3 :: Bool-#endif- ------------------------------------- -- Decoding the trie array form -- -completionsFrom :: (Enum k, Enum v) => IntTrie k v -> Word32 -> Completions k v+completionsFrom :: IntTrie -> Word32 -> Completions completionsFrom trie@(IntTrie arr) nodeOff =-    [ (word32ToEnum (untag key), next)+    [ (Key (untag key), next)     | keyOff <- [keysStart..keysEnd]     , let key   = arr ! keyOff           entry = arr ! (keyOff + nodeSize)           next | isNode key = Completions (completionsFrom trie entry)-               | otherwise  = Entry (word32ToEnum entry)+               | otherwise  = Entry (Value entry)     ]   where     nodeSize  = arr ! nodeOff@@ -248,10 +111,10 @@ -- | Convert the trie to a list -- -- This is the left inverse to 'construct' (modulo ordering).-toList :: forall k v. (Enum k, Enum v) => IntTrie k v -> [([k], v)]+toList :: IntTrie -> [([Key], Value)] toList = concatMap (aux []) . (`completionsFrom` 0)   where-    aux :: [k] -> (k, TrieLookup k v) -> [([k], v)]+    aux :: [Key] -> (Key, TrieLookup) -> [([Key], Value)]     aux ks (k, Entry v)        = [(reverse (k:ks), v)]     aux ks (k, Completions cs) = concatMap (aux (k:ks)) cs @@ -265,7 +128,7 @@ -- | Build an 'IntTrie' from a bunch of (key, value) pairs, where the keys -- are sequences. ---construct :: (Enum k, Enum v) => [([k], v)] -> IntTrie k v+construct :: [([Key], Value)] -> IntTrie construct = finalise . flip inserts empty  @@ -273,13 +136,15 @@ -- Looking up in the trie array -- -data TrieLookup  k v = Entry !v | Completions (Completions k v) deriving Show-type Completions k v = [(k, TrieLookup k v)]+data TrieLookup = Entry !Value | Completions Completions+  deriving (Eq, Ord, Show) -lookup :: forall k v. (Enum k, Enum v) => IntTrie k v -> [k] -> Maybe (TrieLookup k v)+type Completions = [(Key, TrieLookup)]++lookup :: IntTrie -> [Key] -> Maybe TrieLookup lookup trie@(IntTrie arr) = go 0   where-    go :: Word32 -> [k] -> Maybe (TrieLookup k v)+    go :: Word32 -> [Key] -> Maybe TrieLookup     go nodeOff []     = Just (completions nodeOff)     go nodeOff (k:ks) = case search nodeOff (tagLeaf k') of       Just entryOff@@ -289,9 +154,9 @@         Nothing       -> Nothing         Just entryOff -> go (arr ! entryOff) ks       where-        k' = enumToWord32 k+        k' = unKey k -    entry       entryOff = Entry (word32ToEnum (arr ! entryOff))+    entry       entryOff = Entry (Value (arr ! entryOff))     completions nodeOff  = Completions (completionsFrom trie nodeOff)      search :: Word32 -> Word32 -> Maybe Word32@@ -310,77 +175,73 @@           GT -> bsearch (mid+1) b key       where mid = (a + b) `div` 2 --enumToWord32 :: Enum n => n -> Word32-enumToWord32 = fromIntegral . fromEnum--word32ToEnum :: Enum n => Word32 -> n-word32ToEnum = toEnum . fromIntegral-- ------------------------- -- Building Tries -- -newtype IntTrieBuilder k v = IntTrieBuilder (IntMap (TrieNode k v))+newtype IntTrieBuilder = IntTrieBuilder (IntMap TrieNode)   deriving (Show, Eq) -data TrieNode k v = TrieLeaf {-# UNPACK #-} !Word32-                  | TrieNode !(IntTrieBuilder k v)+data TrieNode = TrieLeaf {-# UNPACK #-} !Word32+              | TrieNode !IntTrieBuilder   deriving (Show, Eq) -empty :: IntTrieBuilder k v+empty :: IntTrieBuilder empty = IntTrieBuilder IntMap.empty -insert :: (Enum k, Enum v) => [k] -> v-       -> IntTrieBuilder k v -> IntTrieBuilder k v+insert :: [Key] -> Value+       -> IntTrieBuilder -> IntTrieBuilder insert []    _v t = t-insert (k:ks) v t = insertTrie (fromEnum k) (map fromEnum ks) (enumToWord32 v) t+insert (k:ks) v t = insertTrie+  (fromIntegral (unKey k) :: Int)+  (map (fromIntegral . unKey) ks :: [Int])+  (unValue v)+  t  insertTrie :: Int -> [Int] -> Word32-           -> IntTrieBuilder k v -> IntTrieBuilder k v+           -> IntTrieBuilder -> IntTrieBuilder insertTrie k ks v (IntTrieBuilder t) =     IntTrieBuilder $       IntMap.alter (\t' -> Just $! maybe (freshTrieNode  ks v)                                          (insertTrieNode ks v) t')                    k t -insertTrieNode :: [Int] -> Word32 -> TrieNode k v -> TrieNode k v+insertTrieNode :: [Int] -> Word32 -> TrieNode -> TrieNode insertTrieNode []     v  _           = TrieLeaf v insertTrieNode (k:ks) v (TrieLeaf _) = TrieNode (freshTrie  k ks v) insertTrieNode (k:ks) v (TrieNode t) = TrieNode (insertTrie k ks v t) -freshTrie :: Int -> [Int] -> Word32 -> IntTrieBuilder k v+freshTrie :: Int -> [Int] -> Word32 -> IntTrieBuilder freshTrie k []      v =   IntTrieBuilder (IntMap.singleton k (TrieLeaf v)) freshTrie k (k':ks) v =   IntTrieBuilder (IntMap.singleton k (TrieNode (freshTrie k' ks v))) -freshTrieNode :: [Int] -> Word32 -> TrieNode k v+freshTrieNode :: [Int] -> Word32 -> TrieNode freshTrieNode []     v = TrieLeaf v freshTrieNode (k:ks) v = TrieNode (freshTrie k ks v) -inserts :: (Enum k, Enum v) => [([k], v)]-        -> IntTrieBuilder k v -> IntTrieBuilder k v+inserts :: [([Key], Value)]+        -> IntTrieBuilder -> IntTrieBuilder inserts kvs t = foldl' (\t' (ks, v) -> insert ks v t') t kvs -finalise :: IntTrieBuilder k v -> IntTrie k v+finalise :: IntTrieBuilder -> IntTrie finalise trie =     IntTrie $       A.listArray (0, fromIntegral (flatTrieLength trie) - 1)                   (flattenTrie trie) -unfinalise :: (Enum k, Enum v) => IntTrie k v -> IntTrieBuilder k v+unfinalise :: IntTrie -> IntTrieBuilder unfinalise trie =     go (completionsFrom trie 0)   where     go kns =       IntTrieBuilder $         IntMap.fromList-          [ (fromEnum k, t)+          [ (fromIntegral (unKey k) :: Int, t)           | (k, n) <- kns           , let t = case n of-                      Entry       v    -> TrieLeaf (enumToWord32 v)+                      Entry       v    -> TrieLeaf (unValue v)                       Completions kns' -> TrieNode (go kns')           ] @@ -390,7 +251,7 @@  type Offset = Int -flatTrieLength :: IntTrieBuilder k v -> Int+flatTrieLength :: IntTrieBuilder -> Int flatTrieLength (IntTrieBuilder tns) =     1   + 2 * IntMap.size tns@@ -401,12 +262,12 @@ -- time we put them into the list. We keep a running offset so we know where -- to allocate next. ---flattenTrie :: IntTrieBuilder k v -> [Word32]+flattenTrie :: IntTrieBuilder -> [Word32] flattenTrie trie = go (queue [trie]) (size trie)   where     size (IntTrieBuilder tns) = 1 + 2 * IntMap.size tns -    go :: Q (IntTrieBuilder k v) -> Offset -> [Word32]+    go :: Q IntTrieBuilder -> Offset -> [Word32]     go todo !offset =       case dequeue todo of         Nothing                   -> []@@ -418,19 +279,13 @@                    : Map.keys  keysValues                   ++ Map.elems keysValues             (!offset', !keysValues, !tries') =-#if MIN_VERSION_containers(0,4,2)               IntMap.foldlWithKey' accumNodes                                    (offset, Map.empty, tries)                                    tnodes-#else-              foldl' (\a (k,v) -> accumNodes a k v)-                     (offset, Map.empty, tries)-                     (IntMap.toList tnodes)-#endif -    accumNodes :: (Offset, Map.Map Word32 Word32, Q (IntTrieBuilder k v))-               -> Int -> TrieNode k v-               -> (Offset, Map.Map Word32 Word32, Q (IntTrieBuilder k v))+    accumNodes :: (Offset, Map.Map Word32 Word32, Q IntTrieBuilder)+               -> Int -> TrieNode+               -> (Offset, Map.Map Word32 Word32, Q IntTrieBuilder)     accumNodes (!off, !kvs, !tries) !k (TrieLeaf v) =         (off, kvs', tries)       where@@ -464,19 +319,19 @@ -- (de)serialisation -- -serialise :: IntTrie k v -> BS.Builder+serialise :: IntTrie -> BS.Builder serialise (IntTrie arr) =     let (_, !ixEnd) = A.bounds arr in     BS.word32BE (ixEnd+1)  <> foldr (\n r -> BS.word32BE n <> r) mempty (A.elems arr) -serialiseSize :: IntTrie k v -> Int+serialiseSize :: IntTrie -> Int serialiseSize (IntTrie arr) =     let (_, ixEnd) = A.bounds arr in     4   + 4 * (fromIntegral ixEnd + 1) -deserialise :: BS.ByteString -> Maybe (IntTrie k v, BS.ByteString)+deserialise :: BS.ByteString -> Maybe (IntTrie, BS.ByteString) deserialise bs   | BS.length bs >= 4   , let lenArr   = readWord32BE bs 0@@ -498,110 +353,3 @@   + fromIntegral (BS.unsafeIndex bs (i + 1)) `shiftL` 16   + fromIntegral (BS.unsafeIndex bs (i + 2)) `shiftL` 8   + fromIntegral (BS.unsafeIndex bs (i + 3))------------------------------- Correctness property-----#ifdef TESTS--prop_lookup :: (Ord k, Enum k, Eq v, Enum v, Show k, Show v)-            => [([k], v)] -> Bool-prop_lookup paths =-  flip all paths $ \(key, value) ->-    case lookup trie key of-      Just (Entry value') | value' == value -> True-      Just (Entry value')   -> error $ "IntTrie: " ++ show (key, value, value')-      Nothing               -> error $ "IntTrie: didn't find " ++ show key-      Just (Completions xs) -> error $ "IntTrie: " ++ show xs--  where-    trie = construct paths--prop_completions :: forall k v. (Ord k, Enum k, Eq v, Enum v) => [([k], v)] -> Bool-prop_completions paths =-    inserts paths empty - == convertCompletions (completionsFrom (construct paths) 0)-  where-    convertCompletions :: Ord k => Completions k v -> IntTrieBuilder k v-    convertCompletions kls =-      IntTrieBuilder $-        IntMap.fromList-          [ case l of-              Entry v          -> mkleaf k v-              Completions kls' -> mknode k (convertCompletions kls')-          | (k, l) <- sortBy (compare `on` fst) kls ]---prop_lookup_mono :: ValidPaths -> Bool-prop_lookup_mono (ValidPaths paths) = prop_lookup paths--prop_completions_mono :: ValidPaths -> Bool-prop_completions_mono (ValidPaths paths) = prop_completions paths--prop_construct_toList :: ValidPaths -> Bool-prop_construct_toList (ValidPaths paths) =-       sortBy (compare `on` fst) (toList (construct paths))-    == sortBy (compare `on` fst) paths--prop_finalise_unfinalise :: ValidPaths -> Bool-prop_finalise_unfinalise (ValidPaths paths) =-    builder == unfinalise (finalise builder)-  where-    builder :: IntTrieBuilder Char Char-    builder = inserts paths empty--prop_serialise_deserialise :: ValidPaths -> Bool-prop_serialise_deserialise (ValidPaths paths) =-    Just (trie, BS.empty) == (deserialise-                            . toStrict . BS.toLazyByteString-                            . serialise) trie-  where-    trie :: IntTrie Char Char-    trie = construct paths--prop_serialiseSize :: ValidPaths -> Bool-prop_serialiseSize (ValidPaths paths) =-    (fromIntegral . LBS.length . BS.toLazyByteString . serialise) trie- == serialiseSize trie-  where-    trie :: IntTrie Char Char-    trie = construct paths--newtype ValidPaths = ValidPaths [([Char], Char)] deriving Show--instance Arbitrary ValidPaths where-  arbitrary =-      ValidPaths . makeNoPrefix <$> listOf ((,) <$> listOf1 arbitrary <*> arbitrary)-    where-      makeNoPrefix [] = []-      makeNoPrefix ((k,v):kvs)-        | all (\(k', _) -> not (isPrefixOfOther k k')) kvs-                     = (k,v) : makeNoPrefix kvs-        | otherwise  =         makeNoPrefix kvs--  shrink (ValidPaths kvs) =-      map ValidPaths . filter noPrefix . filter nonEmpty . shrink $ kvs-    where-      noPrefix []           = True-      noPrefix ((k,_):kvs') = all (\(k', _) -> not (isPrefixOfOther k k')) kvs'-                           && noPrefix kvs'-      nonEmpty = all (not . null . fst)--isPrefixOfOther a b = a `isPrefixOf` b || b `isPrefixOf` a--toStrict :: LBS.ByteString -> BS.ByteString-#if MIN_VERSION_bytestring(0,10,0)-toStrict = LBS.toStrict-#else-toStrict = BS.concat . LBS.toChunks-#endif--#endif--#if !(MIN_VERSION_base(4,5,0))-(<>) :: Monoid m => m -> m -> m-(<>) = mappend-#endif-

@@ -0,0 +1,530 @@+{-# LANGUAGE CPP, BangPatterns, PatternGuards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Codec.Archive.Tar.Index.Internal+-- Copyright   :  (c) 2010-2015 Duncan Coutts+-- License     :  BSD3+--+-- Maintainer  :  duncan@community.haskell.org+-- Portability :  portable+--+-----------------------------------------------------------------------------+module Codec.Archive.Tar.Index.Internal (++    -- * Index type+    TarIndex(..),++    -- * Index lookup+    lookup,+    TarIndexEntry(..),+    toList,+    PathComponentId(..),++    -- ** I\/O operations+    TarEntryOffset,+    hReadEntry,+    hReadEntryHeader,++    -- * Index construction+    build,+    -- ** Incremental construction+    IndexBuilder,+    empty,+    addNextEntry,+    skipNextEntry,+    finalise,+    unfinalise,++    -- * Serialising indexes+    serialise,+    deserialise,++    -- * Lower level operations with offsets and I\/O on tar files+    hReadEntryHeaderOrEof,+    hSeekEntryOffset,+    hSeekEntryContentOffset,+    hSeekEndEntryOffset,+    nextEntryOffset,+    indexEndEntryOffset,+    indexNextEntryOffset,++    toComponentIds,+    serialiseLBS,+    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+import Codec.Archive.Tar.Index.StringTable (StringTable, StringTableBuilder)+import qualified Codec.Archive.Tar.Index.IntTrie as IntTrie+import Codec.Archive.Tar.Index.IntTrie (IntTrie, IntTrieBuilder)+import Codec.Archive.Tar.PackAscii++import qualified System.FilePath.Posix as FilePath+import Data.Monoid (Monoid(..))+import Data.Monoid ((<>))+import Data.Word+import Data.Int+import Data.Bits+import qualified Data.Array.Unboxed as A+import Prelude hiding (lookup)+import System.IO+import Control.Exception (assert, throwIO)+import Control.DeepSeq++import qualified Data.ByteString        as BS+import qualified Data.ByteString.Char8  as BS.Char8+import qualified Data.ByteString.Lazy   as LBS+import qualified Data.ByteString.Unsafe as BS+import Data.ByteString.Builder          as BS+import Data.ByteString.Builder.Extra    as BS (toLazyByteStringWith,+                                               untrimmedStrategy)++-- | An index of the entries in a tar file.+--+-- This index type is designed to be quite compact and suitable to store either+-- on disk or in memory.+--+data TarIndex = TarIndex++  -- As an example of how the mapping works, consider these example files:+  --   "foo/bar.hs" at offset 0+  --   "foo/baz.hs" at offset 1024+  --+  -- We split the paths into components and enumerate them.+  --   { "foo" -> TokenId 0, "bar.hs" -> TokenId 1,  "baz.hs" -> TokenId 2 }+  --+  -- We convert paths into sequences of 'TokenId's, i.e.+  --   "foo/bar.hs" becomes [PathComponentId 0, PathComponentId 1]+  --   "foo/baz.hs" becomes [PathComponentId 0, PathComponentId 2]+  --+  -- We use a trie mapping sequences of 'PathComponentId's to the entry offset:+  --  { [PathComponentId 0, PathComponentId 1] -> offset 0+  --  , [PathComponentId 0, PathComponentId 2] -> offset 1024 }++  -- The mapping of filepath components as strings to ids.+  {-# UNPACK #-} !(StringTable PathComponentId)++  -- Mapping of sequences of filepath component ids to tar entry offsets.+  {-# UNPACK #-} !IntTrie -- key = PathComponentId, value = TarEntryOffset++  -- The offset immediatly after the last entry, where we would append any+  -- additional entries.+  {-# UNPACK #-} !TarEntryOffset++  deriving (Eq, Show, Typeable)++instance NFData TarIndex where+  rnf (TarIndex _ _ _) = () -- fully strict by construction++-- | The result of 'lookup' in a 'TarIndex'. It can either be a file directly,+-- or a directory entry containing further entries (and all subdirectories+-- recursively). Note that the subtrees are constructed lazily, so it's+-- cheaper if you don't look at them.+--+data TarIndexEntry = TarFileEntry {-# UNPACK #-} !TarEntryOffset+                   | TarDir [(FilePath, TarIndexEntry)]+  deriving (Show, Typeable)+++newtype PathComponentId = PathComponentId Int+  deriving (Eq, Ord, Enum, Show, Typeable)++-- | An offset within a tar file. Use 'hReadEntry', 'hReadEntryHeader' or+-- 'hSeekEntryOffset'.+--+-- This is actually a tar \"record\" number, not a byte offset.+--+type TarEntryOffset = Word32+++-- | Look up a given filepath in the 'TarIndex'. It may return a 'TarFileEntry'+-- containing the 'TarEntryOffset' of the file within the tar file, or if+-- the filepath identifies a directory then it returns a 'TarDir' containing+-- the list of files within that directory.+--+-- Given the 'TarEntryOffset' you can then use one of the I\/O operations:+--+-- * 'hReadEntry' to read the whole entry;+--+-- * 'hReadEntryHeader' to read just the file metadata (e.g. its length);+--+lookup :: TarIndex -> FilePath -> Maybe TarIndexEntry+lookup (TarIndex pathTable pathTrie _) path = do+    fpath  <- toComponentIds pathTable path+    tentry <- IntTrie.lookup pathTrie $ map pathComponentIdToKey fpath+    return (mkIndexEntry tentry)+  where+    mkIndexEntry (IntTrie.Entry offset)        = TarFileEntry $ IntTrie.unValue offset+    mkIndexEntry (IntTrie.Completions entries) =+      TarDir [ (fromComponentId pathTable $ keyToPathComponentId key, mkIndexEntry entry)+             | (key, entry) <- entries ]+++toComponentIds :: StringTable PathComponentId -> FilePath -> Maybe [PathComponentId]+toComponentIds table =+    lookupComponents []+  . filter (/= BS.Char8.singleton '.')+  . splitDirectories+  . packAscii+  where+    lookupComponents cs' []     = Just (reverse cs')+    lookupComponents cs' (c:cs) = case StringTable.lookup table c of+      Nothing  -> Nothing+      Just cid -> lookupComponents (cid:cs') cs++fromComponentId :: StringTable PathComponentId -> PathComponentId -> FilePath+fromComponentId table = BS.Char8.unpack . StringTable.index table++-- | All the files in the index with their corresponding 'TarEntryOffset's.+--+-- Note that the files are in no special order. If you intend to read all or+-- most files then is is recommended to sort by the 'TarEntryOffset'.+--+toList :: TarIndex -> [(FilePath, TarEntryOffset)]+toList (TarIndex pathTable pathTrie _) =+    [ (path, IntTrie.unValue off)+    | (cids, off) <- IntTrie.toList pathTrie+    , let path = FilePath.joinPath (map (fromComponentId pathTable . keyToPathComponentId) cids) ]+++-- | Build a 'TarIndex' from a sequence of tar 'Entries'. The 'Entries' are+-- assumed to start at offset @0@ within a file.+--+build :: Entries e -> Either e TarIndex+build = go empty+  where+    go !builder (Next e es) = go (addNextEntry e builder) es+    go !builder  Done       = Right $! finalise builder+    go !_       (Fail err)  = Left err++-- | The intermediate type used for incremental construction of a 'TarIndex'.+--+data IndexBuilder+   = IndexBuilder !(StringTableBuilder PathComponentId)+                  !IntTrieBuilder -- key = PathComponentId, value = TarEntryOffset+   {-# UNPACK #-} !TarEntryOffset+  deriving (Eq, Show)++instance NFData IndexBuilder where+  rnf (IndexBuilder _ _ _) = () -- fully strict by construction++-- | The initial empty 'IndexBuilder'.+--+empty :: IndexBuilder+empty = IndexBuilder StringTable.empty IntTrie.empty 0++-- | Add the next 'Entry' into the 'IndexBuilder'.+--+addNextEntry :: Entry -> IndexBuilder -> IndexBuilder+addNextEntry entry (IndexBuilder stbl itrie nextOffset) =+    IndexBuilder stbl' itrie'+                 (nextEntryOffset entry nextOffset)+  where+    !entrypath    = splitTarPath (entryTarPath entry)+    (stbl', cids) = StringTable.inserts entrypath stbl+    itrie'        = IntTrie.insert (map pathComponentIdToKey cids) (IntTrie.Value nextOffset) itrie++-- | Use this function if you want to skip some entries and not add them to the+-- final 'TarIndex'.+--+skipNextEntry :: Entry -> IndexBuilder -> IndexBuilder+skipNextEntry entry (IndexBuilder stbl itrie nextOffset) =+    IndexBuilder stbl itrie (nextEntryOffset entry nextOffset)++-- | Finish accumulating 'Entry' information and build the compact 'TarIndex'+-- lookup structure.+--+finalise :: IndexBuilder -> TarIndex+finalise (IndexBuilder stbl itrie finalOffset) =+    TarIndex pathTable pathTrie finalOffset+  where+    pathTable = StringTable.finalise stbl+    pathTrie  = IntTrie.finalise itrie++-- | This is the offset immediately following the entry most recently added+-- to the 'IndexBuilder'. You might use this if you need to know the offsets+-- but don't want to use the 'TarIndex' lookup structure.+-- Use with 'hSeekEntryOffset'. See also 'nextEntryOffset'.+--+indexNextEntryOffset :: IndexBuilder -> TarEntryOffset+indexNextEntryOffset (IndexBuilder _ _ off) = off++-- | This is the offset immediately following the last entry in the tar file.+-- This can be useful to append further entries into the tar file.+-- Use with 'hSeekEntryOffset', or just use 'hSeekEndEntryOffset' directly.+--+indexEndEntryOffset :: TarIndex -> TarEntryOffset+indexEndEntryOffset (TarIndex _ _ off) = off++-- | Calculate the 'TarEntryOffset' of the next entry, given the size and+-- offset of the current entry.+--+-- This is much like using 'skipNextEntry' and 'indexNextEntryOffset', but without+-- using an 'IndexBuilder'.+--+nextEntryOffset :: Entry -> TarEntryOffset -> TarEntryOffset+nextEntryOffset entry offset =+    offset+  + 1+  + case entryContent entry of+      NormalFile     _   size -> blocks size+      OtherEntryType _ _ size -> blocks size+      _                       -> 0+  where+    -- NOTE: to avoid underflow, do the (fromIntegral :: Int64 -> Word32) last+    blocks :: Int64 -> TarEntryOffset+    blocks size = fromIntegral (1 + (size - 1) `div` 512)++type FilePathBS = BS.ByteString++splitTarPath :: TarPath -> [FilePathBS]+splitTarPath (TarPath name prefix) =+    splitDirectories prefix ++ splitDirectories name++splitDirectories :: FilePathBS -> [FilePathBS]+splitDirectories bs =+    case BS.Char8.split '/' bs of+      c:cs | BS.null c -> BS.Char8.singleton '/' : filter (not . BS.null) cs+      cs               ->                          filter (not . BS.null) cs+++-------------------------+-- Resume building an existing index+--++-- | Resume building an existing index+--+-- A 'TarIndex' is optimized for a highly compact and efficient in-memory+-- representation. This, however, makes it read-only. If you have an existing+-- 'TarIndex' for a large file, and want to add to it, you can translate the+-- 'TarIndex' back to an 'IndexBuilder'. Be aware that this is a relatively+-- costly operation (linear in the size of the 'TarIndex'), though still+-- faster than starting again from scratch.+--+-- This is the left inverse to 'finalise' (modulo ordering).+--+unfinalise :: TarIndex -> IndexBuilder+unfinalise (TarIndex pathTable pathTrie finalOffset) =+    IndexBuilder (StringTable.unfinalise pathTable)+                 (IntTrie.unfinalise pathTrie)+                 finalOffset+++-------------------------+-- I/O operations+--++-- | Reads an entire 'Entry' at the given 'TarEntryOffset' in the tar file.+-- The 'Handle' must be open for reading and be seekable.+--+-- This reads the whole entry into memory strictly, not incrementally. For more+-- control, use 'hReadEntryHeader' and then read the entry content manually.+--+hReadEntry :: Handle -> TarEntryOffset -> IO Entry+hReadEntry hnd off = do+    entry <- hReadEntryHeader hnd off+    case entryContent entry of+      NormalFile       _ size -> do body <- LBS.hGet hnd (fromIntegral size)+                                    return entry {+                                      entryContent = NormalFile body size+                                    }+      OtherEntryType c _ size -> do body <- LBS.hGet hnd (fromIntegral size)+                                    return entry {+                                      entryContent = OtherEntryType c body size+                                    }+      _                       -> return entry++-- | Read the header for a 'Entry' at the given 'TarEntryOffset' in the tar+-- file. The 'entryContent' will contain the correct metadata but an empty file+-- content. The 'Handle' must be open for reading and be seekable.+--+-- The 'Handle' position is advanced to the beginning of the entry content (if+-- any). You must check the 'entryContent' to see if the entry is of type+-- 'NormalFile'. If it is, the 'NormalFile' gives the content length and you+-- are free to read this much data from the 'Handle'.+--+-- > entry <- Tar.hReadEntryHeader hnd+-- > case Tar.entryContent entry of+-- >   Tar.NormalFile _ size -> do content <- BS.hGet hnd size+-- >                               ...+--+-- Of course you don't have to read it all in one go (as 'hReadEntry' does),+-- you can use any appropriate method to read it incrementally.+--+-- In addition to I\/O errors, this can throw a 'FormatError' if the offset is+-- wrong, or if the file is not valid tar format.+--+-- There is also the lower level operation 'hSeekEntryOffset'.+--+hReadEntryHeader :: Handle -> TarEntryOffset -> IO Entry+hReadEntryHeader hnd blockOff = do+    hSeekEntryOffset hnd blockOff+    header <- LBS.hGet hnd 512+    case Tar.read header of+      Tar.Next entry _ -> return entry+      Tar.Fail e       -> throwIO e+      Tar.Done         -> fail "hReadEntryHeader: impossible"++-- | Set the 'Handle' position to the position corresponding to the given+-- 'TarEntryOffset'.+--+-- This position is where the entry metadata can be read. If you already know+-- the entry has a body (and perhaps know it's length), you may wish to seek to+-- the body content directly using 'hSeekEntryContentOffset'.+--+hSeekEntryOffset :: Handle -> TarEntryOffset -> IO ()+hSeekEntryOffset hnd blockOff =+    hSeek hnd AbsoluteSeek (fromIntegral blockOff * 512)++-- | Set the 'Handle' position to the entry content position corresponding to+-- the given 'TarEntryOffset'.+--+-- This position is where the entry content can be read using ordinary I\/O+-- operations (though you have to know in advance how big the entry content+-- is). This is /only valid/ if you /already know/ the entry has a body (i.e.+-- is a normal file).+--+hSeekEntryContentOffset :: Handle -> TarEntryOffset -> IO ()+hSeekEntryContentOffset hnd blockOff =+    hSeekEntryOffset hnd (blockOff + 1)++-- | This is a low level variant on 'hReadEntryHeader', that can be used to+-- iterate through a tar file, entry by entry.+--+-- It has a few differences compared to 'hReadEntryHeader':+--+-- * It returns an indication when the end of the tar file is reached.+--+-- * It /does not/ move the 'Handle' position to the beginning of the entry+--   content.+--+-- * It returns the 'TarEntryOffset' of the next entry.+--+-- After this action, the 'Handle' position is not in any useful place. If+-- you want to skip to the next entry, take the 'TarEntryOffset' returned and+-- use 'hReadEntryHeaderOrEof' again. Or if having inspected the 'Entry'+-- header you want to read the entry content (if it has one) then use+-- 'hSeekEntryContentOffset' on the original input 'TarEntryOffset'.+--+hReadEntryHeaderOrEof :: Handle -> TarEntryOffset+                      -> IO (Maybe (Entry, TarEntryOffset))+hReadEntryHeaderOrEof hnd blockOff = do+    hSeekEntryOffset hnd blockOff+    header <- LBS.hGet hnd 1024+    case Tar.read header of+      Tar.Next entry _ -> let !blockOff' = nextEntryOffset entry blockOff+                           in return (Just (entry, blockOff'))+      Tar.Done         -> return Nothing+      Tar.Fail e       -> throwIO e++-- | Seek to the end of a tar file, to the position where new entries can+-- be appended, and return that 'TarEntryOffset'.+--+-- If you have a valid 'TarIndex' for this tar file then you should supply it+-- because it allows seeking directly to the correct location.+--+-- If you do not have an index, then this becomes an expensive linear+-- operation because we have to read each tar entry header from the beginning+-- to find the location immediately after the last entry (this is because tar+-- files have a variable length trailer and we cannot reliably find that by+-- starting at the end). In this mode, it will fail with an exception if the+-- file is not in fact in the tar format.+--+hSeekEndEntryOffset :: Handle -> Maybe TarIndex -> IO TarEntryOffset+hSeekEndEntryOffset hnd (Just index) = do+    let offset = indexEndEntryOffset index+    hSeekEntryOffset hnd offset+    return offset++hSeekEndEntryOffset hnd Nothing = do+    size <- hFileSize hnd+    if size == 0+      then return 0+      else seekToEnd 0+  where+    seekToEnd offset = do+      mbe <- hReadEntryHeaderOrEof hnd offset+      case mbe of+        Nothing -> do hSeekEntryOffset hnd offset+                      return offset+        Just (_, offset') -> seekToEnd offset'++-------------------------+-- (de)serialisation+--++-- | The 'TarIndex' is compact in memory, and it has a similarly compact+-- external representation.+--+serialise :: TarIndex -> BS.ByteString+serialise = toStrict . serialiseLBS++-- we keep this version around just so we can check we got the size right.+serialiseLBS :: TarIndex -> LBS.ByteString+serialiseLBS index =+    BS.toLazyByteStringWith+      (BS.untrimmedStrategy (serialiseSize index) 512) LBS.empty+      (serialiseBuilder index)++serialiseSize :: TarIndex -> Int+serialiseSize (TarIndex stringTable intTrie _) =+    StringTable.serialiseSize stringTable+  + IntTrie.serialiseSize intTrie+  + 8++serialiseBuilder :: TarIndex -> BS.Builder+serialiseBuilder (TarIndex stringTable intTrie finalOffset) =+     BS.word32BE 2 -- format version+  <> BS.word32BE finalOffset+  <> StringTable.serialise stringTable+  <> IntTrie.serialise intTrie++-- | Read the external representation back into a 'TarIndex'.+--+deserialise :: BS.ByteString -> Maybe (TarIndex, BS.ByteString)+deserialise bs+  | BS.length bs < 8+  = Nothing++  | let ver = readWord32BE bs 0+  , ver == 1+  = do let !finalOffset = readWord32BE bs 4+       (stringTable, bs')  <- StringTable.deserialiseV1 (BS.drop 8 bs)+       (intTrie,     bs'') <- IntTrie.deserialise bs'+       return (TarIndex stringTable intTrie finalOffset, bs'')++  | let ver = readWord32BE bs 0+  , ver == 2+  = do let !finalOffset = readWord32BE bs 4+       (stringTable, bs')  <- StringTable.deserialiseV2 (BS.drop 8 bs)+       (intTrie,     bs'') <- IntTrie.deserialise bs'+       return (TarIndex stringTable intTrie finalOffset, bs'')++  | otherwise = Nothing++readWord32BE :: BS.ByteString -> Int -> Word32+readWord32BE bs i =+    assert (i >= 0 && i+3 <= BS.length bs - 1) $+    fromIntegral (BS.unsafeIndex bs (i + 0)) `shiftL` 24+  + fromIntegral (BS.unsafeIndex bs (i + 1)) `shiftL` 16+  + fromIntegral (BS.unsafeIndex bs (i + 2)) `shiftL` 8+  + fromIntegral (BS.unsafeIndex bs (i + 3))++toStrict :: LBS.ByteString -> BS.ByteString+toStrict = LBS.toStrict++-- 'fromIntegral' is safe even on 32-bit machines, but 'fromEnum' / 'toEnum' is not,+-- because 'fromEnum' on 'Word32' near 'maxBound' fails, as well as+-- 'toEnum :: Int -> Word32' on negative arguments.++pathComponentIdToKey :: PathComponentId -> IntTrie.Key+pathComponentIdToKey (PathComponentId n) = IntTrie.Key (fromIntegral n)++keyToPathComponentId :: IntTrie.Key -> PathComponentId+keyToPathComponentId (IntTrie.Key n) = PathComponentId (fromIntegral n)

@@ -1,8 +1,9 @@ {-# LANGUAGE CPP, BangPatterns, PatternGuards, DeriveDataTypeable #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module Codec.Archive.Tar.Index.StringTable ( -    StringTable,+    StringTable(..),     lookup,     index,     construct,@@ -19,13 +20,7 @@     deserialiseV1,     deserialiseV2, -#ifdef TESTS-    prop_valid,-    prop_sorted,-    prop_finalise_unfinalise,-    prop_serialise_deserialise,-    prop_serialiseSize,-#endif+    index'  ) where  import Data.Typeable (Typeable)@@ -37,33 +32,20 @@ import Data.Int  (Int32) import Data.Bits import Data.Monoid (Monoid(..))-#if (MIN_VERSION_base(4,5,0)) import Data.Monoid ((<>))-#endif import Control.Exception (assert)  import qualified Data.Array.Unboxed as A import           Data.Array.Unboxed ((!))-#if MIN_VERSION_containers(0,5,0) import qualified Data.Map.Strict        as Map import           Data.Map.Strict (Map)-#else-import qualified Data.Map               as Map-import           Data.Map (Map)-#endif import qualified Data.ByteString        as BS import qualified Data.ByteString.Unsafe as BS import qualified Data.ByteString.Lazy   as LBS-#if MIN_VERSION_bytestring(0,10,2) || defined(MIN_VERSION_bytestring_builder) import Data.ByteString.Builder          as BS import Data.ByteString.Builder.Extra    as BS (byteStringCopy)-#else-import Data.ByteString.Lazy.Builder     as BS-import Data.ByteString.Lazy.Builder.Extras as BS (byteStringCopy)-#endif ---- | An effecient mapping from strings to a dense set of integers.+-- | An efficient mapping from strings to a dense set of integers. -- data StringTable id = StringTable          {-# UNPACK #-} !BS.ByteString           -- all strings concatenated@@ -249,76 +231,3 @@   + fromIntegral (BS.unsafeIndex bs (i + 1)) `shiftL` 16   + fromIntegral (BS.unsafeIndex bs (i + 2)) `shiftL` 8   + fromIntegral (BS.unsafeIndex bs (i + 3))--#ifdef TESTS--prop_valid :: [BS.ByteString] -> Bool-prop_valid strs =-     all lookupIndex (enumStrings tbl)-  && all indexLookup (enumIds tbl)--  where-    tbl :: StringTable Int-    tbl = construct strs--    lookupIndex str = index tbl ident == str-      where Just ident = lookup tbl str--    indexLookup ident = lookup tbl str == Just ident-      where str       = index tbl ident---- this is important so we can use Map.fromAscList-prop_sorted :: [BS.ByteString] -> Bool-prop_sorted strings =-    isSorted [ index' strs offsets ix-             | ix <- A.range (A.bounds ids) ]-  where-    _tbl :: StringTable Int-    _tbl@(StringTable strs offsets ids _ixs) = construct strings-    isSorted xs = and (zipWith (<) xs (tail xs))--prop_finalise_unfinalise :: [BS.ByteString] -> Bool-prop_finalise_unfinalise strs =-    builder == unfinalise (finalise builder)-  where-    builder :: StringTableBuilder Int-    builder = foldl' (\tbl s -> fst (insert s tbl)) empty strs--prop_serialise_deserialise :: [BS.ByteString] -> Bool-prop_serialise_deserialise strs =-    Just (strtable, BS.empty) == (deserialiseV2-                                . toStrict . BS.toLazyByteString-                                . serialise) strtable-  where-    strtable :: StringTable Int-    strtable = construct strs--prop_serialiseSize :: [BS.ByteString] -> Bool-prop_serialiseSize strs =-    (fromIntegral . LBS.length . BS.toLazyByteString . serialise) strtable- == serialiseSize strtable-  where-    strtable :: StringTable Int-    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--enumIds :: Enum id => StringTable id -> [id]-enumIds (StringTable _ offsets _ _) = [toEnum 0 .. toEnum (fromIntegral (h-1))]-  where (0,h) = A.bounds offsets--toStrict :: LBS.ByteString -> BS.ByteString-#if MIN_VERSION_bytestring(0,10,0)-toStrict = LBS.toStrict-#else-toStrict = BS.concat . LBS.toChunks-#endif--#endif--#if !(MIN_VERSION_base(4,5,0))-(<>) :: Monoid m => m -> m -> m-(<>) = mappend-#endif

@@ -0,0 +1,153 @@+{-# LANGUAGE LambdaCase #-}++module Codec.Archive.Tar.LongNames+  ( encodeLongNames+  , decodeLongNames+  , DecodeLongNamesError(..)+  ) where++import Codec.Archive.Tar.Types+import Control.Exception+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL++-- | Errors raised by 'decodeLongNames'.+--+-- @since 0.6.0.0+data DecodeLongNamesError+  = TwoTypeKEntries+  -- ^ Two adjacent 'OtherEntryType' @\'K\'@ nodes.+  | TwoTypeLEntries+  -- ^ Two adjacent 'OtherEntryType' @\'L\'@ nodes.+  | NoLinkEntryAfterTypeKEntry+  -- ^ 'OtherEntryType' @\'K\'@ node is not followed by a 'SymbolicLink' / 'HardLink'.+  deriving (Eq, Ord, Show)++instance Exception DecodeLongNamesError++-- | Translate high-level entries with POSIX 'FilePath's for files and symlinks+-- into entries suitable for serialization by emitting additional+-- 'OtherEntryType' @\'K\'@ and 'OtherEntryType' @\'L\'@ nodes.+--+-- Input 'FilePath's must be POSIX file names, not native ones.+--+-- @since 0.6.0.0+encodeLongNames+  :: GenEntry FilePath FilePath+  -> [Entry]+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)+  -- ^ (LongLink entry, actual entry)+encodeTarPath e = case toTarPath' (entryTarPath e) of+  FileNameEmpty -> (Nothing, e { entryTarPath = TarPath mempty mempty })+  FileNameOK tarPath -> (Nothing, e { entryTarPath = tarPath })+  FileNameTooLong tarPath -> (Just $ longLinkEntry $ entryTarPath e, e { entryTarPath = tarPath })++encodeLinkTarget+  :: GenEntry tarPath FilePath+  -> (Maybe (GenEntry TarPath LinkTarget), GenEntry tarPath LinkTarget)+  -- ^ (LongLink symlink entry, actual entry)+encodeLinkTarget e = case entryContent e of+  NormalFile x y -> (Nothing, e { entryContent = NormalFile x y })+  Directory -> (Nothing, e { entryContent = Directory })+  SymbolicLink lnk -> let (mEntry, lnk') = encodeLinkPath lnk in+    (mEntry, e { entryContent = SymbolicLink lnk' })+  HardLink lnk -> let (mEntry, lnk') = encodeLinkPath lnk in+    (mEntry, e { entryContent = HardLink lnk' })+  CharacterDevice x y -> (Nothing, e { entryContent = CharacterDevice x y })+  BlockDevice x y -> (Nothing, e { entryContent = BlockDevice x y })+  NamedPipe -> (Nothing, e { entryContent = NamedPipe })+  OtherEntryType x y z -> (Nothing, e { entryContent = OtherEntryType x y z })++encodeLinkPath+  :: FilePath+  -> (Maybe (GenEntry TarPath LinkTarget), LinkTarget)+encodeLinkPath lnk = case toTarPath' lnk of+  FileNameEmpty -> (Nothing, LinkTarget mempty)+  FileNameOK (TarPath name prefix)+    | B.null prefix -> (Nothing, LinkTarget name)+    | otherwise -> (Just $ longSymLinkEntry lnk, LinkTarget name)+  FileNameTooLong (TarPath name _) ->+    (Just $ longSymLinkEntry lnk, LinkTarget name)++-- | Translate low-level entries (usually freshly deserialized) into+-- high-level entries with POSIX 'FilePath's for files and symlinks+-- by parsing and eliminating+-- 'OtherEntryType' @\'K\'@ and 'OtherEntryType' @\'L\'@ nodes.+--+-- Resolved 'FilePath's are still POSIX file names, not native ones.+--+-- @since 0.6.0.0+decodeLongNames+  :: Entries e+  -> GenEntries FilePath FilePath (Either e DecodeLongNamesError)+decodeLongNames = go Nothing Nothing+  where+    go :: Maybe FilePath -> Maybe FilePath -> Entries e -> GenEntries FilePath FilePath (Either e DecodeLongNamesError)+    go _ _ (Fail err) = Fail (Left err)+    go _ _ Done = Done++    go Nothing Nothing (Next e rest) = case entryContent e of+      OtherEntryType 'K' fn _ ->+        go (Just (otherEntryPayloadToFilePath fn)) Nothing rest+      OtherEntryType 'L' fn _ ->+        go Nothing (Just (otherEntryPayloadToFilePath fn)) rest+      _ ->+        Next (castEntry e) (go Nothing Nothing rest)++    go Nothing (Just path) (Next e rest) = case entryContent e of+      OtherEntryType 'K' fn _ ->+        go (Just (otherEntryPayloadToFilePath fn)) (Just path) rest+      OtherEntryType 'L' _ _ ->+        Fail $ Right TwoTypeLEntries+      _ -> Next ((castEntry e) { entryTarPath = path }) (go Nothing Nothing rest)++    go (Just link) Nothing (Next e rest) = case entryContent e of+      OtherEntryType 'K' _ _ ->+        Fail $ Right TwoTypeKEntries+      OtherEntryType 'L' fn _ ->+        go (Just link) (Just (otherEntryPayloadToFilePath fn)) rest+      SymbolicLink{} ->+        Next ((castEntry e) { entryContent = SymbolicLink link }) (go Nothing Nothing rest)+      HardLink{} ->+        Next ((castEntry e) { entryContent = HardLink link }) (go Nothing Nothing rest)+      _ ->+        Fail $ Right NoLinkEntryAfterTypeKEntry++    go (Just link) (Just path) (Next e rest) = case entryContent e of+      OtherEntryType 'K' _ _ ->+        Fail $ Right TwoTypeKEntries+      OtherEntryType 'L' _ _ ->+        Fail $ Right TwoTypeLEntries+      SymbolicLink{} ->+        Next ((castEntry e) { entryTarPath = path, entryContent = SymbolicLink link }) (go Nothing Nothing rest)+      HardLink{} ->+        Next ((castEntry e) { entryTarPath = path, entryContent = HardLink link }) (go Nothing Nothing rest)+      _ ->+        Fail $ Right NoLinkEntryAfterTypeKEntry++otherEntryPayloadToFilePath :: BL.ByteString -> FilePath+otherEntryPayloadToFilePath = B.unpack . B.takeWhile (/= '\0') . BL.toStrict++castEntry :: Entry -> GenEntry FilePath FilePath+castEntry e = e+  { entryTarPath = fromTarPathToPosixPath (entryTarPath e)+  , entryContent = castEntryContent (entryContent e)+  }++castEntryContent :: EntryContent -> GenEntryContent FilePath+castEntryContent = \case+  NormalFile x y -> NormalFile x y+  Directory -> Directory+  SymbolicLink linkTarget -> SymbolicLink $ fromLinkTargetToPosixPath linkTarget+  HardLink linkTarget -> HardLink $ fromLinkTargetToPosixPath linkTarget+  CharacterDevice x y -> CharacterDevice x y+  BlockDevice x y -> BlockDevice x y+  NamedPipe -> NamedPipe+  OtherEntryType x y z -> OtherEntryType x y z

@@ -1,4 +1,8 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module      :  Codec.Archive.Tar@@ -13,45 +17,47 @@ ----------------------------------------------------------------------------- module Codec.Archive.Tar.Pack (     pack,+    packAndCheck,     packFileEntry,     packDirectoryEntry,+    packSymlinkEntry,+    longLinkEntry,      getDirectoryContentsRecursive,   ) where +import Codec.Archive.Tar.LongNames import Codec.Archive.Tar.Types--import qualified Data.ByteString.Lazy as BS+import Control.Monad (join, when, forM, (>=>))+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 )+         ( addTrailingPathSeparator, hasTrailingPathSeparator, splitDirectories ) import System.Directory-         ( getDirectoryContents, doesDirectoryExist, getModificationTime-         , Permissions(..), getPermissions )-#if MIN_VERSION_directory(1,2,0)--- The directory package switched to the new time package+         ( listDirectory, doesDirectoryExist, getModificationTime+         , pathIsSymbolicLink, getSymbolicLinkTarget+         , Permissions(..), getPermissions, getFileSize ) import Data.Time.Clock          ( UTCTime ) import Data.Time.Clock.POSIX          ( utcTimeToPOSIXSeconds )-#else-import System.Time-         ( ClockTime(..) )-#endif import System.IO          ( IOMode(ReadMode), openBinaryFile, 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 -- archive will be relative to the given base directory. -- -- This is a portable implementation of packing suitable for portable archives.--- In particular it only constructs 'NormalFile' and 'Directory' entries. Hard--- links and symbolic links are treated like ordinary files. It cannot be used--- to pack directories containing recursive symbolic links. Special files like--- FIFOs (named pipes), sockets or device files will also cause problems.+-- In particular it only constructs 'NormalFile', 'Directory' and 'SymbolicLink'+-- entries. Hard links are treated like ordinary files. Special files like+-- FIFOs (named pipes), sockets or device files will cause problems. -- -- An exception will be thrown for any file names that are too long to -- represent as a 'TarPath'.@@ -59,33 +65,58 @@ -- * This function returns results lazily. Subdirectories are scanned -- and files are read one by one as the list of entries is consumed. ---pack :: FilePath   -- ^ Base directory-     -> [FilePath] -- ^ Files and directories to pack, relative to the base dir-     -> IO [Entry]-pack baseDir paths0 = preparePaths baseDir paths0 >>= packPaths baseDir+pack+  :: FilePath   -- ^ Base directory+  -> [FilePath] -- ^ Files and directories to pack, relative to the base dir+  -> IO [Entry]+pack = packAndCheck (const Nothing) +-- | Like '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+-- in 'Codec.Tar.Check.unpack' / 'Codec.Tar.Check.unpackAndCheck'.+--+-- @since 0.6.0.0+packAndCheck+  :: (GenEntry FilePath FilePath -> Maybe SomeException)+  -> FilePath   -- ^ Base directory+  -> [FilePath] -- ^ Files and directories to pack, relative to the base dir+  -> IO [Entry]+packAndCheck secCB baseDir relpaths = do+  paths <- preparePaths baseDir relpaths+  entries <- packPaths baseDir paths+  traverse_ (maybe (pure ()) throwIO . secCB) entries+  pure $ concatMap encodeLongNames entries+ preparePaths :: FilePath -> [FilePath] -> IO [FilePath]-preparePaths baseDir paths =-  fmap concat $ interleave-    [ do isDir  <- doesDirectoryExist (baseDir </> path)-         if isDir-           then do entries <- getDirectoryContentsRecursive (baseDir </> path)-                   let entries' = map (path </>) entries-                       dir = FilePath.Native.addTrailingPathSeparator path-                   if null path then return entries'-                                else return (dir : entries')-           else return [path]-    | path <- paths ]+preparePaths baseDir = fmap concat . interleave . map go+  where+    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+          then entries'+          else FilePath.Native.addTrailingPathSeparator relpath : entries'+      else return [relpath] -packPaths :: FilePath -> [FilePath] -> IO [Entry]-packPaths baseDir paths =-  interleave-    [ do tarpath <- either fail return (toTarPath isDir relpath)-         if isDir then packDirectoryEntry filepath tarpath-                  else packFileEntry      filepath tarpath-    | relpath <- paths-    , let isDir    = FilePath.Native.hasTrailingPathSeparator filepath-          filepath = baseDir </> relpath ]+-- | Pack paths while accounting for overlong filepaths.+packPaths+  :: FilePath+  -> [FilePath]+  -> IO [GenEntry FilePath FilePath]+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+  mkEntry abspath relpath  interleave :: [IO a] -> IO [a] interleave = unsafeInterleaveIO . go@@ -104,36 +135,70 @@ -- -- * The file contents is read lazily. ---packFileEntry :: FilePath -- ^ Full path to find the file on the local disk-              -> TarPath  -- ^ Path to use for the tar Entry in the archive-              -> IO Entry+packFileEntry+  :: FilePath -- ^ Full path to find the file on the local disk+  -> tarPath  -- ^ Path to use for the tar 'Entry' in the archive+  -> IO (GenEntry tarPath linkTarget) packFileEntry filepath tarpath = do   mtime   <- getModTime filepath   perms   <- getPermissions filepath-  file    <- openBinaryFile filepath ReadMode-  size    <- hFileSize file-  content <- BS.hGetContents file-  return (simpleEntry tarpath (NormalFile content (fromIntegral size))) {-    entryPermissions = if executable perms then executableFilePermissions-                                           else ordinaryFilePermissions,-    entryTime = mtime-  }+  -- Get file size without opening it.+  approxSize <- getFileSize filepath +  (content, size) <- if approxSize < 131072+    -- If file is short enough, just read it strictly+    -- so that no file handle dangles around indefinitely.+    then do+      cnt <- B.readFile filepath+      pure (BL.fromStrict cnt, fromIntegral $ B.length cnt)+    else do+      hndl <- openBinaryFile filepath ReadMode+      -- File size could have changed between measuring approxSize+      -- and here. Measuring again.+      sz <- hFileSize hndl+      -- 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, fromInteger sz)++  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. -- Directory ownership and detailed permissions are not preserved. ---packDirectoryEntry :: FilePath -- ^ Full path to find the file on the local disk-                   -> TarPath  -- ^ Path to use for the tar Entry in the archive-                   -> IO Entry+packDirectoryEntry+  :: FilePath -- ^ Full path to find the file on the local disk+  -> tarPath  -- ^ Path to use for the tar 'Entry' in the archive+  -> IO (GenEntry tarPath linkTarget) packDirectoryEntry filepath tarpath = do   mtime   <- getModTime filepath   return (directoryEntry tarpath) {     entryTime = mtime   } --- | This is a utility function, much like 'getDirectoryContents'. The+-- | 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 'Entry' in the archive+  -> IO (GenEntry tarPath FilePath)+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@@ -148,6 +213,8 @@ -- -- * 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,+-- the behaviour is undefined. -- getDirectoryContentsRecursive :: FilePath -> IO [FilePath] getDirectoryContentsRecursive dir0 =@@ -156,34 +223,24 @@ recurseDirectories :: FilePath -> [FilePath] -> IO [FilePath] recurseDirectories _    []         = return [] recurseDirectories base (dir:dirs) = unsafeInterleaveIO $ do-  (files, dirs') <- collect [] [] =<< getDirectoryContents (base </> dir)+  (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) | ignore entry-                                        = collect files dirs' entries     collect files dirs' (entry:entries) = do       let dirEntry  = dir </> entry           dirEntry' = FilePath.Native.addTrailingPathSeparator dirEntry       isDirectory <- doesDirectoryExist (base </> dirEntry)-      if isDirectory+      isSymlink <- pathIsSymbolicLink (base </> dirEntry)+      if isDirectory && not isSymlink         then collect files (dirEntry':dirs') entries         else collect (dirEntry:files) dirs' entries -    ignore ['.']      = True-    ignore ['.', '.'] = True-    ignore _          = False- getModTime :: FilePath -> IO EpochTime getModTime path = do-#if MIN_VERSION_directory(1,2,0)   -- The directory package switched to the new time package   t <- getModificationTime path   return . floor . utcTimeToPOSIXSeconds $ t-#else-  (TOD s _) <- getModificationTime path-  return $! fromIntegral s-#endif

@@ -0,0 +1,14 @@+module Codec.Archive.Tar.PackAscii+  ( packAscii+  ) where++import qualified Data.ByteString.Char8 as BS.Char8+import Data.Char+import GHC.Stack++-- | We should really migrate to @OsPath@ from @filepath@ package,+-- but for now let's not corrupt data silently.+packAscii :: HasCallStack => FilePath -> BS.Char8.ByteString+packAscii xs+  | all isAscii xs = BS.Char8.pack xs+  | otherwise = error $ "packAscii: only ASCII filenames are supported, but got " ++ xs

@@ -32,11 +32,6 @@  import Prelude hiding (read) -#if !MIN_VERSION_bytestring(0,10,0)-import Data.Monoid (Monoid(..))-import qualified Data.ByteString.Lazy.Internal as LBS-#endif- -- | Errors that can be encountered when parsing a Tar archive. data FormatError   = TruncatedArchive@@ -47,7 +42,6 @@   | NotTarFormat   | UnrecognisedTarFormat   | HeaderBadNumericEncoding-#if MIN_VERSION_base(4,8,0)   deriving (Eq, Show, Typeable)  instance Exception FormatError where@@ -59,22 +53,7 @@   displayException NotTarFormat             = "data is not in tar format"   displayException UnrecognisedTarFormat    = "tar entry not in a recognised format"   displayException HeaderBadNumericEncoding = "tar header is malformed (bad numeric encoding)"-#else-  deriving (Eq, Typeable) -instance Show FormatError where-  show TruncatedArchive         = "truncated tar archive"-  show ShortTrailer             = "short tar trailer"-  show BadTrailer               = "bad tar trailer"-  show TrailingJunk             = "tar file has trailing junk"-  show ChecksumIncorrect        = "tar checksum error"-  show NotTarFormat             = "data is not in tar format"-  show UnrecognisedTarFormat    = "tar entry not in a recognised format"-  show HeaderBadNumericEncoding = "tar header is malformed (bad numeric encoding)"--instance Exception FormatError-#endif- instance NFData    FormatError where   rnf !_ = () -- enumerations are fully strict by construction @@ -94,19 +73,28 @@   -- Tar files end with at least two blocks of all '0'. Checking this serves   -- two purposes. It checks the format but also forces the tail of the data   -- which is necessary to close the file if it came from a lazily read file.-  | LBS.head bs == 0 = case LBS.splitAt 1024 bs of+  --+  -- It's tempting to fall into trailer parsing as soon as LBS.head bs == '\0',+  -- because, if interpreted as an 'Entry', it means that 'entryTarPath' is an empty+  -- string. Yet it's not a concern of this function: parse it as an 'Entry'+  -- and let further pipeline such as 'checkEntrySecurity' deal with it. After all,+  -- it might be a format extension with unknown semantics. Such somewhat malformed+  -- archives do exist in the wild, see https://github.com/haskell/tar/issues/73.+  --+  -- Only if an entire block is null, we assume that we are parsing a trailer.+  | LBS.all (== 0) (LBS.take 512 bs) = case LBS.splitAt 1024 bs of       (end, trailing)         | LBS.length end /= 1024        -> Left ShortTrailer         | not (LBS.all (== 0) end)      -> Left BadTrailer         | not (LBS.all (== 0) trailing) -> Left TrailingJunk         | otherwise                     -> Right Nothing -  | otherwise  = partial $ do+  | otherwise  = do    case (chksum_, format_) of-    (Ok chksum, _   ) | correctChecksum header chksum -> return ()-    (Ok _,      Ok _) -> Error ChecksumIncorrect-    _                 -> Error NotTarFormat+    (Right chksum, _ ) | correctChecksum header chksum -> return ()+    (Right _, Right _) -> Left ChecksumIncorrect+    _                  -> Left NotTarFormat    -- These fields are partial, have to check them   format   <- format_;   mode     <- mode_;@@ -143,12 +131,7 @@   return (Just (entry, bs'))    where-#if MIN_VERSION_bytestring(0,10,0)    header = LBS.toStrict (LBS.take 512 bs)-#else-   header = toStrict (LBS.take 512 bs)-   toStrict = LBS.foldrChunks mappend mempty-#endif     name       = getString   0 100 header    mode_      = getOct    100   8 header@@ -171,7 +154,7 @@      | magic == ustarMagic = return UstarFormat      | magic == gnuMagic   = return GnuFormat      | magic == v7Magic    = return V7Format-     | otherwise           = Error UnrecognisedTarFormat+     | otherwise           = Left UnrecognisedTarFormat  v7Magic, ustarMagic, gnuMagic :: BS.ByteString v7Magic    = BS.Char8.pack "\0\0\0\0\0\0\0\0"@@ -191,15 +174,11 @@  -- * TAR format primitive input -{-# SPECIALISE getOct :: Int -> Int -> BS.ByteString -> Partial FormatError Int   #-}-{-# SPECIALISE getOct :: Int -> Int -> BS.ByteString -> Partial FormatError Int64 #-}-getOct :: (Integral a, Bits a) => Int -> Int -> BS.ByteString -> Partial FormatError a-getOct off len = parseOct-               . BS.Char8.takeWhile (\c -> c /= '\NUL' && c /= ' ')-               . BS.Char8.dropWhile (== ' ')-               . getBytes off len+{-# SPECIALISE getOct :: Int -> Int -> BS.ByteString -> Either FormatError Int   #-}+{-# SPECIALISE getOct :: Int -> Int -> BS.ByteString -> Either FormatError Int64 #-}+getOct :: (Integral a, Bits a) => Int -> Int -> BS.ByteString -> Either FormatError a+getOct off len = parseOct . getBytes off len   where-    parseOct s | BS.null s = return 0     -- As a star extension, octal fields can hold a base-256 value if the high     -- bit of the initial character is set. The initial character can be:     --   0x80 ==> trailing characters hold a positive base-256 value@@ -213,9 +192,14 @@     -- which is what I will assume.     parseOct s | BS.head s == 128 = return (readBytes (BS.tail s))                | BS.head s == 255 = return (negate (readBytes (BS.tail s)))-    parseOct s  = case readOct s of-      Just x  -> return x-      Nothing -> Error HeaderBadNumericEncoding+    parseOct s+      | BS.null stripped = return 0+      | otherwise = case readOct stripped of+        Just x  -> return x+        Nothing -> Left HeaderBadNumericEncoding+     where+      stripped = BS.Char8.takeWhile (\c -> c /= '\NUL' && c /= ' ')+               $ BS.Char8.dropWhile (== ' ') s      readBytes :: (Integral a, Bits a) => BS.ByteString -> a     readBytes = BS.foldl' (\acc x -> acc `shiftL` 8 + fromIntegral x) 0@@ -227,49 +211,20 @@ getByte off bs = BS.Char8.index bs off  getChars :: Int -> Int -> BS.ByteString -> BS.ByteString-getChars off len = getBytes off len+getChars = getBytes  getString :: Int -> Int -> BS.ByteString -> BS.ByteString getString off len = BS.copy . BS.Char8.takeWhile (/='\0') . getBytes off len --- These days we'd just use Either, but in older versions of base there was no--- Monad instance for Either, it was in mtl with an anoying Error constraint.----data Partial e a = Error e | Ok a--partial :: Partial e a -> Either e a-partial (Error msg) = Left msg-partial (Ok x)      = Right x--instance Functor (Partial e) where-    fmap = liftM--instance Applicative (Partial e) where-    pure  = Ok-    (<*>) = ap--instance Monad (Partial e) where-    return        = pure-    Error m >>= _ = Error m-    Ok    x >>= k = k x-#if !MIN_VERSION_base(4,13,0)-    fail          = error "fail @(Partial e)"-#endif- {-# SPECIALISE readOct :: BS.ByteString -> Maybe Int   #-} {-# SPECIALISE readOct :: BS.ByteString -> Maybe Int64 #-} readOct :: Integral n => BS.ByteString -> Maybe n-readOct bs0 = case go 0 0 bs0 of-                -1 -> Nothing-                n  -> Just n+readOct = go 0 0   where-    go :: Integral n => Int -> n -> BS.ByteString -> n-    go !i !n !bs-      | BS.null bs = if i == 0 then -1 else n-      | otherwise  =-          case BS.unsafeHead bs of-            w | w >= 0x30-             && w <= 0x39 -> go (i+1)-                                (n * 8 + (fromIntegral w - 0x30))-                                (BS.unsafeTail bs)-              | otherwise -> -1+    go :: Integral n => Int -> n -> BS.ByteString -> Maybe n+    go !i !n !bs = case BS.uncons bs of+      Nothing -> if i == 0 then Nothing else Just n+      Just (w, tl)+        | w >= 0x30 && w <= 0x39 ->+          go (i+1) (n * 8 + (fromIntegral w - 0x30)) tl+        | otherwise -> Nothing

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, BangPatterns #-}+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, BangPatterns, DeriveTraversable, ScopedTypeVariables, RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module      :  Codec.Archive.Tar.Types@@ -16,9 +16,11 @@ ----------------------------------------------------------------------------- module Codec.Archive.Tar.Types ( -  Entry(..),+  GenEntry(..),+  Entry,   entryPath,-  EntryContent(..),+  GenEntryContent(..),+  EntryContent,   FileSize,   Permissions,   Ownership(..),@@ -29,61 +31,64 @@   Format(..),    simpleEntry,+  longLinkEntry,+  longSymLinkEntry,   fileEntry,+  symlinkEntry,   directoryEntry,    ordinaryFilePermissions,+  symbolicLinkPermission,   executableFilePermissions,   directoryPermissions,    TarPath(..),   toTarPath,+  toTarPath',+  ToTarPathResult(..),   fromTarPath,   fromTarPathToPosixPath,   fromTarPathToWindowsPath,+  fromFilePathToNative,    LinkTarget(..),   toLinkTarget,   fromLinkTarget,   fromLinkTargetToPosixPath,   fromLinkTargetToWindowsPath,+  fromFilePathToWindowsPath, -  Entries(..),+  GenEntries(..),+  Entries,   mapEntries,   mapEntriesNoFail,   foldEntries,   foldlEntries,   unfoldEntries,--#ifdef TESTS-  limitToV7FormatCompat-#endif   ) where  import Data.Int      (Int64)+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 import Control.DeepSeq+import Control.Exception (Exception, displayException)  import qualified System.FilePath as FilePath.Native-         ( joinPath, splitDirectories, addTrailingPathSeparator )+         ( joinPath, splitDirectories, addTrailingPathSeparator, hasTrailingPathSeparator, pathSeparator, isAbsolute, hasTrailingPathSeparator ) import qualified System.FilePath.Posix as FilePath.Posix          ( joinPath, splitPath, splitDirectories, hasTrailingPathSeparator-         , addTrailingPathSeparator )+         , addTrailingPathSeparator, pathSeparator ) import qualified System.FilePath.Windows as FilePath.Windows-         ( joinPath, addTrailingPathSeparator )+         ( joinPath, addTrailingPathSeparator, pathSeparator ) import System.Posix.Types          ( FileMode ) -#ifdef TESTS-import Test.QuickCheck-import Control.Applicative ((<$>), (<*>), pure)-import Data.Word (Word16)-#endif-+import Codec.Archive.Tar.PackAscii  type FileSize  = Int64 -- | The number of seconds since the UNIX epoch@@ -93,17 +98,19 @@ type TypeCode  = Char type Permissions = FileMode --- | Tar archive entry.+-- | Polymorphic tar archive entry. High-level interfaces+-- commonly work with 'GenEntry' 'FilePath' 'FilePath',+-- while low level uses 'GenEntry' 'TarPath' 'LinkTarget'. ---data Entry = Entry {+-- @since 0.6.0.0+data GenEntry tarPath linkTarget = Entry { -    -- | The path of the file or directory within the archive. This is in a-    -- tar-specific form. Use 'entryPath' to get a native 'FilePath'.-    entryTarPath :: {-# UNPACK #-} !TarPath,+    -- | 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 :: !EntryContent,+    entryContent :: !(GenEntryContent linkTarget),      -- | File permissions (Unix style file mode).     entryPermissions :: {-# UNPACK #-} !Permissions,@@ -119,28 +126,40 @@   }   deriving (Eq, Show) +-- | Monomorphic tar archive entry, ready for serialization / deserialization.+--+type Entry = GenEntry TarPath LinkTarget+ -- | Native 'FilePath' of the file or directory within the archive. ---entryPath :: Entry -> FilePath+entryPath :: GenEntry TarPath linkTarget -> FilePath entryPath = fromTarPath . entryTarPath --- | The content of a tar archive entry, which depends on the type of entry.+-- | Polymorphic content of a tar archive entry. High-level interfaces+-- commonly work with 'GenEntryContent' 'FilePath',+-- while low level uses 'GenEntryContent' 'LinkTarget'. -- -- Portable archives should contain only 'NormalFile' and 'Directory'. ---data EntryContent = NormalFile      LBS.ByteString {-# UNPACK #-} !FileSize-                  | Directory-                  | SymbolicLink    !LinkTarget-                  | HardLink        !LinkTarget-                  | CharacterDevice {-# UNPACK #-} !DevMajor-                                    {-# UNPACK #-} !DevMinor-                  | BlockDevice     {-# UNPACK #-} !DevMajor-                                    {-# UNPACK #-} !DevMinor-                  | NamedPipe-                  | OtherEntryType  {-# UNPACK #-} !TypeCode LBS.ByteString-                                    {-# UNPACK #-} !FileSize-    deriving (Eq, Ord, Show)+-- @since 0.6.0.0+data GenEntryContent linkTarget+  = NormalFile      LBS.ByteString {-# UNPACK #-} !FileSize+  | Directory+  | SymbolicLink    !linkTarget+  | HardLink        !linkTarget+  | CharacterDevice {-# UNPACK #-} !DevMajor+                    {-# UNPACK #-} !DevMinor+  | BlockDevice     {-# UNPACK #-} !DevMajor+                    {-# UNPACK #-} !DevMinor+  | NamedPipe+  | OtherEntryType  {-# UNPACK #-} !TypeCode LBS.ByteString+                    {-# UNPACK #-} !FileSize+  deriving (Eq, Ord, Show) +-- | Monomorphic content of a tar archive entry,+-- ready for serialization / deserialization.+type EntryContent = GenEntryContent LinkTarget+ data Ownership = Ownership {     -- | The owner user name. Should be set to @\"\"@ if unknown.     ownerName :: String,@@ -169,30 +188,24 @@      -- | The \"USTAR\" format is an extension of the classic V7 format. It was      -- later standardised by POSIX. It has some restrictions but is the most      -- portable format.-     --    | UstarFormat       -- | The GNU tar implementation also extends the classic V7 format, though-     -- in a slightly different way from the USTAR format. In general for new-     -- archives the standard USTAR/POSIX should be used.-     --+     -- in a slightly different way from the USTAR format. This is the only format+     -- supporting long file names.    | GnuFormat   deriving (Eq, Ord, Show) -instance NFData Entry where-  rnf (Entry _ c _ _ _ _) = rnf c+instance (NFData tarPath, NFData linkTarget) => NFData (GenEntry tarPath linkTarget) where+  rnf (Entry p c _ _ _ _) = rnf p `seq` rnf c -instance NFData EntryContent where+instance NFData linkTarget => NFData (GenEntryContent linkTarget) where   rnf x = case x of-      NormalFile       c _  -> rnflbs c-      OtherEntryType _ c _  -> rnflbs c+      NormalFile       c _  -> rnf c+      SymbolicLink lnk      -> rnf lnk+      HardLink lnk          -> rnf lnk+      OtherEntryType _ c _  -> rnf c       _                     -> seq x ()-    where-#if MIN_VERSION_bytestring(0,10,0)-      rnflbs = rnf-#else-      rnflbs = foldr (\ !_bs r -> r) () . LBS.toChunks-#endif  instance NFData Ownership where   rnf (Ownership o g _ _) = rnf o `seq` rnf g@@ -201,6 +214,12 @@ ordinaryFilePermissions :: Permissions ordinaryFilePermissions   = 0o0644 +-- | @rw-r--r--@ for normal files+--+-- @since 0.6.0.0+symbolicLinkPermission :: Permissions+symbolicLinkPermission   = 0o0777+ -- | @rwxr-xr-x@ for executable files executableFilePermissions :: Permissions executableFilePermissions = 0o0755@@ -210,18 +229,19 @@ directoryPermissions  = 0o0755  -- | An 'Entry' with all default values except for the file name and type. It--- uses the portable USTAR/POSIX format (see 'UstarHeader').+-- uses the portable USTAR/POSIX format (see 'UstarFormat'). -- -- You can use this as a basis and override specific fields, eg: -- -- > (emptyEntry name HardLink) { linkTarget = target } ---simpleEntry :: TarPath -> EntryContent -> Entry+simpleEntry :: tarPath -> GenEntryContent linkTarget -> GenEntry tarPath linkTarget simpleEntry tarpath content = Entry {     entryTarPath     = tarpath,     entryContent     = content,     entryPermissions = case content of                          Directory -> directoryPermissions+                         SymbolicLink _ -> symbolicLinkPermission                          _         -> ordinaryFilePermissions,     entryOwnership   = Ownership "" "" 0 0,     entryTime        = 0,@@ -237,15 +257,56 @@ -- -- > (fileEntry name content) { fileMode = executableFileMode } ---fileEntry :: TarPath -> LBS.ByteString -> Entry+fileEntry :: tarPath -> LBS.ByteString -> GenEntry 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 name targetLink =+  simpleEntry name (SymbolicLink targetLink)++-- | [GNU extension](https://www.gnu.org/software/tar/manual/html_node/Standard.html)+-- to store a filepath too long to fit into 'entryTarPath'+-- as 'OtherEntryType' @\'L\'@ with the full filepath as 'entryContent'.+-- The next entry must contain the actual+-- data with truncated 'entryTarPath'.+--+-- 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 tarpath = Entry {+    entryTarPath     = TarPath (BS.Char8.pack "././@LongLink") BS.empty,+    entryContent     = OtherEntryType 'L' (LBS.fromStrict $ packAscii tarpath) (fromIntegral $ length tarpath),+    entryPermissions = ordinaryFilePermissions,+    entryOwnership   = Ownership "" "" 0 0,+    entryTime        = 0,+    entryFormat      = GnuFormat+  }++-- | [GNU extension](https://www.gnu.org/software/tar/manual/html_node/Standard.html)+-- to store a link target too long to fit into 'entryTarPath'+-- as 'OtherEntryType' @\'K\'@ with the full filepath as 'entryContent'.+-- The next entry must contain the actual+-- data with truncated 'entryTarPath'.+--+-- @since 0.6.0.0+longSymLinkEntry :: FilePath -> GenEntry TarPath linkTarget+longSymLinkEntry linkTarget = Entry {+    entryTarPath     = TarPath (BS.Char8.pack "././@LongLink") BS.empty,+    entryContent     = OtherEntryType 'K' (LBS.fromStrict . packAscii $ linkTarget) (fromIntegral $ length linkTarget),+    entryPermissions = ordinaryFilePermissions,+    entryOwnership   = Ownership "" "" 0 0,+    entryTime        = 0,+    entryFormat      = GnuFormat+  }+ -- | A tar 'Entry' for a directory. -- -- Entry fields such as file permissions and ownership have default values. ---directoryEntry :: TarPath -> Entry+directoryEntry :: tarPath -> GenEntry tarPath linkTarget directoryEntry name = simpleEntry name Directory  --@@ -296,18 +357,11 @@ -- -- * The tar path may be an absolute path or may contain @\"..\"@ components. --   For security reasons this should not usually be allowed, but it is your---   responsibility to check for these conditions (eg using 'checkSecurity').+--   responsibility to check for these conditions+--   (e.g., using 'Codec.Archive.Tar.Check.checkEntrySecurity'). -- fromTarPath :: TarPath -> FilePath-fromTarPath (TarPath namebs prefixbs) = adjustDirectory $-  FilePath.Native.joinPath $ FilePath.Posix.splitDirectories prefix-                          ++ FilePath.Posix.splitDirectories name-  where-    name   = BS.Char8.unpack namebs-    prefix = BS.Char8.unpack prefixbs-    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name-                    = FilePath.Native.addTrailingPathSeparator-                    | otherwise = id+fromTarPath = BS.Char8.unpack . fromTarPathInternal FilePath.Native.pathSeparator  -- | Convert a 'TarPath' to a Unix\/Posix 'FilePath'. --@@ -318,15 +372,7 @@ -- operating system, eg to perform portability checks. -- fromTarPathToPosixPath :: TarPath -> FilePath-fromTarPathToPosixPath (TarPath namebs prefixbs) = adjustDirectory $-  FilePath.Posix.joinPath $ FilePath.Posix.splitDirectories prefix-                         ++ FilePath.Posix.splitDirectories name-  where-    name   = BS.Char8.unpack namebs-    prefix = BS.Char8.unpack prefixbs-    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name-                    = FilePath.Posix.addTrailingPathSeparator-                    | otherwise = id+fromTarPathToPosixPath = BS.Char8.unpack . fromTarPathInternal FilePath.Posix.pathSeparator  -- | Convert a 'TarPath' to a Windows 'FilePath'. --@@ -337,65 +383,97 @@ -- operating system, eg to perform portability checks. -- fromTarPathToWindowsPath :: TarPath -> FilePath-fromTarPathToWindowsPath (TarPath namebs prefixbs) = adjustDirectory $-  FilePath.Windows.joinPath $ FilePath.Posix.splitDirectories prefix-                           ++ FilePath.Posix.splitDirectories name+fromTarPathToWindowsPath = BS.Char8.unpack . fromTarPathInternal FilePath.Windows.pathSeparator++fromTarPathInternal :: Char -> TarPath -> BS.ByteString+fromTarPathInternal sep = go   where-    name   = BS.Char8.unpack namebs-    prefix = BS.Char8.unpack prefixbs-    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name-                    = FilePath.Windows.addTrailingPathSeparator-                    | otherwise = id+    posixSep = FilePath.Posix.pathSeparator+    adjustSeps = if sep == posixSep then id else+      BS.Char8.map $ \c -> if c == posixSep then sep else c+    go (TarPath name prefix)+     | BS.null prefix = adjustSeps name+     | BS.null name = adjustSeps prefix+     | otherwise = adjustSeps prefix <> BS.Char8.cons sep (adjustSeps name)+{-# INLINE fromTarPathInternal #-}  -- | Convert a native 'FilePath' to a 'TarPath'. ----- The conversion may fail if the 'FilePath' is too long. See 'TarPath' for a--- description of the problem with splitting long 'FilePath's.---+-- The conversion may fail if the 'FilePath' is empty or too long.+-- Use 'toTarPath'' for a structured output. toTarPath :: Bool -- ^ Is the path for a directory? This is needed because for                   -- directories a 'TarPath' must always use a trailing @\/@.-          -> FilePath -> Either String TarPath-toTarPath isDir = splitLongPath-                . addTrailingSep-                . FilePath.Posix.joinPath-                . FilePath.Native.splitDirectories+          -> FilePath+          -> Either String TarPath+toTarPath isDir path = case toTarPath' path' of+  FileNameEmpty      -> Left "File name empty"+  FileNameOK tarPath -> Right tarPath+  FileNameTooLong{}  -> Left "File name too long"   where-    addTrailingSep | isDir     = FilePath.Posix.addTrailingPathSeparator-                   | otherwise = id+    path' = if isDir && not (FilePath.Native.hasTrailingPathSeparator path)+            then path <> [FilePath.Native.pathSeparator]+            else path +-- | Convert a native 'FilePath' to a 'TarPath'.+-- Directory paths must always have a trailing @\/@, this is not checked.+--+-- @since 0.6.0.0+toTarPath'+  :: FilePath+  -> ToTarPathResult+toTarPath'+  = splitLongPath+  . (if nativeSep == posixSep then id else adjustSeps)+  where+    nativeSep = FilePath.Native.pathSeparator+    posixSep = FilePath.Posix.pathSeparator+    adjustSeps = map $ \c -> if c == nativeSep then posixSep else c++-- | Return type of 'toTarPath''.+--+-- @since 0.6.0.0+data ToTarPathResult+  = FileNameEmpty+  -- ^ 'FilePath' was empty, but 'TarPath' must be non-empty.+  | FileNameOK TarPath+  -- ^ All good, this is just a normal 'TarPath'.+  | FileNameTooLong TarPath+  -- ^ 'FilePath' was longer than 255 characters, 'TarPath' contains+  -- a truncated part only. An actual entry must be preceded by+  -- 'longLinkEntry'.+ -- | Take a sanitised path, split on directory separators and try to pack it -- into the 155 + 100 tar file name format. -- -- The strategy is this: take the name-directory components in reverse order -- and try to fit as many components into the 100 long name area as possible. -- If all the remaining components fit in the 155 name area then we win.----splitLongPath :: FilePath -> Either String TarPath-splitLongPath path =-  case packName nameMax (reverse (FilePath.Posix.splitPath path)) of-    Left err                 -> Left err-    Right (name, [])         -> Right $! TarPath (BS.Char8.pack name)-                                                  BS.empty-    Right (name, first:rest) -> case packName prefixMax remainder of-      Left err               -> Left err-      Right (_     , (_:_))  -> Left "File name too long (cannot split)"-      Right (prefix, [])     -> Right $! TarPath (BS.Char8.pack name)-                                                 (BS.Char8.pack prefix)+splitLongPath :: FilePath -> ToTarPathResult+splitLongPath path = case reverse (FilePath.Posix.splitPath path) of+  [] -> FileNameEmpty+  c : cs -> case packName nameMax (c :| cs) of+    Nothing                 -> FileNameTooLong $ TarPath (packAscii $ take 100 path) BS.empty+    Just (name, [])         -> FileNameOK $! TarPath (packAscii name) BS.empty+    Just (name, first:rest) -> case packName prefixMax remainder of+      Nothing               -> FileNameTooLong $ TarPath (packAscii $ take 100 path) BS.empty+      Just (_     , _:_)    -> FileNameTooLong $ TarPath (packAscii $ take 100 path) BS.empty+      Just (prefix, [])     -> FileNameOK $! TarPath (packAscii name) (packAscii prefix)       where         -- drop the '/' between the name and prefix:-        remainder = init first : rest+        remainder = init first :| rest    where     nameMax, prefixMax :: Int     nameMax   = 100     prefixMax = 155 -    packName _      []     = Left "File name empty"-    packName maxLen (c:cs)-      | n > maxLen         = Left "File name too long"-      | otherwise          = Right (packName' maxLen n [c] cs)+    packName :: Int -> NonEmpty FilePath -> Maybe (FilePath, [FilePath])+    packName maxLen (c :| cs)+      | n > maxLen         = Nothing+      | otherwise          = Just (packName' maxLen n [c] cs)       where n = length c +    packName' :: Int -> Int -> [FilePath] -> [FilePath] -> (FilePath, [FilePath])     packName' maxLen n ok (c:cs)       | n' <= maxLen             = packName' maxLen n' (c:ok) cs                                      where n' = n + length c@@ -408,66 +486,80 @@   deriving (Eq, Ord, Show)  instance NFData LinkTarget where-#if MIN_VERSION_bytestring(0,10,0)     rnf (LinkTarget bs) = rnf bs-#else-    rnf (LinkTarget !_bs) = ()-#endif --- | Convert a native 'FilePath' to a tar 'LinkTarget'. This may fail if the+-- | Convert a native 'FilePath' to a tar 'LinkTarget'. -- string is longer than 100 characters or if it contains non-portable -- characters.----toLinkTarget   :: FilePath -> Maybe LinkTarget-toLinkTarget path | length path <= 100 = Just $! LinkTarget (BS.Char8.pack path)-                  | otherwise          = Nothing+toLinkTarget :: FilePath -> Maybe LinkTarget+toLinkTarget path+  | length path <= 100 = do+    target <- toLinkTarget' path+    Just $! LinkTarget (packAscii target)+  | otherwise = Nothing --- | Convert a tar 'LinkTarget' to a native 'FilePath'.----fromLinkTarget :: LinkTarget -> FilePath-fromLinkTarget (LinkTarget pathbs) = adjustDirectory $-  FilePath.Native.joinPath $ FilePath.Posix.splitDirectories path+data LinkTargetException = IsAbsolute FilePath+                         | TooLong FilePath+  deriving (Show,Typeable)++instance Exception LinkTargetException where+  displayException (IsAbsolute fp) = "Link target \"" <> fp <> "\" is unexpectedly absolute"+  displayException (TooLong _) = "The link target is too long"++-- | Convert a native 'FilePath' to a unix filepath suitable for+-- using as 'LinkTarget'. Does not error if longer than 100 characters.+toLinkTarget' :: FilePath -> Maybe FilePath+toLinkTarget' path+  | FilePath.Native.isAbsolute path = Nothing+  | otherwise = Just $ adjustDirectory $ FilePath.Posix.joinPath $ FilePath.Native.splitDirectories path   where-    path = BS.Char8.unpack pathbs-    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path-                    = FilePath.Native.addTrailingPathSeparator+    adjustDirectory | FilePath.Native.hasTrailingPathSeparator path+                    = FilePath.Posix.addTrailingPathSeparator                     | otherwise = id --- | Convert a tar 'LinkTarget' to a Unix/Posix 'FilePath'.---+-- | Convert a tar 'LinkTarget' to a native 'FilePath'.+fromLinkTarget :: LinkTarget -> FilePath+fromLinkTarget (LinkTarget pathbs) = fromFilePathToNative $ BS.Char8.unpack pathbs++-- | Convert a tar 'LinkTarget' to a Unix\/POSIX 'FilePath' (@\'/\'@ path separators). fromLinkTargetToPosixPath :: LinkTarget -> FilePath-fromLinkTargetToPosixPath (LinkTarget pathbs) = adjustDirectory $-  FilePath.Posix.joinPath $ FilePath.Posix.splitDirectories path-  where-    path = BS.Char8.unpack pathbs-    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path-                    = FilePath.Native.addTrailingPathSeparator-                    | otherwise = id+fromLinkTargetToPosixPath (LinkTarget pathbs) = BS.Char8.unpack pathbs --- | Convert a tar 'LinkTarget' to a Windows 'FilePath'.---+-- | Convert a tar 'LinkTarget' to a Windows 'FilePath' (@\'\\\\\'@ path separators). fromLinkTargetToWindowsPath :: LinkTarget -> FilePath-fromLinkTargetToWindowsPath (LinkTarget pathbs) = adjustDirectory $-  FilePath.Windows.joinPath $ FilePath.Posix.splitDirectories path+fromLinkTargetToWindowsPath (LinkTarget pathbs) =+  fromFilePathToWindowsPath $ BS.Char8.unpack pathbs++-- | Convert a unix FilePath to a native 'FilePath'.+fromFilePathToNative :: FilePath -> FilePath+fromFilePathToNative =+  fromFilePathInternal FilePath.Posix.pathSeparator FilePath.Native.pathSeparator++-- | Convert a unix FilePath to a Windows 'FilePath'.+fromFilePathToWindowsPath :: FilePath -> FilePath+fromFilePathToWindowsPath =+  fromFilePathInternal FilePath.Posix.pathSeparator FilePath.Windows.pathSeparator++fromFilePathInternal :: Char -> Char -> FilePath -> FilePath+fromFilePathInternal fromSep toSep = adjustSeps   where-    path = BS.Char8.unpack pathbs-    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path-                    = FilePath.Windows.addTrailingPathSeparator-                    | otherwise = id+    adjustSeps = if fromSep == toSep then id else+      map $ \c -> if c == fromSep then toSep else c+{-# INLINE fromFilePathInternal #-}  -- -- * Entries type -- --- | A tar archive is a sequence of entries.+-- | Polymorphic sequence of archive entries.+-- High-level interfaces+-- commonly work with 'GenEntries' 'FilePath' 'FilePath',+-- while low level uses 'GenEntries' 'TarPath' 'LinkTarget'. -- -- The point of this type as opposed to just using a list is that it makes the -- failure case explicit. We need this because the sequence of entries we get -- from reading a tarball can include errors. ----- It is a concrete data type so you can manipulate it directly but it is often--- clearer to use the provided functions for mapping, folding and unfolding.--- -- Converting from a list can be done with just @foldr Next Done@. Converting -- back into a list can be done with 'foldEntries' however in that case you -- must be prepared to handle the 'Fail' case inherent in the 'Entries' type.@@ -475,21 +567,36 @@ -- The 'Monoid' instance lets you concatenate archives or append entries to an -- archive. ---data Entries e = Next Entry (Entries e)-               | Done-               | Fail e-  deriving (Eq, Show)+-- @since 0.6.0.0+data GenEntries tarPath linkTarget e+  = Next (GenEntry tarPath linkTarget) (GenEntries tarPath linkTarget e)+  | Done+  | Fail e+  deriving+    ( Eq+    , Show+    , Functor+    , Foldable    -- ^ @since 0.6.0.0+    , Traversable -- ^ @since 0.6.0.0+    )  infixr 5 `Next` --- | This is like the standard 'unfoldr' function on lists, but for 'Entries'.+-- | Monomorphic sequence of archive entries,+-- ready for serialization / deserialization.+type Entries e = GenEntries 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 -- return. -- -- It can be used to generate 'Entries' from some other type. For example it is -- used internally to lazily unfold entries from a 'LBS.ByteString'. ---unfoldEntries :: (a -> Either e (Maybe (Entry, a))) -> a -> Entries e+unfoldEntries+  :: (a -> Either e (Maybe (GenEntry tarPath linkTarget, a)))+  -> a+  -> GenEntries tarPath linkTarget e unfoldEntries f = unfold   where     unfold x = case f x of@@ -504,7 +611,11 @@ -- This is used to consume a sequence of entries. For example it could be used -- to scan a tarball for problems or to collect an index of the contents. ---foldEntries :: (Entry -> a -> a) -> a -> (e -> a) -> Entries e -> a+foldEntries+  :: (GenEntry tarPath linkTarget -> a -> a)+  -> a+  -> (e -> a)+  -> GenEntries tarPath linkTarget e -> a foldEntries next done fail' = fold   where     fold (Next e es) = next e (fold es)@@ -515,8 +626,12 @@ -- accumulator result, or the failure along with the intermediate accumulator -- value. ---foldlEntries :: (a -> Entry -> a) -> a -> Entries e -> Either (e, a) a-foldlEntries f z = go z+foldlEntries+  :: (a -> GenEntry tarPath linkTarget -> a)+  -> a+  -> GenEntries tarPath linkTarget e+  -> Either (e, a) a+foldlEntries f = go   where     go !acc (Next e es) = go (f acc e) es     go !acc  Done       = Right acc@@ -527,181 +642,33 @@ -- -- If your mapping function cannot fail it may be more convenient to use -- 'mapEntriesNoFail'-mapEntries :: (Entry -> Either e' Entry) -> Entries e -> Entries (Either e e')+mapEntries+  :: (GenEntry tarPath linkTarget -> Either e' (GenEntry tarPath linkTarget))+  -- ^ Function to apply to each entry+  -> GenEntries tarPath linkTarget e+  -- ^ Input sequence+  -> GenEntries tarPath linkTarget (Either e e') mapEntries f =-  foldEntries (\entry rest -> either (Fail . Right) (flip Next rest) (f entry)) Done (Fail . Left)+  foldEntries (\entry rest -> either (Fail . Right) (`Next` rest) (f entry)) Done (Fail . Left)  -- | Like 'mapEntries' but the mapping function itself cannot fail. ---mapEntriesNoFail :: (Entry -> Entry) -> Entries e -> Entries e+mapEntriesNoFail+  :: (GenEntry tarPath linkTarget -> GenEntry tarPath linkTarget)+  -> GenEntries tarPath linkTarget e+  -> GenEntries tarPath linkTarget e mapEntriesNoFail f =-  foldEntries (\entry -> Next (f entry)) Done Fail+  foldEntries (Next . f) Done Fail  -- | @since 0.5.1.0-instance Sem.Semigroup (Entries e) where+instance Sem.Semigroup (GenEntries tarPath linkTarget e) where   a <> b = foldEntries Next b Fail a -instance Monoid (Entries e) where+instance Monoid (GenEntries tarPath linkTarget e) where   mempty  = Done   mappend = (Sem.<>) -instance Functor Entries where-  fmap f = foldEntries Next Done (Fail . f)--instance NFData e => NFData (Entries e) where+instance (NFData tarPath, NFData linkTarget, NFData e) => NFData (GenEntries tarPath linkTarget e) where   rnf (Next e es) = rnf e `seq` rnf es   rnf  Done       = ()   rnf (Fail e)    = rnf e------------------------------- QuickCheck instances-----#ifdef TESTS--instance Arbitrary Entry where-  arbitrary = Entry <$> arbitrary <*> arbitrary <*> arbitraryPermissions-                    <*> arbitrary <*> arbitraryEpochTime <*> arbitrary-    where-      arbitraryPermissions :: Gen Permissions-      arbitraryPermissions = fromIntegral <$> (arbitrary :: Gen Word16)--      arbitraryEpochTime :: Gen EpochTime-      arbitraryEpochTime = arbitraryOctal 11--  shrink (Entry path content perms author time format) =-      [ Entry path' content' perms author' time' format-      | (path', content', author', time') <--         shrink (path, content, author, time) ]-   ++ [ Entry path content perms' author time format-      | perms' <- shrinkIntegral perms ]--instance Arbitrary TarPath where-  arbitrary = either error id-            . toTarPath False-            . FilePath.Posix.joinPath-          <$> listOf1ToN (255 `div` 5)-                         (elements (map (replicate 4) "abcd"))--  shrink = map (either error id . toTarPath False)-         . map FilePath.Posix.joinPath-         . filter (not . null)-         . shrinkList shrinkNothing-         . FilePath.Posix.splitPath-         . fromTarPathToPosixPath--instance Arbitrary LinkTarget where-  arbitrary = maybe (error "link target too large") id-            . toLinkTarget-            . FilePath.Native.joinPath-          <$> listOf1ToN (100 `div` 5)-                         (elements (map (replicate 4) "abcd"))--  shrink = map (maybe (error "link target too large") id . toLinkTarget)-         . map FilePath.Posix.joinPath-         . filter (not . null)-         . shrinkList shrinkNothing-         . FilePath.Posix.splitPath-         . fromLinkTargetToPosixPath---listOf1ToN :: Int -> Gen a -> Gen [a]-listOf1ToN n g = sized $ \sz -> do-    n <- choose (1, min n (max 1 sz))-    vectorOf n g--listOf0ToN :: Int -> Gen a -> Gen [a]-listOf0ToN n g = sized $ \sz -> do-    n <- choose (0, min n sz)-    vectorOf n g--instance Arbitrary EntryContent where-  arbitrary =-    frequency-      [ (16, do bs <- arbitrary;-                return (NormalFile bs (LBS.length bs)))-      , (2, pure Directory)-      , (1, SymbolicLink    <$> arbitrary)-      , (1, HardLink        <$> arbitrary)-      , (1, CharacterDevice <$> arbitraryOctal 7 <*> arbitraryOctal 7)-      , (1, BlockDevice     <$> arbitraryOctal 7 <*> arbitraryOctal 7)-      , (1, pure NamedPipe)-      , (1, do c  <- elements (['A'..'Z']++['a'..'z'])-               bs <- arbitrary;-               return (OtherEntryType c bs (LBS.length bs)))-      ]--  shrink (NormalFile bs _)   = [ NormalFile bs' (LBS.length bs') -                               | bs' <- shrink bs ]-  shrink  Directory          = []-  shrink (SymbolicLink link) = [ SymbolicLink link' | link' <- shrink link ]-  shrink (HardLink     link) = [ HardLink     link' | link' <- shrink link ]-  shrink (CharacterDevice ma mi) = [ CharacterDevice ma' mi'-                                   | (ma', mi') <- shrink (ma, mi) ]-  shrink (BlockDevice     ma mi) = [ BlockDevice ma' mi'-                                   | (ma', mi') <- shrink (ma, mi) ]-  shrink  NamedPipe              = []-  shrink (OtherEntryType c bs _) = [ OtherEntryType c bs' (LBS.length bs') -                                   | bs' <- shrink bs ]--instance Arbitrary LBS.ByteString where-  arbitrary = fmap LBS.pack arbitrary-  shrink    = map LBS.pack . shrink . LBS.unpack--instance Arbitrary BS.ByteString where-  arbitrary = fmap BS.pack arbitrary-  shrink    = map BS.pack . shrink . BS.unpack--instance Arbitrary Ownership where-  arbitrary = Ownership <$> name <*> name-                        <*> idno <*> idno-    where-      -- restrict user/group to posix ^[a-z][-a-z0-9]{0,30}$-      name = do-        first <- choose ('a', 'z')-        rest <- listOf0ToN 30 (oneof [choose ('a', 'z'), choose ('0', '9'), pure '-'])-        return $ first : rest-      idno = arbitraryOctal 7--  shrink (Ownership oname gname oid gid) =-    [ Ownership oname' gname' oid' gid'-    | (oname', gname', oid', gid') <- shrink (oname, gname, oid, gid) ]--instance Arbitrary Format where-  arbitrary = elements [V7Format, UstarFormat, GnuFormat]-----arbitraryOctal :: (Integral n, Random n) => Int -> Gen n-arbitraryOctal n =-    oneof [ pure 0-          , choose (0, upperBound)-          , pure upperBound-          ]-  where-    upperBound = 8^n-1---- For QC tests it's useful to have a way to limit the info to that which can--- be expressed in the old V7 format-limitToV7FormatCompat :: Entry -> Entry-limitToV7FormatCompat entry@Entry { entryFormat = V7Format } =-    entry {-      entryContent = case entryContent entry of-        CharacterDevice _ _ -> OtherEntryType  '3' LBS.empty 0-        BlockDevice     _ _ -> OtherEntryType  '4' LBS.empty 0-        Directory           -> OtherEntryType  '5' LBS.empty 0-        NamedPipe           -> OtherEntryType  '6' LBS.empty 0-        other               -> other,--      entryOwnership = (entryOwnership entry) {-        groupName = "",-        ownerName = ""-      },--      entryTarPath = let TarPath name _prefix = entryTarPath entry-                      in TarPath name BS.empty-    }-limitToV7FormatCompat entry = entry--#endif-

@@ -1,4 +1,11 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Use for_" #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Codec.Archive.Tar@@ -13,31 +20,48 @@ ----------------------------------------------------------------------------- module Codec.Archive.Tar.Unpack (   unpack,+  unpackAndCheck,   ) where  import Codec.Archive.Tar.Types import Codec.Archive.Tar.Check+import Codec.Archive.Tar.LongNames +import Data.Bits+         ( testBit )+import Data.List (partition, nub)+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          ( takeDirectory ) import System.Directory-         ( createDirectoryIfMissing, copyFile )+    ( createDirectoryIfMissing,+      copyFile,+      setPermissions,+      listDirectory,+      doesDirectoryExist,+      createDirectoryLink,+      createFileLink,+      setModificationTime,+      emptyPermissions,+      setOwnerReadable,+      setOwnerWritable,+      setOwnerExecutable,+      setOwnerSearchable ) import Control.Exception-         ( Exception, throwIO )-#if MIN_VERSION_directory(1,2,3)-import System.Directory-         ( setModificationTime )+         ( Exception, throwIO, handle )+import System.IO ( stderr, hPutStr )+import System.IO.Error ( ioeGetErrorType, isPermissionError )+import GHC.IO (unsafeInterleaveIO)+import Data.Foldable (traverse_)+import GHC.IO.Exception (IOErrorType(InappropriateType, IllegalOperation, PermissionDenied, InvalidArgument)) import Data.Time.Clock.POSIX          ( posixSecondsToUTCTime ) import Control.Exception as Exception-         ( catch )-import System.IO.Error-         ( isPermissionError )-#endif-+         ( catch, SomeException(..) )  -- | Create local files and directories based on the entries of a tar archive. --@@ -54,71 +78,214 @@ -- into an empty directory so that you can easily clean up if unpacking fails -- part-way. ----- On its own, this function only checks for security (using 'checkSecurity').--- You can do other checks by applying checking functions to the 'Entries' that--- you pass to this function. For example:+-- On its own, this function only checks for security (using 'checkEntrySecurity').+-- Use 'unpackAndCheck' if you need more checks. ----- > unpack dir (checkTarbomb expectedDir entries)+unpack+  :: Exception e+  => FilePath+  -- ^ Base directory+  -> Entries e+  -- ^ Entries to upack+  -> IO ()+unpack = unpackAndCheck (fmap SomeException . checkEntrySecurity)++-- | Like 'unpack', but run custom sanity/security checks instead of 'checkEntrySecurity'.+-- For example, ----- If you care about the priority of the reported errors then you may want to--- use 'checkSecurity' before 'checkTarbomb' or other checks.+-- > unpackAndCheck (\x -> SomeException <$> checkEntryPortability x+-- >                   <|> SomeException <$> checkEntrySecurity x) dir entries ---unpack :: Exception e => FilePath -> Entries e -> IO ()-unpack baseDir entries = unpackEntries [] (checkSecurity entries)-                     >>= emulateLinks+-- @since 0.6.0.0+unpackAndCheck+  :: Exception e+  => (GenEntry FilePath FilePath -> Maybe SomeException)+  -- ^ Checks to run on each entry before unpacking+  -> FilePath+  -- ^ Base directory+  -> Entries e+  -- ^ Entries to upack+  -> IO ()+unpackAndCheck secCB baseDir entries = do+  let resolvedEntries = decodeLongNames entries+  uEntries <- unpackEntries [] resolvedEntries+  let (hardlinks, symlinks) = partition (\(_, _, x) -> x) uEntries+  -- handle hardlinks first, in case a symlink points to it+  handleHardLinks hardlinks+  handleSymlinks symlinks    where-    -- We're relying here on 'checkSecurity' to make sure we're not scribbling+    -- We're relying here on 'secCB' to make sure we're not scribbling     -- files all over the place. +    unpackEntries :: Exception e+                  => [(FilePath, FilePath, Bool)]+                  -- ^ links (path, link, isHardLink)+                  -> GenEntries FilePath FilePath (Either e DecodeLongNamesError)+                  -- ^ entries+                  -> IO [(FilePath, FilePath, Bool)]     unpackEntries _     (Fail err)      = either throwIO throwIO err     unpackEntries links Done            = return links-    unpackEntries links (Next entry es) = case entryContent entry of-      NormalFile file _ -> extractFile path file mtime-                        >> unpackEntries links es-      Directory         -> extractDir path mtime-                        >> unpackEntries links es-      HardLink     link -> (unpackEntries $! saveLink path link links) es-      SymbolicLink link -> (unpackEntries $! saveLink path link links) es-      _                 -> unpackEntries links es --ignore other file types-      where-        path  = entryPath entry-        mtime = entryTime entry+    unpackEntries links (Next entry es) = do+      case secCB entry of+        Nothing -> pure ()+        Just e -> throwIO e -    extractFile path content mtime = do+      case entryContent entry of+        NormalFile file _ -> do+          extractFile (entryPermissions entry) (entryTarPath entry) file (entryTime entry)+          unpackEntries links es+        Directory -> do+          extractDir (entryTarPath entry) (entryTime entry)+          unpackEntries links es+        HardLink link -> do+          (unpackEntries $! saveLink True (entryTarPath entry) link links) es+        SymbolicLink link -> do+          (unpackEntries $! saveLink False (entryTarPath entry) link links) es+        OtherEntryType{} ->+          -- the spec demands that we attempt to extract as normal file on unknown typecode,+          -- but we just skip it+          unpackEntries links es+        CharacterDevice{} -> unpackEntries links es+        BlockDevice{} -> unpackEntries links es+        NamedPipe -> unpackEntries links es++    extractFile permissions (fromFilePathToNative -> 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+      setOwnerPermissions absPath permissions       setModTime absPath mtime       where         absDir  = baseDir </> FilePath.Native.takeDirectory path         absPath = baseDir </> path -    extractDir path mtime = do+    extractDir (fromFilePathToNative -> path) mtime = do       createDirectoryIfMissing True absPath       setModTime absPath mtime       where         absPath = baseDir </> path -    saveLink path link links = seq (length path)-                             $ seq (length link')-                             $ (path, link'):links-      where link' = fromLinkTarget link+    saveLink isHardLink (fromFilePathToNative -> path) (fromFilePathToNative -> link) links+      = seq (length path)+          $ seq (length link)+          $ (path, link, isHardLink):links -    emulateLinks = mapM_ $ \(relPath, relLinkTarget) ->++    -- for hardlinks, we just copy+    handleHardLinks = mapM_ $ \(relPath, relLinkTarget, _) ->       let absPath   = baseDir </> relPath+          -- hard links link targets are always "absolute" paths in+          -- the context of the tar root+          absTarget = baseDir </> relLinkTarget+      -- we don't expect races here, since we should be the+      -- only process unpacking the tar archive and writing to+      -- the destination+      in doesDirectoryExist absTarget >>= \case+          True -> copyDirectoryRecursive absTarget absPath+          False -> copyFile absTarget absPath++    -- For symlinks, we first try to recreate them and if that fails+    -- with 'IllegalOperation', 'PermissionDenied' or 'InvalidArgument',+    -- we fall back to copying.+    -- 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 = mapM_ $ \(relPath, relLinkTarget, _) ->+      let absPath   = baseDir </> relPath+          -- hard links link targets are always "absolute" paths in+          -- the context of the tar root           absTarget = FilePath.Native.takeDirectory absPath </> relLinkTarget-       in copyFile absTarget absPath+      -- we don't expect races here, since we should be the+      -- only process unpacking the tar archive and writing to+      -- the destination+      in doesDirectoryExist absTarget >>= \case+          True -> handleSymlinkError (copyDirectoryRecursive absTarget absPath)+            $ createDirectoryLink relLinkTarget absPath+          False -> handleSymlinkError (copyFile absTarget absPath)+            $ createFileLink relLinkTarget absPath +      where+        handleSymlinkError action =+          handle (\e -> if ioeGetErrorType e `elem` [IllegalOperation+                                                    ,PermissionDenied+                                                    ,InvalidArgument]+                      then action+                      else throwIO e+                 )++-- | Recursively copy the contents of one directory to another path.+--+-- This is a rip-off of Cabal library.+copyDirectoryRecursive :: FilePath -> FilePath -> IO ()+copyDirectoryRecursive srcDir destDir = do+  srcFiles <- getDirectoryContentsRecursive srcDir+  copyFilesWith copyFile destDir [ (srcDir, f)+                                   | f <- srcFiles ]+  where+    -- | Common implementation of 'copyFiles', 'installOrdinaryFiles',+    -- 'installExecutableFiles' and 'installMaybeExecutableFiles'.+    copyFilesWith :: (FilePath -> FilePath -> IO ())+                  -> FilePath -> [(FilePath, FilePath)] -> IO ()+    copyFilesWith doCopy targetDir srcFiles = do++      -- Create parent directories for everything+      let dirs = map (targetDir </>) . nub . map (FilePath.Native.takeDirectory . snd) $ srcFiles+      traverse_ (createDirectoryIfMissing True) dirs++      -- Copy all the files+      sequence_ [ let src  = srcBase   </> srcFile+                      dest = targetDir </> srcFile+                   in doCopy src dest+                | (srcBase, srcFile) <- srcFiles ]++    -- | List all the files in a directory and all subdirectories.+    --+    -- The order places files in sub-directories after all the files in their+    -- 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 [""]+      where+        recurseDirectories :: [FilePath] -> IO [FilePath]+        recurseDirectories []         = return []+        recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do+          (files, dirs') <- collect [] [] =<< listDirectory (topdir </> dir)+          files' <- recurseDirectories (dirs' ++ dirs)+          return (files ++ files')++          where+            collect files dirs' []              = return (reverse files+                                                         ,reverse dirs')+            collect files dirs' (entry:entries) = do+              let dirEntry = dir </> entry+              isDirectory <- doesDirectoryExist (topdir </> dirEntry)+              if isDirectory+                then collect files (dirEntry:dirs') entries+                else collect (dirEntry:files) dirs' entries+ setModTime :: FilePath -> EpochTime -> IO ()-#if MIN_VERSION_directory(1,2,3)--- functionality only supported as of directory-1.2.3.x setModTime path t =     setModificationTime path (posixSecondsToUTCTime (fromIntegral t))-      `Exception.catch` \e ->-        if isPermissionError e then return () else throwIO e-#else-setModTime _path _t = return ()-#endif+      `Exception.catch` \e -> case ioeGetErrorType e of+        PermissionDenied -> return ()+        -- On FAT32 file system setting time prior to DOS Epoch (1980-01-01)+        -- throws InvalidArgument, https://github.com/haskell/tar/issues/37+        InvalidArgument -> return ()+        _ -> throwIO e++setOwnerPermissions :: FilePath -> Permissions -> IO ()+setOwnerPermissions path permissions =+  setPermissions path ownerPermissions+  where+    -- | Info on Permission bits can be found here:+    -- https://www.gnu.org/software/libc/manual/html_node/Permission-Bits.html+    ownerPermissions =+      setOwnerReadable   (testBit permissions 8) $+      setOwnerWritable   (testBit permissions 7) $+      setOwnerExecutable (testBit permissions 6) $+      setOwnerSearchable (testBit permissions 6) $+      emptyPermissions

@@ -14,7 +14,9 @@  import Codec.Archive.Tar.Types -import Data.Char     (ord)+import Data.Bits+import Data.Char     (chr,ord)+import Data.Int import Data.List     (foldl') import Data.Monoid   (mempty) import Numeric       (showOct)@@ -35,7 +37,17 @@  putEntry :: Entry -> LBS.ByteString putEntry entry = case entryContent entry of-  NormalFile       content size -> LBS.concat [ header, content, padding size ]+  NormalFile       content size+    -- size field is 12 bytes long, so in octal format (see 'putOct')+    -- it can hold numbers up to 8Gb+    | size >= 1 `shiftL` (3 * (12 -1))+    , entryFormat entry == V7Format+    -> error "putEntry: support for files over 8Gb is a Ustar extension"+    | otherwise -> LBS.concat [ header, content, padding size ]+  OtherEntryType 'K' _ _+    | entryFormat entry /= GnuFormat -> error "putEntry: long symlink support is a GNU extension"+  OtherEntryType 'L' _ _+    | entryFormat entry /= GnuFormat -> error "putEntry: long filename support is a GNU extension"   OtherEntryType _ content size -> LBS.concat [ header, content, padding size ]   _                             -> header   where@@ -49,8 +61,6 @@    $ take 148 block   ++ putOct 7 checksum   ++ ' ' : drop 156 block---  ++ putOct 8 checksum---  ++ drop 156 block   where     block    = putHeaderNoChkSum entry     checksum = foldl' (\x y -> x + ord y) 0 block@@ -66,38 +76,45 @@   } =    concat-    [ putBString 100 $ name-    , putOct       8 $ permissions+    [ putBString 100 name+    , putOct       8 permissions     , putOct       8 $ ownerId ownership     , putOct       8 $ groupId ownership-    , putOct      12 $ contentSize-    , putOct      12 $ modTime-    , fill         8 $ ' ' -- dummy checksum-    , putChar8       $ typeCode-    , putBString 100 $ linkTarget+    , numField    12 contentSize+    , putOct      12 modTime+    , replicate    8 ' ' -- dummy checksum+    , putChar8       typeCode+    , putBString 100 linkTarget     ] ++   case format of   V7Format    ->-      fill 255 '\NUL'+      replicate 255 '\NUL'   UstarFormat -> concat-    [ putBString   8 $ ustarMagic+    [ putBString   8 ustarMagic     , putString   32 $ ownerName ownership     , putString   32 $ groupName ownership-    , putOct       8 $ deviceMajor-    , putOct       8 $ deviceMinor-    , putBString 155 $ prefix-    , fill        12 $ '\NUL'+    , putOct       8 deviceMajor+    , putOct       8 deviceMinor+    , putBString 155 prefix+    , replicate   12 '\NUL'     ]   GnuFormat -> concat-    [ putBString   8 $ gnuMagic+    [ putBString   8 gnuMagic     , putString   32 $ ownerName ownership     , putString   32 $ groupName ownership-    , putGnuDev    8 $ deviceMajor-    , putGnuDev    8 $ deviceMinor-    , putBString 155 $ prefix-    , fill        12 $ '\NUL'+    , putGnuDev    8 deviceMajor+    , putGnuDev    8 deviceMinor+    , putBString 155 prefix+    , replicate   12 '\NUL'     ]   where+    numField :: FieldWidth -> Int64 -> String+    numField w n+      | n >= 0 && n < 1 `shiftL` (3 * (w - 1))+      = putOct w n+      | otherwise+      = putLarge w n+     (typeCode, contentSize, linkTarget,      deviceMajor, deviceMinor) = case content of        NormalFile      _ size            -> ('0' , size, mempty, 0,     0)@@ -123,21 +140,23 @@ type FieldWidth = Int  putBString :: FieldWidth -> BS.ByteString -> String-putBString n s = BS.Char8.unpack (BS.take n s) ++ fill (n - BS.length s) '\NUL'+putBString n s = BS.Char8.unpack (BS.take n s) ++ replicate (n - BS.length s) '\NUL'  putString :: FieldWidth -> String -> String-putString n s = take n s ++ fill (n - length s) '\NUL'+putString n s = take n s ++ replicate (n - length s) '\NUL' ---TODO: check integer widths, eg for large file sizes+{-# SPECIALISE putLarge :: FieldWidth -> Int64 -> String #-}+putLarge :: (Bits a, Integral a) => FieldWidth -> a -> String+putLarge n0 x0 = '\x80' : reverse (go (n0-1) x0)+  where go 0 _ = []+        go n x = chr (fromIntegral (x .&. 0xff)) : go (n-1) (x `shiftR` 8)+ putOct :: (Integral a, Show a) => FieldWidth -> a -> String putOct n x =   let octStr = take (n-1) $ showOct x ""-   in fill (n - length octStr - 1) '0'+   in replicate (n - length octStr - 1) '0'    ++ octStr    ++ putChar8 '\NUL'  putChar8 :: Char -> String putChar8 c = [c]--fill :: FieldWidth -> Char -> String-fill n c = replicate n c

@@ -0,0 +1,13 @@+# tar [![Hackage](https://img.shields.io/hackage/v/tar.svg)](https://hackage.haskell.org/package/tar)++This library is for working with `.tar` archive files. It can read and write a range of common variations of archive format including V7, POSIX USTAR and GNU formats. It provides support for packing and unpacking portable archives and features for random access to archive content using an index.++For a quick start with the API look at `htar/htar.hs`,+which implements a very basic `tar` command-line tool.++To run benchmarks download [`01-index.tar`](https://hackage.haskell.org/01-index.tar) into the package folder:++```sh+wget https://hackage.haskell.org/01-index.tar+cabal bench+```

@@ -4,10 +4,13 @@ import qualified Codec.Archive.Tar.Index as TarIndex  import qualified Data.ByteString.Lazy    as BS+import Data.Maybe import Control.Exception+import System.Directory+import System.Environment+import System.IO.Temp -import Criterion-import Criterion.Main+import Test.Tasty.Bench  main = defaultMain benchmarks @@ -24,11 +27,21 @@    , env loadTarIndex $ \entries ->       bench "index rebuild" (nf (TarIndex.finalise . TarIndex.unfinalise) entries)++  , env loadTarEntries $ \entries ->+      bench "unpack" (nfIO $ withSystemTempDirectory "tar-bench" $ \baseDir -> Tar.unpack baseDir entries)   ]  loadTarFile :: IO BS.ByteString-loadTarFile =-    BS.readFile "01-index.tar"+loadTarFile = do+    mTarFile <- lookupEnv "TAR_TEST_FILE"+    let tarFile = fromMaybe "01-index.tar" mTarFile+    exists <- doesFileExist tarFile+    if exists+      then BS.readFile tarFile+      else case mTarFile of+             Just _ -> error $ tarFile <> " does not exist"+             Nothing -> error "01-index.tar does not exist, copy it from ~/.cabal/packages/hackage.haskell.org/01-index.tar"  loadTarEntries :: IO (Tar.Entries Tar.FormatError) loadTarEntries =

@@ -1,47 +1,89 @@-See also http://pvp.haskell.org/faq+## 0.6.0.0 Bodigrim <andrew.lelechenko@gmail.com> December 2023 -0.5.1.1 Herbert Valerio Riedel <hvr@gnu.org> March 2018+  This release features support for long file paths and symlinks+  (thanks to Julian Ospald) and variety of changes and improvements+  across entire package, fixing multiple causes of silent data corruption. +  Breaking changes:++  * Generalize `Entries`, `Entry` and `EntryContent` to `GenEntries`, `GenEntry` and `GenEntryContent`.+    * Functions working on entries have been generalized to more polymorphic types,+      where possible.+    * Modules which used to `import Codec.Archive.Tar (Entry(..))` should now+      `import Codec.Archive.Tar (GenEntry(..), Entry)` and similar for other `Gen`-types.+  * Redesign `Codec.Archive.Tar.Check`.+    * Change types of `checkSecurity`, `checkTarbomb`, `checkPortability`.+    * Add offending path as new field to `TarBombError` constructor.+    * Extend `FileNameError` with `UnsafeLinkTarget` constructor.+  * Drop deprecated `emptyIndex` and `finaliseIndex`.++  Bug fixes:++  * Add support for over-long filepaths via GNU extension.+  * Fix handling of hardlinks and symlinks.+  * Handle > 8 GB files insted of silent corruption.+  * Prohibit non-ASCII file names instead of silent corruption.+  * Set permissions on extracted files.+  * Ignore FAT32 errors when setting modification time.+  * Switch to trailer parsing mode only after a full block of `NUL`.++  New API:++  * Add `Traversable Entries` instance.+  * Add `toTarPath'`, `ToTarPathResult`, `longLinkEntry`, `longSymLinkEntry`.+  * Add `packSymlinkEntry` and `symbolicLinkPermission`.+  * Add `packAndCheck` and `unpackAndCheck`.+  * Add `checkEntrySecurity`, `checkEntryTarbomb` and `checkEntryPortability`.+  * Add `encodeLongNames`, `decodeLongNames`, `DecodeLongNamesError`.++  Improvements:++  * Speed up `fromTarPath`, `fromTarPathToPosixPath` and `fromTarPathToWindowsPath`.+  * Alleviate leakage of file handles in `packFileEntry`.+  * Fix tests on 32-bit architectures.++## 0.5.1.1 Herbert Valerio Riedel <hvr@gnu.org> August 2019+   * Add support for GHC 8.8.1 / base-4.13 -0.5.1.0 Herbert Valerio Riedel <hvr@gnu.org> March 2018+## 0.5.1.0 Herbert Valerio Riedel <hvr@gnu.org> March 2018    * Add support for GHC 8.4.1 / base-4.11   * Add `Semigroup` instance for `Entries` -0.5.0.3 Duncan Coutts <duncan@community.haskell.org> May 2016+## 0.5.0.3 Duncan Coutts <duncan@community.haskell.org> May 2016    * Fix tarbomb logic to ignore special PAX entries. Was breaking many     valid tarballs. https://github.com/haskell/cabal/issues/3390 -0.5.0.2 Duncan Coutts <duncan@community.haskell.org> April 2016+## 0.5.0.2 Duncan Coutts <duncan@community.haskell.org> April 2016    * Fix compatability when using ghc-7.4.x and directory >= 1.2.3 -0.5.0.1 Duncan Coutts <duncan@community.haskell.org> January 2016+## 0.5.0.1 Duncan Coutts <duncan@community.haskell.org> January 2016    * Fix compatability with directory-1.2.3+ -0.5.0.0 Duncan Coutts <duncan@community.haskell.org> January 2016+## 0.5.0.0 Duncan Coutts <duncan@community.haskell.org> January 2016    * Work with old version of bytestring (using bytestring-builder package).   * Builds with GHC 6.10 -- 8.0.   * Change type of Index.serialise to be simply strict bytestring.   * Preserve file timestamps on unpack (with directory-1.2.3+) -0.4.5.0 Duncan Coutts <duncan@community.haskell.org> January 2016+## 0.4.5.0 Duncan Coutts <duncan@community.haskell.org> January 2016    * Revert accidental minor API change in 0.4.x series (the type of the     owner and group name strings). The 0.4.3.0 and 0.4.4.0 releases     contained the accidental API change.   * Add a handy foldlEntries function -0.4.4.0 Duncan Coutts <duncan@community.haskell.org> January 2016+## 0.4.4.0 Duncan Coutts <duncan@community.haskell.org> January 2016    * Build and warning fixes for GHC 7.10 and 8.0   * New Index module function `toList` to get all index entries -0.4.3.0 Duncan Coutts <duncan@community.haskell.org> January 2016+## 0.4.3.0 Duncan Coutts <duncan@community.haskell.org> January 2016    * New Index function `unfinalise` to extend existing index   * 9x  faster reading@@ -52,32 +94,32 @@   * Greater QC test coverage   * Fix minor bug in reading non-standard v7 format entries -0.4.2.2 Edsko de Vries <edsko@well-typed.com> October 2015+## 0.4.2.2 Edsko de Vries <edsko@well-typed.com> October 2015    * Fix bug in Index -0.4.2.1 Duncan Coutts <duncan@community.haskell.org> July 2015+## 0.4.2.1 Duncan Coutts <duncan@community.haskell.org> July 2015    * Fix tests for the Index modules (the code was right) -0.4.2.0 Duncan Coutts <duncan@community.haskell.org> July 2015+## 0.4.2.0 Duncan Coutts <duncan@community.haskell.org> July 2015    * New Index module for random access to tar file contents   * New lower level tar file I/O actions   * New tarball file 'append' action -0.4.1.0 Duncan Coutts <duncan@community.haskell.org> January 2015+## 0.4.1.0 Duncan Coutts <duncan@community.haskell.org> January 2015    * Build with GHC 7.10   * Switch from old-time to time package   * Added more instance for Entries type -0.4.0.1 Duncan Coutts <duncan@community.haskell.org> October 2012+## 0.4.0.1 Duncan Coutts <duncan@community.haskell.org> October 2012    * fixes to work with directory 1.2   * More Eq/Ord instances -0.4.0.0 Duncan Coutts <duncan@community.haskell.org> February 2012+## 0.4.0.0 Duncan Coutts <duncan@community.haskell.org> February 2012    * More explicit error types and error handling   * Support star base-256 number format

@@ -1,12 +1,10 @@-cabal-version:   1.12 name:            tar-version:         0.5.1.1-+version:         0.6.0.0 license:         BSD3 license-file:    LICENSE author:          Duncan Coutts <duncan@community.haskell.org>                  Bjorn Bringert <bjorn@bringert.net>-maintainer:      Duncan Coutts <duncan@community.haskell.org>+maintainer:      Bodigrim <andrew.lelechenko@gmail.com> bug-reports:     https://github.com/haskell/tar/issues copyright:       2007 Bjorn Bringert <bjorn@bringert.net>                  2008-2016 Duncan Coutts <duncan@community.haskell.org>@@ -24,62 +22,57 @@                  It also provides features for random access to archive                  content using an index. build-type:      Simple-extra-source-files: changelog.md-tested-with:     GHC==7.0.4, GHC==7.2.2, GHC==7.4.2, GHC==7.6.3,-                 GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.1+cabal-version:   2.0+extra-source-files:+                 test/data/long-filepath.tar+                 test/data/long-symlink.tar+                 test/data/symlink.tar+extra-doc-files: changelog.md+                 README.md+tested-with:     GHC==9.8.1, GHC==9.6.3, 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  source-repository head   type: git   location: https://github.com/haskell/tar.git -flag old-time-  default: False--flag old-bytestring-  default: False- library--  build-depends: base       >= 4 && < 4.14,-                 filepath             < 1.5,-                 array                < 0.6,-                 containers >= 0.2 && < 0.7,-                 deepseq    >= 1.1 && < 1.5--  if flag(old-time)-    build-depends: directory < 1.2, old-time < 1.2-  else-    build-depends: directory >= 1.2 && < 1.4, time < 1.10+  default-language: Haskell2010+  build-depends: tar-internal -  if flag(old-bytestring)-    build-depends: bytestring-builder >= 0.10.4.0.2 && < 0.11, bytestring == 0.9.*-  else-    build-depends: bytestring == 0.10.*+  reexported-modules:+    Codec.Archive.Tar,+    Codec.Archive.Tar.Entry,+    Codec.Archive.Tar.Check,+    Codec.Archive.Tar.Index -  if !impl(ghc >= 8.0)-    build-depends: semigroups == 0.18.*+library tar-internal+  default-language: Haskell2010+  build-depends: base       >= 4.11  && < 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,+                 time                  < 1.13    exposed-modules:     Codec.Archive.Tar     Codec.Archive.Tar.Entry     Codec.Archive.Tar.Check+    Codec.Archive.Tar.Check.Internal     Codec.Archive.Tar.Index--  other-modules:+    Codec.Archive.Tar.LongNames     Codec.Archive.Tar.Types     Codec.Archive.Tar.Read     Codec.Archive.Tar.Write     Codec.Archive.Tar.Pack+    Codec.Archive.Tar.PackAscii     Codec.Archive.Tar.Unpack     Codec.Archive.Tar.Index.StringTable     Codec.Archive.Tar.Index.IntTrie--  default-language: Haskell2010-  -- Previously, the package used GHC's default Haskell mode which implies-  -- NDI; so we keep it transitionally enabled here until we've reviewed the-  -- code to make sure there isn't any code relies on NDI and keeps compiling-  -- albeit with different semantics even without NDI-  default-extensions: NondecreasingIndentation+    Codec.Archive.Tar.Index.Internal    other-extensions:     BangPatterns@@ -89,55 +82,40 @@     PatternGuards     ScopedTypeVariables -   ghc-options: -Wall -fno-warn-unused-imports  test-suite properties   type:          exitcode-stdio-1.0-  build-depends: base,-                 filepath,+  default-language: Haskell2010+  build-depends: base < 5,                  array,+                 bytestring >= 0.10,                  containers,                  deepseq,-                 bytestring-handle,+                 directory >= 1.2,+                 file-embed,+                 filepath,                  QuickCheck       == 2.*,-                 tasty            >= 0.10 && <0.12,-                 tasty-quickcheck == 0.8.*--  if flag(old-time)-    build-depends: directory < 1.2, old-time-  else-    build-depends: directory >= 1.2, time--  if flag(old-bytestring)-    build-depends: bytestring-builder, bytestring >= 0.9 && <0.10-  else-    build-depends: bytestring >= 0.10--  if !impl(ghc >= 8.0)-    build-depends: semigroups == 0.18.*--  default-language: Haskell2010+                 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 -  hs-source-dirs: . test+  hs-source-dirs: test -  main-is: test/Properties.hs-  cpp-options: -DTESTS+  main-is: Properties.hs    other-modules:-    Codec.Archive.Tar.Index-    Codec.Archive.Tar.Index.StringTable-    Codec.Archive.Tar.Index.IntTrie--  -- shared w/ lib:tar component-  other-modules:-    Codec.Archive.Tar-    Codec.Archive.Tar.Check-    Codec.Archive.Tar.Pack-    Codec.Archive.Tar.Read-    Codec.Archive.Tar.Types-    Codec.Archive.Tar.Unpack-    Codec.Archive.Tar.Write+    Codec.Archive.Tar.Tests+    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+    Codec.Archive.Tar.Unpack.Tests    other-extensions:     CPP@@ -149,32 +127,17 @@  benchmark bench   type:          exitcode-stdio-1.0-  hs-source-dirs: . bench-  main-is:       bench/Main.hs-  build-depends: base,+  default-language: Haskell2010+  hs-source-dirs: bench+  main-is:       Main.hs+  build-depends: base < 5,+                 tar,                  bytestring >= 0.10,                  filepath,                  directory >= 1.2,                  array,                  containers,                  deepseq,+                 temporary < 1.4,                  time,-                 criterion >= 1.0--  if !impl(ghc >= 8.0)-    build-depends: semigroups == 0.18.*--  default-language: Haskell2010--  -- shared w/ lib:tar component-  other-modules:-    Codec.Archive.Tar-    Codec.Archive.Tar.Check-    Codec.Archive.Tar.Index-    Codec.Archive.Tar.Index.IntTrie-    Codec.Archive.Tar.Index.StringTable-    Codec.Archive.Tar.Pack-    Codec.Archive.Tar.Read-    Codec.Archive.Tar.Types-    Codec.Archive.Tar.Unpack-    Codec.Archive.Tar.Write+                 tasty-bench < 0.4

@@ -0,0 +1,252 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Codec.Archive.Tar.Index.IntTrie.Tests (+  test1, test2, test3,+  ValidPaths(..),+  prop_lookup,+  prop_completions,+  prop_lookup_mono,+  prop_completions_mono,+  prop_construct_toList,+  prop_finalise_unfinalise,+  prop_serialise_deserialise,+  prop_serialiseSize,+ ) where++import Prelude hiding (lookup)+import Codec.Archive.Tar.Index.IntTrie++import qualified Data.Array.Unboxed as A+import Data.Char+import Data.Function (on)+import Data.List hiding (lookup, insert)+import Data.Word (Word32)+import qualified Data.ByteString        as BS+import qualified Data.ByteString.Lazy   as LBS+#if MIN_VERSION_bytestring(0,10,2) || defined(MIN_VERSION_bytestring_builder)+import Data.ByteString.Builder          as BS+#else+import Data.ByteString.Lazy.Builder     as BS+#endif+#if MIN_VERSION_containers(0,5,0)+import qualified Data.IntMap.Strict     as IntMap+import Data.IntMap.Strict (IntMap)+#else+import qualified Data.IntMap            as IntMap+import Data.IntMap (IntMap)+#endif++import Test.QuickCheck+import Control.Applicative ((<$>), (<*>))+import Data.Bits+import Data.Int++-- Example mapping:+--+example0 :: [(FilePath, Int)]+example0 =+  [("foo-1.0/foo-1.0.cabal", 512)   -- tar block 1+  ,("foo-1.0/LICENSE",       2048)  -- tar block 4+  ,("foo-1.0/Data/Foo.hs",   4096)] -- tar block 8++-- After converting path components to integers this becomes:+--+example1 :: [([Key], Value)]+example1 =+  [([Key 1, Key 2], Value 512)+  ,([Key 1, Key 3], Value 2048)+  ,([Key 1, Key 4, Key 5], Value 4096)]++-- As a trie this looks like:++--  [ (1, *) ]+--        |+--        [ (2, 512), (3, 1024), (4, *) ]+--                                   |+--                                   [ (5, 4096) ]++-- We use an intermediate trie representation++mktrie :: [(Int, TrieNode)] -> IntTrieBuilder+mkleaf :: Key -> Value          -> (Int, TrieNode)+mknode :: Key -> IntTrieBuilder -> (Int, TrieNode)++mktrie = IntTrieBuilder . IntMap.fromList+mkleaf k v = (fromIntegral $ unKey k, TrieLeaf (unValue v))+mknode k t = (fromIntegral $ unKey k, TrieNode t)++example2 :: IntTrieBuilder+example2 = mktrie [ mknode (Key 1) t1 ]+  where+    t1   = mktrie [ mkleaf (Key 2) (Value 512), mkleaf (Key 3) (Value 2048), mknode (Key 4) t2 ]+    t2   = mktrie [ mkleaf (Key 5) (Value 4096) ]+++example2' :: IntTrieBuilder+example2' = mktrie [ mknode (Key 0) t1 ]+  where+    t1   = mktrie [ mknode (Key 3) t2 ]+    t2   = mktrie [ mknode (Key 1) t3, mknode (Key 2) t4 ]+    t3   = mktrie [ mkleaf (Key 4) (Value 10608) ]+    t4   = mktrie [ mkleaf (Key 4) (Value 10612) ]+{-+0: [1,N0,3]++  3: [1,N3,6]++   6: [2,N1,N2,11,12]++     11: [1,4,10608]+     14: [1,4,10612]+-}++example2'' :: IntTrieBuilder+example2'' = mktrie [ mknode (Key 1) t1, mknode (Key 2) t2 ]+  where+    t1   = mktrie [ mkleaf (Key 4) (Value 10608) ]+    t2   = mktrie [ mkleaf (Key 4) (Value 10612) ]++example2''' :: IntTrieBuilder+example2''' = mktrie [ mknode (Key 0) t3 ]+  where+    t3  = mktrie [ mknode (Key 4) t8, mknode (Key 6) t11 ]+    t8  = mktrie [ mknode (Key 1) t14 ]+    t11 = mktrie [ mkleaf (Key 5) (Value 10605) ]+    t14 = mktrie [ mknode (Key 2) t19, mknode (Key 3) t22 ]+    t19 = mktrie [ mkleaf (Key 7) (Value 10608) ]+    t22 = mktrie [ mkleaf (Key 7) (Value 10612) ]+{-+ 0: [1,N0,3]+ 3: [2,N4,N6,8,11]+ 8: [1,N1,11]+11: [1,5,10605]+14: [2,N2,N3,16,19]+19: [1,7,10608]+22: [1,7,10612]+-}++-- We convert from the 'Paths' to the 'IntTrieBuilder' using 'inserts':+--+test1 = example2 === inserts example1 empty++-- So the overall array form of the above trie is:+--+-- offset:   0   1    2    3   4  5  6    7    8     9     10  11  12+-- array:  [ 1 | N1 | 3 ][ 3 | 2, 3, N4 | 512, 2048, 10 ][ 1 | 5 | 4096 ]+--                     \__/                           \___/++example3 :: [Word32]+example3 =+ [1, tagNode 1,+     3,+  3, tagLeaf 2, tagLeaf 3, tagNode 4,+     512,       2048,      10,+  1, tagLeaf 5,+     4096+ ]++-- We get the array form by using flattenTrie:++test2 = example3 === flattenTrie example2++example4 :: IntTrie+example4 = IntTrie (mkArray example3)++mkArray :: [Word32] -> A.UArray Word32 Word32+mkArray xs = A.listArray (0, fromIntegral (length xs) - 1) xs++test3 = case lookup example4 [Key 1] of+          Just (Completions [(Key 2,_),(Key 3,_),(Key 4,_)]) -> True+          _                          -> False++test1 :: Property++prop_lookup :: [([Key], Value)] -> Property+prop_lookup paths =+  conjoin $ flip map paths $ \(key, value) ->+    counterexample (show (trie, key)) $+      lookup trie key === Just (Entry value)+  where+    trie = construct paths++prop_completions :: [([Key], Value)] -> Property+prop_completions paths =+    inserts paths empty+ === convertCompletions (completionsFrom (construct paths) 0)+  where+    convertCompletions :: Completions -> IntTrieBuilder+    convertCompletions kls =+      IntTrieBuilder $+        IntMap.fromList+          [ case l of+              Entry v          -> mkleaf k v+              Completions kls' -> mknode k (convertCompletions kls')+          | (k, l) <- sortBy (compare `on` fst) kls ]+++prop_lookup_mono :: ValidPaths -> Property+prop_lookup_mono (ValidPaths paths) = prop_lookup paths++prop_completions_mono :: ValidPaths -> Property+prop_completions_mono (ValidPaths paths) = prop_completions paths++prop_construct_toList :: ValidPaths -> Property+prop_construct_toList (ValidPaths paths) =+       sortBy (compare `on` fst) (toList (construct paths))+    === sortBy (compare `on` fst) paths++prop_finalise_unfinalise :: ValidPaths -> Property+prop_finalise_unfinalise (ValidPaths paths) =+    builder === unfinalise (finalise builder)+  where+    builder :: IntTrieBuilder+    builder = inserts paths empty++prop_serialise_deserialise :: ValidPaths -> Property+prop_serialise_deserialise (ValidPaths paths) =+    Just (trie, BS.empty) === (deserialise+                            . LBS.toStrict . BS.toLazyByteString+                            . serialise) trie+  where+    trie :: IntTrie+    trie = construct paths++prop_serialiseSize :: ValidPaths -> Property+prop_serialiseSize (ValidPaths paths) =+    (fromIntegral . LBS.length . BS.toLazyByteString . serialise) trie+ === serialiseSize trie+  where+    trie :: IntTrie+    trie = construct paths++newtype ValidPaths = ValidPaths [([Key], Value)] deriving Show++instance Arbitrary ValidPaths where+  arbitrary =+      ValidPaths . makeNoPrefix <$> listOf ((,)+        -- Key is actually Word31+        <$> listOf1 (fmap (Key . fromIntegral @Int32 . getNonNegative) arbitrary)+        <*> fmap Value arbitrary)+    where+      makeNoPrefix :: [([Key], Value)] -> [([Key], Value)]+      makeNoPrefix [] = []+      makeNoPrefix ((ks, v) : ksvs)+        | all (\(ks', _) -> not (isPrefixOfOther ks ks')) ksvs+                     = (ks, v) : makeNoPrefix ksvs+        | otherwise  =           makeNoPrefix ksvs++  shrink (ValidPaths kvs)+      = map ValidPaths . filter noPrefix . filter nonEmpty . map (map (\(ks, v) -> (map Key ks, Value v)))+      . shrink+      . map (\(ks, v) -> (map unKey ks, unValue v)) $ kvs+    where+      noPrefix :: [([Key], Value)] -> Bool+      noPrefix []           = True+      noPrefix ((k,_):kvs') = all (\(k', _) -> not (isPrefixOfOther k k')) kvs'+                           && noPrefix kvs'+      nonEmpty = all (not . null . fst)++isPrefixOfOther :: [Key] -> [Key] -> Bool+isPrefixOfOther a b = a `isPrefixOf` b || b `isPrefixOf` a

@@ -0,0 +1,84 @@+{-# LANGUAGE CPP #-}++module Codec.Archive.Tar.Index.StringTable.Tests (+    prop_valid,+    prop_sorted,+    prop_finalise_unfinalise,+    prop_serialise_deserialise,+    prop_serialiseSize,+ ) where++import Prelude hiding (lookup)+import Codec.Archive.Tar.Index.StringTable+import Test.Tasty.QuickCheck++import Data.List hiding (lookup, insert)+import qualified Data.Array.Unboxed as A+import qualified Data.ByteString        as BS+import qualified Data.ByteString.Lazy   as LBS+#if MIN_VERSION_bytestring(0,10,2) || defined(MIN_VERSION_bytestring_builder)+import Data.ByteString.Builder          as BS+import Data.ByteString.Builder.Extra    as BS (byteStringCopy)+#else+import Data.ByteString.Lazy.Builder     as BS+import Data.ByteString.Lazy.Builder.Extras as BS (byteStringCopy)+#endif++prop_valid :: [BS.ByteString] -> Property+prop_valid strs =+       conjoin (map lookupIndex (enumStrings tbl))+  .&&. conjoin (map indexLookup (enumIds tbl))++  where+    tbl :: StringTable Int+    tbl = construct strs++    lookupIndex :: BS.ByteString -> Property+    lookupIndex str = index tbl ident === str+      where Just ident = lookup tbl str++    indexLookup :: Int -> Property+    indexLookup ident = lookup tbl str === Just ident+      where str       = index tbl ident++-- this is important so we can use Map.fromAscList+prop_sorted :: [BS.ByteString] -> Property+prop_sorted strings = property $+    isSorted [ index' strs offsets ix+             | ix <- A.range (A.bounds ids) ]+  where+    _tbl :: StringTable Int+    _tbl@(StringTable strs offsets ids _ixs) = construct strings+    isSorted xs = and (zipWith (<) xs (tail xs))++prop_finalise_unfinalise :: [BS.ByteString] -> Property+prop_finalise_unfinalise strs =+    builder === unfinalise (finalise builder)+  where+    builder :: StringTableBuilder Int+    builder = foldl' (\tbl s -> fst (insert s tbl)) empty strs++prop_serialise_deserialise :: [BS.ByteString] -> Property+prop_serialise_deserialise strs =+    Just (strtable, BS.empty) === (deserialiseV2+                                . LBS.toStrict . BS.toLazyByteString+                                . serialise) strtable+  where+    strtable :: StringTable Int+    strtable = construct strs++prop_serialiseSize :: [BS.ByteString] -> Property+prop_serialiseSize strs =+    (fromIntegral . LBS.length . BS.toLazyByteString . serialise) strtable+ === serialiseSize strtable+  where+    strtable :: StringTable Int+    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++enumIds :: Enum id => StringTable id -> [id]+enumIds (StringTable _ offsets _ _) = [toEnum 0 .. toEnum (fromIntegral (h-1))]+  where (0,h) = A.bounds offsets

@@ -0,0 +1,273 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Codec.Archive.Tar.Index.Tests+-- Copyright   :  (c) 2010-2015 Duncan Coutts+-- License     :  BSD3+--+-- Maintainer  :  duncan@community.haskell.org+-- Portability :  portable+--+-----------------------------------------------------------------------------+module Codec.Archive.Tar.Index.Tests (+    prop_lookup,+    prop_toList,+    prop_valid,+    prop_serialise_deserialise,+    prop_serialiseSize,+#ifdef MIN_VERSION_bytestring_handle+    prop_index_matches_tar,+#endif+    prop_finalise_unfinalise,+  ) where++import Codec.Archive.Tar (GenEntries(..), Entries, GenEntry, Entry, GenEntryContent(..))+import Codec.Archive.Tar.Index.Internal (TarIndexEntry(..), TarIndex(..), IndexBuilder, TarEntryOffset(..))+import qualified Codec.Archive.Tar.Index.Internal as Tar+import qualified Codec.Archive.Tar.Index.IntTrie as IntTrie+import qualified Codec.Archive.Tar.Index.IntTrie.Tests as IntTrie+import qualified Codec.Archive.Tar.Index.StringTable as StringTable+import qualified Codec.Archive.Tar.Index.StringTable.Tests as StringTable+import qualified Codec.Archive.Tar.Types as Tar+import qualified Codec.Archive.Tar.Write as Tar++import qualified Data.ByteString        as BS+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++import Prelude hiding (lookup)+import qualified Prelude+import Test.QuickCheck+import Test.QuickCheck.Property (ioProperty)+import Control.Applicative ((<$>), (<*>))+import Control.Monad (unless)+import Data.List (nub, sort, sortBy, stripPrefix, isPrefixOf)+import Data.Maybe+import Data.Function (on)+import Control.Exception (SomeException, try, throwIO)++#ifdef MIN_VERSION_bytestring_handle+import qualified Data.ByteString.Handle as HBS+#endif++-- Not quite the properties of a finite mapping because we also have lookups+-- that result in completions.++prop_lookup :: ValidPaths -> NonEmptyFilePath -> Property+prop_lookup (ValidPaths paths) (NonEmptyFilePath p) =+  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)+    _                                              -> property False+  where+    index       = construct paths+    completions = [ head (FilePath.splitDirectories completion)+                  | (path,_) <- paths+                  , completion <- maybeToList $ stripPrefix (p ++ "/") path ]++prop_toList :: ValidPaths -> Property+prop_toList (ValidPaths paths) =+    sort (Tar.toList index)+ === sort [ (path, off) | (path, (_sz, off)) <- paths ]+  where+    index = construct paths++prop_valid :: ValidPaths -> Property+prop_valid (ValidPaths paths) =+  StringTable.prop_valid   pathbits .&&.+  IntTrie.prop_lookup      intpaths .&&.+  IntTrie.prop_completions intpaths .&&.+  prop'++  where+    index@(TarIndex pathTable _ _) = construct paths++    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 ]+    prop' = conjoin $ flip map paths $ \(file, (_size, offset)) ->+      case Tar.lookup index file of+        Just (TarFileEntry offset') -> offset' === offset+        _                           -> property False++prop_serialise_deserialise :: ValidPaths -> Property+prop_serialise_deserialise (ValidPaths paths) =+    Just (index, BS.empty) === (Tar.deserialise . Tar.serialise) index+  where+    index = construct paths++prop_serialiseSize :: ValidPaths -> Property+prop_serialiseSize (ValidPaths paths) =+    case (LBS.toChunks . Tar.serialiseLBS) index of+      [c1] -> BS.length c1 === Tar.serialiseSize index+      _    -> property False+  where+    index = construct paths++newtype NonEmptyFilePath = NonEmptyFilePath FilePath deriving Show++instance Arbitrary NonEmptyFilePath where+  arbitrary = NonEmptyFilePath . FilePath.joinPath+                <$> listOf1 (elements ["a", "b", "c", "d"])++newtype ValidPaths = ValidPaths [(FilePath, (Int64, TarEntryOffset))] deriving Show++instance Arbitrary ValidPaths where+  arbitrary = do+      paths <- makeNoPrefix <$> listOf arbitraryPath+      sizes <- vectorOf (length paths) (getNonNegative <$> arbitrary)+      let offsets = scanl (\o sz -> o + 1 + blocks sz) 0 sizes+      return (ValidPaths (zip paths (zip sizes offsets)))+    where+      arbitraryPath   = FilePath.joinPath+                         <$> listOf1 (elements ["a", "b", "c", "d"])+      makeNoPrefix [] = []+      makeNoPrefix (k:ks)+        | all (not . isPrefixOfOther k) ks+                     = k : makeNoPrefix ks+        | otherwise  =     makeNoPrefix ks++      isPrefixOfOther a b = a `isPrefixOf` b || b `isPrefixOf` a++      blocks :: Int64 -> TarEntryOffset+      blocks size = fromIntegral (1 + ((size - 1) `div` 512))++-- Helper for bulk construction.+construct :: [(FilePath, (Int64, TarEntryOffset))] -> TarIndex+construct =+    either (const undefined) id+  . Tar.build+  . foldr (\(path, (size, _off)) es -> Next (testEntry path size) es) Done++example0 :: Entries ()+example0 =+         testEntry "foo-1.0/foo-1.0.cabal" 1500 -- at block 0+  `Next` testEntry "foo-1.0/LICENSE"       2000 -- at block 4+  `Next` testEntry "foo-1.0/Data/Foo.hs"   1000 -- at block 9+  `Next` Done++example1 :: Entries ()+example1 =+  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++-- | Simple tar archive containing regular files only+data SimpleTarArchive = SimpleTarArchive {+    simpleTarEntries :: Tar.Entries ()+  , simpleTarRaw     :: [(FilePath, LBS.ByteString)]+  , simpleTarBS      :: LBS.ByteString+  }++instance Show SimpleTarArchive where+  show = show . simpleTarRaw++#ifdef MIN_VERSION_bytestring_handle+prop_index_matches_tar :: SimpleTarArchive -> Property+prop_index_matches_tar sta =+    ioProperty (try go >>= either (\e -> throwIO (e :: SomeException))+                                  (\_ -> return True))+  where+    go :: IO ()+    go = do+      h <- HBS.readHandle True (simpleTarBS sta)+      goEntries h 0 (simpleTarEntries sta)++    goEntries :: Handle -> TarEntryOffset -> Entries () -> IO ()+    goEntries _ _ Done =+      return ()+    goEntries _ _ (Fail _) =+      throwIO (userError "Fail entry in SimpleTarArchive")+    goEntries h offset (Tar.Next e es) = do+      goEntry h offset e+      goEntries h (Tar.nextEntryOffset e offset) es++    goEntry :: Handle -> TarEntryOffset -> Tar.Entry -> IO ()+    goEntry h offset e = do+      e' <- Tar.hReadEntry h offset+      case (Tar.entryContent e, Tar.entryContent e') of+        (Tar.NormalFile bs sz, Tar.NormalFile bs' sz') ->+          unless (sz == sz' && bs == bs') $+            throwIO $ userError "Entry mismatch"+        _otherwise ->+          throwIO $ userError "unexpected entry types"+#endif++instance Arbitrary SimpleTarArchive where+  arbitrary = do+      numEntries <- sized $ \n -> choose (0, n)+      rawEntries <- mkRaw numEntries+      let entries = mkList rawEntries+      return SimpleTarArchive {+          simpleTarEntries = mkEntries entries+        , simpleTarRaw     = rawEntries+        , simpleTarBS      = Tar.write entries+        }+    where+      mkRaw :: Int -> Gen [(FilePath, LBS.ByteString)]+      mkRaw 0 = return []+      mkRaw n = do+         -- Pick a size around 0, 1, or 2 block boundaries+         sz <- sized $ \n -> elements (take n fileSizes)+         bs <- LBS.pack `fmap` vectorOf sz arbitrary+         es <- mkRaw (n - 1)+         return $ ("file" ++ show n, bs) : es++      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)++      mkEntries :: [Tar.Entry] -> Tar.Entries ()+      mkEntries []     = Tar.Done+      mkEntries (e:es) = Tar.Next e (mkEntries es)++      -- Sizes around 0, 1, and 2 block boundaries+      fileSizes :: [Int]+      fileSizes = [+                           0 ,    1 ,    2+        ,  510 ,  511 ,  512 ,  513 ,  514+        , 1022 , 1023 , 1024 , 1025 , 1026+        ]++-- | 'IndexBuilder' constructed from a 'SimpleIndex'+newtype SimpleIndexBuilder = SimpleIndexBuilder IndexBuilder+  deriving Show++instance Arbitrary SimpleIndexBuilder where+  arbitrary = SimpleIndexBuilder . build' . simpleTarEntries <$> arbitrary+    where+      -- like 'build', but don't finalize+      build' :: Show e => Entries e -> IndexBuilder+      build' = go Tar.empty+        where+          go !builder (Next e es) = go (Tar.addNextEntry e builder) es+          go !builder  Done       = builder+          go !_       (Fail err)  = error (show err)++prop_finalise_unfinalise :: SimpleIndexBuilder -> Property+prop_finalise_unfinalise (SimpleIndexBuilder index) =+    Tar.unfinalise (Tar.finalise index) === index++#if !(MIN_VERSION_base(4,5,0))+(<>) :: Monoid m => m -> m -> m+(<>) = mappend+#endif

@@ -0,0 +1,96 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Codec.Archive.Tar.Pack.Tests+  ( prop_roundtrip+  , unit_roundtrip_symlink+  , unit_roundtrip_long_symlink+  , unit_roundtrip_long_filepath+  ) where++import Control.DeepSeq+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.FileEmbed+import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Pack as Pack+import Codec.Archive.Tar.Types (GenEntries(..), Entries, simpleEntry, toTarPath)+import qualified Codec.Archive.Tar.Unpack as Unpack+import qualified Codec.Archive.Tar.Write as Write+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)+  | 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] >>= evaluate . force++    -- 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 `elem` [' ', '.', ':']) 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_symlink :: Property+unit_roundtrip_symlink =+  let tar :: BL.ByteString = BL.fromStrict $(embedFile "test/data/symlink.tar")+      entries = Tar.foldEntries (:) [] (const []) (Tar.read tar)+  in Tar.write entries === tar++unit_roundtrip_long_filepath :: Property+unit_roundtrip_long_filepath =+  let tar :: BL.ByteString = BL.fromStrict $(embedFile "test/data/long-filepath.tar")+      entries = Tar.foldEntries (:) [] (const []) (Tar.read tar)+  in Tar.write entries === tar++unit_roundtrip_long_symlink :: Property+unit_roundtrip_long_symlink =+  let tar :: BL.ByteString = BL.fromStrict $(embedFile "test/data/long-symlink.tar")+      entries = Tar.foldEntries (:) [] (const []) (Tar.read tar)+  in Tar.write entries === tar

@@ -0,0 +1,55 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Codec.Archive.Tar.Tests+-- Copyright   :  (c) 2007 Bjorn Bringert,+--                    2008 Andrea Vezzosi,+--                    2008-2012 Duncan Coutts+-- License     :  BSD3+--+-- Maintainer  :  duncan@community.haskell.org+-- Portability :  portable+--+-----------------------------------------------------------------------------+module Codec.Archive.Tar.Tests (+  prop_write_read_ustar,+  prop_write_read_gnu,+  prop_write_read_v7,+  prop_large_filesize,+  ) where++import Codec.Archive.Tar+import Codec.Archive.Tar.Types+import Codec.Archive.Tar.Types.Tests+import qualified Data.ByteString.Lazy as BL+import Prelude hiding (read)+import Test.Tasty.QuickCheck++prop_write_read_ustar :: [Entry] -> Property+prop_write_read_ustar entries =+    foldr Next Done entries' === read (write entries')+  where+    entries' = filter ((== UstarFormat) . entryFormat) entries++prop_write_read_gnu :: [Entry] -> Property+prop_write_read_gnu entries =+    foldr Next Done entries' === read (write entries')+  where+    entries' = filter ((== GnuFormat) . entryFormat) entries++prop_write_read_v7 :: [Entry] -> Property+prop_write_read_v7 entries =+    foldr Next Done entries' === read (write entries')+  where+    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'

@@ -0,0 +1,225 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Codec.Archive.Tar.Types.Tests+-- Copyright   :  (c) 2007 Bjorn Bringert,+--                    2008 Andrea Vezzosi,+--                    2008-2009 Duncan Coutts+--                    2011 Max Bolingbroke+-- License     :  BSD3+--+-----------------------------------------------------------------------------+{-# LANGUAGE RecordWildCards #-}++module Codec.Archive.Tar.Types.Tests+  ( limitToV7FormatCompat+  , prop_fromTarPath+  , prop_fromTarPathToPosixPath+  , prop_fromTarPathToWindowsPath+  ) where++import Codec.Archive.Tar.Types++import qualified Data.ByteString       as BS+import qualified Data.ByteString.Char8 as BS.Char8+import qualified Data.ByteString.Lazy  as LBS++import qualified System.FilePath as FilePath.Native+         ( joinPath, splitDirectories, addTrailingPathSeparator )+import qualified System.FilePath.Posix as FilePath.Posix+         ( joinPath, splitPath, splitDirectories, hasTrailingPathSeparator+         , addTrailingPathSeparator )+import qualified System.FilePath.Windows as FilePath.Windows+         ( joinPath, splitDirectories, addTrailingPathSeparator )++import Test.QuickCheck+import Control.Applicative ((<$>), (<*>), pure)+import Data.Word (Word16)++prop_fromTarPath :: TarPath -> Property+prop_fromTarPath tp = fromTarPath tp === fromTarPathRef tp++prop_fromTarPathToPosixPath :: TarPath -> Property+prop_fromTarPathToPosixPath tp = fromTarPathToPosixPath tp === fromTarPathToPosixPathRef tp++prop_fromTarPathToWindowsPath :: TarPath -> Property+prop_fromTarPathToWindowsPath tp = fromTarPathToWindowsPath tp === fromTarPathToWindowsPathRef tp++fromTarPathRef :: TarPath -> FilePath+fromTarPathRef (TarPath namebs prefixbs) = adjustDirectory $+  FilePath.Native.joinPath $ FilePath.Posix.splitDirectories prefix+                          ++ FilePath.Posix.splitDirectories name+  where+    name   = BS.Char8.unpack namebs+    prefix = BS.Char8.unpack prefixbs+    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name+                    = FilePath.Native.addTrailingPathSeparator+                    | otherwise = id++fromTarPathToPosixPathRef :: TarPath -> FilePath+fromTarPathToPosixPathRef (TarPath namebs prefixbs) = adjustDirectory $+  FilePath.Posix.joinPath $ FilePath.Posix.splitDirectories prefix+                         ++ FilePath.Posix.splitDirectories name+  where+    name   = BS.Char8.unpack namebs+    prefix = BS.Char8.unpack prefixbs+    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name+                    = FilePath.Posix.addTrailingPathSeparator+                    | otherwise = id++fromTarPathToWindowsPathRef :: TarPath -> FilePath+fromTarPathToWindowsPathRef (TarPath namebs prefixbs) = adjustDirectory $+  FilePath.Windows.joinPath $ FilePath.Posix.splitDirectories prefix+                           ++ FilePath.Posix.splitDirectories name+  where+    name   = BS.Char8.unpack namebs+    prefix = BS.Char8.unpack prefixbs+    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name+                    = FilePath.Windows.addTrailingPathSeparator+                    | otherwise = id++instance (Arbitrary tarPath, Arbitrary linkTarget) => Arbitrary (GenEntry tarPath linkTarget) where+  arbitrary = do+    entryTarPath <- arbitrary+    entryContent <- arbitrary+    entryPermissions <- fromIntegral <$> (arbitrary :: Gen Word16)+    entryOwnership <- arbitrary+    entryTime <- arbitraryOctal 11+    entryFormat <- case entryContent of+      OtherEntryType 'K' _ _ -> pure GnuFormat+      OtherEntryType 'L' _ _ -> pure GnuFormat+      _ -> arbitrary+    pure Entry{..}++  shrink (Entry path content perms author time format) =+      [ Entry path' content' perms author' time' format+      | (path', content', author', time') <-+         shrink (path, content, author, time) ]+   ++ [ Entry path content perms' author time format+      | perms' <- shrinkIntegral perms ]++instance Arbitrary TarPath where+  arbitrary = either error id+            . toTarPath False+            . FilePath.Posix.joinPath+          <$> listOf1ToN (255 `div` 5)+                         (elements (map (replicate 4) "abcd"))++  shrink = map (either error id . toTarPath False)+         . map FilePath.Posix.joinPath+         . filter (not . null)+         . shrinkList shrinkNothing+         . FilePath.Posix.splitPath+         . fromTarPathToPosixPath++instance Arbitrary LinkTarget where+  arbitrary = maybe (error "link target too large") id+            . toLinkTarget+            . FilePath.Native.joinPath+          <$> listOf1ToN (100 `div` 5)+                         (elements (map (replicate 4) "abcd"))++  shrink = map (maybe (error "link target too large") id . toLinkTarget)+         . map FilePath.Posix.joinPath+         . filter (not . null)+         . shrinkList shrinkNothing+         . FilePath.Posix.splitPath+         . fromLinkTargetToPosixPath+++listOf1ToN :: Int -> Gen a -> Gen [a]+listOf1ToN n g = sized $ \sz -> do+    n <- choose (1, min n (max 1 sz))+    vectorOf n g++listOf0ToN :: Int -> Gen a -> Gen [a]+listOf0ToN n g = sized $ \sz -> do+    n <- choose (0, min n sz)+    vectorOf n g++instance Arbitrary linkTarget => Arbitrary (GenEntryContent linkTarget) where+  arbitrary =+    frequency+      [ (16, do bs <- arbitrary;+                return (NormalFile bs (LBS.length bs)))+      , (2, pure Directory)+      , (1, SymbolicLink    <$> arbitrary)+      , (1, HardLink        <$> arbitrary)+      , (1, CharacterDevice <$> arbitraryOctal 7 <*> arbitraryOctal 7)+      , (1, BlockDevice     <$> arbitraryOctal 7 <*> arbitraryOctal 7)+      , (1, pure NamedPipe)+      , (1, do c  <- elements (['A'..'Z']++['a'..'z'])+               bs <- arbitrary;+               return (OtherEntryType c bs (LBS.length bs)))+      ]++  shrink (NormalFile bs _)   = [ NormalFile bs' (LBS.length bs')+                               | bs' <- shrink bs ]+  shrink  Directory          = []+  shrink (SymbolicLink link) = [ SymbolicLink link' | link' <- shrink link ]+  shrink (HardLink     link) = [ HardLink     link' | link' <- shrink link ]+  shrink (CharacterDevice ma mi) = [ CharacterDevice ma' mi'+                                   | (ma', mi') <- shrink (ma, mi) ]+  shrink (BlockDevice     ma mi) = [ BlockDevice ma' mi'+                                   | (ma', mi') <- shrink (ma, mi) ]+  shrink  NamedPipe              = []+  shrink (OtherEntryType c bs _) = [ OtherEntryType c bs' (LBS.length bs')+                                   | bs' <- shrink bs ]++instance Arbitrary LBS.ByteString where+  arbitrary = fmap LBS.pack arbitrary+  shrink    = map LBS.pack . shrink . LBS.unpack++instance Arbitrary BS.ByteString where+  arbitrary = fmap BS.pack arbitrary+  shrink    = map BS.pack . shrink . BS.unpack++instance Arbitrary Ownership where+  arbitrary = Ownership <$> name <*> name+                        <*> idno <*> idno+    where+      -- restrict user/group to posix ^[a-z][-a-z0-9]{0,30}$+      name = do+        first <- choose ('a', 'z')+        rest <- listOf0ToN 30 (oneof [choose ('a', 'z'), choose ('0', '9'), pure '-'])+        return $ first : rest+      idno = arbitraryOctal 7++  shrink (Ownership oname gname oid gid) =+    [ Ownership oname' gname' oid' gid'+    | (oname', gname', oid', gid') <- shrink (oname, gname, oid, gid) ]++instance Arbitrary Format where+  arbitrary = elements [V7Format, UstarFormat, GnuFormat]+  shrink GnuFormat = []+  shrink _ = [GnuFormat]++--arbitraryOctal :: (Integral n, Random n) => Int -> Gen n+arbitraryOctal n =+    oneof [ pure 0+          , choose (0, upperBound)+          , pure upperBound+          ]+  where+    upperBound = 8^n-1++-- For QC tests it's useful to have a way to limit the info to that which can+-- be expressed in the old V7 format+limitToV7FormatCompat :: Entry -> Entry+limitToV7FormatCompat entry@Entry { entryFormat = V7Format } =+    entry {+      entryContent = case entryContent entry of+        CharacterDevice _ _ -> OtherEntryType  '3' LBS.empty 0+        BlockDevice     _ _ -> OtherEntryType  '4' LBS.empty 0+        Directory           -> OtherEntryType  '5' LBS.empty 0+        NamedPipe           -> OtherEntryType  '6' LBS.empty 0+        other               -> other,++      entryOwnership = (entryOwnership entry) {+        groupName = "",+        ownerName = ""+      },++      entryTarPath = let TarPath name _prefix = entryTarPath entry+                      in TarPath name BS.empty+    }+limitToV7FormatCompat entry = entry

@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}++module Codec.Archive.Tar.Unpack.Tests+  ( case_modtime_1970+  ) where++import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Types as Tar+import Codec.Archive.Tar.Types (GenEntries(..), Entries, GenEntry(..))+import qualified Codec.Archive.Tar.Unpack as Unpack+import Control.Exception+import Data.Time.Clock+import Data.Time.Clock.System+import System.Directory+import System.FilePath+import System.IO.Temp+import Test.Tasty.QuickCheck++case_modtime_1970 :: Property+case_modtime_1970 = ioProperty $ withSystemTempDirectory "tar-test" $ \baseDir -> do+  let filename = "foo"+  Right tarPath <- pure $ Tar.toTarPath False filename+  let entry = (Tar.fileEntry tarPath "bar") { entryTime = 0 }+      entries = Next entry Done :: Entries IOException+  Tar.unpack baseDir entries+  modTime <- getModificationTime (baseDir </> filename)+  pure $ modTime === UTCTime systemEpochDay 0

@@ -1,11 +1,14 @@-module Main where+{-# LANGUAGE CPP #-} -import qualified Codec.Archive.Tar.Index as Index-import qualified Codec.Archive.Tar.Index.IntTrie as IntTrie-import qualified Codec.Archive.Tar.Index.StringTable as StringTable-import qualified Codec.Archive.Tar       as Tar+module Main where -import qualified Data.ByteString as BS+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 qualified Codec.Archive.Tar.Types.Tests as Types+import qualified Codec.Archive.Tar.Unpack.Tests as Unpack  import Test.Tasty import Test.Tasty.QuickCheck@@ -15,10 +18,17 @@   defaultMain $     testGroup "tar tests" [ -      testGroup "write/read" [+      testGroup "fromTarPath" [+        testProperty "fromTarPath" Types.prop_fromTarPath,+        testProperty "fromTarPathToPosixPath" Types.prop_fromTarPathToPosixPath,+        testProperty "fromTarPathToWindowsPath" Types.prop_fromTarPathToWindowsPath+      ]++    , testGroup "write/read" [         testProperty "ustar format" Tar.prop_write_read_ustar,         testProperty "gnu format"   Tar.prop_write_read_gnu,-        testProperty "v7 format"    Tar.prop_write_read_v7+        testProperty "v7 format"    Tar.prop_write_read_v7,+        testProperty "large filesize" Tar.prop_large_filesize       ]      , testGroup "string table" [@@ -47,8 +57,20 @@         testProperty "toList"      Index.prop_toList,         testProperty "serialise"   Index.prop_serialise_deserialise,         testProperty "size"        Index.prop_serialiseSize,+#ifdef MIN_VERSION_bytestring_handle         testProperty "matches tar" Index.prop_index_matches_tar,+#endif         testProperty "unfinalise"  Index.prop_finalise_unfinalise       ]-    ] +    , testGroup "pack" [+      testProperty "roundtrip" Pack.prop_roundtrip,+      testProperty "symlink" Pack.unit_roundtrip_symlink,+      testProperty "long filepath" Pack.unit_roundtrip_long_filepath,+      testProperty "long symlink" Pack.unit_roundtrip_long_symlink+      ]++    , testGroup "unpack" [+      testProperty "modtime 1970-01-01" Unpack.case_modtime_1970+      ]+    ]

binary file changed (absent → 20480 bytes)

binary file changed (absent → 5632 bytes)

binary file changed (absent → 3072 bytes)