tar-conduit 0.1.1 → 0.2.0

raw patch · 9 files changed

+1212/−119 lines, 9 filesdep +conduitdep +containersdep +criteriondep ~basedep ~conduit-combinatorsnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: conduit, containers, criterion, deepseq, directory, filepath, hspec, tar-conduit, time, unix, unix-compat, weigh

Dependency ranges changed: base, conduit-combinators

API changes (from Hackage documentation)

Files

• ChangeLog.md +9/−0
• src/Data/Conduit/Tar.hs +573/−103
• src/Data/Conduit/Tar/Types.hs +110/−0
• src/Data/Conduit/Tar/Unix.hs +75/−0
• src/Data/Conduit/Tar/Windows.hs +62/−0
• tar-conduit.cabal +66/−16
• tests/Space.hs +116/−0
• tests/Spec.hs +81/−0
• tests/Time.hs +120/−0

@@ -1,3 +1,12 @@+## 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 some GNU tar features: long file name, discardes.+ * Helper tar/untar functions for dealing with 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))

@@ -1,76 +1,75 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns       #-}+{-# LANGUAGE CPP                #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE RecordWildCards    #-} {-| 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+      tar+    , tarEntries+    , untar+    , untarWithFinalizers+    , restoreFile+    , restoreFileInto     , withEntry     , withEntries       -- * Helper functions     , headerFileType     , headerFilePath+      -- ** Creation+    , tarFilePath+    , filePathConduit+      -- * Directly on files+    , createTarball+    , writeTarball+    , extractTarball       -- * Types-    , Header (..)-    , TarChunk (..)-    , TarException (..)-    , Offset-    , Size-    , FileType (..)+    , module Data.Conduit.Tar.Types     ) 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 ((<>))+import           Conduit                  as C+import           Control.Exception        (assert)+import           Control.Monad            (unless, void)+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           Data.Monoid              ((<>), mempty)+import           Foreign.C.Types          (CTime (..))+import           System.Directory         (createDirectoryIfMissing,+                                           getCurrentDirectory)+import           System.FilePath+import           System.IO  #if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<*))+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+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.length headerFileNamePrefix > 0+        then S.concat+                 [fromShort headerFileNamePrefix, pathSeparatorS, fromShort headerFileNameSuffix]+        else fromShort headerFileNameSuffix+ headerFilePath :: Header -> FilePath-headerFilePath h = S8.unpack $ fromShort-                 $ headerFileNamePrefix h <> headerFileNameSuffix h+headerFilePath = S8.unpack . headerFilePathBS -data FileType-    = FTNormal-    | FTHardLink-    | FTSymbolicLink-    | FTCharacterSpecial-    | FTBlockSpecial-    | FTDirectory-    | FTFifo-    | FTOther !Word8-    deriving (Show, Eq)  headerFileType :: Header -> FileType headerFileType h =@@ -78,39 +77,14 @@         0  -> FTNormal         48 -> FTNormal         49 -> FTHardLink-        50 -> FTSymbolicLink+        50 -> FTSymbolicLink (fromShort (headerLinkName h))         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 :: FileOffset -> 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@@ -124,8 +98,10 @@         , headerOwnerId        = getOctal 108 8         , headerGroupId        = getOctal 116 8         , headerPayloadSize    = getOctal 124 12-        , headerTime           = getOctal 136 12+        , headerTime           = CTime $ getOctal 136 12         , headerLinkIndicator  = BU.unsafeIndex bs 156+        , headerLinkName       = getShort 157 100+        , headerMagicVersion   = toShort $ S.take 8 $ S.drop 257 bs         , headerOwnerName      = getShort 265 32         , headerGroupName      = getShort 297 32         , headerDeviceMajor    = getOctal 329 8@@ -150,8 +126,8 @@     zero = 48     seven = 55 -untar :: Monad m => ConduitM ByteString TarChunk m ()-untar =+untarChunks :: Monad m => ConduitM ByteString TarChunk m ()+untarChunks =     loop 0   where     loop !offset = assert (offset `mod` 512 == 0) $ do@@ -179,9 +155,9 @@                         yield $ ChunkHeader h                         offset' <- payloads (offset + 512) $ headerPayloadSize h                         let expectedOffset = offset + 512 + headerPayloadSize h +-                                (case (512 - (headerPayloadSize h `mod` 512)) of+                                (case 512 - (headerPayloadSize h `mod` 512) of                                     512 -> 0-                                    x -> x)+                                    x   -> x)                         assert (offset' == expectedOffset) (loop offset')             _ -> do                 leftover bs@@ -191,23 +167,24 @@         let padding =                 case offset `mod` 512 of                     0 -> 0-                    x -> 512 - x+                    x -> 512 - fromIntegral x         takeCE padding .| sinkNull-        return $! offset + padding+        return $! offset + fromIntegral padding     payloads !offset !size = do         mbs <- await         case mbs of             Nothing -> do-                yield $ ChunkException $ IncompletePayload offset size+                yield $ ChunkException $ IncompletePayload offset $ fromIntegral size                 return offset             Just bs -> do-                let (x, y) = S.splitAt size bs+                let (x, y) = S.splitAt (fromIntegral (min size (fromIntegral (maxBound :: Int)))) bs                 yield $ ChunkPayload offset x-                let size' = size - S.length x-                    offset' = offset + S.length 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. withEntry :: MonadThrow m           => (Header -> ConduitM ByteString o m r)@@ -216,20 +193,24 @@     mc <- await     case mc of         Nothing -> throwM NoMoreHeaders-        Just (ChunkHeader h) -> payloads .| (inner h <* sinkNull)+        Just (ChunkHeader h) -> payloadsConduit .| (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 () ++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. @@ -237,17 +218,17 @@  > 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.untarChunks           -- decode the tar archive >                                .| CT.withEntries hashentry -- process each file >                                .| printC                   -- print the results >                                )@@ -270,3 +251,492 @@             => (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 portions of GNU format:+--   * '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>+withFileInfo :: MonadThrow m+             => (FileInfo -> ConduitM ByteString o m ())+             -> ConduitM TarChunk o m ()+withFileInfo inner = go+  where+    go = do+        mc <- await+        case mc of+            Nothing -> return ()+            Just (ChunkHeader h)+                | headerLinkIndicator h >= 55 -> do+                    if (headerMagicVersion h == gnuTarMagicVersion)+                        then handleGnuTarHeader h .| go+                        else go+            Just (ChunkHeader h) -> do+                payloadsConduit .| (inner (fileInfoFromHeader h) <* sinkNull)+                go+            Just x@(ChunkPayload offset _bs) -> do+                leftover x+                throwM $ UnexpectedPayload offset+            Just (ChunkException e) -> throwM e++-- | Take care of custom GNU tar format.+handleGnuTarHeader :: MonadThrow m+                   => Header+                   -> ConduitM TarChunk TarChunk m ()+handleGnuTarHeader h = do+    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 .| sinkBuilder+            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."+                    yield+                        (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 ()++++-- | Just like `withFileInfo`, but works directly on the stream of bytes.+untar :: MonadThrow m+      => (FileInfo -> ConduitM ByteString o m ())+      -> ConduitM ByteString o m ()+untar inner = untarChunks .| withFileInfo inner+++-- | 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.+untarWithFinalizers ::+       (MonadThrow m, MonadIO m)+    => (FileInfo -> ConduitM ByteString (IO ()) m ())+    -> ConduitM ByteString c m ()+untarWithFinalizers inner = do+    finilizers <- untar inner .| foldlC (>>) (return ())+    liftIO finilizers+++--------------------------------------------------------------------------------+-- 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"+    let (prefix, suffix) = splitPathAt 100 $ filePath fi+    if (SS.length prefix > 155)+        then return $ Left $ FileNameTooLong fi+        else do+            (payloadSize, linkName, linkIndicator) <-+                case fileType fi of+                    FTNormal -> return (fileSize fi, SS.empty, 48)+                    FTSymbolicLink ln -> return (0, toShort ln, 50)+                    FTDirectory -> return (0, SS.empty, 53)+                    fty -> throwM $ TarCreationError $ "Unsupported file type: " ++ show fty+            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+    encChecksum <- encodeOctal 7 $ sumsl left + 32 * 8 + sumsl right+    return $+        SL.toStrict $+        toLazyByteString $ lazyByteString left <> encChecksum <> word8 0 <> lazyByteString right+++packHeaderNoChecksum :: MonadThrow m => Header -> m (SL.ByteString, SL.ByteString)+packHeaderNoChecksum Header {..} = do+    let CTime headerTime' = headerTime+    hNameSuffix <- encodeShort 100 headerFileNameSuffix+    hFileMode <- encodeOctal 7 headerFileMode+    hOwnerId <- encodeOctal 7 headerOwnerId+    hGroupId <- encodeOctal 7 headerGroupId+    hPayloadSize <- encodeOctal 11 headerPayloadSize+    hTime <- encodeOctal 11 headerTime'+    hLinkName <- encodeShort 100 headerLinkName+    hMagicVersion <- encodeShort 8 headerMagicVersion+    hOwnerName <- encodeShort 32 headerOwnerName+    hGroupName <- encodeShort 32 headerGroupName+    hDevMajor <- encodeDevice headerDeviceMajor+    hDevMinor <- encodeDevice headerDeviceMinor+    hNamePrefix <- encodeShort 155 headerFileNamePrefix+    return+        ( toLazyByteString $+          hNameSuffix <>+          hFileMode <> word8 0 <>+          hOwnerId <> word8 0 <>+          hGroupId <> word8 0 <>+          hPayloadSize <> word8 0 <>+          hTime <> word8 0+        , toLazyByteString $+          word8 headerLinkIndicator <>+          hLinkName <>+          hMagicVersion <>+          hOwnerName <>+          hGroupName <>+          hDevMajor <> word8 0 <>+          hDevMinor <> word8 0 <>+          hNamePrefix <>+          byteString (S.replicate 12 0)+        )+  where+    encodeDevice 0     = return $ byteString $ S.replicate 7 0+    encodeDevice devid = encodeOctal 7 devid+++-- | Encode a `ShortByteString` with an exact length, NUL terminating if it is+-- shorter, but throwing `TarCreationError` if it is longer.+encodeShort :: MonadThrow m => Int -> ShortByteString -> m Builder+encodeShort !len !sbs+    | lenShort <= len = return $ shortByteString sbs <> byteString (S.replicate (len - lenShort) 0)+    | otherwise =+        throwM $+        TarCreationError $ "Can't fit '" ++ S8.unpack (fromShort sbs) ++ "' into the tar header"+  where+    lenShort = SS.length sbs+++-- | Encode a number in 8base padded with zeros. Throws `TarCreationError` when overflows.+encodeOctal :: (Show a, Integral a, MonadThrow m) => Int -> a -> m Builder+encodeOctal !len !val = go 0 val mempty+  where+    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 =+        throwM $+        TarCreationError $+        "<encodeOctal>: Tar value overflow (for maxLen " ++ show len ++ "): " ++ show val++++-- | 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 recieving 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."+            Just (Right content) -> do+                let nextSize = prevSize + fromIntegral (S.length content)+                unless (nextSize <= headerPayloadSize header) $+                    throwM $ TarCreationError "Too much payload"+                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 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 _) ->+            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 should no be modified+-- afterwards. Returned is the total size of the bytestring as a `FileOffset`.+tar :: MonadResource 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.+tarEntries :: MonadResource 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.+filePathConduit :: MonadResource m =>+                   ConduitM FilePath (Either FileInfo ByteString) m ()+filePathConduit = do+    mfp <- await+    case mfp of+        Just fp -> do+            fi <- liftIO $ getFileInfo $ S8.pack fp+            case fileType fi of+                FTNormal -> do+                    yield (Left fi)+                    sourceFile (S8.unpack (filePath fi)) .| mapC Right+                FTSymbolicLink _ -> yield (Left fi)+                FTDirectory -> do+                    yield (Left fi)+                    sourceDirectory (S8.unpack (filePath fi)) .| filePathConduit+                fty -> do+                    leftover fp+                    throwM $ TarCreationError $ "Unsupported file type: " ++ show fty+            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.+tarFilePath :: 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+createTarball :: FilePath -- ^ File name for the tarball+              -> [FilePath] -- ^ List of files and directories to include in the tarball+              -> IO ()+createTarball tarfp dirs = do+    runConduitRes $ yieldMany dirs .| void tarFilePath .| sinkFile tarfp+++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 = do+    runConduitRes $ yieldMany dirs .| void tarFilePath .| sinkHandle tarHandle+++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.+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)+++-- | 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 fi =+    restoreFile fi {filePath = S8.pack (cd </> makeRelative "/" (S8.unpack (filePath fi)))}++

