yesod-form 0.0.0.2 → 0.1.0
raw patch · 11 files changed
+2101/−2080 lines, 11 filesdep +textdep ~blaze-builderdep ~hamletdep ~persistentsetup-changed
Dependencies added: text
Dependency ranges changed: blaze-builder, hamlet, persistent, yesod-core, yesod-persistent
Files
- LICENSE +25/−25
- Setup.lhs +7/−7
- Yesod/Form.hs +313/−311
- Yesod/Form/Class.hs +69/−61
- Yesod/Form/Core.hs +376/−370
- Yesod/Form/Fields.hs +509/−506
- Yesod/Form/Jquery.hs +241/−237
- Yesod/Form/Nic.hs +65/−63
- Yesod/Form/Profiles.hs +251/−249
- Yesod/Helpers/Crud.hs +202/−209
- yesod-form.cabal +43/−42
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,311 +1,313 @@-{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} --- | 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) - -#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" - --- | 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" - --- | 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 :: String -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' <- [|string|] - 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 [String] -formFailures (FormFailure x) = Just x -formFailures _ = Nothing +{-# 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
Yesod/Form/Class.hs view
@@ -1,61 +1,69 @@-{-# 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) - -class ToForm a y where - toForm :: Formlet sub y a -class ToFormField a y where - toFormField :: FormFieldSettings -> FormletField sub y a - -instance ToFormField String y where - toFormField = stringField -instance ToFormField (Maybe String) 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 #-}+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
Yesod/Form/Core.hs view
@@ -1,370 +1,376 @@-{-# 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) - --- | 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 [String] - | 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 = [(String, String)] -type FileEnv = [(String, FileInfo)] - --- | Get a unique identifier. -newFormIdent :: Monad m => StateT Ints m String -newFormIdent = do - i <- get - let i' = incrInts i - put i' - return $ '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 = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = mkWidget theId name val True - , fiErrors = case res of - FormFailure [x] -> Just $ string 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 = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = mkWidget theId name val False - , fiErrors = case res of - FormFailure x -> Just $ string $ 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 :: String - , fiInput :: GWidget sub y () - , fiErrors :: Maybe Html - , fiRequired :: Bool - } - -data FormFieldSettings = FormFieldSettings - { ffsLabel :: String - , ffsTooltip :: Html - , ffsId :: Maybe String - , ffsName :: Maybe String - } -instance IsString FormFieldSettings where - fromString s = FormFieldSettings 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 :: String -> Either String a - , fpRender :: a -> String - -- | ID, name, value, required - , fpWidget :: String -> String -> String -> 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 String 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 -> string 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 +{-# 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,506 +1,509 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} -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) - -#if __GLASGOW_HASKELL__ >= 700 -#define HAMLET hamlet -#else -#define HAMLET $hamlet -#endif - -stringField :: (IsForm f, FormType f ~ String) - => FormFieldSettings -> Maybe String -> f -stringField = requiredFieldHelper stringFieldProfile - -maybeStringField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> f -maybeStringField = optionalFieldHelper stringFieldProfile - -passwordField :: (IsForm f, FormType f ~ String) - => FormFieldSettings -> Maybe String -> f -passwordField = requiredFieldHelper passwordFieldProfile - -maybePasswordField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> f -maybePasswordField = optionalFieldHelper passwordFieldProfile - -intInput :: Integral i => String -> FormInput sub master i -intInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper intFieldProfile (nameSettings n) Nothing - -maybeIntInput :: Integral i => String -> 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 = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = [HAMLET| -<input id="#{theId}" type="checkbox" name="#{name}" :val:checked=""> -|] - , fiErrors = case res of - FormFailure [x] -> Just $ string 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, String)] - -> 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 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 = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = input - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = True - } - return (res, fi, UrlEncoded) - -maybeSelectField :: (Eq x, IsForm f, Maybe x ~ FormType f) - => [(x, String)] - -> 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 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 = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = input - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = False - } - return (res, fi, UrlEncoded) - -stringInput :: String -> FormInput sub master String -stringInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper stringFieldProfile (nameSettings n) Nothing - -maybeStringInput :: String -> FormInput sub master (Maybe String) -maybeStringInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper stringFieldProfile (nameSettings n) Nothing - -boolInput :: String -> 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 :: String -> FormInput sub master Day -dayInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper dayFieldProfile (nameSettings n) Nothing - -maybeDayInput :: String -> FormInput sub master (Maybe Day) -maybeDayInput n = - mapFormXml fieldsToInput $ - optionalFieldHelper dayFieldProfile (nameSettings n) Nothing - -nameSettings :: String -> FormFieldSettings -nameSettings n = FormFieldSettings mempty mempty (Just n) (Just n) - -urlField :: (IsForm f, FormType f ~ String) - => FormFieldSettings -> Maybe String -> f -urlField = requiredFieldHelper urlFieldProfile - -maybeUrlField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> f -maybeUrlField = optionalFieldHelper urlFieldProfile - -urlInput :: String -> FormInput sub master String -urlInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper urlFieldProfile (nameSettings n) Nothing - -emailField :: (IsForm f, FormType f ~ String) - => FormFieldSettings -> Maybe String -> f -emailField = requiredFieldHelper emailFieldProfile - -maybeEmailField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> f -maybeEmailField = optionalFieldHelper emailFieldProfile - -emailInput :: String -> FormInput sub master String -emailInput n = - mapFormXml fieldsToInput $ - requiredFieldHelper emailFieldProfile (nameSettings n) Nothing - -searchField :: (IsForm f, FormType f ~ String) - => AutoFocus -> FormFieldSettings -> Maybe String -> f -searchField = requiredFieldHelper . searchFieldProfile - -maybeSearchField :: (IsForm f, FormType f ~ Maybe String) - => AutoFocus -> FormFieldSettings -> Maybe (Maybe String) -> 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 ~ String) - => FormFieldSettings -> Maybe String -> f -hiddenField = requiredFieldHelper hiddenFieldProfile - -maybeHiddenField :: (IsForm f, FormType f ~ Maybe String) - => FormFieldSettings -> Maybe (Maybe String) -> 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 = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = fileWidget theId name True - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = True - } - let res' = case res of - FormFailure [e] -> FormFailure [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 = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = fileWidget theId name False - , fiErrors = Nothing - , fiRequired = True - } - return (res, fi, Multipart) - -fileWidget :: String -> String -> 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, String)] - -> 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 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 = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = input - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = True - } - return (res, fi, UrlEncoded) - -maybeRadioField - :: (Eq x, IsForm f, FormType f ~ Maybe x) - => [(x, String)] - -> 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 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 = string label - , fiTooltip = tooltip - , fiIdent = theId - , fiInput = input - , fiErrors = case res of - FormFailure [x] -> Just $ string x - _ -> Nothing - , fiRequired = False - } - return (res, fi, UrlEncoded) +{-# 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)
Yesod/Form/Jquery.hs view
@@ -1,237 +1,241 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} --- | 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) - -#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 :: String -> String -googleHostedJqueryUiCss theme = concat - [ "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) String - 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) String - 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) String - urlJqueryUiCss _ = Right $ googleHostedJqueryUiCss "cupertino" - - -- | jQuery UI time picker add-on. - urlJqueryUiDateTimePicker :: a -> Either (Route a) String - 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 - , fpRender = 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" - jsBool False = "false" - 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 - , fpRender = 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 String 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 ~ String, YesodJquery (FormMaster f)) - => Route (FormMaster f) - -> FormFieldSettings - -> Maybe (FormType f) - -> f -jqueryAutocompleteField = requiredFieldHelper . jqueryAutocompleteFieldProfile - -maybeJqueryAutocompleteField - :: (IsForm f, FormType f ~ Maybe String, YesodJquery (FormMaster f)) - => Route (FormMaster f) - -> FormFieldSettings - -> Maybe (FormType f) - -> f -maybeJqueryAutocompleteField src = - optionalFieldHelper $ jqueryAutocompleteFieldProfile src - -jqueryAutocompleteFieldProfile :: YesodJquery y => Route y -> FieldProfile sub y String -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) String) -> GWidget sub y () -addScript' f = do - y <- lift getYesod - addScriptEither $ f y - -addStylesheet' :: (y -> Either (Route y) String) -> 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 #-}+-- | 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+ }
Yesod/Form/Nic.hs view
@@ -1,63 +1,65 @@-{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} --- | 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) - -class YesodNic a where - -- | NIC Editor Javascript file. - urlNicEdit :: a -> Either (Route a) String - 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 - , fpRender = 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) String) -> GWidget sub y () -addScript' f = do - y <- lift getYesod - addScriptEither $ f y +{-# 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
Yesod/Form/Profiles.hs view
@@ -1,249 +1,251 @@-{-# 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 - -#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 - , fpRender = 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 - , fpRender = 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 - , fpRender = 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 - , fpRender = 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 - , fpRender = 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 :: String } - deriving (Show, Read, Eq, PersistField) -instance ToHtml Textarea where - toHtml = - unsafeByteString - . S.concat - . L.toChunks - . toLazyByteString - . fromWriteList writeHtmlEscapedChar - . 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 String -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 String -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 String -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 String 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 String 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 [Char] TimeOfDay -parseTimeHelper (h1, h2, m1, m2, s1, s2) - | h < 0 || h > 23 = Left $ "Invalid hour: " ++ show h - | m < 0 || m > 59 = Left $ "Invalid minute: " ++ show m - | s < 0 || s > 59 = Left $ "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 String -emailFieldProfile = FieldProfile - { fpParse = \s -> if Email.isValid 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 String -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 String -urlFieldProfile = FieldProfile - { fpParse = \s -> case parseURI 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}"> -|] - } +{-# 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/Helpers/Crud.hs view
@@ -1,209 +1,202 @@-{-# 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 -import Yesod.Core -import Yesod.Widget -import Yesod.Dispatch -import Yesod.Content -import Yesod.Handler -import Text.Hamlet -import Yesod.Form -import Language.Haskell.TH.Syntax -import Yesod.Persist --- | 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 -> String - --- | 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 ''Yesod [VarT $ mkName "master"] - , 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/#String CrudEditR GET POST -/delete/#String 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) - => String -> GHandler (Crud master item) master RepHtml -getCrudEditR s = do - itemId <- maybe notFound return $ itemReadId 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) - => String -> GHandler (Crud master item) master RepHtml -postCrudEditR s = do - itemId <- maybe notFound return $ itemReadId 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)) - => String -> GHandler (Crud master item) master RepHtml -getCrudDeleteR s = do - itemId <- maybe notFound return $ itemReadId 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)) - => String -> GHandler (Crud master item) master RepHtml -postCrudDeleteR s = do - itemId <- maybe notFound return $ itemReadId s - crud <- getYesodSub - toMaster <- getRouteToMaster - crudDelete crud itemId - redirect RedirectTemporary $ toMaster CrudListR - -itemReadId :: SinglePiece x => String -> Maybe x -itemReadId = either (const Nothing) Just . fromSinglePiece - -crudHelper - :: (Item a, Yesod master, SinglePiece (Key a), ToForm a master) - => String -> 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 $ string 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 - } +{-# 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)++-- | 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,42 +1,43 @@-name: yesod-form -version: 0.0.0.2 -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://docs.yesodweb.com/ - -library - build-depends: base >= 4 && < 5 - , yesod-core >= 0.7 && < 0.8 - , time >= 1.1.4 && < 1.3 - , hamlet >= 0.7 && < 0.8 - , yesod-persistent >= 0.0.0 && < 0.0.1 - , persistent >= 0.4 && < 0.5 - , 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.3 - , network >= 2.2 && < 2.4 - , email-validate >= 0.2.6 && < 0.3 - , blaze-html >= 0.4 && < 0.5 - , bytestring >= 0.9 && < 0.10 - 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.1.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 && < 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+ 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