haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

README.md, and some minor code cleanups

Browse Source
This commit is contained in:
Michael Snoyman 2016-11-24 07:51:54 +02:00
parent ab4d6540ca
commit f3fc735a25
12 changed files with 338 additions and 111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

227
yesod-bin/Devel.hs
View File

@ -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

106
yesod-bin/README.md Normal file
View File

@ -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.

1
yesod-bin/devel-example/.gitignore vendored Normal file
View File

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

5
yesod-bin/devel-example/README.md Normal file
View File

@ -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`

2
yesod-bin/devel-example/Setup.hs Normal file
View File

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

6
yesod-bin/devel-example/app/Main.hs Normal file
View File

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

5
yesod-bin/devel-example/app/devel.hs Normal file
View File

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

30
yesod-bin/devel-example/devel-example.cabal Normal file
View File

@ -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

47
yesod-bin/devel-example/src/DevelExample.hs Normal file
View File

@ -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

8
yesod-bin/devel-example/stack.yaml Normal file
View File

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

7
yesod-bin/main.hs
View File

@ -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")

5
yesod-bin/yesod-bin.cabal
View File

@ -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