yesod devel displays "app not loaded" message

In order to achieve this, yesod devel listens on port 3000 and reverse
proxies to port 3001. An environment variable is set to tell the app to
listen on port 3001.

yesod-default/Yesod/Default/Main.hs

@@ -15,6 +15,9 @@ import Network.Wai.Middleware.Gzip (gzip, GzipFiles (GzipCacheFolder), gzipFiles
 import Network.Wai.Middleware.Autohead (autohead)
 import Network.Wai.Middleware.Jsonp (jsonp)
 import Control.Monad (when)
+import System.Environment (getEnvironment)
+import Data.Maybe (fromMaybe)
+import Safe (readMay)
 
 #ifndef WINDOWS
 import qualified System.Posix.Signals as Signal
@@ -81,7 +84,9 @@ defaultDevelApp
     -> IO (Int, Application)
 defaultDevelApp load getApp = do
     conf   <- load
-    let p = appPort conf
-    putStrLn $ "Devel application launched: http://localhost:" ++ show p
+    env <- getEnvironment
+    let p = fromMaybe (appPort conf) $ lookup "PORT" env >>= readMay
+        pdisplay = fromMaybe p $ lookup "DISPLAY_PORT" env >>= readMay
+    putStrLn $ "Devel application launched: http://localhost:" ++ show pdisplay
     app <- getApp conf
     return (p, app)

yesod-default/yesod-default.cabal

@@ -1,5 +1,5 @@
 name:            yesod-default
-version:         1.1.0.2
+version:         1.1.1
 license:         MIT
 license-file:    LICENSE
 author:          Patrick Brisbin
@@ -34,6 +34,7 @@ library
                    , unordered-containers
                    , hamlet                >= 1.1     && < 1.2
                    , data-default
+                   , safe
 
     if !os(windows)
          build-depends: unix

yesod/Devel.hs

@@ -41,6 +41,7 @@ import           Data.Maybe                            (fromMaybe)
 import qualified Data.Set                              as Set
 
 import           System.Directory
+import           System.Environment                    (getEnvironment)
 import           System.Exit                           (ExitCode (..),
                                                         exitFailure,
                                                         exitSuccess)
@@ -62,7 +63,8 @@ import           System.Process                        (ProcessHandle,
                                                         readProcess,
                                                         runInteractiveProcess,
                                                         system,
-                                                        terminateProcess)
+                                                        terminateProcess,
+                                                        env)
 import           System.Timeout                        (timeout)
 
 import           Build                                 (getDeps, isNewerThan,
@@ -72,6 +74,12 @@ import           GhcBuild                              (buildPackage,
 
 import qualified Config                                as GHC
 import           SrcLoc                                (Located)
+import           Network.HTTP.ReverseProxy             (waiProxyTo, ProxyDest (ProxyDest))
+import           Network                               (withSocketsDo)
+import           Network.Wai                           (responseLBS)
+import           Network.HTTP.Types                    (status200)
+import           Network.Wai.Handler.Warp              (run)
+import           Network.HTTP.Conduit                  (newManager, def)
 
 lockFile :: DevelOpts -> FilePath
 lockFile _opts =  "yesod-devel/devel-terminate"
@@ -108,8 +116,26 @@ cabalCommand opts | isCabalDev opts = "cabal-dev"
 defaultDevelOpts :: DevelOpts
 defaultDevelOpts = DevelOpts False False False (-1) Nothing Nothing Nothing
 
+-- | 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
+    manager <- newManager def
+    run 3000 $ waiProxyTo
+        (const $ return $ Right $ ProxyDest "localhost" 3001)
+        onExc
+        manager
+  where
+    onExc _ _ = return $ responseLBS
+        status200
+        [ ("content-type", "text/html")
+        , ("Refresh", "1")
+        ]
+        "<h1>App not ready, please refresh</h1>"
+
 devel :: DevelOpts -> [String] -> IO ()
 devel opts passThroughArgs = withManager $ \manager -> do
+    _ <- forkIO reverseProxy
     checkDevelFile
     writeLock opts
 
@@ -162,7 +188,10 @@ devel opts passThroughArgs = withManager $ \manager -> do
                    liftIO $ putStrLn
                             $ if verbose opts then "Starting development server: runghc " ++ L.unwords devArgs
                                               else "Starting development server..."
-                   (_,_,_,ph) <- liftIO $ createProcess $ proc "runghc" devArgs
+                   env0 <- liftIO getEnvironment
+                   (_,_,_,ph) <- liftIO $ createProcess (proc "runghc" devArgs)
+                        { env = Just $ ("PORT", "3001") : ("DISPLAY_PORT", "3000") : env0
+                        }
                    derefMap <- get
                    watchTid <- liftIO . forkIO . try_ $ flip evalStateT derefMap $ do
                       loop list

yesod/scaffold/project.cabal.cg

@@ -55,7 +55,7 @@ library
                  , yesod-core                    >= 1.1.2      && < 1.2
                  , yesod-auth                    >= 1.1        && < 1.2
                  , yesod-static                  >= 1.1        && < 1.2
-                 , yesod-default                 >= 1.1        && < 1.2
+                 , yesod-default                 >= 1.1.1      && < 1.2
                  , yesod-form                    >= 1.1        && < 1.2
                  , yesod-test                    >= 0.3        && < 0.4
                  , clientsession                 >= 0.8        && < 0.9

yesod/yesod.cabal

@@ -138,6 +138,9 @@ executable             yesod
                      , fsnotify           >= 0.0          && < 0.1
                      , split              >= 0.2          && < 0.3
                      , lifted-base
+                     , http-reverse-proxy >= 0.1.0.4
+                     , network
+                     , http-conduit
 
     ghc-options:       -Wall -threaded
     main-is:           main.hs