module Yesod.Form
(
GForm
, FormResult (..)
, Enctype (..)
, FormFieldSettings (..)
, Textarea (..)
, FieldInfo (..)
, formFailures
, Form
, Formlet
, FormField
, FormletField
, FormInput
, generateForm
, runFormGet
, runFormMonadGet
, runFormPost
, runFormPostNoNonce
, runFormMonadPost
, runFormGet'
, runFormPost'
, runFormTable
, runFormDivs
, fieldsToTable
, fieldsToDivs
, fieldsToPlain
, checkForm
, module Yesod.Form.Class
, 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
fieldsToPlain :: FormField sub y a -> Form sub y a
fieldsToPlain = mapFormXml $ mapM_ fiInput
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"
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"
runFormPostNoNonce :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype)
runFormPostNoNonce f = do
(pp, files) <- runRequestBody
runFormGeneric pp files f
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"
runFormMonadPost :: GFormMonad s m a -> GHandler s m (a, Enctype)
runFormMonadPost f = do
(pp, files) <- runRequestBody
runFormGeneric pp files f
runFormPost' :: GForm sub y xml a -> GHandler sub y a
runFormPost' f = do
(pp, files) <- runRequestBody
x <- runFormGeneric pp files f
helper x
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}">
|])
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}">
|])
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"]
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}">
|])
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
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