yesod-test-1.2.0/0000755000000000000000000000000012140376426012005 5ustar0000000000000000yesod-test-1.2.0/LICENSE0000644000000000000000000000207512140376426013016 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. yesod-test-1.2.0/README.md0000644000000000000000000000600712140376426013267 0ustar0000000000000000# yesod-test Pragmatic integration tests for haskell web applications using WAI and optionally a database (Persistent). It's main goal is to encourage integration and system testing of web applications by making everything /easy to test/. Your tests are like browser sessions that keep track of cookies and the last visited page. You can perform assertions on the content of HTML responses using css selectors. You can also easily build requests using forms present in the current page. This is very useful for testing web applications built in yesod for example, were your forms may have field names generated by the framework or a randomly generated "\_token" field. Your database is also directly available so you can use runDB to set up backend pre-conditions, or to assert that your session is having the desired effect. The testing facilities behind the scenes are HSpec (on top of HUnit). This is the helloworld and kitchen sink. In this case for testing a yesod app. ```haskell import Yesod import Yesod.Static import qualified MySite.Settings as Settings import MySite.Models main :: IO a main = do cfg <- (loadConfig Test) >>= either fail return st <- static Settings.staticDir Settings.withConnectionPool (connStr cfg) $ \cnPool -> do -- ... Perhaps some code here to truncate your test database? app <- toWaiApp $ MyApp st cfg runTests app cnPool $ mySuite mySuite = do describe "Basic navigation and assertions" $ do it "Gets a page that has a form, with auto generated fields and token" $ do get_ "url/of/page/with/form" -- Load a page statusIs 200 -- Assert the status was success bodyContains "Hello Person" -- Assert any part of the document contains some text. -- Perform a css queries and assertions. htmlCount "form .main" 1 -- It matches 1 element htmlAllContain "h1#mainTitle" "Sign Up Now!" -- All matches have some text -- Performs the post using the current page to extract field values: post "url/to/post/to" $ do addNonce -- Add the _nonce field with the currently shown value -- Lookup field by the text on the labels pointing to them. byLabel "Email:" "gustavo@cerati.com" byLabel "Password:" "secret" byLabel "Confirm:" "secret" it "Sends another form, this one has a file" $ do post "url/to/post/file/to" $ do -- You can add files this easy, you still have to provide the mime type manually though. addFile "file_field_name" "path/to/local/file" "image/jpeg" -- And of course you can add any field if you know it's name byName "answer" "42" statusIs 302 describe "Db access, still very raw" $ do it "selects the list" $ do msgs <- testDB $ do (selectList [] [] :: SqlPersist IO [(Key SqlPersist Message, Message)]) assertEqual "One Message in the DB" 1 (DL.length msgs) ``` yesod-test-1.2.0/Setup.lhs0000644000000000000000000000016212140376426013614 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain yesod-test-1.2.0/yesod-test.cabal0000644000000000000000000000475712140376426015106 0ustar0000000000000000name: yesod-test version: 1.2.0 license: MIT license-file: LICENSE author: Nubis maintainer: Nubis , Michael Snoyman synopsis: integration testing for WAI/Yesod Applications category: Web, Yesod, Testing stability: Experimental cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com description: Behaviour Oriented integration Testing for Yesod Applications extra-source-files: README.md, LICENSE, test/main.hs library build-depends: base >= 4.3 && < 5 , attoparsec >= 0.10 , persistent >= 1.0 , transformers >= 0.2.2 , wai >= 1.3 , wai-test >= 1.3 , network >= 2.2 , http-types >= 0.7 , HUnit >= 1.2 , hspec >= 1.4 , bytestring >= 0.9 , case-insensitive >= 0.2 , text , xml-conduit >= 1.0 , xml-types >= 0.3 , containers , html-conduit >= 0.1 , blaze-html >= 0.5 , blaze-markup >= 0.5.1 , pool-conduit , monad-control , time , blaze-builder , cookie , yesod-core >= 1.2 exposed-modules: Yesod.Test Yesod.Test.CssQuery Yesod.Test.TransversingCSS 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 , HUnit , xml-conduit , bytestring , containers , html-conduit , yesod-core , yesod-form , text source-repository head type: git location: git://github.com/yesodweb/yesod.git yesod-test-1.2.0/Yesod/0000755000000000000000000000000012140376426013070 5ustar0000000000000000yesod-test-1.2.0/Yesod/Test.hs0000644000000000000000000005021412140376426014345 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-| Yesod.Test is a pragmatic framework for testing web applications built using wai and persistent. By pragmatic I may also mean 'dirty'. It's main goal is to encourage integration and system testing of web applications by making everything /easy to test/. Your tests are like browser sessions that keep track of cookies and the last visited page. You can perform assertions on the content of HTML responses, using css selectors to explore the document more easily. You can also easily build requests using forms present in the current page. This is very useful for testing web applications built in yesod for example, were your forms may have field names generated by the framework or a randomly generated '_nonce' field. Your database is also directly available so you can use runDBRunner to set up backend pre-conditions, or to assert that your session is having the desired effect. -} module Yesod.Test ( -- * Declaring and running your test suite yesodSpec , YesodSpec , YesodExample , YesodSpecTree (..) , ydescribe , yit -- * Making requests -- | To make a request you need to point to an url and pass in some parameters. -- -- To build your parameters you will use the RequestBuilder monad that lets you -- add values, add files, lookup fields by label and find the current -- nonce value and add it to your request too. -- , get , post , request , addRequestHeader , setMethod , addPostParam , addGetParam , addFile , RequestBuilder , setUrl -- | Yesod can auto generate field ids, so you are never sure what -- the argument name should be for each one of your args when constructing -- your requests. What you do know is the /label/ of the field. -- These functions let you add parameters to your request based -- on currently displayed label names. , byLabel , fileByLabel -- | Does the current form have a _nonce? Use any of these to add it to your -- request parameters. , addNonce , addNonce_ -- * Assertions , assertEqual , assertHeader , assertNoHeader , statusIs , bodyEquals , bodyContains , htmlAllContain , htmlAnyContain , htmlCount -- * Grab information , getTestYesod , getResponse -- * Debug output , printBody , printMatches -- * Utils for building your own assertions -- | Please consider generalizing and contributing the assertions you write. , htmlQuery , parseHTML , withResponse ) where import qualified Test.Hspec as Hspec import qualified Test.Hspec.Core as Core import qualified Data.List as DL import qualified Data.ByteString.Char8 as BS8 import Data.ByteString (ByteString) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.ByteString.Lazy.Char8 as BSL8 import qualified Test.HUnit as HUnit import qualified Network.HTTP.Types as H import qualified Network.Socket.Internal as Sock import Data.CaseInsensitive (CI) import Network.Wai import Network.Wai.Test hiding (assertHeader, assertNoHeader, request) import qualified Control.Monad.Trans.State as ST import Control.Monad.IO.Class import System.IO import Yesod.Test.TransversingCSS import Yesod.Core import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) import Text.XML.Cursor hiding (element) import qualified Text.XML.Cursor as C import qualified Text.HTML.DOM as HD import Control.Monad.Trans.Writer import qualified Data.Map as M import qualified Web.Cookie as Cookie import qualified Blaze.ByteString.Builder as Builder import Data.Time.Clock (getCurrentTime) -- | The state used in a single test case defined using 'yit' -- -- Since 1.2.0 data YesodExampleData site = YesodExampleData { yedApp :: !Application , yedSite :: !site , yedCookies :: !Cookies , yedResponse :: !(Maybe SResponse) } -- | A single test case, to be run with 'yit'. -- -- Since 1.2.0 type YesodExample site = ST.StateT (YesodExampleData site) IO -- | Mapping from cookie name to value. -- -- Since 1.2.0 type Cookies = M.Map ByteString Cookie.SetCookie -- | Corresponds to hspec\'s 'Spec'. -- -- Since 1.2.0 type YesodSpec site = Writer [YesodSpecTree site] () -- | Internal data structure, corresponding to hspec\'s 'YesodSpecTree'. -- -- Since 1.2.0 data YesodSpecTree site = YesodSpecGroup String [YesodSpecTree site] | YesodSpecItem String (YesodExample site ()) -- | Get the foundation value used for the current test. -- -- Since 1.2.0 getTestYesod :: YesodExample site site getTestYesod = fmap yedSite ST.get -- | Get the most recently provided response value, if available. -- -- Since 1.2.0 getResponse :: YesodExample site (Maybe SResponse) getResponse = fmap yedResponse ST.get data RequestBuilderData site = RequestBuilderData { rbdPosts :: [RequestPart] , rbdResponse :: (Maybe SResponse) , rbdMethod :: H.Method , rbdSite :: site , rbdPath :: [T.Text] , rbdGets :: H.Query , rbdHeaders :: H.RequestHeaders } -- | Request parts let us discern regular key/values from files sent in the request. data RequestPart = ReqPlainPart T.Text T.Text | ReqFilePart T.Text FilePath BSL8.ByteString T.Text -- | The RequestBuilder state monad constructs an url encoded string of arguments -- to send with your requests. Some of the functions that run on it use the current -- response to analize the forms that the server is expecting to receive. type RequestBuilder site = ST.StateT (RequestBuilderData site) IO -- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application' -- and 'ConnectionPool' ydescribe :: String -> YesodSpec site -> YesodSpec site ydescribe label yspecs = tell [YesodSpecGroup label $ execWriter yspecs] yesodSpec :: YesodDispatch site => site -> YesodSpec site -> Hspec.Spec yesodSpec site yspecs = Core.fromSpecList $ map unYesod $ execWriter yspecs where unYesod (YesodSpecGroup x y) = Core.SpecGroup x $ map unYesod y unYesod (YesodSpecItem x y) = Core.it x $ do app <- toWaiAppPlain site ST.evalStateT y YesodExampleData { yedApp = app , yedSite = site , yedCookies = M.empty , yedResponse = Nothing } -- | Describe a single test that keeps cookies, and a reference to the last response. yit :: String -> YesodExample site () -> YesodSpec site yit label example = tell [YesodSpecItem label example] -- Performs a given action using the last response. Use this to create -- response-level assertions withResponse' :: MonadIO m => (state -> Maybe SResponse) -> (SResponse -> ST.StateT state m a) -> ST.StateT state m a withResponse' getter f = maybe err f . getter =<< ST.get where err = failure "There was no response, you should make a request" -- | Performs a given action using the last response. Use this to create -- response-level assertions withResponse :: (SResponse -> YesodExample site a) -> YesodExample site a withResponse = withResponse' yedResponse -- | Use HXT to parse a value from an html tag. -- Check for usage examples in this module's source. parseHTML :: HtmlLBS -> Cursor parseHTML html = fromDocument $ HD.parseLBS html -- | Query the last response using css selectors, returns a list of matched fragments htmlQuery' :: MonadIO m => (state -> Maybe SResponse) -> Query -> ST.StateT state m [HtmlLBS] htmlQuery' getter query = withResponse' getter $ \ res -> case findBySelector (simpleBody res) query of Left err -> failure $ query <> " did not parse: " <> T.pack (show err) Right matches -> return $ map (encodeUtf8 . TL.pack) matches -- | Query the last response using css selectors, returns a list of matched fragments htmlQuery :: Query -> YesodExample site [HtmlLBS] htmlQuery = htmlQuery' yedResponse -- | Asserts that the two given values are equal. assertEqual :: (Eq a) => String -> a -> a -> YesodExample site () assertEqual msg a b = liftIO $ HUnit.assertBool msg (a == b) -- | Assert the last response status is as expected. statusIs :: Int -> YesodExample site () statusIs number = withResponse $ \ SResponse { simpleStatus = s } -> liftIO $ flip HUnit.assertBool (H.statusCode s == number) $ concat [ "Expected status was ", show number , " but received status was ", show $ H.statusCode s ] -- | Assert the given header key/value pair was returned. assertHeader :: CI BS8.ByteString -> BS8.ByteString -> YesodExample site () assertHeader header value = withResponse $ \ SResponse { simpleHeaders = h } -> case lookup header h of Nothing -> failure $ T.pack $ 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 :: CI BS8.ByteString -> YesodExample site () assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } -> case lookup header h of Nothing -> return () Just s -> failure $ T.pack $ 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 :: String -> YesodExample site () 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 :: String -> YesodExample site () bodyContains text = withResponse $ \ res -> liftIO $ HUnit.assertBool ("Expected body to contain " ++ text) $ (simpleBody res) `contains` text contains :: BSL8.ByteString -> String -> Bool contains a b = DL.isInfixOf b (BSL8.unpack a) -- | Queries the html using a css selector, and all matched elements must contain -- the given string. htmlAllContain :: Query -> String -> YesodExample site () htmlAllContain query search = do matches <- htmlQuery query case matches of [] -> failure $ "Nothing matched css query: " <> query _ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search) $ DL.all (DL.isInfixOf search) (map (TL.unpack . decodeUtf8) matches) -- | Queries the html using a css selector, and passes if any matched -- element contains the given string. -- -- Since 0.3.5 htmlAnyContain :: Query -> String -> YesodExample site () htmlAnyContain query search = do matches <- htmlQuery query case matches of [] -> failure $ "Nothing matched css query: " <> query _ -> liftIO $ HUnit.assertBool ("None of "++T.unpack query++" contain "++search) $ DL.any (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. htmlCount :: Query -> Int -> YesodExample site () htmlCount query count = do matches <- fmap DL.length $ htmlQuery query liftIO $ flip HUnit.assertBool (matches == count) ("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 :: YesodExample site () printBody = withResponse $ \ SResponse { simpleBody = b } -> liftIO $ hPutStrLn stderr $ BSL8.unpack b -- | Performs a CSS query and print the matches to stderr. printMatches :: Query -> YesodExample site () printMatches query = do matches <- htmlQuery query liftIO $ hPutStrLn stderr $ show matches -- | Add a parameter with the given name and value. addPostParam :: T.Text -> T.Text -> RequestBuilder site () addPostParam name value = ST.modify $ \rbd -> rbd { rbdPosts = ReqPlainPart name value : rbdPosts rbd } addGetParam :: T.Text -> T.Text -> RequestBuilder site () addGetParam name value = ST.modify $ \rbd -> rbd { rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value) : rbdGets rbd } -- | Add a file to be posted with the current request -- -- Adding a file will automatically change your request content-type to be multipart/form-data addFile :: T.Text -> FilePath -> T.Text -> RequestBuilder site () addFile name path mimetype = do contents <- liftIO $ BSL8.readFile path ST.modify $ \rbd -> rbd { rbdPosts = ReqFilePart name path contents mimetype : rbdPosts rbd } -- This looks up the name of a field based on the contents of the label pointing to it. nameFromLabel :: T.Text -> RequestBuilder site T.Text nameFromLabel label = do mres <- fmap rbdResponse ST.get res <- case mres of Nothing -> failure "nameFromLabel: No response available" Just res -> return res let body = simpleBody res mfor = parseHTML body $// C.element "label" >=> contentContains label >=> attribute "for" contentContains x c | x `T.isInfixOf` T.concat (c $// content) = [c] | otherwise = [] case mfor of for:[] -> do let mname = parseHTML body $// attributeIs "id" for >=> attribute "name" case mname of "":_ -> failure $ T.concat [ "Label " , label , " resolved to id " , for , " which was not found. " ] name:_ -> return name _ -> failure $ "More than one input with id " <> for [] -> failure $ "No label contained: " <> label _ -> failure $ "More than one label contained " <> label (<>) :: T.Text -> T.Text -> T.Text (<>) = T.append byLabel :: T.Text -> T.Text -> RequestBuilder site () byLabel label value = do name <- nameFromLabel label addPostParam name value fileByLabel :: T.Text -> FilePath -> T.Text -> RequestBuilder site () fileByLabel label path mime = do name <- nameFromLabel label addFile name path mime -- | 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_ :: Query -> RequestBuilder site () addNonce_ scope = do matches <- htmlQuery' rbdResponse $ scope <> "input[name=_token][type=hidden][value]" case matches of [] -> failure $ "No nonce found in the current page" element:[] -> addPostParam "_token" $ head $ attribute "value" $ parseHTML element _ -> failure $ "More than one nonce found in the page" -- | For responses that display a single form, just lookup the only nonce available. addNonce :: RequestBuilder site () addNonce = addNonce_ "" -- | Perform a POST request to url post :: (Yesod site, RedirectUrl site url) => url -> YesodExample site () post url = request $ do setMethod "POST" setUrl url -- | Perform a GET request to url, using params get :: (Yesod site, RedirectUrl site url) => url -> YesodExample site () get url = request $ do setMethod "GET" setUrl url setMethod :: H.Method -> RequestBuilder site () setMethod m = ST.modify $ \rbd -> rbd { rbdMethod = m } setUrl :: (Yesod site, RedirectUrl site url) => url -> RequestBuilder site () setUrl url' = do site <- fmap rbdSite ST.get eurl <- runFakeHandler M.empty (const $ error "Yesod.Test: No logger available") site (toTextUrl url') url <- either (error . show) return eurl let (urlPath, urlQuery) = T.break (== '?') url ST.modify $ \rbd -> rbd { rbdPath = case DL.filter (/="") $ T.split (== '/') urlPath of ("http:":_:rest) -> rest ("https:":_:rest) -> rest x -> x , rbdGets = rbdGets rbd ++ H.parseQuery (TE.encodeUtf8 urlQuery) } addRequestHeader :: H.Header -> RequestBuilder site () addRequestHeader header = ST.modify $ \rbd -> rbd { rbdHeaders = header : rbdHeaders rbd } -- | General interface to performing requests, allowing you to add extra -- headers as well as letting you specify the request method. request :: Yesod site => RequestBuilder site () -> YesodExample site () request reqBuilder = do YesodExampleData app site oldCookies mRes <- ST.get RequestBuilderData {..} <- liftIO $ ST.execStateT reqBuilder RequestBuilderData { rbdPosts = [] , rbdResponse = mRes , rbdMethod = "GET" , rbdSite = site , rbdPath = [] , rbdGets = [] , rbdHeaders = [] } let path = T.cons '/' $ T.intercalate "/" rbdPath -- expire cookies and filter them for the current path. TODO: support max age currentUtc <- liftIO getCurrentTime let cookies = M.filter (checkCookieTime currentUtc) oldCookies cookiesForPath = M.filter (checkCookiePath path) cookies let maker | DL.any isFile rbdPosts = makeMultipart | otherwise = makeSinglepart req = maker cookiesForPath rbdPosts rbdMethod rbdHeaders path rbdGets response <- liftIO $ runSession (srequest req) app let newCookies = map (Cookie.parseSetCookie . snd) $ DL.filter (("Set-Cookie"==) . fst) $ simpleHeaders response cookies' = M.fromList [(Cookie.setCookieName c, c) | c <- newCookies] `M.union` cookies ST.put $ YesodExampleData app site cookies' (Just response) where isFile (ReqFilePart _ _ _ _) = True isFile _ = False checkCookieTime t c = case Cookie.setCookieExpires c of Nothing -> True Just t' -> t < t' checkCookiePath url c = case Cookie.setCookiePath c of Nothing -> True Just x -> x `BS8.isPrefixOf` TE.encodeUtf8 url -- For building the multi-part requests boundary :: String boundary = "*******noneedtomakethisrandom" separator = BS8.concat ["--", BS8.pack boundary, "\r\n"] makeMultipart cookies parts method extraHeaders urlPath urlQuery = flip SRequest (BSL8.fromChunks [multiPartBody parts]) $ mkRequest [ ("Cookie", Builder.toByteString $ Cookie.renderCookies [(Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies]) , ("Content-Type", BS8.pack $ "multipart/form-data; boundary=" ++ boundary) ] method extraHeaders urlPath urlQuery multiPartBody parts = BS8.concat $ separator : [BS8.concat [multipartPart p, separator] | p <- parts] multipartPart (ReqPlainPart k v) = BS8.concat [ "Content-Disposition: form-data; " , "name=\"", TE.encodeUtf8 k, "\"\r\n\r\n" , TE.encodeUtf8 v, "\r\n"] multipartPart (ReqFilePart k v bytes mime) = BS8.concat [ "Content-Disposition: form-data; " , "name=\"", TE.encodeUtf8 k, "\"; " , "filename=\"", BS8.pack v, "\"\r\n" , "Content-Type: ", TE.encodeUtf8 mime, "\r\n\r\n" , BS8.concat $ BSL8.toChunks bytes, "\r\n"] -- For building the regular non-multipart requests makeSinglepart cookies parts method extraHeaders urlPath urlQuery = SRequest (mkRequest [ ("Cookie", Builder.toByteString $ Cookie.renderCookies [(Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies]) , ("Content-Type", "application/x-www-form-urlencoded") ] method extraHeaders urlPath urlQuery) $ BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" $ map singlepartPart parts singlepartPart (ReqFilePart _ _ _ _) = "" singlepartPart (ReqPlainPart k v) = T.concat [k,"=",v] -- General request making mkRequest headers method extraHeaders urlPath urlQuery = defaultRequest { requestMethod = method , remoteHost = Sock.SockAddrInet 1 2 , requestHeaders = headers ++ extraHeaders , rawPathInfo = TE.encodeUtf8 urlPath , pathInfo = DL.filter (/="") $ T.split (== '/') urlPath , rawQueryString = H.renderQuery False urlQuery , queryString = urlQuery } -- Yes, just a shortcut failure :: (MonadIO a) => T.Text -> a b failure reason = (liftIO $ HUnit.assertFailure $ T.unpack reason) >> error "" yesod-test-1.2.0/Yesod/Test/0000755000000000000000000000000012140376426014007 5ustar0000000000000000yesod-test-1.2.0/Yesod/Test/CssQuery.hs0000644000000000000000000000541712140376426016130 0ustar0000000000000000{-# 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-1.2.0/Yesod/Test/TransversingCSS.hs0000644000000000000000000000600212140376426017377 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {- | This module uses HXT to transverse an HTML document using CSS selectors. The most important function here is 'findBySelector', it takes a CSS query and a string containing the HTML to look into, 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/ * Get jiggy with it: /div[data-attr=yeah] > .mon, .foo.bar div, #oneThing/ -} module Yesod.Test.TransversingCSS ( findBySelector, HtmlLBS, Query, -- * For HXT hackers -- | These functions expose some low level details that you can blissfully ignore. parseQuery, runQuery, Selector(..), SelectorGroup(..) ) 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 import qualified Text.HTML.DOM as HD import Text.Blaze.Html (toHtml) import Text.Blaze.Html.Renderer.String (renderHtml) type Query = T.Text type HtmlLBS = L.ByteString -- | Perform a css 'Query' on 'Html'. Returns Either -- -- * Left: Query parse error. -- -- * Right: List of matching Html fragments. findBySelector :: HtmlLBS -> Query -> Either String [String] findBySelector html query = (\x -> map (renderHtml . toHtml . node) . runQuery x) <$> (Right $ fromDocument $ HD.parseLBS html) <*> parseQuery query -- Run a compiled query on Html, returning a list of matching Html fragments. runQuery :: Cursor -> [[SelectorGroup]] -> [Cursor] runQuery html query = concatMap (runGroup html) query 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 yesod-test-1.2.0/test/0000755000000000000000000000000012140376426012764 5ustar0000000000000000yesod-test-1.2.0/test/main.hs0000644000000000000000000001221312140376426014243 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} import Test.HUnit hiding (Test) import Test.Hspec import Yesod.Core import Yesod.Form import Yesod.Test import Yesod.Test.CssQuery import Yesod.Test.TransversingCSS import Text.XML import Data.Text (Text) import Data.Monoid ((<>)) import Control.Applicative import Data.ByteString.Lazy.Char8 () import qualified Data.Map as Map import qualified Text.HTML.DOM as HD parseQuery_ = either error id . parseQuery findBySelector_ x = either error id . findBySelector x parseHtml_ = HD.parseLBS main :: IO () main = hspec $ do describe "CSS selector parsing" $ do it "elements" $ parseQuery_ "strong" @?= [[DeepChildren [ByTagName "strong"]]] it "child elements" $ parseQuery_ "strong > i" @?= [[DeepChildren [ByTagName "strong"], DirectChildren [ByTagName "i"]]] it "comma" $ parseQuery_ "strong.bar, #foo" @?= [[DeepChildren [ByTagName "strong", ByClass "bar"]], [DeepChildren [ById "foo"]]] describe "find by selector" $ do it "XHTML" $ let html = "foo

