Better support for optional fields

2011-05-20 08:24:30 +03:00 · 2011-05-20 08:24:30 +03:00 · ab5bf32ea3
commit ab5bf32ea3
parent 4651ae8b69
6 changed files with 84 additions and 49 deletions
--- a/Yesod/Form/Fields.hs
+++ b/Yesod/Form/Fields.hs
@ -70,6 +70,8 @@ data FormMessage = MsgInvalidInteger Text
                 | MsgInvalidSecond Text
                 | MsgInvalidDay
                 | MsgCsrfWarning
+                 | MsgValueRequired
+                 | MsgInputNotFound Text

 defaultFormMessage :: FormMessage -> Text
 defaultFormMessage (MsgInvalidInteger t) = "Invalid integer: " `mappend` t
@ -83,10 +85,20 @@ defaultFormMessage (MsgInvalidHour t) = "Invalid hour: " `mappend` t
 defaultFormMessage (MsgInvalidMinute t) = "Invalid minute: " `mappend` t
 defaultFormMessage (MsgInvalidSecond t) = "Invalid second: " `mappend` t
 defaultFormMessage MsgCsrfWarning = "As a protection against cross-site request forgery attacks, please confirm your form submission."
+defaultFormMessage MsgValueRequired = "Value is required"
+defaultFormMessage (MsgInputNotFound t) = "Input not found: " `mappend` t
+
+blank :: (Text -> Either msg a) -> Maybe Text -> Either msg (Maybe a)
+blank _ Nothing = Right Nothing
+blank _ (Just "") = Right Nothing
+blank f (Just t) = either Left (Right . Just) $ f t

 intField :: (Monad monad, Integral i) => Field (GGWidget master monad ()) FormMessage i
 intField = Field
