From b7e76ebcd825141fbb2a6034e49134a713570edd Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 2 Aug 2011 20:19:53 +0300 Subject: [PATCH] Better form validation --- yesod-form/Yesod/Form/Class.hs | 33 +++++++++--------- yesod-form/Yesod/Form/Fields.hs | 20 +++++++---- yesod-form/Yesod/Form/Functions.hs | 55 +++++++++++++++++++++--------- yesod-form/Yesod/Form/Input.hs | 31 ++++++++++------- yesod-form/Yesod/Form/MassInput.hs | 5 +-- yesod-form/Yesod/Form/Types.hs | 2 +- yesod-form/hello-forms.hs | 27 +++++++++++++++ 7 files changed, 119 insertions(+), 54 deletions(-) diff --git a/yesod-form/Yesod/Form/Class.hs b/yesod-form/Yesod/Form/Class.hs index cdac8dc7..039b3278 100644 --- a/yesod-form/Yesod/Form/Class.hs +++ b/yesod-form/Yesod/Form/Class.hs @@ -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 diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index 3e9f6bc0..ff9b5367 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -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 = "" 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 @@ -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 diff --git a/yesod-form/Yesod/Form/Functions.hs b/yesod-form/Yesod/Form/Functions.hs index 01fe8629..e2e87bfc 100644 --- a/yesod-form/Yesod/Form/Functions.hs +++ b/yesod-form/Yesod/Form/Functions.hs @@ -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
#{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 + } diff --git a/yesod-form/Yesod/Form/Input.hs b/yesod-form/Yesod/Form/Input.hs index cb3d98e5..2eb5b1eb 100644 --- a/yesod-form/Yesod/Form/Input.hs +++ b/yesod-form/Yesod/Form/Input.hs @@ -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 diff --git a/yesod-form/Yesod/Form/MassInput.hs b/yesod-form/Yesod/Form/MassInput.hs index 3d41bb09..11ccb074 100644 --- a/yesod-form/Yesod/Form/MassInput.hs +++ b/yesod-form/Yesod/Form/MassInput.hs @@ -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 diff --git a/yesod-form/Yesod/Form/Types.hs b/yesod-form/Yesod/Form/Types.hs index 5cfc8c65..37dcc062 100644 --- a/yesod-form/Yesod/Form/Types.hs +++ b/yesod-form/Yesod/Form/Types.hs @@ -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 diff --git a/yesod-form/hello-forms.hs b/yesod-form/hello-forms.hs index 1bebdf0c..c96bc9e7 100644 --- a/yesod-form/hello-forms.hs +++ b/yesod-form/hello-forms.hs @@ -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

See the mass form +

+ Validation form |] myMassForm = fixType $ runFormGet $ renderTable $ inputList "People" massTable @@ -71,4 +76,26 @@ getMassR = do 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| +

Result: #{show res} +

+ + ^{form} +