Merge remote-tracking branch 'origin/master'

Conflicts:
	yesod/scaffold/Handler/Home.hs.cg
	yesod/scaffold/config/routes.cg
	yesod/scaffold/project.cabal.cg
	yesod/yesod.cabal

package-list.sh

@@ -12,4 +12,4 @@ pkgs=(      ./yesod-routes
             ./yesod-auth
             ./yesod-sitemap
             ./yesod-default
-            ./yesod                 )
+            ./yesod )

yesod-core/yesod-core.cabal

@@ -82,7 +82,6 @@ library
                    , conduit               >= 0.3      && < 0.4
                    , resourcet             >= 0.3      && < 0.4
                    , lifted-base           >= 0.1      && < 0.2
-
     exposed-modules: Yesod.Content
                      Yesod.Core
                      Yesod.Dispatch

yesod-routes/Yesod/Routes/TH/Dispatch.hs

@@ -19,10 +19,10 @@ import Data.List (foldl')
 
 -- |
 --
--- This function will generate a single clause that will address all your
--- routing needs. It takes three arguments. The third (a list of 'Resource's)
--- is self-explanatory. We\'ll discuss the first two. But first, let\'s cover
--- the terminology.
+-- This function will generate a single clause that will address all
+-- your routing needs. It takes four arguments. The fourth (a list of
+-- 'Resource's) is self-explanatory. We\'ll discuss the first
+-- three. But first, let\'s cover the terminology.
 --
 -- Dispatching involves a master type and a sub type. When you dispatch to the
 -- top level type, master and sub are the same. Each time to dispatch to
@@ -63,7 +63,23 @@ import Data.List (foldl')
 -- > dispatcher :: master -> sub -> (Route sub -> Route master) -> app -> handler sub master -> Text -> [Text] -> app
 --
 -- Where the parameters mean master, sub, toMaster, 404 response, 405 response,
--- request method and path pieces.
+-- request method and path pieces. This is the second argument of our function.
+--
+-- Finally, we need a way to decide which of the possible formats
+-- should the handler send the data out. Think of each URL holding an
+-- abstract object which has multiple representation (JSON, plain HTML
+-- etc). Each client might have a preference on which format it wants
+-- the abstract object in. For example, a javascript making a request
+-- (on behalf of a browser) might prefer a JSON object over a plain
+-- HTML file where as a user browsing with javascript disabled would
+-- want the page in HTML. The third argument is a function that
+-- converts the abstract object to the desired representation
+-- depending on the preferences sent by the client.
+--
+-- The typical values for the first three arguments are,
+-- @'yesodRunner'@ for the first, @'yesodDispatch'@ for the second and
+-- @fmap 'chooseRep'@.
+
 mkDispatchClause :: Q Exp -- ^ runHandler function
                  -> Q Exp -- ^ dispatcher function
                  -> Q Exp -- ^ fixHandler function

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.

yesod-test/README.md

@@ -0,0 +1,75 @@
+# TestWaiPersistent - Pragmatic integration tests for haskell web applications using WAI and Persistent
+
+yesod-test is designed for testing web applications built using wai and persistent.
+It's main goal is to encourage integration and system testing of web applications by making everything /easy to test/. 
+
+Your tests are like browser sessions that keep track of cookies and the last
+visited page. You can perform assertions on the content of HTML responses,
+using css selectors 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 "\_token" field.
+
+Your database is also directly available so you can use runDB to set up
+backend pre-conditions, or to assert that your session is having the desired effect.
+
+The testing facilities behind the scenes are HUnit and HSpec.
+
+This is the helloworld and kitchen sink. In this case for testing a yesod app.
+
+```haskell
+
+  import Yesod
+  import Yesod.Static
+  import qualified MySite.Settings as Settings
+  import MySite.Models
+
+  main :: IO a
+  main = do
+    cfg <- (loadConfig Test) >>= either fail return
+    st <-  static Settings.staticDir
+    Settings.withConnectionPool (connStr cfg) $ \cnPool -> do
+      -- ... Perhaps some code here to truncate your test database?
+      app <- toWaiApp $ MyApp st cfg 
+      runTests app cnPool $ mySuite
+
+  mySuite = do
+    describe "Basic navigation and assertions" $ do
+      it "Gets a page that has a form, with auto generated fields and token" $ do
+        get_ "url/of/page/with/form" -- Load a page
+        statusIs 200 -- Assert the status was success
+
+        bodyContains "Hello Person" -- Assert any part of the document contains some text.
+        
+        -- Perform a css queries and assertions.
+        htmlCount "form .main" 1 -- It matches 1 element
+        htmlAllContain "h1#mainTitle" "Sign Up Now!" -- All matches have some text
+
+        -- Performs the post using the current page to extract field values:
+        post "url/to/post/to" $ do
+          addNonce -- Add the _nonce field with the currently shown value
+
+          -- Lookup field by the text on the labels pointing to them.
+          byLabel "Email:" "gustavo@cerati.com"
+          byLabel "Password:" "secret"
+          byLabel "Confirm:" "secret"
+
+      it "Sends another form, this one has a file" $ do
+        post "url/to/post/file/to" $ do
+          -- You can add files this easy, you still have to provide the mime type manually though.
+          addFile "file_field_name" "path/to/local/file" "image/jpeg"
+          
+          -- And of course you can add any field if you know it's name
+          byName "answer" "42"
+
+        statusIs 302
+
+    describe "Db access, still very raw" $ do
+      it "selects the list" $ do
+        msgs <- testDB $ do (selectList [] [] :: SqlPersist IO [(Key SqlPersist Message, Message)])
+        assertEqual "One Message in the DB" 1 (DL.length msgs)
+
+```
+

yesod-test/Setup.lhs

@@ -0,0 +1,7 @@
+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain

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 ""

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
+

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:           integration testing for WAI/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.8      && < 0.9
+                   , transformers              >= 0.2.2    && < 0.3
+                   , wai                       >= 1.1      && < 1.2
+                   , wai-test                  >= 1.0      && < 2.0
+                   , 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

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
@@ -76,6 +76,9 @@ scaffold = do
         uncapitalize s = toLower (head s) : tail s
         backendLower = uncapitalize $ show backend 
         upper = show backend
+    
+    let useTests = True
+    let testsDep = if useTests then ", yesod-test" else ""
 
     let runMigration  =
           case backend of
@@ -123,10 +126,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"
@@ -155,6 +160,9 @@ scaffold = do
     writeFile' ("main.hs") $(codegen "main.hs")
     writeFile' ("devel.hs") $(codegen "devel.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")
@@ -182,6 +190,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)|])

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?: 

