From b28ee833d169f56ece202f35b6610c28489e86fc Mon Sep 17 00:00:00 2001 From: Eric Ahlberg Date: Wed, 21 Sep 2022 10:26:16 +0200 Subject: [PATCH 1/4] Add tests --- yesod-test/test/main.hs | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index 808ccf65..4276c850 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -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 ("" :: Text) onStatic "label-contain-error" $ dispatchTo $ return ("" :: Text) + onStatic "selector-label-contain" $ dispatchTo $ + return ("
" :: Text) + onStatic "selector-label-contain-error" $ dispatchTo $ + return ("
" :: Text) onStatic "label-prefix" $ dispatchTo $ return ("" :: Text) onStatic "label-prefix-error" $ dispatchTo $ From bd86b4db7a49628a11fc48021feea455be8a6b8a Mon Sep 17 00:00:00 2001 From: Eric Ahlberg Date: Wed, 21 Sep 2022 10:33:40 +0200 Subject: [PATCH 2/4] Add bySelectorLabelContain --- yesod-test/Yesod/Test.hs | 70 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 70 insertions(+) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 8c580060..301cfbc2 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -170,6 +170,7 @@ module Yesod.Test , byLabelContain , byLabelPrefix , byLabelSuffix + , bySelectorLabelContain , fileByLabel , fileByLabelExact , fileByLabelContain @@ -908,6 +909,54 @@ genericNameFromLabel match label = do name:_ -> return name _ -> failure $ "More than one label contained " <> label +-- | +-- 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 + 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 = [] + + case mfor of + for:[] -> do + let mname = parsedHTML + $// attributeIs "id" for + >=> attribute "name" + case mname of + "":_ -> failure $ T.concat + [ "Label " + , label + , " resolved to id " + , for + , " which was not found. " + ] + name:_ -> return name + [] -> failure $ "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 + 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 @\