Hello World

" query = "body > p" in findBySelector_ html query @?= ["

Hello World

"] it "HTML" $ let html = "foo

Hello World

" query = "body > p" in findBySelector_ html query @?= ["

Hello World

"] describe "HTML parsing" $ do it "XHTML" $ let html = "foo

Hello World

" doc = Document (Prologue [] Nothing []) root [] root = Element "html" Map.empty [ NodeElement $ Element "head" Map.empty [ NodeElement $ Element "title" Map.empty [NodeContent "foo"] ] , NodeElement $ Element "body" Map.empty [ NodeElement $ Element "p" Map.empty [NodeContent "Hello World"] ] ] in parseHtml_ html @?= doc it "HTML" $ let html = "foo

Hello World

" doc = Document (Prologue [] Nothing []) root [] root = Element "html" Map.empty [ NodeElement $ Element "head" Map.empty [ NodeElement $ Element "title" Map.empty [NodeContent "foo"] ] , NodeElement $ Element "body" Map.empty [ NodeElement $ Element "br" Map.empty [] , NodeElement $ Element "p" Map.empty [NodeContent "Hello World"] ] ] in parseHtml_ html @?= doc describe "basic usage" $ yesodSpec app $ do ydescribe "tests1" $ do yit "tests1a" $ do get ("/" :: Text) statusIs 200 bodyEquals "Hello world!" yit "tests1b" $ do get ("/foo" :: Text) statusIs 404 ydescribe "tests2" $ do yit "type-safe URLs" $ do get $ LiteAppRoute [] statusIs 200 yit "type-safe URLs with query-string" $ do get (LiteAppRoute [], [("foo", "bar")]) statusIs 200 bodyEquals "foo=bar" yit "post params" $ do post ("/post" :: Text) statusIs 500 request $ do setMethod "POST" setUrl $ LiteAppRoute ["post"] addPostParam "foo" "foobarbaz" statusIs 200 bodyEquals "foobarbaz" yit "labels" $ do get ("/form" :: Text) statusIs 200 request $ do setMethod "POST" setUrl ("/form" :: Text) byLabel "Some Label" "12345" fileByLabel "Some File" "test/main.hs" "text/plain" addNonce statusIs 200 bodyEquals "12345" instance RenderMessage LiteApp FormMessage where renderMessage _ _ = defaultFormMessage app :: LiteApp app = liteApp $ do dispatchTo $ do mfoo <- lookupGetParam "foo" case mfoo of Nothing -> return "Hello world!" Just foo -> return $ "foo=" <> foo onStatic "post" $ dispatchTo $ do mfoo <- lookupPostParam "foo" case mfoo of Nothing -> error "No foo" Just foo -> return foo onStatic "form" $ dispatchTo $ do ((mfoo, widget), _) <- runFormPost $ renderDivs $ (,) <$> areq textField "Some Label" Nothing <*> areq fileField "Some File" Nothing case mfoo of FormSuccess (foo, _) -> return $ toHtml foo _ -> defaultLayout widget