Merge pull request #1781 from eahlberg/add-by-selector-label-contain
Add bySelectorLabelContain to support testing inputs with the same label
This commit is contained in:
Michael Snoyman
GitHub
commit
f729d9bbb6
@ -1,5 +1,10 @@
|
||||
# ChangeLog for yesod-test
|
||||
|
||||
|
||||
## 1.6.15
|
||||
|
||||
* Add `bySelectorLabelContain`. [#1781](https://github.com/yesodweb/yesod/pull/1781)
|
||||
|
||||
## 1.6.14
|
||||
|
||||
* Fix quotes not matching in htmlContain* functions [#1768](https://github.com/yesodweb/yesod/pull/1768).
|
||||
|
||||
@ -170,6 +170,7 @@ module Yesod.Test
|
||||
, byLabelContain
|
||||
, byLabelPrefix
|
||||
, byLabelSuffix
|
||||
, bySelectorLabelContain
|
||||
, fileByLabel
|
||||
, fileByLabelExact
|
||||
, fileByLabelContain
|
||||
@ -876,9 +877,36 @@ genericNameFromLabel match label = do
|
||||
case mres of
|
||||
Nothing -> failure "genericNameFromLabel: No response available"
|
||||
Just res -> return res
|
||||
let body = simpleBody res
|
||||
case genericNameFromHTML match label body of
|
||||
Left e -> failure e
|
||||
Right x -> pure x
|
||||
|
||||
-- |
|
||||
-- This looks up the name of a field based on a CSS selector and the contents of the label pointing to it.
|
||||
genericNameFromSelectorLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> T.Text -> RequestBuilder site T.Text
|
||||
genericNameFromSelectorLabel match selector label = do
|
||||
mres <- fmap rbdResponse getSIO
|
||||
res <-
|
||||
case mres of
|
||||
Nothing -> failure "genericNameSelectorFromLabel: No response available"
|
||||
Just res -> return res
|
||||
let body = simpleBody res
|
||||
html <-
|
||||
case findBySelector body selector of
|
||||
Left parseError -> failure $ "genericNameFromSelectorLabel: Parse error" <> T.pack parseError
|
||||
Right [] -> failure $ "genericNameFromSelectorLabel: No fragments match selector " <> selector
|
||||
Right [matchingFragment] -> pure $ BSL8.pack matchingFragment
|
||||
Right _matchingFragments -> failure $ "genericNameFromSelectorLabel: Multiple fragments match selector " <> selector
|
||||
case genericNameFromHTML match label html of
|
||||
Left e -> failure e
|
||||
Right x -> pure x
|
||||
|
||||
genericNameFromHTML :: (T.Text -> T.Text -> Bool) -> T.Text -> HtmlLBS -> Either T.Text T.Text
|
||||
genericNameFromHTML match label html =
|
||||
let
|
||||
body = simpleBody res
|
||||
mlabel = parseHTML body
|
||||
parsedHTML = parseHTML html
|
||||
mlabel = parsedHTML
|
||||
$// C.element "label"
|
||||
>=> isContentMatch label
|
||||
mfor = mlabel >>= attribute "for"
|
||||
@ -887,26 +915,26 @@ genericNameFromLabel match label = do
|
||||
| x `match` T.concat (c $// content) = [c]
|
||||
| otherwise = []
|
||||
|
||||
case mfor of
|
||||
in case mfor of
|
||||
for:[] -> do
|
||||
let mname = parseHTML body
|
||||
let mname = parsedHTML
|
||||
$// attributeIs "id" for
|
||||
>=> attribute "name"
|
||||
case mname of
|
||||
"":_ -> failure $ T.concat
|
||||
"":_ -> Left $ T.concat
|
||||
[ "Label "
|
||||
, label
|
||||
, " resolved to id "
|
||||
, for
|
||||
, " which was not found. "
|
||||
]
|
||||
name:_ -> return name
|
||||
[] -> failure $ "No input with id " <> for
|
||||
name:_ -> Right name
|
||||
[] -> Left $ "No input with id " <> for
|
||||
[] ->
|
||||
case filter (/= "") $ mlabel >>= (child >=> C.element "input" >=> attribute "name") of
|
||||
[] -> failure $ "No label contained: " <> label
|
||||
name:_ -> return name
|
||||
_ -> failure $ "More than one label contained " <> label
|
||||
[] -> Left $ "No label contained: " <> label
|
||||
name:_ -> Right name
|
||||
_ -> Left $ "More than one label contained " <> label
|
||||
|
||||
byLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
|
||||
-> T.Text -- ^ The text contained in the @\<label>@.
|
||||
@ -916,6 +944,15 @@ byLabelWithMatch match label value = do
|
||||
name <- genericNameFromLabel match label
|
||||
addPostParam name value
|
||||
|
||||
bySelectorLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
|
||||
-> T.Text -- ^ The CSS selector.
|
||||
-> T.Text -- ^ The text contained in the @\<label>@.
|
||||
-> T.Text -- ^ The value to set the parameter to.
|
||||
-> RequestBuilder site ()
|
||||
bySelectorLabelWithMatch match selector label value = do
|
||||
name <- genericNameFromSelectorLabel match selector label
|
||||
addPostParam name value
|
||||
|
||||
-- How does this work for the alternate <label><input></label> syntax?
|
||||
|
||||
-- | Finds the @\<label>@ with the given value, finds its corresponding @\<input>@, then adds a parameter
|
||||
@ -1029,6 +1066,18 @@ byLabelSuffix :: T.Text -- ^ The text in the @\<label>@.
|
||||
-> RequestBuilder site ()
|
||||
byLabelSuffix = byLabelWithMatch T.isSuffixOf
|
||||
|
||||
-- |
|
||||
-- Note: This function throws an error if it finds multiple labels or if the
|
||||
-- CSS selector fails to parse, doesn't match any fragment, or matches multiple
|
||||
-- fragments.
|
||||
--
|
||||
-- @since 1.6.15
|
||||
bySelectorLabelContain :: T.Text -- ^ The CSS selector.
|
||||
-> T.Text -- ^ The text in the @\<label>@.
|
||||
-> T.Text -- ^ The value to set the parameter to.
|
||||
-> RequestBuilder site ()
|
||||
bySelectorLabelContain = bySelectorLabelWithMatch T.isInfixOf
|
||||
|
||||
fileByLabelWithMatch :: (T.Text -> T.Text -> Bool) -- ^ The matching method which is used to find labels (i.e. exact, contains)
|
||||
-> T.Text -- ^ The text contained in the @\<label>@.
|
||||
-> FilePath -- ^ The path to the file.
|
||||
|
||||
@ -319,6 +319,21 @@ main = hspec $ do
|
||||
setUrl ("label-contain-error" :: Text)
|
||||
byLabelContain "hobby" "fishing")
|
||||
assertEq "failure wasn't called" (isLeft bad) True
|
||||
yit "bySelectorLabelContain looks for the selector and label which contain the given label name" $ do
|
||||
get ("/selector-label-contain" :: Text)
|
||||
request $ do
|
||||
setMethod "POST"
|
||||
setUrl ("check-hobby" :: Text)
|
||||
bySelectorLabelContain "#hobby-container" "hobby" "fishing"
|
||||
res <- maybe "Couldn't get response" simpleBody <$> getResponse
|
||||
assertEq "hobby isn't set" res "fishing"
|
||||
yit "bySelectorLabelContain throws an error if the selector matches multiple elements" $ do
|
||||
get ("selector-label-contain-error" :: Text)
|
||||
(bad :: Either SomeException ()) <- try (request $ do
|
||||
setMethod "POST"
|
||||
setUrl ("check-hobby" :: Text)
|
||||
bySelectorLabelContain "#hobby-container" "hobby" "fishing")
|
||||
assertEq "failure wasn't called" (isLeft bad) True
|
||||
yit "byLabelPrefix matches over the prefix of the labels" $ do
|
||||
get ("/label-prefix" :: Text)
|
||||
request $ do
|
||||
@ -576,6 +591,10 @@ app = liteApp $ do
|
||||
return ("<html><label for='hobby'>XXXhobbyXXX</label><input type='text' name='hobby' id='hobby'></html>" :: Text)
|
||||
onStatic "label-contain-error" $ dispatchTo $
|
||||
return ("<html><label for='hobby'>XXXhobbyXXX</label><label for='hobby2'>XXXhobby2XXX</label><input type='text' name='hobby' id='hobby'><input type='text' name='hobby2' id='hobby2'></html>" :: Text)
|
||||
onStatic "selector-label-contain" $ dispatchTo $
|
||||
return ("<html><div><label for='hobby-1'>XXXhobbyXXX</label><input type='text' name='hobby-1' id='hobby-1'></div><div id='hobby-container'><label for='hobby'>XXXhobbyXXX</label><input type='text' name='hobby' id='hobby'></div></html>" :: Text)
|
||||
onStatic "selector-label-contain-error" $ dispatchTo $
|
||||
return ("<html><div id='hobby-container'><label for='hobby-1'>XXXhobbyXXX</label><input type='text' name='hobby-1' id='hobby-1'></div><div id='hobby-container'><label for='hobby'>XXXhobbyXXX</label><input type='text' name='hobby' id='hobby'></div></html>" :: Text)
|
||||
onStatic "label-prefix" $ dispatchTo $
|
||||
return ("<html><label for='hobby'>hobbyXXX</label><input type='text' name='hobby' id='hobby'></html>" :: Text)
|
||||
onStatic "label-prefix-error" $ dispatchTo $
|
||||
|
||||
Loading…
Reference in New Issue
Block a user