Merge pull request #2363 from Blaisorblade/2361-ignore-pax-header-ent…

…ries

stack unpack: Ignore pax headers (fix #2361)

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

@@ -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

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,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

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