diff --git a/Codec/Archive/Tar/Index.hs b/Codec/Archive/Tar/Index.hs --- a/Codec/Archive/Tar/Index.hs +++ b/Codec/Archive/Tar/Index.hs @@ -124,6 +124,7 @@ #endif #ifdef TESTS +import Data.These import qualified Prelude import Test.QuickCheck import Test.QuickCheck.Property (ioProperty) @@ -710,7 +711,7 @@ testEntry :: RawFilePath -> Int64 -> Entry testEntry name size = simpleEntry path (NormalFile mempty size) where - Right path = toTarPath False name + That path = toTarPath False name -- | Simple tar archive containing regular files only data SimpleTarArchive = SimpleTarArchive { @@ -775,7 +776,7 @@ mkList [] = [] mkList ((fp, bs):es) = entry : mkList es where - Right path = toTarPath False fp + That path = toTarPath False fp entry = simpleEntry path content content = NormalFile bs (LBS.length bs) diff --git a/Codec/Archive/Tar/Pack.hs b/Codec/Archive/Tar/Pack.hs --- a/Codec/Archive/Tar/Pack.hs +++ b/Codec/Archive/Tar/Pack.hs @@ -21,8 +21,10 @@ import Codec.Archive.Tar.Types import Control.Applicative +import Control.Monad (join) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L +import Data.These import qualified System.Posix.IO.ByteString as SPI import System.Posix.FD import System.Posix.ByteString.FilePath (RawFilePath) @@ -73,8 +75,8 @@ packPaths :: RawFilePath -> [RawFilePath] -> IO [Entry] packPaths baseDir paths = - interleave - [ do tarpath <- either fail return (toTarPath isDir relpath) + join <$> interleave + [ do let tarpath = toTarPath isDir relpath if isDir then packDirectoryEntry filepath tarpath else packFileEntry filepath tarpath | relpath <- paths @@ -99,33 +101,51 @@ -- * The file contents is read lazily. -- packFileEntry :: RawFilePath -- ^ Full path to find the file on the local disk - -> TarPath -- ^ Path to use for the tar Entry in the archive - -> IO Entry + -> These SplitError TarPath -- ^ Path to use for the tar Entry in the archive + -> IO [Entry] packFileEntry filepath tarpath = do mtime <- getModTime filepath executable <- isExecutable filepath file <- openFd filepath SPI.ReadOnly [] Nothing >>= SPI.fdToHandle size <- hFileSize file content <- L.hGetContents file - return (simpleEntry tarpath (NormalFile content (fromIntegral size))) { - entryPermissions = if executable then executableFilePermissions - else ordinaryFilePermissions, - entryTime = mtime - } + let entry tp = (simpleEntry tp (NormalFile content (fromIntegral size))) { + entryPermissions = if executable then executableFilePermissions + else ordinaryFilePermissions, + entryTime = mtime + } + + case tarpath of + This e -> fail $ show e + That tp -> return [entry tp] + These _ tp -> do + let lEntry = longLinkEntry filepath + return [lEntry, entry tp] + + -- | Construct a tar 'Entry' based on a local directory (but not its contents). -- -- The only attribute of the directory that is used is its modification time. -- Directory ownership and detailed permissions are not preserved. -- packDirectoryEntry :: RawFilePath -- ^ Full path to find the file on the local disk - -> TarPath -- ^ Path to use for the tar Entry in the archive - -> IO Entry + -> These SplitError TarPath -- ^ Path to use for the tar Entry in the archive + -> IO [Entry] packDirectoryEntry filepath tarpath = do mtime <- getModTime filepath - return (directoryEntry tarpath) { + + let dEntry tp = (directoryEntry tp) { entryTime = mtime } + + case tarpath of + This e -> fail $ show e + That tp -> return [dEntry tp] + These _ tp -> do + let lEntry = longLinkEntry filepath + return [lEntry, dEntry tp] + -- | This is a utility function, much like 'getDirectoryContents'. The -- difference is that it includes the contents of subdirectories. diff --git a/Codec/Archive/Tar/Types.hs b/Codec/Archive/Tar/Types.hs --- a/Codec/Archive/Tar/Types.hs +++ b/Codec/Archive/Tar/Types.hs @@ -29,6 +29,7 @@ RawFilePath, simpleEntry, + longLinkEntry, fileEntry, directoryEntry, @@ -37,6 +38,7 @@ directoryPermissions, TarPath(..), + SplitError(..), toTarPath, fromTarPath, fromTarPathToPosixPath, @@ -64,6 +66,7 @@ import Data.Int (Int64) import Data.Monoid (Monoid(..)) import Data.Semigroup as Sem +import Data.These import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS.Char8 import qualified Data.ByteString.Lazy as LBS @@ -246,6 +249,22 @@ entryFormat = UstarFormat } + +-- | Gnu entry for when a filepath is too long to be in entryTarPath. +-- Gnu tar uses OtherEntryType 'L' then as the first Entry and puts path +-- in the entryContent. The Next entry will then be the "original" +-- entry with the entryTarPath truncated. +longLinkEntry :: RawFilePath -> Entry +longLinkEntry tarpath = Entry { + entryTarPath = TarPath (BS.Char8.pack "././@LongLink") BS.empty, + entryContent = OtherEntryType 'L' (LBS.fromStrict tarpath) (fromIntegral $ BS.length tarpath), + entryPermissions = ordinaryFilePermissions, + entryOwnership = Ownership "" "" 0 0, + entryTime = 0, + entryFormat = GnuFormat + } + + -- | A tar 'Entry' for a file. -- -- Entry fields such as file permissions and ownership have default values. @@ -349,7 +368,7 @@ -- toTarPath :: Bool -- ^ Is the path for a directory? This is needed because for -- directories a 'TarPath' must always use a trailing @\/@. - -> RawFilePath -> Either String TarPath + -> RawFilePath -> These SplitError TarPath toTarPath isDir = splitLongPath . addTrailingSep . FilePath.Posix.joinPath @@ -358,6 +377,11 @@ addTrailingSep | isDir = FilePath.Posix.addTrailingPathSeparator | otherwise = id + +data SplitError = FileNameEmpty + | FileNameTooLong + deriving Show + -- | Take a sanitised path, split on directory separators and try to pack it -- into the 155 + 100 tar file name format. -- @@ -365,15 +389,17 @@ -- and try to fit as many components into the 100 long name area as possible. -- If all the remaining components fit in the 155 name area then we win. -- -splitLongPath :: RawFilePath -> Either String TarPath +splitLongPath :: RawFilePath -> These SplitError TarPath splitLongPath path = case packName nameMax (reverse (FilePath.Posix.splitPath path)) of - Left err -> Left err - Right (name, []) -> Right $! TarPath name BS.empty + Left FileNameTooLong -> These FileNameTooLong $ TarPath (BS.take 100 path) BS.empty + Left e -> This e + Right (name, []) -> That $! TarPath name BS.empty Right (name, first:rest) -> case packName prefixMax remainder of - Left err -> Left err - Right (_ , (_:_)) -> Left "File name too long (cannot split)" - Right (prefix, []) -> Right $! TarPath name prefix + Left FileNameTooLong -> These FileNameTooLong $ TarPath (BS.take 100 path) BS.empty + Left e -> This e + Right (_ , (_:_)) -> These FileNameTooLong $ TarPath (BS.take 100 path) BS.empty + Right (prefix, []) -> That $! TarPath name prefix where -- drop the '/' between the name and prefix: remainder = BS.init first : rest @@ -383,9 +409,9 @@ nameMax = 100 prefixMax = 155 - packName _ [] = Left "File name empty" + packName _ [] = Left FileNameEmpty packName maxLen (c:cs) - | n > maxLen = Left "File name too long" + | n > maxLen = Left FileNameTooLong | otherwise = Right (packName' maxLen n [c] cs) where n = BS.length c @@ -558,14 +584,14 @@ | perms' <- shrinkIntegral perms ] instance Arbitrary TarPath where - arbitrary = either error id + arbitrary = these (error . show) id (flip const) . toTarPath False . FilePath.Posix.joinPath . fmap BS.Char8.pack <$> listOf1ToN (255 `div` 5) (elements (map (replicate 4) "abcd")) - shrink = map (either error id . toTarPath False) + shrink = map (these (error . show) id (flip const) . toTarPath False) . map FilePath.Posix.joinPath . filter (not . null) . shrinkList shrinkNothing diff --git a/Codec/Archive/Tar/Unpack.hs b/Codec/Archive/Tar/Unpack.hs --- a/Codec/Archive/Tar/Unpack.hs +++ b/Codec/Archive/Tar/Unpack.hs @@ -18,6 +18,7 @@ import Codec.Archive.Tar.Types import Codec.Archive.Tar.Check +import Data.List (partition) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as L import System.Posix.FilePath @@ -65,8 +66,12 @@ -- use 'checkSecurity' before 'checkTarbomb' or other checks. -- unpack :: Exception e => RawFilePath -> Entries e -> IO () -unpack baseDir entries = unpackEntries [] (checkSecurity entries) - >>= emulateLinks +unpack baseDir entries = do + uEntries <- unpackEntries [] (checkSecurity entries) + let (hardlinks, symlinks) = partition (\(_, _, x) -> x) uEntries + -- emulate hardlinks first, in case a symlink points to it + emulateLinks hardlinks + emulateLinks symlinks where -- We're relying here on 'checkSecurity' to make sure we're not scribbling @@ -75,23 +80,37 @@ unpackEntries _ (Fail err) = either throwIO throwIO err unpackEntries links Done = return links unpackEntries links (Next entry es) = case entryContent entry of - NormalFile file _ -> extractFile entry path file mtime + NormalFile file _ -> extractFile fPerms path file mtime >> unpackEntries links es Directory -> extractDir path mtime >> unpackEntries links es - HardLink link -> (unpackEntries $! saveLink path link links) es - SymbolicLink link -> (unpackEntries $! saveLink path link links) es - _ -> unpackEntries links es --ignore other file types + HardLink link -> (unpackEntries $! saveLink True path link links) es + SymbolicLink link -> (unpackEntries $! saveLink False path link links) es + OtherEntryType 'L' fn _ -> + case es of + (Next entry' es') -> case entryContent entry' of + NormalFile file _ -> extractFile fPerms (L.toStrict fn) file mtime + >> unpackEntries links es' + Directory -> extractDir (L.toStrict fn) mtime + >> unpackEntries links es' + HardLink link -> (unpackEntries $! saveLink True path link links) es' + SymbolicLink link -> (unpackEntries $! saveLink False path link links) es' + OtherEntryType 'L' _ _ -> throwIO $ userError "Two subsequent OtherEntryType 'L'" + _ -> unpackEntries links es' + (Fail err) -> either throwIO throwIO err + Done -> throwIO $ userError "././@LongLink without a subsequent entry" + _ -> unpackEntries links es --ignore other file types where path = entryPath entry mtime = entryTime entry + fPerms = entryPermissions entry - extractFile entry path content mtime = do + extractFile fPerms path content mtime = do -- Note that tar archives do not make sure each directory is created -- before files they contain, indeed we may have to create several -- levels of directory. createDirRecursive dirPerms (normalise absDir) - writeFileL absPath (Just $ entryPermissions entry) content + writeFileL absPath (Just fPerms) content setModTime absPath mtime where absDir = baseDir FilePath.Native.takeDirectory path @@ -103,15 +122,18 @@ where absPath = baseDir path - saveLink path link links = seq (BS.length path) - $ seq (BS.length link') - $ (path, link'):links + saveLink isHardLink path link links = seq (BS.length path) + $ seq (BS.length link') + $ (path, link', isHardLink):links where link' = fromLinkTarget link - emulateLinks = mapM_ $ \(relPath, relLinkTarget) -> do - let absPath = baseDir relPath - absTarget = FilePath.Native.takeDirectory absPath relLinkTarget - copyFile absTarget absPath Overwrite + emulateLinks = mapM_ $ \(relPath, relLinkTarget, isHardLink) -> + let absPath = baseDir relPath + -- hard links link targets are always "absolute" paths in + -- the context of the tar root + absTarget = if isHardLink then baseDir relLinkTarget else FilePath.Native.takeDirectory absPath relLinkTarget + in copyFile absTarget absPath Overwrite + setModTime :: RawFilePath -> EpochTime -> IO () setModTime p t = setModificationTime p (fromIntegral t) diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,9 @@ See also http://pvp.haskell.org/faq +0.6.3.0 + + * Fix unpacking of hard links + 0.6.2.0 * fix executable bit: https://github.com/haskell/tar/issues/25 diff --git a/tar-bytestring.cabal b/tar-bytestring.cabal --- a/tar-bytestring.cabal +++ b/tar-bytestring.cabal @@ -1,5 +1,5 @@ name: tar-bytestring -version: 0.6.2.0 +version: 0.6.3.0 license: BSD3 license-file: LICENSE author: Duncan Coutts @@ -48,6 +48,7 @@ hpath-filepath >= 0.10.4 && < 0.11, hpath-posix >= 0.13.1 && < 0.14, safe-exceptions >= 0.1, + these >= 1.0.1, unix, word8 @@ -98,6 +99,7 @@ hpath-filepath >= 0.10.4 && < 0.11, hpath-posix >= 0.13.1 && < 0.14, safe-exceptions >= 0.1, + these >= 1.0.1, unix, word8 @@ -151,6 +153,7 @@ hpath-filepath >= 0.10.4 && < 0.11, hpath-posix >= 0.13.1 && < 0.14, safe-exceptions >= 0.1, + these >= 1.0.1, unix, word8