From 4676331db3c02728bc69df36f003c917ea43cf31 Mon Sep 17 00:00:00 2001 From: Piyush P Kurur Date: Sat, 17 Mar 2012 05:32:33 +0530 Subject: [PATCH 1/8] some documentation fixes to mkDispatchClause --- yesod-routes/Yesod/Routes/TH/Dispatch.hs | 26 +++++++++++++++++++----- 1 file changed, 21 insertions(+), 5 deletions(-) diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs index c8797bca..ab2424a7 100644 --- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs +++ b/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 From b13a3d38580af32c24b701277564b56e0d7107ba Mon Sep 17 00:00:00 2001 From: Nubis Date: Sun, 15 Jan 2012 19:05:46 +0800 Subject: [PATCH 2/8] integrated yesod tests to scaffolder. still work in progress --- package-list.sh | 3 +- yesod-test/LICENSE | 25 ++ yesod-test/README | 0 yesod-test/Setup.lhs | 7 + yesod-test/Yesod/Test.hs | 392 +++++++++++++++++++++++ yesod-test/Yesod/Test/TransversingCSS.hs | 177 ++++++++++ yesod-test/yesod-test.cabal | 40 +++ yesod/Scaffolding/Scaffolder.hs | 9 +- yesod/input/use-tests.cg | 6 + yesod/scaffold/Tests.hs.cg | 37 +++ yesod/scaffold/project.cabal.cg | 2 +- 11 files changed, 695 insertions(+), 3 deletions(-) create mode 100644 yesod-test/LICENSE create mode 100644 yesod-test/README create mode 100755 yesod-test/Setup.lhs create mode 100644 yesod-test/Yesod/Test.hs create mode 100644 yesod-test/Yesod/Test/TransversingCSS.hs create mode 100644 yesod-test/yesod-test.cabal create mode 100644 yesod/input/use-tests.cg create mode 100644 yesod/scaffold/Tests.hs.cg diff --git a/package-list.sh b/package-list.sh index c461efb3..a9b56aa6 100644 --- a/package-list.sh +++ b/package-list.sh @@ -10,4 +10,5 @@ pkgs=( ./yesod-routes ./yesod-auth ./yesod-sitemap ./yesod-default - ./yesod ) + ./yesod + ./yesod-test ) diff --git a/yesod-test/LICENSE b/yesod-test/LICENSE new file mode 100644 index 00000000..243990d1 --- /dev/null +++ b/yesod-test/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2010, Nubis. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/yesod-test/README b/yesod-test/README new file mode 100644 index 00000000..e69de29b diff --git a/yesod-test/Setup.lhs b/yesod-test/Setup.lhs new file mode 100755 index 00000000..06e2708f --- /dev/null +++ b/yesod-test/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs new file mode 100644 index 00000000..d15b310d --- /dev/null +++ b/yesod-test/Yesod/Test.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-| +Yesod.Test is a pragmatic framework for testing web applications built +using wai and persistent. + +By pragmatic I may also mean 'dirty'. It's main goal is to encourage integration +and system testing of web applications by making everything /easy to test/. + +Your tests are like browser sessions that keep track of cookies and the last +visited page. You can perform assertions on the content of HTML responses, +using css selectors to explore the document more easily. + +You can also easily build requests using forms present in the current page. +This is very useful for testing web applications built in yesod for example, +were your forms may have field names generated by the framework or a randomly +generated '_nonce' field. + +Your database is also directly available so you can use runDB to set up +backend pre-conditions, or to assert that your session is having the desired effect. + +This is the helloworld and kitchen sink. In this case for testing a yesod app. + +> import Yesod +> import Yesod.Static +> import qualified MySite.Settings as Settings +> import MySite.Models +> +> main :: IO a +> main = do +> cfg <- (loadConfig Test) >>= either fail return +> st <- static Settings.staticDir +> Settings.withConnectionPool (connStr cfg) $ \cnPool -> do +> -- ... Perhaps some code here to truncate your test database? +> app <- toWaiApp $ S4M st cfg +> runTests app cnPool $ mySuite +> +> mySuite = do +> describe "Basic navigation and assertions" $ do +> it "Gets a page that has a form, with auto generated fields and nonce" $ do +> doGet_ "url/of/page/with/form" -- Load a page +> statusIs 200 -- Assert the status was success +> +> bodyContains "Hello Person" -- Assert any part of the document contains some text. +> +> -- Perform css queries and assertions. +> htmlCount "form .main" 1 -- It matches 1 element +> htmlAllContain "h1#mainTitle" "Sign Up Now!" -- All matches have some text +> +> -- Performs the post using the current page to extract field values: +> doPost "url/to/post/to" $ do +> addNonce -- Add the _nonce field with the currently shown value +> +> -- Lookup field by the text on the labels pointing to them. +> byLabel "Email:" "gustavo@cerati.com" +> byLabel "Password:" "secret" +> byLabel "Confirm:" "secret" +> +> it "Sends another form, this one has a file" $ do +> doPost "url/to/post/file/to" $ do +> -- You can add files this easy, you still have to provide the mime type manually though. +> addFile "file_field_name" "path/to/local/file" "image/jpeg" +> +> -- And of course you can add any field if you know it's name +> byName "answer" "42" +> +> statusIs 302 +> +> describe "Db access, still very raw" $ do +> it "rubs the lotion on it's skin or else it gets the hose again" $ do +> msgs <- testDB $ do (selectList [] [] :: SqlPersist IO [(Key SqlPersist Message, Message)]) +> assertEqual "One Message in the DB" 1 (DL.length msgs) + +-} + +module Yesod.Test ( + -- * Declaring and running your test suite + runTests, describe, it, + + -- * Making requests + -- | To make a request you need to point to an url and pass in some parameters. + -- + -- To build your parameters you will use the RequestBuilder monad that lets you + -- add values, add files, lookup fields by label and find the current + -- nonce value and add it to your request too. + doPost, doPost_, doGet, doGet_, doRequest, + byName, byLabel, addFile, addNonce, addNonce_, + + -- * Running database queries + testDB, + + -- * Assertions + assertEqual, statusIs, bodyContains, htmlAllContain, htmlCount, + + -- * Utils for debugging tests + printBody, printMatches, + + -- * Utils for building your own assertions + -- | Please consider generalizing and contributing the assertions you write. + htmlQuery, parseHTML + +) + +where + +import qualified Test.Hspec.Core as Core +import qualified Test.Hspec.Runner as Runner +import qualified Data.List as DL +import qualified Data.Maybe as DY +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.ByteString.Lazy.Char8 as BSL8 +import qualified Test.HUnit as HUnit +import qualified Test.Hspec.HUnit () +import qualified Network.HTTP.Types as H +import qualified Network.Socket.Internal as Sock +import Text.XML.HXT.Core hiding (app, err, txt) +import Network.Wai +import Network.Wai.Test +import Control.Monad.Trans.State (get, put, execStateT, StateT) +import "monads-tf" Control.Monad.Trans +import System.IO +import Yesod.Test.TransversingCSS +import Database.Persist.GenericSql + +-- | The state used in 'describe' to build a list of specs +data SpecsData = SpecsData Application ConnectionPool [Core.Spec] + +-- | The specs state monad is where 'describe' runs. +type Specs = StateT SpecsData IO () + +-- | The state used in a single test case defined using 'it' +data OneSpecData = OneSpecData Application ConnectionPool CookieValue (Maybe SResponse) + +-- | The OneSpec state monad is where 'it' runs. +type OneSpec = StateT OneSpecData IO + +data RequestBuilderData = RequestBuilderData [RequestPart] (Maybe SResponse) + +-- | Request parts let us discern regular key/values from files sent in the request. +data RequestPart + = ReqPlainPart String String + | ReqFilePart String FilePath BSL8.ByteString String + +-- | The RequestBuilder state monad constructs an url encoded string of arguments +-- to send with your requests. Some of the functions that run on it use the current +-- response to analize the forms that the server is expecting to receive. +type RequestBuilder = StateT RequestBuilderData IO + +-- | Both the OneSpec and RequestBuilder monads hold a response that can be analized, +-- by making them instances of this class we can have general methods that work on +-- the last received response. +class HoldsResponse a where + readResponse :: a -> Maybe SResponse +instance HoldsResponse OneSpecData where + readResponse (OneSpecData _ _ _ x) = x +instance HoldsResponse RequestBuilderData where + readResponse (RequestBuilderData _ x) = x + +type CookieValue = H.Ascii + +-- | Runs your test suite, using you wai 'Application' and 'ConnectionPool' for performing +-- the database queries in your tests. +-- +-- You application may already have your connection pool but you need to pass another one +-- separately here. +-- +-- Look at the examples directory on this package to get an idea of the (small) amount of +-- boilerplate code you'll need to write before calling this. +runTests :: Application -> ConnectionPool -> Specs -> IO a +runTests app connection specsDef = do + (SpecsData _ _ specs) <- execStateT specsDef (SpecsData app connection []) + Runner.hspecX specs + +-- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application' +-- and 'ConnectionPool' +describe :: String -> Specs -> Specs +describe label action = do + sData <- get + SpecsData app conn specs <- liftIO $ execStateT action sData + put $ SpecsData app conn (Core.describe label [specs]) + +-- | Describe a single test that keeps cookies, and a reference to the last response. +it :: String -> OneSpec () -> Specs +it label action = do + SpecsData app conn specs <- get + let spec = Core.it label $ do + _ <- execStateT action $ OneSpecData app conn "" Nothing + return () + put $ SpecsData app conn (specs++spec) + +-- Performs a given action using the last response. +withResponse :: HoldsResponse a => b -> (SResponse -> StateT a IO b) -> StateT a IO b +withResponse e f = maybe err f =<< fmap readResponse get + where + err = do + liftIO $ HUnit.assertFailure "There was no response, you should make a request" + return e + +-- | Use HXT to parse a value from an html tag. +-- Check for usage examples in this module's source. +parseHTML :: String -> LA XmlTree a -> [a] +parseHTML html p = runLA (hread >>> p ) html + +-- | Query the last response using css selectors, returns a list of matched fragments +htmlQuery :: HoldsResponse a => Query -> StateT a IO [Html] +htmlQuery query = withResponse [] $ \ res -> + case findBySelector (BSL8.unpack $ simpleBody res) query of + Left err -> do + liftIO $ HUnit.assertFailure $ query ++ " did not parse: " ++ (show err) + return [] + Right matches -> return matches + +-- | Asserts that the two given values are equal. +assertEqual :: (Eq a) => String -> a -> a -> OneSpec () +assertEqual msg a b = liftIO $ HUnit.assertBool msg (a == b) + +-- | Assert the last response status is as expected. +statusIs :: HoldsResponse a => Int -> StateT a IO () +statusIs number = withResponse () $ \ SResponse { simpleStatus = s } -> + liftIO $ flip HUnit.assertBool (H.statusCode s == number) $ concat + [ "Expected status was ", show number + , " but received status was ", show $ H.statusCode s + ] + +-- | Assert the last response has the given text. The check is performed using the response +-- body in full text form. +bodyContains :: HoldsResponse a => String -> StateT a IO () +bodyContains txt = withResponse () $ \ res -> + liftIO $ HUnit.assertBool ("Expected body to contain " ++ txt) $ (simpleBody res) `contains` txt +contains :: BSL8.ByteString -> String -> Bool +contains a b = DL.isInfixOf b (BSL8.unpack a) + +-- | Queries the html using a css selector, and all matched elements must contain +-- the given string. +htmlAllContain :: HoldsResponse a => Query -> String -> StateT a IO () +htmlAllContain query search = do + matches <- htmlQuery query + case matches of + [] -> liftIO $ HUnit.assertFailure $ "Nothing matched css query: "++query + _ -> liftIO $ HUnit.assertBool ("Not all "++query++" contain "++search) $ + DL.all (DL.isInfixOf search) matches + +-- | Performs a css query on the last response and asserts the matched elements +-- are as many as expected. +htmlCount :: HoldsResponse a => Query -> Int -> StateT a IO () +htmlCount query count = do + matches <- fmap DL.length $ htmlQuery query + liftIO $ flip HUnit.assertBool (matches == count) + ("Expected "++(show count)++" elements to match "++query++", found "++(show matches)) + +-- | Outputs the last response body to stderr (So it doesn't get captured by HSpec) +printBody :: HoldsResponse a => StateT a IO () +printBody = withResponse () $ \ SResponse { simpleBody = b } -> + liftIO $ hPutStrLn stderr $ BSL8.unpack b + +-- | Performs a CSS query and print the matches to stderr. +printMatches :: HoldsResponse a => Query -> StateT a IO () +printMatches query = do + matches <- htmlQuery query + liftIO $ hPutStrLn stderr $ show matches + +-- | Add a parameter with the given name and value. +byName :: String -> String -> RequestBuilder () +byName name value = do + RequestBuilderData parts r <- get + put $ RequestBuilderData ((ReqPlainPart name value):parts) r + +-- | Add a file to be posted with the current request +-- +-- Adding a file will automatically change your request content-type to be multipart/form-data +addFile :: String -> FilePath -> String -> RequestBuilder () +addFile name path mimetype = do + RequestBuilderData parts r <- get + contents <- liftIO $ BSL8.readFile path + put $ RequestBuilderData ((ReqFilePart name path contents mimetype):parts) r + +-- | Some frameworks like Yesod cat auto generate field ids, so you are never sure what +-- the argument name should be for each one of your args when constructing +-- your requests. What you do know is the /label/ of the field. This looks up a label +-- and adds a parameter for the field name that label is pointing to. +-- +-- If the label or field it points to are not found its treated as a faild Hspec assertion. +byLabel :: String -> String -> RequestBuilder () +byLabel label value = withResponse () $ \ res -> do + let + body = BSL8.unpack $ simpleBody res + mfor = parseHTML body $ deep $ + hasName "label" >>> filterA (getChildren >>> hasText (DL.isInfixOf label)) >>> getAttrValue "for" + + case mfor of + for:[] -> do + let mname = parseHTML body $ deep $ hasAttrValue "id" (==for) >>> getAttrValue "name" + case mname of + "":_ -> liftIO $ HUnit.assertFailure $ + "Label "++label++" resolved to id "++for++" which was not found. " + name:_ -> byName name value + _ -> liftIO $ HUnit.assertFailure $ "More than one input with id " ++ for + [] -> liftIO $ HUnit.assertFailure $ "No label contained: "++label + _ -> liftIO $ HUnit.assertFailure $ "More than one label contained "++label + +-- | Useful for yesod testing: Lookup a _nonce form field and add it's value to the params +-- being built. Receives a selector that should point to the form containing the desired nonce. +addNonce_ :: String -> RequestBuilder () +addNonce_ scope = do + matches <- htmlQuery $ scope ++ "input[name=_nonce][type=hidden][value]" + case matches of + [] -> liftIO $ HUnit.assertFailure $ "No nonce found in the current page" + element:[] -> byName "_nonce" $ head $ parseHTML element $ getAttrValue "value" + _ -> liftIO $ HUnit.assertFailure $ "More than one nonce found in the page" + +-- | For responses that display a single form, lookup the current Nonce on the page and +-- add it to the params being built +addNonce :: RequestBuilder () +addNonce = addNonce_ "" + +-- | Perform a POST request to url, using params +doPost :: BS8.ByteString -> RequestBuilder () -> OneSpec () +doPost url paramsBuild = do + doRequest "POST" url paramsBuild + +-- | Perform a POST request without params +doPost_ :: BS8.ByteString -> OneSpec () +doPost_ = flip doPost $ return () + +-- | Perform a GET request to url, using params +doGet :: BS8.ByteString -> RequestBuilder () -> OneSpec () +doGet url paramsBuild = doRequest "GET" url paramsBuild + +-- | Perform a GET request without params +doGet_ :: BS8.ByteString -> OneSpec () +doGet_ = flip doGet $ return () + +-- | General interface to performing requests, letting you specify the request method and extra headers. +doRequest :: H.Method -> BS8.ByteString -> RequestBuilder a -> OneSpec () +doRequest method url paramsBuild = do + OneSpecData app conn cookie mRes <- get + RequestBuilderData parts _ <- liftIO $ execStateT paramsBuild $ RequestBuilderData [] mRes + let req = if DL.any isFile parts + then makeMultipart cookie parts + else makeSinglepart cookie parts + + response <- liftIO $ runSession (srequest req) app + let cookie' = DY.fromMaybe cookie $ fmap snd $ DL.find (("Set-Cookie"==) . fst) $ simpleHeaders response + put $ OneSpecData app conn cookie' (Just response) + where + isFile (ReqFilePart _ _ _ _) = True + isFile _ = False + + -- For building the multi-part requests + boundary :: String + boundary = "*******noneedtomakethisrandom" + separator = BS8.concat ["--", BS8.pack boundary, "\r\n"] + makeMultipart cookie parts = + flip SRequest (BSL8.fromChunks [multiPartBody parts]) $ mkRequest + [ ("Cookie", cookie) + , ("Content-Type", BS8.pack $ "multipart/form-data; boundary=" ++ boundary)] + multiPartBody parts = BS8.concat $ separator : [BS8.concat [multipartPart p, separator] | p <- parts] + multipartPart (ReqPlainPart k v) = BS8.concat + [ "Content-Disposition: form-data; " + , "name=\"", (BS8.pack k), "\"\r\n\r\n" + , (BS8.pack v), "\r\n"] + multipartPart (ReqFilePart k v bytes mime) = BS8.concat + [ "Content-Disposition: form-data; " + , "name=\"", BS8.pack k, "\"; " + , "filename=\"", BS8.pack v, "\"\r\n" + , "Content-Type: ", BS8.pack mime, "\r\n\r\n" + , BS8.concat $ BSL8.toChunks bytes, "\r\n"] + + -- For building the regular non-multipart requests + makeSinglepart cookie parts = + SRequest (mkRequest [("Cookie",cookie), ("Content-Type", "application/x-www-form-urlencoded")]) $ + BSL8.pack $ DL.concat $ DL.intersperse "&" $ map singlepartPart parts + singlepartPart (ReqFilePart _ _ _ _) = "" + singlepartPart (ReqPlainPart k v) = concat [k,"=",v] + + -- General request making + mkRequest headers = defaultRequest + { requestMethod = method + , remoteHost = Sock.SockAddrInet 1 2 + , requestHeaders = headers + , rawPathInfo = url + , pathInfo = T.split (== '/') $ TE.decodeUtf8 url + } + +-- | Run a persistent db query. For asserting on the results of performed actions +-- or setting up pre-conditions. At the moment this part is still very raw. +testDB :: SqlPersist IO a -> OneSpec a +testDB query = do + OneSpecData _ pool _ _ <- get + liftIO $ runSqlPool query pool diff --git a/yesod-test/Yesod/Test/TransversingCSS.hs b/yesod-test/Yesod/Test/TransversingCSS.hs new file mode 100644 index 00000000..8d697bbc --- /dev/null +++ b/yesod-test/Yesod/Test/TransversingCSS.hs @@ -0,0 +1,177 @@ +{- | +This module uses HXT to transverse an HTML document using CSS selectors. + +The most important function here is 'findBySelector', it takes a CSS query and +a string containing the HTML to look into, +and it returns a list of the HTML fragments that matched the given query. + +Only a subset of the CSS spec is currently supported: + + * By tag name: /table td a/ + + * By class names: /.container .content/ + + * By Id: /#oneId/ + + * By attribute: /[hasIt]/, /[exact=match]/, /[contains*=text]/, /[starts^=with]/, /[ends$=with]/ + + * Union: /a, span, p/ + + * Immediate children: /div > p/ + + * Get jiggy with it: /div[data-attr=yeah] > .mon, .foo.bar div, #oneThing/ + +-} + +module Yesod.Test.TransversingCSS ( + findBySelector, + Html, + Query, + -- * For HXT hackers + -- | These functions expose some low level details that you can blissfully ignore. + parseQuery, + runQuery, + queryToArrow, + Selector(..), + SelectorGroup(..) + + ) +where + +import Text.XML.HXT.Core +import qualified Data.List as DL +import Text.ParserCombinators.Parsec +import Text.Parsec.Prim (Parsec) + +type Html = String +type Query = String + +-- | Perform a css 'Query' on 'Html'. Returns Either +-- +-- * Left: Query parse error. +-- +-- * Right: List of matching Html fragments. +findBySelector :: Html-> Query -> Either ParseError [Html] +findBySelector html query = fmap (runQuery html) (parseQuery query) + +-- Run a compiled query on Html, returning a list of matching Html fragments. +runQuery :: Html -> [[SelectorGroup]] -> [Html] +runQuery html query = + runLA (hread >>> (queryToArrow query) >>> xshow this) html + +-- | Transform a compiled query into the HXT arrow that finally transverses the Html +queryToArrow :: ArrowXml a => [[SelectorGroup]] -> a XmlTree XmlTree +queryToArrow commaSeparated = + DL.foldl uniteCommaSeparated none commaSeparated + where + uniteCommaSeparated accum selectorGroups = + accum <+> (DL.foldl sequenceSelectorGroups this selectorGroups) + sequenceSelectorGroups accum (DirectChildren sels) = + accum >>> getChildren >>> (DL.foldl applySelectors this $ sels) + sequenceSelectorGroups accum (DeepChildren sels) = + accum >>> getChildren >>> multi (DL.foldl applySelectors this $ sels) + applySelectors accum selector = accum >>> (toArrow selector) + toArrow selector = case selector of + ById v -> hasAttrValue "id" (==v) + ByClass v -> hasAttrValue "class" ((DL.elem v) . words) + ByTagName v -> hasName v + ByAttrExists n -> hasAttr n + ByAttrEquals n v -> hasAttrValue n (==v) + ByAttrContains n v -> hasAttrValue n (DL.isInfixOf v) + ByAttrStarts n v -> hasAttrValue n (DL.isPrefixOf v) + ByAttrEnds n v -> hasAttrValue n (DL.isSuffixOf v) + +-- | Parses a query into an intermediate format which is easy to feed to HXT +-- +-- * The top-level lists represent the top level comma separated queries. +-- +-- * SelectorGroup is a group of qualifiers which are separated +-- with spaces or > like these three: /table.main.odd tr.even > td.big/ +-- +-- * A SelectorGroup as a list of Selector items, following the above example +-- the selectors in the group are: /table/, /.main/ and /.odd/ +parseQuery :: String -> Either ParseError [[SelectorGroup]] +parseQuery = parse cssQuery "" + +data SelectorGroup + = DirectChildren [Selector] + | DeepChildren [Selector] + deriving Show + +data Selector + = ById String + | ByClass String + | ByTagName String + | ByAttrExists String + | ByAttrEquals String String + | ByAttrContains String String + | ByAttrStarts String String + | ByAttrEnds String String + deriving Show + +-- Below this line is the Parsec parser for css queries. +cssQuery :: Parsec String u [[SelectorGroup]] +cssQuery = sepBy rules (char ',' >> (optional (char ' '))) + +rules :: Parsec String u [SelectorGroup] +rules = many $ directChildren <|> deepChildren + +directChildren :: Parsec String u SelectorGroup +directChildren = do + _ <- char '>' + _ <- char ' ' + sels <- selectors + optional $ char ' ' + return $ DirectChildren sels + +deepChildren :: Parsec String u SelectorGroup +deepChildren = do + sels <- selectors + optional $ char ' ' + return $ DeepChildren sels + +selectors :: Parsec String u [Selector] +selectors = many1 $ parseId + <|> parseClass + <|> parseTag + <|> parseAttr + +parseId :: Parsec String u Selector +parseId = do + _ <- char '#' + x <- many $ noneOf ",#.[ >" + return $ ById x + +parseClass :: Parsec String u Selector +parseClass = do + _ <- char '.' + x <- many $ noneOf ",#.[ >" + return $ ByClass x + +parseTag :: Parsec String u Selector +parseTag = do + x <- many1 $ noneOf ",#.[ >" + return $ ByTagName x + +parseAttr :: Parsec String u Selector +parseAttr = do + _ <- char '[' + name <- many $ noneOf ",#.=$^*]" + (parseAttrExists name) + <|> (parseAttrWith "=" ByAttrEquals name) + <|> (parseAttrWith "*=" ByAttrContains name) + <|> (parseAttrWith "^=" ByAttrStarts name) + <|> (parseAttrWith "$=" ByAttrEnds name) + +parseAttrExists :: String -> Parsec String u Selector +parseAttrExists attrname = do + _ <- char ']' + return $ ByAttrExists attrname + +parseAttrWith :: String -> (String -> String -> Selector) -> String -> Parsec String u Selector +parseAttrWith sign constructor name = do + _ <- string sign + value <- many $ noneOf ",#.]" + _ <- char ']' + return $ constructor name value + diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal new file mode 100644 index 00000000..d85fddb8 --- /dev/null +++ b/yesod-test/yesod-test.cabal @@ -0,0 +1,40 @@ +name: yesod-test +version: 0.1 +license: BSD3 +license-file: LICENSE +author: Nubis +maintainer: Nubis +synopsis: Behaviour Oriented integration Testing for Yesod Applications +category: Web, Yesod, Testing +stability: Experimental +cabal-version: >= 1.6 +build-type: Simple +homepage: http://www.yesodweb.com +description: Behaviour Oriented integration Testing for Yesod Applications +extra-source-files: README.md, LICENSE + +library + build-depends: hxt >= 9.1.5 + , parsec >= 3.1.1 + , base + , containers + , filepath + , persistent >= 0.6.4 + , monad-control >= 0.2 + , transformers >= 0.2 + , wai-test + , wai >= 0.4 + , ascii + , network + , http-types >= 0.6 + , hspec >= 0.9 + , HUnit >= 1.0 + , bytestring + , text + , monads-tf + exposed-modules: Yesod.Test + ghc-options: -Wall + +source-repository head + type: git + location: git://github.com/yesodweb/yesod.git diff --git a/yesod/Scaffolding/Scaffolder.hs b/yesod/Scaffolding/Scaffolder.hs index 9ee58e6e..ccc50add 100644 --- a/yesod/Scaffolding/Scaffolder.hs +++ b/yesod/Scaffolding/Scaffolder.hs @@ -5,7 +5,7 @@ module Scaffolding.Scaffolder (scaffold) where import Scaffolding.CodeGen import Language.Haskell.TH.Syntax -import Control.Monad (unless) +import Control.Monad (unless, when) import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT import qualified Data.ByteString.Lazy as L @@ -83,6 +83,11 @@ scaffold = do uncapitalize s = toLower (head s) : tail s backendLower = uncapitalize $ show backend upper = show backend + + puts $(codegenDir "input" "use-tests") + useTestsC <- prompt $ flip elem $ [return 'y', return 'n'] + let useTests = useTestsC == "y" + let testsDep = if useTests then ", yesod-test" else "" let runMigration = case backend of @@ -145,6 +150,7 @@ scaffold = do mkDir "deploy" mkDir "Settings" mkDir "messages" + mkDir "tests" writeFile' ("deploy/Procfile") $(codegen "deploy/Procfile") @@ -188,6 +194,7 @@ scaffold = do $(codegen "templates/homepage.julius") unless isTiny $ writeFile' "config/models" $(codegen "config/models") writeFile' "messages/en.msg" $(codegen "messages/en.msg") + when useTests $ writeFile' "Tests.hs" $(codegen "Tests.hs") S.writeFile (dir ++ "/static/js/modernizr.js") $(runIO (S.readFile "scaffold/static/js/modernizr.js.cg") >>= \bs -> diff --git a/yesod/input/use-tests.cg b/yesod/input/use-tests.cg new file mode 100644 index 00000000..2a9f4212 --- /dev/null +++ b/yesod/input/use-tests.cg @@ -0,0 +1,6 @@ +Yesod also comes with an optional integration tests tool. +You should always test your application, the only reason +not to use the yesod testing facilities is because you +already have some other testing tool that you like better. + +Include tests?: diff --git a/yesod/scaffold/Tests.hs.cg b/yesod/scaffold/Tests.hs.cg new file mode 100644 index 00000000..69e96c24 --- /dev/null +++ b/yesod/scaffold/Tests.hs.cg @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module Testing (main) where + +import Import +import Settings +import Yesod +import Yesod.Static +import Yesod.Logger (makeLogger) +import qualified Database.Persist.Base +import Database.Persist.GenericSql (runMigration) +import Yesod.Default.Config +import Yesod.Test +import Application + +main :: IO a +main = do + conf <- loadConfig Testing + logger <- makeLogger + dbconf <- withYamlEnvironment "config/~dbConfigFile~.yml" (appEnv conf) + $ either error return . Database.Persist.Base.loadConfig + s <- static Settings.staticDir + Database.Persist.Base.withPool (dbconf :: Settings.PersistConfig) $ \p -> do + Database.Persist.Base.runPool dbconf ~runMigration~ p + app <- toWaiAppPlain $ ~sitearg~ conf logger s p + runTests app p allTests + +allTests = do + describe "These are some example tests" $ do + it "loads the index and checks it looks right" $ do + doGet_ "." + printBody + statusIs 200 + htmlCount "form" 1 + htmlAllContain "h1" "Welcome to Yesod!" + diff --git a/yesod/scaffold/project.cabal.cg b/yesod/scaffold/project.cabal.cg index dde270a9..fb5874ed 100644 --- a/yesod/scaffold/project.cabal.cg +++ b/yesod/scaffold/project.cabal.cg @@ -97,4 +97,4 @@ executable ~project~ , wai-extra >= 1.0 && < 1.2 , yaml >= 0.5 && < 0.6 , http-conduit >= 1.2 && < 1.3 - + ~testsDep~ From a72a62827b9067d8389a5aed487b13bd877a8649 Mon Sep 17 00:00:00 2001 From: Nubis Date: Tue, 17 Jan 2012 11:40:35 +0800 Subject: [PATCH 3/8] Fixed dependencies --- yesod-core/yesod-core.cabal | 1 - yesod-test/yesod-test.cabal | 36 ++++++++++++++++++------------------ 2 files changed, 18 insertions(+), 19 deletions(-) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 4a4c7ac7..64be3d76 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -81,7 +81,6 @@ library , wai-logger >= 0.0.1 , conduit >= 0.2 && < 0.3 , lifted-base >= 0.1 && < 0.2 - exposed-modules: Yesod.Content Yesod.Core Yesod.Dispatch diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index d85fddb8..6d268d1e 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -13,25 +13,25 @@ homepage: http://www.yesodweb.com description: Behaviour Oriented integration Testing for Yesod Applications extra-source-files: README.md, LICENSE +flag ghc7 + 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 + 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 exposed-modules: Yesod.Test ghc-options: -Wall From a7ce59cd2a98d948766e3747f212fba4f30a88dc Mon Sep 17 00:00:00 2001 From: Nubis Date: Tue, 24 Jan 2012 19:27:35 +0800 Subject: [PATCH 4/8] integrated scaffold and improved scaffolded site --- yesod-test/Yesod/Test.hs | 256 ++++++++---------- yesod-test/yesod-test.cabal | 2 + yesod/Scaffolding/Scaffolder.hs | 15 +- yesod/scaffold/Handler/Root.hs.cg | 26 +- yesod/scaffold/cabal_test_suite.cg | 42 +++ yesod/scaffold/config/mongoDB.yml.cg | 2 +- yesod/scaffold/config/postgresql.yml.cg | 2 +- yesod/scaffold/config/routes.cg | 2 +- yesod/scaffold/config/sqlite.yml.cg | 2 +- .../templates/boilerplate-wrapper.hamlet.cg | 42 +++ .../templates/default-layout.lucius.cg | 52 +++- yesod/scaffold/templates/homepage.hamlet.cg | 41 ++- yesod/scaffold/templates/homepage.lucius.cg | 2 +- yesod/scaffold/tests_main.hs.cg | 46 ++++ 14 files changed, 381 insertions(+), 151 deletions(-) create mode 100644 yesod/scaffold/cabal_test_suite.cg create mode 100644 yesod/scaffold/templates/boilerplate-wrapper.hamlet.cg create mode 100644 yesod/scaffold/tests_main.hs.cg diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index d15b310d..3548ddf8 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -19,63 +19,11 @@ 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, + runTests, describe, it, Specs, OneSpec, -- * Making requests -- | To make a request you need to point to an url and pass in some parameters. @@ -83,11 +31,23 @@ module Yesod.Test ( -- 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_, + -- + 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 - testDB, + runDB, -- * Assertions assertEqual, statusIs, bodyContains, htmlAllContain, htmlCount, @@ -115,11 +75,11 @@ 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 Text.XML.HXT.Core hiding (app, err) import Network.Wai import Network.Wai.Test -import Control.Monad.Trans.State (get, put, execStateT, StateT) -import "monads-tf" Control.Monad.Trans +import qualified Control.Monad.Trans.State as ST +import Control.Monad.IO.Class import System.IO import Yesod.Test.TransversingCSS import Database.Persist.GenericSql @@ -128,13 +88,13 @@ import Database.Persist.GenericSql data SpecsData = SpecsData Application ConnectionPool [Core.Spec] -- | The specs state monad is where 'describe' runs. -type Specs = StateT SpecsData IO () +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 = StateT OneSpecData IO +type OneSpec = ST.StateT OneSpecData IO data RequestBuilderData = RequestBuilderData [RequestPart] (Maybe SResponse) @@ -146,7 +106,7 @@ data RequestPart -- | 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 +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 @@ -170,33 +130,30 @@ type CookieValue = H.Ascii -- 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 []) + (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 <- get - SpecsData app conn specs <- liftIO $ execStateT action sData - put $ SpecsData app conn (Core.describe label [specs]) + 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 <- get + SpecsData app conn specs <- ST.get let spec = Core.it label $ do - _ <- execStateT action $ OneSpecData app conn "" Nothing + _ <- ST.execStateT action $ OneSpecData app conn "" Nothing return () - put $ SpecsData app conn (specs++spec) + ST.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 +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. @@ -204,12 +161,10 @@ 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 -> +htmlQuery :: HoldsResponse a => Query -> ST.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 [] + Left err -> failure $ query ++ " did not parse: " ++ (show err) Right matches -> return matches -- | Asserts that the two given values are equal. @@ -217,8 +172,8 @@ 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 } -> +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 @@ -226,37 +181,39 @@ statusIs number = withResponse () $ \ SResponse { simpleStatus = 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 +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 -> StateT a IO () +htmlAllContain :: HoldsResponse a => Query -> String -> ST.StateT a IO () htmlAllContain query search = do matches <- htmlQuery query case matches of - [] -> liftIO $ HUnit.assertFailure $ "Nothing matched css query: "++query + [] -> 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 -> StateT a IO () +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 => StateT a IO () -printBody = withResponse () $ \ SResponse { simpleBody = b } -> +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 -> StateT a IO () +printMatches :: HoldsResponse a => Query -> ST.StateT a IO () printMatches query = do matches <- htmlQuery query liftIO $ hPutStrLn stderr $ show matches @@ -264,86 +221,103 @@ printMatches query = do -- | 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 + 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 -addFile :: String -> FilePath -> String -> RequestBuilder () -addFile name path mimetype = do - RequestBuilderData parts r <- get +fileByName :: String -> FilePath -> String -> RequestBuilder () +fileByName name path mimetype = do + RequestBuilderData parts r <- ST.get contents <- liftIO $ BSL8.readFile path - put $ RequestBuilderData ((ReqFilePart name path contents mimetype):parts) r + ST.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 +-- 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 - mfor = parseHTML body $ deep $ - hasName "label" >>> filterA (getChildren >>> hasText (DL.isInfixOf label)) >>> getAttrValue "for" + 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 - "":_ -> 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 + "":_ -> 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 --- | 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. +-- | 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 - [] -> liftIO $ HUnit.assertFailure $ "No nonce found in the current page" + [] -> failure $ "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" + _ -> failure $ "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 +-- | 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 -doPost :: BS8.ByteString -> RequestBuilder () -> OneSpec () -doPost url paramsBuild = do +post :: BS8.ByteString -> RequestBuilder () -> OneSpec () +post url paramsBuild = do doRequest "POST" url paramsBuild -- | Perform a POST request without params -doPost_ :: BS8.ByteString -> OneSpec () -doPost_ = flip doPost $ return () +post_ :: BS8.ByteString -> OneSpec () +post_ = flip post $ return () -- | Perform a GET request to url, using params -doGet :: BS8.ByteString -> RequestBuilder () -> OneSpec () -doGet url paramsBuild = doRequest "GET" url paramsBuild +get :: BS8.ByteString -> RequestBuilder () -> OneSpec () +get url paramsBuild = doRequest "GET" url paramsBuild -- | Perform a GET request without params -doGet_ :: BS8.ByteString -> OneSpec () -doGet_ = flip doGet $ return () +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 <- get - RequestBuilderData parts _ <- liftIO $ execStateT paramsBuild $ RequestBuilderData [] mRes + 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 - put $ OneSpecData app conn cookie' (Just response) + ST.put $ OneSpecData app conn cookie' (Just response) where isFile (ReqFilePart _ _ _ _) = True isFile _ = False @@ -356,7 +330,8 @@ doRequest method url paramsBuild = do 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] + 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" @@ -369,9 +344,10 @@ doRequest method url paramsBuild = do , 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 + 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] @@ -381,12 +357,16 @@ doRequest method url paramsBuild = do , remoteHost = Sock.SockAddrInet 1 2 , requestHeaders = headers , rawPathInfo = url - , pathInfo = T.split (== '/') $ TE.decodeUtf8 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. -testDB :: SqlPersist IO a -> OneSpec a -testDB query = do - OneSpecData _ pool _ _ <- get +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 "" diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 6d268d1e..754d99b0 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -32,7 +32,9 @@ library , 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 diff --git a/yesod/Scaffolding/Scaffolder.hs b/yesod/Scaffolding/Scaffolder.hs index ccc50add..af79fddd 100644 --- a/yesod/Scaffolding/Scaffolder.hs +++ b/yesod/Scaffolding/Scaffolder.hs @@ -135,10 +135,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" @@ -150,7 +152,6 @@ scaffold = do mkDir "deploy" mkDir "Settings" mkDir "messages" - mkDir "tests" writeFile' ("deploy/Procfile") $(codegen "deploy/Procfile") @@ -168,6 +169,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") @@ -194,7 +198,10 @@ 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") + + 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 -> diff --git a/yesod/scaffold/Handler/Root.hs.cg b/yesod/scaffold/Handler/Root.hs.cg index 708a5382..1d5c1762 100644 --- a/yesod/scaffold/Handler/Root.hs.cg +++ b/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 diff --git a/yesod/scaffold/cabal_test_suite.cg b/yesod/scaffold/cabal_test_suite.cg new file mode 100644 index 00000000..806b57b6 --- /dev/null +++ b/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 diff --git a/yesod/scaffold/config/mongoDB.yml.cg b/yesod/scaffold/config/mongoDB.yml.cg index b97d7dfa..a7ba4064 100644 --- a/yesod/scaffold/config/mongoDB.yml.cg +++ b/yesod/scaffold/config/mongoDB.yml.cg @@ -9,7 +9,7 @@ Default: &defaults Development: <<: *defaults -Test: +Testing: database: ~project~_test <<: *defaults diff --git a/yesod/scaffold/config/postgresql.yml.cg b/yesod/scaffold/config/postgresql.yml.cg index aceae393..56b718f5 100644 --- a/yesod/scaffold/config/postgresql.yml.cg +++ b/yesod/scaffold/config/postgresql.yml.cg @@ -9,7 +9,7 @@ Default: &defaults Development: <<: *defaults -Test: +Testing: database: ~project~_test <<: *defaults diff --git a/yesod/scaffold/config/routes.cg b/yesod/scaffold/config/routes.cg index 7a0bb067..ac818391 100644 --- a/yesod/scaffold/config/routes.cg +++ b/yesod/scaffold/config/routes.cg @@ -4,4 +4,4 @@ /favicon.ico FaviconR GET /robots.txt RobotsR GET -/ RootR GET +/ RootR GET POST diff --git a/yesod/scaffold/config/sqlite.yml.cg b/yesod/scaffold/config/sqlite.yml.cg index ebee1fa8..499afd76 100644 --- a/yesod/scaffold/config/sqlite.yml.cg +++ b/yesod/scaffold/config/sqlite.yml.cg @@ -5,7 +5,7 @@ Default: &defaults Development: <<: *defaults -Test: +Testing: database: ~project~_test.sqlite3 <<: *defaults diff --git a/yesod/scaffold/templates/boilerplate-wrapper.hamlet.cg b/yesod/scaffold/templates/boilerplate-wrapper.hamlet.cg new file mode 100644 index 00000000..11b34199 --- /dev/null +++ b/yesod/scaffold/templates/boilerplate-wrapper.hamlet.cg @@ -0,0 +1,42 @@ +\ +\ +\ +\ +\ + + + + + #{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]--> \ No newline at end of file diff --git a/yesod/scaffold/templates/default-layout.lucius.cg b/yesod/scaffold/templates/default-layout.lucius.cg index 853ac29a..59c6386b 100644 --- a/yesod/scaffold/templates/default-layout.lucius.cg +++ b/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; } diff --git a/yesod/scaffold/templates/homepage.hamlet.cg b/yesod/scaffold/templates/homepage.hamlet.cg index e8907860..07f2084b 100644 --- a/yesod/scaffold/templates/homepage.hamlet.cg +++ b/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> diff --git a/yesod/scaffold/templates/homepage.lucius.cg b/yesod/scaffold/templates/homepage.lucius.cg index f8fa5617..54986f81 100644 --- a/yesod/scaffold/templates/homepage.lucius.cg +++ b/yesod/scaffold/templates/homepage.lucius.cg @@ -1,6 +1,6 @@ h1 { text-align: center } -h2##{h2id} { +h2##{aDomId} { color: #990 } diff --git a/yesod/scaffold/tests_main.hs.cg b/yesod/scaffold/tests_main.hs.cg new file mode 100644 index 00000000..596ed2a5 --- /dev/null +++ b/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" From 7803cbb10eb1f3e36203ca09a2bfe76368f087ed Mon Sep 17 00:00:00 2001 From: Nubis <nubis@woobiz.com.ar> Date: Tue, 24 Jan 2012 19:29:57 +0800 Subject: [PATCH 5/8] deleted old tests module --- yesod/scaffold/Tests.hs.cg | 37 ------------------------------------- 1 file changed, 37 deletions(-) delete mode 100644 yesod/scaffold/Tests.hs.cg diff --git a/yesod/scaffold/Tests.hs.cg b/yesod/scaffold/Tests.hs.cg deleted file mode 100644 index 69e96c24..00000000 --- a/yesod/scaffold/Tests.hs.cg +++ /dev/null @@ -1,37 +0,0 @@ -{-# 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!" - From 494b2be2998ef04b10b869d7b898c1f84b8a4994 Mon Sep 17 00:00:00 2001 From: gregwebs <greg@gregweber.info> Date: Fri, 16 Mar 2012 21:18:41 -0700 Subject: [PATCH 6/8] cleanup test branch --- package-list.sh | 3 +-- yesod-test/yesod-test.cabal | 6 +++--- yesod/Scaffolding/Scaffolder.hs | 4 +--- 3 files changed, 5 insertions(+), 8 deletions(-) diff --git a/package-list.sh b/package-list.sh index a9b56aa6..abbfbfa3 100644 --- a/package-list.sh +++ b/package-list.sh @@ -10,5 +10,4 @@ pkgs=( ./yesod-routes ./yesod-auth ./yesod-sitemap ./yesod-default - ./yesod - ./yesod-test ) + ./yesod ) diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 754d99b0..293839a5 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -23,10 +23,10 @@ library build-depends: base >= 4 && < 4.3 build-depends: hxt >= 9.1.6 , parsec >= 2.1 && < 4 - , persistent >= 0.7 && < 0.8 + , persistent >= 0.8 && < 0.9 , transformers >= 0.2.2 && < 0.3 - , wai >= 1.0 && < 1.1 - , wai-test >= 1.0 && < 1.1 + , 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 diff --git a/yesod/Scaffolding/Scaffolder.hs b/yesod/Scaffolding/Scaffolder.hs index af79fddd..d386c203 100644 --- a/yesod/Scaffolding/Scaffolder.hs +++ b/yesod/Scaffolding/Scaffolder.hs @@ -84,9 +84,7 @@ scaffold = do 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 useTests = True let testsDep = if useTests then ", yesod-test" else "" let runMigration = From 17cecdad80468bc293978052407b7cddd464751d Mon Sep 17 00:00:00 2001 From: gregwebs <greg@gregweber.info> Date: Fri, 16 Mar 2012 21:52:49 -0700 Subject: [PATCH 7/8] add documentation --- yesod-test/README | 0 yesod-test/README.md | 75 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 75 insertions(+) delete mode 100644 yesod-test/README create mode 100644 yesod-test/README.md diff --git a/yesod-test/README b/yesod-test/README deleted file mode 100644 index e69de29b..00000000 diff --git a/yesod-test/README.md b/yesod-test/README.md new file mode 100644 index 00000000..23b81daf --- /dev/null +++ b/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 + 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 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: + 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 "selects the list" $ do + msgs <- testDB $ do (selectList [] [] :: SqlPersist IO [(Key SqlPersist Message, Message)]) + assertEqual "One Message in the DB" 1 (DL.length msgs) + +``` + From 32d11e886d7f8a5be98f78d5e3e87afa3662b51c Mon Sep 17 00:00:00 2001 From: gregwebs <greg@gregweber.info> Date: Fri, 16 Mar 2012 22:20:16 -0700 Subject: [PATCH 8/8] more testing cleanup --- yesod-test/README.md | 6 +-- yesod-test/yesod-test.cabal | 2 +- yesod/Scaffolding/Scaffolder.hs | 2 +- yesod/scaffold/cabal_test_suite.cg | 23 --------- yesod/scaffold/templates/homepage.hamlet.cg | 11 ++--- yesod/scaffold/templates/homepage.julius.cg | 2 +- .../{tests_main.hs.cg => tests/main.hs.cg} | 6 +-- yesod/yesod.cabal | 47 ++++++++++--------- 8 files changed, 38 insertions(+), 61 deletions(-) rename yesod/scaffold/{tests_main.hs.cg => tests/main.hs.cg} (90%) diff --git a/yesod-test/README.md b/yesod-test/README.md index 23b81daf..6a34bea7 100644 --- a/yesod-test/README.md +++ b/yesod-test/README.md @@ -38,7 +38,7 @@ This is the helloworld and kitchen sink. In this case for testing a yesod app. mySuite = do describe "Basic navigation and assertions" $ do it "Gets a page that has a form, with auto generated fields and token" $ do - doGet_ "url/of/page/with/form" -- Load a page + 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. @@ -48,7 +48,7 @@ This is the helloworld and kitchen sink. In this case for testing a yesod app. 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 + 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. @@ -57,7 +57,7 @@ This is the helloworld and kitchen sink. In this case for testing a yesod app. byLabel "Confirm:" "secret" it "Sends another form, this one has a file" $ do - doPost "url/to/post/file/to" $ 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" diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 293839a5..982d91c4 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -4,7 +4,7 @@ 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 +synopsis: integration testing for WAI/Yesod Applications category: Web, Yesod, Testing stability: Experimental cabal-version: >= 1.6 diff --git a/yesod/Scaffolding/Scaffolder.hs b/yesod/Scaffolding/Scaffolder.hs index d386c203..e4add9e3 100644 --- a/yesod/Scaffolding/Scaffolder.hs +++ b/yesod/Scaffolding/Scaffolder.hs @@ -199,7 +199,7 @@ scaffold = do when useTests $ do mkDir "tests" - writeFile' "tests/main.hs" $(codegen "tests_main.hs") + 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 -> diff --git a/yesod/scaffold/cabal_test_suite.cg b/yesod/scaffold/cabal_test_suite.cg index 806b57b6..a6b5eae2 100644 --- a/yesod/scaffold/cabal_test_suite.cg +++ b/yesod/scaffold/cabal_test_suite.cg @@ -16,27 +16,4 @@ test-suite integration-tests 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 diff --git a/yesod/scaffold/templates/homepage.hamlet.cg b/yesod/scaffold/templates/homepage.hamlet.cg index 07f2084b..ae0f27f7 100644 --- a/yesod/scaffold/templates/homepage.hamlet.cg +++ b/yesod/scaffold/templates/homepage.hamlet.cg @@ -1,13 +1,10 @@ <h1>_{MsgHello} -<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>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>. diff --git a/yesod/scaffold/templates/homepage.julius.cg b/yesod/scaffold/templates/homepage.julius.cg index d636ce89..efae7990 100644 --- a/yesod/scaffold/templates/homepage.julius.cg +++ b/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."; diff --git a/yesod/scaffold/tests_main.hs.cg b/yesod/scaffold/tests/main.hs.cg similarity index 90% rename from yesod/scaffold/tests_main.hs.cg rename to yesod/scaffold/tests/main.hs.cg index 596ed2a5..a9e8e47b 100644 --- a/yesod/scaffold/tests_main.hs.cg +++ b/yesod/scaffold/tests/main.hs.cg @@ -12,19 +12,19 @@ import qualified Database.Persist.Store import Database.Persist.GenericSql (runMigration) import Yesod.Default.Config import Yesod.Test -import Network.HTTP.Conduit (newManagerIO) +import Network.HTTP.Conduit (newManager, def) import Application() main :: IO a main = do conf <- loadConfig $ (configSettings Testing) { csParseExtra = parseExtra } - manager <- newManagerIO 10 + 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 + app <- toWaiAppPlain $ ~sitearg~ conf logger s p manager dbconf runTests app p allTests allTests :: Specs diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index 1fd725ba..37653aee 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -19,46 +19,49 @@ 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/templates/homepage.hamlet.cg - scaffold/templates/default-layout.hamlet.cg - scaffold/templates/default-layout-wrapper.hamlet.cg scaffold/deploy/Procfile.cg - scaffold/main.hs.cg - scaffold/devel.hs.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/templates/normalize.lucius.cg + scaffold/templates/boilerplate-wrapper.hamlet.cg + scaffold/templates/homepage.lucius.cg scaffold/Handler/Root.hs.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