From a3436ee14e38563ad3ad7e58123b0009b86fef96 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Thu, 6 Sep 2018 16:05:40 -0700 Subject: [PATCH 1/7] Fix takeSubDir to match whole directory names --- subs/pantry/src/Pantry/Archive.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index c1ef4f6edb..f12c7c792f 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -17,6 +17,7 @@ import Pantry.Tree import Pantry.Types import Pantry.Internal (normalizeParents, makeTarRelative) import qualified RIO.Text as T +import qualified RIO.Text.Partial as T import qualified RIO.List as List import qualified RIO.ByteString.Lazy as BL import qualified RIO.Map as Map @@ -437,5 +438,8 @@ takeSubdir -> [(FilePath, a)] -- ^ files after stripping common prefix -> [(Text, a)] takeSubdir subdir = mapMaybe $ \(fp, a) -> do - stripped <- T.stripPrefix subdir $ T.pack fp - Just (T.dropWhile (== '/') stripped, a) + stripped <- List.stripPrefix subdirs $ splitDirs $ T.pack fp + Just (T.intercalate "/" stripped, a) + where + splitDirs = List.dropWhile (== "") . T.splitOn "/" + subdirs = splitDirs subdir From cd9a9bd4d1894391cbde0275cb273fbdaee90b55 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Thu, 6 Sep 2018 16:13:02 -0700 Subject: [PATCH 2/7] Fix for subdirs: . --- subs/pantry/src/Pantry/Archive.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index f12c7c792f..49b8b915fa 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -441,5 +441,5 @@ takeSubdir subdir = mapMaybe $ \(fp, a) -> do stripped <- List.stripPrefix subdirs $ splitDirs $ T.pack fp Just (T.intercalate "/" stripped, a) where - splitDirs = List.dropWhile (== "") . T.splitOn "/" + splitDirs = List.dropWhile (`elem` [".", ""]) . T.splitOn "/" subdirs = splitDirs subdir From 01d910419d64ea5f66d56ad03d5b04b6f4714662 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Thu, 6 Sep 2018 16:14:42 -0700 Subject: [PATCH 3/7] Update changelog --- ChangeLog.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index ca593c00e5..c4b7b6934e 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -84,6 +84,9 @@ Bug fixes: * Handle a change in GHC's hi-dump format around `addDependentFile`, which now includes a hash. See [yesodweb/yesod#1551](https://github.com/yesodweb/yesod/issues/1551) +* Fix `subdirs` for git repos in `extra-deps` to match whole directory names. + Also fixes for `subdirs: .`. See + [#4292](https://github.com/commercialhaskell/stack/issues/4292) ## v1.9.0.1 (release candidate) From c5c5dd279bf6d0f7bded49f3f66a192466f12c8d Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Fri, 7 Sep 2018 10:15:10 -0700 Subject: [PATCH 4/7] Allow trailing and duplicate slashes --- subs/pantry/src/Pantry/Archive.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index 49b8b915fa..e0b401bd6d 100644 --- a/subs/pantry/src/Pantry/Archive.hs +++ b/subs/pantry/src/Pantry/Archive.hs @@ -441,5 +441,5 @@ takeSubdir subdir = mapMaybe $ \(fp, a) -> do stripped <- List.stripPrefix subdirs $ splitDirs $ T.pack fp Just (T.intercalate "/" stripped, a) where - splitDirs = List.dropWhile (`elem` [".", ""]) . T.splitOn "/" + splitDirs = List.dropWhile (== ".") . filter (/= "") . T.splitOn "/" subdirs = splitDirs subdir From abc95802c3b44d9d1c9778043fa0af84a330b050 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Fri, 7 Sep 2018 10:36:59 -0700 Subject: [PATCH 5/7] Factor out common code in ArchiveSpec --- subs/pantry/test/Pantry/ArchiveSpec.hs | 94 ++++++++++++++++---------- 1 file changed, 57 insertions(+), 37 deletions(-) diff --git a/subs/pantry/test/Pantry/ArchiveSpec.hs b/subs/pantry/test/Pantry/ArchiveSpec.hs index e4491e29da..bb657b210c 100644 --- a/subs/pantry/test/Pantry/ArchiveSpec.hs +++ b/subs/pantry/test/Pantry/ArchiveSpec.hs @@ -1,50 +1,70 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Pantry.ArchiveSpec (spec) where import Test.Hspec +import Data.Maybe (fromJust) import RIO +import RIO.Text as T import Pantry import Path.IO (resolveFile') -spec :: Spec -spec = do - it "cabal file from tarball" $ asIO $ runPantryApp $ do - let rel = "attic/package-0.1.2.3.tar.gz" - abs' <- resolveFile' rel - ident <- getPackageLocationIdent $ PLIArchive - Archive - { archiveLocation = ALFilePath ResolvedPath - { resolvedRelative = RelFilePath $ fromString rel - , resolvedAbsolute = abs' - } - , archiveHash = Nothing - , archiveSize = Nothing - , archiveSubdir = "" - } - PackageMetadata - { pmName = Nothing - , pmVersion = Nothing - , pmTreeKey = Nothing - , pmCabal = Nothing +data TestLocation + = TLFilePath String + | TLUrl Text + +data TestArchive = TestArchive + { testLocation :: !TestLocation + , testSubdir :: !Text + } + +getPackageLocationIdent' :: TestArchive -> IO PackageIdentifier +getPackageLocationIdent' TestArchive{..} = do + testLocation' <- case testLocation of + TLFilePath relPath -> do + absPath <- resolveFile' relPath + return $ ALFilePath $ ResolvedPath + { resolvedRelative = RelFilePath $ fromString relPath + , resolvedAbsolute = absPath } - case parsePackageIdentifier "package-0.1.2.3" of - Nothing -> error "should have parsed" - Just expected -> liftIO $ ident `shouldBe` expected - it "handles symlinks to parent dirs" $ do - ident <- runPantryApp $ getPackageLocationIdent $ PLIArchive - Archive - { archiveLocation = ALUrl "https://github.com/commercialhaskell/stack/archive/2b846ff4fda13a8cd095e7421ce76df0a08b10dc.tar.gz" + TLUrl url -> return $ ALUrl url + let archive = Archive + { archiveLocation = testLocation' , archiveHash = Nothing , archiveSize = Nothing - , archiveSubdir = "subs/pantry/" + , archiveSubdir = testSubdir } - PackageMetadata - { pmName = Nothing - , pmVersion = Nothing - , pmTreeKey = Nothing - , pmCabal = Nothing - } - case parsePackageIdentifier "pantry-0.1.0.0" of - Nothing -> error "should have parsed" - Just expected -> ident `shouldBe` expected + runPantryApp $ getPackageLocationIdent $ PLIArchive archive metadata + where + metadata = PackageMetadata + { pmName = Nothing + , pmVersion = Nothing + , pmTreeKey = Nothing + , pmCabal = Nothing + } + +parsePackageIdentifier' :: String -> PackageIdentifier +parsePackageIdentifier' = fromJust . parsePackageIdentifier + +urlToStackCommit :: Text -> TestLocation +urlToStackCommit commit = TLUrl $ T.concat + [ "https://github.com/commercialhaskell/stack/archive/" + , commit + , ".tar.gz" + ] + +spec :: Spec +spec = do + it "finds cabal file from tarball" $ do + ident <- getPackageLocationIdent' TestArchive + { testLocation = TLFilePath "attic/package-0.1.2.3.tar.gz" + , testSubdir = "" + } + ident `shouldBe` parsePackageIdentifier' "package-0.1.2.3" + it "finds cabal file from tarball with subdir 'subs/pantry/'" $ do + ident <- getPackageLocationIdent' TestArchive + { testLocation = urlToStackCommit "2b846ff4fda13a8cd095e7421ce76df0a08b10dc" + , testSubdir = "subs/pantry/" + } + ident `shouldBe` parsePackageIdentifier' "pantry-0.1.0.0" From 334cb79315fa5fea622d695d11d36cab6eb61d35 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Fri, 7 Sep 2018 10:58:30 -0700 Subject: [PATCH 6/7] Add test for subdir '.' --- subs/pantry/test/Pantry/ArchiveSpec.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/subs/pantry/test/Pantry/ArchiveSpec.hs b/subs/pantry/test/Pantry/ArchiveSpec.hs index bb657b210c..b4f50451a6 100644 --- a/subs/pantry/test/Pantry/ArchiveSpec.hs +++ b/subs/pantry/test/Pantry/ArchiveSpec.hs @@ -62,6 +62,12 @@ spec = do , testSubdir = "" } ident `shouldBe` parsePackageIdentifier' "package-0.1.2.3" + it "finds cabal file from tarball with subdir '.'" $ do + ident <- getPackageLocationIdent' TestArchive + { testLocation = TLFilePath "attic/package-0.1.2.3.tar.gz" + , testSubdir = "." + } + ident `shouldBe` parsePackageIdentifier' "package-0.1.2.3" it "finds cabal file from tarball with subdir 'subs/pantry/'" $ do ident <- getPackageLocationIdent' TestArchive { testLocation = urlToStackCommit "2b846ff4fda13a8cd095e7421ce76df0a08b10dc" From 6381b78dfa354870b65c2082f2846b972f0ae45e Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Fri, 7 Sep 2018 11:19:21 -0700 Subject: [PATCH 7/7] Add test for matching a whole directory name --- subs/pantry/test/Pantry/ArchiveSpec.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/subs/pantry/test/Pantry/ArchiveSpec.hs b/subs/pantry/test/Pantry/ArchiveSpec.hs index b4f50451a6..b54650f63b 100644 --- a/subs/pantry/test/Pantry/ArchiveSpec.hs +++ b/subs/pantry/test/Pantry/ArchiveSpec.hs @@ -54,6 +54,10 @@ urlToStackCommit commit = TLUrl $ T.concat , ".tar.gz" ] +treeWithoutCabalFile :: Selector PantryException +treeWithoutCabalFile (TreeWithoutCabalFile _) = True +treeWithoutCabalFile _ = False + spec :: Spec spec = do it "finds cabal file from tarball" $ do @@ -74,3 +78,9 @@ spec = do , testSubdir = "subs/pantry/" } ident `shouldBe` parsePackageIdentifier' "pantry-0.1.0.0" + it "matches whole directory name" $ + getPackageLocationIdent' TestArchive + { testLocation = urlToStackCommit "2b846ff4fda13a8cd095e7421ce76df0a08b10dc" + , testSubdir = "subs/pant" + } + `shouldThrow` treeWithoutCabalFile