diff --git a/yesod/Devel.hs b/yesod/Devel.hs index ab3826d2..fe19b5da 100644 --- a/yesod/Devel.hs +++ b/yesod/Devel.hs @@ -67,11 +67,14 @@ import GhcBuild (buildPackage, getBuildFlags) import qualified Config as GHC +import Data.Conduit.Network (HostPreference (HostIPv4), + bindPort) import Network (withSocketsDo) import Network.HTTP.Conduit (def, newManager) import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest), waiProxyTo) import Network.HTTP.Types (status200) +import Network.Socket (sClose) import Network.Wai (responseLBS) import Network.Wai.Handler.Warp (run) import SrcLoc (Located) @@ -99,27 +102,29 @@ data DevelOpts = DevelOpts , successHook :: Maybe String , failHook :: Maybe String , buildDir :: Maybe String + , develPort :: Int } deriving (Show, Eq) getBuildDir :: DevelOpts -> String getBuildDir opts = fromMaybe "dist" (buildDir opts) defaultDevelOpts :: DevelOpts -defaultDevelOpts = DevelOpts False False False (-1) Nothing Nothing Nothing +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 -- 3001, give an appropriate message to the user. -reverseProxy :: IO () -reverseProxy = withSocketsDo $ do +reverseProxy :: DevelOpts -> Int -> IO () +reverseProxy opts appPort = do manager <- newManager def - forever $ do - run 3000 $ waiProxyTo - (const $ return $ Right $ ProxyDest "127.0.0.1" 3001) - onExc - manager - putStrLn "Reverse proxy stopped, but it shouldn't" - threadDelay 1000000 - putStrLn "Restarting reverse proxy" + let loop = forever $ do + run (develPort opts) $ waiProxyTo + (const $ return $ Right $ ProxyDest "127.0.0.1" appPort) + onExc + manager + putStrLn "Reverse proxy stopped, but it shouldn't" + threadDelay 1000000 + putStrLn "Restarting reverse proxy" + loop `Ex.onException` exitFailure where onExc _ _ = return $ responseLBS status200 @@ -128,9 +133,26 @@ reverseProxy = withSocketsDo $ do ] "

App not ready, please refresh

