yesod-form 1.3.7 → 1.3.8
raw patch · 4 files changed
+326/−7 lines, 4 filesdep +byteabledep −crypto-api
Dependencies added: byteable
Dependencies removed: crypto-api
Files
- Yesod/Form/Bootstrap3.hs +262/−0
- Yesod/Form/Fields.hs +1/−1
- Yesod/Form/Functions.hs +60/−4
- yesod-form.cabal +3/−2
+ Yesod/Form/Bootstrap3.hs view
@@ -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/Fields.hs view
@@ -334,7 +334,7 @@ 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/Functions.hs view
@@ -24,6 +24,8 @@ -- * Generate a blank form , generateFormPost , generateFormGet+ -- * More than one form on a handler+ , identifyForm -- * Rendering , FormRender , renderTable@@ -45,10 +47,10 @@ 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@@ -221,7 +223,7 @@ | 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)@@ -285,6 +287,57 @@ 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@@ -334,7 +387,9 @@ |] 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: --@@ -369,6 +424,7 @@ <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)
yesod-form.cabal view
@@ -1,5 +1,5 @@ name: yesod-form-version: 1.3.7+version: 1.3.8 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -35,13 +35,14 @@ , 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