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:
parent
bc3054bfa2
commit
878534a272
@ -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.
|
||||||
|
|||||||
@ -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>
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user