diff --git a/yesod-bin/ChangeLog.md b/yesod-bin/ChangeLog.md index 9a8c6990..2ffb0332 100644 --- a/yesod-bin/ChangeLog.md +++ b/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) diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index 4289317b..22e6a515 100644 --- a/yesod-bin/Devel.hs +++ b/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 diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 54eb1805..67d6392f 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/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