@@ -0,0 +1,110 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+-- | Module contains all the types necessary for tarball processing.+module Data.Conduit.Tar.Types+    ( Header(..)+    , TarChunk(..)+    , TarException(..)+    , TarCreateException(..)+    , FileType(..)+    , FileInfo(..)+    , FileOffset+    , ByteCount+    , UserID+    , GroupID+    , DeviceID+    , EpochTime+    ) where++import           Control.Exception        (Exception)+import           Data.ByteString          (ByteString)+import           Data.ByteString.Short    (ShortByteString)+import           Data.Typeable+import           Data.Word++#if WINDOWS+import           System.PosixCompat.Types+#else+import           System.Posix.Types+#endif++data FileType+    = FTNormal+    | FTHardLink+    | 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`, `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++++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+    deriving (Show, Typeable)+instance Exception TarException+++data TarCreateException+    = FileNameTooLong   !FileInfo+    | TarCreationError  !String+    deriving (Show, Typeable)+instance Exception TarCreateException++

@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Data.Conduit.Tar.Unix+    ( getFileInfo+    , restoreFile+    ) where++import           Conduit+import           Control.Exception+import           Control.Monad                 (when)+import           Data.Bits+import qualified Data.ByteString.Char8         as S8+import           Data.Conduit.Tar.Types        (FileInfo (..), FileType (..))+import qualified System.Directory              as Dir+import qualified System.Posix.Files.ByteString as Posix+import qualified System.Posix.User             as Posix++getFileInfo :: S8.ByteString -> IO FileInfo+getFileInfo fp = do+    fs <- Posix.getSymbolicLinkStatus fp+    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+    euEntry :: Either IOException Posix.UserEntry <- try $ Posix.getUserEntryForID uid+    egEntry :: Either IOException Posix.GroupEntry <- try $ Posix.getGroupEntryForID gid+    (fType, fSize) <-+        case () of+            () | Posix.isRegularFile fs     -> return (FTNormal, Posix.fileSize fs)+               | Posix.isSymbolicLink fs    -> do+                     ln <- Posix.readSymbolicLink fp+                     return (FTSymbolicLink 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  = either (const "") (S8.pack . Posix.userName) euEntry+        , fileGroupId   = gid+        , fileGroupName = either (const "") (S8.pack . Posix.groupName) egEntry+        , fileMode      = Posix.fileMode fs .&. 0o7777+        , fileSize      = fSize+        , fileType      = fType+        , fileModTime   = Posix.modificationTime fs+        }++-- | 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 FileInfo {..} = do+    let filePath' = S8.unpack filePath+    case fileType of+        FTDirectory -> do+            liftIO $ Dir.createDirectoryIfMissing False filePath'+            yield $+                (Dir.doesDirectoryExist filePath' >>=+                 (`when` Posix.setFileTimes filePath fileModTime fileModTime))+        FTSymbolicLink link ->+            liftIO $ do+                exist <- Posix.fileExist filePath+                when exist $ Dir.removeFile filePath'+                Posix.createSymbolicLink link filePath+        FTNormal -> sinkFile filePath'+        ty -> error $ "Unsupported tar entry type: " ++ show ty+    liftIO $ do+        Posix.setFileTimes filePath fileModTime fileModTime+        Posix.setSymbolicLinkOwnerAndGroup filePath fileUserId fileGroupId+        Posix.setFileMode filePath fileMode

@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+module Data.Conduit.Tar.Windows+    ( getFileInfo+    , restoreFile+    ) where++import           Conduit+import           Control.Monad            (when)+import           Data.Bits+import qualified Data.ByteString.Char8    as S8+import           Data.Conduit.Tar.Types   (FileInfo (..), FileType (..))+import           Data.Time.Clock.POSIX+import           Foreign.C.Types          (CTime (..))+import qualified System.Directory         as Dir+import qualified System.PosixCompat.Files as Posix++getFileInfo :: S8.ByteString -> IO FileInfo+getFileInfo fp = do+    let fp' = S8.unpack fp+    fs <- Posix.getSymbolicLinkStatus fp'+    let uid = Posix.fileOwner fs+        gid = 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      = fp+        , fileUserId    = uid+        , fileUserName  = ""+        , fileGroupId   = gid+        , fileGroupName = ""+        , fileMode      = Posix.fileMode fs .&. 0o7777+        , fileSize      = fSize+        , fileType      = fType+        , fileModTime   = Posix.modificationTime fs+        }++-- | 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 FileInfo {..} = do+    let filePath' = S8.unpack filePath+        CTime modTimeEpoch = fileModTime+        modTime = posixSecondsToUTCTime (fromIntegral modTimeEpoch)+    case fileType of+        FTDirectory -> do+            liftIO $ Dir.createDirectoryIfMissing False filePath'+            yield $+                (Dir.doesDirectoryExist filePath' >>=+                 (`when` Dir.setModificationTime filePath' modTime))+        FTNormal -> sinkFile filePath'+        ty -> error $ "Unsupported tar entry type: " ++ show ty+    liftIO $ do+        Dir.setModificationTime filePath' modTime+        Posix.setSymbolicLinkOwnerAndGroup filePath' fileUserId fileGroupId+        Posix.setFileMode filePath' fileMode+

