From bb4befcf3b1a6e1aa0e02fa03d508a2399fd3627 Mon Sep 17 00:00:00 2001
From: "Paolo G. Giarrusso"
Date: Sun, 17 Jul 2016 20:36:57 +0200
Subject: [PATCH 1/7] fetchPackages': Close tarfile earlier
Prepare to split this function to have unit tests for it.
This change should be harmless but is not a refactoring, separating this
for testing.
---
src/Stack/Fetch.hs | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs
index b1fc193fc8..a8094182cd 100644
--- a/src/Stack/Fetch.hs
+++ b/src/Stack/Fetch.hs
@@ -497,6 +497,7 @@ fetchPackages' mdistDir toFetchAll = do
let progressSink _ =
liftIO $ runInBase $ $logInfo $ packageIdentifierText ident <> ": download"
_ <- verifiedDownload downloadReq destpath progressSink
+ let identStr = packageIdentifierString ident
let fp = toFilePath destpath
@@ -515,7 +516,6 @@ fetchPackages' mdistDir toFetchAll = do
$ 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),
@@ -530,6 +530,7 @@ fetchPackages' mdistDir toFetchAll = do
(FP.dropTrailingPathSeparator fp')
perm) filePerms
+ liftIO $ do
case mdistDir of
Nothing -> return ()
-- See: https://github.com/fpco/stack/issues/157
From eef92902ce6a2da0cfe623ecceefd47b08d72097 Mon Sep 17 00:00:00 2001
From: "Paolo G. Giarrusso"
Date: Sun, 17 Jul 2016 20:50:14 +0200
Subject: [PATCH 2/7] Translate line to use FilePath
---
src/Stack/Fetch.hs | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs
index a8094182cd..243e71d5c1 100644
--- a/src/Stack/Fetch.hs
+++ b/src/Stack/Fetch.hs
@@ -505,7 +505,7 @@ fetchPackages' mdistDir toFetchAll = do
let dest = toFilePath $ parent destDir
innerDest = toFilePath destDir
- liftIO $ ensureDir (parent destDir)
+ liftIO $ D.createDirectoryIfMissing True dest
liftIO $ withBinaryFile fp ReadMode $ \h -> do
-- Avoid using L.readFile, which is more likely to leak
From 6e6c41ef95fc01d6794b919178e8f93515d07fd0 Mon Sep 17 00:00:00 2001
From: "Paolo G. Giarrusso"
Date: Sun, 17 Jul 2016 20:56:40 +0200
Subject: [PATCH 3/7] Split untar function from fetchPackages'
---
src/Stack/Fetch.hs | 53 +++++++++++++++++++++++++---------------------
1 file changed, 29 insertions(+), 24 deletions(-)
diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs
index 243e71d5c1..ed5de31605 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 (..)
@@ -505,30 +506,7 @@ fetchPackages' mdistDir toFetchAll = do
let dest = toFilePath $ parent destDir
innerDest = toFilePath destDir
- liftIO $ D.createDirectoryIfMissing True dest
-
- 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
-
- 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
+ liftIO $ untar fp identStr dest
liftIO $ do
case mdistDir of
@@ -556,6 +534,33 @@ fetchPackages' mdistDir toFetchAll = do
atomically $ modifyTVar outputVar $ Map.insert ident destDir
+-- | Internal function used to unpack tarball.
+untar :: FilePath -> FilePath -> FilePath -> IO ()
+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)
+ $ Tar.checkTarbomb identStr
+ $ Tar.read $ decompress lbs
+ wrap :: Exception e => e -> FetchException
+ wrap = Couldn'tReadPackageTarball fp . toException
+
+ 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
+
parMapM_ :: (F.Foldable f,MonadIO m,MonadBaseControl IO m)
=> Int
-> (a -> m ())
From 6af46db4aa8ddb13d27bf2d78d90c6e41d7159db Mon Sep 17 00:00:00 2001
From: "Paolo G. Giarrusso"
Date: Sun, 10 Jul 2016 20:58:18 +0200
Subject: [PATCH 4/7] stack unpack: Ignore pax headers (fix #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 | 2 ++
src/Stack/Fetch.hs | 44 +++++++++++++++++++++++++---
src/test/Stack/Untar/README.md | 1 +
src/test/Stack/Untar/UntarSpec.hs | 40 +++++++++++++++++++++++++
src/test/Stack/Untar/createFiles.sh | 26 ++++++++++++++++
src/test/Stack/Untar/test1.tar.gz | Bin 0 -> 273 bytes
src/test/Stack/Untar/test2.tar.gz | Bin 0 -> 367 bytes
stack.cabal | 2 ++
8 files changed, 111 insertions(+), 4 deletions(-)
create mode 100644 src/test/Stack/Untar/README.md
create mode 100644 src/test/Stack/Untar/UntarSpec.hs
create mode 100755 src/test/Stack/Untar/createFiles.sh
create mode 100644 src/test/Stack/Untar/test1.tar.gz
create mode 100644 src/test/Stack/Untar/test2.tar.gz
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 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 0000000000000000000000000000000000000000..17993d243c60cf55ca2c73c38bbedf7ffaad279d
GIT binary patch
literal 273
zcmV+s0q*`EiwFSfql{Mo1MSsKYQr!P1z@dn3ZEdBW=2xF$iB;7L9}+sqNG?3{=NxMO&6C!?5OUW*c&w>oj8%>nv|>7Rx3kZ*pM+y
zN*m+JscJvw5a;Y-AG$Qk9Pj#pNLQiXyfkYgZna|JJ6WW?$8zu1bHX%^VXvos$06e0
z+PpfKb5HV-e_iIE#fz%!v}0xO`G0-hgs$7gxIKL?9c$YQ&ne68m&o@&_y@GxGoRr*
zzS959obI34di4Js%Ko>+gZ@A4-Fi-#M$Z4JaUb}c|7-o9^DoA;s%FXLKkt7400000
X0000000000_&eSJ5w~2O04M+e7DbI_
literal 0
HcmV?d00001
diff --git a/src/test/Stack/Untar/test2.tar.gz b/src/test/Stack/Untar/test2.tar.gz
new file mode 100644
index 0000000000000000000000000000000000000000..7791b75a61486ed31911f88ddf32929e23dcdfaa
GIT binary patch
literal 367
zcmV-#0g(P5iwFSfql{Mo1MQeWPQx$|MYHZHa)QR=8QblG4QyC)g+No(1p*~0>hYPx
z&{RnPMc4t_d7DuzD<0YUFIJY>U4FPN@=Z}zOVVg5tBb1ENk9~1iQ3Bat5QZKpdBG-
zAZrr^zz<1!2-(DE?5jF2xs^HA`h#ed=JoEWxZ<5(t&p6?1&=+Pj#;3^Z}%z0p$&T$
zca0|E&KO^td^c$7@~`^&N26Slnz(IwKJx$axXa6OUsccJ^LW~J`^9_ua{DLv^B;Tz
z?s-pwF~$Fg$mg$7{67zU|C@h
literal 0
HcmV?d00001
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
From 2fb8bdc4173ebd06fef8acef42d3fce02df90cae Mon Sep 17 00:00:00 2001
From: "Paolo G. Giarrusso"
Date: Mon, 18 Jul 2016 13:48:32 +0200
Subject: [PATCH 5/7] Refactoring: renames
---
src/Stack/Fetch.hs | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs
index dc5d106243..21da522bd3 100644
--- a/src/Stack/Fetch.hs
+++ b/src/Stack/Fetch.hs
@@ -541,14 +541,14 @@ fetchPackages' mdistDir toFetchAll = do
-- 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
+untar tarFP expectedTarFolder dest = do
D.createDirectoryIfMissing True dest
- withBinaryFile fp ReadMode $ \h -> do
+ withBinaryFile tarFP 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 identStr
+ $ Tar.checkTarbomb expectedTarFolder
$ Tar.read $ decompress lbs
filterEntries
@@ -579,7 +579,7 @@ untar fp identStr dest = do
(entries, unexpectedEntries) = filterEntries extractableEntry rawEntries
wrap :: Exception e => e -> FetchException
- wrap = Couldn'tReadPackageTarball fp . toException
+ wrap = Couldn'tReadPackageTarball tarFP . toException
getPerms :: Tar.Entry -> (FilePath, Tar.Permissions)
getPerms e = (dest FP.> Tar.fromTarPath (Tar.entryTarPath e),
@@ -592,8 +592,8 @@ untar fp identStr dest = do
-- 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')
+ mapM_ (\(fp, perm) -> setFileMode
+ (FP.dropTrailingPathSeparator fp)
perm) filePerms
return unexpectedEntries
From 738a72f3487c35e5117401750ea53bca4f526815 Mon Sep 17 00:00:00 2001
From: "Paolo G. Giarrusso"
Date: Tue, 19 Jul 2016 17:51:41 +0200
Subject: [PATCH 6/7] untar: prefer taking Path to FilePath
Now I can also use Path's `ensureDir` again (I had to inline it to
`D.createDirectoryIfMissing True`).
Also, inline calls to toFilePath in untar, because:
1. toFilePath costs nothing so the inlining is safe.
2. Having to name both the Path and FilePath variants of the same
variable means looking for trouble.
---
src/Stack/Fetch.hs | 22 +++++++++++-----------
src/test/Stack/Untar/UntarSpec.hs | 31 +++++++++++++++++++------------
2 files changed, 30 insertions(+), 23 deletions(-)
diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs
index 21da522bd3..475171dfe4 100644
--- a/src/Stack/Fetch.hs
+++ b/src/Stack/Fetch.hs
@@ -71,6 +71,7 @@ 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
@@ -499,14 +500,13 @@ fetchPackages' mdistDir toFetchAll = do
liftIO $ runInBase $ $logInfo $ packageIdentifierText ident <> ": download"
_ <- verifiedDownload downloadReq destpath progressSink
let identStr = packageIdentifierString ident
-
- let fp = toFilePath destpath
+ identStrP <- parseRelDir identStr
F.forM_ (tfDestDir toFetch) $ \destDir -> do
let dest = toFilePath $ parent destDir
innerDest = toFilePath destDir
- unexpectedEntries <- liftIO $ untar fp identStr dest
+ unexpectedEntries <- liftIO $ untar destpath identStrP (parent destDir)
liftIO $ do
case mdistDir of
@@ -540,15 +540,15 @@ fetchPackages' mdistDir toFetchAll = do
-- 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 tarFP expectedTarFolder dest = do
- D.createDirectoryIfMissing True dest
- withBinaryFile tarFP ReadMode $ \h -> do
+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 expectedTarFolder
+ $ Tar.checkTarbomb (toFilePathNoTrailingSep expectedTarFolder)
$ Tar.read $ decompress lbs
filterEntries
@@ -579,16 +579,16 @@ untar tarFP expectedTarFolder dest = do
(entries, unexpectedEntries) = filterEntries extractableEntry rawEntries
wrap :: Exception e => e -> FetchException
- wrap = Couldn'tReadPackageTarball tarFP . toException
+ wrap = Couldn'tReadPackageTarball (toFilePath tarPath) . toException
getPerms :: Tar.Entry -> (FilePath, Tar.Permissions)
- getPerms e = (dest FP.> Tar.fromTarPath (Tar.entryTarPath e),
+ 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 dest 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
diff --git a/src/test/Stack/Untar/UntarSpec.hs b/src/test/Stack/Untar/UntarSpec.hs
index 2702fd2844..b3a8081761 100644
--- a/src/test/Stack/Untar/UntarSpec.hs
+++ b/src/test/Stack/Untar/UntarSpec.hs
@@ -1,12 +1,14 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Stack.Untar.UntarSpec where
import Data.List (sort)
-import System.FilePath ((>))
-import System.Directory (removeDirectoryRecursive)
+import Path
+import Path.IO (removeDirRecur)
+import qualified System.FilePath as FP
import Stack.Fetch (untar)
import Test.Hspec
@@ -17,24 +19,29 @@ spec = do
where
-- XXX tests are run in the project root folder, but data files are next to
-- this source data.
- currentFolder = "src" > "test" > "Stack" > "Untar"
+ 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.
- tarFiles = [ ("test1", [])
- , ("test2", [ ("test2" > "bar", "named pipe")
- , ("test2" > "devB", "block device")
- , ("test2" > "devC", "character device")])]
+ 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
- let tarFP = currentFolder > name ++ ".tar.gz"
- expectedTarFolder = name
- dest = currentFolder
+ tarballName <- parseRelFile $ name ++ ".tar.gz"
+ expectedTarFolder <- parseRelDir name
- entries <- untar tarFP expectedTarFolder dest
- removeDirectoryRecursive $ currentFolder > expectedTarFolder
+ entries <- untar (currentFolder > tarballName) expectedTarFolder currentFolder
+ removeDirRecur $ currentFolder > expectedTarFolder
return $ sort entries
From 1f534a70a0efe52454d814707db120bd7e5ce192 Mon Sep 17 00:00:00 2001
From: "Paolo G. Giarrusso"
Date: Tue, 19 Jul 2016 19:00:49 +0200
Subject: [PATCH 7/7] FilePath -> Path in most of fetchPackages'
---
src/Stack/Fetch.hs | 20 +++++++++-----------
1 file changed, 9 insertions(+), 11 deletions(-)
diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs
index 475171dfe4..3fae1e0e5f 100644
--- a/src/Stack/Fetch.hs
+++ b/src/Stack/Fetch.hs
@@ -77,7 +77,6 @@ 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),
@@ -499,12 +498,11 @@ fetchPackages' mdistDir toFetchAll = do
let progressSink _ =
liftIO $ runInBase $ $logInfo $ packageIdentifierText ident <> ": download"
_ <- verifiedDownload downloadReq destpath progressSink
- let identStr = packageIdentifierString ident
- identStrP <- parseRelDir identStr
+
+ identStrP <- parseRelDir $ packageIdentifierString ident
F.forM_ (tfDestDir toFetch) $ \destDir -> do
- let dest = toFilePath $ parent destDir
- innerDest = toFilePath destDir
+ let innerDest = toFilePath destDir
unexpectedEntries <- liftIO $ untar destpath identStrP (parent destDir)
@@ -513,18 +511,18 @@ fetchPackages' mdistDir toFetchAll = do
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.>