Fix failure to find package when a dependency is shared between projects (#5680)

ChangeLog.md

@@ -26,6 +26,8 @@ Bug fixes:
   See [rio#237](https://github.com/commercialhaskell/rio/pull/237)
 * Fix handling of overwritten `ghc` and `ghc-pkg` locations.
   [#5597](https://github.com/commercialhaskell/stack/pull/5597)
+* Fix failure to find package when a dependency is shared between projects.
+  [#5680](https://github.com/commercialhaskell/stack/issues/5680)
 
 ## v2.7.3
 

src/Stack/Build/Cache.hs

@@ -12,6 +12,7 @@ module Stack.Build.Cache
     , tryGetConfigCache
     , tryGetCabalMod
     , tryGetSetupConfigMod
+    , tryGetPackageProjectRoot
     , getInstalledExes
     , tryGetFlagCache
     , deleteCaches
@@ -22,6 +23,7 @@ module Stack.Build.Cache
     , writeConfigCache
     , writeCabalMod
     , writeSetupConfigMod
+    , writePackageProjectRoot
     , TestStatus (..)
     , setTestStatus
     , getTestStatus
@@ -34,6 +36,7 @@ module Stack.Build.Cache
 import           Stack.Prelude
 import           Crypto.Hash (hashWith, SHA256(..))
 import qualified Data.ByteArray as Mem (convert)
+import           Data.ByteString.Builder (byteString)
 import qualified Data.Map as M
 import qualified Data.Set as Set
 import qualified Data.Text as T
@@ -154,6 +157,18 @@ tryGetFileMod fp =
   liftIO $ either (const Nothing) (Just . modificationTime) <$>
       tryIO (getFileStatus fp)
 
+-- | Try to read the project root from the last build of a package
+tryGetPackageProjectRoot :: HasEnvConfig env
+               => Path Abs Dir -> RIO env (Maybe ByteString)
+tryGetPackageProjectRoot dir = do
+  fp <- toFilePath <$> configPackageProjectRoot dir
+  tryReadFileBinary fp
+
+tryReadFileBinary :: MonadIO m => FilePath -> m (Maybe ByteString)
+tryReadFileBinary fp =
+  liftIO $ either (const Nothing) Just <$>
+      tryIO (readFileBinary fp)
+
 -- | Write the dirtiness cache for this package's files.
 writeBuildCache :: HasEnvConfig env
                 => Path Abs Dir
@@ -197,6 +212,16 @@ writeSetupConfigMod dir (Just x) = do
     writeBinaryFileAtomic fp "Just used for its modification time"
     liftIO $ setFileTimes (toFilePath fp) x x
 
+-- | See 'tryGetPackageProjectRoot'
+writePackageProjectRoot
+  :: HasEnvConfig env
+  => Path Abs Dir
+  -> ByteString
+  -> RIO env ()
+writePackageProjectRoot dir projectRoot = do
+    fp <- configPackageProjectRoot dir
+    writeBinaryFileAtomic fp (byteString projectRoot)
+
 -- | Delete the caches for the project.
 deleteCaches :: HasEnvConfig env => Path Abs Dir -> RIO env ()
 deleteCaches dir

src/Stack/Build/Execute.hs

@@ -849,6 +849,7 @@ ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp task =
           liftIO $ either (const Nothing) (Just . modificationTime) <$>
           tryJust (guard . isDoesNotExistError) (getFileStatus (toFilePath setupConfigfp))
     newSetupConfigMod <- getNewSetupConfigMod
+    newProjectRoot <- S8.pack . toFilePath <$> view projectRootL
     -- See https://github.com/commercialhaskell/stack/issues/3554
     taskAnyMissingHack <- view $ actualCompilerVersionL.to getGhcVersion.to (< mkVersion [8, 4])
     needConfig <-
@@ -870,10 +871,12 @@ ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp task =
                 -- Cabal's setup-config is created per OS/Cabal version, multiple
                 -- projects using the same package could get a conflict because of this
                 mOldSetupConfigMod <- tryGetSetupConfigMod pkgDir
+                mOldProjectRoot <- tryGetPackageProjectRoot pkgDir
 
                 return $ fmap ignoreComponents mOldConfigCache /= Just (ignoreComponents newConfigCache)
                       || mOldCabalMod /= Just newCabalMod
                       || mOldSetupConfigMod /= newSetupConfigMod
+                      || mOldProjectRoot /= Just newProjectRoot
     let ConfigureOpts dirs nodirs = configCacheOpts newConfigCache
 
     when (taskBuildTypeConfig task) ensureConfigureScript
@@ -912,6 +915,7 @@ ensureConfig newConfigCache pkgDir ExecuteEnv {..} announce cabal cabalfp task =
         -- check if our config mod file is newer than the file above, but this
         -- seems reasonable too.
         getNewSetupConfigMod >>= writeSetupConfigMod pkgDir
+        writePackageProjectRoot pkgDir newProjectRoot
 
     return needConfig
   where

src/Stack/Constants/Config.hs

@@ -11,6 +11,7 @@ module Stack.Constants.Config
   , projectDockerSandboxDir
   , configCabalMod
   , configSetupConfigMod
+  , configPackageProjectRoot
   , buildCachesDir
   , testSuccessFile
   , testBuiltFile
@@ -85,6 +86,15 @@ configSetupConfigMod dir =
         (</> $(mkRelFile "stack-setup-config-mod"))
         (distDirFromDir dir)
 
+-- | The filename used for the project root from the last build of a package
+configPackageProjectRoot :: (MonadThrow m, MonadReader env m, HasEnvConfig env)
+                     => Path Abs Dir      -- ^ Package directory.
+                     -> m (Path Abs File)
+configPackageProjectRoot dir =
+    liftM
+        (</> $(mkRelFile "stack-project-root"))
+        (distDirFromDir dir)
+
 -- | Directory for HPC work.
 hpcDirFromDir
     :: (MonadThrow m, MonadReader env m, HasEnvConfig env)

test/integration/lib/StackTest.hs

@@ -289,15 +289,20 @@ removeDirIgnore fp = removeDirectoryRecursive fp `catch` \e ->
     then return ()
     else throwIO e
 
--- | Changes working directory to Stack source directory
-withSourceDirectory :: HasCallStack => IO () -> IO ()
-withSourceDirectory action = do
-  dir <- stackSrc
+-- | Changes to the specified working directory.
+withCwd :: HasCallStack => FilePath -> IO () -> IO ()
+withCwd dir action = do
   currentDirectory <- getCurrentDirectory
   let enterDir = setCurrentDirectory dir
       exitDir = setCurrentDirectory currentDirectory
   bracket_ enterDir exitDir action
 
+-- | Changes working directory to Stack source directory.
+withSourceDirectory :: HasCallStack => IO () -> IO ()
+withSourceDirectory action = do
+  dir <- stackSrc
+  withCwd dir action
+
 -- | Mark a test as superslow, only to be run when explicitly requested.
 superslow :: HasCallStack => IO () -> IO ()
 superslow inner = do

test/integration/tests/5680-share-package-across-projects/Main.hs

@@ -0,0 +1,8 @@
+import StackTest
+
+main :: IO ()
+main = do
+    stackEnv <- stackExe
+    withCwd "package-a" $ stack ["build"]
+    withCwd "package-b" $ stack ["build"]
+    withCwd "package-a" $ stack ["build"]

test/integration/tests/5680-share-package-across-projects/files/package-a/package.yaml

@@ -0,0 +1,6 @@
+name:                package-a
+version:             0.1.0.0
+dependencies:
+- base >= 4.7 && < 5
+library:
+  source-dirs: src

test/integration/tests/5680-share-package-across-projects/files/package-a/src/Lib.hs

@@ -0,0 +1,6 @@
+module Lib
+    ( someFunc
+    ) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"

test/integration/tests/5680-share-package-across-projects/files/package-a/stack.yaml

@@ -0,0 +1,4 @@
+resolver: lts-17.15
+packages:
+- .
+- ../package-c

test/integration/tests/5680-share-package-across-projects/files/package-b/package.yaml

@@ -0,0 +1,6 @@
+name:                package-b
+version:             0.1.0.0
+dependencies:
+- base >= 4.7 && < 5
+library:
+  source-dirs: src

test/integration/tests/5680-share-package-across-projects/files/package-b/src/Lib.hs

@@ -0,0 +1,6 @@
+module Lib
+    ( someFunc
+    ) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"

test/integration/tests/5680-share-package-across-projects/files/package-b/stack.yaml

@@ -0,0 +1,4 @@
+resolver: lts-17.15
+packages:
+- .
+- ../package-c

test/integration/tests/5680-share-package-across-projects/files/package-c/package.yaml

@@ -0,0 +1,6 @@
+name:                package-c
+version:             0.1.0.0
+dependencies:
+- base >= 4.7 && < 5
+library:
+  source-dirs: src

test/integration/tests/5680-share-package-across-projects/files/package-c/src/Lib.hs

@@ -0,0 +1,6 @@
+module Lib
+    ( someFunc
+    ) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"

test/integration/tests/5680-share-package-across-projects/files/package-c/stack.yaml

@@ -0,0 +1,3 @@
+resolver: lts-17.15
+packages:
+- .