@@ -1,12 +1,12 @@ name:                tar-conduit-version:             0.1.1-synopsis:            Parse tar files using conduit for streaming-description:         Please see README.md+version:             0.2.0+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@@ -14,23 +14,73 @@  library   hs-source-dirs:      src-  exposed-modules:     Data.Conduit.Tar+  exposed-modules:     Data.Conduit.Tar, Data.Conduit.Tar.Types   build-depends:       base >= 4.7 && < 5                      , bytestring                      , conduit-combinators >= 1.0.8.1+                     , filepath   default-language:    Haskell2010+  ghc-options:         -Wall+  if os(windows)+      other-modules: Data.Conduit.Tar.Windows+      build-depends: directory+                   , time+                   , unix-compat+      cpp-options:   -DWINDOWS+  else+      other-modules: Data.Conduit.Tar.Unix+      build-depends: directory+                   , 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:       base+                     , bytestring+                     , directory+                     , filepath+                     , hspec+                     , tar-conduit+                     , conduit-combinators+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  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+               , weigh+               , deepseq+               , containers+               , bytestring+               , directory+               , filepath+               , hspec+               , tar-conduit+               , conduit-combinators+               , conduit++benchmark time+  default-language:    Haskell2010+  type: exitcode-stdio-1.0+  ghc-options: -O2+  main-is: Time.hs+  hs-source-dirs: tests+  build-depends: base+               , criterion+               , deepseq+               , containers+               , bytestring+               , directory+               , filepath+               , hspec+               , tar-conduit+               , conduit-combinators+               , conduit  source-repository head   type:     git

