stack unpack: Ignore pax headers (fix commercialhaskell#2361)

* Stop trying to reset permissions on pax header entries.
* Add changelog entry.
* Output warnings for unexpected entries.
* Add testcases.

The interface of untar is designed for unit testing.

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
 

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

src/test/Stack/Untar/README.md

@@ -0,0 +1 @@
+Use ./createFiles.sh to regenerate the test tarballs in this directory.

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

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

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