packages feed

tar 0.4.5.0 → 0.7.2.0

raw patch · 31 files changed

Files

Codec/Archive/Tar.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Codec.Archive.Tar@@ -52,34 +51,42 @@    -- * Notes   -- ** Compressed tar archives-  -- | Tar files are commonly used in conjunction with gzip compression, as in-  -- \"@.tar.gz@\" or \"@.tar.bz2@\" files. This module does not directly+  -- | Tar files are commonly used in conjunction with compression, as in+  -- @.tar.gz@ or @.tar.bz2@ files. This module does not directly   -- handle compressed tar files however they can be handled easily by   -- composing functions from this module and the modules-  -- @Codec.Compression.GZip@ or @Codec.Compression.BZip@-  -- (see @zlib@ or @bzlib@ packages).+  -- [@Codec.Compression.GZip@](https://hackage.haskell.org/package/zlib/docs/Codec-Compression-Zlib.html)+  -- or+  -- [@Codec.Compression.BZip@](https://hackage.haskell.org/package/bzlib-0.5.0.5/docs/Codec-Compression-BZip.html).   ---  -- Creating a compressed \"@.tar.gz@\" file is just a minor variation on the+  -- Creating a compressed @.tar.gz@ file is just a minor variation on the   -- 'create' function, but where throw compression into the pipeline:   ---  -- > BS.writeFile tar . GZip.compress . Tar.write =<< Tar.pack base dir+  -- > import qualified Data.ByteString.Lazy as BL+  -- > import qualified Codec.Compression.GZip as GZip+  -- >+  -- > BL.writeFile tar . GZip.compress =<< Tar.write' =<< Tar.pack' base dir   ---  -- Similarly, extracting a compressed \"@.tar.gz@\" is just a minor variation+  -- Similarly, extracting a compressed @.tar.gz@ is just a minor variation   -- on the 'extract' function where we use decompression in the pipeline:   ---  -- > Tar.unpack dir . Tar.read . GZip.decompress =<< BS.readFile tar+  -- > import qualified Data.ByteString.Lazy as BL+  -- > import qualified Codec.Compression.GZip as GZip+  -- >+  -- > Tar.unpack dir . Tar.read . GZip.decompress =<< BL.readFile tar   --    -- ** Security   -- | This is pretty important. A maliciously constructed tar archives could   -- contain entries that specify bad file names. It could specify absolute-  -- file names like \"@\/etc\/passwd@\" or relative files outside of the-  -- archive like \"..\/..\/..\/something\". This security problem is commonly+  -- file names like @\/etc\/passwd@ or relative files outside of the+  -- archive like @..\/..\/..\/something@. This security problem is commonly   -- called a \"directory traversal vulnerability\". Historically, such   -- vulnerabilities have been common in packages handling tar archives.   ---  -- The 'extract' and 'unpack' functions check for bad file names. See the-  -- 'checkSecurity' function for more details. If you need to do any custom+  -- The 'extract' and 'Codec.Archive.Tar.unpack' functions check for bad file names. See the+  -- 'Codec.Archive.Tar.Check.checkSecurity' function for more details.+  -- If you need to do any custom   -- unpacking then you should use this.    -- ** Tarbombs@@ -88,8 +95,13 @@   -- 'extract' function does not check for these however if you want to do   -- that you can use the 'checkTarbomb' function like so:   ---  -- > Tar.unpack dir . Tar.checkTarbomb expectedDir-  -- >                . Tar.read =<< BS.readFile tar+  -- > import Control.Exception (SomeException(..))+  -- > import Control.Applicative ((<|>))+  -- > import qualified Data.ByteString.Lazy as BL+  -- >+  -- > Tar.unpackAndCheck (\x -> SomeException <$> checkEntryTarbomb expectedDir x+  -- >                       <|> SomeException <$> checkEntrySecurity x) dir .+  -- > Tar.read =<< BL.readFile tar   --   -- In this case extraction will fail if any file is outside of @expectedDir@. @@ -100,6 +112,10 @@   -- produces the standard format.   read,   write,+  writeEntry,+  write',+  writeEntry',+  writeTrailer,    -- * Packing and unpacking files to\/from internal representation   -- | These functions are for packing and unpacking portable archives. They@@ -107,25 +123,37 @@   -- and permissions or to archive special files like named pipes and Unix   -- device files.   pack,+  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+  -- the 'GenEntry' 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.@@ -133,34 +161,27 @@   -- The style of error handling by returning structured errors. The pure   -- functions in the library do not throw exceptions, they return the errors   -- as data. The IO actions in the library can throw exceptions, in particular-  -- the 'unpack' action does this. All the error types used are an instance of+  -- the 'Codec.Archive.Tar.unpack' action does this. All the error types used are an instance of   -- the standard 'Exception' class so it is possible to 'throw' and 'catch'   -- them.    -- ** 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.Types--import Codec.Archive.Tar.Read-import Codec.Archive.Tar.Write--import Codec.Archive.Tar.Pack-import Codec.Archive.Tar.Unpack-import Codec.Archive.Tar.Index (hSeekEndEntryOffset)- import Codec.Archive.Tar.Check+import Codec.Archive.Tar.Entry+import Codec.Archive.Tar.Index (hSeekEndEntryOffset)+import Codec.Archive.Tar.LongNames (decodeLongNames, encodeLongNames, DecodeLongNamesError(..))+import Codec.Archive.Tar.Pack (pack, pack', packAndCheck)+import Codec.Archive.Tar.Read (read, FormatError(..))+import Codec.Archive.Tar.Types (unfoldEntries, foldlEntries, foldEntries, mapEntriesNoFail, mapEntries, Entries, GenEntries(..))+import Codec.Archive.Tar.Unpack (unpack, unpackAndCheck)+import Codec.Archive.Tar.Write (write, writeEntry, write', writeEntry', writeTrailer) -import Control.Exception (Exception, throw, catch)-import qualified Data.ByteString.Lazy as BS+import Control.Applicative ((<|>))+import Control.Exception (Exception, throw, catch, SomeException(..))+import qualified Data.ByteString.Lazy as BL import System.IO (withFile, IOMode(..)) import Prelude hiding (read) @@ -174,10 +195,7 @@ -- @.\/base\/dir\/foo.txt@. The file names inside the resulting tar file will be -- relative to @dir@, eg @dir\/foo.txt@. ----- This is a high level \"all in one\" operation. Since you may need variations--- on this function it is instructive to see how it is written. It is just:------ > BS.writeFile tar . Tar.write =<< Tar.pack base paths+-- This is a high level \"all in one\" operation, combining 'pack'' and 'write''. -- -- Notes: --@@ -199,7 +217,7 @@        -> FilePath   -- ^ Base directory        -> [FilePath] -- ^ Files and directories to archive, relative to base dir        -> IO ()-create tar base paths = BS.writeFile tar . write =<< pack base paths+create tar base paths = BL.writeFile tar =<< write' =<< pack' base paths  -- | Extract all the files contained in a @\".tar\"@ file. --@@ -210,10 +228,7 @@ -- So for example if the @tarball.tar@ file contains @foo\/bar.txt@ then this -- will extract it to @dir\/foo\/bar.txt@. ----- This is a high level \"all in one\" operation. Since you may need variations--- on this function it is instructive to see how it is written. It is just:------ > Tar.unpack dir . Tar.read =<< BS.readFile tar+-- This is a high level \"all in one\" operation, combining 'unpack' and 'read'. -- -- Notes: --@@ -232,7 +247,7 @@ extract :: FilePath -- ^ Destination directory         -> FilePath -- ^ Tarball         -> IO ()-extract dir tar = unpack dir . read =<< BS.readFile tar+extract dir tar = unpack dir . read =<< BL.readFile tar  -- | Append new entries to a @\".tar\"@ file from a directory of files. --@@ -247,31 +262,4 @@ append tar base paths =     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+      BL.hPut hnd =<< write' =<< pack' base paths
Codec/Archive/Tar/Check.hs view
@@ -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,223 +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 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
+ Codec/Archive/Tar/Check/Internal.hs view
@@ -0,0 +1,313 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- 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 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.+--+-- Whenever possible, consider fusing 'Codec.Archive.Tar.Check.checkSecurity'+-- with packing / unpacking by using+-- 'Codec.Archive.Tar.packAndCheck' / 'Codec.Archive.Tar.unpackAndCheck'+-- with 'Codec.Archive.Tar.Check.checkEntrySecurity'.+-- Not only it is faster, but also alleviates issues with lazy I/O+-- such as exhaustion of file handlers.+checkSecurity+  :: Entries e+  -> GenEntries Char8.ByteString FilePath FilePath (Either (Either e DecodeLongNamesError) FileNameError)+checkSecurity = checkEntries checkEntrySecurity . decodeLongNames++-- | Worker of 'Codec.Archive.Tar.Check.checkSecurity'.+--+-- @since 0.6.0.0+checkEntrySecurity :: GenEntry Char8.ByteString 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++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 'Codec.Archive.Tar.Check.checkSecurity'+-- (or 'Codec.Archive.Tar.Check.checkPortability').+--+-- Whenever possible, consider fusing 'Codec.Archive.Tar.Check.checkTarbomb'+-- with packing / unpacking by using+-- 'Codec.Archive.Tar.packAndCheck' / 'Codec.Archive.Tar.unpackAndCheck'+-- with 'Codec.Archive.Tar.Check.checkEntryTarbomb'.+-- Not only it is faster, but also alleviates issues with lazy I/O+-- such as exhaustion of file handlers.+checkTarbomb+  :: FilePath+  -> Entries e+  -> GenEntries Char8.ByteString FilePath FilePath (Either (Either e DecodeLongNamesError) TarBombError)+checkTarbomb expectedTopDir+  = checkEntries (checkEntryTarbomb expectedTopDir)+  . decodeLongNames++-- | Worker of 'checkTarbomb'.+--+-- @since 0.6.0.0+checkEntryTarbomb :: FilePath -> GenEntry Char8.ByteString FilePath linkTarget -> Maybe TarBombError+checkEntryTarbomb expectedTopDir entry = do+  case entryContent entry of+    -- Global extended header aka XGLTYPE aka pax_global_header+    -- 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.++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.+--+-- Whenever possible, consider fusing 'checkPortability' with packing / unpacking by using+-- 'Codec.Archive.Tar.packAndCheck' / 'Codec.Archive.Tar.unpackAndCheck'+-- with 'checkEntryPortability'.+-- Not only it is faster, but also alleviates issues with lazy I/O+-- such as exhaustion of file handlers.+checkPortability+  :: Entries e+  -> GenEntries Char8.ByteString FilePath FilePath (Either (Either e DecodeLongNamesError) PortabilityError)+checkPortability = checkEntries checkEntryPortability . decodeLongNames++-- | Worker of 'checkPortability'.+--+-- @since 0.6.0.0+checkEntryPortability :: GenEntry Char8.ByteString 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++-- | 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 content tarPath linkTarget -> Maybe e')+  -> GenEntries content tarPath linkTarget e+  -> GenEntries content tarPath linkTarget (Either e e')+checkEntries checkEntry =+  mapEntries (\entry -> maybe (Right entry) Left (checkEntry entry))
Codec/Archive/Tar/Entry.hs view
@@ -22,17 +22,17 @@ -- > import qualified Codec.Archive.Tar.Entry as Tar -- -----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+ 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 +47,8 @@   simpleEntry,   fileEntry,   directoryEntry,+  longLinkEntry,+  longSymLinkEntry,    -- * Standard file permissions   -- | For maximum portability when constructing archives use only these file@@ -58,6 +60,10 @@   -- * Constructing entries from disk files   packFileEntry,   packDirectoryEntry,+  packSymlinkEntry,+#if __GLASGOW_HASKELL__ >= 908+  {-# DEPRECATED "The re-export will be removed in future releases of tar, use directory-ospath-streaming package directly " #-}+#endif   getDirectoryContentsRecursive,    -- * TarPath type@@ -73,8 +79,8 @@   fromLinkTarget,   fromLinkTargetToPosixPath,   fromLinkTargetToWindowsPath,-   ) where  import Codec.Archive.Tar.Types import Codec.Archive.Tar.Pack+import System.Directory.OsPath.Streaming (getDirectoryContentsRecursive)
Codec/Archive/Tar/Index.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE CPP, BangPatterns, PatternGuards #-}-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}- ----------------------------------------------------------------------------- -- | -- Module      :  Codec.Archive.Tar.Index@@ -25,11 +22,11 @@     -- within the archive.     --     -- This module provides an index of a @tar@ file. A linear pass of the-    -- @tar@ file is needed to 'build' the 'TarIndex', but thereafter you can+    -- @tar@ file is needed to 'build' the t'TarIndex', but thereafter you can     -- 'lookup' paths in the @tar@ file, and then use 'hReadEntry' to     -- seek to the right part of the file and read the entry.     ---    -- An index cannot be used to lookup 'Directory' entries in a tar file;+    -- An index cannot be used to lookup 'Codec.Archive.Tar.Directory' entries in a tar file;     -- instead, you will get 'TarDir' entry listing all the entries in the     -- directory. @@ -69,196 +66,19 @@     nextEntryOffset,     indexEndEntryOffset,     indexNextEntryOffset,--    -- * Deprecated aliases-    emptyIndex,-    finaliseIndex,--#ifdef TESTS-    prop_lookup,-    prop_toList,-    prop_valid,-    prop_serialise_deserialise,-    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)-import Data.ByteString.Builder          as BS-#else-import Data.ByteString.Lazy.Builder     as BS-#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 t'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--- order, otherwise the resulting 'TarIndex' will report the wrong--- 'TarEntryOffset's. At the end use 'finalise' to get the 'TarIndex'.+-- each 'Codec.Archive.Tar.Entry.Entry' in the tar file in order. Every entry must added or skipped in+-- order, otherwise the resulting t'TarIndex' will report the wrong+-- 'TarEntryOffset's. At the end use 'finalise' to get the t'TarIndex'. -- -- For example, 'build' is simply: --@@ -267,524 +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.Builder-serialise (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-                             . LBS.toStrict . BS.toLazyByteString-                             . serialise) index-  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--#if !(MIN_VERSION_base(4,5,0))-(<>) :: Monoid m => m -> m -> m-(<>) = mappend-#endif
Codec/Archive/Tar/Index/IntTrie.hs view
@@ -1,13 +1,16 @@ {-# LANGUAGE CPP, BangPatterns, PatternGuards #-}-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# OPTIONS_HADDOCK hide #-}  module Codec.Archive.Tar.Index.IntTrie ( -  IntTrie,+  IntTrie(..),   construct,   toList, -  IntTrieBuilder,+  IntTrieBuilder(..),   empty,   insert,   finalise,@@ -17,24 +20,22 @@   TrieLookup(..),    serialise,+  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,-#endif- ) where+  TrieNode(..),+  Completions,+  inserts,+  completionsFrom,+  flattenTrie,+  tagLeaf,+  tagNode, -import Prelude hiding (lookup)+  Key(..),+  Value(..),+  ) where -import Data.Typeable (Typeable)+import Prelude hiding (lookup)  import qualified Data.Array.Unboxed as A import Data.Array.IArray  ((!))@@ -42,141 +43,43 @@ 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) 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+import GHC.IO +import Codec.Archive.Tar.Index.Utils  -- | 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)-    deriving (Eq, Show, Typeable)+newtype IntTrie = IntTrie (A.UArray Word32 Word32)+    deriving (Eq, Show) +-- | 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. @@ -191,52 +94,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@@ -246,10 +115,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 @@ -257,13 +126,13 @@ -- Toplevel trie array construction -- --- So constructing the 'IntTrie' as a whole is just a matter of stringing+-- So constructing the t'IntTrie' as a whole is just a matter of stringing -- together all the bits --- | Build an 'IntTrie' from a bunch of (key, value) pairs, where the keys+-- | Build an t'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  @@ -271,13 +140,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@@ -287,9 +158,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@@ -308,77 +179,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')           ] @@ -388,7 +255,7 @@  type Offset = Int -flatTrieLength :: IntTrieBuilder k v -> Int+flatTrieLength :: IntTrieBuilder -> Int flatTrieLength (IntTrieBuilder tns) =     1   + 2 * IntMap.size tns@@ -399,12 +266,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                   -> []@@ -420,9 +287,9 @@                                    (offset, Map.empty, tries)                                    tnodes -    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@@ -456,123 +323,29 @@ -- (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) -deserialise :: BS.ByteString -> Maybe (IntTrie k v, BS.ByteString)+serialiseSize :: IntTrie -> Int+serialiseSize (IntTrie arr) =+    let (_, ixEnd) = A.bounds arr in+    4+  + 4 * (fromIntegral ixEnd + 1)++deserialise :: BS.ByteString -> Maybe (IntTrie, BS.ByteString) deserialise bs   | BS.length bs >= 4   , let lenArr   = readWord32BE bs 0         lenTotal = 4 + 4 * fromIntegral lenArr   , BS.length bs >= 4 + 4 * fromIntegral lenArr-  , let !arr = A.array (0, lenArr-1)-                      [ (i, readWord32BE bs off)-                      | (i, off) <- zip [0..lenArr-1] [4,8 .. lenTotal - 4] ]-        !bs' = BS.drop lenTotal bs-  = Just (IntTrie arr, bs')+  , let !bs_without_len = BS.unsafeDrop 4 bs+        !bs_remaining = BS.unsafeDrop lenTotal bs+        !arr = unsafePerformIO $ beToLe lenArr bs_without_len+  = Just (IntTrie arr, bs_remaining)    | 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))------------------------------- 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-                            . LBS.toStrict . BS.toLazyByteString-                            . serialise) 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--#endif--#if !(MIN_VERSION_base(4,5,0))-(<>) :: Monoid m => m -> m -> m-(<>) = mappend-#endif
+ Codec/Archive/Tar/Index/Internal.hs view
@@ -0,0 +1,521 @@+{-# LANGUAGE CPP, BangPatterns, PatternGuards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_HADDOCK hide #-}++-----------------------------------------------------------------------------+-- |+-- 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 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.Utils (readWord32BE)+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)++instance NFData TarIndex where+  rnf (TarIndex _ _ _) = () -- fully strict by construction++-- | The result of 'Codec.Archive.Tar.Index.lookup' in a t'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)++newtype PathComponentId = PathComponentId Int+  deriving (Eq, Ord, Enum, Show)++-- | 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 t'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+  . posixToByteString+  . toPosixString+  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 = fromPosixString . byteToPosixString . 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 t'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 t'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 t'IndexBuilder'.+--+empty :: IndexBuilder+empty = IndexBuilder StringTable.empty IntTrie.empty 0++-- | Add the next t'Entry' into the t'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 t'TarIndex'.+--+skipNextEntry :: Entry -> IndexBuilder -> IndexBuilder+skipNextEntry entry (IndexBuilder stbl itrie nextOffset) =+    IndexBuilder stbl itrie (nextEntryOffset entry nextOffset)++-- | Finish accumulating t'Entry' information and build the compact t'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 t'IndexBuilder'. You might use this if you need to know the offsets+-- but don't want to use the t'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 t'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 (posixToByteString prefix) ++ splitDirectories (posixToByteString 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 t'TarIndex' is optimized for a highly compact and efficient in-memory+-- representation. This, however, makes it read-only. If you have an existing+-- t'TarIndex' for a large file, and want to add to it, you can translate the+-- t'TarIndex' back to an t'IndexBuilder'. Be aware that this is a relatively+-- costly operation (linear in the size of the t'TarIndex'), though still+-- faster than starting again from scratch.+--+-- This is the left inverse to 'Codec.Archive.Tar.Index.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 t'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 t'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 t'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 t'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 t'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 t'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 1+       (stringTable, bs')  <- StringTable.deserialiseV1 (BS.unsafeDrop 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 1+       (stringTable, bs')  <- StringTable.deserialiseV2 (BS.unsafeDrop 8 bs)+       (intTrie,     bs'') <- IntTrie.deserialise bs'+       return (TarIndex stringTable intTrie finalOffset, bs'')++  | otherwise = Nothing++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)
Codec/Archive/Tar/Index/StringTable.hs view
@@ -1,8 +1,10 @@-{-# LANGUAGE CPP, BangPatterns, PatternGuards, DeriveDataTypeable #-}+{-# LANGUAGE CPP, BangPatterns, PatternGuards #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_HADDOCK hide #-}  module Codec.Archive.Tar.Index.StringTable ( -    StringTable,+    StringTable(..),     lookup,     index,     construct,@@ -15,19 +17,13 @@     unfinalise,      serialise,+    serialiseSize,     deserialiseV1,     deserialiseV2, -#ifdef TESTS-    prop_valid,-    prop_sorted,-    prop_finalise_unfinalise,-    prop_serialise_deserialise,-#endif+    index'  ) where -import Data.Typeable (Typeable)- import Prelude   hiding (lookup, id) import Data.List hiding (lookup, insert) import Data.Function (on)@@ -35,39 +31,32 @@ 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 qualified Data.Array.Base 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)-import Data.ByteString.Builder      as BS-#else-import Data.ByteString.Lazy.Builder as BS-#endif-+import qualified Data.ByteString.Lazy   as LBS+import Data.ByteString.Builder          as BS+import Data.ByteString.Builder.Extra    as BS (byteStringCopy)+import GHC.IO (unsafePerformIO) +import Unsafe.Coerce (unsafeCoerce)+import Codec.Archive.Tar.Index.Utils --- | 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          {-# UNPACK #-} !(A.UArray Int32 Word32) -- string offset table          {-# UNPACK #-} !(A.UArray Int32 Int32)  -- string index to id table          {-# UNPACK #-} !(A.UArray Int32 Int32)  -- string id to index table-  deriving (Show, Typeable)+  deriving (Show)  instance (Eq id, Enum id) => Eq (StringTable id) where   tbl1 == tbl2 = unfinalise tbl1 == unfinalise tbl2@@ -105,7 +94,7 @@     index' bs offsets . (ixs !) . fromIntegral . fromEnum  --- | Given a list of strings, construct a 'StringTable' mapping those strings+-- | Given a list of strings, construct a t'StringTable' mapping those strings -- to a dense set of integers. Also return the ids for all the strings used -- in the construction. --@@ -116,7 +105,7 @@ data StringTableBuilder id = StringTableBuilder                                               !(Map BS.ByteString id)                                {-# UNPACK #-} !Word32-  deriving (Eq, Show, Typeable)+  deriving (Eq, Show)  empty :: StringTableBuilder id empty = StringTableBuilder Map.empty 0@@ -166,19 +155,27 @@        BS.word32BE (fromIntegral (BS.length strs))    <> BS.word32BE (fromIntegral ixEnd + 1)-   <> BS.byteString strs+   <> BS.byteStringCopy strs    <> foldr (\n r -> BS.word32BE n <> r) mempty (A.elems offs)    <> foldr (\n r -> BS.int32BE  n <> r) mempty (A.elems ids)    <> foldr (\n r -> BS.int32BE  n <> r) mempty (A.elems ixs) +serialiseSize :: StringTable id -> Int+serialiseSize (StringTable strs offs _ids _ixs) =+    let (_, !ixEnd) = A.bounds offs+     in 4 * 2+      + BS.length strs+      + 4 * (fromIntegral ixEnd + 1)+      + 8 *  fromIntegral ixEnd+ deserialiseV1 :: BS.ByteString -> Maybe (StringTable id, BS.ByteString) deserialiseV1 bs   | BS.length bs >= 8   , let lenStrs = fromIntegral (readWord32BE bs 0)-        lenArr  = fromIntegral (readWord32BE bs 4)+        lenArr  = fromIntegral (readWord32BE bs 1)         lenTotal= 8 + lenStrs + 4 * lenArr   , BS.length bs >= lenTotal-  , let strs = BS.take lenStrs (BS.drop 8 bs)+  , let strs = BS.unsafeTake lenStrs (BS.unsafeDrop 8 bs)         arr  = A.array (0, fromIntegral lenArr - 1)                        [ (i, readWord32BE bs off)                        | (i, off) <- zip [0 .. fromIntegral lenArr - 1]@@ -200,99 +197,32 @@ deserialiseV2 bs   | BS.length bs >= 8   , let lenStrs = fromIntegral (readWord32BE bs 0)-        lenArr  = fromIntegral (readWord32BE bs 4)+        lenArr  = fromIntegral (readWord32BE bs 1)         lenTotal= 8                   -- the two length prefixes                 + lenStrs                 + 4 * lenArr                 +(4 * (lenArr - 1)) * 2 -- offsets array is 1 longer   , BS.length bs >= lenTotal-  , let strs = BS.take lenStrs (BS.drop 8 bs)-        offs = A.listArray (0, fromIntegral lenArr - 1)-                           [ readWord32BE bs off-                           | off <- offsets offsOff ]-        -- the second two arrays are 1 shorter-        ids  = A.listArray (0, fromIntegral lenArr - 2)-                           [ readInt32BE bs off-                           | off <- offsets idsOff ]-        ixs  = A.listArray (0, fromIntegral lenArr - 2)-                           [ readInt32BE bs off-                           | off <- offsets ixsOff ]-        offsOff = 8 + lenStrs-        idsOff  = offsOff + 4 * lenArr-        ixsOff  = idsOff  + 4 * (lenArr-1)-        offsets from = [from,from+4 .. from + 4 * (lenArr - 1)]-        !stringTable = StringTable strs offs ids ixs-        !bs'         = BS.drop lenTotal bs-  = Just (stringTable, bs')+  , let strs    = BS.unsafeTake lenStrs (BS.unsafeDrop 8 bs)+        offs_bs = BS.unsafeDrop (8 + lenStrs) bs+        ids_bs  = BS.unsafeDrop (lenArr * 4) offs_bs+        ixs_bs  = BS.unsafeDrop ((lenArr - 1) * 4) ids_bs -  | otherwise-  = Nothing+        castArray :: A.UArray i Word32 -> A.UArray i Int32+        castArray (A.UArray a b c d) = (A.UArray a b c d) -readInt32BE :: BS.ByteString -> Int -> Int32-readInt32BE bs i = fromIntegral (readWord32BE bs i)+        -- Bangs are crucial for this to work in spite of unsafePerformIO!+        (offs, ids, ixs) = unsafePerformIO $ do+                  !r1 <- beToLe (fromIntegral lenArr) offs_bs+                  !r2 <- castArray <$> beToLe (fromIntegral lenArr - 1) ids_bs+                  !r3 <- castArray <$> beToLe (fromIntegral lenArr - 1) ixs_bs+                  return (r1, r2, r3) -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)) -#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-                                . LBS.toStrict . BS.toLazyByteString-                                . serialise) 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+        !stringTable = StringTable strs offs ids ixs+        !bs_left     = BS.drop lenTotal bs+  = Just (stringTable, bs_left) -#endif+  | otherwise+  = Nothing -#if !(MIN_VERSION_base(4,5,0))-(<>) :: Monoid m => m -> m -> m-(<>) = mappend-#endif
+ Codec/Archive/Tar/Index/Utils.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, CPP #-}+{-# OPTIONS_HADDOCK hide #-}++module Codec.Archive.Tar.Index.Utils where++import Data.ByteString as BS+import Control.Exception (assert)++import Data.ByteString.Internal (ByteString(..), unsafeWithForeignPtr, accursedUnutterablePerformIO)+import GHC.Int (Int(..), Int32)+import GHC.Word (Word32(..), byteSwap32)+import Foreign.Storable (peek)+import GHC.Ptr (castPtr, plusPtr, Ptr)+import GHC.Exts+import GHC.IO (IO(..), unsafePerformIO)+import Data.Array.Base+import Data.Array.IO.Internals (unsafeFreezeIOUArray)+import Control.DeepSeq (NFData(..))+import GHC.Storable+import GHC.ByteOrder++#include <MachDeps.h>++-- | Construct a `UArray Word32 Word32` from a ByteString of 32bit big endian+-- words.+--+-- Note: If using `unsafePerformIO`, be sure to force the result of running the+-- IO action right away... (e.g. see calls to beToLe in StringTable)+beToLe :: (Integral i, Num i) => i+       -- ^ The total array length (the number of 32bit words in the array)+       -> BS.ByteString+       -- ^ The bytestring from which the UArray is constructed.+       -- The content must start in the first byte! (i.e. the meta-data words+       -- that shouldn't be part of the array, must have been dropped already)+       -> IO (UArray i Word32)+beToLe lenArr (BS fptr _) = do+  unsafeWithForeignPtr fptr $ \ptr -> do+    let ptr' = castPtr ptr :: Ptr Word32+        !(I# lenBytes#) = fromIntegral (lenArr * 4)++    -- In spirit, the following does this, but we can't use `newGenArray`+    -- because it only has been introduced in later versions of array:+    -- @@+    -- unsafeFreezeIOUArray =<<+    --   newGenArray (0, lenArr - 1) (\offset -> do+    --     byteSwap32 <$> peek (ptr' `plusPtr` (fromIntegral offset * 4)))+    -- @@+    IO $ \rw0 ->+      case newByteArray# lenBytes# rw0 of+        (# rw1, mba# #) ->++          let loop :: Int -> State# RealWorld -> State# RealWorld+              loop !offset st+                | offset < fromIntegral lenArr+                = let IO getV = readWord32OffPtrBE ptr' offset+                      !(I# o#) = offset+                   in case getV st of+                    (# st', W32# v# #) ->+                      loop (offset + 1) (writeWord32Array# mba# o# v# st')+                | otherwise = st++           in case unsafeFreezeByteArray# mba# (loop 0 rw1) of+             (# rw2, ba# #) -> (# rw2, UArray 0 (lenArr - 1) (fromIntegral lenArr) ba# #)++{-# SPECIALISE beToLe :: Word32 -> BS.ByteString -> IO (UArray Word32 Word32) #-}+{-# SPECIALISE beToLe :: Int32 -> BS.ByteString -> IO (UArray Int32 Word32) #-}++readInt32BE :: BS.ByteString -> Int -> Int32+readInt32BE bs i = fromIntegral (readWord32BE bs i)+{-# INLINE readInt32BE #-}++readWord32OffPtrBE :: Ptr Word32 -> Int -> IO Word32+readWord32OffPtrBE ptr i = do+#if defined(WORDS_BIGENDIAN)+  readWord32OffPtr ptr i+#else+  byteSwap32 <$> readWord32OffPtr ptr i+#endif++readWord32BE :: BS.ByteString -> Int -> Word32+readWord32BE (BS fptr len) i =+    assert (i >= 0 && i+3 <= len - 1) $+    accursedUnutterablePerformIO $+      unsafeWithForeignPtr fptr $ \ptr -> do+        readWord32OffPtrBE (castPtr ptr) i+{-# INLINE readWord32BE #-}
+ Codec/Archive/Tar/LongNames.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_HADDOCK hide #-}++module Codec.Archive.Tar.LongNames+  ( encodeLongNames+  , decodeLongNames+  , DecodeLongNamesError(..)+  ) where++import Codec.Archive.Tar.PackAscii+import Codec.Archive.Tar.Types+import Control.Exception+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL+import "os-string" System.OsString.Posix (PosixString, PosixChar)+import qualified "os-string" System.OsString.Posix as PS++-- | 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 content FilePath FilePath+  -> [GenEntry content TarPath LinkTarget]+encodeLongNames e = maybe id (:) mEntry $ maybe id (:) mEntry' [e'']+  where+    (mEntry, e') = encodeLinkTarget e+    (mEntry', e'') = encodeTarPath e'++encodeTarPath+  :: GenEntry content FilePath linkTarget+  -> (Maybe (GenEntry content TarPath whatever), GenEntry content TarPath linkTarget)+  -- ^ (LongLink entry, actual entry)+encodeTarPath e = case toTarPath' (entryTarPath e) of+  FileNameEmpty -> (Nothing, e { entryTarPath = TarPath mempty mempty })+  FileNameOK tarPath -> (Nothing, e { entryTarPath = tarPath })+  FileNameTooLong tarPath -> (Just $ longLinkEntry $ entryTarPath e, e { entryTarPath = tarPath })++encodeLinkTarget+  :: GenEntry content tarPath FilePath+  -> (Maybe (GenEntry content TarPath LinkTarget), GenEntry content tarPath LinkTarget)+  -- ^ (LongLink symlink entry, actual entry)+encodeLinkTarget e = case entryContent e of+  NormalFile x y -> (Nothing, e { entryContent = NormalFile x y })+  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 content TarPath LinkTarget), LinkTarget)+encodeLinkPath lnk = case toTarPath' lnk of+  FileNameEmpty -> (Nothing, LinkTarget mempty)+  FileNameOK (TarPath name prefix)+    | PS.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 BL.ByteString FilePath FilePath (Either e DecodeLongNamesError)+decodeLongNames = go Nothing Nothing+  where+    isKEntry :: GenEntryContent content linkTarget -> Maybe FilePath+    isKEntry = \case+      OtherEntryType 'K' fn _ ->+        Just $ otherEntryKLPayloadToFilePath fn+      OtherEntryType 'x' fn _+        | Just fp <- lookup (B.pack "linkpath") (parsePaxExtendedHeader fn) ->+        Just $ B.unpack fp+      _ -> Nothing++    isLEntry :: GenEntryContent content linkTarget -> Maybe FilePath+    isLEntry = \case+      OtherEntryType 'L' fn _ ->+        Just $ otherEntryKLPayloadToFilePath fn+      OtherEntryType 'x' fn _+        | Just fp <- lookup (B.pack "path") (parsePaxExtendedHeader fn) ->+        Just $ B.unpack fp+      _ -> Nothing++    go :: Maybe FilePath -> Maybe FilePath -> Entries e -> GenEntries BL.ByteString FilePath FilePath (Either e DecodeLongNamesError)+    go _ _ (Fail err) = Fail (Left err)+    go _ _ Done = Done++    go Nothing Nothing (Next e rest)+      | Just link <- isKEntry (entryContent e)+      = go (Just link) Nothing rest+      | Just path <- isLEntry (entryContent e)+      = go Nothing (Just path) rest+      | otherwise+      = Next (castEntry e) (go Nothing Nothing rest)++    go Nothing (Just path) (Next e rest)+      | Just link <- isKEntry (entryContent e)+      = go (Just link) (Just path) rest+      | Just{} <- isLEntry (entryContent e)+      = Fail $ Right TwoTypeLEntries+      | otherwise+      = Next ((castEntry e) { entryTarPath = path }) (go Nothing Nothing rest)++    go (Just link) Nothing (Next e rest)+      | Just{} <- isKEntry (entryContent e)+      = Fail $ Right TwoTypeKEntries+      | Just path <- isLEntry (entryContent e)+      = go (Just link) (Just path) rest+      | otherwise+      = case entryContent e of+      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)+      | Just{} <- isKEntry (entryContent e)+      = Fail $ Right TwoTypeKEntries+      | Just{} <- isLEntry (entryContent e)+      = Fail $ Right TwoTypeLEntries+      | otherwise+      = case entryContent e of+      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++otherEntryKLPayloadToFilePath :: BL.ByteString -> FilePath+otherEntryKLPayloadToFilePath =+  fromPosixString . byteToPosixString . B.takeWhile (/= '\0') . BL.toStrict++parsePaxExtendedHeader :: BL.ByteString -> [(B.ByteString, B.ByteString)]+parsePaxExtendedHeader xs+  | BL.null xs = []+  | otherwise = case BL.readInt xs of+  Nothing -> corrupted+  Just (n, ys) -> let (zs, xs') = BL.splitAt (fromIntegral (n - length (show n))) ys in+    case B.uncons (BL.toStrict zs) of+      Just (' ', us) -> case B.unsnoc us of+        Just (vs, '\n') -> let (key, value') = B.span (/= '=') vs in+          case B.uncons value' of+            Just ('=', value) -> (key, value) : parsePaxExtendedHeader xs'+            _ -> corrupted+        _ -> corrupted+      _ -> corrupted+  where+    corrupted = [] -- let's be permissive++castEntry :: Entry -> GenEntry BL.ByteString FilePath FilePath+castEntry e = e+  { entryTarPath = fromTarPathToPosixPath (entryTarPath e)+  , entryContent = castEntryContent (entryContent e)+  }++castEntryContent :: EntryContent -> GenEntryContent BL.ByteString 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
Codec/Archive/Tar/Pack.hs view
@@ -1,10 +1,17 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Avoid restricted function" #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Codec.Archive.Tar -- Copyright   :  (c) 2007 Bjorn Bringert, --                    2008 Andrea Vezzosi,---                    2008-2009 Duncan Coutts+--                    2008-2009, 2012, 2016 Duncan Coutts -- License     :  BSD3 -- -- Maintainer  :  duncan@community.haskell.org@@ -13,90 +20,142 @@ ----------------------------------------------------------------------------- module Codec.Archive.Tar.Pack (     pack,+    pack',+    defaultRead,+    packAndCheck,     packFileEntry,     packDirectoryEntry,--    getDirectoryContentsRecursive,+    packSymlinkEntry,+    longLinkEntry,   ) where +import Codec.Archive.Tar.LongNames+import Codec.Archive.Tar.PackAscii (filePathToOsPath, osPathToFilePath) import Codec.Archive.Tar.Types -import qualified Data.ByteString.Lazy as BS-import System.FilePath-         ( (</>) )-import qualified System.FilePath as FilePath.Native+import Data.Int (Int64)+import Control.Applicative+import Prelude hiding (Applicative(..))+import Data.Bifunctor (bimap)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Foldable+import System.File.OsPath+import System.OsPath+         ( OsPath, (</>) )+import qualified System.OsPath as FilePath.Native          ( addTrailingPathSeparator, hasTrailingPathSeparator )-import System.Directory-         ( getDirectoryContents, doesDirectoryExist, getModificationTime-         , Permissions(..), getPermissions )-#if MIN_VERSION_directory(1,2,0)--- The directory package switched to the new time package-import Data.Time.Clock-         ( UTCTime )+import System.Directory.OsPath+         ( doesDirectoryExist, getModificationTime+         , pathIsSymbolicLink, getSymbolicLinkTarget+         , Permissions(..), getPermissions, getFileSize )+import qualified System.Directory.OsPath.Types as FT+import System.Directory.OsPath.Streaming (getDirectoryContentsRecursive) import Data.Time.Clock.POSIX          ( utcTimeToPOSIXSeconds )-#else-import System.Time-         ( ClockTime(..) )-#endif import System.IO-         ( IOMode(ReadMode), openBinaryFile, hFileSize )+         ( IOMode(ReadMode), hFileSize, hClose ) import System.IO.Unsafe (unsafeInterleaveIO)+import Control.Exception (throwIO, SomeException)+import System.IO.Error (annotateIOError)  -- | Creates a tar archive from a list of directory or files. Any directories -- specified will have their contents included recursively. Paths in the -- 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.------ An exception will be thrown for any file names that are too long to--- represent as a 'TarPath'.+-- 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. -- -- * This function returns results lazily. Subdirectories are scanned -- and files are read one by one as the list of entries is consumed.+-- Do not change their contents before the output of 'Codec.Archive.Tar.pack' was consumed in full. ---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) -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 ]+-- | 'pack'' is like 'pack', but doesn't read the contents of files,+-- only creating entries with 'OsPath' as contents.+--+-- @since 0.7.0.0+pack'+  :: FilePath+  -> [FilePath]+  -> IO [GenEntry OsPath TarPath LinkTarget]+pack' = packAndCheckWithRead (\_ -> return) (const Nothing) -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 ]+-- | Like 'Codec.Archive.Tar.pack', but allows to specify additional sanity/security+-- checks on the input filenames. This is useful if you know which+-- check will be used on client side+-- in 'Codec.Archive.Tar.unpack' / 'Codec.Archive.Tar.unpackAndCheck'.+--+-- @since 0.6.0.0+packAndCheck+  :: (GenEntry BL.ByteString FilePath FilePath -> Maybe SomeException)+  -> FilePath   -- ^ Base directory+  -> [FilePath] -- ^ Files and directories to pack, relative to the base dir+  -> IO [Entry]+packAndCheck = packAndCheckWithRead defaultRead -interleave :: [IO a] -> IO [a]-interleave = unsafeInterleaveIO . go+packAndCheckWithRead+  :: (Int64 -> OsPath -> IO content)+  -> (GenEntry content FilePath FilePath -> Maybe SomeException)+  -> FilePath+  -> [FilePath]+  -> IO [GenEntry content TarPath LinkTarget]+packAndCheckWithRead r secCB (filePathToOsPath -> baseDir) (map filePathToOsPath -> relpaths) = do+  paths <- preparePaths baseDir relpaths+  entries' <- packPathsWithRead r baseDir paths+  let entries = map (bimap osPathToFilePath osPathToFilePath) entries'+  traverse_ (maybe (pure ()) throwIO . secCB) entries+  pure $ concatMap encodeLongNames entries++preparePaths :: OsPath -> [OsPath] -> IO [OsPath]+preparePaths baseDir = fmap concat . interleavedSequence . map go   where-    go []     = return []-    go (x:xs) = do-      x'  <- x-      xs' <- interleave xs-      return (x':xs')+    go :: OsPath -> IO [OsPath]+    go relpath = do+      let abspath = baseDir </> relpath+      isDir  <- doesDirectoryExist abspath+      isSymlink <- pathIsSymbolicLink abspath+      if isDir && not isSymlink then do+        entries <- getDirectoryContentsRecursive abspath+        let entries' = map ((relpath </>) . addSeparatorIfDir) entries+        return $ if relpath == mempty+          then entries'+          else FilePath.Native.addTrailingPathSeparator relpath : entries'+      else return [relpath] --- | Construct a tar 'Entry' based on a local file.+    addSeparatorIfDir (fn, ty) = case ty of+      FT.Directory{} -> FilePath.Native.addTrailingPathSeparator fn+      _ -> fn++-- | Pack paths while accounting for overlong filepaths.+packPathsWithRead+  :: (Int64 -> OsPath -> IO content)+  -> OsPath+  -> [OsPath]+  -> IO [GenEntry content OsPath OsPath]+packPathsWithRead r baseDir paths = interleavedSequence $ flip map paths $ \relpath -> do+  let isDir = FilePath.Native.hasTrailingPathSeparator abspath+      abspath = baseDir </> relpath+  isSymlink <- pathIsSymbolicLink abspath+  let mkEntry+        | isSymlink = packSymlinkEntry'+        | isDir = packDirectoryEntry'+        | otherwise = packFileEntryWithRead' r+  mkEntry abspath relpath++-- | As a normal 'sequence', but interleaving IO actions.+interleavedSequence :: [IO a] -> IO [a]+interleavedSequence =+  foldr ((unsafeInterleaveIO .) . liftA2 (:)) (pure [])++-- | Construct a tar entry based on a local file. -- -- This sets the entry size, the data contained in the file and the file's -- modification time. If the file is executable then that information is also@@ -104,86 +163,145 @@ -- -- * 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 tarpath = do+packFileEntry+  :: FilePath -- ^ Full path to find the file on the local disk+  -> tarPath  -- ^ Path to use for the tar 'GenEntry' in the archive+  -> IO (GenEntry BL.ByteString tarPath linkTarget)+packFileEntry = packFileEntry' . filePathToOsPath++packFileEntry'+  :: OsPath  -- ^ Full path to find the file on the local disk+  -> tarPath -- ^ Path to use for the tar 'GenEntry' in the archive+  -> IO (GenEntry BL.ByteString 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 --- | Construct a tar 'Entry' based on a local directory (but not its contents).+  (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 <- 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+    }++-- | --+-- @since 0.7.0.0+defaultRead+  :: Int64 -- ^ expected size+  -> OsPath+  -> IO BL.ByteString+defaultRead approxSize filepath = do+  if approxSize < 131072+    -- If file is short enough, just read it strictly+    -- so that no file handle dangles around indefinitely.+    then do+      cnt <- readFile' filepath+      let sz = fromIntegral (B.length cnt) :: Int64+      if sz /= approxSize+      then throwWrongSize sz+      else pure (BL.fromStrict cnt)+    else do+      hndl <- openBinaryFile filepath ReadMode+      -- File size could have changed between measuring approxSize+      -- and here. Measuring again.+      sz <- fromInteger <$> hFileSize hndl+      if sz /= approxSize+      then do+        hClose hndl+        throwWrongSize sz+      else do+        -- Lazy I/O at its best: once cnt is forced in full,+        -- BL.hGetContents will close the handle.+        cnt <- BL.hGetContents hndl+        -- It would be wrong to return (cnt, BL.length sz):+        -- NormalFile constructor below forces size which in turn+        -- allocates entire cnt in memory at once.+        pure cnt+  where+    throwWrongSize :: Int64 -> IO a+    throwWrongSize sz = do+        let msg = "File size changed, expecting " ++ show approxSize ++ "; got " ++ show sz+        ioError (annotateIOError (userError msg) "defaultRead" Nothing (Just (osPathToFilePath filepath)))++packFileEntryWithRead'+  :: (Int64 -> OsPath -> IO content)+  -> OsPath  -- ^ Full path to find the file on the local disk+  -> tarPath -- ^ Path to use for the tar 'GenEntry' in the archive+  -> IO (GenEntry content tarPath linkTarget)+packFileEntryWithRead' r filepath tarpath = do+  mtime   <- getModTime filepath+  perms   <- getPermissions filepath+  -- Get file size without opening it.+  size <- fromInteger <$> getFileSize filepath+  content <- r size filepath++  pure (simpleEntry tarpath (NormalFile content size))+    { entryPermissions =+      if executable perms then executableFilePermissions else ordinaryFilePermissions+    , entryTime = mtime+    }++-- | Construct a tar entry based on a local directory (but not its contents).+-- -- The only attribute of the directory that is used is its modification time. -- 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 tarpath = do+packDirectoryEntry+  :: FilePath -- ^ Full path to find the file on the local disk+  -> tarPath  -- ^ Path to use for the tar 'GenEntry' in the archive+  -> IO (GenEntry content tarPath linkTarget)+packDirectoryEntry = packDirectoryEntry' . filePathToOsPath++packDirectoryEntry'+  :: OsPath  -- ^ Full path to find the file on the local disk+  -> tarPath -- ^ Path to use for the tar 'GenEntry' in the archive+  -> IO (GenEntry content tarPath linkTarget)+packDirectoryEntry' filepath tarpath = do   mtime   <- getModTime filepath   return (directoryEntry tarpath) {     entryTime = mtime   } --- | This is a utility function, much like 'getDirectoryContents'. The--- difference is that it includes the contents of subdirectories.------ The paths returned are all relative to the top directory. Directory paths--- are distinguishable by having a trailing path separator--- (see 'FilePath.Native.hasTrailingPathSeparator').------ All directories are listed before the files that they contain. Amongst the--- contents of a directory, subdirectories are listed after normal files. The--- overall result is that files within a directory will be together in a single--- contiguous group. This tends to improve file layout and IO performance when--- creating or extracting tar archives.------ * This function returns results lazily. Subdirectories are not scanned--- until the files entries in the parent directory have been consumed.+-- | Construct a tar entry based on a local symlink. ---getDirectoryContentsRecursive :: FilePath -> IO [FilePath]-getDirectoryContentsRecursive dir0 =-  fmap tail (recurseDirectories dir0 [""])--recurseDirectories :: FilePath -> [FilePath] -> IO [FilePath]-recurseDirectories _    []         = return []-recurseDirectories base (dir:dirs) = unsafeInterleaveIO $ do-  (files, dirs') <- collect [] [] =<< getDirectoryContents (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-        then collect files (dirEntry':dirs') entries-        else collect (dirEntry:files) dirs' entries+-- @since 0.6.0.0+packSymlinkEntry+  :: FilePath -- ^ Full path to find the file on the local disk+  -> tarPath  -- ^ Path to use for the tar 'GenEntry' in the archive+  -> IO (GenEntry content tarPath FilePath)+packSymlinkEntry = ((fmap (fmap osPathToFilePath) .) . packSymlinkEntry') . filePathToOsPath -    ignore ['.']      = True-    ignore ['.', '.'] = True-    ignore _          = False+packSymlinkEntry'+  :: OsPath  -- ^ Full path to find the file on the local disk+  -> tarPath -- ^ Path to use for the tar 'GenEntry' in the archive+  -> IO (GenEntry content tarPath OsPath)+packSymlinkEntry' filepath tarpath = do+  linkTarget <- getSymbolicLinkTarget filepath+  pure $ symlinkEntry tarpath linkTarget -getModTime :: FilePath -> IO EpochTime+getModTime :: OsPath -> 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
+ Codec/Archive/Tar/PackAscii.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE PackageImports #-}++{-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS_GHC -Wno-deprecations #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Avoid restricted function" #-}++module Codec.Archive.Tar.PackAscii+  ( toPosixString+  , fromPosixString+  , posixToByteString+  , byteToPosixString+  , packLatin1+  , filePathToOsPath+  , osPathToFilePath+  ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS.Char8+import qualified Data.ByteString.Short as Sh+import Data.Char+import GHC.Stack+import System.IO.Unsafe (unsafePerformIO)+import "os-string" System.OsString.Posix (PosixString)+import qualified "filepath" System.OsPath as OS+import qualified "os-string" System.OsString.Posix as PS+import qualified "os-string" System.OsString.Internal.Types as PS++toPosixString :: FilePath -> PosixString+toPosixString = unsafePerformIO . PS.encodeFS++fromPosixString :: PosixString -> FilePath+fromPosixString = unsafePerformIO . PS.decodeFS++posixToByteString :: PosixString -> ByteString+posixToByteString = Sh.fromShort . PS.getPosixString++byteToPosixString :: ByteString -> PosixString+byteToPosixString = PS.PosixString . Sh.toShort++packLatin1 :: HasCallStack => FilePath -> BS.Char8.ByteString+packLatin1 xs+  | all isLatin1 xs = BS.Char8.pack xs+  | otherwise = error $ "packLatin1: only Latin-1 inputs are supported, but got " ++ xs++filePathToOsPath :: FilePath -> OS.OsPath+filePathToOsPath = unsafePerformIO . OS.encodeFS++osPathToFilePath :: OS.OsPath -> FilePath+osPathToFilePath = unsafePerformIO . OS.decodeFS
Codec/Archive/Tar/Read.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE CPP, DeriveDataTypeable, BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | -- Module      :  Codec.Archive.Tar.Read@@ -12,27 +14,33 @@ -- Portability :  portable -- ------------------------------------------------------------------------------module Codec.Archive.Tar.Read (read, FormatError(..)) where+module Codec.Archive.Tar.Read+  ( read+  , FormatError(..)+  ) where +import Codec.Archive.Tar.PackAscii import Codec.Archive.Tar.Types  import Data.Char     (ord) import Data.Int      (Int64)-import Data.Bits     (Bits(shiftL))+import Data.Bits     (Bits(shiftL, (.&.), complement)) import Control.Exception (Exception(..))-import Data.Typeable (Typeable) import Control.Applicative import Control.Monad import Control.DeepSeq+import Control.Monad.Trans.State.Lazy  import qualified Data.ByteString        as BS import qualified Data.ByteString.Char8  as BS.Char8 import qualified Data.ByteString.Unsafe as BS import qualified Data.ByteString.Lazy   as LBS+import System.IO.Unsafe (unsafePerformIO)+import "os-string" System.OsString.Posix (PosixString, PosixChar)+import qualified "os-string" System.OsString.Posix as PS  import Prelude hiding (read) - -- | Errors that can be encountered when parsing a Tar archive. data FormatError   = TruncatedArchive@@ -43,8 +51,7 @@   | NotTarFormat   | UnrecognisedTarFormat   | HeaderBadNumericEncoding-#if MIN_VERSION_base(4,8,0)-  deriving (Eq, Show, Typeable)+  deriving (Eq, Show)  instance Exception FormatError where   displayException TruncatedArchive         = "truncated tar archive"@@ -55,22 +62,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 @@ -81,88 +73,128 @@ -- * The conversion is done lazily. -- read :: LBS.ByteString -> Entries FormatError-read = unfoldEntries getEntry+read = evalState (readStreaming getN get)+  where+    getN :: Int64 -> State LBS.ByteString LBS.ByteString+    getN n = do+      (pref, st) <- LBS.splitAt n <$> get+      put st+      pure pref -getEntry :: LBS.ByteString -> Either FormatError (Maybe (Entry, LBS.ByteString))-getEntry bs-  | BS.length header < 512 = Left TruncatedArchive+readStreaming+  :: Monad m+  => (Int64 -> m LBS.ByteString)+  -> m LBS.ByteString+  -> m (Entries FormatError)+readStreaming = (unfoldEntriesM id .) . getEntryStreaming -  -- 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-      (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+getEntryStreaming+  :: Monad m+  => (Int64 -> m LBS.ByteString)+  -> m LBS.ByteString+  -> m (Either FormatError (Maybe Entry))+getEntryStreaming getN getAll = do+  header <- getN 512+  if LBS.length header < 512 then pure (Left TruncatedArchive) else do -  | otherwise  = partial $ do+    -- 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.+    --+    -- 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.+    if LBS.all (== 0) header then do+      nextBlock <- getN 512+      if LBS.length nextBlock < 512 then pure (Left ShortTrailer)+        else if LBS.all (== 0) nextBlock then do+          remainder <- getAll+          pure $ if LBS.all (== 0) remainder then Right Nothing else Left TrailingJunk+          else pure (Left BadTrailer) -  case (chksum_, format_) of-    (Ok chksum, _   ) | correctChecksum header chksum -> return ()-    (Ok _,      Ok _) -> Error ChecksumIncorrect-    _                 -> Error NotTarFormat+      else case parseHeader header of+        Left err -> pure $ Left err+        Right (name, mode, uid, gid, size, mtime, typecode, linkname, format, uname, gname, devmajor, devminor, prefix) -> do -  -- These fields are partial, have to check them-  format   <- format_;   mode     <- mode_;-  uid      <- uid_;      gid      <- gid_;-  size     <- size_;     mtime    <- mtime_;-  devmajor <- devmajor_; devminor <- devminor_;+          -- It is crucial to get (size + padding) in one monadic operation+          -- and drop padding in a pure computation. If you get size bytes first,+          -- then skip padding, unpacking in constant memory will become impossible.+          let paddedSize = (size + 511) .&. complement 511+          paddedContent <- getN paddedSize+          let content = LBS.take size paddedContent -  let content = LBS.take size (LBS.drop 512 bs)-      padding = (512 - size) `mod` 512-      bs'     = LBS.drop (512 + size + padding) bs+          pure $ Right $ Just $ Entry {+            entryTarPath     = TarPath (byteToPosixString name) (byteToPosixString prefix),+            entryContent     = case typecode of+                 '\0' -> NormalFile      content size+                 '0'  -> NormalFile      content size+                 '1'  -> HardLink        (LinkTarget $ byteToPosixString linkname)+                 '2'  -> SymbolicLink    (LinkTarget $ byteToPosixString linkname)+                 _ | format == V7Format+                      -> OtherEntryType  typecode content size+                 '3'  -> CharacterDevice devmajor devminor+                 '4'  -> BlockDevice     devmajor devminor+                 '5'  -> Directory+                 '6'  -> NamedPipe+                 '7'  -> NormalFile      content size+                 _    -> OtherEntryType  typecode content size,+            entryPermissions = mode,+            entryOwnership   = Ownership (BS.Char8.unpack uname)+                                         (BS.Char8.unpack gname) uid gid,+            entryTime        = mtime,+            entryFormat      = format+            } -      entry = Entry {-        entryTarPath     = TarPath name prefix,-        entryContent     = case typecode of-                   '\0' -> NormalFile      content size-                   '0'  -> NormalFile      content size-                   '1'  -> HardLink        (LinkTarget linkname)-                   '2'  -> SymbolicLink    (LinkTarget linkname)-                   _ | format == V7Format-                        -> OtherEntryType  typecode content size-                   '3'  -> CharacterDevice devmajor devminor-                   '4'  -> BlockDevice     devmajor devminor-                   '5'  -> Directory-                   '6'  -> NamedPipe-                   '7'  -> NormalFile      content size-                   _    -> OtherEntryType  typecode content size,-        entryPermissions = mode,-        entryOwnership   = Ownership (BS.Char8.unpack uname)-                                     (BS.Char8.unpack gname) uid gid,-        entryTime        = mtime,-        entryFormat      = format-    }+parseHeader+  :: LBS.ByteString+  -> Either FormatError (BS.ByteString, Permissions, Int, Int, Int64, EpochTime, Char, BS.ByteString, Format, BS.ByteString, BS.ByteString, DevMajor, DevMinor, BS.ByteString)+parseHeader header' = do+  case (chksum_, format_ magic) of+    (Right chksum, _ ) | correctChecksum header chksum -> return ()+    (Right _, Right _) -> Left ChecksumIncorrect+    _                  -> Left NotTarFormat -  return (Just (entry, bs'))+  mode     <- mode_+  uid      <- uid_+  gid      <- gid_+  size     <- size_+  mtime    <- mtime_+  format   <- format_ magic+  devmajor <- devmajor_+  devminor <- devminor_ +  pure (name, mode, uid, gid, size, mtime, typecode, linkname, format, uname, gname, devmajor, devminor, prefix)   where-   header = LBS.toStrict (LBS.take 512 bs)+    header     = LBS.toStrict header' -   name       = getString   0 100 header-   mode_      = getOct    100   8 header-   uid_       = getOct    108   8 header-   gid_       = getOct    116   8 header-   size_      = getOct    124  12 header-   mtime_     = getOct    136  12 header-   chksum_    = getOct    148   8 header-   typecode   = getByte   156     header-   linkname   = getString 157 100 header-   magic      = getChars  257   8 header-   uname      = getString 265  32 header-   gname      = getString 297  32 header-   devmajor_  = getOct    329   8 header-   devminor_  = getOct    337   8 header-   prefix     = getString 345 155 header--- trailing   = getBytes  500  12 header+    name       = getString   0 100 header+    mode_      = getOct    100   8 header+    uid_       = getOct    108   8 header+    gid_       = getOct    116   8 header+    size_      = getOct    124  12 header+    mtime_     = getOct    136  12 header+    chksum_    = getOct    148   8 header+    typecode   = getByte   156     header+    linkname   = getString 157 100 header+    magic      = getChars  257   8 header+    uname      = getString 265  32 header+    gname      = getString 297  32 header+    devmajor_  = getOct    329   8 header+    devminor_  = getOct    337   8 header+    prefix     = getString 345 155 header+    -- trailing   = getBytes  500  12 header -   format_-     | magic == ustarMagic = return UstarFormat-     | magic == gnuMagic   = return GnuFormat-     | magic == v7Magic    = return V7Format-     | otherwise           = Error UnrecognisedTarFormat+format_ :: BS.ByteString -> Either FormatError Format+format_ magic+  | magic == ustarMagic = return UstarFormat+  | magic == gnuMagic   = return GnuFormat+  | magic == v7Magic    = return V7Format+  | otherwise           = Left UnrecognisedTarFormat  v7Magic, ustarMagic, gnuMagic :: BS.ByteString v7Magic    = BS.Char8.pack "\0\0\0\0\0\0\0\0"@@ -182,15 +214,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@@ -204,9 +232,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@@ -218,47 +251,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-    fail          = error "fail @(Partial e)"- {-# 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
Codec/Archive/Tar/Types.hs view
@@ -1,4 +1,12 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_HADDOCK hide #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Codec.Archive.Tar.Types@@ -16,9 +24,11 @@ ----------------------------------------------------------------------------- module Codec.Archive.Tar.Types ( -  Entry(..),+  GenEntry(..),+  Entry,   entryPath,-  EntryContent(..),+  GenEntryContent(..),+  EntryContent,   FileSize,   Permissions,   Ownership(..),@@ -29,79 +39,99 @@   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+  unfoldEntriesM,   ) where +import Data.Bifunctor (Bifunctor, bimap) import Data.Int      (Int64)+import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid   (Monoid(..))+import Data.Semigroup as Sem 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, (<*>))-#endif+import "os-string" System.OsString.Posix (PosixString, PosixChar)+import qualified "os-string" System.OsString.Posix as PS +import Codec.Archive.Tar.PackAscii +-- | File size in bytes. type FileSize  = Int64--- | The number of seconds since the UNIX epoch++-- | The number of seconds since the UNIX epoch. type EpochTime = Int64++-- | Major device number. type DevMajor  = Int++-- | Minor device number. type DevMinor  = Int++-- | User-defined tar format expansion. type TypeCode  = Char++-- | Permissions information for 'GenEntry'. type Permissions = FileMode --- | Tar archive entry.+-- | Polymorphic tar archive entry. High-level interfaces+-- commonly work with 'GenEntry' 'FilePath' 'FilePath',+-- while low-level ones use 'GenEntry' t'TarPath' t'LinkTarget'. ---data Entry = Entry {+-- @since 0.6.0.0+data GenEntry content 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 content linkTarget),      -- | File permissions (Unix style file mode).     entryPermissions :: {-# UNPACK #-} !Permissions,@@ -115,35 +145,69 @@     -- | The tar format the archive is using.     entryFormat :: !Format   }-  deriving (Eq, Show)+  deriving+  ( Eq+  , Show+  , Functor -- ^ @since 0.6.4.0+  ) --- | Native 'FilePath' of the file or directory within the archive.+-- | @since 0.6.4.0+instance Bifunctor (GenEntry content) where+  bimap f g e = e+    { entryTarPath = f (entryTarPath e)+    , entryContent = fmap g (entryContent e)+    }++-- | Monomorphic tar archive entry, ready for serialization / deserialization. ---entryPath :: Entry -> FilePath+type Entry = GenEntry LBS.ByteString TarPath LinkTarget++-- | Low-level function to get a native 'FilePath' of the file or directory+-- within the archive, not accounting for long names. It's likely+-- that you want to apply 'Codec.Archive.Tar.decodeLongNames'+-- and use 'Codec.Archive.Tar.Entry.entryTarPath' afterwards instead of 'entryPath'.+--+entryPath :: GenEntry content 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 ones use 'GenEntryContent' t'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 content linkTarget+  = NormalFile      content {-# 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+  , Functor -- ^ @since 0.6.4.0+  ) +-- | Monomorphic content of a tar archive entry,+-- ready for serialization / deserialization.+type EntryContent = GenEntryContent LBS.ByteString LinkTarget++-- | Ownership information for 'GenEntry'. data Ownership = Ownership {     -- | The owner user name. Should be set to @\"\"@ if unknown.+    -- Must not contain non-ASCII characters.     ownerName :: String,      -- | The owner group name. Should be set to @\"\"@ if unknown.+    -- Must not contain non-ASCII characters.     groupName :: String,      -- | Numeric owner user id. Should be set to @0@ if unknown.@@ -154,6 +218,9 @@   }     deriving (Eq, Ord, Show) +defaultOwnership :: Ownership+defaultOwnership = Ownership "" "" 0 0+ -- | There have been a number of extensions to the tar file format over the -- years. They all share the basic entry fields and put more meta-data in -- different extended headers.@@ -167,23 +234,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 content, NFData linkTarget) => NFData (GenEntry content tarPath linkTarget) where+  rnf (Entry p c _ _ _ _) = rnf p `seq` rnf c -instance NFData EntryContent where-  rnf (NormalFile       c _) = rnf c-  rnf (OtherEntryType _ c _) = rnf c-  rnf  x                     = seq x ()+instance (NFData linkTarget, NFData content) => NFData (GenEntryContent content linkTarget) where+  rnf x = case x of+      NormalFile       c _  -> rnf c+      SymbolicLink lnk      -> rnf lnk+      HardLink lnk          -> rnf lnk+      OtherEntryType _ c _  -> rnf c+      _                     -> seq x ()  instance NFData Ownership where   rnf (Ownership o g _ _) = rnf o `seq` rnf g@@ -192,6 +260,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@@ -200,26 +274,27 @@ directoryPermissions :: Permissions directoryPermissions  = 0o0755 --- | An 'Entry' with all default values except for the file name and type. It--- uses the portable USTAR/POSIX format (see 'UstarHeader').+-- | An entry with all default values except for the file name and type. It+-- 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 content = Entry {-    entryTarPath     = tarpath,+simpleEntry :: tarPath -> GenEntryContent content linkTarget -> GenEntry content tarPath linkTarget+simpleEntry tarPath content = Entry {+    entryTarPath     = tarPath,     entryContent     = content,     entryPermissions = case content of                          Directory -> directoryPermissions+                         SymbolicLink _ -> symbolicLinkPermission                          _         -> ordinaryFilePermissions,-    entryOwnership   = Ownership "" "" 0 0,+    entryOwnership   = defaultOwnership,     entryTime        = 0,     entryFormat      = UstarFormat   } --- | A tar 'Entry' for a file.+-- | A tar entry for a file. -- -- Entry  fields such as file permissions and ownership have default values. --@@ -228,15 +303,56 @@ -- -- > (fileEntry name content) { fileMode = executableFileMode } ---fileEntry :: TarPath -> LBS.ByteString -> Entry+fileEntry :: tarPath -> LBS.ByteString -> GenEntry LBS.ByteString tarPath linkTarget fileEntry name fileContent =   simpleEntry name (NormalFile fileContent (LBS.length fileContent)) --- | A tar 'Entry' for a directory.+-- | A tar entry for a symbolic link.+symlinkEntry :: tarPath -> linkTarget -> GenEntry content 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 'Codec.Archive.Tar.Entry.entryTarPath'+-- as 'OtherEntryType' @\'L\'@ with the full filepath as 'entryContent'.+-- The next entry must contain the actual+-- data with truncated 'Codec.Archive.Tar.Entry.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 content TarPath linkTarget+longLinkEntry tarpath = Entry {+    entryTarPath     = TarPath [PS.pstr|././@LongLink|] mempty,+    entryContent     = OtherEntryType 'L' (LBS.fromStrict $ posixToByteString $ toPosixString tarpath) (fromIntegral $ length tarpath),+    entryPermissions = ordinaryFilePermissions,+    entryOwnership   = defaultOwnership,+    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 'Codec.Archive.Tar.Entry.entryTarPath'+-- as 'OtherEntryType' @\'K\'@ with the full filepath as 'entryContent'.+-- The next entry must contain the actual+-- data with truncated 'Codec.Archive.Tar.Entry.entryTarPath'.+--+-- @since 0.6.0.0+longSymLinkEntry :: FilePath -> GenEntry content TarPath linkTarget+longSymLinkEntry linkTarget = Entry {+    entryTarPath     = TarPath [PS.pstr|././@LongLink|] mempty,+    entryContent     = OtherEntryType 'K' (LBS.fromStrict $ posixToByteString $ toPosixString $ linkTarget) (fromIntegral $ length linkTarget),+    entryPermissions = ordinaryFilePermissions,+    entryOwnership   = defaultOwnership,+    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 content tarPath linkTarget directoryEntry name = simpleEntry name Directory  --@@ -267,8 +383,11 @@ -- -- * The directory separator between the prefix and name is /not/ stored. ---data TarPath = TarPath {-# UNPACK #-} !BS.ByteString -- path name, 100 characters max.-                       {-# UNPACK #-} !BS.ByteString -- path prefix, 155 characters max.+data TarPath = TarPath+  {-# UNPACK #-} !PosixString+  -- ^ path name, 100 characters max.+  {-# UNPACK #-} !PosixString+  -- ^ path prefix, 155 characters max.   deriving (Eq, Ord)  instance NFData TarPath where@@ -277,7 +396,7 @@ instance Show TarPath where   show = show . fromTarPath --- | Convert a 'TarPath' to a native 'FilePath'.+-- | Convert a t'TarPath' to a native 'FilePath'. -- -- The native 'FilePath' will use the native directory separator but it is not -- otherwise checked for validity or sanity. In particular:@@ -287,106 +406,122 @@ -- -- * 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 = fromPosixString . fromTarPathInternal (PS.unsafeFromChar FilePath.Native.pathSeparator) --- | Convert a 'TarPath' to a Unix\/Posix 'FilePath'.+-- | Convert a t'TarPath' to a Unix\/Posix 'FilePath'. -- -- The difference compared to 'fromTarPath' is that it always returns a Unix -- style path irrespective of the current operating system. ----- This is useful to check how a 'TarPath' would be interpreted on a specific+-- This is useful to check how a t'TarPath' would be interpreted on a specific -- 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 = fromPosixString . fromTarPathInternal (PS.unsafeFromChar FilePath.Posix.pathSeparator) --- | Convert a 'TarPath' to a Windows 'FilePath'.+-- | Convert a t'TarPath' to a Windows 'FilePath'. -- -- The only difference compared to 'fromTarPath' is that it always returns a -- Windows style path irrespective of the current operating system. ----- This is useful to check how a 'TarPath' would be interpreted on a specific+-- This is useful to check how a t'TarPath' would be interpreted on a specific -- 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 = fromPosixString . fromTarPathInternal (PS.unsafeFromChar FilePath.Windows.pathSeparator)++fromTarPathInternal :: PosixChar -> TarPath -> PosixString+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 = PS.unsafeFromChar FilePath.Posix.pathSeparator+    adjustSeps = if sep == posixSep then id else+      PS.map $ \c -> if c == posixSep then sep else c+    go (TarPath name prefix)+     | PS.null prefix = adjustSeps name+     | PS.null name = adjustSeps prefix+     | otherwise = adjustSeps prefix <> PS.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.+-- | Convert a native 'FilePath' to a t'TarPath'. --+-- The conversion may fail if the 'FilePath' is empty or too long. 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+                  -- directories a t'TarPath' must always use a trailing @\/@.+          -> 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: " ++ path'   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 t'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 t'TarPath' must be non-empty.+  | FileNameOK TarPath+  -- ^ All good, this is just a normal t'TarPath'.+  | FileNameTooLong TarPath+  -- ^ 'FilePath' was longer than 255 characters, t'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 (toPosixString $ take 100 path) mempty+    Just (name, [])         -> FileNameOK $! TarPath (toPosixString name) mempty+    Just (name, first:rest) -> case packName prefixMax remainder of+      Nothing               -> FileNameTooLong $ TarPath (toPosixString $ take 100 path) mempty+      Just (_     , _:_)    -> FileNameTooLong $ TarPath (toPosixString $ take 100 path) mempty+      Just (prefix, [])     -> FileNameOK $! TarPath (toPosixString name) (toPosixString 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@@ -395,63 +530,84 @@ -- | The tar format allows just 100 ASCII characters for the 'SymbolicLink' and -- 'HardLink' entry types. ---newtype LinkTarget = LinkTarget BS.ByteString-  deriving (Eq, Ord, Show, NFData)+newtype LinkTarget = LinkTarget PosixString+  deriving (Eq, Ord, Show) --- | Convert a native 'FilePath' to a tar 'LinkTarget'. This may fail if the+instance NFData LinkTarget where+    rnf (LinkTarget bs) = rnf bs++-- | Convert a native 'FilePath' to a tar t'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 (toPosixString 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)++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 t'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 t'LinkTarget' to a native 'FilePath'.+fromLinkTarget :: LinkTarget -> FilePath+fromLinkTarget (LinkTarget pathbs) = fromFilePathToNative $ fromPosixString pathbs++-- | Convert a tar t'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) = fromPosixString pathbs --- | Convert a tar 'LinkTarget' to a Windows 'FilePath'.---+-- | Convert a tar t'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 $ fromPosixString 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 ones use 'GenEntries' t'TarPath' t'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.@@ -459,21 +615,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 content tarPath linkTarget e+  = Next (GenEntry content tarPath linkTarget) (GenEntries content 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 LBS.ByteString TarPath LinkTarget e++-- | This is like the standard 'Data.List.unfoldr' function on lists, but for 'Entries'. -- It includes failure as an extra possibility that the stepper function may -- 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 content tarPath linkTarget, a)))+  -> a+  -> GenEntries content tarPath linkTarget e unfoldEntries f = unfold   where     unfold x = case f x of@@ -481,203 +652,86 @@       Right Nothing        -> Done       Right (Just (e, x')) -> Next e (unfold x') --- | This is like the standard 'foldr' function on lists, but for 'Entries'.--- Compared to 'foldr' it takes an extra function to account for the+unfoldEntriesM+  :: Monad m+  => (forall a. m a -> m a)+  -- ^ id or unsafeInterleaveIO+  -> m (Either e (Maybe (GenEntry content tarPath linkTarget)))+  -> m (GenEntries content tarPath linkTarget e)+unfoldEntriesM interleave f = unfold+  where+    unfold = do+      f' <- f+      case f' of+        Left err       -> pure $ Fail err+        Right Nothing  -> pure Done+        Right (Just e) -> Next e <$> interleave unfold++-- | This is like the standard 'Data.List.foldr' function on lists, but for 'Entries'.+-- Compared to 'Data.List.foldr' it takes an extra function to account for the -- possibility of failure. -- -- 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 content tarPath linkTarget -> a -> a)+  -> a+  -> (e -> a)+  -> GenEntries content tarPath linkTarget e -> a foldEntries next done fail' = fold   where     fold (Next e es) = next e (fold es)     fold Done        = done     fold (Fail err)  = fail' err --- | A 'foldl'-like function on Entries. It either returns the final+-- | A 'Data.List.foldl'-like function on Entries. It either returns the final -- 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 content tarPath linkTarget -> a)+  -> a+  -> GenEntries content 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     go !acc (Fail err)  = Left (err, acc) --- | This is like the standard 'map' function on lists, but for 'Entries'. It+-- | This is like the standard 'Data.List.map' function on lists, but for 'Entries'. It -- includes failure as a extra possible outcome of the mapping function. -- -- 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 content tarPath linkTarget -> Either e' (GenEntry content tarPath linkTarget))+  -- ^ Function to apply to each entry+  -> GenEntries content tarPath linkTarget e+  -- ^ Input sequence+  -> GenEntries content 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 content tarPath linkTarget -> GenEntry content tarPath linkTarget)+  -> GenEntries content tarPath linkTarget e+  -> GenEntries content tarPath linkTarget e mapEntriesNoFail f =-  foldEntries (\entry -> Next (f entry)) Done Fail+  foldEntries (Next . f) Done Fail -instance Monoid (Entries e) where-  mempty      = Done-  mappend a b = foldEntries Next b Fail a+-- | @since 0.5.1.0+instance Sem.Semigroup (GenEntries content tarPath linkTarget e) where+  a <> b = foldEntries Next b Fail a -instance Functor Entries where-  fmap f = foldEntries Next Done (Fail . f)+instance Monoid (GenEntries content tarPath linkTarget e) where+  mempty  = Done+  mappend = (Sem.<>) -instance NFData e => NFData (Entries e) where+instance (NFData tarPath, NFData content, NFData linkTarget, NFData e) => NFData (GenEntries content tarPath linkTarget e) where   rnf (Next e es) = rnf e `seq` rnf es   rnf  Done       = ()   rnf (Fail e)    = rnf e------------------------------- QuickCheck instances-----#ifdef TESTS--instance Arbitrary Entry where-  arbitrary = Entry <$> arbitrary <*> arbitrary <*> arbitraryPermissions-                    <*> arbitrary <*> arbitraryEpochTime <*> arbitrary-    where-      arbitraryPermissions :: Gen Permissions-      arbitraryPermissions = fromIntegral <$> (arbitraryOctal 7 :: Gen Int)--      arbitraryEpochTime :: Gen EpochTime-      arbitraryEpochTime = fromIntegral <$> (arbitraryOctal 11 :: Gen Int)--  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-      name = listOf0ToN 32 (arbitrary `suchThat` (/= '\0'))-      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-
Codec/Archive/Tar/Unpack.hs view
@@ -1,9 +1,19 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++{-# OPTIONS_HADDOCK hide #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Use for_" #-}+{-# HLINT ignore "Avoid restricted function" #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Codec.Archive.Tar -- Copyright   :  (c) 2007 Bjorn Bringert, --                    2008 Andrea Vezzosi,---                    2008-2009 Duncan Coutts+--                    2008-2009, 2012, 2016 Duncan Coutts -- License     :  BSD3 -- -- Maintainer  :  duncan@community.haskell.org@@ -12,20 +22,52 @@ ----------------------------------------------------------------------------- module Codec.Archive.Tar.Unpack (   unpack,+  unpackAndCheck,   ) where  import Codec.Archive.Tar.Types import Codec.Archive.Tar.Check+import Codec.Archive.Tar.LongNames+import Codec.Archive.Tar.PackAscii (filePathToOsPath) +import Data.Bits+         ( testBit )+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+import Prelude hiding (writeFile)+import System.File.OsPath+import System.OsPath+         ( OsPath, (</>) )+import qualified System.OsPath as FilePath.Native          ( takeDirectory )-import System.Directory-         ( createDirectoryIfMissing, copyFile )+import System.Directory.OsPath+    ( createDirectoryIfMissing,+      copyFile,+      setPermissions,+      listDirectory,+      doesDirectoryExist,+      createDirectoryLink,+      createFileLink,+      setModificationTime,+      emptyPermissions,+      setOwnerReadable,+      setOwnerWritable,+      setOwnerExecutable,+      setOwnerSearchable ) import Control.Exception-         ( Exception, throwIO )+         ( 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, SomeException(..) )+import qualified Data.ByteString.Lazy as BL  -- | Create local files and directories based on the entries of a tar archive. --@@ -42,54 +84,227 @@ -- 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 'Codec.Archive.Tar.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.+-- > import Control.Exception (SomeException(..))+-- > import Control.Applicative ((<|>))+-- >+-- > 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 BL.ByteString FilePath FilePath -> Maybe SomeException)+  -- ^ Checks to run on each entry before unpacking+  -> FilePath+  -- ^ Base directory+  -> Entries e+  -- ^ Entries to upack+  -> IO ()+unpackAndCheck secCB (filePathToOsPath -> 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+                  => [(OsPath, OsPath, Bool)]+                  -- ^ links (path, link, isHardLink)+                  -> GenEntries BL.ByteString FilePath FilePath (Either e DecodeLongNamesError)+                  -- ^ entries+                  -> IO [(OsPath, OsPath, 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-                        >> unpackEntries links es-      Directory         -> extractDir path-                        >> 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+    unpackEntries links (Next entry es) = do+      case secCB entry of+        Nothing -> pure ()+        Just e -> throwIO e -    extractFile path content = 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 -> FilePath -> BS.ByteString -> EpochTime -> IO ()+    extractFile permissions (filePathToNativeOsPath -> path) content mtime = do       -- Note that tar archives do not make sure each directory is created       -- before files they contain, indeed we may have to create several       -- levels of directory.       createDirectoryIfMissing True absDir-      BS.writeFile absPath content+      writeFile absPath content+      setOwnerPermissions absPath permissions+      setModTime absPath mtime       where         absDir  = baseDir </> FilePath.Native.takeDirectory path         absPath = baseDir </> path -    extractDir path = createDirectoryIfMissing True (baseDir </> path)+    extractDir :: FilePath -> EpochTime -> IO ()+    extractDir (filePathToNativeOsPath -> 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+      :: t+      -> FilePath+      -> FilePath+      -> [(OsPath, OsPath, t)]+      -> [(OsPath, OsPath, t)]+    saveLink isHardLink (filePathToNativeOsPath -> path) (filePathToNativeOsPath -> link) =+      path `seq` link `seq` ((path, link, isHardLink) :) -    emulateLinks = mapM_ $ \(relPath, relLinkTarget) ->+    -- for hardlinks, we just copy+    handleHardLinks :: [(OsPath, OsPath, t)] -> IO ()+    handleHardLinks = mapM_ $ \(relPath, relLinkTarget, _) ->       let absPath   = baseDir </> relPath+          -- hard links link targets are always "absolute" paths in+          -- 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 :: [(OsPath, OsPath, c)] -> IO ()+    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+                 )++filePathToNativeOsPath :: FilePath -> OsPath+filePathToNativeOsPath = filePathToOsPath . fromFilePathToNative++-- | Recursively copy the contents of one directory to another path.+--+-- This is a rip-off of Cabal library.+copyDirectoryRecursive :: OsPath -> OsPath -> 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 :: (OsPath -> OsPath -> IO ())+                  -> OsPath -> [(OsPath, OsPath)] -> 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 :: OsPath -> IO [OsPath]+    getDirectoryContentsRecursive topdir = recurseDirectories [mempty]+      where+        recurseDirectories :: [OsPath] -> IO [OsPath]+        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 :: OsPath -> EpochTime -> IO ()+setModTime path t =+    setModificationTime path (posixSecondsToUTCTime (fromIntegral t))+      `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 :: OsPath -> 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
Codec/Archive/Tar/Write.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_HADDOCK hide #-}+{- HLINT ignore "Avoid restricted function" -} ----------------------------------------------------------------------------- -- | -- Module      :  Codec.Archive.Tar.Write@@ -10,20 +13,34 @@ -- Portability :  portable -- ------------------------------------------------------------------------------module Codec.Archive.Tar.Write (write) where+module Codec.Archive.Tar.Write+  ( write+  , writeEntry+  , write'+  , writeEntry'+  , writeTrailer+  ) where +import Codec.Archive.Tar.PackAscii import Codec.Archive.Tar.Types+import Codec.Archive.Tar.Pack (defaultRead) -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)+import System.IO.Unsafe (unsafeInterleaveIO)+import System.OsPath+         ( OsPath )  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.Lazy.Char8  as LBS.Char8-+import "os-string" System.OsString.Posix (PosixString)+import qualified "os-string" System.OsString.Posix as PS  -- | Create the external representation of a tar archive by serialising a list -- of tar entries.@@ -31,11 +48,43 @@ -- * The conversion is done lazily. -- write :: [Entry] -> LBS.ByteString-write es = LBS.concat $ map putEntry es ++ [LBS.replicate (512*2) 0]+write es = LBS.concat $ map writeEntry es ++ [writeTrailer] -putEntry :: Entry -> LBS.ByteString-putEntry entry = case entryContent entry of-  NormalFile       content size -> LBS.concat [ header, content, padding size ]+-- | Like 'write' but for 'GenEntry' with 'OsPath' as contents.+--+-- @since 0.7.0.0+write' :: [GenEntry OsPath TarPath LinkTarget] -> IO LBS.ByteString+write' es = interleavedByteStringConcat $ map writeEntry' es ++ [pure writeTrailer]++-- | Standard TAR trailer of two empty blocks, put it at the end of any archive.+--+-- @since 0.7.1.0+writeTrailer :: LBS.ByteString+writeTrailer = LBS.replicate (512*2) 0++interleavedByteStringConcat :: [IO LBS.ByteString] -> IO LBS.ByteString+interleavedByteStringConcat [] = return LBS.empty+interleavedByteStringConcat (x:xs) = do+  y <- x+  ys <- unsafeInterleaveIO (interleavedByteStringConcat xs)+  return (LBS.append y ys)++-- | Convert an entry to its representation in TAR format.+--+-- @since 0.7.1.0+writeEntry :: Entry -> LBS.ByteString+writeEntry entry = case entryContent entry of+  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 "writeEntry: support for files over 8Gb is a Ustar extension"+    | otherwise -> LBS.concat [ header, content, padding size ]+  OtherEntryType 'K' _ _+    | entryFormat entry /= GnuFormat -> error "writeEntry: long symlink support is a GNU extension"+  OtherEntryType 'L' _ _+    | entryFormat entry /= GnuFormat -> error "writeEntry: long filename support is a GNU extension"   OtherEntryType _ content size -> LBS.concat [ header, content, padding size ]   _                             -> header   where@@ -43,19 +92,38 @@     padding size = LBS.replicate paddingSize 0       where paddingSize = fromIntegral (negate size `mod` 512) +-- | Convert an entry to its representation in TAR format.+--+-- @since 0.7.1.0+writeEntry' :: GenEntry OsPath TarPath LinkTarget -> IO LBS.ByteString+writeEntry' entry' = do+  entryContent' <- case entryContent entry' of+    NormalFile path size -> do+      content <- defaultRead size path+      return $ NormalFile content size++    Directory -> return Directory+    SymbolicLink linkTarget -> return (SymbolicLink linkTarget)+    HardLink linkTarget -> return (HardLink linkTarget)+    CharacterDevice devMajor devMinor -> return (CharacterDevice devMajor devMinor)+    BlockDevice devMajor devMinor -> return (BlockDevice devMajor devMinor)+    NamedPipe -> return NamedPipe+    OtherEntryType typeCode lbs fileSize -> return (OtherEntryType typeCode lbs fileSize)++  return (writeEntry entry' { entryContent = entryContent' })+ putHeader :: Entry -> LBS.ByteString putHeader entry =-     LBS.Char8.pack-   $ take 148 block-  ++ putOct 7 checksum-  ++ ' ' : drop 156 block---  ++ putOct 8 checksum---  ++ drop 156 block+     LBS.fromStrict+   $ BS.take 148 block+  <> putOct 7 checksum+  <> BS.cons 0x20 (BS.drop 156 block)   where     block    = putHeaderNoChkSum entry-    checksum = foldl' (\x y -> x + ord y) 0 block+    checksum :: Int+    checksum = BS.foldl' (\x y -> x + fromIntegral y) 0 block -putHeaderNoChkSum :: Entry -> String+putHeaderNoChkSum :: Entry -> BS.ByteString putHeaderNoChkSum Entry {     entryTarPath     = TarPath name prefix,     entryContent     = content,@@ -65,39 +133,46 @@     entryFormat      = format   } = -  concat-    [ putBString 100 $ name-    , putOct       8 $ permissions+  BS.concat+    [ putPosixString 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+    , BS.replicate 8 0x20 -- dummy checksum+    , putChar8       typeCode+    , putPosixString 100 linkTarget+    ] <>   case format of   V7Format    ->-      fill 255 '\NUL'-  UstarFormat -> concat-    [ putBString   8 $ ustarMagic+      BS.replicate 255 0x00+  UstarFormat -> BS.concat+    [ 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+    , putPosixString 155 prefix+    , BS.replicate   12 0x00     ]-  GnuFormat -> concat-    [ putBString   8 $ gnuMagic+  GnuFormat -> BS.concat+    [ 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+    , putPosixString 155 prefix+    , BS.replicate   12 0x00     ]   where+    numField :: FieldWidth -> Int64 -> BS.ByteString+    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)@@ -112,32 +187,37 @@     putGnuDev w n = case content of       CharacterDevice _ _ -> putOct w n       BlockDevice     _ _ -> putOct w n-      _                   -> replicate w '\NUL'+      _                   -> BS.replicate w 0x00  ustarMagic, gnuMagic :: BS.ByteString-ustarMagic = BS.Char8.pack "ustar\NUL00"-gnuMagic   = BS.Char8.pack "ustar  \NUL"+ustarMagic = BS.pack [0x75, 0x73, 0x74, 0x61, 0x72, 0x00, 0x30, 0x30]  -- ustar\NUL00+gnuMagic   = BS.pack [0x75, 0x73, 0x74, 0x61, 0x72, 0x20, 0x20, 0x00]  -- ustar  \NUL  -- * TAR format primitive output  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 :: FieldWidth -> BS.ByteString -> BS.ByteString+putBString n s = BS.take n s <> BS.replicate (n - BS.length s) 0x00 -putString :: FieldWidth -> String -> String-putString n s = take n s ++ fill (n - length s) '\NUL'+putPosixString :: FieldWidth -> PosixString -> BS.ByteString+putPosixString n s = posixToByteString (PS.take n s) <> BS.replicate (n - PS.length s) 0x00 ---TODO: check integer widths, eg for large file sizes-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'-   ++ octStr-   ++ putChar8 '\NUL'+putString :: FieldWidth -> String -> BS.ByteString+putString n s = BS.take n (packLatin1 s) <> BS.replicate (n - length s) 0x00 -putChar8 :: Char -> String-putChar8 c = [c]+{-# SPECIALISE putLarge :: FieldWidth -> Int64 -> BS.ByteString #-}+putLarge :: (Bits a, Integral a) => FieldWidth -> a -> BS.ByteString+putLarge n0 x0 = BS.Char8.pack $ '\x80' : reverse (go (n0-1) x0)+  where go 0 _ = []+        go n x = chr (fromIntegral (x .&. 0xff)) : go (n-1) (x `shiftR` 8) -fill :: FieldWidth -> Char -> String-fill n c = replicate n c+putOct :: (Integral a, Show a) => FieldWidth -> a -> BS.ByteString+putOct n x =+  let octStr = BS.take (n-1) $ BS.Char8.pack $ showOct x ""+   in BS.replicate (n - BS.length octStr - 1) 0x30+   <> octStr+   <> BS.singleton 0x00++putChar8 :: Char -> BS.ByteString+putChar8 = BS.Char8.singleton
+ README.md view
@@ -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+```
bench/Main.hs view
@@ -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,24 @@    , 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)++  , env (fmap TarIndex.serialise  loadTarIndex) $ \tarfile ->+      bench "deserialise index" (nf TarIndex.deserialise tarfile)   ]  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 =
changelog.md view
@@ -1,16 +1,141 @@-0.4.5.0 Duncan Coutts <duncan@community.haskell.org> January 2016+## 0.7.2.0 Bodigrim <andrew.lelechenko@gmail.com> July 2026 +  * Allow writing entries with strings containing the entire set of Latin-1 encoding,+    so that at least we can write any entry we can read.++## 0.7.1.0 Bodigrim <andrew.lelechenko@gmail.com> April 2026++  * Support long file paths and symlinks in PAX format.+  * Export `writeEntry`, `writeEntry'` and `writeTrailer`.++## 0.7.0.0 Bodigrim <andrew.lelechenko@gmail.com> September 2025++  This release fixes a long-standing issue with exhaustion of file handles+  (thanks to Oleg Grenrus).++  * Extend `GenEntries` with yet another type argument for file contents.+  * Add `write' :: [GenEntry OsPath TarPath LinkTarget] -> IO LazyByteString`.+  * Add `pack' :: FilePath -> [FilePath] -> IO [GenEntry OsPath TarPath LinkTarget]`.++## 0.6.4.0 Bodigrim <andrew.lelechenko@gmail.com> January 2025++  * Migrate internals of packing / unpacking to `OsPath`.+  * Use `getDirectoryContentsRecursive` from `directory-ospath-streaming`.++## 0.6.3.0 Bodigrim <andrew.lelechenko@gmail.com> June 2024++  * [Speed up `deserialize`](https://github.com/haskell/tar/pull/95).++## 0.6.2.0 Bodigrim <andrew.lelechenko@gmail.com> March 2024++  * Fix issues with Unicode support in filenames.++## 0.6.1.0 Bodigrim <andrew.lelechenko@gmail.com> January 2024++  * Support Unicode in filenames (encoded as UTF-8).+  * Reduce peak memory consumption when unpacking large files.++## 0.6.0.0 Bodigrim <andrew.lelechenko@gmail.com> December 2023++  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 (Entry, pattern Entry)` and similar for other `Gen`-types.+      Another option is to import the entire module qualified.+  * 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`.++  Examples of migration:++  * [`hackage-security`](https://github.com/haskell/hackage-security/commit/24693ce115c9769fe3c6ec9ca1d137d14d0d27ff)+  * [`archive-backpack`](https://github.com/vmchale/archive-backpack/commit/4b3d1bdff15fcf044d6171ca649a930c775d491b)+  * [`keter`](https://github.com/snoyberg/keter/commit/20a33d9276d5781ca6993b857d8d097085983ede)+  * [`libarchive`](https://github.com/vmchale/libarchive/commit/c0e101fede924a6e12f1d726587626c48444e65d)+  * [`cabal-install`](https://github.com/haskell/cabal/commit/51e6483f95ecb4f395dce36e47af296902a75143)+  * [`ghcup`](https://github.com/haskell/ghcup-hs/commit/6ae312c1f9dd054546e4afe4c969c37cd54b09a9)+  * [`hackage-server`](https://github.com/haskell/hackage-server/commit/6b71d1659500aba50b6a1e48aa53039046720af8)+  * [`hedgehog-extras`](https://github.com/input-output-hk/hedgehog-extras/commit/1d4468ce4e74e7a4b3c1fec5c1b21360051a3e72)++  Bug fixes:++  * Add support for over-long filepaths via GNU extension.+    * Now `entryPath` corresponds to an internal, low-level path, limited+      to 255 characters. To list filenames properly use `decodeLongNames`,+      followed by `entryTarPath`.+  * 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++  * 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++  * 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++  * 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++  * Fix compatability with directory-1.2.3+++## 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+   * 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@@ -21,32 +146,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
tar.cabal view
@@ -1,10 +1,11 @@+cabal-version:   2.2 name:            tar-version:         0.4.5.0-license:         BSD3+version:         0.7.2.0+license:         BSD-3-Clause 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>@@ -12,97 +13,131 @@ synopsis:        Reading, writing and manipulating ".tar" archive files. description:     This library is for working with \"@.tar@\" archive files. It                  can read and write a range of common variations of archive-                 format including V7, USTAR, POSIX and GNU formats. It provides-                 support for packing and unpacking portable archives. This-                 makes it suitable for distribution but not backup because-                 details like file ownership and exact permissions are not-                 preserved.+                 format including V7, POSIX USTAR and GNU formats.+                 .+                 It provides support for packing and unpacking portable+                 archives. This makes it suitable for distribution but not+                 backup because details like file ownership and exact+                 permissions are not preserved.+                 .+                 It also provides features for random access to archive+                 content using an index. build-type:      Simple-cabal-version:   >=1.8-extra-source-files: changelog.md-tested-with:     GHC ==7.4.2, GHC ==7.6.3, GHC ==7.8.4, GHC ==7.10.2+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.14.1, GHC==9.12.4, GHC==9.10.3, GHC==9.8.4,+                 GHC==9.6.7, GHC==9.4.8, GHC==9.2.8, GHC==9.0.2,+                 GHC==8.10.7, GHC==8.8.4, GHC==8.6.5  source-repository head   type: git   location: https://github.com/haskell/tar.git -flag old-time-  default: False- library-  build-depends: base == 4.*,-                 bytestring >= 0.10,-                 filepath,-                 directory,-                 array,-                 containers >= 0.4.2,-                 deepseq >= 1.1 && < 1.5-  if flag(old-time)-    build-depends: directory < 1.2, old-time-  else-    build-depends: directory >= 1.2, time+  default-language: Haskell2010+  build-depends: tar-internal +  reexported-modules:+    Codec.Archive.Tar,+    Codec.Archive.Tar.Entry,+    Codec.Archive.Tar.Check,+    Codec.Archive.Tar.Index++library tar-internal+  default-language: Haskell2010+  build-depends: base       >= 4.12  && < 5,+                 array                 < 0.6,+                 bytestring >= 0.10 && < 0.13,+                 containers >= 0.2  && < 0.9,+                 deepseq    >= 1.1  && < 1.6,+                 directory  >= 1.3.8.0 && < 1.4,+                 directory-ospath-streaming >= 0.2.1 && < 0.4,+                 file-io                < 0.3,+                 filepath   >= 1.4.100 && < 1.6,+                 os-string  >= 2.0 && < 2.1,+                 time                  < 1.17,+                 transformers          < 0.7,+   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+    Codec.Archive.Tar.Index.Internal+    Codec.Archive.Tar.Index.Utils    other-extensions:-    CPP, BangPatterns,-    DeriveDataTypeable, ScopedTypeVariables+    BangPatterns+    CPP+    GeneralizedNewtypeDeriving+    PatternGuards+    ScopedTypeVariables    ghc-options: -Wall -fno-warn-unused-imports  test-suite properties   type:          exitcode-stdio-1.0-  build-depends: base,-                 bytestring,-                 filepath, directory,+  default-language: Haskell2010+  build-depends: base < 5,                  array,+                 bytestring >= 0.10,                  containers,                  deepseq,-                 old-time, time,-                 bytestring-handle,-                 QuickCheck == 2.*,-                 tasty            >= 0.10 && <0.12,-                 tasty-quickcheck == 0.8.*+                 directory >= 1.2,+                 directory-ospath-streaming,+                 file-embed,+                 filepath,+                 QuickCheck       == 2.*,+                 tar-internal,+                 tasty            >= 0.10 && <1.6,+                 tasty-quickcheck >= 0.8  && <1,+                 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+    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, BangPatterns,-    DeriveDataTypeable, ScopedTypeVariables+    CPP+    BangPatterns,+    ScopedTypeVariables    ghc-options: -fno-ignore-asserts  benchmark bench   type:          exitcode-stdio-1.0-  hs-source-dirs: . bench-  main-is:       bench/Main.hs-  build-depends: base,-                 bytestring,-                 filepath, directory,-                 array,-                 containers,-                 deepseq,-                 old-time, time,-                 criterion >= 1.0-+  default-language: Haskell2010+  hs-source-dirs: bench+  main-is:       Main.hs+  build-depends: base < 5,+                 tar,+                 bytestring >= 0.10,+                 directory >= 1.2,+                 temporary < 1.4,+                 tasty-bench >= 0.4 && < 0.6
+ test/Codec/Archive/Tar/Index/IntTrie/Tests.hs view
@@ -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
+ test/Codec/Archive/Tar/Index/StringTable/Tests.hs view
@@ -0,0 +1,89 @@+{-# 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 = case lookup tbl str of+      Nothing -> property False+      Just ident -> index tbl ident === 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 (drop 1 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) [lo .. hi - 1]+  where+    (lo, hi) = A.bounds offsets++enumIds :: Enum id => StringTable id -> [id]+enumIds (StringTable _ offsets _ _) =+  [toEnum (fromIntegral lo) .. toEnum (fromIntegral (hi - 1))]+  where+    (lo, hi) = A.bounds offsets
+ test/Codec/Archive/Tar/Index/Tests.hs view
@@ -0,0 +1,278 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-}+-----------------------------------------------------------------------------+-- |+-- 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+import Data.Monoid ((<>))+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.Bifunctor (first)+import Data.List (nub, sort, sortBy, stripPrefix, isPrefixOf, uncons)+import qualified Data.List.NonEmpty as NE+import Data.Maybe+import Data.Function (on)+import Control.Exception (SomeException, try, throwIO)++#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)          ->+      fmap NE.head (NE.group (sort (map fst entries))) ===+        fmap NE.head (NE.group (sort completions))+    _                                              -> property False+  where+    index = construct paths+    completions = map fst $+      mapMaybe (uncons . FilePath.splitDirectories) $+        mapMaybe (stripPrefix (p ++ "/") . fst) paths++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 (first (map (\(Tar.PathComponentId n) -> IntTrie.Key (fromIntegral n)))) $+        mapMaybe (\(path, (_size, offset)) -> (, IntTrie.Value offset) <$> Tar.toComponentIds pathTable path) paths++    prop' = conjoin $ flip map paths $ \(file, (_size, offset)) ->+      case Tar.lookup index file of+        Just (TarFileEntry offset') -> offset' === offset+        _                           -> 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 = case Tar.toTarPath False name of+  Left err -> error err+  Right path -> Tar.simpleEntry path (NormalFile mempty size)++-- | Simple tar archive containing regular files only+data SimpleTarArchive = SimpleTarArchive {+    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) = case Tar.toTarPath False fp of+        Left err -> error err+        Right path -> entry : mkList es+          where+            entry   = Tar.simpleEntry path content+            content = NormalFile bs (LBS.length bs)++      mkEntries :: [Tar.Entry] -> Tar.Entries ()+      mkEntries []     = Tar.Done+      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+        ]++-- | t'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
+ test/Codec/Archive/Tar/Pack/Tests.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Avoid restricted function" #-}++module Codec.Archive.Tar.Pack.Tests+  ( prop_roundtrip+  , unit_roundtrip_unicode+  , 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.Char+import Data.FileEmbed+import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Pack as Pack+import Codec.Archive.Tar.PackAscii (filePathToOsPath)+import qualified Codec.Archive.Tar.Read as Read+import Codec.Archive.Tar.Types (GenEntries(..), Entries, simpleEntry, toTarPath, GenEntry (entryTarPath))+import qualified Codec.Archive.Tar.Unpack as Unpack+import qualified Codec.Archive.Tar.Write as Write+import Control.Exception+import qualified Data.List as L+import Data.List.NonEmpty (NonEmpty(..))+import GHC.IO.Encoding+import System.Directory+import System.Directory.OsPath.Streaming (getDirectoryContentsRecursive)+import System.FilePath+import qualified System.FilePath.Posix as Posix+import qualified System.Info+import System.IO.Temp+import System.IO.Unsafe+import Test.Tasty.QuickCheck++supportsUnicode :: Bool+supportsUnicode = unsafePerformIO $ do+  -- Normally getFileSystemEncoding returns a Unicode encoding,+  -- but if it is ASCII, we should not generate Unicode filenames.+  enc <- getFileSystemEncoding+  pure $ case textEncodingName enc of+    "ASCII"          -> False+    "ANSI_X3.4-1968" -> False+    _                -> True+{-# NOINLINE supportsUnicode #-}++-- | Write a single file, deeply buried within nested folders;+-- pack and unpack; read back and compare results.+prop_roundtrip :: Int -> [String] -> String -> Property+prop_roundtrip n' xss cnt+  | x : xs <- filter (not . null) $ map mkFilePath xss+  = ioProperty $ withSystemTempDirectory "tar-test" $ \baseDir -> do+    file : dirs <- pure $ trimUpToMaxPathLength baseDir (x : xs)++    let relDir = joinPath dirs+        absDir = baseDir </> relDir+        relFile = relDir </> file+        absFile = absDir </> file+        n       = n' `mod` (length dirs + 1)+        (target, expectedFileNames) = case n of+          0 -> (relFile, [relFile])+          _ -> (joinPath $ take (n - 1) dirs,+            map (addTrailingPathSeparator . joinPath)+              (drop (max 1 (n - 1)) $ L.inits dirs) ++ [relFile])+        errMsg = "relDir  = '" ++ relDir ++ "'" +++               "\nabsDir  = '" ++ absDir ++ "'" +++               "\nrelFile = '" ++ relFile ++ "'" +++               "\nabsFile = '" ++ absFile ++ "'" +++               "\ntarget  = '" ++ target ++ "'"++    -- Not all filesystems allow paths to contain arbitrary Unicode.+    -- E. g., at the moment of writing Apple FS does not support characters+    -- introduced in Unicode 15.0.+    canCreateDirectory <- try (createDirectoryIfMissing True absDir)+    case canCreateDirectory of+      Left (e :: IOException) -> discard+      Right () -> do+        canWriteFile <- try (writeFile absFile cnt)+        case canWriteFile of+          Left (e :: IOException) -> discard+          Right () -> counterexample errMsg <$> do+            -- Forcing the result, otherwise lazy IO misbehaves.+            !entries <- Pack.pack baseDir [target] >>= evaluate . force++            let fileNames+                  = map (map (\c -> if c == Posix.pathSeparator then pathSeparator else c))+                  $ Tar.foldEntries ((:) . entryTarPath) [] undefined+                  -- decodeLongNames produces FilePath with POSIX path separators+                  $ Tar.decodeLongNames $ foldr Next Done entries++            if expectedFileNames /= fileNames then pure (expectedFileNames === fileNames) else do++              -- 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)+              exist <- doesFileExist absFile+              if exist then do+                cnt' <- readFile absFile >>= evaluate . force+                pure $ cnt === cnt'+              else do+                -- Forcing the result, otherwise lazy IO misbehaves.+                recFiles <- getDirectoryContentsRecursive (filePathToOsPath baseDir) >>= evaluate . force+                pure $ counterexample ("File " ++ absFile ++ " does not exist; instead found\n" ++ unlines (map show recFiles)) False++  | otherwise = discard++mkFilePath :: String -> FilePath+mkFilePath xs = makeValid $ filter isGood $+  map (if supportsUnicode then id else chr . (`mod` 128) . ord) xs+  where+    isGood c+      = not (isPathSeparator c)+      && c `notElem` [' ', '\n', '\r', '.', ':']+      && generalCategory c /= Surrogate+      && (supportsUnicode || isAscii c)++trimUpToMaxPathLength :: FilePath -> [FilePath] -> [FilePath]+trimUpToMaxPathLength baseDir = go (maxPathLength - utf8Length baseDir - 1)+  where+    go :: Int -> [FilePath] -> [FilePath]+    go cnt [] = []+    go cnt (x : xs)+      | cnt < 4 = []+      | cnt <= utf8Length x = [take (cnt `quot` 4) x]+      | otherwise = x : go (cnt - utf8Length x - 1) xs++utf8Length :: String -> Int+utf8Length = sum . map charLength+  where+    charLength c+      | c < chr 0x80 = 1+      | c < chr 0x800 = 2+      | c < chr 0x10000 = 3+      | otherwise = 4++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++unit_roundtrip_unicode :: Property+unit_roundtrip_unicode = do+  ioProperty $ withSystemTempDirectory "tar-test" $ \baseDir -> do+    let relFile = "TModula𐐀bA.hs"++    canWriteFile <- try (writeFile (baseDir </> relFile) "foo")+    case canWriteFile of+      Left (e :: IOException) -> pure $ property True+      Right () -> do+        entries <- Pack.pack baseDir [relFile]+        pure $ case Tar.foldlEntries (flip seq) () (Read.read (Write.write entries)) of+          Right{} -> property True+          Left (err, _) -> counterexample (show err) $ property False
+ test/Codec/Archive/Tar/Tests.hs view
@@ -0,0 +1,58 @@+{-# 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 = case toTarPath False "Large.file" of+  Left{} -> property False+  Right fn -> case read tar of+    Next entry' _ -> case entryContent entry' of+      NormalFile _ sz' -> sz === sz'+      _ -> property False+    _ -> property False+    where+      sz = fromIntegral $ n * 1024 * 1024 * 128+      entry = simpleEntry fn (NormalFile (BL.replicate sz 42) sz)+      -- Trim the tail so it does not blow up RAM+      tar = BL.take 2048 $ write [entry]
+ test/Codec/Archive/Tar/Types/Tests.hs view
@@ -0,0 +1,228 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Codec.Archive.Tar.Types.Tests+-- Copyright   :  (c) 2007 Bjorn Bringert,+--                    2008 Andrea Vezzosi,+--                    2008-2009 Duncan Coutts+--                    2011 Max Bolingbroke+-- License     :  BSD3+--+-----------------------------------------------------------------------------+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}++module Codec.Archive.Tar.Types.Tests+  ( limitToV7FormatCompat+  , prop_fromTarPath+  , prop_fromTarPathToPosixPath+  , prop_fromTarPathToWindowsPath+  ) where++import Codec.Archive.Tar.PackAscii+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 $ posixToByteString namebs+    prefix = BS.Char8.unpack $ posixToByteString 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 $ posixToByteString namebs+    prefix = BS.Char8.unpack $ posixToByteString 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 $ posixToByteString namebs+    prefix = BS.Char8.unpack $ posixToByteString prefixbs+    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name+                    = FilePath.Windows.addTrailingPathSeparator+                    | otherwise = id++instance (Arbitrary tarPath, Arbitrary linkTarget, content ~ LBS.ByteString) => Arbitrary (GenEntry content 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, content ~ LBS.ByteString) => Arbitrary (GenEntryContent content 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 mempty+    }+limitToV7FormatCompat entry = entry
+ test/Codec/Archive/Tar/Unpack/Tests.hs view
@@ -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
test/Properties.hs view
@@ -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,16 +18,24 @@   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" [         testProperty "construction" StringTable.prop_valid,         testProperty "sorted"       StringTable.prop_sorted,         testProperty "serialise"    StringTable.prop_serialise_deserialise,+        testProperty "size"         StringTable.prop_serialiseSize,         testProperty "unfinalise"   StringTable.prop_finalise_unfinalise       ] @@ -36,6 +47,7 @@         testProperty "completions" IntTrie.prop_completions_mono,         testProperty "toList"      IntTrie.prop_construct_toList,         testProperty "serialise"   IntTrie.prop_serialise_deserialise,+        testProperty "size"        IntTrie.prop_serialiseSize,         testProperty "unfinalise"  IntTrie.prop_finalise_unfinalise       ] @@ -44,8 +56,23 @@         testProperty "valid"       Index.prop_valid,         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" [+      adjustOption (\(QuickCheckMaxRatio n) -> QuickCheckMaxRatio (max n 100)) $+      testProperty "roundtrip" Pack.prop_roundtrip,+      testProperty "unicode" Pack.unit_roundtrip_unicode,+      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+      ]+    ]
+ test/data/long-filepath.tar view

binary file changed (absent → 20480 bytes)

+ test/data/long-symlink.tar view

binary file changed (absent → 5632 bytes)

+ test/data/symlink.tar view

binary file changed (absent → 3072 bytes)