haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

yesod devel: cycle listening ports

Browse Source
This commit is contained in:
Michael Snoyman 2012-12-26 16:13:40 +02:00
parent e709eb2192
commit f240709ea1
1 changed files with 18 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
yesod/Devel.hs
View File

@ -33,6 +33,7 @@ import Control.Monad (forever, unless, void,
when) when)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.State (evalStateT, get) import Control.Monad.Trans.State (evalStateT, get)
import qualified Data.IORef as I
import Data.Char (isNumber, isUpper) import Data.Char (isNumber, isUpper)
import qualified Data.List as L import qualified Data.List as L
@ -116,12 +117,14 @@ defaultDevelOpts = DevelOpts False False False (-1) Nothing Nothing Nothing 3000
-- | Run a reverse proxy from port 3000 to 3001. If there is no response on -- | Run a reverse proxy from port 3000 to 3001. If there is no response on
-- 3001, give an appropriate message to the user. -- 3001, give an appropriate message to the user.
reverseProxy :: DevelOpts -> Int -> IO () reverseProxy :: DevelOpts -> I.IORef Int -> IO ()
reverseProxy opts appPort = do reverseProxy opts iappPort = do
manager <- newManager def manager <- newManager def
let loop = forever $ do let loop = forever $ do
run (develPort opts) $ waiProxyToSettings run (develPort opts) $ waiProxyToSettings
(const $ return $ Right $ ProxyDest "127.0.0.1" appPort) (const $ do
appPort <- liftIO $ I.readIORef iappPort
return $ Right $ ProxyDest "127.0.0.1" appPort)
def def
{ wpsOnExc = onExc { wpsOnExc = onExc
, wpsTimeout = Just 10000000 , wpsTimeout = Just 10000000
@ -157,8 +160,8 @@ devel :: DevelOpts -> [String] -> IO ()
devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do
avail <- checkPort $ develPort opts avail <- checkPort $ develPort opts
unless avail $ error "devel port unavailable" unless avail $ error "devel port unavailable"
appPort <- getPort 17834 iappPort <- getPort 17834 >>= I.newIORef
_ <- forkIO $ reverseProxy opts appPort _ <- forkIO $ reverseProxy opts iappPort
checkDevelFile checkDevelFile
writeLock opts writeLock opts
@ -166,7 +169,7 @@ devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do
_ <- forkIO $ do _ <- forkIO $ do
filesModified <- newEmptyMVar filesModified <- newEmptyMVar
watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ())) watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ()))
evalStateT (mainOuterLoop appPort filesModified) Map.empty evalStateT (mainOuterLoop iappPort filesModified) Map.empty
_ <- getLine _ <- getLine
writeLock opts writeLock opts
exitSuccess exitSuccess
@ -174,7 +177,7 @@ devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do
bd = getBuildDir opts bd = getBuildDir opts
-- outer loop re-reads the cabal file -- outer loop re-reads the cabal file
mainOuterLoop appPort filesModified = do mainOuterLoop iappPort filesModified = do
ghcVer <- liftIO ghcVersion ghcVer <- liftIO ghcVersion
cabal <- liftIO $ D.findPackageDesc "." cabal <- liftIO $ D.findPackageDesc "."
gpd <- liftIO $ D.readPackageDescription D.normal cabal gpd <- liftIO $ D.readPackageDescription D.normal cabal
@ -186,10 +189,10 @@ devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do
liftIO $ removeFileIfExists "yesod-devel/arargs.txt" -- the configure step, remove them to force liftIO $ removeFileIfExists "yesod-devel/arargs.txt" -- the configure step, remove them to force
liftIO $ removeFileIfExists "yesod-devel/ldargs.txt" -- a cabal build first liftIO $ removeFileIfExists "yesod-devel/ldargs.txt" -- a cabal build first
rebuild <- liftIO $ mkRebuild gpd ghcVer cabal opts ldar rebuild <- liftIO $ mkRebuild gpd ghcVer cabal opts ldar
mainInnerLoop appPort hsSourceDirs filesModified cabal gpd lib ghcVer rebuild mainInnerLoop iappPort hsSourceDirs filesModified cabal gpd lib ghcVer rebuild
-- inner loop rebuilds after files change -- inner loop rebuilds after files change
mainInnerLoop appPort hsSourceDirs filesModified cabal gpd lib ghcVer rebuild = go mainInnerLoop iappPort hsSourceDirs filesModified cabal gpd lib ghcVer rebuild = go
where where
go = do go = do
_ <- recompDeps hsSourceDirs _ <- recompDeps hsSourceDirs
@ -212,6 +215,11 @@ devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do
$ if verbose opts then "Starting development server: runghc " ++ L.unwords devArgs $ if verbose opts then "Starting development server: runghc " ++ L.unwords devArgs
else "Starting development server..." else "Starting development server..."
env0 <- liftIO getEnvironment env0 <- liftIO getEnvironment
-- get a new port for the new process to listen on
appPort <- liftIO $ I.readIORef iappPort >>= getPort . (+ 1)
liftIO $ I.writeIORef iappPort appPort
(_,_,_,ph) <- liftIO $ createProcess (proc "runghc" devArgs) (_,_,_,ph) <- liftIO $ createProcess (proc "runghc" devArgs)
{ env = Just $ ("PORT", show appPort) : ("DISPLAY_PORT", show $ develPort opts) : env0 { env = Just $ ("PORT", show appPort) : ("DISPLAY_PORT", show $ develPort opts) : env0
} }
@ -229,7 +237,7 @@ devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do
liftIO $ Ex.throwTo watchTid (userError "process finished") liftIO $ Ex.throwTo watchTid (userError "process finished")
loop list loop list
n <- liftIO $ cabal `isNewerThan` (bd </> "setup-config") n <- liftIO $ cabal `isNewerThan` (bd </> "setup-config")
if n then mainOuterLoop appPort filesModified else go if n then mainOuterLoop iappPort filesModified else go
runBuildHook :: Maybe String -> IO () runBuildHook :: Maybe String -> IO ()
runBuildHook (Just s) = do runBuildHook (Just s) = do