From f3fc735a25eb3d5c051c761b59070eb9a0e4e156 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 24 Nov 2016 07:51:54 +0200 Subject: [PATCH] README.md, and some minor code cleanups --- yesod-bin/Devel.hs | 227 ++++++++++---------- yesod-bin/README.md | 106 +++++++++ yesod-bin/devel-example/.gitignore | 1 + yesod-bin/devel-example/README.md | 5 + yesod-bin/devel-example/Setup.hs | 2 + yesod-bin/devel-example/app/Main.hs | 6 + yesod-bin/devel-example/app/devel.hs | 5 + yesod-bin/devel-example/devel-example.cabal | 30 +++ yesod-bin/devel-example/src/DevelExample.hs | 47 ++++ yesod-bin/devel-example/stack.yaml | 8 + yesod-bin/main.hs | 7 +- yesod-bin/yesod-bin.cabal | 5 +- 12 files changed, 338 insertions(+), 111 deletions(-) create mode 100644 yesod-bin/README.md create mode 100644 yesod-bin/devel-example/.gitignore create mode 100644 yesod-bin/devel-example/README.md create mode 100644 yesod-bin/devel-example/Setup.hs create mode 100644 yesod-bin/devel-example/app/Main.hs create mode 100644 yesod-bin/devel-example/app/devel.hs create mode 100644 yesod-bin/devel-example/devel-example.cabal create mode 100644 yesod-bin/devel-example/src/DevelExample.hs create mode 100644 yesod-bin/devel-example/stack.yaml diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index 5c864a41..2b5ee7b8 100644 --- a/yesod-bin/Devel.hs +++ b/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 - -- build loop - (takeMVar watchingBaton >> runStackBuild packageName) + -- + -- We need to put withChangedVar outside of all this, since we + -- need to ensure we start watching files before the stack build + -- 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_ $ - setDelegateCtlc True $ - proc "stack" $ + let procConfig = setDelegateCtlc True $ proc "stack" $ [ "build" , "--fast" , "--file-watch" - -- Turn on various flags, and indicate the specific - -- component we want - , "--flag", packageName ++ ":dev" - , "--flag", packageName ++ ":library-only" + -- Indicate the component we want , 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 - runApp appPortVar watchingBaton develHsPath = do + sayV $ show procConfig + + 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 - withManager $ \manager -> do - -- Variable indicating that the signal file has been - -- changed. We reset it each time we handle the signal. - changedVar <- newTVarIO False + -- Start watching the signal file, and set changedVar to + -- True each time it's changed. + 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) - -- Start watching the signal file, and set changedVar to - -- True each time it's changed. - 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) + -- Run the inner action + inner changedVar - -- Alright, watching is set up, let the build thread know - -- it can get started. - putMVar watchingBaton () + -- Each time the library builds successfully, run the application + runApp appPortVar changedVar develHsPath = do + -- 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 - -- has been built - atomically $ do - changed <- readTVar changedVar - check changed - writeTVar changedVar False + sayV "First successful build complete, running app" - 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 - -- for the child below - env <- fmap Map.fromList getEnvironment + -- Keep looping forever, print any synchronous exceptions, + -- and eventually die from an async exception from one of + -- 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, - -- and eventually die from an async exception from one of - -- 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 + -- Modified environment + let env' = Map.toList + $ Map.insert "PORT" (show newPort) + $ Map.insert "DISPLAY_PORT" (show $ develPort opts) + env - -- Modified environment - let env' = Map.toList - $ Map.insert "PORT" (show newPort) - $ Map.insert "DISPLAY_PORT" (show $ develPort opts) - env + -- Remove the terminate file so we don't immediately exit + removeSpecialFile TermFile - -- Remove the terminate file so we don't immediately exit - removeSpecialFile TermFile + -- Launch the main function in the Main module defined + -- 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 - -- 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 = setEnv env' $ proc "stack" - [ "ghc" - , "--" - , develHsPath - , "-e" - , "Main.main" - ] + -- Start running the child process with GHC + withProcess procDef $ \p -> do + -- Wait for either the process to exit, or for a new build to come through + 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 - -- Start running the child process with GHC - withProcess procDef $ \p -> do - -- Wait for either the process to exit, or for a new build to come through - 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 + -- Wait until the child properly exits, then we'll try again + ec <- waitExitCode p + sayV $ "Expected: child process exited with " ++ show ec diff --git a/yesod-bin/README.md b/yesod-bin/README.md new file mode 100644 index 00000000..0a1ae54a --- /dev/null +++ b/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. diff --git a/yesod-bin/devel-example/.gitignore b/yesod-bin/devel-example/.gitignore new file mode 100644 index 00000000..6d15596d --- /dev/null +++ b/yesod-bin/devel-example/.gitignore @@ -0,0 +1 @@ +yesod-devel/ diff --git a/yesod-bin/devel-example/README.md b/yesod-bin/devel-example/README.md new file mode 100644 index 00000000..f5654dd0 --- /dev/null +++ b/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` diff --git a/yesod-bin/devel-example/Setup.hs b/yesod-bin/devel-example/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/yesod-bin/devel-example/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/yesod-bin/devel-example/app/Main.hs b/yesod-bin/devel-example/app/Main.hs new file mode 100644 index 00000000..bd9fba8a --- /dev/null +++ b/yesod-bin/devel-example/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import DevelExample + +main :: IO () +main = prodMain diff --git a/yesod-bin/devel-example/app/devel.hs b/yesod-bin/devel-example/app/devel.hs new file mode 100644 index 00000000..8085fbc2 --- /dev/null +++ b/yesod-bin/devel-example/app/devel.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PackageImports #-} +import "devel-example" DevelExample (develMain) + +main :: IO () +main = develMain diff --git a/yesod-bin/devel-example/devel-example.cabal b/yesod-bin/devel-example/devel-example.cabal new file mode 100644 index 00000000..a1a3ddb5 --- /dev/null +++ b/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 diff --git a/yesod-bin/devel-example/src/DevelExample.hs b/yesod-bin/devel-example/src/DevelExample.hs new file mode 100644 index 00000000..649ac522 --- /dev/null +++ b/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")] + "

Well, this is really boring.

" + +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 diff --git a/yesod-bin/devel-example/stack.yaml b/yesod-bin/devel-example/stack.yaml new file mode 100644 index 00000000..c39726a6 --- /dev/null +++ b/yesod-bin/devel-example/stack.yaml @@ -0,0 +1,8 @@ +resolver: lts-7.10 + +packages: +- . +- .. + +extra-deps: +- typed-process-0.1.0.0 diff --git a/yesod-bin/main.hs b/yesod-bin/main.hs index 3615bcfe..5bf60e4a 100755 --- a/yesod-bin/main.hs +++ b/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") diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index a2f6e4f4..77177339 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -5,16 +5,17 @@ license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman 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