Better form validation
This commit is contained in:
Michael Snoyman
parent
dccd17e0ac
commit
b7e76ebcd8
@ -17,6 +17,7 @@ import Data.Time (Day, TimeOfDay)
|
||||
import Data.Text (Text)
|
||||
import Yesod.Handler (GGHandler)
|
||||
import Yesod.Message (RenderMessage)
|
||||
import Control.Monad.IO.Class (MonadIO) -- FIXME
|
||||
|
||||
class ToForm a master monad where
|
||||
toForm :: AForm ([FieldView (GGWidget master monad ())] -> [FieldView (GGWidget master monad ())]) master monad a
|
||||
@ -31,44 +32,44 @@ instance ToFormField (Maybe String) y where
|
||||
toFormField = maybeStringField
|
||||
-}
|
||||
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField Text master (GGHandler sub master m) where
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField Text master (GGHandler sub master m) where
|
||||
toField = areq textField
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Text) master (GGHandler sub master m) where
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField (Maybe Text) master (GGHandler sub master m) where
|
||||
toField = aopt textField
|
||||
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField Int master (GGHandler sub master m) where
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField Int master (GGHandler sub master m) where
|
||||
toField = areq intField
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Int) master (GGHandler sub master m) where
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField (Maybe Int) master (GGHandler sub master m) where
|
||||
toField = aopt intField
|
||||
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField Int64 master (GGHandler sub master m) where
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField Int64 master (GGHandler sub master m) where
|
||||
toField = areq intField
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Int64) master (GGHandler sub master m) where
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField (Maybe Int64) master (GGHandler sub master m) where
|
||||
toField = aopt intField
|
||||
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField Double master (GGHandler sub master m) where
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField Double master (GGHandler sub master m) where
|
||||
toField = areq doubleField
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Double) master (GGHandler sub master m) where
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField (Maybe Double) master (GGHandler sub master m) where
|
||||
toField = aopt doubleField
|
||||
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField Day master (GGHandler sub master m) where
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField Day master (GGHandler sub master m) where
|
||||
toField = areq dayField
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Day) master (GGHandler sub master m) where
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField (Maybe Day) master (GGHandler sub master m) where
|
||||
toField = aopt dayField
|
||||
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField TimeOfDay master (GGHandler sub master m) where
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField TimeOfDay master (GGHandler sub master m) where
|
||||
toField = areq timeField
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe TimeOfDay) master (GGHandler sub master m) where
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField (Maybe TimeOfDay) master (GGHandler sub master m) where
|
||||
toField = aopt timeField
|
||||
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField Html master (GGHandler sub master m) where
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField Html master (GGHandler sub master m) where
|
||||
toField = areq htmlField
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Html) master (GGHandler sub master m) where
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField (Maybe Html) master (GGHandler sub master m) where
|
||||
toField = aopt htmlField
|
||||
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField Textarea master (GGHandler sub master m) where
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField Textarea master (GGHandler sub master m) where
|
||||
toField = areq textareaField
|
||||
instance (Monad m, RenderMessage master FormMessage) => ToField (Maybe Textarea) master (GGHandler sub master m) where
|
||||
instance (MonadIO m, RenderMessage master FormMessage) => ToField (Maybe Textarea) master (GGHandler sub master m) where
|
||||
toField = aopt textareaField
|
||||
|
||||
{- FIXME
|
||||
|
||||
@ -44,6 +44,7 @@ import Control.Monad (when, unless)
|
||||
import Data.List (intersect, nub)
|
||||
import Data.Either (rights)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.String (IsString (..))
|
||||
|
||||
import qualified Blaze.ByteString.Builder.Html.Utf8 as B
|
||||
import Blaze.ByteString.Builder (writeByteString, toLazyByteString)
|
||||
@ -88,6 +89,7 @@ data FormMessage = MsgInvalidInteger Text
|
||||
| MsgInvalidBool Text
|
||||
| MsgBoolYes
|
||||
| MsgBoolNo
|
||||
| MsgOther Text
|
||||
|
||||
defaultFormMessage :: FormMessage -> Text
|
||||
defaultFormMessage (MsgInvalidInteger t) = "Invalid integer: " `mappend` t
|
||||
@ -107,11 +109,15 @@ defaultFormMessage MsgSelectNone = "<None>"
|
||||
defaultFormMessage (MsgInvalidBool t) = "Invalid boolean: " `mappend` t
|
||||
defaultFormMessage MsgBoolYes = "Yes"
|
||||
defaultFormMessage MsgBoolNo = "No"
|
||||
defaultFormMessage (MsgOther t) = t
|
||||
|
||||
blank :: (Text -> Either msg a) -> [Text] -> Either msg (Maybe a)
|
||||
blank _ [] = Right Nothing
|
||||
blank _ ("":_) = Right Nothing
|
||||
blank f (x:_) = either Left (Right . Just) $ f x
|
||||
instance IsString FormMessage where
|
||||
fromString = MsgOther . fromString
|
||||
|
||||
blank :: (Text -> Either msg a) -> [Text] -> IO (Either msg (Maybe a))
|
||||
blank _ [] = return $ Right Nothing
|
||||
blank _ ("":_) = return $ Right Nothing
|
||||
blank f (x:_) = return $ either Left (Right . Just) $ f x
|
||||
|
||||
|
||||
|
||||
@ -340,7 +346,7 @@ radioField = selectFieldHelper
|
||||
|
||||
boolField :: (Monad monad, RenderMessage master FormMessage) => Field (GGWidget master (GGHandler sub master monad) ()) FormMessage Bool
|
||||
boolField = Field
|
||||
{ fieldParse = boolParser
|
||||
{ fieldParse = return . boolParser
|
||||
, fieldView = \theId name val isReq -> [WHAMLET|
|
||||
$if not isReq
|
||||
<input id=#{theId}-none type=radio name=#{name} value=none checked>
|
||||
@ -369,7 +375,7 @@ multiSelectFieldHelper :: (Show a, Eq a, Monad monad)
|
||||
-> (Text -> Text -> Text -> Bool -> Text -> GGWidget master monad ())
|
||||
-> [(Text, a)] -> Field (GGWidget master monad ()) FormMessage [a]
|
||||
multiSelectFieldHelper outside inside opts = Field
|
||||
{ fieldParse = selectParser
|
||||
{ fieldParse = return . selectParser
|
||||
, fieldView = \theId name vals _ ->
|
||||
outside theId name $ do
|
||||
flip mapM_ pairs $ \pair -> inside
|
||||
@ -393,7 +399,7 @@ selectFieldHelper :: (Eq a, Monad monad)
|
||||
-> (Text -> Text -> Text -> Bool -> Text -> GGWidget master monad ())
|
||||
-> [(Text, a)] -> Field (GGWidget master monad ()) FormMessage a
|
||||
selectFieldHelper outside onOpt inside opts = Field
|
||||
{ fieldParse = selectParser
|
||||
{ fieldParse = return . selectParser
|
||||
, fieldView = \theId name val isReq ->
|
||||
outside theId name $ do
|
||||
unless isReq $ onOpt theId name $ not $ (render val) `elem` map (pack . show . fst) pairs
|
||||
|
||||
@ -24,6 +24,10 @@ module Yesod.Form.Functions
|
||||
, FormRender
|
||||
, renderTable
|
||||
, renderDivs
|
||||
-- * Validation
|
||||
, check
|
||||
, checkBool
|
||||
, checkM
|
||||
) where
|
||||
|
||||
import Yesod.Form.Types
|
||||
@ -42,6 +46,7 @@ import Text.Hamlet (html)
|
||||
import Data.Monoid (mempty)
|
||||
import Data.Maybe (listToMaybe)
|
||||
import Yesod.Message (RenderMessage (..))
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO) -- FIXME
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
#define WHAMLET whamlet
|
||||
@ -86,17 +91,17 @@ askFiles = do
|
||||
(x, _, _) <- ask
|
||||
return $ liftM snd x
|
||||
|
||||
mreq :: (Monad m, RenderMessage master msg, RenderMessage master msg2, RenderMessage master FormMessage)
|
||||
mreq :: (MonadIO m, RenderMessage master msg, RenderMessage master msg2, RenderMessage master FormMessage)
|
||||
=> Field xml msg a -> FieldSettings msg2 -> Maybe a
|
||||
-> Form master (GGHandler sub master m) (FormResult a, FieldView xml)
|
||||
mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True
|
||||
|
||||
mopt :: (Monad m, RenderMessage master msg, RenderMessage master msg2)
|
||||
mopt :: (MonadIO m, RenderMessage master msg, RenderMessage master msg2)
|
||||
=> Field xml msg a -> FieldSettings msg2 -> Maybe (Maybe a)
|
||||
-> Form master (GGHandler sub master m) (FormResult (Maybe a), FieldView xml)
|
||||
mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False
|
||||
|
||||
mhelper :: (Monad m, RenderMessage master msg, RenderMessage master msg2)
|
||||
mhelper :: (MonadIO m, RenderMessage master msg, RenderMessage master msg2)
|
||||
=> Field xml msg a
|
||||
-> FieldSettings msg2
|
||||
-> Maybe a
|
||||
@ -111,17 +116,18 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
|
||||
theId <- lift $ maybe (liftM pack newIdent) return fsId
|
||||
(_, master, langs) <- ask
|
||||
let mr2 = renderMessage master langs
|
||||
let (res, val) =
|
||||
case mp of
|
||||
Nothing -> (FormMissing, maybe (Left "") Right mdef)
|
||||
Just p ->
|
||||
let mvals = map snd $ filter (\(n,_) -> n == name) p
|
||||
in case fieldParse mvals of
|
||||
Left 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)
|
||||
(res, val) <-
|
||||
case mp of
|
||||
Nothing -> return (FormMissing, maybe (Left "") Right mdef)
|
||||
Just p -> do
|
||||
let mvals = map snd $ filter (\(n,_) -> n == name) p
|
||||
emx <- liftIO $ fieldParse mvals
|
||||
return $ case emx of
|
||||
Left 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
|
||||
@ -134,12 +140,12 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
|
||||
, fvRequired = isReq
|
||||
})
|
||||
|
||||
areq :: (Monad m, RenderMessage master msg1, RenderMessage master msg2, RenderMessage master FormMessage)
|
||||
areq :: (MonadIO m, RenderMessage master msg1, RenderMessage master msg2, RenderMessage master FormMessage)
|
||||
=> Field xml msg1 a -> FieldSettings msg2 -> Maybe a
|
||||
-> AForm ([FieldView xml] -> [FieldView xml]) master (GGHandler sub master m) a
|
||||
areq a b = formToAForm . mreq a b
|
||||
|
||||
aopt :: (Monad m, RenderMessage master msg1, RenderMessage master msg2)
|
||||
aopt :: (MonadIO m, RenderMessage master msg1, RenderMessage master msg2)
|
||||
=> Field xml msg1 a -> FieldSettings msg2 -> Maybe (Maybe a)
|
||||
-> AForm ([FieldView xml] -> [FieldView xml]) master (GGHandler sub master m) (Maybe a)
|
||||
aopt a b = formToAForm . mopt a b
|
||||
@ -241,3 +247,20 @@ $forall view <- views
|
||||
<div .errors>#{err}
|
||||
|]
|
||||
return (res, widget)
|
||||
|
||||
check :: (a -> Either msg a) -> Field xml msg a -> Field xml msg a
|
||||
check f = checkM $ return . f
|
||||
|
||||
-- | Return the given error message if the predicate is false.
|
||||
checkBool :: (a -> Bool) -> msg -> Field xml msg a -> Field xml msg a
|
||||
checkBool b s = check $ \x -> if b x then Right x else Left s
|
||||
|
||||
checkM :: (a -> IO (Either msg a)) -> Field xml msg a -> Field xml msg a
|
||||
checkM f field = field
|
||||
{ fieldParse = \ts -> do
|
||||
e1 <- fieldParse field ts
|
||||
case e1 of
|
||||
Left msg -> return $ Left msg
|
||||
Right Nothing -> return $ Right Nothing
|
||||
Right (Just a) -> fmap (either Left (Right . Just)) $ f a
|
||||
}
|
||||
|
||||
@ -17,41 +17,47 @@ import Yesod.Request (reqGetParams, languages)
|
||||
import Control.Monad (liftM)
|
||||
import Yesod.Widget (GWidget)
|
||||
import Yesod.Message (RenderMessage (..))
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO) -- FIXME
|
||||
|
||||
type DText = [Text] -> [Text]
|
||||
newtype FormInput master a = FormInput { unFormInput :: master -> [Text] -> Env -> Either DText a }
|
||||
newtype FormInput master a = FormInput { unFormInput :: master -> [Text] -> Env -> IO (Either DText a) }
|
||||
instance Functor (FormInput master) where
|
||||
fmap a (FormInput f) = FormInput $ \c d e -> either Left (Right . a) $ f c d e
|
||||
fmap a (FormInput f) = FormInput $ \c d e -> fmap (either Left (Right . a)) $ f c d e
|
||||
instance Applicative (FormInput master) where
|
||||
pure = FormInput . const . const . const . Right
|
||||
(FormInput f) <*> (FormInput x) = FormInput $ \c d e ->
|
||||
case (f c d e, x c d e) of
|
||||
pure = FormInput . const . const . const . return . Right
|
||||
(FormInput f) <*> (FormInput x) = FormInput $ \c d e -> do
|
||||
res1 <- f c d e
|
||||
res2 <- x c d e
|
||||
return $ case (res1, res2) of
|
||||
(Left a, Left b) -> Left $ a . b
|
||||
(Left a, _) -> Left a
|
||||
(_, Left b) -> Left b
|
||||
(Right a, Right b) -> Right $ a b
|
||||
|
||||
ireq :: (RenderMessage master msg, RenderMessage master FormMessage) => Field (GWidget sub master ()) msg a -> Text -> FormInput master a
|
||||
ireq field name = FormInput $ \m l env ->
|
||||
ireq field name = FormInput $ \m l env -> do
|
||||
let filteredEnv = map snd $ filter (\y -> fst y == name) env
|
||||
in case fieldParse field $ filteredEnv of
|
||||
emx <- fieldParse field $ filteredEnv
|
||||
return $ case emx of
|
||||
Left e -> Left $ (:) $ renderMessage m l e
|
||||
Right Nothing -> Left $ (:) $ renderMessage m l $ MsgInputNotFound name
|
||||
Right (Just a) -> Right a
|
||||
|
||||
iopt :: RenderMessage master msg => Field (GWidget sub master ()) msg a -> Text -> FormInput master (Maybe a)
|
||||
iopt field name = FormInput $ \m l env ->
|
||||
iopt field name = FormInput $ \m l env -> do
|
||||
let filteredEnv = map snd $ filter (\y -> fst y == name) env
|
||||
in case fieldParse field $ filteredEnv of
|
||||
emx <- fieldParse field $ filteredEnv
|
||||
return $ case emx of
|
||||
Left e -> Left $ (:) $ renderMessage m l e
|
||||
Right x -> Right x
|
||||
|
||||
runInputGet :: Monad monad => FormInput master a -> GGHandler sub master monad a
|
||||
runInputGet :: MonadIO monad => FormInput master a -> GGHandler sub master monad a
|
||||
runInputGet (FormInput f) = do
|
||||
env <- liftM reqGetParams getRequest
|
||||
m <- getYesod
|
||||
l <- languages
|
||||
case f m l env of
|
||||
emx <- liftIO $ f m l env
|
||||
case emx of
|
||||
Left errs -> invalidArgs $ errs []
|
||||
Right x -> return x
|
||||
|
||||
@ -60,6 +66,7 @@ runInputPost (FormInput f) = do
|
||||
env <- liftM fst runRequestBody
|
||||
m <- getYesod
|
||||
l <- languages
|
||||
case f m l env of
|
||||
emx <- liftIO $ f m l env
|
||||
case emx of
|
||||
Left errs -> invalidArgs $ errs []
|
||||
Right x -> return x
|
||||
|
||||
@ -24,6 +24,7 @@ import Data.Text.Read (decimal)
|
||||
import Control.Monad (liftM)
|
||||
import Data.Either (partitionEithers)
|
||||
import Data.Traversable (sequenceA)
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 700
|
||||
#define WHAMLET whamlet
|
||||
@ -49,7 +50,7 @@ up i = do
|
||||
IntCons _ is' -> put is' >> newFormIdent >> return ()
|
||||
up $ i - 1
|
||||
|
||||
inputList :: (Monad mo, m ~ GGHandler sub master mo, xml ~ GGWidget master (GGHandler sub master mo) (), RenderMessage master FormMessage)
|
||||
inputList :: (MonadIO mo, m ~ GGHandler sub master mo, xml ~ GGWidget master (GGHandler sub master mo) (), RenderMessage master FormMessage)
|
||||
=> Html
|
||||
-> ([[FieldView xml]] -> xml)
|
||||
-> (Maybe a -> AForm ([FieldView xml] -> [FieldView xml]) master m a)
|
||||
@ -92,7 +93,7 @@ inputList label fixXml single mdef = formToAForm $ do
|
||||
, fvRequired = False
|
||||
})
|
||||
|
||||
withDelete :: (xml ~ GGWidget master m (), m ~ GGHandler sub master mo, Monad mo, RenderMessage master FormMessage)
|
||||
withDelete :: (MonadIO mo, xml ~ GGWidget master m (), m ~ GGHandler sub master mo, Monad mo, RenderMessage master FormMessage)
|
||||
=> AForm ([FieldView xml] -> [FieldView xml]) master m a
|
||||
-> Form master m (Either xml (FormResult a, [FieldView xml]))
|
||||
withDelete af = do
|
||||
|
||||
@ -114,7 +114,7 @@ data FieldView xml = FieldView
|
||||
}
|
||||
|
||||
data Field xml msg a = Field
|
||||
{ fieldParse :: [Text] -> Either msg (Maybe a)
|
||||
{ fieldParse :: [Text] -> IO (Either msg (Maybe a)) -- FIXME
|
||||
-- | ID, name, (invalid text OR legimiate result), required?
|
||||
, fieldView :: Text
|
||||
-> Text
|
||||
|
||||
@ -6,6 +6,8 @@ import Yesod.Form.MassInput
|
||||
import Control.Applicative
|
||||
import Data.Text (Text, pack)
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
import Data.Time (utctDay, getCurrentTime)
|
||||
import qualified Data.Text as T
|
||||
|
||||
data Fruit = Apple | Banana | Pear
|
||||
deriving (Show, Enum, Bounded, Eq)
|
||||
@ -39,6 +41,7 @@ instance Yesod HelloForms where
|
||||
mkYesod "HelloForms" [parseRoutes|
|
||||
/ RootR GET
|
||||
/mass MassR GET
|
||||
/valid ValidR GET
|
||||
|]
|
||||
|
||||
getRootR = do
|
||||
@ -51,6 +54,8 @@ getRootR = do
|
||||
<input type=submit>
|
||||
<p>
|
||||
<a href=@{MassR}>See the mass form
|
||||
<p>
|
||||
<a href=@{ValidR}>Validation form
|
||||
|]
|
||||
|
||||
myMassForm = fixType $ runFormGet $ renderTable $ inputList "People" massTable
|
||||
@ -71,4 +76,26 @@ getMassR = do
|
||||
<a href=@{RootR}>See the regular form
|
||||
|]
|
||||
|
||||
myValidForm = fixType $ runFormGet $ renderTable $ pure (,,)
|
||||
<*> areq (check (\x -> if T.length x < 3 then Left "Need at least 3 letters" else Right x) textField) "Name" Nothing
|
||||
<*> areq (checkBool (>= 18) "Must be 18 or older" intField) "Age" Nothing
|
||||
<*> areq (checkM inPast dayField) "Anniversary" Nothing
|
||||
where
|
||||
inPast x = do
|
||||
now <- getCurrentTime
|
||||
return $ if utctDay now < x then Left "Need a date in the past" else Right x
|
||||
|
||||
getValidR = do
|
||||
((res, form), enctype) <- myValidForm
|
||||
defaultLayout [whamlet|
|
||||
<p>Result: #{show res}
|
||||
<form enctype=#{enctype}>
|
||||
<table>
|
||||
^{form}
|
||||
<div>
|
||||
<input type=submit>
|
||||
<p>
|
||||
<a href=@{RootR}>See the regular form
|
||||
|]
|
||||
|
||||
main = toWaiApp HelloForms >>= run 3000
|
||||
|
||||
Loading…
Reference in New Issue
Block a user