From b13a3d38580af32c24b701277564b56e0d7107ba Mon Sep 17 00:00:00 2001 From: Nubis Date: Sun, 15 Jan 2012 19:05:46 +0800 Subject: [PATCH] integrated yesod tests to scaffolder. still work in progress --- package-list.sh | 3 +- yesod-test/LICENSE | 25 ++ yesod-test/README | 0 yesod-test/Setup.lhs | 7 + yesod-test/Yesod/Test.hs | 392 +++++++++++++++++++++++ yesod-test/Yesod/Test/TransversingCSS.hs | 177 ++++++++++ yesod-test/yesod-test.cabal | 40 +++ yesod/Scaffolding/Scaffolder.hs | 9 +- yesod/input/use-tests.cg | 6 + yesod/scaffold/Tests.hs.cg | 37 +++ yesod/scaffold/project.cabal.cg | 2 +- 11 files changed, 695 insertions(+), 3 deletions(-) create mode 100644 yesod-test/LICENSE create mode 100644 yesod-test/README create mode 100755 yesod-test/Setup.lhs create mode 100644 yesod-test/Yesod/Test.hs create mode 100644 yesod-test/Yesod/Test/TransversingCSS.hs create mode 100644 yesod-test/yesod-test.cabal create mode 100644 yesod/input/use-tests.cg create mode 100644 yesod/scaffold/Tests.hs.cg diff --git a/package-list.sh b/package-list.sh index c461efb3..a9b56aa6 100644 --- a/package-list.sh +++ b/package-list.sh @@ -10,4 +10,5 @@ pkgs=( ./yesod-routes ./yesod-auth ./yesod-sitemap ./yesod-default - ./yesod ) + ./yesod + ./yesod-test ) diff --git a/yesod-test/LICENSE b/yesod-test/LICENSE new file mode 100644 index 00000000..243990d1 --- /dev/null +++ b/yesod-test/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2010, Nubis. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/yesod-test/README b/yesod-test/README new file mode 100644 index 00000000..e69de29b diff --git a/yesod-test/Setup.lhs b/yesod-test/Setup.lhs new file mode 100755 index 00000000..06e2708f --- /dev/null +++ b/yesod-test/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs new file mode 100644 index 00000000..d15b310d --- /dev/null +++ b/yesod-test/Yesod/Test.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-| +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 runDB to set up +backend pre-conditions, or to assert that your session is having the desired effect. + +This is the helloworld and kitchen sink. In this case for testing a yesod app. + +> 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 $ S4M 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 nonce" $ do +> doGet_ "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 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: +> doPost "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 +> doPost "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 "rubs the lotion on it's skin or else it gets the hose again" $ do +> msgs <- testDB $ do (selectList [] [] :: SqlPersist IO [(Key SqlPersist Message, Message)]) +> assertEqual "One Message in the DB" 1 (DL.length msgs) + +-} + +module Yesod.Test ( + -- * Declaring and running your test suite + runTests, describe, it, + + -- * 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. + doPost, doPost_, doGet, doGet_, doRequest, + byName, byLabel, addFile, addNonce, addNonce_, + + -- * Running database queries + testDB, + + -- * Assertions + assertEqual, statusIs, 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 + +) + +where + +import qualified Test.Hspec.Core as Core +import qualified Test.Hspec.Runner as Runner +import qualified Data.List as DL +import qualified Data.Maybe as DY +import qualified Data.ByteString.Char8 as BS8 +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 Test.Hspec.HUnit () +import qualified Network.HTTP.Types as H +import qualified Network.Socket.Internal as Sock +import Text.XML.HXT.Core hiding (app, err, txt) +import Network.Wai +import Network.Wai.Test +import Control.Monad.Trans.State (get, put, execStateT, StateT) +import "monads-tf" Control.Monad.Trans +import System.IO +import Yesod.Test.TransversingCSS +import Database.Persist.GenericSql + +-- | The state used in 'describe' to build a list of specs +data SpecsData = SpecsData Application ConnectionPool [Core.Spec] + +-- | The specs state monad is where 'describe' runs. +type Specs = StateT SpecsData IO () + +-- | The state used in a single test case defined using 'it' +data OneSpecData = OneSpecData Application ConnectionPool CookieValue (Maybe SResponse) + +-- | The OneSpec state monad is where 'it' runs. +type OneSpec = StateT OneSpecData IO + +data RequestBuilderData = RequestBuilderData [RequestPart] (Maybe SResponse) + +-- | Request parts let us discern regular key/values from files sent in the request. +data RequestPart + = ReqPlainPart String String + | ReqFilePart String FilePath BSL8.ByteString String + +-- | 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 = StateT RequestBuilderData IO + +-- | Both the OneSpec and RequestBuilder monads hold a response that can be analized, +-- by making them instances of this class we can have general methods that work on +-- the last received response. +class HoldsResponse a where + readResponse :: a -> Maybe SResponse +instance HoldsResponse OneSpecData where + readResponse (OneSpecData _ _ _ x) = x +instance HoldsResponse RequestBuilderData where + readResponse (RequestBuilderData _ x) = x + +type CookieValue = H.Ascii + +-- | Runs your test suite, using you wai 'Application' and 'ConnectionPool' for performing +-- the database queries in your tests. +-- +-- You application may already have your connection pool but you need to pass another one +-- separately here. +-- +-- Look at the examples directory on this package to get an idea of the (small) amount of +-- boilerplate code you'll need to write before calling this. +runTests :: Application -> ConnectionPool -> Specs -> IO a +runTests app connection specsDef = do + (SpecsData _ _ specs) <- execStateT specsDef (SpecsData app connection []) + Runner.hspecX specs + +-- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application' +-- and 'ConnectionPool' +describe :: String -> Specs -> Specs +describe label action = do + sData <- get + SpecsData app conn specs <- liftIO $ execStateT action sData + put $ SpecsData app conn (Core.describe label [specs]) + +-- | Describe a single test that keeps cookies, and a reference to the last response. +it :: String -> OneSpec () -> Specs +it label action = do + SpecsData app conn specs <- get + let spec = Core.it label $ do + _ <- execStateT action $ OneSpecData app conn "" Nothing + return () + put $ SpecsData app conn (specs++spec) + +-- Performs a given action using the last response. +withResponse :: HoldsResponse a => b -> (SResponse -> StateT a IO b) -> StateT a IO b +withResponse e f = maybe err f =<< fmap readResponse get + where + err = do + liftIO $ HUnit.assertFailure "There was no response, you should make a request" + return e + +-- | 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 + +-- | Query the last response using css selectors, returns a list of matched fragments +htmlQuery :: HoldsResponse a => Query -> StateT a IO [Html] +htmlQuery query = withResponse [] $ \ res -> + case findBySelector (BSL8.unpack $ simpleBody res) query of + Left err -> do + liftIO $ HUnit.assertFailure $ query ++ " did not parse: " ++ (show err) + return [] + Right matches -> return matches + +-- | Asserts that the two given values are equal. +assertEqual :: (Eq a) => String -> a -> a -> OneSpec () +assertEqual msg a b = liftIO $ HUnit.assertBool msg (a == b) + +-- | Assert the last response status is as expected. +statusIs :: HoldsResponse a => Int -> StateT a IO () +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 last response has the given text. The check is performed using the response +-- body in full text form. +bodyContains :: HoldsResponse a => String -> StateT a IO () +bodyContains txt = withResponse () $ \ res -> + liftIO $ HUnit.assertBool ("Expected body to contain " ++ txt) $ (simpleBody res) `contains` txt +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 :: HoldsResponse a => Query -> String -> StateT a IO () +htmlAllContain query search = do + matches <- htmlQuery query + case matches of + [] -> liftIO $ HUnit.assertFailure $ "Nothing matched css query: "++query + _ -> liftIO $ HUnit.assertBool ("Not all "++query++" contain "++search) $ + DL.all (DL.isInfixOf search) matches + +-- | Performs a css query on the last response and asserts the matched elements +-- are as many as expected. +htmlCount :: HoldsResponse a => Query -> Int -> StateT a IO () +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)) + +-- | Outputs the last response body to stderr (So it doesn't get captured by HSpec) +printBody :: HoldsResponse a => StateT a IO () +printBody = withResponse () $ \ SResponse { simpleBody = b } -> + liftIO $ hPutStrLn stderr $ BSL8.unpack b + +-- | Performs a CSS query and print the matches to stderr. +printMatches :: HoldsResponse a => Query -> StateT a IO () +printMatches query = do + matches <- htmlQuery query + liftIO $ hPutStrLn stderr $ show matches + +-- | Add a parameter with the given name and value. +byName :: String -> String -> RequestBuilder () +byName name value = do + RequestBuilderData parts r <- get + put $ RequestBuilderData ((ReqPlainPart name value):parts) r + +-- | 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 :: String -> FilePath -> String -> RequestBuilder () +addFile name path mimetype = do + RequestBuilderData parts r <- get + contents <- liftIO $ BSL8.readFile path + put $ RequestBuilderData ((ReqFilePart name path contents mimetype):parts) r + +-- | Some frameworks like Yesod cat 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. This looks up a label +-- and adds a parameter for the field name that label is pointing to. +-- +-- If the label or field it points to are not found its treated as a faild Hspec assertion. +byLabel :: String -> String -> RequestBuilder () +byLabel label value = withResponse () $ \ res -> do + let + body = BSL8.unpack $ simpleBody res + mfor = parseHTML body $ deep $ + hasName "label" >>> filterA (getChildren >>> hasText (DL.isInfixOf label)) >>> getAttrValue "for" + + case mfor of + for:[] -> do + let mname = parseHTML body $ deep $ hasAttrValue "id" (==for) >>> getAttrValue "name" + case mname of + "":_ -> liftIO $ HUnit.assertFailure $ + "Label "++label++" resolved to id "++for++" which was not found. " + name:_ -> byName name value + _ -> liftIO $ HUnit.assertFailure $ "More than one input with id " ++ for + [] -> liftIO $ HUnit.assertFailure $ "No label contained: "++label + _ -> liftIO $ HUnit.assertFailure $ "More than one label contained "++label + +-- | Useful for yesod testing: Lookup a _nonce form field and add it's value to the params +-- being built. Receives a selector that should point to the form containing the desired nonce. +addNonce_ :: String -> RequestBuilder () +addNonce_ scope = do + matches <- htmlQuery $ scope ++ "input[name=_nonce][type=hidden][value]" + case matches of + [] -> liftIO $ HUnit.assertFailure $ "No nonce found in the current page" + element:[] -> byName "_nonce" $ head $ parseHTML element $ getAttrValue "value" + _ -> liftIO $ HUnit.assertFailure $ "More than one nonce found in the page" + +-- | For responses that display a single form, lookup the current Nonce on the page and +-- add it to the params being built +addNonce :: RequestBuilder () +addNonce = addNonce_ "" + +-- | Perform a POST request to url, using params +doPost :: BS8.ByteString -> RequestBuilder () -> OneSpec () +doPost url paramsBuild = do + doRequest "POST" url paramsBuild + +-- | Perform a POST request without params +doPost_ :: BS8.ByteString -> OneSpec () +doPost_ = flip doPost $ return () + +-- | Perform a GET request to url, using params +doGet :: BS8.ByteString -> RequestBuilder () -> OneSpec () +doGet url paramsBuild = doRequest "GET" url paramsBuild + +-- | Perform a GET request without params +doGet_ :: BS8.ByteString -> OneSpec () +doGet_ = flip doGet $ return () + +-- | General interface to performing requests, letting you specify the request method and extra headers. +doRequest :: H.Method -> BS8.ByteString -> RequestBuilder a -> OneSpec () +doRequest method url paramsBuild = do + OneSpecData app conn cookie mRes <- get + RequestBuilderData parts _ <- liftIO $ execStateT paramsBuild $ RequestBuilderData [] mRes + let req = if DL.any isFile parts + then makeMultipart cookie parts + else makeSinglepart cookie parts + + response <- liftIO $ runSession (srequest req) app + let cookie' = DY.fromMaybe cookie $ fmap snd $ DL.find (("Set-Cookie"==) . fst) $ simpleHeaders response + put $ OneSpecData app conn cookie' (Just response) + where + isFile (ReqFilePart _ _ _ _) = True + isFile _ = False + + -- For building the multi-part requests + boundary :: String + boundary = "*******noneedtomakethisrandom" + separator = BS8.concat ["--", BS8.pack boundary, "\r\n"] + makeMultipart cookie parts = + flip SRequest (BSL8.fromChunks [multiPartBody parts]) $ mkRequest + [ ("Cookie", cookie) + , ("Content-Type", BS8.pack $ "multipart/form-data; boundary=" ++ boundary)] + multiPartBody parts = BS8.concat $ separator : [BS8.concat [multipartPart p, separator] | p <- parts] + multipartPart (ReqPlainPart k v) = BS8.concat + [ "Content-Disposition: form-data; " + , "name=\"", (BS8.pack k), "\"\r\n\r\n" + , (BS8.pack v), "\r\n"] + multipartPart (ReqFilePart k v bytes mime) = BS8.concat + [ "Content-Disposition: form-data; " + , "name=\"", BS8.pack k, "\"; " + , "filename=\"", BS8.pack v, "\"\r\n" + , "Content-Type: ", BS8.pack mime, "\r\n\r\n" + , BS8.concat $ BSL8.toChunks bytes, "\r\n"] + + -- For building the regular non-multipart requests + makeSinglepart cookie parts = + SRequest (mkRequest [("Cookie",cookie), ("Content-Type", "application/x-www-form-urlencoded")]) $ + BSL8.pack $ DL.concat $ DL.intersperse "&" $ map singlepartPart parts + singlepartPart (ReqFilePart _ _ _ _) = "" + singlepartPart (ReqPlainPart k v) = concat [k,"=",v] + + -- General request making + mkRequest headers = defaultRequest + { requestMethod = method + , remoteHost = Sock.SockAddrInet 1 2 + , requestHeaders = headers + , rawPathInfo = url + , pathInfo = T.split (== '/') $ TE.decodeUtf8 url + } + +-- | Run a persistent db query. For asserting on the results of performed actions +-- or setting up pre-conditions. At the moment this part is still very raw. +testDB :: SqlPersist IO a -> OneSpec a +testDB query = do + OneSpecData _ pool _ _ <- get + liftIO $ runSqlPool query pool diff --git a/yesod-test/Yesod/Test/TransversingCSS.hs b/yesod-test/Yesod/Test/TransversingCSS.hs new file mode 100644 index 00000000..8d697bbc --- /dev/null +++ b/yesod-test/Yesod/Test/TransversingCSS.hs @@ -0,0 +1,177 @@ +{- | +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, + Html, + Query, + -- * For HXT hackers + -- | 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) + +type Html = String +type Query = String + +-- | 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) + +-- 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) + +parseAttrExists :: String -> Parsec String u Selector +parseAttrExists attrname = do + _ <- char ']' + return $ ByAttrExists attrname + +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 + diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal new file mode 100644 index 00000000..d85fddb8 --- /dev/null +++ b/yesod-test/yesod-test.cabal @@ -0,0 +1,40 @@ +name: yesod-test +version: 0.1 +license: BSD3 +license-file: LICENSE +author: Nubis +maintainer: Nubis +synopsis: Behaviour Oriented integration Testing for Yesod Applications +category: Web, Yesod, Testing +stability: Experimental +cabal-version: >= 1.6 +build-type: Simple +homepage: http://www.yesodweb.com +description: Behaviour Oriented integration Testing for Yesod Applications +extra-source-files: README.md, LICENSE + +library + build-depends: hxt >= 9.1.5 + , parsec >= 3.1.1 + , base + , containers + , filepath + , persistent >= 0.6.4 + , monad-control >= 0.2 + , transformers >= 0.2 + , wai-test + , wai >= 0.4 + , ascii + , network + , http-types >= 0.6 + , hspec >= 0.9 + , HUnit >= 1.0 + , bytestring + , text + , monads-tf + exposed-modules: Yesod.Test + ghc-options: -Wall + +source-repository head + type: git + location: git://github.com/yesodweb/yesod.git diff --git a/yesod/Scaffolding/Scaffolder.hs b/yesod/Scaffolding/Scaffolder.hs index 9ee58e6e..ccc50add 100644 --- a/yesod/Scaffolding/Scaffolder.hs +++ b/yesod/Scaffolding/Scaffolder.hs @@ -5,7 +5,7 @@ module Scaffolding.Scaffolder (scaffold) where import Scaffolding.CodeGen import Language.Haskell.TH.Syntax -import Control.Monad (unless) +import Control.Monad (unless, when) import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT import qualified Data.ByteString.Lazy as L @@ -83,6 +83,11 @@ scaffold = do uncapitalize s = toLower (head s) : tail s backendLower = uncapitalize $ show backend upper = show backend + + puts $(codegenDir "input" "use-tests") + useTestsC <- prompt $ flip elem $ [return 'y', return 'n'] + let useTests = useTestsC == "y" + let testsDep = if useTests then ", yesod-test" else "" let runMigration = case backend of @@ -145,6 +150,7 @@ scaffold = do mkDir "deploy" mkDir "Settings" mkDir "messages" + mkDir "tests" writeFile' ("deploy/Procfile") $(codegen "deploy/Procfile") @@ -188,6 +194,7 @@ scaffold = do $(codegen "templates/homepage.julius") unless isTiny $ writeFile' "config/models" $(codegen "config/models") writeFile' "messages/en.msg" $(codegen "messages/en.msg") + when useTests $ writeFile' "Tests.hs" $(codegen "Tests.hs") S.writeFile (dir ++ "/static/js/modernizr.js") $(runIO (S.readFile "scaffold/static/js/modernizr.js.cg") >>= \bs -> diff --git a/yesod/input/use-tests.cg b/yesod/input/use-tests.cg new file mode 100644 index 00000000..2a9f4212 --- /dev/null +++ b/yesod/input/use-tests.cg @@ -0,0 +1,6 @@ +Yesod also comes with an optional integration tests tool. +You should always test your application, the only reason +not to use the yesod testing facilities is because you +already have some other testing tool that you like better. + +Include tests?: diff --git a/yesod/scaffold/Tests.hs.cg b/yesod/scaffold/Tests.hs.cg new file mode 100644 index 00000000..69e96c24 --- /dev/null +++ b/yesod/scaffold/Tests.hs.cg @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module Testing (main) where + +import Import +import Settings +import Yesod +import Yesod.Static +import Yesod.Logger (makeLogger) +import qualified Database.Persist.Base +import Database.Persist.GenericSql (runMigration) +import Yesod.Default.Config +import Yesod.Test +import Application + +main :: IO a +main = do + conf <- loadConfig Testing + logger <- makeLogger + dbconf <- withYamlEnvironment "config/~dbConfigFile~.yml" (appEnv conf) + $ either error return . Database.Persist.Base.loadConfig + s <- static Settings.staticDir + Database.Persist.Base.withPool (dbconf :: Settings.PersistConfig) $ \p -> do + Database.Persist.Base.runPool dbconf ~runMigration~ p + app <- toWaiAppPlain $ ~sitearg~ conf logger s p + runTests app p allTests + +allTests = do + describe "These are some example tests" $ do + it "loads the index and checks it looks right" $ do + doGet_ "." + printBody + statusIs 200 + htmlCount "form" 1 + htmlAllContain "h1" "Welcome to Yesod!" + diff --git a/yesod/scaffold/project.cabal.cg b/yesod/scaffold/project.cabal.cg index dde270a9..fb5874ed 100644 --- a/yesod/scaffold/project.cabal.cg +++ b/yesod/scaffold/project.cabal.cg @@ -97,4 +97,4 @@ executable ~project~ , wai-extra >= 1.0 && < 1.2 , yaml >= 0.5 && < 0.6 , http-conduit >= 1.2 && < 1.3 - + ~testsDep~