Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Loading…

Hi guys, this is my branch for the integrated integration tests. #241

Closed
wants to merge 5 commits into from

4 participants

@nubis

These are the changes, it's ready to integrate but I'm already thinking the API may change a bit, and still uses HXT, anyways, you can probably merge and run the scaffold to see what it is all about.

cheers

@snoyberg
Owner

Could you merge this with the newest master? There are some mismatches that I'm not sure about (e.g., what's going on with the default layout files, I moved us to boilerplate, I'm not sure what you'd want to change), plus it looks like some of your changes roll back some fixes for newer versions of persistent (e.g., upperCaseSettings).

BTW, I really like the CSS engine, if you're not opposed I'd like to actually factor it out into some other packages so it's more generally available. I could imagine using that at work for great fun and profit :).

@nubis
@maxcan

is this going to be a part of 1.0?

@gregwebs
Owner

yes, I am going to merge this soon for you

@gregwebs
Owner

oh, right: we are blocked on this because we don't want an hxt dependency. It is not supposed to be a big effort to switch to xml-conduit, but it needs to be done first. Also, I am trying to make it everyone's policy to switch to attoparsec. I have wasted too much time with parsec because it doesn't bactrack and you have to insert 'try', This is something that makes the code harder to maintain and harder for contributors.

@snoyberg
Owner

attoparsec doesn't do backtracking by default either, only for strings. The one advantage of Parsec versus attoparsec is that the former gives line/column information. It's something that I often times miss in xml-conduit. However, I agree that we should standardize on attoparsec.

I can help with some of the migration stuff next week. I agree it would be best to have this included in 1.0.

@gregwebs
Owner

Max needs this for yesod-generate as a means to ensure the generation works.

not sure what exactly you are saying for attoparsec.
http://hackage.haskell.org/packages/archive/attoparsec/0.10.1.1/doc/html/src/Data-Attoparsec-Text-Internal.html#try

@snoyberg
Owner

Whoa, I stand corrected. That's pretty awesome.

@gregwebs
Owner

not having good error info is a pretty big downside. I think the library should be able to be modified to have a slower mode that figures out where the error is. In many of our case we could do a fast parse first and then if there is an error re-parse in the slow mode to get exact info. Probably one of the many other parsing libraries out there has backtracking & good error info.

@snoyberg
Owner

Getting better error messages into attoparsec would be nice, but I don't think it should be a prerequisite here. If I'm not mistaken, Parsec is only being used for parsing the CSS declarations, right? Given that these things are (hopefully) minuscule, I don't see it as a problem that we can't give line/column numbers.

@gregwebs
Owner

agreed. was just thinking out loud about parsing in general.

@maxcan

the dicier part will be getting rid of HXT since its used to walk the tree and basically implement css/jquery style selectors.

@snoyberg
Owner
@gregwebs
Owner

I am rebasing this branch. I will just go ahead and upload yesod-test to hackage as is after testing it out

@gregwebs gregwebs closed this
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Jan 15, 2012
  1. @nubis
Commits on Jan 17, 2012
  1. @nubis

    Fixed dependencies

    nubis authored
  2. @nubis

    ignoring scripts

    nubis authored
Commits on Jan 24, 2012
  1. @nubis
  2. @nubis

    deleted old tests module

    nubis authored
This page is out of date. Refresh to see the latest.
Showing with 865 additions and 24 deletions.
  1. +2 −0  .gitignore
  2. +2 −1  package-list.sh
  3. +0 −1  yesod-core/yesod-core.cabal
  4. +25 −0 yesod-test/LICENSE
  5. 0  yesod-test/README
  6. +7 −0 yesod-test/Setup.lhs
  7. +372 −0 yesod-test/Yesod/Test.hs
  8. +177 −0 yesod-test/Yesod/Test/TransversingCSS.hs
  9. +42 −0 yesod-test/yesod-test.cabal
  10. +19 −5 yesod/Scaffolding/Scaffolder.hs
  11. +6 −0 yesod/input/use-tests.cg
  12. +24 −2 yesod/scaffold/Handler/Root.hs.cg
  13. +1 −1  yesod/scaffold/Model.hs.cg
  14. +42 −0 yesod/scaffold/cabal_test_suite.cg
  15. +1 −1  yesod/scaffold/config/mongoDB.yml.cg
  16. +1 −1  yesod/scaffold/config/postgresql.yml.cg
  17. +1 −1  yesod/scaffold/config/routes.cg
  18. +1 −1  yesod/scaffold/config/settings.yml.cg
  19. +1 −1  yesod/scaffold/config/sqlite.yml.cg
  20. +1 −1  yesod/scaffold/templates/boilerplate-wrapper.hamlet.cg
  21. +1 −1  yesod/scaffold/templates/default-layout-wrapper.hamlet.cg
  22. +0 −1  yesod/scaffold/templates/default-layout.hamlet.cg
  23. +51 −1 yesod/scaffold/templates/default-layout.lucius.cg
  24. +40 −1 yesod/scaffold/templates/homepage.hamlet.cg
  25. +1 −2  yesod/scaffold/templates/homepage.julius.cg
  26. +1 −2  yesod/scaffold/templates/homepage.lucius.cg
  27. +46 −0 yesod/scaffold/tests_main.hs.cg