yesod/scaffold/Handler/Home.hs.cg

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections, OverloadedStrings #-}
 module Handler.Home where
 
 import Import
@@ -11,7 +12,28 @@ import Import
 -- inclined, or create a single monolithic file.
 getHomeR :: Handler RepHtml
 getHomeR = 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

yesod/scaffold/cabal_test_suite.cg

@@ -0,0 +1,19 @@
+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-test                    >= 0.1        && < 0.2

yesod/scaffold/config/mongoDB.yml.cg

@@ -9,7 +9,7 @@ Default: &defaults
 Development:
   <<: *defaults
 
-Test:
+Testing:
   database: ~project~_test
   <<: *defaults
 

yesod/scaffold/config/postgresql.yml.cg

@@ -9,7 +9,7 @@ Default: &defaults
 Development:
   <<: *defaults
 
-Test:
+Testing:
   database: ~project~_test
   <<: *defaults
 

yesod/scaffold/config/routes.cg

@@ -4,4 +4,4 @@
 /favicon.ico FaviconR GET
 /robots.txt RobotsR GET
 
-/ HomeR GET
+/ HomeR GET POST

yesod/scaffold/config/sqlite.yml.cg

@@ -5,7 +5,7 @@ Default: &defaults
 Development:
   <<: *defaults
 
-Test:
+Testing:
   database: ~project~_test.sqlite3
   <<: *defaults
 

yesod/scaffold/project.cabal.cg

@@ -97,3 +97,4 @@ executable         ~project~
                  , yaml                          >= 0.6        && < 0.7
                  , http-conduit                  >= 1.3        && < 1.4
 
+                 ~testsDep~

yesod/scaffold/templates/boilerplate-wrapper.hamlet.cg

@@ -0,0 +1,42 @@
+\<!doctype html>
+\<!--[if lt IE 7]> <html class="no-js ie6 oldie" lang="en"> <![endif]-->
+\<!--[if IE 7]>    <html class="no-js ie7 oldie" lang="en"> <![endif]-->
+\<!--[if IE 8]>    <html class="no-js ie8 oldie" lang="en"> <![endif]-->
+\<!--[if gt IE 8]><!-->
+<html class="no-js" lang="en"> <!--<![endif]-->
+    <head>
+        <meta charset="UTF-8">
+
+        <title>#{pageTitle pc}
+        <meta name="description" content="">
+        <meta name="author" content="">
+
+        <meta name="viewport" content="width=device-width,initial-scale=1">
+
+        ^{pageHead pc}
+
+        \<!--[if lt IE 9]>
+        \<script src="http://html5shiv.googlecode.com/svn/trunk/html5.js"></script>
+        \<![endif]-->
+
+        <script>
+          document.documentElement.className = document.documentElement.className.replace(/\bno-js\b/,'js');
+    <body>
+        <div id="container">
+            <header>
+            <div id="main" role="main">
+              ^{pageBody pc}
+            <footer>
+
+        \<!-- Change UA-XXXXX-X to be your site's ID -->
+        <script>
+            window._gaq = [['_setAccount','UAXXXXXXXX1'],['_trackPageview'],['_trackPageLoadTime']];
+            YepNope.load({
+            \  load: ('https:' == location.protocol ? '//ssl' : '//www') + '.google-analytics.com/ga.js'
+            });
+        \<!-- Prompt IE 6 users to install Chrome Frame. Remove this if you want to support IE 6.  chromium.org/developers/how-tos/chrome-frame-getting-started -->
+        \<!--[if lt IE 7 ]>
+            <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]-->

