module Yesod.Form
(
GForm
, FormResult (..)
, Enctype (..)
, FormFieldSettings (..)
, Textarea (..)
, FieldInfo (..)
, formFailures
, Form
, Formlet
, FormField
, FormletField
, FormInput
, generateForm
, runFormGet
, runFormMonadGet
, runFormPost
, runFormPostNoNonce
, runFormMonadPost
, runFormGet'
, runFormPost'
, 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 Text.Hamlet
import Yesod.Request
import Yesod.Handler
import Control.Applicative hiding (optional)
import Data.Maybe (fromMaybe, mapMaybe)
import "transformers" Control.Monad.IO.Class
import Control.Monad ((<=<))
import Language.Haskell.TH.Syntax
import Database.Persist.Base (EntityDef (..), PersistEntity (entityDef))
import Data.Char (toUpper, isUpper)
import Control.Arrow ((&&&))
import Data.List (group, sort)
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$
.tooltip $fiTooltip.fi$
%td
^fiInput.fi^
$maybe fiErrors.fi err
%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|
.$clazz.fi$
%label!for=$fiIdent.fi$ $fiLabel.fi$
.tooltip $fiTooltip.fi$
^fiInput.fi^
$maybe fiErrors.fi err
%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
rr <- getRequest
(pp, files) <- liftIO $ reqRequestBody rr
runFormGeneric pp files f
runFormPost :: GForm s m xml a -> GHandler s m (FormResult a, xml, Enctype, Html)
runFormPost f = do
rr <- getRequest
(pp, files) <- liftIO $ reqRequestBody rr
nonce <- fmap reqNonce getRequest
(res, xml, enctype) <- runFormGeneric pp files f
let res' =
case res of
FormSuccess x ->
if lookup nonceName pp == Just 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, 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
rr <- getRequest
(pp, files) <- liftIO $ reqRequestBody rr
runFormGeneric pp files f
runFormPost' :: GForm sub y xml a -> GHandler sub y a
runFormPost' f = do
rr <- getRequest
(pp, files) <- liftIO $ reqRequestBody rr
x <- runFormGeneric pp files f
helper x
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|%input!type=hidden!name=$nonceName$!value=$nonce$|])
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