From 1c28ca8744416effd4abb9aee4a493deb5a95453 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Wed, 28 Mar 2012 09:14:43 +0200
Subject: [PATCH] Initial migration to xml-conduit

---
 yesod-test/Yesod/Test.hs                 | 14 +++--
 yesod-test/Yesod/Test/TransversingCSS.hs | 76 +++++++++++++++---------
 yesod-test/yesod-test.cabal              |  2 +
 3 files changed, 57 insertions(+), 35 deletions(-)

diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs
index ab7430af..6bd1f44d 100644
--- a/yesod-test/Yesod/Test.hs
+++ b/yesod-test/Yesod/Test.hs
@@ -86,6 +86,8 @@ import System.IO
 import Yesod.Test.TransversingCSS
 import Database.Persist.GenericSql
 import Data.Monoid (mappend)
+import qualified Data.Text.Lazy as TL
+import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)
 
 -- | The state used in 'describe' to build a list of specs
 data SpecsData = SpecsData Application ConnectionPool [Core.Spec]
@@ -161,15 +163,15 @@ withResponse f = maybe err f =<< fmap readResponse ST.get
 
 -- | Use HXT to parse a value from an html tag.
 -- Check for usage examples in this module's source.
-parseHTML :: String -> LA XmlTree a -> [a]
-parseHTML html p = runLA (hread >>> p ) html
+parseHTML :: Html -> LA XmlTree a -> [a]
+parseHTML html p = runLA (hread >>> p ) (TL.unpack $ decodeUtf8 html)
 
 -- | Query the last response using css selectors, returns a list of matched fragments
 htmlQuery :: HoldsResponse a => Query -> ST.StateT a IO [Html]
 htmlQuery query = withResponse $ \ res ->
-  case findBySelector (BSL8.unpack $ simpleBody res) query of
+  case findBySelector (simpleBody res) query of
     Left err -> failure $ T.unpack query ++ " did not parse: " ++ (show err)
-    Right matches -> return matches
+    Right matches -> return $ map (encodeUtf8 . TL.pack) matches
 
 -- | Asserts that the two given values are equal.
 assertEqual :: (Eq a) => String -> a -> a -> OneSpec ()
@@ -240,7 +242,7 @@ htmlAllContain query search = do
   case matches of
     [] -> failure $ "Nothing matched css query: "++T.unpack query
     _ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search) $
-          DL.all (DL.isInfixOf search) matches
+          DL.all (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches)
 
 -- | Performs a css query on the last response and asserts the matched elements
 -- are as many as expected.
@@ -280,7 +282,7 @@ fileByName name path mimetype = do
 nameFromLabel :: String -> RequestBuilder String
 nameFromLabel label = withResponse $ \ res -> do
   let
-    body = BSL8.unpack $ simpleBody res
+    body = simpleBody res
     escaped = escapeHtmlEntities label
     mfor = parseHTML body $ deep $ hasName "label"
         >>> filterA (xshow this >>> mkText >>> hasText (DL.isInfixOf escaped))
