diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 9af7978..8e66885 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -73,16 +73,6 @@ jobs: compilerVersion: 8.4.4 setup-method: hvr-ppa allow-failure: false - - compiler: ghc-8.2.2 - compilerKind: ghc - compilerVersion: 8.2.2 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-8.0.2 - compilerKind: ghc - compilerVersion: 8.0.2 - setup-method: hvr-ppa - allow-failure: false fail-fast: false steps: - name: apt diff --git a/Codec/Archive/Tar/Entry.hs b/Codec/Archive/Tar/Entry.hs index 2bb85ca..93941f5 100644 --- a/Codec/Archive/Tar/Entry.hs +++ b/Codec/Archive/Tar/Entry.hs @@ -48,6 +48,7 @@ module Codec.Archive.Tar.Entry ( fileEntry, directoryEntry, longLinkEntry, + longSymLinkEntry, -- * Standard file permissions -- | For maximum portability when constructing archives use only these file diff --git a/Codec/Archive/Tar/Pack.hs b/Codec/Archive/Tar/Pack.hs index 5d60e19..ac5b154 100644 --- a/Codec/Archive/Tar/Pack.hs +++ b/Codec/Archive/Tar/Pack.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- | -- Module : Codec.Archive.Tar @@ -23,6 +24,7 @@ module Codec.Archive.Tar.Pack ( import Codec.Archive.Tar.Types import Control.Monad (join, when, forM) +import qualified Data.ByteString as BSS import qualified Data.ByteString.Lazy as BS import System.FilePath ( () ) @@ -80,11 +82,24 @@ preparePaths baseDir paths = packPaths :: FilePath -> [FilePath] -> IO [Entry] packPaths baseDir paths = fmap concat $ interleave - [ do let tarpath = toTarPath' isDir relpath + [ do let tarpathRes = toTarPath' isDir relpath isSymlink <- pathIsSymbolicLink filepath - if | isSymlink -> withLongLinkEntry filepath tarpath packSymlinkEntry - | isDir -> withLongLinkEntry filepath tarpath packDirectoryEntry - | otherwise -> withLongLinkEntry filepath tarpath packFileEntry + case tarpathRes of + FileNameEmpty -> throwIO $ userError "File name empty" + FileNameOK tarpath + | isSymlink -> (:[]) <$> packSymlinkEntry filepath tarpath + | isDir -> (:[]) <$> packDirectoryEntry filepath tarpath + | otherwise -> (:[]) <$> packFileEntry filepath tarpath + FileNameTooLong tarpath + | isSymlink -> do + linkTarget <- getSymbolicLinkTarget filepath + packSymlinkEntry' linkTarget tarpath >>= \case + sym@(Entry { entryContent = SymbolicLink (LinkTarget bs) }) + | BSS.length bs > 100 -> do + pure [longSymLinkEntry linkTarget, longLinkEntry filepath, sym] + _ -> withLongLinkEntry filepath tarpath packSymlinkEntry + | isDir -> withLongLinkEntry filepath tarpath packDirectoryEntry + | otherwise -> withLongLinkEntry filepath tarpath packFileEntry | relpath <- paths , let isDir = FilePath.Native.hasTrailingPathSeparator filepath filepath = baseDir relpath ] @@ -92,12 +107,10 @@ packPaths baseDir paths = -- prepend the long filepath entry if necessary withLongLinkEntry :: FilePath - -> ToTarPathResult + -> TarPath -> (FilePath -> TarPath -> IO Entry) -> IO [Entry] - withLongLinkEntry _ FileNameEmpty _ = throwIO $ userError "File name empty" - withLongLinkEntry filepath (FileNameOK tarpath) f = (:[]) <$> f filepath tarpath - withLongLinkEntry filepath (FileNameTooLong tarpath) f = do + withLongLinkEntry filepath tarpath f = do mainEntry <- f filepath tarpath pure [longLinkEntry filepath, mainEntry] @@ -156,6 +169,12 @@ packSymlinkEntry :: FilePath -- ^ Full path to find the file on the local disk -> IO Entry packSymlinkEntry filepath tarpath = do linkTarget <- getSymbolicLinkTarget filepath + packSymlinkEntry' linkTarget tarpath + +packSymlinkEntry' :: String -- ^ link target + -> TarPath -- ^ Path to use for the tar Entry in the archive + -> IO Entry +packSymlinkEntry' linkTarget tarpath = do let entry tp = symlinkEntry tp linkTarget safeReturn tp = maybe (pure tp) throwIO $ checkEntrySecurity tp safeReturn $ entry tarpath diff --git a/Codec/Archive/Tar/Types.hs b/Codec/Archive/Tar/Types.hs index 192a853..37ecbcd 100644 --- a/Codec/Archive/Tar/Types.hs +++ b/Codec/Archive/Tar/Types.hs @@ -30,6 +30,7 @@ module Codec.Archive.Tar.Types ( simpleEntry, longLinkEntry, + longSymLinkEntry, fileEntry, symlinkEntry, directoryEntry, @@ -265,6 +266,23 @@ longLinkEntry tarpath = Entry { entryFormat = GnuFormat } +-- | [GNU extension](https://www.gnu.org/software/tar/manual/html_node/Standard.html) +-- to store a link target too long to fit into 'entryTarPath' +-- as 'OtherEntryType' @\'K\'@ with the full filepath as 'entryContent'. +-- The next entry must contain the actual +-- data with truncated 'entryTarPath'. +-- +-- @since 0.6.0.0 +longSymLinkEntry :: FilePath -> Entry +longSymLinkEntry linkTarget = Entry { + entryTarPath = TarPath (BS.Char8.pack "././@LongLink") BS.empty, + entryContent = OtherEntryType 'K' (LBS.fromStrict $ packAscii linkTarget) (fromIntegral $ length linkTarget), + entryPermissions = ordinaryFilePermissions, + entryOwnership = Ownership "" "" 0 0, + entryTime = 0, + entryFormat = GnuFormat + } + -- | A tar 'Entry' for a directory. -- -- Entry fields such as file permissions and ownership have default values. diff --git a/Codec/Archive/Tar/Unpack.hs b/Codec/Archive/Tar/Unpack.hs index 2831699..8b450da 100644 --- a/Codec/Archive/Tar/Unpack.hs +++ b/Codec/Archive/Tar/Unpack.hs @@ -22,6 +22,7 @@ import Codec.Archive.Tar.Check import Data.Bits ( testBit ) import Data.List (partition, nub) +import Data.Maybe ( fromMaybe ) import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString.Lazy as BS import System.FilePath @@ -32,6 +33,7 @@ import System.Directory ( createDirectoryIfMissing, copyFile, setPermissions, getDirectoryContents, doesDirectoryExist, createDirectoryLink, createFileLink ) import Control.Exception ( Exception, throwIO, handle ) +import System.IO ( stderr, hPutStr ) import System.IO.Error ( ioeGetErrorType ) import GHC.IO (unsafeInterleaveIO) @@ -73,7 +75,7 @@ import System.IO.Error -- unpack :: Exception e => FilePath -> Entries e -> IO () unpack baseDir entries = do - uEntries <- unpackEntries [] (checkSecurity entries) + uEntries <- unpackEntries Nothing Nothing [] (checkSecurity entries) let (hardlinks, symlinks) = partition (\(_, _, x) -> x) uEntries -- handle hardlinks first, in case a symlink points to it handleHardLinks hardlinks @@ -83,32 +85,49 @@ unpack baseDir entries = do -- We're relying here on 'checkSecurity' to make sure we're not scribbling -- files all over the place. - unpackEntries _ (Fail err) = either throwIO throwIO err - unpackEntries links Done = return links - unpackEntries links (Next entry es) = case entryContent entry of - NormalFile file _ -> do - extractFile (entryPermissions entry) (entryPath entry) file (entryTime entry) - unpackEntries links es - Directory -> do - extractDir (entryPath entry) (entryTime entry) - unpackEntries links es - HardLink link -> (unpackEntries $! saveLink True (entryPath entry) link links) es - SymbolicLink link -> (unpackEntries $! saveLink False (entryPath entry) link links) es - OtherEntryType 'L' (Char8.unpack . BS.toStrict -> fn) _ -> - case es of - (Next entry' es') -> case entryContent entry' of - NormalFile file _ -> do - extractFile (entryPermissions entry') fn file (entryTime entry') - unpackEntries links es' - Directory -> extractDir fn (entryTime entry') - >> unpackEntries links es' - HardLink link -> (unpackEntries $! saveLink True fn link links) es' - SymbolicLink link -> (unpackEntries $! saveLink False fn 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 + unpackEntries :: Exception e + => Maybe LinkTarget + -> Maybe FilePath + -> [(FilePath, FilePath, Bool)] -- ^ links (path, link, isHardLink) + -> Entries (Either e FileNameError) -- ^ entries + -> IO [(FilePath, FilePath, Bool)] + unpackEntries _ _ _ (Fail err) = either throwIO throwIO err + unpackEntries _ _ links Done = return links + unpackEntries mLink mPath links (Next entry es) = do + let path = fromMaybe (entryPath entry) mPath + case entryContent entry of + NormalFile file _ + | Just _ <- mLink -> throwIO $ userError "Expected SymbolicLink or HardLink after OtherEntryType K" + | otherwise -> do + extractFile (entryPermissions entry) path file (entryTime entry) + unpackEntries Nothing Nothing links es + Directory + | Just _ <- mLink -> throwIO $ userError "Expected SymbolicLink or HardLink after OtherEntryType K" + | otherwise -> do + extractDir path (entryTime entry) + unpackEntries Nothing Nothing links es + HardLink link -> do + let linkTarget = fromMaybe link mLink + (unpackEntries Nothing Nothing $! saveLink True path linkTarget links) es + SymbolicLink link -> do + let linkTarget = fromMaybe link mLink + (unpackEntries Nothing Nothing $! saveLink False path linkTarget links) es + OtherEntryType 'L' fn _ + | Just _ <- mPath -> throwIO $ userError "Two subsequent OtherEntryType L" + | otherwise -> unpackEntries mLink (Just . Char8.unpack . BS.toStrict $ fn) links es + OtherEntryType 'K' link _ + | Just _ <- mLink -> throwIO $ userError "Two subsequent OtherEntryType K" + | otherwise -> unpackEntries (Just . LinkTarget . BS.toStrict $ link) mPath links es + OtherEntryType _ _ _ + | Just _ <- mLink -> throwIO $ userError "Unknown entry type following OtherEntryType K" + | Just _ <- mPath -> throwIO $ userError "Unknown entry type following OtherEntryType L" + | otherwise -> do + -- the spec demands that we attempt to extract as normal file on unknown typecode, + -- but we just skip it + unpackEntries Nothing Nothing links es + _ -> do + unpackEntries Nothing Nothing links es -- ignore other file types + extractFile permissions path content mtime = do -- Note that tar archives do not make sure each directory is created diff --git a/tar.cabal b/tar.cabal index abfc6af..f220cb9 100644 --- a/tar.cabal +++ b/tar.cabal @@ -23,10 +23,10 @@ description: This library is for working with \"@.tar@\" archive files. It content using an index. build-type: Simple cabal-version: 2.0 -extra-source-files: changelog.md +extra-source-files: test/data/long.tar +extra-doc-files: changelog.md tested-with: GHC==9.8.1, GHC==9.6.3, GHC==9.4.8, GHC==9.2.8, GHC==9.0.2, - GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, - GHC==8.2.2, GHC==8.0.2 + GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4 source-repository head type: git @@ -44,7 +44,7 @@ library library tar-internal default-language: Haskell2010 - build-depends: base >= 4.9 && < 5, + build-depends: base >= 4.11.0.0 && < 5, array < 0.6, bytestring >= 0.10 && < 0.13, containers >= 0.2 && < 0.8, @@ -87,6 +87,7 @@ test-suite properties containers, deepseq, directory >= 1.2, + file-embed, filepath, QuickCheck == 2.*, tar-internal, diff --git a/test/Codec/Archive/Tar/Pack/Tests.hs b/test/Codec/Archive/Tar/Pack/Tests.hs index 035bb5e..59b14d7 100644 --- a/test/Codec/Archive/Tar/Pack/Tests.hs +++ b/test/Codec/Archive/Tar/Pack/Tests.hs @@ -1,9 +1,17 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} module Codec.Archive.Tar.Pack.Tests ( prop_roundtrip + , unit_roundtrip ) where +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.FileEmbed +import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Pack as Pack import Codec.Archive.Tar.Types (Entries(..)) import qualified Codec.Archive.Tar.Unpack as Unpack @@ -49,3 +57,10 @@ prop_roundtrip xss (ASCIIString cnt) mkFilePath :: ASCIIString -> FilePath mkFilePath (ASCIIString xs) = makeValid $ filter (\c -> not $ isPathSeparator c || c == '.') xs + +unit_roundtrip :: Property +unit_roundtrip = + let tar :: BL.ByteString = BL.fromStrict $(embedFile "test/data/long.tar") + entries = Tar.foldEntries (:) [] (const []) (Tar.read tar) + in Tar.write entries === tar + diff --git a/test/Properties.hs b/test/Properties.hs index b5869ff..5f442a1 100644 --- a/test/Properties.hs +++ b/test/Properties.hs @@ -55,7 +55,8 @@ main = ] , testGroup "pack" [ - testProperty "roundtrip" Pack.prop_roundtrip + testProperty "roundtrip" Pack.prop_roundtrip, + testProperty "long symlink" Pack.unit_roundtrip ] ] diff --git a/test/data/long.tar b/test/data/long.tar new file mode 100644 index 0000000..b4ad726 Binary files /dev/null and b/test/data/long.tar differ