99 lines
2.9 KiB
Haskell
99 lines
2.9 KiB
Haskell
-- | Parse forms (and query strings).
|
|
module Yesod.Form
|
|
( Form (..)
|
|
, runFormGeneric
|
|
, runFormPost
|
|
, runFormGet
|
|
, input
|
|
, applyForm
|
|
-- * Specific checks
|
|
, required
|
|
, notEmpty
|
|
, checkDay
|
|
, checkBool
|
|
) where
|
|
|
|
import Yesod.Request
|
|
import Yesod.Handler
|
|
import Control.Applicative
|
|
import Data.Time (Day)
|
|
import Data.Convertible.Text
|
|
import Data.Attempt
|
|
import Data.Maybe (fromMaybe)
|
|
|
|
noParamNameError :: String
|
|
noParamNameError = "No param name (miscalling of Yesod.Form library)"
|
|
|
|
data Form x = Form (
|
|
(ParamName -> [ParamValue])
|
|
-> Either [(ParamName, FormError)] (Maybe ParamName, x)
|
|
)
|
|
|
|
instance Functor Form where
|
|
fmap f (Form x) = Form $ \l -> case x l of
|
|
Left errors -> Left errors
|
|
Right (pn, x') -> Right (pn, f x')
|
|
instance Applicative Form where
|
|
pure x = Form $ \_ -> Right (Nothing, x)
|
|
(Form f') <*> (Form x') = Form $ \l -> case (f' l, x' l) of
|
|
(Right (_, f), Right (_, x)) -> Right $ (Nothing, f x)
|
|
(Left e1, Left e2) -> Left $ e1 ++ e2
|
|
(Left e, _) -> Left e
|
|
(_, Left e) -> Left e
|
|
|
|
type FormError = String
|
|
|
|
runFormGeneric :: (ParamName -> [ParamValue]) -> Form x -> Handler y x
|
|
runFormGeneric params (Form f) =
|
|
case f params of
|
|
Left es -> invalidArgs es
|
|
Right (_, x) -> return x
|
|
|
|
-- | Run a form against POST parameters.
|
|
runFormPost :: Form x -> Handler y x
|
|
runFormPost f = do
|
|
rr <- getRawRequest
|
|
pp <- postParams rr
|
|
runFormGeneric pp f
|
|
|
|
-- | Run a form against GET parameters.
|
|
runFormGet :: Form x -> Handler y x
|
|
runFormGet f = do
|
|
rr <- getRawRequest
|
|
runFormGeneric (getParams rr) f
|
|
|
|
input :: ParamName -> Form [ParamValue]
|
|
input pn = Form $ \l -> Right $ (Just pn, l pn)
|
|
|
|
applyForm :: (x -> Either FormError y) -> Form x -> Form y
|
|
applyForm f (Form x') =
|
|
Form $ \l ->
|
|
case x' l of
|
|
Left e -> Left e
|
|
Right (pn, x) ->
|
|
case f x of
|
|
Left e -> Left [(fromMaybe noParamNameError pn, e)]
|
|
Right y -> Right (pn, y)
|
|
|
|
required :: Form [ParamValue] -> Form ParamValue
|
|
required = applyForm $ \pvs -> case pvs of
|
|
[x] -> Right x
|
|
[] -> Left "No value for required field"
|
|
_ -> Left "Multiple values for required field"
|
|
|
|
notEmpty :: Form ParamValue -> Form ParamValue
|
|
notEmpty = applyForm $ \pv ->
|
|
if null pv
|
|
then Left "Value required"
|
|
else Right pv
|
|
|
|
checkDay :: Form ParamValue -> Form Day
|
|
checkDay = applyForm $ attempt (const (Left "Invalid day")) Right . ca
|
|
|
|
checkBool :: Form [ParamValue] -> Form Bool
|
|
checkBool = applyForm $ \pv -> Right $ case pv of
|
|
[] -> False
|
|
[""] -> False
|
|
["false"] -> False
|
|
_ -> True
|