diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 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,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: -- +-- +-- @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 $ + ": 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 $ + ": 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 $ + ": 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 $ + ": 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 $ - ": Tar value overflow (for maxLen " ++ show len ++ "): " ++ show val - + ": 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 $ + ": 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 $ + ": 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 ": 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 ": 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 ": 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 $ + ": 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))} diff --git a/src/Data/Conduit/Tar/Types.hs b/src/Data/Conduit/Tar/Types.hs --- a/src/Data/Conduit/Tar/Types.hs +++ b/src/Data/Conduit/Tar/Types.hs @@ -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 diff --git a/src/Data/Conduit/Tar/Unix.hs b/src/Data/Conduit/Tar/Unix.hs --- a/src/Data/Conduit/Tar/Unix.hs +++ b/src/Data/Conduit/Tar/Unix.hs @@ -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 + diff --git a/src/Data/Conduit/Tar/Windows.hs b/src/Data/Conduit/Tar/Windows.hs --- a/src/Data/Conduit/Tar/Windows.hs +++ b/src/Data/Conduit/Tar/Windows.hs @@ -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 diff --git a/tar-conduit.cabal b/tar-conduit.cabal --- a/tar-conduit.cabal +++ b/tar-conduit.cabal @@ -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 diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -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 -