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

Stop trying to reset permissions on pax header entries. XXX incomplete.
Blaisorblade · Jul 10, 2016 · 1430574 · 1430574
1 parent 4304711
commit 1430574
Showing 1 changed file with 20 additions and 2 deletions.
diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs
@@ -510,9 +510,25 @@ fetchPackages' mdistDir toFetchAll = 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 f = Tar.foldEntries (\e -> if f e then Tar.Next e else id) Tar.Done Tar.Fail
+                    extractableEntry e =
+                      case Tar.entryContent e of
+                        Tar.NormalFile _ _ -> True
+                        Tar.Directory -> True
+                        Tar.SymbolicLink _ -> True
+                        Tar.HardLink _ -> True
+                        Tar.CharacterDevice _ _ -> False
+                        Tar.BlockDevice _ _ -> False
+                        Tar.NamedPipe -> False
+                        Tar.OtherEntryType 'g' _ _ -> False
+                        Tar.OtherEntryType 'x' _ _ -> False
+                        -- XXX give a warning for an unexpected entry type.
+                        Tar.OtherEntryType _ _ _ -> False
+                    entries = filterEntries extractableEntry rawEntries
+
                     wrap :: Exception e => e -> FetchException
                     wrap = Couldn'tReadPackageTarball fp . toException
                     identStr = packageIdentifierString ident
@@ -525,7 +541,9 @@ fetchPackages' mdistDir toFetchAll = 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