Merge remote-tracking branch 'origin/master' into persistent2-simpler-dispatch

Conflicts:
	.gitignore
	yesod-core/yesod-core.cabal

.gitignore

@@ -1,3 +1,4 @@
+*~
 *.o
 *.o_p
 *.hi
@@ -10,7 +11,7 @@ yesod/foobar/
 .cabal-sandbox/
 cabal.sandbox.config
 /vendor/
-/.shelly/
+.shelly/
 tarballs/
 *.swp
 dist

.travis.yml

@@ -11,5 +11,3 @@ script:
     - mega-sdist --test
     - cabal install mega-sdist hspec cabal-meta cabal-src
     - cabal-meta install --force-reinstalls
-
-script: mega-sdist --test

package-list.sh

@@ -3,7 +3,7 @@
 pkgs=(      ./yesod-routes
             ./yesod-core
             ./yesod-json
-            ./crypto-conduit
+            ./cryptohash-conduit
             ./authenticate/authenticate
             ./yesod-static
             ./yesod-persistent

sources.txt

@@ -11,3 +11,4 @@
 ./yesod
 ./authenticate
 ./yesod-eventsource
+./yesod-websockets

yesod-auth/Yesod/Auth.hs

@@ -111,7 +111,7 @@ 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 $ authLayout $ do
@@ -379,7 +379,7 @@ setUltDestReferer' = lift $ do
     master <- getYesod
     when (redirectToReferer master) setUltDestReferer
 
-getLoginR :: AuthHandler master RepHtml
+getLoginR :: AuthHandler master Html
 getLoginR = setUltDestReferer' >> loginHandler
 
 getLogoutR :: AuthHandler master ()

yesod-auth/Yesod/Auth/BrowserId.hs

@@ -4,7 +4,7 @@
 {-# LANGUAGE RecordWildCards #-}
 module Yesod.Auth.BrowserId
     ( authBrowserId
-    , createOnClick
+    , createOnClick, createOnClickOverride
     , def
     , BrowserIdSettings
     , bisAudience
@@ -107,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) {
@@ -152,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/Email.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE Rank2Types #-}
 module Yesod.Auth.Email
     ( -- * Plugin
       authEmail
@@ -24,6 +25,10 @@ module Yesod.Auth.Email
      -- * Misc
     , loginLinkKey
     , setLoginLinkKey
+     -- * Default handlers
+    , defaultRegisterHandler
+    , defaultForgotPasswordHandler
+    , defaultSetPasswordHandler
     ) where
 
 import Network.Mail.Mime (randomString)
@@ -174,15 +179,49 @@ class (YesodAuth site, PathPiece (AuthEmailId site)) => YesodAuthEmail site wher
 
     -- | Additional normalization of email addresses, besides standard canonicalization.
     --
-    -- Default: do nothing. Note that in future versions of Yesod, the default
+    -- Default: Lower case the email address.
-    -- will change to lower casing the email address. At that point, you will
-    -- need to either ensure your database values are migrated to lower case,
-    -- or change this default back to doing nothing.
     --
     -- 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 Html
+    setPasswordHandler = defaultSetPasswordHandler
+
+
 authEmail :: YesodAuthEmail m => AuthPlugin m
 authEmail =
     AuthPlugin "email" dispatch $ \tm ->
@@ -218,7 +257,13 @@ $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 $ authLayout $ do
@@ -272,7 +317,13 @@ postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Htm
 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 $ authLayout $ do
@@ -350,14 +401,21 @@ postLoginR = do
 getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html
 getPasswordR = do
     maid <- lift maybeAuthId
-    pass0 <- newIdent
-    pass1 <- newIdent
-    pass2 <- newIdent
     case maid of
         Just _ -> return ()
         Nothing -> loginErrorMessageI LoginR Msg.BadSetPass
-    tp <- getRouteToParent
     needOld <- maybe (return True) (lift . needOldPassword) maid
+    setPasswordHandler needOld
+
+-- | Default implementation of 'setPasswordHandler'.
+--
+-- Since: 1.2.6
+defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master Html
+defaultSetPasswordHandler needOld = do
+    tp <- getRouteToParent
+    pass0 <- newIdent
+    pass1 <- newIdent
+    pass2 <- newIdent
     lift $ authLayout $ do
         setTitleI Msg.SetPassTitle
         [whamlet|
@@ -394,7 +452,7 @@ postPasswordR = do
             Just aid -> return aid
 
     tm <- getRouteToParent
-    
+
     needOld <- lift $ needOldPassword aid
     when needOld $ do
         current <- lift $ runInputPost $ ireq textField "current"
@@ -432,7 +490,7 @@ 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

yesod-auth/yesod-auth.cabal

@@ -1,5 +1,5 @@
 name:            yesod-auth
-version:         1.2.5.3
+version:         1.2.7
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin

yesod-bin/Devel.hs

@@ -69,7 +69,7 @@ import           Data.Conduit.Network                  (HostPreference (HostIPv4
 import           Network                               (withSocketsDo)
 #if MIN_VERSION_http_conduit(2, 0, 0)
 import           Network.HTTP.Conduit                  (conduitManagerSettings, newManager)
-import           Data.Default                          (def)
+import           Data.Default.Class                    (def)
 #else
 import           Network.HTTP.Conduit                  (def, newManager)
 #endif

yesod-bin/HsFile.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE OverloadedStrings #-}
+module HsFile (mkHsFile) where
+import Text.ProjectTemplate (createTemplate)
+import Data.Conduit 
+    ( ($$), (=$), runResourceT, ResourceT, ConduitM, awaitForever, yield )
+import qualified Data.Conduit.List as CL
+import Data.Conduit.Filesystem (traverse, sourceFile)
+import Prelude hiding (FilePath)
+import Filesystem.Path ( FilePath )
+import Filesystem.Path.CurrentOS ( encodeString )
+import qualified Data.ByteString as BS
+import Control.Monad.IO.Class (liftIO)
+
+mkHsFile :: IO ()
+mkHsFile = runResourceT $ traverse False "."
+        $$ 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/hsfiles/mongo.hsfiles

@@ -14,6 +14,7 @@ cabal-dev/
 yesod-devel/
 .cabal-sandbox
 cabal.sandbox.config
+.DS_Store
 
 {-# START_FILE Application.hs #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -419,11 +420,11 @@ library
                  , shakespeare-text              >= 1.0        && < 1.1
                  , hjsmin                        >= 0.1        && < 0.2
                  , monad-control                 >= 0.3        && < 0.4
-                 , wai-extra                     >= 2.0        && < 2.1
+                 , wai-extra                     >= 2.1        && < 2.2
                  , yaml                          >= 0.8        && < 0.9
                  , http-conduit                  >= 2.0        && < 2.1
                  , directory                     >= 1.1        && < 1.3
-                 , warp                          >= 2.0        && < 2.1
+                 , warp                          >= 2.1        && < 2.2
                  , data-default
                  , aeson                         >= 0.6        && < 0.8
                  , conduit                       >= 1.0        && < 2.0
@@ -807,7 +808,7 @@ web: ./dist/build/PROJECTNAME/PROJECTNAME production -p $PORT
 {-# LANGUAGE PackageImports #-}
 import "PROJECTNAME" Application (getApplicationDev)
 import Network.Wai.Handler.Warp
-    (runSettings, defaultSettings, settingsPort)
+    (runSettings, defaultSettings, setPort)
 import Control.Concurrent (forkIO)
 import System.Directory (doesFileExist, removeFile)
 import System.Exit (exitSuccess)
@@ -817,9 +818,7 @@ main :: IO ()
 main = do
     putStrLn "Starting devel application"
     (port, app) <- getApplicationDev
-    forkIO $ runSettings defaultSettings
+    forkIO $ runSettings (setPort port defaultSettings) app
-        { settingsPort = port
-        } app
     loop
 
 loop :: IO ()

yesod-bin/hsfiles/mysql.hsfiles

@@ -14,6 +14,7 @@ cabal-dev/
 yesod-devel/
 .cabal-sandbox
 cabal.sandbox.config
+.DS_Store
 
 {-# START_FILE Application.hs #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -423,11 +424,11 @@ library
                  , shakespeare-text              >= 1.0        && < 1.1
                  , hjsmin                        >= 0.1        && < 0.2
                  , monad-control                 >= 0.3        && < 0.4
-                 , wai-extra                     >= 2.0        && < 2.1
+                 , wai-extra                     >= 2.1        && < 2.2
                  , yaml                          >= 0.8        && < 0.9
                  , http-conduit                  >= 2.0        && < 2.1
                  , directory                     >= 1.1        && < 1.3
-                 , warp                          >= 2.0        && < 2.1
+                 , warp                          >= 2.1        && < 2.2
                  , data-default
                  , aeson                         >= 0.6        && < 0.8
                  , conduit                       >= 1.0        && < 2.0
@@ -837,7 +838,7 @@ web: ./dist/build/PROJECTNAME/PROJECTNAME production -p $PORT
 {-# LANGUAGE PackageImports #-}
 import "PROJECTNAME" Application (getApplicationDev)
 import Network.Wai.Handler.Warp
-    (runSettings, defaultSettings, settingsPort)
+    (runSettings, defaultSettings, setPort)
 import Control.Concurrent (forkIO)
 import System.Directory (doesFileExist, removeFile)
 import System.Exit (exitSuccess)
@@ -847,9 +848,7 @@ main :: IO ()
 main = do
     putStrLn "Starting devel application"
     (port, app) <- getApplicationDev
-    forkIO $ runSettings defaultSettings
+    forkIO $ runSettings (setPort port defaultSettings) app
-        { settingsPort = port
-        } app
     loop
 
 loop :: IO ()

yesod-bin/hsfiles/postgres-fay.hsfiles

@@ -15,6 +15,7 @@ cabal-dev/
 yesod-devel/
 .cabal-sandbox
 cabal.sandbox.config
+.DS_Store
 
 {-# START_FILE Application.hs #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -460,11 +461,11 @@ library
                  , shakespeare-js                >= 1.2        && < 1.3
                  , shakespeare-text              >= 1.0        && < 1.1
                  , monad-control                 >= 0.3        && < 0.4
-                 , wai-extra                     >= 2.0        && < 2.1
+                 , wai-extra                     >= 2.1        && < 2.2
                  , yaml                          >= 0.8        && < 0.9
                  , http-conduit                  >= 2.0        && < 2.1
                  , directory                     >= 1.1        && < 1.3
-                 , warp                          >= 2.0        && < 2.1
+                 , warp                          >= 2.1        && < 2.2
                  , data-default
                  , aeson                         >= 0.6        && < 0.8
                  , conduit                       >= 1.0        && < 2.0
@@ -861,7 +862,7 @@ web: ./dist/build/PROJECTNAME/PROJECTNAME production -p $PORT
 {-# LANGUAGE PackageImports #-}
 import "PROJECTNAME" Application (getApplicationDev)
 import Network.Wai.Handler.Warp
-    (runSettings, defaultSettings, settingsPort)
+    (runSettings, defaultSettings, setPort)
 import Control.Concurrent (forkIO)
 import System.Directory (doesFileExist, removeFile)
 import System.Exit (exitSuccess)
@@ -871,9 +872,7 @@ main :: IO ()
 main = do
     putStrLn "Starting devel application"
     (port, app) <- getApplicationDev
-    forkIO $ runSettings defaultSettings
+    forkIO $ runSettings (setPort port defaultSettings) app
-        { settingsPort = port
-        } app
     loop
 
 loop :: IO ()

yesod-bin/hsfiles/postgres.hsfiles

@@ -14,6 +14,7 @@ cabal-dev/
 yesod-devel/
 .cabal-sandbox
 cabal.sandbox.config
+.DS_Store
 
 {-# START_FILE Application.hs #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -423,11 +424,11 @@ library
                  , shakespeare-text              >= 1.0        && < 1.1
                  , hjsmin                        >= 0.1        && < 0.2
                  , monad-control                 >= 0.3        && < 0.4
-                 , wai-extra                     >= 2.0        && < 2.1
+                 , wai-extra                     >= 2.1        && < 2.2
                  , yaml                          >= 0.8        && < 0.9
                  , http-conduit                  >= 2.0        && < 2.1
                  , directory                     >= 1.1        && < 1.3
-                 , warp                          >= 2.0        && < 2.1
+                 , warp                          >= 2.1        && < 2.2
                  , data-default
                  , aeson                         >= 0.6        && < 0.8
                  , conduit                       >= 1.0        && < 2.0
@@ -811,7 +812,7 @@ web: ./dist/build/PROJECTNAME/PROJECTNAME production -p $PORT
 {-# LANGUAGE PackageImports #-}
 import "PROJECTNAME" Application (getApplicationDev)
 import Network.Wai.Handler.Warp
-    (runSettings, defaultSettings, settingsPort)
+    (runSettings, defaultSettings, setPort)
 import Control.Concurrent (forkIO)
 import System.Directory (doesFileExist, removeFile)
 import System.Exit (exitSuccess)
@@ -821,9 +822,7 @@ main :: IO ()
 main = do
     putStrLn "Starting devel application"
     (port, app) <- getApplicationDev
-    forkIO $ runSettings defaultSettings
+    forkIO $ runSettings (setPort port defaultSettings) app
-        { settingsPort = port
-        } app
     loop
 
 loop :: IO ()

yesod-bin/hsfiles/simple.hsfiles

@@ -14,6 +14,7 @@ cabal-dev/
 yesod-devel/
 .cabal-sandbox
 cabal.sandbox.config
+.DS_Store
 
 {-# START_FILE Application.hs #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -347,11 +348,11 @@ library
                  , shakespeare-text              >= 1.0        && < 1.1
                  , hjsmin                        >= 0.1        && < 0.2
                  , monad-control                 >= 0.3        && < 0.4
-                 , wai-extra                     >= 2.0        && < 2.1
+                 , wai-extra                     >= 2.1        && < 2.2
                  , yaml                          >= 0.8        && < 0.9
                  , http-conduit                  >= 2.0        && < 2.1
                  , directory                     >= 1.1        && < 1.3
-                 , warp                          >= 2.0        && < 2.1
+                 , warp                          >= 2.1        && < 2.2
                  , data-default
                  , aeson                         >= 0.6        && < 0.8
                  , conduit                       >= 1.0        && < 2.0
@@ -685,7 +686,7 @@ web: ./dist/build/PROJECTNAME/PROJECTNAME production -p $PORT
 {-# LANGUAGE PackageImports #-}
 import "PROJECTNAME" Application (getApplicationDev)
 import Network.Wai.Handler.Warp
-    (runSettings, defaultSettings, settingsPort)
+    (runSettings, defaultSettings, setPort)
 import Control.Concurrent (forkIO)
 import System.Directory (doesFileExist, removeFile)
 import System.Exit (exitSuccess)
@@ -695,9 +696,7 @@ main :: IO ()
 main = do
     putStrLn "Starting devel application"
     (port, app) <- getApplicationDev
-    forkIO $ runSettings defaultSettings
+    forkIO $ runSettings (setPort port defaultSettings) app
-        { settingsPort = port
-        } app
     loop
 
 loop :: IO ()

yesod-bin/hsfiles/sqlite.hsfiles

@@ -14,6 +14,7 @@ cabal-dev/
 yesod-devel/
 .cabal-sandbox
 cabal.sandbox.config
+.DS_Store
 
 {-# START_FILE Application.hs #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -423,11 +424,11 @@ library
                  , shakespeare-text              >= 1.0        && < 1.1
                  , hjsmin                        >= 0.1        && < 0.2
                  , monad-control                 >= 0.3        && < 0.4
-                 , wai-extra                     >= 2.0        && < 2.1
+                 , wai-extra                     >= 2.1        && < 2.2
                  , yaml                          >= 0.8        && < 0.9
                  , http-conduit                  >= 2.0        && < 2.1
                  , directory                     >= 1.1        && < 1.3
-                 , warp                          >= 2.0        && < 2.1
+                 , warp                          >= 2.1        && < 2.2
                  , data-default
                  , aeson                         >= 0.6        && < 0.8
                  , conduit                       >= 1.0        && < 2.0
@@ -807,7 +808,7 @@ web: ./dist/build/PROJECTNAME/PROJECTNAME production -p $PORT
 {-# LANGUAGE PackageImports #-}
 import "PROJECTNAME" Application (getApplicationDev)
 import Network.Wai.Handler.Warp
-    (runSettings, defaultSettings, settingsPort)
+    (runSettings, defaultSettings, setPort)
 import Control.Concurrent (forkIO)
 import System.Directory (doesFileExist, removeFile)
 import System.Exit (exitSuccess)
@@ -817,9 +818,7 @@ main :: IO ()
 main = do
     putStrLn "Starting devel application"
     (port, app) <- getApplicationDev
-    forkIO $ runSettings defaultSettings
+    forkIO $ runSettings (setPort port defaultSettings) app
-        { settingsPort = port
-        } app
     loop
 
 loop :: IO ()

yesod-bin/main.hs

@@ -21,6 +21,7 @@ import           Options.Applicative.Types (ReadM (ReadM))
 import           Options.Applicative.Builder.Internal (Mod, OptionFields)
 #endif
 
+import           HsFile                 (mkHsFile)
 #ifndef WINDOWS
 import           Build                  (touch)
 
@@ -47,6 +48,7 @@ data Options = Options
   deriving (Show, Eq)
 
 data Command = Init { _initBare :: Bool }
+             | HsFiles
              | Configure
              | Build { buildExtraArgs   :: [String] }
              | Touch
@@ -96,6 +98,7 @@ main = do
   let cabal = rawSystem' (cabalCommand o)
   case optCommand o of
     Init bare       -> scaffold bare
+    HsFiles         -> mkHsFile
     Configure       -> cabal ["configure"]
     Build es        -> touch' >> cabal ("build":es)
     Touch           -> touch'
@@ -124,8 +127,10 @@ 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 (Init <$> switch (long "bare" <> help "Create files in current folder"))
+                            (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)

yesod-bin/yesod-bin.cabal

@@ -1,5 +1,5 @@
 name:            yesod-bin
-version:         1.2.6
+version:         1.2.7.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -89,7 +89,8 @@ executable             yesod
                      , transformers
                      , warp               >= 1.3.7.5
                      , wai                >= 1.4
-                     , data-default
+                     , data-default-class
+                     , filesystem-conduit >= 1.0          && < 2.0
 
     ghc-options:       -Wall -threaded
     main-is:           main.hs
@@ -101,6 +102,7 @@ executable             yesod
                        AddHandler
                        Paths_yesod_bin
                        Options
+                       HsFile
 
 source-repository head
   type:     git

yesod-core/Yesod/Core/Handler.hs

@@ -89,6 +89,9 @@ module Yesod.Core.Handler
     , sendResponseStatus
     , sendResponseCreated
     , sendWaiResponse
+#if MIN_VERSION_wai(2, 1, 0)
+    , sendRawResponse
+#endif
       -- * Different representations
       -- $representations
     , selectRep
@@ -134,6 +137,7 @@ module Yesod.Core.Handler
     , newIdent
       -- * Lifting
     , handlerToIO
+    , forkHandler
       -- * i18n
     , getMessageRender
       -- * Per-request caching
@@ -146,18 +150,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, InternalState)
 
 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)
@@ -170,10 +173,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
@@ -183,10 +184,9 @@ 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, getInternalState, liftResourceT)
 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           Yesod.Core.Class.Handler
 import           Yesod.Core.Types
@@ -195,9 +195,23 @@ import Control.Failure (failure)
 import Blaze.ByteString.Builder (Builder)
 import Safe (headMay)
 import Data.CaseInsensitive (CI)
+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
@@ -382,6 +396,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
@@ -547,6 +573,23 @@ sendResponseCreated url = do
 sendWaiResponse :: MonadHandler m => W.Response -> m b
 sendWaiResponse = handlerError . HCWai
 
+#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
+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
+
 -- | Return a 404 not found page. Also denotes no handler available.
 notFound :: MonadHandler m => m a
 notFound = hcError NotFound

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

@@ -47,9 +47,20 @@ yarToResponse (YRWai a) _ _ _ is =
     case a of
         ResponseSource s hs w -> return $ ResponseSource s hs $ \f ->
             w f `finally` closeInternalState is
-        _ -> do
+        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
@@ -128,7 +139,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/Json.hs

@@ -10,6 +10,7 @@ module Yesod.Core.Json
       -- * Convert to a JSON value
     , parseJsonBody
     , parseJsonBody_
+    , requireJsonBody
 
       -- * Produce JSON values
     , J.Value (..)
@@ -99,7 +100,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/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/ErrorHandling.hs

@@ -13,6 +13,8 @@ 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)
 
 data App = App
 
@@ -29,6 +31,8 @@ mkYesod "App" [parseRoutes|
 /builder BuilderR GET
 /file-bad-len FileBadLenR GET
 /file-bad-name FileBadNameR GET
+
+/good-builder GoodBuilderR GET
 |]
 
 overrideStatus = mkStatus 15 "OVERRIDE"
@@ -88,6 +92,12 @@ getFileBadLenR = return $ TypedContent "ignored" $ ContentFile "yesod-core.cabal
 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
+
 errorHandlingTest :: Spec
 errorHandlingTest = describe "Test.ErrorHandling" $ do
       it "says not found" caseNotFound
@@ -99,6 +109,7 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do
       it "builder" caseBuilder
       it "file with bad len" caseFileBadLen
       it "file with bad name" caseFileBadName
+      it "builder includes content-length" caseGoodBuilder
 
 runner :: Session () -> IO ()
 runner f = toWaiApp App >>= runSession f
@@ -175,3 +186,11 @@ 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

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,62 @@
+{-# 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 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
+
+data App = App
+
+mkYesod "App" [parseRoutes|
+/ HomeR 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
+
+getFreePort :: IO Int
+getFreePort = do
+    loop 43124
+  where
+    loop port = do
+        esocket <- try $ bindPort port "*"
+        case esocket of
+            Left (_ :: IOException) -> loop (succ port)
+            Right socket -> do
+                sClose socket
+                return port
+
+specs :: Spec
+specs = 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")

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.2.7
+version:         1.2.8
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -122,9 +122,26 @@ test-suite tests
                   , containers
                   , lifted-base
                   , resourcet
+                  , network-conduit
+                  , network
+                  , async
     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
   location: https://github.com/yesodweb/yesod

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
@@ -68,6 +69,7 @@ import Database.Persist.Sql (PersistField, PersistFieldSql (..))
 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
@@ -82,7 +84,7 @@ 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, concat, intercalate, unpack, pack, splitOn)
 import qualified Data.Text.Read
 
 import qualified Data.Map as Map
@@ -306,12 +308,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}">
 |]

yesod-form/Yesod/Form/Functions.hs

@@ -24,6 +24,8 @@ module Yesod.Form.Functions
       -- * Generate a blank form
     , generateFormPost
     , generateFormGet
+      -- * More than one form on a handler
+    , identifyForm
       -- * Rendering
     , FormRender
     , renderTable
@@ -39,15 +41,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
@@ -220,7 +223,7 @@ 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)
@@ -284,6 +287,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
@@ -333,7 +387,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:
 --
@@ -368,6 +424,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)
@@ -428,6 +485,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/Types.hs

@@ -98,7 +98,7 @@ 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'

yesod-form/hello-forms.hs

@@ -23,7 +23,7 @@ mkYesod "HelloForms" [parseRoutes|
 /file FileR GET POST
 |]
 
-myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,)
+myForm = fixType $ runFormGet $ renderDivs $ pure (,,,,,,,,,)
     <*> areq boolField "Bool field" Nothing
     <*> aopt boolField "Opt bool field" Nothing
     <*> areq textField "Text field" Nothing
@@ -33,6 +33,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.5.1
+version:         1.3.8
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -35,13 +35,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-platform/make-cabal.sh

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

yesod-platform/yesod-platform.cabal

@@ -1,5 +1,5 @@
 name:            yesod-platform
-version:         1.2.7.1
+version:         1.2.8
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -14,17 +14,21 @@ homepage:        http://www.yesodweb.com/
 
 library
     build-depends: base >= 4 && < 5
+                 , ReadArgs == 1.2.1
                  , SHA == 1.6.4
-                 , aeson == 0.7.0.1
+                 , aeson == 0.7.0.2
                  , ansi-terminal == 0.6.1.1
-                 , asn1-encoding == 0.8.1.2
+                 , ansi-wl-pprint == 0.6.7.1
+                 , asn1-encoding == 0.8.1.3
                  , asn1-parse == 0.8.1
                  , asn1-types == 0.2.3
-                 , attoparsec == 0.11.1.0
+                 , async == 2.0.1.5
+                 , attoparsec == 0.11.2.1
                  , attoparsec-conduit == 1.0.1.2
                  , authenticate == 1.3.2.6
                  , base-unicode-symbols == 0.2.2.4
                  , base64-bytestring == 1.0.0.1
+                 , basic-prelude == 0.3.6.0
                  , blaze-builder == 0.3.3.2
                  , blaze-builder-conduit == 1.0.0
                  , blaze-html == 0.7.0.1
@@ -33,39 +37,38 @@ library
                  , byteorder == 1.0.4
                  , case-insensitive == 1.1.0.3
                  , cereal == 0.4.0.1
-                 , cipher-aes == 0.2.6
+                 , cipher-aes == 0.2.7
                  , cipher-rc4 == 0.1.4
                  , clientsession == 0.9.0.3
-                 , conduit == 1.0.14
+                 , conduit == 1.0.15.1
                  , connection == 0.2.0
                  , control-monad-loop == 0.1
                  , cookie == 0.4.0.1
                  , cprng-aes == 0.5.2
                  , crypto-api == 0.13
                  , crypto-cipher-types == 0.0.9
-                 , crypto-conduit == 0.5.2.2
                  , crypto-numbers == 0.2.3
                  , crypto-pubkey == 0.2.4
-                 , crypto-pubkey-types == 0.4.1
+                 , crypto-pubkey-types == 0.4.2.2
                  , crypto-random == 0.0.7
                  , cryptohash == 0.11.2
-                 , cryptohash-cryptoapi == 0.1.0
+                 , cryptohash-conduit == 0.1.0
-                 , css-text == 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
-                 , dlist == 0.6.0.1
+                 , dlist == 0.7
                  , email-validate == 2.0.1
                  , entropy == 0.2.2.4
-                 , esqueleto == 1.3.4.5
+                 , esqueleto == 1.3.5
                  , failure == 0.2.0.1
                  , fast-logger == 2.1.5
                  , file-embed == 0.0.6
                  , filesystem-conduit == 1.0.0.1
-                 , hamlet == 1.1.7.7
+                 , hamlet == 1.1.9.2
                  , hjsmin == 0.1.4.5
                  , hspec == 1.8.3
                  , hspec-expectations == 0.5.0.1
@@ -73,54 +76,55 @@ library
                  , http-client == 0.2.2.2
                  , http-client-conduit == 0.2.0.1
                  , http-client-tls == 0.2.1.1
-                 , http-conduit == 2.0.0.5
+                 , http-conduit == 2.0.0.8
                  , http-date == 0.0.4
+                 , http-reverse-proxy == 0.3.1.1
                  , http-types == 0.8.3
-                 , language-javascript == 0.5.8
+                 , language-javascript == 0.5.9
-                 , lifted-base == 0.2.2.0
+                 , lifted-base == 0.2.2.1
-                 , mime-mail == 0.4.4
+                 , mime-mail == 0.4.4.1
                  , mime-types == 0.1.0.3
                  , mmorph == 1.0.2
                  , monad-control == 0.3.2.3
                  , monad-logger == 0.3.4.0
                  , monad-loops == 0.4.2
-                 , network-conduit == 1.0.2.2
+                 , network-conduit == 1.0.4
                  , optparse-applicative == 0.7.0.2
                  , path-pieces == 0.1.3.1
                  , pem == 0.2.1
-                 , persistent == 1.3.0.2
+                 , persistent == 1.3.0.3
-                 , persistent-template == 1.3.1.1
+                 , persistent-template == 1.3.1.2
-                 , pool-conduit == 0.1.2
+                 , pool-conduit == 0.1.2.1
-                 , primitive == 0.5.1.0
+                 , primitive == 0.5.2.1
                  , process-conduit == 1.0.0.1
                  , publicsuffixlist == 0.1
                  , pureMD5 == 2.1.2.1
                  , pwstore-fast == 2.4.1
                  , quickcheck-io == 0.1.0
                  , resource-pool == 0.2.1.1
-                 , resourcet == 0.4.10
+                 , resourcet == 0.4.10.1
                  , safe == 0.3.4
-                 , scientific == 0.2.0.1
+                 , scientific == 0.2.0.2
                  , securemem == 0.1.3
                  , semigroups == 0.12.2
                  , setenv == 0.1.1.1
-                 , shakespeare == 1.2.0.4
+                 , shakespeare == 1.2.1.1
-                 , shakespeare-css == 1.0.6.6
+                 , shakespeare-css == 1.0.7.1
                  , shakespeare-i18n == 1.0.0.5
-                 , shakespeare-js == 1.2.0.3
+                 , shakespeare-js == 1.2.0.4
-                 , shakespeare-text == 1.0.1
+                 , shakespeare-text == 1.0.2
                  , silently == 1.2.4.1
                  , simple-sendfile == 0.2.13
-                 , skein == 1.0.8.1
+                 , skein == 1.0.9
                  , socks == 0.5.4
                  , stm-chans == 3.0.0
                  , stringsearch == 0.3.6.5
                  , system-fileio == 0.3.12
                  , system-filepath == 0.4.9
-                 , tagged == 0.7
+                 , tagged == 0.7.1
                  , tagsoup == 0.13.1
                  , tagstream-conduit == 0.5.5
-                 , text-stream-decode == 0.1.0.3
+                 , text-stream-decode == 0.1.0.4
                  , tls == 1.2.2
                  , transformers-base == 0.4.1
                  , unix-compat == 0.4.1.1
@@ -129,29 +133,29 @@ library
                  , utf8-string == 0.3.7
                  , vector == 0.10.9.1
                  , void == 0.6.1
-                 , wai == 2.0.0
+                 , wai == 2.1.0
-                 , wai-app-static == 2.0.0.2
+                 , wai-app-static == 2.0.0.4
-                 , wai-extra == 2.0.3.3
+                 , wai-extra == 2.1.0.1
                  , wai-logger == 2.1.1
-                 , wai-test == 2.0.0.1
+                 , wai-test == 2.0.0.2
-                 , warp == 2.0.3.2
+                 , warp == 2.1.1.2
-                 , warp-tls == 2.0.2
+                 , warp-tls == 2.0.3.1
                  , word8 == 0.0.4
-                 , x509 == 1.4.7
+                 , x509 == 1.4.11
                  , x509-store == 1.4.4
                  , x509-system == 1.4.2
                  , x509-validation == 1.5.0
                  , xml-conduit == 1.1.0.9
                  , xml-types == 0.3.4
-                 , xss-sanitize == 0.3.4.2
+                 , xss-sanitize == 0.3.5
                  , yaml == 0.8.7.2
                  , yesod == 1.2.5
-                 , yesod-auth == 1.2.5.3
+                 , yesod-auth == 1.2.7
-                 , yesod-core == 1.2.6.7
+                 , yesod-core == 1.2.8
-                 , yesod-form == 1.3.5.1
+                 , yesod-form == 1.3.8
                  , yesod-persistent == 1.2.2.1
                  , yesod-routes == 1.2.0.6
-                 , yesod-static == 1.2.2.1
+                 , yesod-static == 1.2.2.2
                  , yesod-test == 1.2.1
                  , zlib-bindings == 0.1.1.3
                  , zlib-conduit == 1.0.0

yesod-static/Yesod/Static.hs

@@ -73,14 +73,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.CryptoAPI (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
@@ -359,7 +359,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 =
@@ -367,7 +367,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

yesod-static/yesod-static.cabal

@@ -1,5 +1,5 @@
 name:            yesod-static
-version:         1.2.2.1
+version:         1.2.2.2
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -29,7 +29,7 @@ library
                    , old-time              >= 1.0
                    , yesod-core            >= 1.2      && < 1.3
                    , base64-bytestring     >= 0.1.0.1
-                   , cereal                >= 0.3
+                   , byteable              >= 0.1
                    , bytestring            >= 0.9.1.4
                    , template-haskell
                    , directory             >= 1.0
@@ -41,8 +41,8 @@ library
                    , http-types            >= 0.7
                    , unix-compat           >= 0.2
                    , conduit               >= 0.5
-                   , crypto-conduit        >= 0.4
+                   , cryptohash-conduit    >= 0.1
-                   , cryptohash-cryptoapi  >= 0.1.0
+                   , cryptohash            >= 0.11
                    , system-filepath       >= 0.4.6    && < 0.5
                    , system-fileio         >= 0.3
                    , data-default
@@ -80,8 +80,8 @@ test-suite tests
                    , old-time
                    , yesod-core
                    , base64-bytestring
-                   , cereal
                    , bytestring
+                   , byteable
                    , template-haskell
                    , directory
                    , transformers
@@ -92,8 +92,8 @@ test-suite tests
                    , http-types
                    , unix-compat
                    , conduit
-                   , crypto-conduit
+                   , cryptohash-conduit
-                   , cryptohash-cryptoapi
+                   , cryptohash
                    , system-filepath
                    , system-fileio
                    , data-default

yesod-websockets/LICENSE

@@ -0,0 +1,20 @@
+Copyright (c) 2014 Michael Snoyman, http://www.yesodweb.com/
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

yesod-websockets/Setup.hs

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

yesod-websockets/Yesod/WebSockets.hs

@@ -0,0 +1,124 @@
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Yesod.WebSockets
+    ( -- * Core API
+      WebSocketsT
+    , webSockets
+    , receiveData
+    , sendTextData
+    , sendBinaryData
+      -- * Conduit API
+    , sourceWS
+    , sinkWSText
+    , sinkWSBinary
+      -- * Async helpers
+    , race
+    , race_
+    , concurrently
+    , concurrently_
+    ) where
+
+import qualified Control.Concurrent.Async       as A
+import           Control.Monad                  (forever, void, when)
+import           Control.Monad.IO.Class         (MonadIO (liftIO))
+import           Control.Monad.Trans.Control    (control)
+import           Control.Monad.Trans.Control    (MonadBaseControl (liftBaseWith, restoreM))
+import           Control.Monad.Trans.Reader     (ReaderT (ReaderT, runReaderT))
+import qualified Data.Conduit                   as C
+import qualified Data.Conduit.List              as CL
+import qualified Network.Wai.Handler.WebSockets as WaiWS
+import qualified Network.WebSockets             as WS
+import qualified Yesod.Core                     as Y
+
+-- | A transformer for a WebSockets handler.
+--
+-- Since 0.1.0
+type WebSocketsT = ReaderT WS.Connection
+
+-- | Attempt to run a WebSockets handler. This function first checks if the
+-- client initiated a WebSockets connection and, if so, runs the provided
+-- application, short-circuiting the rest of your handler. If the client did
+-- not request a WebSockets connection, the rest of your handler will be called
+-- instead.
+--
+-- Since 0.1.0
+webSockets :: (Y.MonadBaseControl IO m, Y.MonadHandler m) => WebSocketsT m () -> m ()
+webSockets inner = do
+    req <- Y.waiRequest
+    when (WaiWS.isWebSocketsReq req) $
+        Y.sendRawResponse $ \src sink -> control $ \runInIO -> WaiWS.runWebSockets
+            WS.defaultConnectionOptions
+            (WaiWS.getRequestHead req)
+            (\pconn -> do
+                conn <- WS.acceptRequest pconn
+                runInIO $ runReaderT inner conn)
+            src
+            sink
+
+-- | Receive a piece of data from the client.
+--
+-- Since 0.1.0
+receiveData :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m a
+receiveData = ReaderT $ liftIO . WS.receiveData
+
+-- | Send a textual messsage to the client.
+--
+-- Since 0.1.0
+sendTextData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
+sendTextData x = ReaderT $ liftIO . flip WS.sendTextData x
+
+-- | Send a binary messsage to the client.
+--
+-- Since 0.1.0
+sendBinaryData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
+sendBinaryData x = ReaderT $ liftIO . flip WS.sendBinaryData x
+
+-- | A @Source@ of WebSockets data from the user.
+--
+-- Since 0.1.0
+sourceWS :: (MonadIO m, WS.WebSocketsData a) => C.Producer (WebSocketsT m) a
+sourceWS = forever $ Y.lift receiveData >>= C.yield
+
+-- | A @Sink@ for sending textual data to the user.
+--
+-- Since 0.1.0
+sinkWSText :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) ()
+sinkWSText = CL.mapM_ sendTextData
+
+-- | A @Sink@ for sending binary data to the user.
+--
+-- Since 0.1.0
+sinkWSBinary :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) ()
+sinkWSBinary = CL.mapM_ sendBinaryData
+
+-- | Generalized version of 'A.race'.
+--
+-- Since 0.1.0
+race :: MonadBaseControl IO m => m a -> m b -> m (Either a b)
+race x y = liftBaseWith (\run -> A.race (run x) (run y))
+    >>= either (fmap Left . restoreM) (fmap Right . restoreM)
+
+-- | Generalized version of 'A.race_'.
+--
+-- Since 0.1.0
+race_ :: MonadBaseControl IO m => m a -> m b -> m ()
+race_ x y = void $ race x y
+
+-- | Generalized version of 'A.concurrently'. Note that if your underlying
+-- monad has some kind of mutable state, the state from the second action will
+-- overwrite the state from the first.
+--
+-- Since 0.1.0
+concurrently :: MonadBaseControl IO m => m a -> m b -> m (a, b)
+concurrently x y = do
+    (resX, resY) <- liftBaseWith $ \run -> A.concurrently (run x) (run y)
+    x' <- restoreM resX
+    y' <- restoreM resY
+    return (x', y')
+
+-- | Run two actions concurrently (like 'A.concurrently'), but discard their
+-- results and any modified monadic state.
+--
+-- Since 0.1.0
+concurrently_ :: MonadBaseControl IO m => m a -> m b -> m ()
+concurrently_ x y = void $ liftBaseWith $ \run -> A.concurrently (run x) (run y)

yesod-websockets/chat.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-}
+import Yesod.Core
+import Yesod.WebSockets
+import qualified Data.Text.Lazy as TL
+import Control.Monad (forever)
+import Control.Monad.Trans.Reader
+import Control.Concurrent (threadDelay)
+import Data.Time
+import Conduit
+import Data.Monoid ((<>))
+import Control.Concurrent.STM.Lifted
+import Data.Text (Text)
+
+data App = App (TChan Text)
+
+instance Yesod App
+
+mkYesod "App" [parseRoutes|
+/ HomeR GET
+|]
+
+chatApp :: WebSocketsT Handler ()
+chatApp = do
+    sendTextData ("Welcome to the chat server, please enter your name." :: Text)
+    name <- receiveData
+    sendTextData $ "Welcome, " <> name
+    App writeChan <- getYesod
+    readChan <- atomically $ do
+        writeTChan writeChan $ name <> " has joined the chat"
+        dupTChan writeChan
+    race_
+        (forever $ atomically (readTChan readChan) >>= sendTextData)
+        (sourceWS $$ mapM_C (\msg ->
+            atomically $ writeTChan writeChan $ name <> ": " <> msg))
+
+getHomeR :: Handler Html
+getHomeR = do
+    webSockets chatApp
+    defaultLayout $ do
+        [whamlet|
+            <div #output>
+            <form #form>
+                <input #input autofocus>
+        |]
+        toWidget [lucius|
+            \#output {
+                width: 600px;
+                height: 400px;
+                border: 1px solid black;
+                margin-bottom: 1em;
+                p {
+                    margin: 0 0 0.5em 0;
+                    padding: 0 0 0.5em 0;
+                    border-bottom: 1px dashed #99aa99;
+                }
+            }
+            \#input {
+                width: 600px;
+                display: block;
+            }
+        |]
+        toWidget [julius|
+            var url = document.URL,
+                output = document.getElementById("output"),
+                form = document.getElementById("form"),
+                input = document.getElementById("input"),
+                conn;
+
+            url = url.replace("http:", "ws:").replace("https:", "wss:");
+            conn = new WebSocket(url);
+
+            conn.onmessage = function(e) {
+                var p = document.createElement("p");
+                p.appendChild(document.createTextNode(e.data));
+                output.appendChild(p);
+            };
+
+            form.addEventListener("submit", function(e){
+                conn.send(input.value);
+                input.value = "";
+                e.preventDefault();
+            });
+        |]
+
+main :: IO ()
+main = do
+    chan <- atomically newBroadcastTChan
+    warp 3000 $ App chan

yesod-websockets/sample.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-}
+import Yesod.Core
+import Yesod.WebSockets
+import qualified Data.Text.Lazy as TL
+import Control.Monad (forever)
+import Control.Monad.Trans.Reader
+import Control.Concurrent (threadDelay)
+import Data.Time
+import Conduit
+
+data App = App
+
+instance Yesod App
+
+mkYesod "App" [parseRoutes|
+/ HomeR GET
+|]
+
+timeSource :: MonadIO m => Source m TL.Text
+timeSource = forever $ do
+    now <- liftIO getCurrentTime
+    yield $ TL.pack $ show now
+    liftIO $ threadDelay 5000000
+
+getHomeR :: Handler Html
+getHomeR = do
+    webSockets $ race_
+        (sourceWS $$ mapC TL.toUpper =$ sinkWSText)
+        (timeSource $$ sinkWSText)
+    defaultLayout $
+        toWidget
+            [julius|
+                var conn = new WebSocket("ws://localhost:3000/");
+                conn.onopen = function() {
+                    document.write("<p>open!</p>");
+                    document.write("<button id=button>Send another message</button>")
+                    document.getElementById("button").addEventListener("click", function(){
+                        var msg = prompt("Enter a message for the server");
+                        conn.send(msg);
+                    });
+                    conn.send("hello world");
+                };
+                conn.onmessage = function(e) {
+                    document.write("<p>" + e.data + "</p>");
+                };
+            |]
+
+main :: IO ()
+main = warp 3000 App

yesod-websockets/yesod-websockets.cabal

@@ -0,0 +1,30 @@
+-- Initial yesod-websockets.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                yesod-websockets
+version:             0.1.0.0
+synopsis:            WebSockets support for Yesod
+description:         WebSockets support for Yesod
+homepage:            https://github.com/yesodweb/yesod
+license:             MIT
+license-file:        LICENSE
+author:              Michael Snoyman
+maintainer:          michael@snoyman.com
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.8
+
+library
+  exposed-modules:     Yesod.WebSockets
+  build-depends:       base              >= 4.5 && < 5
+                     , wai-websockets    >= 2.1
+                     , websockets        >= 0.8
+                     , transformers      >= 0.2
+                     , yesod-core        >= 1.2.7
+                     , monad-control     >= 0.3
+                     , conduit           >= 1.0.15.1
+                     , async             >= 2.0.1.5
+
+source-repository head
+  type:     git
+  location: https://github.com/yesodweb/yesod