yesod/scaffold/templates/default-layout.lucius.cg

@@ -1,3 +1,53 @@
 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;
 }

yesod/scaffold/templates/homepage.hamlet.cg

@@ -1,2 +1,38 @@
 <h1>_{MsgHello}
-<h2 ##{h2id}>You do not have Javascript enabled.
+
+<ol>
+  <li>Now that you have a working project you should use the #
+    <a href="http://www.yesodweb.com/book/">Yesod book</a> to learn more.
+    You can also use this scaffolded site to explore some basic concepts.
+
+  <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>

yesod/scaffold/templates/homepage.julius.cg

@@ -1 +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.";

yesod/scaffold/templates/homepage.lucius.cg

@@ -1,6 +1,6 @@
 h1 {
     text-align: center
 }
-h2##{h2id} {
+h2##{aDomId} {
     color: #990
 }

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 (newManager, def)
+import Application()
+
+main :: IO a
+main = do
+    conf <- loadConfig $ (configSettings Testing) { csParseExtra = parseExtra }
+    manager <- newManager def
+    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 dbconf
+    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"

yesod/yesod.cabal

@@ -19,46 +19,52 @@ homepage:        http://www.yesodweb.com/
 
 extra-source-files:
   input/*.cg
-  scaffold/templates/default-layout.lucius.cg
-  scaffold/templates/homepage.lucius.cg
   scaffold/Model.hs.cg
-  scaffold/Import.hs.cg
-  scaffold/Foundation.hs.cg
   scaffold/LICENSE.cg
+  scaffold/project.cabal.cg
   scaffold/mongoDBConnPool.cg
-  scaffold/tiny/Import.hs.cg
-  scaffold/tiny/Foundation.hs.cg
+  scaffold/main.hs.cg
+  scaffold/static/js/modernizr.js.cg
+  scaffold/postgresqlConnPool.cg
+  scaffold/Foundation.hs.cg
   scaffold/tiny/project.cabal.cg
+  scaffold/tiny/Foundation.hs.cg
+  scaffold/tiny/Import.hs.cg
+  scaffold/tiny/Settings.hs.cg
   scaffold/tiny/Application.hs.cg
   scaffold/tiny/config/routes.cg
-  scaffold/tiny/Settings.hs.cg
-  scaffold/templates/normalize.lucius.cg
-  scaffold/postgresqlConnPool.cg
   scaffold/sqliteConnPool.cg
+  scaffold/cabal_test_suite.cg
+  scaffold/Import.hs.cg
   scaffold/.ghci.cg
-  scaffold/project.cabal.cg
+  scaffold/tests/main.hs.cg
+  scaffold/Settings.hs.cg
+  scaffold/Settings/StaticFiles.hs.cg
   scaffold/Application.hs.cg
-  scaffold/templates/homepage.julius.cg
+  scaffold/deploy/Procfile.cg
   scaffold/templates/homepage.hamlet.cg
+  scaffold/templates/default-layout.lucius.cg
   scaffold/templates/default-layout.hamlet.cg
+  scaffold/templates/homepage.julius.cg
   scaffold/templates/default-layout-wrapper.hamlet.cg
   scaffold/deploy/Procfile.cg
   scaffold/main.hs.cg
   scaffold/devel.hs.cg
   scaffold/Handler/Home.hs.cg
+  scaffold/templates/normalize.lucius.cg
+  scaffold/templates/boilerplate-wrapper.hamlet.cg
+  scaffold/templates/homepage.lucius.cg
+  scaffold/messages/en.msg.cg
   scaffold/config/models.cg
+  scaffold/config/mysql.yml.cg
   scaffold/config/sqlite.yml.cg
   scaffold/config/settings.yml.cg
   scaffold/config/favicon.ico.cg
   scaffold/config/postgresql.yml.cg
-  scaffold/config/mysql.yml.cg
-  scaffold/config/mongoDB.yml.cg
   scaffold/config/routes.cg
   scaffold/config/robots.txt.cg
-  scaffold/Settings.hs.cg
-  scaffold/Settings/StaticFiles.hs.cg
-  scaffold/messages/en.msg.cg
-  scaffold/static/js/modernizr.js.cg
+  scaffold/config/mongoDB.yml.cg
+  scaffold/devel.hs.cg
 
 
 flag ghc7