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.