diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 - diff --git a/src/Data/Conduit/Tar.hs b/src/Data/Conduit/Tar.hs --- a/src/Data/Conduit/Tar.hs +++ b/src/Data/Conduit/Tar.hs @@ -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: +-- +-- +-- @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", , , +-- +-- If the record does not parse @(, )@, 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 $ + ": 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 $ + ": 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 $ + ": 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 $ + ": 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 $ + ": 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 $ + ": Not enough payload for file: " ++ headerFilePath header + Just (Right content) -> do + let nextSize = prevSize + fromIntegral (S.length content) + unless (nextSize <= headerPayloadSize header) $ + throwM $ + TarCreationError $ + ": 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 ": 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 ": 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 ": 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 $ + ": 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 diff --git a/src/Data/Conduit/Tar/Types.hs b/src/Data/Conduit/Tar/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Tar/Types.hs @@ -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 diff --git a/src/Data/Conduit/Tar/Unix.hs b/src/Data/Conduit/Tar/Unix.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Tar/Unix.hs @@ -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]) + diff --git a/src/Data/Conduit/Tar/Windows.hs b/src/Data/Conduit/Tar/Windows.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Tar/Windows.hs @@ -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]) + diff --git a/tar-conduit.cabal b/tar-conduit.cabal --- a/tar-conduit.cabal +++ b/tar-conduit.cabal @@ -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 diff --git a/tests/Space.hs b/tests/Space.hs new file mode 100644 --- /dev/null +++ b/tests/Space.hs @@ -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 diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -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" diff --git a/tests/Time.hs b/tests/Time.hs new file mode 100644 --- /dev/null +++ b/tests/Time.hs @@ -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 diff --git a/tests/files/libpq-0.3.tar.gz b/tests/files/libpq-0.3.tar.gz new file mode 100644 Binary files /dev/null and b/tests/files/libpq-0.3.tar.gz differ diff --git a/tests/files/subdir.tar b/tests/files/subdir.tar new file mode 100644 Binary files /dev/null and b/tests/files/subdir.tar differ