diff --git a/Yesod/Test.hs b/Yesod/Test.hs --- a/Yesod/Test.hs +++ b/Yesod/Test.hs @@ -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" diff --git a/Yesod/Test/CssQuery.hs b/Yesod/Test/CssQuery.hs new file mode 100644 --- /dev/null +++ b/Yesod/Test/CssQuery.hs @@ -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 diff --git a/Yesod/Test/HtmlParse.hs b/Yesod/Test/HtmlParse.hs new file mode 100644 --- /dev/null +++ b/Yesod/Test/HtmlParse.hs @@ -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" + ] diff --git a/Yesod/Test/TransversingCSS.hs b/Yesod/Test/TransversingCSS.hs --- a/Yesod/Test/TransversingCSS.hs +++ b/Yesod/Test/TransversingCSS.hs @@ -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 diff --git a/yesod-test.cabal b/yesod-test.cabal --- a/yesod-test.cabal +++ b/yesod-test.cabal @@ -1,13 +1,13 @@ name: yesod-test -version: 0.1 -license: BSD3 +version: 0.2.0 +license: MIT license-file: LICENSE author: Nubis maintainer: Nubis 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