Fix race condition in yesod-bin

Stack build process emittles line even after successful build process
which leads to the overwriting of the appPortVar with -1. This leads
it to a compile mode again. Pressing Return Key and rebuilding it
again makes it go, but that's just a workaround I have to do every now
and then to solve the actual issue.

I'm using a `MVar` based locking solution for fixing the race
condition introduced.
This commit is contained in:
Sibi Prabakaran 2017-04-20 18:52:20 +05:30
parent bc3054bfa2
commit 878534a272
No known key found for this signature in database
GPG Key ID: D19E3E0EBB557613
2 changed files with 36 additions and 3 deletions

View File

@ -1,3 +1,4 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
@ -11,9 +12,12 @@ import Control.Applicative ((<|>))
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (race_) import Control.Concurrent.Async (race_)
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Concurrent.MVar
import System.IO
import qualified Control.Exception.Safe as Ex import qualified Control.Exception.Safe as Ex
import Control.Monad (forever, unless, void, import Control.Monad (forever, unless, void,
when) when)
import Data.ByteString (ByteString, isInfixOf)
import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy as LB
import Data.Conduit (($$), (=$)) import Data.Conduit (($$), (=$))
import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.Binary as CB
@ -222,6 +226,33 @@ checkDevelFile =
then return x then return x
else loop xs else loop xs
stackSuccessString :: ByteString
stackSuccessString = "ExitSuccess"
stackFailureString :: ByteString
stackFailureString = "ExitFailure"
data BuildOutput = Started
deriving (Show, Eq, Ord)
makeEmptyMVar :: MVar a -> IO ()
makeEmptyMVar mvar = do
isEmpty <- isEmptyMVar mvar
case isEmpty of
True -> return ()
False -> takeMVar mvar >> return ()
updateAppPort :: ByteString -> MVar (BuildOutput) -> TVar Int -> IO ()
updateAppPort bs mvar appPortVar = do
isEmpty <- isEmptyMVar mvar
let hasEnd = isInfixOf stackFailureString bs || isInfixOf stackSuccessString bs
case (isEmpty,hasEnd) of
(True,False) -> do
putMVar mvar Started
atomically $ writeTVar appPortVar (-1 :: Int)
(_,False) -> return ()
(_,True) -> makeEmptyMVar mvar
-- | Get the set of all flags available in the given cabal file -- | Get the set of all flags available in the given cabal file
getAvailableFlags :: D.GenericPackageDescription -> Set.Set String getAvailableFlags :: D.GenericPackageDescription -> Set.Set String
getAvailableFlags = getAvailableFlags =
@ -283,6 +314,7 @@ devel opts passThroughArgs = do
sayV = when (verbose opts) . sayString sayV = when (verbose opts) . sayString
-- Leverage "stack build --file-watch" to do the build -- Leverage "stack build --file-watch" to do the build
runStackBuild :: TVar Int -> [Char] -> Set.Set [Char] -> IO ()
runStackBuild appPortVar packageName availableFlags = do runStackBuild appPortVar packageName availableFlags = do
-- We call into this app for the devel-signal command -- We call into this app for the devel-signal command
myPath <- getExecutablePath myPath <- getExecutablePath
@ -316,7 +348,7 @@ devel opts passThroughArgs = do
passThroughArgs passThroughArgs
sayV $ show procConfig sayV $ show procConfig
mvar <- newEmptyMVar
-- Monitor the stdout and stderr content from the build process. Any -- Monitor the stdout and stderr content from the build process. Any
-- time some output comes, we invalidate the currently running app by -- time some output comes, we invalidate the currently running app by
-- changing the destination port for reverse proxying to -1. We also -- changing the destination port for reverse proxying to -1. We also
@ -325,12 +357,13 @@ devel opts passThroughArgs = do
withProcess_ procConfig $ \p -> do withProcess_ procConfig $ \p -> do
let helper getter h = let helper getter h =
getter p getter p
$$ CL.iterM (\_ -> atomically $ writeTVar appPortVar (-1)) $$ CL.iterM (\(str :: ByteString) -> updateAppPort str mvar appPortVar)
=$ CB.sinkHandle h =$ CB.sinkHandle h
race_ (helper getStdout stdout) (helper getStderr stderr) race_ (helper getStdout stdout) (helper getStderr stderr)
-- Run the inner action with a TVar which will be set to True -- Run the inner action with a TVar which will be set to True
-- whenever the signal file is modified. -- whenever the signal file is modified.
withChangedVar :: (TVar Bool -> IO a) -> IO a
withChangedVar inner = withManager $ \manager -> do withChangedVar inner = withManager $ \manager -> do
-- Variable indicating that the signal file has been changed. We -- Variable indicating that the signal file has been changed. We
-- reset it each time we handle the signal. -- reset it each time we handle the signal.

View File

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