Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

integrated yesod tests to scaffolder. still work in progress

  • Loading branch information...
commit b13a3d38580af32c24b701277564b56e0d7107ba 1 parent 18d4b98
@nubis nubis authored gregwebs committed
View
3  package-list.sh
@@ -10,4 +10,5 @@ pkgs=( ./yesod-routes
./yesod-auth
./yesod-sitemap
./yesod-default
- ./yesod )
+ ./yesod
+ ./yesod-test )
View
25 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.
View
0  yesod-test/README
No changes.
View
7 yesod-test/Setup.lhs
@@ -0,0 +1,7 @@
+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain
View
392 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
View
177 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
+
View
40 yesod-test/yesod-test.cabal
@@ -0,0 +1,40 @@
+name: yesod-test
+version: 0.1
+license: BSD3
+license-file: LICENSE
+author: Nubis <nubis@woobiz.com.ar>
+maintainer: Nubis <nubis@woobiz.com.ar>
+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
View
9 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 ->
View
6 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?:
View
37 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!"
+
View
2  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~
Please sign in to comment.
Something went wrong with that request. Please try again.