Merge remote-tracking branch 'upstream/master'

.gitignore

@@ -1,3 +1,4 @@
+*~
 *.o
 *.o_p
 *.hi
@@ -6,7 +7,12 @@ dist
 client_session_key.aes
 cabal-dev/
 yesod/foobar/
-.virthualenv
+.hsenv/
+.cabal-sandbox/
+cabal.sandbox.config
 /vendor/
-/.shelly/
+.shelly/
-/tarballs/
+tarballs/
+*.swp
+dist
+client_session_key.aes

.gitmodules

@@ -1,3 +0,0 @@
-[submodule "scripts"]
-	path = scripts
-	url = git://github.com/yesodweb/scripts.git

.travis.yml

@@ -2,12 +2,12 @@ language: haskell
 
 install:
     - cabal update
-    - cabal install mega-sdist hspec cabal-meta cabal-src
+    - cabal install --force-reinstalls hspec cabal-meta cabal-src alex
-    - git clone https://github.com/snoyberg/tagstream-conduit.git
+    - cabal-meta install --force-reinstalls
-    - cd tagstream-conduit
-    - cabal-src-install --src-only
-    - cd ..
-    - cabal-meta install --force-reinstalls --enable-tests
 
 script:
     - echo Done
+    - cabal-meta install --enable-tests
+    - mega-sdist --test
+    - cabal install hspec cabal-meta cabal-src
+    - cabal-meta install --force-reinstalls

README

@@ -0,0 +1,15 @@
+Authentication methods for Haskell web applications.
+
+Note for Rpxnow: 
+By default on some (all?) installs wget does not come with root certificates
+for SSL.  If this is the case then Web.Authenticate.Rpxnow.authenticate will
+fail as wget cannot establish a secure connection to rpxnow's servers.
+
+A simple *nix solution, if potentially insecure (man in the middle attacks as
+you are downloading the certs) is to grab a copy of the certs extracted from
+those that come with firefox, hosted by CURL at
+http://curl.haxx.se/ca/cacert.pem , put them somewhere (for ex,
+~/.wget/cacert.pem) and then edit your ~/.wgetrc to include:
+ca_certificate=~/.wget/cacert.pem
+
+This should fix the problem.

README.md

@@ -9,7 +9,6 @@ An advanced web framework using the Haskell programming language. Featuring:
     * techniques for constant-space memory consumption
   * asynchronous IO
     * this is built in to the Haskell programming language (like Erlang)
-    * handles a greater concurrent load than any other web application server
 
 # Learn more: http://yesodweb.com/
 
@@ -27,18 +26,19 @@ Your application is a cabal package and you use `cabal` to install its dependenc
 
 Install conflicts are unfortunately common in Haskell development.
 If you are not using any sandbox tools, you may discover that some of the other haskell installs on your system are broken.
-You can prevent this by using sandbox tools: `cabal-dev` or `hsenv`.
+You can prevent this by using cabal sandbox.
 
-Isolating an entire project with a virtual machine is also a great idea, you just need some tools to help that process.
+Isolating an entire project is also a great idea, you just need some tools to help that process.
-[Vagrant](http://vagrantup.com) is a great tool for that and there is a [Haskell Platform installer](https://bitbucket.org/puffnfresh/vagrant-haskell-heroku) for it.
+On Linux you can use Docker.
+On any OS you can use a virtual machine. [Vagrant](http://vagrantup.com) is a great tool for that and there is a [Haskell Platform installer](https://bitbucket.org/puffnfresh/vagrant-haskell-heroku) for it.
 
-## Using cabal-dev
+## Using cabal sandbox
 
-cabal-dev creates a sandboxed environment for an individual cabal package.
+To sandbox a project, type:
-Instead of using the `cabal` command, use the `cabal-dev` command which will use the sandbox.
 
-Use `yesod devel --dev` when developing your application.
+    cabal sandbox init
 
+This ensures that future installs will be local to the sandboxed directory.
 
 
 ## Installing the latest development version from github for use with your application
@@ -55,32 +55,18 @@ In your application folder, create a `sources.txt` file with the following conte
     https://github.com/yesodweb/wai
 
 `./` means build your app. The yesod repos will be cloned and placed in a `vendor` repo.
-Now run: `cabal-meta install`. If you use `cabal-dev`, run `cabal-meta --dev install`
+Now run: `cabal-meta install`.
 
 This should work almost all of the time. You can read more on [cabal-meta](https://github.com/yesodweb/cabal-meta)
 If you aren't building from an application, remove the `./` and create a new directory for your sources.txt first.
 
 
 
-## hsenv (Linux only)
+## hsenv (Linux and Mac OS X)
 
-[hsenv](http://hackage.haskell.org/package/hsenv) prevents your custom build of Yesod from interfering with your currently installed cabal packages:
+[hsenv](https://github.com/tmhedberg/hsenv) also provides a sandbox, but works at the shell level.
+Generally we recommend using cabal sandbox, but hsenv has tools for allowing you to use different versions of GHC, which may be useful for you.
 
-* hsenv creates an isolated environment like cabal-dev
-* hsenv works at the shell level, so every shell must activate the hsenv
-* cabal-dev by default isolates a single cabal package, but hsenv isolates multiple packages together.
-* cabal-dev can isolate multiple packages together by using the -s sandbox argument
-
-
-## cabal-src
-
-The cabal-src tool helps resolve dependency conflicts when installing local packages.
-This capability is already built in if you are using cabal-dev or cabal-meta. Otherwise install cabal-src with:
-
-    cabal install cabal-src
-
-Whenever you would use `cabal install` to install a local package, use `cabal-src-install` instead.
-Our installer script now uses cabal-src-install when it is available.
 
 
 ## Cloning the repos
@@ -100,7 +86,7 @@ done
 
 ## Building your changes to Yesod
 
-Yesod is composed of 4 "mega-repos", each with multiple cabal packages. `./script/install` will run tests against each package and install each package.
+The traditional Yesod stack requires 4 "mega-repos", each with multiple cabal packages. `./script/install` will run tests against each package and install each package.
 
 ### install package in all repos
 

package-list.sh

@@ -1,15 +0,0 @@
-#!/bin/bash
-
-pkgs=(      ./yesod-routes
-            ./yesod-core
-            ./yesod-json
-            ./crypto-conduit
-            ./authenticate/authenticate
-            ./yesod-static
-            ./yesod-persistent
-            ./yesod-newsfeed
-            ./yesod-form
-            ./yesod-auth
-            ./yesod-sitemap
-            ./yesod-default
-            ./yesod )

scripts

@@ -1 +0,0 @@
-Subproject commit 9902ff808afbcb417c6ad125941343878e3afe11

sources.txt

@@ -9,3 +9,5 @@
 ./yesod-test
 ./yesod-bin
 ./yesod
+./yesod-eventsource
+./yesod-websockets

yesod-auth-oauth/Yesod/Auth/OAuth.hs

@@ -43,6 +43,7 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
     url = PluginR name []
     lookupTokenSecret = bsToText . fromMaybe "" . lookup "oauth_token_secret" . unCredential
     oauthSessionName = "__oauth_token_secret"
+
     dispatch "GET" ["forward"] = do
         render <- lift getUrlRender
         tm <- getRouteToParent
@@ -72,8 +73,9 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login
       master <- getYesod
       accTok <- getAccessToken oauth reqTok (authHttpManager master)
       creds  <- liftIO $ mkCreds accTok
-      setCreds True creds
+      setCredsRedirect creds
     dispatch _ _ = notFound
+
     login tm = do
         render <- getUrlRender
         let oaUrl = render $ tm $ oauthUrl name

yesod-auth-oauth/yesod-auth-oauth.cabal

@@ -1,9 +1,9 @@
 name:            yesod-auth-oauth
-version:         1.2.0
+version:         1.3.0
 license:         BSD3
 license-file:    LICENSE
 author:          Hiromi Ishii
-maintainer:      Hiromi Ishii
+maintainer:      Michael Litchard
 synopsis:        OAuth Authentication for Yesod.
 category:        Web, Yesod
 stability:       Stable
@@ -20,13 +20,13 @@ library
         cpp-options:     -DGHC7
     else
         build-depends:   base                >= 4         && < 4.3
-    build-depends:   authenticate-oauth      >= 1.4       && < 1.5
+    build-depends:   authenticate-oauth      >= 1.5       && < 1.6
                    , bytestring              >= 0.9.1.4
                    , yesod-core              >= 1.2       && < 1.3
-                   , yesod-auth              >= 1.2       && < 1.3
+                   , yesod-auth              >= 1.3       && < 1.4
-                   , text                    >= 0.7       && < 0.12
+                   , text                    >= 0.7
                    , yesod-form              >= 1.3       && < 1.4
-                   , transformers            >= 0.2.2     && < 0.4
+                   , transformers            >= 0.2.2     && < 0.5
                    , lifted-base             >= 0.2       && < 0.3
     exposed-modules: Yesod.Auth.OAuth
     ghc-options:     -Wall

yesod-auth/Yesod/Auth.hs

@@ -22,6 +22,7 @@ module Yesod.Auth
       -- * Plugin interface
     , Creds (..)
     , setCreds
+    , setCredsRedirect
     , clearCreds
     , loginErrorMessage
     , loginErrorMessageI
@@ -34,6 +35,11 @@ module Yesod.Auth
     , AuthException (..)
       -- * Helper
     , AuthHandler
+      -- * Internal
+    , credsKey
+    , provideJsonMessage
+    , messageJson401
+    , asHtml
     ) where
 
 import Control.Monad                 (when)
@@ -62,6 +68,7 @@ import Control.Exception (Exception)
 import Network.HTTP.Types          (unauthorized401)
 import Control.Monad.Trans.Resource (MonadResourceBase)
 import qualified Control.Monad.Trans.Writer    as Writer
+import Control.Monad (void)
 
 type AuthRoute = Route Auth
 
@@ -72,7 +79,7 @@ type Piece = Text
 
 data AuthPlugin master = AuthPlugin
     { apName :: Text
-    , apDispatch :: Method -> [Piece] -> AuthHandler master ()
+    , apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent
     , apLogin :: (Route Auth -> Route master) -> WidgetT master IO ()
     }
 
@@ -89,6 +96,10 @@ data Creds master = Creds
 class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage) => YesodAuth master where
     type AuthId master
 
+    -- | specify the layout. Uses defaultLayout by default
+    authLayout :: WidgetT master IO () -> HandlerT master IO Html
+    authLayout = defaultLayout
+
     -- | Default destination on successful login, if no other
     -- destination exists.
     loginDest :: master -> Route master
@@ -104,10 +115,10 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
     authPlugins :: master -> [AuthPlugin master]
 
     -- | What to show on the login page.
-    loginHandler :: AuthHandler master RepHtml
+    loginHandler :: AuthHandler master Html
     loginHandler = do
         tp <- getRouteToParent
-        lift $ defaultLayout $ do
+        lift $ authLayout $ do
             setTitleI Msg.LoginTitle
             master <- getYesod
             mapM_ (flip apLogin tp) (authPlugins master)
@@ -163,6 +174,16 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
         => HandlerT master IO (Maybe (AuthId master))
     maybeAuthId = defaultMaybeAuthId
 
+    -- | Called on login error for HTTP requests. By default, calls
+    -- @setMessage@ and redirects to @dest@.
+    onErrorHtml :: (MonadResourceBase m) => Route master -> Text -> HandlerT master m Html
+    onErrorHtml dest msg = do
+        setMessage $ toHtml msg
+        fmap asHtml $ redirect dest
+
+-- | Internal session key used to hold the authentication information.
+--
+-- Since 1.2.3
 credsKey :: Text
 credsKey = "_ID"
 
@@ -212,7 +233,7 @@ cachedAuth aid = runMaybeT $ do
 loginErrorMessageI :: (MonadResourceBase m, YesodAuth master)
                    => Route child
                    -> AuthMessage
-                   -> HandlerT child (HandlerT master m) a
+                   -> HandlerT child (HandlerT master m) TypedContent
 loginErrorMessageI dest msg = do
   toParent <- getRouteToParent
   lift $ loginErrorMessageMasterI (toParent dest) msg
@@ -221,61 +242,74 @@ loginErrorMessageI dest msg = do
 loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage)
          => Route master
          -> AuthMessage
-         -> HandlerT master m a
+         -> HandlerT master m TypedContent
 loginErrorMessageMasterI dest msg = do
   mr <- getMessageRender
   loginErrorMessage dest (mr msg)
 
 -- | For HTML, set the message and redirect to the route.
 -- For JSON, send the message and a 401 status
-loginErrorMessage :: MonadResourceBase m
+loginErrorMessage :: (YesodAuth master, MonadResourceBase m)
-         => Route site
+         => Route master
          -> Text
-         -> HandlerT site m a
+         -> HandlerT master m TypedContent
-loginErrorMessage dest msg =
+loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)
-  sendResponseStatus unauthorized401 =<< (
+
-    selectRep $ do
+messageJson401 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent
-      provideRep $ do
+messageJson401 msg html = selectRep $ do
-          setMessage $ toHtml msg
+    provideRep html
-          fmap asHtml $ redirect dest
+    provideRep $ do
-      provideJsonMessage msg
+        let obj = object ["message" .= msg]
-  )
+        void $ sendResponseStatus unauthorized401 obj
-  where
+        return obj
-    asHtml :: Html -> Html
-    asHtml = id
 
 provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) ()
 provideJsonMessage msg = provideRep $ return $ object ["message" .= msg]
 
 
+setCredsRedirect :: YesodAuth master
+         => Creds master -- ^ new credentials
+         -> HandlerT master IO TypedContent
+setCredsRedirect creds = do
+    y    <- getYesod
+    maid <- getAuthId creds
+    case maid of
+        Nothing ->
+            case authRoute y of
+                Nothing -> do
+                    messageJson401 "Invalid Login" $ authLayout $
+                        toWidget [shamlet|<h1>Invalid login|]
+                Just ar -> loginErrorMessageMasterI ar Msg.InvalidLogin
+        Just aid -> do
+            setSession credsKey $ toPathPiece aid
+            onLogin
+            res <- selectRep $ do
+                provideRepType typeHtml $
+                    fmap asHtml $ redirectUltDest $ loginDest y
+                provideJsonMessage "Login Successful"
+            sendResponse res
+
 -- | Sets user credentials for the session after checking them with authentication backends.
 setCreds :: YesodAuth master
          => Bool         -- ^ if HTTP redirects should be done
          -> Creds master -- ^ new credentials
          -> HandlerT master IO ()
-setCreds doRedirects creds = do
+setCreds doRedirects creds =
-    y    <- getYesod
+    if doRedirects
-    maid <- getAuthId creds
+      then void $ setCredsRedirect creds
-    case maid of
+      else do maid <- getAuthId creds
-        Nothing -> when doRedirects $ do
+              case maid of
-            case authRoute y of
+                  Nothing -> return ()
-                Nothing -> do
+                  Just aid -> setSession credsKey $ toPathPiece aid
-                    sendResponseStatus unauthorized401 =<< (
+
-                      selectRep $ do
+-- | same as defaultLayoutJson, but uses authLayout
-                        provideRep $ defaultLayout $ toWidget [shamlet|<h1>Invalid login|]
+authLayoutJson :: (YesodAuth site, ToJSON j)
-                        provideJsonMessage "Invalid Login"
+                  => WidgetT site IO ()  -- ^ HTML
-                      )
+                  -> HandlerT site IO j  -- ^ JSON
-                Just ar -> loginErrorMessageMasterI ar Msg.InvalidLogin
+                  -> HandlerT site IO TypedContent
-        Just aid -> do
+authLayoutJson w json = selectRep $ do
-            setSession credsKey $ toPathPiece aid
+    provideRep $ authLayout w
-            when doRedirects $ do
+    provideRep $ fmap toJSON json
-              onLogin
-              res <- selectRep $ do
-                  provideRepType typeHtml $ do
-                      _ <- redirectUltDest $ loginDest y
-                      return ()
-                  provideJsonMessage "Login Successful"
-              sendResponse res
 
 -- | Clears current user credentials for the session.
 --
@@ -293,7 +327,7 @@ clearCreds doRedirects = do
 getCheckR :: AuthHandler master TypedContent
 getCheckR = lift $ do
     creds <- maybeAuthId
-    defaultLayoutJson (do
+    authLayoutJson (do
         setTitle "Authentication Status"
         toWidget $ html' creds) (return $ jsonCreds creds)
   where
@@ -316,7 +350,7 @@ setUltDestReferer' = lift $ do
     master <- getYesod
     when (redirectToReferer master) setUltDestReferer
 
-getLoginR :: AuthHandler master RepHtml
+getLoginR :: AuthHandler master Html
 getLoginR = setUltDestReferer' >> loginHandler
 
 getLogoutR :: AuthHandler master ()
@@ -325,7 +359,7 @@ getLogoutR = setUltDestReferer' >> redirectToPost LogoutR
 postLogoutR :: AuthHandler master ()
 postLogoutR = lift $ clearCreds True
 
-handlePluginR :: Text -> [Text] -> AuthHandler master ()
+handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent
 handlePluginR plugin pieces = do
     master <- lift getYesod
     env <- waiRequest
@@ -334,6 +368,11 @@ handlePluginR plugin pieces = do
         [] -> notFound
         ap:_ -> apDispatch ap method pieces
 
+-- | Similar to 'maybeAuthId', but additionally look up the value associated
+-- with the user\'s database identifier to get the value in the database. This
+-- assumes that you are using a Persistent database.
+--
+-- Since 1.1.0
 maybeAuth :: ( YesodAuth master
              , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val
              , b ~ YesodPersistBackend master
@@ -383,6 +422,10 @@ type AuthEntity master = KeyEntity (AuthId master)
 requireAuthId :: YesodAuthPersist master => HandlerT master IO (AuthId master)
 requireAuthId = maybeAuthId >>= maybe redirectLogin return
 
+-- | Similar to 'maybeAuth', but redirects to a login page if user is not
+-- authenticated.
+--
+-- Since 1.1.0
 requireAuth :: YesodAuthPersist master => HandlerT master IO (Entity (AuthEntity master))
 requireAuth = maybeAuth >>= maybe redirectLogin return
 
@@ -403,3 +446,6 @@ instance Exception AuthException
 
 instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where
     yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)
+
+asHtml :: Html -> Html
+asHtml = id

yesod-auth/Yesod/Auth/BrowserId.hs

@@ -4,7 +4,7 @@
 {-# LANGUAGE RecordWildCards #-}
 module Yesod.Auth.BrowserId
     ( authBrowserId
-    , createOnClick
+    , createOnClick, createOnClickOverride
     , def
     , BrowserIdSettings
     , bisAudience
@@ -75,8 +75,9 @@ authBrowserId bis@BrowserIdSettings {..} = AuthPlugin
                 case memail of
                     Nothing -> do
                       $logErrorS "yesod-auth" "BrowserID assertion failure"
-                      loginErrorMessage LoginR "BrowserID login error."
+                      tm <- getRouteToParent
-                    Just email -> lift $ setCreds True Creds
+                      lift $ loginErrorMessage (tm LoginR) "BrowserID login error."
+                    Just email -> lift $ setCredsRedirect Creds
                         { credsPlugin = pid
                         , credsIdent = email
                         , credsExtra = []
@@ -106,14 +107,16 @@ $newline never
 
 -- | Generates a function to handle on-click events, and returns that function
 -- name.
-createOnClick :: BrowserIdSettings
+createOnClickOverride :: BrowserIdSettings
               -> (Route Auth -> Route master)
+              -> Maybe (Route master)
               -> WidgetT master IO Text
-createOnClick BrowserIdSettings {..} toMaster = do
+createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do
     unless bisLazyLoad $ addScriptRemote browserIdJs
     onclick <- newIdent
     render <- getUrlRender
-    let login = toJSON $ getPath $ render (toMaster LoginR)
+    let login = toJSON $ getPath $ render loginRoute -- (toMaster LoginR)
+        loginRoute = maybe (toMaster LoginR) id mOnRegistration
     toWidget [julius|
         function #{rawJS onclick}() {
             if (navigator.id) {
@@ -151,3 +154,10 @@ createOnClick BrowserIdSettings {..} toMaster = do
     getPath t = fromMaybe t $ do
         uri <- parseURI $ T.unpack t
         return $ T.pack $ uriPath uri
+
+-- | Generates a function to handle on-click events, and returns that function
+-- name.
+createOnClick :: BrowserIdSettings
+              -> (Route Auth -> Route master)
+              -> WidgetT master IO Text
+createOnClick bidSettings toMaster = createOnClickOverride bidSettings toMaster Nothing

yesod-auth/Yesod/Auth/Dummy.hs

@@ -18,7 +18,7 @@ authDummy =
   where
     dispatch "POST" [] = do
         ident <- lift $ runInputPost $ ireq textField "ident"
-        lift $ setCreds True $ Creds "dummy" ident []
+        lift $ setCredsRedirect $ Creds "dummy" ident []
     dispatch _ _ = notFound
     url = PluginR "dummy" []
     login authToMaster =

yesod-auth/Yesod/Auth/Email.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE Rank2Types #-}
 module Yesod.Auth.Email
     ( -- * Plugin
       authEmail
@@ -24,25 +25,32 @@ module Yesod.Auth.Email
      -- * Misc
     , loginLinkKey
     , setLoginLinkKey
+     -- * Default handlers
+    , defaultRegisterHandler
+    , defaultForgotPasswordHandler
+    , defaultSetPasswordHandler
     ) where
 
 import Network.Mail.Mime (randomString)
 import Yesod.Auth
 import System.Random
-import Data.Digest.Pure.MD5
 import qualified Data.Text as TS
+import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Encoding as TE
 import qualified Data.Text.Lazy.Encoding as TLE
+import qualified Crypto.Hash.MD5 as H
+import Data.ByteString.Base16 as B16
 import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
 import Data.Text (Text)
 import Yesod.Core
-import qualified Crypto.PasswordStore as PS
+import qualified Yesod.PasswordStore as PS
 import qualified Text.Email.Validate
 import qualified Yesod.Auth.Message as Msg
 import Control.Applicative ((<$>), (<*>))
+import Control.Monad (void)
 import Yesod.Form
-import Control.Monad (when)
 import Data.Time (getCurrentTime, addUTCTime)
 import Safe (readMay)
 
@@ -78,7 +86,11 @@ data EmailCreds site = EmailCreds
     , emailCredsEmail :: Email
     }
 
-class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site where
+class ( YesodAuth site
+      , PathPiece (AuthEmailId site)
+      , (RenderMessage site Msg.AuthMessage)
+      )
+  => YesodAuthEmail site where
     type AuthEmailId site
 
     -- | Add a new email address to the database, but indicate that the address
@@ -164,6 +176,63 @@ class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site wher
         | TS.length x >= 3 = return $ Right ()
         | otherwise = return $ Left "Password must be at least three characters"
 
+    -- | Response after sending a confirmation email.
+    --
+    -- Since 1.2.2
+    confirmationEmailSentResponse :: Text -> HandlerT site IO TypedContent
+    confirmationEmailSentResponse identifier = do
+        mr <- getMessageRender
+        messageJson401 (mr msg) $ authLayout $ do
+              setTitleI Msg.ConfirmationEmailSentTitle
+              [whamlet|<p>_{msg}|]
+      where
+        msg = Msg.ConfirmationEmailSent identifier
+
+    -- | Additional normalization of email addresses, besides standard canonicalization.
+    --
+    -- Default: Lower case the email address.
+    --
+    -- Since 1.2.3
+    normalizeEmailAddress :: site -> Text -> Text
+    normalizeEmailAddress _ = TS.toLower
+
+    -- | Handler called to render the registration page.  The
+    -- default works fine, but you may want to override it in
+    -- order to have a different DOM.
+    --
+    -- Default: 'defaultRegisterHandler'.
+    --
+    -- Since: 1.2.6.
+    registerHandler :: AuthHandler site Html
+    registerHandler = defaultRegisterHandler
+
+    -- | Handler called to render the \"forgot password\" page.
+    -- The default works fine, but you may want to override it in
+    -- order to have a different DOM.
+    --
+    -- Default: 'defaultForgotPasswordHandler'.
+    --
+    -- Since: 1.2.6.
+    forgotPasswordHandler :: AuthHandler site Html
+    forgotPasswordHandler = defaultForgotPasswordHandler
+
+    -- | Handler called to render the \"set password\" page.  The
+    -- default works fine, but you may want to override it in
+    -- order to have a different DOM.
+    --
+    -- Default: 'defaultSetPasswordHandler'.
+    --
+    -- Since: 1.2.6.
+    setPasswordHandler ::
+         Bool
+         -- ^ Whether the old password is needed.  If @True@, a
+         -- field for the old password should be presented.
+         -- Otherwise, just two fields for the new password are
+         -- needed.
+      -> AuthHandler site TypedContent
+    setPasswordHandler = defaultSetPasswordHandler
+
+
 authEmail :: YesodAuthEmail m => AuthPlugin m
 authEmail =
     AuthPlugin "email" dispatch $ \tm ->
@@ -181,8 +250,11 @@ $newline never
                 <input type="password" name="password">
         <tr>
             <td colspan="2">
-                <input type="submit" value=_{Msg.LoginViaEmail}>
+                <button type=submit .btn .btn-success>
-                <a href="@{tm registerR}">I don't have an account
+                    _{Msg.LoginViaEmail}
+                &nbsp;
+                <a href="@{tm registerR}" .btn .btn-default>
+                    _{Msg.RegisterLong}
 |]
   where
     dispatch "GET" ["register"] = getRegisterR >>= sendResponse
@@ -199,10 +271,16 @@ $newline never
     dispatch _ _ = notFound
 
 getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
-getRegisterR = do
+getRegisterR = registerHandler
+
+-- | Default implementation of 'registerHandler'.
+--
+-- Since: 1.2.6
+defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html
+defaultRegisterHandler = do
     email <- newIdent
     tp <- getRouteToParent
-    lift $ defaultLayout $ do
+    lift $ authLayout $ do
         setTitleI Msg.RegisterLong
         [whamlet|
             <p>_{Msg.EnterEmail}
@@ -216,51 +294,59 @@ getRegisterR = do
 registerHelper :: YesodAuthEmail master
                => Bool -- ^ allow usernames?
                -> Route Auth
-               -> HandlerT Auth (HandlerT master IO) Html
+               -> HandlerT Auth (HandlerT master IO) TypedContent
 registerHelper allowUsername dest = do
     y <- lift getYesod
     midentifier <- lookupPostParam "email"
-    identifier <-
+    let eidentifier = case midentifier of
-        case midentifier of
+            Nothing -> Left Msg.NoIdentifierProvided
-            Nothing -> do
-                loginErrorMessageI dest Msg.NoIdentifierProvided
             Just x
                 | Just x' <- Text.Email.Validate.canonicalizeEmail (encodeUtf8 x) ->
-                    return $ decodeUtf8With lenientDecode x'
+                    Right $ normalizeEmailAddress y $ decodeUtf8With lenientDecode x'
-                | allowUsername -> return $ TS.strip x
+                | allowUsername -> Right $ TS.strip x
-                | otherwise -> do
+                | otherwise -> Left Msg.InvalidEmailAddress
-                    loginErrorMessageI dest Msg.InvalidEmailAddress
-    mecreds <- lift $ getEmailCreds identifier
-    (lid, verKey, email) <-
-        case mecreds of
-            Just (EmailCreds lid _ _ (Just key) email) -> return (lid, key, email)
-            Just (EmailCreds lid _ _ Nothing email) -> do
-                key <- liftIO $ randomKey y
-                lift $ setVerifyKey lid key
-                return (lid, key, email)
-            Nothing
-                | allowUsername -> do
-                    setMessage $ toHtml $ "No record for that identifier in our database: " `TS.append` identifier
-                    redirect dest
-                | otherwise -> do
-                    key <- liftIO $ randomKey y
-                    lid <- lift $ addUnverified identifier key
-                    return (lid, key, identifier)
-    render <- getUrlRender
-    let verUrl = render $ verify (toPathPiece lid) verKey
-    lift $ sendVerifyEmail email verKey verUrl
-    lift $ defaultLayout $ do
-        setTitleI Msg.ConfirmationEmailSentTitle
-        [whamlet|<p>_{Msg.ConfirmationEmailSent identifier}|]
 
-postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
+    case eidentifier of
+        Left route -> loginErrorMessageI dest route
+        Right identifier -> do
+
+            mecreds <- lift $ getEmailCreds identifier
+            registerCreds <-
+                case mecreds of
+                    Just (EmailCreds lid _ _ (Just key) email) -> return $ Just (lid, key, email)
+                    Just (EmailCreds lid _ _ Nothing email) -> do
+                        key <- liftIO $ randomKey y
+                        lift $ setVerifyKey lid key
+                        return $ Just (lid, key, email)
+                    Nothing
+                        | allowUsername -> return Nothing
+                        | otherwise -> do
+                            key <- liftIO $ randomKey y
+                            lid <- lift $ addUnverified identifier key
+                            return $ Just (lid, key, identifier)
+
+            case registerCreds of
+                Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier)
+                Just (lid, verKey, email) -> do
+                    render <- getUrlRender
+                    let verUrl = render $ verify (toPathPiece lid) verKey
+                    lift $ sendVerifyEmail email verKey verUrl
+                    lift $ confirmationEmailSentResponse identifier
+
+postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
 postRegisterR = registerHelper False registerR
 
 getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
-getForgotPasswordR = do
+getForgotPasswordR = forgotPasswordHandler
+
+-- | Default implementation of 'forgotPasswordHandler'.
+--
+-- Since: 1.2.6
+defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html
+defaultForgotPasswordHandler = do
     tp <- getRouteToParent
     email <- newIdent
-    lift $ defaultLayout $ do
+    lift $ authLayout $ do
         setTitleI Msg.PasswordResetTitle
         [whamlet|
             <p>_{Msg.PasswordResetPrompt}
@@ -271,35 +357,43 @@ getForgotPasswordR = do
                 <button .btn>_{Msg.SendPasswordResetEmail}
         |]
 
-postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
+postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
 postForgotPasswordR = registerHelper True forgotPasswordR
 
 getVerifyR :: YesodAuthEmail site
            => AuthEmailId site
            -> Text
-           -> HandlerT Auth (HandlerT site IO) Html
+           -> HandlerT Auth (HandlerT site IO) TypedContent
 getVerifyR lid key = do
     realKey <- lift $ getVerifyKey lid
     memail <- lift $ getEmail lid
+    mr <- lift getMessageRender
     case (realKey == Just key, memail) of
         (True, Just email) -> do
             muid <- lift $ verifyAccount lid
             case muid of
-                Nothing -> return ()
+                Nothing -> invalidKey mr
                 Just uid -> do
                     lift $ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?
-                    lift $ setMessageI Msg.AddressVerified
                     lift $ setLoginLinkKey uid
-                    redirect setpassR
+                    let msgAv = Msg.AddressVerified
-        _ -> return ()
+                    selectRep $ do
-    lift $ defaultLayout $ do
+                      provideRep $ do
-        setTitleI Msg.InvalidKey
+                        lift $ setMessageI msgAv
+                        fmap asHtml $ redirect setpassR
+                      provideJsonMessage $ mr msgAv
+        _ -> invalidKey mr
+  where
+    msgIk = Msg.InvalidKey
+    invalidKey mr = messageJson401 (mr msgIk) $ lift $ authLayout $ do
+        setTitleI msgIk
         [whamlet|
 $newline never
-<p>_{Msg.InvalidKey}
+<p>_{msgIk}
 |]
 
-postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) ()
+
+postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
 postLoginR = do
     (identifier, pass) <- lift $ runInputPost $ (,)
         <$> ireq textField "email"
@@ -322,30 +416,40 @@ postLoginR = do
     let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier
     case maid of
         Just email ->
-            lift $ setCreds True $ Creds
+            lift $ setCredsRedirect $ Creds
                 (if isEmail then "email" else "username")
                 email
                 [("verifiedEmail", email)]
-        Nothing -> do
+        Nothing ->
             loginErrorMessageI LoginR $
                 if isEmail
                     then Msg.InvalidEmailPass
                     else Msg.InvalidUsernamePass
 
-getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
+getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
 getPasswordR = do
     maid <- lift maybeAuthId
+    case maid of
+        Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
+        Just _ -> do
+            needOld <- maybe (return True) (lift . needOldPassword) maid
+            setPasswordHandler needOld
+
+-- | Default implementation of 'setPasswordHandler'.
+--
+-- Since: 1.2.6
+defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent
+defaultSetPasswordHandler needOld = do
+    tp <- getRouteToParent
     pass0 <- newIdent
     pass1 <- newIdent
     pass2 <- newIdent
-    case maid of
+    mr <- lift getMessageRender
-        Just _ -> return ()
+    selectRep $ do
-        Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
+      provideJsonMessage $ mr Msg.SetPass
-    tp <- getRouteToParent
+      provideRep $ lift $ authLayout $ do
-    needOld <- maybe (return True) (lift . needOldPassword) maid
+          setTitleI Msg.SetPassTitle
-    lift $ defaultLayout $ do
+          [whamlet|
-        setTitleI Msg.SetPassTitle
-        [whamlet|
 $newline never
 <h3>_{Msg.SetPass}
 <form method="post" action="@{tp setpassR}">
@@ -371,41 +475,52 @@ $newline never
                 <input type="submit" value=_{Msg.SetPassTitle}>
 |]
 
-postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) ()
+postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
 postPasswordR = do
     maid <- lift maybeAuthId
-    aid <- case maid of
+    case maid of
-            Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
+        Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
-            Just aid -> return aid
+        Just aid -> do
+            tm <- getRouteToParent
 
-    needOld <- lift $ needOldPassword aid
+            needOld <- lift $ needOldPassword aid
-    when needOld $ do
+            if not needOld then confirmPassword aid tm else do
-        current <- lift $ runInputPost $ ireq textField "current"
+                current <- lift $ runInputPost $ ireq textField "current"
-        mrealpass <- lift $ getPassword aid
+                mrealpass <- lift $ getPassword aid
-        case mrealpass of
+                case mrealpass of
-            Nothing -> loginErrorMessage setpassR "You do not currently have a password set on your account"
+                    Nothing ->
-            Just realpass
+                        lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"
-                | isValidPass current realpass -> return ()
+                    Just realpass
-                | otherwise -> loginErrorMessage setpassR "Invalid current password, please try again"
+                        | isValidPass current realpass -> confirmPassword aid tm
+                        | otherwise ->
+                            lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
 
-    (new, confirm) <- lift $ runInputPost $ (,)
+  where
-        <$> ireq textField "new"
+    msgOk = Msg.PassUpdated
-        <*> ireq textField "confirm"
+    confirmPassword aid tm = do
-    when (new /= confirm) $
+        (new, confirm) <- lift $ runInputPost $ (,)
-        loginErrorMessageI setpassR Msg.PassMismatch
+            <$> ireq textField "new"
+            <*> ireq textField "confirm"
 
-    isSecure <- lift $ checkPasswordSecurity aid new
+        if new /= confirm
-    case isSecure of
+          then loginErrorMessageI setpassR Msg.PassMismatch
-        Left e -> loginErrorMessage setpassR e
+          else do
-        Right () -> return ()
+              isSecure <- lift $ checkPasswordSecurity aid new
+              case isSecure of
+                  Left e -> lift $ loginErrorMessage (tm setpassR) e
+                  Right () -> do
+                      salted <- liftIO $ saltPass new
+                      y <- lift $ do
+                          setPassword aid salted
+                          deleteSession loginLinkKey
+                          setMessageI msgOk
+                          getYesod
 
-    salted <- liftIO $ saltPass new
+                      mr <- lift getMessageRender
-    lift $ do
+                      selectRep $ do
-        y <- getYesod
+                        provideRep $
-        setPassword aid salted
+                          fmap asHtml $ lift $ redirect $ afterPasswordRoute y
-        setMessageI Msg.PassUpdated
+                        provideJsonMessage (mr msgOk)
-        deleteSession loginLinkKey
-        redirect $ afterPasswordRoute y
 
 saltLength :: Int
 saltLength = 5
@@ -413,11 +528,12 @@ saltLength = 5
 -- | Salt a password with a randomly generated salt.
 saltPass :: Text -> IO Text
 saltPass = fmap (decodeUtf8With lenientDecode)
-         . flip PS.makePassword 12
+         . flip PS.makePassword 14
          . encodeUtf8
 
 saltPass' :: String -> String -> String
-saltPass' salt pass = salt ++ show (md5 $ TLE.encodeUtf8 $ TL.pack $ salt ++ pass)
+saltPass' salt pass =
+    salt ++ T.unpack (TE.decodeUtf8 $ B16.encode $ H.hash $ TE.encodeUtf8 $ T.pack $ salt ++ pass)
 
 isValidPass :: Text -- ^ cleartext password
             -> SaltedPass -- ^ salted password

yesod-auth/Yesod/Auth/GoogleEmail.hs

@@ -54,7 +54,9 @@ authGoogleEmail =
             , ("openid.ui.icon", "true")
             ] (authHttpManager master)
         either
-          (\err -> loginErrorMessage LoginR $ T.pack $ show (err :: SomeException))
+          (\err -> do
+            tm <- getRouteToParent
+            lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException))
           redirect
           eres
     dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
@@ -67,17 +69,19 @@ authGoogleEmail =
         completeHelper posts
     dispatch _ _ = notFound
 
-completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master ()
+completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master TypedContent
 completeHelper gets' = do
       master <- lift getYesod
       eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
-      either onFailure onSuccess eres
+      tm <- getRouteToParent
+      either (onFailure tm) (onSuccess tm) eres
     where
-      onFailure err = loginErrorMessage LoginR $ T.pack $ show (err :: SomeException)
+      onFailure tm err =
-      onSuccess oir = do
+        lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException)
+      onSuccess tm oir = do
               let OpenId.Identifier ident = OpenId.oirOpLocal oir
               memail <- lookupGetParam "openid.ext1.value.email"
               case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of
-                  (Just email, True) -> lift $ setCreds True $ Creds pid email []
+                  (Just email, True) -> lift $ setCredsRedirect $ Creds pid email []
-                  (_, False)   -> loginErrorMessage LoginR "Only Google login is supported"
+                  (_, False)   -> lift $ loginErrorMessage (tm LoginR) "Only Google login is supported"
-                  (Nothing, _) -> loginErrorMessage LoginR "No email address provided"
+                  (Nothing, _) -> lift $ loginErrorMessage (tm LoginR) "No email address provided"

yesod-auth/Yesod/Auth/GoogleEmail2.hs

@@ -0,0 +1,202 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+-- | Use an email address as an identifier via Google's login system.
+--
+-- Note that this is a replacement for "Yesod.Auth.GoogleEmail", which depends
+-- on Google's now deprecated OpenID system. For more information, see
+-- <https://developers.google.com/+/api/auth-migration>.
+--
+-- By using this plugin, you are trusting Google to validate an email address,
+-- and requiring users to have a Google account. On the plus side, you get to
+-- use email addresses as the identifier, many users have existing Google
+-- accounts, the login system has been long tested (as opposed to BrowserID),
+-- and it requires no credential managing or setup (as opposed to Email).
+--
+-- In order to use this plugin:
+--
+-- * Create an application on the Google Developer Console <https://console.developers.google.com/>
+--
+-- * Create OAuth credentials. The redirect URI will be <http://yourdomain/auth/page/googleemail2/complete>. (If you have your authentication subsite at a different root than \/auth\/, please adjust accordingly.)
+--
+-- * Enable the Google+ API.
+--
+-- Since 1.3.1
+module Yesod.Auth.GoogleEmail2
+    ( authGoogleEmail
+    , forwardUrl
+    ) where
+
+import           Blaze.ByteString.Builder (fromByteString, toByteString)
+import           Control.Applicative      ((<$>), (<*>))
+import           Control.Arrow            (second)
+import           Control.Monad            (liftM, unless)
+import           Data.Aeson.Parser        (json')
+import           Data.Aeson.Types         (FromJSON (parseJSON), parseEither,
+                                           withObject)
+import           Data.Conduit             (($$+-))
+import           Data.Conduit.Attoparsec  (sinkParser)
+import           Data.Monoid              (mappend)
+import           Data.Text                (Text)
+import qualified Data.Text                as T
+import           Data.Text.Encoding       (decodeUtf8, encodeUtf8)
+import           Network.HTTP.Client      (parseUrl, requestHeaders,
+                                           responseBody, urlEncodedBody)
+import           Network.HTTP.Conduit     (http)
+import           Network.HTTP.Types       (renderQueryText)
+import           Network.Mail.Mime        (randomString)
+import           System.Random            (newStdGen)
+import           Yesod.Auth               (Auth, AuthPlugin (AuthPlugin),
+                                           AuthRoute, Creds (Creds),
+                                           Route (PluginR), YesodAuth,
+                                           authHttpManager, setCredsRedirect)
+import qualified Yesod.Auth.Message       as Msg
+import           Yesod.Core               (HandlerSite, MonadHandler,
+                                           getRouteToParent, getUrlRender,
+                                           getYesod, invalidArgs, lift,
+                                           lookupGetParam,
+                                           lookupSession, notFound, redirect,
+                                           setSession, whamlet, (.:),
+                                           TypedContent, HandlerT, liftIO)
+
+pid :: Text
+pid = "googleemail2"
+
+forwardUrl :: AuthRoute
+forwardUrl = PluginR pid ["forward"]
+
+csrfKey :: Text
+csrfKey = "_GOOGLE_CSRF_TOKEN"
+
+getCsrfToken :: MonadHandler m => m (Maybe Text)
+getCsrfToken = lookupSession csrfKey
+
+getCreateCsrfToken :: MonadHandler m => m Text
+getCreateCsrfToken = do
+    mtoken <- getCsrfToken
+    case mtoken of
+        Just token -> return token
+        Nothing -> do
+            stdgen <- liftIO newStdGen
+            let token = T.pack $ fst $ randomString 10 stdgen
+            setSession csrfKey token
+            return token
+
+authGoogleEmail :: YesodAuth m
+                => Text -- ^ client ID
+                -> Text -- ^ client secret
+                -> AuthPlugin m
+authGoogleEmail clientID clientSecret =
+    AuthPlugin pid dispatch login
+  where
+    complete = PluginR pid ["complete"]
+
+    getDest :: MonadHandler m
+            => (Route Auth -> Route (HandlerSite m))
+            -> m Text
+    getDest tm = do
+        csrf <- getCreateCsrfToken
+        render <- getUrlRender
+        let qs = map (second Just)
+                [ ("scope", "email")
+                , ("state", csrf)
+                , ("redirect_uri", render $ tm complete)
+                , ("response_type", "code")
+                , ("client_id", clientID)
+                , ("access_type", "offline")
+                ]
+        return $ decodeUtf8
+               $ toByteString
+               $ fromByteString "https://accounts.google.com/o/oauth2/auth"
+                    `mappend` renderQueryText True qs
+
+    login tm = do
+        url <- getDest tm
+        [whamlet|<a href=#{url}>_{Msg.LoginGoogle}|]
+
+    dispatch :: YesodAuth site
+             => Text
+             -> [Text]
+             -> HandlerT Auth (HandlerT site IO) TypedContent
+    dispatch "GET" ["forward"] = do
+        tm <- getRouteToParent
+        lift (getDest tm) >>= redirect
+
+    dispatch "GET" ["complete"] = do
+        mstate <- lookupGetParam "state"
+        case mstate of
+            Nothing -> invalidArgs ["CSRF state from Google is missing"]
+            Just state -> do
+                mtoken <- getCsrfToken
+                unless (Just state == mtoken) $ invalidArgs ["Invalid CSRF token from Google"]
+        mcode <- lookupGetParam "code"
+        code <-
+            case mcode of
+                Nothing -> invalidArgs ["Missing code paramter"]
+                Just c -> return c
+
+        render <- getUrlRender
+
+        req' <- liftIO $ parseUrl "https://accounts.google.com/o/oauth2/token" -- FIXME don't hardcode, use: https://accounts.google.com/.well-known/openid-configuration
+        let req =
+                urlEncodedBody
+                    [ ("code", encodeUtf8 code)
+                    , ("client_id", encodeUtf8 clientID)
+                    , ("client_secret", encodeUtf8 clientSecret)
+                    , ("redirect_uri", encodeUtf8 $ render complete)
+                    , ("grant_type", "authorization_code")
+                    ]
+                    req'
+                        { requestHeaders = []
+                        }
+        manager <- liftM authHttpManager $ lift getYesod
+        res <- http req manager
+        value <- responseBody res $$+- sinkParser json'
+        Tokens accessToken _idToken tokenType <-
+            case parseEither parseJSON value of
+                Left e -> error e
+                Right t -> return t
+
+        unless (tokenType == "Bearer") $ error $ "Unknown token type: " ++ show tokenType
+
+        req2' <- liftIO $ parseUrl "https://www.googleapis.com/plus/v1/people/me"
+        let req2 = req2'
+                { requestHeaders =
+                    [ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken)
+                    ]
+                }
+        res2 <- http req2 manager
+        value2 <- responseBody res2 $$+- sinkParser json'
+        Person emails <-
+            case parseEither parseJSON value2 of
+                Left e -> error e
+                Right x -> return x
+        email <-
+            case map emailValue $ filter (\e -> emailType e == "account") emails of
+                [e] -> return e
+                [] -> error "No account email"
+                x -> error $ "Too many account emails: " ++ show x
+        lift $ setCredsRedirect $ Creds pid email []
+
+    dispatch _ _ = notFound
+
+data Tokens = Tokens Text Text Text
+instance FromJSON Tokens where
+    parseJSON = withObject "Tokens" $ \o -> Tokens
+        <$> o .: "access_token"
+        <*> o .: "id_token"
+        <*> o .: "token_type"
+
+data Person = Person [Email]
+instance FromJSON Person where
+    parseJSON = withObject "Person" $ \o -> Person
+        <$> o .: "emails"
+
+data Email = Email
+    { emailValue :: Text
+    , emailType  :: Text
+    }
+    deriving Show
+instance FromJSON Email where
+    parseJSON = withObject "Email" $ \o -> Email
+        <$> o .: "value"
+        <*> o .: "type"

yesod-auth/Yesod/Auth/HashDB.hs

@@ -1,268 +0,0 @@
-{-# LANGUAGE QuasiQuotes                #-}
-{-# LANGUAGE ConstraintKinds            #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE TemplateHaskell            #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE GADTs                      #-}
-{-# LANGUAGE CPP                        #-}
--------------------------------------------------------------------------------
--- |
--- Module      :  Yesod.Auth.HashDB
--- Copyright   :  (c) Patrick Brisbin 2010 
--- License     :  as-is
---
--- Maintainer  :  pbrisbin@gmail.com
--- Stability   :  Stable
--- Portability :  Portable
---
--- A yesod-auth AuthPlugin designed to look users up in Persist where
--- their user id's and a salted SHA1 hash of their password is stored.
---
--- Example usage:
---
--- > -- import the function
--- > import Auth.HashDB
--- >
--- > -- make sure you have an auth route
--- > mkYesodData "MyApp" [$parseRoutes|
--- > / RootR GET
--- > /auth AuthR Auth getAuth
--- > |]
--- >
--- >
--- > -- make your app an instance of YesodAuth using this plugin
--- > instance YesodAuth MyApp where
--- >    type AuthId MyApp = UserId
--- >
--- >    loginDest _  = RootR
--- >    logoutDest _ = RootR
--- >    getAuthId    = getAuthIdHashDB AuthR (Just . UniqueUser)
--- >    authPlugins  = [authHashDB (Just . UniqueUser)]
--- >
--- >
--- > -- include the migration function in site startup
--- > withServer :: (Application -> IO a) -> IO a
--- > withServer f = withConnectionPool $ \p -> do
--- >     runSqlPool (runMigration migrateUsers) p
--- >     let h = DevSite p
---
--- Note that function which converts username to unique identifier must be same.
---
--- Your app must be an instance of YesodPersist. and the username,
--- salt and hashed-passwords should be added to the database.
---
--- > echo -n 'MySaltMyPassword' | sha1sum
---
--- can be used to get the hash from the commandline.
---
--------------------------------------------------------------------------------
-module Yesod.Auth.HashDB
-    ( HashDBUser(..)
-    , Unique (..)
-    , setPassword
-      -- * Authentification
-    , validateUser
-    , authHashDB
-    , getAuthIdHashDB
-      -- * Predefined data type
-    , User
-    , UserGeneric (..)
-    , UserId
-    , EntityField (..)
-    , migrateUsers
-    ) where
-
-import Yesod.Persist
-import Yesod.Form
-import Yesod.Auth
-import Yesod.Core
-import Text.Hamlet (hamlet)
-
-import Control.Applicative         ((<$>), (<*>))
-import Control.Monad               (replicateM,liftM)
-
-import qualified Data.ByteString.Lazy.Char8 as BS (pack)
-import Data.Digest.Pure.SHA        (sha1, showDigest)
-import Data.Text                   (Text, pack, unpack, append)
-import Data.Maybe                  (fromMaybe)
-import System.Random               (randomRIO)
--- | Interface for data type which holds user info. It's just a
---   collection of getters and setters
-class HashDBUser user where
-  -- | Retrieve password hash from user data
-  userPasswordHash :: user -> Maybe Text
-  -- | Retrieve salt for password
-  userPasswordSalt :: user -> Maybe Text
-
-  -- | Deprecated for the better named setSaltAndPasswordHash 
-  setUserHashAndSalt :: Text    -- ^ Salt
-                     -> Text    -- ^ Password hash
-                     -> user -> user
-  setUserHashAndSalt = setSaltAndPasswordHash
-
-  -- | a callback for setPassword
-  setSaltAndPasswordHash :: Text    -- ^ Salt
-                     -> Text    -- ^ Password hash
-                     -> user -> user
-  setSaltAndPasswordHash = setUserHashAndSalt
-
--- | Generate random salt. Length of 8 is chosen arbitrarily
-randomSalt :: MonadIO m => m Text
-randomSalt = pack `liftM` liftIO (replicateM 8 (randomRIO ('0','z')))
-
--- | Calculate salted hash using SHA1.
-saltedHash :: Text              -- ^ Salt
-           -> Text              -- ^ Password
-           -> Text
-saltedHash salt = 
-  pack . showDigest . sha1 . BS.pack . unpack . append salt
-
--- | Set password for user. This function should be used for setting
---   passwords. It generates random salt and calculates proper hashes.
-setPassword :: (MonadIO m, HashDBUser user) => Text -> user -> m user
-setPassword pwd u = do salt <- randomSalt
-                       return $ setSaltAndPasswordHash salt (saltedHash salt pwd) u
-
-
-----------------------------------------------------------------
--- Authentification
-----------------------------------------------------------------
-
--- | Given a user ID and password in plaintext, validate them against
---   the database values.
-validateUser :: ( YesodPersist yesod
-                , b ~ YesodPersistBackend yesod
-                , PersistMonadBackend (b (HandlerT yesod IO)) ~ PersistEntityBackend user
-                , PersistUnique (b (HandlerT yesod IO))
-                , PersistEntity user
-                , HashDBUser    user
-                ) => 
-                Unique user     -- ^ User unique identifier
-             -> Text            -- ^ Password in plaint-text
-             -> HandlerT yesod IO Bool
-validateUser userID passwd = do
-  -- Checks that hash and password match
-  let validate u = do hash <- userPasswordHash u
-                      salt <- userPasswordSalt u
-                      return $ hash == saltedHash salt passwd
-  -- Get user data
-  user <- runDB $ getBy userID
-  return $ fromMaybe False $ validate . entityVal =<< user
-
-
-login :: AuthRoute
-login = PluginR "hashdb" ["login"]
-
-
--- | Handle the login form. First parameter is function which maps
---   username (whatever it might be) to unique user ID.
-postLoginR :: ( YesodAuth y, YesodPersist y
-              , HashDBUser user, PersistEntity user
-              , b ~ YesodPersistBackend y
-              , PersistMonadBackend (b (HandlerT y IO)) ~ PersistEntityBackend user
-              , PersistUnique (b (HandlerT y IO))
-              )
-           => (Text -> Maybe (Unique user))
-           -> HandlerT Auth (HandlerT y IO) ()
-postLoginR uniq = do
-    (mu,mp) <- lift $ runInputPost $ (,)
-        <$> iopt textField "username"
-        <*> iopt textField "password"
-
-    isValid <- lift $ fromMaybe (return False) 
-                 (validateUser <$> (uniq =<< mu) <*> mp)
-    if isValid 
-       then lift $ setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
-       else loginErrorMessage LoginR "Invalid username/password"
-
-
--- | A drop in for the getAuthId method of your YesodAuth instance which
---   can be used if authHashDB is the only plugin in use.
-getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
-                   , HashDBUser user, PersistEntity user
-                   , Key user ~ AuthId master
-                   , b ~ YesodPersistBackend master
-                   , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend user
-                   , PersistUnique (b (HandlerT master IO))
-                   )
-                => (AuthRoute -> Route master)   -- ^ your site's Auth Route
-                -> (Text -> Maybe (Unique user)) -- ^ gets user ID
-                -> Creds master                  -- ^ the creds argument
-                -> HandlerT master IO (Maybe (AuthId master))
-getAuthIdHashDB authR uniq creds = do
-    muid <- maybeAuthId
-    case muid of
-        -- user already authenticated
-        Just uid -> return $ Just uid
-        Nothing       -> do
-            x <- case uniq (credsIdent creds) of
-                   Nothing -> return Nothing
-                   Just u  -> runDB (getBy u)
-            case x of
-                -- user exists
-                Just (Entity uid _) -> return $ Just uid
-                Nothing       -> loginErrorMessage (authR LoginR) "User not found"
-
--- | Prompt for username and password, validate that against a database
---   which holds the username and a hash of the password
-authHashDB :: ( YesodAuth m, YesodPersist m
-              , HashDBUser user
-              , PersistEntity user
-              , b ~ YesodPersistBackend m
-              , PersistMonadBackend (b (HandlerT m IO)) ~ PersistEntityBackend user
-              , PersistUnique (b (HandlerT m IO)))
-           => (Text -> Maybe (Unique user)) -> AuthPlugin m
-authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> toWidget [hamlet|
-$newline never
-    <div id="header">
-        <h1>Login
-
-    <div id="login">
-        <form method="post" action="@{tm login}">
-            <table>
-                <tr>
-                    <th>Username:
-                    <td>
-                        <input id="x" name="username" autofocus="" required>
-                <tr>
-                    <th>Password:
-                    <td>
-                        <input type="password" name="password" required>
-                <tr>
-                    <td>&nbsp;
-                    <td>
-                        <input type="submit" value="Login">
-
-            <script>
-                if (!("autofocus" in document.createElement("input"))) {
-                    document.getElementById("x").focus();
-                }
-
-|]
-    where
-        dispatch "POST" ["login"] = postLoginR uniq >>= sendResponse
-        dispatch _ _              = notFound
-
-
-----------------------------------------------------------------
--- Predefined datatype
-----------------------------------------------------------------
-
--- | Generate data base instances for a valid user
-share [mkPersist sqlSettings, mkMigrate "migrateUsers"]
-         [persistUpperCase|
-User
-    username Text Eq
-    password Text
-    salt     Text
-    UniqueUser username
-|]
-
-instance HashDBUser (UserGeneric backend) where
-  userPasswordHash = Just . userPassword
-  userPasswordSalt = Just . userSalt
-  setSaltAndPasswordHash s h u = u { userSalt     = s
-                               , userPassword = h
-                               }

yesod-auth/Yesod/Auth/Message.hs

@@ -14,6 +14,7 @@ module Yesod.Auth.Message
     , finnishMessage
     , chineseMessage
     , spanishMessage
+    , czechMessage
     ) where
 
 import Data.Monoid (mappend)
@@ -25,6 +26,7 @@ data AuthMessage =
     | LoginGoogle
     | LoginYahoo
     | Email
+    | IdentifierNotFound Text
     | Password
     | Register
     | RegisterLong
@@ -101,6 +103,7 @@ englishMessage ProvideIdentifier = "Email or Username"
 englishMessage SendPasswordResetEmail = "Send password reset email"
 englishMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
 englishMessage InvalidUsernamePass = "Invalid username/password combination"
+englishMessage (IdentifierNotFound ident) = "Login not found: " `mappend` ident
 
 portugueseMessage :: AuthMessage -> Text
 portugueseMessage NoOpenID = "Nenhum identificador OpenID encontrado"
@@ -142,6 +145,8 @@ portugueseMessage ProvideIdentifier = "E-mail ou nome de usuário"
 portugueseMessage SendPasswordResetEmail = "Enviar e-mail para resetar senha"
 portugueseMessage PasswordResetPrompt = "Insira seu endereço de e-mail ou nome de usuário abaixo.  Um e-mail para resetar sua senha será enviado para você."
 portugueseMessage InvalidUsernamePass = "Nome de usuário ou senha inválidos"
+-- TODO
+portugueseMessage i@(IdentifierNotFound _) = englishMessage i
 
 spanishMessage :: AuthMessage -> Text
 spanishMessage NoOpenID = "No se encuentra el identificador OpenID"
@@ -183,6 +188,8 @@ spanishMessage ProvideIdentifier = "Cuenta de correo o nombre de usuario"
 spanishMessage SendPasswordResetEmail = "Correo de actualización de contraseña enviado"
 spanishMessage PasswordResetPrompt = "Escriba su cuenta de correo o nombre de usuario, y una confirmación de actualización de contraseña será enviada a su cuenta de correo."
 spanishMessage InvalidUsernamePass = "Combinación de nombre de usuario/contraseña invalida"
+-- TODO
+spanishMessage i@(IdentifierNotFound _) = englishMessage i
 
 swedishMessage :: AuthMessage -> Text
 swedishMessage NoOpenID = "Fann ej OpenID identifierare"
@@ -225,6 +232,8 @@ swedishMessage SendPasswordResetEmail = "Skicka email för återställning av l
 swedishMessage PasswordResetPrompt = "Skriv in din emailadress eller användarnamn nedan och " `mappend`
                                      "ett email för återställning av lösenord kommmer att skickas till dig."
 swedishMessage InvalidUsernamePass = "Ogiltig kombination av användarnamn och lösenord"
+-- TODO
+swedishMessage i@(IdentifierNotFound _) = englishMessage i
 
 germanMessage :: AuthMessage -> Text
 germanMessage NoOpenID = "Kein OpenID-Identifier gefunden"
@@ -266,6 +275,8 @@ germanMessage ProvideIdentifier = "Email-Adresse oder Nutzername"
 germanMessage SendPasswordResetEmail = "Email zusenden um Passwort zurückzusetzen"
 germanMessage PasswordResetPrompt = "Nach Einhabe der Email-Adresse oder des Nutzernamen wird eine Email zugesendet mit welcher das Passwort zurückgesetzt werden kann."
 germanMessage InvalidUsernamePass = "Ungültige Kombination aus Nutzername und Passwort"
+-- TODO
+germanMessage i@(IdentifierNotFound _) = englishMessage i
 
 frenchMessage :: AuthMessage -> Text
 frenchMessage NoOpenID = "Aucun fournisseur OpenID n'a été trouvé"
@@ -300,13 +311,14 @@ frenchMessage NowLoggedIn = "Vous êtes maintenant connecté"
 frenchMessage LoginTitle = "Se connecter"
 frenchMessage PleaseProvideUsername = "Merci de renseigner votre nom d'utilisateur"
 frenchMessage PleaseProvidePassword = "Merci de spécifier un mot de passe"
-frenchMessage NoIdentifierProvided = "No email/username provided"
+frenchMessage NoIdentifierProvided = "Adresse électronique/nom d'utilisateur non spécifié"
-frenchMessage InvalidEmailAddress = "Invalid email address provided"
+frenchMessage InvalidEmailAddress = "Adresse électronique spécifiée invalide"
-frenchMessage PasswordResetTitle = "Password Reset"
+frenchMessage PasswordResetTitle = "Réinitialisation de mot de passe"
-frenchMessage ProvideIdentifier = "Email or Username"
+frenchMessage ProvideIdentifier = "Adresse électronique ou nom d'utilisateur"
-frenchMessage SendPasswordResetEmail = "Send password reset email"
+frenchMessage SendPasswordResetEmail = "Envoie d'un message électronique pour Réinitialisation le mot de passe"
-frenchMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
+frenchMessage PasswordResetPrompt = "Entrez votre adresse électronique ou votre nom d'utilisateur ci-dessous, et un message électronique de réinitialisation de mot de passe vous sera envoyé."
-frenchMessage InvalidUsernamePass = "Invalid username/password combination"
+frenchMessage InvalidUsernamePass = "Le couble nom d'utilisateur/mot de passe invalide"
+frenchMessage (IdentifierNotFound ident) = "Nom d'utilisateur introuvable: " `mappend` ident
 
 norwegianBokmålMessage :: AuthMessage -> Text
 norwegianBokmålMessage NoOpenID = "Ingen OpenID-identifiserer funnet"
@@ -348,6 +360,8 @@ norwegianBokmålMessage ProvideIdentifier = "Email or Username"
 norwegianBokmålMessage SendPasswordResetEmail = "Send password reset email"
 norwegianBokmålMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
 norwegianBokmålMessage InvalidUsernamePass = "Invalid username/password combination"
+-- TODO
+norwegianBokmålMessage i@(IdentifierNotFound _) = englishMessage i
 
 japaneseMessage :: AuthMessage -> Text
 japaneseMessage NoOpenID = "OpenID識別子がありません"
@@ -389,6 +403,8 @@ japaneseMessage ProvideIdentifier = "Email or Username"
 japaneseMessage SendPasswordResetEmail = "Send password reset email"
 japaneseMessage PasswordResetPrompt = "Enter your e-mail address or username below, and a password reset e-mail will be sent to you."
 japaneseMessage InvalidUsernamePass = "Invalid username/password combination"
+japaneseMessage (IdentifierNotFound ident) =
+  "「" `mappend` ident `mappend` "」は正しくないログインので、または未入力の項目があります。"
 
 finnishMessage :: AuthMessage -> Text
 finnishMessage NoOpenID = "OpenID-tunnistetta ei löydy"
@@ -431,6 +447,8 @@ finnishMessage ProvideIdentifier = "Sähköpostiosoite tai käyttäjänimi"
 finnishMessage SendPasswordResetEmail = "Lähetä uusi salasana sähköpostitse"
 finnishMessage PasswordResetPrompt = "Anna sähköpostiosoitteesi tai käyttäjätunnuksesi alla, niin lähetämme uuden salasanan sähköpostitse."
 finnishMessage InvalidUsernamePass = "Virheellinen käyttäjänimi tai salasana."
+-- TODO
+finnishMessage i@(IdentifierNotFound _) = englishMessage i
 
 chineseMessage :: AuthMessage -> Text
 chineseMessage NoOpenID = "无效的OpenID"
@@ -472,5 +490,46 @@ chineseMessage ProvideIdentifier = "邮箱或用户名"
 chineseMessage SendPasswordResetEmail = "发送密码重置邮件"
 chineseMessage PasswordResetPrompt = "输入你的邮箱地址或用户名，你将收到一封密码重置邮件。"
 chineseMessage InvalidUsernamePass = "无效的用户名/密码组合"
+-- TODO
+chineseMessage i@(IdentifierNotFound _) = englishMessage i
 
-
+czechMessage :: AuthMessage -> Text
+czechMessage NoOpenID = "Nebyl nalezen identifikátor OpenID"
+czechMessage LoginOpenID = "Přihlásit přes OpenID"
+czechMessage LoginGoogle = "Přihlásit přes Google"
+czechMessage LoginYahoo = "Přihlásit přes Yahoo"
+czechMessage Email = "E-mail"
+czechMessage Password = "Heslo"
+czechMessage Register = "Registrovat"
+czechMessage RegisterLong = "Zaregistrovat nový účet"
+czechMessage EnterEmail = "Níže zadejte svou e-mailovou adresu a bude vám poslán potvrzovací e-mail."
+czechMessage ConfirmationEmailSentTitle = "Potvrzovací e-mail odeslán"
+czechMessage (ConfirmationEmailSent email) =
+    "Potvrzovací e-mail byl odeslán na " `mappend` email `mappend` "."
+czechMessage AddressVerified = "Adresa byla ověřena, prosím nastavte si nové heslo"
+czechMessage InvalidKeyTitle = "Neplatný ověřovací klíč"
+czechMessage InvalidKey = "Bohužel, ověřovací klíč je neplatný."
+czechMessage InvalidEmailPass = "Neplatná kombinace e-mail/heslo"
+czechMessage BadSetPass = "Pro nastavení hesla je vyžadováno přihlášení"
+czechMessage SetPassTitle = "Nastavit heslo"
+czechMessage SetPass = "Nastavit nové heslo"
+czechMessage NewPass = "Nové heslo"
+czechMessage ConfirmPass = "Potvrdit"
+czechMessage PassMismatch = "Hesla si neodpovídají, zkuste to znovu"
+czechMessage PassUpdated = "Heslo aktualizováno"
+czechMessage Facebook = "Přihlásit přes Facebook"
+czechMessage LoginViaEmail = "Přihlásit přes e-mail"
+czechMessage InvalidLogin = "Neplatné přihlášení"
+czechMessage NowLoggedIn = "Přihlášení proběhlo úspěšně"
+czechMessage LoginTitle = "Přihlásit"
+czechMessage PleaseProvideUsername = "Prosím, zadejte svoje uživatelské jméno"
+czechMessage PleaseProvidePassword = "Prosím, zadejte svoje heslo"
+czechMessage NoIdentifierProvided = "Nebyl poskytnut žádný e-mail nebo uživatelské jméno"
+czechMessage InvalidEmailAddress = "Zadaná e-mailová adresa je neplatná"
+czechMessage PasswordResetTitle = "Obnovení hesla"
+czechMessage ProvideIdentifier = "E-mail nebo uživatelské jméno"
+czechMessage SendPasswordResetEmail = "Poslat e-mail pro obnovení hesla"
+czechMessage PasswordResetPrompt = "Zadejte svou e-mailovou adresu nebo uživatelské jméno a bude vám poslán email pro obnovení hesla."
+czechMessage InvalidUsernamePass = "Neplatná kombinace uživatelského jména a hesla"
+-- TODO
+czechMessage i@(IdentifierNotFound _) = englishMessage i

yesod-auth/Yesod/Auth/OpenId.hs

@@ -69,8 +69,10 @@ $newline never
                 master <- lift getYesod
                 eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master)
                 case eres of
-                    Left err -> loginErrorMessage LoginR $ T.pack $
+                    Left err -> do
-                                 show (err :: SomeException)
+                        tm <- getRouteToParent
+                        lift $ loginErrorMessage (tm LoginR) $ T.pack $
+                                show (err :: SomeException)
                     Right x -> redirect x
             Nothing -> loginErrorMessageI LoginR Msg.NoOpenID
     dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
@@ -83,14 +85,16 @@ $newline never
         completeHelper idType posts
     dispatch _ _ = notFound
 
-completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master ()
+completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
 completeHelper idType gets' = do
     master <- lift getYesod
     eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master)
     either onFailure onSuccess eres
   where
-    onFailure err = loginErrorMessage LoginR $ T.pack $
+    onFailure err = do 
-                      show (err :: SomeException)
+        tm <- getRouteToParent
+        lift $ loginErrorMessage (tm LoginR) $ T.pack $
+                show (err :: SomeException)
     onSuccess oir = do
             let claimed =
                     case OpenId.oirClaimed oir of
@@ -104,7 +108,7 @@ completeHelper idType gets' = do
                         case idType of
                             OPLocal -> OpenId.oirOpLocal oir
                             Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir
-            lift $ setCreds True $ Creds "openid" i gets''
+            lift $ setCredsRedirect $ Creds "openid" i gets''
 
 -- | The main identifier provided by the OpenID authentication plugin is the
 -- \"OP-local identifier\". There is also sometimes a \"claimed\" identifier

yesod-auth/Yesod/Auth/Rpxnow.hs

@@ -48,7 +48,7 @@ $newline never
                 $ maybe id (\x -> (:) ("displayName", x))
                     (fmap pack $ getDisplayName $ map (unpack *** unpack) extra)
                   []
-        lift $ setCreds True creds
+        lift $ setCredsRedirect creds
     dispatch _ _ = notFound
 
 -- | Get some form of a display name.

yesod-auth/Yesod/PasswordStore.hs

@@ -0,0 +1,429 @@
+{-# LANGUAGE OverloadedStrings, BangPatterns #-}
+{-# LANGUAGE CPP #-}
+-- |
+-- Module      : Crypto.PasswordStore
+-- Copyright   : (c) Peter Scott, 2011
+-- License     : BSD-style
+--
+-- Maintainer  : pjscott@iastate.edu
+-- Stability   : experimental
+-- Portability : portable
+--
+-- Securely store hashed, salted passwords. If you need to store and verify
+-- passwords, there are many wrong ways to do it, most of them all too
+-- common. Some people store users' passwords in plain text. Then, when an
+-- attacker manages to get their hands on this file, they have the passwords for
+-- every user's account. One step up, but still wrong, is to simply hash all
+-- passwords with SHA1 or something. This is vulnerable to rainbow table and
+-- dictionary attacks. One step up from that is to hash the password along with
+-- a unique salt value. This is vulnerable to dictionary attacks, since guessing
+-- a password is very fast. The right thing to do is to use a slow hash
+-- function, to add some small but significant delay, that will be negligible
+-- for legitimate users but prohibitively expensive for someone trying to guess
+-- passwords by brute force. That is what this library does. It iterates a
+-- SHA256 hash, with a random salt, a few thousand times. This scheme is known
+-- as PBKDF1, and is generally considered secure; there is nothing innovative
+-- happening here.
+--
+-- The API here is very simple. What you store are called /password hashes/.
+-- They are strings (technically, ByteStrings) that look like this:
+--
+-- > "sha256|14|jEWU94phx4QzNyH94Qp4CQ==|5GEw+jxP/4WLgzt9VS3Ee3nhqBlDsrKiB+rq7JfMckU="
+--
+-- Each password hash shows the algorithm, the strength (more on that later),
+-- the salt, and the hashed-and-salted password. You store these on your server,
+-- in a database, for when you need to verify a password. You make a password
+-- hash with the 'makePassword' function. Here's an example:
+--
+-- > >>> makePassword "hunter2" 14
+-- > "sha256|14|Zo4LdZGrv/HYNAUG3q8WcA==|zKjbHZoTpuPLp1lh6ATolWGIKjhXvY4TysuKvqtNFyk="
+--
+-- This will hash the password @\"hunter2\"@, with strength 12, which is a good
+-- default value. The strength here determines how long the hashing will
+-- take. When doing the hashing, we iterate the SHA256 hash function
+-- @2^strength@ times, so increasing the strength by 1 makes the hashing take
+-- twice as long. When computers get faster, you can bump up the strength a
+-- little bit to compensate. You can strengthen existing password hashes with
+-- the 'strengthenPassword' function. Note that 'makePassword' needs to generate
+-- random numbers, so its return type is 'IO' 'ByteString'. If you want to avoid
+-- the 'IO' monad, you can generate your own salt and pass it to
+-- 'makePasswordSalt'.
+--
+-- Your strength value should not be less than 12, and 14 is a good default
+-- value at the time of this writing, in 2013.
+--
+-- Once you've got your password hashes, the second big thing you need to do
+-- with them is verify passwords against them. When a user gives you a password,
+-- you compare it with a password hash using the 'verifyPassword' function:
+--
+-- > >>> verifyPassword "wrong guess" passwordHash
+-- > False
+-- > >>> verifyPassword "hunter2" passwordHash
+-- > True
+--
+-- These two functions are really all you need. If you want to make existing
+-- password hashes stronger, you can use 'strengthenPassword'. Just pass it an
+-- existing password hash and a new strength value, and it will return a new
+-- password hash with that strength value, which will match the same password as
+-- the old password hash.
+--
+-- Note that, as of version 2.4, you can also use PBKDF2, and specify the exact
+-- iteration count. This does not have a significant effect on security, but can
+-- be handy for compatibility with other code.
+
+module Yesod.PasswordStore (
+
+        -- * Algorithms
+        pbkdf1,                 -- :: ByteString -> Salt -> Int -> ByteString
+        pbkdf2,                 -- :: ByteString -> Salt -> Int -> ByteString
+
+        -- * Registering and verifying passwords
+        makePassword,           -- :: ByteString -> Int -> IO ByteString
+        makePasswordWith,       -- :: (ByteString -> Salt -> Int -> ByteString) ->
+                                --    ByteString -> Int -> IO ByteString
+        makePasswordSalt,       -- :: ByteString -> ByteString -> Int -> ByteString
+        makePasswordSaltWith,   -- :: (ByteString -> Salt -> Int -> ByteString) ->
+                                --    ByteString -> Salt -> Int -> ByteString
+        verifyPassword,         -- :: ByteString -> ByteString -> Bool
+        verifyPasswordWith,     -- :: (ByteString -> Salt -> Int -> ByteString) ->
+                                --    (Int -> Int) -> ByteString -> ByteString -> Bool
+
+        -- * Updating password hash strength
+        strengthenPassword,     -- :: ByteString -> Int -> ByteString
+        passwordStrength,       -- :: ByteString -> Int
+
+        -- * Utilities
+        Salt,
+        isPasswordFormatValid,  -- :: ByteString -> Bool
+        genSaltIO,              -- :: IO Salt
+        genSaltRandom,          -- :: (RandomGen b) => b -> (Salt, b)
+        makeSalt,               -- :: ByteString -> Salt
+        exportSalt,             -- :: Salt -> ByteString
+        importSalt              -- :: ByteString -> Salt
+  ) where
+
+
+import qualified Crypto.Hash as CH
+import qualified Crypto.Hash.SHA256 as H
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Binary as Binary
+import Control.Monad
+import Control.Monad.ST
+import Data.Byteable (toBytes)
+import Data.STRef
+import Data.Bits
+import Data.ByteString.Char8 (ByteString)
+import Data.ByteString.Base64 (encode, decodeLenient)
+import System.IO
+import System.Random
+import Data.Maybe
+import qualified Control.Exception
+
+---------------------
+-- Cryptographic base
+---------------------
+
+-- | PBKDF1 key-derivation function. Takes a password, a 'Salt', and a number of
+-- iterations. The number of iterations should be at least 1000, and probably
+-- more. 5000 is a reasonable number, computing almost instantaneously. This
+-- will give a 32-byte 'ByteString' as output. Both the salt and this 32-byte
+-- key should be stored in the password file. When a user wishes to authenticate
+-- a password, just pass it and the salt to this function, and see if the output
+-- matches.
+pbkdf1 :: ByteString -> Salt -> Int -> ByteString
+pbkdf1 password (SaltBS salt) iter = hashRounds first_hash (iter + 1)
+    where first_hash = H.finalize $ H.init `H.update` password `H.update` salt
+
+-- | Hash a 'ByteString' for a given number of rounds. The number of rounds is 0
+-- or more. If the number of rounds specified is 0, the ByteString will be
+-- returned unmodified.
+hashRounds :: ByteString -> Int -> ByteString
+hashRounds (!bs) 0 = bs
+hashRounds bs rounds = hashRounds (H.hash bs) (rounds - 1)
+
+-- | Computes the hmacSHA256 of the given message, with the given 'Salt'.
+hmacSHA256 :: ByteString
+           -- ^ The secret (the salt)
+           -> ByteString
+           -- ^ The clear-text message
+           -> ByteString
+           -- ^ The encoded message
+hmacSHA256 secret msg =
+    toBytes (CH.hmacGetDigest (CH.hmac secret msg) :: CH.Digest CH.SHA256)
+
+-- | PBKDF2 key-derivation function.
+-- For details see @http://tools.ietf.org/html/rfc2898@.
+-- @32@ is the most common digest size for @SHA256@, and is
+-- what the algorithm internally uses.
+-- @HMAC+SHA256@ is used as @PRF@, because @HMAC+SHA1@ is considered too weak.
+pbkdf2 :: ByteString -> Salt -> Int -> ByteString
+pbkdf2 password (SaltBS salt) c =
+    let hLen = 32
+        dkLen = hLen in go hLen dkLen
+  where
+    go hLen dkLen | dkLen > (2^32 - 1) * hLen = error "Derived key too long."
+                  | otherwise =
+                      let !l = ceiling ((fromIntegral dkLen / fromIntegral hLen) :: Double)
+                          !r = dkLen - (l - 1) * hLen
+                          chunks = [f i | i <- [1 .. l]]
+                      in (B.concat . init $ chunks) `B.append` B.take r (last chunks)
+
+    -- The @f@ function, as defined in the spec.
+    -- It calls 'u' under the hood.
+    f :: Int -> ByteString
+    f i = let !u1 = hmacSHA256 password (salt `B.append` int i)
+      -- Using the ST Monad, for maximum performance.
+      in runST $ do
+          u <- newSTRef u1
+          accum <- newSTRef u1
+          forM_ [2 .. c] $ \_ -> do
+            modifySTRef' u (hmacSHA256 password)
+            currentU <- readSTRef u
+            modifySTRef' accum (`xor'` currentU)
+          readSTRef accum
+
+    -- int(i), as defined in the spec.
+    int :: Int -> ByteString
+    int i = let str = BL.unpack . Binary.encode $ i
+            in BS.pack $ drop (length str - 4) str
+
+    -- | A convenience function to XOR two 'ByteString' together.
+    xor' :: ByteString -> ByteString -> ByteString
+    xor' !b1 !b2 = BS.pack $ BS.zipWith xor b1 b2
+
+-- | Generate a 'Salt' from 128 bits of data from @\/dev\/urandom@, with the
+-- system RNG as a fallback. This is the function used to generate salts by
+-- 'makePassword'.
+genSaltIO :: IO Salt
+genSaltIO =
+    Control.Exception.catch genSaltDevURandom def
+  where
+    def :: IOError -> IO Salt
+    def _ = genSaltSysRandom
+
+-- | Generate a 'Salt' from @\/dev\/urandom@.
+genSaltDevURandom :: IO Salt
+genSaltDevURandom = withFile "/dev/urandom" ReadMode $ \h -> do
+                      rawSalt <- B.hGet h 16
+                      return $ makeSalt rawSalt
+
+-- | Generate a 'Salt' from 'System.Random'.
+genSaltSysRandom :: IO Salt
+genSaltSysRandom = randomChars >>= return . makeSalt . B.pack
+    where randomChars = sequence $ replicate 16 $ randomRIO ('\NUL', '\255')
+
+-----------------------
+-- Password hash format
+-----------------------
+
+-- Format: "sha256|strength|salt|hash", where strength is an unsigned int, salt
+-- is a base64-encoded 16-byte random number, and hash is a base64-encoded hash
+-- value.
+
+-- | Try to parse a password hash.
+readPwHash :: ByteString -> Maybe (Int, Salt, ByteString)
+readPwHash pw | length broken /= 4
+                || algorithm /= "sha256"
+                || B.length hash /= 44 = Nothing
+              | otherwise = case B.readInt strBS of
+                              Just (strength, _) -> Just (strength, SaltBS salt, hash)
+                              Nothing -> Nothing
+    where broken = B.split '|' pw
+          [algorithm, strBS, salt, hash] = broken
+
+-- | Encode a password hash, from a @(strength, salt, hash)@ tuple, where
+-- strength is an 'Int', and both @salt@ and @hash@ are base64-encoded
+-- 'ByteString's.
+writePwHash :: (Int, Salt, ByteString) -> ByteString
+writePwHash (strength, SaltBS salt, hash) =
+    B.intercalate "|" ["sha256", B.pack (show strength), salt, hash]
+
+-----------------
+-- High level API
+-----------------
+
+-- | Hash a password with a given strength (14 is a good default). The output of
+-- this function can be written directly to a password file or
+-- database. Generates a salt using high-quality randomness from
+-- @\/dev\/urandom@ or (if that is not available, for example on Windows)
+-- 'System.Random', which is included in the hashed output.
+makePassword :: ByteString -> Int -> IO ByteString
+makePassword = makePasswordWith pbkdf1
+
+-- | A generic version of 'makePassword', which allow the user
+-- to choose the algorithm to use.
+--
+-- >>> makePasswordWith pbkdf1 "password" 14
+--
+makePasswordWith :: (ByteString -> Salt -> Int -> ByteString)
+                 -- ^ The algorithm to use (e.g. pbkdf1)
+                 -> ByteString
+                 -- ^ The password to encrypt
+                 -> Int
+                 -- ^ log2 of the number of iterations
+                 -> IO ByteString
+makePasswordWith algorithm password strength = do
+  salt <- genSaltIO
+  return $ makePasswordSaltWith algorithm (2^) password salt strength
+
+-- | A generic version of 'makePasswordSalt', meant to give the user
+-- the maximum control over the generation parameters.
+-- Note that, unlike 'makePasswordWith', this function takes the @raw@
+-- number of iterations. This means the user will need to specify a
+-- sensible value, typically @10000@ or @20000@.
+makePasswordSaltWith :: (ByteString -> Salt -> Int -> ByteString)
+                     -- ^ A function modeling an algorithm (e.g. 'pbkdf1')
+                     -> (Int -> Int)
+                     -- ^ A function to modify the strength
+                     -> ByteString
+                     -- ^ A password, given as clear text
+                     -> Salt
+                     -- ^ A hash 'Salt'
+                     -> Int
+                     -- ^ The password strength (e.g. @10000, 20000, etc.@)
+                     -> ByteString
+makePasswordSaltWith algorithm strengthModifier pwd salt strength = writePwHash (strength, salt, hash)
+    where hash = encode $ algorithm pwd salt (strengthModifier strength)
+
+-- | Hash a password with a given strength (14 is a good default), using a given
+-- salt. The output of this function can be written directly to a password file
+-- or database. Example:
+--
+-- > >>> makePasswordSalt "hunter2" (makeSalt "72cd18b5ebfe6e96") 14
+-- > "sha256|14|NzJjZDE4YjVlYmZlNmU5Ng==|yuiNrZW3KHX+pd0sWy9NTTsy5Yopmtx4UYscItSsoxc="
+makePasswordSalt :: ByteString -> Salt -> Int -> ByteString
+makePasswordSalt = makePasswordSaltWith pbkdf1 (2^)
+
+-- | 'verifyPasswordWith' @algorithm userInput pwHash@ verifies
+-- the password @userInput@ given by the user against the stored password
+-- hash @pwHash@, with the hashing algorithm @algorithm@.  Returns 'True' if the
+-- given password is correct, and 'False' if it is not.
+-- This function allows the programmer to specify the algorithm to use,
+-- e.g. 'pbkdf1' or 'pbkdf2'.
+-- Note: If you want to verify a password previously generated with
+-- 'makePasswordSaltWith', but without modifying the number of iterations,
+-- you can do:
+--
+-- > >>> verifyPasswordWith pbkdf2 id "hunter2" "sha256..."
+-- > True
+--
+verifyPasswordWith :: (ByteString -> Salt -> Int -> ByteString)
+                   -- ^ A function modeling an algorithm (e.g. pbkdf1)
+                   -> (Int -> Int)
+                   -- ^ A function to modify the strength
+                   -> ByteString
+                   -- ^ User password
+                   -> ByteString
+                   -- ^ The generated hash (e.g. sha256|14...)
+                   -> Bool
+verifyPasswordWith algorithm strengthModifier userInput pwHash =
+    case readPwHash pwHash of
+      Nothing -> False
+      Just (strength, salt, goodHash) ->
+          encode (algorithm userInput salt (strengthModifier strength)) == goodHash
+
+-- | Like 'verifyPasswordWith', but uses 'pbkdf1' as algorithm.
+verifyPassword :: ByteString -> ByteString -> Bool
+verifyPassword = verifyPasswordWith pbkdf1 (2^)
+
+-- | Try to strengthen a password hash, by hashing it some more
+-- times. @'strengthenPassword' pwHash new_strength@ will return a new password
+-- hash with strength at least @new_strength@. If the password hash already has
+-- strength greater than or equal to @new_strength@, then it is returned
+-- unmodified. If the password hash is invalid and does not parse, it will be
+-- returned without comment.
+--
+-- This function can be used to periodically update your password database when
+-- computers get faster, in order to keep up with Moore's law. This isn't hugely
+-- important, but it's a good idea.
+strengthenPassword :: ByteString -> Int -> ByteString
+strengthenPassword pwHash newstr =
+    case readPwHash pwHash of
+      Nothing -> pwHash
+      Just (oldstr, salt, hashB64) ->
+          if oldstr < newstr then
+              writePwHash (newstr, salt, newHash)
+          else
+              pwHash
+          where newHash = encode $ hashRounds hash extraRounds
+                extraRounds = (2^newstr) - (2^oldstr)
+                hash = decodeLenient hashB64
+
+-- | Return the strength of a password hash.
+passwordStrength :: ByteString -> Int
+passwordStrength pwHash = case readPwHash pwHash of
+                            Nothing               -> 0
+                            Just (strength, _, _) -> strength
+
+------------
+-- Utilities
+------------
+
+-- | A salt is a unique random value which is stored as part of the password
+-- hash. You can generate a salt with 'genSaltIO' or 'genSaltRandom', or if you
+-- really know what you're doing, you can create them from your own ByteString
+-- values with 'makeSalt'.
+newtype Salt = SaltBS ByteString
+    deriving (Show, Eq, Ord)
+
+-- | Create a 'Salt' from a 'ByteString'. The input must be at least 8
+-- characters, and can contain arbitrary bytes. Most users will not need to use
+-- this function.
+makeSalt :: ByteString -> Salt
+makeSalt = SaltBS . encode . check_length
+    where check_length salt | B.length salt < 8 =
+                                error "Salt too short. Minimum length is 8 characters."
+                            | otherwise = salt
+
+-- | Convert a 'Salt' into a 'ByteString'. The resulting 'ByteString' will be
+-- base64-encoded. Most users will not need to use this function.
+exportSalt :: Salt -> ByteString
+exportSalt (SaltBS bs) = bs
+
+-- | Convert a raw 'ByteString' into a 'Salt'.
+-- Use this function with caution, since using a weak salt will result in a
+-- weak password.
+importSalt :: ByteString -> Salt
+importSalt = SaltBS
+
+-- | Is the format of a password hash valid? Attempts to parse a given password
+-- hash. Returns 'True' if it parses correctly, and 'False' otherwise.
+isPasswordFormatValid :: ByteString -> Bool
+isPasswordFormatValid = isJust . readPwHash
+
+-- | Generate a 'Salt' with 128 bits of data taken from a given random number
+-- generator. Returns the salt and the updated random number generator. This is
+-- meant to be used with 'makePasswordSalt' by people who would prefer to either
+-- use their own random number generator or avoid the 'IO' monad.
+genSaltRandom :: (RandomGen b) => b -> (Salt, b)
+genSaltRandom gen = (salt, newgen)
+    where rands _ 0 = []
+          rands g n = (a, g') : rands g' (n-1 :: Int)
+              where (a, g') = randomR ('\NUL', '\255') g
+          salt   = makeSalt $ B.pack $ map fst (rands gen 16)
+          newgen = snd $ last (rands gen 16)
+
+#if !MIN_VERSION_base(4, 6, 0)
+-- | Strict version of 'modifySTRef'
+modifySTRef' :: STRef s a -> (a -> a) -> ST s ()
+modifySTRef' ref f = do
+    x <- readSTRef ref
+    let x' = f x
+    x' `seq` writeSTRef ref x'
+#endif
+
+#if MIN_VERSION_bytestring(0, 10, 0)
+toStrict :: BL.ByteString -> BS.ByteString
+toStrict = BL.toStrict
+
+fromStrict :: BS.ByteString -> BL.ByteString
+fromStrict = BL.fromStrict
+#else
+toStrict :: BL.ByteString -> BS.ByteString
+toStrict = BS.concat . BL.toChunks
+
+fromStrict :: BS.ByteString -> BL.ByteString
+fromStrict = BL.fromChunks . return
+#endif

yesod-auth/yesod-auth.cabal

@@ -1,5 +1,5 @@
 name:            yesod-auth
-version:         1.2.1
+version:         1.3.1.1
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -10,9 +10,14 @@ stability:       Stable
 cabal-version:   >= 1.6.0
 build-type:      Simple
 homepage:        http://www.yesodweb.com/
-description:     This package provides a pluggable mechanism for allowing users to authenticate with your site. It comes with a number of common plugins, such as OpenID, BrowserID (a.k.a., Mozilla Persona), and email. Other packages are available from Hackage as well. If you've written such an add-on, please notify me so that it can be added to this description.
+description:
-                 .
+    This package provides a pluggable mechanism for allowing users to authenticate with your site. It comes with a number of common plugins, such as OpenID, BrowserID (a.k.a., Mozilla Persona), and email. Other packages are available from Hackage as well. If you've written such an add-on, please notify me so that it can be added to this description.
-                 * <http://hackage.haskell.org/package/yesod-auth-account>: An account authentication plugin for Yesod
+   .
+   * <http://hackage.haskell.org/package/yesod-auth-account>: An account authentication plugin for Yesod
+   .
+   * <http://hackage.haskell.org/package/yesod-auth-hashdb>: The HashDB module previously packaged in yesod-auth, now with stronger, but compatible, security.
+   .
+   * <https://github.com/ollieh/yesod-auth-bcrypt/>: An alternative to the HashDB module.
 extra-source-files: persona_sign_in_blue.png
 
 library
@@ -22,24 +27,24 @@ library
                    , yesod-core              >= 1.2       && < 1.3
                    , wai                     >= 1.4
                    , template-haskell
-                   , pureMD5                 >= 2.0
+                   , base16-bytestring
+                   , cryptohash
                    , random                  >= 1.0.0.2
                    , text                    >= 0.7
                    , mime-mail               >= 0.3
                    , yesod-persistent        >= 1.2
-                   , hamlet                  >= 1.1       && < 1.2
+                   , hamlet                  >= 1.1
-                   , shakespeare-css         >= 1.0       && < 1.1
+                   , shakespeare
-                   , shakespeare-js          >= 1.0.2     && < 1.2
+                   , shakespeare-css         >= 1.0
+                   , shakespeare-js          >= 1.0.2
                    , containers
                    , unordered-containers
                    , yesod-form              >= 1.3       && < 1.4
                    , transformers            >= 0.2.2
-                   , persistent              >= 1.2       && < 1.3
+                   , persistent              >= 1.2       && < 1.4
-                   , persistent-template     >= 1.2       && < 1.3
+                   , persistent-template     >= 1.2       && < 1.4
-                   , SHA                     >= 1.4.1.3
                    , http-conduit            >= 1.5
                    , aeson                   >= 0.5
-                   , pwstore-fast            >= 2.2
                    , lifted-base             >= 0.1
                    , blaze-html              >= 0.5
                    , blaze-markup            >= 0.5.1
@@ -51,6 +56,14 @@ library
                    , resourcet
                    , safe
                    , time
+                   , base64-bytestring
+                   , byteable
+                   , binary
+                   , http-client
+                   , blaze-builder
+                   , conduit
+                   , conduit-extra
+                   , attoparsec-conduit
 
     exposed-modules: Yesod.Auth
                      Yesod.Auth.BrowserId
@@ -58,10 +71,11 @@ library
                      Yesod.Auth.Email
                      Yesod.Auth.OpenId
                      Yesod.Auth.Rpxnow
-                     Yesod.Auth.HashDB
                      Yesod.Auth.Message
                      Yesod.Auth.GoogleEmail
+                     Yesod.Auth.GoogleEmail2
     other-modules:   Yesod.Auth.Routes
+                     Yesod.PasswordStore
     ghc-options:     -Wall
 
 source-repository head

yesod-bin/AddHandler.hs

@@ -106,7 +106,7 @@ mkHandler name pattern methods = unlines
 
     getTypes "" = []
     getTypes ('/':rest) = getTypes rest
-    getTypes ('#':rest) =
+    getTypes (c:rest) | c `elem` "#*" =
         typ : getTypes rest'
       where
         (typ, rest') = break (== '/') rest

yesod-bin/Devel.hs

@@ -1,14 +1,14 @@
 {-# LANGUAGE CPP                 #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell   #-}
 module Devel
     ( devel
     , DevelOpts(..)
+    , DevelTermOpt(..)
     , defaultDevelOpts
     ) where
 
-import           Paths_yesod_bin
-
 import qualified Distribution.Compiler                 as D
 import qualified Distribution.ModuleName               as D
 import qualified Distribution.PackageDescription       as D
@@ -24,7 +24,7 @@ import           Control.Concurrent.MVar               (MVar, newEmptyMVar,
                                                         takeMVar, tryPutMVar)
 import qualified Control.Exception                     as Ex
 import           Control.Monad                         (forever, unless, void,
-                                                        when)
+                                                        when, forM)
 import           Control.Monad.IO.Class                (liftIO)
 import           Control.Monad.Trans.State             (evalStateT, get)
 import qualified Data.IORef                            as I
@@ -64,20 +64,26 @@ import           GhcBuild                              (buildPackage,
                                                         getBuildFlags, getPackageArgs)
 
 import qualified Config                                as GHC
-import           Data.Conduit.Network                  (HostPreference (HostIPv4),
+import           Data.Streaming.Network                (bindPortTCP)
-                                                        bindPort)
 import           Network                               (withSocketsDo)
+#if MIN_VERSION_http_conduit(2, 0, 0)
+import           Network.HTTP.Conduit                  (conduitManagerSettings, newManager)
+import           Data.Default.Class                    (def)
+#else
 import           Network.HTTP.Conduit                  (def, newManager)
+#endif
 import           Network.HTTP.ReverseProxy             (ProxyDest (ProxyDest),
                                                         waiProxyToSettings, wpsTimeout, wpsOnExc)
 #if MIN_VERSION_http_reverse_proxy(0, 2, 0)
 import qualified Network.HTTP.ReverseProxy             as ReverseProxy
 #endif
-import           Network.HTTP.Types                    (status200)
+import           Network.HTTP.Types                    (status200, status503)
 import           Network.Socket                        (sClose)
-import           Network.Wai                           (responseLBS)
+import           Network.Wai                           (responseLBS, requestHeaders)
+import           Network.Wai.Parse                     (parseHttpAccept)
 import           Network.Wai.Handler.Warp              (run)
 import           SrcLoc                                (Located)
+import           Data.FileEmbed        (embedFile)
 
 lockFile :: DevelOpts -> FilePath
 lockFile _opts =  "yesod-devel/devel-terminate"
@@ -94,6 +100,8 @@ removeLock opts = do
     removeFileIfExists (lockFile opts)
     removeFileIfExists "dist/devel-terminate"  -- for compatibility with old devel.hs
 
+data DevelTermOpt = TerminateOnEnter | TerminateOnlyInterrupt
+     deriving (Show, Eq)
 data DevelOpts = DevelOpts
       { isCabalDev   :: Bool
       , forceCabal   :: Bool
@@ -105,13 +113,14 @@ data DevelOpts = DevelOpts
       , develPort    :: Int
       , proxyTimeout :: Int
       , useReverseProxy :: Bool
+      , terminateWith :: DevelTermOpt
       } deriving (Show, Eq)
 
 getBuildDir :: DevelOpts -> String
 getBuildDir opts = fromMaybe "dist" (buildDir opts)
 
 defaultDevelOpts :: DevelOpts
-defaultDevelOpts = DevelOpts False False False (-1) Nothing Nothing Nothing 3000 10 True
+defaultDevelOpts = DevelOpts False False False (-1) Nothing Nothing Nothing 3000 10 True TerminateOnEnter
 
 cabalProgram :: DevelOpts -> FilePath
 cabalProgram opts | isCabalDev opts = "cabal-dev"
@@ -121,8 +130,26 @@ cabalProgram opts | isCabalDev opts = "cabal-dev"
 -- 3001, give an appropriate message to the user.
 reverseProxy :: DevelOpts -> I.IORef Int -> IO ()
 reverseProxy opts iappPort = do
+#if MIN_VERSION_http_conduit(2, 0, 0)
+    manager <- newManager conduitManagerSettings
+#else
     manager <- newManager def
-    let loop = forever $ do
+#endif
+    let refreshHtml = LB.fromChunks $ return $(embedFile "refreshing.html")
+    let onExc _ req
+            | maybe False (("application/json" `elem`) . parseHttpAccept)
+                (lookup "accept" $ requestHeaders req) =
+                    return $ responseLBS status503
+                        [ ("Retry-After", "1")
+                        ]
+                        "{\"message\":\"Recompiling\"}"
+            | otherwise = return $ responseLBS status200
+                [ ("content-type", "text/html")
+                , ("Refresh", "1")
+                ]
+                refreshHtml
+
+    let runProxy =
             run (develPort opts) $ waiProxyToSettings
                 (const $ do
                     appPort <- liftIO $ I.readIORef iappPort
@@ -134,31 +161,28 @@ reverseProxy opts iappPort = do
 #endif
                         $ ProxyDest "127.0.0.1" appPort)
                 def
+#if MIN_VERSION_wai(3, 0, 0)
+                    { wpsOnExc = \e req f -> onExc e req >>= f
+#else
                     { wpsOnExc = onExc
+#endif
                     , wpsTimeout =
                         if proxyTimeout opts == 0
                             then Nothing
                             else Just (1000000 * proxyTimeout opts)
                     }
                 manager
-            putStrLn "Reverse proxy stopped, but it shouldn't"
+    loop runProxy `Ex.onException` exitFailure
-            threadDelay 1000000
-            putStrLn "Restarting reverse proxy"
-    loop `Ex.onException` exitFailure
   where
-    onExc _ _ = do
+    loop proxy = forever $ do
-      refreshing <- liftIO $ getDataFileName "refreshing.html"
+        void proxy
-      html <- liftIO $ LB.readFile refreshing
+        putStrLn "Reverse proxy stopped, but it shouldn't"
-      return $ responseLBS
+        threadDelay 1000000
-        status200
+        putStrLn "Restarting reverse proxy"
-        [ ("content-type", "text/html")
-        , ("Refresh", "1")
-        ]
-        html
 
 checkPort :: Int -> IO Bool
 checkPort p = do
-    es <- Ex.try $ bindPort p HostIPv4
+    es <- Ex.try $ bindPortTCP p "*4"
     case es of
         Left (_ :: Ex.IOException) -> return False
         Right s -> do
@@ -174,21 +198,31 @@ getPort _ p0 =
         avail <- checkPort p
         if avail then return p else loop (succ p)
 
+unlessM :: Monad m => m Bool -> m () -> m ()
+unlessM c a = c >>= \res -> unless res a
+
 devel :: DevelOpts -> [String] -> IO ()
 devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do
-    avail <- checkPort $ develPort opts
+    unlessM (checkPort $ develPort opts) $ error "devel port unavailable"
-    unless avail $ error "devel port unavailable"
     iappPort <- getPort opts 17834 >>= I.newIORef
     when (useReverseProxy opts) $ void $ forkIO $ reverseProxy opts iappPort
     checkDevelFile
     writeLock opts
 
-    putStrLn "Yesod devel server. Press ENTER to quit"
+    let (terminator, after) = case terminateWith opts of
-    _ <- forkIO $ do
+          TerminateOnEnter ->
+              ("Press ENTER", void getLine)
+          TerminateOnlyInterrupt ->  -- run for one year
+              ("Interrupt", threadDelay $ 1000 * 1000 * 60 * 60 * 24 * 365)
+
+
+    putStrLn $ "Yesod devel server. "  ++ terminator ++ " to quit"
+    void $ forkIO $ do
       filesModified <- newEmptyMVar
-      watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ()))
+      void $ forkIO $
+        void $ watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ()))
       evalStateT (mainOuterLoop iappPort filesModified) Map.empty
-    _ <- getLine
+    after
     writeLock opts
     exitSuccess
   where
@@ -247,7 +281,10 @@ devel opts passThroughArgs = withSocketsDo $ withManager $ \manager -> do
                    liftIO $ I.writeIORef iappPort appPort
 
                    (_,_,_,ph) <- liftIO $ createProcess (proc "runghc" devArgs)
-                        { env = Just $ ("PORT", show appPort) : ("DISPLAY_PORT", show $ develPort opts) : env0
+                        { env = Just $ Map.toList
+                                     $ Map.insert "PORT" (show appPort)
+                                     $ Map.insert "DISPLAY_PORT" (show $ develPort opts)
+                                     $ Map.fromList env0
                         }
                    derefMap <- get
                    watchTid <- liftIO . forkIO . try_ $ flip evalStateT derefMap $ do
@@ -278,8 +315,8 @@ runBuildHook Nothing = return ()
 -}
 configure :: DevelOpts -> [String] -> IO Bool
 configure opts extraArgs =
-  checkExit =<< (createProcess $ proc (cabalProgram opts)
+  checkExit =<< createProcess (proc (cabalProgram opts) $
-                                ([ "configure"
+                                 [ "configure"
                                  , "-flibrary-only"
                                  , "-fdevel"
                                  , "--disable-library-profiling"
@@ -287,7 +324,7 @@ configure opts extraArgs =
                                  , "--with-ghc=yesod-ghc-wrapper"
                                  , "--with-ar=yesod-ar-wrapper"
                                  , "--with-hc-pkg=ghc-pkg"
-                                 ] ++ extraArgs)
+                                 ] ++ extraArgs
                )
 
 removeFileIfExists :: FilePath -> IO ()
@@ -302,7 +339,7 @@ mkRebuild ghcVer cabalFile opts (ldPath, arPath)
   | GHC.cProjectVersion /= ghcVer =
        failWith "Yesod has been compiled with a different GHC version, please reinstall"
   | forceCabal opts               = return (rebuildCabal opts)
-  | otherwise                     = do
+  | otherwise                     =
       return $ do
         ns <- mapM (cabalFile `isNewerThan`)
            [ "yesod-devel/ghcargs.txt", "yesod-devel/arargs.txt", "yesod-devel/ldargs.txt" ]
@@ -327,7 +364,7 @@ rebuildCabal opts = do
            | otherwise    = [ "build", "-v0" ]
 
 try_ :: forall a. IO a -> IO ()
-try_ x = (Ex.try x :: IO (Either Ex.SomeException a)) >> return ()
+try_ x = void (Ex.try x :: IO (Either Ex.SomeException a))
 
 type FileList = Map.Map FilePath EpochTime
 
@@ -335,7 +372,7 @@ getFileList :: [FilePath] -> [FilePath] -> IO FileList
 getFileList hsSourceDirs extraFiles = do
     (files, deps) <- getDeps hsSourceDirs
     let files' = extraFiles ++ files ++ map fst (Map.toList deps)
-    fmap Map.fromList $ flip mapM files' $ \f -> do
+    fmap Map.fromList $ forM files' $ \f -> do
         efs <- Ex.try $ getFileStatus f
         return $ case efs of
             Left (_ :: Ex.SomeException) -> (f, 0)
@@ -389,7 +426,7 @@ failWith msg = do
     exitFailure
 
 checkFileList :: FileList -> D.Library -> [FilePath]
-checkFileList fl lib = filter isUnlisted . filter isSrcFile $ sourceFiles
+checkFileList fl lib = filter (not . isSetup) . filter isUnlisted . filter isSrcFile $ sourceFiles
   where
     al = allModules lib
     -- a file is only a possible 'module file' if all path pieces start with a capital letter
@@ -399,6 +436,12 @@ checkFileList fl lib = filter isUnlisted . filter isSrcFile $ sourceFiles
     isUnlisted file = not (toModuleName file `Set.member` al)
     toModuleName = L.intercalate "." . filter (/=".") . splitDirectories . dropExtension
 
+    isSetup "Setup.hs" = True
+    isSetup "./Setup.hs" = True
+    isSetup "Setup.lhs" = True
+    isSetup "./Setup.lhs" = True
+    isSetup _ = False
+
 allModules :: D.Library -> Set.Set String
 allModules lib = Set.fromList $ map toString $ D.exposedModules lib ++ (D.otherModules . D.libBuildInfo) lib
     where

yesod-bin/GhcBuild.hs

@@ -39,10 +39,14 @@ import           GHC.Paths          (libdir)
 import           HscTypes           (HscEnv (..), emptyHomePackageTable)
 import qualified Module
 import           MonadUtils         (liftIO)
-import           Panic              (ghcError, panic)
+import           Panic              (throwGhcException, panic)
 import           SrcLoc             (Located, mkGeneralLocated)
 import qualified StaticFlags
+#if __GLASGOW_HASKELL__ >= 707
+import           DynFlags           (ldInputs)
+#else
 import           StaticFlags        (v_Ld_inputs)
+#endif
 import           System.FilePath    (normalise, (</>))
 import           Util               (consIORef, looksLikeModuleName)
 
@@ -147,7 +151,9 @@ buildPackage' argv2 ld ar = do
         haskellish (f,Nothing) =
           looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
         haskellish (_,Just phase) =
-#if MIN_VERSION_ghc(7,4,0)
+#if MIN_VERSION_ghc(7,8,3)
+          phase `notElem` [As True, As False, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
+#elif MIN_VERSION_ghc(7,4,0)
           phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
 #else
           phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]
@@ -162,7 +168,15 @@ buildPackage' argv2 ld ar = do
     o_files <- mapM (\x -> compileFile hsc_env StopLn x)
 #endif
                  non_hs_srcs
+#if __GLASGOW_HASKELL__ >= 707
+    let dflags4 = dflags3
+            { ldInputs = map (DF.FileOption "") (reverse o_files)
+                      ++ ldInputs dflags3
+            }
+    GHC.setSessionDynFlags dflags4
+#else
     liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
+#endif
     targets <- mapM (uncurry GHC.guessTarget) hs_srcs
     GHC.setTargets targets
     ok_flag <- GHC.load GHC.LoadAllTargets
@@ -234,7 +248,7 @@ parseModeFlags args = do
              Nothing     -> doMakeMode
              Just (m, _) -> m
       errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2
-  when (not (null errs)) $ ghcError $ errorsToGhcException errs
+  when (not (null errs)) $ throwGhcException $ errorsToGhcException errs
   return (mode, flags' ++ leftover, warns)
 
 type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
@@ -289,7 +303,11 @@ mode_flags =
   , Flag "E"            (PassFlag (setMode (stopBeforeMode anyHsc)))
   , Flag "C"            (PassFlag (\f -> do setMode (stopBeforeMode HCc) f
                                             addFlag "-fvia-C" f))
+#if MIN_VERSION_ghc(7,8,3)
+  , Flag "S"            (PassFlag (setMode (stopBeforeMode (As True))))
+#else
   , Flag "S"            (PassFlag (setMode (stopBeforeMode As)))
+#endif
   , Flag "-make"        (PassFlag (setMode doMakeMode))
   , Flag "-interactive" (PassFlag (setMode doInteractiveMode))
   , Flag "-abi-hash"    (PassFlag (setMode doAbiHashMode))

yesod-bin/HsFile.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedStrings #-}
+module HsFile (mkHsFile) where
+import Text.ProjectTemplate (createTemplate)
+import Data.Conduit 
+    ( ($$), (=$), ConduitM, awaitForever, yield, Source )
+import Control.Monad.Trans.Resource (ResourceT, runResourceT)
+import qualified Data.Conduit.List as CL
+import Prelude hiding (FilePath)
+import Filesystem.Path ( FilePath )
+import Filesystem.Path.CurrentOS ( encodeString )
+import qualified Filesystem as F
+import qualified Data.ByteString as BS
+import Control.Monad.IO.Class (liftIO)
+
+traverse :: FilePath -> Source (ResourceT IO) FilePath
+traverse dir = do
+    liftIO (F.listDirectory dir) >>= mapM_ go
+  where
+    go fp = do
+        isFile' <- liftIO $ F.isFile fp
+        if isFile'
+            then yield fp
+            else do
+                isDir <- liftIO $ F.isDirectory fp
+                if isDir
+                    then traverse fp
+                    else return ()
+
+mkHsFile :: IO ()
+mkHsFile = runResourceT $ traverse "."
+        $$ readIt
+        =$ createTemplate 
+        =$ awaitForever (liftIO . BS.putStr)
+
+-- Reads a filepath from upstream and dumps a pair of (filepath, filecontents)
+readIt :: ConduitM FilePath (FilePath, ResourceT IO BS.ByteString) (ResourceT IO) ()
+readIt = CL.map $ \i -> (i, liftIO $ BS.readFile $ encodeString i)
+

yesod-bin/Keter.hs

@@ -62,7 +62,10 @@ keter cabal noBuild = do
     L.writeFile fp $ compress $ Tar.write archive
 
     case Map.lookup "copy-to" value of
-        Just (String s) -> run "scp" [fp, T.unpack s]
+        Just (String s) ->
+            case parseMaybe (.: "copy-to-port") value of
+                Just i -> run "scp" ["-P" ++ show (i :: Int), fp, T.unpack s]
+                Nothing -> run "scp" [fp, T.unpack s]
         _ -> return ()
 
 try' :: IO a -> IO (Either SomeException a)

yesod-bin/Options.hs

@@ -11,7 +11,7 @@ import           Data.Char                 (isAlphaNum, isSpace, toLower)
 import           Data.List                 (foldl')
 import           Data.List.Split           (splitOn)
 import qualified Data.Map                  as M
-import           Data.Maybe                (catMaybes)
+import           Data.Maybe                (mapMaybe)
 import           Data.Monoid
 import           Options.Applicative
 import           Options.Applicative.Types
@@ -52,10 +52,10 @@ updateA env key upd a =
 
 -- | really simple key/value file reader:   x.y = z -> (["x","y"],"z")
 configLines :: String -> [([String], String)]
-configLines = catMaybes . map (mkLine . takeWhile (/='#')) . lines
+configLines = mapMaybe (mkLine . takeWhile (/='#')) . lines
   where
     trim = let f = reverse . dropWhile isSpace in f . f
-    mkLine l | (k, ('=':v)) <- break (=='=') l = Just (splitOn "." (trim k), trim v)
+    mkLine l | (k, '=':v) <- break (=='=') l = Just (splitOn "." (trim k), trim v)
              | otherwise                       = Nothing
 
 -- | inject the environment into the parser
@@ -71,16 +71,27 @@ injectDefaultP env path p@(OptP o)
            in  parseri { infoParser = injectDefaultP env (path ++ [normalizeName cmd]) (infoParser parseri) }
      in  OptP (Option (CmdReader cmds (`M.lookup` cmdMap)) props)
   | (Option (OptReader names (CReader _ rdr) _) _) <- o =
-     p <|> either (const empty) pure (msum $ map (rdr <=< (maybe (Left $ ErrorMsg "Missing environment variable") Right . getEnvValue env path)) names)
+     p <|> either' (const empty) pure (msum $ map (rdr <=< (maybe (left $ ErrorMsg "Missing environment variable") right . getEnvValue env path)) names)
   | (Option (FlagReader names a) _) <- o =
      p <|> if any ((==Just "1") . getEnvValue env path) names then pure a else empty
   | otherwise = p
+  where
+#if MIN_VERSION_optparse_applicative(0,6,0)
+    right= ReadM . Right
+    left = ReadM . Left
+    either' f g (ReadM x) = either f g x
+#else
+    right = Right
+    left = Left
+    either' = either
+#endif
 injectDefaultP env path (MultP p1 p2) =
    MultP (injectDefaultP env path p1) (injectDefaultP env path p2)
 injectDefaultP env path (AltP p1 p2) =
    AltP (injectDefaultP env path p1) (injectDefaultP env path p2)
 injectDefaultP _env _path b@(BindP {}) = b
 
+
 getEnvValue :: M.Map [String] String -> [String] -> OptName -> Maybe String
 getEnvValue env path (OptLong l) = M.lookup (path ++ [normalizeName l]) env
 getEnvValue _ _ _                = Nothing

yesod-bin/Scaffolding/Scaffolder.hs

@@ -4,7 +4,8 @@ module Scaffolding.Scaffolder (scaffold) where
 
 import           Control.Arrow         ((&&&))
 import qualified Data.ByteString.Char8 as S
-import           Data.Conduit          (runResourceT, yield, ($$), ($$+-))
+import           Data.Conduit          (yield, ($$), ($$+-))
+import Control.Monad.Trans.Resource (runResourceT)
 import           Data.FileEmbed        (embedFile)
 import           Data.String           (fromString)
 import qualified Data.Text             as T
@@ -14,6 +15,9 @@ import           Text.ProjectTemplate  (unpackTemplate, receiveFS)
 import           System.IO
 import           Text.Shakespeare.Text (renderTextUrl, textFile)
 import Network.HTTP.Conduit (withManager, http, parseUrl, responseBody)
+import           Data.Maybe            (isJust)
+import           Distribution.Text     (simpleParse)
+import           Distribution.Package  (PackageName)
 
 prompt :: (String -> Maybe a) -> IO a
 prompt f = do
@@ -58,20 +62,15 @@ backendBS Mysql = $(embedFile "hsfiles/mysql.hsfiles")
 backendBS MongoDB = $(embedFile "hsfiles/mongo.hsfiles")
 backendBS Simple = $(embedFile "hsfiles/simple.hsfiles")
 
--- | Is the character valid for a project name?
+validPackageName :: String -> Bool
-validPN :: Char -> Bool
+validPackageName s = isJust (simpleParse s :: Maybe PackageName)
-validPN c
-    | 'A' <= c && c <= 'Z' = True
-    | 'a' <= c && c <= 'z' = True
-    | '0' <= c && c <= '9' = True
-validPN '-' = True
-validPN _ = False
 
-scaffold :: IO ()
+scaffold :: Bool -- ^ bare directory instead of a new subdirectory?
-scaffold = do
+         -> IO ()
+scaffold isBare = do
     puts $ renderTextUrl undefined $(textFile "input/welcome.cg")
     project <- prompt $ \s ->
-        if all validPN s && not (null s) && s /= "test"
+        if validPackageName s && s /= "test"
             then Just s
             else Nothing
     let dir = project
@@ -90,7 +89,7 @@ scaffold = do
     putStrLn "That's it! I'm creating your files now..."
 
     let sink = unpackTemplate
-                (receiveFS $ fromString project)
+                (receiveFS $ if isBare then "." else fromString project)
                 (T.replace "PROJECTNAME" (T.pack project))
     case ebackend of
         Left req -> withManager $ \m -> do

yesod-bin/input/done.cg

@@ -24,9 +24,4 @@ Take part in the community: http://yesodweb.com/page/community
 
 Start your project:
 
-   cd PROJECTNAME && cabal install && yesod devel
+   cd PROJECTNAME && cabal sandbox init && cabal install --enable-tests . yesod-platform yesod-bin --max-backjumps=-1 --reorder-goals && yesod devel
-
-or if you use cabal-dev:
-
-   cd PROJECTNAME && cabal-dev install && yesod --dev devel
-

yesod-bin/main.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE CPP             #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE RecordWildCards             #-}
 
 import           Control.Monad          (unless)
 import           Data.Monoid
@@ -9,14 +9,19 @@ import           System.Exit            (ExitCode (ExitSuccess), exitWith)
 import           System.Process         (rawSystem)
 
 import           AddHandler             (addHandler)
-import           Devel                  (DevelOpts (..), devel)
+import           Devel                  (DevelOpts (..), devel, DevelTermOpt(..))
 import           Keter                  (keter)
 import           Options                (injectDefaults)
 import qualified Paths_yesod_bin
 import           Scaffolding.Scaffolder
 
+#if MIN_VERSION_optparse_applicative(0,6,0)
+import           Options.Applicative.Types (ReadM (ReadM))
+#else
 import           Options.Applicative.Builder.Internal (Mod, OptionFields)
+#endif
 
+import           HsFile                 (mkHsFile)
 #ifndef WINDOWS
 import           Build                  (touch)
 
@@ -42,7 +47,8 @@ data Options = Options
                }
   deriving (Show, Eq)
 
-data Command = Init
+data Command = Init { _initBare :: Bool }
+             | HsFiles
              | Configure
              | Build { buildExtraArgs   :: [String] }
              | Touch
@@ -56,6 +62,7 @@ data Command = Init
                      , _develPort        :: Int
                      , _proxyTimeout     :: Int
                      , _noReverseProxy   :: Bool
+                     , _interruptOnly    :: Bool
                      }
              | Test
              | AddHandler
@@ -71,36 +78,46 @@ cabalCommand mopt
 
 main :: IO ()
 main = do
-  o <- execParser =<< injectDefaults "yesod" [ ("yesod.devel.extracabalarg" , \o args -> o { optCommand =
+  o <- execParser =<< injectDefaults "yesod"
-                                                    case optCommand o of
+         [ ("yesod.devel.extracabalarg" , \o args -> o { optCommand =
-                                                        d@Devel{} -> d { develExtraArgs = args }
+                case optCommand o of
-                                                        c -> c
+                    d@Devel{} -> d { develExtraArgs = args }
-                                                    })
+                    c -> c
-                                             , ("yesod.devel.ignore"        , \o args -> o { optCommand =
+                })
-                                                    case optCommand o of
+         , ("yesod.devel.ignore"        , \o args -> o { optCommand =
-                                                        d@Devel{} -> d { develIgnore = args }
+                case optCommand o of
-                                                        c -> c
+                    d@Devel{} -> d { develIgnore = args }
-                                                    })
+                    c -> c
-                                             , ("yesod.build.extracabalarg" , \o args -> o { optCommand =
+                })
-                                                    case optCommand o of
+         , ("yesod.build.extracabalarg" , \o args -> o { optCommand =
-                                                        b@Build{} -> b { buildExtraArgs = args }
+                case optCommand o of
-                                                        c -> c
+                    b@Build{} -> b { buildExtraArgs = args }
-                                                    })
+                    c -> c
-                                             ] optParser'
+                })
-  let cabal xs = rawSystem' (cabalCommand o) xs
+         ] optParser'
+  let cabal = rawSystem' (cabalCommand o)
   case optCommand o of
-    Init                    -> scaffold
+    Init bare       -> scaffold bare
-    Configure               -> cabal ["configure"]
+    HsFiles         -> mkHsFile
-    Build es                -> touch' >> cabal ("build":es)
+    Configure       -> cabal ["configure"]
-    Touch                   -> touch'
+    Build es        -> touch' >> cabal ("build":es)
-    Devel da s f r b _ig es p t nrp -> devel (DevelOpts (optCabalPgm o == CabalDev) da (optVerbose o) r s f b p t (not nrp)) es
+    Touch           -> touch'
-    Keter noRebuild         -> keter (cabalCommand o) noRebuild
+    Keter noRebuild -> keter (cabalCommand o) noRebuild
-    Version                 -> do putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version)
+    Version         -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version)
-    AddHandler              -> addHandler
+    AddHandler      -> addHandler
-    Test                    -> do touch'
+    Test            -> cabalTest cabal
-                                  cabal ["configure", "--enable-tests", "-flibrary-only"]
+    Devel{..}       -> devel (DevelOpts
-                                  cabal ["build"]
+                              (optCabalPgm o == CabalDev) _develDisableApi (optVerbose o)
-                                  cabal ["test"]
+                              _develRescan _develSuccessHook _develFailHook
+                              _develBuildDir _develPort _proxyTimeout
+                              (not _noReverseProxy)
+                              (if _interruptOnly then TerminateOnlyInterrupt else TerminateOnEnter )
+                           ) develExtraArgs
+  where
+    cabalTest cabal = do touch'
+                         _ <- cabal ["configure", "--enable-tests", "-flibrary-only"]
+                         _ <- cabal ["build"]
+                         cabal ["test"]
 
 optParser' :: ParserInfo Options
 optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" )
@@ -109,8 +126,11 @@ optParser :: Parser Options
 optParser = Options
         <$> flag Cabal CabalDev ( long "dev"     <> short 'd' <> help "use cabal-dev" )
         <*> switch              ( long "verbose" <> short 'v' <> help "More verbose output" )
-        <*> subparser ( command "init"      (info (pure Init)
+        <*> subparser ( command "init"
+                            (info (Init <$> (switch (long "bare" <> help "Create files in current folder")))
                             (progDesc "Scaffold a new site"))
+                      <> command "hsfiles" (info (pure HsFiles)
+                            (progDesc "Create a hsfiles file for the current folder"))
                       <> command "configure" (info (pure Configure)
                             (progDesc "Configure a project for building"))
                       <> command "build"     (info (Build <$> extraCabalArgs)
@@ -153,6 +173,8 @@ develOptions = Devel <$> switch ( long "disable-api"  <> short 'd'
                             <> help "Devel server timeout before returning 'not ready' message (in seconds, 0 for none)" )
                      <*> switch ( long "disable-reverse-proxy" <> short 'n'
                             <> help "Disable reverse proxy" )
+                     <*> switch ( long "interrupt-only"  <> short 'c'
+                            <> help "Disable exiting when enter is pressed")
 
 extraCabalArgs :: Parser [String]
 extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG"
@@ -164,7 +186,11 @@ optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String)
 optStr m =
     nullOption $ value Nothing <> reader (success . str)  <> m
   where
+#if MIN_VERSION_optparse_applicative(0,6,0)
+    success = ReadM . Right
+#else
     success = Right
+#endif
 
 -- | Like @rawSystem@, but exits if it receives a non-success result.
 rawSystem' :: String -> [String] -> IO ()

yesod-bin/refreshing.html

@@ -58,7 +58,8 @@
       <h1>The application isn’t built</h1>
       <h2>We’ll keep trying to refresh every second</h2>
       <div class="msgs">
-        <p>Meanwhile, here are some motivational messages:</p>
+        <script> document.getElementsByClassName("msgs")[0].style.display = "none"; </script>
+        <p>Meanwhile, here is a motivational message:</p>
         <ul>
           <li>You are a beautiful person making a beautiful web site.</li>
           <li>Keep going, you’ve nearly fixed the bug!</li>
@@ -66,7 +67,20 @@
           <li>Get a glass of water, keep hydrated.</li>
         </ul>
       </div>
-      <footer><small><script>document.write(new Date())</script></small></footer>
+      <script>
+        var msg = document.getElementsByClassName("msgs")[0];
+        var lis = Array.prototype.slice.call(msg.querySelectorAll("li"));
+        lis.forEach(function(li){ li.style.display = "none"; });
+        lis[Math.floor(Math.random() * lis.length)].style.display = "block";
+        msg.style.display = "block";
+      </script>
+      <footer>
+        <small>
+          <script>
+            document.write(new Date())
+          </script>
+        </small>
+      </footer>
     </div>
   </body>
 </html>

yesod-bin/yesod-bin.cabal

@@ -1,5 +1,5 @@
 name:            yesod-bin
-version:         1.2.2
+version:         1.2.11
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -34,6 +34,7 @@ executable             yesod-ld-wrapper
     build-depends:
                     base                       >= 4         && < 5
                   , Cabal
+
 executable             yesod-ar-wrapper
     main-is: ghcwrapper.hs
     cpp-options:     -DARCMD
@@ -44,15 +45,17 @@ executable             yesod-ar-wrapper
 executable             yesod
     if os(windows)
         cpp-options:     -DWINDOWS
+
     build-depends:     base               >= 4.3          && < 5
-                     , ghc                >= 7.0.3        && < 7.8
+                     , ghc                >= 7.0.3
                      , ghc-paths          >= 0.1
                      , parsec             >= 2.1          && < 4
                      , text               >= 0.11
-                     , shakespeare-text   >= 1.0          && < 1.1
+                     , shakespeare
-                     , shakespeare        >= 1.0.2        && < 1.1
+                     , shakespeare-text   >= 1.0
-                     , shakespeare-js     >= 1.0.2        && < 1.2
+                     , shakespeare        >= 1.0.2        && < 2.1
-                     , shakespeare-css    >= 1.0.2        && < 1.1
+                     , shakespeare-js     >= 1.0.2
+                     , shakespeare-css    >= 1.0.2
                      , bytestring         >= 0.9.1.4
                      , time               >= 1.1.4
                      , template-haskell
@@ -72,11 +75,12 @@ executable             yesod
                      , unordered-containers
                      , yaml               >= 0.8          && < 0.9
                      , optparse-applicative >= 0.5
-                     , fsnotify           >= 0.0          && < 0.1
+                     , fsnotify           >= 0.0          && < 0.2
                      , split              >= 0.2          && < 0.3
                      , file-embed
-                     , conduit            >= 0.5          && < 1.1
+                     , conduit            >= 0.5          && < 1.2
-                     , resourcet          >= 0.3          && < 0.5
+                     , conduit-extra
+                     , resourcet          >= 0.3          && < 1.2
                      , base64-bytestring
                      , lifted-base
                      , http-reverse-proxy >= 0.1.1
@@ -87,8 +91,11 @@ executable             yesod
                      , transformers
                      , warp               >= 1.3.7.5
                      , wai                >= 1.4
+                     , wai-extra
+                     , data-default-class
+                     , streaming-commons
 
-    ghc-options:       -Wall -threaded
+    ghc-options:       -Wall -threaded -rtsopts
     main-is:           main.hs
     other-modules:     Scaffolding.Scaffolder
                        Devel
@@ -98,6 +105,7 @@ executable             yesod
                        AddHandler
                        Paths_yesod_bin
                        Options
+                       HsFile
 
 source-repository head
   type:     git

yesod-core/README

@@ -1 +1 @@
-Learn more at http://docs.yesodweb.com/
+Learn more at http://www.yesodweb.com/

yesod-core/Yesod/Core.hs

@@ -24,6 +24,8 @@ module Yesod.Core
     , widgetToPageContent
       -- * Defaults
     , defaultErrorHandler
+    , defaultYesodMiddleware
+    , authorizationCheck
       -- * Data types
     , AuthResult (..)
     , unauthorizedI

yesod-core/Yesod/Core/Class/Handler.hs

@@ -41,7 +41,7 @@ replaceToParent hd = hd { handlerToParent = const () }
 instance MonadResourceBase m => MonadHandler (HandlerT site m) where
     type HandlerSite (HandlerT site m) = site
     liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent
-{-# RULES "liftHandlerT (HandlerT site IO)" forall action. liftHandlerT action = id #-}
+{-# RULES "liftHandlerT (HandlerT site IO)" liftHandlerT = id #-}
 
 instance MonadResourceBase m => MonadHandler (WidgetT site m) where
     type HandlerSite (WidgetT site m) = site
@@ -61,7 +61,9 @@ GOX(Monoid w, RWST r w s)
 GOX(Monoid w, Strict.RWST r w s)
 GO(Strict.StateT s)
 GOX(Monoid w, Strict.WriterT w)
+#if !MIN_VERSION_resourcet(1,1,0)
 GO(ExceptionT)
+#endif
 GO(Pipe l i o u)
 GO(ConduitM i o)
 #undef GO
@@ -85,7 +87,9 @@ GOX(Monoid w, RWST r w s)
 GOX(Monoid w, Strict.RWST r w s)
 GO(Strict.StateT s)
 GOX(Monoid w, Strict.WriterT w)
+#if !MIN_VERSION_resourcet(1,1,0)
 GO(ExceptionT)
+#endif
 GO(Pipe l i o u)
 GO(ConduitM i o)
 #undef GO

yesod-core/Yesod/Core/Class/Yesod.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE CPP               #-}
 module Yesod.Core.Class.Yesod where
 
 import           Control.Monad.Logger               (logErrorS)
@@ -39,10 +40,16 @@ import           Data.Default                       (def)
 import           Network.Wai.Parse                  (lbsBackEnd,
                                                      tempFileBackEnd)
 import           System.IO                          (stdout)
+#if MIN_VERSION_fast_logger(2, 0, 0)
+import           Network.Wai.Logger                 (ZonedDate, clockDateCacher)
+import           System.Log.FastLogger
+import qualified GHC.IO.FD
+#else
+import           System.Log.FastLogger.Date         (ZonedDate)
 import           System.Log.FastLogger              (LogStr (..), Logger,
                                                      loggerDate, loggerPutStr,
                                                      mkLogger)
-import           System.Log.FastLogger.Date         (ZonedDate)
+#endif
 import           Text.Blaze                         (customAttribute, textTag,
                                                      toValue, (!))
 import           Text.Blaze                         (preEscapedToMarkup)
@@ -209,7 +216,18 @@ class RenderRoute site => Yesod site where
     --
     -- Default: Sends to stdout and automatically flushes on each write.
     makeLogger :: site -> IO Logger
+#if MIN_VERSION_fast_logger(2, 0, 0)
+    makeLogger _ = do
+#if MIN_VERSION_fast_logger(2, 1, 0)
+        loggerSet <- newLoggerSet defaultBufSize Nothing
+#else
+        loggerSet <- newLoggerSet defaultBufSize GHC.IO.FD.stdout
+#endif
+        (getter, _) <- clockDateCacher
+        return $! Logger loggerSet getter
+#else
     makeLogger _ = mkLogger True stdout
+#endif
 
     -- | Send a message to the @Logger@ provided by @getLogger@.
     --
@@ -498,7 +516,7 @@ defaultErrorHandler (BadMethod m) = selectRep $ do
             <h1>Method Not Supported
             <p>Method <code>#{S8.unpack m}</code> not supported
         |]
-    provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= m]
+    provideRep $ return $ object ["message" .= ("Bad method" :: Text), "method" .= TE.decodeUtf8With TEE.lenientDecode m]
 
 asyncHelper :: (url -> [x] -> Text)
          -> [Script (url)]
@@ -523,6 +541,30 @@ asyncHelper render scripts jscript jsLoc =
                     Nothing -> Nothing
                     Just j -> Just $ jelper j
 
+#if MIN_VERSION_fast_logger(2, 0, 0)
+formatLogMessage :: IO ZonedDate
+                 -> Loc
+                 -> LogSource
+                 -> LogLevel
+                 -> LogStr -- ^ message
+                 -> IO LogStr
+formatLogMessage getdate loc src level msg = do
+    now <- getdate
+    return $
+        toLogStr now `mappend`
+        " [" `mappend`
+        (case level of
+            LevelOther t -> toLogStr t
+            _ -> toLogStr $ drop 5 $ show level) `mappend`
+        (if T.null src
+            then mempty
+            else "#" `mappend` toLogStr src) `mappend`
+        "] " `mappend`
+        msg `mappend`
+        " @(" `mappend`
+        toLogStr (fileLocationToString loc) `mappend`
+        ")\n"
+#else
 formatLogMessage :: IO ZonedDate
                  -> Loc
                  -> LogSource
@@ -548,7 +590,7 @@ formatLogMessage getdate loc src level msg = do
         , LS $ fileLocationToString loc
         , LB ")\n"
         ]
-
+#endif
 
 -- | Customize the cookies used by the session backend.  You may
 -- use this function on your definition of 'makeSessionBackend'.

yesod-core/Yesod/Core/Content.hs

@@ -60,7 +60,8 @@ import Data.Monoid (mempty)
 
 import Text.Hamlet (Html)
 import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
-import Data.Conduit (Source, ResourceT, Flush (Chunk), ResumableSource, mapOutput)
+import Data.Conduit (Source, Flush (Chunk), ResumableSource, mapOutput)
+import Control.Monad.Trans.Resource (ResourceT)
 import Data.Conduit.Internal (ResumableSource (ResumableSource))
 
 import qualified Data.Aeson as J
@@ -68,6 +69,8 @@ import Data.Aeson.Encode (fromValue)
 import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze
 import Data.Text.Lazy.Builder (toLazyText)
 import Yesod.Core.Types
+import Text.Lucius (Css, renderCss)
+import Text.Julius (Javascript, unJavascript)
 
 -- | Zero-length enumerator.
 emptyContent :: Content
@@ -107,6 +110,11 @@ instance ToContent (ContentType, Content) where
 instance ToContent TypedContent where
     toContent (TypedContent _ c) = c
 
+instance ToContent Css where
+    toContent = toContent . renderCss
+instance ToContent Javascript where
+    toContent = toContent . toLazyText . unJavascript
+
 instance ToFlushBuilder builder => ToContent (Source (ResourceT IO) builder) where
     toContent src = ContentSource $ mapOutput toFlushBuilder src
 instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) builder) where
@@ -244,6 +252,12 @@ instance HasContentType Text where
 instance HasContentType T.Text where
     getContentType _ = typePlain
 
+instance HasContentType Css where
+    getContentType _ = typeCss
+
+instance HasContentType Javascript where
+    getContentType _ = typeJavascript
+
 -- | Any type which can be converted to 'TypedContent'.
 --
 -- Since 1.2.0
@@ -276,3 +290,8 @@ instance ToTypedContent a => ToTypedContent (DontFullyEvaluate a) where
     toTypedContent (DontFullyEvaluate a) =
         let TypedContent ct c = toTypedContent a
          in TypedContent ct (ContentDontEvaluate c)
+
+instance ToTypedContent Css where
+    toTypedContent = TypedContent typeCss . toContent
+instance ToTypedContent Javascript where
+    toTypedContent = TypedContent typeJavascript . toContent

yesod-core/Yesod/Core/Dispatch.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE CPP #-}
 module Yesod.Core.Dispatch
     ( -- * Quasi-quoted routing
       parseRoutes
@@ -26,6 +27,7 @@ module Yesod.Core.Dispatch
     , warpDebug
     , warpEnv
     , mkDefaultMiddlewares
+    , defaultMiddlewaresNoLogging
       -- * WAI subsites
     , WaiSubsite (..)
     ) where
@@ -40,7 +42,7 @@ import qualified Network.Wai as W
 
 import Data.ByteString.Lazy.Char8 ()
 
-import Data.Text (Text)
+import Data.Text (Text, pack)
 import Data.Monoid (mappend)
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Char8 as S8
@@ -63,6 +65,7 @@ import Network.Wai.Middleware.MethodOverride
 import qualified Network.Wai.Handler.Warp
 import System.Log.FastLogger
 import Control.Monad.Logger
+import Control.Monad (when)
 import qualified Paths_yesod_core
 import Data.Version (showVersion)
 
@@ -89,8 +92,13 @@ toWaiAppYre yre req =
   where
     site = yreSite yre
     sendRedirect :: Yesod master => master -> [Text] -> W.Application
+#if MIN_VERSION_wai(3, 0, 0)
+    sendRedirect y segments' env sendResponse =
+         sendResponse $ W.responseLBS status301
+#else
     sendRedirect y segments' env =
          return $ W.responseLBS status301
+#endif
                 [ ("Content-Type", "text/plain")
                 , ("Location", Blaze.ByteString.Builder.toByteString dest')
                 ] "Redirecting"
@@ -117,6 +125,10 @@ toWaiAppYre yre req =
 toWaiApp :: YesodDispatch site => site -> IO W.Application
 toWaiApp site = do
     logger <- makeLogger site
+    toWaiAppLogger logger site
+
+toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application
+toWaiAppLogger logger site = do
     sb <- makeSessionBackend site
     let yre = YesodRunnerEnv
                 { yreLogger = logger
@@ -143,17 +155,37 @@ toWaiApp site = do
 --
 -- Since 1.2.0
 warp :: YesodDispatch site => Int -> site -> IO ()
-warp port site = toWaiApp site >>= Network.Wai.Handler.Warp.runSettings
+warp port site = do
-    Network.Wai.Handler.Warp.defaultSettings
+    logger <- makeLogger site
-        { Network.Wai.Handler.Warp.settingsPort = port
+    toWaiAppLogger logger site >>= Network.Wai.Handler.Warp.runSettings
-        , Network.Wai.Handler.Warp.settingsServerName = S8.pack $ concat
+        Network.Wai.Handler.Warp.defaultSettings
-            [ "Warp/"
+            { Network.Wai.Handler.Warp.settingsPort = port
-            , Network.Wai.Handler.Warp.warpVersion
+            {- FIXME
-            , " + Yesod/"
+            , Network.Wai.Handler.Warp.settingsServerName = S8.pack $ concat
-            , showVersion Paths_yesod_core.version
+                [ "Warp/"
-            , " (core)"
+                , Network.Wai.Handler.Warp.warpVersion
-            ]
+                , " + Yesod/"
-        }
+                , showVersion Paths_yesod_core.version
+                , " (core)"
+                ]
+            -}
+            , Network.Wai.Handler.Warp.settingsOnException = const $ \e ->
+                when (shouldLog' e) $
+                messageLoggerSource
+                    site
+                    logger
+                    $(qLocation >>= liftLoc)
+                    "yesod-core"
+                    LevelError
+                    (toLogStr $ "Exception from Warp: " ++ show e)
+            }
+  where
+    shouldLog' =
+#if MIN_VERSION_warp(2,1,3)
+        Network.Wai.Handler.Warp.defaultShouldDisplayException
+#else
+        const True
+#endif
 
 -- | A default set of middlewares.
 --
@@ -161,14 +193,20 @@ warp port site = toWaiApp site >>= Network.Wai.Handler.Warp.runSettings
 mkDefaultMiddlewares :: Logger -> IO W.Middleware
 mkDefaultMiddlewares logger = do
     logWare <- mkRequestLogger def
+#if MIN_VERSION_fast_logger(2, 0, 0)
+        { destination = Network.Wai.Middleware.RequestLogger.Logger $ loggerSet logger
+#else
         { destination = Logger logger
+#endif
         , outputFormat = Apache FromSocket
         }
-    return $ logWare
+    return $ logWare . defaultMiddlewaresNoLogging
-           . acceptOverride
+
-           . autohead
+-- | All of the default middlewares, excluding logging.
-           . gzip def
+--
-           . methodOverride
+-- Since 1.2.12
+defaultMiddlewaresNoLogging :: W.Middleware
+defaultMiddlewaresNoLogging = acceptOverride . autohead . gzip def . methodOverride
 
 -- | Deprecated synonym for 'warp'.
 warpDebug :: YesodDispatch site => Int -> site -> IO ()

yesod-core/Yesod/Core/Handler.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP                        #-}
 {-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE ConstraintKinds            #-}
 {-# LANGUAGE FlexibleInstances          #-}
@@ -8,6 +9,7 @@
 {-# LANGUAGE TupleSections              #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE DeriveDataTypeable         #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Handler
@@ -73,6 +75,7 @@ module Yesod.Core.Handler
     , redirect
     , redirectWith
     , redirectToPost
+    , Fragment(..)
       -- ** Errors
     , notFound
     , badMethod
@@ -88,6 +91,13 @@ module Yesod.Core.Handler
     , sendResponseStatus
     , sendResponseCreated
     , sendWaiResponse
+    , sendWaiApplication
+#if MIN_VERSION_wai(2, 1, 0)
+    , sendRawResponse
+#endif
+#if MIN_VERSION_wai(3, 0, 0)
+    , sendRawResponseNoConduit
+#endif
       -- * Different representations
       -- $representations
     , selectRep
@@ -133,6 +143,7 @@ module Yesod.Core.Handler
     , newIdent
       -- * Lifting
     , handlerToIO
+    , forkHandler
       -- * i18n
     , getMessageRender
       -- * Per-request caching
@@ -145,18 +156,17 @@ import           Yesod.Core.Internal.Request   (langKey, mkFileInfoFile,
                                                 mkFileInfoLBS, mkFileInfoSource)
 
 import           Control.Applicative           ((<$>), (<|>))
-import           Control.Exception             (evaluate)
+import           Control.Exception             (evaluate, SomeException)
+import           Control.Exception.Lifted      (handle)
 
-import           Control.Monad                 (liftM)
+import           Control.Monad                 (liftM, void)
 import qualified Control.Monad.Trans.Writer    as Writer
 
 import           Control.Monad.IO.Class        (MonadIO, liftIO)
-import           Control.Monad.Trans.Resource  (MonadResource, liftResourceT)
 
 import qualified Network.HTTP.Types            as H
 import qualified Network.Wai                   as W
 import Control.Monad.Trans.Class (lift)
-import Data.Conduit (transPipe, Flush (Flush), yield, Producer)
 
 import qualified Data.Text                     as T
 import           Data.Text.Encoding            (decodeUtf8With, encodeUtf8)
@@ -169,10 +179,8 @@ import qualified Data.ByteString               as S
 import qualified Data.ByteString.Lazy          as L
 import qualified Data.Map                      as Map
 
-import Data.Conduit (Source)
 import           Control.Arrow                 ((***))
 import qualified Data.ByteString.Char8         as S8
-import           Data.Maybe                    (mapMaybe)
 import           Data.Monoid                   (Endo (..), mappend, mempty)
 import           Data.Text                     (Text)
 import qualified Network.Wai.Parse             as NWP
@@ -182,18 +190,37 @@ import           Yesod.Core.Content            (ToTypedContent (..), simpleConte
 import           Yesod.Core.Internal.Util      (formatRFC1123)
 import           Text.Blaze.Html               (preEscapedToMarkup, toHtml)
 
-import           Control.Monad.Trans.Resource  (ResourceT, runResourceT, withInternalState)
 import           Data.Dynamic                  (fromDynamic, toDyn)
 import qualified Data.IORef.Lifted             as I
-import           Data.Maybe                    (listToMaybe)
+import           Data.Maybe                    (listToMaybe, mapMaybe)
 import           Data.Typeable                 (Typeable, typeOf)
+import           Web.PathPieces                (PathPiece(..))
 import           Yesod.Core.Class.Handler
 import           Yesod.Core.Types
 import           Yesod.Routes.Class            (Route)
-import Control.Failure (failure)
+import Control.Exception (throwIO)
 import Blaze.ByteString.Builder (Builder)
 import Safe (headMay)
 import Data.CaseInsensitive (CI)
+import qualified Data.Conduit.List as CL
+import Control.Monad (unless)
+import           Control.Monad.Trans.Resource  (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO
+#if MIN_VERSION_wai(2, 0, 0)
+#else
+              , ResourceT
+#endif
+              )
+#if MIN_VERSION_wai(2, 0, 0)
+import qualified System.PosixCompat.Files as PC
+#endif
+#if MIN_VERSION_wai(2, 1, 0)
+import Control.Monad.Trans.Control (control, MonadBaseControl)
+#endif
+import Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer
+#if MIN_VERSION_wai(2, 1, 0)
+                    , Sink
+#endif
+                   )
 
 get :: MonadHandler m => m GHState
 get = liftHandlerT $ HandlerT $ I.readIORef . handlerState
@@ -208,7 +235,7 @@ tell :: MonadHandler m => Endo [Header] -> m ()
 tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
 
 handlerError :: MonadHandler m => HandlerContents -> m a
-handlerError = liftHandlerT . failure
+handlerError = liftIO . throwIO
 
 hcError :: MonadHandler m => ErrorResponse -> m a
 hcError = handlerError . HCError
@@ -229,21 +256,41 @@ runRequestBody = do
         Just rbc -> return rbc
         Nothing -> do
             rr <- waiRequest
+#if MIN_VERSION_wai_extra(2, 0, 1)
+            internalState <- liftResourceT getInternalState
+            rbc <- liftIO $ rbHelper upload rr internalState
+#elif MIN_VERSION_wai(2, 0, 0)
+            rbc <- liftIO $ rbHelper upload rr
+#else
             rbc <- liftResourceT $ rbHelper upload rr
+#endif
             put x { ghsRBC = Just rbc }
             return rbc
 
+#if MIN_VERSION_wai(2, 0, 0)
+rbHelper :: FileUpload -> W.Request -> InternalState -> IO RequestBodyContents
+rbHelper upload req internalState =
+#else
 rbHelper :: FileUpload -> W.Request -> ResourceT IO RequestBodyContents
-rbHelper upload =
+rbHelper upload req =
+#endif
     case upload of
-        FileUploadMemory s -> rbHelper' s mkFileInfoLBS
+        FileUploadMemory s -> rbHelper' s mkFileInfoLBS req
-        FileUploadDisk s -> rbHelper' s mkFileInfoFile
+#if MIN_VERSION_wai_extra(2, 0, 1)
-        FileUploadSource s -> rbHelper' s mkFileInfoSource
+        FileUploadDisk s -> rbHelper' (s internalState) mkFileInfoFile req
+#else
+        FileUploadDisk s -> rbHelper' s mkFileInfoFile req
+#endif
+        FileUploadSource s -> rbHelper' s mkFileInfoSource req
 
 rbHelper' :: NWP.BackEnd x
           -> (Text -> Text -> x -> FileInfo)
           -> W.Request
+#if MIN_VERSION_wai(2, 0, 0)
+          -> IO ([(Text, Text)], [(Text, FileInfo)])
+#else
           -> ResourceT IO ([(Text, Text)], [(Text, FileInfo)])
+#endif
 rbHelper' backend mkFI req =
     (map fix1 *** mapMaybe fix2) <$> (NWP.parseRequestBody backend req)
   where
@@ -327,7 +374,11 @@ handlerToIO =
           where
             oldReq    = handlerRequest oldHandlerData
             oldWaiReq = reqWaiRequest oldReq
+#if MIN_VERSION_wai(3, 0, 0)
+            newWaiReq = oldWaiReq { W.requestBody = return mempty
+#else
             newWaiReq = oldWaiReq { W.requestBody = mempty
+#endif
                                   , W.requestBodyLength = W.KnownLength 0
                                   }
         oldEnv = handlerEnv oldHandlerData
@@ -358,6 +409,18 @@ handlerToIO =
                 }
         liftIO (f newHandlerData)
 
+-- | forkIO for a Handler (run an action in the background)
+--
+-- Uses 'handlerToIO', liftResourceT, and resourceForkIO
+-- for correctness and efficiency
+--
+-- Since 1.2.8
+forkHandler :: (SomeException -> HandlerT site IO ()) -- ^ error handler
+              -> HandlerT site IO ()
+              -> HandlerT site IO ()
+forkHandler onErr handler = do
+    yesRunner <- handlerToIO
+    void $ liftResourceT $ resourceForkIO $ yesRunner $ handle onErr handler
 
 -- | Redirect to the given route.
 -- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0
@@ -486,8 +549,17 @@ sendFilePart :: MonadHandler m
              -> Integer -- ^ offset
              -> Integer -- ^ count
              -> m a
-sendFilePart ct fp off count =
+sendFilePart ct fp off count = do
+#if MIN_VERSION_wai(2, 0, 0)
+    fs <- liftIO $ PC.getFileStatus fp
+    handlerError $ HCSendFile ct fp $ Just W.FilePart
+        { W.filePartOffset = off
+        , W.filePartByteCount = count
+        , W.filePartFileSize = fromIntegral $ PC.fileSize fs
+        }
+#else
     handlerError $ HCSendFile ct fp $ Just $ W.FilePart off count
+#endif
 
 -- | Bypass remaining handler code and output the given content with a 200
 -- status code.
@@ -514,6 +586,61 @@ sendResponseCreated url = do
 sendWaiResponse :: MonadHandler m => W.Response -> m b
 sendWaiResponse = handlerError . HCWai
 
+-- | Switch over to handling the current request with a WAI @Application@.
+--
+-- Since 1.2.17
+sendWaiApplication :: MonadHandler m => W.Application -> m b
+sendWaiApplication = handlerError . HCWaiApp
+
+#if MIN_VERSION_wai(3, 0, 0)
+-- | Send a raw response without conduit. This is used for cases such as
+-- WebSockets. Requires WAI 3.0 or later, and a web server which supports raw
+-- responses (e.g., Warp).
+--
+-- Since 1.2.16
+sendRawResponseNoConduit
+    :: (MonadHandler m, MonadBaseControl IO m)
+    => (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ())
+    -> m a
+sendRawResponseNoConduit raw = control $ \runInIO ->
+    runInIO $ sendWaiResponse $ flip W.responseRaw fallback
+    $ \src sink -> runInIO (raw src sink) >> return ()
+  where
+    fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]
+        "sendRawResponse: backend does not support raw responses"
+#endif
+
+#if MIN_VERSION_wai(2, 1, 0)
+-- | Send a raw response. This is used for cases such as WebSockets. Requires
+-- WAI 2.1 or later, and a web server which supports raw responses (e.g.,
+-- Warp).
+--
+-- Since 1.2.7
+sendRawResponse :: (MonadHandler m, MonadBaseControl IO m)
+                => (Source IO S8.ByteString -> Sink S8.ByteString IO () -> m ())
+                -> m a
+#if MIN_VERSION_wai(3, 0, 0)
+sendRawResponse raw = control $ \runInIO ->
+    runInIO $ sendWaiResponse $ flip W.responseRaw fallback
+    $ \src sink -> runInIO (raw (src' src) (CL.mapM_ sink)) >> return ()
+  where
+    fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]
+        "sendRawResponse: backend does not support raw responses"
+    src' src = do
+        bs <- liftIO src
+        unless (S.null bs) $ do
+            yield bs
+            src' src
+#else
+sendRawResponse raw = control $ \runInIO ->
+    runInIO $ sendWaiResponse $ flip W.responseRaw fallback
+    $ \src sink -> runInIO (raw src sink) >> return ()
+  where
+    fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]
+        "sendRawResponse: backend does not support raw responses"
+#endif
+#endif
+
 -- | Return a 404 not found page. Also denotes no handler available.
 notFound :: MonadHandler m => m a
 notFound = hcError NotFound
@@ -607,7 +734,12 @@ cacheSeconds i = setHeader "Cache-Control" $ T.concat
 -- | Set the Expires header to some date in 2037. In other words, this content
 -- is never (realistically) expired.
 neverExpires :: MonadHandler m => m ()
-neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
+neverExpires = do
+    setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
+    cacheSeconds oneYear
+  where
+    oneYear :: Int
+    oneYear = 60 * 60 * 24 * 365
 
 -- | Set an Expires header in the past, meaning this content should not be
 -- cached.
@@ -677,6 +809,18 @@ instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, va
 instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, Map.Map key val) where
     toTextUrl (url, params) = toTextUrl (url, Map.toList params)
 
+-- | Add a fragment identifier to a route to be used when
+-- redirecting.  For example:
+--
+-- > redirect (NewsfeedR :#: storyId)
+--
+-- Since 1.2.9.
+data Fragment a b = a :#: b deriving (Show, Typeable)
+
+instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b) where
+  toTextUrl (a :#: b) = (\ua -> T.concat [ua, "#", toPathPiece b]) <$> toTextUrl a
+
+
 -- | Lookup for session data.
 lookupSession :: MonadHandler m => Text -> m (Maybe Text)
 lookupSession = (liftM . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS
@@ -697,7 +841,7 @@ newIdent = do
     x <- get
     let i' = ghsIdent x + 1
     put x { ghsIdent = i' }
-    return $ T.pack $ 'h' : show i'
+    return $ T.pack $ "hident" ++ show i'
 
 -- | Redirect to a POST resource.
 --
@@ -916,7 +1060,7 @@ selectRep w = do
         ]) reps
 
     -- match on the type for sub-type wildcards.
-    -- If the accept is text/* it should match a provided text/html
+    -- If the accept is text/ * it should match a provided text/html
     mainTypeMap = Map.fromList $ reverse $ map
       (\v@(ProvidedRep ct _) -> (fst $ contentTypeTypes ct, v)) reps
 
@@ -972,7 +1116,22 @@ provideRepType ct handler =
 rawRequestBody :: MonadHandler m => Source m S.ByteString
 rawRequestBody = do
     req <- lift waiRequest
-    transPipe liftResourceT $ W.requestBody req
+#if MIN_VERSION_wai(3, 0, 0)
+    let loop = do
+            bs <- liftIO $ W.requestBody req
+            unless (S.null bs) $ do
+                yield bs
+                loop
+    loop
+#else
+    transPipe
+#if MIN_VERSION_wai(2, 0, 0)
+        liftIO
+#else
+        liftResourceT
+#endif
+        (W.requestBody req)
+#endif
 
 -- | Stream the data from the file. Since Yesod 1.2, this has been generalized
 -- to work in any @MonadResource@.

yesod-core/Yesod/Core/Internal/Request.hs

@@ -40,14 +40,32 @@ import Data.Conduit.List (sourceList)
 import Data.Conduit.Binary (sourceFile, sinkFile)
 import Data.Word (Word64)
 import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Resource (runResourceT, ResourceT)
 import Control.Exception (throwIO)
 import Yesod.Core.Types
 import qualified Data.Map as Map
+import Data.IORef
 
 -- | Impose a limit on the size of the request body.
-limitRequestBody :: Word64 -> W.Request -> W.Request
+limitRequestBody :: Word64 -> W.Request -> IO W.Request
+#if MIN_VERSION_wai(3, 0, 0)
+limitRequestBody maxLen req = do
+    ref <- newIORef maxLen
+    return req
+        { W.requestBody = do
+            bs <- W.requestBody req
+            remaining <- readIORef ref
+            let len = fromIntegral $ S8.length bs
+                remaining' = remaining - len
+            if remaining < len
+                then throwIO $ HCWai tooLargeResponse
+                else do
+                    writeIORef ref remaining'
+                    return bs
+        }
+#else
 limitRequestBody maxLen req =
-    req { W.requestBody = W.requestBody req $= limit maxLen }
+    return req { W.requestBody = W.requestBody req $= limit maxLen }
   where
     tooLarge = liftIO $ throwIO $ HCWai tooLargeResponse
 
@@ -62,6 +80,7 @@ limitRequestBody maxLen req =
                 else do
                     yield bs
                     limit $ remaining - len
+#endif
 
 tooLargeResponse :: W.Response
 tooLargeResponse = W.responseLBS
@@ -74,7 +93,7 @@ parseWaiRequest :: RandomGen g
                 -> SessionMap
                 -> Bool
                 -> Maybe Word64 -- ^ max body size
-                -> (Either YesodRequest (g -> YesodRequest))
+                -> (Either (IO YesodRequest) (g -> IO YesodRequest))
 parseWaiRequest env session useToken mmaxBodySize =
     -- In most cases, we won't need to generate any random values. Therefore,
     -- we split our results: if we need a random generator, return a Right
@@ -84,17 +103,19 @@ parseWaiRequest env session useToken mmaxBodySize =
         Left token -> Left $ mkRequest token
         Right mkToken -> Right $ mkRequest . mkToken
   where
-    mkRequest token' = YesodRequest
+    mkRequest token' = do
-        { reqGetParams  = gets
+        envLimited <- maybe return limitRequestBody mmaxBodySize env
-        , reqCookies    = cookies
+        return YesodRequest
-        , reqWaiRequest = maybe id limitRequestBody mmaxBodySize env
+            { reqGetParams  = gets
-        , reqLangs      = langs''
+            , reqCookies    = cookies
-        , reqToken      = token'
+            , reqWaiRequest = envLimited
-        , reqSession    = if useToken
+            , reqLangs      = langs''
-                            then Map.delete tokenKey session
+            , reqToken      = token'
-                            else session
+            , reqSession    = if useToken
-        , reqAccept     = httpAccept env
+                                then Map.delete tokenKey session
-        }
+                                else session
+            , reqAccept     = httpAccept env
+            }
     gets = textQueryString env
     reqCookie = lookup "Cookie" $ W.requestHeaders env
     cookies = maybe [] parseCookiesText reqCookie

yesod-core/Yesod/Core/Internal/Response.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP               #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternGuards     #-}
 {-# LANGUAGE RankNTypes        #-}
@@ -12,6 +13,13 @@ import qualified Data.ByteString.Char8        as S8
 import           Data.CaseInsensitive         (CI)
 import qualified Data.CaseInsensitive         as CI
 import           Network.Wai
+#if MIN_VERSION_wai(2, 0, 0)
+import           Data.Conduit                 (transPipe)
+import           Control.Monad.Trans.Resource (runInternalState, getInternalState, runResourceT, InternalState, closeInternalState)
+import           Control.Monad.Trans.Class    (lift)
+import           Network.Wai.Internal
+import           Control.Exception            (finally)
+#endif
 import           Prelude                      hiding (catch)
 import           Web.Cookie                   (renderSetCookie)
 import           Yesod.Core.Content
@@ -25,14 +33,20 @@ import qualified Data.ByteString.Lazy         as L
 import qualified Data.Map                     as Map
 import           Yesod.Core.Internal.Request  (tokenKey)
 import           Data.Text.Encoding           (encodeUtf8)
+import           Data.Conduit                 (Flush (..), ($$))
+import qualified Data.Conduit.List            as CL
 
-yarToResponse :: Monad m
+#if MIN_VERSION_wai(3, 0, 0)
-              => YesodResponse
+yarToResponse :: YesodResponse
-              -> (SessionMap -> m [Header]) -- ^ save session
+              -> (SessionMap -> IO [Header]) -- ^ save session
               -> YesodRequest
-              -> m Response
+              -> Request
-yarToResponse (YRWai a) _ _ = return a
+              -> InternalState
-yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq = do
+              -> (Response -> IO ResponseReceived)
+              -> IO ResponseReceived
+yarToResponse (YRWai a) _ _ _ _ sendResponse = sendResponse a
+yarToResponse (YRWaiApp app) _ _ req _ sendResponse = app req sendResponse
+yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req is sendResponse = do
     extraHeaders <- do
         let nsToken = maybe
                 newSess
@@ -43,6 +57,88 @@ yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq = do
     let finalHeaders = extraHeaders ++ map headerToPair hs
         finalHeaders' len = ("Content-Length", S8.pack $ show len)
                           : finalHeaders
+
+    let go (ContentBuilder b mlen) = do
+            let hs' = maybe finalHeaders finalHeaders' mlen
+            sendResponse $ ResponseBuilder s hs' b
+        go (ContentFile fp p) = do
+            sendResponse $ ResponseFile s finalHeaders fp p
+        go (ContentSource body) = sendResponse $ responseStream s finalHeaders
+            $ \sendChunk flush -> do
+                transPipe (flip runInternalState is) body
+                $$ CL.mapM_ (\mchunk ->
+                    case mchunk of
+                        Flush -> flush
+                        Chunk builder -> sendChunk builder)
+        go (ContentDontEvaluate c') = go c'
+    go c
+  where
+    s
+        | s' == defaultStatus = H.status200
+        | otherwise = s'
+
+#else
+yarToResponse :: YesodResponse
+              -> (SessionMap -> IO [Header]) -- ^ save session
+              -> YesodRequest
+              -> Request
+#if MIN_VERSION_wai(2, 0, 0)
+              -> InternalState
+#endif
+              -> IO Response
+#if MIN_VERSION_wai(2, 0, 0)
+yarToResponse (YRWaiApp app) _ _ req _ = app req
+yarToResponse (YRWai a) _ _ _ is =
+    case a of
+        ResponseSource s hs w -> return $ ResponseSource s hs $ \f ->
+            w f `finally` closeInternalState is
+        ResponseBuilder{} -> do
+            closeInternalState is
+            return a
+        ResponseFile{} -> do
+            closeInternalState is
+            return a
+#if MIN_VERSION_wai(2, 1, 0)
+        -- Ignore the fallback provided, in case it refers to a ResourceT state
+        -- in a ResponseSource.
+        ResponseRaw raw _ -> return $ ResponseRaw
+            (\f -> raw f `finally` closeInternalState is)
+            (responseLBS H.status500 [("Content-Type", "text/plain")]
+                "yarToResponse: backend does not support raw responses")
+#endif
+#else
+yarToResponse (YRWai a) _ _ _ = return a
+#endif
+yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq req
+#if MIN_VERSION_wai(2, 0, 0)
+  is
+#endif
+  = do
+    extraHeaders <- do
+        let nsToken = maybe
+                newSess
+                (\n -> Map.insert tokenKey (encodeUtf8 n) newSess)
+                (reqToken yreq)
+        sessionHeaders <- saveSession nsToken
+        return $ ("Content-Type", ct) : map headerToPair sessionHeaders
+    let finalHeaders = extraHeaders ++ map headerToPair hs
+        finalHeaders' len = ("Content-Length", S8.pack $ show len)
+                          : finalHeaders
+
+#if MIN_VERSION_wai(2, 0, 0)
+    let go (ContentBuilder b mlen) = do
+            let hs' = maybe finalHeaders finalHeaders' mlen
+            closeInternalState is
+            return $ ResponseBuilder s hs' b
+        go (ContentFile fp p) = do
+            closeInternalState is
+            return $ ResponseFile s finalHeaders fp p
+        go (ContentSource body) = return $ ResponseSource s finalHeaders $ \f ->
+            f (transPipe (flip runInternalState is) body) `finally`
+            closeInternalState is
+        go (ContentDontEvaluate c') = go c'
+    go c
+#else
     let go (ContentBuilder b mlen) =
             let hs' = maybe finalHeaders finalHeaders' mlen
              in ResponseBuilder s hs' b
@@ -50,10 +146,12 @@ yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq = do
         go (ContentSource body) = ResponseSource s finalHeaders body
         go (ContentDontEvaluate c') = go c'
     return $ go c
+#endif
   where
     s
         | s' == defaultStatus = H.status200
         | otherwise = s'
+#endif
 
 -- | Indicates that the user provided no specific status code to be used, and
 -- therefore the default status code should be used. For normal responses, this
@@ -87,7 +185,9 @@ headerToPair (Header key value) = (CI.mk key, value)
 evaluateContent :: Content -> IO (Either ErrorResponse Content)
 evaluateContent (ContentBuilder b mlen) = handle f $ do
     let lbs = toLazyByteString b
-    L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen)
+        len = L.length lbs
+        mlen' = maybe (Just $ fromIntegral len) Just mlen
+    len `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen')
   where
     f :: SomeException -> IO (Either ErrorResponse Content)
     f = return . Left . InternalError . T.pack . show

yesod-core/Yesod/Core/Internal/Run.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP               #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternGuards     #-}
 {-# LANGUAGE RankNTypes        #-}
@@ -9,13 +10,15 @@ module Yesod.Core.Internal.Run where
 import Yesod.Core.Internal.Response
 import           Blaze.ByteString.Builder     (toByteString)
 import           Control.Applicative          ((<$>))
-import           Control.Exception            (fromException)
+import           Control.Exception            (fromException, bracketOnError, evaluate)
+import qualified Control.Exception            as E
 import           Control.Exception.Lifted     (catch)
+import           Control.Monad                (mplus)
 import           Control.Monad.IO.Class       (MonadIO)
 import           Control.Monad.IO.Class       (liftIO)
 import           Control.Monad.Logger         (LogLevel (LevelError), LogSource,
                                                liftLoc)
-import           Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState)
+import           Control.Monad.Trans.Resource (runResourceT, withInternalState, runInternalState, createInternalState, closeInternalState)
 import qualified Data.ByteString              as S
 import qualified Data.ByteString.Char8        as S8
 import qualified Data.IORef                   as I
@@ -31,8 +34,13 @@ import           Data.Text.Encoding.Error     (lenientDecode)
 import           Language.Haskell.TH.Syntax   (Loc, qLocation)
 import qualified Network.HTTP.Types           as H
 import           Network.Wai
+#if MIN_VERSION_wai(2, 0, 0)
+import           Network.Wai.Internal
+#endif
 import           Prelude                      hiding (catch)
+#if !MIN_VERSION_fast_logger(2, 0, 0)
 import           System.Log.FastLogger        (Logger)
+#endif
 import           System.Log.FastLogger        (LogStr, toLogStr)
 import           System.Random                (newStdGen)
 import           Yesod.Core.Content
@@ -41,6 +49,19 @@ import           Yesod.Core.Types
 import           Yesod.Core.Internal.Request  (parseWaiRequest,
                                                tooLargeResponse)
 import           Yesod.Routes.Class           (Route, renderRoute)
+import Control.DeepSeq (($!!), NFData)
+import Control.Monad (liftM)
+
+returnDeepSessionMap :: Monad m => SessionMap -> m SessionMap
+#if MIN_VERSION_bytestring(0, 10, 0)
+returnDeepSessionMap sm = return $!! sm
+#else
+returnDeepSessionMap sm = fmap unWrappedBS `liftM` (return $!! fmap WrappedBS sm)
+
+-- | Work around missing NFData instance for bytestring 0.9.
+newtype WrappedBS = WrappedBS { unWrappedBS :: S8.ByteString }
+instance NFData WrappedBS
+#endif
 
 -- | Function used internally by Yesod in the process of converting a
 -- 'HandlerT' into an 'Application'. Should not be needed by users.
@@ -71,29 +92,43 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
         (\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
                       $ fromException e)
     state <- liftIO $ I.readIORef istate
-    let finalSession = ghsSession state
+
-    let headers = ghsHeaders state
+    (finalSession, mcontents1) <- (do
-    let contents = either id (HCContent defaultStatus . toTypedContent) contents'
+        finalSession <- returnDeepSessionMap (ghsSession state)
+        return (finalSession, Nothing)) `E.catch` \e -> return
+            (Map.empty, Just $! HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
+
+    (headers, mcontents2) <- (do
+        headers <- return $!! appEndo (ghsHeaders state) []
+        return (headers, Nothing)) `E.catch` \e -> return
+            ([], Just $! HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
+
+    let contents =
+            case mcontents1 `mplus` mcontents2 of
+                Just x -> x
+                Nothing -> either id (HCContent defaultStatus . toTypedContent) contents'
     let handleError e = flip runInternalState resState $ do
             yar <- rheOnError e yreq
                 { reqSession = finalSession
                 }
             case yar of
                 YRPlain status' hs ct c sess ->
-                    let hs' = appEndo headers hs
+                    let hs' = headers ++ hs
                         status
                             | status' == defaultStatus = getStatus e
                             | otherwise = status'
                      in return $ YRPlain status hs' ct c sess
                 YRWai _ -> return yar
     let sendFile' ct fp p =
-            return $ YRPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession
+            return $ YRPlain H.status200 headers ct (ContentFile fp p) finalSession
-    case contents of
+    contents1 <- evaluate contents `E.catch` \e -> return
+        (HCError $! InternalError $! T.pack $! show (e :: E.SomeException))
+    case contents1 of
         HCContent status (TypedContent ct c) -> do
             ec' <- liftIO $ evaluateContent c
             case ec' of
                 Left e -> handleError e
-                Right c' -> return $ YRPlain status (appEndo headers []) ct c' finalSession
+                Right c' -> return $ YRPlain status headers ct c' finalSession
         HCError e -> handleError e
         HCRedirect status loc -> do
             let disable_caching x =
@@ -101,7 +136,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
                     : Header "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
                     : x
                 hs = (if status /= H.movedPermanently301 then disable_caching else id)
-                      $ Header "Location" (encodeUtf8 loc) : appEndo headers []
+                      $ Header "Location" (encodeUtf8 loc) : headers
             return $ YRPlain
                 status hs typePlain emptyContent
                 finalSession
@@ -109,7 +144,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
             (sendFile' ct fp p)
             (handleError . toErrorHandler)
         HCCreated loc -> do
-            let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []
+            let hs = Header "Location" (encodeUtf8 loc) : headers
             return $ YRPlain
                 H.status201
                 hs
@@ -117,6 +152,7 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
                 emptyContent
                 finalSession
         HCWai r -> return $ YRWai r
+        HCWaiApp a -> return $ YRWaiApp a
 
 safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
        -> ErrorResponse
@@ -179,20 +215,27 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
                      typePlain
                      (toContent ("runFakeHandler: errHandler" :: S8.ByteString))
                      (reqSession req)
-      fakeWaiRequest =
+      fakeWaiRequest = Request
-        Request
           { requestMethod  = "POST"
           , httpVersion    = H.http11
           , rawPathInfo    = "/runFakeHandler/pathInfo"
           , rawQueryString = ""
+#if MIN_VERSION_wai(2, 0, 0)
+          , requestHeaderHost = Nothing
+#else
           , serverName     = "runFakeHandler-serverName"
           , serverPort     = 80
+#endif
           , requestHeaders = []
           , isSecure       = False
           , remoteHost     = error "runFakeHandler-remoteHost"
           , pathInfo       = ["runFakeHandler", "pathInfo"]
           , queryString    = []
+#if MIN_VERSION_wai(3, 0, 0)
+          , requestBody    = return mempty
+#else
           , requestBody    = mempty
+#endif
           , vault          = mempty
           , requestBodyLength = KnownLength 0
           }
@@ -215,8 +258,13 @@ yesodRunner :: (ToTypedContent res, Yesod site)
             -> YesodRunnerEnv site
             -> Maybe (Route site)
             -> Application
+#if MIN_VERSION_wai(3, 0, 0)
+yesodRunner handler' YesodRunnerEnv {..} route req sendResponse
+  | Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = sendResponse tooLargeResponse
+#else
 yesodRunner handler' YesodRunnerEnv {..} route req
   | Just maxLen <- mmaxLen, KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse
+#endif
   | otherwise = do
     let dontSaveSession _ = return []
     (session, saveSession) <- liftIO $ do
@@ -243,8 +291,25 @@ yesodRunner handler' YesodRunnerEnv {..} route req
         rhe = rheSafe
             { rheOnError = runHandler rheSafe . errorHandler
             }
+#if MIN_VERSION_wai(3, 0, 0)
+
+    E.bracket createInternalState closeInternalState $ \is -> do
+        yreq' <- yreq
+        yar <- runInternalState (runHandler rhe handler yreq') is
+        yarToResponse yar saveSession yreq' req is sendResponse
+
+#else
+
+#if MIN_VERSION_wai(2, 0, 0)
+    bracketOnError createInternalState closeInternalState $ \is -> do
+        yreq' <- yreq
+        yar <- runInternalState (runHandler rhe handler yreq') is
+        liftIO $ yarToResponse yar saveSession yreq' req is
+#else
     yar <- runHandler rhe handler yreq
-    liftIO $ yarToResponse yar saveSession yreq
+    liftIO $ yarToResponse yar saveSession yreq req
+#endif
+#endif
   where
     mmaxLen = maximumContentLength yreSite route
     handler = yesodMiddleware handler'

yesod-core/Yesod/Core/Json.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Yesod.Core.Json
     ( -- * Convert from a JSON value
@@ -10,6 +11,7 @@ module Yesod.Core.Json
       -- * Convert to a JSON value
     , parseJsonBody
     , parseJsonBody_
+    , requireJsonBody
 
       -- * Produce JSON values
     , J.Value (..)
@@ -27,6 +29,7 @@ module Yesod.Core.Json
 
 import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep)
 import Control.Monad.Trans.Writer (Writer)
+import Control.Monad.Trans.Resource (runExceptionT)
 import Data.Monoid (Endo)
 import Yesod.Core.Content (TypedContent)
 import Yesod.Core.Types (reqAccept)
@@ -41,6 +44,7 @@ import Data.Conduit.Attoparsec (sinkParser)
 import Data.Text (pack)
 import qualified Data.Vector as V
 import Data.Conduit
+import Data.Conduit.Lift
 import qualified Data.ByteString.Char8 as B8
 import Data.Maybe (listToMaybe)
 import Control.Monad (liftM)
@@ -84,10 +88,18 @@ provideJson = provideRep . return . J.toJSON
 -- If you want the raw JSON value, just ask for a @'J.Result'
 -- 'J.Value'@.
 --
+-- Note that this function will consume the request body. As such, calling it
+-- twice will result in a parse error on the second call, since the request
+-- body will no longer be available.
+--
 -- /Since: 0.3.0/
 parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
 parseJsonBody = do
+#if MIN_VERSION_resourcet(1,1,0)
+    eValue <- rawRequestBody $$ runCatchC (sinkParser JP.value')
+#else
     eValue <- runExceptionT $ rawRequestBody $$ sinkParser JP.value'
+#endif
     return $ case eValue of
         Left e -> J.Error $ show e
         Right value -> J.fromJSON value
@@ -95,7 +107,13 @@ parseJsonBody = do
 -- | Same as 'parseJsonBody', but return an invalid args response on a parse
 -- error.
 parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a
-parseJsonBody_ = do
+parseJsonBody_ = requireJsonBody
+{-# DEPRECATED parseJsonBody_ "Use requireJsonBody instead" #-}
+
+-- | Same as 'parseJsonBody', but return an invalid args response on a parse
+-- error.
+requireJsonBody :: (MonadHandler m, J.FromJSON a) => m a
+requireJsonBody = do
     ra <- parseJsonBody
     case ra of
         J.Error s -> invalidArgs [pack s]

yesod-core/Yesod/Core/Types.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE CPP #-}
 module Yesod.Core.Types where
 
 import qualified Blaze.ByteString.Builder           as BBuilder
@@ -15,16 +16,21 @@ import           Control.Arrow                      (first)
 import           Control.Exception                  (Exception)
 import           Control.Monad                      (liftM, ap)
 import           Control.Monad.Base                 (MonadBase (liftBase))
+import           Control.Monad.Catch                (MonadCatch (..))
+#if MIN_VERSION_exceptions(0,6,0)
+import           Control.Monad.Catch                (MonadMask (..))
+#endif
 import           Control.Monad.IO.Class             (MonadIO (liftIO))
 import           Control.Monad.Logger               (LogLevel, LogSource,
                                                      MonadLogger (..))
 import           Control.Monad.Trans.Control        (MonadBaseControl (..))
-import           Control.Monad.Trans.Resource       (MonadResource (..), InternalState, runInternalState)
+import           Control.Monad.Trans.Resource       (MonadResource (..), InternalState, runInternalState, MonadThrow (..), monadThrow, ResourceT)
+#if !MIN_VERSION_resourcet(1,1,0)
+import           Control.Monad.Trans.Resource       (MonadUnsafeIO (..))
+#endif
 import           Data.ByteString                    (ByteString)
 import qualified Data.ByteString.Lazy               as L
-import           Data.Conduit                       (Flush, MonadThrow (..),
+import           Data.Conduit                       (Flush, Source)
-                                                     MonadUnsafeIO (..),
-                                                     ResourceT, Source)
 import           Data.Dynamic                       (Dynamic)
 import           Data.IORef                         (IORef)
 import           Data.Map                           (Map, unionWith)
@@ -46,7 +52,12 @@ import           Network.Wai                        (FilePart,
                                                      RequestBodyLength)
 import qualified Network.Wai                        as W
 import qualified Network.Wai.Parse                  as NWP
+#if MIN_VERSION_fast_logger(2, 0, 0)
+import           System.Log.FastLogger              (LogStr, LoggerSet, toLogStr, pushLogStr)
+import           Network.Wai.Logger                 (DateCacheGetter)
+#else
 import           System.Log.FastLogger              (LogStr, Logger, toLogStr)
+#endif
 import           Text.Blaze.Html                    (Html)
 import           Text.Hamlet                        (HtmlUrl)
 import           Text.Julius                        (JavascriptUrl)
@@ -54,6 +65,9 @@ import           Web.Cookie                         (SetCookie)
 import           Yesod.Core.Internal.Util           (getTime, putTime)
 import           Control.Monad.Trans.Class          (MonadTrans (..))
 import           Yesod.Routes.Class                 (RenderRoute (..), ParseRoute (..))
+import           Control.Monad.Reader               (MonadReader (..))
+import Prelude hiding (catch)
+import Control.DeepSeq (NFData (rnf))
 
 -- Sessions
 type SessionMap = Map Text ByteString
@@ -112,6 +126,7 @@ data YesodRequest = YesodRequest
 -- or a higher-level data structure which Yesod will turn into a @Response@.
 data YesodResponse
     = YRWai !W.Response
+    | YRWaiApp !W.Application
     | YRPlain !H.Status ![Header] !ContentType !Content !SessionMap
 
 -- | A tuple containing both the POST parameters and submitted files.
@@ -128,7 +143,11 @@ data FileInfo = FileInfo
     }
 
 data FileUpload = FileUploadMemory !(NWP.BackEnd L.ByteString)
+#if MIN_VERSION_wai_extra(2, 0, 1)
+                | FileUploadDisk !(InternalState -> NWP.BackEnd FilePath)
+#else
                 | FileUploadDisk !(NWP.BackEnd FilePath)
+#endif
                 | FileUploadSource !(NWP.BackEnd (Source (ResourceT IO) ByteString))
 
 -- | How to determine the root of the application for constructing URLs.
@@ -298,6 +317,14 @@ data Header =
     | Header ByteString ByteString
     deriving (Eq, Show)
 
+-- FIXME In the next major version bump, let's just add strictness annotations
+-- to Header (and probably everywhere else). We can also add strictness
+-- annotations to SetCookie in the cookie package.
+instance NFData Header where
+    rnf (AddCookie x) = rnf x
+    rnf (DeleteCookie x y) = x `seq` y `seq` ()
+    rnf (Header x y) = x `seq` y `seq` ()
+
 data Location url = Local url | Remote Text
     deriving (Show, Eq)
 
@@ -346,6 +373,7 @@ data HandlerContents =
     | HCRedirect H.Status Text
     | HCCreated Text
     | HCWai W.Response
+    | HCWaiApp W.Application
     deriving Typeable
 
 instance Show HandlerContents where
@@ -355,6 +383,7 @@ instance Show HandlerContents where
     show (HCRedirect s t) = "HCRedirect " ++ show (s, t)
     show (HCCreated t) = "HCCreated " ++ show t
     show (HCWai _) = "HCWai"
+    show (HCWaiApp _) = "HCWaiApp"
 instance Exception HandlerContents
 
 -- Instances for WidgetT
@@ -375,17 +404,54 @@ instance MonadBase b m => MonadBase b (WidgetT site m) where
     liftBase = WidgetT . const . liftBase . fmap (, mempty)
 instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
     data StM (WidgetT site m) a = StW (StM m (a, GWData (Route site)))
-    liftBaseWith f = WidgetT $ \reader ->
+    liftBaseWith f = WidgetT $ \reader' ->
         liftBaseWith $ \runInBase ->
             liftM (\x -> (x, mempty))
-            (f $ liftM StW . runInBase . flip unWidgetT reader)
+            (f $ liftM StW . runInBase . flip unWidgetT reader')
     restoreM (StW base) = WidgetT $ const $ restoreM base
+instance Monad m => MonadReader site (WidgetT site m) where
+    ask = WidgetT $ \hd -> return (rheSite $ handlerEnv hd, mempty)
+    local f (WidgetT g) = WidgetT $ \hd -> g hd
+        { handlerEnv = (handlerEnv hd)
+            { rheSite = f $ rheSite $ handlerEnv hd
+            }
+        }
 
 instance MonadTrans (WidgetT site) where
     lift = WidgetT . const . liftM (, mempty)
 instance MonadThrow m => MonadThrow (WidgetT site m) where
+#if MIN_VERSION_resourcet(1,1,0)
+    throwM = lift . throwM
+
+instance MonadCatch m => MonadCatch (HandlerT site m) where
+  catch (HandlerT m) c = HandlerT $ \r -> m r `catch` \e -> unHandlerT (c e) r
+#if MIN_VERSION_exceptions(0,6,0)
+instance MonadMask m => MonadMask (HandlerT site m) where
+#endif
+  mask a = HandlerT $ \e -> mask $ \u -> unHandlerT (a $ q u) e
+    where q u (HandlerT b) = HandlerT (u . b)
+  uninterruptibleMask a =
+    HandlerT $ \e -> uninterruptibleMask $ \u -> unHandlerT (a $ q u) e
+      where q u (HandlerT b) = HandlerT (u . b)
+instance MonadCatch m => MonadCatch (WidgetT site m) where
+  catch (WidgetT m) c = WidgetT $ \r -> m r `catch` \e -> unWidgetT (c e) r
+#if MIN_VERSION_exceptions(0,6,0)
+instance MonadMask m => MonadMask (WidgetT site m) where
+#endif
+  mask a = WidgetT $ \e -> mask $ \u -> unWidgetT (a $ q u) e
+    where q u (WidgetT b) = WidgetT (u . b)
+  uninterruptibleMask a =
+    WidgetT $ \e -> uninterruptibleMask $ \u -> unWidgetT (a $ q u) e
+      where q u (WidgetT b) = WidgetT (u . b)
+#else
     monadThrow = lift . monadThrow
+#endif
+
+#if MIN_VERSION_resourcet(1,1,0)
+instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where
+#else
 instance (Applicative m, MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (WidgetT site m) where
+#endif
     liftResourceT f = WidgetT $ \hd -> liftIO $ fmap (, mempty) $ runInternalState f (handlerResource hd)
 
 instance MonadIO m => MonadLogger (WidgetT site m) where
@@ -408,6 +474,13 @@ instance MonadIO m => MonadIO (HandlerT site m) where
     liftIO = lift . liftIO
 instance MonadBase b m => MonadBase b (HandlerT site m) where
     liftBase = lift . liftBase
+instance Monad m => MonadReader site (HandlerT site m) where
+    ask = HandlerT $ return . rheSite . handlerEnv
+    local f (HandlerT g) = HandlerT $ \hd -> g hd
+        { handlerEnv = (handlerEnv hd)
+            { rheSite = f $ rheSite $ handlerEnv hd
+            }
+        }
 -- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s
 -- @fork@ function is incompatible with the underlying @ResourceT@ system.
 -- Instead, if you must fork a separate thread, you should use
@@ -418,14 +491,23 @@ instance MonadBase b m => MonadBase b (HandlerT site m) where
 -- after cleanup. Please contact the maintainers.\"
 instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where
     data StM (HandlerT site m) a = StH (StM m a)
-    liftBaseWith f = HandlerT $ \reader ->
+    liftBaseWith f = HandlerT $ \reader' ->
         liftBaseWith $ \runInBase ->
-            f $ liftM StH . runInBase . (\(HandlerT r) -> r reader)
+            f $ liftM StH . runInBase . (\(HandlerT r) -> r reader')
     restoreM (StH base) = HandlerT $ const $ restoreM base
 
 instance MonadThrow m => MonadThrow (HandlerT site m) where
+#if MIN_VERSION_resourcet(1,1,0)
+    throwM = lift . monadThrow
+#else
     monadThrow = lift . monadThrow
+#endif
+
+#if MIN_VERSION_resourcet(1,1,0)
+instance (MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (HandlerT site m) where
+#else
 instance (MonadIO m, MonadUnsafeIO m, MonadThrow m) => MonadResource (HandlerT site m) where
+#endif
     liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd)
 
 instance MonadIO m => MonadLogger (HandlerT site m) where
@@ -445,3 +527,13 @@ instance RenderRoute WaiSubsite where
     renderRoute (WaiSubsiteRoute ps qs) = (ps, qs)
 instance ParseRoute WaiSubsite where
     parseRoute (x, y) = Just $ WaiSubsiteRoute x y
+
+#if MIN_VERSION_fast_logger(2, 0, 0)
+data Logger = Logger
+    { loggerSet :: !LoggerSet
+    , loggerDate :: !DateCacheGetter
+    }
+
+loggerPutStr :: Logger -> LogStr -> IO ()
+loggerPutStr (Logger ls _) = pushLogStr ls
+#endif

yesod-core/Yesod/Core/Widget.hs

@@ -47,6 +47,7 @@ module Yesod.Core.Widget
     , handlerToWidget
       -- * Internal
     , whamletFileWithSettings
+    , asWidgetT
     ) where
 
 import Data.Monoid
@@ -82,10 +83,16 @@ instance render ~ RY site => ToWidget site (render -> Html) where
     toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
 instance render ~ RY site => ToWidget site (render -> Css) where
     toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x
+instance ToWidget site Css where
+    toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x
 instance render ~ RY site => ToWidget site (render -> CssBuilder) where
     toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
+instance ToWidget site CssBuilder where
+    toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty
 instance render ~ RY site => ToWidget site (render -> Javascript) where
     toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
+instance ToWidget site Javascript where
+    toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty
 instance (site' ~ site, IO ~ m, a ~ ()) => ToWidget site' (WidgetT site m a) where
     toWidget = liftWidgetT
 instance ToWidget site Html where
@@ -104,8 +111,12 @@ class ToWidgetMedia site a where
                   -> m ()
 instance render ~ RY site => ToWidgetMedia site (render -> Css) where
     toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x
+instance ToWidgetMedia site Css where
+    toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x
 instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where
     toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty
+instance ToWidgetMedia site CssBuilder where
+    toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty
 
 class ToWidgetBody site a where
     toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m ()
@@ -114,6 +125,8 @@ instance render ~ RY site => ToWidgetBody site (render -> Html) where
     toWidgetBody = toWidget
 instance render ~ RY site => ToWidgetBody site (render -> Javascript) where
     toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
+instance ToWidgetBody site Javascript where
+    toWidgetBody j = toWidget $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j
 instance ToWidgetBody site Html where
     toWidgetBody = toWidget
 
@@ -124,10 +137,16 @@ instance render ~ RY site => ToWidgetHead site (render -> Html) where
     toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
 instance render ~ RY site => ToWidgetHead site (render -> Css) where
     toWidgetHead = toWidget
+instance ToWidgetHead site Css where
+    toWidgetHead = toWidget
 instance render ~ RY site => ToWidgetHead site (render -> CssBuilder) where
     toWidgetHead = toWidget
+instance ToWidgetHead site CssBuilder where
+    toWidgetHead = toWidget
 instance render ~ RY site => ToWidgetHead site (render -> Javascript) where
     toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
+instance ToWidgetHead site Javascript where
+    toWidgetHead j = toWidgetHead $ \_ -> H.script $ preEscapedLazyText $ renderJavascript j
 instance ToWidgetHead site Html where
     toWidgetHead = toWidgetHead . const
 

yesod-core/bench/widget.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 -- | BigTable benchmark implemented using Hamlet.
 --
 {-# LANGUAGE QuasiQuotes #-}
@@ -7,19 +8,22 @@ import Criterion.Main
 import Text.Hamlet
 import Numeric (showInt)
 import qualified Data.ByteString.Lazy as L
-import qualified Text.Blaze.Renderer.Utf8 as Utf8
+import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8
 import Data.Monoid (mconcat)
 import Text.Blaze.Html5 (table, tr, td)
-import Yesod.Widget
+import Text.Blaze.Html (toHtml)
+import Yesod.Core.Widget
 import Control.Monad.Trans.Writer
 import Control.Monad.Trans.RWS
 import Data.Functor.Identity
-import Yesod.Internal
+import Yesod.Core.Types
+import Data.Monoid
+import Data.IORef
 
 main = defaultMain
     [ bench "bigTable html" $ nf bigTableHtml bigTableData
     , bench "bigTable hamlet" $ nf bigTableHamlet bigTableData
-    , bench "bigTable widget" $ nf bigTableWidget bigTableData
+    , bench "bigTable widget" $ nfIO (bigTableWidget bigTableData)
     , bench "bigTable blaze" $ nf bigTableBlaze bigTableData
     ]
   where
@@ -30,50 +34,35 @@ main = defaultMain
     bigTableData = replicate rows [1..10]
     {-# NOINLINE bigTableData #-}
 
-bigTableHtml rows = L.length $ renderHtml [$hamlet|
+bigTableHtml rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
-<table
+<table>
     $forall row <- rows
-        <tr
+        <tr>
             $forall cell <- row
                 <td>#{show cell}
 |]
 
-bigTableHamlet rows = L.length $ renderHamlet id [$hamlet|
+bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
-<table
+<table>
     $forall row <- rows
-        <tr
+        <tr>
             $forall cell <- row
                 <td>#{show cell}
 |]
 
-bigTableWidget rows = L.length $ renderHtml $ (run [$hamlet|
+bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet|
-<table
+<table>
     $forall row <- rows
-        <tr
+        <tr>
             $forall cell <- row
                 <td>#{show cell}
-|]) (\_ _ -> "foo")
+|])
   where
-  run (GWidget w) =
+  render _ _ = "foo"
-    let (_, _, GWData (Body x) _ _ _ _ _ _) = runRWS w () 0
+  run (WidgetT w) = do
-     in x
+    (_, GWData { gwdBody = Body x }) <- w undefined
-  {-
+    return x
-  run (GWidget w) = runIdentity $ do
-    w' <- flip evalStateT 0
-        $ runWriterT $ runWriterT $ runWriterT $ runWriterT
-        $ runWriterT $ runWriterT $ runWriterT w
-    let ((((((((),
-         Body body),
-         _),
-         _),
-         _),
-         _),
-         _),
-         _) = w'
 
-    return body
+bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ mconcat $ map row t
-    -}
-
-bigTableBlaze t = L.length $ renderHtml $ table $ mconcat $ map row t
   where
-    row r = tr $ mconcat $ map (td . string . show) r
+    row r = tr $ mconcat $ map (td . toHtml . show) r

yesod-core/test/YesodCoreTest.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP                        #-}
 module YesodCoreTest (specs) where 
 
 import YesodCoreTest.CleanPath
@@ -14,6 +15,9 @@ import qualified YesodCoreTest.Redirect as Redirect
 import qualified YesodCoreTest.JsLoader as JsLoader
 import qualified YesodCoreTest.RequestBodySize as RequestBodySize
 import qualified YesodCoreTest.Json as Json
+#if MIN_VERSION_wai(2, 1, 0)
+import qualified YesodCoreTest.RawResponse as RawResponse
+#endif
 import qualified YesodCoreTest.Streaming as Streaming
 import qualified YesodCoreTest.Reps as Reps
 import qualified YesodCoreTest.Auth as Auth
@@ -37,6 +41,9 @@ specs = do
       JsLoader.specs
       RequestBodySize.specs
       Json.specs
+#if MIN_VERSION_wai(2, 1, 0)
+      RawResponse.specs
+#endif
       Streaming.specs
       Reps.specs
       Auth.specs

yesod-core/test/YesodCoreTest/Auth.hs

@@ -8,6 +8,7 @@ import Network.Wai
 import qualified Data.ByteString.Char8 as S8
 import qualified Data.Text as T
 import Data.List (isSuffixOf)
+import qualified Network.HTTP.Types as H
 
 data App = App
 
@@ -51,6 +52,7 @@ test method path f = it (method ++ " " ++ path) $ do
             , requestHeaders =
                 if not $ isSuffixOf "json" path then [] else
                   [("Accept", S8.pack "application/json")]
+            , httpVersion = H.http11
             }
         f sres
 

yesod-core/test/YesodCoreTest/CleanPath.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
 module YesodCoreTest.CleanPath (cleanPathTest, Widget) where
 
 import Test.Hspec
@@ -32,7 +33,11 @@ instance ParseRoute Subsite where
     parseRoute (x, _) = Just $ SubsiteRoute x
 
 instance YesodSubDispatch Subsite master where
+#if MIN_VERSION_wai(3, 0, 0)
+    yesodSubDispatch _ req f = f $ responseLBS
+#else
     yesodSubDispatch _ req = return $ responseLBS
+#endif
         status200
         [ ("Content-Type", "SUBSITE")
         ] $ L8.pack $ show (pathInfo req)

yesod-core/test/YesodCoreTest/ErrorHandling.hs

@@ -13,6 +13,11 @@ import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Char8 as S8
 import Control.Exception (SomeException, try)
 import Network.HTTP.Types (mkStatus)
+import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString)
+import Data.Monoid (mconcat)
+import Data.Text (Text, pack)
+import Control.Monad (forM_)
+import qualified Control.Exception.Lifted as E
 
 data App = App
 
@@ -24,6 +29,14 @@ mkYesod "App" [parseRoutes|
 /error-in-body ErrorInBodyR GET
 /error-in-body-noeval ErrorInBodyNoEvalR GET
 /override-status OverrideStatusR GET
+/error/#Int ErrorR GET
+
+-- https://github.com/yesodweb/yesod/issues/658
+/builder BuilderR GET
+/file-bad-len FileBadLenR GET
+/file-bad-name FileBadNameR GET
+
+/good-builder GoodBuilderR GET
 |]
 
 overrideStatus = mkStatus 15 "OVERRIDE"
@@ -74,6 +87,33 @@ getErrorInBodyNoEvalR = fmap DontFullyEvaluate getErrorInBodyR
 getOverrideStatusR :: Handler ()
 getOverrideStatusR = invalidArgs ["OVERRIDE"]
 
+getBuilderR :: Handler TypedContent
+getBuilderR = return $ TypedContent "ignored" $ ContentBuilder (error "builder-3.14159") Nothing
+
+getFileBadLenR :: Handler TypedContent
+getFileBadLenR = return $ TypedContent "ignored" $ ContentFile "yesod-core.cabal" (error "filebadlen")
+
+getFileBadNameR :: Handler TypedContent
+getFileBadNameR = return $ TypedContent "ignored" $ ContentFile (error "filebadname") Nothing
+
+goodBuilderContent :: Builder
+goodBuilderContent = mconcat $ replicate 100 $ fromByteString "This is a test\n"
+
+getGoodBuilderR :: Handler TypedContent
+getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent
+
+getErrorR :: Int -> Handler ()
+getErrorR 1 = setSession undefined "foo"
+getErrorR 2 = setSession "foo" undefined
+getErrorR 3 = deleteSession undefined
+getErrorR 4 = addHeader undefined "foo"
+getErrorR 5 = addHeader "foo" undefined
+getErrorR 6 = expiresAt undefined
+getErrorR 7 = setLanguage undefined
+getErrorR 8 = cacheSeconds undefined
+getErrorR 9 = setUltDest (undefined :: Text)
+getErrorR 10 = setMessage undefined
+
 errorHandlingTest :: Spec
 errorHandlingTest = describe "Test.ErrorHandling" $ do
       it "says not found" caseNotFound
@@ -82,8 +122,13 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
       it "error in body == 500" caseErrorInBody
       it "error in body, no eval == 200" caseErrorInBodyNoEval
       it "can override status code" caseOverrideStatus
+      it "builder" caseBuilder
+      it "file with bad len" caseFileBadLen
+      it "file with bad name" caseFileBadName
+      it "builder includes content-length" caseGoodBuilder
+      forM_ [1..10] $ \i -> it ("error case " ++ show i) (caseError i)
 
-runner :: Session () -> IO ()
+runner :: Session a -> IO a
 runner f = toWaiApp App >>= runSession f
 
 caseNotFound :: IO ()
@@ -130,13 +175,45 @@ caseErrorInBody = runner $ do
 caseErrorInBodyNoEval :: IO ()
 caseErrorInBodyNoEval = do
     eres <- try $ runner $ do
-        _ <- request defaultRequest { pathInfo = ["error-in-body-noeval"] }
+        request defaultRequest { pathInfo = ["error-in-body-noeval"] }
-        return ()
     case eres of
         Left (_ :: SomeException) -> return ()
-        Right _ -> error "Expected an exception"
+        Right x -> error $ "Expected an exception, got: " ++ show x
 
 caseOverrideStatus :: IO ()
 caseOverrideStatus = runner $ do
     res <- request defaultRequest { pathInfo = ["override-status"] }
     assertStatus 15 res
+
+caseBuilder :: IO ()
+caseBuilder = runner $ do
+    res <- request defaultRequest { pathInfo = ["builder"] }
+    assertStatus 500 res
+    assertBodyContains "builder-3.14159" res
+
+caseFileBadLen :: IO ()
+caseFileBadLen = runner $ do
+    res <- request defaultRequest { pathInfo = ["file-bad-len"] }
+    assertStatus 500 res
+    assertBodyContains "filebadlen" res
+
+caseFileBadName :: IO ()
+caseFileBadName = runner $ do
+    res <- request defaultRequest { pathInfo = ["file-bad-name"] }
+    assertStatus 500 res
+    assertBodyContains "filebadname" res
+
+caseGoodBuilder :: IO ()
+caseGoodBuilder = runner $ do
+    res <- request defaultRequest { pathInfo = ["good-builder"] }
+    assertStatus 200 res
+    let lbs = toLazyByteString goodBuilderContent
+    assertBody lbs res
+    assertHeader "content-length" (S8.pack $ show $ L.length lbs) res
+
+caseError :: Int -> IO ()
+caseError i = runner $ do
+    res <- request defaultRequest { pathInfo = ["error", pack $ show i] }
+    assertStatus 500 res `E.catch` \e -> do
+        liftIO $ print res
+        E.throwIO (e :: E.SomeException)

yesod-core/test/YesodCoreTest/InternalRequest.hs

@@ -12,6 +12,7 @@ import Data.Monoid (mempty)
 import Data.Map (singleton)
 import Yesod.Core
 import Data.Word (Word64)
+import System.IO.Unsafe (unsafePerformIO)
 
 randomStringSpecs :: Spec
 randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do
@@ -36,7 +37,7 @@ parseWaiRequest' :: Request
                  -> Bool
                  -> Word64
                  -> YesodRequest
-parseWaiRequest' a b c d =
+parseWaiRequest' a b c d = unsafePerformIO $ -- ugly hack, just to ease migration, should be removed
     case parseWaiRequest a b c (Just d) of
         Left yreq -> yreq
         Right needGen -> needGen g

yesod-core/test/YesodCoreTest/Json.hs

@@ -19,7 +19,7 @@ instance Yesod App
 
 getHomeR :: Handler RepPlain
 getHomeR = do
-    val <- parseJsonBody_
+    val <- requireJsonBody
     case Map.lookup ("foo" :: Text) val of
         Nothing -> invalidArgs ["foo not found"]
         Just foo -> return $ RepPlain $ toContent (foo :: Text)

yesod-core/test/YesodCoreTest/RawResponse.hs

@@ -0,0 +1,110 @@
+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ScopedTypeVariables #-}
+module YesodCoreTest.RawResponse (specs, Widget) where
+
+import Yesod.Core
+import Test.Hspec
+import qualified Data.Map as Map
+import Network.Wai.Test
+import Network.Wai (responseStream)
+import Data.Text (Text)
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.Conduit.List as CL
+import qualified Data.ByteString.Char8 as S8
+import Data.Conduit
+import qualified Data.Conduit.Binary as CB
+import Data.Char (toUpper)
+import Control.Exception (try, IOException)
+import Data.Conduit.Network
+import Network.Socket (sClose)
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async (withAsync)
+import Control.Monad.Trans.Resource (register)
+import Data.IORef
+import Data.Streaming.Network (bindPortTCP)
+import Network.HTTP.Types (status200)
+import Blaze.ByteString.Builder (fromByteString)
+
+data App = App
+
+mkYesod "App" [parseRoutes|
+/ HomeR GET
+/wai-stream WaiStreamR GET
+/wai-app-stream WaiAppStreamR GET
+|]
+
+instance Yesod App
+
+getHomeR :: Handler ()
+getHomeR = do
+    ref <- liftIO $ newIORef 0
+    _ <- register $ writeIORef ref 1
+    sendRawResponse $ \src sink -> liftIO $ do
+        val <- readIORef ref
+        yield (S8.pack $ show val) $$ sink
+        src $$ CL.map (S8.map toUpper) =$ sink
+
+getWaiStreamR :: Handler ()
+getWaiStreamR = sendWaiResponse $ responseStream status200 [] $ \send flush -> do
+    flush
+    send $ fromByteString "hello"
+    flush
+    send $ fromByteString " world"
+
+getWaiAppStreamR :: Handler ()
+getWaiAppStreamR = sendWaiApplication $ \_ f -> f $ responseStream status200 [] $ \send flush -> do
+    flush
+    send $ fromByteString "hello"
+    flush
+    send $ fromByteString " world"
+
+getFreePort :: IO Int
+getFreePort = do
+    loop 43124
+  where
+    loop port = do
+        esocket <- try $ bindPortTCP port "*"
+        case esocket of
+            Left (_ :: IOException) -> loop (succ port)
+            Right socket -> do
+                sClose socket
+                return port
+
+specs :: Spec
+specs = do
+    describe "RawResponse" $ do
+        it "works" $ do
+            port <- getFreePort
+            withAsync (warp port App) $ \_ -> do
+                threadDelay 100000
+                runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
+                    yield "GET / HTTP/1.1\r\n\r\nhello" $$ appSink ad
+                    (appSource ad $$ CB.take 6) >>= (`shouldBe` "0HELLO")
+                    yield "WORLd" $$ appSink ad
+                    (appSource ad $$ await) >>= (`shouldBe` Just "WORLD")
+
+    let body req = do
+            port <- getFreePort
+            withAsync (warp port App) $ \_ -> do
+                threadDelay 100000
+                runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
+                    yield req $$ appSink ad
+                    appSource ad $$ CB.lines =$ do
+                        let loop = do
+                                x <- await
+                                case x of
+                                    Nothing -> return ()
+                                    Just "\r" -> return ()
+                                    _ -> loop
+                        loop
+
+                        Just "0005\r" <- await
+                        Just "hello\r" <- await
+
+                        Just "0006\r" <- await
+                        Just " world\r" <- await
+
+                        return ()
+    it "sendWaiResponse + responseStream" $ do
+        body "GET /wai-stream HTTP/1.1\r\n\r\n"
+    it "sendWaiApplication + responseStream" $ do
+        body "GET /wai-app-stream HTTP/1.1\r\n\r\n"

yesod-core/test/YesodCoreTest/Redirect.hs

@@ -7,7 +7,7 @@ import qualified Network.HTTP.Types as H
 
 data Y = Y
 mkYesod "Y" [parseRoutes|
-/ RootR GET
+/ RootR GET POST
 /r301 R301 GET
 /r303 R303 GET
 /r307 R307 GET
@@ -20,6 +20,9 @@ app = yesod Y
 getRootR :: Handler ()
 getRootR = return ()
 
+postRootR :: Handler ()
+postRootR = return ()
+
 getR301, getR303, getR307, getRRegular :: Handler ()
 getR301 = redirectWith H.status301 RootR
 getR303 = redirectWith H.status303 RootR
@@ -28,6 +31,11 @@ getRRegular = redirect RootR
 
 specs :: Spec
 specs = describe "Redirect" $ do
+    it "no redirect" $ app $ do
+      res <- request defaultRequest { pathInfo = [], requestMethod = "POST" }
+      assertStatus 200 res
+      assertBodyContains "" res
+
     it "301 redirect" $ app $ do
       res <- request defaultRequest { pathInfo = ["r301"] }
       assertStatus 301 res
@@ -45,7 +53,8 @@ specs = describe "Redirect" $ do
 
     it "303 redirect for regular, HTTP 1.1" $ app $ do
       res <- request defaultRequest {
-        pathInfo = ["rregular"]
+        pathInfo = ["rregular"],
+        httpVersion = H.http11
       }
       assertStatus 303 res
       assertBodyContains "" res

yesod-core/test/YesodCoreTest/RequestBodySize.hs

@@ -83,8 +83,8 @@ specs :: Spec
 specs = describe "Test.RequestBodySize" $ do
     caseHelper "lookupPostParam- large" "post" "foobarbaz=bin" 413 413
     caseHelper "lookupPostParam- small" "post" "foo=bin" 200 200
-    caseHelper "consume- large" "consume" "this is longer than 10" 413 413
+    caseHelper "total consume- large" "consume" "this is longer than 10" 413 413
-    caseHelper "consume- small" "consume" "smaller" 200 200
+    caseHelper "total consume- small" "consume" "smaller" 200 200
     caseHelper "partial consume- large" "partial-consume" "this is longer than 10" 200 413
     caseHelper "partial consume- small" "partial-consume" "smaller" 200 200
     caseHelper "unused- large" "unused" "this is longer than 10" 200 413

yesod-core/test/YesodCoreTest/WaiSubsite.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-}
+{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-}
 module YesodCoreTest.WaiSubsite (specs, Widget) where
 
 import YesodCoreTest.YesodTest
@@ -6,7 +6,11 @@ import Yesod.Core
 import qualified Network.HTTP.Types as H
 
 myApp :: Application
+#if MIN_VERSION_wai(3, 0, 0)
+myApp _ f = f $ responseLBS H.status200 [("Content-type", "text/plain")] "WAI"
+#else
 myApp _ = return $ responseLBS H.status200 [("Content-type", "text/plain")] "WAI"
+#endif
 
 getApp :: a -> WaiSubsite
 getApp _ = WaiSubsite myApp

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.2.4
+version:         1.2.17
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -26,28 +26,28 @@ library
     build-depends:   base                  >= 4.3      && < 5
                    , time                  >= 1.1.4
                    , yesod-routes          >= 1.2      && < 1.3
-                   , wai                   >= 1.4      && < 1.5
+                   , wai                   >= 1.4
-                   , wai-extra             >= 1.3      && < 1.4
+                   , wai-extra             >= 1.3
                    , bytestring            >= 0.9.1.4
-                   , text                  >= 0.7      && < 0.12
+                   , text                  >= 0.7
                    , template-haskell
                    , path-pieces           >= 0.1.2    && < 0.2
-                   , hamlet                >= 1.1      && < 1.2
+                   , hamlet                >= 1.1
-                   , shakespeare           >= 1.0      && < 1.1
+                   , shakespeare           >= 1.0      && < 2.1
-                   , shakespeare-js        >= 1.0.2    && < 1.2
+                   , shakespeare-js        >= 1.0.2
-                   , shakespeare-css       >= 1.0      && < 1.1
+                   , shakespeare-css       >= 1.0
-                   , shakespeare-i18n      >= 1.0      && < 1.1
+                   , shakespeare-i18n      >= 1.0
                    , blaze-builder         >= 0.2.1.4  && < 0.4
-                   , transformers          >= 0.2.2    && < 0.4
+                   , transformers          >= 0.2.2
+                   , mtl
                    , clientsession         >= 0.9      && < 0.10
                    , random                >= 1.0.0.2  && < 1.1
-                   , cereal                >= 0.3      && < 0.4
+                   , cereal                >= 0.3
                    , old-locale            >= 1.0.0.2  && < 1.1
-                   , failure               >= 0.2      && < 0.3
                    , containers            >= 0.2
                    , monad-control         >= 0.3      && < 0.4
                    , transformers-base     >= 0.4
-                   , cookie                >= 0.4      && < 0.5
+                   , cookie                >= 0.4.1    && < 0.5
                    , http-types            >= 0.7
                    , case-insensitive      >= 0.2
                    , parsec                >= 2        && < 3.2
@@ -55,9 +55,10 @@ library
                    , vector                >= 0.9      && < 0.11
                    , aeson                 >= 0.5
                    , fast-logger           >= 0.2
+                   , wai-logger            >= 0.2
                    , monad-logger          >= 0.3.1    && < 0.4
-                   , conduit               >= 0.5
+                   , conduit               >= 1.0.11
-                   , resourcet             >= 0.4.6    && < 0.5
+                   , resourcet             >= 0.4.9    && < 1.2
                    , lifted-base           >= 0.1.2
                    , attoparsec-conduit
                    , blaze-html            >= 0.5
@@ -65,6 +66,10 @@ library
                    , data-default
                    , safe
                    , warp                  >= 1.3.8
+                   , unix-compat
+                   , conduit-extra
+                   , exceptions
+                   , deepseq
 
     exposed-modules: Yesod.Core
                      Yesod.Core.Content
@@ -91,6 +96,9 @@ library
     -- This looks like a GHC bug
     extensions:      MultiParamTypeClasses
 
+    -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443
+    extensions:      TemplateHaskell
+
 test-suite tests
     type: exitcode-stdio-1.0
     main-is: test.hs
@@ -100,7 +108,7 @@ test-suite tests
     build-depends: base
                   ,hspec >= 1.3
                   ,wai-test >= 1.3.0.5
-                  ,wai
+                  ,wai >= 3.0
                   ,yesod-core
                   ,bytestring
                   ,hamlet
@@ -117,7 +125,29 @@ test-suite tests
                   , containers
                   , lifted-base
                   , resourcet
+                  , network-conduit
+                  , network
+                  , async
+                  , conduit-extra
+                  , shakespeare
+                  , streaming-commons
+                  , wai-extra
     ghc-options:     -Wall
+    extensions: TemplateHaskell
+
+benchmark widgets
+    type: exitcode-stdio-1.0
+    hs-source-dirs: bench
+    build-depends:  base
+                  , criterion
+                  , bytestring
+                  , text
+                  , hamlet
+                  , transformers
+                  , yesod-core
+                  , blaze-html
+    main-is:        widget.hs
+    ghc-options:    -Wall -O2
 
 source-repository head
   type:     git

yesod-eventsource/Yesod/EventSource.hs

@@ -46,7 +46,18 @@ repEventSource :: (EventSourcePolyfill -> C.Source (HandlerT site IO) ES.ServerE
                -> HandlerT site IO TypedContent
 repEventSource src =
   prepareForEventSource >>=
-  respondEventStream . ES.sourceToSource . src
+  respondEventStream . sourceToSource . src
+
+-- | Convert a ServerEvent source into a Builder source of serialized
+-- events.
+sourceToSource :: Monad m => C.Source m ES.ServerEvent -> C.Source m (C.Flush Builder)
+sourceToSource src =
+    src C.$= C.awaitForever eventToFlushBuilder
+  where
+    eventToFlushBuilder event =
+        case ES.eventToBuilder event of
+            Nothing -> return ()
+            Just x -> C.yield (C.Chunk x) >> C.yield C.Flush
 
 
 -- | Return a Server-Sent Event stream given a 'HandlerT' action

yesod-eventsource/yesod-eventsource.cabal

@@ -1,5 +1,5 @@
 name:            yesod-eventsource
-version:         1.1
+version:         1.1.1
 license:         MIT
 license-file:    LICENSE
 author:          Felipe Lessa <felipe.lessa@gmail.com>
@@ -29,9 +29,10 @@ description:
 library
     build-depends:   base                  >= 4        && < 5
                    , yesod-core            == 1.2.*
-                   , conduit               >= 0.5      && < 1.1
+                   , conduit               >= 0.5      && < 1.2
-                   , wai                   >= 1.3      && < 1.5
+                   , wai                   >= 1.3
-                   , wai-eventsource       >= 1.3      && < 1.4
+                   , wai-eventsource       >= 1.3
+                   , wai-extra
                    , blaze-builder
                    , transformers
     exposed-modules: Yesod.EventSource

yesod-form/Yesod/Form/Bootstrap3.hs

@@ -0,0 +1,262 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | Helper functions for creating forms when using Bootstrap v3.
+module Yesod.Form.Bootstrap3
+  ( -- * Rendering forms
+    renderBootstrap3
+  , BootstrapFormLayout(..)
+  , BootstrapGridOptions(..)
+    -- * Field settings
+  , bfs
+  , withPlaceholder
+  , withAutofocus
+  , withLargeInput
+  , withSmallInput
+    -- * Submit button
+  , bootstrapSubmit
+  , mbootstrapSubmit
+  , BootstrapSubmit(..)
+  ) where
+
+import Control.Arrow (second)
+import Control.Monad (liftM)
+import Data.Text (Text)
+import Data.String (IsString(..))
+import Yesod.Core
+
+import qualified Data.Text as T
+
+import Yesod.Form.Types
+import Yesod.Form.Functions
+
+-- | Create a new 'FieldSettings' with the classes that are
+-- required by Bootstrap v3.
+--
+-- Since: yesod-form 1.3.8
+bfs :: RenderMessage site msg => msg -> FieldSettings site
+bfs msg =
+    FieldSettings (SomeMessage msg) Nothing Nothing Nothing [("class", "form-control")]
+
+
+-- | Add a placeholder attribute to a field.  If you need i18n
+-- for the placeholder, currently you\'ll need to do a hack and
+-- use 'getMessageRender' manually.
+--
+-- Since: yesod-form 1.3.8
+withPlaceholder :: Text -> FieldSettings site -> FieldSettings site
+withPlaceholder placeholder fs = fs { fsAttrs = newAttrs }
+    where newAttrs = ("placeholder", placeholder) : fsAttrs fs
+
+
+-- | Add an autofocus attribute to a field.
+--
+-- Since: yesod-form 1.3.8
+withAutofocus :: FieldSettings site -> FieldSettings site
+withAutofocus fs = fs { fsAttrs = newAttrs }
+    where newAttrs = ("autofocus", "autofocus") : fsAttrs fs
+
+
+-- | Add the @input-lg@ CSS class to a field.
+--
+-- Since: yesod-form 1.3.8
+withLargeInput :: FieldSettings site -> FieldSettings site
+withLargeInput fs = fs { fsAttrs = newAttrs }
+    where newAttrs = addClass "input-lg" (fsAttrs fs)
+
+
+-- | Add the @input-sm@ CSS class to a field.
+--
+-- Since: yesod-form 1.3.8
+withSmallInput :: FieldSettings site -> FieldSettings site
+withSmallInput fs = fs { fsAttrs = newAttrs }
+    where newAttrs = addClass "input-sm" (fsAttrs fs)
+
+
+addClass :: Text -> [(Text, Text)] -> [(Text, Text)]
+addClass klass []                    = [("class", klass)]
+addClass klass (("class", old):rest) = ("class", T.concat [old, " ", klass]) : rest
+addClass klass (other         :rest) = other : addClass klass rest
+
+
+-- | How many bootstrap grid columns should be taken (see
+-- 'BootstrapFormLayout').
+--
+-- Since: yesod-form 1.3.8
+data BootstrapGridOptions =
+    ColXs !Int
+  | ColSm !Int
+  | ColMd !Int
+  | ColLg !Int
+    deriving (Eq, Ord, Show)
+
+toColumn :: BootstrapGridOptions -> String
+toColumn (ColXs 0) = ""
+toColumn (ColSm 0) = ""
+toColumn (ColMd 0) = ""
+toColumn (ColLg 0) = ""
+toColumn (ColXs columns) = "col-xs-" ++ show columns
+toColumn (ColSm columns) = "col-sm-" ++ show columns
+toColumn (ColMd columns) = "col-md-" ++ show columns
+toColumn (ColLg columns) = "col-lg-" ++ show columns
+
+toOffset :: BootstrapGridOptions -> String
+toOffset (ColXs 0) = ""
+toOffset (ColSm 0) = ""
+toOffset (ColMd 0) = ""
+toOffset (ColLg 0) = ""
+toOffset (ColXs columns) = "col-xs-offset-" ++ show columns
+toOffset (ColSm columns) = "col-sm-offset-" ++ show columns
+toOffset (ColMd columns) = "col-md-offset-" ++ show columns
+toOffset (ColLg columns) = "col-lg-offset-" ++ show columns
+
+addGO :: BootstrapGridOptions -> BootstrapGridOptions -> BootstrapGridOptions
+addGO (ColXs a) (ColXs b) = ColXs (a+b)
+addGO (ColSm a) (ColSm b) = ColSm (a+b)
+addGO (ColMd a) (ColMd b) = ColMd (a+b)
+addGO (ColLg a) (ColLg b) = ColLg (a+b)
+addGO a b     | a > b = addGO b a
+addGO (ColXs a) other = addGO (ColSm a) other
+addGO (ColSm a) other = addGO (ColMd a) other
+addGO (ColMd a) other = addGO (ColLg a) other
+addGO (ColLg _) _     = error "Yesod.Form.Bootstrap.addGO: never here"
+
+
+-- | The layout used for the bootstrap form.
+--
+-- Since: yesod-form 1.3.8
+data BootstrapFormLayout =
+    BootstrapBasicForm
+  | BootstrapInlineForm
+  | BootstrapHorizontalForm
+      { bflLabelOffset :: !BootstrapGridOptions
+      , bflLabelSize   :: !BootstrapGridOptions
+      , bflInputOffset :: !BootstrapGridOptions
+      , bflInputSize   :: !BootstrapGridOptions
+      }
+    deriving (Show)
+
+
+-- | Render the given form using Bootstrap v3 conventions.
+--
+-- Sample Hamlet for 'BootstrapHorizontalForm':
+--
+-- >  <form .form-horizontal role=form method=post action=@{ActionR} enctype=#{formEnctype}>
+-- >    ^{formWidget}
+-- >    ^{bootstrapSubmit MsgSubmit}
+--
+-- Since: yesod-form 1.3.8
+renderBootstrap3 :: Monad m => BootstrapFormLayout -> FormRender m a
+renderBootstrap3 formLayout aform fragment = do
+    (res, views') <- aFormToForm aform
+    let views = views' []
+        has (Just _) = True
+        has Nothing  = False
+        widget = [whamlet|
+            $newline never
+            #{fragment}
+            $forall view <- views
+              <div .form-group :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.has-error>
+                $case formLayout
+                  $of BootstrapBasicForm
+                    $if fvId view /= bootstrapSubmitId
+                      <label for=#{fvId view}>#{fvLabel view}
+                    ^{fvInput view}
+                    ^{helpWidget view}
+                  $of BootstrapInlineForm
+                    $if fvId view /= bootstrapSubmitId
+                      <label .sr-only for=#{fvId view}>#{fvLabel view}
+                    ^{fvInput view}
+                    ^{helpWidget view}
+                  $of BootstrapHorizontalForm labelOffset labelSize inputOffset inputSize
+                    $if fvId view /= bootstrapSubmitId
+                      <label .control-label .#{toOffset labelOffset} .#{toColumn labelSize} for=#{fvId view}>#{fvLabel view}
+                      <div .#{toOffset inputOffset} .#{toColumn inputSize}>
+                        ^{fvInput view}
+                        ^{helpWidget view}
+                    $else
+                      <div .#{toOffset (addGO inputOffset (addGO labelOffset labelSize))} .#{toColumn inputSize}>
+                        ^{fvInput view}
+                        ^{helpWidget view}
+                |]
+    return (res, widget)
+
+
+-- | (Internal) Render a help widget for tooltips and errors.
+helpWidget :: FieldView site -> WidgetT site IO ()
+helpWidget view = [whamlet|
+    $maybe tt <- fvTooltip view
+      <span .help-block>#{tt}
+    $maybe err <- fvErrors view
+      <span .help-block>#{err}
+|]
+
+
+-- | How the 'bootstrapSubmit' button should be rendered.
+--
+-- Since: yesod-form 1.3.8
+data BootstrapSubmit msg =
+    BootstrapSubmit
+        { bsValue   :: msg
+          -- ^ The text of the submit button.
+        , bsClasses :: Text
+          -- ^ Classes added to the @<button>@.
+        , bsAttrs   :: [(Text, Text)]
+          -- ^ Attributes added to the @<button>@.
+        } deriving (Show)
+
+instance IsString msg => IsString (BootstrapSubmit msg) where
+    fromString msg = BootstrapSubmit (fromString msg) " btn-default " []
+
+
+-- | A Bootstrap v3 submit button disguised as a field for
+-- convenience.  For example, if your form currently is:
+--
+-- > Person <$> areq textField "Name"    Nothing
+-- >        <*> areq textField "Surname" Nothing
+--
+-- Then just change it to:
+--
+-- > Person <$> areq textField "Name"    Nothing
+-- >        <*> areq textField "Surname" Nothing
+-- >        <*  bootstrapSubmit "Register"
+--
+-- (Note that @<*@ is not a typo.)
+--
+-- Alternatively, you may also just create the submit button
+-- manually as well in order to have more control over its
+-- layout.
+--
+-- Since: yesod-form 1.3.8
+bootstrapSubmit
+    :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
+    => BootstrapSubmit msg -> AForm m ()
+bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
+
+
+-- | Same as 'bootstrapSubmit' but for monadic forms.  This isn't
+-- as useful since you're not going to use 'renderBootstrap3'
+-- anyway.
+--
+-- Since: yesod-form 1.3.8
+mbootstrapSubmit
+    :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
+    => BootstrapSubmit msg -> MForm m (FormResult (), FieldView site)
+mbootstrapSubmit (BootstrapSubmit msg classes attrs) =
+    let res = FormSuccess ()
+        widget = [whamlet|<button class="btn #{classes}" type=submit *{attrs}>_{msg}|]
+        fv  = FieldView { fvLabel    = ""
+                        , fvTooltip  = Nothing
+                        , fvId       = bootstrapSubmitId
+                        , fvInput    = widget
+                        , fvErrors   = Nothing
+                        , fvRequired = False }
+    in return (res, fv)
+
+
+-- | A royal hack.  Magic id used to identify whether a field
+-- should have no label.  A valid HTML4 id which is probably not
+-- going to clash with any other id should someone use
+-- 'bootstrapSubmit' outside 'renderBootstrap3'.
+bootstrapSubmitId :: Text
+bootstrapSubmitId = "b:ootstrap___unique__:::::::::::::::::submit-id"

yesod-form/Yesod/Form/Fields.hs

@@ -18,6 +18,7 @@ module Yesod.Form.Fields
     , timeField
     , htmlField
     , emailField
+    , multiEmailField
     , searchField
     , AutoFocus
     , urlField
@@ -36,12 +37,15 @@ module Yesod.Form.Fields
     , selectFieldList
     , radioField
     , radioFieldList
+    , checkboxesFieldList
+    , checkboxesField
     , multiSelectField
     , multiSelectFieldList
     , Option (..)
     , OptionList (..)
     , mkOptionList
     , optionsPersist
+    , optionsPersistKey
     , optionsPairs
     , optionsEnum
     ) where
@@ -61,10 +65,11 @@ import qualified Text.Email.Validate as Email
 import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
 import Data.Text.Encoding.Error (lenientDecode)
 import Network.URI (parseURI)
-import Database.Persist.Sql (PersistField, PersistFieldSql)
+import Database.Persist.Sql (PersistField, PersistFieldSql (..))
-import Database.Persist (Entity (..))
+import Database.Persist (Entity (..), SqlType (SqlString))
 import Text.HTML.SanitizeXSS (sanitizeBalance)
 import Control.Monad (when, unless)
+import Data.Either (partitionEithers)
 import Data.Maybe (listToMaybe, fromMaybe)
 
 import qualified Blaze.ByteString.Builder.Html.Utf8 as B
@@ -75,17 +80,22 @@ import Database.Persist (PersistMonadBackend, PersistEntityBackend)
 import Text.Blaze.Html.Renderer.String (renderHtml)
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as L
-import Data.Text (Text, unpack, pack)
+import Data.Text as T ( Text, append, concat, cons, head
+                      , intercalate, isPrefixOf, null, unpack, pack, splitOn
+                      )
+import qualified Data.Text as T (drop, dropWhile)  
 import qualified Data.Text.Read
 
 import qualified Data.Map as Map
-import Yesod.Persist (selectList, runDB, Filter, SelectOpt, Key, YesodPersist, PersistEntity, PersistQuery, YesodDB)
+import Yesod.Persist (selectList, runDB, Filter, SelectOpt, Key, YesodPersist, PersistEntity, PersistQuery)
 import Control.Arrow ((&&&))
 
 import Control.Applicative ((<$>), (<|>))
 
 import Data.Attoparsec.Text (Parser, char, string, digit, skipSpace, endOfInput, parseOnly)
 
+import Yesod.Persist.Core
+
 defaultFormMessage :: FormMessage -> Text
 defaultFormMessage = englishFormMessage
 
@@ -99,7 +109,7 @@ intField = Field
 
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
 $newline never
-<input id="#{theId}" name="#{name}" *{attrs} type="number" :isReq:required="" value="#{showVal val}">
+<input id="#{theId}" name="#{name}" *{attrs} type="number" step=1 :isReq:required="" value="#{showVal val}">
 |]
     , fieldEnctype = UrlEncoded
     }
@@ -110,13 +120,13 @@ $newline never
 doubleField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Double
 doubleField = Field
     { fieldParse = parseHelper $ \s ->
-        case Data.Text.Read.double s of
+        case Data.Text.Read.double (prependZero s) of
             Right (a, "") -> Right a
             _ -> Left $ MsgInvalidNumber s
 
     , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
 $newline never
-<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{showVal val}">
+<input id="#{theId}" name="#{name}" *{attrs} type="number" step=any :isReq:required="" value="#{showVal val}">
 |]
     , fieldEnctype = UrlEncoded
     }
@@ -163,7 +173,9 @@ $newline never
 -- | A newtype wrapper around a 'Text' that converts newlines to HTML
 -- br-tags.
 newtype Textarea = Textarea { unTextarea :: Text }
-    deriving (Show, Read, Eq, PersistField, PersistFieldSql, Ord)
+    deriving (Show, Read, Eq, PersistField, Ord, ToJSON, FromJSON)
+instance PersistFieldSql Textarea where
+    sqlType _ = SqlString
 instance ToHtml Textarea where
     toHtml =
         unsafeByteString
@@ -295,12 +307,37 @@ $newline never
     , fieldEnctype = UrlEncoded
     }
 
+-- |
+--
+-- Since 1.3.7
+multiEmailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m [Text]
+multiEmailField = Field
+    { fieldParse = parseHelper $
+        \s ->
+            let addrs = map validate $ splitOn "," s
+            in case partitionEithers addrs of
+                ([], good) -> Right good
+                (bad, _) -> Left $ MsgInvalidEmail $ cat bad
+    , fieldView = \theId name attrs val isReq -> toWidget [hamlet|
+$newline never
+<input id="#{theId}" name="#{name}" *{attrs} type="email" multiple :isReq:required="" value="#{either id cat val}">
+|]
+    , fieldEnctype = UrlEncoded
+    }
+    where
+        -- report offending address along with error
+        validate a = case Email.validate $ encodeUtf8 a of
+                        Left e -> Left $ T.concat [a, " (",  pack e, ")"]
+                        Right r -> Right $ emailToText r
+        cat = intercalate ", "
+        emailToText = decodeUtf8With lenientDecode . Email.toByteString
+
 type AutoFocus = Bool
 searchField :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus -> Field m Text
 searchField autoFocus = Field
     { fieldParse = parseHelper Right
     , fieldView = \theId name attrs val isReq -> do
-        [whamlet|\
+        [whamlet|
 $newline never
 <input id="#{theId}" name="#{name}" *{attrs} type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">
 |]
@@ -385,6 +422,28 @@ radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
                -> Field (HandlerT site IO) a
 radioFieldList = radioField . optionsPairs
 
+checkboxesFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) => [(msg, a)]
+                     -> Field (HandlerT site IO) [a]
+checkboxesFieldList = checkboxesField . optionsPairs
+
+checkboxesField :: (Eq a, RenderMessage site FormMessage)
+                 => HandlerT site IO (OptionList a)
+                 -> Field (HandlerT site IO) [a]
+checkboxesField ioptlist = (multiSelectField ioptlist)
+    { fieldView =
+        \theId name attrs val isReq -> do
+            opts <- fmap olOptions $ handlerToWidget ioptlist
+            let optselected (Left _) _ = False
+                optselected (Right vals) opt = (optionInternalValue opt) `elem` vals
+            [whamlet|
+                <span ##{theId}>
+                    $forall opt <- opts
+                        <label>
+                            <input type=checkbox name=#{name} value=#{optionExternalValue opt} *{attrs} :optselected val opt:checked>
+                            #{optionDisplay opt}
+                |]
+    }
+
 radioField :: (Eq a, RenderMessage site FormMessage)
            => HandlerT site IO (OptionList a)
            -> Field (HandlerT site IO) a
@@ -434,6 +493,8 @@ $newline never
       "yes" -> Right $ Just True
       "on" -> Right $ Just True
       "no" -> Right $ Just False
+      "true" -> Right $ Just True
+      "false" -> Right $ Just False
       t -> Left $ SomeMessage $ MsgInvalidBool t
     showVal = either (\_ -> False)
 
@@ -495,9 +556,9 @@ optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a)
 optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound]
 
 optionsPersist :: ( YesodPersist site, PersistEntity a
-                  , PersistQuery (YesodDB site)
+                  , PersistQuery (YesodPersistBackend site (HandlerT site IO))
                   , PathPiece (Key a)
-                  , PersistEntityBackend a ~ PersistMonadBackend (YesodDB site)
+                  , PersistEntityBackend a ~ PersistMonadBackend (YesodPersistBackend site (HandlerT site IO))
                   , RenderMessage site msg
                   )
                => [Filter a]
@@ -513,6 +574,31 @@ optionsPersist filts ords toDisplay = fmap mkOptionList $ do
         , optionExternalValue = toPathPiece key
         }) pairs
 
+-- | An alternative to 'optionsPersist' which returns just the @Key@ instead of
+-- the entire @Entity@.
+--
+-- Since 1.3.2
+optionsPersistKey
+  :: (YesodPersist site
+     , PersistEntity a
+     , PersistQuery (YesodPersistBackend site (HandlerT site IO))
+     , PathPiece (Key a)
+     , RenderMessage site msg
+     , PersistEntityBackend a ~ PersistMonadBackend (YesodPersistBackend site (HandlerT site IO)))
+  => [Filter a]
+  -> [SelectOpt a]
+  -> (a -> msg)
+  -> HandlerT site IO (OptionList (Key a))
+
+optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do
+    mr <- getMessageRender
+    pairs <- runDB $ selectList filts ords
+    return $ map (\(Entity key value) -> Option
+        { optionDisplay = mr (toDisplay value)
+        , optionInternalValue = key
+        , optionExternalValue = toPathPiece key
+        }) pairs
+
 selectFieldHelper
         :: (Eq a, RenderMessage site FormMessage)
         => (Text -> Text -> [(Text, Text)] -> WidgetT site IO () -> WidgetT site IO ())
@@ -531,7 +617,7 @@ selectFieldHelper outside onOpt inside opts' = Field
             flip mapM_ opts $ \opt -> inside
                 theId
                 name
-                attrs
+                ((if isReq then (("required", "required"):) else id) attrs)
                 (optionExternalValue opt)
                 ((render opts val) == optionExternalValue opt)
                 (optionDisplay opt)
@@ -628,3 +714,19 @@ $newline never
 incrInts :: Ints -> Ints
 incrInts (IntSingle i) = IntSingle $ i + 1
 incrInts (IntCons i is) = (i + 1) `IntCons` is
+
+
+-- | Adds a '0' to some text so that it may be recognized as a double.
+--   The read ftn does not recognize ".3" as 0.3 nor "-.3" as -0.3, so this
+--   function changes ".xxx" to "0.xxx" and "-.xxx" to "-0.xxx"
+
+prependZero :: Text -> Text
+prependZero t0 = if T.null t1
+                 then t1
+                 else if T.head t1 == '.'
+                      then '0' `T.cons` t1
+                      else if "-." `T.isPrefixOf` t1
+                           then "-0." `T.append` (T.drop 2 t1)
+                           else t1
+
+  where t1 = T.dropWhile ((==) ' ') t0

yesod-form/Yesod/Form/Functions.hs

@@ -23,7 +23,10 @@ module Yesod.Form.Functions
     , runFormGet
       -- * Generate a blank form
     , generateFormPost
+    , generateFormGet'
     , generateFormGet
+      -- * More than one form on a handler
+    , identifyForm
       -- * Rendering
     , FormRender
     , renderTable
@@ -39,15 +42,16 @@ module Yesod.Form.Functions
       -- * Utilities
     , fieldSettingsLabel
     , parseHelper
+    , parseHelperGen
     ) where
 
 import Yesod.Form.Types
 import Data.Text (Text, pack)
 import Control.Arrow (second)
-import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)
+import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local)
 import Control.Monad.Trans.Class
 import Control.Monad (liftM, join)
-import Crypto.Classes (constTimeEq)
+import Data.Byteable (constEqBytes)
 import Text.Blaze (Markup, toMarkup)
 #define Html Markup
 #define toHtml toMarkup
@@ -99,13 +103,18 @@ askFiles = do
     (x, _, _) <- ask
     return $ liftM snd x
 
+-- | Converts a form field into monadic form. This field requires a value
+-- and will return 'FormFailure' if left empty.
 mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
-     => Field m a
+     => Field m a           -- ^ form field
-     -> FieldSettings site
+     -> FieldSettings site  -- ^ settings for this field
-     -> Maybe a
+     -> Maybe a             -- ^ optional default value
      -> MForm m (FormResult a, FieldView site)
 mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True
 
+-- | Converts a form field into monadic form. This field is optional, i.e.
+-- if filled in, it returns 'Just a', if left empty, it returns 'Nothing'.
+-- Arguments are the same as for 'mreq' (apart from type of default value).
 mopt :: (site ~ HandlerSite m, MonadHandler m)
      => Field m a
      -> FieldSettings site
@@ -155,6 +164,7 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
         , fvRequired = isReq
         })
 
+-- | Applicative equivalent of 'mreq'.
 areq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
      => Field m a
      -> FieldSettings site
@@ -162,6 +172,7 @@ areq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
      -> AForm m a
 areq a b = formToAForm . liftM (second return) . mreq a b
 
+-- | Applicative equivalent of 'mopt'.
 aopt :: MonadHandler m
      => Field m a
      -> FieldSettings (HandlerSite m)
@@ -175,7 +186,7 @@ runFormGeneric :: Monad m
                -> [Text]
                -> Maybe (Env, FileEnv)
                -> m (a, Enctype)
-runFormGeneric form site langs env = evalRWST form (env, site, langs) (IntSingle 1)
+runFormGeneric form site langs env = evalRWST form (env, site, langs) (IntSingle 0)
 
 -- | This function is used to both initially render a form and to later extract
 -- results from it. Note that, due to CSRF protection and a few other issues,
@@ -213,12 +224,12 @@ postHelper form env = do
                     | not (Map.lookup tokenKey params === reqToken req) ->
                         FormFailure [renderMessage m langs MsgCsrfWarning]
                 _ -> res
-            where (Just [t1]) === (Just t2) = TE.encodeUtf8 t1 `constTimeEq` TE.encodeUtf8 t2
+            where (Just [t1]) === (Just t2) = TE.encodeUtf8 t1 `constEqBytes` TE.encodeUtf8 t2
                   Nothing     === Nothing   = True   -- It's important to use constTimeEq
                   _           === _         = False  -- in order to avoid timing attacks.
     return ((res', xml), enctype)
 
--- | Similar to 'runFormPost', except it always ignore the currently available
+-- | Similar to 'runFormPost', except it always ignores the currently available
 -- environment. This is necessary in cases like a wizard UI, where a single
 -- page will both receive and incoming form and produce a new, blank form. For
 -- general usage, you can stick with @runFormPost@.
@@ -259,6 +270,17 @@ runFormGet form = do
                 Just _ -> Just (Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) gets, Map.empty)
     getHelper form env
 
+{- FIXME: generateFormGet' "Will be renamed to generateFormGet in next verison of Yesod" -}
+-- |
+--
+-- Since 1.3.11
+generateFormGet'
+    :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m)
+    => (Html -> MForm m (FormResult a, xml))
+    -> m (xml, Enctype)
+generateFormGet' form = first snd `liftM` getHelper form Nothing
+
+{-# DEPRECATED generateFormGet "Will require RenderMessage in next verison of Yesod" #-}
 generateFormGet :: MonadHandler m
                 => (Html -> MForm m a)
                 -> m (a, Enctype)
@@ -277,6 +299,57 @@ getHelper form env = do
     m <- getYesod
     runFormGeneric (form fragment) m langs env
 
+
+-- | Creates a hidden field on the form that identifies it.  This
+-- identification is then used to distinguish between /missing/
+-- and /wrong/ form data when a single handler contains more than
+-- one form.
+--
+-- For instance, if you have the following code on your handler:
+--
+-- > ((fooRes, fooWidget), fooEnctype) <- runFormPost fooForm
+-- > ((barRes, barWidget), barEnctype) <- runFormPost barForm
+--
+-- Then replace it with
+--
+-- > ((fooRes, fooWidget), fooEnctype) <- runFormPost $ identifyForm "foo" fooForm
+-- > ((barRes, barWidget), barEnctype) <- runFormPost $ identifyForm "bar" barForm
+--
+-- Note that it's your responsibility to ensure that the
+-- identification strings are unique (using the same one twice on a
+-- single handler will not generate any errors).  This allows you
+-- to create a variable number of forms and still have them work
+-- even if their number or order change between the HTML
+-- generation and the form submission.
+identifyForm
+  :: Monad m
+  => Text -- ^ Form identification string.
+  -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
+  -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
+identifyForm identVal form = \fragment -> do
+    -- Create hidden <input>.
+    let fragment' =
+          [shamlet|
+            <input type=hidden name=#{identifyFormKey} value=#{identVal}>
+            #{fragment}
+          |]
+
+    -- Check if we got its value back.
+    mp <- askParams
+    let missing = (mp >>= Map.lookup identifyFormKey) /= Just [identVal]
+
+    -- Run the form proper (with our hidden <input>).  If the
+    -- data is missing, then do not provide any params to the
+    -- form, which will turn its result into FormMissing.  Also,
+    -- doing this avoids having lots of fields with red errors.
+    let eraseParams | missing   = local (\(_, h, l) -> (Nothing, h, l))
+                    | otherwise = id
+    eraseParams (form fragment')
+
+identifyFormKey :: Text
+identifyFormKey = "_formid"
+
+
 type FormRender m a =
        AForm m a
     -> Html
@@ -326,7 +399,9 @@ $forall view <- views
 |]
     return (res, widget)
 
--- | Render a form using Bootstrap-friendly shamlet syntax.
+-- | Render a form using Bootstrap v2-friendly shamlet syntax.
+-- If you're using Bootstrap v3, then you should use the
+-- functions from module "Yesod.Form.Bootstrap3".
 --
 -- Sample Hamlet:
 --
@@ -361,6 +436,7 @@ renderBootstrap aform fragment = do
                                 <span .help-block>#{err}
                 |]
     return (res, widget)
+{-# DEPRECATED renderBootstrap "Please use the Yesod.Form.Bootstrap3 module." #-}
 
 check :: (Monad m, RenderMessage (HandlerSite m) msg)
       => (a -> Either msg a)
@@ -421,6 +497,15 @@ fieldSettingsLabel msg = FieldSettings (SomeMessage msg) Nothing Nothing Nothing
 parseHelper :: (Monad m, RenderMessage site FormMessage)
             => (Text -> Either FormMessage a)
             -> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
-parseHelper _ [] _ = return $ Right Nothing
+parseHelper = parseHelperGen
-parseHelper _ ("":_) _ = return $ Right Nothing
+
-parseHelper f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $ f x
+-- | A generalized version of 'parseHelper', allowing any type for the message
+-- indicating a bad parse.
+--
+-- Since 1.3.6
+parseHelperGen :: (Monad m, RenderMessage site msg)
+               => (Text -> Either msg a)
+               -> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
+parseHelperGen _ [] _ = return $ Right Nothing
+parseHelperGen _ ("":_) _ = return $ Right Nothing
+parseHelperGen f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $ f x

yesod-form/Yesod/Form/Input.hs

@@ -4,6 +4,7 @@ module Yesod.Form.Input
     ( FormInput (..)
     , runInputGet
     , runInputPost
+    , runInputPostResult
     , ireq
     , iopt
     ) where
@@ -66,11 +67,22 @@ toMap :: [(Text, a)] -> Map.Map Text [a]
 toMap = Map.unionsWith (++) . map (\(x, y) -> Map.singleton x [y])
 
 runInputPost :: MonadHandler m => FormInput m a -> m a
-runInputPost (FormInput f) = do
+runInputPost fi = do
+    emx <- runInputPostHelper fi
+    case emx of
+        Left errs -> invalidArgs errs
+        Right x -> return x
+
+runInputPostResult :: MonadHandler m => FormInput m a -> m (FormResult a)
+runInputPostResult fi = do
+    emx <- runInputPostHelper fi
+    case emx of
+        Left errs -> return $ FormFailure errs
+        Right x   -> return $ FormSuccess x
+
+runInputPostHelper :: MonadHandler m => FormInput m a -> m (Either [Text] a)
+runInputPostHelper (FormInput f) = do
     (env, fenv) <- liftM (toMap *** toMap) runRequestBody
     m <- getYesod
     l <- languages
-    emx <- f m l env fenv
+    fmap (either (Left . ($ [])) Right) $ f m l env fenv
-    case emx of
-        Left errs -> invalidArgs $ errs []
-        Right x -> return x

yesod-form/Yesod/Form/MassInput.hs

@@ -11,7 +11,7 @@ module Yesod.Form.MassInput
 
 import Yesod.Form.Types
 import Yesod.Form.Functions
-import Yesod.Form.Fields (boolField)
+import Yesod.Form.Fields (checkBoxField)
 import Yesod.Core
 import Control.Monad.Trans.RWS (get, put, ask)
 import Data.Maybe (fromMaybe)
@@ -97,7 +97,7 @@ $newline never
 <input type=hidden name=#{deleteName} value=yes>
 |]
         _ -> do
-            (_, xml2) <- aFormToForm $ areq boolField FieldSettings
+            (_, xml2) <- aFormToForm $ areq checkBoxField FieldSettings
                 { fsLabel = SomeMessage MsgDelete
                 , fsTooltip = Nothing
                 , fsName = Just deleteName

yesod-form/Yesod/Form/Types.hs

@@ -98,11 +98,11 @@ instance Monad m => Functor (AForm m) where
       where
         go (w, x, y, z) = (fmap f w, x, y, z)
 instance Monad m => Applicative (AForm m) where
-    pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, mempty, ints, mempty)
+    pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, id, ints, mempty)
     (AForm f) <*> (AForm g) = AForm $ \mr env ints -> do
         (a, b, ints', c) <- f mr env ints
         (x, y, ints'', z) <- g mr env ints'
-        return (a <*> x, b `mappend` y, ints'', c `mappend` z)
+        return (a <*> x, b . y, ints'', c `mappend` z)
 instance (Monad m, Monoid a) => Monoid (AForm m a) where
     mempty = pure mempty
     mappend a b = mappend <$> a <*> b

yesod-form/hello-forms.hs

@@ -23,7 +23,8 @@ mkYesod "HelloForms" [parseRoutes|
 /file FileR GET POST
 |]
 
-myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,)
+myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,,,)
+    <*> pure "pure works!"
     <*> areq boolField "Bool field" Nothing
     <*> aopt boolField "Opt bool field" Nothing
     <*> areq textField "Text field" Nothing
@@ -33,6 +34,7 @@ myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,)
     <*> aopt (multiSelectFieldList fruits) "Opt multi select field" Nothing
     <*> aopt intField "Opt int field" Nothing
     <*> aopt (radioFieldList fruits) "Opt radio" Nothing
+    <*> aopt multiEmailField "Opt multi email" Nothing
 
 data HelloForms = HelloForms
 

yesod-form/yesod-form.cabal

@@ -1,5 +1,5 @@
 name:            yesod-form
-version:         1.3.0.1
+version:         1.3.11
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -17,10 +17,11 @@ library
                    , yesod-core            >= 1.2      && < 1.3
                    , yesod-persistent      >= 1.2      && < 1.3
                    , time                  >= 1.1.4
-                   , hamlet                >= 1.1      && < 1.2
+                   , hamlet                >= 1.1.8
-                   , shakespeare-css       >= 1.0      && < 1.1
+                   , shakespeare
-                   , shakespeare-js        >= 1.0.2    && < 1.2
+                   , shakespeare-css       >= 1.0
-                   , persistent            >= 1.2      && < 1.3
+                   , shakespeare-js        >= 1.0.2
+                   , persistent            >= 1.2      && < 1.4
                    , template-haskell
                    , transformers          >= 0.2.2
                    , data-default
@@ -35,13 +36,14 @@ library
                    , blaze-html            >= 0.5
                    , blaze-markup          >= 0.5.1
                    , attoparsec            >= 0.10
-                   , crypto-api            >= 0.8
+                   , byteable
                    , aeson
                    , resourcet
 
     exposed-modules: Yesod.Form
                      Yesod.Form.Types
                      Yesod.Form.Functions
+                     Yesod.Form.Bootstrap3
                      Yesod.Form.Input
                      Yesod.Form.Fields
                      Yesod.Form.Jquery

yesod-newsfeed/Yesod/AtomFeed.hs

@@ -20,6 +20,7 @@
 -- | Generation of Atom newsfeeds.
 module Yesod.AtomFeed
     ( atomFeed
+    , atomFeedText
     , atomLink
     , RepAtom (..)
     , module Yesod.FeedTypes
@@ -47,6 +48,11 @@ atomFeed feed = do
     render <- getUrlRender
     return $ RepAtom $ toContent $ renderLBS def $ template feed render
 
+-- | Same as @'atomFeed'@ but for @'Feed Text'@. Useful for cases where you are
+--   generating a feed of external links.
+atomFeedText :: MonadHandler m => Feed Text -> m RepAtom
+atomFeedText feed = return $ RepAtom $ toContent $ renderLBS def $ template feed id
+
 template :: Feed url -> (url -> Text) -> Document
 template Feed {..} render =
     Document (Prologue [] Nothing []) (addNS root) []
@@ -62,7 +68,7 @@ template Feed {..} render =
         : Element "link" (Map.singleton "href" $ render feedLinkHome) []
         : Element "updated" Map.empty [NodeContent $ formatW3 feedUpdated]
         : Element "id" Map.empty [NodeContent $ render feedLinkHome]
-        : Element "author" Map.empty [NodeContent feedAuthor]
+        : Element "author" Map.empty [NodeElement $ Element "name" Map.empty [NodeContent feedAuthor]]
         : map (flip entryTemplate render) feedEntries
 
 entryTemplate :: FeedEntry url -> (url -> Text) -> Element

yesod-newsfeed/Yesod/Feed.hs

@@ -17,6 +17,7 @@
 -------------------------------------------------------------------------------
 module Yesod.Feed
     ( newsFeed
+    , newsFeedText
     , module Yesod.FeedTypes
     ) where
 
@@ -29,3 +30,10 @@ newsFeed :: MonadHandler m => Feed (Route (HandlerSite m)) -> m TypedContent
 newsFeed f = selectRep $ do
     provideRep $ atomFeed f
     provideRep $ rssFeed f
+
+-- | Same as @'newsFeed'@ but for @'Feed Text'@. Useful for cases where you are
+--   generating a feed of external links.
+newsFeedText :: MonadHandler m => Feed Text -> m TypedContent
+newsFeedText f = selectRep $ do
+    provideRep $ atomFeedText f
+    provideRep $ rssFeedText f

yesod-newsfeed/Yesod/RssFeed.hs

@@ -16,6 +16,7 @@
 -------------------------------------------------------------------------------
 module Yesod.RssFeed
     ( rssFeed
+    , rssFeedText
     , rssLink
     , RepRss (..)
     , module Yesod.FeedTypes
@@ -44,6 +45,11 @@ rssFeed feed = do
     render <- getUrlRender
     return $ RepRss $ toContent $ renderLBS def $ template feed render
 
+-- | Same as @'rssFeed'@ but for @'Feed Text'@. Useful for cases where you are
+--   generating a feed of external links.
+rssFeedText :: MonadHandler m => Feed Text -> m RepRss
+rssFeedText feed = return $ RepRss $ toContent $ renderLBS def $ template feed id
+
 template :: Feed url -> (url -> Text) -> Document
 template Feed {..} render =
     Document (Prologue [] Nothing []) root []

yesod-newsfeed/yesod-newsfeed.cabal

@@ -1,5 +1,5 @@
 name:            yesod-newsfeed
-version:         1.2.0
+version:         1.2.0.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -16,7 +16,8 @@ library
     build-depends:   base                 >= 4        && < 5
                    , yesod-core           >= 1.2      && < 1.3
                    , time                 >= 1.1.4
-                   , hamlet               >= 1.1      && < 1.2
+                   , hamlet               >= 1.1
+                   , shakespeare
                    , bytestring           >= 0.9.1.4
                    , text                 >= 0.9
                    , xml-conduit          >= 1.0

yesod-persistent/Yesod/Persist/Core.hs

@@ -25,16 +25,17 @@ import Control.Monad.Trans.Reader (runReaderT)
 import Yesod.Core
 import Data.Conduit
 import Blaze.ByteString.Builder (Builder)
-import Data.IORef.Lifted
+import Data.Pool
-import Data.Conduit.Pool
 import Control.Monad.Trans.Resource
+import Control.Exception (throwIO)
+import Yesod.Core.Types (HandlerContents (HCError))
 import qualified Database.Persist.Sql as SQL
 
 type YesodDB site = YesodPersistBackend site (HandlerT site IO)
 
 class Monad (YesodPersistBackend site (HandlerT site IO)) => YesodPersist site where
     type YesodPersistBackend site :: (* -> *) -> * -> *
-    runDB :: YesodDB site a -> HandlerT site IO a
+    runDB :: YesodPersistBackend site (HandlerT site IO) a -> HandlerT site IO a
 
 -- | Helper for creating 'runDB'.
 --
@@ -70,7 +71,7 @@ class YesodPersist site => YesodPersistRunner site where
     getDBRunner :: HandlerT site IO (DBRunner site, HandlerT site IO ())
 
 newtype DBRunner site = DBRunner
-    { runDBRunner :: forall a. YesodDB site a -> HandlerT site IO a
+    { runDBRunner :: forall a. YesodPersistBackend site (HandlerT site IO) a -> HandlerT site IO a
     }
 
 -- | Helper for implementing 'getDBRunner'.
@@ -80,24 +81,23 @@ defaultGetDBRunner :: YesodPersistBackend site ~ SqlPersistT
                    => (site -> Pool SQL.Connection)
                    -> HandlerT site IO (DBRunner site, HandlerT site IO ())
 defaultGetDBRunner getPool = do
-    ididSucceed <- newIORef False
-
     pool <- fmap getPool getYesod
-    managedConn <- takeResource pool
+    let withPrep conn f = f conn (SQL.connPrepare conn)
-    let conn = mrValue managedConn
+    (relKey, (conn, local)) <- allocate
+        (do
+            (conn, local) <- takeResource pool
+            withPrep conn SQL.connBegin
+            return (conn, local)
+            )
+        (\(conn, local) -> do
+            withPrep conn SQL.connRollback
+            destroyResource pool local conn)
 
-    let withPrep f = f conn (SQL.connPrepare conn)
+    let cleanup = liftIO $ do
-    (finishTransaction, ()) <- allocate (withPrep SQL.connBegin) $ \() -> do
+            withPrep conn SQL.connCommit
-        didSucceed <- readIORef ididSucceed
+            putResource local conn
-        withPrep $ if didSucceed
+            _ <- unprotect relKey
-            then SQL.connCommit
+            return ()
-            else SQL.connRollback
-
-    let cleanup = do
-            writeIORef ididSucceed True
-            release finishTransaction
-            mrReuse managedConn True
-            mrRelease managedConn
 
     return (DBRunner $ \x -> runReaderT (unSqlPersistT x) conn, cleanup)
 
@@ -106,7 +106,7 @@ defaultGetDBRunner getPool = do
 --
 -- Since 1.2.0
 runDBSource :: YesodPersistRunner site
-            => Source (YesodDB site) a
+            => Source (YesodPersistBackend site (HandlerT site IO)) a
             -> Source (HandlerT site IO) a
 runDBSource src = do
     (dbrunner, cleanup) <- lift getDBRunner
@@ -116,7 +116,7 @@ runDBSource src = do
 -- | Extends 'respondSource' to create a streaming database response body.
 respondSourceDB :: YesodPersistRunner site
                 => ContentType
-                -> Source (YesodDB site) (Flush Builder)
+                -> Source (YesodPersistBackend site (HandlerT site IO)) (Flush Builder)
                 -> HandlerT site IO TypedContent
 respondSourceDB ctype = respondSource ctype . runDBSource
 
@@ -132,7 +132,7 @@ get404 :: ( PersistStore (t m)
 get404 key = do
     mres <- get key
     case mres of
-        Nothing -> lift notFound
+        Nothing -> notFound'
         Just res -> return res
 
 -- | Get the given entity by unique key, or return a 404 not found if it doesn't
@@ -148,9 +148,14 @@ getBy404 :: ( PersistUnique (t m)
 getBy404 key = do
     mres <- getBy key
     case mres of
-        Nothing -> lift notFound
+        Nothing -> notFound'
         Just res -> return res
 
+-- | Should be equivalent to @lift . notFound@, but there's an apparent bug in
+-- GHC 7.4.2 that leads to segfaults. This is a workaround.
+notFound' :: MonadIO m => m a
+notFound' = liftIO $ throwIO $ HCError NotFound
+
 instance MonadHandler m => MonadHandler (SqlPersistT m) where
     type HandlerSite (SqlPersistT m) = HandlerSite m
     liftHandlerT = lift . liftHandlerT

yesod-persistent/yesod-persistent.cabal

@@ -1,5 +1,5 @@
 name:            yesod-persistent
-version:         1.2.1
+version:         1.2.3
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -15,14 +15,13 @@ description:     Some helpers for using Persistent from Yesod.
 library
     build-depends:   base                      >= 4        && < 5
                    , yesod-core                >= 1.2.2    && < 1.3
-                   , persistent                >= 1.2      && < 1.3
+                   , persistent                >= 1.2      && < 1.4
-                   , persistent-template       >= 1.2      && < 1.3
+                   , persistent-template       >= 1.2      && < 1.4
-                   , transformers              >= 0.2.2    && < 0.4
+                   , transformers              >= 0.2.2
                    , blaze-builder
                    , conduit
-                   , lifted-base
+                   , resourcet                 >= 0.4.5
-                   , pool-conduit
+                   , resource-pool
-                   , resourcet
     exposed-modules: Yesod.Persist
                      Yesod.Persist.Core
     ghc-options:     -Wall
@@ -35,6 +34,7 @@ test-suite test
     build-depends: base
                  , hspec
                  , wai-test
+                 , wai-extra
                  , yesod-core
                  , persistent-sqlite
                  , yesod-persistent

yesod-platform/make-cabal.sh

@@ -7,4 +7,16 @@ then
     cabal install cabal-nirvana -fgenerate
 fi
 
-cabal-nirvana-generate yesod yesod-static hjsmin blaze-html yesod-test shakespeare-text | runghc to-cabal.hs > yesod-platform.cabal
+cabal-nirvana-generate \
+    yesod \
+    yesod-static \
+    yesod-auth-hashdb \
+    hjsmin \
+    blaze-html \
+    yesod-test \
+    shakespeare-text \
+    esqueleto \
+    warp-tls \
+    hjsmin \
+    http-reverse-proxy \
+    | runghc to-cabal.hs > yesod-platform.cabal

yesod-platform/to-cabal.hs

@@ -3,7 +3,7 @@ import Control.Applicative ((<$>))
 
 main = do
     pkgs <- map (intercalate " == ")
-          . filter (\xs -> not $ any (`isPrefixOf` xs) $ map return ["parsec", "text", "transformers", "mtl", "HUnit", "QuickCheck", "binary", "zlib", "stm", "regex-compat", "hashable"])
+          . filter (\xs -> not $ any (`isPrefixOf` xs) $ map return ["parsec", "text", "transformers", "mtl", "HUnit", "QuickCheck", "binary", "zlib", "stm", "regex-compat", "hashable", "vault", "integer-gmp"])
           . map words
           . filter (not . null)
           . lines

yesod-platform/yesod-platform.cabal

@@ -1,5 +1,5 @@
 name:            yesod-platform
-version:         1.2.3
+version:         1.2.12.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -14,131 +14,146 @@ homepage:        http://www.yesodweb.com/
 
 library
     build-depends: base >= 4 && < 5
-                 , SHA == 1.6.1
+                 , SHA == 1.6.4
-                 , aeson == 0.6.1.0
+                 , aeson == 0.7.0.6
-                 , ansi-terminal == 0.6
+                 , ansi-terminal == 0.6.1.1
-                 , asn1-data == 0.7.1
+                 , ansi-wl-pprint == 0.6.7.1
-                 , asn1-types == 0.2.0
+                 , asn1-encoding == 0.8.1.3
-                 , attoparsec == 0.10.4.0
+                 , asn1-parse == 0.8.1
-                 , attoparsec-conduit == 1.0.1.2
+                 , asn1-types == 0.2.3
-                 , authenticate == 1.3.2.6
+                 , async == 2.0.1.5
-                 , base-unicode-symbols == 0.2.2.4
+                 , attoparsec == 0.12.0.0
+                 , attoparsec-conduit == 1.1.0
+                 , authenticate == 1.3.2.8
+                 , base16-bytestring == 0.1.1.6
                  , base64-bytestring == 1.0.0.1
-                 , blaze-builder == 0.3.1.1
+                 , blaze-builder == 0.3.3.2
-                 , blaze-builder-conduit == 1.0.0
+                 , blaze-builder-conduit == 1.1.0
-                 , blaze-html == 0.6.1.1
+                 , blaze-html == 0.7.0.2
-                 , blaze-markup == 0.5.1.5
+                 , blaze-markup == 0.6.1.0
                  , byteable == 0.1.1
                  , byteorder == 1.0.4
-                 , case-insensitive == 1.0.0.2
+                 , case-insensitive == 1.2.0.0
-                 , cereal == 0.3.5.2
+                 , cereal == 0.4.0.1
-                 , certificate == 1.3.8
+                 , cipher-aes == 0.2.7
-                 , cipher-aes == 0.1.8
+                 , cipher-des == 0.0.6
-                 , cipher-rc4 == 0.1.2
+                 , cipher-rc4 == 0.1.4
-                 , clientsession == 0.9
+                 , clientsession == 0.9.0.3
-                 , conduit == 1.0.7.3
+                 , conduit == 1.1.6
-                 , cookie == 0.4.0.1
+                 , conduit-extra == 1.1.0.4
-                 , cprng-aes == 0.3.4
+                 , connection == 0.2.1
-                 , crypto-api == 0.12.2.1
+                 , cookie == 0.4.1.1
-                 , crypto-conduit == 0.5.2
+                 , cprng-aes == 0.5.2
-                 , crypto-numbers == 0.1.3
+                 , crypto-api == 0.13
-                 , crypto-pubkey == 0.1.4
+                 , crypto-cipher-types == 0.0.9
-                 , crypto-pubkey-types == 0.4.0
+                 , crypto-numbers == 0.2.3
-                 , crypto-random-api == 0.2.0
+                 , crypto-pubkey == 0.2.4
-                 , cryptohash == 0.9.1
+                 , crypto-pubkey-types == 0.4.2.2
-                 , css-text == 0.1.1
+                 , crypto-random == 0.0.7
+                 , cryptohash == 0.11.5
+                 , cryptohash-conduit == 0.1.1
+                 , css-text == 0.1.2.1
                  , data-default == 0.5.3
                  , data-default-class == 0.0.1
                  , data-default-instances-base == 0.0.1
                  , data-default-instances-containers == 0.0.1
                  , data-default-instances-dlist == 0.0.1
                  , data-default-instances-old-locale == 0.0.1
-                 , date-cache == 0.3.0
+                 , dlist == 0.7.0.1
-                 , dlist == 0.5
+                 , email-validate == 2.0.1
-                 , email-validate == 1.0.0
+                 , entropy == 0.3.2
-                 , entropy == 0.2.2.1
+                 , esqueleto == 1.4.1.2
-                 , failure == 0.2.0.1
+                 , exceptions == 0.6.1
-                 , fast-logger == 0.3.2
+                 , fast-logger == 2.1.5
-                 , file-embed == 0.0.4.9
+                 , file-embed == 0.0.7
-                 , filesystem-conduit == 1.0.0.1
+                 , hamlet == 1.2.0
-                 , hamlet == 1.1.7.1
+                 , hjsmin == 0.1.4.6
-                 , hjsmin == 0.1.4.1
+                 , hspec == 1.9.5
-                 , hspec == 1.6.1
+                 , hspec-expectations == 0.5.0.1
-                 , hspec-expectations == 0.3.2
+                 , html-conduit == 1.1.0.5
-                 , html-conduit == 1.1.0
+                 , http-client == 0.3.3
-                 , http-attoparsec == 0.1.0
+                 , http-client-tls == 0.2.1.1
-                 , http-conduit == 1.9.4.1
+                 , http-conduit == 2.1.2
                  , http-date == 0.0.4
-                 , http-types == 0.8.0
+                 , http-reverse-proxy == 0.3.1.8
-                 , language-javascript == 0.5.7
+                 , http-types == 0.8.5
-                 , lifted-base == 0.2.1.0
+                 , language-javascript == 0.5.13
-                 , mime-mail == 0.4.2
+                 , lifted-base == 0.2.2.2
-                 , mime-types == 0.1.0.3
+                 , mime-mail == 0.4.5.2
-                 , mmorph == 1.0.0
+                 , mime-types == 0.1.0.4
-                 , monad-control == 0.3.2.1
+                 , mmorph == 1.0.3
-                 , monad-logger == 0.3.1.1
+                 , monad-control == 0.3.3.0
-                 , network-conduit == 1.0.0
+                 , monad-logger == 0.3.6.1
-                 , path-pieces == 0.1.2
+                 , monad-loops == 0.4.2
-                 , pem == 0.1.2
+                 , nats == 0.2
-                 , persistent == 1.2.2.0
+                 , network-conduit == 1.1.0
-                 , persistent-template == 1.2.0.2
+                 , optparse-applicative == 0.8.1
-                 , pool-conduit == 0.1.2
+                 , path-pieces == 0.1.3.1
-                 , primitive == 0.5.0.1
+                 , pem == 0.2.2
+                 , persistent == 1.3.1.1
+                 , persistent-template == 1.3.1.4
+                 , primitive == 0.5.3.0
                  , publicsuffixlist == 0.1
-                 , pureMD5 == 2.1.2.1
+                 , pwstore-fast == 2.4.1
-                 , pwstore-fast == 2.3
+                 , quickcheck-io == 0.1.1
-                 , quickcheck-io == 0.1.0
+                 , resource-pool == 0.2.3.0
-                 , resource-pool == 0.2.1.1
+                 , resourcet == 1.1.2.2
-                 , resourcet == 0.4.7.1
+                 , safe == 0.3.4
-                 , safe == 0.3.3
+                 , scientific == 0.3.2.1
-                 , semigroups == 0.9.2
+                 , securemem == 0.1.3
-                 , setenv == 0.1.0
+                 , semigroups == 0.15
-                 , shakespeare == 1.0.5
+                 , setenv == 0.1.1.1
-                 , shakespeare-css == 1.0.6.2
+                 , shakespeare == 2.0.0.3
-                 , shakespeare-i18n == 1.0.0.3
+                 , shakespeare-css == 1.1.0
-                 , shakespeare-js == 1.1.4.1
+                 , shakespeare-i18n == 1.1.0
-                 , shakespeare-text == 1.0.0.6
+                 , shakespeare-js == 1.3.0
+                 , shakespeare-text == 1.1.0
                  , silently == 1.2.4.1
-                 , simple-sendfile == 0.2.12
+                 , simple-sendfile == 0.2.14
-                 , skein == 1.0.3
+                 , skein == 1.0.9
-                 , socks == 0.5.1
+                 , socks == 0.5.4
-                 , stringsearch == 0.3.6.4
+                 , stm-chans == 3.0.0.2
-                 , system-fileio == 0.3.11
+                 , streaming-commons == 0.1.3
-                 , system-filepath == 0.4.7
+                 , stringsearch == 0.3.6.5
-                 , tagged == 0.6.1
+                 , system-fileio == 0.3.14
-                 , tagsoup == 0.12.8
+                 , system-filepath == 0.4.12
-                 , tagstream-conduit == 0.5.4
+                 , tagged == 0.7.2
-                 , tls == 1.1.2
+                 , tagsoup == 0.13.1
-                 , tls-extra == 0.6.4
+                 , tagstream-conduit == 0.5.5.1
-                 , transformers-base == 0.4.1
+                 , tf-random == 0.5
+                 , tls == 1.2.8
+                 , transformers-base == 0.4.2
+                 -- , transformers-compat == 0.3.3.4
                  , unix-compat == 0.4.1.1
-                 , unordered-containers == 0.2.3.1
+                 , unordered-containers == 0.2.4.0
-                 , utf8-light == 0.4.0.1
+                 , utf8-string == 0.3.8
-                 , utf8-string == 0.3.7
+                 , vector == 0.10.11.0
-                 , vault == 0.2.0.4
-                 , vector == 0.10.0.1
                  , void == 0.6.1
-                 , wai == 1.4.0.1
+                 , wai == 3.0.0
-                 , wai-app-static == 1.3.1.3
+                 , wai-app-static == 3.0.0
-                 , wai-extra == 1.3.4.2
+                 , wai-extra == 3.0.0
-                 , wai-logger == 0.3.1
+                 , wai-logger == 2.1.1
-                 , wai-test == 1.3.1.1
+                 , wai-test == 3.0.0
-                 , warp == 1.3.9
+                 , warp == 3.0.0.2
-                 , word8 == 0.0.3
+                 , warp-tls == 3.0.0
-                 , xml-conduit == 1.1.0.5
+                 , word8 == 0.0.4
+                 , x509 == 1.4.11
+                 , x509-store == 1.4.4
+                 , x509-system == 1.4.5
+                 , x509-validation == 1.5.0
+                 , xml-conduit == 1.2.0.2
                  , xml-types == 0.3.4
-                 , xss-sanitize == 0.3.4
+                 , xss-sanitize == 0.3.5.2
-                 , yaml == 0.8.4
+                 , yaml == 0.8.8.3
-                 , yesod == 1.2.1.1
+                 , yesod == 1.2.6
-                 , yesod-auth == 1.2.0.2
+                 , yesod-auth == 1.3.1
-                 , yesod-core == 1.2.3
+                 , yesod-auth-hashdb == 1.3.0.1
-                 , yesod-form == 1.3.0.1
+                 , yesod-core == 1.2.16
-                 , yesod-persistent == 1.2.1
+                 , yesod-form == 1.3.10
-                 , yesod-routes == 1.2.0.1
+                 , yesod-persistent == 1.2.3
-                 , yesod-static == 1.2.0
+                 , yesod-routes == 1.2.0.6
-                 , yesod-test == 1.2.0
+                 , yesod-static == 1.2.4
-                 , zlib-bindings == 0.1.1.3
+                 , yesod-test == 1.2.3
-                 , zlib-conduit == 1.0.0
 
     exposed-modules: Yesod.Platform
 

yesod-routes/Yesod/Routes/Overlap.hs

@@ -8,15 +8,42 @@ module Yesod.Routes.Overlap
 import Yesod.Routes.TH.Types
 import Data.List (intercalate)
 
+data Flattened t = Flattened
+    { fNames :: [String]
+    , fPieces :: [(CheckOverlap, Piece t)]
+    , fHasSuffix :: Bool
+    }
+
+flatten :: ResourceTree t -> [Flattened t]
+flatten =
+    go id id
+  where
+    go names pieces (ResourceLeaf r) = return Flattened
+        { fNames = names [resourceName r]
+        , fPieces = pieces (resourcePieces r)
+        , fHasSuffix = hasSuffix $ ResourceLeaf r
+        }
+    go names pieces (ResourceParent newname newpieces children) =
+        concatMap (go names' pieces') children
+      where
+        names' = names . (newname:)
+        pieces' = pieces . (newpieces ++)
+
 data Overlap t = Overlap
     { overlapParents :: [String] -> [String] -- ^ parent resource trees
     , overlap1 :: ResourceTree t
     , overlap2 :: ResourceTree t
     }
 
+data OverlapF = OverlapF
+    { overlapF1 :: [String]
+    , overlapF2 :: [String]
+    }
+
 findOverlaps :: ([String] -> [String]) -> [ResourceTree t] -> [Overlap t]
 findOverlaps _ [] = []
 findOverlaps front (x:xs) = concatMap (findOverlap front x) xs ++ findOverlaps front xs
+{-# DEPRECATED findOverlaps "This function is no longer used" #-}
 
 findOverlap :: ([String] -> [String]) -> ResourceTree t -> ResourceTree t -> [Overlap t]
 findOverlap front x y =
@@ -30,14 +57,6 @@ findOverlap front x y =
             ResourceParent name _ children -> findOverlaps (front . (name:)) children
             ResourceLeaf{} -> []
 
-hasSuffix :: ResourceTree t -> Bool
-hasSuffix (ResourceLeaf r) =
-    case resourceDispatch r of
-        Subsite{} -> True
-        Methods Just{} _ -> True
-        Methods Nothing _ -> False
-hasSuffix ResourceParent{} = True
-
 overlaps :: [(CheckOverlap, Piece t)] -> [(CheckOverlap, Piece t)] -> Bool -> Bool -> Bool
 
 -- No pieces on either side, will overlap regardless of suffix
@@ -66,9 +85,26 @@ piecesOverlap _ _ = True
 
 findOverlapNames :: [ResourceTree t] -> [(String, String)]
 findOverlapNames =
-    map go . findOverlaps id
+    map go . findOverlapsF . concatMap Yesod.Routes.Overlap.flatten
   where
-    go (Overlap front x y) =
+    go (OverlapF x y) =
-        (go' $ resourceTreeName x, go' $ resourceTreeName y)
+        (go' x, go' y)
       where
-        go' = intercalate "/" . front . return
+        go' = intercalate "/"
+
+findOverlapsF :: [Flattened t] -> [OverlapF]
+findOverlapsF [] = []
+findOverlapsF (x:xs) = concatMap (findOverlapF x) xs ++ findOverlapsF xs
+
+findOverlapF :: Flattened t -> Flattened t -> [OverlapF]
+findOverlapF x y
+    | overlaps (fPieces x) (fPieces y) (fHasSuffix x) (fHasSuffix y) = [OverlapF (fNames x) (fNames y)]
+    | otherwise = []
+
+hasSuffix :: ResourceTree t -> Bool
+hasSuffix (ResourceLeaf r) =
+    case resourceDispatch r of
+        Subsite{} -> True
+        Methods Just{} _ -> True
+        Methods Nothing _ -> False
+hasSuffix ResourceParent{} = True

yesod-routes/Yesod/Routes/Parse.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE PatternGuards #-}
 {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
 module Yesod.Routes.Parse
     ( parseRoutes
@@ -18,6 +19,8 @@ import qualified System.IO as SIO
 import Yesod.Routes.TH
 import Yesod.Routes.Overlap (findOverlapNames)
 import Data.List (foldl')
+import Data.Maybe (mapMaybe)
+import qualified Data.Set as Set
 
 -- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for
 -- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the
@@ -29,7 +32,7 @@ parseRoutes = QuasiQuoter { quoteExp = x }
         let res = resourcesFromString s
         case findOverlapNames res of
             [] -> lift res
-            z -> error $ "Overlapping routes: " ++ unlines (map show z)
+            z -> error $ unlines $ "Overlapping routes: " : map show z
 
 parseRoutesFile :: FilePath -> Q Exp
 parseRoutesFile = parseRoutesFileWith parseRoutes
@@ -60,21 +63,37 @@ parseRoutesNoCheck = QuasiQuoter
 -- invalid input.
 resourcesFromString :: String -> [ResourceTree String]
 resourcesFromString =
-    fst . parse 0 . lines
+    fst . parse 0 . filter (not . all (== ' ')) . lines
   where
     parse _ [] = ([], [])
     parse indent (thisLine:otherLines)
         | length spaces < indent = ([], thisLine : otherLines)
         | otherwise = (this others, remainder)
       where
+        parseAttr ('!':x) = Just x
+        parseAttr _ = Nothing
+
+        stripColonLast =
+            go id
+          where
+            go _ [] = Nothing
+            go front [x]
+                | null x = Nothing
+                | last x == ':' = Just $ front [init x]
+                | otherwise = Nothing
+            go front (x:xs) = go (front . (x:)) xs
+
         spaces = takeWhile (== ' ') thisLine
         (others, remainder) = parse indent otherLines'
         (this, otherLines') =
             case takeWhile (/= "--") $ words thisLine of
-                [pattern, constr] | last constr == ':' ->
+                (pattern:rest0)
+                    | Just (constr:rest) <- stripColonLast rest0
+                    , Just attrs <- mapM parseAttr rest ->
                     let (children, otherLines'') = parse (length spaces + 1) otherLines
+                        children' = addAttrs attrs children
                         (pieces, Nothing) = piecesFromString $ drop1Slash pattern
-                     in ((ResourceParent (init constr) pieces children :), otherLines'')
+                     in ((ResourceParent constr pieces children' :), otherLines'')
                 (pattern:constr:rest) ->
                     let (pieces, mmulti) = piecesFromString $ drop1Slash pattern
                         (attrs, rest') = takeAttrs rest
@@ -83,6 +102,29 @@ resourcesFromString =
                 [] -> (id, otherLines)
                 _ -> error $ "Invalid resource line: " ++ thisLine
 
+addAttrs :: [String] -> [ResourceTree String] -> [ResourceTree String]
+addAttrs attrs =
+    map goTree
+  where
+    goTree (ResourceLeaf res) = ResourceLeaf (goRes res)
+    goTree (ResourceParent x y z) = ResourceParent x y (map goTree z)
+
+    goRes res =
+        res { resourceAttrs = noDupes ++ resourceAttrs res }
+      where
+        usedKeys = Set.fromList $ map fst $ mapMaybe toPair $ resourceAttrs res
+        used attr =
+            case toPair attr of
+                Nothing -> False
+                Just (key, _) -> key `Set.member` usedKeys
+        noDupes = filter (not . used) attrs
+
+    toPair s =
+        case break (== '=') s of
+            (x, '=':y) -> Just (x, y)
+            _ -> Nothing
+
+
 -- | Take attributes out of the list and put them in the first slot in the
 -- result tuple.
 takeAttrs :: [String] -> ([String], [String])
@@ -184,6 +226,7 @@ ttToType (TTList t) = ListT `AppT` ttToType t
 
 pieceFromString :: String -> Either String (CheckOverlap, Piece String)
 pieceFromString ('#':'!':x) = Right $ (False, Dynamic x)
+pieceFromString ('!':'#':x) = Right $ (False, Dynamic x) -- https://github.com/yesodweb/yesod/issues/652
 pieceFromString ('#':x) = Right $ (True, Dynamic x)
 pieceFromString ('*':x) = Left x
 pieceFromString ('+':x) = Left x

yesod-routes/test/Hierarchy.hs

@@ -10,7 +10,7 @@ module Hierarchy
     ( hierarchy
     , Dispatcher (..)
     , runHandler
-    , Handler
+    , Handler2
     , App
     , toText
     , Env (..)
@@ -24,9 +24,10 @@ import Yesod.Routes.TH
 import Yesod.Routes.Class
 import Language.Haskell.TH.Syntax
 import qualified Yesod.Routes.Class as YRC
-import Data.Text (Text, pack, append)
+import Data.Text (Text, pack, unpack, append)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as S8
+import qualified Data.Set as Set
 
 class ToText a where
     toText :: a -> Text
@@ -34,7 +35,9 @@ class ToText a where
 instance ToText Text where toText = id
 instance ToText String where toText = pack
 
-type Handler sub master a = a
+type Handler2 sub master a = a
+type Handler site a = Handler2 site site a
+
 type Request = ([Text], ByteString) -- path info, method
 type App sub master = Request -> (Text, Maybe (YRC.Route master))
 data Env sub master = Env
@@ -45,7 +48,7 @@ data Env sub master = Env
 
 subDispatch
     :: (Env sub master -> App sub master)
-    -> (Handler sub master Text -> Env sub master -> Maybe (YRC.Route sub) -> App sub master)
+    -> (Handler2 sub master Text -> Env sub master -> Maybe (YRC.Route sub) -> App sub master)
     -> (master -> sub)
     -> (YRC.Route sub -> YRC.Route master)
     -> Env master master
@@ -63,24 +66,49 @@ class Dispatcher sub master where
 
 runHandler
     :: ToText a
-    => Handler sub master a
+    => Handler2 sub master a
     -> Env sub master
     -> Maybe (Route sub)
     -> App sub master
 runHandler h Env {..} route _ = (toText h, fmap envToMaster route)
 
-
 data Hierarchy = Hierarchy
 
 do
     let resources = [parseRoutes|
 / HomeR GET
+
+/!#Int BackwardsR GET
+
 /admin/#Int AdminR:
-    / AdminRootR GET
+    /            AdminRootR GET
-    /login LoginR GET POST
+    /login       LoginR     GET POST
-    /table/#Text TableR GET
+    /table/#Text TableR     GET
+
+/nest/ NestR !NestingAttr:
+
+  /spaces      SpacedR   GET !NonNested
+
+  /nest2 Nest2:
+    /           GetPostR  GET POST
+    /get        Get2      GET
+    /post       Post2         POST
+--    /#Int       Delete2            DELETE
+  /nest3 Nest3:
+    /get        Get3      GET
+    /post       Post3         POST
+--    /#Int       Delete3            DELETE
+
+/afterwards AfterR !parent !key=value1:
+  /             After     GET !child !key=value2
+
+-- /trailing-nest TrailingNestR:
+--  /foo TrailingFooR GET
+--  /#Int TrailingIntR GET
 |]
+
     rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
+    rainst <- mkRouteAttrsInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
     prinst <- mkParseRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
     dispatch <- mkDispatchClause MkDispatchSettings
         { mdsRunHandler = [|runHandler|]
@@ -100,25 +128,50 @@ do
                 `AppT` ConT ''Hierarchy)
             [FunD (mkName "dispatcher") [dispatch]]
         : prinst
+        : rainst
         : rrinst
 
-getHomeR :: Handler sub master String
+getSpacedR :: Handler site String
+getSpacedR = "root-leaf"
+
+getGet2   :: Handler site String; getGet2 = "get"
+postPost2 :: Handler site String; postPost2 = "post"
+deleteDelete2 :: Int -> Handler site String; deleteDelete2 = const "delete"
+getGet3   :: Handler site String; getGet3 = "get"
+postPost3 :: Handler site String; postPost3 = "post"
+deleteDelete3   :: Int -> Handler site String; deleteDelete3 = const "delete"
+
+getAfter   :: Handler site String; getAfter = "after"
+
+getHomeR :: Handler site String
 getHomeR = "home"
 
-getAdminRootR :: Int -> Handler sub master Text
+getBackwardsR :: Int -> Handler site Text
+getBackwardsR _ = pack "backwards"
+
+getAdminRootR :: Int -> Handler site Text
 getAdminRootR i = pack $ "admin root: " ++ show i
 
-getLoginR :: Int -> Handler sub master Text
+getLoginR :: Int -> Handler site Text
 getLoginR i = pack $ "login: " ++ show i
 
-postLoginR :: Int -> Handler sub master Text
+postLoginR :: Int -> Handler site Text
 postLoginR i = pack $ "post login: " ++ show i
 
-getTableR :: Int -> Text -> Handler sub master Text
+getTableR :: Int -> Text -> Handler site Text
-getTableR _ t = append "TableR " t
+getTableR _ = append "TableR "
+
+getGetPostR :: Handler site Text
+getGetPostR = pack "get"
+
+postGetPostR :: Handler site Text
+postGetPostR = pack "post"
+
 
 hierarchy :: Spec
 hierarchy = describe "hierarchy" $ do
+    it "nested with spacing" $
+        renderRoute (NestR SpacedR) @?= (["nest", "spaces"], [])
     it "renders root correctly" $
         renderRoute (AdminR 5 AdminRootR) @?= (["admin", "5"], [])
     it "renders table correctly" $
@@ -130,6 +183,18 @@ hierarchy = describe "hierarchy" $ do
                 , envSub = Hierarchy
                 })
             (map pack ps, S8.pack m)
+
+    let testGetPost route getRes postRes = do
+          let routeStrs = map unpack $ fst (renderRoute route)
+          disp "GET" routeStrs @?= (getRes, Just route)
+          disp "POST" routeStrs @?= (postRes, Just route)
+
+    it "dispatches routes with multiple METHODs: admin" $
+        testGetPost (AdminR 1 LoginR) "login: 1" "post login: 1"
+
+    it "dispatches routes with multiple METHODs: nesting" $
+        testGetPost (NestR $ Nest2 GetPostR) "get" "post"
+
     it "dispatches root correctly" $ disp "GET" ["admin", "7"] @?= ("admin root: 7", Just $ AdminR 7 AdminRootR)
     it "dispatches table correctly" $ disp "GET" ["admin", "8", "table", "bar"] @?= ("TableR bar", Just $ AdminR 8 $ TableR "bar")
     it "parses" $ do
@@ -137,3 +202,7 @@ hierarchy = describe "hierarchy" $ do
         parseRoute ([], [("foo", "bar")]) @?= Just HomeR
         parseRoute (["admin", "5"], []) @?= Just (AdminR 5 AdminRootR)
         parseRoute (["admin!", "5"], []) @?= (Nothing :: Maybe (Route Hierarchy))
+    it "inherited attributes" $ do
+        routeAttrs (NestR SpacedR) @?= Set.fromList ["NestingAttr", "NonNested"]
+    it "pair attributes" $
+        routeAttrs (AfterR After) @?= Set.fromList ["parent", "child", "key=value2"]

yesod-routes/yesod-routes.cabal

@@ -1,5 +1,5 @@
 name:            yesod-routes
-version:         1.2.0.1
+version:         1.2.0.7
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -16,7 +16,7 @@ extra-source-files:
 
 library
     build-depends:   base                      >= 4        && < 5
-                   , text                      >= 0.5      && < 0.12
+                   , text                      >= 0.5
                    , vector                    >= 0.8      && < 0.11
                    , containers                >= 0.2
                    , template-haskell
@@ -42,7 +42,7 @@ test-suite runtests
 
     build-depends: base                      >= 4.3      && < 5
                  , yesod-routes
-                 , text                      >= 0.5      && < 0.12
+                 , text                      >= 0.5
                  , HUnit                     >= 1.2      && < 1.3
                  , hspec                     >= 1.3
                  , containers

yesod-static/Yesod/EmbeddedStatic.hs

@@ -0,0 +1,188 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-- | A subsite which serves static content which is embedded at compile time.
+--
+-- At compile time, you supply a list of files, directories, processing functions (like javascript
+-- minification), and even custom content generators.  You can also specify the specific relative
+-- locations within the static subsite where these resources should appear.  The 'mkEmbeddedStatic'
+-- function then computes the resources and embeds them directly into the executable at
+-- compile time, so that the original files do not need to be distributed along with
+-- the executable.  The content is also compressed and hashed at compile time, so that
+-- during runtime the compressed content can be sent directly on the wire with the appropriate
+-- HTTP header.  The precomputed hash is used for an ETag so the client does not redownload
+-- the content multiple times.  There is also a development mode which does not embed the
+-- contents but recomputes it on every request. A simple example using an embedded static
+-- subsite is
+-- <https://github.com/yesodweb/yesod/blob/master/yesod-static/sample-embed.hs static-embed.hs>.
+--
+-- To add this to a scaffolded project, replace the code in @Settings/StaticFiles.hs@
+-- with a call to 'mkEmbeddedStatic' with the list of all your generators, use the type
+-- 'EmbeddedStatic' in your site datatype for @getStatic@, update the route for @/static@ to
+-- use the type 'EmbeddedStatic', use 'embedStaticContent' for 'addStaticContent' in
+-- @Foundation.hs@, use the routes generated by 'mkEmbeddedStatic' and exported by
+-- @Settings/StaticFiles.hs@ to link to your static content, and finally update
+-- @Application.hs@ use the variable binding created by 'mkEmbeddedStatic' which
+-- contains the created 'EmbeddedStatic'.
+--
+-- It is recommended that you serve static resources from a separate domain to save time
+-- on transmitting cookies.  You can use 'urlRenderOverride' to do so, by redirecting
+-- routes to this subsite to a different domain (but the same path) and then pointing the
+-- alternative domain to this server.  In addition, you might consider using a reverse
+-- proxy like varnish or squid to cache the static content, but the embedded content in
+-- this subsite is cached and served directly from memory so is already quite fast.
+module Yesod.EmbeddedStatic (
+  -- * Subsite
+    EmbeddedStatic
+  , embeddedResourceR
+  , mkEmbeddedStatic
+  , embedStaticContent
+
+  -- * Generators
+  , module Yesod.EmbeddedStatic.Generators
+) where
+
+import Control.Applicative ((<$>))
+import Data.IORef
+import Data.Maybe (catMaybes)
+import Language.Haskell.TH
+import Network.HTTP.Types.Status (status404)
+import Network.Wai (responseLBS, pathInfo)
+import Network.Wai.Application.Static (staticApp)
+import System.IO.Unsafe (unsafePerformIO)
+import Yesod.Core
+          ( HandlerT
+          , Yesod(..)
+          , YesodSubDispatch(..)
+          )
+import Yesod.Core.Types
+          ( YesodSubRunnerEnv(..)
+          , YesodRunnerEnv(..)
+          )
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as T
+import qualified Data.HashMap.Strict as M
+import qualified WaiAppStatic.Storage.Embedded as Static
+
+import Yesod.EmbeddedStatic.Types
+import Yesod.EmbeddedStatic.Internal
+import Yesod.EmbeddedStatic.Generators
+
+-- Haddock doesn't support associated types in instances yet so we can't
+-- export EmbeddedResourceR directly.
+
+-- | Construct a route to an embedded resource.
+embeddedResourceR :: [T.Text] -> [(T.Text, T.Text)] -> Route EmbeddedStatic
+embeddedResourceR = EmbeddedResourceR
+
+instance Yesod master => YesodSubDispatch EmbeddedStatic (HandlerT master IO) where
+    yesodSubDispatch YesodSubRunnerEnv {..} req = resp
+        where
+            master = yreSite ysreParentEnv
+            site = ysreGetSub master
+            resp = case pathInfo req of
+                            ("res":_) -> stApp site req
+                            ("widget":_) -> staticApp (widgetSettings site) req
+#if MIN_VERSION_wai(3,0,0)
+                            _ -> ($ responseLBS status404 [] "Not Found")
+#else
+                            _ -> return $ responseLBS status404 [] "Not Found"
+#endif
+
+-- | Create the haskell variable for the link to the entry
+mkRoute :: ComputedEntry -> Q [Dec]
+mkRoute (ComputedEntry { cHaskellName = Nothing }) = return []
+mkRoute (c@ComputedEntry { cHaskellName = Just name }) = do
+    routeType <- [t| Route EmbeddedStatic |]
+    link <- [| $(cLink c) |]
+    return [ SigD name routeType
+           , ValD (VarP name) (NormalB link) []
+           ]
+
+-- | Creates an 'EmbeddedStatic' by running, at compile time, a list of generators. 
+-- Each generator produces a list of entries to embed into the executable.
+--
+-- This template haskell splice creates a variable binding holding the resulting
+-- 'EmbeddedStatic' and in addition creates variable bindings for all the routes
+-- produced by the generators.  For example, if a directory called static has
+-- the following contents:
+--
+-- * js/jquery.js
+--
+-- * css/bootstrap.css
+--
+-- * img/logo.png
+--
+-- then a call to
+--
+-- > #ifdef DEVELOPMENT
+-- > #define DEV_BOOL True
+-- > #else
+-- > #define DEV_BOOL False
+-- > #endif
+-- > mkEmbeddedStatic DEV_BOOL "myStatic" [embedDir "static"]
+--
+-- will produce variables
+--
+-- > myStatic :: EmbeddedStatic
+-- > js_jquery_js :: Route EmbeddedStatic
+-- > css_bootstrap_css :: Route EmbeddedStatic
+-- > img_logo_png :: Route EmbeddedStatic
+mkEmbeddedStatic :: Bool -- ^ development?
+                 -> String -- ^ variable name for the created 'EmbeddedStatic'
+                 -> [Generator] -- ^ the generators (see "Yesod.EmbeddedStatic.Generators")
+                 -> Q [Dec]
+mkEmbeddedStatic dev esName gen = do
+    entries <- concat <$> sequence gen
+    computed <- runIO $ mapM (if dev then devEmbed else prodEmbed) entries
+
+    let settings = Static.mkSettings $ return $ map cStEntry computed
+        devExtra = listE $ catMaybes $ map ebDevelExtraFiles entries
+        ioRef  = [| unsafePerformIO $ newIORef M.empty |]
+
+    -- build the embedded static
+    esType <- [t| EmbeddedStatic |]
+    esCreate <- if dev
+                  then [| EmbeddedStatic (develApp $settings $devExtra) $ioRef |]
+                  else [| EmbeddedStatic (staticApp $! $settings) $ioRef |]
+    let es = [ SigD (mkName esName) esType
+             , ValD (VarP $ mkName esName) (NormalB esCreate) []
+             ]
+
+    routes <- mapM mkRoute computed
+
+    return $ es ++ concat routes
+
+-- | Use this for 'addStaticContent' to have the widget static content be served by
+--   the embedded static subsite.  For example,
+--
+-- > import Yesod
+-- > import Yesod.EmbeddedStatic
+-- > import Text.Jasmine (minifym)
+-- >
+-- > data MySite = { ..., getStatic :: EmbeddedStatic, ... }
+-- >
+-- > mkYesod "MySite" [parseRoutes|
+-- > ...
+-- > /static StaticR EmbeddedStatic getStatic
+-- > ...
+-- > |]
+-- >
+-- > instance Yesod MySite where
+-- >     ...
+-- >     addStaticContent = embedStaticContent getStatic StaticR mini
+-- >         where mini = if development then Right else minifym
+-- >     ...
+embedStaticContent :: Yesod site
+                   => (site -> EmbeddedStatic)   -- ^ How to retrieve the embedded static subsite from your site
+                   -> (Route EmbeddedStatic -> Route site) -- ^ how to convert an embedded static route
+                   -> (BL.ByteString -> Either a BL.ByteString) -- ^ javascript minifier
+                   -> AddStaticContent site
+embedStaticContent = staticContentHelper

yesod-static/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs

@@ -0,0 +1,80 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- | Manipulate CSS urls.
+--
+-- * Make relative urls absolute (useful when combining assets)
+module Yesod.EmbeddedStatic.Css.AbsoluteUrl (
+  -- * Absolute urls
+    absoluteUrls
+  , absoluteUrlsAt
+  , absoluteUrlsWith
+  , absCssUrlsFileProd
+  , absCssUrlsProd
+) where
+
+import Prelude hiding (FilePath)
+import Yesod.EmbeddedStatic.Generators
+import Yesod.EmbeddedStatic.Types
+
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.IO as T
+import qualified Data.Text.Lazy.Encoding as TL
+import Control.Monad ((>=>))
+import Data.Maybe (fromMaybe)
+import Filesystem.Path.CurrentOS ((</>), collapse, FilePath, fromText, toText, encodeString, decodeString)
+
+import Yesod.EmbeddedStatic.Css.Util
+
+-------------------------------------------------------------------------------
+-- Generator
+-------------------------------------------------------------------------------
+
+-- | Anchors relative CSS image urls
+absCssUrlsFileProd :: FilePath -- ^ Anchor relative urls to here
+                     -> FilePath
+                     -> IO BL.ByteString
+absCssUrlsFileProd dir file = do
+    contents <- T.readFile (encodeString file)
+    return $ TL.encodeUtf8 $ absCssUrlsProd dir contents
+
+absCssUrlsProd :: FilePath -- ^ Anchor relative urls to here
+               -> T.Text
+               -> TL.Text
+absCssUrlsProd dir contents =
+    let css = either error id $ parseCssUrls contents
+    in  renderCssWith toAbsoluteUrl css
+  where
+    toAbsoluteUrl (UrlReference rel) = T.concat
+        [ "url('/"
+        , (either id id $ toText $ collapse $ dir </> fromText rel)
+        , "')"
+        ]
+
+
+-- | Equivalent to passing the same string twice to 'absoluteUrlsAt'.
+absoluteUrls :: FilePath -> Generator
+absoluteUrls f = absoluteUrlsAt (encodeString f) f
+
+-- | Equivalent to passing @return@ to 'absoluteUrlsWith'.
+absoluteUrlsAt :: Location -> FilePath -> Generator
+absoluteUrlsAt loc f = absoluteUrlsWith loc f Nothing
+
+-- | Automatically make relative urls absolute
+--
+-- During development, leave CSS as is.
+--
+-- When CSS is organized into a directory structure, it will work properly for individual requests for each file.
+-- During production, we want to combine and minify CSS as much as possible.
+-- The combination process combines files from different directories, messing up relative urls.
+-- This pre-processor makes relative urls absolute
+absoluteUrlsWith ::
+    Location -- ^ The location the CSS file should appear in the static subsite
+  -> FilePath -- ^ Path to the CSS file.
+  -> Maybe (CssGeneration -> IO BL.ByteString) -- ^ Another filter function run after this one (for example @return . yuiCSS . cssContent@) or other CSS filter that runs after this filter.
+                     -> Generator
+absoluteUrlsWith loc file mpostFilter =
+    return [ cssProductionFilter (absCssUrlsFileProd (decodeString loc) >=> postFilter . mkCssGeneration loc file) loc file
+    ]
+  where
+    postFilter = fromMaybe (return . cssContent) mpostFilter

yesod-static/Yesod/EmbeddedStatic/Css/Util.hs

@@ -0,0 +1,196 @@
+{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TupleSections, GeneralizedNewtypeDeriving #-}
+module Yesod.EmbeddedStatic.Css.Util where
+
+import Prelude hiding (FilePath)
+import Control.Applicative
+import Control.Monad (void, foldM)
+import Data.Hashable (Hashable)
+import Data.Monoid
+import Network.Mime (MimeType, defaultMimeLookup)
+import Filesystem.Path.CurrentOS (FilePath, directory, (</>), dropExtension, filename, toText, decodeString, encodeString, fromText, absolute)
+import Text.CSS.Parse (parseBlocks)
+import Language.Haskell.TH (litE, stringL)
+import Text.CSS.Render (renderBlocks)
+import Yesod.EmbeddedStatic.Types
+import Yesod.EmbeddedStatic (pathToName)
+import Data.Default (def)
+
+import qualified Blaze.ByteString.Builder as B
+import qualified Blaze.ByteString.Builder.Char.Utf8 as B
+import qualified Data.Attoparsec.Text as P
+import qualified Data.Attoparsec.ByteString.Lazy as PBL
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.HashMap.Lazy as M
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.IO as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Builder as TL
+
+-------------------------------------------------------------------------------
+-- Loading CSS
+-------------------------------------------------------------------------------
+
+-- | In the parsed CSS, this will be an image reference that we want to replace.
+-- the contents will be the filepath.
+newtype UrlReference = UrlReference T.Text
+    deriving (Show, Eq, Hashable, Ord)
+
+type EithUrl = (T.Text, Either T.Text UrlReference)
+
+-- | The parsed CSS
+type Css = [(T.Text, [EithUrl])]
+
+-- | Parse the filename out of url('filename')
+parseUrl :: P.Parser T.Text
+parseUrl = do
+    P.skipSpace
+    void $ P.string "url('"
+    P.takeTill (== '\'')
+
+checkForUrl :: T.Text -> T.Text -> EithUrl
+checkForUrl n@("background-image") v = parseBackgroundImage n v
+checkForUrl n@("src") v = parseBackgroundImage n v
+checkForUrl n v = (n, Left v)
+
+-- | Check if a given CSS attribute is a background image referencing a local file
+checkForImage :: T.Text -> T.Text -> EithUrl
+checkForImage n@("background-image") v = parseBackgroundImage n v
+checkForImage n v = (n, Left v)
+
+parseBackgroundImage :: T.Text -> T.Text -> EithUrl
+parseBackgroundImage n v = (n, case P.parseOnly parseUrl v of
+    Left _ -> Left v -- Can't parse url
+    Right url -> -- maybe we should find a uri parser
+        if any (`T.isPrefixOf` url) ["http://", "https://", "//"] || absolute (fromText url)
+            then Left v
+            else Right $ UrlReference url)
+
+parseCssWith :: (T.Text -> T.Text -> EithUrl) -> T.Text -> Either String Css
+parseCssWith urlParser contents =
+    let mparsed = parseBlocks contents in
+    case mparsed of
+        Left err -> Left err
+        Right blocks -> Right [ (t, map (uncurry urlParser) b) | (t,b) <- blocks ]
+
+parseCssUrls :: T.Text -> Either String Css
+parseCssUrls = parseCssWith checkForUrl
+
+parseCssFileWith :: (T.Text -> T.Text -> EithUrl) -> FilePath -> IO Css
+parseCssFileWith urlParser fp = do
+    mparsed <- parseCssWith urlParser <$> T.readFile (encodeString fp)
+    case mparsed of
+        Left err -> fail $ "Unable to parse " ++ encodeString fp ++ ": " ++ err
+        Right css -> return css
+
+parseCssFileUrls :: FilePath -> IO Css
+parseCssFileUrls = parseCssFileWith checkForUrl
+
+renderCssWith :: (UrlReference -> T.Text) -> Css -> TL.Text
+renderCssWith urlRenderer css =
+    TL.toLazyText $ renderBlocks [(n, map render block) | (n,block) <- css]
+  where
+    render (n, Left b) = (n, b)
+    render (n, Right f) = (n, urlRenderer f)
+
+-- | Load an image map from the images in the CSS
+loadImages :: FilePath -> Css -> (FilePath -> IO (Maybe a)) -> IO (M.HashMap UrlReference a)
+loadImages dir css loadImage = foldM load M.empty $ concat [map snd block | (_,block) <- css]
+    where
+        load imap (Left _) = return imap
+        load imap (Right f) | f `M.member` imap = return imap
+        load imap (Right f@(UrlReference path)) = do
+            img <- loadImage (dir </> fromText path)
+            return $ maybe imap (\i -> M.insert f i imap) img
+
+
+-- | If you tack on additional CSS post-processing filters, they use this as an argument.
+data CssGeneration = CssGeneration {
+                       cssContent :: BL.ByteString
+                     , cssStaticLocation :: Location
+                     , cssFileLocation :: FilePath
+                     }
+
+mkCssGeneration :: Location -> FilePath -> BL.ByteString -> CssGeneration
+mkCssGeneration loc file content =
+    CssGeneration { cssContent = content
+                  , cssStaticLocation = loc
+                  , cssFileLocation = file
+                  }
+
+cssProductionFilter ::
+       (FilePath ->  IO BL.ByteString) -- ^ a filter to be run on production
+     -> Location -- ^ The location the CSS file should appear in the static subsite
+     -> FilePath -- ^ Path to the CSS file.
+     -> Entry
+cssProductionFilter prodFilter loc file =
+    def { ebHaskellName = Just $ pathToName loc
+        , ebLocation = loc
+        , ebMimeType = "text/css"
+        , ebProductionContent = prodFilter file
+        , ebDevelReload = [| develPassThrough $(litE (stringL loc)) $(litE (stringL $ encodeString file)) |]
+        , ebDevelExtraFiles = Nothing
+        }
+
+cssProductionImageFilter :: (FilePath -> IO BL.ByteString) -> Location -> FilePath -> Entry
+cssProductionImageFilter prodFilter loc file =
+  (cssProductionFilter prodFilter loc file)
+    { ebDevelReload = [| develBgImgB64 $(litE (stringL loc)) $(litE (stringL $ encodeString file)) |]
+    , ebDevelExtraFiles = Just [| develExtraFiles $(litE (stringL loc)) |]
+    }
+
+-------------------------------------------------------------------------------
+-- Helpers for the generators
+-------------------------------------------------------------------------------
+
+-- For development, all we need to do is update the background-image url to base64 encode it.
+-- We want to preserve the formatting (whitespace+newlines) during development so we do not parse
+-- using css-parse.  Instead we write a simple custom parser.
+
+parseBackground :: Location -> FilePath -> PBL.Parser B.Builder
+parseBackground loc file = do
+    void $ PBL.string "background-image"
+    s1 <- PBL.takeWhile (\x -> x == 32 || x == 9) -- space or tab
+    void $ PBL.word8 58 -- colon
+    s2 <- PBL.takeWhile (\x -> x == 32 || x == 9) -- space or tab
+    void $ PBL.string "url('"
+    url <- PBL.takeWhile (/= 39) -- single quote
+    void $ PBL.string "')"
+
+    let b64 = B64.encode $ T.encodeUtf8 (either id id $ toText (directory file)) <> url
+        newUrl = B.fromString (encodeString $ filename $ decodeString loc) <> B.fromString "/" <> B.fromByteString b64
+
+    return $ B.fromByteString "background-image"
+          <> B.fromByteString s1
+          <> B.fromByteString ":"
+          <> B.fromByteString s2
+          <> B.fromByteString "url('"
+          <> newUrl
+          <> B.fromByteString "')"
+
+parseDev :: Location -> FilePath -> B.Builder -> PBL.Parser B.Builder
+parseDev loc file b = do
+    b' <- parseBackground loc file <|> (B.fromWord8 <$> PBL.anyWord8)
+    (PBL.endOfInput *> (pure $! b <> b')) <|> (parseDev loc file $! b <> b')
+
+develPassThrough :: Location -> FilePath -> IO BL.ByteString
+develPassThrough _ = BL.readFile . encodeString
+
+-- | Create the CSS during development
+develBgImgB64 :: Location -> FilePath -> IO BL.ByteString
+develBgImgB64 loc file = do
+    ct <- BL.readFile $ encodeString file
+    case PBL.eitherResult $ PBL.parse (parseDev loc file mempty) ct of
+        Left err -> error err
+        Right b -> return $ B.toLazyByteString b
+
+-- | Serve the extra image files during development
+develExtraFiles :: Location -> [T.Text] -> IO (Maybe (MimeType, BL.ByteString))
+develExtraFiles loc parts =
+    case reverse parts of
+        (file:dir) | T.pack loc == T.intercalate "/" (reverse dir) -> do
+            let file' = T.decodeUtf8 $ B64.decodeLenient $ T.encodeUtf8 $ either id id $ toText $ dropExtension $ fromText file
+            ct <- BL.readFile $ T.unpack file'
+            return $ Just (defaultMimeLookup file', ct)
+        _ -> return Nothing

yesod-static/Yesod/EmbeddedStatic/Generators.hs

@@ -0,0 +1,329 @@
+{-# LANGUAGE TemplateHaskell, QuasiQuotes, ScopedTypeVariables #-}
+-- | A generator is executed at compile time to load a list of entries
+-- to embed into the subsite.  This module contains several basic generators,
+-- but the design of generators and entries is such that it is straightforward
+-- to make custom generators for your own specific purposes, see <#g:4 this section>.
+module Yesod.EmbeddedStatic.Generators (
+  -- * Generators
+    Location
+  , embedFile
+  , embedFileAt
+  , embedDir
+  , embedDirAt
+  , concatFiles
+  , concatFilesWith
+
+  -- * Compression options for 'concatFilesWith'
+  , jasmine
+  , uglifyJs
+  , yuiJavascript
+  , yuiCSS
+  , closureJs
+  , compressTool
+  , tryCompressTools
+
+  -- * Util
+  , pathToName
+  
+  -- * Custom Generators
+  
+  -- $example
+) where
+
+import Control.Applicative ((<$>), (<*>))
+import Control.Exception (try, SomeException)
+import Control.Monad (forM, when)
+import Control.Monad.Trans.Resource (runResourceT)
+import Data.Char (isDigit, isLower)
+import Data.Conduit (($$))
+import Data.Default (def)
+import Data.Maybe (isNothing)
+import Language.Haskell.TH
+import Network.Mime (defaultMimeLookup)
+import System.Directory (doesDirectoryExist, getDirectoryContents, findExecutable)
+import System.FilePath ((</>))
+import Text.Jasmine (minifym)
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Conduit.List as C
+import Data.Conduit.Binary (sourceHandle)
+import qualified Data.Text as T
+import qualified System.Process as Proc
+import System.Exit (ExitCode (ExitSuccess))
+import Control.Concurrent.Async (Concurrently (..))
+import System.IO (hClose)
+
+import Yesod.EmbeddedStatic.Types
+
+-- | Embed a single file.  Equivalent to passing the same string twice to 'embedFileAt'.
+embedFile :: FilePath -> Generator
+embedFile f = embedFileAt f f
+
+-- | Embed a single file at a given location within the static subsite and generate a
+--   route variable based on the location via 'pathToName'.  The @FilePath@ must be a relative
+--   path to the directory in which you run @cabal build@.  During development, the file located
+--   at this filepath will be reloaded on every request.  When compiling for production, the contents
+--   of the file will be embedded into the executable and so the file does not need to be
+--   distributed along with the executable.
+embedFileAt :: Location -> FilePath -> Generator
+embedFileAt loc f = do
+    let mime = defaultMimeLookup $ T.pack f
+    let entry = def {
+                    ebHaskellName = Just $ pathToName loc
+                  , ebLocation = loc
+                  , ebMimeType = mime
+                  , ebProductionContent = BL.readFile f
+                  , ebDevelReload = [| BL.readFile $(litE $ stringL f) |]
+                  }
+    return [entry]
+
+-- | List all files recursively in a directory
+getRecursiveContents :: Location -- ^ The directory to search
+                     -> FilePath   -- ^ The prefix to add to the filenames
+                     -> IO [(Location,FilePath)]
+getRecursiveContents prefix topdir = do
+  names <- getDirectoryContents topdir
+  let properNames = filter (`notElem` [".", ".."]) names
+  paths <- forM properNames $ \name -> do
+    let path = topdir </> name
+    let loc = if null prefix then name else prefix ++ "/" ++ name
+    isDirectory <- doesDirectoryExist path
+    if isDirectory
+      then getRecursiveContents loc path
+      else return [(loc, path)]
+  return (concat paths)
+
+-- | Embed all files in a directory into the static subsite.
+-- 
+-- Equivalent to passing the empty string as the location to 'embedDirAt',
+-- so the directory path itself is not part of the resource locations (and so
+-- also not part of the generated route variable names).
+embedDir :: FilePath -> Generator
+embedDir = embedDirAt ""
+
+-- | Embed all files in a directory to a given location within the static subsite.
+--
+-- The directory tree rooted at the 'FilePath' (which must be relative to the directory in
+-- which you run @cabal build@) is embedded into the static subsite at the given
+-- location.  Also, route variables will be created based on the final location
+-- of each file.  For example, if a directory \"static\" contains the files
+--
+-- * css/bootstrap.css
+--
+-- * js/jquery.js
+--
+-- * js/bootstrap.js
+-- 
+-- then @embedDirAt \"somefolder\" \"static\"@ will
+--
+-- * Make the file @static\/css\/bootstrap.css@ available at the location
+--   @somefolder\/css\/bootstrap.css@ within the static subsite and similarly
+--   for the other two files.
+--
+-- * Create variables @somefolder_css_bootstrap_css@, @somefolder_js_jquery_js@,
+--   @somefolder_js_bootstrap_js@ all of type @Route EmbeddedStatic@.
+--
+-- * During development, the files will be reloaded on every request.  During
+--   production, the contents of all files will be embedded into the executable.
+--
+-- * During development, files that are added to the directory while the server
+--   is running will not be detected.  You need to recompile the module which
+--   contains the call to @mkEmbeddedStatic@.  This will also generate new route
+--   variables for the new files.
+embedDirAt :: Location -> FilePath -> Generator
+embedDirAt loc dir = do
+    files <- runIO $ getRecursiveContents loc dir
+    concat <$> mapM (uncurry embedFileAt) files
+
+-- | Concatinate a list of files and embed it at the location.  Equivalent to passing @return@ to
+--   'concatFilesWith'.
+concatFiles :: Location -> [FilePath] -> Generator
+concatFiles loc files = concatFilesWith loc return files
+
+-- | Concatinate a list of files into a single 'BL.ByteString', run the resulting content through the given
+--   function, embed it at the given location, and create a haskell variable name for the route based on
+--   the location.
+--
+--   The processing function is only run when compiling for production, and the processing function is
+--   executed at compile time.  During development, on every request the files listed are reloaded,
+--   concatenated, and served as a single resource at the given location without being processed.
+concatFilesWith :: Location -> (BL.ByteString -> IO BL.ByteString) -> [FilePath] -> Generator
+concatFilesWith loc process files = do
+    let load = do putStrLn $ "Creating " ++ loc
+                  BL.concat <$> mapM BL.readFile files >>= process
+        expFiles = listE $ map (litE . stringL) files
+        expCt = [| BL.concat <$> mapM BL.readFile $expFiles |]
+        mime = defaultMimeLookup $ T.pack loc
+    return [def { ebHaskellName = Just $ pathToName loc
+                , ebLocation = loc
+                , ebMimeType = mime
+                , ebProductionContent = load
+                , ebDevelReload = expCt
+                }]
+
+-- | Convienient rexport of 'minifym' with a type signature to work with 'concatFilesWith'.
+jasmine :: BL.ByteString -> IO BL.ByteString
+jasmine ct = return $ either (const ct) id $ minifym ct
+
+-- | Use <https://github.com/mishoo/UglifyJS2 UglifyJS2> to compress javascript.
+-- Assumes @uglifyjs@ is located in the path and uses options @[\"-m\", \"-c\"]@
+-- to both mangle and compress and the option \"-\" to cause uglifyjs to read from
+-- standard input.
+uglifyJs :: BL.ByteString -> IO BL.ByteString
+uglifyJs = compressTool "uglifyjs" ["-m", "-c", "-"]
+
+-- | Use <http://yui.github.io/yuicompressor/ YUI Compressor> to compress javascript.
+-- Assumes a script @yuicompressor@ is located in the path.  If not, you can still
+-- use something like
+--
+-- > compressTool "java" ["-jar", "/path/to/yuicompressor.jar", "--type", "js"]
+yuiJavascript :: BL.ByteString -> IO BL.ByteString
+yuiJavascript = compressTool "yuicompressor" ["--type", "js"]
+
+-- | Use <http://yui.github.io/yuicompressor/ YUI Compressor> to compress CSS.
+-- Assumes a script @yuicompressor@ is located in the path.
+yuiCSS :: BL.ByteString -> IO BL.ByteString
+yuiCSS = compressTool "yuicompressor" ["--type", "css"]
+
+-- | Use <https://developers.google.com/closure/compiler/ Closure> to compress
+-- javascript using the default options.  Assumes a script @closure@ is located in
+-- the path. If not, you can still run using
+--
+-- > compressTool "java" ["-jar", "/path/to/compiler.jar"]
+closureJs :: BL.ByteString -> IO BL.ByteString
+closureJs = compressTool "closure" []
+
+-- | Helper to convert a process into a compression function.  The process
+-- should be set up to take input from standard input and write to standard output.
+compressTool :: FilePath -- ^ program
+             -> [String] -- ^ options
+             -> BL.ByteString -> IO BL.ByteString
+compressTool f opts ct = do
+    mpath <- findExecutable f
+    when (isNothing mpath) $
+        fail $ "Unable to find " ++ f
+    let p = (Proc.proc f opts)
+                { Proc.std_in = Proc.CreatePipe
+                , Proc.std_out = Proc.CreatePipe
+                }
+    (Just hin, Just hout, _, ph) <- Proc.createProcess p
+    (compressed, (), code) <- runConcurrently $ (,,)
+        <$> Concurrently (sourceHandle hout $$ C.consume)
+        <*> Concurrently (BL.hPut hin ct >> hClose hin)
+        <*> Concurrently (Proc.waitForProcess ph)
+    if code == ExitSuccess
+        then do
+            putStrLn $ "Compressed successfully with " ++ f
+            return $ BL.fromChunks compressed
+        else error $ "compressTool: compression failed with " ++ f
+
+
+-- | Try a list of processing functions (like the compressions above) one by one until
+-- one succeeds (does not raise an exception).  Once a processing function succeeds,
+-- none of the remaining functions are used.  If none succeeds, the input is just
+-- returned unprocessed.  This is helpful if you are distributing
+-- code on hackage and do not know what compressors the user will have installed.  You
+-- can list several and they will be tried in order until one succeeds.
+tryCompressTools :: [BL.ByteString -> IO BL.ByteString] -> BL.ByteString -> IO BL.ByteString
+tryCompressTools [] x = return x
+tryCompressTools (p:ps) x = do
+    mres <- try $ p x
+    case mres of
+        Left (err :: SomeException) -> do
+            putStrLn $ show err
+            tryCompressTools ps x
+        Right res -> return res
+
+-- | Clean up a path to make it a valid haskell name by replacing all non-letters
+--   and non-numbers by underscores.  In addition, if the path starts with a capital
+--   letter or number add an initial underscore.
+pathToName :: FilePath -> Name
+pathToName f = routeName
+    where
+      replace c
+        | 'A' <= c && c <= 'Z' = c
+        | 'a' <= c && c <= 'z' = c
+        | '0' <= c && c <= '9' = c
+        | otherwise = '_'
+      name = map replace f
+      routeName = mkName $
+            case () of
+                ()
+                    | null name -> error "null-named file"
+                    | isDigit (head name) -> '_' : name
+                    | isLower (head name) -> name
+                    | otherwise -> '_' : name
+
+
+-- $example
+-- Here is an example of creating your own custom generator.
+-- Because of template haskell stage restrictions, you must define generators in a
+-- different module from where you use them.  The following generator will embed a
+-- JSON document that contains the compile time.
+--
+-- >{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
+-- >module CompileTime where
+-- >
+-- >import Data.Aeson
+-- >import Data.Default
+-- >import Data.Time
+-- >import Yesod.EmbeddedStatic.Generators
+-- >import Yesod.EmbeddedStatic.Types
+-- >import qualified Data.ByteString.Lazy as BL
+-- >
+-- >getTime :: IO BL.ByteString
+-- >getTime = do
+-- >    t <- getCurrentTime
+-- >    return $ encode $
+-- >        object [ "compile_time" .= show t ]
+-- >
+-- >timeGenerator :: Location -> Generator
+-- >timeGenerator loc =
+-- >    return $ [def
+-- >        { ebHaskellName = Just $ pathToName loc
+-- >        , ebLocation    = loc
+-- >        , ebMimeType    = "application/json"
+-- >        , ebProductionContent = getTime
+-- >        , ebDevelReload = [| getTime |]
+-- >        }]
+--
+-- Notice how the @getTime@ action is given as both 'ebProductionContent' and
+-- 'ebDevelReload'.  The result is that during development, the @getTime@ action
+-- will be re-executed on every request so the time returned will be different
+-- for each reload.  When compiling for production, the @getTime@ action will
+-- be executed once at compile time to produce the content to embed and never
+-- called at runtime.
+--
+-- Here is a small example yesod program using this generator.  Try toggling
+-- the development argument to @mkEmbeddedStatic@.
+-- 
+-- >{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies #-}
+-- >module Main where
+-- >
+-- >import Yesod
+-- >import Yesod.EmbeddedStatic
+-- >import CompileTime (timeGenerator)
+-- >
+-- >mkEmbeddedStatic True "eStatic" [timeGenerator "compile-time.json"]
+-- >
+-- >-- The above will generate variables
+-- >-- eStatic :: EmbeddedStatic
+-- >-- compile_time_json :: Route EmbeddedStatic
+-- >
+-- >data MyApp = MyApp { getStatic :: EmbeddedStatic }
+-- >
+-- >mkYesod "MyApp" [parseRoutes|
+-- >/ HomeR GET
+-- >/static StaticR EmbeddedStatic getStatic
+-- >|]
+-- >
+-- >instance Yesod MyApp
+-- >
+-- >getHomeR :: Handler Html
+-- >getHomeR = defaultLayout $ [whamlet|
+-- ><h1>Hello
+-- ><p>Check the 
+-- >    <a href=@{StaticR compile_time_json}>compile time
+-- >|]
+-- >
+-- >main :: IO ()
+-- >main = warp 3000 $ MyApp eStatic

yesod-static/Yesod/EmbeddedStatic/Internal.hs

@@ -0,0 +1,187 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE CPP #-}
+module Yesod.EmbeddedStatic.Internal (
+      EmbeddedStatic(..)
+    , Route(..)
+    , ComputedEntry(..)
+    , devEmbed
+    , prodEmbed
+    , develApp
+    , AddStaticContent
+    , staticContentHelper
+    , widgetSettings
+) where
+
+import Control.Applicative ((<$>))
+import Data.IORef
+import Language.Haskell.TH
+import Network.HTTP.Types (Status(..), status404, status200, status304)
+import Network.Mime (MimeType)
+import Network.Wai
+import Network.Wai.Application.Static (defaultWebAppSettings, staticApp)
+import WaiAppStatic.Types
+import Yesod.Core
+          ( HandlerT
+          , ParseRoute(..)
+          , RenderRoute(..)
+          , Yesod(..)
+          , getYesod
+          , liftIO
+          )
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.HashMap.Strict as M
+import qualified WaiAppStatic.Storage.Embedded as Static
+
+import Yesod.Static (base64md5)
+import Yesod.EmbeddedStatic.Types
+
+#if !MIN_VERSION_base(4,6,0)
+-- copied from base
+atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b
+atomicModifyIORef' ref f = do
+    b <- atomicModifyIORef ref
+            (\x -> let (a, b) = f x
+                    in (a, a `seq` b))
+    b `seq` return b
+#endif
+
+-- | The subsite for the embedded static file server.
+data EmbeddedStatic = EmbeddedStatic {
+    stApp :: !Application
+  , widgetFiles :: !(IORef (M.HashMap T.Text File))
+}
+
+instance RenderRoute EmbeddedStatic where
+    data Route EmbeddedStatic = EmbeddedResourceR [T.Text] [(T.Text,T.Text)]
+                              | EmbeddedWidgetR T.Text
+            deriving (Eq, Show, Read)
+    renderRoute (EmbeddedResourceR x y) = ("res":x, y)
+    renderRoute (EmbeddedWidgetR h) = (["widget",h], [])
+instance ParseRoute EmbeddedStatic where
+    parseRoute (("res":x), y) = Just $ EmbeddedResourceR x y
+    parseRoute (["widget",h], _) = Just $ EmbeddedWidgetR h
+    parseRoute _ = Nothing
+
+-- | At compile time, one of these is created for every 'Entry' created by
+-- the generators.  The cLink is a template haskell expression of type @Route EmbeddedStatic@.
+data ComputedEntry = ComputedEntry {
+      cHaskellName :: Maybe Name               -- ^ Optional haskell name to create a variable for the route
+    , cStEntry     :: Static.EmbeddableEntry   -- ^ The entry to be embedded into the executable
+    , cLink        :: ExpQ                     -- ^ The route for this entry
+}
+
+mkStr :: String -> ExpQ
+mkStr = litE . stringL
+
+-- | Create a 'ComputedEntry' for development mode, reloading the content on every request.
+devEmbed :: Entry -> IO ComputedEntry
+devEmbed e = return computed
+    where
+        st = Static.EmbeddableEntry {
+                   Static.eLocation = "res/" `T.append` T.pack (ebLocation e)
+                 , Static.eMimeType = ebMimeType e
+                 , Static.eContent  = Right [| $(ebDevelReload e) >>= \c ->
+                                               return (T.pack (base64md5 c), c) |]
+                 }
+        link = [| EmbeddedResourceR (T.splitOn (T.pack "/") $ T.pack $(mkStr $ ebLocation e)) [] |]
+        computed = ComputedEntry (ebHaskellName e) st link
+
+-- | Create a 'ComputedEntry' for production mode, hashing and embedding the content into the executable.
+prodEmbed :: Entry -> IO ComputedEntry
+prodEmbed e = do
+    ct <- ebProductionContent e
+    let hash = base64md5 ct
+        link = [| EmbeddedResourceR (T.splitOn (T.pack "/") $ T.pack $(mkStr $ ebLocation e))
+                                    [(T.pack "etag", T.pack $(mkStr hash))] |]
+        st = Static.EmbeddableEntry {
+                   Static.eLocation = "res/" `T.append` T.pack (ebLocation e)
+                 , Static.eMimeType = ebMimeType e
+                 , Static.eContent  = Left (T.pack hash, ct)
+                 }
+    return $ ComputedEntry (ebHaskellName e) st link
+
+toApp :: (Request -> IO Response) -> Application
+#if MIN_VERSION_wai(3, 0, 0)
+toApp f req g = f req >>= g
+#else
+toApp = id
+#endif
+
+tryExtraDevelFiles :: [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Application
+tryExtraDevelFiles = toApp . tryExtraDevelFiles'
+
+tryExtraDevelFiles' :: [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Request -> IO Response
+tryExtraDevelFiles' [] _ = return $ responseLBS status404 [] ""
+tryExtraDevelFiles' (f:fs) r = do
+    mct <- liftIO $ f $ drop 1 $ pathInfo r -- drop the initial "res"
+    case mct of
+        Nothing -> tryExtraDevelFiles' fs r
+        Just (mime, ct) -> do
+            let hash = T.encodeUtf8 $ T.pack $ base64md5 ct
+            let headers = [ ("Content-Type", mime)
+                          , ("ETag", hash)
+                          ]
+            case lookup "If-None-Match" (requestHeaders r) of
+                Just h | hash == h -> return $ responseLBS status304 headers ""
+                _ -> return $ responseLBS status200 headers ct
+
+-- | Helper to create the development application at runtime
+develApp :: StaticSettings -> [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Application
+#if MIN_VERSION_wai(3, 0, 0)
+develApp settings extra req sendResponse = do
+    staticApp settings {ssMaxAge = NoMaxAge} req $ \resp ->
+        if statusCode (responseStatus resp) == 404
+            then tryExtraDevelFiles extra req sendResponse
+            else sendResponse resp
+#else
+develApp settings extra req = do
+    resp <- staticApp settings {ssMaxAge = NoMaxAge} req
+    if statusCode (responseStatus resp) == 404
+        then tryExtraDevelFiles extra req
+        else return resp
+#endif
+
+-- | The type of 'addStaticContent'
+type AddStaticContent site = T.Text -> T.Text -> BL.ByteString
+                          -> HandlerT site IO (Maybe (Either T.Text (Route site, [(T.Text, T.Text)])))
+
+-- | Helper for embedStaticContent and embedLicensedStaticContent.
+staticContentHelper :: Yesod site
+                    => (site -> EmbeddedStatic)
+                    -> (Route EmbeddedStatic -> Route site)
+                    -> (BL.ByteString -> Either a BL.ByteString)
+                    -> AddStaticContent site
+staticContentHelper getStatic staticR minify ext _ ct = do
+    wIORef <- widgetFiles . getStatic <$> getYesod
+    let hash = T.pack $ base64md5 ct
+        hash' = Just $ T.encodeUtf8 hash
+        filename = T.concat [hash, ".", ext]
+        content = case ext of
+                    "js" -> either (const ct) id $ minify ct
+                    _    -> ct
+        file = File
+                { fileGetSize = fromIntegral $ BL.length content
+                , fileToResponse = \s h -> responseLBS s h content
+                , fileName = unsafeToPiece filename
+                , fileGetHash = return hash'
+                , fileGetModified = Nothing
+                }
+    liftIO $ atomicModifyIORef' wIORef $ \m ->
+        (M.insertWith (\old _ -> old) filename file m, ())
+
+    return $ Just $ Right (staticR $ EmbeddedWidgetR filename, [])
+
+-- | Create a wai-app-static settings based on the IORef inside the EmbeddedStaic site.
+widgetSettings :: EmbeddedStatic -> StaticSettings
+widgetSettings es = (defaultWebAppSettings "") { ssLookupFile = lookupFile }
+    where
+        lookupFile [_,p] = do -- The first part of the path is "widget"
+            m <- readIORef $ widgetFiles es
+            return $ maybe LRNotFound LRFile $ M.lookup (fromPiece p) m
+        lookupFile _ = return LRNotFound

yesod-static/Yesod/EmbeddedStatic/Types.hs

@@ -0,0 +1,67 @@
+{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
+module Yesod.EmbeddedStatic.Types(
+    Location
+  , Generator
+  -- ** Entry
+  , Entry
+  , ebHaskellName
+  , ebLocation
+  , ebMimeType
+  , ebProductionContent
+  , ebDevelReload
+  , ebDevelExtraFiles
+) where
+
+import Data.Default
+import Language.Haskell.TH
+import Network.Mime (MimeType)
+import qualified Data.ByteString.Lazy as BL
+
+-- | A location is a relative path within the static subsite at which resource(s) are made available.
+-- The location can include slashes to simulate directories but must not start or end with a slash.
+type Location = String
+
+-- | A single resource embedded into the executable at compile time.
+--
+-- This data type is a settings type.  For more information, see
+-- <http://www.yesodweb.com/book/settings-types>.
+data Entry = Entry {
+    ebHaskellName :: Maybe Name
+        -- ^ An optional haskell name. If the name is present, a variable
+        --   of type @Route 'Yesod.EmbeddedStatic.EmbeddedStatic'@ with the
+        --   given name will be created which points to this resource.
+  , ebLocation :: Location     -- ^ The location to serve the resource from.
+  , ebMimeType :: MimeType     -- ^ The mime type of the resource.
+  , ebProductionContent :: IO BL.ByteString 
+        -- ^ If the development argument to 'Yesod.EmbeddedStatic.mkEmbeddedStatic' is False,
+        -- then at compile time this action will be executed to load the content.
+        -- During development, this action will not be executed.
+  , ebDevelReload :: ExpQ
+        -- ^ This must be a template haskell expression of type @IO 'BL.ByteString'@.
+        -- If the development argument to 'Yesod.EmbeddedStatic.mkEmbeddedStatic' is True,
+        -- this action is executed on every request to compute the content.  Most of the
+        -- time, 'ebProductionContent' and 'ebDevelReload' should be the same action but
+        -- occasionally you might want additional processing inside the 'ebProductionContent'
+        -- function like javascript/css minification to only happen when building for production.
+  , ebDevelExtraFiles :: Maybe ExpQ
+        -- ^ Occasionally, during development an entry needs extra files/resources available
+        --   that are not present during production (for example, image files that are embedded
+        --   into the CSS at production but left unembedded during development).  If present,
+        --   @ebDevelExtraFiles@ must be a template haskell expression of type
+        --   @['T.Text'] -> IO (Maybe ('MimeType', 'BL.ByteString'))@.  That is, a function
+        --   taking as input the list of path pieces and optionally returning a mime type
+        --   and content.
+}
+
+-- | When using 'def', you must fill in at least 'ebLocation'.
+instance Default Entry where
+    def = Entry { ebHaskellName = Nothing
+                , ebLocation = "xxxx"
+                , ebMimeType = "application/octet-stream"
+                , ebProductionContent = return BL.empty
+                , ebDevelReload = [| return BL.empty |]
+                , ebDevelExtraFiles = Nothing
+                }
+
+-- | An embedded generator is executed at compile time to produce the entries to embed.
+type Generator = Q [Entry]

yesod-static/Yesod/Static.hs

@@ -35,7 +35,6 @@ module Yesod.Static
       -- * Smart constructor
     , static
     , staticDevel
-    , embed
       -- * Combining CSS/JS
       -- $combining
     , combineStylesheets'
@@ -54,6 +53,8 @@ module Yesod.Static
     , publicFiles
       -- * Hashing
     , base64md5
+      -- * Embed
+    , embed
 #ifdef TEST_EXPORT
     , getFileListPieces
 #endif
@@ -65,6 +66,7 @@ import System.Directory
 import Control.Monad
 import Data.FileEmbed (embedDir)
 
+import Control.Monad.Trans.Resource (runResourceT)
 import Yesod.Core
 import Yesod.Core.Types
 
@@ -72,14 +74,14 @@ import Data.List (intercalate)
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax as TH
 
-import Crypto.Conduit (hashFile, sinkHash)
+import Crypto.Hash.Conduit (hashFile, sinkHash)
-import Crypto.Hash.MD5 (MD5)
+import Crypto.Hash (MD5, Digest)
 import Control.Monad.Trans.State
 
+import qualified Data.Byteable as Byteable
 import qualified Data.ByteString.Base64
 import qualified Data.ByteString.Char8 as S8
 import qualified Data.ByteString.Lazy as L
-import qualified Data.Serialize
 import Data.Text (Text, pack)
 import qualified Data.Text as T
 import qualified Data.Map as M
@@ -100,7 +102,7 @@ import Filesystem (createTree)
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Encoding as TLE
 import Data.Default
-import Text.Lucius (luciusRTMinified)
+--import Text.Lucius (luciusRTMinified)
 
 import Network.Wai.Application.Static
     ( StaticSettings (..)
@@ -134,8 +136,11 @@ staticDevel dir = do
     hashLookup <- cachedETagLookupDevel dir
     return $ Static $ webAppSettingsWithLookup (F.decodeString dir) hashLookup
 
--- | Produce a 'Static' based on embedding all of the static
+-- | Produce a 'Static' based on embedding all of the static files' contents in the
--- files' contents in the executable at compile time.
+-- executable at compile time.
+--
+-- You should use "Yesod.EmbeddedStatic" instead, it is much more powerful.
+--
 -- Nota Bene: if you replace the scaffolded 'static' call in Settings/StaticFiles.hs
 -- you will need to change the scaffolded addStaticContent.  Otherwise, some of your
 -- assets will be 404'ed.  This is because by default yesod will generate compile those
@@ -222,7 +227,7 @@ getFileListPieces = flip evalStateT M.empty . flip go id
 -- definitions would be created:
 --
 -- > style_css    = StaticRoute ["style.css"]    []
--- > js_script_js = StaticRoute ["js/script.js"] []
+-- > js_script_js = StaticRoute ["js", "script.js"] []
 --
 -- Note that dots (@.@), dashes (@-@) and slashes (@\/@) are
 -- replaced by underscores (@\_@) to create valid Haskell
@@ -355,7 +360,7 @@ mkStaticFilesList fp fs routeConName makeHash = do
 
 base64md5File :: Prelude.FilePath -> IO String
 base64md5File = fmap (base64 . encode) . hashFile
-    where encode d = Data.Serialize.encode (d :: MD5)
+    where encode d = Byteable.toBytes (d :: Digest MD5)
 
 base64md5 :: L.ByteString -> String
 base64md5 lbs =
@@ -363,7 +368,7 @@ base64md5 lbs =
           $ runIdentity
           $ sourceList (L.toChunks lbs) $$ sinkHash
   where
-    encode d = Data.Serialize.encode (d :: MD5)
+    encode d = Byteable.toBytes (d :: Digest MD5)
 
 base64 :: S.ByteString -> String
 base64 = map tr
@@ -442,7 +447,7 @@ data CombineSettings = CombineSettings
     , csCssPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString
     -- ^ Post processing to be performed on CSS files.
     --
-    -- Default: Use Lucius to minify.
+    -- Default: Pass-through.
     --
     -- Since 1.2.0
     , csJsPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString
@@ -474,10 +479,13 @@ data CombineSettings = CombineSettings
 instance Default CombineSettings where
     def = CombineSettings
         { csStaticDir = "static"
+        {- Disabled due to: https://github.com/yesodweb/yesod/issues/623
         , csCssPostProcess = \fps ->
               either (error . (errorIntro fps)) (return . TLE.encodeUtf8)
             . flip luciusRTMinified []
             . TLE.decodeUtf8
+        -}
+        , csCssPostProcess = const return
         , csJsPostProcess = const return
            -- FIXME The following borders on a hack. With combining of files,
            -- the final location of the CSS is no longer fixed, so relative

yesod-static/sample-embed.hs

@@ -1,23 +1,42 @@
-{-# LANGUAGE QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies #-}
-{-# LANGUAGE OverloadedStrings #-}
+-- | This embeds just a single file; it embeds the source code file 
-{-# LANGUAGE TemplateHaskell #-}
+-- \"sample-embed.hs\" from the current directory so when you compile,
-import Yesod.Static
+-- the sample-embed.hs file must be in the current directory.
-import Yesod.Dispatch
+--
+-- Try toggling the development argument to 'mkEmbeddedStatic'. When the
+-- development argument is true the file \"sample-embed.hs\" is reloaded
+-- from disk on every request (try changing it after you start the server).
+-- When development is false, the contents are embedded and the sample-embed.hs
+-- file does not even need to be present during runtime.
+module Main where
+
 import Yesod.Core
-import Network.Wai.Handler.Warp (run)
+import Yesod.EmbeddedStatic
 
-staticFiles "."
+mkEmbeddedStatic False "eStatic" [embedFile "sample-embed.hs"]
 
-data Sample = Sample
+-- The above will generate variables
-getStatic _ = $(embed "tests")
+-- eStatic :: EmbeddedStatic
-mkYesod "Sample" [parseRoutes|
+-- sample_embed_hs :: Route EmbeddedStatic
-/ RootR GET
+
-/static StaticR Static getStatic
+data MyApp = MyApp { getStatic :: EmbeddedStatic }
+
+mkYesod "MyApp" [parseRoutes|
+/ HomeR GET
+/static StaticR EmbeddedStatic getStatic
 |]
-instance Yesod Sample where approot _ = ""
 
-getRootR = do
+instance Yesod MyApp where
-    redirectText RedirectPermanent "static"
+     addStaticContent = embedStaticContent getStatic StaticR Right
-    return ()
 
-main = toWaiApp Sample >>= run 3000
+getHomeR :: Handler Html
+getHomeR = defaultLayout $ do
+    toWidget [julius|console.log("Hello World");|]
+    [whamlet|
+<h1>Hello
+<p>Check the
+    <a href=@{StaticR sample_embed_hs}>embedded file
+|]
+
+main :: IO ()
+main = warp 3000 $ MyApp eStatic

yesod-static/test/EmbedDevelTest.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies, OverloadedStrings #-}
+module EmbedDevelTest where
+
+-- Tests the development mode of the embedded static subsite by
+-- using a custom generator testGen.
+
+import Data.Maybe (isNothing)
+import EmbedTestGenerator
+import EmbedProductionTest (findEtag)
+import Network.Wai.Test (SResponse(simpleHeaders))
+import Test.HUnit (assertBool)
+import Test.Hspec (Spec)
+import Yesod.Core
+import Yesod.EmbeddedStatic
+import Yesod.Test
+
+mkEmbeddedStatic True "eDev" [testGen]
+
+data MyApp = MyApp { getStatic :: EmbeddedStatic }
+
+mkYesod "MyApp" [parseRoutes|
+/static StaticR EmbeddedStatic getStatic
+|]
+
+instance Yesod MyApp
+
+noCacheControl :: YesodExample site ()
+noCacheControl = withResponse $ \r -> do
+    liftIO $ assertBool "Cache-Control exists" $
+        isNothing $ lookup "Cache-Control" $ simpleHeaders r
+    liftIO $ assertBool "Expires exists" $
+        isNothing $ lookup "Expires" $ simpleHeaders r
+
+embedDevSpecs :: Spec
+embedDevSpecs = yesodSpec (MyApp eDev) $ do
+    ydescribe "Embedded Development Entries" $ do
+        yit "e1 loads" $ do
+            get $ StaticR e1
+            statusIs 200
+            assertHeader "Content-Type" "text/plain"
+            noCacheControl
+            bodyEquals "e1 devel"
+
+            tag <- findEtag
+            request $ do
+                setMethod "GET"
+                setUrl $ StaticR e1
+                addRequestHeader ("If-None-Match", tag)
+            statusIs 304
+
+        yit "e2 with simulated directory" $ do
+            get $ StaticR e2
+            statusIs 200
+            assertHeader "Content-Type" "abcdef"
+            noCacheControl
+            bodyEquals "e2 devel"
+
+        yit "e3 without haskell name" $ do
+            get $ StaticR $ embeddedResourceR ["xxxx", "e3"] []
+            statusIs 200
+            assertHeader "Content-Type" "yyy"
+            noCacheControl
+            bodyEquals "e3 devel"
+
+        yit "e4 loads" $ do
+            get $ StaticR e4
+            statusIs 200
+            assertHeader "Content-Type" "text/plain"
+            noCacheControl
+            bodyEquals "e4 devel"
+
+        yit "e4 extra development dev1" $ do
+            get $ StaticR $ embeddedResourceR ["dev1"] []
+            statusIs 200
+            assertHeader "Content-Type" "mime"
+            noCacheControl
+            bodyEquals "dev1 content"
+
+            tag <- findEtag
+            request $ do
+                setMethod "GET"
+                setUrl $ StaticR $ embeddedResourceR ["dev1"] []
+                addRequestHeader ("If-None-Match", tag)
+            statusIs 304
+
+        yit "e4 extra development with path" $ do
+            get $ StaticR $ embeddedResourceR ["dir", "dev2"] []
+            statusIs 200
+            assertHeader "Content-Type" "mime2"
+            noCacheControl
+            bodyEquals "dev2 content"
+
+        yit "extra development file 404" $ do
+            get $ StaticR $ embeddedResourceR ["xxxxxxxxxx"] []
+            statusIs 404

yesod-static/test/EmbedProductionTest.hs

@@ -0,0 +1,118 @@
+{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies, OverloadedStrings #-}
+module EmbedProductionTest where
+
+-- Tests the production mode of the embedded static subsite by
+-- using a custom generator testGen.  Also tests that the widget
+-- content is embedded properly.
+
+import Data.Maybe (isJust)
+import EmbedTestGenerator
+import Network.Wai.Test (SResponse(simpleHeaders))
+import Test.HUnit (assertFailure, assertBool)
+import Test.Hspec (Spec)
+import Yesod.Core
+import Yesod.EmbeddedStatic
+import Yesod.Test
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as TL
+
+mkEmbeddedStatic False "eProduction" [testGen]
+
+data MyApp = MyApp { getStatic :: EmbeddedStatic }
+
+mkYesod "MyApp" [parseRoutes|
+/ HomeR GET
+/static StaticR EmbeddedStatic getStatic
+|]
+
+getHomeR :: Handler Html
+getHomeR = defaultLayout $ do
+    toWidget [julius|console.log("Hello World");|]
+    [whamlet|<h1>Hello|]
+
+instance Yesod MyApp where
+     addStaticContent = embedStaticContent getStatic StaticR Right
+
+findEtag :: YesodExample site B.ByteString
+findEtag = withResponse $ \r ->
+    case lookup "ETag" (simpleHeaders r) of
+        Nothing -> liftIO (assertFailure "No etag found") >> error ""
+        Just e -> return e
+
+hasCacheControl :: YesodExample site ()
+hasCacheControl = withResponse $ \r -> do
+    liftIO $ assertBool "Cache-Control missing" $
+        isJust $ lookup "Cache-Control" $ simpleHeaders r
+    liftIO $ assertBool "Expires missing" $
+        isJust $ lookup "Expires" $ simpleHeaders r
+
+embedProductionSpecs :: Spec
+embedProductionSpecs = yesodSpec (MyApp eProduction) $ do
+    ydescribe "Embedded Production Entries" $ do
+        yit "e1 loads" $ do
+            get $ StaticR e1
+            statusIs 200
+            assertHeader "Content-Type" "text/plain"
+            hasCacheControl
+            bodyEquals "e1 production"
+
+            tag <- findEtag
+            request $ do
+                setMethod "GET"
+                setUrl $ StaticR e1
+                addRequestHeader ("If-None-Match", tag)
+            statusIs 304
+
+        yit "e1 with custom built path" $ do
+            get $ StaticR $ embeddedResourceR ["e1"] []
+            statusIs 200
+            assertHeader "Content-Type" "text/plain"
+            hasCacheControl
+            bodyEquals "e1 production"
+
+        yit "e2 with simulated directory" $ do
+            get $ StaticR e2
+            statusIs 200
+            assertHeader "Content-Type" "abcdef"
+            hasCacheControl
+            bodyEquals "e2 production"
+
+        yit "e2 with custom built directory path" $ do
+            get $ StaticR $ embeddedResourceR ["dir", "e2"] []
+            statusIs 200
+            assertHeader "Content-Type" "abcdef"
+            hasCacheControl
+            bodyEquals "e2 production"
+
+        yit "e3 without haskell name" $ do
+            get $ StaticR $ embeddedResourceR ["xxxx", "e3"] []
+            statusIs 200
+            assertHeader "Content-Type" "yyy"
+            hasCacheControl
+            bodyEquals "e3 production"
+
+        yit "e4 is embedded" $ do
+            get $ StaticR e4
+            statusIs 200
+            assertHeader "Content-Type" "text/plain"
+            hasCacheControl
+            bodyEquals "e4 production"
+
+        yit "e4 extra development files are not embedded" $ do
+            get $ StaticR $ embeddedResourceR ["dev1"] []
+            statusIs 404
+
+    ydescribe "Embedded Widget Content" $
+        yit "Embedded Javascript" $ do
+            get HomeR
+            statusIs 200
+            [script] <- htmlQuery "script"
+            let src = BL.takeWhile (/= 34) $ BL.drop 1 $ BL.dropWhile (/= 34) script -- 34 is "
+
+            get $ TL.toStrict $ TL.decodeUtf8 src
+            statusIs 200
+            hasCacheControl
+            assertHeader "Content-Type" "application/javascript"
+            bodyEquals "console.log(\"Hello World\");"

yesod-static/test/EmbedTestGenerator.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
+module EmbedTestGenerator (testGen) where
+
+import Data.Default
+import Network.Mime (MimeType)
+import Yesod.EmbeddedStatic.Types
+import Yesod.EmbeddedStatic.Generators (pathToName)
+
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as TL
+import qualified Data.ByteString.Lazy as BL
+
+e1, e2, e3, e4 :: Entry
+
+-- Basic entry
+e1 = def
+        { ebHaskellName = Just $ pathToName "e1"
+        , ebLocation = "e1"
+        , ebMimeType = "text/plain"
+        , ebProductionContent = return $ TL.encodeUtf8 "e1 production"
+        , ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e1 devel" |]
+        , ebDevelExtraFiles = Nothing
+        }
+
+-- Test simulated directory in location
+e2 = def
+        { ebHaskellName = Just $ pathToName "e2"
+        , ebLocation = "dir/e2"
+        , ebMimeType = "abcdef"
+        , ebProductionContent = return $ TL.encodeUtf8 "e2 production"
+        , ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e2 devel" |]
+        , ebDevelExtraFiles = Nothing
+        }
+
+-- Test empty haskell name
+e3 = def
+        { ebHaskellName = Nothing
+        , ebLocation = "xxxx/e3"
+        , ebMimeType = "yyy"
+        , ebProductionContent = return $ TL.encodeUtf8 "e3 production"
+        , ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e3 devel" |]
+        , ebDevelExtraFiles = Nothing
+        }
+
+devExtra :: [T.Text] -> IO (Maybe (MimeType, BL.ByteString))
+devExtra ["dev1"] = return $ Just ("mime", "dev1 content")
+devExtra ["dir", "dev2"] = return $ Just ("mime2", "dev2 content")
+devExtra _ = return Nothing
+
+-- Entry with devel extra files
+e4 = def
+        { ebHaskellName = Just $ pathToName "e4"
+        , ebLocation = "e4"
+        , ebMimeType = "text/plain"
+        , ebProductionContent = return $ TL.encodeUtf8 "e4 production"
+        , ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e4 devel" |]
+        , ebDevelExtraFiles = Just [| devExtra |]
+        }
+
+testGen :: Generator
+testGen = return [e1, e2, e3, e4]

yesod-static/test/FileGeneratorTests.hs

@@ -0,0 +1,92 @@
+{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
+module FileGeneratorTests (fileGenSpecs) where
+
+import Control.Exception
+import Control.Monad (forM_)
+import GeneratorTestUtil
+import Test.Hspec
+import Test.HUnit (assertFailure, assertEqual)
+import Yesod.EmbeddedStatic.Generators
+import qualified Data.ByteString.Lazy as BL
+
+-- | Embeds the LICENSE file
+license :: GenTestResult
+license = $(embedFile "LICENSE" >>= 
+            testOneEntry (Just "_LICENSE") "LICENSE" (BL.readFile "LICENSE")
+           )
+
+licenseAt :: GenTestResult
+licenseAt = $(embedFileAt "abc.txt" "LICENSE" >>=
+              testOneEntry (Just "abc_txt") "abc.txt" (BL.readFile "LICENSE")
+             )
+
+embDir :: [GenTestResult]
+embDir = $(embedDir "test/embed-dir" >>=
+           testEntries 
+            [ (Just "abc_def_txt", "abc/def.txt", BL.readFile "test/embed-dir/abc/def.txt")
+            , (Just "lorem_txt", "lorem.txt", BL.readFile "test/embed-dir/lorem.txt")
+            , (Just "foo", "foo", BL.readFile "test/embed-dir/foo")
+            ]
+          )
+
+embDirAt :: [GenTestResult]
+embDirAt = $(embedDirAt "xxx" "test/embed-dir" >>=
+           testEntries 
+            [ (Just "xxx_abc_def_txt", "xxx/abc/def.txt", BL.readFile "test/embed-dir/abc/def.txt")
+            , (Just "xxx_lorem_txt", "xxx/lorem.txt", BL.readFile "test/embed-dir/lorem.txt")
+            , (Just "xxx_foo", "xxx/foo", BL.readFile "test/embed-dir/foo")
+            ]
+          )
+
+concatR :: GenTestResult
+concatR = $(concatFiles "out.txt" [ "test/embed-dir/abc/def.txt", "test/embed-dir/foo"] >>=
+            testOneEntry (Just "out_txt") "out.txt" (return "Yesod Rocks\nBar\n")
+           )
+
+-- The transform function should only run at compile for the production content
+concatWithR :: GenTestResult
+concatWithR = $(concatFilesWith "out2.txt"
+                                (\x -> return $ x `BL.append` "Extra")
+                                [ "test/embed-dir/abc/def.txt", "test/embed-dir/foo"] >>=
+                testOneEntry (Just "out2_txt") "out2.txt" (return "Yesod Rocks\nBar\nExtra")
+               )
+            
+fileGenSpecs :: Spec
+fileGenSpecs = do
+    describe "Embed File" $ do
+        it "embeds a single file" $
+            assertGenResult (BL.readFile "LICENSE") license
+        it "embeds a single file at a location" $
+            assertGenResult (BL.readFile "LICENSE") licenseAt
+
+    describe "Embed Directory" $ do
+        it "embeds a directory" $
+            forM_ [embDir, embDirAt] $ \d -> case d of
+                [GenError e] -> assertFailure e
+                [def, foo, lorem] -> do
+                    assertGenResult (BL.readFile "test/embed-dir/abc/def.txt") def
+                    assertGenResult (BL.readFile "test/embed-dir/foo") foo
+                    assertGenResult (BL.readFile "test/embed-dir/lorem.txt") lorem
+                _ -> assertFailure "Bad directory list"
+
+    describe "Concat Files" $ do
+        it "simple concat" $
+            assertGenResult (return "Yesod Rocks\nBar\n") concatR
+        it "concat with processing function" $
+            assertGenResult (return "Yesod Rocks\nBar\n") concatWithR -- no Extra since this is development
+
+    describe "Compress" $ do
+        it "compress tool function" $ do
+            out <- compressTool "runhaskell" [] "main = putStrLn \"Hello World\""
+            assertEqual "" "Hello World\n" out
+
+        it "tryCompressTools" $ do
+            out <- flip tryCompressTools "abcdef" 
+                            [ const $ throwIO $ ErrorCall "An expected error"
+                            , const $ return "foo"
+                            , const $ return "bar"
+                            ]
+            assertEqual "" "foo" out
+            out2 <- flip tryCompressTools "abcdef"
+                            [ const $ throwIO $ ErrorCall "An expected error"]
+            assertEqual "" "abcdef" out2

yesod-static/test/GeneratorTestUtil.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
+module GeneratorTestUtil where
+
+import Control.Applicative
+import Control.Monad (when)
+import Data.List (sortBy)
+import Language.Haskell.TH
+import Test.HUnit
+import Yesod.EmbeddedStatic.Types
+import qualified Data.ByteString.Lazy as BL
+
+-- We test the generators by executing them at compile time
+-- and sticking the result into the GenTestResult.  We then
+-- test the GenTestResult at runtime.  But to test the ebDevelReload
+-- we must run the action at runtime so that is also embedded.
+-- Because of template haskell stage restrictions, this code
+-- needs to be in a separate module.
+
+data GenTestResult = GenError String
+                   | GenSuccessWithDevel (IO BL.ByteString)
+
+-- | Creates a GenTestResult at compile time by testing the entry.
+testEntry :: Maybe String -> Location -> IO BL.ByteString -> Entry -> ExpQ
+testEntry name _ _ e | ebHaskellName e /= (mkName <$> name) =
+    [| GenError ("haskell name " ++ $(litE $ stringL $ show $ ebHaskellName e)
+                                 ++ " /= "
+                                 ++ $(litE $ stringL $ show name)) |]
+testEntry _ loc _ e  | ebLocation e /= loc =
+    [| GenError ("location " ++ $(litE $ stringL $ show $ ebLocation e)) |]
+testEntry _ _ act e = do
+    expected <- runIO act
+    actual <- runIO $ ebProductionContent e
+    if expected == actual
+        then [| GenSuccessWithDevel $(ebDevelReload e) |]
+        else [| GenError "production content" |]
+
+testOneEntry :: Maybe String -> Location -> IO BL.ByteString -> [Entry] -> ExpQ
+testOneEntry name loc ct [e] = testEntry name loc ct e
+testOneEntry _ _ _ _ = [| GenError "not exactly one entry" |]
+
+-- | Tests a list of entries 
+testEntries :: [(Maybe String, Location, IO BL.ByteString)] -> [Entry] -> ExpQ
+testEntries a b | length a /= length b = [| [GenError "lengths differ"] |]
+testEntries a b = listE $ zipWith f a' b'
+    where 
+        a' = sortBy (\(_,l1,_) (_,l2,_) -> compare l1 l2) a
+        b' = sortBy (\e1 e2 -> ebLocation e1 `compare` ebLocation e2) b
+        f (name, loc, ct) e = testEntry name loc ct e
+
+-- | Use this at runtime to assert the 'GenTestResult' is OK
+assertGenResult :: (IO BL.ByteString) -- ^ expected development content
+                -> GenTestResult -- ^ test result created at compile time
+                -> Assertion
+assertGenResult _ (GenError e) = assertFailure ("invalid " ++ e)
+assertGenResult mexpected (GenSuccessWithDevel mactual) = do
+    expected <- mexpected
+    actual <- mactual
+    when (expected /= actual) $
+        assertFailure "invalid devel content"