diff --git a/Yesod/Test.hs b/Yesod/Test.hs --- a/Yesod/Test.hs +++ b/Yesod/Test.hs @@ -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 diff --git a/Yesod/Test/TransversingCSS.hs b/Yesod/Test/TransversingCSS.hs --- a/Yesod/Test/TransversingCSS.hs +++ b/Yesod/Test/TransversingCSS.hs @@ -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 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -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 diff --git a/yesod-test.cabal b/yesod-test.cabal --- a/yesod-test.cabal +++ b/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 0.3.5 +version: 1.2.0 license: MIT license-file: LICENSE author: Nubis @@ -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