Merge pull request #1408 from mwotton/master

add clickOn function (closes #1405)

yesod-test/ChangeLog.md

@@ -1,3 +1,8 @@
+## 1.5.7
+
+* Add clickOn.
+[#1408](https://github.com/yesodweb/yesod/pull/1408)
+
 ## 1.5.6
 
 * Add assertNotEq.

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,25 @@ 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"
+--
+-- @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 ->
+    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__

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
@@ -41,7 +42,7 @@ where
 
 import Yesod.Test.CssQuery
 import qualified Data.Text as T
-import Control.Applicative ((<$>), (<*>))
+import qualified Control.Applicative
 import Text.XML
 import Text.XML.Cursor
 import qualified Data.ByteString.Lazy as L
@@ -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)
+findBySelector html query =
-    Control.Applicative.<$> (Right $ fromDocument $ HD.parseLBS html)
+  map (renderHtml . toHtml . node) Control.Applicative.<$> findCursorsBySelector html query
-    Control.Applicative.<*> parseQuery 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)
+       Control.Applicative.<$> 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) Control.Applicative.<$> findCursorsBySelector html query
+
 
 -- Run a compiled query on Html, returning a list of matching Html fragments.
 runQuery :: Cursor -> [[SelectorGroup]] -> [Cursor]

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,16 @@ 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
+              bodyEquals "<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon</p></body></html>"
+
+              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 +337,8 @@ app = liteApp $ do
     onStatic "html" $ dispatchTo $
         return ("<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon</p></body></html>" :: Text)
 
+    onStatic "htmlWithLink" $ dispatchTo $
+        return ("<html><head><title>A link</title></head><body><a href=\"/html\" id=\"thelink\">Link!</a></body></html>" :: Text)
     onStatic "labels" $ dispatchTo $
         return ("<html><label><input type='checkbox' name='fooname' id='foobar'>Foo Bar</label></html>" :: Text)
 

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 <nubis@woobiz.com.ar>