tar-conduit 0.2.1 → 0.2.2
raw patch · 7 files changed
+519/−155 lines, 7 filesdep +QuickCheckdep +safe-exceptionsdep +textnew-uploader
Dependencies added: QuickCheck, safe-exceptions, text
Files
- ChangeLog.md +15/−3
- src/Data/Conduit/Tar.hs +230/−105
- src/Data/Conduit/Tar/Types.hs +53/−4
- src/Data/Conduit/Tar/Unix.hs +40/−22
- src/Data/Conduit/Tar/Windows.hs +15/−16
- tar-conduit.cabal +8/−4
- tests/Spec.hs +158/−1
ChangeLog.md view
@@ -1,15 +1,27 @@+## 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+ * 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.+ * 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
src/Data/Conduit/Tar.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# 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. -}@@ -10,12 +11,14 @@ tar , tarEntries , untar- , untarChunks , untarWithFinalizers , restoreFile , restoreFileInto+ -- ** Operate on Chunks+ , untarChunks , withEntry , withEntries+ , withFileInfo -- * Helper functions , headerFileType , headerFilePath@@ -33,6 +36,7 @@ import Conduit as C import Control.Exception (assert) import Control.Monad (unless, void)+import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.ByteString.Builder@@ -44,6 +48,7 @@ import Data.Foldable (foldr') import Data.Monoid ((<>), mempty) import Foreign.C.Types (CTime (..))+import Foreign.Storable import System.Directory (createDirectoryIfMissing, getCurrentDirectory) import System.FilePath@@ -68,10 +73,15 @@ [fromShort headerFileNamePrefix, pathSeparatorS, fromShort headerFileNameSuffix] else fromShort headerFileNameSuffix +-- | Construct a `FilePath` from `headerFileNamePrefix` and `headerFileNameSuffix`.+--+-- @since 0.1.0 headerFilePath :: Header -> FilePath-headerFilePath = S8.unpack . headerFilePathBS-+headerFilePath = decodeFilePath . headerFilePathBS +-- | Get Header file type.+--+-- @since 0.1.0 headerFileType :: Header -> FileType headerFileType h = case headerLinkIndicator h of@@ -86,27 +96,32 @@ x -> FTOther x parseHeader :: FileOffset -> ByteString -> Either TarException Header-parseHeader offset bs = assert (S.length bs == 512) $ do+parseHeader offset bs = do+ unless (S.length bs == 512) $ Left $ IncompleteHeader offset let checksumBytes = S.take 8 $ S.drop 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 = getOctal 108 8- , headerGroupId = getOctal 116 8- , headerPayloadSize = getOctal 124 12- , headerTime = CTime $ getOctal 136 12+ , 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 = toShort $ S.take 8 $ S.drop 257 bs+ , headerMagicVersion = magicVersion , headerOwnerName = getShort 265 32 , headerGroupName = getShort 297 32- , headerDeviceMajor = getOctal 329 8- , headerDeviceMinor = getOctal 337 8+ , headerDeviceMajor = getNumber 329 8+ , headerDeviceMinor = getNumber 337 8 , headerFileNamePrefix = getShort 345 155 } where@@ -115,8 +130,16 @@ 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+ 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 = S.foldl' (\t c -> t * 8 + fromIntegral (c - zero)) 0 . S.takeWhile (\c -> zero <= c && c <= seven)@@ -127,7 +150,15 @@ zero = 48 seven = 55 --- | Convert a stream of raw bytes into a stream of 'TarChunk's.+-- | 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. This stream can further be passed+-- into `withFileInfo` or `withHeaders` functions. -- -- @since 0.2.1 untarChunks :: Monad m => ConduitM ByteString TarChunk m ()@@ -190,6 +221,9 @@ -- | 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@@ -250,6 +284,8 @@ > 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 ())@@ -264,37 +300,42 @@ -- * Old v7 tar format. -- * ustar: POSIX 1003.1-1988 format -- * and only portions of GNU format:+-- * Larger values for `fileUserId`, `fileGroupId`, `fileSize` and `fileModTime`. -- * 'L' type - long file names, but only up to 4096 chars to prevent DoS attack -- * other types are simply discarded -- -- /Note/ - Here is a really good reference for specifics of different tar formats: -- <https://github.com/libarchive/libarchive/wiki/ManPageTar5>+--+-- @since 0.2.2 withFileInfo :: MonadThrow m => (FileInfo -> ConduitM ByteString o m ()) -> ConduitM TarChunk o m ()-withFileInfo inner = go+withFileInfo inner =+ start where- go = do- mc <- await- case mc of- Nothing -> return ()- Just (ChunkHeader h)+ start = await >>= maybe (return ()) go++ go x = do+ case x of+ ChunkHeader h | headerLinkIndicator h >= 55 -> do if (headerMagicVersion h == gnuTarMagicVersion)- then handleGnuTarHeader h .| go- else go- Just (ChunkHeader h) -> do+ then handleGnuTarHeader h >>= maybe start go+ else start+ ChunkHeader h -> do payloadsConduit .| (inner (fileInfoFromHeader h) <* sinkNull)- go- Just x@(ChunkPayload offset _bs) -> do+ start+ ChunkPayload offset _bs -> do leftover x throwM $ UnexpectedPayload offset- Just (ChunkException e) -> throwM e+ ChunkException e -> throwM e + -- | Take care of custom GNU tar format. handleGnuTarHeader :: MonadThrow m => Header- -> ConduitM TarChunk TarChunk m ()+ -> ConduitM TarChunk o m (Maybe TarChunk) handleGnuTarHeader h = do case headerLinkIndicator h of 76 -> do@@ -313,8 +354,8 @@ throwM $ FileTypeError (headerPayloadOffset nh) 'L' $ "Long filename doesn't match the original."- yield- (ChunkHeader $+ return+ (Just $ ChunkHeader $ nh { headerFileNameSuffix = toShort longFileName , headerFileNamePrefix = SS.empty@@ -327,11 +368,14 @@ 83 -> do payloadsConduit .| sinkNull -- discard sparse files payload -- TODO : Implement restoring of sparse files- _ -> return ()+ return Nothing+ _ -> return Nothing -- | Just like `withFileInfo`, but works directly on the stream of bytes.+--+-- @since 0.2.0 untar :: MonadThrow m => (FileInfo -> ConduitM ByteString o m ()) -> ConduitM ByteString o m ()@@ -342,6 +386,8 @@ -- 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 ())@@ -395,9 +441,12 @@ -> m (Either TarCreateException Header) headerFromFileInfo offset fi = do unless (offset `mod` 512 == 0) $- throwM $ TarCreationError $ "Offset must always be a multiple of 512"+ throwM $+ TarCreationError $+ "<headerFromFileInfo>: Offset must always be a multiple of 512 for file: " +++ getFileInfoPath fi let (prefix, suffix) = splitPathAt 100 $ filePath fi- if (SS.length prefix > 155)+ if (SS.length prefix > 155 || SS.null suffix) then return $ Left $ FileNameTooLong fi else do (payloadSize, linkName, linkIndicator) <-@@ -405,7 +454,11 @@ 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+ fty ->+ throwM $+ TarCreationError $+ "<headerFromFileInfo>: Unsupported file type: " +++ show fty ++ " for file: " ++ getFileInfoPath fi return $ Right Header@@ -449,81 +502,121 @@ (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-+ checksum = sumsl left + 32 * 8 + sumsl right+ encChecksum <-+ either+ (\(_, val) ->+ throwM $+ TarCreationError $+ "<packHeader>: Impossible happened - Checksum " +++ show val ++ " doesn't fit into header for file: " ++ headerFilePath header)+ return $+ encodeOctal 8 checksum+ return $ SL.toStrict $ left <> toLazyByteString encChecksum <> right packHeaderNoChecksum :: MonadThrow m => Header -> m (SL.ByteString, SL.ByteString)-packHeaderNoChecksum Header {..} = do+packHeaderNoChecksum h@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+ 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 <> word8 0 <>- hOwnerId <> word8 0 <>- hGroupId <> word8 0 <>- hPayloadSize <> word8 0 <>- hTime <> word8 0+ hFileMode <>+ hOwnerId <>+ hGroupId <>+ hPayloadSize <>+ hTime , toLazyByteString $ word8 headerLinkIndicator <> hLinkName <> hMagicVersion <> hOwnerName <> hGroupName <>- hDevMajor <> word8 0 <>- hDevMinor <> word8 0 <>+ hDevMajor <>+ hDevMinor <> hNamePrefix <> byteString (S.replicate 12 0) ) where- encodeDevice 0 = return $ byteString $ S.replicate 7 0- encodeDevice devid = encodeOctal 7 devid+ 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)) = fmap ((,) gnuTarMagicVersion) $ encodeHex len val+ throwNumberEither _ (Right v) = return v+ throwNumberEither field (Left (len, val)) =+ throwM $+ TarCreationError $+ "<packHeaderNoChecksum>: Tar value overflow for file: " +++ headerFilePath h +++ " (for field '" ++ field ++ "' with maxLen " ++ show len ++ "): " ++ show val --- | Encode a `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"+-- | 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- lenShort = SS.length sbs+ 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. Throws `TarCreationError` when overflows.-encodeOctal :: (Show a, Integral a, MonadThrow m) => Int -> a -> m Builder-encodeOctal !len !val = go 0 val mempty+-- | 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 =+ | 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 $- "<encodeOctal>: Tar value overflow (for maxLen " ++ show len ++ "): " ++ show val-+ "<encodeShort>: Tar string value overflow for file: " +++ headerFilePath h +++ " (for field '" ++ field ++ "' with maxLen " ++ show len ++ "): " ++ S8.unpack (fromShort sbs)+ where+ lenShort = SS.length sbs -- | Produce a ByteString chunk with NUL characters of the size needed to get up@@ -538,12 +631,11 @@ - -- | 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+ -> 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@@ -556,18 +648,26 @@ case eContent of Just h@(Left _) -> do leftover h- throwM $ TarCreationError "Not enough payload."+ throwM $+ TarCreationError $+ "<tarPayload>: Not enough payload for file: " ++ headerFilePath header Just (Right content) -> do let nextSize = prevSize + fromIntegral (S.length content) unless (nextSize <= headerPayloadSize header) $- throwM $ TarCreationError "Too much payload"+ throwM $+ TarCreationError $+ "<tarPayload>: Too much payload (" +++ show nextSize ++ ") for file with size (" +++ show (headerPayloadSize header) ++ "): " ++ headerFilePath header yield content if nextSize == headerPayloadSize header then do paddedSize <- yieldNulPadding nextSize cont (headerPayloadOffset header + paddedSize) else go nextSize- Nothing -> throwM $ TarCreationError "Stream finished abruptly. Not enough payload."+ Nothing ->+ throwM $+ TarCreationError "<tarPayload>: Stream finished abruptly. Not enough payload." @@ -576,9 +676,11 @@ 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."+ throwM $+ TarCreationError "<tarHeader>: Received payload without a corresponding Header." Just (Left header) -> do packHeader header >>= yield tarPayload 0 header tarHeader@@ -593,8 +695,12 @@ tarFileInfo offset = do eContent <- await case eContent of- Just (Right _) ->- throwM $ TarCreationError "Received payload without a corresponding FileInfo."+ Just (Right bs)+ | S.null bs -> tarFileInfo offset -- ignore empty content+ Just c@(Right _) -> do+ leftover c+ throwM $+ TarCreationError "<tarFileInfo>: Received payload without a corresponding FileInfo." Just (Left fi) -> do eHeader <- headerFromFileInfo offset fi case eHeader of@@ -635,9 +741,11 @@ -- | 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+-- is properly terminated at the end, therefore it can not be extended -- afterwards. Returned is the total size of the bytestring as a `FileOffset`.-tar :: MonadResource m =>+--+-- @since 0.2.0+tar :: MonadThrow m => ConduitM (Either FileInfo ByteString) ByteString m FileOffset tar = do offset <- tarFileInfo 0@@ -648,8 +756,10 @@ -- | 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+--+-- @since 0.2.0+tarEntries :: MonadThrow m =>+ ConduitM (Either Header ByteString) ByteString m FileOffset tarEntries = do offset <- tarHeader 0 yield terminatorBlock@@ -659,24 +769,29 @@ -- | 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 :: MonadResource m => ConduitM FilePath (Either FileInfo ByteString) m () filePathConduit = do mfp <- await case mfp of Just fp -> do- fi <- liftIO $ getFileInfo $ S8.pack fp+ fi <- liftIO $ getFileInfo fp case fileType fi of FTNormal -> do yield (Left fi)- sourceFile (S8.unpack (filePath fi)) .| mapC Right+ sourceFile (getFileInfoPath fi) .| mapC Right FTSymbolicLink _ -> yield (Left fi) FTDirectory -> do yield (Left fi)- sourceDirectory (S8.unpack (filePath fi)) .| filePathConduit+ sourceDirectory (getFileInfoPath fi) .| filePathConduit fty -> do leftover fp- throwM $ TarCreationError $ "Unsupported file type: " ++ show fty+ throwM $+ TarCreationError $+ "<filePathConduit>: Unsupported file type: " +++ show fty ++ " for file: " ++ getFileInfoPath fi filePathConduit Nothing -> return () @@ -686,19 +801,25 @@ -- 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 :: 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 = do 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 ()@@ -725,7 +846,11 @@ } --- | Extract a tarball.+-- | 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@@ -741,6 +866,6 @@ restoreFileInto :: MonadResource m => FilePath -> FileInfo -> ConduitM ByteString (IO ()) m () restoreFileInto cd fi =- restoreFile fi {filePath = S8.pack (cd </> makeRelative "/" (S8.unpack (filePath fi)))}+ restoreFile fi {filePath = encodeFilePath (cd </> makeRelative "/" (getFileInfoPath fi))}
src/Data/Conduit/Tar/Types.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} -- | Module contains all the types necessary for tarball processing. module Data.Conduit.Tar.Types@@ -14,6 +15,11 @@ , GroupID , DeviceID , EpochTime+ , CUid(..)+ , CGid(..)+ , encodeFilePath+ , decodeFilePath+ , getFileInfoPath ) where import Control.Exception (Exception)@@ -21,11 +27,44 @@ import Data.ByteString.Short (ShortByteString) import Data.Typeable import Data.Word--#if WINDOWS-import System.PosixCompat.Types-#else import System.Posix.Types+import qualified Data.ByteString.Char8 as S8+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@@ -107,4 +146,14 @@ deriving (Show, Typeable) instance Exception TarCreateException +-- | Convert `FilePath` into a UTF-8 encoded `ByteString`+encodeFilePath :: FilePath -> S8.ByteString+encodeFilePath = T.encodeUtf8 . T.pack +-- | Convert UTF-8 encoded `ByteString` back into the `FilePath`.+decodeFilePath :: S8.ByteString -> FilePath+decodeFilePath = T.unpack . T.decodeUtf8With T.lenientDecode++-- | Get the `FilePath`.+getFileInfoPath :: FileInfo -> FilePath+getFileInfoPath = decodeFilePath . filePath
src/Data/Conduit/Tar/Unix.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -7,18 +8,21 @@ ) where import Conduit-import Control.Exception-import Control.Monad (when)+import Control.Exception.Safe+import Control.Monad (void, when) import Data.Bits import qualified Data.ByteString.Char8 as S8-import Data.Conduit.Tar.Types (FileInfo (..), FileType (..))+import Data.Conduit.Tar.Types+import Foreign.C.Types (CTime (..)) import qualified System.Directory as Dir-import qualified System.Posix.Files.ByteString as Posix+import qualified System.Posix.Files as Posix import qualified System.Posix.User as Posix -getFileInfo :: S8.ByteString -> IO FileInfo-getFileInfo fp = do- fs <- Posix.getSymbolicLinkStatus fp++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.@@ -30,14 +34,14 @@ case () of () | Posix.isRegularFile fs -> return (FTNormal, Posix.fileSize fs) | Posix.isSymbolicLink fs -> do- ln <- Posix.readSymbolicLink fp- return (FTSymbolicLink ln, 0)+ 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+ return $! FileInfo { filePath = fp , fileUserId = uid , fileUserName = either (const "") (S8.pack . Posix.userName) euEntry@@ -49,27 +53,41 @@ , 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+ let fpStr = decodeFilePath filePath+ restorePermissions = do+ void $ tryAny $ Posix.setOwnerAndGroup fpStr fileUserId fileGroupId+ void $ tryAny $ Posix.setFileMode fpStr fileMode case fileType of FTDirectory -> do- liftIO $ Dir.createDirectoryIfMissing False filePath'+ liftIO $ do+ Dir.createDirectoryIfMissing False fpStr+ restorePermissions yield $- (Dir.doesDirectoryExist filePath' >>=- (`when` Posix.setFileTimes filePath fileModTime fileModTime))+ (Dir.doesDirectoryExist fpStr >>=+ (`when` Posix.setFileTimes fpStr fileModTime fileModTime)) FTSymbolicLink link -> liftIO $ do- exist <- Posix.fileExist filePath- when exist $ Dir.removeFile filePath'- Posix.createSymbolicLink link filePath- FTNormal -> sinkFile filePath'+ -- Try to unlink any existing file/symlink+ _ <- tryAny $ Posix.removeLink fpStr+ Posix.createSymbolicLink (decodeFilePath link) fpStr+ _ <- tryAny $ Posix.setSymbolicLinkOwnerAndGroup fpStr fileUserId fileGroupId+ -- Try best effort in setting symbolic link modification time.+#if MIN_VERSION_unix(2,7,0)+ let CTime epochInt32 = fileModTime+ unixModTime = fromInteger (fromIntegral epochInt32)+ void $ tryAny $ Posix.setSymbolicLinkTimesHiRes fpStr unixModTime unixModTime+#endif+ FTNormal -> do+ sinkFile fpStr+ liftIO $ do+ restorePermissions+ Posix.setFileTimes fpStr fileModTime fileModTime ty -> error $ "Unsupported tar entry type: " ++ show ty- liftIO $ do- Posix.setFileTimes filePath fileModTime fileModTime- Posix.setSymbolicLinkOwnerAndGroup filePath fileUserId fileGroupId- Posix.setFileMode filePath fileMode+
src/Data/Conduit/Tar/Windows.hs view
@@ -9,25 +9,25 @@ import Control.Monad (when) import Data.Bits import qualified Data.ByteString.Char8 as S8-import Data.Conduit.Tar.Types (FileInfo (..), FileType (..))+import Data.Conduit.Tar.Types 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 :: FilePath -> IO FileInfo getFileInfo fp = do- let fp' = S8.unpack fp- fs <- Posix.getSymbolicLinkStatus fp'- let uid = Posix.fileOwner fs- gid = Posix.fileGroup fs+ 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'+ | otherwise -> error $ "Unsupported file type: " ++ fp return FileInfo- { filePath = fp+ { filePath = encodeFilePath fp , fileUserId = uid , fileUserName = "" , fileGroupId = gid@@ -44,19 +44,18 @@ restoreFile :: (MonadResource m) => FileInfo -> ConduitM S8.ByteString (IO ()) m () restoreFile FileInfo {..} = do- let filePath' = S8.unpack filePath+ let fpStr = decodeFilePath filePath CTime modTimeEpoch = fileModTime modTime = posixSecondsToUTCTime (fromIntegral modTimeEpoch) case fileType of FTDirectory -> do- liftIO $ Dir.createDirectoryIfMissing False filePath'+ liftIO $ Dir.createDirectoryIfMissing False fpStr yield $- (Dir.doesDirectoryExist filePath' >>=- (`when` Dir.setModificationTime filePath' modTime))- FTNormal -> sinkFile filePath'+ (Dir.doesDirectoryExist fpStr >>=+ (`when` Dir.setModificationTime fpStr modTime))+ FTNormal -> sinkFile fpStr ty -> error $ "Unsupported tar entry type: " ++ show ty liftIO $ do- Dir.setModificationTime filePath' modTime- Posix.setSymbolicLinkOwnerAndGroup filePath' fileUserId fileGroupId- Posix.setFileMode filePath' fileMode+ Dir.setModificationTime fpStr modTime+ Posix.setFileMode fpStr fileMode
tar-conduit.cabal view
@@ -1,5 +1,5 @@ name: tar-conduit-version: 0.2.1+version: 0.2.2 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@@ -19,6 +19,7 @@ , bytestring , conduit-combinators >= 1.0.8.1 , filepath+ , text default-language: Haskell2010 ghc-options: -Wall if os(windows)@@ -30,20 +31,23 @@ else other-modules: Data.Conduit.Tar.Unix build-depends: directory+ , safe-exceptions , unix test-suite tests type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Spec.hs- build-depends: base+ build-depends: QuickCheck+ , base , bytestring+ , conduit+ , conduit-combinators , directory , filepath , hspec , tar-conduit- , conduit-combinators- ghc-options: -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -O2 -threaded -rtsopts default-language: Haskell2010 test-suite space
tests/Spec.hs view
@@ -1,19 +1,37 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-} module Main where import Prelude as P import Conduit import Control.Monad (void, when, zipWithM_)+import Data.Conduit.List import Test.Hspec+import Test.QuickCheck import Data.Conduit.Tar import System.Directory import Data.ByteString as S+import Data.ByteString.Char8 as S8+import Data.Int+import Data.Monoid import System.IO import System.FilePath+import System.IO (hSetBuffering, stdout, BufferMode(LineBuffering)) import Control.Exception +#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), pure)+import Data.Word+#endif+++ main :: IO () main = do+ hSetBuffering stdout LineBuffering let baseTmp = "tar-conduit-tests" isStack <- doesDirectoryExist ".stack-work" let testPaths =@@ -44,7 +62,147 @@ P.length tb1 `shouldBe` P.length tb2 zipWithM_ shouldBe (fmap fst tb2) (fmap fst tb1) zipWithM_ shouldBe (fmap snd tb2) (fmap snd tb1)+ describe "ustar" ustarSpec+ describe "GNUtar" gnutarSpec +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-" <>) <$> 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+ ]+ (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' </> 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' </> P.replicate 100 'o' </> P.replicate 99 'b')+ }+ it "LongLink - multiple files with long file names" $ do+ fileInfoExpectation+ [ ( defFileInfo+ { filePath =+ S8.pack (P.replicate 100 'f' </> P.replicate 100 'o' </> P.replicate 99 'b')+ , fileSize = 10+ }+ , "1234567890")+ , ( defFileInfo+ { filePath =+ S8.pack (P.replicate 1000 'g' </> P.replicate 1000 'o' </> 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@@ -78,4 +236,3 @@ collectContent dir = runConduitRes $ sourceDirectoryDeep False dir .| mapMC (\fp -> runConduit (sourceFileBS fp .| foldC)) .| foldC-