@@ -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

@@ -0,0 +1,81 @@+{-# LANGUAGE FlexibleContexts #-}+module Main where++import Prelude as P+import Conduit+import Control.Monad (void, when, zipWithM_)+import Test.Hspec+import Data.Conduit.Tar+import System.Directory+import Data.ByteString as S+import System.IO+import System.FilePath+import Control.Exception++main :: IO ()+main = do+    let baseTmp = "tar-conduit-tests"+    isStack <- doesDirectoryExist ".stack-work"+    let testPaths =+            ["src", "./tests", "README.md", "ChangeLog.md", "LICENSE"] +++            if isStack+                then [".stack-work", "./sample"]+                else []+    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 <- readTarball fpIn+                    tb2 <- readTarball fpOut+                    P.length tb1 `shouldBe` P.length tb2+                    zipWithM_ shouldBe (fmap fst tb2) (fmap fst tb1)+                    zipWithM_ shouldBe (fmap snd tb2) (fmap snd tb1)++withTempTarFiles :: FilePath -> ((FilePath, Handle, FilePath, FilePath) -> IO c) -> IO c+withTempTarFiles base =+    bracket+        (do tmpDir <- getTemporaryDirectory+            (fp1, h1) <- openBinaryTempFile tmpDir (addExtension base ".tar")+            let outPath = dropExtension fp1 ++ ".out"+            return (fp1, h1, outPath, addExtension outPath ".tar")+        )+        (\(fp, h, dirOut, fpOut) -> do+             hClose h+             removeFile fp+             doesDirectoryExist dirOut >>= (`when` removeDirectoryRecursive dirOut)+             doesFileExist fpOut >>= (`when` removeFile fpOut)+        )+++readTarball+  :: (MonadIO m, MonadThrow m, MonadBaseControl IO m) =>+     FilePath -> m [(FileInfo, Maybe ByteString)]+readTarball fp = runConduitRes $ sourceFileBS fp .| untar grabBoth .| sinkList+  where+    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+

@@ -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