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) diff --git a/subs/pantry/src/Pantry/Archive.hs b/subs/pantry/src/Pantry/Archive.hs index c1ef4f6edb..e0b401bd6d 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 (== ".") . filter (/= "") . T.splitOn "/" + subdirs = splitDirs subdir diff --git a/subs/pantry/test/Pantry/ArchiveSpec.hs b/subs/pantry/test/Pantry/ArchiveSpec.hs index e4491e29da..b54650f63b 100644 --- a/subs/pantry/test/Pantry/ArchiveSpec.hs +++ b/subs/pantry/test/Pantry/ArchiveSpec.hs @@ -1,50 +1,86 @@ {-# 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" + ] + +treeWithoutCabalFile :: Selector PantryException +treeWithoutCabalFile (TreeWithoutCabalFile _) = True +treeWithoutCabalFile _ = False + +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 '.'" $ 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" + it "matches whole directory name" $ + getPackageLocationIdent' TestArchive + { testLocation = urlToStackCommit "2b846ff4fda13a8cd095e7421ce76df0a08b10dc" + , testSubdir = "subs/pant" + } + `shouldThrow` treeWithoutCabalFile