haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

yesod-test can use type-safe URLs

Browse Source
This commit is contained in:
Michael Snoyman 2013-04-02 17:29:09 +03:00
parent ad817275e8
commit db53252960
3 changed files with 116 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

178
yesod-test/Yesod/Test.hs
View File

@ -6,7 +6,7 @@ Yesod.Test is a pragmatic framework for testing web applications built
using wai and persistent. using wai and persistent.
By pragmatic I may also mean 'dirty'. It's main goal is to encourage integration 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 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, visited page. You can perform assertions on the content of HTML responses,
@ -84,7 +84,7 @@ import qualified Control.Monad.Trans.State as ST
import Control.Monad.IO.Class import Control.Monad.IO.Class
import System.IO import System.IO
import Yesod.Test.TransversingCSS import Yesod.Test.TransversingCSS
import Yesod.Core (toWaiAppPlain, YesodDispatch) import Yesod.Core
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)
import Text.XML.Cursor hiding (element) import Text.XML.Cursor hiding (element)
@ -381,7 +381,7 @@ fileByLabel label path mime = do
name <- nameFromLabel label name <- nameFromLabel label
fileByName name path mime fileByName 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. -- Receives a CSS selector that should resolve to the form element containing the nonce.
addNonce_ :: Query -> RequestBuilder () addNonce_ :: Query -> RequestBuilder ()
addNonce_ scope = do addNonce_ scope = do
@ -396,107 +396,125 @@ addNonce :: RequestBuilder ()
addNonce = addNonce_ "" addNonce = addNonce_ ""
-- | Perform a POST request to url, using params -- | Perform a POST request to url, using params
post :: BS8.ByteString -> RequestBuilder () -> YesodExample site () post :: (Yesod site, RedirectUrl site url)
=> url -> RequestBuilder () -> YesodExample site ()
post url paramsBuild = do post url paramsBuild = do
doRequest "POST" url paramsBuild doRequest "POST" url paramsBuild
-- | Perform a POST request without params -- | Perform a POST request without params
post_ :: BS8.ByteString -> YesodExample site () post_ :: (Yesod site, RedirectUrl site url) => url -> YesodExample site ()
post_ = flip post $ return () post_ = flip post $ return ()
-- | Perform a GET request to url, using params -- | Perform a GET request to url, using params
get :: BS8.ByteString -> RequestBuilder () -> YesodExample site () get :: (Yesod site, RedirectUrl site url) => url -> RequestBuilder () -> YesodExample site ()
get url paramsBuild = doRequest "GET" url paramsBuild get url paramsBuild = doRequest "GET" url paramsBuild
-- | Perform a GET request without params -- | Perform a GET request without params
get_ :: BS8.ByteString -> YesodExample site () get_ :: (Yesod site, RedirectUrl site url) => url -> YesodExample site ()
get_ = flip get $ return () get_ = flip get $ return ()
-- | General interface to performing requests, letting you specify the request method -- | General interface to performing requests, letting you specify the request method
doRequest :: H.Method -> BS8.ByteString -> RequestBuilder a -> YesodExample site () doRequest :: (Yesod site, RedirectUrl site url)
=> H.Method -> url -> RequestBuilder a -> YesodExample site ()
doRequest method url paramsBuild = doRequestHeaders method url [] paramsBuild doRequest method url paramsBuild = doRequestHeaders method url [] paramsBuild
fromHandler :: Yesod site => HandlerT site IO a -> YesodExample site a
fromHandler h = do
site <- fmap yedSite ST.get
eres <- runFakeHandler
M.empty
(const $ error "Yesod.Test: No logger available")
site
h
either (error . show) return eres
-- | General interface to performing requests, allowing you to add extra -- | General interface to performing requests, allowing you to add extra
-- headers as well as letting you specify the request method. -- headers as well as letting you specify the request method.
doRequestHeaders :: H.Method -> BS8.ByteString -> [H.Header] -> RequestBuilder a -> YesodExample site () doRequestHeaders :: (Yesod site, RedirectUrl site url)
doRequestHeaders method url extrahead paramsBuild = do => H.Method
YesodExampleData app conn oldCookies mRes <- ST.get -> url
-> [H.Header]
-> RequestBuilder a
-> YesodExample site ()
doRequestHeaders method url' extrahead paramsBuild = do
url <- fromHandler $ toTextUrl url'
let (urlPath, urlQuery) = T.break (== '?') url
YesodExampleData app conn oldCookies mRes <- ST.get
-- expire cookies and filter them for the current path. TODO: support max age -- expire cookies and filter them for the current path. TODO: support max age
currentUtc <- liftIO getCurrentTime currentUtc <- liftIO getCurrentTime
let cookies = M.filter (checkCookieTime currentUtc) oldCookies let cookies = M.filter (checkCookieTime currentUtc) oldCookies
cookiesForPath = M.filter checkCookiePath cookies cookiesForPath = M.filter (checkCookiePath url) cookies
RequestBuilderData parts _ <- liftIO $ ST.execStateT paramsBuild RequestBuilderData RequestBuilderData parts _ <- liftIO $ ST.execStateT paramsBuild RequestBuilderData
{ rbdPosts = [] { rbdPosts = []
, rbdResponse = mRes , rbdResponse = mRes
} }
let maker let maker
| DL.any isFile parts = makeMultipart | DL.any isFile parts = makeMultipart
| otherwise = makeSinglepart | otherwise = makeSinglepart
req = maker cookiesForPath parts req = maker cookiesForPath parts urlPath urlQuery
response <- liftIO $ runSession (srequest req) app response <- liftIO $ runSession (srequest req) app
let newCookies = map (Cookie.parseSetCookie . snd) $ DL.filter (("Set-Cookie"==) . fst) $ simpleHeaders response 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 cookies' = M.fromList [(Cookie.setCookieName c, c) | c <- newCookies] `M.union` cookies
ST.put $ YesodExampleData app conn cookies' (Just response) ST.put $ YesodExampleData app conn cookies' (Just response)
where where
isFile (ReqFilePart _ _ _ _) = True isFile (ReqFilePart _ _ _ _) = True
isFile _ = False isFile _ = False
checkCookieTime t c = case Cookie.setCookieExpires c of checkCookieTime t c = case Cookie.setCookieExpires c of
Nothing -> True Nothing -> True
Just t' -> t < t' Just t' -> t < t'
checkCookiePath c = case Cookie.setCookiePath c of checkCookiePath url c =
Nothing -> True case Cookie.setCookiePath c of
Just x -> x `BS8.isPrefixOf` url Nothing -> True
Just x -> x `BS8.isPrefixOf` TE.encodeUtf8 url
-- For building the multi-part requests -- For building the multi-part requests
boundary :: String boundary :: String
boundary = "*******noneedtomakethisrandom" boundary = "*******noneedtomakethisrandom"
separator = BS8.concat ["--", BS8.pack boundary, "\r\n"] separator = BS8.concat ["--", BS8.pack boundary, "\r\n"]
makeMultipart cookies parts = makeMultipart cookies parts urlPath urlQuery =
flip SRequest (BSL8.fromChunks [multiPartBody parts]) $ mkRequest $ flip SRequest (BSL8.fromChunks [multiPartBody parts]) $ mkRequest
[ ("Cookie", Builder.toByteString $ Cookie.renderCookies ([ ("Cookie", Builder.toByteString $ Cookie.renderCookies
[(Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies]) [(Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies])
, ("Content-Type", BS8.pack $ "multipart/form-data; boundary=" ++ boundary) , ("Content-Type", BS8.pack $ "multipart/form-data; boundary=" ++ boundary)
] ++ extrahead ] ++ extrahead) urlPath urlQuery
multiPartBody parts = multiPartBody parts =
BS8.concat $ separator : [BS8.concat [multipartPart p, separator] | p <- parts] BS8.concat $ separator : [BS8.concat [multipartPart p, separator] | p <- parts]
multipartPart (ReqPlainPart k v) = BS8.concat multipartPart (ReqPlainPart k v) = BS8.concat
[ "Content-Disposition: form-data; " [ "Content-Disposition: form-data; "
, "name=\"", TE.encodeUtf8 k, "\"\r\n\r\n" , "name=\"", TE.encodeUtf8 k, "\"\r\n\r\n"
, TE.encodeUtf8 v, "\r\n"] , TE.encodeUtf8 v, "\r\n"]
multipartPart (ReqFilePart k v bytes mime) = BS8.concat multipartPart (ReqFilePart k v bytes mime) = BS8.concat
[ "Content-Disposition: form-data; " [ "Content-Disposition: form-data; "
, "name=\"", TE.encodeUtf8 k, "\"; " , "name=\"", TE.encodeUtf8 k, "\"; "
, "filename=\"", BS8.pack v, "\"\r\n" , "filename=\"", BS8.pack v, "\"\r\n"
, "Content-Type: ", TE.encodeUtf8 mime, "\r\n\r\n" , "Content-Type: ", TE.encodeUtf8 mime, "\r\n\r\n"
, BS8.concat $ BSL8.toChunks bytes, "\r\n"] , BS8.concat $ BSL8.toChunks bytes, "\r\n"]
-- For building the regular non-multipart requests -- For building the regular non-multipart requests
makeSinglepart cookies parts = SRequest (mkRequest $ makeSinglepart cookies parts urlPath urlQuery = SRequest (mkRequest
[ ("Cookie", Builder.toByteString $ Cookie.renderCookies ([ ("Cookie", Builder.toByteString $ Cookie.renderCookies
[(Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies]) [(Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies])
, ("Content-Type", "application/x-www-form-urlencoded") , ("Content-Type", "application/x-www-form-urlencoded")
] ++ extrahead) $ ] ++ extrahead) urlPath urlQuery) $
BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" $ map singlepartPart parts BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" $ map singlepartPart parts
singlepartPart (ReqFilePart _ _ _ _) = "" singlepartPart (ReqFilePart _ _ _ _) = ""
singlepartPart (ReqPlainPart k v) = T.concat [k,"=",v] singlepartPart (ReqPlainPart k v) = T.concat [k,"=",v]
-- General request making -- General request making
mkRequest headers = defaultRequest mkRequest headers urlPath urlQuery = defaultRequest
{ requestMethod = method { requestMethod = method
, remoteHost = Sock.SockAddrInet 1 2 , remoteHost = Sock.SockAddrInet 1 2
, requestHeaders = headers , requestHeaders = headers
, rawPathInfo = urlPath , rawPathInfo = TE.encodeUtf8 urlPath
, pathInfo = DL.filter (/="") $ T.split (== '/') $ TE.decodeUtf8 urlPath , pathInfo = DL.filter (/="") $ T.split (== '/') urlPath
, rawQueryString = urlQuery , rawQueryString = TE.encodeUtf8 urlQuery
, queryString = H.parseQuery urlQuery , queryString = H.parseQuery $ TE.encodeUtf8 urlQuery
} }
(urlPath, urlQuery) = BS8.break (== '?') url
-- Yes, just a shortcut -- Yes, just a shortcut
failure :: (MonadIO a) => T.Text -> a b failure :: (MonadIO a) => T.Text -> a b

22
yesod-test/test/main.hs
View File

@ -3,11 +3,13 @@
import Test.HUnit hiding (Test) import Test.HUnit hiding (Test)
import Test.Hspec import Test.Hspec
import Yesod.Core (liteApp, dispatchTo, Html) import Yesod.Core
import Yesod.Test import Yesod.Test
import Yesod.Test.CssQuery import Yesod.Test.CssQuery
import Yesod.Test.TransversingCSS import Yesod.Test.TransversingCSS
import Text.XML import Text.XML
import Data.Text (Text)
import Data.Monoid ((<>))
import Data.ByteString.Lazy.Char8 () import Data.ByteString.Lazy.Char8 ()
import qualified Data.Map as Map import qualified Data.Map as Map
@ -62,16 +64,26 @@ main = hspec $ do
] ]
] ]
in parseHtml_ html @?= doc in parseHtml_ html @?= doc
let app = liteApp $ dispatchTo $ return ("Hello world!" :: Html) let app = liteApp $ dispatchTo $ do
mfoo <- lookupGetParam "foo"
case mfoo of
Nothing -> return "Hello world!"
Just foo -> return $ "foo=" <> foo
describe "basic usage" $ yesodSpec app $ do describe "basic usage" $ yesodSpec app $ do
ydescribe "tests1" $ do ydescribe "tests1" $ do
yit "tests1a" $ do yit "tests1a" $ do
get_ "/" get_ ("/" :: Text)
statusIs 200 statusIs 200
bodyEquals "Hello world!" bodyEquals "Hello world!"
yit "tests1b" $ do yit "tests1b" $ do
get_ "/foo" get_ ("/foo" :: Text)
statusIs 404 statusIs 404
ydescribe "tests2" $ do ydescribe "tests2" $ do
yit "tests2a" $ return () 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 "tests2b" $ return () yit "tests2b" $ return ()

1
yesod-test/yesod-test.cabal
View File

@ -58,6 +58,7 @@ test-suite test
, containers , containers
, html-conduit , html-conduit
, yesod-core , yesod-core
, text
source-repository head source-repository head
type: git type: git