diff --git a/ChangeLog.md b/ChangeLog.md index 6d34761d14..150e5655d9 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -27,6 +27,8 @@ Bug fixes: [#2225](https://github.com/commercialhaskell/stack/issues/2225) * Detect resolver change in `stack solver` [#2252](https://github.com/commercialhaskell/stack/issues/2252) +* Ignore special entries when unpacking tarballs + [#2361](https://github.com/commercialhaskell/stack/issues/2361) ## 1.1.2 diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs index b1fc193fc8..3fae1e0e5f 100644 --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -16,6 +16,7 @@ module Stack.Fetch ( unpackPackages , unpackPackageIdents , fetchPackages + , untar , resolvePackages , resolvePackagesAllowMissing , ResolvedPackage (..) @@ -70,12 +71,12 @@ import Data.Typeable (Typeable) import Data.Word (Word64) import Network.HTTP.Download import Path +import Path.Extra (toFilePathNoTrailingSep) import Path.IO import Prelude -- Fix AMP warning import Stack.GhcPkg import Stack.PackageIndex import Stack.Types -import qualified System.Directory as D import System.FilePath ((<.>)) import qualified System.FilePath as FP import System.IO (IOMode (ReadMode), @@ -498,54 +499,30 @@ fetchPackages' mdistDir toFetchAll = do liftIO $ runInBase $ $logInfo $ packageIdentifierText ident <> ": download" _ <- verifiedDownload downloadReq destpath progressSink - let fp = toFilePath destpath + identStrP <- parseRelDir $ packageIdentifierString ident F.forM_ (tfDestDir toFetch) $ \destDir -> do - let dest = toFilePath $ parent destDir - innerDest = toFilePath destDir + let innerDest = toFilePath destDir - liftIO $ ensureDir (parent destDir) - - liftIO $ withBinaryFile fp ReadMode $ \h -> do - -- Avoid using L.readFile, which is more likely to leak - -- resources - lbs <- L.hGetContents h - let entries = fmap (either wrap wrap) - $ Tar.checkTarbomb identStr - $ Tar.read $ decompress lbs - wrap :: Exception e => e -> FetchException - wrap = Couldn'tReadPackageTarball fp . toException - identStr = packageIdentifierString ident - - getPerms :: Tar.Entry -> (FilePath, Tar.Permissions) - getPerms e = (dest FP. Tar.fromTarPath (Tar.entryTarPath e), - Tar.entryPermissions e) - - filePerms :: [(FilePath, Tar.Permissions)] - filePerms = catMaybes $ Tar.foldEntries (\e -> (:) (Just $ getPerms e)) - [] (const []) entries - Tar.unpack dest entries - -- Reset file permissions as they were in the tarball - mapM_ (\(fp', perm) -> setFileMode - (FP.dropTrailingPathSeparator fp') - perm) filePerms + unexpectedEntries <- liftIO $ untar destpath identStrP (parent destDir) + liftIO $ do case mdistDir of Nothing -> return () -- See: https://github.com/fpco/stack/issues/157 Just distDir -> do - let inner = dest FP. identStr - oldDist = inner FP. "dist" - newDist = inner FP. toFilePath distDir - exists <- D.doesDirectoryExist oldDist + let inner = parent destDir identStrP + oldDist = inner $(mkRelDir "dist") + newDist = inner distDir + exists <- doesDirExist oldDist when exists $ do -- Previously used takeDirectory, but that got confused -- by trailing slashes, see: -- https://github.com/commercialhaskell/stack/issues/216 -- -- Instead, use Path which is a bit more resilient - ensureDir . parent =<< parseAbsDir newDist - D.renameDirectory oldDist newDist + ensureDir $ parent newDist + renameDir oldDist newDist let cabalFP = innerDest FP. @@ -554,6 +531,69 @@ fetchPackages' mdistDir toFetchAll = do S.writeFile cabalFP $ tfCabal toFetch atomically $ modifyTVar outputVar $ Map.insert ident destDir + $logWarn $ mconcat $ map (\(path, entryType) -> "Unexpected entry type " <> entryType <> " for entry " <> T.pack path) unexpectedEntries + +-- | Internal function used to unpack tarball. +-- +-- Takes a path to a .tar.gz file, the name of the directory it should contain, +-- and a destination folder to extract the tarball into. Returns unexpected +-- entries, as pairs of paths and descriptions. +untar :: forall b1 b2. Path b1 File -> Path Rel Dir -> Path b2 Dir -> IO [(FilePath, T.Text)] +untar tarPath expectedTarFolder destDirParent = do + ensureDir destDirParent + withBinaryFile (toFilePath tarPath) ReadMode $ \h -> do + -- Avoid using L.readFile, which is more likely to leak + -- resources + lbs <- L.hGetContents h + let rawEntries = fmap (either wrap wrap) + $ Tar.checkTarbomb (toFilePathNoTrailingSep expectedTarFolder) + $ Tar.read $ decompress lbs + + filterEntries + :: Monoid w => (Tar.Entry -> (Bool, w)) + -> Tar.Entries b -> (Tar.Entries b, w) + -- Allow collecting warnings, Writer-monad style. + filterEntries f = + Tar.foldEntries + (\e -> let (res, w) = f e in + \(rest, wOld) -> ((if res then Tar.Next e else id) rest, wOld <> w)) + (Tar.Done, mempty) + (\err -> (Tar.Fail err, mempty)) + + extractableEntry e = + case Tar.entryContent e of + Tar.NormalFile _ _ -> (True, []) + Tar.Directory -> (True, []) + Tar.SymbolicLink _ -> (True, []) + Tar.HardLink _ -> (True, []) + Tar.OtherEntryType 'g' _ _ -> (False, []) + Tar.OtherEntryType 'x' _ _ -> (False, []) + Tar.CharacterDevice _ _ -> (False, [(path, "character device")]) + Tar.BlockDevice _ _ -> (False, [(path, "block device")]) + Tar.NamedPipe -> (False, [(path, "named pipe")]) + Tar.OtherEntryType code _ _ -> (False, [(path, "other entry type with code " <> T.pack (show code))]) + where + path = Tar.fromTarPath $ Tar.entryTarPath e + (entries, unexpectedEntries) = filterEntries extractableEntry rawEntries + + wrap :: Exception e => e -> FetchException + wrap = Couldn'tReadPackageTarball (toFilePath tarPath) . toException + + getPerms :: Tar.Entry -> (FilePath, Tar.Permissions) + getPerms e = (toFilePath destDirParent FP. Tar.fromTarPath (Tar.entryTarPath e), + Tar.entryPermissions e) + + filePerms :: [(FilePath, Tar.Permissions)] + filePerms = catMaybes $ Tar.foldEntries (\e -> (:) (Just $ getPerms e)) + [] (const []) entries + Tar.unpack (toFilePath destDirParent) entries + -- Reset file permissions as they were in the tarball, but only + -- for extracted entries (whence filterEntries extractableEntry above). + -- See https://github.com/commercialhaskell/stack/issues/2361 + mapM_ (\(fp, perm) -> setFileMode + (FP.dropTrailingPathSeparator fp) + perm) filePerms + return unexpectedEntries parMapM_ :: (F.Foldable f,MonadIO m,MonadBaseControl IO m) => Int diff --git a/src/test/Stack/Untar/README.md b/src/test/Stack/Untar/README.md new file mode 100644 index 0000000000..35b2a11eea --- /dev/null +++ b/src/test/Stack/Untar/README.md @@ -0,0 +1 @@ +Use ./createFiles.sh to regenerate the test tarballs in this directory. diff --git a/src/test/Stack/Untar/UntarSpec.hs b/src/test/Stack/Untar/UntarSpec.hs new file mode 100644 index 0000000000..b3a8081761 --- /dev/null +++ b/src/test/Stack/Untar/UntarSpec.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Stack.Untar.UntarSpec where + +import Data.List (sort) +import Path +import Path.IO (removeDirRecur) +import qualified System.FilePath as FP +import Stack.Fetch (untar) +import Test.Hspec + +spec :: Spec +spec = do + describe "Untarring ignores strange entries" $ + mapM_ testTarFile tarFiles + where + -- XXX tests are run in the project root folder, but data files are next to + -- this source data. + currentFolder = $(mkRelDir $ "src" FP. "test" FP. "Stack" FP. "Untar") + + -- Pairs test tarball names + list of unexpected entries contained: for each + -- entry, a tar pathname + description. + tarFilesBase = [ ("test1", []) + , ("test2", [ ("bar", "named pipe") + , ("devB", "block device") + , ("devC", "character device")])] + -- Prepend tarball name to tar pathnames: + tarFiles = + [ (name, + [ (name FP. entryName, d) + | (entryName, d) <- entries]) + | (name, entries) <- tarFilesBase ] + + testTarFile (name, expected) = + it ("works on test " ++ name) $ + getEntries name `shouldReturn` sort expected + + getEntries name = do + tarballName <- parseRelFile $ name ++ ".tar.gz" + expectedTarFolder <- parseRelDir name + + entries <- untar (currentFolder tarballName) expectedTarFolder currentFolder + removeDirRecur $ currentFolder expectedTarFolder + return $ sort entries diff --git a/src/test/Stack/Untar/createFiles.sh b/src/test/Stack/Untar/createFiles.sh new file mode 100755 index 0000000000..25ca45805e --- /dev/null +++ b/src/test/Stack/Untar/createFiles.sh @@ -0,0 +1,26 @@ +#!/bin/sh + +# This allows recreating + +# Name for GNU tar. +TAR=tar +CHOWN=chown +# Needed on my OS X install with HomeBrew. +#TAR=gtar +#CHOWN=gchown + +mkdir -p test1 test2 +touch test1/foo +mkfifo test2/bar +sudo mknod test2/devB b 1 0 +sudo mknod test2/devC c 3 2 +sudo $CHOWN --reference=test2 test2/* + +for i in 1 2; do + $TAR czf test$i.tar.gz --format=posix test$i +done +for i in 1 2; do + gtar czf test$i.tar.gz --format=posix test$i +done + +rm -rf test1 test2 diff --git a/src/test/Stack/Untar/test1.tar.gz b/src/test/Stack/Untar/test1.tar.gz new file mode 100644 index 0000000000..17993d243c Binary files /dev/null and b/src/test/Stack/Untar/test1.tar.gz differ diff --git a/src/test/Stack/Untar/test2.tar.gz b/src/test/Stack/Untar/test2.tar.gz new file mode 100644 index 0000000000..7791b75a61 Binary files /dev/null and b/src/test/Stack/Untar/test2.tar.gz differ diff --git a/stack.cabal b/stack.cabal index 4ee8c0ce86..708df554ea 100644 --- a/stack.cabal +++ b/stack.cabal @@ -288,6 +288,7 @@ test-suite stack-test , Stack.StoreSpec , Network.HTTP.Download.VerifiedSpec , Stack.SolverSpec + , Stack.Untar.UntarSpec ghc-options: -threaded -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates build-depends: Cabal >= 1.18.1.5 && < 1.25 , QuickCheck < 2.10 @@ -299,6 +300,7 @@ test-suite stack-test , cryptohash , directory >= 1.2.1.0 , exceptions + , filepath , hspec <2.3 , http-conduit , monad-logger