Add chooseByLabel to yesod-test for testing radio buttons

yesod-form/ChangeLog.md

@@ -1,6 +1,11 @@
 # ChangeLog for yesod-form
 
 
+## 1.7.8
+
+* Added `radioField'` for creating radio button in more correct way than original `radioField`.
+  Function `radioField` marked as deprecated. [#1842](https://github.com/yesodweb/yesod/pull/1842)
+
 ## 1.7.7
 
 * Added `optionsFromList'` to create an OptionList from a List, using the PathPiece instance for the external value and

yesod-form/Yesod/Form/Fields.hs

@@ -48,6 +48,7 @@ module Yesod.Form.Fields
     , selectFieldList
     , selectFieldListGrouped
     , radioField
+    , radioField'
     , radioFieldList
     , withRadioField
     , checkboxesField
@@ -123,6 +124,8 @@ import Data.Monoid
 
 import Data.Char (isHexDigit)
 
+{-# DEPRECATED radioField "This function seems to have a bug (label could not be found with byLabel algorithm)" #-}
+
 defaultFormMessage :: FormMessage -> Text
 defaultFormMessage = englishFormMessage
 
@@ -529,6 +532,7 @@ checkboxesField ioptlist = (multiSelectField ioptlist)
                             #{optionDisplay opt}
                 |]
     }
+
 -- | Creates an input with @type="radio"@ for selecting one option.
 radioField :: (Eq a, RenderMessage site FormMessage)
            => HandlerFor site (OptionList a)
@@ -552,6 +556,28 @@ $newline never
 |])
 
 
+-- | Creates an input with @type="radio"@ for selecting one option.
+--
+--   @since 1.7.8
+radioField' :: (Eq a, RenderMessage site FormMessage)
+           => HandlerFor site (OptionList a)
+           -> Field (HandlerFor site) a
+radioField' = withRadioField
+    (\theId optionWidget -> [whamlet|
+$newline never
+<.radio>
+  ^{optionWidget}
+  <label for=#{theId}-none>
+    _{MsgSelectNone}
+|])
+    (\theId value _isSel text optionWidget -> [whamlet|
+$newline never
+<.radio>
+  ^{optionWidget}
+  <label for=#{theId}-#{value}>
+    \#{text}
+|])
+
 -- | Allows the user to place the option radio widget somewhere in
 --   the template.
 --   For example: If you want a table of radio options to select.
@@ -579,7 +605,6 @@ $newline never
 <input id=#{theId}-#{(value)} type=radio name=#{name} value=#{(value)} :isSel:checked *{attrs}>
 |]
 
-
 -- | Creates a group of radio buttons to answer the question given in the message. Radio buttons are used to allow differentiating between an empty response (@Nothing@) and a no response (@Just False@). Consider using the simpler 'checkBoxField' if you don't need to make this distinction.
 --
 -- If this field is optional, the first radio button is labeled "\<None>", the second \"Yes" and the third \"No".

yesod-form/yesod-form.cabal

@@ -1,6 +1,6 @@
 cabal-version:   >= 1.10
 name:            yesod-form
-version:         1.7.7
+version:         1.7.8
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <[email protected]>

yesod-test/ChangeLog.md

@@ -1,5 +1,8 @@
 # ChangeLog for yesod-test
 
+## 1.6.17
+
+* Add `chooseByLabel` to yesod-test. [#1842](https://github.com/yesodweb/yesod/pull/1842)
 
 ## 1.6.16
 

yesod-test/Yesod/Test.hs

@@ -177,6 +177,7 @@ module Yesod.Test
     , fileByLabelContain
     , fileByLabelPrefix
     , fileByLabelSuffix
+    , chooseByLabel
 
     -- *** CSRF Tokens
     -- | In order to prevent CSRF exploits, yesod-form adds a hidden input
@@ -1669,3 +1670,96 @@ instance YesodDispatch site => Hspec.Example (SIO (YesodExampleData site) a) whe
                 return ())
             params
             ($ ())