" +checkPort :: Int -> IO Bool +checkPort p = do + es <- Ex.try $ bindPort p HostIPv4 + case es of + Left (_ :: Ex.IOException) -> return False + Right s -> do + sClose s + return True + +getPort :: Int -> IO Int +getPort p = do + avail <- checkPort p + if avail then return p else getPort (succ p) + devel :: DevelOpts -> [String] -> IO () -devel opts passThroughArgs = withManager $ \manager -> do - _ <- forkIO reverseProxy +devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do + avail <- checkPort $ develPort opts + unless avail $ error "devel port unavailable" + appPort <- getPort 17834 + _ <- forkIO $ reverseProxy opts appPort checkDevelFile writeLock opts @@ -138,7 +160,7 @@ devel opts passThroughArgs = withManager $ \manager -> do _ <- forkIO $ do filesModified <- newEmptyMVar watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ())) - evalStateT (mainOuterLoop filesModified) Map.empty + evalStateT (mainOuterLoop appPort filesModified) Map.empty _ <- getLine writeLock opts exitSuccess @@ -146,7 +168,7 @@ devel opts passThroughArgs = withManager $ \manager -> do bd = getBuildDir opts -- outer loop re-reads the cabal file - mainOuterLoop filesModified = do + mainOuterLoop appPort filesModified = do ghcVer <- liftIO ghcVersion cabal <- liftIO $ D.findPackageDesc "." gpd <- liftIO $ D.readPackageDescription D.normal cabal @@ -158,10 +180,10 @@ devel opts passThroughArgs = withManager $ \manager -> do liftIO $ removeFileIfExists "yesod-devel/arargs.txt" -- the configure step, remove them to force liftIO $ removeFileIfExists "yesod-devel/ldargs.txt" -- a cabal build first rebuild <- liftIO $ mkRebuild gpd ghcVer cabal opts ldar - mainInnerLoop hsSourceDirs filesModified cabal gpd lib ghcVer rebuild + mainInnerLoop appPort hsSourceDirs filesModified cabal gpd lib ghcVer rebuild -- inner loop rebuilds after files change - mainInnerLoop hsSourceDirs filesModified cabal gpd lib ghcVer rebuild = go + mainInnerLoop appPort hsSourceDirs filesModified cabal gpd lib ghcVer rebuild = go where go = do _ <- recompDeps hsSourceDirs @@ -185,7 +207,7 @@ devel opts passThroughArgs = withManager $ \manager -> do else "Starting development server..." env0 <- liftIO getEnvironment (_,_,_,ph) <- liftIO $ createProcess (proc "runghc" devArgs) - { env = Just $ ("PORT", "3001") : ("DISPLAY_PORT", "3000") : env0 + { env = Just $ ("PORT", show appPort) : ("DISPLAY_PORT", show $ develPort opts) : env0 } derefMap <- get watchTid <- liftIO . forkIO . try_ $ flip evalStateT derefMap $ do @@ -201,7 +223,7 @@ devel opts passThroughArgs = withManager $ \manager -> do liftIO $ Ex.throwTo watchTid (userError "process finished") loop list n <- liftIO $ cabal `isNewerThan` (bd "setup-config") - if n then mainOuterLoop filesModified else go + if n then mainOuterLoop appPort filesModified else go runBuildHook :: Maybe String -> IO () runBuildHook (Just s) = do diff --git a/yesod/GhcBuild.hs b/yesod/GhcBuild.hs index 02a6ef87..712999f7 100644 --- a/yesod/GhcBuild.hs +++ b/yesod/GhcBuild.hs @@ -62,8 +62,8 @@ getBuildFlags = do return argv2 buildPackage :: [Located String] -> FilePath -> FilePath -> IO Bool -buildPackage a ld ar = buildPackage' a ld ar `Ex.catch` \(e::Ex.SomeException) -> do - putStrLn ("exception building package: " ++ show e) +buildPackage a ld ar = buildPackage' a ld ar `Ex.catch` \e -> do + putStrLn ("exception building package: " ++ show (e :: Ex.SomeException)) return False buildPackage' :: [Located String] -> FilePath -> FilePath -> IO Bool diff --git a/yesod/main.hs b/yesod/main.hs index 610e597d..d9780e8b 100755 --- a/yesod/main.hs +++ b/yesod/main.hs @@ -53,6 +53,7 @@ data Command = Init , _develBuildDir :: Maybe String , develIgnore :: [String] , develExtraArgs :: [String] + , _develPort :: Int } | Test | AddHandler @@ -90,7 +91,7 @@ main = do Configure -> cabal ["configure"] Build es -> touch' >> cabal ("build":es) Touch -> touch' - Devel da s f r b _ig es -> devel (DevelOpts (optCabalPgm o == CabalDev) da (optVerbose o) r s f b) es + Devel da s f r b _ig es p -> devel (DevelOpts (optCabalPgm o == CabalDev) da (optVerbose o) r s f b p) es Keter noRebuild -> keter (cabalCommand o) noRebuild Version -> do putStrLn ("yesod-core version:" ++ yesodVersion) putStrLn ("yesod version:" ++ showVersion Paths_yesod.version) @@ -145,6 +146,8 @@ develOptions = Devel <$> switch ( long "disable-api" <> short 'd' <> help "ignore file changes in DIR" ) ) <*> extraCabalArgs + <*> option ( long "port" <> short 'p' <> value 3000 <> metavar "N" + <> help "Devel server listening port" ) extraCabalArgs :: Parser [String] extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG" diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index 2de0acf8..70c6e597 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -108,6 +108,7 @@ executable yesod , http-reverse-proxy >= 0.1.0.4 , network , http-conduit + , network-conduit , project-template >= 0.1.1 ghc-options: -Wall -threaded