Fix race condition in stack support code

Language/Haskell/GhcMod.hs

@@ -3,7 +3,7 @@
 module Language.Haskell.GhcMod (
   -- * Cradle
     Cradle(..)
-  , ProjectType(..)
+  , Project(..)
   , findCradle
   -- * Options
   , Options(..)

Language/Haskell/GhcMod/CabalHelper.hs

@@ -20,7 +20,6 @@ module Language.Haskell.GhcMod.CabalHelper
   ( getComponents
   , getGhcMergedPkgOptions
   , getCabalPackageDbStack
-  , getStackPackageDbStack
   , prepareCabalHelper
   )
 #endif
@@ -44,7 +43,6 @@ import Language.Haskell.GhcMod.Logging
 import Language.Haskell.GhcMod.Output
 import Language.Haskell.GhcMod.CustomPackageDb
 import System.FilePath
-import System.Directory (findExecutable)
 import System.Process
 import System.Exit
 import Prelude hiding ((.))
@@ -136,30 +134,18 @@ prepareCabalHelper = do
   let projdir = cradleRootDir crdl
       distdir = projdir </> cradleDistDir crdl
   readProc <- gmReadProcess
-  when (cradleProjectType crdl == CabalProject || cradleProjectType crdl == StackProject) $
+  when (isCabalHelperProject $ cradleProject crdl) $
        withCabal $ liftIO $ prepare readProc projdir distdir
 
-getStackPackageDbStack :: IOish m => m [GhcPkgDb]
-getStackPackageDbStack = do
-    mstack <- liftIO $ findExecutable "stack"
-    case mstack of
-      Nothing -> return []
-      Just stack -> do
-        snapshotDb <- liftIO $ readProcess stack ["path", "--snapshot-pkg-db"] ""
-        localDb <- liftIO $ readProcess stack ["path", "--local-pkg-db"] ""
-        return $ map (PackageDb . takeWhile (/='\n')) [snapshotDb, localDb]
-
 patchStackPrograms :: (IOish m, GmOut m) => Cradle -> Programs -> m Programs
-patchStackPrograms crdl progs
-    | cradleProjectType crdl /= StackProject = return progs
-patchStackPrograms crdl progs = do
-  let projdir = cradleRootDir crdl
-  Just ghc <- getStackGhcPath projdir
-  Just ghcPkg <- getStackGhcPkgPath projdir
+patchStackPrograms Cradle { cradleProject = (StackProject senv) } progs = do
+  Just ghc <- getStackGhcPath senv
+  Just ghcPkg <- getStackGhcPkgPath senv
   return $ progs {
       ghcProgram = ghc
     , ghcPkgProgram = ghcPkg
     }
+patchStackPrograms _crdl progs = return progs
 
 withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a
 withCabal action = do
@@ -188,7 +174,7 @@ withCabal action = do
 
            Nothing -> return False
 
-    projType <- cradleProjectType <$> cradle
+    proj <- cradleProject <$> cradle
 
     when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $
       gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project."
@@ -202,14 +188,14 @@ withCabal action = do
     when ( isSetupConfigOutOfDate mCabalFile mCabalConfig
         || pkgDbStackOutOfSync
         || isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $
-          case projType of
+          case proj of
             CabalProject ->
                 cabalReconfigure readProc (optPrograms opts) crdl projdir distdir
-            StackProject ->
+            StackProject {} ->
 
                 stackReconfigure crdl (optPrograms opts)
             _ ->
-                error $ "withCabal: unsupported project type: " ++ show projType
+                error $ "withCabal: unsupported project type: " ++ show proj
 
     action
 

Language/Haskell/GhcMod/Cradle.hs

@@ -69,7 +69,7 @@ cabalCradle wdir = do
     let cabalDir = takeDirectory cabalFile
 
     return Cradle {
-        cradleProjectType = CabalProject
+        cradleProject    = CabalProject
       , cradleCurrentDir = wdir
       , cradleRootDir    = cabalDir
       , cradleTempDir    = error "tmpDir"
@@ -89,22 +89,22 @@ stackCradle wdir = do
     -- rather than stack, or maybe that's just me ;)
     whenM (liftIO $ doesFileExist $ setupConfigPath "dist") $ mzero
 
-    distDir <- MaybeT $ getStackDistDir cabalDir
+    senv <- MaybeT $ getStackEnv cabalDir
 
     return Cradle {
-        cradleProjectType = StackProject
+        cradleProject    = StackProject senv
       , cradleCurrentDir = wdir
       , cradleRootDir    = cabalDir
       , cradleTempDir    = error "tmpDir"
       , cradleCabalFile  = Just cabalFile
-      , cradleDistDir    = distDir
+      , cradleDistDir    = seDistDir senv
       }
 
 sandboxCradle :: IOish m => FilePath -> MaybeT m Cradle
 sandboxCradle wdir = do
     sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir
     return Cradle {
-        cradleProjectType = SandboxProject
+        cradleProject    = SandboxProject
       , cradleCurrentDir = wdir
       , cradleRootDir    = sbDir
       , cradleTempDir    = error "tmpDir"
@@ -115,7 +115,7 @@ sandboxCradle wdir = do
 plainCradle :: IOish m => FilePath -> MaybeT m Cradle
 plainCradle wdir = do
     return $ Cradle {
-        cradleProjectType = PlainProject
+        cradleProject    = PlainProject
       , cradleCurrentDir = wdir
       , cradleRootDir    = wdir
       , cradleTempDir    = error "tmpDir"

Language/Haskell/GhcMod/Debug.hs

@@ -26,9 +26,9 @@ debugInfo = do
     Cradle {..} <- cradle
 
     cabal <-
-        case cradleProjectType of
+        case cradleProject of
           CabalProject -> cabalDebug
-          StackProject -> (++) <$> stackPaths <*> cabalDebug
+          StackProject {} -> (++) <$> stackPaths <*> cabalDebug
           _ -> return []
 
     pkgOpts <- packageGhcOptions
@@ -45,9 +45,9 @@ debugInfo = do
 
 stackPaths :: IOish m => GhcModT m [String]
 stackPaths = do
-    Cradle {..} <- cradle
-    Just ghc <- getStackGhcPath cradleRootDir
-    Just ghcPkg <- getStackGhcPkgPath cradleRootDir
+    Cradle { cradleProject = StackProject senv } <- cradle
+    ghc <- getStackGhcPath senv
+    ghcPkg <- getStackGhcPkgPath senv
     return $
          [ "Stack ghc executable:    " ++ show ghc
          , "Stack ghc-pkg executable:" ++ show ghcPkg
@@ -64,7 +64,7 @@ cabalDebug = do
 
     return $
          [ "Cabal file:           " ++ show cradleCabalFile
-         , "Cabal Project Type:   " ++ show cradleProjectType
+         , "Project:   " ++ show cradleProject
          , "Cabal entrypoints:\n"       ++ render (nest 4 $
               mapDoc gmComponentNameDoc smpDoc entrypoints)
          , "Cabal components:\n"        ++ render (nest 4 $

Language/Haskell/GhcMod/GhcPkg.hs

@@ -65,9 +65,9 @@ getGhcPkgProgram :: IOish m => GhcModT m FilePath
 getGhcPkgProgram = do
   crdl <- cradle
   progs <- optPrograms <$> options
-  case cradleProjectType crdl of
-    StackProject -> do
-        Just ghcPkg <- getStackGhcPkgPath (cradleRootDir crdl)
+  case cradleProject crdl of
+    (StackProject senv) -> do
+        Just ghcPkg <- getStackGhcPkgPath senv
         return ghcPkg
     _ ->
         return $ ghcPkgProgram progs
@@ -77,7 +77,7 @@ getPackageDbStack :: IOish m => GhcModT m [GhcPkgDb]
 getPackageDbStack = do
   crdl <- cradle
   mCusPkgStack <- getCustomPkgDbStack
-  stack <- case cradleProjectType crdl of
+  stack <- case cradleProject crdl of
     PlainProject ->
         return [GlobalDb, UserDb]
     SandboxProject -> do
@@ -85,8 +85,8 @@ getPackageDbStack = do
         return $ [GlobalDb, db]
     CabalProject ->
         getCabalPackageDbStack
-    StackProject ->
-        getStackPackageDbStack
+    (StackProject StackEnv {..}) ->
+        return $ map PackageDb [seSnapshotPkgDb, seLocalPkgDb]
   return $ fromMaybe stack mCusPkgStack
 
 getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath]

Language/Haskell/GhcMod/PathsAndFiles.hs

@@ -27,6 +27,7 @@ import Control.Monad
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Class
 import Data.List
+import Data.List.Split
 import Data.Char
 import Data.Maybe
 import Data.Traversable hiding (mapM)
@@ -85,22 +86,29 @@ findStackConfigFile dir = do
       Just (d, Just a)  -> return $ Just $ d </> a
       Just (_, Nothing) -> error "findStackConfigFile"
 
-getStackDistDir :: (IOish m, GmOut m) => FilePath -> m (Maybe FilePath)
-getStackDistDir projdir = U.withDirectory_ projdir $ runMaybeT $ do
-    takeWhile (/='\n') <$> readStack ["path", "--dist-dir"]
+getStackEnv :: (IOish m, GmOut m) => FilePath -> m (Maybe StackEnv)
+getStackEnv projdir = U.withDirectory_ projdir $ runMaybeT $ do
+    env <- map (liToTup . splitOn ": ") . lines <$> readStack ["path"]
+    let look k = fromJust $ lookup k env
+    return StackEnv {
+        seDistDir       = look "dist-dir"
+      , seBinPath       = splitSearchPath $ look "bin-path"
+      , seSnapshotPkgDb = look "snapshot-pkg-db"
+      , seLocalPkgDb    = look "local-pkg-db"
+      }
+ where
+   liToTup [k,v] = (k,v)
+   liToTup _ = error "getStackEnv"
 
-getStackGhcPath :: (IOish m, GmOut m) => FilePath -> m (Maybe FilePath)
+getStackGhcPath :: IOish m => StackEnv -> m (Maybe FilePath)
 getStackGhcPath = findExecutablesInStackBinPath "ghc"
 
-getStackGhcPkgPath :: (IOish m, GmOut m) => FilePath -> m (Maybe FilePath)
+getStackGhcPkgPath :: IOish m => StackEnv -> m (Maybe FilePath)
 getStackGhcPkgPath = findExecutablesInStackBinPath  "ghc-pkg"
 
-findExecutablesInStackBinPath :: (IOish m, GmOut m) => String -> FilePath -> m (Maybe FilePath)
-findExecutablesInStackBinPath exe projdir =
-    U.withDirectory_ projdir $ runMaybeT $ do
-      path <- splitSearchPath . takeWhile (/='\n')
-                <$> readStack ["path", "--bin-path"]
-      MaybeT $ liftIO $ listToMaybe <$> findExecutablesInDirectories' path exe
+findExecutablesInStackBinPath :: IOish m => String -> StackEnv -> m (Maybe FilePath)
+findExecutablesInStackBinPath exe StackEnv {..} =
+    liftIO $ listToMaybe <$> findExecutablesInDirectories' seBinPath exe
 
 findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath]
 findExecutablesInDirectories' path binary =

Language/Haskell/GhcMod/Target.hs

@@ -150,10 +150,10 @@ targetGhcOptions :: forall m. IOish m
 targetGhcOptions crdl sefnmn = do
     when (Set.null sefnmn) $ error "targetGhcOptions: no targets given"
 
-    case cradleProjectType crdl of
-      CabalProject -> cabalOpts crdl
-      StackProject -> cabalOpts crdl
-      _ -> sandboxOpts crdl
+    case cradleProject crdl of
+      proj
+          | isCabalHelperProject proj -> cabalOpts crdl
+          | otherwise -> sandboxOpts crdl
  where
    zipMap f l = l `zip` (f `map` l)
 
@@ -267,10 +267,10 @@ packageGhcOptions :: (Applicative m, IOish m, Gm m)
                   => m [GHCOption]
 packageGhcOptions = do
     crdl <- cradle
-    case cradleProjectType crdl of
-      CabalProject -> getGhcMergedPkgOptions
-      StackProject -> getGhcMergedPkgOptions
-      _ -> sandboxOpts crdl
+    case cradleProject crdl of
+      proj
+          | isCabalHelperProject proj -> getGhcMergedPkgOptions
+          | otherwise -> sandboxOpts crdl
 
 -- also works for plain projects!
 sandboxOpts :: (IOish m, GmEnv m) => Cradle -> m [String]

Language/Haskell/GhcMod/Types.hs

@@ -139,12 +139,27 @@ defaultOptions = Options {
 
 ----------------------------------------------------------------
 
-data ProjectType = CabalProject | SandboxProject | PlainProject | StackProject
-                 deriving (Eq, Show)
+data Project = CabalProject
+             | SandboxProject
+             | PlainProject
+             | StackProject StackEnv
+               deriving (Eq, Show)
+
+isCabalHelperProject :: Project -> Bool
+isCabalHelperProject StackProject {} = True
+isCabalHelperProject CabalProject {} = True
+isCabalHelperProject _ = False
+
+data StackEnv = StackEnv {
+      seDistDir       :: FilePath
+    , seBinPath       :: [FilePath]
+    , seSnapshotPkgDb :: FilePath
+    , seLocalPkgDb    :: FilePath
+    } deriving (Eq, Show)
 
 -- | The environment where this library is used.
 data Cradle = Cradle {
-    cradleProjectType:: ProjectType
+    cradleProject    :: Project
   -- | The directory where this library is executed.
   , cradleCurrentDir :: FilePath
   -- | The project root directory.

src/GHCMod.hs

@@ -679,7 +679,7 @@ nukeCaches = do
   chdir <- liftIO $ (</> "cabal-helper") <$> getAppUserDataDirectory "ghc-mod"
   c <- cradle
 
-  when (cradleProjectType c == CabalProject || cradleProjectType c == StackProject) $ do
+  when (isCabalHelperProject $ cradleProject c) $ do
     let root = cradleRootDir c
     let dist = cradleDistDir c
     liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root </> dist]