Merge branch 'add-by-selector-label-contain' of github.com:eahlberg/y…

…esod into eahlberg-add-by-selector-label-contain

yesod-test/ChangeLog.md

@@ -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).

yesod-test/Yesod/Test.hs

@@ -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.

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 ("<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 $