yesod-form 0.1.0.1 → 0.2.0
raw patch · 14 files changed
+1245/−2103 lines, 14 filesdep +waidep ~hamletdep ~yesod-coresetup-changed
Dependencies added: wai
Dependency ranges changed: hamlet, yesod-core
Files
- LICENSE +25/−25
- Setup.lhs +7/−7
- Yesod/Form.hs +14/−313
- Yesod/Form/Class.hs +77/−69
- Yesod/Form/Core.hs +0/−376
- Yesod/Form/Fields.hs +392/−509
- Yesod/Form/Functions.hs +234/−0
- Yesod/Form/Input.hs +63/−0
- Yesod/Form/Jquery.hs +202/−241
- Yesod/Form/Nic.hs +61/−65
- Yesod/Form/Profiles.hs +0/−251
- Yesod/Form/Types.hs +124/−0
- Yesod/Helpers/Crud.hs +0/−203
- yesod-form.cabal +46/−44
LICENSE view
@@ -1,25 +1,25 @@-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: - -* Redistributions of source code must retain the above copyright notice, this - list of conditions and the following disclaimer. - -* 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. - -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 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:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* 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.++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.
Setup.lhs view
@@ -1,7 +1,7 @@-#!/usr/bin/env runhaskell - -> module Main where -> import Distribution.Simple - -> main :: IO () -> main = defaultMain +#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
Yesod/Form.hs view
@@ -1,313 +1,14 @@-{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} --- | Parse forms (and query strings). -module Yesod.Form - ( -- * Data types - GForm - , FormResult (..) - , Enctype (..) - , FormFieldSettings (..) - , Textarea (..) - , FieldInfo (..) - -- ** Utilities - , formFailures - -- * Type synonyms - , Form - , Formlet - , FormField - , FormletField - , FormInput - -- * Unwrapping functions - , generateForm - , runFormGet - , runFormMonadGet - , runFormPost - , runFormPostNoNonce - , runFormMonadPost - , runFormGet' - , runFormPost' - -- ** High-level form post unwrappers - , runFormTable - , runFormDivs - -- * Field/form helpers - , fieldsToTable - , fieldsToDivs - , fieldsToPlain - , checkForm - -- * Type classes - , module Yesod.Form.Class - -- * Template Haskell - , mkToForm - , module Yesod.Form.Fields - ) where - -import Yesod.Form.Core -import Yesod.Form.Fields -import Yesod.Form.Class -import Yesod.Form.Profiles (Textarea (..)) -import Yesod.Widget (GWidget) - -import Text.Hamlet -import Yesod.Request -import Yesod.Handler -import Control.Applicative hiding (optional) -import Data.Maybe (fromMaybe, mapMaybe) -import Control.Monad ((<=<)) -import Language.Haskell.TH.Syntax hiding (lift) -import Database.Persist.Base (EntityDef (..), PersistEntity (entityDef)) -import Data.Char (toUpper, isUpper) -import Control.Arrow ((&&&)) -import Data.List (group, sort) -import Data.Monoid (mempty) -import Data.Text (Text) - -#if __GLASGOW_HASKELL__ >= 700 -#define HAMLET hamlet -#else -#define HAMLET $hamlet -#endif --- | Display only the actual input widget code, without any decoration. -fieldsToPlain :: FormField sub y a -> Form sub y a -fieldsToPlain = mapFormXml $ mapM_ fiInput - --- | Display the label, tooltip, input code and errors in a single row of a --- table. -fieldsToTable :: FormField sub y a -> Form sub y a -fieldsToTable = mapFormXml $ mapM_ go - where - go fi = [HAMLET| -<tr .#{clazz fi}> - <td> - <label for="#{fiIdent fi}">#{fiLabel fi} - <div .tooltip>#{fiTooltip fi} - <td> - \^{fiInput fi} - $maybe err <- fiErrors fi - <td .errors>#{err} -|] - clazz fi = if fiRequired fi then "required" else "optional" :: Text - --- | Display the label, tooltip, input code and errors in a single div. -fieldsToDivs :: FormField sub y a -> Form sub y a -fieldsToDivs = mapFormXml $ mapM_ go - where - go fi = [HAMLET| -<div .#{clazz fi}> - <label for="#{fiIdent fi}">#{fiLabel fi} - <div .tooltip>#{fiTooltip fi} - \^{fiInput fi} - $maybe err <- fiErrors fi - <div .errors>#{err} -|] - clazz fi = if fiRequired fi then "required" else "optional" :: Text - --- | Run a form against POST parameters, without CSRF protection. -runFormPostNoNonce :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) -runFormPostNoNonce f = do - (pp, files) <- runRequestBody - runFormGeneric pp files f - --- | Run a form against POST parameters. --- --- This function includes CSRF protection by checking a nonce value. You must --- therefore embed this nonce in the form as a hidden field; that is the --- meaning of the fourth element in the tuple. -runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype, Html) -runFormPost f = do - (pp, files) <- runRequestBody - nonce <- fmap reqNonce getRequest - (res, xml, enctype) <- runFormGeneric pp files f - let res' = - case res of - FormSuccess x -> - if lookup nonceName pp == nonce - then FormSuccess x - else FormFailure ["As a protection against cross-site request forgery attacks, please confirm your form submission."] - _ -> res - return (res', xml, enctype, maybe mempty hidden nonce) - where - hidden nonce = [HAMLET| - <input type="hidden" name="#{nonceName}" value="#{nonce}"> -|] - -nonceName :: Text -nonceName = "_nonce" - --- | Run a form against POST parameters. Please note that this does not provide --- CSRF protection. -runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype) -runFormMonadPost f = do - (pp, files) <- runRequestBody - runFormGeneric pp files f - --- | Run a form against POST parameters, disregarding the resulting HTML and --- returning an error response on invalid input. Note: this does /not/ perform --- CSRF protection. -runFormPost' :: GForm sub y xml a -> GHandler sub y a -runFormPost' f = do - (pp, files) <- runRequestBody - x <- runFormGeneric pp files f - helper x - --- | Create a table-styled form. --- --- This function wraps around 'runFormPost' and 'fieldsToTable', taking care of --- some of the boiler-plate in creating forms. In particular, is automatically --- creates the form element, sets the method, action and enctype attributes, --- adds the CSRF-protection nonce hidden field and inserts a submit button. -runFormTable :: Route m -> String -> FormField s m a - -> GHandler s m (FormResult a, GWidget s m ()) -runFormTable dest inputLabel form = do - (res, widget, enctype, nonce) <- runFormPost $ fieldsToTable form - return (res, [HAMLET| -<form method="post" action="@{dest}" enctype="#{enctype}"> - <table> - \^{widget} - <tr> - <td colspan="2"> - \#{nonce} - <input type="submit" value="#{inputLabel}"> -|]) - --- | Same as 'runFormPostTable', but uses 'fieldsToDivs' for styling. -runFormDivs :: Route m -> String -> FormField s m a - -> GHandler s m (FormResult a, GWidget s m ()) -runFormDivs dest inputLabel form = do - (res, widget, enctype, nonce) <- runFormPost $ fieldsToDivs form - return (res, [HAMLET| -<form method="post" action="@{dest}" enctype="#{enctype}"> - \^{widget} - <div> - \#{nonce} - <input type="submit" value="#{inputLabel}"> -|]) - --- | Run a form against GET parameters, disregarding the resulting HTML and --- returning an error response on invalid input. -runFormGet' :: GForm sub y xml a -> GHandler sub y a -runFormGet' = helper <=< runFormGet - -helper :: (FormResult a, b, c) -> GHandler sub y a -helper (FormSuccess a, _, _) = return a -helper (FormFailure e, _, _) = invalidArgs e -helper (FormMissing, _, _) = invalidArgs ["No input found"] - --- | Generate a form, feeding it no data. The third element in the result tuple --- is a nonce hidden field. -generateForm :: GForm s m xml a -> GHandler s m (xml, Enctype, Html) -generateForm f = do - (_, b, c) <- runFormGeneric [] [] f - nonce <- fmap reqNonce getRequest - return (b, c, [HAMLET|\ -$maybe n <- nonce - <input type="hidden" name="#{nonceName}" value="#{n}"> -|]) - --- | Run a form against GET parameters. -runFormGet :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype) -runFormGet f = do - gs <- reqGetParams `fmap` getRequest - runFormGeneric gs [] f - -runFormMonadGet :: GFormMonad s m a -> GHandler s m (a, Enctype) -runFormMonadGet f = do - gs <- reqGetParams `fmap` getRequest - runFormGeneric gs [] f - --- | Create 'ToForm' instances for the given entity. In addition to regular 'EntityDef' attributes understood by persistent, it also understands label= and tooltip=. -mkToForm :: PersistEntity v => v -> Q [Dec] -mkToForm = - fmap return . derive . entityDef - where - afterPeriod s = - case dropWhile (/= '.') s of - ('.':t) -> t - _ -> s - beforePeriod s = - case break (== '.') s of - (t, '.':_) -> Just t - _ -> Nothing - getSuperclass (_, _, z) = getTFF' z >>= beforePeriod - getTFF (_, _, z) = maybe "toFormField" afterPeriod $ getTFF' z - getTFF' [] = Nothing - getTFF' (('t':'o':'F':'o':'r':'m':'F':'i':'e':'l':'d':'=':x):_) = Just x - getTFF' (_:x) = getTFF' x - getLabel (x, _, z) = fromMaybe (toLabel x) $ getLabel' z - getLabel' [] = Nothing - getLabel' (('l':'a':'b':'e':'l':'=':x):_) = Just x - getLabel' (_:x) = getLabel' x - getTooltip (_, _, z) = fromMaybe "" $ getTooltip' z - getTooltip' (('t':'o':'o':'l':'t':'i':'p':'=':x):_) = Just x - getTooltip' (_:x) = getTooltip' x - getTooltip' [] = Nothing - getId (_, _, z) = fromMaybe "" $ getId' z - getId' (('i':'d':'=':x):_) = Just x - getId' (_:x) = getId' x - getId' [] = Nothing - getName (_, _, z) = fromMaybe "" $ getName' z - getName' (('n':'a':'m':'e':'=':x):_) = Just x - getName' (_:x) = getName' x - getName' [] = Nothing - derive :: EntityDef -> Q Dec - derive t = do - let cols = map ((getId &&& getName) &&& ((getLabel &&& getTooltip) &&& getTFF)) $ entityColumns t - ap <- [|(<*>)|] - just <- [|pure|] - nothing <- [|Nothing|] - let just' = just `AppE` ConE (mkName $ entityName t) - string' <- [|toHtml|] - ftt <- [|fieldsToTable|] - ffs' <- [|FormFieldSettings|] - let stm "" = nothing - stm x = just `AppE` LitE (StringL x) - let go_ = go ap just' ffs' stm string' ftt - let c1 = Clause [ ConP (mkName "Nothing") [] - ] - (NormalB $ go_ $ zip cols $ map (const nothing) cols) - [] - xs <- mapM (const $ newName "x") cols - let xs' = map (AppE just . VarE) xs - let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ entityName t) - $ map VarP xs]] - (NormalB $ go_ $ zip cols xs') - [] - let y = mkName "y" - let ctx = map (\x -> ClassP (mkName x) [VarT y]) - $ map head $ group $ sort - $ mapMaybe getSuperclass - $ entityColumns t - return $ InstanceD ctx ( ConT ''ToForm - `AppT` ConT (mkName $ entityName t) - `AppT` VarT y) - [FunD (mkName "toForm") [c1, c2]] - go ap just' ffs' stm string' ftt a = - let x = foldl (ap' ap) just' $ map (go' ffs' stm string') a - in ftt `AppE` x - go' ffs' stm string' (((theId, name), ((label, tooltip), tff)), ex) = - let label' = LitE $ StringL label - tooltip' = string' `AppE` LitE (StringL tooltip) - ffs = ffs' `AppE` - label' `AppE` - tooltip' `AppE` - (stm theId) `AppE` - (stm name) - in VarE (mkName tff) `AppE` ffs `AppE` ex - ap' ap x y = InfixE (Just x) ap (Just y) - -toLabel :: String -> String -toLabel "" = "" -toLabel (x:rest) = toUpper x : go rest - where - go "" = "" - go (c:cs) - | isUpper c = ' ' : c : go cs - | otherwise = c : go cs - -formFailures :: FormResult a -> Maybe [Text] -formFailures (FormFailure x) = Just x -formFailures _ = Nothing +-- | Parse forms (and query strings).+module Yesod.Form+ ( 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+import Yesod.Form.Class+import Yesod.Form.Input
Yesod/Form/Class.hs view
@@ -1,69 +1,77 @@-{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -module Yesod.Form.Class - ( ToForm (..) - , ToFormField (..) - ) where - -import Text.Hamlet -import Yesod.Form.Fields -import Yesod.Form.Core -import Yesod.Form.Profiles (Textarea) -import Data.Int (Int64) -import Data.Time (Day, TimeOfDay) -import Data.Text (Text) - -class ToForm a y where - toForm :: Formlet sub y a -class ToFormField a y where - toFormField :: FormFieldSettings -> FormletField sub y a - -{- FIXME -instance ToFormField String y where - toFormField = stringField -instance ToFormField (Maybe String) y where - toFormField = maybeStringField --} - -instance ToFormField Text y where - toFormField = stringField -instance ToFormField (Maybe Text) y where - toFormField = maybeStringField - -instance ToFormField Int y where - toFormField = intField -instance ToFormField (Maybe Int) y where - toFormField = maybeIntField -instance ToFormField Int64 y where - toFormField = intField -instance ToFormField (Maybe Int64) y where - toFormField = maybeIntField - -instance ToFormField Double y where - toFormField = doubleField -instance ToFormField (Maybe Double) y where - toFormField = maybeDoubleField - -instance ToFormField Day y where - toFormField = dayField -instance ToFormField (Maybe Day) y where - toFormField = maybeDayField - -instance ToFormField TimeOfDay y where - toFormField = timeField -instance ToFormField (Maybe TimeOfDay) y where - toFormField = maybeTimeField - -instance ToFormField Bool y where - toFormField = boolField - -instance ToFormField Html y where - toFormField = htmlField -instance ToFormField (Maybe Html) y where - toFormField = maybeHtmlField - -instance ToFormField Textarea y where - toFormField = textareaField -instance ToFormField (Maybe Textarea) y where - toFormField = maybeTextareaField +{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts #-}+module Yesod.Form.Class+ ( ToForm (..)+ , ToField (..)+ ) where++import Text.Hamlet+import Yesod.Widget (GGWidget)+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.Handler (GGHandler)+import Yesod.Message (RenderMessage)++class ToForm a master monad where+ toForm :: AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) master monad a++class ToField a master monad where+ toField :: RenderMessage master msg => FieldSettings msg -> Maybe a -> AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) master monad a++{- FIXME+instance ToFormField String y where+ toFormField = stringField+instance ToFormField (Maybe String) y where+ toFormField = maybeStringField+-}++instance (Monad m, RenderMessage master FormMessage) => ToField Text master (GGHandler sub master m) where+ toField = areq textField+instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Text) master (GGHandler sub master m) where+ toField = aopt textField++instance (Monad m, RenderMessage master FormMessage) => ToField Int master (GGHandler sub master m) where+ toField = areq intField+instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Int) master (GGHandler sub master m) where+ toField = aopt intField++instance (Monad m, RenderMessage master FormMessage) => ToField Int64 master (GGHandler sub master m) where+ toField = areq intField+instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Int64) master (GGHandler sub master m) where+ toField = aopt intField++instance (Monad m, RenderMessage master FormMessage) => ToField Double master (GGHandler sub master m) where+ toField = areq doubleField+instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Double) master (GGHandler sub master m) where+ toField = aopt doubleField++instance (Monad m, RenderMessage master FormMessage) => ToField Day master (GGHandler sub master m) where+ toField = areq dayField+instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Day) master (GGHandler sub master m) where+ toField = aopt dayField++instance (Monad m, RenderMessage master FormMessage) => ToField TimeOfDay master (GGHandler sub master m) where+ toField = areq timeField+instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe TimeOfDay) master (GGHandler sub master m) where+ toField = aopt timeField++instance (Monad m, RenderMessage master FormMessage) => ToField Html master (GGHandler sub master m) where+ toField = areq htmlField+instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Html) master (GGHandler sub master m) where+ toField = aopt htmlField++instance (Monad m, RenderMessage master FormMessage) => ToField Textarea master (GGHandler sub master m) where+ toField = areq textareaField+instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Textarea) master (GGHandler sub master m) where+ toField = aopt textareaField++{- FIXME+instance ToFormField Bool y where+ toFormField = boolField+-}
− Yesod/Form/Core.hs
@@ -1,376 +0,0 @@-{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} --- | Users of the forms library should not need to use this module in general. --- It is intended only for writing custom forms and form fields. -module Yesod.Form.Core - ( FormResult (..) - , GForm (..) - , newFormIdent - , deeperFormIdent - , shallowerFormIdent - , Env - , FileEnv - , Enctype (..) - , Ints (..) - , requiredFieldHelper - , optionalFieldHelper - , fieldsToInput - , mapFormXml - , checkForm - , checkField - , askParams - , askFiles - , liftForm - , IsForm (..) - , RunForm (..) - , GFormMonad - -- * Data types - , FieldInfo (..) - , FormFieldSettings (..) - , FieldProfile (..) - -- * Type synonyms - , Form - , Formlet - , FormField - , FormletField - , FormInput - ) where - -import Control.Monad.Trans.State -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Writer -import Control.Monad.Trans.Class (lift) -import Yesod.Handler -import Yesod.Widget -import Data.Monoid (Monoid (..)) -import Control.Applicative -import Yesod.Request -import Control.Monad (liftM) -import Text.Hamlet -import Text.Blaze (ToHtml (..)) -import Data.String -import Control.Monad (join) -import Data.Text (Text, pack) -import qualified Data.Text as T -import Prelude hiding ((++)) - -(++) :: Monoid a => a -> a -> a -(++) = mappend - --- | 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. -data FormResult a = FormMissing - | FormFailure [Text] - | FormSuccess a - deriving Show -instance Functor FormResult where - fmap _ FormMissing = FormMissing - fmap _ (FormFailure errs) = FormFailure errs - fmap f (FormSuccess a) = FormSuccess $ f a -instance Applicative FormResult where - pure = FormSuccess - (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g - (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y - (FormFailure x) <*> _ = FormFailure x - _ <*> (FormFailure y) = FormFailure y - _ <*> _ = FormMissing -instance Monoid m => Monoid (FormResult m) where - mempty = pure mempty - mappend x y = mappend <$> x <*> y - --- | The encoding type required by a form. The 'Show' instance produces values --- that can be inserted directly into HTML. -data Enctype = UrlEncoded | Multipart - deriving (Eq, Enum, Bounded) -instance ToHtml Enctype where - toHtml UrlEncoded = unsafeByteString "application/x-www-form-urlencoded" - toHtml Multipart = unsafeByteString "multipart/form-data" -instance Monoid Enctype where - mempty = UrlEncoded - mappend UrlEncoded UrlEncoded = UrlEncoded - mappend _ _ = Multipart - -data Ints = IntCons Int Ints | IntSingle Int -instance Show Ints where - show (IntSingle i) = show i - show (IntCons i is) = show i ++ ('-' : show is) - -incrInts :: Ints -> Ints -incrInts (IntSingle i) = IntSingle $ i + 1 -incrInts (IntCons i is) = (i + 1) `IntCons` is - --- | A generic form, allowing you to specifying the subsite datatype, master --- site datatype, a datatype for the form XML and the return type. -newtype GForm s m xml a = GForm - { deform :: FormInner s m (FormResult a, xml, Enctype) - } - -type GFormMonad s m a = WriterT Enctype (FormInner s m) a - -type FormInner s m = - StateT Ints ( - ReaderT Env ( - ReaderT FileEnv ( - GHandler s m - ))) - -type Env = [(Text, Text)] -type FileEnv = [(Text, FileInfo)] - --- | Get a unique identifier. -newFormIdent :: Monad m => StateT Ints m Text -newFormIdent = do - i <- get - let i' = incrInts i - put i' - return $ pack $ 'f' : show i' - -deeperFormIdent :: Monad m => StateT Ints m () -deeperFormIdent = do - i <- get - let i' = 1 `IntCons` incrInts i - put i' - -shallowerFormIdent :: Monad m => StateT Ints m () -shallowerFormIdent = do - IntCons _ i <- get - put i - -instance Monoid xml => Functor (GForm sub url xml) where - fmap f (GForm g) = - GForm $ liftM (first3 $ fmap f) g - where - first3 f' (x, y, z) = (f' x, y, z) - -instance Monoid xml => Applicative (GForm sub url xml) where - pure a = GForm $ return (pure a, mempty, mempty) - (GForm f) <*> (GForm g) = GForm $ do - (f1, f2, f3) <- f - (g1, g2, g3) <- g - return (f1 <*> g1, f2 `mappend` g2, f3 `mappend` g3) - --- | Create a required field (ie, one that cannot be blank) from a --- 'FieldProfile'. -requiredFieldHelper - :: IsForm f - => FieldProfile (FormSub f) (FormMaster f) (FormType f) - -> FormFieldSettings - -> Maybe (FormType f) - -> f -requiredFieldHelper (FieldProfile parse render mkWidget) ffs orig = toForm $ do - env <- lift ask - let (FormFieldSettings label tooltip theId' name') = ffs - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let (res, val) = - if null env - then (FormMissing, maybe "" render orig) - else case lookup name env of - Nothing -> (FormMissing, "") - Just "" -> (FormFailure ["Value is required"], "") - Just x -> - case parse x of - Left e -> (FormFailure [e], x) - Right y -> (FormSuccess y, x) - let fi = FieldInfo - { fiLabel = toHtml label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = mkWidget theId name val True - , fiErrors = case res of - FormFailure [x] -> Just $ toHtml x - _ -> Nothing - , fiRequired = True - } - let res' = case res of - FormFailure [e] -> FormFailure [label ++ ": " ++ e] - _ -> res - return (res', fi, UrlEncoded) - -class IsForm f where - type FormSub f - type FormMaster f - type FormType f - toForm :: FormInner - (FormSub f) - (FormMaster f) - (FormResult (FormType f), - FieldInfo (FormSub f) (FormMaster f), - Enctype) -> f -instance IsForm (FormField s m a) where - type FormSub (FormField s m a) = s - type FormMaster (FormField s m a) = m - type FormType (FormField s m a) = a - toForm x = GForm $ do - (a, b, c) <- x - return (a, [b], c) -instance (FormResult ~ formResult) => IsForm (GFormMonad s m (formResult a, FieldInfo s m)) where - type FormSub (GFormMonad s m (formResult a, FieldInfo s m)) = s - type FormMaster (GFormMonad s m (formResult a, FieldInfo s m)) = m - type FormType (GFormMonad s m (formResult a, FieldInfo s m)) = a - toForm x = do - (res, fi, enctype) <- lift x - tell enctype - return (res, fi) - -class RunForm f where - type RunFormSub f - type RunFormMaster f - type RunFormType f - runFormGeneric :: Env -> FileEnv -> f - -> GHandler (RunFormSub f) - (RunFormMaster f) - (RunFormType f) - -instance RunForm (GForm s m xml a) where - type RunFormSub (GForm s m xml a) = s - type RunFormMaster (GForm s m xml a) = m - type RunFormType (GForm s m xml a) = - (FormResult a, xml, Enctype) - runFormGeneric env fe (GForm f) = - runReaderT (runReaderT (evalStateT f $ IntSingle 1) env) fe - -instance RunForm (GFormMonad s m a) where - type RunFormSub (GFormMonad s m a) = s - type RunFormMaster (GFormMonad s m a) = m - type RunFormType (GFormMonad s m a) = (a, Enctype) - runFormGeneric e fe f = - runReaderT (runReaderT (evalStateT (runWriterT f) $ IntSingle 1) e) fe - --- | Create an optional field (ie, one that can be blank) from a --- 'FieldProfile'. -optionalFieldHelper - :: (IsForm f, Maybe b ~ FormType f) - => FieldProfile (FormSub f) (FormMaster f) b - -> FormFieldSettings - -> Maybe (Maybe b) - -> f -optionalFieldHelper (FieldProfile parse render mkWidget) ffs orig' = toForm $ do - env <- lift ask - let (FormFieldSettings label tooltip theId' name') = ffs - let orig = join orig' - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let (res, val) = - if null env - then (FormSuccess Nothing, maybe "" render orig) - else case lookup name env of - Nothing -> (FormSuccess Nothing, "") - Just "" -> (FormSuccess Nothing, "") - Just x -> - case parse x of - Left e -> (FormFailure [e], x) - Right y -> (FormSuccess $ Just y, x) - let fi = FieldInfo - { fiLabel = toHtml label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = mkWidget theId name val False - , fiErrors = case res of - FormFailure x -> Just $ toHtml $ T.unlines x - _ -> Nothing - , fiRequired = False - } - let res' = case res of - FormFailure [e] -> FormFailure [label ++ ": " ++ e] - _ -> res - return (res', fi, UrlEncoded) - -fieldsToInput :: [FieldInfo sub y] -> [GWidget sub y ()] -fieldsToInput = map fiInput - --- | Convert the XML in a 'GForm'. -mapFormXml :: (xml1 -> xml2) -> GForm s y xml1 a -> GForm s y xml2 a -mapFormXml f (GForm g) = GForm $ do - (res, xml, enc) <- g - return (res, f xml, enc) - --- | Using this as the intermediate XML representation for fields allows us to --- write generic field functions and then different functions for producing --- actual HTML. See, for example, 'fieldsToTable' and 'fieldsToPlain'. -data FieldInfo sub y = FieldInfo - { fiLabel :: Html - , fiTooltip :: Html - , fiIdent :: Text - , fiInput :: GWidget sub y () - , fiErrors :: Maybe Html - , fiRequired :: Bool - } - -data FormFieldSettings = FormFieldSettings - { ffsLabel :: Text - , ffsTooltip :: Html - , ffsId :: Maybe Text - , ffsName :: Maybe Text - } -instance IsString FormFieldSettings where - fromString s = FormFieldSettings (pack s) mempty Nothing Nothing - --- | A generic definition of a form field that can be used for generating both --- required and optional fields. See 'requiredFieldHelper and --- 'optionalFieldHelper'. -data FieldProfile sub y a = FieldProfile - { fpParse :: Text -> Either Text a - , fpRender :: a -> Text - -- | ID, name, value, required - , fpWidget :: Text -> Text -> Text -> Bool -> GWidget sub y () - } - -type Form sub y = GForm sub y (GWidget sub y ()) -type Formlet sub y a = Maybe a -> Form sub y a -type FormField sub y = GForm sub y [FieldInfo sub y] -type FormletField sub y a = Maybe a -> FormField sub y a -type FormInput sub y = GForm sub y [GWidget sub y ()] - --- | Add a validation check to a form. --- --- Note that if there is a validation error, this message will /not/ --- automatically appear on the form; for that, you need to use 'checkField'. -checkForm :: (a -> FormResult b) -> GForm s m x a -> GForm s m x b -checkForm f (GForm form) = GForm $ do - (res, xml, enc) <- form - let res' = case res of - FormSuccess a -> f a - FormFailure e -> FormFailure e - FormMissing -> FormMissing - return (res', xml, enc) - --- | Add a validation check to a 'FormField'. --- --- Unlike 'checkForm', the validation error will appear in the generated HTML --- of the form. -checkField :: (a -> Either Text b) -> FormField s m a -> FormField s m b -checkField f (GForm form) = GForm $ do - (res, xml, enc) <- form - let (res', merr) = - case res of - FormSuccess a -> - case f a of - Left e -> (FormFailure [e], Just e) - Right x -> (FormSuccess x, Nothing) - FormFailure e -> (FormFailure e, Nothing) - FormMissing -> (FormMissing, Nothing) - let xml' = - case merr of - Nothing -> xml - Just err -> flip map xml $ \fi -> fi - { fiErrors = Just $ - case fiErrors fi of - Nothing -> toHtml err - Just x -> x - } - return (res', xml', enc) - -askParams :: Monad m => StateT Ints (ReaderT Env m) Env -askParams = lift ask - -askFiles :: Monad m => StateT Ints (ReaderT Env (ReaderT FileEnv m)) FileEnv -askFiles = lift $ lift ask - -liftForm :: Monad m => m a -> StateT Ints (ReaderT Env (ReaderT FileEnv m)) a -liftForm = lift . lift . lift
Yesod/Form/Fields.hs view
@@ -1,509 +1,392 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -module Yesod.Form.Fields - ( -- * Fields - -- ** Required - stringField - , passwordField - , textareaField - , hiddenField - , intField - , doubleField - , dayField - , timeField - , htmlField - , selectField - , radioField - , boolField - , emailField - , searchField - , urlField - , fileField - -- ** Optional - , maybeStringField - , maybePasswordField - , maybeTextareaField - , maybeHiddenField - , maybeIntField - , maybeDoubleField - , maybeDayField - , maybeTimeField - , maybeHtmlField - , maybeSelectField - , maybeRadioField - , maybeEmailField - , maybeSearchField - , maybeUrlField - , maybeFileField - -- * Inputs - -- ** Required - , stringInput - , intInput - , boolInput - , dayInput - , emailInput - , urlInput - -- ** Optional - , maybeStringInput - , maybeDayInput - , maybeIntInput - ) where - -import Yesod.Form.Core -import Yesod.Form.Profiles -import Yesod.Request (FileInfo) -import Yesod.Widget (GWidget) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ask) -import Data.Time (Day, TimeOfDay) -import Text.Hamlet -import Data.Monoid -import Control.Monad (join) -import Data.Maybe (fromMaybe, isNothing) -import Data.Text (Text, unpack) -import qualified Data.Text as T - -#if __GLASGOW_HASKELL__ >= 700 -#define HAMLET hamlet -#else -#define HAMLET $hamlet -#endif - -stringField :: (IsForm f, FormType f ~ Text) - => FormFieldSettings -> Maybe Text -> f -stringField = requiredFieldHelper stringFieldProfile - -maybeStringField :: (IsForm f, FormType f ~ Maybe Text) - => FormFieldSettings -> Maybe (Maybe Text) -> f -maybeStringField = optionalFieldHelper stringFieldProfile - -passwordField :: (IsForm f, FormType f ~ Text) - => FormFieldSettings -> Maybe Text -> f -passwordField = requiredFieldHelper passwordFieldProfile - -maybePasswordField :: (IsForm f, FormType f ~ Maybe Text) - => FormFieldSettings -> Maybe (Maybe Text) -> f -maybePasswordField = optionalFieldHelper passwordFieldProfile - -intInput :: Integral i => Text -> FormInput sub master i -intInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper intFieldProfile (nameSettings n) Nothing - -maybeIntInput :: Integral i => Text -> FormInput sub master (Maybe i) -maybeIntInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper intFieldProfile (nameSettings n) Nothing - -intField :: (Integral (FormType f), IsForm f) - => FormFieldSettings -> Maybe (FormType f) -> f -intField = requiredFieldHelper intFieldProfile - -maybeIntField :: (Integral i, FormType f ~ Maybe i, IsForm f) - => FormFieldSettings -> Maybe (FormType f) -> f -maybeIntField = optionalFieldHelper intFieldProfile - -doubleField :: (IsForm f, FormType f ~ Double) - => FormFieldSettings -> Maybe Double -> f -doubleField = requiredFieldHelper doubleFieldProfile - -maybeDoubleField :: (IsForm f, FormType f ~ Maybe Double) - => FormFieldSettings -> Maybe (Maybe Double) -> f -maybeDoubleField = optionalFieldHelper doubleFieldProfile - -dayField :: (IsForm f, FormType f ~ Day) - => FormFieldSettings -> Maybe Day -> f -dayField = requiredFieldHelper dayFieldProfile - -maybeDayField :: (IsForm f, FormType f ~ Maybe Day) - => FormFieldSettings -> Maybe (Maybe Day) -> f -maybeDayField = optionalFieldHelper dayFieldProfile - -timeField :: (IsForm f, FormType f ~ TimeOfDay) - => FormFieldSettings -> Maybe TimeOfDay -> f -timeField = requiredFieldHelper timeFieldProfile - -maybeTimeField :: (IsForm f, FormType f ~ Maybe TimeOfDay) - => FormFieldSettings -> Maybe (Maybe TimeOfDay) -> f -maybeTimeField = optionalFieldHelper timeFieldProfile - -boolField :: (IsForm f, FormType f ~ Bool) - => FormFieldSettings -> Maybe Bool -> f -boolField ffs orig = toForm $ do - env <- askParams - let label = ffsLabel ffs - tooltip = ffsTooltip ffs - name <- maybe newFormIdent return $ ffsName ffs - theId <- maybe newFormIdent return $ ffsId ffs - let (res, val) = - if null env - then (FormMissing, fromMaybe False orig) - else case lookup name env of - Nothing -> (FormSuccess False, False) - Just "" -> (FormSuccess False, False) - Just "false" -> (FormSuccess False, False) - Just _ -> (FormSuccess True, True) - let fi = FieldInfo - { fiLabel = toHtml label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = [HAMLET| -<input id="#{theId}" type="checkbox" name="#{name}" :val:checked=""> -|] - , fiErrors = case res of - FormFailure [x] -> Just $ toHtml x - _ -> Nothing - , fiRequired = True - } - return (res, fi, UrlEncoded) - -htmlField :: (IsForm f, FormType f ~ Html) - => FormFieldSettings -> Maybe Html -> f -htmlField = requiredFieldHelper htmlFieldProfile - -maybeHtmlField :: (IsForm f, FormType f ~ Maybe Html) - => FormFieldSettings -> Maybe (Maybe Html) -> f -maybeHtmlField = optionalFieldHelper htmlFieldProfile - -selectField :: (Eq x, IsForm f, FormType f ~ x) - => [(x, Text)] - -> FormFieldSettings - -> Maybe x - -> f -selectField pairs ffs initial = toForm $ do - env <- askParams - let label = ffsLabel ffs - tooltip = ffsTooltip ffs - theId <- maybe newFormIdent return $ ffsId ffs - name <- maybe newFormIdent return $ ffsName ffs - let pairs' = zip [1 :: Int ..] pairs - let res = case lookup name env of - Nothing -> FormMissing - Just "none" -> FormFailure ["Field is required"] - Just x -> - case reads $ unpack x of - (x', _):_ -> - case lookup x' pairs' of - Nothing -> FormFailure ["Invalid entry"] - Just (y, _) -> FormSuccess y - [] -> FormFailure ["Invalid entry"] - let isSelected x = - case res of - FormSuccess y -> x == y - _ -> Just x == initial - let input = -#if __GLASGOW_HASKELL__ >= 700 - [hamlet| -#else - [$hamlet| -#endif -<select id="#{theId}" name="#{name}"> - <option value="none"> - $forall pair <- pairs' - <option value="#{show (fst pair)}" :isSelected (fst (snd pair)):selected="">#{snd (snd pair)} -|] - let fi = FieldInfo - { fiLabel = toHtml label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = input - , fiErrors = case res of - FormFailure [x] -> Just $ toHtml x - _ -> Nothing - , fiRequired = True - } - return (res, fi, UrlEncoded) - -maybeSelectField :: (Eq x, IsForm f, Maybe x ~ FormType f) - => [(x, Text)] - -> FormFieldSettings - -> Maybe (FormType f) - -> f -maybeSelectField pairs ffs initial' = toForm $ do - env <- askParams - let initial = join initial' - label = ffsLabel ffs - tooltip = ffsTooltip ffs - theId <- maybe newFormIdent return $ ffsId ffs - name <- maybe newFormIdent return $ ffsName ffs - let pairs' = zip [1 :: Int ..] pairs - let res = case lookup name env of - Nothing -> FormMissing - Just "none" -> FormSuccess Nothing - Just x -> - case reads $ unpack x of - (x', _):_ -> - case lookup x' pairs' of - Nothing -> FormFailure ["Invalid entry"] - Just (y, _) -> FormSuccess $ Just y - [] -> FormFailure ["Invalid entry"] - let isSelected x = - case res of - FormSuccess y -> Just x == y - _ -> Just x == initial - let input = -#if __GLASGOW_HASKELL__ >= 700 - [hamlet| -#else - [$hamlet| -#endif -<select id="#{theId}" name="#{name}"> - <option value="none"> - $forall pair <- pairs' - <option value="#{show (fst pair)}" :isSelected (fst (snd pair)):selected="">#{snd (snd pair)} -|] - let fi = FieldInfo - { fiLabel = toHtml label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = input - , fiErrors = case res of - FormFailure [x] -> Just $ toHtml x - _ -> Nothing - , fiRequired = False - } - return (res, fi, UrlEncoded) - -stringInput :: Text -> FormInput sub master Text -stringInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper stringFieldProfile (nameSettings n) Nothing - -maybeStringInput :: Text -> FormInput sub master (Maybe Text) -maybeStringInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper stringFieldProfile (nameSettings n) Nothing - -boolInput :: Text -> FormInput sub master Bool -boolInput n = GForm $ do - env <- askParams - let res = case lookup n env of - Nothing -> FormSuccess False - Just "" -> FormSuccess False - Just "false" -> FormSuccess False - Just _ -> FormSuccess True - let xml = [HAMLET| - <input id="#{n}" type="checkbox" name="#{n}"> -|] - return (res, [xml], UrlEncoded) - -dayInput :: Text -> FormInput sub master Day -dayInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper dayFieldProfile (nameSettings n) Nothing - -maybeDayInput :: Text -> FormInput sub master (Maybe Day) -maybeDayInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper dayFieldProfile (nameSettings n) Nothing - -nameSettings :: Text -> FormFieldSettings -nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) - -urlField :: (IsForm f, FormType f ~ Text) - => FormFieldSettings -> Maybe Text -> f -urlField = requiredFieldHelper urlFieldProfile - -maybeUrlField :: (IsForm f, FormType f ~ Maybe Text) - => FormFieldSettings -> Maybe (Maybe Text) -> f -maybeUrlField = optionalFieldHelper urlFieldProfile - -urlInput :: Text -> FormInput sub master Text -urlInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper urlFieldProfile (nameSettings n) Nothing - -emailField :: (IsForm f, FormType f ~ Text) - => FormFieldSettings -> Maybe Text -> f -emailField = requiredFieldHelper emailFieldProfile - -maybeEmailField :: (IsForm f, FormType f ~ Maybe Text) - => FormFieldSettings -> Maybe (Maybe Text) -> f -maybeEmailField = optionalFieldHelper emailFieldProfile - -emailInput :: Text -> FormInput sub master Text -emailInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper emailFieldProfile (nameSettings n) Nothing - -searchField :: (IsForm f, FormType f ~ Text) - => AutoFocus -> FormFieldSettings -> Maybe Text -> f -searchField = requiredFieldHelper . searchFieldProfile - -maybeSearchField :: (IsForm f, FormType f ~ Maybe Text) - => AutoFocus -> FormFieldSettings -> Maybe (Maybe Text) -> f -maybeSearchField = optionalFieldHelper . searchFieldProfile - -textareaField :: (IsForm f, FormType f ~ Textarea) - => FormFieldSettings -> Maybe Textarea -> f -textareaField = requiredFieldHelper textareaFieldProfile - -maybeTextareaField :: FormFieldSettings -> FormletField sub y (Maybe Textarea) -maybeTextareaField = optionalFieldHelper textareaFieldProfile - -hiddenField :: (IsForm f, FormType f ~ Text) - => FormFieldSettings -> Maybe Text -> f -hiddenField = requiredFieldHelper hiddenFieldProfile - -maybeHiddenField :: (IsForm f, FormType f ~ Maybe Text) - => FormFieldSettings -> Maybe (Maybe Text) -> f -maybeHiddenField = optionalFieldHelper hiddenFieldProfile - -fileField :: (IsForm f, FormType f ~ FileInfo) - => FormFieldSettings -> f -fileField ffs = toForm $ do - env <- lift ask - fenv <- lift $ lift ask - let (FormFieldSettings label tooltip theId' name') = ffs - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let res = - if null env && null fenv - then FormMissing - else case lookup name fenv of - Nothing -> FormFailure ["File is required"] - Just x -> FormSuccess x - let fi = FieldInfo - { fiLabel = toHtml label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = fileWidget theId name True - , fiErrors = case res of - FormFailure [x] -> Just $ toHtml x - _ -> Nothing - , fiRequired = True - } - let res' = case res of - FormFailure [e] -> FormFailure [T.concat [label, ": ", e]] - _ -> res - return (res', fi, Multipart) - -maybeFileField :: (IsForm f, FormType f ~ Maybe FileInfo) - => FormFieldSettings -> f -maybeFileField ffs = toForm $ do - fenv <- lift $ lift ask - let (FormFieldSettings label tooltip theId' name') = ffs - name <- maybe newFormIdent return name' - theId <- maybe newFormIdent return theId' - let res = FormSuccess $ lookup name fenv - let fi = FieldInfo - { fiLabel = toHtml label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = fileWidget theId name False - , fiErrors = Nothing - , fiRequired = True - } - return (res, fi, Multipart) - -fileWidget :: Text -> Text -> Bool -> GWidget s m () -fileWidget theId name isReq = [HAMLET| -<input id="#{theId}" type="file" name="#{name}" :isReq:required=""> -|] - -radioField :: (Eq x, IsForm f, FormType f ~ x) - => [(x, Text)] - -> FormFieldSettings - -> Maybe x - -> f -radioField pairs ffs initial = toForm $ do - env <- askParams - let label = ffsLabel ffs - tooltip = ffsTooltip ffs - theId <- maybe newFormIdent return $ ffsId ffs - name <- maybe newFormIdent return $ ffsName ffs - let pairs' = zip [1 :: Int ..] pairs - let res = case lookup name env of - Nothing -> FormMissing - Just "none" -> FormFailure ["Field is required"] - Just x -> - case reads $ unpack x of - (x', _):_ -> - case lookup x' pairs' of - Nothing -> FormFailure ["Invalid entry"] - Just (y, _) -> FormSuccess y - [] -> FormFailure ["Invalid entry"] - let isSelected x = - case res of - FormSuccess y -> x == y - _ -> Just x == initial - let input = [HAMLET| -<div id="#{theId}"> - $forall pair <- pairs' - <div> - <input id="#{theId}-#{show (fst pair)}" type="radio" name="#{name}" value="#{show (fst pair)}" :isSelected (fst (snd pair)):checked=""> - <label for="#{name}-#{show (fst pair)}">#{snd (snd pair)} -|] - let fi = FieldInfo - { fiLabel = toHtml label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = input - , fiErrors = case res of - FormFailure [x] -> Just $ toHtml x - _ -> Nothing - , fiRequired = True - } - return (res, fi, UrlEncoded) - -maybeRadioField - :: (Eq x, IsForm f, FormType f ~ Maybe x) - => [(x, Text)] - -> FormFieldSettings - -> Maybe (FormType f) - -> f -maybeRadioField pairs ffs initial' = toForm $ do - env <- askParams - let initial = join initial' - label = ffsLabel ffs - tooltip = ffsTooltip ffs - theId <- maybe newFormIdent return $ ffsId ffs - name <- maybe newFormIdent return $ ffsName ffs - let pairs' = zip [1 :: Int ..] pairs - let res = case lookup name env of - Nothing -> FormMissing - Just "none" -> FormSuccess Nothing - Just x -> - case reads $ unpack x of - (x', _):_ -> - case lookup x' pairs' of - Nothing -> FormFailure ["Invalid entry"] - Just (y, _) -> FormSuccess $ Just y - [] -> FormFailure ["Invalid entry"] - let isSelected x = - case res of - FormSuccess y -> Just x == y - _ -> Just x == initial - let isNone = - case res of - FormSuccess Nothing -> True - FormSuccess Just{} -> False - _ -> isNothing initial - let input = -#if __GLASGOW_HASKELL__ >= 700 - [hamlet| -#else - [$hamlet| -#endif -<div id="#{theId}"> - $forall pair <- pairs' - <div> - <input id="#{theId}-none" type="radio" name="#{name}" value="none" :isNone:checked="">None - <div> - <input id="#{theId}-#{show (fst pair)}" type="radio" name="#{name}" value="#{show (fst pair)}" :isSelected (fst (snd pair)):checked=""> - <label for="#{name}-#{show (fst pair)}">#{snd (snd pair)} -|] - let fi = FieldInfo - { fiLabel = toHtml label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = input - , fiErrors = case res of - FormFailure [x] -> Just $ toHtml x - _ -> Nothing - , fiRequired = False - } - return (res, fi, UrlEncoded) +{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+module Yesod.Form.Fields+ ( FormMessage (..)+ , defaultFormMessage+ , textField+ , passwordField+ , textareaField+ , hiddenField+ , intField+ , dayField+ , timeField+ , htmlField+ , emailField+ , searchField+ , selectField+ , AutoFocus+ , urlField+ , doubleField+ , parseDate+ , parseTime+ , Textarea (..)+ , radioField+ , boolField+ ) where++import Yesod.Form.Types+import Yesod.Widget+import Yesod.Message (RenderMessage)+import Yesod.Handler (GGHandler)+import Text.Hamlet hiding (renderHtml)+import Text.Blaze (ToHtml (..))+import Text.Cassius+import Data.Time (Day, TimeOfDay(..))+import qualified Text.Email.Validate as Email+import Network.URI (parseURI)+import Database.Persist (PersistField)+import Text.HTML.SanitizeXSS (sanitizeBalance)+import Control.Monad (when, unless)++import qualified Blaze.ByteString.Builder.Html.Utf8 as B+import Blaze.ByteString.Builder (writeByteString, toLazyByteString)+import Blaze.ByteString.Builder.Internal.Write (fromWriteList)++import Text.Blaze.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.Read+import Data.Monoid (mappend)+import Text.Hamlet.NonPoly (html)++#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++data FormMessage = MsgInvalidInteger Text+ | MsgInvalidNumber Text+ | MsgInvalidEntry Text+ | MsgInvalidUrl Text+ | MsgInvalidEmail Text+ | MsgInvalidTimeFormat+ | MsgInvalidHour Text+ | MsgInvalidMinute Text+ | MsgInvalidSecond Text+ | MsgInvalidDay+ | MsgCsrfWarning+ | MsgValueRequired+ | MsgInputNotFound Text+ | MsgSelectNone+ | MsgInvalidBool Text+ | MsgBoolYes+ | MsgBoolNo++defaultFormMessage :: FormMessage -> Text+defaultFormMessage (MsgInvalidInteger t) = "Invalid integer: " `mappend` t+defaultFormMessage (MsgInvalidNumber t) = "Invalid number: " `mappend` t+defaultFormMessage (MsgInvalidEntry t) = "Invalid entry: " `mappend` t+defaultFormMessage MsgInvalidTimeFormat = "Invalid time, must be in HH:MM[:SS] format"+defaultFormMessage MsgInvalidDay = "Invalid day, must be in YYYY-MM-DD format"+defaultFormMessage (MsgInvalidUrl t) = "Invalid URL: " `mappend` t+defaultFormMessage (MsgInvalidEmail t) = "Invalid e-mail address: " `mappend` t+defaultFormMessage (MsgInvalidHour t) = "Invalid hour: " `mappend` t+defaultFormMessage (MsgInvalidMinute t) = "Invalid minute: " `mappend` t+defaultFormMessage (MsgInvalidSecond t) = "Invalid second: " `mappend` t+defaultFormMessage MsgCsrfWarning = "As a protection against cross-site request forgery attacks, please confirm your form submission."+defaultFormMessage MsgValueRequired = "Value is required"+defaultFormMessage (MsgInputNotFound t) = "Input not found: " `mappend` t+defaultFormMessage MsgSelectNone = "<None>"+defaultFormMessage (MsgInvalidBool t) = "Invalid boolean: " `mappend` t+defaultFormMessage MsgBoolYes = "Yes"+defaultFormMessage MsgBoolNo = "No"++blank :: (Text -> Either msg a) -> Maybe Text -> Either msg (Maybe a)+blank _ Nothing = Right Nothing+blank _ (Just "") = Right Nothing+blank f (Just t) = either Left (Right . Just) $ f t++intField :: (Monad monad, Integral i) => Field (GGWidget master monad ()) FormMessage i+intField = Field+ { fieldParse = blank $ \s ->+ case Data.Text.Read.signed Data.Text.Read.decimal s of+ Right (a, "") -> Right a+ _ -> Left $ MsgInvalidInteger s+ , fieldRender = pack . showI+ , fieldView = \theId name val isReq -> addHamlet+ [HAMLET|\+<input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{val}">+|]+ }+ where+ showI x = show (fromIntegral x :: Integer)++doubleField :: Monad monad => Field (GGWidget master monad ()) FormMessage Double+doubleField = Field+ { fieldParse = blank $ \s ->+ case Data.Text.Read.double s of+ Right (a, "") -> Right a+ _ -> Left $ MsgInvalidNumber s+ , fieldRender = pack . show+ , fieldView = \theId name val isReq -> addHamlet+ [HAMLET|\+<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}">+|]+ }++dayField :: Monad monad => Field (GGWidget master monad ()) FormMessage Day+dayField = Field+ { fieldParse = blank $ parseDate . unpack+ , fieldRender = pack . show+ , fieldView = \theId name val isReq -> addHamlet+ [HAMLET|\+<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}">+|]+ }++timeField :: Monad monad => Field (GGWidget master monad ()) FormMessage TimeOfDay+timeField = Field+ { fieldParse = blank $ parseTime . unpack+ , fieldRender = pack . show . roundFullSeconds+ , fieldView = \theId name val isReq -> addHamlet+ [HAMLET|\+<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}">+|]+ }+ where+ roundFullSeconds tod =+ TimeOfDay (todHour tod) (todMin tod) fullSec+ where+ fullSec = fromInteger $ floor $ todSec tod++htmlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Html+htmlField = Field+ { fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize+ , fieldRender = pack . renderHtml+ , fieldView = \theId name val _isReq -> addHamlet+ [HAMLET|\+<textarea id="#{theId}" name="#{name}" .html>#{val}+|]+ }++-- | A newtype wrapper around a 'String' that converts newlines to HTML+-- br-tags.+newtype Textarea = Textarea { unTextarea :: Text }+ deriving (Show, Read, Eq, PersistField)+instance ToHtml Textarea where+ toHtml =+ unsafeByteString+ . S.concat+ . L.toChunks+ . toLazyByteString+ . fromWriteList writeHtmlEscapedChar+ . unpack+ . unTextarea+ where+ -- Taken from blaze-builder and modified with newline handling.+ writeHtmlEscapedChar '\n' = writeByteString "<br>"+ writeHtmlEscapedChar c = B.writeHtmlEscapedChar c++textareaField :: Monad monad => Field (GGWidget master monad ()) FormMessage Textarea+textareaField = Field+ { fieldParse = blank $ Right . Textarea+ , fieldRender = unTextarea+ , fieldView = \theId name val _isReq -> addHamlet+ [HAMLET|\+<textarea id="#{theId}" name="#{name}">#{val}+|]+ }++hiddenField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text+hiddenField = Field+ { fieldParse = blank $ Right+ , fieldRender = id+ , fieldView = \theId name val _isReq -> addHamlet+ [HAMLET|\+<input type="hidden" id="#{theId}" name="#{name}" value="#{val}">+|]+ }++textField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text+textField = Field+ { fieldParse = blank $ Right+ , fieldRender = id+ , fieldView = \theId name val isReq ->+ [WHAMLET|+<input id="#{theId}" name="#{name}" type="text" :isReq:required value="#{val}">+|]+ }++passwordField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text+passwordField = Field+ { fieldParse = blank $ Right+ , fieldRender = id+ , fieldView = \theId name val isReq -> addHamlet+ [HAMLET|\+<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{val}">+|]+ }++readMay :: Read a => String -> Maybe a+readMay s = case reads s of+ (x, _):_ -> Just x+ [] -> Nothing++parseDate :: String -> Either FormMessage Day+parseDate = maybe (Left MsgInvalidDay) Right+ . readMay . replace '/' '-'++-- | Replaces all instances of a value in a list by another value.+-- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace+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++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+ where+ h = read [h1, h2] -- FIXME isn't this a really bad idea?+ m = read [m1, m2]+ s = fromInteger $ read [s1, s2]++emailField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text+emailField = Field+ { fieldParse = blank $+ \s -> if Email.isValid (unpack s)+ then Right s+ else Left $ MsgInvalidEmail s+ , fieldRender = id+ , fieldView = \theId name val isReq -> addHamlet+ [HAMLET|\+<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{val}">+|]+ }++type AutoFocus = Bool+searchField :: Monad monad => AutoFocus -> Field (GGWidget master monad ()) FormMessage Text+searchField autoFocus = Field+ { fieldParse = blank Right+ , fieldRender = id+ , fieldView = \theId name val isReq -> do+ addHtml [HAMLET|\+<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{val}">+|]+ when autoFocus $ do+ addHtml $ [HAMLET|\<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}</script> +|]+ addCassius [CASSIUS|+ #{theId}+ -webkit-appearance: textfield+ |]+ }++urlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text+urlField = Field+ { fieldParse = blank $ \s ->+ case parseURI $ unpack s of+ Nothing -> Left $ MsgInvalidUrl s+ Just _ -> Right s+ , fieldRender = id+ , fieldView = \theId name val isReq -> addHtml+ [HAMLET|+<input ##{theId} name=#{name} type=url :isReq:required value=#{val}>+|]+ }++selectField :: (Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage a+selectField = selectFieldHelper+ (\theId name inside -> [WHAMLET|<select ##{theId} name=#{name}>^{inside}|])+ (\_theId _name isSel -> [WHAMLET|<option value=none :isSel:selected>_{MsgSelectNone}|])+ (\_theId _name value isSel text -> addHtml [HTML|<option value=#{value} :isSel:selected>#{text}|])++radioField :: (Eq a, Monad monad, RenderMessage master FormMessage) => [(Text, a)] -> Field (GGWidget master (GGHandler sub master monad) ()) FormMessage 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}+|])+ (\theId name value isSel text -> [WHAMLET|+<div>+ <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked>+ <label for=#{theId}-#{value}>#{text}+|])++boolField :: (Monad monad, RenderMessage master FormMessage) => Field (GGWidget master (GGHandler sub master monad) ()) FormMessage Bool+boolField = Field+ { fieldParse = \s ->+ case s of+ Nothing -> Right Nothing+ Just "" -> Right Nothing+ Just "none" -> Right Nothing+ Just "yes" -> Right $ Just True+ Just "no" -> Right $ Just False+ Just t -> Left $ MsgInvalidBool t+ , fieldRender = \a -> if a then "yes" else "no"+ , fieldView = \theId name val isReq -> [WHAMLET|+$if not isReq+ <input id=#{theId}-none type=radio name=#{name} value=none :isNone val:checked>+ <label for=#{theId}-none>_{MsgSelectNone}++<input id=#{theId}-yes type=radio name=#{name} value=yes :(==) val "yes":checked>+<label for=#{theId}-yes>_{MsgBoolYes}++<input id=#{theId}-no type=radio name=#{name} value=no :(==) val "no":checked>+<label for=#{theId}-no>_{MsgBoolNo}+|]+ }+ where+ isNone val = not $ val `elem` ["yes", "no"]++selectFieldHelper :: (Eq a, Monad monad)+ => (Text -> Text -> GGWidget master monad () -> GGWidget master monad ())+ -> (Text -> Text -> Bool -> GGWidget master monad ())+ -> (Text -> Text -> Text -> Bool -> Text -> GGWidget master monad ())+ -> [(Text, a)] -> Field (GGWidget master monad ()) FormMessage a+selectFieldHelper outside onOpt inside opts = Field+ { fieldParse = \s ->+ case s of+ Nothing -> Right Nothing+ Just "" -> Right Nothing+ Just "none" -> Right Nothing+ Just x ->+ case Data.Text.Read.decimal x of+ Right (a, "") ->+ case lookup a pairs of+ Nothing -> Left $ MsgInvalidEntry x+ Just y -> Right $ Just $ snd y+ _ -> Left $ MsgInvalidNumber x+ , fieldRender = \a -> maybe "" (pack . show) $ lookup a rpairs+ , fieldView = \theId name val isReq ->+ outside theId name $ do+ unless isReq $ onOpt theId name $ not $ val `elem` map (pack . show . fst) pairs+ flip mapM_ pairs $ \pair -> inside+ theId+ name+ (pack $ show $ fst pair)+ (val == pack (show $ fst pair))+ (fst $ snd pair)+ }+ where+ pairs = zip [1 :: Int ..] opts -- FIXME use IntMap+ rpairs = zip (map snd opts) [1 :: Int ..]
+ Yesod/Form/Functions.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}+module Yesod.Form.Functions+ ( -- * Running in Form monad+ newFormIdent+ , askParams+ , askFiles+ -- * Applicative/Monadic conversion+ , formToAForm+ , aFormToForm+ -- * Fields to Forms+ , mreq+ , mopt+ , areq+ , aopt+ -- * Run a form+ , runFormPost+ , runFormPostNoNonce+ , runFormGet+ -- * Rendering+ , FormRender+ , renderTable+ , renderDivs+ ) where++import Yesod.Form.Types+import Yesod.Form.Fields (FormMessage (MsgCsrfWarning, MsgValueRequired))+import Data.Text (Text, pack)+import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)+import Control.Monad.Trans.Class (lift)+import Control.Monad (liftM, join)+import Text.Blaze (Html, toHtml)+import Yesod.Handler (GHandler, GGHandler, getRequest, runRequestBody, newIdent, getYesod)+import Yesod.Core (RenderMessage)+import Yesod.Widget (GGWidget, whamlet)+import Yesod.Request (reqNonce, reqWaiRequest, reqGetParams, languages)+import Network.Wai (requestMethod)+import Text.Hamlet.NonPoly (html)+import Data.Monoid (mempty)+import Data.Maybe (fromMaybe)+import Yesod.Message (RenderMessage (..))++#if __GLASGOW_HASKELL__ >= 700+#define WHAMLET whamlet+#define HTML html+#else+#define HTML $html+#define WHAMLET $whamlet+#endif++-- | Get a unique identifier.+newFormIdent :: Monad m => Form msg m Text+newFormIdent = do+ i <- get+ let i' = incrInts i+ put i'+ return $ pack $ 'f' : show i'+ where+ incrInts (IntSingle i) = IntSingle $ i + 1+ incrInts (IntCons i is) = (i + 1) `IntCons` is++formToAForm :: Monad m => Form msg m (FormResult a, xml) -> AForm ([xml] -> [xml]) msg m a+formToAForm form = AForm $ \(master, langs) env ints -> do+ ((a, xml), ints', enc) <- runRWST form (env, master, langs) ints+ return (a, (:) xml, ints', enc)++aFormToForm :: Monad m => AForm xml msg m a -> Form msg m (FormResult a, xml)+aFormToForm (AForm aform) = do+ ints <- get+ (env, master, langs) <- ask+ (a, xml, ints', enc) <- lift $ aform (master, langs) env ints+ put ints'+ tell enc+ return (a, xml)++askParams :: Monad m => Form msg m (Maybe Env)+askParams = do+ (x, _, _) <- ask+ return $ liftM fst x++askFiles :: Monad m => Form msg m (Maybe FileEnv)+askFiles = do+ (x, _, _) <- ask+ return $ liftM snd x++mreq :: (Monad m, RenderMessage master msg, RenderMessage master msg2, RenderMessage master FormMessage)+ => Field xml msg a -> FieldSettings msg2 -> Maybe a+ -> Form master (GGHandler sub master m) (FormResult a, FieldView xml)+mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True++mopt :: (Monad m, RenderMessage master msg, RenderMessage master msg2)+ => Field xml msg a -> FieldSettings msg2 -> Maybe (Maybe a)+ -> Form master (GGHandler sub master m) (FormResult (Maybe a), FieldView xml)+mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False++mhelper :: (Monad m, RenderMessage master msg, RenderMessage master msg2)+ => Field xml msg a+ -> FieldSettings msg2+ -> Maybe a+ -> (master -> [Text] -> FormResult b) -- ^ on missing+ -> (a -> FormResult b) -- ^ on success+ -> Bool -- ^ is it required?+ -> Form master (GGHandler sub master m) (FormResult b, FieldView xml)+mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do+ mp <- askParams+ name <- maybe newFormIdent return fsName+ theId <- lift $ maybe (liftM pack newIdent) return fsId+ (_, master, langs) <- ask+ let mr2 = renderMessage master langs+ let (res, val) =+ case mp of+ Nothing -> (FormMissing, maybe "" fieldRender mdef)+ Just p ->+ let mval = lookup name p+ valB = fromMaybe "" mval+ in case fieldParse mval of+ Left e -> (FormFailure [renderMessage master langs e], valB)+ Right mx ->+ case mx of+ Nothing -> (onMissing master langs, valB)+ Just x -> (onFound x, valB)+ return (res, FieldView+ { fvLabel = toHtml $ mr2 fsLabel+ , fvTooltip = fmap toHtml $ fmap mr2 fsTooltip+ , fvId = theId+ , fvInput = fieldView theId name val isReq+ , fvErrors =+ case res of+ FormFailure [e] -> Just $ toHtml e+ _ -> Nothing+ , fvRequired = isReq+ })++areq :: (Monad m, RenderMessage master msg1, RenderMessage master msg2, RenderMessage master FormMessage)+ => Field xml msg1 a -> FieldSettings msg2 -> Maybe a+ -> AForm ([FieldView xml] -> [FieldView xml]) master (GGHandler sub master m) a+areq a b = formToAForm . mreq a b++aopt :: (Monad m, RenderMessage master msg1, RenderMessage master msg2)+ => Field xml msg1 a -> FieldSettings msg2 -> Maybe (Maybe a)+ -> AForm ([FieldView xml] -> [FieldView xml]) master (GGHandler sub master m) (Maybe a)+aopt a b = formToAForm . mopt a b++runFormGeneric :: Monad m => Form master m a -> master -> [Text] -> Maybe (Env, FileEnv) -> m (a, Enctype)+runFormGeneric form master langs env = evalRWST form (env, master, langs) (IntSingle 1)++runFormPost :: RenderMessage master FormMessage+ => (Html -> Form master (GHandler sub master) (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)+runFormPost form = do+ req <- getRequest+ let nonceKey = "_nonce"+ let nonce =+ case reqNonce req of+ Nothing -> mempty+ Just n -> [HTML|<input type=hidden name=#{nonceKey} value=#{n}>|]+ env <- if requestMethod (reqWaiRequest req) == "GET"+ then return Nothing+ else fmap Just runRequestBody+ m <- getYesod+ langs <- languages+ ((res, xml), enctype) <- runFormGeneric (form nonce) m langs env+ let res' =+ case (res, env) of+ (FormSuccess{}, Just (params, _))+ | lookup nonceKey params /= reqNonce req ->+ FormFailure [renderMessage m langs MsgCsrfWarning]+ _ -> res+ return ((res', xml), enctype)++runFormPostNoNonce :: (Html -> Form master (GHandler sub master) (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)+runFormPostNoNonce form = do+ req <- getRequest+ env <- if requestMethod (reqWaiRequest req) == "GET"+ then return Nothing+ else fmap Just runRequestBody+ langs <- languages+ m <- getYesod+ runFormGeneric (form mempty) m langs env++runFormGet :: Monad m => (Html -> Form master (GGHandler sub master m) a) -> GGHandler sub master m (a, Enctype)+runFormGet form = do+ let key = "_hasdata"+ let fragment = [HTML|<input type=hidden name=#{key}>|]+ gets <- liftM reqGetParams getRequest+ let env =+ case lookup key gets of+ Nothing -> Nothing+ Just _ -> Just (gets, [])+ langs <- languages+ m <- getYesod+ runFormGeneric (form fragment) m langs env++type FormRender master msg m a =+ AForm ([FieldView (GGWidget master m ())] -> [FieldView (GGWidget master m ())]) msg m a+ -> Html+ -> Form msg m (FormResult a, GGWidget master m ())++renderTable, renderDivs :: Monad m => FormRender master msg m a+renderTable aform fragment = do+ (res, views') <- aFormToForm aform+ let views = views' []+ -- FIXME non-valid HTML+ let widget = [WHAMLET|+\#{fragment}+$forall view <- views+ <tr :fvRequired view:.required :not $ fvRequired view:.optional>+ <td>+ <label for=#{fvId view}>#{fvLabel view}+ $maybe tt <- fvTooltip view+ <div .tooltip>#{tt}+ <td>^{fvInput view}+ $maybe err <- fvErrors view+ <td .errors>#{err}+|]+ return (res, widget)++renderDivs aform fragment = do+ (res, views') <- aFormToForm aform+ let views = views' []+ let widget = [WHAMLET|+\#{fragment}+$forall view <- views+ <div :fvRequired view:.required :not $ fvRequired view:.optional>+ <label for=#{fvId view}>#{fvLabel view}+ $maybe tt <- fvTooltip view+ <div .tooltip>#{tt}+ ^{fvInput view}+ $maybe err <- fvErrors view+ <div .errors>#{err}+|]+ return (res, widget)
+ Yesod/Form/Input.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+module Yesod.Form.Input+ ( FormInput (..)+ , runInputGet+ , runInputPost+ , ireq+ , iopt+ ) where++import Yesod.Form.Types+import Yesod.Form.Fields (FormMessage (MsgInputNotFound))+import Data.Text (Text)+import Control.Applicative (Applicative (..))+import Yesod.Handler (GHandler, GGHandler, invalidArgs, runRequestBody, getRequest, getYesod)+import Yesod.Request (reqGetParams, languages)+import Control.Monad (liftM)+import Yesod.Widget (GWidget)+import Yesod.Message (RenderMessage (..))++type DText = [Text] -> [Text]+newtype FormInput master a = FormInput { unFormInput :: master -> [Text] -> Env -> Either DText a }+instance Functor (FormInput master) where+ fmap a (FormInput f) = FormInput $ \c d e -> either Left (Right . a) $ f c d e+instance Applicative (FormInput master) where+ pure = FormInput . const . const . const . Right+ (FormInput f) <*> (FormInput x) = FormInput $ \c d e ->+ case (f c d e, x c d e) 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 msg, RenderMessage master FormMessage) => Field (GWidget sub master ()) msg a -> Text -> FormInput master a+ireq field name = FormInput $ \m l env ->+ case fieldParse field $ lookup name env of+ Left e -> Left $ (:) $ renderMessage m l e+ Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name+ Right (Just a) -> Right a++iopt :: RenderMessage master msg => Field (GWidget sub master ()) msg a -> Text -> FormInput master (Maybe a)+iopt field name = FormInput $ \m l env ->+ case fieldParse field $ lookup name env of+ Left e -> Left $ (:) $ renderMessage m l e+ Right x -> Right x++runInputGet :: Monad monad => FormInput master a -> GGHandler sub master monad a+runInputGet (FormInput f) = do+ env <- liftM reqGetParams getRequest+ m <- getYesod+ l <- languages+ case f m l env of+ Left errs -> invalidArgs $ errs []+ Right x -> return x++runInputPost :: FormInput master a -> GHandler sub master a+runInputPost (FormInput f) = do+ env <- liftM fst runRequestBody+ m <- getYesod+ l <- languages+ case f m l env of+ Left errs -> invalidArgs $ errs []+ Right x -> return x
Yesod/Form/Jquery.hs view
@@ -1,241 +1,202 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} --- | Some fields spiced up with jQuery UI. -module Yesod.Form.Jquery - ( YesodJquery (..) - , jqueryDayField - , maybeJqueryDayField - , jqueryDayTimeField - , jqueryDayTimeFieldProfile - , jqueryAutocompleteField - , maybeJqueryAutocompleteField - , jqueryDayFieldProfile - , googleHostedJqueryUiCss - , JqueryDaySettings (..) - , Default (..) - ) where - -import Yesod.Handler -import Yesod.Form.Core -import Yesod.Form.Profiles -import Yesod.Widget -import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime, - timeToTimeOfDay) -import Data.Char (isSpace) -import Data.Default -import Text.Hamlet (hamlet) -import Text.Julius (julius) -import Control.Monad.Trans.Class (lift) -import Data.Text (Text, pack, unpack) -import Data.Monoid (mconcat) - -#if __GLASGOW_HASKELL__ >= 700 -#define HAMLET hamlet -#define CASSIUS cassius -#define JULIUS julius -#else -#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/" - , theme - , "/jquery-ui.css" - ] - -class YesodJquery a where - -- | The jQuery 1.4 Javascript file. - urlJqueryJs :: a -> Either (Route a) Text - urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4/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" - - -- | The jQuery UI 1.8 CSS file; defaults to cupertino theme. - urlJqueryUiCss :: a -> Either (Route a) Text - urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "cupertino" - - -- | jQuery UI time picker add-on. - urlJqueryUiDateTimePicker :: a -> Either (Route a) Text - urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" - -jqueryDayField :: (IsForm f, FormType f ~ Day, YesodJquery (FormMaster f)) - => JqueryDaySettings - -> FormFieldSettings - -> Maybe (FormType f) - -> f -jqueryDayField = requiredFieldHelper . jqueryDayFieldProfile - -maybeJqueryDayField - :: (IsForm f, FormType f ~ Maybe Day, YesodJquery (FormMaster f)) - => JqueryDaySettings - -> FormFieldSettings - -> Maybe (FormType f) - -> f -maybeJqueryDayField = optionalFieldHelper . jqueryDayFieldProfile - -jqueryDayFieldProfile :: YesodJquery y - => JqueryDaySettings -> FieldProfile sub y Day -jqueryDayFieldProfile jds = FieldProfile - { fpParse = maybe - (Left "Invalid day, must be in YYYY-MM-DD format") - Right - . readMay - . unpack - , fpRender = pack . show - , fpWidget = \theId name val isReq -> do - addHtml [HAMLET|\ -<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}"> -|] - addScript' urlJqueryJs - addScript' urlJqueryUiJs - addStylesheet' urlJqueryUiCss - addJulius [JULIUS| -$(function(){$("##{theId}").datepicker({ - dateFormat:'yy-mm-dd', - changeMonth:#{jsBool $ jdsChangeMonth jds}, - changeYear:#{jsBool $ jdsChangeYear jds}, - numberOfMonths:#{mos $ jdsNumberOfMonths jds}, - yearRange:"#{jdsYearRange jds}" -})}); -|] - } - where - jsBool True = "true" :: Text - jsBool False = "false" :: Text - mos (Left i) = show i - mos (Right (x, y)) = concat - [ "[" - , show x - , "," - , show y - , "]" - ] - -ifRight :: Either a b -> (b -> c) -> Either a c -ifRight e f = case e of - Left l -> Left l - Right r -> Right $ f r - -showLeadingZero :: (Show a) => a -> String -showLeadingZero time = let t = show time in if length t == 1 then "0" ++ t else t - -jqueryDayTimeField - :: (IsForm f, FormType f ~ UTCTime, YesodJquery (FormMaster f)) - => FormFieldSettings - -> Maybe (FormType f) - -> f -jqueryDayTimeField = requiredFieldHelper jqueryDayTimeFieldProfile - --- use A.M/P.M and drop seconds and "UTC" (as opposed to normal UTCTime show) -jqueryDayTimeUTCTime :: UTCTime -> String -jqueryDayTimeUTCTime (UTCTime day utcTime) = - let timeOfDay = timeToTimeOfDay utcTime - in (replace '-' '/' (show day)) ++ " " ++ showTimeOfDay timeOfDay - where - showTimeOfDay (TimeOfDay hour minute _) = - let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM") - in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm - -jqueryDayTimeFieldProfile :: YesodJquery y => FieldProfile sub y UTCTime -jqueryDayTimeFieldProfile = FieldProfile - { fpParse = parseUTCTime . unpack - , fpRender = pack . jqueryDayTimeUTCTime - , fpWidget = \theId name val isReq -> do - addHtml [HAMLET|\ -<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}"> -|] - addScript' urlJqueryJs - addScript' urlJqueryUiJs - addScript' urlJqueryUiDateTimePicker - addStylesheet' urlJqueryUiCss - addJulius [JULIUS| -$(function(){$("##{theId}").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})}); -|] - } - -parseUTCTime :: String -> Either Text UTCTime -parseUTCTime s = - let (dateS, timeS) = break isSpace (dropWhile isSpace s) - dateE = parseDate dateS - in case dateE of - Left l -> Left l - Right date -> - ifRight (parseTime timeS) - (UTCTime date . timeOfDayToTime) - -jqueryAutocompleteField - :: (IsForm f, FormType f ~ Text, YesodJquery (FormMaster f)) - => Route (FormMaster f) - -> FormFieldSettings - -> Maybe (FormType f) - -> f -jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile - -maybeJqueryAutocompleteField - :: (IsForm f, FormType f ~ Maybe Text, YesodJquery (FormMaster f)) - => Route (FormMaster f) - -> FormFieldSettings - -> Maybe (FormType f) - -> f -maybeJqueryAutocompleteField src = - optionalFieldHelper $ jqueryAutocompleteFieldProfile src - -jqueryAutocompleteFieldProfile :: YesodJquery y => Route y -> FieldProfile sub y Text -jqueryAutocompleteFieldProfile src = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val isReq -> do - addHtml [HAMLET|\ -<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}" .autocomplete> -|] - addScript' urlJqueryJs - addScript' urlJqueryUiJs - addStylesheet' urlJqueryUiCss - addJulius [JULIUS| -$(function(){$("##{theId}").autocomplete({source:"@{src}",minLength:2})}); -|] - } - -addScript' :: (y -> Either (Route y) Text) -> GWidget sub y () -addScript' f = do - y <- lift getYesod - addScriptEither $ f y - -addStylesheet' :: (y -> Either (Route y) Text) -> GWidget sub y () -addStylesheet' f = do - y <- lift getYesod - addStylesheetEither $ f y - -readMay :: Read a => String -> Maybe a -readMay s = case reads s of - (x, _):_ -> Just x - [] -> Nothing - --- | Replaces all instances of a value in a list by another value. --- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace -replace :: Eq a => a -> a -> [a] -> [a] -replace x y = map (\z -> if z == x then y else z) - -data JqueryDaySettings = JqueryDaySettings - { jdsChangeMonth :: Bool - , jdsChangeYear :: Bool - , jdsYearRange :: String - , jdsNumberOfMonths :: Either Int (Int, Int) - } - -instance Default JqueryDaySettings where - def = JqueryDaySettings - { jdsChangeMonth = False - , jdsChangeYear = False - , jdsYearRange = "c-10:c+10" - , jdsNumberOfMonths = Left 1 - } +{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove+-- | Some fields spiced up with jQuery UI.+module Yesod.Form.Jquery+ ( YesodJquery (..)+ , jqueryDayField+ , jqueryDayTimeField+ , jqueryAutocompleteField+ , googleHostedJqueryUiCss+ , JqueryDaySettings (..)+ , Default (..)+ ) where++import Yesod.Handler+import Yesod.Form+import Yesod.Widget+import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime,+ timeToTimeOfDay)+import Data.Char (isSpace)+import Data.Default+import Text.Hamlet (hamlet)+import Text.Julius (julius)+import Control.Monad.Trans.Class (lift)+import Data.Text (Text, pack, unpack)+import Data.Monoid (mconcat)++#if __GLASGOW_HASKELL__ >= 700+#define HAMLET hamlet+#define CASSIUS cassius+#define JULIUS julius+#else+#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/"+ , theme+ , "/jquery-ui.css"+ ]++class YesodJquery a where+ -- | The jQuery 1.4 Javascript file.+ urlJqueryJs :: a -> Either (Route a) Text+ urlJqueryJs _ = Right "http://ajax.googleapis.com/ajax/libs/jquery/1.4/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"++ -- | The jQuery UI 1.8 CSS file; defaults to cupertino theme.+ urlJqueryUiCss :: a -> Either (Route a) Text+ urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "cupertino"++ -- | jQuery UI time picker add-on.+ urlJqueryUiDateTimePicker :: a -> Either (Route a) Text+ urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"++blank :: (Text -> Either msg a) -> Maybe Text -> Either msg (Maybe a)+blank _ Nothing = Right Nothing+blank _ (Just "") = Right Nothing+blank f (Just t) = either Left (Right . Just) $ f t++jqueryDayField :: (YesodJquery master) => JqueryDaySettings -> Field (GWidget sub master ()) FormMessage Day+jqueryDayField jds = Field+ { fieldParse = blank $ maybe+ (Left MsgInvalidDay)+ Right+ . readMay+ . unpack+ , fieldRender = pack . show+ , fieldView = \theId name val isReq -> do+ addHtml [HAMLET|\+<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}">+|]+ addScript' urlJqueryJs+ addScript' urlJqueryUiJs+ addStylesheet' urlJqueryUiCss+ addJulius [JULIUS|+$(function(){$("##{theId}").datepicker({+ dateFormat:'yy-mm-dd',+ changeMonth:#{jsBool $ jdsChangeMonth jds},+ changeYear:#{jsBool $ jdsChangeYear jds},+ numberOfMonths:#{mos $ jdsNumberOfMonths jds},+ yearRange:"#{jdsYearRange jds}"+})});+|]+ }+ where+ jsBool True = "true" :: Text+ jsBool False = "false" :: Text+ mos (Left i) = show i+ mos (Right (x, y)) = concat+ [ "["+ , show x+ , ","+ , show y+ , "]"+ ]++ifRight :: Either a b -> (b -> c) -> Either a c+ifRight e f = case e of+ Left l -> Left l+ Right r -> Right $ f r++showLeadingZero :: (Show a) => a -> String+showLeadingZero time = let t = show time in if length t == 1 then "0" ++ t else t++-- use A.M/P.M and drop seconds and "UTC" (as opposed to normal UTCTime show)+jqueryDayTimeUTCTime :: UTCTime -> String+jqueryDayTimeUTCTime (UTCTime day utcTime) =+ let timeOfDay = timeToTimeOfDay utcTime+ in (replace '-' '/' (show day)) ++ " " ++ showTimeOfDay timeOfDay+ where+ showTimeOfDay (TimeOfDay hour minute _) =+ let (h, apm) = if hour < 12 then (hour, "AM") else (hour - 12, "PM")+ in (show h) ++ ":" ++ (showLeadingZero minute) ++ " " ++ apm++jqueryDayTimeField :: YesodJquery master => Field (GWidget sub master ()) FormMessage UTCTime+jqueryDayTimeField = Field+ { fieldParse = blank $ parseUTCTime . unpack+ , fieldRender = pack . jqueryDayTimeUTCTime+ , fieldView = \theId name val isReq -> do+ addHtml [HAMLET|\+<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}">+|]+ addScript' urlJqueryJs+ addScript' urlJqueryUiJs+ addScript' urlJqueryUiDateTimePicker+ addStylesheet' urlJqueryUiCss+ addJulius [JULIUS|+$(function(){$("##{theId}").datetimepicker({dateFormat : "yyyy/mm/dd h:MM TT"})});+|]+ }++parseUTCTime :: String -> Either FormMessage UTCTime+parseUTCTime s =+ let (dateS, timeS) = break isSpace (dropWhile isSpace s)+ dateE = parseDate dateS+ in case dateE of+ Left l -> Left l+ Right date ->+ ifRight (parseTime timeS)+ (UTCTime date . timeOfDayToTime)++jqueryAutocompleteField :: YesodJquery master => Route master -> Field (GWidget sub master ()) FormMessage Text+jqueryAutocompleteField src = Field+ { fieldParse = Right+ , fieldRender = id+ , fieldView = \theId name val isReq -> do+ addHtml [HAMLET|\+<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}" .autocomplete>+|]+ addScript' urlJqueryJs+ addScript' urlJqueryUiJs+ addStylesheet' urlJqueryUiCss+ addJulius [JULIUS|+$(function(){$("##{theId}").autocomplete({source:"@{src}",minLength:2})});+|]+ }++addScript' :: Monad m => (t -> Either (Route master) Text) -> GGWidget master (GGHandler sub t m) ()+addScript' f = do+ y <- lift getYesod+ addScriptEither $ f y++addStylesheet' :: (y -> Either (Route y) Text) -> GWidget sub y ()+addStylesheet' f = do+ y <- lift getYesod+ addStylesheetEither $ f y++readMay :: Read a => String -> Maybe a+readMay s = case reads s of+ (x, _):_ -> Just x+ [] -> Nothing++-- | Replaces all instances of a value in a list by another value.+-- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace+replace :: Eq a => a -> a -> [a] -> [a]+replace x y = map (\z -> if z == x then y else z)++data JqueryDaySettings = JqueryDaySettings+ { jdsChangeMonth :: Bool+ , jdsChangeYear :: Bool+ , jdsYearRange :: String+ , jdsNumberOfMonths :: Either Int (Int, Int)+ }++instance Default JqueryDaySettings where+ def = JqueryDaySettings+ { jdsChangeMonth = False+ , jdsChangeYear = False+ , jdsYearRange = "c-10:c+10"+ , jdsNumberOfMonths = Left 1+ }
Yesod/Form/Nic.hs view
@@ -1,65 +1,61 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} --- | Provide the user with a rich text editor. -module Yesod.Form.Nic - ( YesodNic (..) - , nicHtmlField - , maybeNicHtmlField - ) where - -import Yesod.Handler -import Yesod.Form.Core -import Yesod.Widget -import Text.HTML.SanitizeXSS (sanitizeBalance) -import Text.Hamlet (Html, hamlet) -import Text.Julius (julius) -import Text.Blaze.Renderer.String (renderHtml) -import Text.Blaze (preEscapedString) -import Control.Monad.Trans.Class (lift) -import Data.Text (Text, pack, unpack) - -class YesodNic a where - -- | NIC Editor Javascript file. - urlNicEdit :: a -> Either (Route a) Text - urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" - -nicHtmlField :: (IsForm f, FormType f ~ Html, YesodNic (FormMaster f)) - => FormFieldSettings -> Maybe Html -> f -nicHtmlField = requiredFieldHelper nicHtmlFieldProfile - -maybeNicHtmlField - :: (IsForm f, FormType f ~ Maybe Html, YesodNic (FormMaster f)) - => FormFieldSettings -> Maybe (FormType f) -> f -maybeNicHtmlField = optionalFieldHelper nicHtmlFieldProfile - -nicHtmlFieldProfile :: YesodNic y => FieldProfile sub y Html -nicHtmlFieldProfile = FieldProfile - { fpParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME - , fpRender = pack . renderHtml - , fpWidget = \theId name val _isReq -> do - addHtml -#if __GLASGOW_HASKELL__ >= 700 - [hamlet| -#else - [$hamlet| -#endif - <textarea id="#{theId}" name="#{name}" .html>#{val} -|] - addScript' urlNicEdit - addJulius -#if __GLASGOW_HASKELL__ >= 700 - [julius| -#else - [$julius| -#endif -bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{theId}")}); -|] - } - -addScript' :: (y -> Either (Route y) Text) -> GWidget sub y () -addScript' f = do - y <- lift getYesod - addScriptEither $ f y +{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-} -- FIXME remove+-- | Provide the user with a rich text editor.+module Yesod.Form.Nic+ ( YesodNic (..)+ , nicHtmlField+ ) where++import Yesod.Handler+import Yesod.Form+import Yesod.Widget+import Text.HTML.SanitizeXSS (sanitizeBalance)+import Text.Hamlet (Html, hamlet)+import Text.Julius (julius)+import Text.Blaze.Renderer.String (renderHtml)+import Text.Blaze (preEscapedString)+import Control.Monad.Trans.Class (lift)+import Data.Text (Text, pack, unpack)++class YesodNic a where+ -- | NIC Editor Javascript file.+ urlNicEdit :: a -> Either (Route a) Text+ urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"++blank :: (Text -> Either msg a) -> Maybe Text -> Either msg (Maybe a)+blank _ Nothing = Right Nothing+blank _ (Just "") = Right Nothing+blank f (Just t) = either Left (Right . Just) $ f t++nicHtmlField :: YesodNic master => Field (GWidget sub master ()) msg Html+nicHtmlField = Field+ { fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME+ , fieldRender = pack . renderHtml+ , fieldView = \theId name val _isReq -> do+ addHtml+#if __GLASGOW_HASKELL__ >= 700+ [hamlet|+#else+ [$hamlet|+#endif+ <textarea id="#{theId}" name="#{name}" .html>#{val}+|]+ addScript' urlNicEdit+ addJulius+#if __GLASGOW_HASKELL__ >= 700+ [julius|+#else+ [$julius|+#endif+bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{theId}")});+|]+ }++addScript' :: (y -> Either (Route y) Text) -> GWidget sub y ()+addScript' f = do+ y <- lift getYesod+ addScriptEither $ f y
− Yesod/Form/Profiles.hs
@@ -1,251 +0,0 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} -module Yesod.Form.Profiles - ( stringFieldProfile - , passwordFieldProfile - , textareaFieldProfile - , hiddenFieldProfile - , intFieldProfile - , dayFieldProfile - , timeFieldProfile - , htmlFieldProfile - , emailFieldProfile - , searchFieldProfile - , AutoFocus - , urlFieldProfile - , doubleFieldProfile - , parseDate - , parseTime - , Textarea (..) - ) where - -import Yesod.Form.Core -import Yesod.Widget -import Text.Hamlet hiding (renderHtml) -import Text.Blaze (ToHtml (..)) -import Text.Cassius -import Data.Time (Day, TimeOfDay(..)) -import qualified Text.Email.Validate as Email -import Network.URI (parseURI) -import Database.Persist (PersistField) -import Text.HTML.SanitizeXSS (sanitizeBalance) -import Control.Monad (when) - -import qualified Blaze.ByteString.Builder.Html.Utf8 as B -import Blaze.ByteString.Builder (writeByteString, toLazyByteString) -import Blaze.ByteString.Builder.Internal.Write (fromWriteList) - -import Text.Blaze.Renderer.String (renderHtml) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import Data.Text (Text, unpack, pack) - -#if __GLASGOW_HASKELL__ >= 700 -#define HAMLET hamlet -#define CASSIUS cassius -#define JULIUS julius -#else -#define HAMLET $hamlet -#define CASSIUS $cassius -#define JULIUS $julius -#endif - -intFieldProfile :: Integral i => FieldProfile sub y i -intFieldProfile = FieldProfile - { fpParse = maybe (Left "Invalid integer") Right . readMayI . unpack -- FIXME Data.Text.Read - , fpRender = pack . showI - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET|\ -<input id="#{theId}" name="#{name}" type="number" :isReq:required="" value="#{val}"> -|] - } - where - showI x = show (fromIntegral x :: Integer) - readMayI s = case reads s of - (x, _):_ -> Just $ fromInteger x - [] -> Nothing - -doubleFieldProfile :: FieldProfile sub y Double -doubleFieldProfile = FieldProfile - { fpParse = maybe (Left "Invalid number") Right . readMay . unpack -- FIXME use Data.Text.Read - , fpRender = pack . show - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET|\ -<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}"> -|] - } - -dayFieldProfile :: FieldProfile sub y Day -dayFieldProfile = FieldProfile - { fpParse = parseDate . unpack - , fpRender = pack . show - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET|\ -<input id="#{theId}" name="#{name}" type="date" :isReq:required="" value="#{val}"> -|] - } - -timeFieldProfile :: FieldProfile sub y TimeOfDay -timeFieldProfile = FieldProfile - { fpParse = parseTime . unpack - , fpRender = pack . show . roundFullSeconds - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET|\ -<input id="#{theId}" name="#{name}" :isReq:required="" value="#{val}"> -|] - } - where - roundFullSeconds tod = - TimeOfDay (todHour tod) (todMin tod) fullSec - where - fullSec = fromInteger $ floor $ todSec tod - -htmlFieldProfile :: FieldProfile sub y Html -htmlFieldProfile = FieldProfile - { fpParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize - , fpRender = pack . renderHtml - , fpWidget = \theId name val _isReq -> addHamlet - [HAMLET|\ -<textarea id="#{theId}" name="#{name}" .html>#{val} -|] - } - --- | A newtype wrapper around a 'String' that converts newlines to HTML --- br-tags. -newtype Textarea = Textarea { unTextarea :: Text } - deriving (Show, Read, Eq, PersistField) -instance ToHtml Textarea where - toHtml = - unsafeByteString - . S.concat - . L.toChunks - . toLazyByteString - . fromWriteList writeHtmlEscapedChar - . unpack - . unTextarea - where - -- Taken from blaze-builder and modified with newline handling. - writeHtmlEscapedChar '\n' = writeByteString "<br>" - writeHtmlEscapedChar c = B.writeHtmlEscapedChar c - -textareaFieldProfile :: FieldProfile sub y Textarea -textareaFieldProfile = FieldProfile - { fpParse = Right . Textarea - , fpRender = unTextarea - , fpWidget = \theId name val _isReq -> addHamlet - [HAMLET|\ -<textarea id="#{theId}" name="#{name}">#{val} -|] - } - -hiddenFieldProfile :: FieldProfile sub y Text -hiddenFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val _isReq -> addHamlet - [HAMLET|\ -<input type="hidden" id="#{theId}" name="#{name}" value="#{val}"> -|] - } - -stringFieldProfile :: FieldProfile sub y Text -stringFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET|\ -<input id="#{theId}" name="#{name}" type="text" :isReq:required="" value="#{val}"> -|] - } - -passwordFieldProfile :: FieldProfile s m Text -passwordFieldProfile = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET|\ -<input id="#{theId}" name="#{name}" type="password" :isReq:required="" value="#{val}"> -|] - } - -readMay :: Read a => String -> Maybe a -readMay s = case reads s of - (x, _):_ -> Just x - [] -> Nothing - -parseDate :: String -> Either Text Day -parseDate = maybe (Left "Invalid day, must be in YYYY-MM-DD format") Right - . readMay . replace '/' '-' - --- | Replaces all instances of a value in a list by another value. --- from http://hackage.haskell.org/packages/archive/cgi/3001.1.7.1/doc/html/src/Network-CGI-Protocol.html#replace -replace :: Eq a => a -> a -> [a] -> [a] -replace x y = map (\z -> if z == x then y else z) - -parseTime :: String -> Either Text 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 "Invalid time, must be in HH:MM[:SS] format" - -parseTimeHelper :: (Char, Char, Char, Char, Char, Char) - -> Either Text TimeOfDay -parseTimeHelper (h1, h2, m1, m2, s1, s2) - | h < 0 || h > 23 = Left $ pack $ "Invalid hour: " ++ show h - | m < 0 || m > 59 = Left $ pack $ "Invalid minute: " ++ show m - | s < 0 || s > 59 = Left $ pack $ "Invalid second: " ++ show s - | otherwise = Right $ TimeOfDay h m s - where - h = read [h1, h2] - m = read [m1, m2] - s = fromInteger $ read [s1, s2] - -emailFieldProfile :: FieldProfile s y Text -emailFieldProfile = FieldProfile - { fpParse = \s -> if Email.isValid (unpack s) - then Right s - else Left "Invalid e-mail address" - , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET|\ -<input id="#{theId}" name="#{name}" type="email" :isReq:required="" value="#{val}"> -|] - } - -type AutoFocus = Bool -searchFieldProfile :: AutoFocus -> FieldProfile s y Text -searchFieldProfile autoFocus = FieldProfile - { fpParse = Right - , fpRender = id - , fpWidget = \theId name val isReq -> do - addHtml [HAMLET|\ -<input id="#{theId}" name="#{name}" type="search" :isReq:required="" :autoFocus:autofocus="" value="#{val}"> -|] - when autoFocus $ do - addHtml $ [HAMLET|\<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}</script> -|] - addCassius [CASSIUS| - #{theId} - -webkit-appearance: textfield - |] - } - -urlFieldProfile :: FieldProfile s y Text -urlFieldProfile = FieldProfile - { fpParse = \s -> case parseURI $ unpack s of - Nothing -> Left "Invalid URL" - Just _ -> Right s - , fpRender = id - , fpWidget = \theId name val isReq -> addHamlet - [HAMLET|\ -<input id="#{theId}" name="#{name}" type="url" :isReq:required="" value="#{val}"> -|] - }
+ Yesod/Form/Types.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+module Yesod.Form.Types+ ( -- * Helpers+ Enctype (..)+ , FormResult (..)+ , Env+ , FileEnv+ , Ints (..)+ -- * Form+ , Form+ , AForm (..)+ -- * Build forms+ , Field (..)+ , FieldSettings (..)+ , FieldView (..)+ ) where++import Control.Monad.Trans.RWS (RWST)+import Yesod.Request (FileInfo)+import Data.Text (Text)+import Data.Monoid (Monoid (..))+import Text.Blaze (Html, ToHtml (toHtml))+import Control.Applicative ((<$>), Applicative (..))+import Control.Monad (liftM)+import Data.String (IsString (..))+import Control.Monad.Trans.Class (MonadTrans (..))++-- | 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.+data FormResult a = FormMissing+ | FormFailure [Text]+ | FormSuccess a+ deriving Show+instance Functor FormResult where+ fmap _ FormMissing = FormMissing+ fmap _ (FormFailure errs) = FormFailure errs+ fmap f (FormSuccess a) = FormSuccess $ f a+instance Applicative FormResult where+ pure = FormSuccess+ (FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g+ (FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y+ (FormFailure x) <*> _ = FormFailure x+ _ <*> (FormFailure y) = FormFailure y+ _ <*> _ = FormMissing+instance Monoid m => Monoid (FormResult m) where+ mempty = pure mempty+ mappend x y = mappend <$> x <*> y++-- | The encoding type required by a form. The 'ToHtml' instance produces values+-- that can be inserted directly into HTML.+data Enctype = UrlEncoded | Multipart+ deriving (Eq, Enum, Bounded)+instance ToHtml Enctype where+ toHtml UrlEncoded = "application/x-www-form-urlencoded"+ toHtml Multipart = "multipart/form-data"+instance Monoid Enctype where+ mempty = UrlEncoded+ mappend UrlEncoded UrlEncoded = UrlEncoded+ mappend _ _ = Multipart++data Ints = IntCons Int Ints | IntSingle Int+instance Show Ints where+ show (IntSingle i) = show i+ show (IntCons i is) = show i ++ ('-' : show is)++type Env = [(Text, Text)] -- FIXME use a Map+type FileEnv = [(Text, FileInfo)]++type Form master m a = RWST (Maybe (Env, FileEnv), master, [Text]) Enctype Ints m a++newtype AForm xml master m a = AForm+ { unAForm :: (master, [Text]) -> Maybe (Env, FileEnv) -> Ints -> m (FormResult a, xml, Ints, Enctype)+ }+instance Monad m => Functor (AForm xml msg 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 (Monad m, Monoid xml) => Applicative (AForm xml msg m) where+ pure x = AForm $ const $ const $ \ints -> return (FormSuccess x, mempty, 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 (Monad m, Monoid xml, Monoid a) => Monoid (AForm xml msg m a) where+ mempty = pure mempty+ mappend a b = mappend <$> a <*> b+instance Monoid xml => MonadTrans (AForm xml msg) where+ lift mx = AForm $ const $ const $ \ints -> do+ x <- mx+ return (pure x, mempty, ints, mempty)++data FieldSettings msg = FieldSettings+ { fsLabel :: msg+ , fsTooltip :: Maybe msg+ , fsId :: Maybe Text+ , fsName :: Maybe Text+ }++instance (a ~ Text) => IsString (FieldSettings a) where+ fromString s = FieldSettings (fromString s) Nothing Nothing Nothing++data FieldView xml = FieldView+ { fvLabel :: Html+ , fvTooltip :: Maybe Html+ , fvId :: Text+ , fvInput :: xml+ , fvErrors :: Maybe Html+ , fvRequired :: Bool+ }++data Field xml msg a = Field+ { fieldParse :: Maybe Text -> Either msg (Maybe a)+ , fieldRender :: a -> Text+ , fieldView :: Text -- ^ ID+ -> Text -- ^ name+ -> Text -- ^ value+ -> Bool -- ^ required?+ -> xml+ }
− Yesod/Helpers/Crud.hs
@@ -1,203 +0,0 @@-{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -module Yesod.Helpers.Crud - ( Item (..) - , Crud (..) - , CrudRoute (..) - , defaultCrud - ) where - -import Yesod.Core -import Text.Hamlet -import Yesod.Form -import Language.Haskell.TH.Syntax -import Yesod.Persist -import Data.Text (Text) -import Web.Routes.Quasi (toSinglePiece, fromSinglePiece) - --- | An entity which can be displayed by the Crud subsite. -class Item a where - -- | The title of an entity, to be displayed in the list of all entities. - itemTitle :: a -> Text - --- | Defines all of the CRUD operations (Create, Read, Update, Delete) --- necessary to implement this subsite. When using the "Yesod.Form" module and --- 'ToForm' typeclass, you can probably just use 'defaultCrud'. -data Crud master item = Crud - { crudSelect :: GHandler (Crud master item) master [(Key item, item)] - , crudReplace :: Key item -> item -> GHandler (Crud master item) master () - , crudInsert :: item -> GHandler (Crud master item) master (Key item) - , crudGet :: Key item -> GHandler (Crud master item) master (Maybe item) - , crudDelete :: Key item -> GHandler (Crud master item) master () - } - -mkYesodSub "Crud master item" - [ ClassP ''Item [VarT $ mkName "item"] - , ClassP ''SinglePiece [ConT ''Key `AppT` VarT (mkName "item")] - , ClassP ''ToForm [VarT $ mkName "item", VarT $ mkName "master"] - ] -#if __GLASGOW_HASKELL__ >= 700 - [parseRoutes| -#else - [$parseRoutes| -#endif -/ CrudListR GET -/add CrudAddR GET POST -/edit/#Text CrudEditR GET POST -/delete/#Text CrudDeleteR GET POST -|] - -getCrudListR :: (Yesod master, Item item, SinglePiece (Key item)) - => GHandler (Crud master item) master RepHtml -getCrudListR = do - items <- getYesodSub >>= crudSelect - toMaster <- getRouteToMaster - defaultLayout $ do - setTitle "Items" - addWidget -#if __GLASGOW_HASKELL__ >= 700 - [hamlet| -#else - [$hamlet| -#endif -<h1>Items -<ul> - $forall item <- items - <li> - <a href="@{toMaster (CrudEditR (toSinglePiece (fst item)))}"> - \#{itemTitle (snd item)} -<p> - <a href="@{toMaster CrudAddR}">Add new item -|] - -getCrudAddR :: (Yesod master, Item item, SinglePiece (Key item), - ToForm item master) - => GHandler (Crud master item) master RepHtml -getCrudAddR = crudHelper - "Add new" - (Nothing :: Maybe (Key item, item)) - False - -postCrudAddR :: (Yesod master, Item item, SinglePiece (Key item), - ToForm item master) - => GHandler (Crud master item) master RepHtml -postCrudAddR = crudHelper - "Add new" - (Nothing :: Maybe (Key item, item)) - True - -getCrudEditR :: (Yesod master, Item item, SinglePiece (Key item), - ToForm item master) - => Text -> GHandler (Crud master item) master RepHtml -getCrudEditR s = do - itemId <- maybe notFound return $ fromSinglePiece s - crud <- getYesodSub - item <- crudGet crud itemId >>= maybe notFound return - crudHelper - "Edit item" - (Just (itemId, item)) - False - -postCrudEditR :: (Yesod master, Item item, SinglePiece (Key item), - ToForm item master) - => Text -> GHandler (Crud master item) master RepHtml -postCrudEditR s = do - itemId <- maybe notFound return $ fromSinglePiece s - crud <- getYesodSub - item <- crudGet crud itemId >>= maybe notFound return - crudHelper - "Edit item" - (Just (itemId, item)) - True - -getCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item)) - => Text -> GHandler (Crud master item) master RepHtml -getCrudDeleteR s = do - itemId <- maybe notFound return $ fromSinglePiece s - crud <- getYesodSub - item <- crudGet crud itemId >>= maybe notFound return -- Just ensure it exists - toMaster <- getRouteToMaster - defaultLayout $ do - setTitle "Confirm delete" - addWidget -#if __GLASGOW_HASKELL__ >= 700 - [hamlet| -#else - [$hamlet| -#endif -<form method="post" action="@{toMaster (CrudDeleteR s)}"> - <h1>Really delete? - <p>Do you really want to delete #{itemTitle item}? - <p> - <input type="submit" value="Yes"> - \ - <a href="@{toMaster CrudListR}">No -|] - -postCrudDeleteR :: (Yesod master, Item item, SinglePiece (Key item)) - => Text -> GHandler (Crud master item) master RepHtml -postCrudDeleteR s = do - itemId <- maybe notFound return $ fromSinglePiece s - crud <- getYesodSub - toMaster <- getRouteToMaster - crudDelete crud itemId - redirect RedirectTemporary $ toMaster CrudListR - -crudHelper - :: (Item a, Yesod master, SinglePiece (Key a), ToForm a master) - => Text -> Maybe (Key a, a) -> Bool - -> GHandler (Crud master a) master RepHtml -crudHelper title me isPost = do - crud <- getYesodSub - (errs, form, enctype, hidden) <- runFormPost $ toForm $ fmap snd me - toMaster <- getRouteToMaster - case (isPost, errs) of - (True, FormSuccess a) -> do - eid <- case me of - Just (eid, _) -> do - crudReplace crud eid a - return eid - Nothing -> crudInsert crud a - redirect RedirectTemporary $ toMaster $ CrudEditR - $ toSinglePiece eid - _ -> return () - defaultLayout $ do - setTitle $ toHtml title - addWidget -#if __GLASGOW_HASKELL__ >= 700 - [hamlet| -#else - [$hamlet| -#endif -<p> - <a href="@{toMaster CrudListR}">Return to list -<h1>#{title} -<form method="post" enctype="#{enctype}"> - <table> - \^{form} - <tr> - <td colspan="2"> - \#{hidden} - <input type="submit"> - $maybe e <- me - \ - <a href="@{toMaster (CrudDeleteR (toSinglePiece (fst e)))}">Delete -|] - --- | A default 'Crud' value which relies about persistent and "Yesod.Form". -defaultCrud - :: (PersistEntity i, PersistBackend (YesodDB a (GGHandler (Crud a i) a IO)), - YesodPersist a) - => a -> Crud a i -defaultCrud = const Crud - { crudSelect = runDB $ selectList [] [] 0 0 - , crudReplace = \a -> runDB . replace a - , crudInsert = runDB . insert - , crudGet = runDB . get - , crudDelete = runDB . delete - }
yesod-form.cabal view
@@ -1,44 +1,46 @@-name: yesod-form -version: 0.1.0.1 -license: BSD3 -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/ - -library - build-depends: base >= 4 && < 5 - , yesod-core >= 0.8 && < 0.9 - , time >= 1.1.4 && < 1.3 - , hamlet >= 0.8 && < 0.9 - , persistent >= 0.5 && < 0.6 - , yesod-persistent >= 0.1 && < 0.2 - , template-haskell - , transformers >= 0.2.2 && < 0.3 - , data-default >= 0.2 && < 0.3 - , xss-sanitize >= 0.2.4 && < 0.3 - , blaze-builder >= 0.2.1 && < 0.4 - , network >= 2.2 && < 2.4 - , email-validate >= 0.2.6 && < 0.3 - , blaze-html >= 0.4 && < 0.5 - , bytestring >= 0.9 && < 0.10 - , text >= 0.7 && < 1.0 - , web-routes-quasi >= 0.7 && < 0.8 - exposed-modules: Yesod.Form - Yesod.Form.Class - Yesod.Form.Core - Yesod.Form.Fields - Yesod.Form.Jquery - Yesod.Form.Nic - Yesod.Form.Profiles - Yesod.Helpers.Crud - ghc-options: -Wall - -source-repository head - type: git - location: git://github.com/snoyberg/yesod-form.git +name: yesod-form+version: 0.2.0+license: BSD3+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/++library+ build-depends: base >= 4 && < 5+ , yesod-core >= 0.8.2 && < 0.9+ , time >= 1.1.4 && < 1.3+ , hamlet >= 0.8.1 && < 0.9+ , persistent >= 0.5 && < 0.6+ , yesod-persistent >= 0.1 && < 0.2+ , template-haskell+ , transformers >= 0.2.2 && < 0.3+ , data-default >= 0.2 && < 0.3+ , xss-sanitize >= 0.2.4 && < 0.3+ , blaze-builder >= 0.2.1 && < 0.4+ , network >= 2.2 && < 2.4+ , email-validate >= 0.2.6 && < 0.3+ , blaze-html >= 0.4 && < 0.5+ , bytestring >= 0.9 && < 0.10+ , text >= 0.7 && < 1.0+ , web-routes-quasi >= 0.7 && < 0.8+ , wai >= 0.4 && < 0.5+ exposed-modules: Yesod.Form+ Yesod.Form.Class+ Yesod.Form.Types+ Yesod.Form.Functions+ Yesod.Form.Input+ Yesod.Form.Fields+ Yesod.Form.Jquery+ Yesod.Form.Nic+ -- FIXME Yesod.Helpers.Crud+ ghc-options: -Wall++source-repository head+ type: git+ location: git://github.com/snoyberg/yesod-form.git