Merge pull request #1381 from psibi/yesod-deadlock-2

Fixing race condition in yesod-bin

yesod-bin/ChangeLog.md

@@ -1,3 +1,7 @@
+## 1.5.2.3
+
+* Fix race condition which leads dev server to stay in compilation mode. [#1380](https://github.com/yesodweb/yesod/issues/1380)
+
 ## 1.5.2.2
 
 * I guess `--no-nix-pure` implies Nix... sigh [#1359](https://github.com/yesodweb/yesod/issues/1359)

yesod-bin/Devel.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE CPP                 #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE TemplateHaskell     #-}
@@ -14,6 +15,7 @@ import           Control.Concurrent.STM
 import qualified Control.Exception.Safe                as Ex
 import           Control.Monad                         (forever, unless, void,
                                                         when)
+import Data.ByteString (ByteString, isInfixOf)
 import qualified Data.ByteString.Lazy                  as LB
 import           Data.Conduit                          (($$), (=$))
 import qualified Data.Conduit.Binary                   as CB
@@ -126,6 +128,7 @@ reverseProxy :: DevelOpts -> TVar Int -> IO ()
 reverseProxy opts appPortVar = do
     manager <- newManager $ managerSetProxy noProxy tlsManagerSettings
     let refreshHtml = LB.fromChunks [$(embedFile "refreshing.html")]
+        sayV = when (verbose opts) . sayString    
     let onExc _ req
             | maybe False (("application/json" `elem`) . parseHttpAccept)
                 (lookup "accept" $ requestHeaders req) =
@@ -142,6 +145,7 @@ reverseProxy opts appPortVar = do
     let proxyApp = waiProxyToSettings
                 (const $ do
                     appPort <- atomically $ readTVar appPortVar
+                    sayV $ "revProxy: appPort " ++ (show appPort)
                     return $
                         ReverseProxy.WPRProxyDest
                         $ ProxyDest "127.0.0.1" appPort)
@@ -222,6 +226,30 @@ checkDevelFile =
             then return x
             else loop xs
 
+stackSuccessString :: ByteString
+stackSuccessString = "ExitSuccess"
+
+stackFailureString :: ByteString
+stackFailureString = "ExitFailure"
+
+-- We need updateAppPort logic to prevent a race condition.
+-- See https://github.com/yesodweb/yesod/issues/1380
+updateAppPort :: ByteString -> TVar Bool -- ^ Bool to indicate if the
+                                         -- output from stack has
+                                         -- started. False indicate
+                                         -- that it hasn't started
+                                         -- yet.
+              -> TVar Int -> STM ()
+updateAppPort bs buildStarted appPortVar = do
+  hasStarted <- readTVar buildStarted
+  let buildEnd = isInfixOf stackFailureString bs || isInfixOf stackSuccessString bs
+  case (hasStarted, buildEnd) of
+    (False, False) -> do
+      writeTVar appPortVar (-1 :: Int)
+      writeTVar buildStarted True
+    (True, False) -> return ()
+    (_, True) -> writeTVar buildStarted False
+
 -- | Get the set of all flags available in the given cabal file
 getAvailableFlags :: D.GenericPackageDescription -> Set.Set String
 getAvailableFlags =
@@ -283,6 +311,7 @@ devel opts passThroughArgs = do
     sayV = when (verbose opts) . sayString
 
     -- Leverage "stack build --file-watch" to do the build
+    runStackBuild :: TVar Int -> [Char] -> Set.Set [Char] -> IO ()
     runStackBuild appPortVar packageName availableFlags = do
         -- We call into this app for the devel-signal command
         myPath <- getExecutablePath
@@ -316,7 +345,7 @@ devel opts passThroughArgs = do
                 passThroughArgs
 
         sayV $ show procConfig
-
+        buildStarted <- newTVarIO False
         -- Monitor the stdout and stderr content from the build process. Any
         -- time some output comes, we invalidate the currently running app by
         -- changing the destination port for reverse proxying to -1. We also
@@ -325,12 +354,13 @@ devel opts passThroughArgs = do
         withProcess_ procConfig $ \p -> do
             let helper getter h =
                       getter p
-                   $$ CL.iterM (\_ -> atomically $ writeTVar appPortVar (-1))
+                   $$ CL.iterM (\(str :: ByteString) -> atomically (updateAppPort str buildStarted appPortVar))
                    =$ CB.sinkHandle h
             race_ (helper getStdout stdout) (helper getStderr stderr)
 
     -- Run the inner action with a TVar which will be set to True
     -- whenever the signal file is modified.
+    withChangedVar :: (TVar Bool -> IO a) -> IO a
     withChangedVar inner = withManager $ \manager -> do
         -- Variable indicating that the signal file has been changed. We
         -- reset it each time we handle the signal.
@@ -353,6 +383,7 @@ devel opts passThroughArgs = do
         inner changedVar
 
     -- Each time the library builds successfully, run the application
+    runApp :: TVar Int -> TVar Bool -> String -> IO b
     runApp appPortVar changedVar develHsPath = do
         -- Wait for the first change, indicating that the library
         -- has been built

yesod-bin/yesod-bin.cabal

@@ -1,5 +1,5 @@
 name:            yesod-bin
-version:         1.5.2.2
+version:         1.5.2.3
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>