diff --git a/Devel.hs b/Devel.hs
--- a/Devel.hs
+++ b/Devel.hs
@@ -67,11 +67,14 @@
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 @@
, 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 @@
]
"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 @@
_ <- 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 @@
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 @@
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 @@
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 @@
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/GhcBuild.hs b/GhcBuild.hs
--- a/GhcBuild.hs
+++ b/GhcBuild.hs
@@ -62,8 +62,8 @@
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/main.hs b/main.hs
--- a/main.hs
+++ b/main.hs
@@ -53,6 +53,7 @@
, _develBuildDir :: Maybe String
, develIgnore :: [String]
, develExtraArgs :: [String]
+ , _develPort :: Int
}
| Test
| AddHandler
@@ -90,7 +91,7 @@
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 @@
<> 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.cabal b/yesod.cabal
--- a/yesod.cabal
+++ b/yesod.cabal
@@ -1,5 +1,5 @@
name: yesod
-version: 1.1.6
+version: 1.1.7
license: MIT
license-file: LICENSE
author: Michael Snoyman
@@ -32,7 +32,7 @@
, yesod-json >= 1.1 && < 1.2
, yesod-persistent >= 1.1 && < 1.2
, yesod-form >= 1.1 && < 1.3
- , yesod-default >= 1.1.1 && < 1.2
+ , yesod-default >= 1.1.3 && < 1.2
, monad-control >= 0.3 && < 0.4
, transformers >= 0.2.2 && < 0.4
, wai >= 1.3 && < 1.4
@@ -108,6 +108,7 @@
, http-reverse-proxy >= 0.1.0.4
, network
, http-conduit
+ , network-conduit
, project-template >= 0.1.1
ghc-options: -Wall -threaded