yesod-form 0.4.2.1 → 1.7.9.3
raw patch · 30 files changed
Files
- ChangeLog.md +161/−0
- LICENSE +17/−22
- README.md +15/−0
- Yesod/Form.hs +0/−2
- Yesod/Form/Bootstrap3.hs +311/−0
- Yesod/Form/Class.hs +0/−78
- Yesod/Form/Fields.hs +746/−231
- Yesod/Form/Functions.hs +472/−135
- Yesod/Form/I18n/Chinese.hs +28/−0
- Yesod/Form/I18n/Czech.hs +28/−0
- Yesod/Form/I18n/Dutch.hs +28/−0
- Yesod/Form/I18n/English.hs +3/−1
- Yesod/Form/I18n/French.hs +28/−0
- Yesod/Form/I18n/German.hs +3/−1
- Yesod/Form/I18n/Japanese.hs +28/−0
- Yesod/Form/I18n/Korean.hs +28/−0
- Yesod/Form/I18n/Norwegian.hs +28/−0
- Yesod/Form/I18n/Portuguese.hs +3/−1
- Yesod/Form/I18n/Romanian.hs +31/−0
- Yesod/Form/I18n/Russian.hs +28/−0
- Yesod/Form/I18n/Spanish.hs +28/−0
- Yesod/Form/I18n/Swedish.hs +3/−1
- Yesod/Form/Input.hs +66/−33
- Yesod/Form/Jquery.hs +65/−59
- Yesod/Form/MassInput.hs +43/−39
- Yesod/Form/Nic.hs +31/−40
- Yesod/Form/Option.hs +96/−0
- Yesod/Form/Types.hs +134/−37
- test/main.hs +39/−0
- yesod-form.cabal +58/−24
+ ChangeLog.md view
@@ -0,0 +1,161 @@+# ChangeLog for yesod-form++## 1.7.9.3++* Support `yesod-core` 1.7++## 1.7.9.2++* Improve deprecation messages for `radioField` and `checkboxesField` [#1902](https://github.com/yesodweb/yesod/pull/1902)++## 1.7.9.1++* Set `base >= 4.11` for less CPP and imports [#1876](https://github.com/yesodweb/yesod/pull/1876)++## 1.7.9++* Added `checkboxesField'` for creating checkbox in more correct way than original `checkboxesField`+ Function `checkboxesField` marked as deprecated. [#1843](https://github.com/yesodweb/yesod/pull/1843)++## 1.7.8++* Added `radioField'` for creating radio button in more correct way than original `radioField`.+ Function `radioField` marked as deprecated. [#1842](https://github.com/yesodweb/yesod/pull/1842)++## 1.7.7++* Added `optionsFromList'` to create an OptionList from a List, using the PathPiece instance for the external value and+a custom function for the user-facing value. Also added `optionsEnum'` to create an OptionList from an enumeration+[#1828](https://github.com/yesodweb/yesod/pull/1828)++## 1.7.6++* Added `datetimeLocalField` for creating a html `<input type="datetime-local">` [#1817](https://github.com/yesodweb/yesod/pull/1817)++## 1.7.5++* Add Romanian translation [#1801](https://github.com/yesodweb/yesod/pull/1801)++## 1.7.4++* Added a `Monad AForm` instance only when `transformers` >= 0.6 [#1795](https://github.com/yesodweb/yesod/pull/1795)++## 1.7.3++* Fixed `radioField` according to Bootstrap 3 docs. [#1783](https://github.com/yesodweb/yesod/pull/1783)++## 1.7.2++* Added `withRadioField` and re-express `radioField` into that. [#1775](https://github.com/yesodweb/yesod/pull/1775)++## 1.7.1++* Added `colorField` for creating a html color field (`<input type="color">`) [#1748](https://github.com/yesodweb/yesod/pull/1748)++## 1.7.0++* Extended `OptionList` by `OptionListGrouped` and implemented grouped select fields (`<select>` with `<optgroup>`) [#1722](https://github.com/yesodweb/yesod/pull/1722)++## 1.6.7++* Added equivalent version of `mreqMsg` for `areq` and `wreq` correspondingly [#1628](https://github.com/yesodweb/yesod/pull/1628)++## 1.6.6++* Added `mreqMsg` for `mreq` functionality with a configurable MsgValueRequired [#1613](https://github.com/yesodweb/yesod/pull/1613)++## 1.6.5++* Add `.sr-only` to labels in `renderBootstrap3` when they are null.++## 1.6.4++* Make FormResult an instance of Eq++## 1.6.3++* make sure a select field does not lose the selected value even if a validation on the+ field fails++## 1.6.2++* Move `addClass` from private/undocumented in `Yesod.Form.Bootstrap3` to `Yesod.Form.Functions` [#1510](https://github.com/yesodweb/yesod/pull/1510)+* Add `Yesod.Form.Functions.removeClass` [#1510](https://github.com/yesodweb/yesod/pull/1510)+* Changed `Textarea` to derive `IsString` [#1514](https://github.com/yesodweb/yesod/pull/1514)+* Expose `selectFieldHelper` [#1530](https://github.com/yesodweb/yesod/pull/1530)++## 1.6.1++* Explicitly define `(<>)` in the `Semigroup` instance for `Enctype`++## 1.6.0++* Upgrade to yesod-core 1.6.0++## 1.4.16++* Korean translation++## 1.4.15++* Added `Alternative` instance to `FormResult` to simplify handling pages with multiple forms.++## 1.4.14++* Added `WForm` to reduce the verbosity using monadic forms.+* Added `wreq` and `wopt` correspondent functions for `WForm`.++## 1.4.13++* Fixed `textareaField` `writeHtmlEscapedChar` trim "\r"++## 1.4.12++* Password field does not remember its previous value++## 1.4.11++* Fix warnings+* Fixed spelling errors and wording for `Yesod.Form.Functions.convertField`'s+ documentation++## 1.4.10++* Fixed `identifyForm` to properly return `FormMissing` for empty forms. [#1072](https://github.com/yesodweb/yesod/issues/1072)++## 1.4.9++* Added a `ToValue` instance for `Enctype` [#1296](https://github.com/yesodweb/yesod/pull/1296)++## 1.4.8++* Added Yesod.Form.I18n.Spanish++## 1.4.6++* Functor instances for Option/OptionList++## 1.4.5++* Foldable/Traversable instances for FormResult [#1089](https://github.com/yesodweb/yesod/pull/1089)++## 1.4.4.1++* runFormPost has wrong behavior for empty forms [#950](https://github.com/yesodweb/yesod/issues/950)++## 1.4.4++* Add a `Semigroup` instance++## 1.4.3++Added `jqueryDatePickerDayField`.++## 1.4.2.1++Documentation updates++## 1.4.2++Added `timeFieldTypeTime` and `timeFieldTypeText`, and deprecated `timeField`+itself.
LICENSE view
@@ -1,25 +1,20 @@-The following license covers this documentation, and the source code, except-where otherwise indicated.--Copyright 2010, Michael Snoyman. All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ -* Redistributions of source code must retain the above copyright notice, this- list of conditions and the following disclaimer.+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: -* Redistributions in binary form must reproduce the above copyright notice,- this list of conditions and the following disclaimer in the documentation- and/or other materials provided with the distribution.+The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR-IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO-EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,-INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT-NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,-OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF-LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE-OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF-ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+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.
+ README.md view
@@ -0,0 +1,15 @@+## yesod-form++Form handling for Yesod, in the same style as formlets. See [the forms+chapter](http://www.yesodweb.com/book/forms) of the Yesod book.++This package provides a set of basic form inputs such as text, number, time,+checkbox, select, textarea, and etc. via `Yesod.Form.Fields` module. Also,+there is `Yesod.Form.Nic` module providing richtext field using Nic editor.+However, this module is grandfathered now and Nic editor is not actively+maintained since June 2012. You can find additional richtext editor fields in+[`yesod-form-richtext`][yesod-form-richtext] package (currently in provides+support of [Summernote][summernote] editor only).++[yesod-form-richtext]:http://hackage.haskell.org/package/yesod-form-richtext+[summernote]:http://summernote.org/
Yesod/Form.hs view
@@ -3,12 +3,10 @@ ( module Yesod.Form.Types , module Yesod.Form.Functions , module Yesod.Form.Fields- , module Yesod.Form.Class , module Yesod.Form.Input ) where import Yesod.Form.Types import Yesod.Form.Functions import Yesod.Form.Fields hiding (FormMessage (..))-import Yesod.Form.Class import Yesod.Form.Input
+ Yesod/Form/Bootstrap3.hs view
@@ -0,0 +1,311 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- | Helper functions for creating forms when using <http://getbootstrap.com/ Bootstrap 3>.+--++module Yesod.Form.Bootstrap3+ ( -- * Example: Rendering a basic form+ -- $example++ -- * Example: Rendering a horizontal form+ -- $example2++ -- * Rendering forms+ renderBootstrap3+ , BootstrapFormLayout(..)+ , BootstrapGridOptions(..)+ -- * Field settings+ -- $fieldSettings+ , 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 qualified Text.Blaze.Internal as Blaze+import Yesod.Core+import Yesod.Form.Types+import Yesod.Form.Functions++-- | Create a new 'FieldSettings' with the @form-control@ class that is+-- 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)+++-- | 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 -- ^ A form with labels and inputs listed vertically. See <http://getbootstrap.com/css/#forms-example>+ | BootstrapInlineForm -- ^ A form whose @\<inputs>@ are laid out horizontally (displayed as @inline-block@). For this layout, @\<label>@s are still added to the HTML, but are hidden from display. When using this layout, you must add the @form-inline@ class to your form tag. See <http://getbootstrap.com/css/#forms-inline>+ | BootstrapHorizontalForm+ { bflLabelOffset :: !BootstrapGridOptions -- ^ The left <http://getbootstrap.com/css/#grid-offsetting offset> of the @\<label>@.+ , bflLabelSize :: !BootstrapGridOptions -- ^ The number of grid columns the @\<label>@ should use.+ , bflInputOffset :: !BootstrapGridOptions -- ^ The left <http://getbootstrap.com/css/#grid-offsetting offset> of the @\<input>@ from its @\<label>@.+ , bflInputSize :: !BootstrapGridOptions -- ^ The number of grid columns the @\<input>@ should use.+ } -- ^ A form laid out using the Bootstrap grid, with labels in the left column and inputs on the right. When using this layout, you must add the @form-horizontal@ class to your form tag. Bootstrap requires additional markup for the submit button for horizontal forms; you can use 'bootstrapSubmit' in your form or write the markup manually. See <http://getbootstrap.com/css/#forms-horizontal>+ deriving (Show)+++-- | Render the given form using Bootstrap v3 conventions.+--+-- 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 :Blaze.null (fvLabel view):.sr-only 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 :Blaze.null (fvLabel view):.sr-only .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 -> WidgetFor site ()+helpWidget view = [whamlet|+ $maybe tt <- fvTooltip view+ <span .help-block>#{tt}+ $maybe err <- fvErrors view+ <span .help-block .error-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" :: BootstrapSubmit Text)+--+-- (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"++-- $example+-- @\<input\>@ tags in Bootstrap 3 require the @form-control@ class,+-- and so they need modified 'FieldSettings' to display correctly.+--+-- When creating your forms, use the 'bfs' function to add this class:+--+-- > personForm :: AForm Handler Person+-- > personForm = Person+-- > <$> areq textField (bfs ("Name" :: Text)) Nothing+-- > <*> areq textField (bfs ("Surname" :: Text)) Nothing+--+-- That form can then be rendered into a widget using the 'renderBootstrap3' function. Here, the form is laid out vertically using 'BootstrapBasicForm':+--+-- > (formWidget, formEnctype) <- generateFormPost $ renderBootstrap3 BootstrapBasicForm personForm+--+-- And then used in Hamlet:+--+-- > <form role=form method=post action=@{ActionR} enctype=#{formEnctype}>+-- > ^{formWidget}+-- > <button type="submit" .btn .btn-default>Submit++-- $example2+-- Yesod.Form.Bootstrap3 also supports <http://getbootstrap.com/css/#forms-horizontal horizontal, grid based forms>.+-- These forms require additional markup for the submit tag, which is provided by the 'bootstrapSubmit' function:+--+-- > personForm :: AForm Handler Person+-- > personForm = Person+-- > <$> areq textField MsgName Nothing+-- > <*> areq textField MsgSurname Nothing+-- > <* bootstrapSubmit (BootstrapSubmit MsgSubmit "btn-default" [("attribute-name","attribute-value")])+-- > -- Note: bootstrapSubmit works with all BootstrapFormLayouts, but provides the additional markup required for Bootstrap's horizontal forms.+--+-- That form can be rendered with specific grid spacing:+--+-- > (formWidget, formEnctype) <- generateFormPost $ renderBootstrap3 (BootstrapHorizontalForm (ColSm 0) (ColSm 4) (ColSm 0) (ColSm 6)) personForm+--+-- And then used in Hamlet. Note the additional @form-horizontal@ class on the form, and that a manual submit tag isn't required:+--+-- > <form .form-horizontal role=form method=post action=@{ActionR} enctype=#{formEnctype}>+-- > ^{formWidget}++-- $fieldSettings+-- This module comes with several methods to help customize your Bootstrap 3 @\<input\>@s.+-- These functions can be chained together to apply several properties to an input:+--+-- > userForm :: AForm Handler UserForm+-- > userForm = UserForm+-- > <$> areq textField nameSettings Nothing+-- > where nameSettings = withAutofocus $+-- > withPlaceholder "First name" $+-- > (bfs ("Name" :: Text))
− Yesod/Form/Class.hs
@@ -1,78 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleContexts #-}-module Yesod.Form.Class- ( {- FIXME ToForm (..)- , -} ToField (..)- ) where--import Text.Hamlet-import Yesod.Form.Fields-import Yesod.Form.Types-import Yesod.Form.Functions (areq, aopt)-import Data.Int (Int64)-import Data.Time (Day, TimeOfDay)-import Data.Text (Text)-import Yesod.Message (RenderMessage)--{--class ToForm a where- toForm :: AForm sub master a--}--class ToField a master where- toField :: (RenderMessage master msg, RenderMessage master FormMessage)- => FieldSettings msg -> Maybe a -> AForm sub master a--{- FIXME-instance ToFormField String y where- toFormField = stringField-instance ToFormField (Maybe String) y where- toFormField = maybeStringField--}--instance ToField Text master where- toField = areq textField-instance ToField (Maybe Text) master where- toField = aopt textField--instance ToField Int master where- toField = areq intField-instance ToField (Maybe Int) master where- toField = aopt intField--instance ToField Int64 master where- toField = areq intField-instance ToField (Maybe Int64) master where- toField = aopt intField--instance ToField Double master where- toField = areq doubleField-instance ToField (Maybe Double) master where- toField = aopt doubleField--instance ToField Day master where- toField = areq dayField-instance ToField (Maybe Day) master where- toField = aopt dayField--instance ToField TimeOfDay master where- toField = areq timeField-instance ToField (Maybe TimeOfDay) master where- toField = aopt timeField--instance ToField Html master where- toField = areq htmlField-instance ToField (Maybe Html) master where- toField = aopt htmlField--instance ToField Textarea master where- toField = areq textareaField-instance ToField (Maybe Textarea) master where- toField = aopt textareaField--{- FIXME-instance ToFormField Bool y where- toFormField = boolField--}
Yesod/Form/Fields.hs view
@@ -1,9 +1,18 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- | Field functions allow you to easily create and validate forms, cleanly handling the uncertainty of parsing user input.+--+-- When possible, the field functions use a specific input type (e.g. "number"), allowing supporting browsers to validate the input before form submission. Browsers can also improve usability with this information; for example, mobile browsers might present a specialized keyboard for an input of type "email" or "number".+--+-- See the Yesod book <http://www.yesodweb.com/book/forms chapter on forms> for a broader overview of forms in Yesod. module Yesod.Form.Fields ( -- * i18n FormMessage (..)@@ -16,8 +25,11 @@ , intField , dayField , timeField+ , timeFieldTypeTime+ , timeFieldTypeText , htmlField , emailField+ , multiEmailField , searchField , AutoFocus , urlField@@ -27,133 +39,175 @@ , Textarea (..) , boolField , checkBoxField+ , fileField -- * File 'AForm's , fileAFormReq , fileAFormOpt -- * Options+ -- $optionsOverview+ , selectFieldHelper , selectField , selectFieldList+ , selectFieldListGrouped , radioField+ , radioField' , radioFieldList+ , withRadioField+ , checkboxesField+ , checkboxesField'+ , checkboxesFieldList , multiSelectField , multiSelectFieldList , Option (..) , OptionList (..) , mkOptionList+ , mkOptionListGrouped , optionsPersist+ , optionsPersistKey , optionsPairs+ , optionsPairsGrouped , optionsEnum+ , colorField+ , datetimeLocalField ) where import Yesod.Form.Types import Yesod.Form.I18n.English-import Yesod.Handler (getMessageRender)-import Yesod.Widget-import Yesod.Message (RenderMessage (renderMessage), SomeMessage (..))-import Text.Hamlet-import Text.Blaze (ToHtml (..), preEscapedText, unsafeByteString)-import Text.Cassius-import Data.Time (Day, TimeOfDay(..))+import Yesod.Form.Functions (parseHelper)+import Yesod.Core+import Text.Blaze (ToMarkup (toMarkup), unsafeByteString)+#define ToHtml ToMarkup+#define toHtml toMarkup+#define preEscapedText preEscapedToMarkup+import Data.Time (Day, TimeOfDay(..), LocalTime (LocalTime)) import qualified Text.Email.Validate as Email+import Data.Text.Encoding (encodeUtf8, decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode) import Network.URI (parseURI)-import Database.Persist (PersistField)-import Database.Persist.Store (Entity (..))+import Database.Persist.Sql (PersistField, PersistFieldSql (..))+#if MIN_VERSION_persistent(2,5,0)+import Database.Persist (Entity (..), SqlType (SqlString), PersistRecordBackend, PersistQueryRead)+#else+import Database.Persist (Entity (..), SqlType (SqlString), PersistEntity, PersistQuery, PersistEntityBackend)+#endif import Text.HTML.SanitizeXSS (sanitizeBalance)-import Control.Monad (when, unless)-import Data.Maybe (listToMaybe)+import Control.Monad (when, unless, forM_)+import Data.Either (partitionEithers)+import Data.Maybe (listToMaybe, fromMaybe) import qualified Blaze.ByteString.Builder.Html.Utf8 as B import Blaze.ByteString.Builder (writeByteString, toLazyByteString) import Blaze.ByteString.Builder.Internal.Write (fromWriteList)-import Database.Persist.Store (PersistEntityBackend) -import Text.Blaze.Renderer.String (renderHtml)+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 qualified Data.Text as T+import Data.Text as T ( Text, append, concat, cons, head+ , intercalate, isPrefixOf, null, unpack, pack+ , split, splitOn+ )+import qualified Data.Text as T (drop, dropWhile) import qualified Data.Text.Read import qualified Data.Map as Map-import Yesod.Handler (newIdent, lift)-import Yesod.Request (FileInfo)--import Yesod.Core (toPathPiece, GHandler, PathPiece)-import Yesod.Persist (selectList, runDB, Filter, SelectOpt, YesodPersistBackend, Key, YesodPersist, PersistEntity, PersistQuery)+import Yesod.Persist (selectList, Filter, SelectOpt, Key) import Control.Arrow ((&&&)) -#if __GLASGOW_HASKELL__ >= 700-#define WHAMLET whamlet-#define HAMLET hamlet-#define CASSIUS cassius-#define JULIUS julius-#define HTML html-#else-#define WHAMLET $whamlet-#define HAMLET $hamlet-#define CASSIUS $cassius-#define JULIUS $julius-#define HTML $html-#endif+import Control.Applicative ((<|>)) -import Control.Applicative ((<$>))+import Data.Attoparsec.Text (Parser, char, string, digit, skipSpace, endOfInput, parseOnly) +import Yesod.Persist.Core++import Data.String (IsString)+++import Data.Char (isHexDigit)++{-# DEPRECATED radioField "This function seems to have a bug (label could not be found with byLabel algorithm). Use radioField' instead." #-}+{-# DEPRECATED checkboxesField "This function seems to have a bug (label could not be found with byLabel algorithm). Use checkboxesField' instead." #-}+ defaultFormMessage :: FormMessage -> Text defaultFormMessage = englishFormMessage -blank :: (Monad m, RenderMessage master FormMessage)- => (Text -> Either FormMessage a) -> [Text] -> m (Either (SomeMessage master) (Maybe a))-blank _ [] = return $ Right Nothing-blank _ ("":_) = return $ Right Nothing-blank f (x:_) = return $ either (Left . SomeMessage) (Right . Just) $ f x--intField :: (Integral i, RenderMessage master FormMessage) => Field sub master i+-- | Creates a input with @type="number"@ and @step=1@.+intField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Field m i intField = Field- { fieldParse = blank $ \s ->+ { fieldParse = parseHelper $ \s -> case Data.Text.Read.signed Data.Text.Read.decimal s of Right (a, "") -> Right a _ -> Left $ MsgInvalidInteger s - , fieldView = \theId name theClass val isReq -> addHamlet- [HAMLET|\-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="number" :isReq:required="" value="#{showVal val}">+ , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+$newline never+<input id="#{theId}" name="#{name}" *{attrs} type="number" step=1 :isReq:required="" value="#{showVal val}"> |]+ , fieldEnctype = UrlEncoded } where showVal = either id (pack . showI) showI x = show (fromIntegral x :: Integer) -doubleField :: RenderMessage master FormMessage => Field sub master Double+-- | Creates a input with @type="number"@ and @step=any@.+doubleField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Double doubleField = Field- { fieldParse = blank $ \s ->- case Data.Text.Read.double s of+ { fieldParse = parseHelper $ \s ->+ case Data.Text.Read.double (prependZero s) of Right (a, "") -> Right a _ -> Left $ MsgInvalidNumber s - , fieldView = \theId name theClass val isReq -> addHamlet- [HAMLET|\-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="text" :isReq:required="" value="#{showVal val}">+ , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+$newline never+<input id="#{theId}" name="#{name}" *{attrs} type="number" step=any :isReq:required="" value="#{showVal val}"> |]+ , fieldEnctype = UrlEncoded } where showVal = either id (pack . show) -dayField :: RenderMessage master FormMessage => Field sub master Day+-- | Creates an input with @type="date"@, validating the input using the 'parseDate' function.+--+-- Add the @time@ package and import the "Data.Time.Calendar" module to use this function.+dayField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Day dayField = Field- { fieldParse = blank $ parseDate . unpack- , fieldView = \theId name theClass val isReq -> addHamlet- [HAMLET|\-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="date" :isReq:required="" value="#{showVal val}">+ { fieldParse = parseHelper $ parseDate . unpack+ , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+$newline never+<input id="#{theId}" name="#{name}" *{attrs} type="date" :isReq:required="" value="#{showVal val}"> |]+ , fieldEnctype = UrlEncoded } where showVal = either id (pack . show) -timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay-timeField = Field- { fieldParse = blank $ parseTime . unpack- , fieldView = \theId name theClass val isReq -> addHamlet- [HAMLET|\-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate "" theClass}" :isReq:required="" value="#{showVal val}">+-- | An alias for 'timeFieldTypeTime'.+timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay+timeField = timeFieldTypeTime++-- | Creates an input with @type="time"@. <http://caniuse.com/#search=time%20input%20type Browsers not supporting this type> will fallback to a text field, and Yesod will parse the time as described in 'timeFieldTypeText'.+--+-- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.+--+-- @since 1.4.2+timeFieldTypeTime :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay+timeFieldTypeTime = timeFieldOfType "time"++-- | Creates an input with @type="text"@, parsing the time from an [H]H:MM[:SS] format, with an optional AM or PM (if not given, AM is assumed for compatibility with the 24 hour clock system).+--+-- This function exists for backwards compatibility with the old implementation of 'timeField', which used to use @type="text"@. Consider using 'timeField' or 'timeFieldTypeTime' for improved UX and validation from the browser.+--+-- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.+--+-- @since 1.4.2+timeFieldTypeText :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay+timeFieldTypeText = timeFieldOfType "text"++timeFieldOfType :: Monad m => RenderMessage (HandlerSite m) FormMessage => Text -> Field m TimeOfDay+timeFieldOfType inputType = Field+ { fieldParse = parseHelper parseTime+ , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+$newline never+<input id="#{theId}" name="#{name}" *{attrs} type="#{inputType}" :isReq:required="" value="#{showVal val}"> |]+ , fieldEnctype = UrlEncoded } where showVal = either id (pack . show . roundFullSeconds)@@ -162,21 +216,27 @@ where fullSec = fromInteger $ floor $ todSec tod -htmlField :: RenderMessage master FormMessage => Field sub master Html+-- | Creates a @\<textarea>@ tag whose input is sanitized to prevent XSS attacks and is validated for having balanced tags.+htmlField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Html htmlField = Field- { fieldParse = blank $ Right . preEscapedText . sanitizeBalance- , fieldView = \theId name theClass val _isReq -> addHamlet- -- FIXME: There was a class="html" attribute, for what purpose?- [HAMLET|\-<textarea id="#{theId}" name="#{name}" :not (null theClass):class=#{T.intercalate " " theClass}>#{showVal val}+ { fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance+ , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+$newline never+<textarea :isReq:required="" id="#{theId}" name="#{name}" *{attrs}>#{showVal val} |]+ , fieldEnctype = UrlEncoded } where showVal = either id (pack . renderHtml) --- | A newtype wrapper around a 'Text' that converts newlines to HTML--- br-tags.+-- | A newtype wrapper around a 'Text' whose 'ToMarkup' instance converts newlines to HTML @\<br>@ tags.+--+-- (When text is entered into a @\<textarea>@, newline characters are used to separate lines.+-- If this text is then placed verbatim into HTML, the lines won't be separated, thus the need for replacing with @\<br>@ tags).+-- If you don't need this functionality, simply use 'unTextarea' to access the raw text. newtype Textarea = Textarea { unTextarea :: Text }- deriving (Show, Read, Eq, PersistField)+ deriving (Show, Read, Eq, PersistField, Ord, ToJSON, FromJSON, IsString)+instance PersistFieldSql Textarea where+ sqlType _ = SqlString instance ToHtml Textarea where toHtml = unsafeByteString@@ -188,50 +248,61 @@ . unTextarea where -- Taken from blaze-builder and modified with newline handling.+ writeHtmlEscapedChar '\r' = mempty writeHtmlEscapedChar '\n' = writeByteString "<br>" writeHtmlEscapedChar c = B.writeHtmlEscapedChar c -textareaField :: RenderMessage master FormMessage => Field sub master Textarea+-- | Creates a @\<textarea>@ tag whose returned value is wrapped in a 'Textarea'; see 'Textarea' for details.+textareaField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Textarea textareaField = Field- { fieldParse = blank $ Right . Textarea- , fieldView = \theId name theClass val _isReq -> addHamlet- [HAMLET|\-<textarea id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}">#{either id unTextarea val}+ { fieldParse = parseHelper $ Right . Textarea+ , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+$newline never+<textarea id="#{theId}" name="#{name}" :isReq:required="" *{attrs}>#{either id unTextarea val} |]+ , fieldEnctype = UrlEncoded } -hiddenField :: RenderMessage master FormMessage => Field sub master Text+-- | Creates an input with @type="hidden"@; you can use this to store information in a form that users shouldn't see (for example, Yesod stores CSRF tokens in a hidden field).+hiddenField :: (Monad m, PathPiece p, RenderMessage (HandlerSite m) FormMessage)+ => Field m p hiddenField = Field- { fieldParse = blank $ Right- , fieldView = \theId name theClass val _isReq -> addHamlet- [HAMLET|\-<input type="hidden" id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" value="#{either id id val}">+ { fieldParse = parseHelper $ maybe (Left MsgValueRequired) Right . fromPathPiece+ , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|+$newline never+<input type="hidden" id="#{theId}" name="#{name}" *{attrs} value="#{either id toPathPiece val}"> |]+ , fieldEnctype = UrlEncoded } -textField :: RenderMessage master FormMessage => Field sub master Text+-- | Creates a input with @type="text"@.+textField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text textField = Field- { fieldParse = blank $ Right- , fieldView = \theId name theClass val isReq ->- [WHAMLET|-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="text" :isReq:required value="#{either id id val}">+ { fieldParse = parseHelper $ Right+ , fieldView = \theId name attrs val isReq ->+ [whamlet|+$newline never+<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required value="#{either id id val}"> |]+ , fieldEnctype = UrlEncoded }--passwordField :: RenderMessage master FormMessage => Field sub master Text+-- | Creates an input with @type="password"@.+passwordField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text passwordField = Field- { fieldParse = blank $ Right- , fieldView = \theId name theClass val isReq -> addHamlet- [HAMLET|\-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="password" :isReq:required="" value="#{either id id val}">+ { fieldParse = parseHelper $ Right+ , fieldView = \theId name attrs _ isReq -> toWidget [hamlet|+$newline never+<input id="#{theId}" name="#{name}" *{attrs} type="password" :isReq:required=""> |]+ , fieldEnctype = UrlEncoded } readMay :: Read a => String -> Maybe a-readMay s = case reads s of+readMay s = case filter (Prelude.null . snd) $ reads s of (x, _):_ -> Just x [] -> Nothing +-- | Parses a 'Day' from a 'String'. parseDate :: String -> Either FormMessage Day parseDate = maybe (Left MsgInvalidDay) Right . readMay . replace '/' '-'@@ -241,102 +312,191 @@ replace :: Eq a => a -> a -> [a] -> [a] replace x y = map (\z -> if z == x then y else z) -parseTime :: String -> Either FormMessage TimeOfDay-parseTime (h2:':':m1:m2:[]) = parseTimeHelper ('0', h2, m1, m2, '0', '0')-parseTime (h1:h2:':':m1:m2:[]) = parseTimeHelper (h1, h2, m1, m2, '0', '0')-parseTime (h1:h2:':':m1:m2:' ':'A':'M':[]) =- parseTimeHelper (h1, h2, m1, m2, '0', '0')-parseTime (h1:h2:':':m1:m2:' ':'P':'M':[]) =- let [h1', h2'] = show $ (read [h1, h2] :: Int) + 12- in parseTimeHelper (h1', h2', m1, m2, '0', '0')-parseTime (h1:h2:':':m1:m2:':':s1:s2:[]) =- parseTimeHelper (h1, h2, m1, m2, s1, s2)-parseTime _ = Left MsgInvalidTimeFormat+parseTime :: Text -> Either FormMessage TimeOfDay+parseTime = either (Left . fromMaybe MsgInvalidTimeFormat . readMay . drop 2 . dropWhile (/= ':')) Right . parseOnly timeParser -parseTimeHelper :: (Char, Char, Char, Char, Char, Char)- -> Either FormMessage TimeOfDay-parseTimeHelper (h1, h2, m1, m2, s1, s2)- | h < 0 || h > 23 = Left $ MsgInvalidHour $ pack [h1, h2]- | m < 0 || m > 59 = Left $ MsgInvalidMinute $ pack [m1, m2]- | s < 0 || s > 59 = Left $ MsgInvalidSecond $ pack [s1, s2]- | otherwise = Right $ TimeOfDay h m s+timeParser :: Parser TimeOfDay+timeParser = do+ skipSpace+ h <- hour+ _ <- char ':'+ m <- minsec MsgInvalidMinute+ hasSec <- (char ':' >> return True) <|> return False+ s <- if hasSec then minsec MsgInvalidSecond else return 0+ skipSpace+ isPM <-+ (string "am" >> return (Just False)) <|>+ (string "AM" >> return (Just False)) <|>+ (string "pm" >> return (Just True)) <|>+ (string "PM" >> return (Just True)) <|>+ return Nothing+ h' <-+ case isPM of+ Nothing -> return h+ Just x+ | h <= 0 || h > 12 -> fail $ show $ MsgInvalidHour $ pack $ show h+ | h == 12 -> return $ if x then 12 else 0+ | otherwise -> return $ h + (if x then 12 else 0)+ skipSpace+ endOfInput+ return $ TimeOfDay h' m s where- h = read [h1, h2] -- FIXME isn't this a really bad idea?- m = read [m1, m2]- s = fromInteger $ read [s1, s2]+ hour = do+ x <- digit+ y <- (return <$> digit) <|> return []+ let xy = x : y+ let i = read xy+ if i < 0 || i >= 24+ then fail $ show $ MsgInvalidHour $ pack xy+ else return i+ minsec :: Num a => (Text -> FormMessage) -> Parser a+ minsec msg = do+ x <- digit+ y <- digit <|> fail (show $ msg $ pack [x])+ let xy = [x, y]+ let i = read xy+ if i < 0 || i >= 60+ then fail $ show $ msg $ pack xy+ else return $ fromIntegral (i :: Int) -emailField :: RenderMessage master FormMessage => Field sub master Text+-- | Creates an input with @type="email"@. Yesod will validate the email's correctness according to RFC5322 and canonicalize it by removing comments and whitespace (see "Text.Email.Validate").+emailField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text emailField = Field- { fieldParse = blank $- \s -> if Email.isValid (unpack s)- then Right s- else Left $ MsgInvalidEmail s- , fieldView = \theId name theClass val isReq -> addHamlet- [HAMLET|\-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="email" :isReq:required="" value="#{either id id val}">+ { fieldParse = parseHelper $+ \s ->+ case Email.canonicalizeEmail $ encodeUtf8 s of+ Just e -> Right $ decodeUtf8With lenientDecode e+ Nothing -> Left $ MsgInvalidEmail s+ , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+$newline never+<input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{either id id val}"> |]+ , fieldEnctype = UrlEncoded } +-- | Creates an input with @type="email"@ with the <http://w3c.github.io/html/sec-forms.html#the-multiple-attribute multiple> attribute; browsers might implement this as taking a comma separated list of emails. Each email address is validated as described in 'emailField'.+--+-- @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 :: RenderMessage master FormMessage => AutoFocus -> Field sub master Text+-- | Creates an input with @type="search"@. For <http://caniuse.com/#search=autofocus browsers without autofocus support>, a JS fallback is used if @AutoFocus@ is true.+searchField :: Monad m => RenderMessage (HandlerSite m) FormMessage => AutoFocus -> Field m Text searchField autoFocus = Field- { fieldParse = blank Right- , fieldView = \theId name theClass val isReq -> do- [WHAMLET|\-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">+ { fieldParse = parseHelper Right+ , fieldView = \theId name attrs val isReq -> do+ [whamlet|+$newline never+<input id="#{theId}" name="#{name}" *{attrs} type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}"> |] when autoFocus $ do -- we want this javascript to be placed immediately after the field- [WHAMLET|\<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}</script> + [whamlet|+$newline never+<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();} |]- addCassius [CASSIUS|- #{theId}+ toWidget [cassius|+ ##{theId} -webkit-appearance: textfield |]+ , fieldEnctype = UrlEncoded }--urlField :: RenderMessage master FormMessage => Field sub master Text+-- | Creates an input with @type="url"@, validating the URL according to RFC3986.+urlField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text urlField = Field- { fieldParse = blank $ \s ->+ { fieldParse = parseHelper $ \s -> case parseURI $ unpack s of Nothing -> Left $ MsgInvalidUrl s Just _ -> Right s- , fieldView = \theId name theClass val isReq ->- [WHAMLET|-<input ##{theId} name=#{name} :not (null theClass):class="#{T.intercalate " " theClass}" type=url :isReq:required value=#{either id id val}>-|]+ , fieldView = \theId name attrs val isReq ->+ [whamlet|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id id val}>|]+ , fieldEnctype = UrlEncoded } -selectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master a+-- | Creates a @\<select>@ tag for selecting one option. Example usage:+--+-- > areq (selectFieldList [("Value 1" :: Text, "value1"),("Value 2", "value2")]) "Which value?" Nothing+selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)+ => [(msg, a)]+ -> Field (HandlerFor site) a selectFieldList = selectField . optionsPairs -selectField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a+-- | Creates a @\<select>@ tag with @\<optgroup>@s for selecting one option.+--+-- @since 1.7.0+selectFieldListGrouped :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)+ => [(msg, [(msg, a)])]+ -> Field (HandlerFor site) a+selectFieldListGrouped = selectField . optionsPairsGrouped++-- | Creates a @\<select>@ tag with optional @\<optgroup>@s for selecting one option. Example usage:+--+-- > areq (selectField $ optionsPairs [(MsgValue1, "value1"),(MsgValue2, "value2")]) "Which value?" Nothing+selectField :: (Eq a, RenderMessage site FormMessage)+ => HandlerFor site (OptionList a)+ -> Field (HandlerFor site) a selectField = selectFieldHelper- (\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|]) -- outside- (\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|]) -- onOpt- (\_theId _name theClass value isSel text -> [WHAMLET|<option value=#{value} :isSel:selected :not (null theClass):class="#{T.intercalate " " theClass}">#{text}|]) -- inside+ (\theId name attrs inside -> [whamlet|+$newline never+<select ##{theId} name=#{name} *{attrs}>^{inside}+|]) -- outside+ (\_theId _name isSel -> [whamlet|+$newline never+<option value=none :isSel:selected>_{MsgSelectNone}+|]) -- onOpt+ (\_theId _name _attrs value isSel text -> [whamlet|+$newline never+<option value=#{value} :isSel:selected>#{text}+|]) -- inside+ (Just $ \label -> [whamlet|+<optgroup label=#{label}>+|]) -- group label -multiSelectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master [a]+-- | Creates a @\<select>@ tag for selecting multiple options.+multiSelectFieldList :: (Eq a, RenderMessage site msg)+ => [(msg, a)]+ -> Field (HandlerFor site) [a] multiSelectFieldList = multiSelectField . optionsPairs -multiSelectField :: (Eq a, RenderMessage master FormMessage)- => GHandler sub master (OptionList a)- -> Field sub master [a]+-- | Creates a @\<select>@ tag for selecting multiple options.+multiSelectField :: Eq a+ => HandlerFor site (OptionList a)+ -> Field (HandlerFor site) [a] multiSelectField ioptlist =- Field parse view+ Field parse view UrlEncoded where- parse [] = return $ Right Nothing- parse optlist = do+ parse [] _ = return $ Right Nothing+ parse optlist _ = do mapopt <- olReadExternal <$> ioptlist case mapM mapopt optlist of Nothing -> return $ Left "Error parsing values" Just res -> return $ Right $ Just res - view theId name theClass val isReq = do- opts <- fmap olOptions $ lift ioptlist+ view theId name attrs val isReq = do+ opts <- fmap olOptions $ handlerToWidget ioptlist let selOpts = map (id &&& (optselected val)) opts [whamlet|- <select ##{theId} name=#{name} :isReq:required multiple :not (null theClass):class=#{T.intercalate " " theClass}>+ <select ##{theId} name=#{name} :isReq:required multiple *{attrs}> $forall (opt, optsel) <- selOpts <option value=#{optionExternalValue opt} :optsel:selected>#{optionDisplay opt} |]@@ -344,38 +504,152 @@ optselected (Left _) _ = False optselected (Right vals) opt = (optionInternalValue opt) `elem` vals -radioFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master a+-- | Creates an input with @type="radio"@ for selecting one option.+radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)+ => [(msg, a)]+ -> Field (HandlerFor site) a radioFieldList = radioField . optionsPairs -radioField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a-radioField = selectFieldHelper- (\theId _name inside -> [WHAMLET|<div ##{theId}>^{inside}|])- (\theId name isSel -> [WHAMLET|-<div>- <input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>- <label for=#{theId}-none>_{MsgSelectNone}+-- | Creates an input with @type="checkbox"@ for selecting multiple options.+checkboxesFieldList :: (Eq a, RenderMessage site msg) => [(msg, a)]+ -> Field (HandlerFor site) [a]+checkboxesFieldList = checkboxesField . optionsPairs++-- | Creates an input with @type="checkbox"@ for selecting multiple options.+checkboxesField :: Eq a+ => HandlerFor site (OptionList a)+ -> Field (HandlerFor site) [a]+checkboxesField ioptlist = (multiSelectField ioptlist)+ { fieldView =+ \theId name attrs val _isReq -> do+ opts <- fmap olOptions $ handlerToWidget ioptlist+ let optselected (Left _) _ = False+ optselected (Right vals) opt = (optionInternalValue opt) `elem` vals+ [whamlet|+ <span ##{theId}>+ $forall opt <- opts+ <label>+ <input type=checkbox name=#{name} value=#{optionExternalValue opt} *{attrs} :optselected val opt:checked>+ #{optionDisplay opt}+ |]+ }++-- | Creates an input with @type="checkbox"@ for selecting multiple options.+checkboxesField' :: Eq a+ => HandlerFor site (OptionList a)+ -> Field (HandlerFor site) [a]+checkboxesField' ioptlist = (multiSelectField ioptlist)+ { fieldView =+ \theId name attrs val _isReq -> do+ opts <- olOptions <$> handlerToWidget ioptlist+ let optselected (Left _) _ = False+ optselected (Right vals) opt = optionInternalValue opt `elem` vals+ [whamlet|+ <span ##{theId}>+ $forall opt <- opts+ <input id=#{theId}-#{optionExternalValue opt} type=checkbox name=#{name} value=#{optionExternalValue opt} *{attrs} :optselected val opt:checked>+ <label for=#{theId}-#{optionExternalValue opt}>+ #{optionDisplay opt}+ |]+ }+++-- | Creates an input with @type="radio"@ for selecting one option.+radioField :: (Eq a, RenderMessage site FormMessage)+ => HandlerFor site (OptionList a)+ -> Field (HandlerFor site) a+radioField = withRadioField+ (\theId optionWidget -> [whamlet|+$newline never+<div .radio>+ <label for=#{theId}-none>+ <div>+ ^{optionWidget}+ _{MsgSelectNone} |])- (\theId name theClass value isSel text -> [WHAMLET|-<div>- <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked :not (null theClass):class="#{T.intercalate " " theClass}">- <label for=#{theId}-#{value}>#{text}+ (\theId value _isSel text optionWidget -> [whamlet|+$newline never+<div .radio>+ <label for=#{theId}-#{value}>+ <div>+ ^{optionWidget}+ \#{text} |]) -boolField :: RenderMessage master FormMessage => Field sub master Bool++-- | Creates an input with @type="radio"@ for selecting one option.+--+-- @since 1.7.8+radioField' :: (Eq a, RenderMessage site FormMessage)+ => HandlerFor site (OptionList a)+ -> Field (HandlerFor site) a+radioField' = withRadioField+ (\theId optionWidget -> [whamlet|+$newline never+<.radio>+ ^{optionWidget}+ <label for=#{theId}-none>+ _{MsgSelectNone}+|])+ (\theId value _isSel text optionWidget -> [whamlet|+$newline never+<.radio>+ ^{optionWidget}+ <label for=#{theId}-#{value}>+ \#{text}+|])++-- | Allows the user to place the option radio widget somewhere in+-- the template.+-- For example: If you want a table of radio options to select.+-- 'radioField' is an example on how to use this function.+--+-- @since 1.7.2+withRadioField :: (Eq a, RenderMessage site FormMessage)+ => (Text -> WidgetFor site ()-> WidgetFor site ()) -- ^ nothing case for mopt+ -> (Text -> Text -> Bool -> Text -> WidgetFor site () -> WidgetFor site ()) -- ^ cases for values+ -> HandlerFor site (OptionList a)+ -> Field (HandlerFor site) a+withRadioField nothingFun optFun =+ selectFieldHelper outside onOpt inside Nothing+ where+ outside theId _name _attrs inside' = [whamlet|+$newline never+<div ##{theId}>^{inside'}+|]+ onOpt theId name isSel = nothingFun theId $ [whamlet|+$newline never+<input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>+|]+ inside theId name attrs value isSel display =+ optFun theId value isSel display [whamlet|+<input id=#{theId}-#{(value)} type=radio name=#{name} value=#{(value)} :isSel:checked *{attrs}>+|]++-- | Creates a group of radio buttons to answer the question given in the message. Radio buttons are used to allow differentiating between an empty response (@Nothing@) and a no response (@Just False@). Consider using the simpler 'checkBoxField' if you don't need to make this distinction.+--+-- If this field is optional, the first radio button is labeled "\<None>", the second \"Yes" and the third \"No".+--+-- If this field is required, the first radio button is labeled \"Yes" and the second \"No".+--+-- (Exact label titles will depend on localization).+boolField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Bool boolField = Field- { fieldParse = return . boolParser- , fieldView = \theId name theClass val isReq -> [WHAMLET|+ { fieldParse = \e _ -> return $ boolParser e+ , fieldView = \theId name attrs val isReq -> [whamlet|+$newline never $if not isReq- <input id=#{theId}-none :not (null theClass):class="#{T.intercalate " " theClass}" type=radio name=#{name} value=none checked>+ <input id=#{theId}-none *{attrs} type=radio name=#{name} value=none checked> <label for=#{theId}-none>_{MsgSelectNone} -<input id=#{theId}-yes :not (null theClass):class="#{T.intercalate " " theClass}" type=radio name=#{name} value=yes :showVal id val:checked>+<input id=#{theId}-yes *{attrs} type=radio name=#{name} value=yes :showVal id val:checked> <label for=#{theId}-yes>_{MsgBoolYes} -<input id=#{theId}-no :not (null theClass):class="#{T.intercalate " " theClass}" type=radio name=#{name} value=no :showVal not val:checked>+<input id=#{theId}-no *{attrs} type=radio name=#{name} value=no :showVal not val:checked> <label for=#{theId}-no>_{MsgBoolNo} |]+ , fieldEnctype = UrlEncoded } where boolParser [] = Right Nothing@@ -383,51 +657,96 @@ "" -> Right Nothing "none" -> Right Nothing "yes" -> Right $ Just True+ "on" -> Right $ Just True "no" -> Right $ Just False+ "true" -> Right $ Just True+ "false" -> Right $ Just False t -> Left $ SomeMessage $ MsgInvalidBool t showVal = either (\_ -> False) --- | While the default @'boolField'@ implements a radio button so you--- can differentiate between an empty response (Nothing) and a no--- response (Just False), this simpler checkbox field returns an empty--- response as Just False.+-- | Creates an input with @type="checkbox"@.+-- While the default @'boolField'@ implements a radio button so you+-- can differentiate between an empty response (@Nothing@) and a no+-- response (@Just False@), this simpler checkbox field returns an empty+-- response as @Just False@. -- -- Note that this makes the field always optional. ---checkBoxField :: RenderMessage m FormMessage => Field s m Bool+checkBoxField :: Monad m => Field m Bool checkBoxField = Field- { fieldParse = return . checkBoxParser- , fieldView = \theId name theClass val _ -> [whamlet|-<input id=#{theId} :not (null theClass):class="#{T.intercalate " " theClass}" type=checkbox name=#{name} value=yes :showVal id val:checked>+ { fieldParse = \e _ -> return $ checkBoxParser e+ , fieldView = \theId name attrs val _ -> [whamlet|+$newline never+<input id=#{theId} *{attrs} type=checkbox name=#{name} value=yes :showVal id val:checked> |]+ , fieldEnctype = UrlEncoded } where checkBoxParser [] = Right $ Just False checkBoxParser (x:_) = case x of "yes" -> Right $ Just True+ "on" -> Right $ Just True _ -> Right $ Just False showVal = either (\_ -> False) -data OptionList a = OptionList+-- | A structure holding a list of options. Typically you can use a convenience function like 'mkOptionList' or 'optionsPairs' instead of creating this directly.+--+-- Extended by 'OptionListGrouped' in 1.7.0.+data OptionList a+ = OptionList { olOptions :: [Option a]- , olReadExternal :: Text -> Maybe a+ , olReadExternal :: Text -> Maybe a -- ^ A function mapping from the form's value ('optionExternalValue') to the selected Haskell value ('optionInternalValue'). }+ | OptionListGrouped+ { olOptionsGrouped :: [(Text, [Option a])]+ , olReadExternalGrouped :: Text -> Maybe a -- ^ A function mapping from the form's value ('optionExternalValue') to the selected Haskell value ('optionInternalValue').+ } +-- | Convert grouped 'OptionList' to a normal one.+--+-- @since 1.7.0+flattenOptionList :: OptionList a -> OptionList a+flattenOptionList (OptionListGrouped os re) = OptionList (concatMap snd os) re+flattenOptionList ol = ol++-- | @since 1.4.6+instance Functor OptionList where+ fmap f (OptionList options readExternal) =+ OptionList ((fmap.fmap) f options) (fmap f . readExternal)+ fmap f (OptionListGrouped options readExternal) =+ OptionListGrouped (map (\(g, os) -> (g, (fmap.fmap) f os)) options) (fmap f . readExternal)++-- | Creates an 'OptionList', using a 'Map' to implement the 'olReadExternal' function. mkOptionList :: [Option a] -> OptionList a mkOptionList os = OptionList { olOptions = os , olReadExternal = flip Map.lookup $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) os } +-- | Creates an 'OptionList', using a 'Map' to implement the 'olReadExternalGrouped' function.+--+-- @since 1.7.0+mkOptionListGrouped :: [(Text, [Option a])] -> OptionList a+mkOptionListGrouped os = OptionListGrouped+ { olOptionsGrouped = os+ , olReadExternalGrouped = flip Map.lookup $ Map.fromList $ map (optionExternalValue &&& optionInternalValue) $ concatMap snd os+ }+ data Option a = Option- { optionDisplay :: Text- , optionInternalValue :: a- , optionExternalValue :: Text+ { optionDisplay :: Text -- ^ The user-facing label.+ , optionInternalValue :: a -- ^ The Haskell value being selected.+ , optionExternalValue :: Text -- ^ The representation of this value stored in the form. } -optionsPairs :: RenderMessage master msg => [(msg, a)] -> GHandler sub master (OptionList a)+-- | @since 1.4.6+instance Functor Option where+ fmap f (Option display internal external) = Option display (f internal) external++-- | Creates an 'OptionList' from a list of (display-value, internal value) pairs.+optionsPairs :: (MonadHandler m, RenderMessage (HandlerSite m) msg)+ => [(msg, a)] -> m (OptionList a) optionsPairs opts = do mr <- getMessageRender let mkOption external (display, internal) =@@ -437,16 +756,73 @@ } return $ mkOptionList (zipWith mkOption [1 :: Int ..] opts) -optionsEnum :: (Show a, Enum a, Bounded a) => GHandler sub master (OptionList a)+-- | Creates an 'OptionList' from a list of (display-value, internal value) pairs.+--+-- @since 1.7.0+optionsPairsGrouped+ :: forall m msg a. (MonadHandler m, RenderMessage (HandlerSite m) msg)+ => [(msg, [(msg, a)])] -> m (OptionList a)+optionsPairsGrouped opts = do+ mr <- getMessageRender+ let mkOption (external, (display, internal)) =+ Option { optionDisplay = mr display+ , optionInternalValue = internal+ , optionExternalValue = pack $ show external+ }+ opts' = enumerateSublists opts :: [(msg, [(Int, (msg, a))])]+ opts'' = map (\(x, ys) -> (mr x, map mkOption ys)) opts'+ return $ mkOptionListGrouped opts''++-- | Helper to enumerate sublists with one consecutive index.+enumerateSublists :: forall a b. [(a, [b])] -> [(a, [(Int, b)])]+enumerateSublists xss =+ let yss :: [(Int, (a, [b]))]+ yss = snd $ foldl (\(i, res) xs -> (i + (length.snd) xs, res ++ [(i, xs)])) (1, []) xss+ in map (\(i, (x, ys)) -> (x, zip [i :: Int ..] ys)) yss++-- | Creates an 'OptionList' from an 'Enum', using its 'Show' instance for the user-facing value.+optionsEnum :: (MonadHandler m, Show a, Enum a, Bounded a) => m (OptionList a) optionsEnum = optionsPairs $ map (\x -> (pack $ show x, x)) [minBound..maxBound] -optionsPersist :: ( YesodPersist master, PersistEntity a- , PersistQuery (YesodPersistBackend master) (GHandler sub master)- , PathPiece (Key (YesodPersistBackend master) a)- , RenderMessage master msg- , PersistEntityBackend a ~ YesodPersistBackend master+-- | Selects a list of 'Entity's with the given 'Filter' and 'SelectOpt's. The @(a -> msg)@ function is then used to derive the display value for an 'OptionList'. Example usage:+--+-- > Country+-- > name Text+-- > deriving Eq -- Must derive Eq+--+-- > data CountryForm = CountryForm+-- > { country :: Entity Country+-- > }+-- >+-- > countryNameForm :: AForm Handler CountryForm+-- > countryNameForm = CountryForm+-- > <$> areq (selectField countries) "Which country do you live in?" Nothing+-- > where+-- > countries = optionsPersist [] [Asc CountryName] countryName+#if MIN_VERSION_persistent(2,5,0)+optionsPersist :: ( YesodPersist site+ , PersistQueryRead backend+ , PathPiece (Key a)+ , RenderMessage site msg+ , YesodPersistBackend site ~ backend+ , PersistRecordBackend a backend )- => [Filter a] -> [SelectOpt a] -> (a -> msg) -> GHandler sub master (OptionList (Entity a))+ => [Filter a]+ -> [SelectOpt a]+ -> (a -> msg)+ -> HandlerFor site (OptionList (Entity a))+#else+optionsPersist :: ( YesodPersist site, PersistEntity a+ , PersistQuery (PersistEntityBackend a)+ , PathPiece (Key a)+ , RenderMessage site msg+ , YesodPersistBackend site ~ PersistEntityBackend a+ )+ => [Filter a]+ -> [SelectOpt a]+ -> (a -> msg)+ -> HandlerFor site (OptionList (Entity a))+#endif optionsPersist filts ords toDisplay = fmap mkOptionList $ do mr <- getMessageRender pairs <- runDB $ selectList filts ords@@ -456,30 +832,80 @@ , optionExternalValue = toPathPiece key }) pairs +-- | An alternative to 'optionsPersist' which returns just the 'Key' instead of+-- the entire 'Entity'.+--+-- @since 1.3.2+#if MIN_VERSION_persistent(2,5,0)+optionsPersistKey+ :: (YesodPersist site+ , PersistQueryRead backend+ , PathPiece (Key a)+ , RenderMessage site msg+ , backend ~ YesodPersistBackend site+ , PersistRecordBackend a backend+ )+ => [Filter a]+ -> [SelectOpt a]+ -> (a -> msg)+ -> HandlerFor site (OptionList (Key a))+#else+optionsPersistKey+ :: (YesodPersist site+ , PersistEntity a+ , PersistQuery (PersistEntityBackend a)+ , PathPiece (Key a)+ , RenderMessage site msg+ , YesodPersistBackend site ~ PersistEntityBackend a+ )+ => [Filter a]+ -> [SelectOpt a]+ -> (a -> msg)+ -> HandlerFor site (OptionList (Key a))+#endif++optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do+ mr <- getMessageRender+ pairs <- runDB $ selectList filts ords+ return $ map (\(Entity key value) -> Option+ { optionDisplay = mr (toDisplay value)+ , optionInternalValue = key+ , optionExternalValue = toPathPiece key+ }) pairs++-- |+-- A helper function for constucting 'selectField's with optional option groups. You may want to use this when you define your custom 'selectField's or 'radioField's.+--+-- @since 1.6.2 selectFieldHelper- :: (Eq a, RenderMessage master FormMessage)- => (Text -> Text -> GWidget sub master () -> GWidget sub master ())- -> (Text -> Text -> Bool -> GWidget sub master ())- -> (Text -> Text -> [Text] -> Text -> Bool -> Text -> GWidget sub master ())- -> GHandler sub master (OptionList a) -> Field sub master a-selectFieldHelper outside onOpt inside opts' = Field- { fieldParse = \x -> do- opts <- opts'+ :: (Eq a, RenderMessage site FormMessage)+ => (Text -> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ()) -- ^ Outermost part of the field+ -> (Text -> Text -> Bool -> WidgetFor site ()) -- ^ An option for None if the field is optional+ -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ()) -- ^ Other options+ -> (Maybe (Text -> WidgetFor site ())) -- ^ Group headers placed inbetween options+ -> HandlerFor site (OptionList a)+ -> Field (HandlerFor site) a+selectFieldHelper outside onOpt inside grpHdr opts' = Field+ { fieldParse = \x _ -> do+ opts <- fmap flattenOptionList opts' return $ selectParser opts x- , fieldView = \theId name theClass val isReq -> do- opts <- fmap olOptions $ lift opts'- outside theId name $ do- unless isReq $ onOpt theId name $ not $ render opts val `elem` map optionExternalValue opts- flip mapM_ opts $ \opt -> inside- theId- name- theClass- (optionExternalValue opt)- ((render opts val) == optionExternalValue opt)- (optionDisplay opt)+ , fieldView = \theId name attrs val isReq -> do+ outside theId name attrs $ do+ optsFlat <- fmap (olOptions.flattenOptionList) $ handlerToWidget opts'+ unless isReq $ onOpt theId name $ render optsFlat val `notElem` map optionExternalValue optsFlat+ opts'' <- handlerToWidget opts'+ case opts'' of+ OptionList{} -> constructOptions theId name attrs val isReq optsFlat+ OptionListGrouped{olOptionsGrouped=grps} -> do+ forM_ grps $ \(grp, opts) -> do+ case grpHdr of+ Just hdr -> hdr grp+ Nothing -> return ()+ constructOptions theId name attrs val isReq opts+ , fieldEnctype = UrlEncoded } where- render _ (Left _) = ""+ render _ (Left x) = x render opts (Right a) = maybe "" optionExternalValue $ listToMaybe $ filter ((== a) . optionInternalValue) opts selectParser _ [] = Right Nothing selectParser opts (s:_) = case s of@@ -488,9 +914,32 @@ x -> case olReadExternal opts x of Nothing -> Left $ SomeMessage $ MsgInvalidEntry x Just y -> Right $ Just y+ constructOptions theId name attrs val isReq opts =+ forM_ opts $ \opt -> inside+ theId+ name+ ((if isReq then (("required", "required"):) else id) attrs)+ (optionExternalValue opt)+ (render opts val == optionExternalValue opt)+ (optionDisplay opt) -fileAFormReq :: (RenderMessage master msg, RenderMessage master FormMessage) => FieldSettings msg -> AForm sub master FileInfo-fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do+-- | Creates an input with @type="file"@.+fileField :: Monad m+ => Field m FileInfo+fileField = Field+ { fieldParse = \_ files -> return $+ case files of+ [] -> Right Nothing+ file:_ -> Right $ Just file+ , fieldView = \id' name attrs _ isReq -> toWidget [hamlet|+ <input id=#{id'} name=#{name} *{attrs} type=file :isReq:required>+ |]+ , fieldEnctype = Multipart+ }++fileAFormReq :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)+ => FieldSettings (HandlerSite m) -> AForm m FileInfo+fileAFormReq fs = AForm $ \(site, langs) menvs ints -> do let (name, ints') = case fsName fs of Just x -> (x, ints)@@ -503,24 +952,26 @@ Nothing -> (FormMissing, Nothing) Just (_, fenv) -> case Map.lookup name fenv of- Nothing ->- let t = renderMessage master langs MsgValueRequired+ Just (fi:_) -> (FormSuccess fi, Nothing)+ _ ->+ let t = renderMessage site langs MsgValueRequired in (FormFailure [t], Just $ toHtml t)- Just fi -> (FormSuccess fi, Nothing)- let theClass = fsClass fs let fv = FieldView- { fvLabel = toHtml $ renderMessage master langs $ fsLabel fs- , fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs+ { fvLabel = toHtml $ renderMessage site langs $ fsLabel fs+ , fvTooltip = fmap (toHtml . renderMessage site langs) $ fsTooltip fs , fvId = id'- , fvInput = [WHAMLET|-<input type=file name=#{name} ##{id'} :not (null theClass):class="#{T.intercalate " " theClass}">+ , fvInput = [whamlet|+$newline never+<input type=file name=#{name} ##{id'} *{fsAttrs fs}> |] , fvErrors = errs , fvRequired = True } return (res, (fv :), ints', Multipart) -fileAFormOpt :: (RenderMessage master msg, RenderMessage master FormMessage) => FieldSettings msg -> AForm sub master (Maybe FileInfo)+fileAFormOpt :: MonadHandler m+ => FieldSettings (HandlerSite m)+ -> AForm m (Maybe FileInfo) fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do let (name, ints') = case fsName fs of@@ -534,15 +985,15 @@ Nothing -> (FormMissing, Nothing) Just (_, fenv) -> case Map.lookup name fenv of- Nothing -> (FormSuccess Nothing, Nothing)- Just fi -> (FormSuccess $ Just fi, Nothing)- let theClass = fsClass fs+ Just (fi:_) -> (FormSuccess $ Just fi, Nothing)+ _ -> (FormSuccess Nothing, Nothing) let fv = FieldView { fvLabel = toHtml $ renderMessage master langs $ fsLabel fs , fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs , fvId = id'- , fvInput = [WHAMLET|-<input type=file name=#{name} ##{id'} :not (null theClass):class="#{T.intercalate " " theClass}">+ , fvInput = [whamlet|+$newline never+<input type=file name=#{name} ##{id'} *{fsAttrs fs}> |] , fvErrors = errs , fvRequired = False@@ -552,3 +1003,67 @@ incrInts :: Ints -> Ints incrInts (IntSingle i) = IntSingle $ i + 1 incrInts (IntCons i is) = (i + 1) `IntCons` is+++-- | Adds a '0' to some text so that it may be recognized as a double.+-- The read ftn does not recognize ".3" as 0.3 nor "-.3" as -0.3, so this+-- function changes ".xxx" to "0.xxx" and "-.xxx" to "-0.xxx"++prependZero :: Text -> Text+prependZero t0 = if T.null t1+ then t1+ else if T.head t1 == '.'+ then '0' `T.cons` t1+ else if "-." `T.isPrefixOf` t1+ then "-0." `T.append` (T.drop 2 t1)+ else t1++ where t1 = T.dropWhile (== ' ') t0++-- $optionsOverview+-- These functions create inputs where one or more options can be selected from a list.+--+-- The basic datastructure used is an 'Option', which combines a user-facing display value, the internal Haskell value being selected, and an external 'Text' stored as the @value@ in the form (used to map back to the internal value). A list of these, together with a function mapping from an external value back to a Haskell value, form an 'OptionList', which several of these functions take as an argument.+--+-- Typically, you won't need to create an 'OptionList' directly and can instead make one with functions like 'optionsPairs' or 'optionsEnum'. Alternatively, you can use functions like 'selectFieldList', which use their @[(msg, a)]@ parameter to create an 'OptionList' themselves.++-- | Creates an input with @type="color"@.+-- The input value must be provided in hexadecimal format #rrggbb.+--+-- @since 1.7.1+colorField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text+colorField = Field+ { fieldParse = parseHelper $ \s ->+ if isHexColor $ unpack s then Right s+ else Left $ MsgInvalidHexColorFormat s+ , fieldView = \theId name attrs val _ -> [whamlet|+$newline never+<input ##{theId} name=#{name} *{attrs} type=color value=#{either id id val}>+|]+ , fieldEnctype = UrlEncoded+ }+ where+ isHexColor :: String -> Bool+ isHexColor ['#',a,b,c,d,e,f] = all isHexDigit [a,b,c,d,e,f]+ isHexColor _ = False++-- | Creates an input with @type="datetime-local"@.+-- The input value must be provided in YYYY-MM-DD(T| )HH:MM[:SS] format.+--+-- @since 1.7.6+datetimeLocalField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m LocalTime+datetimeLocalField = Field+ { fieldParse = parseHelper $ \s -> case T.split (\c -> (c == 'T') || (c == ' ')) s of+ [d,t] -> do+ day <- parseDate $ unpack d+ time <- parseTime t+ Right $ LocalTime day time+ _ -> Left $ MsgInvalidDatetimeFormat s+ , fieldView = \theId name attrs val isReq -> [whamlet|+$newline never+<input type=datetime-local ##{theId} name=#{name} value=#{showVal val} *{attrs} :isReq:required>+|]+ , fieldEnctype = UrlEncoded+ }+ where+ showVal = either id (pack . show)
Yesod/Form/Functions.hs view
@@ -1,8 +1,12 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+ module Yesod.Form.Functions ( -- * Running in MForm monad newFormIdent@@ -11,62 +15,72 @@ -- * Applicative/Monadic conversion , formToAForm , aFormToForm+ , mFormToWForm+ , wFormToAForm+ , wFormToMForm -- * Fields to Forms+ , wreq+ , wreqMsg+ , wopt , mreq+ , mreqMsg , mopt , areq+ , areqMsg , aopt -- * Run a form , runFormPost- , runFormPostNoNonce+ , runFormPostNoToken , runFormGet -- * Generate a blank form , generateFormPost+ , generateFormGet' , generateFormGet+ -- * More than one form on a handler+ , identifyForm -- * Rendering , FormRender , renderTable , renderDivs+ , renderDivsNoLabels , renderBootstrap+ , renderBootstrap2 -- * Validation , check , checkBool , checkM+ , checkMMap , customErrorMessage -- * Utilities , fieldSettingsLabel- , aformM+ , parseHelper+ , parseHelperGen+ , convertField+ , addClass+ , removeClass ) where import Yesod.Form.Types import Data.Text (Text, pack)+import qualified Data.Text as T import Control.Arrow (second)-import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)-import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Class+import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST, local, mapRWST)+import Control.Monad.Trans.Writer (runWriterT, writer) import Control.Monad (liftM, join)-import Text.Blaze (Html, toHtml)-import Yesod.Handler (GHandler, getRequest, runRequestBody, newIdent, getYesod)-import Yesod.Core (RenderMessage, SomeMessage (..))-import Yesod.Widget (GWidget, whamlet)-import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages, FileInfo (..))+import Data.Byteable (constEqBytes)+import Text.Blaze (Markup, toMarkup)+#define Html Markup+#define toHtml toMarkup+import Yesod.Core import Network.Wai (requestMethod)-import Text.Hamlet (shamlet)-import Data.Monoid (mempty) import Data.Maybe (listToMaybe, fromMaybe)-import Yesod.Message (RenderMessage (..)) import qualified Data.Map as Map-import qualified Data.ByteString.Lazy as L--#if __GLASGOW_HASKELL__ >= 700-#define WHAMLET whamlet-#define HTML shamlet-#else-#define HTML $shamlet-#define WHAMLET $whamlet-#endif+import qualified Data.Text.Encoding as TE+import Control.Arrow (first) -- | Get a unique identifier.-newFormIdent :: MForm sub master Text+newFormIdent :: Monad m => MForm m Text newFormIdent = do i <- get let i' = incrInts i@@ -76,72 +90,173 @@ incrInts (IntSingle i) = IntSingle $ i + 1 incrInts (IntCons i is) = (i + 1) `IntCons` is -formToAForm :: MForm sub master (FormResult a, [FieldView sub master]) -> AForm sub master a-formToAForm form = AForm $ \(master, langs) env ints -> do- ((a, xmls), ints', enc) <- runRWST form (env, master, langs) ints+formToAForm :: (HandlerSite m ~ site, Monad m)+ => MForm m (FormResult a, [FieldView site])+ -> AForm m a+formToAForm form = AForm $ \(site, langs) env ints -> do+ ((a, xmls), ints', enc) <- runRWST form (env, site, langs) ints return (a, (++) xmls, ints', enc) -aFormToForm :: AForm sub master a -> MForm sub master (FormResult a, [FieldView sub master] -> [FieldView sub master])+aFormToForm :: (Monad m, HandlerSite m ~ site)+ => AForm m a+ -> MForm m (FormResult a, [FieldView site] -> [FieldView site]) aFormToForm (AForm aform) = do ints <- get- (env, master, langs) <- ask- (a, xml, ints', enc) <- lift $ aform (master, langs) env ints+ (env, site, langs) <- ask+ (a, xml, ints', enc) <- lift $ aform (site, langs) env ints put ints' tell enc return (a, xml) -askParams :: MForm sub master (Maybe Env)+askParams :: Monad m => MForm m (Maybe Env) askParams = do (x, _, _) <- ask return $ liftM fst x -askFiles :: MForm sub master (Maybe FileEnv)+askFiles :: Monad m => MForm m (Maybe FileEnv) askFiles = do (x, _, _) <- ask return $ liftM snd x -mreq :: (RenderMessage master msg, RenderMessage master FormMessage)- => Field sub master a -> FieldSettings msg -> Maybe a- -> MForm sub master (FormResult a, FieldView sub master)-mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True+-- | Converts a form field into monadic form 'WForm'. This field requires a+-- value and will return 'FormFailure' if left empty.+--+-- @since 1.4.14+wreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)+ => Field m a -- ^ form field+ -> FieldSettings site -- ^ settings for this field+ -> Maybe a -- ^ optional default value+ -> WForm m (FormResult a)+wreq f fs = wreqMsg f fs MsgValueRequired -mopt :: RenderMessage master msg- => Field sub master a -> FieldSettings msg -> Maybe (Maybe a)- -> MForm sub master (FormResult (Maybe a), FieldView sub master)+-- | Same as @wreq@ but with your own message to be rendered in case the value+-- is not provided.+--+-- This is useful when you have several required fields on the page and you+-- want to differentiate between which fields were left blank. Otherwise the+-- user sees "Value is required" multiple times, which is ambiguous.+--+-- @since 1.6.7+wreqMsg :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)+ => Field m a -- ^ form field+ -> FieldSettings site -- ^ settings for this field+ -> msg -- ^ message to use in case value is Nothing+ -> Maybe a -- ^ optional default value+ -> WForm m (FormResult a)+wreqMsg f fs msg = mFormToWForm . mreqMsg f fs msg++-- | Converts a form field into monadic form 'WForm'. This field is optional,+-- i.e. if filled in, it returns 'Just a', if left empty, it returns+-- 'Nothing'. Arguments are the same as for 'wreq' (apart from type of default+-- value).+--+-- @since 1.4.14+wopt :: (MonadHandler m, HandlerSite m ~ site)+ => Field m a -- ^ form field+ -> FieldSettings site -- ^ settings for this field+ -> Maybe (Maybe a) -- ^ optional default value+ -> WForm m (FormResult (Maybe a))+wopt f fs = mFormToWForm . mopt f fs++-- | Converts a monadic form 'WForm' into an applicative form 'AForm'.+--+-- @since 1.4.14+wFormToAForm :: MonadHandler m+ => WForm m (FormResult a) -- ^ input form+ -> AForm m a -- ^ output form+wFormToAForm = formToAForm . wFormToMForm++-- | Converts a monadic form 'WForm' into another monadic form 'MForm'.+--+-- @since 1.4.14+wFormToMForm :: (MonadHandler m, HandlerSite m ~ site)+ => WForm m a -- ^ input form+ -> MForm m (a, [FieldView site]) -- ^ output form+wFormToMForm = mapRWST (fmap group . runWriterT)+ where+ group ((a, ints, enctype), views) = ((a, views), ints, enctype)++-- | Converts a monadic form 'MForm' into another monadic form 'WForm'.+--+-- @since 1.4.14+mFormToWForm :: (MonadHandler m, HandlerSite m ~ site)+ => MForm m (a, FieldView site) -- ^ input form+ -> WForm m a -- ^ output form+mFormToWForm = mapRWST $ \f -> do+ ((a, view), ints, enctype) <- lift f+ writer ((a, ints, enctype), [view])++-- | Converts a form field into monadic form. This field requires a value+-- and will return 'FormFailure' if left empty.+mreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)+ => Field m a -- ^ form field+ -> FieldSettings site -- ^ settings for this field+ -> Maybe a -- ^ optional default value+ -> MForm m (FormResult a, FieldView site)+mreq field fs mdef = mreqMsg field fs MsgValueRequired mdef++-- | Same as @mreq@ but with your own message to be rendered in case the value+-- is not provided.+--+-- This is useful when you have several required fields on the page and you+-- want to differentiate between which fields were left blank. Otherwise the+-- user sees "Value is required" multiple times, which is ambiguous.+--+-- @since 1.6.6+mreqMsg :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)+ => Field m a -- ^ form field+ -> FieldSettings site -- ^ settings for this field+ -> msg -- ^ Message to use in case value is Nothing+ -> Maybe a -- ^ optional default value+ -> MForm m (FormResult a, FieldView site)+mreqMsg field fs msg mdef = mhelper field fs mdef formFailure FormSuccess True+ where formFailure m l = FormFailure [renderMessage m l msg]++-- | Converts a form field into monadic form. This field is optional, i.e.+-- if filled in, it returns 'Just a', if left empty, it returns 'Nothing'.+-- Arguments are the same as for 'mreq' (apart from type of default value).+mopt :: (site ~ HandlerSite m, MonadHandler m)+ => Field m a+ -> FieldSettings site+ -> Maybe (Maybe a)+ -> MForm m (FormResult (Maybe a), FieldView site) mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False -mhelper :: RenderMessage master msg- => Field sub master a- -> FieldSettings msg+mhelper :: (site ~ HandlerSite m, MonadHandler m)+ => Field m a+ -> FieldSettings site -> Maybe a- -> (master -> [Text] -> FormResult b) -- ^ on missing+ -> (site -> [Text] -> FormResult b) -- ^ on missing -> (a -> FormResult b) -- ^ on success -> Bool -- ^ is it required?- -> MForm sub master (FormResult b, FieldView sub master)+ -> MForm m (FormResult b, FieldView site) mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do+ tell fieldEnctype mp <- askParams name <- maybe newFormIdent return fsName theId <- lift $ maybe newIdent return fsId- (_, master, langs) <- ask- let mr2 = renderMessage master langs+ (_, site, langs) <- ask+ let mr2 = renderMessage site langs (res, val) <- case mp of Nothing -> return (FormMissing, maybe (Left "") Right mdef) Just p -> do+ mfs <- askFiles let mvals = fromMaybe [] $ Map.lookup name p- emx <- lift $ fieldParse mvals+ files = fromMaybe [] $ mfs >>= Map.lookup name+ emx <- lift $ fieldParse mvals files return $ case emx of- Left (SomeMessage e) -> (FormFailure [renderMessage master langs e], maybe (Left "") Left (listToMaybe mvals))+ Left (SomeMessage e) -> (FormFailure [renderMessage site langs e], maybe (Left "") Left (listToMaybe mvals)) Right mx -> case mx of- Nothing -> (onMissing master langs, Left "")+ Nothing -> (onMissing site langs, Left "") Just x -> (onFound x, Right x) return (res, FieldView { fvLabel = toHtml $ mr2 fsLabel , fvTooltip = fmap toHtml $ fmap mr2 fsTooltip , fvId = theId- , fvInput = fieldView theId name fsClass val isReq+ , fvInput = fieldView theId name fsAttrs val isReq , fvErrors = case res of FormFailure [e] -> Just $ toHtml e@@ -149,20 +264,45 @@ , fvRequired = isReq }) -areq :: (RenderMessage master msg, RenderMessage master FormMessage)- => Field sub master a -> FieldSettings msg -> Maybe a- -> AForm sub master a-areq a b = formToAForm . fmap (second return) . mreq a b+-- | Applicative equivalent of 'mreq'.+areq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)+ => Field m a -- ^ form field+ -> FieldSettings site -- ^ settings for this field+ -> Maybe a -- ^ optional default value+ -> AForm m a+areq f fs = areqMsg f fs MsgValueRequired -aopt :: RenderMessage master msg- => Field sub master a- -> FieldSettings msg+-- | Same as @areq@ but with your own message to be rendered in case the value+-- is not provided.+--+-- This is useful when you have several required fields on the page and you+-- want to differentiate between which fields were left blank. Otherwise the+-- user sees "Value is required" multiple times, which is ambiguous.+--+-- @since 1.6.7+areqMsg :: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)+ => Field m a -- ^ form field+ -> FieldSettings site -- ^ settings for this field+ -> msg -- ^ message to use in case value is Nothing+ -> Maybe a -- ^ optional default value+ -> AForm m a+areqMsg f fs msg = formToAForm . liftM (second return) . mreqMsg f fs msg++-- | Applicative equivalent of 'mopt'.+aopt :: MonadHandler m+ => Field m a+ -> FieldSettings (HandlerSite m) -> Maybe (Maybe a)- -> AForm sub master (Maybe a)-aopt a b = formToAForm . fmap (second return) . mopt a b+ -> AForm m (Maybe a)+aopt a b = formToAForm . liftM (second return) . mopt a b -runFormGeneric :: MForm sub master a -> master -> [Text] -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype)-runFormGeneric form master langs env = evalRWST form (env, master, langs) (IntSingle 1)+runFormGeneric :: Monad m+ => MForm m a+ -> HandlerSite m+ -> [Text]+ -> Maybe (Env, FileEnv)+ -> m (a, Enctype)+runFormGeneric form site langs env = evalRWST form (env, site, langs) (IntSingle 0) -- | This function is used to both initially render a form and to later extract -- results from it. Note that, due to CSRF protection and a few other issues,@@ -173,46 +313,51 @@ -- For example, a common case is displaying a form on a GET request and having -- the form submit to a POST page. In such a case, both the GET and POST -- handlers should use 'runFormPost'.-runFormPost :: RenderMessage master FormMessage- => (Html -> MForm sub master (FormResult a, xml))- -> GHandler sub master ((FormResult a, xml), Enctype)+runFormPost :: (RenderMessage (HandlerSite m) FormMessage, MonadResource m, MonadHandler m)+ => (Html -> MForm m (FormResult a, xml))+ -> m ((FormResult a, xml), Enctype) runFormPost form = do env <- postEnv postHelper form env -postHelper :: RenderMessage master FormMessage- => (Html -> MForm sub master (FormResult a, xml))+postHelper :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)+ => (Html -> MForm m (FormResult a, xml)) -> Maybe (Env, FileEnv)- -> GHandler sub master ((FormResult a, xml), Enctype)+ -> m ((FormResult a, xml), Enctype) postHelper form env = do req <- getRequest- let nonceKey = "_nonce"- let nonce =- case reqNonce req of+ let tokenKey = defaultCsrfParamName+ let token =+ case reqToken req of Nothing -> mempty- Just n -> [HTML|<input type=hidden name=#{nonceKey} value=#{n}>|]+ Just n -> [shamlet|<input type=hidden name=#{tokenKey} value=#{n}>|] m <- getYesod langs <- languages- ((res, xml), enctype) <- runFormGeneric (form nonce) m langs env+ ((res, xml), enctype) <- runFormGeneric (form token) m langs env let res' = case (res, env) of+ (_, Nothing) -> FormMissing (FormSuccess{}, Just (params, _))- | Map.lookup nonceKey params /= fmap return (reqNonce req) ->+ | not (Map.lookup tokenKey params === reqToken req) -> FormFailure [renderMessage m langs MsgCsrfWarning] _ -> res+ -- It's important to use constant-time comparison (constEqBytes) in order to avoid timing attacks.+ where (Just [t1]) === (Just t2) = TE.encodeUtf8 t1 `constEqBytes` TE.encodeUtf8 t2+ Nothing === Nothing = True+ _ === _ = False return ((res', xml), enctype) --- | Similar to 'runFormPost', except it always ignore the currently available+-- | Similar to 'runFormPost', except it always ignores the currently available -- environment. This is necessary in cases like a wizard UI, where a single -- page will both receive and incoming form and produce a new, blank form. For -- general usage, you can stick with @runFormPost@. generateFormPost- :: RenderMessage master FormMessage- => (Html -> MForm sub master (FormResult a, xml))- -> GHandler sub master ((FormResult a, xml), Enctype)-generateFormPost form = postHelper form Nothing+ :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m)+ => (Html -> MForm m (FormResult a, xml))+ -> m (xml, Enctype)+generateFormPost form = first snd `liftM` postHelper form Nothing -postEnv :: GHandler sub master (Maybe (Env, FileEnv))+postEnv :: MonadHandler m => m (Maybe (Env, FileEnv)) postEnv = do req <- getRequest if requestMethod (reqWaiRequest req) == "GET"@@ -220,18 +365,20 @@ else do (p, f) <- runRequestBody let p' = Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) p- return $ Just (p', Map.fromList $ filter (notEmpty . snd) f)- where- notEmpty = not . L.null . fileContent+ return $ Just (p', Map.unionsWith (++) $ map (\(k, v) -> Map.singleton k [v]) f) -runFormPostNoNonce :: (Html -> MForm sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)-runFormPostNoNonce form = do+runFormPostNoToken :: MonadHandler m+ => (Html -> MForm m a)+ -> m (a, Enctype)+runFormPostNoToken form = do langs <- languages m <- getYesod env <- postEnv runFormGeneric (form mempty) m langs env -runFormGet :: (Html -> MForm sub master a) -> GHandler sub master (a, Enctype)+runFormGet :: MonadHandler m+ => (Html -> MForm m a)+ -> m (a, Enctype) runFormGet form = do gets <- liftM reqGetParams getRequest let env =@@ -240,34 +387,111 @@ Just _ -> Just (Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) gets, Map.empty) getHelper form env -generateFormGet :: (Html -> MForm sub master a) -> GHandler sub master (a, Enctype)+{- FIXME: generateFormGet' "Will be renamed to generateFormGet in next version of Yesod" -}+-- |+--+-- Since 1.3.11+generateFormGet'+ :: MonadHandler m+ => (Html -> MForm m (FormResult a, xml))+ -> m (xml, Enctype)+generateFormGet' form = first snd `liftM` getHelper form Nothing++{-# DEPRECATED generateFormGet "Will require RenderMessage in next version of Yesod" #-}+generateFormGet :: MonadHandler m+ => (Html -> MForm m a)+ -> m (a, Enctype) generateFormGet form = getHelper form Nothing getKey :: Text getKey = "_hasdata" -getHelper :: (Html -> MForm sub master a) -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype)+getHelper :: MonadHandler m+ => (Html -> MForm m a)+ -> Maybe (Env, FileEnv)+ -> m (a, Enctype) getHelper form env = do- let fragment = [HTML|<input type=hidden name=#{getKey}>|]+ let fragment = [shamlet|<input type=hidden name=#{getKey}>|] langs <- languages m <- getYesod runFormGeneric (form fragment) m langs env -type FormRender sub master a =- AForm sub master a++-- | 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, WidgetFor (HandlerSite m) ()))+ -> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))+identifyForm identVal form = \fragment -> do+ -- Create hidden <input>.+ let fragment' =+ [shamlet|+ <input type=hidden name=#{identifyFormKey} value=identify-#{identVal}>+ #{fragment}+ |]++ -- Check if we got its value back.+ mp <- askParams+ let missing = (mp >>= Map.lookup identifyFormKey) /= Just ["identify-" <> 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+ ( res', w) <- eraseParams (form fragment')++ -- Empty forms now properly return FormMissing. [#1072](https://github.com/yesodweb/yesod/issues/1072)+ let res = if missing then FormMissing else res'+ return ( res, w)++identifyFormKey :: Text+identifyFormKey = "_formid"+++type FormRender m a =+ AForm m a -> Html- -> MForm sub master (FormResult a, GWidget sub master ())+ -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()) -renderTable, renderDivs :: FormRender sub master a+renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a+-- | Render a form into a series of tr tags. Note that, in order to allow+-- you to add extra rows to the table, this function does /not/ wrap up+-- the resulting HTML in a table tag; you must do that yourself. renderTable aform fragment = do (res, views') <- aFormToForm aform let views = views' []- -- FIXME non-valid HTML- let widget = [WHAMLET|-\#{fragment}-$forall view <- views+ let widget = [whamlet|+$newline never+$if null views+ \#{fragment}+$forall (isFirst, view) <- addIsFirst views <tr :fvRequired view:.required :not $ fvRequired view:.optional> <td>+ $if isFirst+ \#{fragment} <label for=#{fvId view}>#{fvLabel view} $maybe tt <- fvTooltip view <div .tooltip>#{tt}@@ -276,15 +500,27 @@ <td .errors>#{err} |] return (res, widget)+ where+ addIsFirst [] = []+ addIsFirst (x:y) = (True, x) : map (False, ) y -renderDivs aform fragment = do+-- | render a field inside a div+renderDivs = renderDivsMaybeLabels True++-- | render a field inside a div, not displaying any label+renderDivsNoLabels = renderDivsMaybeLabels False++renderDivsMaybeLabels :: Monad m => Bool -> FormRender m a+renderDivsMaybeLabels withLabels aform fragment = do (res, views') <- aFormToForm aform let views = views' []- let widget = [WHAMLET|+ let widget = [whamlet|+$newline never \#{fragment} $forall view <- views <div :fvRequired view:.required :not $ fvRequired view:.optional>- <label for=#{fvId view}>#{fvLabel view}+ $if withLabels+ <label for=#{fvId view}>#{fvLabel view} $maybe tt <- fvTooltip view <div .tooltip>#{tt} ^{fvInput view}@@ -293,7 +529,9 @@ |] return (res, widget) --- | Render a form using Bootstrap-friendly HTML 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: --@@ -308,59 +546,158 @@ -- > ^{formWidget} -- > <div .form-actions> -- > <input .btn .primary type=submit value=_{MsgSubmit}>-renderBootstrap :: FormRender sub master a-renderBootstrap aform fragment = do+--+-- Since 1.3.14+renderBootstrap2 :: Monad m => FormRender m a+renderBootstrap2 aform fragment = do (res, views') <- aFormToForm aform let views = views' [] has (Just _) = True has Nothing = False let widget = [whamlet|-\#{fragment}-$forall view <- views- <div .control-group .clearfix :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.error>- <label .control-label for=#{fvId view}>#{fvLabel view}- <div .controls .input>- ^{fvInput view}- $maybe tt <- fvTooltip view- <span .help-block>#{tt}- $maybe err <- fvErrors view- <span .help-block>#{err}-|]+ $newline never+ \#{fragment}+ $forall view <- views+ <div .control-group .clearfix :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.error>+ <label .control-label for=#{fvId view}>#{fvLabel view}+ <div .controls .input>+ ^{fvInput view}+ $maybe tt <- fvTooltip view+ <span .help-block>#{tt}+ $maybe err <- fvErrors view+ <span .help-block>#{err}+ |] return (res, widget) -check :: RenderMessage master msg- => (a -> Either msg a) -> Field sub master a -> Field sub master a+-- | Deprecated synonym for 'renderBootstrap2'.+renderBootstrap :: Monad m => FormRender m a+renderBootstrap = renderBootstrap2+{-# DEPRECATED renderBootstrap "Please use the Yesod.Form.Bootstrap3 module." #-}++check :: (Monad m, RenderMessage (HandlerSite m) msg)+ => (a -> Either msg a)+ -> Field m a+ -> Field m a check f = checkM $ return . f -- | Return the given error message if the predicate is false.-checkBool :: RenderMessage master msg- => (a -> Bool) -> msg -> Field sub master a -> Field sub master a+checkBool :: (Monad m, RenderMessage (HandlerSite m) msg)+ => (a -> Bool) -> msg -> Field m a -> Field m a checkBool b s = check $ \x -> if b x then Right x else Left s -checkM :: RenderMessage master msg- => (a -> GHandler sub master (Either msg a))- -> Field sub master a- -> Field sub master a-checkM f field = field- { fieldParse = \ts -> do- e1 <- fieldParse field ts+checkM :: (Monad m, RenderMessage (HandlerSite m) msg)+ => (a -> m (Either msg a))+ -> Field m a+ -> Field m a+checkM f = checkMMap f id++-- | Same as 'checkM', but modifies the datatype.+--+-- In order to make this work, you must provide a function to convert back from+-- the new datatype to the old one (the second argument to this function).+--+-- Since 1.1.2+checkMMap :: (Monad m, RenderMessage (HandlerSite m) msg)+ => (a -> m (Either msg b))+ -> (b -> a)+ -> Field m a+ -> Field m b+checkMMap f inv field = field+ { fieldParse = \ts fs -> do+ e1 <- fieldParse field ts fs case e1 of Left msg -> return $ Left msg Right Nothing -> return $ Right Nothing- Right (Just a) -> fmap (either (Left . SomeMessage) (Right . Just)) $ f a+ Right (Just a) -> liftM (either (Left . SomeMessage) (Right . Just)) $ f a+ , fieldView = \i n a eres req -> fieldView field i n a (fmap inv eres) req } -- | Allows you to overwrite the error message on parse error.-customErrorMessage :: SomeMessage master -> Field sub master a -> Field sub master a-customErrorMessage msg field = field { fieldParse = \ts -> fmap (either-(const $ Left msg) Right) $ fieldParse field ts }+customErrorMessage :: Monad m => SomeMessage (HandlerSite m) -> Field m a -> Field m a+customErrorMessage msg field = field+ { fieldParse = \ts fs ->+ liftM (either (const $ Left msg) Right)+ $ fieldParse field ts fs+ } -- | Generate a 'FieldSettings' from the given label.-fieldSettingsLabel :: msg -> FieldSettings msg-fieldSettingsLabel msg = FieldSettings msg Nothing Nothing Nothing []+fieldSettingsLabel :: RenderMessage site msg => msg -> FieldSettings site+fieldSettingsLabel msg = FieldSettings (SomeMessage msg) Nothing Nothing Nothing [] --- | Generate an 'AForm' that gets its value from the given action.-aformM :: GHandler sub master a -> AForm sub master a-aformM action = AForm $ \_ _ ints -> do- value <- action- return (FormSuccess value, id, ints, mempty)+-- | A helper function for creating custom fields.+--+-- This is intended to help with the common case where a single input value is+-- required, such as when parsing a text field.+--+-- Since 1.1+parseHelper :: (Monad m, RenderMessage site FormMessage)+ => (Text -> Either FormMessage a)+ -> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))+parseHelper = parseHelperGen++-- | 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++-- | Since a 'Field' cannot be a 'Functor', it is not obvious how to "reuse" a Field+-- on a @newtype@ or otherwise equivalent type. This function allows you to convert+-- a @Field m a@ to a @Field m b@ assuming you provide a bidirectional+-- conversion between the two, through the first two functions.+--+-- A simple example:+--+-- > import Data.Monoid+-- > sumField :: (Functor m, Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m (Sum Int)+-- > sumField = convertField Sum getSum intField+--+-- Another example, not using a newtype, but instead creating a Lazy Text field:+--+-- > import qualified Data.Text.Lazy as TL+-- > TextField :: (Functor m, Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m TL.Text+-- > lazyTextField = convertField TL.fromStrict TL.toStrict textField+--+-- Since 1.3.16+convertField :: (Functor m)+ => (a -> b) -> (b -> a)+ -> Field m a -> Field m b+convertField to from (Field fParse fView fEnctype) = let+ fParse' ts = fmap (fmap (fmap to)) . fParse ts+ fView' ti tn at ei = fView ti tn at (fmap from ei)+ in Field fParse' fView' fEnctype++-- | Removes a CSS class from the 'fsAttrs' in a 'FieldSettings'.+--+-- ==== __Examples__+--+-- >>> removeClass "form-control" [("class","form-control login-form"),("id","home-login")]+-- [("class"," login-form"),("id","home-login")]+--+-- @since 1.6.2+removeClass :: Text -- ^ The class to remove+ -> [(Text, Text)] -- ^ List of existing 'fsAttrs'+ -> [(Text, Text)]+removeClass _ [] = []+removeClass klass (("class", old):rest) = ("class", T.replace klass " " old) : rest+removeClass klass (other :rest) = other : removeClass klass rest++-- | Adds a CSS class to the 'fsAttrs' in a 'FieldSettings'.+--+-- ==== __Examples__+--+-- >>> addClass "login-form" [("class", "form-control"), ("id", "home-login")]+-- [("class","form-control login-form"),("id","home-login")]+--+-- @since 1.6.2+addClass :: Text -- ^ The class to add+ -> [(Text, Text)] -- ^ List of existing 'fsAttrs'+ -> [(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
+ Yesod/Form/I18n/Chinese.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Form.I18n.Chinese where++import Yesod.Form.Types (FormMessage (..))+import Data.Text (Text)++chineseFormMessage :: FormMessage -> Text+chineseFormMessage (MsgInvalidInteger t) = "无效的整数: " `mappend` t+chineseFormMessage (MsgInvalidNumber t) = "无效的数字: " `mappend` t+chineseFormMessage (MsgInvalidEntry t) = "无效的条目: " `mappend` t+chineseFormMessage MsgInvalidTimeFormat = "无效的时间, 必须符合HH:MM[:SS]格式"+chineseFormMessage MsgInvalidDay = "无效的日期, 必须符合YYYY-MM-DD格式"+chineseFormMessage (MsgInvalidUrl t) = "无效的链接: " `mappend` t+chineseFormMessage (MsgInvalidEmail t) = "无效的邮箱地址: " `mappend` t+chineseFormMessage (MsgInvalidHour t) = "无效的小时: " `mappend` t+chineseFormMessage (MsgInvalidMinute t) = "无效的分钟: " `mappend` t+chineseFormMessage (MsgInvalidSecond t) = "无效的秒: " `mappend` t+chineseFormMessage MsgCsrfWarning = "为了防备跨站请求伪造, 请确认表格提交."+chineseFormMessage MsgValueRequired = "此项必填"+chineseFormMessage (MsgInputNotFound t) = "输入找不到: " `mappend` t+chineseFormMessage MsgSelectNone = "<空>"+chineseFormMessage (MsgInvalidBool t) = "无效的逻辑值: " `mappend` t+chineseFormMessage MsgBoolYes = "是"+chineseFormMessage MsgBoolNo = "否"+chineseFormMessage MsgDelete = "删除?"+chineseFormMessage (MsgInvalidHexColorFormat t) = "颜色无效，必须为 #rrggbb 十六进制格式: " `mappend` t+chineseFormMessage (MsgInvalidDatetimeFormat t) = "日期時間無效，必須採用 YYYY-MM-DD(T| )HH:MM[:SS] 格式： " `mappend` t
+ Yesod/Form/I18n/Czech.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Form.I18n.Czech where++import Yesod.Form.Types (FormMessage (..))+import Data.Text (Text)++czechFormMessage :: FormMessage -> Text+czechFormMessage (MsgInvalidInteger t) = "Neplatné celé číslo: " `mappend` t+czechFormMessage (MsgInvalidNumber t) = "Neplatné číslo: " `mappend` t+czechFormMessage (MsgInvalidEntry t) = "Neplatná položka: " `mappend` t+czechFormMessage MsgInvalidTimeFormat = "Neplatný čas, musí být ve formátu HH:MM[:SS]"+czechFormMessage MsgInvalidDay = "Neplatný den, musí být formátu YYYY-MM-DD"+czechFormMessage (MsgInvalidUrl t) = "Neplatná URL: " `mappend` t+czechFormMessage (MsgInvalidEmail t) = "Neplatná e-mailová adresa: " `mappend` t+czechFormMessage (MsgInvalidHour t) = "Neplatná hodina: " `mappend` t+czechFormMessage (MsgInvalidMinute t) = "Neplatná minuta: " `mappend` t+czechFormMessage (MsgInvalidSecond t) = "Neplatná sekunda: " `mappend` t+czechFormMessage MsgCsrfWarning = "Prosím potvrďte odeslání formuláře jako ochranu před útekem „cross-site request forgery“."+czechFormMessage MsgValueRequired = "Hodnota je vyžadována"+czechFormMessage (MsgInputNotFound t) = "Vstup nebyl nalezen: " `mappend` t+czechFormMessage MsgSelectNone = "<Nic>"+czechFormMessage (MsgInvalidBool t) = "Neplatná pravdivostní hodnota: " `mappend` t+czechFormMessage MsgBoolYes = "Ano"+czechFormMessage MsgBoolNo = "Ne"+czechFormMessage MsgDelete = "Smazat?"+czechFormMessage (MsgInvalidHexColorFormat t) = "Neplatná barva, musí být v #rrggbb hexadecimálním formátu: " `mappend` t+czechFormMessage (MsgInvalidDatetimeFormat t) = "Neplatné datum a čas, musí být ve formátu YYYY-MM-DD(T| )HH:MM[:SS]: " `mappend` t
+ Yesod/Form/I18n/Dutch.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Form.I18n.Dutch where++import Yesod.Form.Types (FormMessage (..))+import Data.Text (Text)++dutchFormMessage :: FormMessage -> Text+dutchFormMessage (MsgInvalidInteger t) = "Ongeldig aantal: " `mappend` t+dutchFormMessage (MsgInvalidNumber t) = "Ongeldig getal: " `mappend` t+dutchFormMessage (MsgInvalidEntry t) = "Ongeldige invoer: " `mappend` t+dutchFormMessage MsgInvalidTimeFormat = "Ongeldige tijd, het juiste formaat is (UU:MM[:SS])"+dutchFormMessage MsgInvalidDay = "Ongeldige datum, het juiste formaat is (JJJJ-MM-DD)"+dutchFormMessage (MsgInvalidUrl t) = "Ongeldige URL: " `mappend` t+dutchFormMessage (MsgInvalidEmail t) = "Ongeldig e-mail adres: " `mappend` t+dutchFormMessage (MsgInvalidHour t) = "Ongeldig uur: " `mappend` t+dutchFormMessage (MsgInvalidMinute t) = "Ongeldige minuut: " `mappend` t+dutchFormMessage (MsgInvalidSecond t) = "Ongeldige seconde: " `mappend` t+dutchFormMessage MsgCsrfWarning = "Bevestig het indienen van het formulier, dit als veiligheidsmaatregel tegen \"cross-site request forgery\" aanvallen."+dutchFormMessage MsgValueRequired = "Verplicht veld"+dutchFormMessage (MsgInputNotFound t) = "Geen invoer gevonden: " `mappend` t+dutchFormMessage MsgSelectNone = "<Geen>"+dutchFormMessage (MsgInvalidBool t) = "Ongeldige waarheidswaarde: " `mappend` t+dutchFormMessage MsgBoolYes = "Ja"+dutchFormMessage MsgBoolNo = "Nee"+dutchFormMessage MsgDelete = "Verwijderen?"+dutchFormMessage (MsgInvalidHexColorFormat t) = "Ongeldige kleur, moet de hexadecimale indeling #rrggbb hebben: " `mappend` t+dutchFormMessage (MsgInvalidDatetimeFormat t) = "Ongeldige datum/tijd, moet de indeling JJJJ-MM-DD(T| )UU:MM[:SS] hebben: " `mappend` t
Yesod/Form/I18n/English.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-}+ module Yesod.Form.I18n.English where import Yesod.Form.Types (FormMessage (..))-import Data.Monoid (mappend) import Data.Text (Text) englishFormMessage :: FormMessage -> Text@@ -24,3 +24,5 @@ englishFormMessage MsgBoolYes = "Yes" englishFormMessage MsgBoolNo = "No" englishFormMessage MsgDelete = "Delete?"+englishFormMessage (MsgInvalidHexColorFormat t) = "Invalid color, must be in #rrggbb hexadecimal format: " `mappend` t+englishFormMessage (MsgInvalidDatetimeFormat t) = "Invalid datetime, must be in YYYY-MM-DD(T| )HH:MM[:SS] format: " `mappend` t
+ Yesod/Form/I18n/French.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Form.I18n.French (frenchFormMessage) where++import Yesod.Form.Types (FormMessage (..))+import Data.Text (Text)++frenchFormMessage :: FormMessage -> Text+frenchFormMessage (MsgInvalidInteger t) = "Entier invalide : " `mappend` t+frenchFormMessage (MsgInvalidNumber t) = "Nombre invalide : " `mappend` t+frenchFormMessage (MsgInvalidEntry t) = "Entrée invalide : " `mappend` t+frenchFormMessage MsgInvalidTimeFormat = "Heure invalide (elle doit être au format HH:MM ou HH:MM:SS"+frenchFormMessage MsgInvalidDay = "Date invalide (elle doit être au format AAAA-MM-JJ"+frenchFormMessage (MsgInvalidUrl t) = "Adresse Internet invalide : " `mappend` t+frenchFormMessage (MsgInvalidEmail t) = "Adresse électronique invalide : " `mappend` t+frenchFormMessage (MsgInvalidHour t) = "Heure invalide : " `mappend` t+frenchFormMessage (MsgInvalidMinute t) = "Minutes invalides : " `mappend` t+frenchFormMessage (MsgInvalidSecond t) = "Secondes invalides " `mappend` t+frenchFormMessage MsgCsrfWarning = "Afin d'empêcher les attaques CSRF, veuillez ré-envoyer ce formulaire"+frenchFormMessage MsgValueRequired = "Ce champ est requis"+frenchFormMessage (MsgInputNotFound t) = "Entrée non trouvée : " `mappend` t+frenchFormMessage MsgSelectNone = "<Rien>"+frenchFormMessage (MsgInvalidBool t) = "Booléen invalide : " `mappend` t+frenchFormMessage MsgBoolYes = "Oui"+frenchFormMessage MsgBoolNo = "Non"+frenchFormMessage MsgDelete = "Détruire ?"+frenchFormMessage (MsgInvalidHexColorFormat t) = "Couleur non valide. doit être au format hexadécimal #rrggbb : " `mappend` t+frenchFormMessage (MsgInvalidDatetimeFormat t) = "Date/heure non valide. doit être au format AAAA-MM-JJ(T| )HH:MM[:SS] : " `mappend` t
Yesod/Form/I18n/German.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-}+ module Yesod.Form.I18n.German where import Yesod.Form.Types (FormMessage (..))-import Data.Monoid (mappend) import Data.Text (Text) germanFormMessage :: FormMessage -> Text@@ -24,3 +24,5 @@ germanFormMessage MsgBoolYes = "Ja" germanFormMessage MsgBoolNo = "Nein" germanFormMessage MsgDelete = "Löschen?"+germanFormMessage (MsgInvalidHexColorFormat t) = "Ungültige Farbe, muss im Hexadezimalformat #rrggbb vorliegen: " `mappend` t+germanFormMessage (MsgInvalidDatetimeFormat t) = "Ungültige Datums- und Uhrzeitangabe, muss im Format YYYY-MM-DD(T| )HH:MM[:SS] vorliegen: " `mappend` t
+ Yesod/Form/I18n/Japanese.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Form.I18n.Japanese where++import Yesod.Form.Types (FormMessage (..))+import Data.Text (Text)++japaneseFormMessage :: FormMessage -> Text+japaneseFormMessage (MsgInvalidInteger t) = "無効な整数です: " `mappend` t+japaneseFormMessage (MsgInvalidNumber t) = "無効な数値です: " `mappend` t+japaneseFormMessage (MsgInvalidEntry t) = "無効な入力です: " `mappend` t+japaneseFormMessage MsgInvalidTimeFormat = "無効な時刻です。HH:MM[:SS]フォーマットで入力してください"+japaneseFormMessage MsgInvalidDay = "無効な日付です。YYYY-MM-DDフォーマットで入力してください"+japaneseFormMessage (MsgInvalidUrl t) = "無効なURLです: " `mappend` t+japaneseFormMessage (MsgInvalidEmail t) = "無効なメールアドレスです: " `mappend` t+japaneseFormMessage (MsgInvalidHour t) = "無効な時間です: " `mappend` t+japaneseFormMessage (MsgInvalidMinute t) = "無効な分です: " `mappend` t+japaneseFormMessage (MsgInvalidSecond t) = "無効な秒です: " `mappend` t+japaneseFormMessage MsgCsrfWarning = "CSRF攻撃を防ぐため、フォームの入力を確認してください"+japaneseFormMessage MsgValueRequired = "値は必須です"+japaneseFormMessage (MsgInputNotFound t) = "入力が見つかりません: " `mappend` t+japaneseFormMessage MsgSelectNone = "<なし>"+japaneseFormMessage (MsgInvalidBool t) = "無効なbool値です: " `mappend` t+japaneseFormMessage MsgBoolYes = "はい"+japaneseFormMessage MsgBoolNo = "いいえ"+japaneseFormMessage MsgDelete = "削除しますか?"+japaneseFormMessage (MsgInvalidHexColorFormat t) = "無効な色。＃rrggbb16進形式である必要があります: " `mappend` t+japaneseFormMessage (MsgInvalidDatetimeFormat t) = "無効な日時です。YYYY-MM-DD(T| )HH:MM[:SS] 形式である必要があります: " `mappend` t
+ Yesod/Form/I18n/Korean.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Form.I18n.Korean where++import Yesod.Form.Types (FormMessage (..))+import Data.Text (Text)++koreanFormMessage :: FormMessage -> Text+koreanFormMessage (MsgInvalidInteger t) = "잘못된 정수입니다: " `mappend` t+koreanFormMessage (MsgInvalidNumber t) = "잘못된 숫자입니다: " `mappend` t+koreanFormMessage (MsgInvalidEntry t) = "잘못된 입력입니다: " `mappend` t+koreanFormMessage MsgInvalidTimeFormat = "잘못된 시간입니다. HH:MM[:SS] 형태로 입력하세요"+koreanFormMessage MsgInvalidDay = "잘못된 날짜입니다. YYYY-MM-DD 형태로 입력하세요"+koreanFormMessage (MsgInvalidUrl t) = "잘못된 URL입니다: " `mappend` t+koreanFormMessage (MsgInvalidEmail t) = "잘못된 이메일 주소입니다: " `mappend` t+koreanFormMessage (MsgInvalidHour t) = "잘못된 시간입니다: " `mappend` t+koreanFormMessage (MsgInvalidMinute t) = "잘못된 분입니다: " `mappend` t+koreanFormMessage (MsgInvalidSecond t) = "잘못된 초입니다: " `mappend` t+koreanFormMessage MsgCsrfWarning = "CSRF공격을 방지하기 위해 양식의 입력을 확인하세요."+koreanFormMessage MsgValueRequired = "값은 필수입니다"+koreanFormMessage (MsgInputNotFound t) = "입력을 찾을 수 없습니다: " `mappend` t+koreanFormMessage MsgSelectNone = "<없음>"+koreanFormMessage (MsgInvalidBool t) = "잘못된 불(boolean)입니다: " `mappend` t+koreanFormMessage MsgBoolYes = "예"+koreanFormMessage MsgBoolNo = "아니오"+koreanFormMessage MsgDelete = "삭제하시겠습니까?"+koreanFormMessage (MsgInvalidHexColorFormat t) = "색상이 잘못되었습니다. #rrggbb 16진수 형식이어야 합니다.: " `mappend` t+koreanFormMessage (MsgInvalidDatetimeFormat t) = "날짜/시간이 잘못되었습니다. YYYY-MM-DD(T| )HH:MM[:SS] 형식이어야 합니다.: " `mappend` t
+ Yesod/Form/I18n/Norwegian.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Form.I18n.Norwegian where++import Yesod.Form.Types (FormMessage (..))+import Data.Text (Text)++norwegianBokmålFormMessage :: FormMessage -> Text+norwegianBokmålFormMessage (MsgInvalidInteger t) = "Ugyldig antall: " `mappend` t+norwegianBokmålFormMessage (MsgInvalidNumber t) = "Ugyldig nummer: " `mappend` t+norwegianBokmålFormMessage (MsgInvalidEntry t) = "Ugyldig oppføring: " `mappend` t+norwegianBokmålFormMessage MsgInvalidTimeFormat = "Ugyldig klokkeslett, må være i formatet HH:MM[:SS]"+norwegianBokmålFormMessage MsgInvalidDay = "Ugyldig dato, må være i formatet ÅÅÅÅ-MM-DD"+norwegianBokmålFormMessage (MsgInvalidUrl t) = "Ugyldig URL: " `mappend` t+norwegianBokmålFormMessage (MsgInvalidEmail t) = "Ugyldig e-postadresse: " `mappend` t+norwegianBokmålFormMessage (MsgInvalidHour t) = "Ugyldig time: " `mappend` t+norwegianBokmålFormMessage (MsgInvalidMinute t) = "Ugyldig minutt: " `mappend` t+norwegianBokmålFormMessage (MsgInvalidSecond t) = "Ugyldig sekund: " `mappend` t+norwegianBokmålFormMessage MsgValueRequired = "Feltet er obligatorisk"+norwegianBokmålFormMessage (MsgInputNotFound t) = "Feltet ble ikke funnet: " `mappend` t+norwegianBokmålFormMessage MsgSelectNone = "<Ingenting>"+norwegianBokmålFormMessage (MsgInvalidBool t) = "Ugyldig sannhetsverdi: " `mappend` t+norwegianBokmålFormMessage MsgBoolYes = "Ja"+norwegianBokmålFormMessage MsgBoolNo = "Nei"+norwegianBokmålFormMessage MsgDelete = "Slette?"+norwegianBokmålFormMessage MsgCsrfWarning = "Som beskyttelse mot «cross-site request forgery»-angrep, vennligst bekreft innsendt skjema."+norwegianBokmålFormMessage (MsgInvalidHexColorFormat t) = "Ugyldig farge, må være i #rrggbb heksadesimalt format: " `mappend` t+norwegianBokmålFormMessage (MsgInvalidDatetimeFormat t) = "Ugyldig datoklokkeslett, må være i formatet ÅÅÅÅ-MM-DD(T| )HH:MM[:SS]:" `mappend` t
Yesod/Form/I18n/Portuguese.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-}+ module Yesod.Form.I18n.Portuguese where import Yesod.Form.Types (FormMessage (..))-import Data.Monoid (mappend) import Data.Text (Text) portugueseFormMessage :: FormMessage -> Text@@ -24,3 +24,5 @@ portugueseFormMessage MsgBoolYes = "Sim" portugueseFormMessage MsgBoolNo = "Não" portugueseFormMessage MsgDelete = "Remover?"+portugueseFormMessage (MsgInvalidHexColorFormat t) = "Cor inválida, deve estar no formato #rrggbb hexadecimal: " `mappend` t+portugueseFormMessage (MsgInvalidDatetimeFormat t) = "Data e hora inválida, deve estar no formato AAAA-MM-DD(T| )HH:MM[:SS]: " `mappend` t
+ Yesod/Form/I18n/Romanian.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Form.I18n.Romanian where++import Yesod.Form.Types (FormMessage (..))+import Data.Text (Text)++-- | Romanian translation+--+-- @since 1.7.5+romanianFormMessage :: FormMessage -> Text+romanianFormMessage (MsgInvalidInteger t) = "Număr întreg nevalid: " `mappend` t+romanianFormMessage (MsgInvalidNumber t) = "Număr nevalid: " `mappend` t+romanianFormMessage (MsgInvalidEntry t) = "Valoare nevalidă: " `mappend` t+romanianFormMessage MsgInvalidTimeFormat = "Oră nevalidă. Formatul necesar este HH:MM[:SS]"+romanianFormMessage MsgInvalidDay = "Dată nevalidă. Formatul necesar este AAAA-LL-ZZ"+romanianFormMessage (MsgInvalidUrl t) = "Adresă URL nevalidă: " `mappend` t+romanianFormMessage (MsgInvalidEmail t) = "Adresă de e-mail nevalidă: " `mappend` t+romanianFormMessage (MsgInvalidHour t) = "Oră nevalidă: " `mappend` t+romanianFormMessage (MsgInvalidMinute t) = "Minut nevalid: " `mappend` t+romanianFormMessage (MsgInvalidSecond t) = "Secundă nevalidă: " `mappend` t+romanianFormMessage MsgCsrfWarning = "Ca protecție împotriva atacurilor CSRF, vă rugăm să confirmați trimiterea formularului."+romanianFormMessage MsgValueRequired = "Câmp obligatoriu"+romanianFormMessage (MsgInputNotFound t) = "Valoare inexistentă: " `mappend` t+romanianFormMessage MsgSelectNone = "<Niciuna>"+romanianFormMessage (MsgInvalidBool t) = "Valoare booleană nevalidă: " `mappend` t+romanianFormMessage MsgBoolYes = "Da"+romanianFormMessage MsgBoolNo = "Nu"+romanianFormMessage MsgDelete = "Șterge?"+romanianFormMessage (MsgInvalidHexColorFormat t) = "Culoare nevalidă. Formatul necesar este #rrggbb în hexazecimal: " `mappend` t+romanianFormMessage (MsgInvalidDatetimeFormat t) = "Data și ora nevalidă, trebuie să fie în format AAAA-LL-ZZ(T| )HH:MM[:SS]: " `mappend` t
+ Yesod/Form/I18n/Russian.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Form.I18n.Russian where++import Yesod.Form.Types (FormMessage (..))+import Data.Text (Text)++russianFormMessage :: FormMessage -> Text+russianFormMessage (MsgInvalidInteger t) = "Неверно записано целое число: " `mappend` t+russianFormMessage (MsgInvalidNumber t) = "Неверный формат числа: " `mappend` t+russianFormMessage (MsgInvalidEntry t) = "Неверный выбор: " `mappend` t+russianFormMessage MsgInvalidTimeFormat = "Неверно указано время, используйте формат ЧЧ:ММ[:СС]"+russianFormMessage MsgInvalidDay = "Неверно указана дата, используйте формат ГГГГ-ММ-ДД"+russianFormMessage (MsgInvalidUrl t) = "Неверно указан URL адрес: " `mappend` t+russianFormMessage (MsgInvalidEmail t) = "Неверно указана электронная почта: " `mappend` t+russianFormMessage (MsgInvalidHour t) = "Неверно указан час: " `mappend` t+russianFormMessage (MsgInvalidMinute t) = "Неверно указаны минуты: " `mappend` t+russianFormMessage (MsgInvalidSecond t) = "Неверно указаны секунды: " `mappend` t+russianFormMessage MsgCsrfWarning = "Для защиты от межсайтовой подделки запросов (CSRF), пожалуйста, подтвердите отправку данных формы."+russianFormMessage MsgValueRequired = "Обязательно к заполнению"+russianFormMessage (MsgInputNotFound t) = "Поле не найдено: " `mappend` t+russianFormMessage MsgSelectNone = "<Не выбрано>"+russianFormMessage (MsgInvalidBool t) = "Неверное логическое значение: " `mappend` t+russianFormMessage MsgBoolYes = "Да"+russianFormMessage MsgBoolNo = "Нет"+russianFormMessage MsgDelete = "Удалить?"+russianFormMessage (MsgInvalidHexColorFormat t) = "Недопустимое значение цвета, должен быть в шестнадцатеричном формате #rrggbb: " `mappend` t+russianFormMessage (MsgInvalidDatetimeFormat t) = "Недопустимое значение даты и времени. Должно быть в формате ГГГГ-ММ-ДД(T| )ЧЧ:ММ[:СС]: " `mappend` t
+ Yesod/Form/I18n/Spanish.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Form.I18n.Spanish where++import Yesod.Form.Types (FormMessage (..))+import Data.Text (Text)++spanishFormMessage :: FormMessage -> Text+spanishFormMessage (MsgInvalidInteger t) = "Número entero inválido: " `mappend` t+spanishFormMessage (MsgInvalidNumber t) = "Número inválido: " `mappend` t+spanishFormMessage (MsgInvalidEntry t) = "Entrada inválida: " `mappend` t+spanishFormMessage MsgInvalidTimeFormat = "Hora inválida, debe tener el formato HH:MM[:SS]"+spanishFormMessage MsgInvalidDay = "Fecha inválida, debe tener el formato AAAA-MM-DD"+spanishFormMessage (MsgInvalidUrl t) = "URL inválida: " `mappend` t+spanishFormMessage (MsgInvalidEmail t) = "Dirección de correo electrónico inválida: " `mappend` t+spanishFormMessage (MsgInvalidHour t) = "Hora inválida: " `mappend` t+spanishFormMessage (MsgInvalidMinute t) = "Minuto inválido: " `mappend` t+spanishFormMessage (MsgInvalidSecond t) = "Segundo inválido: " `mappend` t+spanishFormMessage MsgCsrfWarning = "Como protección contra ataques CSRF, confirme su envío por favor."+spanishFormMessage MsgValueRequired = "Se requiere un valor"+spanishFormMessage (MsgInputNotFound t) = "Entrada no encontrada: " `mappend` t+spanishFormMessage MsgSelectNone = "<Ninguno>"+spanishFormMessage (MsgInvalidBool t) = "Booleano inválido: " `mappend` t+spanishFormMessage MsgBoolYes = "Sí"+spanishFormMessage MsgBoolNo = "No"+spanishFormMessage MsgDelete = "¿Eliminar?"+spanishFormMessage (MsgInvalidHexColorFormat t) = "Color no válido, debe estar en formato hexadecimal #rrggbb: " `mappend` t+spanishFormMessage (MsgInvalidDatetimeFormat t) = "Fecha y hora no válida; debe estar en formato AAAA-MM-DD(T| )HH:MM[:SS]: " `mappend` t
Yesod/Form/I18n/Swedish.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-}+ module Yesod.Form.I18n.Swedish where import Yesod.Form.Types (FormMessage (..))-import Data.Monoid (mappend) import Data.Text (Text) swedishFormMessage :: FormMessage -> Text@@ -24,3 +24,5 @@ swedishFormMessage MsgBoolNo = "Nej" swedishFormMessage MsgDelete = "Radera?" swedishFormMessage MsgCsrfWarning = "Som skydd mot \"cross-site request forgery\" attacker, vänligen bekräfta skickandet av formuläret."+swedishFormMessage (MsgInvalidHexColorFormat t) = "Ogiltig färg, måste vara i #rrggbb hexadecimalt format: " `mappend` t+swedishFormMessage (MsgInvalidDatetimeFormat t) = "Ogiltig datumtid, måste vara i formatet ÅÅÅÅ-MM-DD(T| )TT:MM[:SS]: " `mappend` t
Yesod/Form/Input.hs view
@@ -1,74 +1,107 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Provides for getting input from either GET or POST params without+-- generating HTML forms. For more information, see:+-- <http://www.yesodweb.com/book/forms#forms_kinds_of_forms>. module Yesod.Form.Input ( FormInput (..) , runInputGet+ , runInputGetResult , runInputPost+ , runInputPostResult , ireq , iopt ) where import Yesod.Form.Types import Data.Text (Text)-import Control.Applicative (Applicative (..))-import Yesod.Handler (GHandler, invalidArgs, runRequestBody, getRequest, getYesod)-import Yesod.Request (reqGetParams, languages)-import Control.Monad (liftM)-import Yesod.Message (RenderMessage (..), SomeMessage (..))+import Yesod.Core+import Control.Monad (liftM, (<=<)) import qualified Data.Map as Map import Data.Maybe (fromMaybe)+import Control.Arrow ((***)) type DText = [Text] -> [Text]-newtype FormInput sub master a = FormInput { unFormInput :: master -> [Text] -> Env -> GHandler sub master (Either DText a) }-instance Functor (FormInput sub master) where- fmap a (FormInput f) = FormInput $ \c d e -> fmap (either Left (Right . a)) $ f c d e-instance Applicative (FormInput sub master) where- pure = FormInput . const . const . const . return . Right- (FormInput f) <*> (FormInput x) = FormInput $ \c d e -> do- res1 <- f c d e- res2 <- x c d e++-- | Type for a form which parses a value of type @a@ with the base monad @m@+-- (usually your @Handler@). Can compose this using its @Applicative@ instance.+newtype FormInput m a = FormInput { unFormInput :: HandlerSite m -> [Text] -> Env -> FileEnv -> m (Either DText a) }+instance Monad m => Functor (FormInput m) where+ fmap a (FormInput f) = FormInput $ \c d e e' -> liftM (either Left (Right . a)) $ f c d e e'+instance Monad m => Applicative (FormInput m) where+ pure = FormInput . const . const . const . const . return . Right+ (FormInput f) <*> (FormInput x) = FormInput $ \c d e e' -> do+ res1 <- f c d e e'+ res2 <- x c d e e' return $ case (res1, res2) of (Left a, Left b) -> Left $ a . b (Left a, _) -> Left a (_, Left b) -> Left b (Right a, Right b) -> Right $ a b -ireq :: (RenderMessage master FormMessage) => Field sub master a -> Text -> FormInput sub master a-ireq field name = FormInput $ \m l env -> do+-- | Promote a @Field@ into a @FormInput@, requiring that the value be present+-- and valid.+ireq :: (Monad m, RenderMessage (HandlerSite m) FormMessage)+ => Field m a+ -> Text -- ^ name of the field+ -> FormInput m a+ireq field name = FormInput $ \m l env fenv -> do let filteredEnv = fromMaybe [] $ Map.lookup name env- emx <- fieldParse field $ filteredEnv+ filteredFEnv = fromMaybe [] $ Map.lookup name fenv+ emx <- fieldParse field filteredEnv filteredFEnv return $ case emx of Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name Right (Just a) -> Right a -iopt :: Field sub master a -> Text -> FormInput sub master (Maybe a)-iopt field name = FormInput $ \m l env -> do+-- | Promote a @Field@ into a @FormInput@, with its presence being optional. If+-- the value is present but does not parse correctly, the form will still fail.+iopt :: Monad m => Field m a -> Text -> FormInput m (Maybe a)+iopt field name = FormInput $ \m l env fenv -> do let filteredEnv = fromMaybe [] $ Map.lookup name env- emx <- fieldParse field $ filteredEnv+ filteredFEnv = fromMaybe [] $ Map.lookup name fenv+ emx <- fieldParse field filteredEnv filteredFEnv return $ case emx of Left (SomeMessage e) -> Left $ (:) $ renderMessage m l e Right x -> Right x -runInputGet :: FormInput sub master a -> GHandler sub master a-runInputGet (FormInput f) = do+-- | Run a @FormInput@ on the GET parameters (i.e., query string). If parsing+-- fails, calls 'invalidArgs'.+runInputGet :: MonadHandler m => FormInput m a -> m a+runInputGet = either invalidArgs return <=< runInputGetHelper++-- | Run a @FormInput@ on the GET parameters (i.e., query string). Does /not/+-- throw exceptions on failure.+--+-- Since 1.4.1+runInputGetResult :: MonadHandler m => FormInput m a -> m (FormResult a)+runInputGetResult = fmap (either FormFailure FormSuccess) . runInputGetHelper++runInputGetHelper :: MonadHandler m => FormInput m a -> m (Either [Text] a)+runInputGetHelper (FormInput f) = do env <- liftM (toMap . reqGetParams) getRequest m <- getYesod l <- languages- emx <- f m l env- case emx of- Left errs -> invalidArgs $ errs []- Right x -> return x+ emx <- f m l env Map.empty+ return $ either (Left . ($ [])) Right emx toMap :: [(Text, a)] -> Map.Map Text [a] toMap = Map.unionsWith (++) . map (\(x, y) -> Map.singleton x [y]) -runInputPost :: FormInput sub master a -> GHandler sub master a-runInputPost (FormInput f) = do- env <- liftM (toMap . fst) runRequestBody+-- | Run a @FormInput@ on the POST parameters (i.e., request body). If parsing+-- fails, calls 'invalidArgs'.+runInputPost :: MonadHandler m => FormInput m a -> m a+runInputPost = either invalidArgs return <=< runInputPostHelper++-- | Run a @FormInput@ on the POST parameters (i.e., request body). Does /not/+-- throw exceptions on failure.+runInputPostResult :: MonadHandler m => FormInput m a -> m (FormResult a)+runInputPostResult = fmap (either FormFailure FormSuccess) . runInputPostHelper++runInputPostHelper :: MonadHandler m => FormInput m a -> m (Either [Text] a)+runInputPostHelper (FormInput f) = do+ (env, fenv) <- liftM (toMap *** toMap) runRequestBody m <- getYesod l <- languages- emx <- f m l env- case emx of- Left errs -> invalidArgs $ errs []- Right x -> return x+ fmap (either (Left . ($ [])) Right) $ f m l env fenv
Yesod/Form/Jquery.hs view
@@ -1,60 +1,50 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+ -- | Some fields spiced up with jQuery UI. module Yesod.Form.Jquery ( YesodJquery (..) , jqueryDayField+ , jqueryDatePickerDayField , jqueryAutocompleteField+ , jqueryAutocompleteField' , googleHostedJqueryUiCss , JqueryDaySettings (..) , Default (..) ) where -import Yesod.Handler-import Yesod.Core (Route)+import Yesod.Core import Yesod.Form-import Yesod.Widget import Data.Time (Day)-import qualified Data.Text as T import Data.Default-import Text.Hamlet (shamlet)-import Text.Julius (julius)+import Text.Julius (rawJS) import Data.Text (Text, pack, unpack)-import Data.Monoid (mconcat)-import Yesod.Core (RenderMessage, SomeMessage (..)) -#if __GLASGOW_HASKELL__ >= 700-#define HTML shamlet-#define HAMLET hamlet-#define CASSIUS cassius-#define JULIUS julius-#else-#define HTML $shamlet-#define HAMLET $hamlet-#define CASSIUS $cassius-#define JULIUS $julius-#endif- -- | Gets the Google hosted jQuery UI 1.8 CSS file with the given theme. googleHostedJqueryUiCss :: Text -> Text googleHostedJqueryUiCss theme = mconcat- [ "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/themes/"+ [ "//ajax.googleapis.com/ajax/libs/jqueryui/1.8/themes/" , theme , "/jquery-ui.css" ] class YesodJquery a where- -- | The jQuery 1.4 Javascript file.+ -- | The jQuery Javascript file. Note that in upgrades to this library, the+ -- version of jQuery referenced, or where it is downloaded from, may be+ -- changed without warning. If you are relying on a specific version of+ -- jQuery, you should give an explicit URL instead of relying on the+ -- default value.+ --+ -- Currently, the default value is jQuery 1.7 from Google\'s CDN. urlJqueryJs :: a -> Either (Route a) Text- urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4/jquery.min.js"+ urlJqueryJs _ = Right "//ajax.googleapis.com/ajax/libs/jquery/1.7/jquery.min.js" -- | The jQuery UI 1.8 Javascript file. urlJqueryUiJs :: a -> Either (Route a) Text- urlJqueryUiJs _ = Right "http://ajax.googleapis.com/ajax/libs/jqueryui/1.8/jquery-ui.min.js"+ urlJqueryUiJs _ = Right "//ajax.googleapis.com/ajax/libs/jqueryui/1.8/jquery-ui.min.js" -- | The jQuery UI 1.8 CSS file; defaults to cupertino theme. urlJqueryUiCss :: a -> Either (Route a) Text@@ -64,44 +54,50 @@ urlJqueryUiDateTimePicker :: a -> Either (Route a) Text urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" -blank :: (RenderMessage master FormMessage, Monad m) => (Text -> Either FormMessage a) -> [Text] -> m (Either (SomeMessage master) (Maybe a))-blank _ [] = return $ Right Nothing-blank _ ("":_) = return $ Right Nothing-blank f (x:_) = return $ either (Left . SomeMessage) (Right . Just) $ f x+jqueryDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerFor site) Day+jqueryDayField = flip jqueryDayField' "date" -jqueryDayField :: (RenderMessage master FormMessage, YesodJquery master) => JqueryDaySettings -> Field sub master Day-jqueryDayField jds = Field- { fieldParse = blank $ maybe+-- | Use jQuery's datepicker as the underlying implementation.+--+-- Since 1.4.3+jqueryDatePickerDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerFor site) Day+jqueryDatePickerDayField = flip jqueryDayField' "text"++jqueryDayField' :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Text -> Field (HandlerFor site) Day+jqueryDayField' jds inputType = Field+ { fieldParse = parseHelper $ maybe (Left MsgInvalidDay) Right . readMay . unpack- , fieldView = \theId name theClass val isReq -> do- addHtml [HTML|\-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="date" :isReq:required="" value="#{showVal val}">+ , fieldView = \theId name attrs val isReq -> do+ toWidget [shamlet|+$newline never+<input id="#{theId}" name="#{name}" *{attrs} type="#{inputType}" :isReq:required="" value="#{showVal val}"> |] addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss- addJulius [JULIUS|+ toWidget [julius| $(function(){- var i = $("##{theId}");- if (i.attr("type") != "date") {- i.datepicker({+ var i = document.getElementById("#{rawJS theId}");+ if (i.type != "date") {+ $(i).datepicker({ dateFormat:'yy-mm-dd', changeMonth:#{jsBool $ jdsChangeMonth jds}, changeYear:#{jsBool $ jdsChangeYear jds},- numberOfMonths:#{mos $ jdsNumberOfMonths jds},- yearRange:"#{jdsYearRange jds}"+ numberOfMonths:#{rawJS $ mos $ jdsNumberOfMonths jds},+ yearRange:#{toJSON $ jdsYearRange jds} }); } }); |]+ , fieldEnctype = UrlEncoded } where showVal = either id (pack . show)- jsBool True = "true" :: Text- jsBool False = "false" :: Text+ jsBool True = toJSON True+ jsBool False = toJSON False mos (Left i) = show i mos (Right (x, y)) = concat [ "["@@ -111,30 +107,40 @@ , "]" ] -jqueryAutocompleteField :: (RenderMessage master FormMessage, YesodJquery master)- => Route master -> Field sub master Text-jqueryAutocompleteField src = Field- { fieldParse = blank $ Right- , fieldView = \theId name theClass val isReq -> do- addHtml [HTML|\-<input id="#{theId}" name="#{name}" :not (null theClass):class="#{T.intercalate " " theClass}" type="text" :isReq:required="" value="#{either id id val}" .autocomplete>+jqueryAutocompleteField :: (RenderMessage site FormMessage, YesodJquery site)+ => Route site -> Field (HandlerFor site) Text+jqueryAutocompleteField = jqueryAutocompleteField' 2++jqueryAutocompleteField' :: (RenderMessage site FormMessage, YesodJquery site)+ => Int -- ^ autocomplete minimum length+ -> Route site+ -> Field (HandlerFor site) Text+jqueryAutocompleteField' minLen src = Field+ { fieldParse = parseHelper $ Right+ , fieldView = \theId name attrs val isReq -> do+ toWidget [shamlet|+$newline never+<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{either id id val}" .autocomplete> |] addScript' urlJqueryJs addScript' urlJqueryUiJs addStylesheet' urlJqueryUiCss- addJulius [JULIUS|-$(function(){$("##{theId}").autocomplete({source:"@{src}",minLength:2})});+ toWidget [julius|+$(function(){$("##{rawJS theId}").autocomplete({source:"@{src}",minLength:#{toJSON minLen}})}); |]+ , fieldEnctype = UrlEncoded } -addScript' :: (master -> Either (Route master) Text) -> GWidget sub master ()+addScript' :: (HandlerSite m ~ site, MonadWidget m) => (site -> Either (Route site) Text) -> m () addScript' f = do- y <- lift getYesod+ y <- getYesod addScriptEither $ f y -addStylesheet' :: (y -> Either (Route y) Text) -> GWidget sub y ()+addStylesheet' :: (MonadWidget m, HandlerSite m ~ site)+ => (site -> Either (Route site) Text)+ -> m () addStylesheet' f = do- y <- lift getYesod+ y <- getYesod addStylesheetEither $ f y readMay :: Read a => String -> Maybe a
Yesod/Form/MassInput.hs view
@@ -1,8 +1,11 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}++-- | A module providing a means of creating multiple input forms, such as a+-- list of 0 or more recipients. module Yesod.Form.MassInput ( inputList , massDivs@@ -11,12 +14,8 @@ import Yesod.Form.Types import Yesod.Form.Functions-import Yesod.Form.Fields (boolField)-import Yesod.Widget (GWidget, whamlet)-import Yesod.Message (RenderMessage)-import Yesod.Handler (newIdent, GHandler)-import Text.Blaze (Html)-import Control.Monad.Trans.Class (lift)+import Yesod.Form.Fields (checkBoxField)+import Yesod.Core import Control.Monad.Trans.RWS (get, put, ask) import Data.Maybe (fromMaybe) import Data.Text.Read (decimal)@@ -26,15 +25,7 @@ import qualified Data.Map as Map import Data.Maybe (listToMaybe) -#if __GLASGOW_HASKELL__ >= 700-#define WHAMLET whamlet-#define HTML html-#else-#define HTML $html-#define WHAMLET $whamlet-#endif--down :: Int -> MForm sub master ()+down :: Monad m => Int -> MForm m () down 0 = return () down i | i < 0 = error "called down with a negative number" down i = do@@ -42,7 +33,7 @@ put $ IntCons 0 is down $ i - 1 -up :: Int -> MForm sub master ()+up :: Monad m => Int -> MForm m () up 0 = return () up i | i < 0 = error "called down with a negative number" up i = do@@ -52,11 +43,19 @@ IntCons _ is' -> put is' >> newFormIdent >> return () up $ i - 1 -inputList :: (m ~ GHandler sub master, xml ~ GWidget sub master (), RenderMessage master FormMessage)+-- | Generate a form that accepts 0 or more values from the user, allowing the+-- user to specify that a new row is necessary.+inputList :: (xml ~ WidgetFor site (), RenderMessage site FormMessage) => Html- -> ([[FieldView sub master]] -> xml)- -> (Maybe a -> AForm sub master a)- -> (Maybe [a] -> AForm sub master [a])+ -- ^ label for the form+ -> ([[FieldView site]] -> xml)+ -- ^ how to display the rows, usually either 'massDivs' or 'massTable'+ -> (Maybe a -> AForm (HandlerFor site) a)+ -- ^ display a single row of the form, where @Maybe a@ gives the+ -- previously submitted value+ -> Maybe [a]+ -- ^ default initial values for the form+ -> AForm (HandlerFor site) [a] inputList label fixXml single mdef = formToAForm $ do theId <- lift newIdent down 1@@ -82,7 +81,8 @@ { fvLabel = label , fvTooltip = Nothing , fvId = theId- , fvInput = [WHAMLET|+ , fvInput = [whamlet|+$newline never ^{fixXml views} <p> $forall xml <- xmls@@ -95,41 +95,44 @@ , fvRequired = False }]) -withDelete :: (xml ~ GWidget sub master (), RenderMessage master FormMessage)- => AForm sub master a- -> MForm sub master (Either xml (FormResult a, [FieldView sub master]))+withDelete :: (xml ~ WidgetFor site (), RenderMessage site FormMessage)+ => AForm (HandlerFor site) a+ -> MForm (HandlerFor site) (Either xml (FormResult a, [FieldView site])) withDelete af = do down 1 deleteName <- newFormIdent (menv, _, _) <- ask res <- case menv >>= Map.lookup deleteName . fst of- Just ("yes":_) -> return $ Left [WHAMLET|<input type=hidden name=#{deleteName} value=yes>|]+ Just ("yes":_) -> return $ Left [whamlet|+$newline never+<input type=hidden name=#{deleteName} value=yes>+|] _ -> do- (_, xml2) <- aFormToForm $ areq boolField FieldSettings- { fsLabel = MsgDelete+ (_, xml2) <- aFormToForm $ areq checkBoxField FieldSettings+ { fsLabel = SomeMessage MsgDelete , fsTooltip = Nothing , fsName = Just deleteName , fsId = Nothing- , fsClass = []+ , fsAttrs = [] } $ Just False (res, xml) <- aFormToForm af return $ Right (res, xml $ xml2 []) up 1 return res -fixme :: (xml ~ GWidget sub master ())- => [Either xml (FormResult a, [FieldView sub master])]- -> (FormResult [a], [xml], [[FieldView sub master]])+fixme :: [Either xml (FormResult a, [FieldView site])]+ -> (FormResult [a], [xml], [[FieldView site]]) fixme eithers = (res, xmls, map snd rest) where (xmls, rest) = partitionEithers eithers- res = sequenceA $ map fst rest+ res = Data.Traversable.sequenceA $ map fst rest massDivs, massTable- :: [[FieldView sub master]]- -> GWidget sub master ()-massDivs viewss = [WHAMLET|+ :: [[FieldView site]]+ -> WidgetFor site ()+massDivs viewss = [whamlet|+$newline never $forall views <- viewss <fieldset> $forall view <- views@@ -142,7 +145,8 @@ <div .errors>#{err} |] -massTable viewss = [WHAMLET|+massTable viewss = [whamlet|+$newline never $forall views <- viewss <fieldset> <table>
Yesod/Form/Nic.hs view
@@ -1,26 +1,28 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+ -- | Provide the user with a rich text editor.+--+-- According to NIC editor homepage it is not actively maintained since June+-- 2012. There is another better alternative — open sourced Summernote editor+-- released under MIT licence. You can use Summernote in your Yesod forms via+-- separately distributed+-- <http://hackage.haskell.org/package/yesod-form-richtext yesod-form-richtext>+-- package. module Yesod.Form.Nic ( YesodNic (..) , nicHtmlField ) where -import Yesod.Handler-import Yesod.Core (Route, ScriptLoadPosition(..), jsLoader, Yesod)+import Yesod.Core import Yesod.Form-import Yesod.Widget import Text.HTML.SanitizeXSS (sanitizeBalance)-import Text.Hamlet (Html, shamlet)-import Text.Julius (julius)-import Text.Blaze.Renderer.String (renderHtml)-import Text.Blaze (preEscapedText)+import Text.Julius (rawJS)+import Text.Blaze.Html.Renderer.String (renderHtml) import Data.Text (Text, pack)-import qualified Data.Text as T import Data.Maybe (listToMaybe) class Yesod a => YesodNic a where@@ -28,43 +30,32 @@ urlNicEdit :: a -> Either (Route a) Text urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" -nicHtmlField :: YesodNic master => Field sub master Html+nicHtmlField :: YesodNic site => Field (HandlerFor site) Html nicHtmlField = Field- { fieldParse = return . Right . fmap (preEscapedText . sanitizeBalance) . listToMaybe- , fieldView = \theId name theClass val _isReq -> do- addHtml-#if __GLASGOW_HASKELL__ >= 700- [shamlet|-#else- [$shamlet|-#endif- <textarea id="#{theId}" :not (null theClass):class="#{T.intercalate " " theClass}" name="#{name}" .html>#{showVal val}+ { fieldParse = \e _ -> return . Right . fmap (preEscapedToMarkup . sanitizeBalance) . listToMaybe $ e+ , fieldView = \theId name attrs val _isReq -> do+ toWidget [shamlet|+$newline never+ <textarea id="#{theId}" *{attrs} name="#{name}" .html>#{showVal val} |] addScript' urlNicEdit- master <- lift getYesod- addJulius $+ master <- getYesod+ toWidget $ case jsLoader master of- BottomOfHeadBlocking ->-#if __GLASGOW_HASKELL__ >= 700- [julius|-#else- [$julius|-#endif-bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{theId}")});+ BottomOfHeadBlocking -> [julius|+bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{rawJS theId}")}); |]- _ ->-#if __GLASGOW_HASKELL__ >= 700- [julius|-#else- [$julius|-#endif-(function(){new nicEditor({fullPanel:true}).panelInstance("#{theId}")})();+ _ -> [julius|+(function(){new nicEditor({fullPanel:true}).panelInstance("#{rawJS theId}")})(); |]+ , fieldEnctype = UrlEncoded } where showVal = either id (pack . renderHtml) -addScript' :: (y -> Either (Route y) Text) -> GWidget sub y ()+addScript' :: (MonadWidget m, HandlerSite m ~ site)+ => (site -> Either (Route site) Text)+ -> m () addScript' f = do- y <- lift getYesod+ y <- getYesod addScriptEither $ f y
+ Yesod/Form/Option.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE FlexibleContexts #-}++module Yesod.Form.Option where++import Yesod.Core+import Yesod.Form.Fields++-- | Creates an `OptionList` from a `List`, using the `PathPiece` instance for+-- the external value and a custom function for the user-facing value.+--+-- @since 1.7.7+--+-- PathPiece instances should provide suitable external values, since path+-- pieces serve to be exposed through URLs or HTML anyway. Show/Read instances+-- are avoided here since they could leak internal representations to forms,+-- query params, javascript etc.+--+-- === __Example usage__+--+-- > data UserRole = URSalesTeam | URSalesHead | URTechTeam | URTechHead+-- >+-- > instance PathPiece UserDepartment where+-- > toPathPiece = \case+-- > URSalesTeam -> "sales-team"+-- > URSalesHead -> "sales-head"+-- > URTechTeam -> "tech-team"+-- > URTechHead -> "tech-head"+-- > fromPathPiece = \case+-- > "sales-team" -> Just URSalesTeam+-- > "sales-head" -> Just URSalesHead+-- > "tech-team" -> Just URTechTeam+-- > "tech-head" -> Just URTechHead+-- > _ -> Nothing+-- >+-- > userRoleOptions ::+-- > (MonadHandler m, RenderMessage (HandlerSite m) msg) => m (OptionList UserRole)+-- > userRoleOptions = optionsFromList' userRoles toMsg+-- > where+-- > userRoles = [URSalesTeam, URSalesHead, URTechTeam, URTechHead]+-- > toMsg :: UserRole -> Text+-- > toMsg = \case+-- > URSalesTeam -> "Sales Team"+-- > URSalesHead -> "Head of Sales Team"+-- > URTechTeam -> "Tech Team"+-- > URTechHead -> "Head of Tech Team"+--+-- userRoleOptions, will produce an OptionList with the following attributes:+--+-- > +----------------+----------------+--------------------++-- > | Internal Value | External Value | User-facing Value |+-- > +----------------+----------------+--------------------++-- > | URSalesTeam | sales-team | Sales Team |+-- > +----------------+----------------+--------------------++-- > | URSalesHead | sales-head | Head of Sales Team |+-- > +----------------+----------------+--------------------++-- > | URTechTeam | tech-team | Tech Team |+-- > +----------------+----------------+--------------------++-- > | URTechHead | tech-head | Head of Tech Team |+-- > +----------------+----------------+--------------------++--+-- Note that the type constraint allows localizable messages in place of toMsg (see+-- https://en.wikipedia.org/wiki/Yesod_(web_framework)#Localizable_messages).++optionsFromList' ::+ MonadHandler m+ => RenderMessage (HandlerSite m) msg+ => PathPiece a+ => [a]+ -> (a -> msg)+ -> m (OptionList a)+optionsFromList' lst toDisplay = do+ mr <- getMessageRender+ pure $ mkOptionList $ flip map lst $ \v -> Option+ { optionDisplay = mr $ toDisplay v+ , optionInternalValue = v+ , optionExternalValue = toPathPiece v+ }++-- | Creates an `OptionList` from an `Enum`.+--+-- @since 1.7.7+--+-- optionsEnum' == optionsFromList' [minBound..maxBound]+--+-- Creates an `OptionList` containing every constructor of `a`, so that these+-- constructors do not need to be typed out. Bounded and Enum instances must+-- exist for `a` to use this.+optionsEnum' ::+ MonadHandler m+ => RenderMessage (HandlerSite m) msg+ => PathPiece a+ => Enum a+ => Bounded a+ => (a -> msg)+ -> m (OptionList a)+optionsEnum' = optionsFromList' [minBound..maxBound]
Yesod/Form/Types.hs view
@@ -1,6 +1,9 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ExistentialQuantification #-}+ module Yesod.Form.Types ( -- * Helpers Enctype (..)@@ -10,34 +13,43 @@ , FileEnv , Ints (..) -- * Form+ , WForm , MForm , AForm (..) -- * Build forms , Field (..) , FieldSettings (..) , FieldView (..)+ , FieldViewFunc ) where import Control.Monad.Trans.RWS (RWST)-import Yesod.Request (FileInfo)+import Control.Monad.Trans.Writer (WriterT) import Data.Text (Text)-import Data.Monoid (Monoid (..))-import Text.Blaze (Html, ToHtml (toHtml))-import Control.Applicative ((<$>), Applicative (..))+import Text.Blaze (Markup, ToMarkup (toMarkup), ToValue (toValue))+#define Html Markup+#define ToHtml ToMarkup+#define toHtml toMarkup+import Control.Applicative (Alternative (..)) import Control.Monad (liftM)+import Control.Monad.Trans.Class import Data.String (IsString (..))-import Yesod.Core (GHandler, GWidget, SomeMessage)+import Yesod.Core import qualified Data.Map as Map+import Data.Traversable+import Data.Foldable -- | A form can produce three different results: there was no data available, -- the data was invalid, or there was a successful parse. -- -- The 'Applicative' instance will concatenate the failure messages in two -- 'FormResult's.+-- The 'Alternative' instance will choose 'FormFailure' before 'FormSuccess',+-- and 'FormMissing' last of all. data FormResult a = FormMissing | FormFailure [Text] | FormSuccess a- deriving Show+ deriving (Show, Eq) instance Functor FormResult where fmap _ FormMissing = FormMissing fmap _ (FormFailure errs) = FormFailure errs@@ -51,8 +63,34 @@ _ <*> _ = FormMissing instance Monoid m => Monoid (FormResult m) where mempty = pure mempty- mappend x y = mappend <$> x <*> y+ mappend = (<>)+instance Semigroup m => Semigroup (FormResult m) where+ x <> y = (<>) <$> x <*> y +-- | @since 1.4.5+instance Data.Foldable.Foldable FormResult where+ foldMap f r = case r of+ FormSuccess a -> f a+ FormFailure _errs -> mempty+ FormMissing -> mempty++-- | @since 1.4.5+instance Data.Traversable.Traversable FormResult where+ traverse f r = case r of+ FormSuccess a -> fmap FormSuccess (f a)+ FormFailure errs -> pure (FormFailure errs)+ FormMissing -> pure FormMissing++-- | @since 1.4.15+instance Alternative FormResult where+ empty = FormMissing++ FormFailure e <|> _ = FormFailure e+ _ <|> FormFailure e = FormFailure e+ FormSuccess s <|> FormSuccess _ = FormSuccess s+ FormMissing <|> result = result+ result <|> FormMissing = result+ -- | The encoding type required by a form. The 'ToHtml' instance produces values -- that can be inserted directly into HTML. data Enctype = UrlEncoded | Multipart@@ -60,10 +98,14 @@ instance ToHtml Enctype where toHtml UrlEncoded = "application/x-www-form-urlencoded" toHtml Multipart = "multipart/form-data"+instance ToValue Enctype where+ toValue UrlEncoded = "application/x-www-form-urlencoded"+ toValue Multipart = "multipart/form-data" instance Monoid Enctype where mempty = UrlEncoded- mappend UrlEncoded UrlEncoded = UrlEncoded- mappend _ _ = Multipart+instance Semigroup Enctype where+ UrlEncoded <> UrlEncoded = UrlEncoded+ _ <> _ = Multipart data Ints = IntCons Int Ints | IntSingle Int instance Show Ints where@@ -71,58 +113,110 @@ show (IntCons i is) = show i ++ ('-' : show is) type Env = Map.Map Text [Text]-type FileEnv = Map.Map Text FileInfo+type FileEnv = Map.Map Text [FileInfo] -type Lang = Text-type MForm sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GHandler sub master) a+-- | 'MForm' variant stacking a 'WriterT'. The following code example using a+-- monadic form 'MForm':+--+-- > formToAForm $ do+-- > (field1F, field1V) <- mreq textField MsgField1 Nothing+-- > (field2F, field2V) <- mreq (checkWith field1F textField) MsgField2 Nothing+-- > (field3F, field3V) <- mreq (checkWith field1F textField) MsgField3 Nothing+-- > return+-- > ( MyForm <$> field1F <*> field2F <*> field3F+-- > , [field1V, field2V, field3V]+-- > )+--+-- Could be rewritten as follows using 'WForm':+--+-- > wFormToAForm $ do+-- > field1F <- wreq textField MsgField1 Nothing+-- > field2F <- wreq (checkWith field1F textField) MsgField2 Nothing+-- > field3F <- wreq (checkWith field1F textField) MsgField3 Nothing+-- > return $ MyForm <$> field1F <*> field2F <*> field3F+--+-- @since 1.4.14+type WForm m a = MForm (WriterT [FieldView (HandlerSite m)] m) a -newtype AForm sub master a = AForm- { unAForm :: (master, [Text]) -> Maybe (Env, FileEnv) -> Ints -> GHandler sub master (FormResult a, [FieldView sub master] -> [FieldView sub master], Ints, Enctype)+type MForm m a = RWST+ (Maybe (Env, FileEnv), HandlerSite m, [Lang])+ Enctype+ Ints+ m+ a++newtype AForm m a = AForm+ { unAForm :: (HandlerSite m, [Text])+ -> Maybe (Env, FileEnv)+ -> Ints+ -> m (FormResult a, [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)], Ints, Enctype) }-instance Functor (AForm sub master) where+instance Monad m => Functor (AForm m) where fmap f (AForm a) = AForm $ \x y z -> liftM go $ a x y z where go (w, x, y, z) = (fmap f w, x, y, z)-instance Applicative (AForm sub master) where- pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, mempty, ints, mempty)+instance Monad m => Applicative (AForm m) where+ pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, id, ints, mempty) (AForm f) <*> (AForm g) = AForm $ \mr env ints -> do (a, b, ints', c) <- f mr env ints (x, y, ints'', z) <- g mr env ints'- return (a <*> x, b `mappend` y, ints'', c `mappend` z)-instance Monoid a => Monoid (AForm sub master a) where+ return (a <*> x, b . y, ints'', c `mappend` z)++#if MIN_VERSION_transformers(0,6,0)+instance Monad m => Monad (AForm m) where+ (AForm f) >>= k = AForm $ \mr env ints -> do+ (a, b, ints', c) <- f mr env ints+ case a of+ FormSuccess r -> do+ (x, y, ints'', z) <- unAForm (k r) mr env ints'+ return (x, b . y, ints'', c `mappend` z)+ FormFailure err -> pure (FormFailure err, b, ints', c)+ FormMissing -> pure (FormMissing, b, ints', c)+#endif+instance (Monad m, Monoid a) => Monoid (AForm m a) where mempty = pure mempty- mappend a b = mappend <$> a <*> b+ mappend = (<>)+instance (Monad m, Semigroup a) => Semigroup (AForm m a) where+ a <> b = (<>) <$> a <*> b -data FieldSettings msg = FieldSettings- { fsLabel :: msg -- FIXME switch to SomeMessage?- , fsTooltip :: Maybe msg+instance MonadTrans AForm where+ lift f = AForm $ \_ _ ints -> do+ x <- f+ return (FormSuccess x, id, ints, mempty)++data FieldSettings master = FieldSettings+ { fsLabel :: SomeMessage master+ , fsTooltip :: Maybe (SomeMessage master) , fsId :: Maybe Text , fsName :: Maybe Text- , fsClass :: [Text]+ , fsAttrs :: [(Text, Text)] } -instance (a ~ Text) => IsString (FieldSettings a) where+instance IsString (FieldSettings a) where fromString s = FieldSettings (fromString s) Nothing Nothing Nothing [] -data FieldView sub master = FieldView+data FieldView site = FieldView { fvLabel :: Html , fvTooltip :: Maybe Html , fvId :: Text- , fvInput :: GWidget sub master ()+ , fvInput :: WidgetFor site () , fvErrors :: Maybe Html , fvRequired :: Bool } -data Field sub master a = Field- { fieldParse :: [Text] -> GHandler sub master (Either (SomeMessage master) (Maybe a))- -- | ID, name, class, (invalid text OR legimiate result), required?- , fieldView :: Text- -> Text- -> [Text]- -> Either Text a- -> Bool- -> GWidget sub master ()+type FieldViewFunc m a+ = Text -- ^ ID+ -> Text -- ^ Name+ -> [(Text, Text)] -- ^ Attributes+ -> Either Text a -- ^ Either (invalid text) or (legitimate result)+ -> Bool -- ^ Required?+ -> WidgetFor (HandlerSite m) ()++data Field m a = Field+ { fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a))+ , fieldView :: FieldViewFunc m a+ , fieldEnctype :: Enctype } data FormMessage = MsgInvalidInteger Text@@ -143,3 +237,6 @@ | MsgBoolYes | MsgBoolNo | MsgDelete+ | MsgInvalidHexColorFormat Text+ | MsgInvalidDatetimeFormat Text+ deriving (Show, Eq, Read)
+ test/main.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}+import Test.Hspec+import Data.Time (TimeOfDay (TimeOfDay))+import Data.Text (pack)++import Yesod.Form.Fields (parseTime)+import Yesod.Form.Types++main :: IO ()+main = hspec $+ describe "parseTime" $ mapM_ (\(s, e) -> it s $ parseTime (pack s) `shouldBe` e)+ [ ("01:00:00", Right $ TimeOfDay 1 0 0)+ , ("1:00", Right $ TimeOfDay 1 0 0)+ , ("1:00 AM", Right $ TimeOfDay 1 0 0)+ , ("1:00 am", Right $ TimeOfDay 1 0 0)+ , ("1:00AM", Right $ TimeOfDay 1 0 0)+ , ("1:00am", Right $ TimeOfDay 1 0 0)+ , ("01:00:00am", Right $ TimeOfDay 1 0 0)+ , ("01:00:00 am", Right $ TimeOfDay 1 0 0)+ , ("01:00:00AM", Right $ TimeOfDay 1 0 0)+ , ("01:00:00 AM", Right $ TimeOfDay 1 0 0)+ , ("1:00:01", Right $ TimeOfDay 1 0 1)+ , ("1:00:02 AM", Right $ TimeOfDay 1 0 2)+ , ("1:00:04 am", Right $ TimeOfDay 1 0 4)+ , ("1:00:05 am", Right $ read "01:00:05")+ , ("1:00:64 am", Left $ MsgInvalidSecond "64")+ , ("1:00:4 am", Left $ MsgInvalidSecond "4")+ , ("0:00", Right $ TimeOfDay 0 0 0)+ , ("12:00am", Right $ TimeOfDay 0 0 0)+ , ("12:59:59am", Right $ TimeOfDay 0 59 59)+ , ("12:59:60am", Left $ MsgInvalidSecond "60")+ , ("12:60:59am", Left $ MsgInvalidMinute "60")+ , ("12:00pm", Right $ TimeOfDay 12 0 0)+ , ("12:59:59pm", Right $ TimeOfDay 12 59 59)+ , ("12:59:60pm", Left $ MsgInvalidSecond "60")+ , ("12:60:59pm", Left $ MsgInvalidMinute "60")+ , ("12:7pm", Left $ MsgInvalidMinute "7")+ , ("23:47", Right $ TimeOfDay 23 47 0)+ ]
yesod-form.cabal view
@@ -1,42 +1,55 @@+cabal-version: >= 1.10 name: yesod-form-version: 0.4.2.1-license: BSD3+version: 1.7.9.3+license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> maintainer: Michael Snoyman <michael@snoyman.com> synopsis: Form handling support for Yesod Web Framework category: Web, Yesod stability: Stable-cabal-version: >= 1.6 build-type: Simple homepage: http://www.yesodweb.com/-description: Form handling support for Yesod Web Framework+description: API docs and the README are available at <http://www.stackage.org/package/yesod-form>. Third-party packages which you can find useful: <http://hackage.haskell.org/package/yesod-form-richtext yesod-form-richtext> - richtext form fields (currently it provides only Summernote support).+extra-source-files: ChangeLog.md+ README.md +flag network-uri+ description: Get Network.URI from the network-uri package+ default: True+ library- build-depends: base >= 4 && < 5- , yesod-core >= 0.10.2 && < 0.11- , yesod-persistent >= 0.3.1 && < 0.4+ default-language: Haskell2010+ build-depends: base >= 4.11 && < 5+ , aeson+ , attoparsec >= 0.10+ , blaze-builder >= 0.2.1.4+ , blaze-html >= 0.5+ , blaze-markup >= 0.5.1+ , byteable+ , bytestring >= 0.9.1.4+ , containers >= 0.2+ , data-default+ , email-validate >= 1.0+ , persistent+ , resourcet+ , shakespeare >= 2.0+ , text >= 0.9 , time >= 1.1.4- , hamlet >= 0.10 && < 0.11- , shakespeare-css >= 0.10 && < 0.11- , shakespeare-js >= 0.11 && < 0.12- , persistent >= 0.8 && < 0.9- , template-haskell- , transformers >= 0.2.2 && < 0.3- , data-default >= 0.3 && < 0.4- , xss-sanitize >= 0.3.0.1 && < 0.4- , blaze-builder >= 0.2.1.4 && < 0.4- , network >= 2.2 && < 2.4- , email-validate >= 0.2.6 && < 0.3- , blaze-html >= 0.4.1.3 && < 0.5- , bytestring >= 0.9.1.4 && < 0.10- , text >= 0.9 && < 1.0- , wai >= 1.1 && < 1.2- , containers >= 0.2 && < 0.5+ , transformers >= 0.2.2+ , wai >= 1.3+ , xss-sanitize >= 0.3.0.1+ , yesod-core >= 1.6 && < 1.8+ , yesod-persistent >= 1.6 && < 1.7++ if flag(network-uri)+ build-depends: network-uri >= 2.6+ exposed-modules: Yesod.Form- Yesod.Form.Class+ Yesod.Form.Option Yesod.Form.Types Yesod.Form.Functions+ Yesod.Form.Bootstrap3 Yesod.Form.Input Yesod.Form.Fields Yesod.Form.Jquery@@ -46,8 +59,29 @@ Yesod.Form.I18n.Portuguese Yesod.Form.I18n.Swedish Yesod.Form.I18n.German+ Yesod.Form.I18n.French+ Yesod.Form.I18n.Norwegian+ Yesod.Form.I18n.Japanese+ Yesod.Form.I18n.Czech+ Yesod.Form.I18n.Russian+ Yesod.Form.I18n.Dutch+ Yesod.Form.I18n.Spanish+ Yesod.Form.I18n.Chinese+ Yesod.Form.I18n.Korean+ Yesod.Form.I18n.Romanian -- FIXME Yesod.Helpers.Crud ghc-options: -Wall++test-suite test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: test+ build-depends: base+ , yesod-form+ , time+ , hspec+ , text source-repository head type: git