diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,8 @@ +## 0.3.0 - 2018-08-28 + * Support for `FTHardLink` restoration, but not creation yet. + * Restoring files made even more lenient with creation of full directory path if any parents of + it are missing. + ## 0.2.5 - 2018-08-28 * Exported `untarWithExceptions`, `restoreFileIntoLenient` 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,6 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -92,7 +93,7 @@ case headerLinkIndicator h of 0 -> FTNormal 48 -> FTNormal - 49 -> FTHardLink + 49 -> FTHardLink (fromShort (headerLinkName h)) 50 -> FTSymbolicLink (fromShort (headerLinkName h)) 51 -> FTCharacterSpecial 52 -> FTBlockSpecial @@ -257,7 +258,9 @@ {-| This function handles each entry of the tar archive according to the behaviour of the function passed as first argument. -Here is a full example function, that reads a compressed tar archive and for each entry that is a simple file, it prints its file path and SHA256 digest. Note that this function can throw exceptions! +Here is a full example function, that reads a compressed tar archive and for each entry that is a +simple file, it prints its file path and SHA256 digest. Note that this function can throw +exceptions! > import qualified Crypto.Hash.Conduit as CH > import qualified Data.Conduit.Tar as CT @@ -284,13 +287,14 @@ The @hashentry@ function handles a single entry, based on its first 'Header' argument. In this example, a 'Consumer' is used to process the whole entry. -Note that the benefits of stream processing are easily lost when working with a 'Consumer'. For example, the following implementation would have used an unbounded amount of memory: +Note that the benefits of stream processing are easily lost when working with a 'Consumer'. For +example, the following implementation would have used an unbounded amount of memory: > hashentry hdr = when (CT.headerFileType hdr == CT.FTNormal) $ do > content <- mconcat <$> sinkList > yield (CT.headerFilePath hdr, hash content) --- @since 0.1.0 +@since 0.1.0 -} withEntries :: MonadThrow m => (Header -> ConduitM ByteString o m ()) @@ -316,20 +320,19 @@ withFileInfo :: MonadThrow m => (FileInfo -> ConduitM ByteString o m ()) -> ConduitM TarChunk o m () -withFileInfo inner = - start +withFileInfo inner = start where start = await >>= maybe (return ()) go - - go x = do + go x = case x of ChunkHeader h - | headerLinkIndicator h >= 55 -> do - if (headerMagicVersion h == gnuTarMagicVersion) + | headerLinkIndicator h >= 55 -> + if headerMagicVersion h == gnuTarMagicVersion then handleGnuTarHeader h >>= maybe start go - else dropWhileC (\x' -> case x' of - ChunkPayload _ _ -> True - _ -> False) >> start + else dropWhileC + (\case + ChunkPayload _ _ -> True + _ -> False) >> start ChunkHeader h -> do payloadsConduit .| (inner (fileInfoFromHeader h) <* sinkNull) start @@ -337,13 +340,13 @@ leftover x throwM $ UnexpectedPayload offset ChunkException e -> throwM e - + -- | Take care of custom GNU tar format. handleGnuTarHeader :: MonadThrow m => Header -> ConduitM TarChunk o m (Maybe TarChunk) -handleGnuTarHeader h = do +handleGnuTarHeader h = case headerLinkIndicator h of 76 -> do let pSize = headerPayloadSize h @@ -359,7 +362,7 @@ Just (ChunkHeader nh) -> do unless (S.isPrefixOf (fromShort (headerFileNameSuffix nh)) longFileName) $ throwM $ - FileTypeError (headerPayloadOffset nh) 'L' $ + FileTypeError (headerPayloadOffset nh) 'L' "Long filename doesn't match the original." return (Just $ ChunkHeader $ @@ -454,11 +457,11 @@ } -headerFromFileInfo :: MonadThrow m => - FileOffset -- ^ Starting offset within the tarball. Must - -- be multiple of 512, otherwise error. - -> FileInfo -- ^ File info. - -> m (Either TarCreateException Header) +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 $ @@ -466,12 +469,13 @@ ": Offset must always be a multiple of 512 for file: " ++ getFileInfoPath fi let (prefix, suffix) = splitPathAt 100 $ filePath fi - if (SS.length prefix > 155 || SS.null suffix) + if SS.length prefix > 155 || SS.null suffix then return $ Left $ FileNameTooLong fi else do (payloadSize, linkName, linkIndicator) <- case fileType fi of FTNormal -> return (fileSize fi, SS.empty, 48) + FTHardLink ln -> return (0, toShort ln, 49) FTSymbolicLink ln -> return (0, toShort ln, 50) FTDirectory -> return (0, SS.empty, 53) fty -> @@ -575,7 +579,7 @@ 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 + fallbackHex _ (Left (len, val)) = (,) gnuTarMagicVersion <$> encodeHex len val throwNumberEither _ (Right v) = return v throwNumberEither field (Left (len, val)) = throwM $ @@ -834,7 +838,7 @@ createTarball :: FilePath -- ^ File name for the tarball -> [FilePath] -- ^ List of files and directories to include in the tarball -> IO () -createTarball tarfp dirs = do +createTarball tarfp dirs = runConduitRes $ yieldMany dirs .| void tarFilePath .| sinkFile tarfp -- | Take a list of files and paths, recursively tar them and write output into supplied handle. @@ -843,7 +847,7 @@ 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 +writeTarball tarHandle dirs = runConduitRes $ yieldMany dirs .| void tarFilePath .| sinkHandle tarHandle @@ -854,7 +858,7 @@ fileInfoFromHeader :: Header -> FileInfo -fileInfoFromHeader header@(Header {..}) = +fileInfoFromHeader header@Header {..} = FileInfo { filePath = headerFilePathBS header , fileUserId = headerOwnerId @@ -884,8 +888,15 @@ prependDirectory :: FilePath -> FileInfo -> FileInfo -prependDirectory cd fi = - fi {filePath = encodeFilePath (cd makeRelative "/" (getFileInfoPath fi))} +prependDirectory cd fi = fi {filePath = prependDir $ getFileInfoPath fi, + fileType = prependDirIfNeeded (fileType fi)} + where + -- Hard links need to be interpreted based on `cd`, not just CWD, if relative, + -- otherwise they may point to some invalid location. + prependDirIfNeeded (FTHardLink p) + | isRelative $ decodeFilePath p = FTHardLink (prependDir $ decodeFilePath p) + prependDirIfNeeded other = other + prependDir p = encodeFilePath (cd makeRelative "/" p) -- | Restore all files into a folder. Absolute file paths will be turned into @@ -901,7 +912,6 @@ restoreFileIntoLenient :: MonadResource m => FilePath -> FileInfo -> ConduitM ByteString (IO (FileInfo, [SomeException])) m () restoreFileIntoLenient cd = restoreFileWithErrors True . prependDirectory cd - -- | Same as `extractTarball`, but ignores possible extraction errors. It can still throw a -- `TarException` if the tarball is corrupt or malformed. 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,6 +1,7 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-} +#if WINDOWS +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +#endif -- | Module contains all the types necessary for tarball processing. module Data.Conduit.Tar.Types ( Header(..) @@ -25,7 +26,6 @@ import Control.Exception (Exception) import Data.ByteString (ByteString) import Data.ByteString.Short (ShortByteString) -import Data.Typeable import Data.Word import System.Posix.Types import qualified Data.ByteString.Char8 as S8 @@ -69,7 +69,7 @@ data FileType = FTNormal - | FTHardLink + | FTHardLink !ByteString | FTSymbolicLink !ByteString | FTCharacterSpecial | FTBlockSpecial @@ -87,9 +87,9 @@ , 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 + , fileType :: !FileType -- ^ File type. `FTNormal`, `FTHardLink` (@since 0.3.0), + -- `FTSymbolicLink` and `FTDirectory` are the only ones supported + -- for now , fileModTime :: !EpochTime -- ^ File modification timestamp } deriving (Show, Eq) @@ -137,14 +137,14 @@ | BadChecksum !FileOffset | FileTypeError !FileOffset !Char !String | UnsupportedType !FileType - deriving (Show, Typeable) + deriving Show instance Exception TarException data TarCreateException = FileNameTooLong !FileInfo | TarCreationError !String - deriving (Show, Typeable) + deriving Show instance Exception TarCreateException -- | Convert `FilePath` into a UTF-8 encoded `ByteString` 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 @@ -18,7 +18,7 @@ import qualified System.Directory as Dir import qualified System.Posix.Files as Posix import qualified System.Posix.User as Posix - +import qualified System.FilePath.Posix as Posix getFileInfo :: FilePath -> IO FileInfo getFileInfo fpStr = do @@ -71,7 +71,7 @@ case fileType of FTDirectory -> do excs <- liftIO $ do - Dir.createDirectoryIfMissing False fpStr + Dir.createDirectoryIfMissing True fpStr restorePermissions yield $ do eExc <- tryAnyCond (Dir.doesDirectoryExist fpStr >>= @@ -91,13 +91,32 @@ #endif return $ fst $ partitionEithers [eExc1, eExc2] unless (null excs) $ yield (return (fi, excs)) + FTHardLink link -> do + excs <- liftIO $ do + let linkedFp = decodeFilePath link + when lenient $ do + linkedFileExists <- Posix.fileExist linkedFp + -- If the linked file does not exist (yet), we cannot create a hard link. + -- Try to "pre-create" it. + unless linkedFileExists $ do + Dir.createDirectoryIfMissing True $ Posix.takeDirectory linkedFp + writeFile linkedFp "" + Dir.createDirectoryIfMissing True $ Posix.takeDirectory fpStr + -- Try to unlink any existing file/hard link + void $ tryAny $ Posix.removeLink fpStr + Posix.createLink linkedFp fpStr + liftIO $ do + excs <- restorePermissions + eExc <- tryAnyCond $ Posix.setFileTimes fpStr fileModTime fileModTime + return (either ((excs ++) . pure) (const excs) eExc) + unless (null excs) $ yield (return (fi, excs)) FTNormal -> do sinkFile fpStr excs <- liftIO $ do excs <- restorePermissions eExc <- tryAnyCond $ Posix.setFileTimes fpStr fileModTime fileModTime return (either ((excs ++) . pure) (const excs) eExc) - unless (null excs) $ yield (return (fi, excs)) + unless (null excs) $ yield $ return (fi, excs) ty -> do let exc = UnsupportedType ty unless lenient $ liftIO $ throwM exc 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 @@ -60,7 +60,7 @@ case fileType of FTDirectory -> do excs <- liftIO $ do - Dir.createDirectoryIfMissing False fpStr + Dir.createDirectoryIfMissing True fpStr restoreTimeAndMode yield $ do eExc <- tryAnyCond (Dir.doesDirectoryExist fpStr >>= 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.5 +version: 0.3.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 diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -130,6 +130,7 @@ [ pure FTNormal , pure FTDirectory , FTSymbolicLink <$> asciiGen linkNameLen + , FTHardLink <$> asciiGen linkNameLen ] (fileSize, mContent) <- case fileType of