yesod-test 0.3.5 → 1.2.0
raw patch · 4 files changed
+396/−222 lines, 4 filesdep +yesod-coredep +yesod-form
Dependencies added: yesod-core, yesod-form
Files
- Yesod/Test.hs +317/−218
- Yesod/Test/TransversingCSS.hs +3/−3
- test/main.hs +71/−0
- yesod-test.cabal +5/−1
Yesod/Test.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-} {-| 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/. +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,@@ -22,51 +23,74 @@ -} -module Yesod.Test (- -- * Declaring and running your test suite- runTests, describe, it, SpecsConn, 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, doRequestHeaders,- 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,+module Yesod.Test+ ( -- * Declaring and running your test suite+ yesodSpec+ , YesodSpec+ , YesodExample+ , YesodSpecTree (..)+ , ydescribe+ , yit - -- | Does the current form have a _nonce? Use any of these to add it to your- -- request parameters.- addNonce, addNonce_,+ -- * 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.+ --+ , get+ , post+ , request+ , addRequestHeader+ , setMethod+ , addPostParam+ , addGetParam+ , addFile+ , RequestBuilder+ , setUrl - -- * Running database queries- runDBRunner,+ -- | Yesod can 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 - -- * Assertions- assertEqual, assertHeader, assertNoHeader, statusIs, bodyEquals, bodyContains,- htmlAllContain, htmlAnyContain, htmlCount,+ -- | Does the current form have a _nonce? Use any of these to add it to your+ -- request parameters.+ , addNonce+ , addNonce_ - -- * Utils for debugging tests- printBody, printMatches,+ -- * Assertions+ , assertEqual+ , assertHeader+ , assertNoHeader+ , statusIs+ , bodyEquals+ , bodyContains+ , htmlAllContain+ , htmlAnyContain+ , htmlCount - -- * Utils for building your own assertions- -- | Please consider generalizing and contributing the assertions you write.- htmlQuery, parseHTML, withResponse+ -- * Grab information+ , getTestYesod+ , getResponse -)+ -- * Debug output+ , printBody+ , printMatches -where+ -- * Utils for building your own assertions+ -- | Please consider generalizing and contributing the assertions you write.+ , htmlQuery+ , parseHTML+ , withResponse+ ) where +import qualified Test.Hspec as Hspec import qualified Test.Hspec.Core as Core-import qualified Test.Hspec.Runner as Runner import qualified Data.List as DL import qualified Data.ByteString.Char8 as BS8 import Data.ByteString (ByteString)@@ -78,40 +102,77 @@ import qualified Network.Socket.Internal as Sock import Data.CaseInsensitive (CI) import Network.Wai-import Network.Wai.Test hiding (assertHeader, assertNoHeader)+import Network.Wai.Test hiding (assertHeader, assertNoHeader, request) import qualified Control.Monad.Trans.State as ST import Control.Monad.IO.Class import System.IO import Yesod.Test.TransversingCSS-import Data.Monoid (mappend)+import Yesod.Core import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) import Text.XML.Cursor hiding (element) import qualified Text.XML.Cursor as C import qualified Text.HTML.DOM as HD-import Data.Conduit.Pool (Pool)-import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Trans.Writer import qualified Data.Map as M import qualified Web.Cookie as Cookie import qualified Blaze.ByteString.Builder as Builder import Data.Time.Clock (getCurrentTime) --- | The state used in 'describe' to build a list of specs-data SpecsData conn = SpecsData Application (Pool conn) [Core.SpecTree]+-- | The state used in a single test case defined using 'yit'+--+-- Since 1.2.0+data YesodExampleData site = YesodExampleData+ { yedApp :: !Application+ , yedSite :: !site+ , yedCookies :: !Cookies+ , yedResponse :: !(Maybe SResponse)+ } --- | The specs state monad is where 'describe' runs.--- parameterized by a database connection.--- You should create type Specs = SpecsConn MyDBConnection-type SpecsConn conn = ST.StateT (SpecsData conn) IO ()+-- | A single test case, to be run with 'yit'.+--+-- Since 1.2.0+type YesodExample site = ST.StateT (YesodExampleData site) IO --- | The state used in a single test case defined using 'it'-data OneSpecData conn = OneSpecData Application (Pool conn) Cookies (Maybe SResponse)+-- | Mapping from cookie name to value.+--+-- Since 1.2.0+type Cookies = M.Map ByteString Cookie.SetCookie --- | The OneSpec state monad is where 'it' runs.-type OneSpec conn = ST.StateT (OneSpecData conn) IO+-- | Corresponds to hspec\'s 'Spec'.+--+-- Since 1.2.0+type YesodSpec site = Writer [YesodSpecTree site] () -data RequestBuilderData = RequestBuilderData [RequestPart] (Maybe SResponse)+-- | Internal data structure, corresponding to hspec\'s 'YesodSpecTree'.+--+-- Since 1.2.0+data YesodSpecTree site+ = YesodSpecGroup String [YesodSpecTree site]+ | YesodSpecItem String (YesodExample site ()) +-- | Get the foundation value used for the current test.+--+-- Since 1.2.0+getTestYesod :: YesodExample site site+getTestYesod = fmap yedSite ST.get++-- | Get the most recently provided response value, if available.+--+-- Since 1.2.0+getResponse :: YesodExample site (Maybe SResponse)+getResponse = fmap yedResponse ST.get++data RequestBuilderData site = RequestBuilderData+ { rbdPosts :: [RequestPart]+ , rbdResponse :: (Maybe SResponse)+ , rbdMethod :: H.Method+ , rbdSite :: site+ , rbdPath :: [T.Text]+ , rbdGets :: H.Query+ , rbdHeaders :: H.RequestHeaders+ }+ -- | Request parts let us discern regular key/values from files sent in the request. data RequestPart = ReqPlainPart T.Text T.Text@@ -120,74 +181,73 @@ -- | 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 conn) where- readResponse (OneSpecData _ _ _ x) = x-instance HoldsResponse RequestBuilderData where- readResponse (RequestBuilderData _ x) = x--type Cookies = M.Map ByteString Cookie.SetCookie---- | 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 -> Pool conn -> SpecsConn conn -> IO ()-runTests app connection specsDef = do- (SpecsData _ _ specs) <- ST.execStateT specsDef (SpecsData app connection [])- (Runner.hspec . Core.fromSpecList) specs+type RequestBuilder site = ST.StateT (RequestBuilderData site) IO -- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application' -- and 'ConnectionPool'-describe :: String -> SpecsConn conn -> SpecsConn conn-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]+ydescribe :: String -> YesodSpec site -> YesodSpec site+ydescribe label yspecs = tell [YesodSpecGroup label $ execWriter yspecs] +yesodSpec :: YesodDispatch site+ => site+ -> YesodSpec site+ -> Hspec.Spec+yesodSpec site yspecs =+ Core.fromSpecList $ map unYesod $ execWriter yspecs+ where+ unYesod (YesodSpecGroup x y) = Core.SpecGroup x $ map unYesod y+ unYesod (YesodSpecItem x y) = Core.it x $ do+ app <- toWaiAppPlain site+ ST.evalStateT y YesodExampleData+ { yedApp = app+ , yedSite = site+ , yedCookies = M.empty+ , yedResponse = Nothing+ }+ -- | Describe a single test that keeps cookies, and a reference to the last response.-it :: String -> OneSpec conn () -> SpecsConn conn-it label action = do- SpecsData app conn specs <- ST.get- let spec = Core.it label $ do- _ <- ST.execStateT action $ OneSpecData app conn M.empty Nothing- return ()- ST.put $ SpecsData app conn $ spec : specs+yit :: String -> YesodExample site () -> YesodSpec site+yit label example = tell [YesodSpecItem label example] -- Performs a given action using the last response. Use this to create -- response-level assertions-withResponse :: HoldsResponse a => (SResponse -> ST.StateT a IO b) -> ST.StateT a IO b-withResponse f = maybe err f =<< fmap readResponse ST.get+withResponse' :: MonadIO m+ => (state -> Maybe SResponse)+ -> (SResponse -> ST.StateT state m a)+ -> ST.StateT state m a+withResponse' getter f = maybe err f . getter =<< ST.get where err = failure "There was no response, you should make a request" +-- | Performs a given action using the last response. Use this to create+-- response-level assertions+withResponse :: (SResponse -> YesodExample site a) -> YesodExample site a+withResponse = withResponse' yedResponse+ -- | Use HXT to parse a value from an html tag. -- Check for usage examples in this module's source.-parseHTML :: Html -> Cursor+parseHTML :: HtmlLBS -> Cursor parseHTML html = fromDocument $ HD.parseLBS 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 ->+htmlQuery' :: MonadIO m+ => (state -> Maybe SResponse)+ -> Query+ -> ST.StateT state m [HtmlLBS]+htmlQuery' getter query = withResponse' getter $ \ res -> case findBySelector (simpleBody res) query of Left err -> failure $ query <> " did not parse: " <> T.pack (show err) Right matches -> return $ map (encodeUtf8 . TL.pack) matches +-- | Query the last response using css selectors, returns a list of matched fragments+htmlQuery :: Query -> YesodExample site [HtmlLBS]+htmlQuery = htmlQuery' yedResponse+ -- | Asserts that the two given values are equal.-assertEqual :: (Eq a) => String -> a -> a -> OneSpec conn ()+assertEqual :: (Eq a) => String -> a -> a -> YesodExample site () 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 :: Int -> YesodExample site () statusIs number = withResponse $ \ SResponse { simpleStatus = s } -> liftIO $ flip HUnit.assertBool (H.statusCode s == number) $ concat [ "Expected status was ", show number@@ -195,7 +255,7 @@ ] -- | Assert the given header key/value pair was returned.-assertHeader :: HoldsResponse a => CI BS8.ByteString -> BS8.ByteString -> ST.StateT a IO ()+assertHeader :: CI BS8.ByteString -> BS8.ByteString -> YesodExample site () assertHeader header value = withResponse $ \ SResponse { simpleHeaders = h } -> case lookup header h of Nothing -> failure $ T.pack $ concat@@ -215,7 +275,7 @@ ] -- | Assert the given header was not included in the response.-assertNoHeader :: HoldsResponse a => CI BS8.ByteString -> ST.StateT a IO ()+assertNoHeader :: CI BS8.ByteString -> YesodExample site () assertNoHeader header = withResponse $ \ SResponse { simpleHeaders = h } -> case lookup header h of Nothing -> return ()@@ -228,14 +288,14 @@ -- | Assert the last response is exactly equal to the given text. This is -- useful for testing API responses.-bodyEquals :: HoldsResponse a => String -> ST.StateT a IO ()+bodyEquals :: String -> YesodExample site () bodyEquals text = withResponse $ \ res -> liftIO $ HUnit.assertBool ("Expected body to equal " ++ text) $ (simpleBody res) == BSL8.pack text -- | 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 :: String -> YesodExample site () bodyContains text = withResponse $ \ res -> liftIO $ HUnit.assertBool ("Expected body to contain " ++ text) $ (simpleBody res) `contains` text@@ -245,7 +305,7 @@ -- | 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 -> String -> YesodExample site () htmlAllContain query search = do matches <- htmlQuery query case matches of@@ -257,7 +317,7 @@ -- element contains the given string. -- -- Since 0.3.5-htmlAnyContain :: HoldsResponse a => Query -> String -> ST.StateT a IO ()+htmlAnyContain :: Query -> String -> YesodExample site () htmlAnyContain query search = do matches <- htmlQuery query case matches of@@ -267,41 +327,54 @@ -- | 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 -> Int -> YesodExample site () htmlCount query count = do matches <- fmap DL.length $ htmlQuery query liftIO $ flip HUnit.assertBool (matches == count) ("Expected "++(show count)++" elements to match "++T.unpack 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 } -> +printBody :: YesodExample site ()+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 -> YesodExample site () printMatches query = do matches <- htmlQuery query liftIO $ hPutStrLn stderr $ show matches -- | Add a parameter with the given name and value.-byName :: T.Text -> T.Text -> RequestBuilder ()-byName name value = do- RequestBuilderData parts r <- ST.get- ST.put $ RequestBuilderData ((ReqPlainPart name value):parts) r+addPostParam :: T.Text -> T.Text -> RequestBuilder site ()+addPostParam name value =+ ST.modify $ \rbd -> rbd+ { rbdPosts = ReqPlainPart name value : rbdPosts rbd+ } +addGetParam :: T.Text -> T.Text -> RequestBuilder site ()+addGetParam name value = ST.modify $ \rbd -> rbd+ { rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value)+ : rbdGets rbd+ }+ -- | 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 :: T.Text -> FilePath -> T.Text -> RequestBuilder ()-fileByName name path mimetype = do- RequestBuilderData parts r <- ST.get+addFile :: T.Text -> FilePath -> T.Text -> RequestBuilder site ()+addFile name path mimetype = do contents <- liftIO $ BSL8.readFile path- ST.put $ RequestBuilderData ((ReqFilePart name path contents mimetype):parts) r+ ST.modify $ \rbd -> rbd+ { rbdPosts = ReqFilePart name path contents mimetype : rbdPosts rbd+ } -- This looks up the name of a field based on the contents of the label pointing to it.-nameFromLabel :: T.Text -> RequestBuilder T.Text-nameFromLabel label = withResponse $ \ res -> do+nameFromLabel :: T.Text -> RequestBuilder site T.Text+nameFromLabel label = do+ mres <- fmap rbdResponse ST.get+ res <-+ case mres of+ Nothing -> failure "nameFromLabel: No response available"+ Just res -> return res let body = simpleBody res mfor = parseHTML body@@ -334,138 +407,164 @@ (<>) :: T.Text -> T.Text -> T.Text (<>) = T.append -byLabel :: T.Text -> T.Text -> RequestBuilder ()+byLabel :: T.Text -> T.Text -> RequestBuilder site () byLabel label value = do name <- nameFromLabel label- byName name value+ addPostParam name value -fileByLabel :: T.Text -> FilePath -> T.Text -> RequestBuilder ()+fileByLabel :: T.Text -> FilePath -> T.Text -> RequestBuilder site () fileByLabel label path mime = do name <- nameFromLabel label- fileByName name path mime+ addFile name path mime --- | Lookup a _nonce form field and add it's value to the params. +-- | 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_ :: Query -> RequestBuilder ()+addNonce_ :: Query -> RequestBuilder site () addNonce_ scope = do- matches <- htmlQuery $ scope `mappend` "input[name=_token][type=hidden][value]"+ matches <- htmlQuery' rbdResponse $ scope <> "input[name=_token][type=hidden][value]" case matches of [] -> failure $ "No nonce found in the current page"- element:[] -> byName "_token" $ head $ attribute "value" $ parseHTML element+ element:[] -> addPostParam "_token" $ head $ attribute "value" $ parseHTML element _ -> 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 :: RequestBuilder site () addNonce = addNonce_ "" --- | Perform a POST request to url, using params-post :: BS8.ByteString -> RequestBuilder () -> OneSpec conn ()-post url paramsBuild = do- doRequest "POST" url paramsBuild+-- | Perform a POST request to url+post :: (Yesod site, RedirectUrl site url)+ => url+ -> YesodExample site ()+post url = request $ do+ setMethod "POST"+ setUrl url --- | Perform a POST request without params-post_ :: BS8.ByteString -> OneSpec conn ()-post_ = flip post $ return ()- -- | Perform a GET request to url, using params-get :: BS8.ByteString -> RequestBuilder () -> OneSpec conn ()-get url paramsBuild = doRequest "GET" url paramsBuild+get :: (Yesod site, RedirectUrl site url)+ => url+ -> YesodExample site ()+get url = request $ do+ setMethod "GET"+ setUrl url --- | Perform a GET request without params-get_ :: BS8.ByteString -> OneSpec conn ()-get_ = flip get $ return ()+setMethod :: H.Method -> RequestBuilder site ()+setMethod m = ST.modify $ \rbd -> rbd { rbdMethod = m } --- | General interface to performing requests, letting you specify the request method-doRequest :: H.Method -> BS8.ByteString -> RequestBuilder a -> OneSpec conn ()-doRequest method url paramsBuild = doRequestHeaders method url [] paramsBuild+setUrl :: (Yesod site, RedirectUrl site url)+ => url+ -> RequestBuilder site ()+setUrl url' = do+ site <- fmap rbdSite ST.get+ eurl <- runFakeHandler+ M.empty+ (const $ error "Yesod.Test: No logger available")+ site+ (toTextUrl url')+ url <- either (error . show) return eurl+ let (urlPath, urlQuery) = T.break (== '?') url+ ST.modify $ \rbd -> rbd+ { rbdPath =+ case DL.filter (/="") $ T.split (== '/') urlPath of+ ("http:":_:rest) -> rest+ ("https:":_:rest) -> rest+ x -> x+ , rbdGets = rbdGets rbd ++ H.parseQuery (TE.encodeUtf8 urlQuery)+ } +addRequestHeader :: H.Header -> RequestBuilder site ()+addRequestHeader header = ST.modify $ \rbd -> rbd+ { rbdHeaders = header : rbdHeaders rbd+ }+ -- | General interface to performing requests, allowing you to add extra -- headers as well as letting you specify the request method.-doRequestHeaders :: H.Method -> BS8.ByteString -> [H.Header] -> RequestBuilder a -> OneSpec conn ()-doRequestHeaders method url extrahead paramsBuild = do- OneSpecData app conn oldCookies mRes <- ST.get+request :: Yesod site+ => RequestBuilder site ()+ -> YesodExample site ()+request reqBuilder = do+ YesodExampleData app site oldCookies mRes <- ST.get - -- expire cookies and filter them for the current path. TODO: support max age- currentUtc <- liftIO getCurrentTime- let cookies = M.filter (checkCookieTime currentUtc) oldCookies- cookiesForPath = M.filter checkCookiePath cookies+ RequestBuilderData {..} <- liftIO $ ST.execStateT reqBuilder RequestBuilderData+ { rbdPosts = []+ , rbdResponse = mRes+ , rbdMethod = "GET"+ , rbdSite = site+ , rbdPath = []+ , rbdGets = []+ , rbdHeaders = []+ }+ let path = T.cons '/' $ T.intercalate "/" rbdPath - RequestBuilderData parts _ <- liftIO $ ST.execStateT paramsBuild $ RequestBuilderData [] mRes- let req = if DL.any isFile parts- then makeMultipart cookiesForPath parts- else makeSinglepart cookiesForPath parts+ -- expire cookies and filter them for the current path. TODO: support max age+ currentUtc <- liftIO getCurrentTime+ let cookies = M.filter (checkCookieTime currentUtc) oldCookies+ cookiesForPath = M.filter (checkCookiePath path) cookies - response <- liftIO $ runSession (srequest req) app- let newCookies = map (Cookie.parseSetCookie . snd) $ DL.filter (("Set-Cookie"==) . fst) $ simpleHeaders response- cookies' = M.fromList [(Cookie.setCookieName c, c) | c <- newCookies] `M.union` cookies- ST.put $ OneSpecData app conn cookies' (Just response)- where- isFile (ReqFilePart _ _ _ _) = True- isFile _ = False+ let maker+ | DL.any isFile rbdPosts = makeMultipart+ | otherwise = makeSinglepart+ req = maker cookiesForPath rbdPosts rbdMethod rbdHeaders path rbdGets - checkCookieTime t c = case Cookie.setCookieExpires c of- Nothing -> True- Just t' -> t < t'- checkCookiePath c = case Cookie.setCookiePath c of- Nothing -> True- Just x -> x `BS8.isPrefixOf` url+ response <- liftIO $ runSession (srequest req) app+ let newCookies = map (Cookie.parseSetCookie . snd) $ DL.filter (("Set-Cookie"==) . fst) $ simpleHeaders response+ cookies' = M.fromList [(Cookie.setCookieName c, c) | c <- newCookies] `M.union` cookies+ ST.put $ YesodExampleData app site cookies' (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 cookies parts =- flip SRequest (BSL8.fromChunks [multiPartBody parts]) $ mkRequest $- [ ("Cookie", Builder.toByteString $ Cookie.renderCookies- [(Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies])- , ("Content-Type", BS8.pack $ "multipart/form-data; boundary=" ++ boundary)- ] ++ extrahead- multiPartBody parts =- BS8.concat $ separator : [BS8.concat [multipartPart p, separator] | p <- parts]- multipartPart (ReqPlainPart k v) = BS8.concat- [ "Content-Disposition: form-data; "- , "name=\"", TE.encodeUtf8 k, "\"\r\n\r\n"- , TE.encodeUtf8 v, "\r\n"]- multipartPart (ReqFilePart k v bytes mime) = BS8.concat- [ "Content-Disposition: form-data; "- , "name=\"", TE.encodeUtf8 k, "\"; "- , "filename=\"", BS8.pack v, "\"\r\n"- , "Content-Type: ", TE.encodeUtf8 mime, "\r\n\r\n"- , BS8.concat $ BSL8.toChunks bytes, "\r\n"]+ checkCookieTime t c = case Cookie.setCookieExpires c of+ Nothing -> True+ Just t' -> t < t'+ checkCookiePath url c =+ case Cookie.setCookiePath c of+ Nothing -> True+ Just x -> x `BS8.isPrefixOf` TE.encodeUtf8 url - -- For building the regular non-multipart requests- makeSinglepart cookies parts = SRequest (mkRequest $- [ ("Cookie", Builder.toByteString $ Cookie.renderCookies- [(Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies])- , ("Content-Type", "application/x-www-form-urlencoded")- ] ++ extrahead) $- BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" $ map singlepartPart parts+ -- For building the multi-part requests+ boundary :: String+ boundary = "*******noneedtomakethisrandom"+ separator = BS8.concat ["--", BS8.pack boundary, "\r\n"]+ makeMultipart cookies parts method extraHeaders urlPath urlQuery =+ flip SRequest (BSL8.fromChunks [multiPartBody parts]) $ mkRequest+ [ ("Cookie", Builder.toByteString $ Cookie.renderCookies+ [(Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies])+ , ("Content-Type", BS8.pack $ "multipart/form-data; boundary=" ++ boundary)+ ] method extraHeaders urlPath urlQuery+ multiPartBody parts =+ BS8.concat $ separator : [BS8.concat [multipartPart p, separator] | p <- parts]+ multipartPart (ReqPlainPart k v) = BS8.concat+ [ "Content-Disposition: form-data; "+ , "name=\"", TE.encodeUtf8 k, "\"\r\n\r\n"+ , TE.encodeUtf8 v, "\r\n"]+ multipartPart (ReqFilePart k v bytes mime) = BS8.concat+ [ "Content-Disposition: form-data; "+ , "name=\"", TE.encodeUtf8 k, "\"; "+ , "filename=\"", BS8.pack v, "\"\r\n"+ , "Content-Type: ", TE.encodeUtf8 mime, "\r\n\r\n"+ , BS8.concat $ BSL8.toChunks bytes, "\r\n"] - singlepartPart (ReqFilePart _ _ _ _) = ""- singlepartPart (ReqPlainPart k v) = T.concat [k,"=",v]+ -- For building the regular non-multipart requests+ makeSinglepart cookies parts method extraHeaders urlPath urlQuery = SRequest (mkRequest+ [ ("Cookie", Builder.toByteString $ Cookie.renderCookies+ [(Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies])+ , ("Content-Type", "application/x-www-form-urlencoded")+ ] method extraHeaders urlPath urlQuery) $+ BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" $ map singlepartPart parts - -- General request making - mkRequest headers = defaultRequest- { requestMethod = method- , remoteHost = Sock.SockAddrInet 1 2- , requestHeaders = headers- , rawPathInfo = urlPath- , pathInfo = DL.filter (/="") $ T.split (== '/') $ TE.decodeUtf8 urlPath- , rawQueryString = urlQuery- , queryString = H.parseQuery urlQuery- }+ singlepartPart (ReqFilePart _ _ _ _) = ""+ singlepartPart (ReqPlainPart k v) = T.concat [k,"=",v] - (urlPath, urlQuery) = BS8.break (== '?') 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.------ It is intended that you parametize the first argument of this function for your backend--- runDB = runDBRunnder SqlPersist-runDBRunner :: (MonadBaseControl IO m, MonadIO m) => (poolrunner m a -> Pool conn -> IO a) -> poolrunner m a -> OneSpec conn a-runDBRunner poolRunner query = do- OneSpecData _ pool _ _ <- ST.get- liftIO $ poolRunner query pool+ -- General request making+ mkRequest headers method extraHeaders urlPath urlQuery = defaultRequest+ { requestMethod = method+ , remoteHost = Sock.SockAddrInet 1 2+ , requestHeaders = headers ++ extraHeaders+ , rawPathInfo = TE.encodeUtf8 urlPath+ , pathInfo = DL.filter (/="") $ T.split (== '/') urlPath+ , rawQueryString = H.renderQuery False urlQuery+ , queryString = urlQuery+ } -- Yes, just a shortcut failure :: (MonadIO a) => T.Text -> a b
Yesod/Test/TransversingCSS.hs view
@@ -27,7 +27,7 @@ module Yesod.Test.TransversingCSS ( findBySelector,- Html,+ HtmlLBS, Query, -- * For HXT hackers -- | These functions expose some low level details that you can blissfully ignore.@@ -50,14 +50,14 @@ import Text.Blaze.Html.Renderer.String (renderHtml) type Query = T.Text-type Html = L.ByteString+type HtmlLBS = L.ByteString -- | Perform a css 'Query' on 'Html'. Returns Either -- -- * Left: Query parse error. -- -- * Right: List of matching Html fragments.-findBySelector :: Html -> Query -> Either String [String]+findBySelector :: HtmlLBS -> Query -> Either String [String] findBySelector html query = (\x -> map (renderHtml . toHtml . node) . runQuery x) <$> (Right $ fromDocument $ HD.parseLBS html) <*> parseQuery query
test/main.hs view
@@ -1,11 +1,18 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-} import Test.HUnit hiding (Test) import Test.Hspec +import Yesod.Core+import Yesod.Form+import Yesod.Test import Yesod.Test.CssQuery import Yesod.Test.TransversingCSS import Text.XML+import Data.Text (Text)+import Data.Monoid ((<>))+import Control.Applicative import Data.ByteString.Lazy.Char8 () import qualified Data.Map as Map@@ -60,3 +67,67 @@ ] ] in parseHtml_ html @?= doc+ describe "basic usage" $ yesodSpec app $ do+ ydescribe "tests1" $ do+ yit "tests1a" $ do+ get ("/" :: Text)+ statusIs 200+ bodyEquals "Hello world!"+ yit "tests1b" $ do+ get ("/foo" :: Text)+ statusIs 404+ ydescribe "tests2" $ do+ yit "type-safe URLs" $ do+ get $ LiteAppRoute []+ statusIs 200+ yit "type-safe URLs with query-string" $ do+ get (LiteAppRoute [], [("foo", "bar")])+ statusIs 200+ bodyEquals "foo=bar"+ yit "post params" $ do+ post ("/post" :: Text)+ statusIs 500++ request $ do+ setMethod "POST"+ setUrl $ LiteAppRoute ["post"]+ addPostParam "foo" "foobarbaz"+ statusIs 200+ bodyEquals "foobarbaz"+ yit "labels" $ do+ get ("/form" :: Text)+ statusIs 200++ request $ do+ setMethod "POST"+ setUrl ("/form" :: Text)+ byLabel "Some Label" "12345"+ fileByLabel "Some File" "test/main.hs" "text/plain"+ addNonce+ statusIs 200+ bodyEquals "12345"++instance RenderMessage LiteApp FormMessage where+ renderMessage _ _ = defaultFormMessage++app :: LiteApp+app = liteApp $ do+ dispatchTo $ do+ mfoo <- lookupGetParam "foo"+ case mfoo of+ Nothing -> return "Hello world!"+ Just foo -> return $ "foo=" <> foo+ onStatic "post" $ dispatchTo $ do+ mfoo <- lookupPostParam "foo"+ case mfoo of+ Nothing -> error "No foo"+ Just foo -> return foo+ onStatic "form" $ dispatchTo $ do+ ((mfoo, widget), _) <- runFormPost+ $ renderDivs+ $ (,)+ <$> areq textField "Some Label" Nothing+ <*> areq fileField "Some File" Nothing+ case mfoo of+ FormSuccess (foo, _) -> return $ toHtml foo+ _ -> defaultLayout widget
yesod-test.cabal view
@@ -1,5 +1,5 @@ name: yesod-test-version: 0.3.5+version: 1.2.0 license: MIT license-file: LICENSE author: Nubis <nubis@woobiz.com.ar>@@ -38,6 +38,7 @@ , time , blaze-builder , cookie+ , yesod-core >= 1.2 exposed-modules: Yesod.Test Yesod.Test.CssQuery@@ -56,6 +57,9 @@ , bytestring , containers , html-conduit+ , yesod-core+ , yesod-form+ , text source-repository head type: git