README.md, and some minor code cleanups

yesod-bin/Devel.hs

@@ -10,8 +10,6 @@ module Devel
 import           Control.Applicative                   ((<|>))
 import           Control.Concurrent                    (threadDelay)
 import           Control.Concurrent.Async              (race_)
-import           Control.Concurrent.MVar               (newEmptyMVar, putMVar,
-                                                        takeMVar)
 import           Control.Concurrent.STM
 import qualified Control.Exception.Safe                as Ex
 import           Control.Monad                         (forever, unless, void,
@@ -20,6 +18,7 @@ import qualified Data.ByteString.Lazy                  as LB
 import           Data.Default.Class                    (def)
 import           Data.FileEmbed                        (embedFile)
 import qualified Data.Map                              as Map
+import qualified Data.Set                              as Set
 import           Data.Streaming.Network                (bindPortTCP,
                                                         bindRandomPortTCP)
 import           Data.String                           (fromString)
@@ -216,6 +215,13 @@ checkDevelFile =
             then return x
             else loop xs
 
+-- | Get the set of all flags available in the given cabal file
+getAvailableFlags :: D.GenericPackageDescription -> Set.Set String
+getAvailableFlags =
+    Set.fromList . map (unFlagName . D.flagName) . D.genPackageFlags
+  where
+    unFlagName (D.FlagName fn) = fn
+
 -- | This is the main entry point. Run the devel server.
 devel :: DevelOpts -- ^ command line options
       -> [String] -- ^ extra options to pass to Stack
@@ -239,11 +245,6 @@ devel opts passThroughArgs = do
     let pd = D.packageDescription gpd
         D.PackageIdentifier (D.PackageName packageName) _version = D.package pd
 
-    -- Create a baton to indicate we're watching for file changes. We
-    -- need to ensure that we install the file watcher before we start
-    -- the Stack build loop.
-    watchingBaton <- newEmptyMVar
-
     -- Which file contains the code to run
     develHsPath <- checkDevelFile
 
@@ -260,37 +261,43 @@ devel opts passThroughArgs = do
 
     -- Run the following concurrently. If any of them exit, take the
     -- whole thing down.
-    withRevProxy $ race_
+    --
-        -- Wait until we're watching for file changes, then start the
+    -- We need to put withChangedVar outside of all this, since we
-        -- build loop
+    -- need to ensure we start watching files before the stack build
-        (takeMVar watchingBaton >> runStackBuild packageName)
+    -- loop starts.
+    withChangedVar $ \changedVar -> withRevProxy $ race_
+        -- Start the build loop
+        (runStackBuild packageName (getAvailableFlags gpd))
 
         -- Run the app itself, restarting when a build succeeds
-        (runApp appPortVar watchingBaton develHsPath)
+        (runApp appPortVar changedVar develHsPath)
   where
     -- say, but only when verbose is on
     sayV = when (verbose opts) . sayString
 
     -- Leverage "stack build --file-watch" to do the build
-    runStackBuild packageName = do
+    runStackBuild packageName availableFlags = do
         -- We call into this app for the devel-signal command
         myPath <- getExecutablePath
-        runProcess_ $
+        let procConfig = setDelegateCtlc True $ proc "stack" $
-            setDelegateCtlc True $
-            proc "stack" $
                 [ "build"
                 , "--fast"
                 , "--file-watch"
 
-                -- Turn on various flags, and indicate the specific
+                -- Indicate the component we want
-                -- component we want
-                , "--flag", packageName ++ ":dev"
-                , "--flag", packageName ++ ":library-only"
                 , packageName ++ ":lib"
 
                 -- signal the watcher that a build has succeeded
                 , "--exec", myPath ++ " devel-signal"
                 ] ++
+
+                -- Turn on relevant flags
+                concatMap
+                    (\flagName -> [ "--flag", packageName ++ ":" ++ flagName])
+                    (Set.toList $ Set.intersection
+                        availableFlags
+                        (Set.fromList ["dev", "library-only"])) ++
+
                 -- Add the success hook
                 (case successHook opts of
                     Nothing -> []
@@ -299,105 +306,109 @@ devel opts passThroughArgs = do
                 -- Any extra args passed on the command line
                 passThroughArgs
 
-    -- Each time the library builds successfully, run the application
+        sayV $ show procConfig
-    runApp appPortVar watchingBaton develHsPath = do
+
+        runProcess_ procConfig
+
+    -- Run the inner action with a TVar which will be set to True
+    -- whenever the signal file is modified.
+    withChangedVar inner = withManager $ \manager -> do
+        -- Variable indicating that the signal file has been changed. We
+        -- reset it each time we handle the signal.
+        changedVar <- newTVarIO False
+
         -- Get the absolute path of the signal file, needed for the
         -- file watching
         develSignalFile' <- canonicalizeSpecialFile SignalFile
 
-        -- Enable file watching
+        -- Start watching the signal file, and set changedVar to
-        withManager $ \manager -> do
+        -- True each time it's changed.
-            -- Variable indicating that the signal file has been
+        void $ watchDir manager
-            -- changed. We reset it each time we handle the signal.
+                -- Using fromString to work with older versions of fsnotify
-            changedVar <- newTVarIO False
+                -- that use system-filepath
+                (fromString (takeDirectory develSignalFile'))
+                (\e -> eventPath e == fromString develSignalFile')
+                (const $ atomically $ writeTVar changedVar True)
 
-            -- Start watching the signal file, and set changedVar to
+        -- Run the inner action
-            -- True each time it's changed.
+        inner changedVar
-            void $ watchDir manager
-                    -- Using fromString to work with older versions of fsnotify
-                    -- that use system-filepath
-                    (fromString (takeDirectory develSignalFile'))
-                    (\e -> eventPath e == fromString develSignalFile')
-                    (const $ atomically $ writeTVar changedVar True)
 
-            -- Alright, watching is set up, let the build thread know
+    -- Each time the library builds successfully, run the application
-            -- it can get started.
+    runApp appPortVar changedVar develHsPath = do
-            putMVar watchingBaton ()
+        -- Wait for the first change, indicating that the library
+        -- has been built
+        atomically $ do
+            changed <- readTVar changedVar
+            check changed
+            writeTVar changedVar False
 
-            -- Wait for the first change, indicating that the library
+        sayV "First successful build complete, running app"
-            -- has been built
-            atomically $ do
-                changed <- readTVar changedVar
-                check changed
-                writeTVar changedVar False
 
-            sayV "First successful build complete, running app"
+        -- We're going to set the PORT and DISPLAY_PORT variables
+        -- for the child below
+        env <- fmap Map.fromList getEnvironment
 
-            -- We're going to set the PORT and DISPLAY_PORT variables
+        -- Keep looping forever, print any synchronous exceptions,
-            -- for the child below
+        -- and eventually die from an async exception from one of
-            env <- fmap Map.fromList getEnvironment
+        -- the other threads (via race_ above).
+        forever $ Ex.handleAny (\e -> sayErrString $ "Exception in runApp: " ++ show e) $ do
+            -- Get the port the child should listen on, and tell
+            -- the reverse proxy about it
+            newPort <-
+                if useReverseProxy opts
+                    then getNewPort opts
+                    -- no reverse proxy, so use the develPort directly
+                    else return (develPort opts)
+            atomically $ writeTVar appPortVar newPort
 
-            -- Keep looping forever, print any synchronous exceptions,
+            -- Modified environment
-            -- and eventually die from an async exception from one of
+            let env' = Map.toList
-            -- the other threads (via race_ above).
+                        $ Map.insert "PORT" (show newPort)
-            forever $ Ex.handleAny (\e -> sayErrString $ "Exception in runApp: " ++ show e) $ do
+                        $ Map.insert "DISPLAY_PORT" (show $ develPort opts)
-                -- Get the port the child should listen on, and tell
+                        env
-                -- the reverse proxy about it
-                newPort <-
-                    if useReverseProxy opts
-                        then getNewPort opts
-                        -- no reverse proxy, so use the develPort directly
-                        else return (develPort opts)
-                atomically $ writeTVar appPortVar newPort
 
-                -- Modified environment
+            -- Remove the terminate file so we don't immediately exit
-                let env' = Map.toList
+            removeSpecialFile TermFile
-                         $ Map.insert "PORT" (show newPort)
-                         $ Map.insert "DISPLAY_PORT" (show $ develPort opts)
-                           env
 
-                -- Remove the terminate file so we don't immediately exit
+            -- Launch the main function in the Main module defined
-                removeSpecialFile TermFile
+            -- in the file develHsPath. We use ghc instead of
+            -- runghc to avoid the extra (confusing) resident
+            -- runghc process. Starting with GHC 8.0.2, that will
+            -- not be necessary.
+            let procDef = setStdin closed $ setEnv env' $ proc "stack"
+                    [ "ghc"
+                    , "--"
+                    , develHsPath
+                    , "-e"
+                    , "Main.main"
+                    ]
 
-                -- Launch the main function in the Main module defined
+            -- Start running the child process with GHC
-                -- in the file develHsPath. We use ghc instead of
+            withProcess procDef $ \p -> do
-                -- runghc to avoid the extra (confusing) resident
+                -- Wait for either the process to exit, or for a new build to come through
-                -- runghc process. Starting with GHC 8.0.2, that will
+                eres <- atomically (fmap Left (waitExitCodeSTM p) <|> fmap Right
-                -- not be necessary.
+                    (do changed <- readTVar changedVar
-                let procDef = setEnv env' $ proc "stack"
+                        check changed
-                        [ "ghc"
+                        writeTVar changedVar False))
-                        , "--"
+                            -- on an async exception, make sure the child dies
-                        , develHsPath
+                            `Ex.onException` writeSpecialFile TermFile
-                        , "-e"
+                case eres of
-                        , "Main.main"
+                    -- Child exited, which indicates some
-                        ]
+                    -- error. Let the user know, sleep for a bit
+                    -- to avoid busy-looping, and then we'll try
+                    -- again.
+                    Left ec -> do
+                        sayErrString $ "Unexpected: child process exited with " ++ show ec
+                        threadDelay 1000000
+                        sayErrString "Trying again"
+                    -- New build succeeded
+                    Right () -> do
+                        -- Kill the child process, both with the
+                        -- TermFile, and by signaling the process
+                        -- directly.
+                        writeSpecialFile TermFile
+                        stopProcess p
 
-                -- Start running the child process with GHC
+                        -- Wait until the child properly exits, then we'll try again
-                withProcess procDef $ \p -> do
+                        ec <- waitExitCode p
-                    -- Wait for either the process to exit, or for a new build to come through
+                        sayV $ "Expected: child process exited with " ++ show ec
-                    eres <- atomically (fmap Left (waitExitCodeSTM p) <|> fmap Right
-                        (do changed <- readTVar changedVar
-                            check changed
-                            writeTVar changedVar False))
-                                -- on an async exception, make sure the child dies
-                                `Ex.onException` writeSpecialFile TermFile
-                    case eres of
-                        -- Child exited, which indicates some
-                        -- error. Let the user know, sleep for a bit
-                        -- to avoid busy-looping, and then we'll try
-                        -- again.
-                        Left ec -> do
-                            sayErrString $ "Unexpected: child process exited with " ++ show ec
-                            threadDelay 1000000
-                            sayErrString "Trying again"
-                        -- New build succeeded
-                        Right () -> do
-                            -- Kill the child process, both with the
-                            -- TermFile, and by signaling the process
-                            -- directly.
-                            writeSpecialFile TermFile
-                            stopProcess p
-
-                            -- Wait until the child properly exits, then we'll try again
-                            ec <- waitExitCode p
-                            sayV $ "Expected: child process exited with " ++ show ec

yesod-bin/README.md

@@ -0,0 +1,106 @@
+## yesod-bin: the Yesod executable
+
+This executable is almost exclusively used for its `yesod devel`
+capabilities, providing a development server for web apps. It also
+provides some legacy functionality, almost all of which has been
+superceded by functionality in the
+[Haskell Stack build tool](http://haskellstack.org/). This README will
+speak exclusively about `yesod devel`.
+
+### Development server
+
+The development server will automatically recompile your application
+whenever you make source code changes. It will then launch your app,
+and reverse-proxy to it. The reverse proxying ensures that you can
+connect to your application on a dedicated port, always get the latest
+version available, and won't get dropped connections when the app
+isn't yet ready. Instead, you'll get some very motivating messages:
+
+![Motivation](https://i.sli.mg/nO6DvN.png)
+
+## Common workflows
+
+The standard Yesod scaffoldings are configured to work with `yesod
+devel` out of the box (though see below for non-Yesod
+development). For the most part, from within your application
+directory, you'll just want to run:
+
+* `stack build yesod-bin`
+* `stack exec -- yesod devel`
+
+This will install the corresponding version of the `yesod` executable
+into your currently selected snapshot, and then use that
+executable. (Starting with version 1.5.0, you can be more lax and use
+a `yesod` executable compiled for a different snapshot. Once 1.5.0 is
+more widespread we'll probably update these instructions.)
+
+Some other common questions:
+
+* If you want to control which port you can access your application
+  on, use the `--port` command line option, e.g. `stack exec -- yesod
+  devel --port 4000`. Changing your port inside your source code _will
+  not work_, because you need to change the reverse proxying port.
+* If you want to run a command after each successful build, you can
+  use `stack exec -- yesod devel --success-hook "echo Yay!"`
+* If for some reason you want to disable the reverse proxy
+  capabilities, use `stack exec -- yesod devel
+  --disable-reverse-proxy`
+
+## How it works
+
+The workflow of the devel server is pretty simple:
+
+* Launch a reverse proxy server
+* Use Stack file-watch capability to run a build loop on your code,
+  rebuilding each time a file is modified
+* Have Stack call `yesod devel-signal` to write to a specific file
+  (`yesod-devel/rebuild`) each time a rebuild is successful
+* Each time `yesod-devel/rebuild` is modified:
+  * Kill the current child process
+  * Get a new random port
+  * Tell the reverse proxy server about the new port to forward to
+  * Run the application's devel script with two environment variables
+    set:
+    * `PORT` gives the newly generated random port. The application
+      needs to listen on that port.
+    * `DISPLAY_PORT` gives the port that the reverse proxy is
+      listening on, used for display purposes or generating URLs.
+
+Now some weird notes:
+
+* The devel script can be one of the following three files. `yesod
+  devel` will search for them in the given order. That script must
+  provide a `main` function.
+  * `app/devel.hs`
+  * `devel.hs`
+  * `src/devel.hs`
+* Unfortunately, directly killing the `ghc` interpreter has never
+  worked reliably, so we have an extra hack: when killing the process,
+  `yesod devel` also writes to a file
+  `yesod-devel/devel-terminate`. Your devel script should respect this
+  file and shutdown whenever it exists.
+* If your .cabal file defines them, `yesod devel` will tell Stack to
+  build with the flags `dev` and `library-only`. You can use this to
+  speed up compile times (biggest win: skip building executables, thus
+  the name `library-only`).
+
+If that all seems a little complicated, remember that the Yesod
+scaffolding handles all of this for you. But if you want to implement
+it yourself...
+
+## Non-Yesod development
+
+If you'd like to use the `yesod devel` server for your non-Yesod
+application, or even for a Yesod application not based on the
+scaffolding, this section is for you! We've got a
+[sample application in the repository](https://github.com/yesodweb/yesod/tree/master/yesod-bin/devel-example)
+that demonstrates how to get this set up. It demonstrates a good way
+to jump through the hoops implied above.
+
+One important note: I highly recommend putting _all_ of the logic in
+your library, and then providing a `develMain :: IO ()` function which
+yoru `app/devel.hs` script reexports as `main`. I've found this to
+greatly simplify things overall, since you can ensure all of your
+dependencies are specified correctly in your `.cabal` file. Also, I
+recommend using `PackageImports` in that file, as the example app
+shows.

yesod-bin/devel-example/.gitignore

@@ -0,0 +1 @@
+yesod-devel/

yesod-bin/devel-example/README.md

@@ -0,0 +1,5 @@
+An example non-Yesod application that is compatible with `yesod devel`. Steps
+to use it:
+
+* `stack build yesod-bin`
+* `stack exec -- yesod devel`

yesod-bin/devel-example/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

yesod-bin/devel-example/app/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import DevelExample
+
+main :: IO ()
+main = prodMain

yesod-bin/devel-example/app/devel.hs

@@ -0,0 +1,5 @@
+{-# LANGUAGE PackageImports #-}
+import "devel-example" DevelExample (develMain)
+
+main :: IO ()
+main = develMain

yesod-bin/devel-example/devel-example.cabal

@@ -0,0 +1,30 @@
+name:                devel-example
+version:             0.1.0.0
+build-type:          Simple
+cabal-version:       >=1.10
+
+flag library-only
+  default: False
+  description: Do not build the executable
+
+library
+  hs-source-dirs:      src
+  exposed-modules:     DevelExample
+  build-depends:       base
+                     , async
+                     , directory
+                     , http-types
+                     , wai
+                     , wai-extra
+                     , warp
+  default-language:    Haskell2010
+
+executable devel-example
+  hs-source-dirs:      app
+  main-is:             Main.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+                     , devel-example
+  default-language:    Haskell2010
+  if flag(library-only)
+    buildable:         False

yesod-bin/devel-example/src/DevelExample.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE OverloadedStrings #-}
+module DevelExample
+    ( prodMain
+    , develMain
+    ) where
+
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async (race_)
+import Network.HTTP.Types
+import Network.Wai
+import Network.Wai.Handler.Warp
+import Network.Wai.Middleware.RequestLogger
+import System.Directory (doesFileExist)
+import System.Environment
+
+myApp :: Application
+myApp _req send = send $ responseLBS
+    status200
+    [(hContentType, "text/html; charset=utf-8")]
+    "<p>Well, this is really <b>boring</b>.</p>"
+
+prodMain :: IO ()
+prodMain = do
+    putStrLn "Running in production mode on port 8080"
+    run 8080 $ logStdout myApp
+
+develMain :: IO ()
+develMain = race_ watchTermFile $ do
+    port <- fmap read $ getEnv "PORT"
+    displayPort <- getEnv "DISPLAY_PORT"
+    putStrLn $ "Running in development mode on port " ++ show port
+    putStrLn $ "But you should connect to port " ++ displayPort
+    run port $ logStdoutDev myApp
+
+-- | Would certainly be more efficient to use fsnotify, but this is
+-- simpler.
+watchTermFile :: IO ()
+watchTermFile =
+    loop
+  where
+    loop = do
+        exists <- doesFileExist "yesod-devel/devel-terminate"
+        if exists
+            then return ()
+            else do
+                threadDelay 100000
+                loop

yesod-bin/devel-example/stack.yaml

@@ -0,0 +1,8 @@
+resolver: lts-7.10
+
+packages:
+- .
+- ..
+
+extra-deps:
+- typed-process-0.1.0.0

yesod-bin/main.hs

@@ -180,7 +180,7 @@ keterOptions = Keter
 develOptions :: Parser Command
 develOptions = Devel <$> optStr ( long "success-hook" <> short 's' <> metavar "COMMAND"
                             <> help "Run COMMAND after rebuild succeeds")
-                     <*> extraCabalArgs
+                     <*> extraStackArgs
                      <*> option auto ( long "port" <> short 'p' <> value 3000 <> metavar "N"
                             <> help "Devel server listening port" )
                      <*> option auto ( long "tls-port" <> short 'q' <> value 3443 <> metavar "N"
@@ -190,6 +190,11 @@ develOptions = Devel <$> optStr ( long "success-hook" <> short 's' <> metavar "C
                      <*> switch ( long "disable-reverse-proxy" <> short 'n'
                             <> help "Disable reverse proxy" )
 
+extraStackArgs :: Parser [String]
+extraStackArgs = many (strOption ( long "extra-stack-arg" <> short 'e' <> metavar "ARG"
+                                   <> help "pass extra argument ARG to stack")
+                      )
+
 extraCabalArgs :: Parser [String]
 extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG"
                                    <> help "pass extra argument ARG to cabal")

yesod-bin/yesod-bin.cabal

@@ -5,16 +5,17 @@ license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
 maintainer:      Michael Snoyman <michael@snoyman.com>
 synopsis:        The yesod helper executable.
-description:     Provides scaffolding, devel server, and some simple code generation helpers.
+description:     See README.md for more information
 category:        Web, Yesod
 stability:       Stable
 cabal-version:   >= 1.6
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
-data-files:      refreshing.html
 
 extra-source-files:
+  README.md
   ChangeLog.md
+  refreshing.html
   *.pem
 
 executable             yesod