yesod-test 0.1 → 0.2.0
raw patch · 5 files changed
+312/−152 lines, 5 filesdep +attoparsecdep +blaze-htmldep +case-insensitivedep −parsecdep ~HUnitdep ~basedep ~bytestringnew-uploader
Dependencies added: attoparsec, blaze-html, case-insensitive, conduit, containers, resourcet, tagstream-conduit, xml-conduit, xml-types, xml2html, yesod-test
Dependencies removed: parsec
Dependency ranges changed: HUnit, base, bytestring, hspec, persistent, transformers, wai, wai-test
Files
- Yesod/Test.hs +61/−16
- Yesod/Test/CssQuery.hs +106/−0
- Yesod/Test/HtmlParse.hs +65/−0
- Yesod/Test/TransversingCSS.hs +49/−127
- yesod-test.cabal +31/−9
Yesod/Test.hs view
@@ -50,14 +50,15 @@ runDB, -- * Assertions- assertEqual, statusIs, bodyContains, htmlAllContain, htmlCount,+ assertEqual, assertHeader, assertNoHeader, statusIs, bodyEquals, bodyContains,+ htmlAllContain, htmlCount, -- * Utils for debugging tests printBody, printMatches, -- * Utils for building your own assertions -- | Please consider generalizing and contributing the assertions you write.- htmlQuery, parseHTML+ htmlQuery, parseHTML, withResponse ) @@ -75,14 +76,18 @@ import qualified Test.Hspec.HUnit () import qualified Network.HTTP.Types as H import qualified Network.Socket.Internal as Sock+import Data.CaseInsensitive (CI) import Text.XML.HXT.Core hiding (app, err) import Network.Wai-import Network.Wai.Test+import Network.Wai.Test hiding (assertHeader, assertNoHeader) import qualified Control.Monad.Trans.State as ST import Control.Monad.IO.Class 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]@@ -150,22 +155,23 @@ return () ST.put $ SpecsData app conn (specs++spec) --- Performs a given action using the last response.+-- Performs a given action using the last response. Use this to create+-- response-level assertions withResponse :: HoldsResponse a => (SResponse -> ST.StateT a IO b) -> ST.StateT a IO b withResponse f = maybe err f =<< fmap readResponse ST.get where err = failure "There was no response, you should make a request" -- | 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- Left err -> failure $ query ++ " did not parse: " ++ (show err)- Right matches -> return matches+ case findBySelector (simpleBody res) query of+ Left err -> failure $ T.unpack query ++ " did not parse: " ++ (show err)+ Right matches -> return $ map (encodeUtf8 . TL.pack) matches -- | Asserts that the two given values are equal. assertEqual :: (Eq a) => String -> a -> a -> OneSpec ()@@ -179,6 +185,45 @@ , " but received status was ", show $ H.statusCode s ] +-- | Assert the given header key/value pair was returned.+assertHeader :: HoldsResponse a => CI BS8.ByteString -> BS8.ByteString -> ST.StateT a IO ()+assertHeader header value = withResponse $ \ SResponse { simpleHeaders = h } ->+ case lookup header h of+ Nothing -> failure $ concat+ [ "Expected header "+ , show header+ , " to be "+ , show value+ , ", but it was not present"+ ]+ Just value' -> liftIO $ flip HUnit.assertBool (value == value') $ concat+ [ "Expected header "+ , show header+ , " to be "+ , show value+ , ", but received "+ , show value'+ ]++-- | Assert the given header was not included in the response.+assertNoHeader :: HoldsResponse a => CI BS8.ByteString -> ST.StateT a IO ()+assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } ->+ case lookup header h of+ Nothing -> return ()+ Just s -> failure $ concat+ [ "Unexpected header "+ , show header+ , " containing "+ , show s+ ]++-- | Assert the last response is exactly equal to the given text. This is+-- useful for testing API responses.+bodyEquals :: HoldsResponse a => String -> ST.StateT a IO ()+bodyEquals text = withResponse $ \ res ->+ liftIO $ HUnit.assertBool ("Expected body to equal " ++ text) $+ (simpleBody res) == BSL8.pack text+ -- | Assert the last response has the given text. The check is performed using the response -- body in full text form. bodyContains :: HoldsResponse a => String -> ST.StateT a IO ()@@ -195,9 +240,9 @@ htmlAllContain query search = do matches <- htmlQuery query case matches of- [] -> failure $ "Nothing matched css query: "++query- _ -> liftIO $ HUnit.assertBool ("Not all "++query++" contain "++search) $- DL.all (DL.isInfixOf search) matches+ [] -> failure $ "Nothing matched css query: "++T.unpack query+ _ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search) $+ 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.@@ -205,7 +250,7 @@ htmlCount query count = do matches <- fmap DL.length $ htmlQuery query liftIO $ flip HUnit.assertBool (matches == count)- ("Expected "++(show count)++" elements to match "++query++", found "++(show matches))+ ("Expected "++(show count)++" elements to match "++T.unpack query++", found "++(show matches)) -- | Outputs the last response body to stderr (So it doesn't get captured by HSpec) printBody :: HoldsResponse a => ST.StateT a IO ()@@ -237,7 +282,7 @@ 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))@@ -277,9 +322,9 @@ -- | Lookup a _nonce form field and add it's value to the params. -- Receives a CSS selector that should resolve to the form element containing the nonce.-addNonce_ :: String -> RequestBuilder ()+addNonce_ :: Query -> RequestBuilder () addNonce_ scope = do- matches <- htmlQuery $ scope ++ "input[name=_nonce][type=hidden][value]"+ matches <- htmlQuery $ scope `mappend` "input[name=_nonce][type=hidden][value]" case matches of [] -> failure $ "No nonce found in the current page" element:[] -> byName "_nonce" $ head $ parseHTML element $ getAttrValue "value"
+ Yesod/Test/CssQuery.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Parsing CSS selectors into queries.+module Yesod.Test.CssQuery+ ( SelectorGroup (..)+ , Selector (..)+ , parseQuery+ ) where++import Prelude hiding (takeWhile)+import Data.Text (Text)+import Data.Attoparsec.Text+import Control.Applicative (many, (<|>), optional)++data SelectorGroup+ = DirectChildren [Selector]+ | DeepChildren [Selector]+ deriving (Show, Eq)++data Selector+ = ById Text+ | ByClass Text+ | ByTagName Text+ | ByAttrExists Text+ | ByAttrEquals Text Text+ | ByAttrContains Text Text+ | ByAttrStarts Text Text+ | ByAttrEnds Text Text+ deriving (Show, Eq)++-- | Parses a query into an intermediate format which is easy to feed to HXT+--+-- * The top-level lists represent the top level comma separated queries.+--+-- * SelectorGroup is a group of qualifiers which are separated+-- with spaces or > like these three: /table.main.odd tr.even > td.big/+--+-- * A SelectorGroup as a list of Selector items, following the above example+-- the selectors in the group are: /table/, /.main/ and /.odd/+parseQuery :: Text -> Either String [[SelectorGroup]]+parseQuery = parseOnly cssQuery++-- Below this line is the Parsec parser for css queries.+cssQuery :: Parser [[SelectorGroup]]+cssQuery = sepBy rules (char ',' >> (optional (char ' ')))++rules :: Parser [SelectorGroup]+rules = many $ directChildren <|> deepChildren++directChildren :: Parser SelectorGroup+directChildren = do+ _ <- char '>'+ _ <- char ' '+ sels <- selectors+ _ <- optional $ char ' '+ return $ DirectChildren sels++deepChildren :: Parser SelectorGroup+deepChildren = do + sels <- selectors+ _ <- optional $ char ' '+ return $ DeepChildren sels+ +selectors :: Parser [Selector]+selectors = many1 $ parseId+ <|> parseClass+ <|> parseTag+ <|> parseAttr++parseId :: Parser Selector+parseId = do+ _ <- char '#'+ x <- takeWhile $ flip notElem ",#.[ >"+ return $ ById x++parseClass :: Parser Selector+parseClass = do+ _ <- char '.'+ x <- takeWhile $ flip notElem ",#.[ >"+ return $ ByClass x++parseTag :: Parser Selector+parseTag = do+ x <- takeWhile1 $ flip notElem ",#.[ >"+ return $ ByTagName x++parseAttr :: Parser Selector+parseAttr = do+ _ <- char '['+ name <- takeWhile $ flip notElem ",#.=$^*]"+ (parseAttrExists name)+ <|> (parseAttrWith "=" ByAttrEquals name)+ <|> (parseAttrWith "*=" ByAttrContains name)+ <|> (parseAttrWith "^=" ByAttrStarts name)+ <|> (parseAttrWith "$=" ByAttrEnds name)++parseAttrExists :: Text -> Parser Selector+parseAttrExists attrname = do+ _ <- char ']'+ return $ ByAttrExists attrname++parseAttrWith :: Text -> (Text -> Text -> Selector) -> Text -> Parser Selector+parseAttrWith sign constructor name = do+ _ <- string sign+ value <- takeWhile $ flip notElem ",#.]"+ _ <- char ']'+ return $ constructor name value
+ Yesod/Test/HtmlParse.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Parse an HTML document into xml-conduit's Document.+--+-- Assumes UTF-8 encoding.+module Yesod.Test.HtmlParse+ ( parseHtml+ ) where++import Text.HTML.TagStream+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Text.XML+import Data.Conduit+import qualified Data.Conduit.List as CL+import Data.Functor.Identity (runIdentity)+import Control.Monad.Trans.Resource (runExceptionT)+import Data.XML.Types (Event (..), Content (ContentText))+import Control.Arrow ((***))+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import qualified Data.Set as Set++parseHtml :: L.ByteString -> Either String Document+parseHtml lbs =+ either (Left . show) Right+ $ runIdentity+ $ runExceptionT+ $ CL.sourceList (L.toChunks lbs)+ $$ tokenStream =$ (CL.concatMap toEvent =$ fromEvents)++toEvent :: Token -> [Event]+toEvent (TagOpen bsname bsattrs isClose') =+ EventBeginElement name attrs : if isClose then [EventEndElement name] else []+ where+ name = toName bsname+ attrs = map (toName *** (return . ContentText . decodeUtf8With lenientDecode)) bsattrs+ isClose = isClose' || isVoid bsname+toEvent (TagClose bsname) = [EventEndElement $ toName bsname]+toEvent (Text bs) = [EventContent $ ContentText $ decodeUtf8With lenientDecode bs]+toEvent (Comment bs) = [EventComment $ decodeUtf8With lenientDecode bs]+toEvent Special{} = []+toEvent Incomplete{} = []++toName :: S.ByteString -> Name+toName bs = Name (decodeUtf8With lenientDecode bs) Nothing Nothing++isVoid :: S.ByteString -> Bool+isVoid = flip Set.member $ Set.fromList+ [ "area"+ , "base"+ , "br"+ , "col"+ , "command"+ , "embed"+ , "hr"+ , "img"+ , "input"+ , "keygen"+ , "link"+ , "meta"+ , "param"+ , "source"+ , "track"+ , "wbr"+ ]
Yesod/Test/TransversingCSS.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {- | This module uses HXT to transverse an HTML document using CSS selectors. @@ -31,147 +32,68 @@ -- | These functions expose some low level details that you can blissfully ignore. parseQuery, runQuery,- queryToArrow, Selector(..), SelectorGroup(..) ) where -import Text.XML.HXT.Core-import qualified Data.List as DL-import Text.ParserCombinators.Parsec-import Text.Parsec.Prim (Parsec)+import Yesod.Test.CssQuery+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 = 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 ParseError [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---- | 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" (==v)- ByClass v -> hasAttrValue "class" ((DL.elem v) . words)- ByTagName v -> hasName v- ByAttrExists n -> hasAttr n- ByAttrEquals n v -> hasAttrValue n (==v)- ByAttrContains n v -> hasAttrValue n (DL.isInfixOf v)- ByAttrStarts n v -> hasAttrValue n (DL.isPrefixOf v)- ByAttrEnds n v -> hasAttrValue n (DL.isSuffixOf v)---- | Parses a query into an intermediate format which is easy to feed to HXT------ * The top-level lists represent the top level comma separated queries.------ * SelectorGroup is a group of qualifiers which are separated--- with spaces or > like these three: /table.main.odd tr.even > td.big/------ * A SelectorGroup as a list of Selector items, following the above example--- the selectors in the group are: /table/, /.main/ and /.odd/ -parseQuery :: String -> Either ParseError [[SelectorGroup]]-parseQuery = parse cssQuery "" --data SelectorGroup - = DirectChildren [Selector]- | DeepChildren [Selector]- deriving Show--data Selector- = ById String- | ByClass String- | ByTagName String- | ByAttrExists String- | ByAttrEquals String String- | ByAttrContains String String- | ByAttrStarts String String- | ByAttrEnds String String- deriving Show---- Below this line is the Parsec parser for css queries.-cssQuery :: Parsec String u [[SelectorGroup]]-cssQuery = sepBy rules (char ',' >> (optional (char ' ')))--rules :: Parsec String u [SelectorGroup]-rules = many $ directChildren <|> deepChildren--directChildren :: Parsec String u SelectorGroup-directChildren = do- _ <- char '>'- _ <- char ' '- sels <- selectors- optional $ char ' '- return $ DirectChildren sels--deepChildren :: Parsec String u SelectorGroup-deepChildren = do - sels <- selectors- optional $ char ' '- return $ DeepChildren sels- -selectors :: Parsec String u [Selector]-selectors = many1 $ parseId- <|> parseClass- <|> parseTag- <|> parseAttr--parseId :: Parsec String u Selector-parseId = do- _ <- char '#'- x <- many $ noneOf ",#.[ >"- return $ ById x--parseClass :: Parsec String u Selector-parseClass = do- _ <- char '.'- x <- many $ noneOf ",#.[ >"- return $ ByClass x--parseTag :: Parsec String u Selector-parseTag = do- x <- many1 $ noneOf ",#.[ >"- return $ ByTagName x--parseAttr :: Parsec String u Selector-parseAttr = do- _ <- char '['- name <- many $ noneOf ",#.=$^*]"- (parseAttrExists name)- <|> (parseAttrWith "=" ByAttrEquals name)- <|> (parseAttrWith "*=" ByAttrContains name)- <|> (parseAttrWith "^=" ByAttrStarts name)- <|> (parseAttrWith "$=" ByAttrEnds name)+runQuery :: Cursor -> [[SelectorGroup]] -> [Cursor]+runQuery html query = concatMap (runGroup html) query -parseAttrExists :: String -> Parsec String u Selector-parseAttrExists attrname = do- _ <- char ']'- return $ ByAttrExists attrname+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 -parseAttrWith :: String -> (String -> String -> Selector) -> String -> Parsec String u Selector-parseAttrWith sign constructor name = do- _ <- string sign- value <- many $ noneOf ",#.]"- _ <- char ']'- return $ constructor name value+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
yesod-test.cabal view
@@ -1,13 +1,13 @@ name: yesod-test-version: 0.1-license: BSD3+version: 0.2.0+license: MIT license-file: LICENSE author: Nubis <nubis@woobiz.com.ar> maintainer: Nubis <nubis@woobiz.com.ar> synopsis: integration testing for WAI/Yesod Applications category: Web, Yesod, Testing stability: Experimental-cabal-version: >= 1.6+cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com description: Behaviour Oriented integration Testing for Yesod Applications @@ -22,20 +22,42 @@ else build-depends: base >= 4 && < 4.3 build-depends: hxt >= 9.1.6- , parsec >= 2.1 && < 4- , persistent >= 0.8 && < 0.9- , transformers >= 0.2.2 && < 0.3- , wai >= 1.1 && < 1.2- , wai-test >= 1.0 && < 2.0+ , attoparsec >= 0.10 && < 0.11+ , persistent >= 0.9 && < 0.10+ , transformers >= 0.2.2 && < 0.4+ , wai >= 1.2 && < 1.3+ , wai-test >= 1.2 && < 1.3 , network >= 2.2 && < 2.4 , http-types >= 0.6 && < 0.7 , HUnit >= 1.2 && < 1.3 , hspec >= 0.9 && < 1.0 , bytestring >= 0.9+ , case-insensitive >= 0.2 , text+ , tagstream-conduit >= 0.3 && < 0.4+ , conduit >= 0.4 && < 0.5+ , resourcet >= 0.3 && < 0.4+ , 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- other-modules: Yesod.Test.TransversingCSS+ Yesod.Test.CssQuery+ Yesod.Test.TransversingCSS+ Yesod.Test.HtmlParse ghc-options: -Wall++test-suite test+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: test+ build-depends: base+ , yesod-test+ , hspec >= 0.9 && < 0.10+ , HUnit+ , xml-conduit+ , bytestring source-repository head type: git