diff --git a/yesod-test/Yesod/Test/TransversingCSS.hs b/yesod-test/Yesod/Test/TransversingCSS.hs
index bb40b42c..862117ea 100644
--- a/yesod-test/Yesod/Test/TransversingCSS.hs
+++ b/yesod-test/Yesod/Test/TransversingCSS.hs
@@ -32,7 +32,6 @@ module Yesod.Test.TransversingCSS (
   -- | These functions expose some low level details that you can blissfully ignore.
   parseQuery,
   runQuery,
-  queryToArrow,
   Selector(..),
   SelectorGroup(..)
 
@@ -44,41 +43,60 @@ import qualified Data.List as DL
 import Yesod.Test.CssQuery
 import Data.Text (unpack)
 import qualified Data.Text as T
+import Yesod.Test.HtmlParse (parseHtml)
+import Control.Applicative ((<$>), (<*>))
+import Text.XML
+import Text.XML.Cursor
+import qualified Data.ByteString.Lazy as L
+import Text.Blaze (toHtml)
+import Text.Blaze.Renderer.String (renderHtml)
+import Text.XML.Xml2Html ()
 
-type Html = String
 type Query = T.Text
- 
+type Html = L.ByteString
+
 -- | Perform a css 'Query' on 'Html'. Returns Either
 --
 -- * Left: Query parse error.
 --
 -- * Right: List of matching Html fragments.
-findBySelector :: Html-> Query -> Either String [Html]
-findBySelector html query = fmap (runQuery html) (parseQuery query)
+findBySelector :: Html -> Query -> Either String [String]
+findBySelector html query = (\x -> map (renderHtml . toHtml . node) . runQuery x)
+    <$> (fromDocument <$> parseHtml html)
+    <*> parseQuery query
 
 -- Run a compiled query on Html, returning a list of matching Html fragments.
-runQuery :: Html -> [[SelectorGroup]] -> [Html]
-runQuery html query =
-  runLA (hread >>> (queryToArrow query) >>> xshow this) html
+runQuery :: Cursor -> [[SelectorGroup]] -> [Cursor]
+runQuery html query = concatMap (runGroup html) query
 
--- | Transform a compiled query into the HXT arrow that finally transverses the Html
-queryToArrow :: ArrowXml a => [[SelectorGroup]] -> a XmlTree XmlTree
-queryToArrow commaSeparated = 
-  DL.foldl uniteCommaSeparated none commaSeparated
- where
-  uniteCommaSeparated accum selectorGroups =
-    accum <+> (DL.foldl sequenceSelectorGroups this selectorGroups)
-  sequenceSelectorGroups accum (DirectChildren sels) =
-    accum >>> getChildren >>> (DL.foldl applySelectors this $ sels)
-  sequenceSelectorGroups accum (DeepChildren sels) =
-    accum >>> getChildren >>> multi (DL.foldl applySelectors this $ sels)
-  applySelectors accum selector = accum >>> (toArrow selector)
-  toArrow selector = case selector of
-    ById v -> hasAttrValue "id" (== unpack v)
-    ByClass v -> hasAttrValue "class" ((DL.elem $ unpack v) . words)
-    ByTagName v -> hasName $ unpack v
-    ByAttrExists n -> hasAttr $ unpack n
-    ByAttrEquals n v -> hasAttrValue (unpack n) (== unpack v)
-    ByAttrContains n v -> hasAttrValue (unpack n) (DL.isInfixOf $ unpack v)
-    ByAttrStarts n v -> hasAttrValue (unpack n) (DL.isPrefixOf $ unpack v)
-    ByAttrEnds n v -> hasAttrValue (unpack n) (DL.isSuffixOf $ unpack v)
+runGroup :: Cursor -> [SelectorGroup] -> [Cursor]
+runGroup c [] = [c]
+runGroup c (DirectChildren s:gs) = concatMap (flip runGroup gs) $ c $/ selectors s
+runGroup c (DeepChildren s:gs) = concatMap (flip runGroup gs) $ c $// selectors s
+
+selectors :: [Selector] -> Cursor -> [Cursor]
+selectors ss c
+    | all (selector c) ss = [c]
+    | otherwise = []
+
+selector :: Cursor -> Selector -> Bool
+selector c (ById x) = not $ null $ attributeIs "id" x c
+selector c (ByClass x) =
+    case attribute "class" c of
+        t:_ -> x `elem` T.words t
+        [] -> False
+selector c (ByTagName t) = not $ null $ element (Name t Nothing Nothing) c
+selector c (ByAttrExists t) = not $ null $ hasAttribute (Name t Nothing Nothing) c
+selector c (ByAttrEquals t v) = not $ null $ attributeIs (Name t Nothing Nothing) v c
+selector c (ByAttrContains n v) =
+    case attribute (Name n Nothing Nothing) c of
+        t:_ -> v `T.isInfixOf` t
+        [] -> False
+selector c (ByAttrStarts n v) =
+    case attribute (Name n Nothing Nothing) c of
+        t:_ -> v `T.isPrefixOf` t
+        [] -> False
+selector c (ByAttrEnds n v) =
+    case attribute (Name n Nothing Nothing) c of
+        t:_ -> v `T.isSuffixOf` t
+        [] -> False
diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal
index 635484d9..1a881034 100644
--- a/yesod-test/yesod-test.cabal
+++ b/yesod-test/yesod-test.cabal
@@ -40,6 +40,8 @@ library
                    , xml-conduit               >= 0.7      && < 0.8
                    , xml-types                 >= 0.3      && < 0.4
                    , containers
+                   , blaze-html                >= 0.4      && < 0.5
+                   , xml2html                  >= 0.1.2    && < 0.2
     exposed-modules: Yesod.Test
                      Yesod.Test.CssQuery
                      Yesod.Test.TransversingCSS