View
2  .gitignore
@@ -5,3 +5,5 @@ dist
*.swp
client_session_key.aes
cabal-dev/
+
+scripts
View
3  package-list.sh
@@ -12,4 +12,5 @@ pkgs=( ./yesod-routes
./yesod-auth
./yesod-sitemap
./yesod-default
- ./yesod )
+ ./yesod
+ ./yesod-test )
View
1  yesod-core/yesod-core.cabal
@@ -81,7 +81,6 @@ library
, wai-logger >= 0.0.1
, conduit >= 0.0 && < 0.1
, lifted-base >= 0.1 && < 0.2
-
exposed-modules: Yesod.Content
Yesod.Core
Yesod.Dispatch
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
372 yesod-test/Yesod/Test.hs
@@ -0,0 +1,372 @@
+{-# 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.
+
+-}
+
+module Yesod.Test (
+ -- * Declaring and running your test suite
+ runTests, describe, it, Specs, OneSpec,
+
+ -- * 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.
+ --
+ post, post_, get, get_, doRequest,
+ byName, fileByName,
+
+ -- | 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.
+ -- 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_,
+
+ -- * Running database queries
+ runDB,
+
+ -- * 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)
+import Network.Wai
+import Network.Wai.Test
+import qualified Control.Monad.Trans.State as ST
+import Control.Monad.IO.Class
+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 = ST.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 = ST.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 = ST.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) <- ST.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 <- ST.get
+ SpecsData app conn specs <- liftIO $ ST.execStateT action sData
+ ST.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 <- ST.get
+ let spec = Core.it label $ do
+ _ <- ST.execStateT action $ OneSpecData app conn "" Nothing
+ return ()
+ ST.put $ SpecsData app conn (specs++spec)
+
+-- Performs a given action using the last response.
+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
+
+-- | 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
+
+-- | 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 -> ST.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 -> ST.StateT a IO ()
+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 :: HoldsResponse a => Query -> String -> ST.StateT a IO ()
+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
+
+-- | Performs a css query on the last response and asserts the matched elements
+-- are as many as expected.
+htmlCount :: HoldsResponse a => Query -> Int -> ST.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 => ST.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 -> ST.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 <- ST.get
+ ST.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
+fileByName :: String -> FilePath -> String -> RequestBuilder ()
+fileByName name path mimetype = do
+ RequestBuilderData parts r <- ST.get
+ contents <- liftIO $ BSL8.readFile path
+ ST.put $ RequestBuilderData ((ReqFilePart name path contents mimetype):parts) r
+
+-- This looks up the name of a field based on the contents of the label pointing to it.
+nameFromLabel :: String -> RequestBuilder String
+nameFromLabel label = withResponse $ \ res -> do
+ let
+ body = BSL8.unpack $ simpleBody res
+ escaped = escapeHtmlEntities label
+ mfor = parseHTML body $ deep $ hasName "label"
+ >>> filterA (xshow this >>> mkText >>> hasText (DL.isInfixOf escaped))
+ >>> getAttrValue "for"
+
+ case mfor of
+ for:[] -> do
+ let mname = parseHTML body $ deep $ hasAttrValue "id" (==for) >>> getAttrValue "name"
+ case mname of
+ "":_ -> failure $ "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
+
+-- | Escape HTML entities in a string, so you can write the text you want in
+-- label lookups without worrying about the fact that yesod escapes some characters.
+escapeHtmlEntities :: String -> String
+escapeHtmlEntities "" = ""
+escapeHtmlEntities (c:cs) = case c of
+ '<' -> '&' : 'l' : 't' : ';' : escapeHtmlEntities cs
+ '>' -> '&' : 'g' : 't' : ';' : escapeHtmlEntities cs
+ '&' -> '&' : 'a' : 'm' : 'p' : ';' : escapeHtmlEntities cs
+ '"' -> '&' : 'q' : 'u' : 'o' : 't' : ';' : escapeHtmlEntities cs
+ '\'' -> '&' : '#' : '3' : '9' : ';' : escapeHtmlEntities cs
+ x -> x : escapeHtmlEntities cs
+
+byLabel :: String -> String -> RequestBuilder ()
+byLabel label value = do
+ name <- nameFromLabel label
+ byName name value
+
+fileByLabel :: String -> FilePath -> String -> RequestBuilder ()
+fileByLabel label path mime = do
+ name <- nameFromLabel label
+ fileByName 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_ :: String -> RequestBuilder ()
+addNonce_ scope = do
+ matches <- htmlQuery $ scope ++ "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"
+ _ -> failure $ "More than one nonce found in the page"
+
+-- | For responses that display a single form, just lookup the only nonce available.
+addNonce :: RequestBuilder ()
+addNonce = addNonce_ ""
+
+-- | Perform a POST request to url, using params
+post :: BS8.ByteString -> RequestBuilder () -> OneSpec ()
+post url paramsBuild = do
+ doRequest "POST" url paramsBuild
+
+-- | Perform a POST request without params
+post_ :: BS8.ByteString -> OneSpec ()
+post_ = flip post $ return ()
+
+-- | Perform a GET request to url, using params
+get :: BS8.ByteString -> RequestBuilder () -> OneSpec ()
+get url paramsBuild = doRequest "GET" url paramsBuild
+
+-- | Perform a GET request without params
+get_ :: BS8.ByteString -> OneSpec ()
+get_ = flip get $ 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 <- ST.get
+ RequestBuilderData parts _ <- liftIO $ ST.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
+ ST.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 = DL.filter (/="") $ 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.
+runDB :: SqlPersist IO a -> OneSpec a
+runDB query = do
+ OneSpecData _ pool _ _ <- ST.get
+ liftIO $ runSqlPool query pool
+
+-- Yes, just a shortcut
+failure :: (MonadIO a) => String -> a b
+failure reason = (liftIO $ HUnit.assertFailure reason) >> error ""
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
42 yesod-test/yesod-test.cabal
@@ -0,0 +1,42 @@
+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
+
+flag ghc7
+
+library
+ if flag(ghc7)
+ build-depends: base >= 4.3 && < 5
+ cpp-options: -DGHC7
+ else
+ build-depends: base >= 4 && < 4.3
+ build-depends: hxt >= 9.1.6
+ , parsec >= 2.1 && < 4
+ , persistent >= 0.7 && < 0.8
+ , transformers >= 0.2.2 && < 0.3
+ , wai >= 1.0 && < 1.1
+ , wai-test >= 1.0 && < 1.1
+ , network >= 2.2 && < 2.4
+ , http-types >= 0.6 && < 0.7
+ , HUnit >= 1.2 && < 1.3
+ , hspec >= 0.9 && < 1.0
+ , bytestring >= 0.9
+ , text
+ exposed-modules: Yesod.Test
+ other-modules: Yesod.Test.TransversingCSS
+ ghc-options: -Wall
+
+source-repository head
+ type: git
+ location: git://github.com/yesodweb/yesod.git
View
24 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
@@ -66,8 +66,8 @@ scaffold = do
backendC <- prompt $ flip elem $ map (return . toLower . head . show) backends
let (backend, importGenericDB, dbMonad, importPersist, mkPersistSettings) =
case backendC of
- "s" -> (Sqlite, "GenericSql", "SqlPersist", "Sqlite", "sqlMkSettings")
- "p" -> (Postgresql, "GenericSql", "SqlPersist", "Postgresql", "sqlMkSettings")
+ "s" -> (Sqlite, "GenericSql", "SqlPersist", "Sqlite", "sqlSettings")
+ "p" -> (Postgresql, "GenericSql", "SqlPersist", "Postgresql", "sqlSettings")
"m" -> (MongoDB, "MongoDB", "Action", "MongoDB", "MkPersistSettings { mpsBackend = ConT ''Action }")
"t" -> (Tiny, "","","",undefined)
_ -> error $ "Invalid backend: " ++ backendC
@@ -80,6 +80,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
@@ -127,10 +132,12 @@ scaffold = do
let fst3 (x, _, _) = x
year <- show . fst3 . toGregorian . utctDay <$> getCurrentTime
- let writeFile' fp s = do
+ let changeFile fileFunc fp s = do
putStrLn $ "Generating " ++ fp
- L.writeFile (dir ++ '/' : fp) $ LT.encodeUtf8 $ LT.pack s
+ fileFunc (dir ++ '/' : fp) $ LT.encodeUtf8 $ LT.pack s
mkDir fp = createDirectoryIfMissing True $ dir ++ '/' : fp
+ writeFile' = changeFile L.writeFile
+ appendFile' = changeFile L.appendFile
mkDir "Handler"
mkDir "templates"
@@ -157,6 +164,9 @@ scaffold = do
writeFile' ("config/settings.yml") $(codegen "config/settings.yml")
writeFile' ("main.hs") $(codegen "main.hs")
writeFile' (project ++ ".cabal") $ ifTiny $(codegen "tiny/project.cabal") $(codegen "project.cabal")
+ when useTests $ do
+ appendFile' (project ++ ".cabal") $(codegen "cabal_test_suite")
+
writeFile' ".ghci" $(codegen ".ghci")
writeFile' "LICENSE" $(codegen "LICENSE")
writeFile' ("Foundation.hs") $ ifTiny $(codegen "tiny/Foundation.hs") $(codegen "Foundation.hs")
@@ -186,6 +196,10 @@ scaffold = do
unless isTiny $ writeFile' "config/models" $(codegen "config/models")
writeFile' "messages/en.msg" $(codegen "messages/en.msg")
+ when useTests $ do
+ mkDir "tests"
+ writeFile' "tests/main.hs" $(codegen "tests_main.hs")
+
S.writeFile (dir ++ "/static/js/modernizr.js")
$(runIO (S.readFile "scaffold/static/js/modernizr.js.cg") >>= \bs ->
[|S.pack $(return $ LitE $ StringL $ S.unpack 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
26 yesod/scaffold/Handler/Root.hs.cg
@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections, OverloadedStrings #-}
module Handler.Root where
import Import
@@ -11,7 +12,28 @@ import Import
-- inclined, or create a single monolithic file.
getRootR :: Handler RepHtml
getRootR = do
+ ((_, formWidget), formEnctype) <- generateFormPost sampleForm
+ let submission = Nothing :: Maybe (FileInfo, Text)
+ handlerName = "getRootR" :: Text
defaultLayout $ do
- h2id <- lift newIdent
- setTitle "~project~ homepage"
+ aDomId <- lift newIdent
+ setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
+
+postRootR :: Handler RepHtml
+postRootR = do
+ ((result, formWidget), formEnctype) <- runFormPost sampleForm
+ let handlerName = "postRootR" :: Text
+ submission = case result of
+ FormSuccess res -> Just res
+ _ -> Nothing
+
+ defaultLayout $ do
+ aDomId <- lift newIdent
+ setTitle "Welcome To Yesod!"
+ $(widgetFile "homepage")
+
+sampleForm :: Form (FileInfo, Text)
+sampleForm = renderDivs $ (,)
+ <$> fileAFormReq "Choose a file"
+ <*> areq textField "What's on the file?" Nothing
View
2  yesod/scaffold/Model.hs.cg
@@ -11,5 +11,5 @@ import Database.Persist.Quasi
-- at:
-- http://www.yesodweb.com/book/persistent/
share [mkPersist ~mkPersistSettings~, mkMigrate "migrateAll"]
- $(persistFile upperCaseSettings "config/models")
+ $(persistFile "config/models")
View
42 yesod/scaffold/cabal_test_suite.cg
@@ -0,0 +1,42 @@
+test-suite integration-tests
+ type: exitcode-stdio-1.0
+ main-is: main.hs
+ hs-source-dirs: tests .
+ ghc-options: -Wall
+ extensions: TemplateHaskell
+ QuasiQuotes
+ OverloadedStrings
+ NoImplicitPrelude
+ CPP
+ OverloadedStrings
+ MultiParamTypeClasses
+ TypeFamilies
+ GADTs
+ GeneralizedNewtypeDeriving
+ FlexibleContexts
+
+ build-depends: base >= 4 && < 5
+ , yesod >= 0.10 && < 0.11
+ , yesod-core >= 0.10 && < 0.11
+ , yesod-auth >= 0.8 && < 0.9
+ , yesod-static >= 0.10 && < 0.11
+ , yesod-default >= 0.6 && < 0.7
+ , yesod-form >= 0.4 && < 0.5
+ , yesod-test >= 0.1 && < 0.2
+ , mime-mail >= 0.3.0.3 && < 0.5
+ , clientsession >= 0.7.3 && < 0.8
+ , bytestring >= 0.9 && < 0.10
+ , text >= 0.11 && < 0.12
+ , persistent >= 0.7 && < 0.8
+ , persistent-sqlite >= 0.7 && < 0.8
+ , template-haskell
+ , hamlet >= 0.10 && < 0.11
+ , shakespeare-css >= 0.10 && < 0.11
+ , shakespeare-js >= 0.10 && < 0.11
+ , shakespeare-text >= 0.10 && < 0.11
+ , hjsmin >= 0.0.14 && < 0.1
+ , monad-control >= 0.3 && < 0.4
+ , wai-extra >= 1.0 && < 1.1
+ , yaml >= 0.5 && < 0.6
+ , http-conduit >= 1.1 && < 1.2
+ , haskell98
View
2  yesod/scaffold/config/mongoDB.yml.cg
@@ -9,7 +9,7 @@ Default: &defaults
Development:
<<: *defaults
-Test:
+Testing:
database: ~project~_test
<<: *defaults
View
2  yesod/scaffold/config/postgresql.yml.cg
@@ -9,7 +9,7 @@ Default: &defaults
Development:
<<: *defaults
-Test:
+Testing:
database: ~project~_test
<<: *defaults
View
2  yesod/scaffold/config/routes.cg
@@ -4,4 +4,4 @@
/favicon.ico FaviconR GET
/robots.txt RobotsR GET
-/ RootR GET
+/ RootR GET POST
View
2  yesod/scaffold/config/settings.yml.cg
@@ -6,7 +6,7 @@ Default: &defaults
Development:
<<: *defaults
-Test:
+Testing:
<<: *defaults
Staging:
View
2  yesod/scaffold/config/sqlite.yml.cg
@@ -5,7 +5,7 @@ Default: &defaults
Development:
<<: *defaults
-Test:
+Testing:
database: ~project~_test.sqlite3
<<: *defaults
View
2  yesod/scaffold/templates/boilerplate-wrapper.hamlet.cg
@@ -39,4 +39,4 @@
<script src="//ajax.googleapis.com/ajax/libs/chrome-frame/1.0.3/CFInstall.min.js">
<script>
window.attachEvent('onload',function(){CFInstall.check({mode:'overlay'})})
- \<![endif]-->
+ \<![endif]-->
View
2  yesod/scaffold/templates/default-layout-wrapper.hamlet.cg
@@ -4,5 +4,5 @@
<title>#{pageTitle pc}
^{pageHead pc}
<body>
+ <div .content>
^{pageBody pc}
-
View
1  yesod/scaffold/templates/default-layout.hamlet.cg
@@ -3,4 +3,3 @@ $maybe msg <- mmsg
^{widget}
<footer>
#{extraCopyright $ appExtra $ settings y}
-
View
52 yesod/scaffold/templates/default-layout.lucius.cg
@@ -1,4 +1,54 @@
body {
- font-family: sans-serif;
+ font-family: helvetica;
+ font-size: 18px;
+ background: #f0f0f0;
+ line-height: 1.9em;
+}
+.content {
+ width: 850px;
+ margin: 0 auto;
+}
+em, a , form{
+ font-style: normal;
+ padding: 0.3em;
+ border: 1px solid #e0e0e0;
+ background: #fff;
+}
+form .required {
+ padding: 0.4em 0;
+ input {
+ margin-left: 0.5em;
+ }
+ .errors {
+ color: #f66;
+ display: inline;
+ }
+}
+
+ol {
+ padding: 0;
+ li {
+ list-style-type: square;
+ margin: 0.5em;
+ }
+}
+li {
+ list-style-image: disc;
+}
+
+form {
+ margin-top: 1em;
+}
+
+.message {
+ border: 1px solid #ff2;
+ background: #ffa;
+ margin: 1em 0;
+ padding: 1em;
+}
+
+footer {
+ text-align: center;
+ margin: 20px;
}
View
41 yesod/scaffold/templates/homepage.hamlet.cg
@@ -1,2 +1,41 @@
<h1>_{MsgHello}
-<h2 ##{h2id}>You do not have Javascript enabled.
+
+<p>Now that you have a working project you should use the
+ <a href="http://www.yesodweb.com/book/">Yesod book</a> to learn more.
+
+<p>
+ You can also use this scaffolded site to explore some basic concepts, these are
+ the main things to look at:
+
+<ol>
+ <li> This page was generated by the #{handlerName} handler in
+ <em>Handler/Root.hs</em>.
+
+ <li> The #{handlerName} handler is set to generate your site's home screen in Routes file
+ <em>config/routes</em>
+
+ <li> The HTML you are seeing now is actually composed by a number of <em>widgets</em>,
+ most of them are brought together by the <em>defaultLayout</em> function which
+ is defined in the <em>Foundation.hs</em> module, and used by <em>#{handlerName}</em>.
+ All the files for templates and wigdets are in <em>templates</em>.
+
+ <li>
+ A Widget's Html, Css and Javascript are separated in three files with the
+ <em>.hamlet</em>, <em>.lucius</em> and <em>.julius</em> extensions.
+
+ <li ##{aDomId}>If you had javascript enabled then you wouldn't be seeing this.
+
+ <li #form>
+ This is an example trivial Form. Read the
+ <a href="http://www.yesodweb.com/book/forms">Forms chapter</a>
+ on the yesod book to learn more about them.
+ $maybe (info,con) <- submission
+ <div .message>
+ Your file's type was <em>#{fileContentType info}</em>. You say it has: <em>#{con}</em>
+ <form method=post action=@{RootR}#form enctype=#{formEnctype}>
+ ^{formWidget}
+ <input type="submit" value="Send it!">
+
+ <li> And last but not least, Testing. In <em>tests/main.hs</em> you will find a
+ test suite that performs tests on this page.
+ You can run your tests by doing: <pre>cabal install --enable-tests && cabal test</pre>
View
3  yesod/scaffold/templates/homepage.julius.cg
@@ -1,2 +1 @@
-document.getElementById("#{h2id}").innerHTML = "<i>Added from JavaScript.</i>";
-
+document.getElementById("#{aDomId}").innerHTML = "This text was added by the Javascript part of the homepage widget.";
View
3  yesod/scaffold/templates/homepage.lucius.cg
@@ -1,7 +1,6 @@
h1 {
text-align: center
}
-h2##{h2id} {
+h2##{aDomId} {
color: #990
}
-
View
46 yesod/scaffold/tests_main.hs.cg
@@ -0,0 +1,46 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Main where
+
+import Import
+import Settings
+import Yesod.Static
+import Yesod.Logger (defaultDevelopmentLogger)
+import qualified Database.Persist.Store
+import Database.Persist.GenericSql (runMigration)
+import Yesod.Default.Config
+import Yesod.Test
+import Network.HTTP.Conduit (newManagerIO)
+import Application()
+
+main :: IO a
+main = do
+ conf <- loadConfig $ (configSettings Testing) { csParseExtra = parseExtra }
+ manager <- newManagerIO 10
+ logger <- defaultDevelopmentLogger
+ dbconf <- withYamlEnvironment "config/~dbConfigFile~.yml" (appEnv conf)
+ Database.Persist.Store.loadConfig
+ s <- static Settings.staticDir
+ p <- Database.Persist.Store.createPoolConfig (dbconf :: Settings.PersistConfig)~runMigration~
+ app <- toWaiAppPlain $ ~sitearg~ conf logger s p manager
+ runTests app p allTests
+
+allTests :: Specs
+allTests = do
+ describe "These are some example tests" $ do
+ it "loads the index and checks it looks right" $ do
+ get_ "/"
+ statusIs 200
+ htmlAllContain "h1" "Hello"
+
+ post "/" $ do
+ addNonce
+ fileByLabel "Choose a file" "tests/main.hs" "text/plain" -- talk about self-reference
+ byLabel "What's on the file?" "Some Content"
+
+ statusIs 200
+ htmlCount ".message" 1
+ htmlAllContain ".message" "Some Content"
+ htmlAllContain ".message" "text/plain"
Something went wrong with that request. Please try again.