module Yesod.Form.Functions
(
newFormIdent
, askParams
, askFiles
, formToAForm
, aFormToForm
, mreq
, mopt
, areq
, aopt
, runFormPost
, runFormPostNoToken
, runFormGet
, generateFormPost
, generateFormGet
, FormRender
, renderTable
, renderDivs
, renderDivsNoLabels
, renderBootstrap
, check
, checkBool
, checkM
, checkMMap
, checkMMod
, customErrorMessage
, fieldSettingsLabel
, aformM
, parseHelper
) where
import Yesod.Form.Types
import Data.Text (Text, pack)
import Control.Arrow (second)
import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)
import Control.Monad.Trans.Class (lift)
import Control.Monad (liftM, join)
import Crypto.Classes (constTimeEq)
import Text.Blaze (Markup, toMarkup)
#define Html Markup
#define toHtml toMarkup
import Yesod.Handler (GHandler, getRequest, runRequestBody, newIdent, getYesod)
import Yesod.Core (RenderMessage, SomeMessage (..))
import Yesod.Widget (GWidget, whamlet)
import Yesod.Request (reqToken, reqWaiRequest, reqGetParams, languages)
import Network.Wai (requestMethod)
import Text.Hamlet (shamlet)
import Data.Monoid (mempty)
import Data.Maybe (listToMaybe, fromMaybe)
import Yesod.Message (RenderMessage (..))
import qualified Data.Map as Map
import qualified Data.Text.Encoding as TE
import Control.Applicative ((<$>))
import Control.Arrow (first)
import Yesod.Request (FileInfo)
newFormIdent :: MForm sub master Text
newFormIdent = do
i <- get
let i' = incrInts i
put i'
return $ pack $ 'f' : show i'
where
incrInts (IntSingle i) = IntSingle $ i + 1
incrInts (IntCons i is) = (i + 1) `IntCons` is
formToAForm :: MForm sub master (FormResult a, [FieldView sub master]) -> AForm sub master a
formToAForm form = AForm $ \(master, langs) env ints -> do
((a, xmls), ints', enc) <- runRWST form (env, master, langs) ints
return (a, (++) xmls, ints', enc)
aFormToForm :: AForm sub master a -> MForm sub master (FormResult a, [FieldView sub master] -> [FieldView sub master])
aFormToForm (AForm aform) = do
ints <- get
(env, master, langs) <- ask
(a, xml, ints', enc) <- lift $ aform (master, langs) env ints
put ints'
tell enc
return (a, xml)
askParams :: MForm sub master (Maybe Env)
askParams = do
(x, _, _) <- ask
return $ liftM fst x
askFiles :: MForm sub master (Maybe FileEnv)
askFiles = do
(x, _, _) <- ask
return $ liftM snd x
mreq :: RenderMessage master FormMessage
=> Field sub master a -> FieldSettings master -> Maybe a
-> MForm sub master (FormResult a, FieldView sub master)
mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True
mopt :: Field sub master a -> FieldSettings master -> Maybe (Maybe a)
-> MForm sub master (FormResult (Maybe a), FieldView sub master)
mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False
mhelper :: Field sub master a
-> FieldSettings master
-> Maybe a
-> (master -> [Text] -> FormResult b)
-> (a -> FormResult b)
-> Bool
-> MForm sub master (FormResult b, FieldView sub master)
mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
tell fieldEnctype
mp <- askParams
name <- maybe newFormIdent return fsName
theId <- lift $ maybe newIdent return fsId
(_, master, langs) <- ask
let mr2 = renderMessage master langs
(res, val) <-
case mp of
Nothing -> return (FormMissing, maybe (Left "") Right mdef)
Just p -> do
mfs <- askFiles
let mvals = fromMaybe [] $ Map.lookup name p
files = fromMaybe [] $ mfs >>= Map.lookup name
emx <- lift $ fieldParse mvals files
return $ case emx of
Left (SomeMessage e) -> (FormFailure [renderMessage master langs e], maybe (Left "") Left (listToMaybe mvals))
Right mx ->
case mx of
Nothing -> (onMissing master langs, Left "")
Just x -> (onFound x, Right x)
return (res, FieldView
{ fvLabel = toHtml $ mr2 fsLabel
, fvTooltip = fmap toHtml $ fmap mr2 fsTooltip
, fvId = theId
, fvInput = fieldView theId name fsAttrs val isReq
, fvErrors =
case res of
FormFailure [e] -> Just $ toHtml e
_ -> Nothing
, fvRequired = isReq
})
areq :: RenderMessage master FormMessage
=> Field sub master a -> FieldSettings master -> Maybe a
-> AForm sub master a
areq a b = formToAForm . fmap (second return) . mreq a b
aopt :: Field sub master a
-> FieldSettings master
-> Maybe (Maybe a)
-> AForm sub master (Maybe a)
aopt a b = formToAForm . fmap (second return) . mopt a b
runFormGeneric :: MForm sub master a -> master -> [Text] -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype)
runFormGeneric form master langs env = evalRWST form (env, master, langs) (IntSingle 1)
runFormPost :: RenderMessage master FormMessage
=> (Html -> MForm sub master (FormResult a, xml))
-> GHandler sub master ((FormResult a, xml), Enctype)
runFormPost form = do
env <- postEnv
postHelper form env
postHelper :: RenderMessage master FormMessage
=> (Html -> MForm sub master (FormResult a, xml))
-> Maybe (Env, FileEnv)
-> GHandler sub master ((FormResult a, xml), Enctype)
postHelper form env = do
req <- getRequest
let tokenKey = "_token"
let token =
case reqToken req of
Nothing -> mempty
Just n -> [shamlet|
$newline never
<input type=hidden name=#{tokenKey} value=#{n}>
|]
m <- getYesod
langs <- languages
((res, xml), enctype) <- runFormGeneric (form token) m langs env
let res' =
case (res, env) of
(FormSuccess{}, Just (params, _))
| not (Map.lookup tokenKey params === reqToken req) ->
FormFailure [renderMessage m langs MsgCsrfWarning]
_ -> res
where (Just [t1]) === (Just t2) = TE.encodeUtf8 t1 `constTimeEq` TE.encodeUtf8 t2
Nothing === Nothing = True
_ === _ = False
return ((res', xml), enctype)
generateFormPost
:: RenderMessage master FormMessage
=> (Html -> MForm sub master (FormResult a, xml))
-> GHandler sub master (xml, Enctype)
generateFormPost form = first snd <$> postHelper form Nothing
postEnv :: GHandler sub master (Maybe (Env, FileEnv))
postEnv = do
req <- getRequest
if requestMethod (reqWaiRequest req) == "GET"
then return Nothing
else do
(p, f) <- runRequestBody
let p' = Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) p
return $ Just (p', Map.unionsWith (++) $ map (\(k, v) -> Map.singleton k [v]) f)
runFormPostNoToken :: (Html -> MForm sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype)
runFormPostNoToken form = do
langs <- languages
m <- getYesod
env <- postEnv
runFormGeneric (form mempty) m langs env
runFormGet :: (Html -> MForm sub master a) -> GHandler sub master (a, Enctype)
runFormGet form = do
gets <- liftM reqGetParams getRequest
let env =
case lookup getKey gets of
Nothing -> Nothing
Just _ -> Just (Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) gets, Map.empty)
getHelper form env
generateFormGet :: (Html -> MForm sub master a) -> GHandler sub master (a, Enctype)
generateFormGet form = getHelper form Nothing
getKey :: Text
getKey = "_hasdata"
getHelper :: (Html -> MForm sub master a) -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype)
getHelper form env = do
let fragment = [shamlet|
$newline never
<input type=hidden name=#{getKey}>
|]
langs <- languages
m <- getYesod
runFormGeneric (form fragment) m langs env
type FormRender sub master a =
AForm sub master a
-> Html
-> MForm sub master (FormResult a, GWidget sub master ())
renderTable, renderDivs, renderDivsNoLabels :: FormRender sub master a
renderTable aform fragment = do
(res, views') <- aFormToForm aform
let views = views' []
let widget = [whamlet|
$newline never
\#{fragment}
$forall view <- views
<tr :fvRequired view:.required :not $ fvRequired view:.optional>
<td>
<label for=#{fvId view}>#{fvLabel view}
$maybe tt <- fvTooltip view
<div .tooltip>#{tt}
<td>^{fvInput view}
$maybe err <- fvErrors view
<td .errors>#{err}
|]
return (res, widget)
renderDivs = renderDivsMaybeLabels True
renderDivsNoLabels = renderDivsMaybeLabels False
renderDivsMaybeLabels :: Bool -> FormRender sub master a
renderDivsMaybeLabels withLabels aform fragment = do
(res, views') <- aFormToForm aform
let views = views' []
let widget = [whamlet|
$newline never
\#{fragment}
$forall view <- views
<div :fvRequired view:.required :not $ fvRequired view:.optional>
$if withLabels
<label for=#{fvId view}>#{fvLabel view}
$maybe tt <- fvTooltip view
<div .tooltip>#{tt}
^{fvInput view}
$maybe err <- fvErrors view
<div .errors>#{err}
|]
return (res, widget)
renderBootstrap :: FormRender sub master a
renderBootstrap aform fragment = do
(res, views') <- aFormToForm aform
let views = views' []
has (Just _) = True
has Nothing = False
let widget = [whamlet|
$newline never
\#{fragment}
$forall view <- views
<div .controlgroup .clearfix :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.error>
<label .controllabel for=#{fvId view}>#{fvLabel view}
<div .controls .input>
^{fvInput view}
$maybe tt <- fvTooltip view
<span .helpblock>#{tt}
$maybe err <- fvErrors view
<span .helpblock>#{err}
|]
return (res, widget)
check :: RenderMessage master msg
=> (a -> Either msg a) -> Field sub master a -> Field sub master a
check f = checkM $ return . f
checkBool :: RenderMessage master msg
=> (a -> Bool) -> msg -> Field sub master a -> Field sub master a
checkBool b s = check $ \x -> if b x then Right x else Left s
checkM :: RenderMessage master msg
=> (a -> GHandler sub master (Either msg a))
-> Field sub master a
-> Field sub master a
checkM f = checkMMap f id
checkMMap :: RenderMessage master msg
=> (a -> GHandler sub master (Either msg b))
-> (b -> a)
-> Field sub master a
-> Field sub master b
checkMMap f inv field = field
{ fieldParse = \ts fs -> do
e1 <- fieldParse field ts fs
case e1 of
Left msg -> return $ Left msg
Right Nothing -> return $ Right Nothing
Right (Just a) -> fmap (either (Left . SomeMessage) (Right . Just)) $ f a
, fieldView = \i n a eres req -> fieldView field i n a (fmap inv eres) req
}
checkMMod :: RenderMessage master msg
=> (a -> GHandler sub master (Either msg b))
-> (b -> a)
-> Field sub master a
-> Field sub master b
checkMMod = checkMMap
customErrorMessage :: SomeMessage master -> Field sub master a -> Field sub master a
customErrorMessage msg field = field { fieldParse = \ts fs -> fmap (either
(const $ Left msg) Right) $ fieldParse field ts fs }
fieldSettingsLabel :: RenderMessage master msg => msg -> FieldSettings master
fieldSettingsLabel msg = FieldSettings (SomeMessage msg) Nothing Nothing Nothing []
aformM :: GHandler sub master a -> AForm sub master a
aformM action = AForm $ \_ _ ints -> do
value <- action
return (FormSuccess value, id, ints, mempty)
parseHelper :: (Monad m, RenderMessage master FormMessage)
=> (Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage master) (Maybe a))
parseHelper _ [] _ = return $ Right Nothing
parseHelper _ ("":_) _ = return $ Right Nothing
parseHelper f (x:_) _ = return $ either (Left . SomeMessage) (Right . Just) $ f x