-    { fieldParse = \s -> maybe (Left $ MsgInvalidInteger s) Right . readMayI $ unpack s -- FIXME Data.Text.Read
+    { fieldParse = blank $ \s ->
+        case Data.Text.Read.signed Data.Text.Read.decimal s of
+            Right (a, "") -> Right a
+            _ -> Left $ MsgInvalidInteger s
    , fieldRender = pack . showI
    , fieldView = \theId name val isReq -> addHamlet
        [HAMLET|\
@ -95,13 +107,13 @@ intField = Field
    }
  where
    showI x = show (fromIntegral x :: Integer)
-    readMayI s = case reads s of
-                    (x, _):_ -> Just $ fromInteger x
-                    [] -> Nothing

 doubleField :: Monad monad => Field (GGWidget master monad ()) FormMessage Double
 doubleField = Field
-    { fieldParse = \s -> maybe (Left $ MsgInvalidNumber s) Right . readMay $ unpack s -- FIXME use Data.Text.Read
+    { fieldParse = blank $ \s ->
+        case Data.Text.Read.double s of
+            Right (a, "") -> Right a
+            _ -> Left $ MsgInvalidNumber s
    , fieldRender = pack . show
    , fieldView = \theId name val isReq -> addHamlet
        [HAMLET|\
@ -111,7 +123,7 @@ doubleField = Field

 dayField :: Monad monad => Field (GGWidget master monad ()) FormMessage Day
 dayField = Field
-    { fieldParse = parseDate . unpack
+    { fieldParse = blank $ parseDate . unpack
    , fieldRender = pack . show
    , fieldView = \theId name val isReq -> addHamlet
        [HAMLET|\
@ -121,7 +133,7 @@ dayField = Field

 timeField :: Monad monad => Field (GGWidget master monad ()) FormMessage TimeOfDay
 timeField = Field
-    { fieldParse = parseTime . unpack
+    { fieldParse = blank $ parseTime . unpack
    , fieldRender = pack . show . roundFullSeconds
    , fieldView = \theId name val isReq -> addHamlet
        [HAMLET|\
@ -136,7 +148,7 @@ timeField = Field

 htmlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Html
 htmlField = Field
-    { fieldParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize
+    { fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME make changes to xss-sanitize
    , fieldRender = pack . renderHtml
    , fieldView = \theId name val _isReq -> addHamlet
        [HAMLET|\
@ -164,7 +176,7 @@ instance ToHtml Textarea where

 textareaField :: Monad monad => Field (GGWidget master monad ()) FormMessage Textarea
 textareaField = Field
-    { fieldParse = Right . Textarea
+    { fieldParse = blank $ Right . Textarea
    , fieldRender = unTextarea
    , fieldView = \theId name val _isReq -> addHamlet
        [HAMLET|\
@ -174,7 +186,7 @@ textareaField = Field

 hiddenField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
 hiddenField = Field
-    { fieldParse = Right
+    { fieldParse = blank $ Right
    , fieldRender = id
    , fieldView = \theId name val _isReq -> addHamlet
        [HAMLET|\
@ -184,7 +196,7 @@ hiddenField = Field

 textField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
 textField = Field
-    { fieldParse = Right
+    { fieldParse = blank $ Right
    , fieldRender = id
    , fieldView = \theId name val isReq ->
        [WHAMLET|
@ -194,7 +206,7 @@ textField = Field

 passwordField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
 passwordField = Field
-    { fieldParse = Right
+    { fieldParse = blank $ Right
    , fieldRender = id
    , fieldView = \theId name val isReq -> addHamlet
        [HAMLET|\
@ -242,9 +254,10 @@ parseTimeHelper (h1, h2, m1, m2, s1, s2)

 emailField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
 emailField = Field
-    { fieldParse = \s -> if Email.isValid (unpack s)
-                        then Right s
-                        else Left $ MsgInvalidEmail s
+    { fieldParse = blank $
+        \s -> if Email.isValid (unpack s)
+                then Right s
+                else Left $ MsgInvalidEmail s
    , fieldRender = id
    , fieldView = \theId name val isReq -> addHamlet
        [HAMLET|\
@ -255,7 +268,7 @@ emailField = Field
 type AutoFocus = Bool
 searchField :: Monad monad => AutoFocus -> Field (GGWidget master monad ()) FormMessage Text
 searchField autoFocus = Field
-    { fieldParse = Right
+    { fieldParse = blank Right
    , fieldRender = id
    , fieldView = \theId name val isReq -> do
        addHtml [HAMLET|\
@ -272,9 +285,10 @@ searchField autoFocus = Field

 urlField :: Monad monad => Field (GGWidget master monad ()) FormMessage Text
 urlField = Field
-    { fieldParse = \s -> case parseURI $ unpack s of
-                        Nothing -> Left $ MsgInvalidUrl s
-                        Just _ -> Right s
+    { fieldParse = blank $ \s ->
+        case parseURI $ unpack s of
+            Nothing -> Left $ MsgInvalidUrl s
+            Just _ -> Right s
    , fieldRender = id
    , fieldView = \theId name val isReq -> addHtml
        [HAMLET|
@ -283,14 +297,19 @@ urlField = Field
    }

 selectField :: (Eq a, Monad monad) => [(Text, a)] -> Field (GGWidget master monad ()) FormMessage a
-selectField opts = Field -- FIXME won't work for optional yet
+selectField opts = Field
    { fieldParse = \s ->
-        case Data.Text.Read.decimal s of
-            Right (a, "") ->
-                case lookup a pairs of
-                    Nothing -> Left $ MsgInvalidEntry s
-                    Just x -> Right $ snd x
-            _ -> Left $ MsgInvalidNumber s
+        case s of
+            Nothing -> Right Nothing
+            Just "" -> Right Nothing
+            Just "none" -> Right Nothing
+            Just x ->
+                case Data.Text.Read.decimal x of
+                    Right (a, "") ->
+                        case lookup a pairs of
+                            Nothing -> Left $ MsgInvalidEntry x
+                            Just y -> Right $ Just $ snd y
+                    _ -> Left $ MsgInvalidNumber x
    , fieldRender = \a -> maybe "" (pack . show) $ lookup a rpairs
    , fieldView = \theId name val isReq -> [WHAMLET|
 <select id=#{theId} name=#{name}
--- a/Yesod/Form/Functions.hs
+++ b/Yesod/Form/Functions.hs
@ -27,7 +27,7 @@ module Yesod.Form.Functions
    ) where

 import Yesod.Form.Types
-import Yesod.Form.Fields (FormMessage (MsgCsrfWarning))
+import Yesod.Form.Fields (FormMessage (MsgCsrfWarning, MsgValueRequired))
 import Data.Text (Text, pack)
 import Control.Monad.Trans.RWS (ask, get, put, runRWST, tell, evalRWST)
 import Control.Monad.Trans.Class (lift)
@ -86,21 +86,21 @@ askFiles = do
    (x, _, _) <- ask
    return $ liftM snd x

-mreq :: (Monad m, RenderMessage master msg, RenderMessage master msg2)
+mreq :: (Monad 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 (FormFailure ["Value is required"]) FormSuccess True -- TRANS
+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)
     => 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) (FormSuccess Nothing) (FormSuccess . Just) False
+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)
        => Field xml msg a
        -> FieldSettings msg2
        -> Maybe a
-        -> FormResult b -- ^ on missing
+        -> (master -> [Text] -> FormResult b) -- ^ on missing
        -> (a -> FormResult b) -- ^ on success
        -> Bool -- ^ is it required?
        -> Form master (GGHandler sub master m) (FormResult b, FieldView xml)
@ -109,15 +109,19 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
    name <- maybe newFormIdent return fsName
    theId <- lift $ maybe (liftM pack newIdent) return fsId
    (_, master, langs) <- ask
-    let mr = renderMessage master langs
    let mr2 = renderMessage master langs
    let (res, val) =
            case mp of
                Nothing -> (FormMissing, maybe "" fieldRender mdef)
                Just p ->
-                    case fromMaybe "" $ lookup name p of
-                        "" -> (onMissing, "") -- TRANS
-                        x -> (either (FormFailure . return . mr) onFound $ fieldParse x, x)
+                    let mval = lookup name p
+                        valB = fromMaybe "" mval
+                     in case fieldParse mval of
+                            Left e -> (FormFailure [renderMessage master langs e], valB)
+                            Right mx ->
+                                case mx of
+                                    Nothing -> (onMissing master langs, valB)
+                                    Just x -> (onFound x, valB)
    return (res, FieldView
        { fvLabel = toHtml $ mr2 fsLabel
        , fvTooltip = fmap toHtml $ fmap mr2 fsTooltip
@ -130,7 +134,7 @@ mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do
        , fvRequired = isReq
        })

-areq :: (Monad m, RenderMessage master msg1, RenderMessage master msg2)
+areq :: (Monad 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
--- a/Yesod/Form/Input.hs
+++ b/Yesod/Form/Input.hs
@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Yesod.Form.Input
    ( FormInput (..)
    , runInputGet
@ -8,11 +9,11 @@ module Yesod.Form.Input
    ) where

 import Yesod.Form.Types
-import Data.Text (Text, append)
+import Yesod.Form.Fields (FormMessage (MsgInputNotFound))
+import Data.Text (Text)
 import Control.Applicative (Applicative (..))
 import Yesod.Handler (GHandler, GGHandler, invalidArgs, runRequestBody, getRequest, getYesod)
 import Yesod.Request (reqGetParams, languages)
-import Data.Maybe (fromMaybe)
 import Control.Monad (liftM)
 import Yesod.Widget (GWidget)
 import Yesod.Message (RenderMessage (..))
@ -30,17 +31,18 @@ instance Applicative (FormInput master) where
            (_, Left b) -> Left b
            (Right a, Right b) -> Right $ a b

-ireq :: RenderMessage master msg => Field (GWidget sub master ()) msg a -> Text -> FormInput master a
+ireq :: (RenderMessage master msg, RenderMessage master FormMessage) => Field (GWidget sub master ()) msg a -> Text -> FormInput master a
 ireq field name = FormInput $ \m l env ->
-    case lookup name env of
-        Nothing -> Left $ (:) $ append "Input not found: " name -- TRANS
-        Just x -> either (Left . (:) . renderMessage m l) Right $ fieldParse field x
+    case fieldParse field $ lookup name env 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 ->
-    case fromMaybe "" $ lookup name env of
-        "" -> Right Nothing
-        x -> either (Left . (:) . renderMessage m l) (Right . Just) $ fieldParse field x
+    case fieldParse field $ lookup name env of
+        Left e -> Left $ (:) $ renderMessage m l e
+        Right x -> Right x

 runInputGet :: Monad monad => FormInput master a -> GGHandler sub master monad a
 runInputGet (FormInput f) = do
--- a/Yesod/Form/Jquery.hs
+++ b/Yesod/Form/Jquery.hs
@ -63,9 +63,14 @@ class YesodJquery a where
    urlJqueryUiDateTimePicker :: a -> Either (Route a) Text
    urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"

+blank :: (Text -> Either msg a) -> Maybe Text -> Either msg (Maybe a)
+blank _ Nothing = Right Nothing
+blank _ (Just "") = Right Nothing
+blank f (Just t) = either Left (Right . Just) $ f t
+
 jqueryDayField :: (YesodJquery master) => JqueryDaySettings -> Field (GWidget sub master ()) FormMessage Day
 jqueryDayField jds = Field
-    { fieldParse = maybe
+    { fieldParse = blank $ maybe
                  (Left MsgInvalidDay)
                  Right
              . readMay
@ -120,7 +125,7 @@ jqueryDayTimeUTCTime (UTCTime day utcTime) =

 jqueryDayTimeField :: YesodJquery master => Field (GWidget sub master ()) FormMessage UTCTime
 jqueryDayTimeField = Field
-    { fieldParse  = parseUTCTime . unpack
+    { fieldParse  = blank $ parseUTCTime . unpack
    , fieldRender = pack . jqueryDayTimeUTCTime
    , fieldView = \theId name val isReq -> do
        addHtml [HAMLET|\
--- a/Yesod/Form/Nic.hs
+++ b/Yesod/Form/Nic.hs
@ -26,9 +26,14 @@ class YesodNic a where
    urlNicEdit :: a -> Either (Route a) Text
    urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"

+blank :: (Text -> Either msg a) -> Maybe Text -> Either msg (Maybe a)
+blank _ Nothing = Right Nothing
+blank _ (Just "") = Right Nothing
+blank f (Just t) = either Left (Right . Just) $ f t
+
 nicHtmlField :: YesodNic master => Field (GWidget sub master ()) msg Html
 nicHtmlField = Field
-    { fieldParse = Right . preEscapedString . sanitizeBalance . unpack -- FIXME
+    { fieldParse = blank $ Right . preEscapedString . sanitizeBalance . unpack -- FIXME
    , fieldRender = pack . renderHtml
    , fieldView = \theId name val _isReq -> do
        addHtml
--- a/Yesod/Form/Types.hs
+++ b/Yesod/Form/Types.hs
@ -113,7 +113,7 @@ data FieldView xml = FieldView
    }

 data Field xml msg a = Field
-    { fieldParse :: Text -> Either msg a -- FIXME probably want to make this more sophisticated, handle no form, no field
+    { fieldParse :: Maybe Text -> Either msg (Maybe a)
    , fieldRender :: a -> Text
    , fieldView :: Text -- ^ ID
                -> Text -- ^ name