From ee9ef1eac58f31f408864f2ca044eba33a4804e5 Mon Sep 17 00:00:00 2001 From: Mark Wotton Date: Wed, 14 Jun 2017 13:40:44 -0400 Subject: [PATCH 1/5] add clickOn function (closes #1406) --- yesod-test/ChangeLog.md | 4 +++ yesod-test/Yesod/Test.hs | 11 ++++++++ yesod-test/Yesod/Test/TransversingCSS.hs | 36 +++++++++++++++++++----- yesod-test/test/main.hs | 12 ++++++++ yesod-test/yesod-test.cabal | 2 +- 5 files changed, 57 insertions(+), 8 deletions(-) diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index 0245581e..81fbda95 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.5.7 + +* Add clickOn + ## 1.5.6 * Add assertNotEq. diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 79a62df5..9dca90f6 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -62,6 +62,7 @@ module Yesod.Test , setRequestBody , RequestBuilder , setUrl + , clickOn -- *** Adding fields by label -- | Yesod can auto generate field names, so you are never sure what @@ -830,6 +831,16 @@ setUrl url' = do , rbdGets = rbdGets rbd ++ H.parseQuery (TE.encodeUtf8 urlQuery) } +clickOn :: Yesod site => Query -> YesodExample site () +clickOn query = do + withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res -> + case findAttributeBySelector (simpleBody res) query "href" of + Left err -> failure $ query <> " did not parse: " <> T.pack (show err) + Right [[match]] -> get match + Right matches -> failure $ "Expected exactly one match for clickOn: got " <> T.pack (show matches) + + + -- | Simple way to set HTTP request body -- -- ==== __ Examples__ diff --git a/yesod-test/Yesod/Test/TransversingCSS.hs b/yesod-test/Yesod/Test/TransversingCSS.hs index 658f30a0..bcf555a6 100644 --- a/yesod-test/Yesod/Test/TransversingCSS.hs +++ b/yesod-test/Yesod/Test/TransversingCSS.hs @@ -10,16 +10,16 @@ and it returns a list of the HTML fragments that matched the given query. Only a subset of the CSS spec is currently supported: * By tag name: /table td a/ - + * By class names: /.container .content/ * By Id: /#oneId/ * By attribute: /[hasIt]/, /[exact=match]/, /[contains*=text]/, /[starts^=with]/, /[ends$=with]/ - + * Union: /a, span, p/ - - * Immediate children: /div > p/ + + * Immediate children: /div > p/ * Get jiggy with it: /div[data-attr=yeah] > .mon, .foo.bar div, #oneThing/ @@ -27,6 +27,7 @@ Only a subset of the CSS spec is currently supported: module Yesod.Test.TransversingCSS ( findBySelector, + findAttributeBySelector, HtmlLBS, Query, -- * For HXT hackers @@ -58,9 +59,30 @@ type HtmlLBS = L.ByteString -- -- * Right: List of matching Html fragments. findBySelector :: HtmlLBS -> Query -> Either String [String] -findBySelector html query = (\x -> map (renderHtml . toHtml . node) . runQuery x) - Control.Applicative.<$> (Right $ fromDocument $ HD.parseLBS html) - Control.Applicative.<*> parseQuery query +findBySelector html query = + map (renderHtml . toHtml . node) <$> findCursorsBySelector html query + +-- | Perform a css 'Query' on 'Html'. Returns Either +-- +-- * Left: Query parse error. +-- +-- * Right: List of matching Cursors +findCursorsBySelector :: HtmlLBS -> Query -> Either String [Cursor] +findCursorsBySelector html query = + runQuery (fromDocument $ HD.parseLBS html) + <$> parseQuery query + +-- | Perform a css 'Query' on 'Html'. Returns Either +-- +-- * Left: Query parse error. +-- +-- * Right: List of matching Cursors +-- +-- Since 1.5.7 +findAttributeBySelector :: HtmlLBS -> Query -> T.Text -> Either String [[T.Text]] +findAttributeBySelector html query attr = + map (laxAttribute attr) <$> findCursorsBySelector html query + -- Run a compiled query on Html, returning a list of matching Html fragments. runQuery :: Cursor -> [[SelectorGroup]] -> [Cursor] diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index ff2cca7c..705e3532 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -34,6 +34,7 @@ import Data.ByteString.Lazy.Char8 () import qualified Data.Map as Map import qualified Text.HTML.DOM as HD import Network.HTTP.Types.Status (status301, status303, unsupportedMediaType415) +import Control.Exception.Lifted(SomeException, try) parseQuery_ :: Text -> [[SelectorGroup]] parseQuery_ = either error id . parseQuery @@ -169,6 +170,15 @@ main = hspec $ do addToken_ "body" statusIs 200 bodyEquals "12345" + yit "can follow a link via clickOn" $ do + get ("/htmlWithLink" :: Text) + clickOn "a#thelink" + statusIs 200 + + get ("/htmlWithLink" :: Text) + (bad :: Either SomeException ()) <- try (clickOn "a#nonexistentlink") + assertEq "bad link" (isLeft bad) True + ydescribe "utf8 paths" $ do yit "from path" $ do @@ -326,6 +336,8 @@ app = liteApp $ do onStatic "html" $ dispatchTo $ return ("Hello

Hello World

Hello Moon

" :: Text) + onStatic "htmlWithLink" $ dispatchTo $ + return ("A linkLink!" :: Text) onStatic "labels" $ dispatchTo $ return ("" :: Text) diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index cd1dddc7..8e834f10 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 1.5.6 +version: 1.5.7 license: MIT license-file: LICENSE author: Nubis From 2a112b551688048eb9ebfbf8039564631742969f Mon Sep 17 00:00:00 2001 From: Mark Wotton Date: Thu, 15 Jun 2017 12:17:49 -0400 Subject: [PATCH 2/5] -Werror fixes --- yesod-test/Yesod/Test/TransversingCSS.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/yesod-test/Yesod/Test/TransversingCSS.hs b/yesod-test/Yesod/Test/TransversingCSS.hs index bcf555a6..806fb285 100644 --- a/yesod-test/Yesod/Test/TransversingCSS.hs +++ b/yesod-test/Yesod/Test/TransversingCSS.hs @@ -42,7 +42,6 @@ where import Yesod.Test.CssQuery import qualified Data.Text as T -import Control.Applicative ((<$>), (<*>)) import Text.XML import Text.XML.Cursor import qualified Data.ByteString.Lazy as L @@ -78,7 +77,7 @@ findCursorsBySelector html query = -- -- * Right: List of matching Cursors -- --- Since 1.5.7 +-- @since 1.5.7 findAttributeBySelector :: HtmlLBS -> Query -> T.Text -> Either String [[T.Text]] findAttributeBySelector html query attr = map (laxAttribute attr) <$> findCursorsBySelector html query From 1bc30deee7d8d7c2a0d4e9d3a4b684ba0955da68 Mon Sep 17 00:00:00 2001 From: Mark Wotton Date: Thu, 15 Jun 2017 13:30:58 -0400 Subject: [PATCH 3/5] import Control.Applicative for 7.8.4 --- yesod-test/Yesod/Test/TransversingCSS.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/yesod-test/Yesod/Test/TransversingCSS.hs b/yesod-test/Yesod/Test/TransversingCSS.hs index 806fb285..7ef7b6fc 100644 --- a/yesod-test/Yesod/Test/TransversingCSS.hs +++ b/yesod-test/Yesod/Test/TransversingCSS.hs @@ -42,6 +42,7 @@ where import Yesod.Test.CssQuery import qualified Data.Text as T +import qualified Control.Applicative import Text.XML import Text.XML.Cursor import qualified Data.ByteString.Lazy as L @@ -59,7 +60,7 @@ type HtmlLBS = L.ByteString -- * Right: List of matching Html fragments. findBySelector :: HtmlLBS -> Query -> Either String [String] findBySelector html query = - map (renderHtml . toHtml . node) <$> findCursorsBySelector html query + map (renderHtml . toHtml . node) Control.Applicative.<$> findCursorsBySelector html query -- | Perform a css 'Query' on 'Html'. Returns Either -- @@ -69,7 +70,7 @@ findBySelector html query = findCursorsBySelector :: HtmlLBS -> Query -> Either String [Cursor] findCursorsBySelector html query = runQuery (fromDocument $ HD.parseLBS html) - <$> parseQuery query + Control.Applicative.<$> parseQuery query -- | Perform a css 'Query' on 'Html'. Returns Either -- @@ -80,7 +81,7 @@ findCursorsBySelector html query = -- @since 1.5.7 findAttributeBySelector :: HtmlLBS -> Query -> T.Text -> Either String [[T.Text]] findAttributeBySelector html query attr = - map (laxAttribute attr) <$> findCursorsBySelector html query + map (laxAttribute attr) Control.Applicative.<$> findCursorsBySelector html query -- Run a compiled query on Html, returning a list of matching Html fragments. From 7cd37db7c66357717b1c2630d191a3ca8c2cba59 Mon Sep 17 00:00:00 2001 From: Mark Wotton Date: Thu, 15 Jun 2017 15:46:25 -0400 Subject: [PATCH 4/5] address review comments --- yesod-test/ChangeLog.md | 3 ++- yesod-test/Yesod/Test.hs | 7 +++++++ yesod-test/test/main.hs | 1 + 3 files changed, 10 insertions(+), 1 deletion(-) diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index 81fbda95..2c1330d4 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -1,6 +1,7 @@ ## 1.5.7 -* Add clickOn +* Add clickOn. +[#1408](https://github.com/yesodweb/yesod/pull/1408) ## 1.5.6 diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 9dca90f6..37c7a10d 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -831,6 +831,13 @@ setUrl url' = do , rbdGets = rbdGets rbd ++ H.parseQuery (TE.encodeUtf8 urlQuery) } + +-- | Click on a link defined by a CSS query +-- +-- ==== __ Examples__ +-- +-- > get "/foobar" +-- > clickOn "a#idofthelink" clickOn :: Yesod site => Query -> YesodExample site () clickOn query = do withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res -> diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index 705e3532..0b2fe611 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -174,6 +174,7 @@ main = hspec $ do get ("/htmlWithLink" :: Text) clickOn "a#thelink" statusIs 200 + bodyEquals "Hello

Hello World

Hello Moon

" get ("/htmlWithLink" :: Text) (bad :: Either SomeException ()) <- try (clickOn "a#nonexistentlink") From c40d39dc5a7408dc958e86b4b12bc9a1e7c5675b Mon Sep 17 00:00:00 2001 From: Mark Wotton Date: Wed, 21 Jun 2017 15:12:03 -0400 Subject: [PATCH 5/5] one more since --- yesod-test/Yesod/Test.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 37c7a10d..6ef3c684 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -838,6 +838,8 @@ setUrl url' = do -- -- > get "/foobar" -- > clickOn "a#idofthelink" +-- +-- @since 1.5.7 clickOn :: Yesod site => Query -> YesodExample site () clickOn query = do withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res ->