diff --git a/ChangeLog.md b/ChangeLog.md index 372e1f965a..f04747554b 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -20,6 +20,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 ed5de31605..dc5d106243 100644 --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -506,7 +506,7 @@ fetchPackages' mdistDir toFetchAll = do let dest = toFilePath $ parent destDir innerDest = toFilePath destDir - liftIO $ untar fp identStr dest + unexpectedEntries <- liftIO $ untar fp identStr dest liftIO $ do case mdistDir of @@ -533,18 +533,51 @@ 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. -untar :: FilePath -> FilePath -> FilePath -> IO () +-- +-- 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 :: FilePath -> FilePath -> FilePath -> IO [(FilePath, T.Text)] untar fp identStr dest = do D.createDirectoryIfMissing True dest 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) + let rawEntries = fmap (either wrap wrap) $ Tar.checkTarbomb identStr $ 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 fp . toException @@ -556,10 +589,13 @@ untar fp identStr dest = do filePerms = catMaybes $ Tar.foldEntries (\e -> (:) (Just $ getPerms e)) [] (const []) entries Tar.unpack dest entries - -- Reset file permissions as they were in the tarball + -- 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..2702fd2844 --- /dev/null +++ b/src/test/Stack/Untar/UntarSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Stack.Untar.UntarSpec where + +import Data.List (sort) +import System.FilePath (()) +import System.Directory (removeDirectoryRecursive) +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 = "src" "test" "Stack" "Untar" + + -- Pairs test tarball names + list of unexpected entries contained: for each + -- entry, a tar pathname + description. + tarFiles = [ ("test1", []) + , ("test2", [ ("test2" "bar", "named pipe") + , ("test2" "devB", "block device") + , ("test2" "devC", "character device")])] + + testTarFile (name, expected) = + it ("works on test " ++ name) $ + getEntries name `shouldReturn` sort expected + + getEntries name = do + let tarFP = currentFolder name ++ ".tar.gz" + expectedTarFolder = name + dest = currentFolder + + entries <- untar tarFP expectedTarFolder dest + removeDirectoryRecursive $ 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 08872914e2..1fe3a4dc6f 100644 --- a/stack.cabal +++ b/stack.cabal @@ -283,6 +283,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 @@ -294,6 +295,7 @@ test-suite stack-test , cryptohash , directory >= 1.2.1.0 , exceptions + , filepath , hspec <2.3 , http-conduit , monad-logger