diff --git a/.gitignore b/.gitignore index 2a3e8fac..fbd2aee8 100644 --- a/.gitignore +++ b/.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 diff --git a/.travis.yml b/.travis.yml index e249b05e..2f2db5f7 100644 --- a/.travis.yml +++ b/.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 diff --git a/package-list.sh b/package-list.sh index 744f06ec..de729ea4 100644 --- a/package-list.sh +++ b/package-list.sh @@ -3,7 +3,7 @@ pkgs=( ./yesod-routes ./yesod-core ./yesod-json - ./crypto-conduit + ./cryptohash-conduit ./authenticate/authenticate ./yesod-static ./yesod-persistent diff --git a/sources.txt b/sources.txt index 46a8d82b..e06080b6 100644 --- a/sources.txt +++ b/sources.txt @@ -11,3 +11,4 @@ ./yesod ./authenticate ./yesod-eventsource +./yesod-websockets diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index eb12ae59..34c05039 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/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 () diff --git a/yesod-auth/Yesod/Auth/BrowserId.hs b/yesod-auth/Yesod/Auth/BrowserId.hs index ee7617b9..8ac5b15b 100644 --- a/yesod-auth/Yesod/Auth/BrowserId.hs +++ b/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 diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 7270119f..6acf45ee 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/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 - -- 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. + -- 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 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 diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index aeac83a6..df0638c5 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/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 diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index 097cc0fb..60890291 100644 --- a/yesod-bin/Devel.hs +++ b/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 diff --git a/yesod-bin/HsFile.hs b/yesod-bin/HsFile.hs new file mode 100644 index 00000000..29095d85 --- /dev/null +++ b/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) + diff --git a/yesod-bin/hsfiles/mongo.hsfiles b/yesod-bin/hsfiles/mongo.hsfiles index 62a5b71e..80b42e77 100644 --- a/yesod-bin/hsfiles/mongo.hsfiles +++ b/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 - { settingsPort = port - } app + forkIO $ runSettings (setPort port defaultSettings) app loop loop :: IO () diff --git a/yesod-bin/hsfiles/mysql.hsfiles b/yesod-bin/hsfiles/mysql.hsfiles index e956c156..d8d42bac 100644 --- a/yesod-bin/hsfiles/mysql.hsfiles +++ b/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 - { settingsPort = port - } app + forkIO $ runSettings (setPort port defaultSettings) app loop loop :: IO () diff --git a/yesod-bin/hsfiles/postgres-fay.hsfiles b/yesod-bin/hsfiles/postgres-fay.hsfiles index 4ab79c62..c89bdb01 100644 --- a/yesod-bin/hsfiles/postgres-fay.hsfiles +++ b/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 - { settingsPort = port - } app + forkIO $ runSettings (setPort port defaultSettings) app loop loop :: IO () diff --git a/yesod-bin/hsfiles/postgres.hsfiles b/yesod-bin/hsfiles/postgres.hsfiles index 34d80db3..172afe85 100644 --- a/yesod-bin/hsfiles/postgres.hsfiles +++ b/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 - { settingsPort = port - } app + forkIO $ runSettings (setPort port defaultSettings) app loop loop :: IO () diff --git a/yesod-bin/hsfiles/simple.hsfiles b/yesod-bin/hsfiles/simple.hsfiles index dd537b8c..09e4f827 100644 --- a/yesod-bin/hsfiles/simple.hsfiles +++ b/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 - { settingsPort = port - } app + forkIO $ runSettings (setPort port defaultSettings) app loop loop :: IO () diff --git a/yesod-bin/hsfiles/sqlite.hsfiles b/yesod-bin/hsfiles/sqlite.hsfiles index 715e7403..2a294299 100644 --- a/yesod-bin/hsfiles/sqlite.hsfiles +++ b/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 - { settingsPort = port - } app + forkIO $ runSettings (setPort port defaultSettings) app loop loop :: IO () diff --git a/yesod-bin/main.hs b/yesod-bin/main.hs index b860a55a..2202fb54 100755 --- a/yesod-bin/main.hs +++ b/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) diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 95fcfa2f..2f553a06 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/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 @@ -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 diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 7c561c52..54b13650 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/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 diff --git a/yesod-core/Yesod/Core/Internal/Response.hs b/yesod-core/Yesod/Core/Internal/Response.hs index fce9e2e7..3f06ac23 100644 --- a/yesod-core/Yesod/Core/Internal/Response.hs +++ b/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 diff --git a/yesod-core/Yesod/Core/Json.hs b/yesod-core/Yesod/Core/Json.hs index d0c0b383..48855b3f 100644 --- a/yesod-core/Yesod/Core/Json.hs +++ b/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] diff --git a/yesod-core/widget-benchmark.hs b/yesod-core/bench/widget.hs similarity index 52% rename from yesod-core/widget-benchmark.hs rename to yesod-core/bench/widget.hs index 9be4acd8..59b18922 100644 --- a/yesod-core/widget-benchmark.hs +++ b/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| - $forall row <- rows - $forall cell <- row
#{show cell} |] -bigTableHamlet rows = L.length $ renderHamlet id [$hamlet| - $forall row <- rows - $forall cell <- row
#{show cell} |] -bigTableWidget rows = L.length $ renderHtml $ (run [$hamlet| - $forall row <- rows - $forall cell <- row
#{show cell} -|]) (\_ _ -> "foo") +|]) where - run (GWidget w) = - let (_, _, GWData (Body x) _ _ _ _ _ _) = runRWS w () 0 - in x - {- - run (GWidget w) = runIdentity $ do - w' <- flip evalStateT 0 - $ runWriterT $ runWriterT $ runWriterT $ runWriterT - $ runWriterT $ runWriterT $ runWriterT w - let ((((((((), - Body body), - _), - _), - _), - _), - _), - _) = w' + render _ _ = "foo" + run (WidgetT w) = do + (_, GWData { gwdBody = Body x }) <- w undefined + return x - return body - -} - -bigTableBlaze t = L.length $ renderHtml $ table $ mconcat $ map row t +bigTableBlaze t = L.length $ Utf8.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 diff --git a/yesod-core/test/YesodCoreTest.hs b/yesod-core/test/YesodCoreTest.hs index 60a1cb2e..703acda4 100644 --- a/yesod-core/test/YesodCoreTest.hs +++ b/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 diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 333d2b89..0bb294fb 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/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 diff --git a/yesod-core/test/YesodCoreTest/Json.hs b/yesod-core/test/YesodCoreTest/Json.hs index 4ce49651..968df40d 100644 --- a/yesod-core/test/YesodCoreTest/Json.hs +++ b/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) diff --git a/yesod-core/test/YesodCoreTest/RawResponse.hs b/yesod-core/test/YesodCoreTest/RawResponse.hs new file mode 100644 index 00000000..8b768ca2 --- /dev/null +++ b/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") diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 3740f781..634c8cdf 100644 --- a/yesod-core/yesod-core.cabal +++ b/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 @@ -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 diff --git a/yesod-form/Yesod/Form/Bootstrap3.hs b/yesod-form/Yesod/Form/Bootstrap3.hs new file mode 100644 index 00000000..84e85fc8 --- /dev/null +++ b/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': +-- +-- >
+-- > ^{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 +
+ $case formLayout + $of BootstrapBasicForm + $if fvId view /= bootstrapSubmitId +