Better form validation

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

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 = "<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)
+instance IsString FormMessage where
-blank _ [] = Right Nothing
+    fromString = MsgOther . fromString
-blank _ ("":_) = Right Nothing
+
-blank f (x:_) = either Left (Right . Just) $ f x
+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

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) =
+    (res, val) <-
-            case mp of
+        case mp of
-                Nothing -> (FormMissing, maybe (Left "") Right mdef)
+            Nothing -> return (FormMissing, maybe (Left "") Right mdef)
-                Just p ->
+            Just p -> do
-                    let mvals = map snd $ filter (\(n,_) -> n == name) p
+                let mvals = map snd $ filter (\(n,_) -> n == name) p
-                     in case fieldParse mvals of
+                emx <- liftIO $ fieldParse mvals
-                            Left e -> (FormFailure [renderMessage master langs e], maybe (Left "") Left (listToMaybe mvals))
+                return $ case emx of
-                            Right mx ->
+                    Left e -> (FormFailure [renderMessage master langs e], maybe (Left "") Left (listToMaybe mvals))
-                                case mx of
+                    Right mx ->
-                                    Nothing -> (onMissing master langs, Left "")
+                        case mx of
-                                    Just x -> (onFound x, Right x)
+                            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
+    }

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
+    pure = FormInput . const . const . const . return . Right
-    (FormInput f) <*> (FormInput x) = FormInput $ \c d e ->
+    (FormInput f) <*> (FormInput x) = FormInput $ \c d e -> do
-        case (f c d e, x c d e) of
+        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

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

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

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
         <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