Add selectByLabel

yesodweb · Aug 26, 2024 · 48061f6 · 48061f6
1 parent bc0e80e
commit 48061f6
Show file tree

Hide file tree

Showing 4 changed files with 70 additions and 3 deletions.
diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md
@@ -1,5 +1,9 @@
 # ChangeLog for yesod-test
 
+## 1.6.19
+
+* Add `selectByLabel` to yesod-test. [#1845](https://github.com/yesodweb/yesod/pull/1845)
+
 ## 1.6.18
 
 * Add `checkByLabel` to yesod-test. [#1843](https://github.com/yesodweb/yesod/pull/1843)

diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs
@@ -179,6 +179,7 @@ module Yesod.Test
     , fileByLabelSuffix
     , chooseByLabel
     , checkByLabel
+    , selectByLabel
 
     -- *** CSRF Tokens
     -- | In order to prevent CSRF exploits, yesod-form adds a hidden input
@@ -1745,6 +1746,47 @@ checkByLabel label = do
     value <- genericValueFromLabel (==) label
     addPostParam name value
 
+-- | Finds the @\<label>@ with the given value, finds its corresponding @\<select>@,
+-- then finds corresponding @\<option>@ and make this options selected.
+--
+-- ==== __Examples__
+--
+-- Given this HTML, we want to submit @f1=2@ (i.e. selected option is "Blue") to the server:
+--
+-- > <form method="post" action="labels-select">
+-- >   <label for="hident2">Selection List</label>
+-- >   <select id="hident2" name="f1">
+-- >     <option value="1">Red</option>
+-- >     <option value="2">Blue</option>
+-- >     <option value="3">Gray</option>
+-- >     <option value="4">Black</option>
+-- >   </select>
+-- > </form>
+--
+-- You can set this parameter like so:
+--
+-- > request $ do
+-- >   setMethod "POST"
+-- >   selectByLabel "Selection List" "Blue"
+--
+-- @since 1.6.19
+selectByLabel :: T.Text -> T.Text -> RequestBuilder site ()
+selectByLabel label option = do
+    name <- genericNameFromLabel (==) label
+    parsedHtml <- parseHTML <$> htmlBody "selectByLabel"
+    let values = parsedHtml $// C.element "select"
+                            >=> attributeIs "name" name
+                            &/ C.element "option"
+                            >=> isContentMatch option
+                            >=> attribute "value"
+    case values of
+      [] -> failure $ T.concat ["selectByLabel: option '" , option, "' not found in select '", label, "'"]
+      [value] -> addPostParam name value
+      _ -> failure $ T.concat ["selectByLabel: too many options '", option, "' found in select '", label, "'"]
+    where isContentMatch x c
+              | x == T.concat (c $// content) = [c]
+              | otherwise = []
+
 -- |
 -- 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

diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs
@@ -35,7 +35,7 @@ import Control.Applicative
 import Network.Wai (pathInfo, rawQueryString, requestHeaders)
 import Network.Wai.Test (SResponse(simpleBody))
 import Numeric (showHex)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isNothing)
 import Data.Either (isLeft, isRight)
 
 import Test.HUnit.Lang
@@ -46,7 +46,6 @@ import Network.HTTP.Types.Status (status200, status301, status303, status403, st
 import UnliftIO.Exception (tryAny, SomeException, try, Exception)
 import Control.Monad.IO.Unlift (toIO)
 import qualified Web.Cookie as Cookie
-import Data.Maybe (isNothing)
 import qualified Data.Text as T
 import qualified Data.ByteString.Char8 as B8
 import Yesod.Test.Internal (contentTypeHeaderIsUtf8)
@@ -331,6 +330,14 @@ main = hspec $ do
                     checkByLabel "Gray"
                     addToken
                 bodyContains "colorCheckBoxes = [Gray,Red]"
+            yit "can select from select list" $ do
+                get ("/labels-select" :: Text)
+                request $ do
+                    setMethod "POST"
+                    setUrl ("/labels-select" :: Text)
+                    addToken
+                    selectByLabel "Selection List" "Blue"
+                bodyContains "SelectionForm {colorSelection = Blue}"
 
         ydescribe "byLabel-related tests" $ do
             yit "fails with \"More than one label contained\" error" $ do
@@ -699,11 +706,25 @@ app = liteApp $ do
                                   ^{widget}
                                |]
 
+    onStatic "labels-select" $ dispatchTo $ do
+        ((result, widget), _) <- runFormPost
+                    $ renderDivs
+                    $ SelectionForm <$> areq (selectField optionsEnum) "Selection List" Nothing
+        case result of
+            FormSuccess color -> return $ toHtml $ show color
+            _ -> defaultLayout [whamlet|$newline never
+                                <p>
+                                  ^{toHtml $ show result}
+                                <form method=post action="labels-checkboxes">
+                                  ^{widget}
+                               |]
+
 data Color = Red | Blue | Gray | Black
     deriving (Show, Eq, Enum, Bounded)
 
 newtype RadioButtonForm = RadioButtonForm { colorRadioButton :: Maybe Color } deriving Show
 newtype CheckboxesForm = CheckboxesForm { colorCheckBoxes :: [Color] } deriving Show
+newtype SelectionForm = SelectionForm {colorSelection :: Color } deriving Show
 
 cookieApp :: LiteApp
 cookieApp = liteApp $ do

diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal
@@ -1,5 +1,5 @@
 name:               yesod-test
-version:            1.6.18
+version:            1.6.19
 license:            MIT
 license-file:       LICENSE
 author:             Nubis <[email protected]>