tar-conduit 0.1.1 → 0.4.1
raw patch · 11 files changed
Files
- ChangeLog.md +70/−1
- src/Data/Conduit/Tar.hs +1127/−272
- src/Data/Conduit/Tar/Types.hs +172/−0
- src/Data/Conduit/Tar/Unix.hs +140/−0
- src/Data/Conduit/Tar/Windows.hs +79/−0
- tar-conduit.cabal +83/−19
- tests/Space.hs +116/−0
- tests/Spec.hs +436/−0
- tests/Time.hs +120/−0
- tests/files/libpq-0.3.tar.gz binary
- tests/files/subdir.tar binary
ChangeLog.md view
@@ -1,3 +1,73 @@+# ChangeLog for tar-conduit++## 0.4.1 - 2024-01-06++* Fix bug in the parsing of pax extended header data when provided in more than+ one sequential chunk [#37](https://github.com/snoyberg/tar-conduit/issues/37)++## 0.4.0 - 2023-08-07++* `untarChunks` and `untar` now provide partial support for the pax interchange+ format, by applying pax header blocks and certain keywords in pax extended+ headers. Exposes `applyPaxChunkHeaders`. Also exposes `untarChunksRaw` and+ `untarRaw`, which do not apply pax header blocks and extended headers.++## 0.3.2.1 - 2023-06-25++* `unix-2.8` compatibility [#32](https://github.com/snoyberg/tar-conduit/pull/32)++## 0.3.2 - 2019-01-14++* Create a prefix directory whenever a directory type entry is missing from the tarball itself. Fixes [#26](https://github.com/snoyberg/tar-conduit/issues/26).++## 0.3.1 - 2018-11-19+ * Fixed modification time restoration on Windows for read-only files [#25](https://github.com/snoyberg/tar-conduit/pull/25).++## 0.3.0 - 2018-08-28+ * Support for `FTHardLink` restoration, but not creation yet.+ * Restoring files made even more lenient with creation of full directory path if any parents of+ it are missing.++## 0.2.5 - 2018-08-28+ * Exported `untarWithExceptions`, `restoreFileIntoLenient`++## 0.2.4 - 2018-08-27+ * Use forward slashes on Windows too, see [issue #21](https://github.com/snoyberg/tar-conduit/issues/21)+ * Addition of `extractTarballLenient` and `restoreFileWithErrors`++## 0.2.3.1 - 2018-06-06+ * Fixed drops associated payload for unsupported headers ((https://github.com/snoyberg/tar-conduit/issues/17)) ([PR 18](https://github.com/snoyberg/tar-conduit/pull/18))+ * Dropped support for GHC 7/Stack LTS-2, LTS-3, LTS-6++## 0.2.3 - 2018-02-10++ * Fixed compatibility with new `conduit >= 1.3.0`++## 0.2.2 - 2018-02-06++ * Fixed proper unicode filepaths handling.+ * Fixed restoration of symbolic links.+ * Fixed restoring files with long names (>255), that use GNU tar format.+ * Utilizing GNU tar standard implemented support for long (>2097151) values of OwnerId, GroupId,+ DeviceMinor and DeviceMajor values, as well as (>8589934591) for FileSize and+ ModificationTime. Thus removing the 8GB size limitation, allowing negative timestamps and fixing+ compatibility with systems that use UID and GID in the higher range.+ * Expose `withFileInfo`.+ * Improved error reporting.++## 0.2.1 - 2018-02-03++ * Expose `untarChunks`++## 0.2.0 - 2018-01-23++ * Implemented tarball creation.+ * Introduced `FileInfo` datatype that makes it easier to work with archives by automatically+ handling tar specific blocks and applying them to `FileInfo`.+ * Full support for `ustar` format.+ * Support for GNU tar features: long file name. Discardes unsupported.+ * Helper tar/untar functions for dealing directly with the filesystem.+ ## 0.1.1 - 2017-05-31 * Allow checksums to have leading spaces ([PR 8](https://github.com/snoyberg/tar-conduit/pull/8))@@ -5,4 +75,3 @@ ## 0.1.0 - 2016-11-03 * Initial release-
src/Data/Conduit/Tar.hs view
@@ -1,272 +1,1127 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-| This module is about stream-processing tar archives. It is currently-not very well tested. See the documentation of 'withEntries' for an usage sample.--}-module Data.Conduit.Tar- ( -- * Basic functions- untar- , withEntry- , withEntries- -- * Helper functions- , headerFileType- , headerFilePath- -- * Types- , Header (..)- , TarChunk (..)- , TarException (..)- , Offset- , Size- , FileType (..)- ) where--import Conduit-import Control.Exception (Exception, assert)-import Control.Monad (unless)-import Data.ByteString (ByteString)-import Data.Typeable (Typeable)-import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Unsafe as BU-import System.Posix.Types (CMode)-import Data.Word (Word8)-import Data.Int (Int64)-import Data.ByteString.Short (ShortByteString, toShort, fromShort)-import Data.Monoid ((<>))--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<*))-#endif--data Header = Header- { headerOffset :: !Offset- , headerPayloadOffset :: !Offset- , headerFileNameSuffix :: !ShortByteString- , headerFileMode :: !CMode- , headerOwnerId :: !Int- , headerGroupId :: !Int- , headerPayloadSize :: !Size- , headerTime :: !Int64- , headerLinkIndicator :: !Word8- , headerOwnerName :: !ShortByteString- , headerGroupName :: !ShortByteString- , headerDeviceMajor :: !Int- , headerDeviceMinor :: !Int- , headerFileNamePrefix :: !ShortByteString- }- deriving Show--headerFilePath :: Header -> FilePath-headerFilePath h = S8.unpack $ fromShort- $ headerFileNamePrefix h <> headerFileNameSuffix h--data FileType- = FTNormal- | FTHardLink- | FTSymbolicLink- | FTCharacterSpecial- | FTBlockSpecial- | FTDirectory- | FTFifo- | FTOther !Word8- deriving (Show, Eq)--headerFileType :: Header -> FileType-headerFileType h =- case headerLinkIndicator h of- 0 -> FTNormal- 48 -> FTNormal- 49 -> FTHardLink- 50 -> FTSymbolicLink- 51 -> FTCharacterSpecial- 52 -> FTBlockSpecial- 53 -> FTDirectory- 54 -> FTFifo- x -> FTOther x--type Offset = Int-type Size = Int--data TarChunk- = ChunkHeader Header- | ChunkPayload !Offset !ByteString- | ChunkException TarException- deriving Show---- | This the the exception type that is used in this module.------ More constructors are susceptible to be added without bumping the major--- version of this module.-data TarException- = NoMoreHeaders- | UnexpectedPayload !Offset- | IncompleteHeader !Offset- | IncompletePayload !Offset !Size- | ShortTrailer !Offset- | BadTrailer !Offset- | InvalidHeader !Offset- | BadChecksum !Offset- deriving (Show, Typeable)-instance Exception TarException--parseHeader :: Offset -> ByteString -> Either TarException Header-parseHeader offset bs = assert (S.length bs == 512) $ do- let checksumBytes = S.take 8 $ S.drop 148 bs- expectedChecksum = parseOctal checksumBytes- actualChecksum = bsum bs - bsum checksumBytes + 8 * space- unless (actualChecksum == expectedChecksum) (Left (BadChecksum offset))- return Header- { headerOffset = offset- , headerPayloadOffset = offset + 512- , headerFileNameSuffix = getShort 0 100- , headerFileMode = getOctal 100 8- , headerOwnerId = getOctal 108 8- , headerGroupId = getOctal 116 8- , headerPayloadSize = getOctal 124 12- , headerTime = getOctal 136 12- , headerLinkIndicator = BU.unsafeIndex bs 156- , headerOwnerName = getShort 265 32- , headerGroupName = getShort 297 32- , headerDeviceMajor = getOctal 329 8- , headerDeviceMinor = getOctal 337 8- , headerFileNamePrefix = getShort 345 155- }- where- bsum :: ByteString -> Int- bsum = S.foldl' (\c n -> c + fromIntegral n) 0-- getShort off len = toShort $ S.takeWhile (/= 0) $ S.take len $ S.drop off bs-- getOctal off len = parseOctal $ S.take len $ S.drop off bs-- parseOctal :: Integral i => ByteString -> i- parseOctal = S.foldl' (\t c -> t * 8 + fromIntegral (c - zero)) 0- . S.takeWhile (\c -> zero <= c && c <= seven)- . S.dropWhile (== space)-- space :: Integral i => i- space = 0x20- zero = 48- seven = 55--untar :: Monad m => ConduitM ByteString TarChunk m ()-untar =- loop 0- where- loop !offset = assert (offset `mod` 512 == 0) $ do- bs <- takeCE 512 .| foldC- case S.length bs of- 0 -> return ()- 512 | S.all (== 0) bs -> do- let offset' = offset + 512- bs' <- takeCE 512 .| foldC- case () of- ()- | S.length bs' /= 512 -> do- leftover bs'- yield $ ChunkException $ ShortTrailer offset'- | S.all (== 0) bs' -> return ()- | otherwise -> do- leftover bs'- yield $ ChunkException $ BadTrailer offset'- 512 ->- case parseHeader offset bs of- Left e -> do- leftover bs- yield $ ChunkException e- Right h -> do- yield $ ChunkHeader h- offset' <- payloads (offset + 512) $ headerPayloadSize h- let expectedOffset = offset + 512 + headerPayloadSize h +- (case (512 - (headerPayloadSize h `mod` 512)) of- 512 -> 0- x -> x)- assert (offset' == expectedOffset) (loop offset')- _ -> do- leftover bs- yield $ ChunkException $ IncompleteHeader offset-- payloads !offset 0 = do- let padding =- case offset `mod` 512 of- 0 -> 0- x -> 512 - x- takeCE padding .| sinkNull- return $! offset + padding- payloads !offset !size = do- mbs <- await- case mbs of- Nothing -> do- yield $ ChunkException $ IncompletePayload offset size- return offset- Just bs -> do- let (x, y) = S.splitAt size bs- yield $ ChunkPayload offset x- let size' = size - S.length x- offset' = offset + S.length x- unless (S.null y) (leftover y)- payloads offset' size'---- | Process a single tar entry. See 'withEntries' for more details.-withEntry :: MonadThrow m- => (Header -> ConduitM ByteString o m r)- -> ConduitM TarChunk o m r-withEntry inner = do- mc <- await- case mc of- Nothing -> throwM NoMoreHeaders- Just (ChunkHeader h) -> payloads .| (inner h <* sinkNull)- Just x@(ChunkPayload offset _bs) -> do- leftover x- throwM $ UnexpectedPayload offset- Just (ChunkException e) -> throwM e- where- payloads = do- mx <- await- case mx of- Just (ChunkPayload _ bs) -> yield bs >> payloads- Just x@ChunkHeader{} -> leftover x- Just (ChunkException e) -> throwM e- Nothing -> return ()--{-| This function handles each entry of the tar archive according to the-behaviour of the function passed as first argument.--Here is a full example function, that reads a compressed tar archive and for each entry that is a simple file, it prints its file path and SHA256 digest. Note that this function can throw exceptions!--> import qualified Crypto.Hash.Conduit as CH-> import qualified Data.Conduit.Tar as CT-> -> import Conduit-> import Crypto.Hash (Digest, SHA256)-> import Control.Monad (when)-> import Data.Conduit.Zlib (ungzip)-> import Data.ByteString (ByteString)-> -> filedigests :: FilePath -> IO ()-> filedigests fp = runConduitRes ( sourceFileBS fp -- read the raw file-> .| ungzip -- gunzip-> .| CT.untar -- decode the tar archive-> .| CT.withEntries hashentry -- process each file-> .| printC -- print the results-> )-> where-> hashentry :: Monad m => CT.Header -> Conduit ByteString m (FilePath, Digest SHA256)-> hashentry hdr = when (CT.headerFileType hdr == CT.FTNormal) $ do-> hash <- CH.sinkHash-> yield (CT.headerFilePath hdr, hash)--The @hashentry@ function handles a single entry, based on its first 'Header' argument.-In this example, a 'Consumer' is used to process the whole entry.--Note that the benefits of stream processing are easily lost when working with a 'Consumer'. For example, the following implementation would have used an unbounded amount of memory:--> hashentry hdr = when (CT.headerFileType hdr == CT.FTNormal) $ do-> content <- mconcat <$> sinkList-> yield (CT.headerFilePath hdr, hash content)--}-withEntries :: MonadThrow m- => (Header -> ConduitM ByteString o m ())- -> ConduitM TarChunk o m ()-withEntries = peekForever . withEntry+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-| This module is about stream-processing tar archives. It is currently+not very well tested. See the documentation of 'withEntries' for an usage sample.+-}+module Data.Conduit.Tar+ ( -- * Basic functions+ tar+ , tarEntries+ , untar+ , untarRaw+ , untarWithFinalizers+ , untarWithExceptions+ , restoreFile+ , restoreFileInto+ , restoreFileIntoLenient+ , restoreFileWithErrors+ -- ** Operate on Chunks+ , untarChunks+ , untarChunksRaw+ , applyPaxChunkHeaders+ , withEntry+ , withEntries+ , withFileInfo+ -- * Helper functions+ , headerFileType+ , headerFilePath+ -- ** Creation+ , tarFilePath+ , filePathConduit+ -- * Directly on files+ , createTarball+ , writeTarball+ , extractTarball+ , extractTarballLenient+ -- * Types+ , module Data.Conduit.Tar.Types+ ) where++import Conduit as C+import Control.Exception (assert, SomeException)+import Control.Monad (unless, void)+import Control.Monad.State.Lazy (StateT, get, put)+import Data.Bits+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import Data.ByteString.Builder+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as SL+import Data.ByteString.Short (ShortByteString, fromShort, toShort)+import qualified Data.ByteString.Short as SS+import qualified Data.ByteString.Unsafe as BU+import Data.Foldable (foldr')+import qualified Data.Map as Map+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid ((<>))+#endif+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (mempty)+#endif+import Data.Word (Word8)+import Foreign.C.Types (CTime (..))+import Foreign.Storable+import System.Directory (createDirectoryIfMissing,+ getCurrentDirectory)+import System.FilePath+import System.IO++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<*))+#endif++import Data.Conduit.Tar.Types+#ifdef WINDOWS+import Data.Conduit.Tar.Windows+#else+import Data.Conduit.Tar.Unix+#endif+++headerFilePathBS :: Header -> S.ByteString+headerFilePathBS Header {..} =+ if SS.null headerFileNamePrefix+ then fromShort headerFileNameSuffix+ else S.concat+ [fromShort headerFileNamePrefix, pathSeparatorS, fromShort headerFileNameSuffix]++-- | Construct a `FilePath` from `headerFileNamePrefix` and `headerFileNameSuffix`.+--+-- @since 0.1.0+headerFilePath :: Header -> FilePath+headerFilePath = decodeFilePath . headerFilePathBS++-- | Get Header file type.+--+-- @since 0.1.0+headerFileType :: Header -> FileType+headerFileType h =+ case headerLinkIndicator h of+ 0 -> FTNormal+ 48 -> FTNormal+ 49 -> FTHardLink (fromShort (headerLinkName h))+ 50 -> FTSymbolicLink (fromShort (headerLinkName h))+ 51 -> FTCharacterSpecial+ 52 -> FTBlockSpecial+ 53 -> FTDirectory+ 54 -> FTFifo+ x -> FTOther x++parseHeader :: FileOffset -> ByteString -> Either TarException Header+parseHeader offset bs = do+ unless (S.length bs == 512) $ Left $ IncompleteHeader offset+ let checksumBytes = BU.unsafeTake 8 $ BU.unsafeDrop 148 bs+ expectedChecksum = parseOctal checksumBytes+ actualChecksum = bsum bs - bsum checksumBytes + 8 * space+ magicVersion = toShort $ BU.unsafeTake 8 $ BU.unsafeDrop 257 bs+ getNumber :: (Storable a, Bits a, Integral a) => Int -> Int -> a+ getNumber = if magicVersion == gnuTarMagicVersion then getHexOctal else getOctal++ unless (actualChecksum == expectedChecksum) (Left (BadChecksum offset))+ return Header+ { headerOffset = offset+ , headerPayloadOffset = offset + 512+ , headerFileNameSuffix = getShort 0 100+ , headerFileMode = getOctal 100 8+ , headerOwnerId = getNumber 108 8+ , headerGroupId = getNumber 116 8+ , headerPayloadSize = getNumber 124 12+ , headerTime = CTime $ getNumber 136 12+ , headerLinkIndicator = BU.unsafeIndex bs 156+ , headerLinkName = getShort 157 100+ , headerMagicVersion = magicVersion+ , headerOwnerName = getShort 265 32+ , headerGroupName = getShort 297 32+ , headerDeviceMajor = getNumber 329 8+ , headerDeviceMinor = getNumber 337 8+ , headerFileNamePrefix = getShort 345 155+ }+ where+ bsum :: ByteString -> Int+ bsum = S.foldl' (\c n -> c + fromIntegral n) 0++ getShort off len = toShort $ S.takeWhile (/= 0) $ BU.unsafeTake len $ BU.unsafeDrop off bs++ getOctal :: Integral a => Int -> Int -> a+ getOctal off len = parseOctal $ BU.unsafeTake len $ BU.unsafeDrop off bs++ -- | Depending on the first bit of the first byte in the range either choose direct+ -- hex representation, or classic octal string view.+ getHexOctal :: (Storable a, Bits a, Integral a) => Int -> Int -> a+ getHexOctal off len = if BU.unsafeIndex bs off .&. 0x80 == 0x80+ then fromHex $ BU.unsafeTake len $ BU.unsafeDrop off bs+ else getOctal off len++ parseOctal :: Integral i => ByteString -> i+ parseOctal = parseBase 8+ . S.takeWhile (\c -> zero <= c && c <= seven)+ . S.dropWhile (== space)++ seven = 55++parseBase :: Integral i => i -> ByteString -> i+parseBase n = S.foldl' (\t c -> t * n + fromIntegral (c - zero)) 0++space :: Integral i => i+space = 0x20 -- UTF-8 ' '++zero :: Word8+zero = 0x30 -- UTF-8 '0'++-- | Make sure we don't use more bytes than we can fit in the data type.+fromHex :: forall a . (Storable a, Bits a, Integral a) => ByteString -> a+fromHex str = S.foldl' (\ acc x -> (acc `shiftL` 8) .|. fromIntegral x) 0 $+ S.drop (max 0 (S.length str - sizeOf (undefined :: a))) str++-- | Convert a stream of raw bytes into a stream of 'TarChunk's, after applying+-- any pax header blocks and extended headers. This stream can further be passed+-- into 'withFileInfo' or 'withHeaders' functions. Only the \'comment\',+-- \'gid\', \'gname\', \'linkpath\', \'path\', \'size\', \'uid\' and \'uname\'+-- pax keywords are supported. For a component that produces unprocessed+-- 'TarChunk's, see 'untarChunksRaw'.+--+-- @since 0.2.1+untarChunks :: Monad m => ConduitM ByteString TarChunk m ()+untarChunks =+ untarChunksRaw+ .| evalStateLC initialPaxState applyPaxChunkHeaders++-- | Convert a stream of raw bytes into a stream of raw 'TarChunk's. This stream+-- can further be passed into `withFileInfo` or `withHeaders` functions. For a+-- component that further processes raw 'TarChunk's to apply pax header blocks+-- and extended headers, see 'untarChunk'.+--+-- @since 0.3.3+untarChunksRaw :: Monad m => ConduitM ByteString TarChunk m ()+untarChunksRaw =+ loop 0+ where+ loop !offset = assert (offset `mod` 512 == 0) $ do+ bs <- takeCE 512 .| foldC+ case S.length bs of+ 0 -> return ()+ 512 | S.all (== 0) bs -> do+ let offset' = offset + 512+ bs' <- takeCE 512 .| foldC+ case () of+ ()+ | S.length bs' /= 512 -> do+ leftover bs'+ yield $ ChunkException $ ShortTrailer offset'+ | S.all (== 0) bs' -> return ()+ | otherwise -> do+ leftover bs'+ yield $ ChunkException $ BadTrailer offset'+ 512 ->+ case parseHeader offset bs of+ Left e -> do+ leftover bs+ yield $ ChunkException e+ Right h -> do+ yield $ ChunkHeader h+ offset' <- payloads (offset + 512) $ headerPayloadSize h+ let expectedOffset = offset + 512 + headerPayloadSize h ++ (case 512 - (headerPayloadSize h `mod` 512) of+ 512 -> 0+ x -> x)+ assert (offset' == expectedOffset) (loop offset')+ _ -> do+ leftover bs+ yield $ ChunkException $ IncompleteHeader offset++ payloads !offset 0 = do+ let padding =+ case offset `mod` 512 of+ 0 -> 0+ x -> 512 - fromIntegral x+ takeCE padding .| sinkNull+ return $! offset + fromIntegral padding+ payloads !offset !size = do+ mbs <- await+ case mbs of+ Nothing -> do+ yield $ ChunkException $ IncompletePayload offset $ fromIntegral size+ return offset+ Just bs -> do+ let (x, y) = S.splitAt (fromIntegral (min size (fromIntegral (maxBound :: Int)))) bs+ yield $ ChunkPayload offset x+ let size' = size - fromIntegral (S.length x)+ offset' = offset + fromIntegral (S.length x)+ unless (S.null y) (leftover y)+ payloads offset' size'+++-- | Process a single tar entry. See 'withEntries' for more details.+--+-- @since 0.1.0+--+withEntry :: MonadThrow m+ => (Header -> ConduitM ByteString o m r)+ -> ConduitM TarChunk o m r+withEntry inner = do+ mc <- await+ case mc of+ Nothing -> throwM NoMoreHeaders+ Just (ChunkHeader h) -> payloadsConduit .| (inner h <* sinkNull)+ Just x@(ChunkPayload offset _bs) -> do+ leftover x+ throwM $ UnexpectedPayload offset+ Just (ChunkException e) -> throwM e+++payloadsConduit :: MonadThrow m+ => ConduitM TarChunk ByteString m ()+payloadsConduit = do+ mx <- await+ case mx of+ Just (ChunkPayload _ bs) -> yield bs >> payloadsConduit+ Just x@ChunkHeader {} -> leftover x+ Just (ChunkException e) -> throwM e+ Nothing -> return ()+++{-| This function handles each entry of the tar archive according to the+behaviour of the function passed as first argument.++Here is a full example function, that reads a compressed tar archive and for each entry that is a+simple file, it prints its file path and SHA256 digest. Note that this function can throw+exceptions!++> import qualified Crypto.Hash.Conduit as CH+> import qualified Data.Conduit.Tar as CT+>+> import Conduit+> import Crypto.Hash (Digest, SHA256)+> import Control.Monad (when)+> import Data.Conduit.Zlib (ungzip)+> import Data.ByteString (ByteString)+>+> filedigests :: FilePath -> IO ()+> filedigests fp = runConduitRes ( sourceFileBS fp -- read the raw file+> .| ungzip -- gunzip+> .| CT.untarChunks -- decode the tar archive+> .| CT.withEntries hashentry -- process each file+> .| printC -- print the results+> )+> where+> hashentry :: Monad m => CT.Header -> Conduit ByteString m (FilePath, Digest SHA256)+> hashentry hdr = when (CT.headerFileType hdr == CT.FTNormal) $ do+> hash <- CH.sinkHash+> yield (CT.headerFilePath hdr, hash)++The @hashentry@ function handles a single entry, based on its first 'Header' argument.+In this example, a 'Consumer' is used to process the whole entry.++Note that the benefits of stream processing are easily lost when working with a 'Consumer'. For+example, the following implementation would have used an unbounded amount of memory:++> hashentry hdr = when (CT.headerFileType hdr == CT.FTNormal) $ do+> content <- mconcat <$> sinkList+> yield (CT.headerFilePath hdr, hash content)++@since 0.1.0+-}+withEntries :: MonadThrow m+ => (Header -> ConduitM ByteString o m ())+ -> ConduitM TarChunk o m ()+withEntries = peekForever . withEntry+++-- | Extract a tarball, similarly to `withEntries`, but instead of dealing directly with tar format,+-- this conduit allows you to work directly on file abstractions `FileInfo`. For now support is+-- minimal:+--+-- * Old v7 tar format.+-- * ustar: POSIX 1003.1-1988 format+-- * and only some portions of GNU format:+-- * Larger values for `fileUserId`, `fileGroupId`, `fileSize` and `fileModTime`.+-- * 'L' type - long file names, but only up to 4096 chars to prevent DoS attack+-- * other types are simply discarded+--+-- /Note/ - Here is a really good reference for specifics of different tar formats:+-- <https://github.com/libarchive/libarchive/wiki/ManPageTar5>+--+-- @since 0.2.2+withFileInfo :: MonadThrow m+ => (FileInfo -> ConduitM ByteString o m ())+ -> ConduitM TarChunk o m ()+withFileInfo inner = start+ where+ start = await >>= maybe (return ()) go+ go x =+ case x of+ ChunkHeader h+ | headerLinkIndicator h >= 55 ->+ if headerMagicVersion h == gnuTarMagicVersion+ then handleGnuTarHeader h >>= maybe start go+ else dropWhileC+ (\case+ ChunkPayload _ _ -> True+ _ -> False) >> start+ ChunkHeader h -> do+ payloadsConduit .| (inner (fileInfoFromHeader h) <* sinkNull)+ start+ ChunkPayload offset _bs -> do+ leftover x+ throwM $ UnexpectedPayload offset+ ChunkException e -> throwM e+++-- | Take care of custom GNU tar format.+handleGnuTarHeader :: MonadThrow m+ => Header+ -> ConduitM TarChunk o m (Maybe TarChunk)+handleGnuTarHeader h =+ case headerLinkIndicator h of+ 76 -> do+ let pSize = headerPayloadSize h+ -- guard against names that are too long in order to prevent a DoS attack on unbounded+ -- file names+ unless (0 < pSize && pSize <= 4096) $+ throwM $+ FileTypeError (headerPayloadOffset h) 'L' $ "Filepath is too long: " ++ show pSize+ longFileNameBuilder <- payloadsConduit .| foldMapC byteString+ let longFileName = SL.toStrict . SL.init . toLazyByteString $ longFileNameBuilder+ mcNext <- await+ case mcNext of+ Just (ChunkHeader nh) -> do+ unless (S.isPrefixOf (fromShort (headerFileNameSuffix nh)) longFileName) $+ throwM $+ FileTypeError (headerPayloadOffset nh) 'L'+ "Long filename doesn't match the original."+ return+ (Just $ ChunkHeader $+ nh+ { headerFileNameSuffix = toShort longFileName+ , headerFileNamePrefix = SS.empty+ })+ Just c@(ChunkPayload offset _) -> do+ leftover c+ throwM $ InvalidHeader offset+ Just (ChunkException exc) -> throwM exc+ Nothing -> throwM NoMoreHeaders+ 83 -> do+ payloadsConduit .| sinkNull -- discard sparse files payload+ -- TODO : Implement restoring of sparse files+ return Nothing+ _ -> return Nothing++-- | Just like 'withFileInfo', but works directly on the stream of bytes.+-- Applies pax header blocks and extended headers. However, only the+-- \'comment\', \'gid\', \'gname\', \'linkpath\', \'path\', \'size\', \'uid\'+-- and \'uname\' pax keywords are supported.+--+-- @since 0.2.0+untar :: MonadThrow m+ => (FileInfo -> ConduitM ByteString o m ())+ -> ConduitM ByteString o m ()+untar inner = untarChunks .| withFileInfo inner++-- | Like 'untar' but does not apply pax header blocks and extended headers.+--+-- @since 0.3.3+untarRaw ::+ MonadThrow m+ => (FileInfo -> ConduitM ByteString o m ())+ -> ConduitM ByteString o m ()+untarRaw inner = untarChunksRaw .| withFileInfo inner++-- | Applies tar chunks that are pax header blocks and extended headers to the+-- tar chunks that follow. However, only the \'comment\', \'gid\', \'gname\',+-- \'linkpath\', \'path\', \'size\', \'uid\' and \'uname\' pax keywords are+-- supported.+applyPaxChunkHeaders ::+ Monad m+ => ConduitM TarChunk TarChunk (StateT PaxState m) ()+applyPaxChunkHeaders = awaitForever $ \i -> do+ state@(PaxState g x) <- lift get+ let updateState f = do+ p <- parsePax+ lift $ put $ f p state+ case i of+ ChunkHeader h -> case headerLinkIndicator h of+ -- 'g' typeflag unique to pax header block+ 0x67 -> updateState updateGlobal+ -- 'x' typeflag unique to pax header block+ 0x78 -> updateState updateNext+ -- All other typeflag+ _ -> do+ yield $ ChunkHeader $ applyPax (Map.union x g) h+ lift $ put $ clearNext state+ _ -> yield i+ where+ updateGlobal p (PaxState g x) = PaxState (Map.union p g) x+ updateNext p (PaxState g _) = PaxState g p+ clearNext = updateNext mempty++-- | Only the \'comment\', \'gid\', \'gname\', \'linkpath\',\'path\', \'size\',+-- \'uid\' and \'uname\' pax keywords are supported.+applyPax :: PaxHeader -> Header -> Header+applyPax p h =+ updateGid+ $ updateGname+ $ updateLinkpath+ $ updatePath+ $ updateSize+ $ updateUid+ $ updateUname h+ where+ update ::+ ByteString+ -> (ByteString -> Header -> Header)+ -> (Header -> Header)+ update k f = maybe id f (Map.lookup k p)+ ifValueDecimal ::+ Integral i+ => (i -> Header -> Header)+ -> ByteString+ -> (Header -> Header)+ ifValueDecimal f v = if S.all isDecimal v+ then f (parseDecimal v)+ else id+ -- There is no 'updateComment' because comments are ignored.+ updateGid = update "gid" $ ifValueDecimal $ \v h' -> h'+ { headerGroupId = v }+ updateGname = update "gname" $ \v h' -> h' { headerGroupName = toShort v }+ updateLinkpath =+ update "linkpath" $ \v h' -> h' { headerLinkName = toShort v }+ updatePath = update "path" $ \v h' -> h'+ { headerFileNameSuffix = toShort v, headerFileNamePrefix = mempty }+ updateSize = update "size" $ ifValueDecimal $ \v h' -> h'+ { headerPayloadSize = v }+ updateUid = update "uid" $ ifValueDecimal $ \v h' -> h'+ { headerOwnerId = v }+ updateUname = update "uname" $ \v h' -> h' { headerOwnerName = toShort v }++parsePax :: Monad m => ConduitM TarChunk TarChunk (StateT PaxState m) PaxHeader+parsePax = paxParser <$> combineChunkPayloads mempty+ where+ combineChunkPayloads bs = await >>= \case+ Nothing -> pure bs+ Just (ChunkPayload _ b) ->+ -- This uses <> (Data.ByteString.Internal.Type.append) rather than, say,+ -- [ByteString] (created in reverse order) and+ -- Data.ByteString.Internal.Type.concat on the reverse of the list. The+ -- reason for doing so is an expectation that, in practice, the pax+ -- extended header data will be received as a single chunk in the very+ -- great majority of cases and, when it is not, in the great majority of+ -- remaining cases it will be received as two sequential chunks. This is+ -- optimised for that expectation, rather than the receipt of the data in+ -- a large number of small chunks.+ combineChunkPayloads $ bs <> b+ Just other -> do+ leftover other+ pure bs++-- | A pax extended header comprises one or more records. If the pax extended+-- header is empty or does not parse, yields an empty 'Pax'.+paxParser :: ByteString -> PaxHeader+paxParser b+ -- This is an error case.+ | S.null b = mempty+paxParser b = paxParser' [] b+ where+ paxParser' :: [(ByteString, ByteString)] -> ByteString -> PaxHeader+ paxParser' l b0+ | S.null b0 = Map.fromList l+ paxParser' l b0 =+ maybe mempty (\(pair, b1) -> paxParser' (pair:l) b1) (recordParser b0)++-- | A record in a pax extended header has format:+--+-- "%d %s=%s\n", <length>, <keyword>, <value>+--+-- If the record does not parse @(<keyword>, <value>)@, yields 'Nothing'.+recordParser :: ByteString -> Maybe ((ByteString, ByteString), ByteString)+recordParser b0 = do+ let (nb, b1) = S.span isDecimal b0+ n <- toMaybe (not $ S.null nb) (parseDecimal nb)+ b2 <- skip isSpace b1+ let (k, b3) = S.span (not . isEquals) b2+ b4 <- skip isEquals b3+ let (v, b5) = S.splitAt (n - S.length nb - S.length k - 3) b4+ b6 <- skip isNewline b5+ Just ((k, v), b6)+ where+ newline = 0x0a -- UTF-8 '\n'+ equals = 0x3d -- UTF-8 '='+ toMaybe :: Bool -> a -> Maybe a+ toMaybe False _ = Nothing+ toMaybe True x = Just x+ skip p b = do+ (w, b') <- S.uncons b+ if p w then Just b' else Nothing+ isSpace = (space ==)+ isEquals = (equals ==)+ isNewline = (newline ==)++parseDecimal :: Integral i => ByteString -> i+parseDecimal = parseBase 10++isDecimal :: Word8 -> Bool+isDecimal w = w >= zero && w <= nine+ where+ nine = 0x39 -- UTF-8 '9'++-- | Just like `untar`, except that each `FileInfo` handling function can produce a finalizing+-- action, all of which will be executed after the whole tarball has been processed in the opposite+-- order. Very useful with `restoreFile` and `restoreFileInto`, since they restore direcory+-- modification timestamps only after files have been fully written to disk.+--+-- @since 0.2.0+untarWithFinalizers ::+ (MonadThrow m, MonadIO m)+ => (FileInfo -> ConduitM ByteString (IO ()) m ())+ -> ConduitM ByteString c m ()+untarWithFinalizers inner = do+ finilizers <- untar inner .| foldlC (>>) (return ())+ liftIO finilizers+++-- | Same as `untarWithFinalizers`, but will also produce a list of any exceptions that might have+-- occured during restoration process.+--+-- @since 0.2.5+untarWithExceptions ::+ (MonadThrow m, MonadIO m)+ => (FileInfo -> ConduitM ByteString (IO (FileInfo, [SomeException])) m ())+ -> ConduitM ByteString c m [(FileInfo, [SomeException])]+untarWithExceptions inner = do+ finalizers <- untar inner .| C.foldMapC (fmap pure)+ filter (not . null . snd) <$> liftIO finalizers+++--------------------------------------------------------------------------------+-- Create a tar file -----------------------------------------------------------+--------------------------------------------------------------------------------++gnuTarMagicVersion :: ShortByteString+gnuTarMagicVersion = toShort (S8.pack "ustar \NUL")++ustarMagicVersion :: ShortByteString+ustarMagicVersion = toShort (S8.pack "ustar\NUL00")++blockSize :: FileOffset+blockSize = 512++terminatorBlock :: ByteString+terminatorBlock = S.replicate (fromIntegral (2 * blockSize)) 0++defHeader :: FileOffset -> Header+defHeader offset = Header+ { headerOffset = offset+ , headerPayloadOffset = offset + 512+ , headerFileNameSuffix = SS.empty+ , headerFileMode = 0o644+ , headerOwnerId = 0+ , headerGroupId = 0+ , headerPayloadSize = 0+ , headerTime = 0+ , headerLinkIndicator = 0+ , headerLinkName = SS.empty+ , headerMagicVersion = ustarMagicVersion+ , headerOwnerName = "root"+ , headerGroupName = "root"+ , headerDeviceMajor = 0+ , headerDeviceMinor = 0+ , headerFileNamePrefix = SS.empty+ }+++headerFromFileInfo ::+ MonadThrow m+ => FileOffset -- ^ Starting offset within the tarball. Must be multiple of 512, otherwise error.+ -> FileInfo -- ^ File info.+ -> m (Either TarCreateException Header)+headerFromFileInfo offset fi = do+ unless (offset `mod` 512 == 0) $+ throwM $+ TarCreationError $+ "<headerFromFileInfo>: Offset must always be a multiple of 512 for file: " +++ getFileInfoPath fi+ let (prefix, suffix) = splitPathAt 100 $ filePath fi+ if SS.length prefix > 155 || SS.null suffix+ then return $ Left $ FileNameTooLong fi+ else do+ (payloadSize, linkName, linkIndicator) <-+ case fileType fi of+ FTNormal -> return (fileSize fi, SS.empty, 48)+ FTHardLink ln -> return (0, toShort ln, 49)+ FTSymbolicLink ln -> return (0, toShort ln, 50)+ FTDirectory -> return (0, SS.empty, 53)+ fty ->+ throwM $+ TarCreationError $+ "<headerFromFileInfo>: Unsupported file type: " +++ show fty ++ " for file: " ++ getFileInfoPath fi+ return $+ Right+ Header+ { headerOffset = offset+ , headerPayloadOffset = offset + 512+ , headerFileNameSuffix = suffix+ , headerFileMode = fileMode fi+ , headerOwnerId = fileUserId fi+ , headerGroupId = fileGroupId fi+ , headerPayloadSize = payloadSize+ , headerTime = fileModTime fi+ , headerLinkIndicator = linkIndicator+ , headerLinkName = linkName+ , headerMagicVersion = ustarMagicVersion+ , headerOwnerName = toShort $ fileUserName fi+ , headerGroupName = toShort $ fileGroupName fi+ , headerDeviceMajor = 0+ , headerDeviceMinor = 0+ , headerFileNamePrefix = prefix+ }+++-- | Split a file path at the @n@ mark from the end, while still keeping the+-- split as a valid path, i.e split at a path separator only.+splitPathAt :: Int -> ByteString -> (ShortByteString, ShortByteString)+splitPathAt n fp+ | S.length fp <= n = (SS.empty, toShort fp)+ | otherwise =+ let sfp = S8.splitWith isPathSeparator fp+ sepWith p (tlen, prefix', suffix') =+ case S.length p + 1 + tlen of+ tlen'+ | tlen' <= n -> (tlen', prefix', p : suffix')+ tlen' -> (tlen', p : prefix', suffix')+ (_, prefix, suffix) = foldr' sepWith (0, [], []) sfp+ toShortPath = toShort . S8.intercalate pathSeparatorS+ in (toShortPath prefix, toShortPath suffix)++packHeader :: MonadThrow m => Header -> m S.ByteString+packHeader header = do+ (left, right) <- packHeaderNoChecksum header+ let sumsl :: SL.ByteString -> Int+ sumsl = SL.foldl' (\ !acc !v -> acc + fromIntegral v) 0+ checksum = sumsl left + 32 * 8 + sumsl right+ encChecksum <-+ either+ (\(_, val) ->+ throwM $+ TarCreationError $+ "<packHeader>: Impossible happened - Checksum " +++ show val ++ " doesn't fit into header for file: " ++ headerFilePath header)+ return $+ encodeOctal 8 checksum+ return $ SL.toStrict $ left <> toLazyByteString encChecksum <> right++packHeaderNoChecksum :: MonadThrow m => Header -> m (SL.ByteString, SL.ByteString)+packHeaderNoChecksum h@Header {..} = do+ let CTime headerTime' = headerTime+ magic0 = headerMagicVersion+ (magic1, hOwnerId) <- encodeNumber magic0 "ownerId" 8 headerOwnerId+ (magic2, hGroupId) <- encodeNumber magic1 "groupId" 8 headerGroupId+ (magic3, hPayloadSize) <- encodeNumber magic2 "payloadSize" 12 headerPayloadSize+ (magic4, hTime) <- encodeNumber magic3 "time" 12 headerTime'+ (magic5, hDevMajor) <- encodeDevice magic4 "Major" headerDeviceMajor+ (magic6, hDevMinor) <- encodeDevice magic5 "Minor" headerDeviceMinor+ hNameSuffix <- encodeShort h "nameSuffix" 100 headerFileNameSuffix+ hFileMode <- throwNumberEither "fileMode" $ encodeOctal 8 headerFileMode+ hLinkName <- encodeShort h "linkName" 100 headerLinkName+ hMagicVersion <- encodeShort h "magicVersion" 8 magic6+ hOwnerName <- encodeShort h "ownerName" 32 headerOwnerName+ hGroupName <- encodeShort h "groupName" 32 headerGroupName+ hNamePrefix <- encodeShort h "namePrefix" 155 headerFileNamePrefix+ return+ ( toLazyByteString $+ hNameSuffix <>+ hFileMode <>+ hOwnerId <>+ hGroupId <>+ hPayloadSize <>+ hTime+ , toLazyByteString $+ word8 headerLinkIndicator <>+ hLinkName <>+ hMagicVersion <>+ hOwnerName <>+ hGroupName <>+ hDevMajor <>+ hDevMinor <>+ hNamePrefix <>+ byteString (S.replicate 12 0)+ )+ where+ encodeNumber magic field len = throwNumberEither field . fallbackHex magic . encodeOctal len+ encodeDevice magic _ 0 = return (magic, byteString $ S.replicate 8 0)+ encodeDevice magic m devid = encodeNumber magic ("device" ++ m) 8 devid+ fallbackHex magic (Right enc) = Right (magic, enc)+ fallbackHex _ (Left (len, val)) = (,) gnuTarMagicVersion <$> encodeHex len val+ throwNumberEither _ (Right v) = return v+ throwNumberEither field (Left (len, val)) =+ throwM $+ TarCreationError $+ "<packHeaderNoChecksum>: Tar value overflow for file: " +++ headerFilePath h +++ " (for field '" ++ field ++ "' with maxLen " ++ show len ++ "): " ++ show val+++-- | Encode a number as hexadecimal with most significant bit set to 1. Returns Left if the value+-- doesn't fit in a ByteString of the supplied length, also prohibits negative numbers if precision+-- of value is higher than available length. Eg. length 8 can't reliably encoed negative numbers,+-- since MSB is already used for flagging Hex extension.+encodeHex :: (Storable a, Bits a, Integral a) =>+ Int -> a -> Either (Int, a) Builder+encodeHex !len !val =+ if complement (complement 0 `shiftL` infoBits) .&. val == val &&+ not (val < 0 && len < sizeOf val)+ then go 0 val mempty+ else Left (len, val)+ where+ len' = len - 1+ infoBits = len * 8 - 1+ go !n !cur !acc+ | n < len' = go (n + 1) (cur `shiftR` 8) (word8 (fromIntegral (cur .&. 0xFF)) <> acc)+ | otherwise = return (word8 (fromIntegral (cur .&. 0x7F) .|. 0x80) <> acc)+++-- | Encode a number in 8base padded with zeros and terminated with NUL.+encodeOctal :: (Integral a) =>+ Int -> a -> Either (Int, a) Builder+encodeOctal !len' !val+ | val < 0 = Left (len', val)+ | otherwise = go 0 val (word8 0)+ where+ !len = len' - 1+ go !n !cur !acc+ | cur == 0 =+ if n < len+ then return $ byteString (S.replicate (len - n) 48) <> acc+ else return acc+ | n < len =+ let !(q, r) = cur `quotRem` 8+ in go (n + 1) q (word8 (fromIntegral r + 48) <> acc)+ | otherwise = Left (len', val)++++-- | Encode a `ShortByteString` with an exact length, NUL terminating if it is+-- shorter, but throwing `TarCreationError` if it is longer.+encodeShort :: MonadThrow m => Header -> String -> Int -> ShortByteString -> m Builder+encodeShort h field !len !sbs+ | lenShort <= len = return $ shortByteString sbs <> byteString (S.replicate (len - lenShort) 0)+ | otherwise =+ throwM $+ TarCreationError $+ "<encodeShort>: Tar string value overflow for file: " +++ headerFilePath h +++ " (for field '" ++ field ++ "' with maxLen " ++ show len ++ "): " ++ S8.unpack (fromShort sbs)+ where+ lenShort = SS.length sbs+++-- | Produce a ByteString chunk with NUL characters of the size needed to get up+-- to the next 512 byte mark in respect to the supplied offset and return that+-- offset incremented to that mark.+yieldNulPadding :: Monad m => FileOffset -> ConduitM i ByteString m FileOffset+yieldNulPadding n = do+ let pad = blockSize - (n `mod` blockSize)+ if pad /= blockSize+ then yield (S.replicate (fromIntegral pad) 0) >> return (n + pad)+ else return n++++-- | Handle tar payload, while validating its size and padding it to the full+-- block at the end.+tarPayload :: MonadThrow m =>+ FileOffset -- ^ Received payload size+ -> Header -- ^ Header for the file that we are currently receiving the payload for+ -> (FileOffset -> ConduitM (Either a ByteString) ByteString m FileOffset)+ -- ^ Continuation for after all payload has been received+ -> ConduitM (Either a ByteString) ByteString m FileOffset+tarPayload size header cont+ | size == headerPayloadSize header = cont (headerOffset header + blockSize)+ | otherwise = go size+ where+ go prevSize = do+ eContent <- await+ case eContent of+ Just h@(Left _) -> do+ leftover h+ throwM $+ TarCreationError $+ "<tarPayload>: Not enough payload for file: " ++ headerFilePath header+ Just (Right content) -> do+ let nextSize = prevSize + fromIntegral (S.length content)+ unless (nextSize <= headerPayloadSize header) $+ throwM $+ TarCreationError $+ "<tarPayload>: Too much payload (" +++ show nextSize ++ ") for file with size (" +++ show (headerPayloadSize header) ++ "): " ++ headerFilePath header+ yield content+ if nextSize == headerPayloadSize header+ then do+ paddedSize <- yieldNulPadding nextSize+ cont (headerPayloadOffset header + paddedSize)+ else go nextSize+ Nothing ->+ throwM $+ TarCreationError "<tarPayload>: Stream finished abruptly. Not enough payload."++++tarHeader :: MonadThrow m =>+ FileOffset -> ConduitM (Either Header ByteString) ByteString m FileOffset+tarHeader offset = do+ eContent <- await+ case eContent of+ Just (Right bs) | S.null bs -> tarHeader offset -- ignore empty content+ Just c@(Right _) -> do+ leftover c+ throwM $+ TarCreationError "<tarHeader>: Received payload without a corresponding Header."+ Just (Left header) -> do+ packHeader header >>= yield+ tarPayload 0 header tarHeader+ Nothing -> do+ yield terminatorBlock+ return $ offset + fromIntegral (S.length terminatorBlock)++++tarFileInfo :: MonadThrow m =>+ FileOffset -> ConduitM (Either FileInfo ByteString) ByteString m FileOffset+tarFileInfo offset = do+ eContent <- await+ case eContent of+ Just (Right bs)+ | S.null bs -> tarFileInfo offset -- ignore empty content+ Just c@(Right _) -> do+ leftover c+ throwM $+ TarCreationError "<tarFileInfo>: Received payload without a corresponding FileInfo."+ Just (Left fi) -> do+ eHeader <- headerFromFileInfo offset fi+ case eHeader of+ Left (FileNameTooLong _) -> do+ let fPath = filePath fi+ fPathLen = fromIntegral (S.length fPath + 1)+ pad =+ case fPathLen `mod` blockSize of+ 0 -> 0+ x -> blockSize - x+ eHeader' <-+ headerFromFileInfo+ (offset + blockSize + fPathLen + pad)+ (fi {filePath = S.take 100 fPath})+ header <- either throwM return eHeader'+ pHeader <- packHeader header+ pFileNameHeader <-+ packHeader $+ (defHeader offset)+ { headerFileNameSuffix = "././@LongLink"+ , headerPayloadSize = fPathLen+ , headerLinkIndicator = 76 -- 'L'+ , headerMagicVersion = gnuTarMagicVersion+ }+ yield pFileNameHeader+ yield fPath+ yield $ S.replicate (fromIntegral pad + 1) 0+ yield pHeader+ tarPayload 0 header tarFileInfo+ Left exc -> throwM exc+ Right header -> do+ packHeader header >>= yield+ tarPayload 0 header tarFileInfo+ Nothing -> return offset++++-- | Create a tar archive by suppying a stream of `Left` `FileInfo`s. Whenever a+-- file type is `FTNormal`, it must be immediately followed by its content as+-- `Right` `ByteString`. The produced `ByteString` is in the raw tar format and+-- is properly terminated at the end, therefore it can not be extended+-- afterwards. Returned is the total size of the bytestring as a `FileOffset`.+--+-- @since 0.2.0+tar :: MonadThrow m =>+ ConduitM (Either FileInfo ByteString) ByteString m FileOffset+tar = do+ offset <- tarFileInfo 0+ yield terminatorBlock+ return $ offset + fromIntegral (S.length terminatorBlock)+++-- | Just like `tar`, except gives you the ability to work at a lower `Header`+-- level, versus more user friendly `FileInfo`. A deeper understanding of tar+-- format is necessary in order to work directly with `Header`s.+--+-- @since 0.2.0+tarEntries :: MonadThrow m =>+ ConduitM (Either Header ByteString) ByteString m FileOffset+tarEntries = do+ offset <- tarHeader 0+ yield terminatorBlock+ return $ offset + fromIntegral (S.length terminatorBlock)++++-- | Turn a stream of file paths into a stream of `FileInfo` and file+-- content. All paths will be decended into recursively.+--+-- @since 0.2.0+filePathConduit :: (MonadThrow m, MonadResource m) =>+ ConduitM FilePath (Either FileInfo ByteString) m ()+filePathConduit = do+ mfp <- await+ case mfp of+ Just fp -> do+ fi <- liftIO $ getFileInfo fp+ case fileType fi of+ FTNormal -> do+ yield (Left fi)+ sourceFile (getFileInfoPath fi) .| mapC Right+ FTSymbolicLink _ -> yield (Left fi)+ FTDirectory -> do+ yield (Left fi)+ sourceDirectory (getFileInfoPath fi) .| filePathConduit+ fty -> do+ leftover fp+ throwM $+ TarCreationError $+ "<filePathConduit>: Unsupported file type: " +++ show fty ++ " for file: " ++ getFileInfoPath fi+ filePathConduit+ Nothing -> return ()+++-- | Recursively tar all of the files and directories. There will be no+-- conversion between relative and absolute paths, so just like with GNU @tar@+-- cli tool, it may be necessary to `setCurrentDirectory` in order to get the+-- paths relative. Using `filePathConduit` directly, while modifying the+-- `filePath`, would be another approach to handling the file paths.+--+-- @since 0.2.0+tarFilePath :: (MonadThrow m, MonadResource m) => ConduitM FilePath ByteString m FileOffset+tarFilePath = filePathConduit .| tar+++-- | Uses `tarFilePath` to create a tarball, that will recursively include the+-- supplied list of all the files and directories+--+-- @since 0.2.0+createTarball :: FilePath -- ^ File name for the tarball+ -> [FilePath] -- ^ List of files and directories to include in the tarball+ -> IO ()+createTarball tarfp dirs =+ runConduitRes $ yieldMany dirs .| void tarFilePath .| sinkFile tarfp++-- | Take a list of files and paths, recursively tar them and write output into supplied handle.+--+-- @since 0.2.0+writeTarball :: Handle -- ^ Handle where created tarball will be written to+ -> [FilePath] -- ^ List of files and directories to include in the tarball+ -> IO ()+writeTarball tarHandle dirs =+ runConduitRes $ yieldMany dirs .| void tarFilePath .| sinkHandle tarHandle+++-- always use forward slash, see+-- https://github.com/snoyberg/tar-conduit/issues/21+pathSeparatorS :: ByteString+pathSeparatorS = "/" -- S8.singleton pathSeparator+++fileInfoFromHeader :: Header -> FileInfo+fileInfoFromHeader header@Header {..} =+ FileInfo+ { filePath = headerFilePathBS header+ , fileUserId = headerOwnerId+ , fileUserName = fromShort headerOwnerName+ , fileGroupId = headerGroupId+ , fileGroupName = fromShort headerGroupName+ , fileMode = headerFileMode+ , fileSize = headerPayloadSize+ , fileType = headerFileType header+ , fileModTime = headerTime+ }+++-- | Extract a tarball while using `restoreFileInfo` for writing files onto the file+-- system. Restoration process is cross platform and should work concistently both on Windows and+-- Posix systems.+--+-- @since 0.2.0+extractTarball :: FilePath -- ^ Filename for the tarball+ -> Maybe FilePath -- ^ Folder where tarball should be extract+ -- to. Default is the current path+ -> IO ()+extractTarball tarfp mcd = do+ cd <- maybe getCurrentDirectory return mcd+ createDirectoryIfMissing True cd+ runConduitRes $ sourceFileBS tarfp .| untarWithFinalizers (restoreFileInto cd)+++prependDirectory :: FilePath -> FileInfo -> FileInfo+prependDirectory cd fi = fi {filePath = prependDir $ getFileInfoPath fi,+ fileType = prependDirIfNeeded (fileType fi)}+ where+ -- Hard links need to be interpreted based on `cd`, not just CWD, if relative,+ -- otherwise they may point to some invalid location.+ prependDirIfNeeded (FTHardLink p)+ | isRelative $ decodeFilePath p = FTHardLink (prependDir $ decodeFilePath p)+ prependDirIfNeeded other = other+ prependDir p = encodeFilePath (cd </> makeRelative "/" p)+++-- | Restore all files into a folder. Absolute file paths will be turned into+-- relative to the supplied folder.+restoreFileInto :: MonadResource m =>+ FilePath -> FileInfo -> ConduitM ByteString (IO ()) m ()+restoreFileInto cd = restoreFile . prependDirectory cd++-- | Restore all files into a folder. Absolute file paths will be turned into relative to the+-- supplied folder. Yields a list with exceptions instead of throwing them.+--+-- @since 0.2.5+restoreFileIntoLenient :: MonadResource m =>+ FilePath -> FileInfo -> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()+restoreFileIntoLenient cd = restoreFileWithErrors True . prependDirectory cd++-- | Same as `extractTarball`, but ignores possible extraction errors. It can still throw a+-- `TarException` if the tarball is corrupt or malformed.+--+-- @since 0.2.5+extractTarballLenient :: FilePath -- ^ Filename for the tarball+ -> Maybe FilePath -- ^ Folder where tarball should be extract+ -- to. Default is the current path+ -> IO [(FileInfo, [SomeException])]+extractTarballLenient tarfp mcd = do+ cd <- maybe getCurrentDirectory return mcd+ createDirectoryIfMissing True cd+ runConduitRes $+ sourceFileBS tarfp .| untarWithExceptions (restoreFileIntoLenient cd)++++-- | Restore files onto the file system. Produces actions that will set the modification time on the+-- directories, which can be executed after the pipeline has finished and all files have been+-- written to disk.+restoreFile :: (MonadResource m) =>+ FileInfo -> ConduitM S8.ByteString (IO ()) m ()+restoreFile fi = restoreFileWithErrors False fi .| mapC void+++-- | Restore files onto the file system, much in the same way `restoreFile` does it, except with+-- ability to ignore restoring problematic files and report errors that occured as a list of+-- exceptions, which will be returned as a list when finilizer executed. If a list is empty, it+-- means, that no errors occured and a file only had a finilizer associated with it.+--+-- @since 0.2.4+restoreFileWithErrors ::+ (MonadResource m)+ => Bool -- ^ Lenient flag, results in exceptions thrown instead of collected when set to @False@.+ -> FileInfo+ -> ConduitM S8.ByteString (IO (FileInfo, [SomeException])) m ()+restoreFileWithErrors = restoreFileInternal
+ src/Data/Conduit/Tar/Types.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE CPP #-}+#if WINDOWS+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+#endif+-- | Module contains all the types necessary for tarball processing.+module Data.Conduit.Tar.Types+ ( Header(..)+ , PaxHeader+ , PaxState (..)+ , initialPaxState+ , TarChunk(..)+ , TarException(..)+ , TarCreateException(..)+ , FileType(..)+ , FileInfo(..)+ , FileOffset+ , ByteCount+ , UserID+ , GroupID+ , DeviceID+ , EpochTime+ , CUid(..)+ , CGid(..)+ , encodeFilePath+ , decodeFilePath+ , getFileInfoPath+ ) where++import Control.Exception (Exception)+import Data.ByteString (ByteString)+import Data.ByteString.Short (ShortByteString)+import Data.Word+import System.Posix.Types+import qualified Data.ByteString.Char8 as S8+import Data.Map (Map)+import Data.Text as T+import Data.Text.Encoding as T+import Data.Text.Encoding.Error as T+#if WINDOWS+import Data.Bits+import Foreign.Storable+newtype CUid =+ CUid Word32+ deriving ( Bounded+ , Enum+ , Eq+ , Integral+ , Num+ , Ord+ , Read+ , Real+ , Show+ , Bits+ , Storable+ )+newtype CGid =+ CGid Word32+ deriving ( Bounded+ , Enum+ , Eq+ , Integral+ , Num+ , Ord+ , Read+ , Real+ , Show+ , Bits+ , Storable+ )+type UserID = CUid+type GroupID = CGid+#endif++data FileType+ = FTNormal+ | FTHardLink !ByteString+ | FTSymbolicLink !ByteString+ | FTCharacterSpecial+ | FTBlockSpecial+ | FTDirectory+ | FTFifo+ | FTOther !Word8+ deriving (Show, Eq)+++data FileInfo = FileInfo+ { filePath :: !ByteString -- ^ File path.+ , fileUserId :: !UserID -- ^ Unix user id.+ , fileUserName :: !ByteString -- ^ Unix user name.+ , fileGroupId :: !GroupID -- ^ Unix group id.+ , fileGroupName :: !ByteString -- ^ Unix group name.+ , fileMode :: !FileMode -- ^ Unix file permissions+ , fileSize :: !FileOffset -- ^ File size+ , fileType :: !FileType -- ^ File type. `FTNormal`, `FTHardLink` (@since 0.3.0),+ -- `FTSymbolicLink` and `FTDirectory` are the only ones supported+ -- for now+ , fileModTime :: !EpochTime -- ^ File modification timestamp+ } deriving (Show, Eq)+++data Header = Header+ { headerOffset :: !FileOffset+ , headerPayloadOffset :: !FileOffset+ , headerFileNameSuffix :: !ShortByteString+ , headerFileMode :: !CMode+ , headerOwnerId :: !UserID+ , headerGroupId :: !GroupID+ , headerPayloadSize :: !FileOffset+ , headerTime :: !EpochTime+ , headerLinkIndicator :: !Word8+ , headerLinkName :: !ShortByteString+ , headerMagicVersion :: !ShortByteString+ , headerOwnerName :: !ShortByteString+ , headerGroupName :: !ShortByteString+ , headerDeviceMajor :: !DeviceID+ , headerDeviceMinor :: !DeviceID+ , headerFileNamePrefix :: !ShortByteString+ }+ deriving Show++-- | Type synonym representing a pax extended header.+type PaxHeader = Map ByteString ByteString++-- | Type representing states (global, next file) given pax extended headers.+data PaxState = PaxState PaxHeader PaxHeader++-- | The initial state before applying any pax extended headers.+initialPaxState :: PaxState+initialPaxState = PaxState mempty mempty++data TarChunk+ = ChunkHeader Header+ | ChunkPayload !FileOffset !ByteString+ | ChunkException TarException+ deriving Show++-- | This the the exception type that is used in this module.+--+-- More constructors are susceptible to be added without bumping the major+-- version of this module.+data TarException+ = NoMoreHeaders+ | UnexpectedPayload !FileOffset+ | IncompleteHeader !FileOffset+ | IncompletePayload !FileOffset !ByteCount+ | ShortTrailer !FileOffset+ | BadTrailer !FileOffset+ | InvalidHeader !FileOffset+ | BadChecksum !FileOffset+ | FileTypeError !FileOffset !Char !String+ | UnsupportedType !FileType+ deriving Show+instance Exception TarException+++data TarCreateException+ = FileNameTooLong !FileInfo+ | TarCreationError !String+ deriving Show+instance Exception TarCreateException++-- | Convert `FilePath` into a UTF-8 encoded `ByteString`+encodeFilePath :: FilePath -> S8.ByteString+encodeFilePath = T.encodeUtf8 . T.pack++-- | Convert UTF-8 encoded `ByteString` back into the `FilePath`.+decodeFilePath :: S8.ByteString -> FilePath+decodeFilePath = T.unpack . T.decodeUtf8With T.lenientDecode++-- | Get the `FilePath`.+getFileInfoPath :: FileInfo -> FilePath+getFileInfoPath = decodeFilePath . filePath
+ src/Data/Conduit/Tar/Unix.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Data.Conduit.Tar.Unix+ ( getFileInfo+ , restoreFileInternal+ ) where++import Conduit hiding (throwM)+import Control.Exception.Safe+import Control.Monad (void, when, unless)+import Data.Bits+import qualified Data.ByteString.Char8 as S8+import Data.Either+import Data.Conduit.Tar.Types+import Foreign.C.Types (CTime (..))+import qualified System.Directory as Dir+import qualified System.Posix.Files as Posix+import qualified System.Posix.User as Posix+import qualified System.FilePath.Posix as Posix+#if MIN_VERSION_unix(2,8,0)+import qualified System.Posix.User.ByteString as UBS+#endif++getFileInfo :: FilePath -> IO FileInfo+getFileInfo fpStr = do+ let fp = encodeFilePath fpStr+ fs <- Posix.getSymbolicLinkStatus fpStr+ let uid = Posix.fileOwner fs+ gid = Posix.fileGroup fs+ -- Allow for username/group retrieval failure, especially useful for non-tty environment.+ -- Workaround for: https://ghc.haskell.org/trac/ghc/ticket/1487+ -- Moreover, names are non-critical as they are not used during unarchival process+#if MIN_VERSION_unix(2,8,0)+ euEntry :: Either IOException UBS.UserEntry <- try $ Posix.getUserEntryForID uid+ egEntry :: Either IOException UBS.GroupEntry <- try $ Posix.getGroupEntryForID gid+ let+ fileUserName = either (const "") UBS.userName euEntry+ fileGroupName = either (const "") UBS.groupName egEntry+#else+ euEntry :: Either IOException Posix.UserEntry <- try $ Posix.getUserEntryForID uid+ egEntry :: Either IOException Posix.GroupEntry <- try $ Posix.getGroupEntryForID gid+ let+ fileUserName = either (const "") (S8.pack . Posix.userName) euEntry+ fileGroupName = either (const "") (S8.pack . Posix.groupName) egEntry+#endif+ (fType, fSize) <-+ case () of+ () | Posix.isRegularFile fs -> return (FTNormal, Posix.fileSize fs)+ | Posix.isSymbolicLink fs -> do+ ln <- Posix.readSymbolicLink fpStr+ return (FTSymbolicLink (encodeFilePath ln), 0)+ | Posix.isCharacterDevice fs -> return (FTCharacterSpecial, 0)+ | Posix.isBlockDevice fs -> return (FTBlockSpecial, 0)+ | Posix.isDirectory fs -> return (FTDirectory, 0)+ | Posix.isNamedPipe fs -> return (FTFifo, 0)+ | otherwise -> error $ "Unsupported file type: " ++ S8.unpack fp+ return $! FileInfo+ { filePath = fp+ , fileUserId = uid+ , fileUserName = fileUserName+ , fileGroupId = gid+ , fileGroupName = fileGroupName+ , fileMode = Posix.fileMode fs .&. 0o7777+ , fileSize = fSize+ , fileType = fType+ , fileModTime = Posix.modificationTime fs+ }++-- | See 'Data.Conduit.Tar.restoreFileWithErrors' for documentation+restoreFileInternal ::+ (MonadResource m)+ => Bool+ -> FileInfo+ -> ConduitM S8.ByteString (IO (FileInfo, [SomeException])) m ()+restoreFileInternal lenient fi@FileInfo {..} = do+ let fpStr = decodeFilePath filePath+ tryAnyCond action = if lenient then tryAny action else fmap Right action+ restorePermissions = do+ eExc1 <- tryAnyCond $ Posix.setOwnerAndGroup fpStr fileUserId fileGroupId+ eExc2 <- tryAnyCond $ Posix.setFileMode fpStr fileMode+ return $! fst $ partitionEithers [eExc1, eExc2]+ -- | Catch all exceptions, but only if lenient is set to True+ case fileType of+ FTDirectory -> do+ excs <- liftIO $ do+ Dir.createDirectoryIfMissing True fpStr+ restorePermissions+ yield $ do+ eExc <- tryAnyCond (Dir.doesDirectoryExist fpStr >>=+ (`when` Posix.setFileTimes fpStr fileModTime fileModTime))+ return (fi, either ((excs ++) . pure) (const excs) eExc)+ FTSymbolicLink link -> do+ excs <- liftIO $ do+ -- Try to unlink any existing file/symlink+ void $ tryAny $ Posix.removeLink fpStr+ when lenient $ Dir.createDirectoryIfMissing True $ Posix.takeDirectory fpStr+ Posix.createSymbolicLink (decodeFilePath link) fpStr+ eExc1 <- tryAnyCond $ Posix.setSymbolicLinkOwnerAndGroup fpStr fileUserId fileGroupId+#if MIN_VERSION_unix(2,7,0)+ -- Try best effort in setting symbolic link modification time.+ let CTime epochInt32 = fileModTime+ unixModTime = fromInteger (fromIntegral epochInt32)+ eExc2 <- tryAny $ Posix.setSymbolicLinkTimesHiRes fpStr unixModTime unixModTime+#endif+ return $ fst $ partitionEithers [eExc1, eExc2]+ unless (null excs) $ yield (return (fi, excs))+ FTHardLink link -> do+ excs <- liftIO $ do+ let linkedFp = decodeFilePath link+ when lenient $ do+ linkedFileExists <- Posix.fileExist linkedFp+ -- If the linked file does not exist (yet), we cannot create a hard link.+ -- Try to "pre-create" it.+ unless linkedFileExists $ do+ Dir.createDirectoryIfMissing True $ Posix.takeDirectory linkedFp+ writeFile linkedFp ""+ Dir.createDirectoryIfMissing True $ Posix.takeDirectory fpStr+ -- Try to unlink any existing file/hard link+ void $ tryAny $ Posix.removeLink fpStr+ Posix.createLink linkedFp fpStr+ liftIO $ do+ excs <- restorePermissions+ eExc <- tryAnyCond $ Posix.setFileTimes fpStr fileModTime fileModTime+ return (either ((excs ++) . pure) (const excs) eExc)+ unless (null excs) $ yield (return (fi, excs))+ FTNormal -> do+ when lenient $ liftIO $ Dir.createDirectoryIfMissing True $ Posix.takeDirectory fpStr+ sinkFile fpStr+ excs <- liftIO $ do+ excs <- restorePermissions+ eExc <- tryAnyCond $ Posix.setFileTimes fpStr fileModTime fileModTime+ return (either ((excs ++) . pure) (const excs) eExc)+ unless (null excs) $ yield $ return (fi, excs)+ ty -> do+ let exc = UnsupportedType ty+ unless lenient $ liftIO $ throwM exc+ yield $ return (fi, [toException exc])+
+ src/Data/Conduit/Tar/Windows.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Data.Conduit.Tar.Windows+ ( getFileInfo+ , restoreFileInternal+ ) where++import Conduit+import Control.Monad (when, unless)+import Control.Exception.Safe (tryAny, SomeException, toException)+import Data.Bits+import qualified Data.ByteString.Char8 as S8+import Data.Conduit.Tar.Types+import Data.Either (partitionEithers)+import Data.Time.Clock.POSIX+import Foreign.C.Types (CTime (..))+import qualified System.Directory as Dir+import qualified System.PosixCompat.Files as Posix+import qualified System.FilePath as FilePath+++getFileInfo :: FilePath -> IO FileInfo+getFileInfo fp = do+ fs <- Posix.getSymbolicLinkStatus fp+ let uid = fromIntegral $ Posix.fileOwner fs+ gid = fromIntegral $ Posix.fileGroup fs+ (fType, fSize) <-+ case () of+ () | Posix.isRegularFile fs -> return (FTNormal, Posix.fileSize fs)+ | Posix.isDirectory fs -> return (FTDirectory, 0)+ | otherwise -> error $ "Unsupported file type: " ++ fp+ return FileInfo+ { filePath = encodeFilePath fp+ , fileUserId = uid+ , fileUserName = ""+ , fileGroupId = gid+ , fileGroupName = ""+ , fileMode = Posix.fileMode fs .&. 0o7777+ , fileSize = fSize+ , fileType = fType+ , fileModTime = Posix.modificationTime fs+ }++++-- | See 'Data.Conduit.Tar.restoreFileWithErrors' for documentation+restoreFileInternal ::+ (MonadResource m)+ => Bool+ -> FileInfo+ -> ConduitM S8.ByteString (IO (FileInfo, [SomeException])) m ()+restoreFileInternal lenient fi@FileInfo {..} = do+ let fpStr = decodeFilePath filePath+ tryAnyCond action = if lenient then tryAny action else fmap Right action+ CTime modTimeEpoch = fileModTime+ modTime = posixSecondsToUTCTime (fromIntegral modTimeEpoch)+ restoreTimeAndMode = do+ eExc1 <- tryAnyCond $ Dir.setModificationTime fpStr modTime+ eExc2 <- tryAnyCond $ Posix.setFileMode fpStr fileMode+ return $! fst $ partitionEithers [eExc1, eExc2]+ case fileType of+ FTDirectory -> do+ excs <- liftIO $ do+ Dir.createDirectoryIfMissing True fpStr+ restoreTimeAndMode+ yield $ do+ eExc <- tryAnyCond (Dir.doesDirectoryExist fpStr >>=+ (`when` Dir.setModificationTime fpStr modTime))+ return (fi, either ((excs ++) . pure) (const excs) eExc)+ FTNormal -> do+ when lenient $ liftIO $ Dir.createDirectoryIfMissing True $ FilePath.takeDirectory fpStr+ sinkFile fpStr+ excs <- liftIO $ restoreTimeAndMode+ unless (null excs) $ yield $ return (fi, excs)+ ty -> do+ let exc = UnsupportedType ty+ unless lenient $ liftIO $ throwM exc+ yield $ return (fi, [toException exc])+
tar-conduit.cabal view
@@ -1,36 +1,100 @@ name: tar-conduit-version: 0.1.1-synopsis: Parse tar files using conduit for streaming-description: Please see README.md+version: 0.4.1+synopsis: Extract and create tar files using conduit for streaming+description: Please see README.md. This is just filler to avoid warnings. homepage: https://github.com/snoyberg/tar-conduit#readme license: MIT license-file: LICENSE author: Michael Snoyman-maintainer: michael@snoyman.com, bartavelle@gmail.com+maintainer: michael@snoyman.com, bartavelle@gmail.com, alexey@kuleshevi.ch category: Data Conduit build-type: Simple-extra-source-files: README.md ChangeLog.md-cabal-version: >=1.10+extra-source-files: README.md+ ChangeLog.md+ tests/files/libpq-0.3.tar.gz+ tests/files/subdir.tar+cabal-version: 1.24 library+ if impl(ghc < 8)+ buildable: False hs-source-dirs: src- exposed-modules: Data.Conduit.Tar- build-depends: base >= 4.7 && < 5+ exposed-modules: Data.Conduit.Tar, Data.Conduit.Tar.Types+ build-depends: base >= 4.9.0.0 && < 5 , bytestring+ , conduit , conduit-combinators >= 1.0.8.1+ , containers+ , directory+ , filepath+ , mtl+ , safe-exceptions+ , text default-language: Haskell2010+ ghc-options: -Wall+ if os(windows)+ other-modules: Data.Conduit.Tar.Windows+ build-depends: time+ , unix-compat+ cpp-options: -DWINDOWS+ else+ other-modules: Data.Conduit.Tar.Unix+ build-depends: unix --- test-suite tar-conduit-test--- type: exitcode-stdio-1.0--- hs-source-dirs: test--- main-is: Spec.hs--- build-depends: base--- , hspec--- , tar-conduit--- , conduit-extra--- , conduit-combinators--- ghc-options: -threaded -rtsopts -with-rtsopts=-N--- default-language: Haskell2010+test-suite tests+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Spec.hs+ build-depends: QuickCheck+ , base >= 4.9.0.0 && < 5+ , bytestring+ , conduit+ , conduit-extra+ , conduit-combinators >= 1.0.8.1+ , directory+ , filepath+ , hspec+ , tar-conduit+ ghc-options: -O2 -threaded -rtsopts+ if os(windows)+ cpp-options: -DWINDOWS+ default-language: Haskell2010++test-suite space+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ ghc-options: -O2+ main-is: Space.hs+ hs-source-dirs: tests+ build-depends: base >= 4.9.0.0+ , bytestring+ , conduit+ , conduit-combinators >= 1.0.8.1+ , containers+ , deepseq+ , directory+ , filepath+ , hspec+ , tar-conduit+ , weigh++benchmark time+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ ghc-options: -O2+ main-is: Time.hs+ hs-source-dirs: tests+ build-depends: base >= 4.9.0.0+ , bytestring+ , conduit+ , conduit-combinators >= 1.0.8.1+ , containers+ , criterion+ , deepseq+ , directory+ , filepath+ , hspec+ , tar-conduit source-repository head type: git
+ tests/Space.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Measure space usage by the tar algo.++module Main where++import Conduit+import Control.DeepSeq+import Control.Monad+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.Conduit.List as CL+import qualified Data.Conduit.Tar as Tar+import Data.Conduit.Tar.Types+import Data.Monoid+import GHC.Generics+import System.Posix.Types+import Weigh++main :: IO ()+main = do+ mainWith+ (do setColumns [Case, Allocated, Max, Live, GCs, Check]+ sequence_+ [ action+ ("tar " ++ show count ++ " files")+ (runConduitRes (CL.sourceList files .| void Tar.tar .| CL.sinkNull))+ | count :: Int <- [1, 10, 100, 1000, 10000]+ , let !files =+ force+ (concat+ (map+ (\i -> makeFileN (S8.pack (show i) <> ".txt") 10)+ [1 :: Int .. count]))+ ]+ sequence_+ [ action+ ("tar file of " ++ show bytes ++ " bytes")+ (runConduitRes (CL.sourceList files .| void Tar.tar .| CL.sinkNull))+ | bytes :: Int <- [1, 10, 100, 1000, 10000]+ , let !files = force (makeFileN "file.txt" bytes)+ ]+ sequence_+ [ action+ ("untar " ++ show count ++ " files")+ (runConduitRes+ (CL.sourceList files .| void Tar.tar .|+ void (Tar.untar (const (return ()))) .|+ CL.sinkNull))+ | count :: Int <- [1, 10, 100, 1000, 10000]+ , let !files =+ force+ (concat+ (map+ (\i -> makeFileN (S8.pack (show i) <> ".txt") 10)+ [1 :: Int .. count]))+ ]+ sequence_+ [ action+ ("untar file of " ++ show bytes ++ " bytes")+ (runConduitRes+ (CL.sourceList files .| void Tar.tar .|+ void (Tar.untar (const (return ()))) .|+ CL.sinkNull))+ | bytes :: Int <- [1, 10, 100, 1000, 10000]+ , let !files = force (makeFileN "file.txt" bytes)+ ])++----------------------------------------------------------------------+-- Helpers++makeFileN :: ByteString -> Int -> [Either FileInfo ByteString]+makeFileN fname bytes =+ let contents = S8.pack (take bytes (cycle "Hello Dave"))+ in [ Left+ FileInfo+ { filePath = fname+ , fileUserId = 0+ , fileUserName = "test"+ , fileGroupId = 0+ , fileGroupName = "test"+ , fileMode = 0+ , fileSize = fromIntegral (S.length contents)+ , fileType = FTNormal+ , fileModTime = 1234+ }+ , Right contents+ ]++----------------------------------------------------------------------+-- NFData helper instances. If ever these instances become available,+-- these can just be removed.++deriving instance Generic FileInfo+instance NFData FileInfo++deriving instance Generic FileType+instance NFData FileType++deriving instance Generic CUid+instance NFData CUid++deriving instance Generic COff+instance NFData COff++deriving instance Generic CGid+instance NFData CGid++deriving instance Generic CMode+instance NFData CMode
+ tests/Spec.hs view
@@ -0,0 +1,436 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Main where++import Conduit+import Control.Exception+import Control.Monad (forM_, void, when, zipWithM_)+import Data.ByteString as S+import Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy.Char8 as LS8+import Data.ByteString.Short (fromShort)+import Data.Conduit.List+import Data.Conduit.Tar+import Data.Int+import Data.List (sortOn)+import Data.Monoid+import Prelude as P+import System.Directory+import qualified System.FilePath as Host+import qualified System.FilePath.Posix as Posix -- always use forward slashes+import System.IO+import System.IO (BufferMode (LineBuffering),+ hSetBuffering, stdout)+import Test.Hspec+import Test.QuickCheck++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (pure, (<$>))+import Data.Word+#endif++import Data.Conduit.Zlib (ungzip)++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ let baseTmp = "tar-conduit-tests"+ isStack <- doesDirectoryExist ".stack-work"+ let testPaths =+ ["src", "README.md", "ChangeLog.md", "LICENSE"]+#ifndef WINDOWS+ <> ["./tests"]+ -- On Windows, the 'stack test' command results in error message:+ --+ -- uncaught exception: IOException of type PermissionDenied+ -- System.Win32File.read: permission denied (Permission denied)+ --+ -- if '.stack-work' is included in the test paths.+ <> [".stack-work" | isStack]+#else+ -- The package does not support symlinks on Windows. See+ -- Data.Conduit.Tar.Windows.getFileInfo.+ <> ["./tests/files"]+#endif+ hspec $ do+ describe "tar/untar" $ do+ let tarUntarContent dir =+ runConduitRes $+ yield dir .| void tarFilePath .| untar (const (foldC >>= yield)) .| foldC+ it "content" $ do+ c <- collectContent "src"+ tarUntarContent "src" `shouldReturn` c+ describe "tar/untar/tar" $ do+ around (withTempTarFiles baseTmp) $+ it "structure" $ \(fpIn, hIn, outDir, fpOut) -> do+ writeTarball hIn testPaths+ hClose hIn+ extractTarball fpIn (Just outDir)+ curDir <- getCurrentDirectory+ finally+ (setCurrentDirectory outDir >> createTarball fpOut testPaths)+ (setCurrentDirectory curDir)+ tb1 <- readTarballSorted fpIn+ tb2 <- readTarballSorted fpOut+ P.length tb1 `shouldBe` P.length tb2+ zipWithM_ shouldBe (fmap fst tb2) (fmap fst tb1)+ zipWithM_ shouldBe (fmap snd tb2) (fmap snd tb1)+ describe "untar" $ do+ around (withTempTarFiles baseTmp) $+ it "create-intermediate" $ \(fpIn, hIn, outDir, fpOut) -> do+ hClose hIn+ extractTarballLenient "tests/files/subdir.tar" (Just outDir)+ curDir <- getCurrentDirectory+ collectContent (outDir Posix.</> "dir/subdir/") `shouldReturn` "Hello World\n"+ describe "ustar" ustarSpec+ describe "GNUtar" gnutarSpec+ describe "pax" paxSpec+ describe "unsupported headers" $ do+ it "associated payload is discarded" $ do+ contents <- readGzipTarball "./tests/files/libpq-0.3.tar.gz"+ let fileNames = filePath . fst <$> contents+ fileNames `shouldContain` [ "libpq-0.3/"+ , "libpq-0.3/.gitignore"+ , "libpq-0.3/Database/"+ , "libpq-0.3/Database/PQ.hsc"+ , "libpq-0.3/LICENSE"+ , "libpq-0.3/README.md"+ , "libpq-0.3/Setup.hs"+ , "libpq-0.3/libpq.cabal"+ ]++defFileInfo :: FileInfo+defFileInfo =+ FileInfo+ { filePath = "test-file-name"+ , fileUserId = 1000+ , fileUserName = "test-user-name"+ , fileGroupId = 1000+ , fileGroupName = "test-group-name"+ , fileMode = 0o644+ , fileSize = 0+ , fileType = FTNormal+ , fileModTime = 123456789+ }+++fileInfoExpectation :: [(FileInfo, ByteString)] -> IO ()+fileInfoExpectation files = do+ let source = P.concat [[Left fi, Right content] | (fi, content) <- files]+ collectBack fi = do+ content <- foldC+ yield (fi, content)+ result <- runConduit $ sourceList source .| void tar .| untar collectBack .| sinkList+ result `shouldBe` files++data GnuTarFile = GnuTarFile FileInfo (Maybe ByteString) deriving (Show, Eq)++asciiGen :: Int -> Gen ByteString+asciiGen n = S.pack <$> vectorOf n (frequency [(1, pure 0x2f), (20, choose (0x20, 0x7e))])++instance Arbitrary GnuTarFile where+ arbitrary = do+ filePathLen <- (`mod` 4090) <$> arbitrary+ filePath <- ("test-" <>) . S8.filter (/= ('\\')) <$> asciiGen filePathLen+ NonNegative fileUserId64 <- arbitrary+ let fileUserId = fromIntegral (fileUserId64 :: Int64)+ NonNegative fileGroupId64 <- arbitrary+ let fileGroupId = fromIntegral (fileGroupId64 :: Int64)+ fileUserNameLen <- (`mod` 32) <$> arbitrary+ fileUserName <- asciiGen fileUserNameLen+ fileGroupNameLen <- (`mod` 32) <$> arbitrary+ fileGroupName <- asciiGen fileGroupNameLen+ fileMode <- fromIntegral <$> choose (0o000 :: Word, 0o777)+ -- TODO: use `filePathLen` instead, once long link name 'K' is implemented+ linkNameLen <- (`mod` 101) <$> arbitrary+ fileType <-+ oneof+ [ pure FTNormal+ , pure FTDirectory+ , FTSymbolicLink <$> asciiGen linkNameLen+ , FTHardLink <$> asciiGen linkNameLen+ ]+ (fileSize, mContent) <-+ case fileType of+ FTNormal -> do+ content <- arbitraryByteString+ return (fromIntegral (S.length content), Just content)+ _ -> return (0, Nothing)+ fileModTime <- fromIntegral <$> (arbitrary :: Gen Int64)+ return (GnuTarFile FileInfo {..} mContent)++arbitraryByteString :: Gen ByteString+arbitraryByteString = do+ maxLen <- arbitrary+ len <- (`mod` (maxLen + 1)) <$> arbitrary+ genFun <- arbitrary+ let strGen x | x < len = Just (genFun x, x + 1)+ | otherwise = Nothing+ return $ fst $ S.unfoldrN maxLen strGen 0++fileInfoProperty :: [GnuTarFile] -> Property+fileInfoProperty files = either throw (source ===) eResult+ where+ eResult = runConduit $ sourceList source .| void tar .| untar collectBack .| sinkList+ source =+ P.concat [Left fi : maybe [] ((: []) . Right) mContent | GnuTarFile fi mContent <- files]+ collectBack fi = do+ yield $ Left fi+ case fileType fi of+ FTNormal -> do+ content <- foldC+ yield $ Right content+ _ -> return ()+++emptyFileInfoExpectation :: FileInfo -> IO ()+emptyFileInfoExpectation fi = fileInfoExpectation [(fi, "")]++ustarSpec :: Spec+ustarSpec = do+ it "minimal" $ do+ emptyFileInfoExpectation defFileInfo+ it "long file name <255" $ do+ emptyFileInfoExpectation $+ defFileInfo {filePath = S8.pack (P.replicate 99 'f' Posix.</> P.replicate 99 'o')}+++gnutarSpec :: Spec+gnutarSpec = do+ it "LongLink - a file with long file name" $ do+ emptyFileInfoExpectation $+ defFileInfo+ { filePath =+ S8.pack (P.replicate 100 'f' Posix.</>+ P.replicate 100 'o' Posix.</>+ P.replicate 99 'b')+ }+ it "LongLink - multiple files with long file names" $ do+ fileInfoExpectation+ [ ( defFileInfo+ { filePath =+ S8.pack (P.replicate 100 'f' Posix.</>+ P.replicate 100 'o' Posix.</>+ P.replicate 99 'b')+ , fileSize = 10+ }+ , "1234567890")+ , ( defFileInfo+ { filePath =+ S8.pack (P.replicate 1000 'g' Posix.</>+ P.replicate 1000 'o' Posix.</>+ P.replicate 99 'b')+ , fileSize = 11+ }+ , "abcxdefghij")+ ]+ it "Large User Id" $ do emptyFileInfoExpectation $ defFileInfo {fileUserId = 0o777777777}+ it "All Large Numeric Values" $ do+ emptyFileInfoExpectation $+ defFileInfo+ { fileUserId = 0x7FFFFFFFFFFFFFFF+ , fileGroupId = 0x7FFFFFFFFFFFFFFF+ , fileModTime = fromIntegral (maxBound :: Int64)+ }+ it "Negative Values" $ do+ emptyFileInfoExpectation $ defFileInfo {fileModTime = fromIntegral (minBound :: Int64)}+ emptyFileInfoExpectation $ defFileInfo {fileModTime = -10}+ emptyFileInfoExpectation $ defFileInfo {fileUserId = fromIntegral (minBound :: Int64)}+ it "Negative Size" $+ (emptyFileInfoExpectation (defFileInfo {fileSize = -10}) `shouldThrow`+ (\case+ TarCreationError _ -> True+ _ -> False))+ it "tar/untar Property" $ property fileInfoProperty+++withTempTarFiles :: FilePath -> ((FilePath, Handle, FilePath, FilePath) -> IO c) -> IO c+withTempTarFiles base =+ bracket+ (do tmpDir <- getTemporaryDirectory+ (fp1, h1) <- openBinaryTempFile tmpDir (Host.addExtension base ".tar")+ let outPath = Host.dropExtension fp1 ++ ".out"+ return (fp1, h1, outPath, Host.addExtension outPath ".tar")+ )+ (\(fp, h, dirOut, fpOut) -> do+ hClose h+ removeFile fp+ doesDirectoryExist dirOut >>= (`when` removeDirectoryRecursive dirOut)+ doesFileExist fpOut >>= (`when` removeFile fpOut)+ )++-- | Collects all of the files and direcotries from the tarball. Then all of them get sorted, since+-- apparently Windows has no guaranteed order the files within a directory will be listed in upon a+-- tarball creation.+readTarballSorted+ :: FilePath -> IO [(FileInfo, Maybe ByteString)]+readTarballSorted fp =+ sortOn (filePath . fst) <$>+ (runConduitRes $ sourceFileBS fp .| untar grabBoth .| sinkList)++readGzipTarball+ :: FilePath+ -> IO [(FileInfo, Maybe ByteString)]+readGzipTarball fp =+ runConduitRes $ sourceFileBS fp .| ungzip .| untar grabBoth .| sinkList++grabBoth+ :: (Monad m)+ => FileInfo+ -> ConduitM ByteString (FileInfo, Maybe ByteString) m ()+grabBoth fi =+ case fileType fi of+ FTNormal -> do+ content <- foldC+ yield (fi, Just content)+ _ -> yield (fi, Nothing)++collectContent :: FilePath -> IO (ByteString)+collectContent dir =+ runConduitRes $+ sourceDirectoryDeep False dir .| mapMC (\fp -> runConduit (sourceFileBS fp .| foldC)) .| foldC++-- | This test uses untar to process a simple example in the pax interchange+-- format.+paxSpec :: Spec+paxSpec = assert payloadSizeCheck $ do+ it "untarChunksRaw, pax interchange format" $ do+ res <- runConduitRes $+ paxExample+ .| chopEvery bigChopSize+ .| untarChunksRaw+ .| processTarChunks+ .| sinkList+ pure res `shouldReturn`+ [ "/pax-global-header"+ , "payload: 19 comment=Example\n"+ , "/pax-extended-header"+ , "payload: " <> bigPayload1+ , "payload: " <> bigPayload2+ , "original-dir/original-filepath"+ , "payload: " <> smallPayload+ ]+ it "untar, pax interchange format" $ do+ res <- runConduitRes $+ paxExample+ .| chopEvery smallChopSize+ .| untar process+ .| sinkList+ pure res `shouldReturn`+ [ (veryLongFilepath, smallPayload1)+ , (veryLongFilepath, smallPayload2)+ ]+ it "untarRaw, pax interchange format" $ do+ res <- runConduitRes $+ paxExample+ .| chopEvery smallChopSize+ .| untarRaw process+ .| sinkList+ pure res `shouldReturn`+ [ ("original-dir/original-filepath", smallPayload1)+ , ("original-dir/original-filepath", smallPayload2)+ ]+ where+ process fi = awaitForever $ \bs -> yield (filePath fi, bs)+ processTarChunks = awaitForever $ \tc -> yield $ case tc of+ ChunkHeader h -> fromShort $+ headerFileNamePrefix h <> "/" <> headerFileNameSuffix h+ ChunkPayload _ bs -> "payload: " <> bs+ ChunkException e -> "exception: " <> S8.pack (show e)+ chopEvery :: (MonadIO m) => Int -> ConduitT ByteString ByteString m ()+ chopEvery n = chop+ where+ chop = await >>= \case+ Nothing -> pure ()+ Just val -> do+ forM_ (split (S.unpack val)) $ \chunk -> yield (S.pack chunk)+ chop+ split = P.takeWhile (not . P.null)+ . P.map (P.take n)+ . P.iterate (P.drop n)+ bigChopSize = 512+ (bigPayload1, bigPayload2) = S.splitAt bigChopSize veryLongFilepathRecord+ smallChopSize = 4+ (smallPayload1, smallPayload2) = S.splitAt smallChopSize smallPayload+ moreThanHalf s l = l > s && l <= 2 * s+ payloadSizeCheck =+ moreThanHalf bigChopSize (S.length veryLongFilepathRecord)+ && moreThanHalf smallChopSize (S.length smallPayload)+++-- | Produces a simple example in the pax interchange format. It has a pax+-- \'global\' header block providing a comment, a pax \'next\' header block+-- providing a very long path (@\"very\very\...\very\long\filepath\"@), and a+-- normal file with filepath @\"original-filepath\"@ and payload @\"payload\".+paxExample :: MonadThrow m => ConduitM a ByteString m ()+paxExample = void $+ yieldMany+ [ Left globalHeader+ , Right globalPayload+ , Left extendedHeader+ , Right extendedPayload+ , Left ustarHeader+ , Right ustarPayload+ ]+ .| void tarEntries+ where+ defaultHeader :: FileOffset -> Header+ defaultHeader offset = Header+ { headerOffset = offset+ , headerPayloadOffset = offset + 512+ , headerFileNameSuffix = mempty+ , headerFileMode = 0o666+ , headerOwnerId = 0x0+ , headerGroupId = 0x0+ , headerPayloadSize = 0x0+ , headerTime = 0x0+ , headerLinkIndicator = 0x0+ , headerLinkName = mempty+ , headerMagicVersion = "ustar"+ , headerOwnerName = "root"+ , headerGroupName = "root"+ , headerDeviceMajor = 0x0+ , headerDeviceMinor = 0x0+ , headerFileNamePrefix = mempty+ }+ nextOffset :: Header -> FileOffset+ nextOffset h =+ let payloadRecordCount = (headerPayloadSize h + 511) `div` 512+ in headerPayloadOffset h + 512 + payloadRecordCount * 512+ globalHeader = (defaultHeader 0x0)+ { headerFileNameSuffix = "pax-global-header"+ , headerPayloadSize = fromIntegral $ S.length globalPayload+ , headerLinkIndicator = 0x67 -- UTF-8 'g'+ }+ globalPayload = "19 comment=Example\n"+ extendedHeader = (defaultHeader $ nextOffset globalHeader)+ { headerFileNameSuffix = "pax-extended-header"+ , headerPayloadSize = fromIntegral $ S.length extendedPayload+ , headerLinkIndicator = 0x78 -- UTF-8 'x'+ }+ -- The path in the pax extended header should override the filepath+ -- specified in the ustar header.+ extendedPayload = veryLongFilepathRecord+ ustarHeader = (defaultHeader $ nextOffset extendedHeader)+ { headerFileNameSuffix = "original-filepath"+ , headerPayloadSize = fromIntegral $ S.length ustarPayload+ , headerLinkIndicator = 0x30 -- UTF-8 '0'+ , headerFileNamePrefix = "original-dir"+ }+ ustarPayload = smallPayload++-- | A very/very/.../very/long/filepath with 653 bytes.+veryLongFilepath :: ByteString+veryLongFilepath =+ S8.toStrict (LS8.take 640 $ LS8.cycle "very/") <> "long/filepath"++-- | A very, very, ..., very, long filepath record with 663 bytes.+veryLongFilepathRecord :: ByteString+veryLongFilepathRecord = "663 path=" <> veryLongFilepath <> "\n"++-- | A small payload.+smallPayload :: ByteString+smallPayload = "payload"
+ tests/Time.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Measure time usage by the tar/untar functions.++module Main where++import Conduit+import Control.DeepSeq+import Control.Monad+import Criterion.Main+import Data.ByteString (ByteString)+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.Conduit.List as CL+import qualified Data.Conduit.Tar as Tar+import Data.Conduit.Tar.Types+import Data.Monoid+import GHC.Generics+import System.Posix.Types++main :: IO ()+main =+ defaultMain+ (concat+ [ [ bench+ ("tar " ++ show count ++ " files")+ (nfIO+ (runConduitRes+ (CL.sourceList files .| void Tar.tar .| CL.sinkNull)))+ | count :: Int <- [1, 10, 100, 1000, 10000]+ , let !files =+ force+ (concat+ (map+ (\i -> makeFileN (S8.pack (show i) <> ".txt") 10)+ [1 :: Int .. count]))+ ]+ , [ bench+ ("tar file of " ++ show bytes ++ " bytes")+ (nfIO+ (runConduitRes+ (CL.sourceList files .| void Tar.tar .| CL.sinkNull)))+ | bytes :: Int <- [1, 10, 100, 1000, 10000]+ , let !files = force (makeFileN "file.txt" bytes)+ ]+ , [ bench+ ("untar " ++ show count ++ " files")+ (nfIO+ (runConduitRes+ (CL.sourceList files .| void Tar.tar .|+ void (Tar.untar (const (return ()))) .|+ CL.sinkNull)))+ | count :: Int <- [1, 10, 100, 1000, 10000]+ , let !files =+ force+ (concat+ (map+ (\i -> makeFileN (S8.pack (show i) <> ".txt") 10)+ [1 :: Int .. count]))+ ]+ , [ bench+ ("untar file of " ++ show bytes ++ " bytes")+ (nfIO+ (runConduitRes+ (CL.sourceList files .| void Tar.tar .|+ void (Tar.untar (const (return ()))) .|+ CL.sinkNull)))+ | bytes :: Int <- [1, 10, 100, 1000, 10000]+ , let !files = force (makeFileN "file.txt" bytes)+ ]+ ])+++----------------------------------------------------------------------+-- Helpers++makeFileN :: ByteString -> Int -> [Either FileInfo ByteString]+makeFileN fname bytes =+ let contents = S8.pack (take bytes (cycle "Hello Dave"))+ in [ Left+ FileInfo+ { filePath = fname+ , fileUserId = 0+ , fileUserName = "test"+ , fileGroupId = 0+ , fileGroupName = "test"+ , fileMode = 0+ , fileSize = fromIntegral (S.length contents)+ , fileType = FTNormal+ , fileModTime = 1234+ }+ , Right contents+ ]++----------------------------------------------------------------------+-- NFData helper instances. If ever these instances become available,+-- these can just be removed.++deriving instance Generic FileInfo+instance NFData FileInfo++deriving instance Generic FileType+instance NFData FileType++deriving instance Generic CUid+instance NFData CUid++deriving instance Generic COff+instance NFData COff++deriving instance Generic CGid+instance NFData CGid++deriving instance Generic CMode+instance NFData CMode
+ tests/files/libpq-0.3.tar.gz view
binary file changed (absent → 23319 bytes)
+ tests/files/subdir.tar view
binary file changed (absent → 10240 bytes)