+
+-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then make this input checked.
+-- It is assumed the @\<input>@ has @type=radio@.
+--
+-- ==== __Examples__
+--
+-- Given this HTML, we want to submit @f1=2@ (i.e. radio button with "Blue" label) to the server:
+--
+-- > <form method="POST">
+-- >   <label for="hident2">Color</label>
+-- >   <div id="hident2">
+-- >     <div class="radio">
+-- >       <input id="hident2-none" type="radio" name="f1" value="none" checked>
+-- >       <label for="hident2-none">&lt;None&gt;</label>
+-- >     </div>
+-- >     <div class="radio">
+-- >       <input id="hident2-1" type="radio" name="f1" value="1">
+-- >       <label for="hident2-1">Red</label>
+-- >     </div>
+-- >     <div class="radio">
+-- >       <input id="hident2-2" type="radio" name="f1" value="2">
+-- >       <label for="hident2-2">Blue</label>
+-- >     </div>
+-- >     <div class="radio">
+-- >       <input id="hident2-3" type="radio" name="f1" value="3">
+-- >       <label for="hident2-3">Gray</label>
+-- >     </div>
+-- >     <div class="radio">
+-- >       <input id="hident2-4" type="radio" name="f1" value="4">
+-- >       <label for="hident2-4">Black</label>
+-- >     </div>
+-- >   </div>
+-- > </form>
+--
+-- You can set this parameter like so:
+--
+-- > request $ do
+-- >   chooseByLabel "Blue"
+--
+-- @since 1.6.17
+chooseByLabel :: T.Text -> RequestBuilder site ()
+chooseByLabel label = do
+    name <- genericNameFromLabel (==) label
+    value <- genericValueFromLabel (==) label
+    addPostParam name value
+
+-- |
+-- This looks up the value of a field based on the contents of the label pointing to it.
+genericValueFromLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
+genericValueFromLabel match label = do
+  mres <- fmap rbdResponse getSIO
+  res <-
+    case mres of
+      Nothing -> failure "genericValueFromLabel: No response available"
+      Just res -> return res
+  let body = simpleBody res
+  case genericValueFromHTML match label body of
+    Left e -> failure e
+    Right x -> pure x
+
+genericValueFromHTML :: (T.Text -> T.Text -> Bool) -> T.Text -> HtmlLBS -> Either T.Text T.Text
+genericValueFromHTML match label html =
+  let
+    parsedHTML = parseHTML html
+    mlabel = parsedHTML
+                $// C.element "label"
+                >=> isContentMatch label
+    mfor = mlabel >>= attribute "for"
+
+    isContentMatch x c
+        | x `match` T.concat (c $// content) = [c]
+        | otherwise = []
+
+  in case mfor of
+    for:[] -> do
+      let mvalue = parsedHTML
+                    $// attributeIs "id" for
+                    >=> attribute "value"
+      case mvalue of
+        "":_ -> Left $ T.concat
+            [ "Label "
+            , label
+            , " resolved to id "
+            , for
+            , " which was not found. "
+            ]
+        value:_ -> Right value
+        [] -> Left $ "No input with id " <> for
+    [] ->
+      case filter (/= "") $ mlabel >>= (child >=> C.element "input" >=> attribute "value") of
+        [] -> Left $ "No label contained: " <> label
+        value:_ -> Right value
+    _ -> Left $ "More than one label contained " <> label

yesod-test/test/main.hs

@@ -314,6 +314,14 @@ main = hspec $ do
                     setMethod "POST"
                     setUrl ("/labels" :: Text)
                     byLabel "Foo Bar" "yes"
+            yit "can click radio button" $ do
+                get ("/labels-radio-buttons" :: Text)
+                request $ do
+                    setMethod "POST"
+                    setUrl ("/labels-radio-buttons" :: Text)
+                    chooseByLabel "Blue"
+                bodyContains "<input id=\"hident2-2\" type=\"radio\" name=\"f1\" value=\"2\" checked>"
+
         ydescribe "byLabel-related tests" $ do
             yit "fails with \"More than one label contained\" error" $ do
                 get ("/labels2" :: Text)
@@ -655,6 +663,23 @@ app = liteApp $ do
     onStatic "get-json-wrong-content-type" $ dispatchTo $ do
         return ("[1]" :: Text)
 
+    onStatic "labels-radio-buttons" $ dispatchTo $ do
+        ((result, widget), _) <- runFormPost
+                    $ renderDivs
+                    $ ColorForm <$> aopt (radioField' optionsEnum) "Color" Nothing
+        case result of
+            FormSuccess color -> return $ toHtml $ show color
+            _ -> defaultLayout [whamlet|$newline never
+                                <form method=post action="labels-radio-buttons">
+                                  ^{widget}
+                               |]
+
+data Color = Red | Blue | Gray | Black
+    deriving (Show, Eq, Enum, Bounded)
+
+newtype ColorForm = ColorForm { colorRadioButton :: Maybe Color }
+    deriving Show
+
 cookieApp :: LiteApp
 cookieApp = liteApp $ do
     dispatchTo $ fromMaybe "no message available" <$> getMessage

yesod-test/yesod-test.cabal

@@ -1,5 +1,5 @@
 name:               yesod-test
-version:            1.6.16
+version:            1.6.17
 license:            MIT
 license-file:       LICENSE
 author:             Nubis <[email protected]>