diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 0.2.4 - 2018-08-28 + * Use forward slashes on Windows too, see [issue #21](https://github.com/snoyberg/tar-conduit/issues/21) + * Addition of `extractTarballLenient` + ## 0.2.3.1 - 2018-06-06 * Fixed drops associated payload for unsupported headers ((https://github.com/snoyberg/tar-conduit/issues/17)) ([PR 18](https://github.com/snoyberg/tar-conduit/pull/18)) * Dropped support for GHC 7/Stack LTS-2, LTS-3, LTS-6 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,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} @@ -14,6 +15,7 @@ , untarWithFinalizers , restoreFile , restoreFileInto + , restoreFileWithErrors -- ** Operate on Chunks , untarChunks , withEntry @@ -29,12 +31,13 @@ , createTarball , writeTarball , extractTarball + , extractTarballLenient -- * Types , module Data.Conduit.Tar.Types ) where import Conduit as C -import Control.Exception (assert) +import Control.Exception (assert, SomeException) import Control.Monad (unless, void) import Data.Bits import Data.ByteString (ByteString) @@ -399,6 +402,19 @@ liftIO finilizers +-- | Same as `untarWithFinalizers`, but will also produce a list of any exceptions that might have +-- occured during restoration process. +-- +-- @since 0.2.4 +untarWithExceptions :: + (MonadThrow m, MonadIO m) + => (FileInfo -> ConduitM ByteString (IO (FileInfo, [SomeException])) m ()) + -> ConduitM ByteString c m [(FileInfo, [SomeException])] +untarWithExceptions inner = do + finalizers <- untar inner .| C.foldMapC (fmap pure) + filter (not . null . snd) <$> liftIO finalizers + + -------------------------------------------------------------------------------- -- Create a tar file ----------------------------------------------------------- -------------------------------------------------------------------------------- @@ -829,8 +845,10 @@ runConduitRes $ yieldMany dirs .| void tarFilePath .| sinkHandle tarHandle +-- always use forward slash, see +-- https://github.com/snoyberg/tar-conduit/issues/21 pathSeparatorS :: ByteString -pathSeparatorS = S8.singleton pathSeparator +pathSeparatorS = "/" -- S8.singleton pathSeparator fileInfoFromHeader :: Header -> FileInfo @@ -863,9 +881,55 @@ runConduitRes $ sourceFileBS tarfp .| untarWithFinalizers (restoreFileInto cd) +prependDirectory :: FilePath -> FileInfo -> FileInfo +prependDirectory cd fi = + fi {filePath = encodeFilePath (cd makeRelative "/" (getFileInfoPath fi))} + + -- | 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 = encodeFilePath (cd makeRelative "/" (getFileInfoPath fi))} +restoreFileInto cd = restoreFile . prependDirectory cd + +-- | Restore all files into a folder. Absolute file paths will be turned into relative to the +-- supplied folder. Yields a list with exceptions instead of throwing them. +restoreFileIntoLenient :: MonadResource m => + FilePath -> FileInfo -> ConduitM ByteString (IO (FileInfo, [SomeException])) m () +restoreFileIntoLenient cd = restoreFileWithErrors True . prependDirectory cd + + +-- | Same as `extractTarball`, but ignores possible extraction errors. It can still throw a +-- `TarException` if the tarball is corrupt or malformed. +-- +-- @since 0.2.4 +extractTarballLenient :: FilePath -- ^ Filename for the tarball + -> Maybe FilePath -- ^ Folder where tarball should be extract + -- to. Default is the current path + -> IO [(FileInfo, [SomeException])] +extractTarballLenient tarfp mcd = do + cd <- maybe getCurrentDirectory return mcd + createDirectoryIfMissing True cd + runConduitRes $ + sourceFileBS tarfp .| untarWithExceptions (restoreFileIntoLenient cd) + + + +-- | Restore files onto the file system. Produces actions that will set the modification time on the +-- directories, which can be executed after the pipeline has finished and all files have been +-- written to disk. +restoreFile :: (MonadResource m) => + FileInfo -> ConduitM S8.ByteString (IO ()) m () +restoreFile fi = restoreFileWithErrors False fi .| mapC void + + +-- | Restore files onto the file system, much in the same way `restoreFile` does it, except with +-- ability to ignore restoring problematic files and report errors that occured as a list of +-- exceptions, which will be returned as a list when finilizer executed. If a list is empty, it +-- means, that no errors occured and a file only had a finilizer associated with it. +restoreFileWithErrors :: + (MonadResource m) + => Bool + -> FileInfo + -> ConduitM S8.ByteString (IO (FileInfo, [SomeException])) m () +restoreFileWithErrors = restoreFileInternal diff --git a/src/Data/Conduit/Tar/Types.hs b/src/Data/Conduit/Tar/Types.hs --- a/src/Data/Conduit/Tar/Types.hs +++ b/src/Data/Conduit/Tar/Types.hs @@ -136,6 +136,7 @@ | InvalidHeader !FileOffset | BadChecksum !FileOffset | FileTypeError !FileOffset !Char !String + | UnsupportedType !FileType deriving (Show, Typeable) instance Exception TarException 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 @@ -4,14 +4,15 @@ {-# LANGUAGE ScopedTypeVariables #-} module Data.Conduit.Tar.Unix ( getFileInfo - , restoreFile + , restoreFileInternal ) where -import Conduit +import Conduit hiding (throwM) import Control.Exception.Safe -import Control.Monad (void, when) +import Control.Monad (void, when, unless) import Data.Bits import qualified Data.ByteString.Char8 as S8 +import Data.Either import Data.Conduit.Tar.Types import Foreign.C.Types (CTime (..)) import qualified System.Directory as Dir @@ -53,41 +54,52 @@ , 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 +-- | See 'Data.Conduit.Tar.restoreFileWithErrors' for documentation +restoreFileInternal :: + (MonadResource m) + => Bool + -> FileInfo + -> ConduitM S8.ByteString (IO (FileInfo, [SomeException])) m () +restoreFileInternal lenient fi@FileInfo {..} = do let fpStr = decodeFilePath filePath + tryAnyCond action = if lenient then tryAny action else fmap Right action restorePermissions = do - void $ tryAny $ Posix.setOwnerAndGroup fpStr fileUserId fileGroupId - void $ tryAny $ Posix.setFileMode fpStr fileMode + eExc1 <- tryAnyCond $ Posix.setOwnerAndGroup fpStr fileUserId fileGroupId + eExc2 <- tryAnyCond $ Posix.setFileMode fpStr fileMode + return $! fst $ partitionEithers [eExc1, eExc2] + -- | Catch all exceptions, but only if lenient is set to True case fileType of FTDirectory -> do - liftIO $ do + excs <- liftIO $ do Dir.createDirectoryIfMissing False fpStr restorePermissions - yield $ - (Dir.doesDirectoryExist fpStr >>= - (`when` Posix.setFileTimes fpStr fileModTime fileModTime)) - FTSymbolicLink link -> - liftIO $ do + yield $ do + eExc <- tryAnyCond (Dir.doesDirectoryExist fpStr >>= + (`when` Posix.setFileTimes fpStr fileModTime fileModTime)) + return (fi, either ((excs ++) . pure) (const excs) eExc) + FTSymbolicLink link -> do + excs <- liftIO $ do -- Try to unlink any existing file/symlink - _ <- tryAny $ Posix.removeLink fpStr + void $ tryAny $ Posix.removeLink fpStr Posix.createSymbolicLink (decodeFilePath link) fpStr - _ <- tryAny $ Posix.setSymbolicLinkOwnerAndGroup fpStr fileUserId fileGroupId - -- Try best effort in setting symbolic link modification time. + eExc1 <- tryAnyCond $ Posix.setSymbolicLinkOwnerAndGroup fpStr fileUserId fileGroupId #if MIN_VERSION_unix(2,7,0) + -- Try best effort in setting symbolic link modification time. let CTime epochInt32 = fileModTime unixModTime = fromInteger (fromIntegral epochInt32) - void $ tryAny $ Posix.setSymbolicLinkTimesHiRes fpStr unixModTime unixModTime + eExc2 <- tryAny $ Posix.setSymbolicLinkTimesHiRes fpStr unixModTime unixModTime #endif + return $ fst $ partitionEithers [eExc1, eExc2] + unless (null excs) $ yield (return (fi, excs)) FTNormal -> do sinkFile fpStr - liftIO $ do - restorePermissions - Posix.setFileTimes fpStr fileModTime fileModTime - ty -> error $ "Unsupported tar entry type: " ++ show ty + excs <- liftIO $ do + excs <- restorePermissions + eExc <- tryAnyCond $ Posix.setFileTimes fpStr fileModTime fileModTime + return (either ((excs ++) . pure) (const excs) eExc) + unless (null excs) $ yield (return (fi, excs)) + ty -> do + let exc = UnsupportedType ty + unless lenient $ liftIO $ throwM exc + yield $ return (fi, [toException exc]) diff --git a/src/Data/Conduit/Tar/Windows.hs b/src/Data/Conduit/Tar/Windows.hs --- a/src/Data/Conduit/Tar/Windows.hs +++ b/src/Data/Conduit/Tar/Windows.hs @@ -2,14 +2,16 @@ {-# LANGUAGE RecordWildCards #-} module Data.Conduit.Tar.Windows ( getFileInfo - , restoreFile + , restoreFileInternal ) where import Conduit -import Control.Monad (when) +import Control.Monad (when, unless) +import Control.Exception.Safe (tryAny, SomeException, toException) import Data.Bits import qualified Data.ByteString.Char8 as S8 import Data.Conduit.Tar.Types +import Data.Either (partitionEithers) import Data.Time.Clock.POSIX import Foreign.C.Types (CTime (..)) import qualified System.Directory as Dir @@ -38,24 +40,38 @@ , 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 + + +-- | See 'Data.Conduit.Tar.restoreFileWithErrors' for documentation +restoreFileInternal :: + (MonadResource m) + => Bool + -> FileInfo + -> ConduitM S8.ByteString (IO (FileInfo, [SomeException])) m () +restoreFileInternal lenient fi@FileInfo {..} = do let fpStr = decodeFilePath filePath + tryAnyCond action = if lenient then tryAny action else fmap Right action CTime modTimeEpoch = fileModTime modTime = posixSecondsToUTCTime (fromIntegral modTimeEpoch) + restoreTimeAndMode = do + eExc1 <- tryAnyCond $ Posix.setFileMode fpStr fileMode + eExc2 <- tryAnyCond $ Dir.setModificationTime fpStr modTime + return $! fst $ partitionEithers [eExc1, eExc2] case fileType of FTDirectory -> do - liftIO $ Dir.createDirectoryIfMissing False fpStr - yield $ - (Dir.doesDirectoryExist fpStr >>= - (`when` Dir.setModificationTime fpStr modTime)) - FTNormal -> sinkFile fpStr - ty -> error $ "Unsupported tar entry type: " ++ show ty - liftIO $ do - Dir.setModificationTime fpStr modTime - Posix.setFileMode fpStr fileMode + excs <- liftIO $ do + Dir.createDirectoryIfMissing False fpStr + restoreTimeAndMode + yield $ do + eExc <- tryAnyCond (Dir.doesDirectoryExist fpStr >>= + (`when` Dir.setModificationTime fpStr modTime)) + return (fi, either ((excs ++) . pure) (const excs) eExc) + FTNormal -> do + sinkFile fpStr + excs <- liftIO $ restoreTimeAndMode + unless (null excs) $ yield $ return (fi, excs) + ty -> do + let exc = UnsupportedType ty + unless lenient $ liftIO $ throwM exc + yield $ return (fi, [toException exc]) diff --git a/tar-conduit.cabal b/tar-conduit.cabal --- a/tar-conduit.cabal +++ b/tar-conduit.cabal @@ -1,5 +1,5 @@ name: tar-conduit -version: 0.2.3.1 +version: 0.2.4 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 @@ -21,21 +21,20 @@ , bytestring , conduit , conduit-combinators >= 1.0.8.1 + , directory , filepath + , safe-exceptions , text default-language: Haskell2010 ghc-options: -Wall if os(windows) other-modules: Data.Conduit.Tar.Windows - build-depends: directory - , time + build-depends: time , unix-compat cpp-options: -DWINDOWS else other-modules: Data.Conduit.Tar.Unix - build-depends: directory - , safe-exceptions - , unix + build-depends: unix test-suite tests type: exitcode-stdio-1.0 diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -13,10 +13,12 @@ import Data.Conduit.List import Data.Conduit.Tar import Data.Int +import Data.List (sortOn) import Data.Monoid import Prelude as P import System.Directory -import System.FilePath +import qualified System.FilePath as Host +import qualified System.FilePath.Posix as Posix -- always use forward slashes import System.IO import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout) @@ -58,8 +60,8 @@ finally (setCurrentDirectory outDir >> createTarball fpOut testPaths) (setCurrentDirectory curDir) - tb1 <- readTarball fpIn - tb2 <- readTarball fpOut + tb1 <- readTarballSorted fpIn + tb2 <- readTarballSorted fpOut P.length tb1 `shouldBe` P.length tb2 zipWithM_ shouldBe (fmap fst tb2) (fmap fst tb1) zipWithM_ shouldBe (fmap snd tb2) (fmap snd tb1) @@ -111,7 +113,7 @@ instance Arbitrary GnuTarFile where arbitrary = do filePathLen <- (`mod` 4090) <$> arbitrary - filePath <- ("test-" <>) <$> asciiGen filePathLen + filePath <- ("test-" <>) . S8.filter (/= ('\\')) <$> asciiGen filePathLen NonNegative fileUserId64 <- arbitrary let fileUserId = fromIntegral (fileUserId64 :: Int64) NonNegative fileGroupId64 <- arbitrary @@ -171,7 +173,7 @@ emptyFileInfoExpectation defFileInfo it "long file name <255" $ do emptyFileInfoExpectation $ - defFileInfo {filePath = S8.pack (P.replicate 99 'f' P.replicate 99 'o')} + defFileInfo {filePath = S8.pack (P.replicate 99 'f' Posix. P.replicate 99 'o')} gnutarSpec :: Spec @@ -180,19 +182,25 @@ emptyFileInfoExpectation $ defFileInfo { filePath = - S8.pack (P.replicate 100 'f' P.replicate 100 'o' P.replicate 99 'b') + S8.pack (P.replicate 100 'f' Posix. + P.replicate 100 'o' Posix. + P.replicate 99 'b') } it "LongLink - multiple files with long file names" $ do fileInfoExpectation [ ( defFileInfo { filePath = - S8.pack (P.replicate 100 'f' P.replicate 100 'o' P.replicate 99 'b') + S8.pack (P.replicate 100 'f' Posix. + P.replicate 100 'o' Posix. + P.replicate 99 'b') , fileSize = 10 } , "1234567890") , ( defFileInfo { filePath = - S8.pack (P.replicate 1000 'g' P.replicate 1000 'o' P.replicate 99 'b') + S8.pack (P.replicate 1000 'g' Posix. + P.replicate 1000 'o' Posix. + P.replicate 99 'b') , fileSize = 11 } , "abcxdefghij") @@ -221,9 +229,9 @@ 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") + (fp1, h1) <- openBinaryTempFile tmpDir (Host.addExtension base ".tar") + let outPath = Host.dropExtension fp1 ++ ".out" + return (fp1, h1, outPath, Host.addExtension outPath ".tar") ) (\(fp, h, dirOut, fpOut) -> do hClose h @@ -232,10 +240,14 @@ doesFileExist fpOut >>= (`when` removeFile fpOut) ) - -readTarball +-- | Collects all of the files and direcotries from the tarball. Then all of them get sorted, since +-- apparently Windows has no guaranteed order the files within a directory will be listed in upon a +-- tarball creation. +readTarballSorted :: FilePath -> IO [(FileInfo, Maybe ByteString)] -readTarball fp = runConduitRes $ sourceFileBS fp .| untar grabBoth .| sinkList +readTarballSorted fp = + sortOn (filePath . fst) <$> + (runConduitRes $ sourceFileBS fp .| untar grabBoth .| sinkList) readGzipTarball :: FilePath