Fix takeSubDir to match whole directory names

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)

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

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