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

Use GADTs for static guarantee you use right type of post data.

Browse Source
This commit is contained in:
Konstantine Rybnikov 2013-07-30 11:11:34 +03:00
parent eb7ad4e480
commit 3655af11d3
1 changed files with 51 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,6 +2,7 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GADTs #-}
{-| {-|
Yesod.Test is a pragmatic framework for testing web applications built Yesod.Test is a pragmatic framework for testing web applications built
using wai and persistent. using wai and persistent.
@ -165,8 +166,8 @@ getTestYesod = fmap yedSite ST.get
getResponse :: YesodExample site (Maybe SResponse) getResponse :: YesodExample site (Maybe SResponse)
getResponse = fmap yedResponse ST.get getResponse = fmap yedResponse ST.get
data RequestBuilderData site = RequestBuilderData data RequestBuilderData site p = RequestBuilderData
{ rbdPostData :: RBDPostData { rbdPostData :: Maybe (RBDPostData p)
, rbdResponse :: (Maybe SResponse) , rbdResponse :: (Maybe SResponse)
, rbdMethod :: H.Method , rbdMethod :: H.Method
, rbdSite :: site , rbdSite :: site
@ -175,8 +176,9 @@ data RequestBuilderData site = RequestBuilderData
, rbdHeaders :: H.RequestHeaders , rbdHeaders :: H.RequestHeaders
} }
data RBDPostData = MultipleItemsPostData [RequestPart] data RBDPostData a where
| BinaryPostData BSL8.ByteString MultipleItemsPostData :: [RequestPart] -> RBDPostData [RequestPart]
BinaryPostData :: BSL8.ByteString -> RBDPostData BSL8.ByteString
-- | Request parts let us discern regular key/values from files sent in the request. -- | Request parts let us discern regular key/values from files sent in the request.
data RequestPart data RequestPart
@ -186,7 +188,7 @@ data RequestPart
-- | The RequestBuilder state monad constructs an url encoded string of arguments -- | 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 -- 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. -- response to analize the forms that the server is expecting to receive.
type RequestBuilder site = ST.StateT (RequestBuilderData site) IO type RequestBuilder site p = ST.StateT (RequestBuilderData site p) IO
-- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application' -- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application'
-- and 'ConnectionPool' -- and 'ConnectionPool'
@ -372,14 +374,16 @@ printMatches query = do
liftIO $ hPutStrLn stderr $ show matches liftIO $ hPutStrLn stderr $ show matches
-- | Add a parameter with the given name and value. -- | Add a parameter with the given name and value.
addPostParam :: T.Text -> T.Text -> RequestBuilder site () addPostParam :: T.Text -> T.Text -> RequestBuilder site [RequestPart] ()
addPostParam name value = addPostParam name value =
ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) } ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) }
where addPostData x@(BinaryPostData _) = x where addPostData :: Maybe (RBDPostData [RequestPart])
addPostData (MultipleItemsPostData posts) = -> Maybe (RBDPostData [RequestPart])
MultipleItemsPostData $ ReqKvPart name value : posts addPostData (Just (MultipleItemsPostData posts)) =
Just $ MultipleItemsPostData $ ReqKvPart name value : posts
addPostData Nothing = Just $ MultipleItemsPostData $ [ReqKvPart name value]
addGetParam :: T.Text -> T.Text -> RequestBuilder site () addGetParam :: T.Text -> T.Text -> RequestBuilder site p ()
addGetParam name value = ST.modify $ \rbd -> rbd addGetParam name value = ST.modify $ \rbd -> rbd
{ rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value) { rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value)
: rbdGets rbd : rbdGets rbd
@ -388,16 +392,20 @@ addGetParam name value = ST.modify $ \rbd -> rbd
-- | Add a file to be posted with the current request -- | 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 -- Adding a file will automatically change your request content-type to be multipart/form-data
addFile :: T.Text -> FilePath -> T.Text -> RequestBuilder site () addFile :: T.Text -> FilePath -> T.Text -> RequestBuilder site [RequestPart] ()
addFile name path mimetype = do addFile name path mimetype = do
contents <- liftIO $ BSL8.readFile path contents <- liftIO $ BSL8.readFile path
ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) } ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) }
where addPostData x@(BinaryPostData _) _ = x where addPostData :: Maybe (RBDPostData [RequestPart])
addPostData (MultipleItemsPostData posts) contents = -> BSL8.ByteString
MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts -> Maybe (RBDPostData [RequestPart])
addPostData (Just (MultipleItemsPostData posts)) contents =
Just $ MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts
addPostData Nothing contents =
Just $ MultipleItemsPostData $ [ReqFilePart name path contents mimetype]
-- This looks up the name of a field based on the contents of the label pointing to it. -- This looks up the name of a field based on the contents of the label pointing to it.
nameFromLabel :: T.Text -> RequestBuilder site T.Text nameFromLabel :: T.Text -> RequestBuilder site p T.Text
nameFromLabel label = do nameFromLabel label = do
mres <- fmap rbdResponse ST.get mres <- fmap rbdResponse ST.get
res <- res <-
@ -436,19 +444,19 @@ nameFromLabel label = do
(<>) :: T.Text -> T.Text -> T.Text (<>) :: T.Text -> T.Text -> T.Text
(<>) = T.append (<>) = T.append
byLabel :: T.Text -> T.Text -> RequestBuilder site () byLabel :: T.Text -> T.Text -> RequestBuilder site [RequestPart] ()
byLabel label value = do byLabel label value = do
name <- nameFromLabel label name <- nameFromLabel label
addPostParam name value addPostParam name value
fileByLabel :: T.Text -> FilePath -> T.Text -> RequestBuilder site () fileByLabel :: T.Text -> FilePath -> T.Text -> RequestBuilder site [RequestPart] ()
fileByLabel label path mime = do fileByLabel label path mime = do
name <- nameFromLabel label name <- nameFromLabel label
addFile 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. -- Receives a CSS selector that should resolve to the form element containing the nonce.
addNonce_ :: Query -> RequestBuilder site () addNonce_ :: Query -> RequestBuilder site [RequestPart] ()
addNonce_ scope = do addNonce_ scope = do
matches <- htmlQuery' rbdResponse $ scope <> "input[name=_token][type=hidden][value]" matches <- htmlQuery' rbdResponse $ scope <> "input[name=_token][type=hidden][value]"
case matches of case matches of
@ -457,7 +465,7 @@ addNonce_ scope = do
_ -> failure $ "More than one nonce found in the page" _ -> failure $ "More than one nonce found in the page"
-- | For responses that display a single form, just lookup the only nonce available. -- | For responses that display a single form, just lookup the only nonce available.
addNonce :: RequestBuilder site () addNonce :: RequestBuilder site [RequestPart] ()
addNonce = addNonce_ "" addNonce = addNonce_ ""
-- | Perform a POST request to url -- | Perform a POST request to url
@ -486,12 +494,12 @@ get url = request $ do
setMethod "GET" setMethod "GET"
setUrl url setUrl url
setMethod :: H.Method -> RequestBuilder site () setMethod :: H.Method -> RequestBuilder site p ()
setMethod m = ST.modify $ \rbd -> rbd { rbdMethod = m } setMethod m = ST.modify $ \rbd -> rbd { rbdMethod = m }
setUrl :: (Yesod site, RedirectUrl site url) setUrl :: (Yesod site, RedirectUrl site url)
=> url => url
-> RequestBuilder site () -> RequestBuilder site p ()
setUrl url' = do setUrl url' = do
site <- fmap rbdSite ST.get site <- fmap rbdSite ST.get
eurl <- runFakeHandler eurl <- runFakeHandler
@ -513,10 +521,10 @@ setUrl url' = do
-- | Simple way to set HTTP request body -- | Simple way to set HTTP request body
setRequestBody :: (Yesod site) setRequestBody :: (Yesod site)
=> BSL8.ByteString => BSL8.ByteString
-> RequestBuilder site () -> RequestBuilder site BSL8.ByteString ()
setRequestBody body = ST.modify $ \rbd -> rbd { rbdPostData = BinaryPostData body } setRequestBody body = ST.modify $ \rbd -> rbd { rbdPostData = Just (BinaryPostData body) }
addRequestHeader :: H.Header -> RequestBuilder site () addRequestHeader :: H.Header -> RequestBuilder site p ()
addRequestHeader header = ST.modify $ \rbd -> rbd addRequestHeader header = ST.modify $ \rbd -> rbd
{ rbdHeaders = header : rbdHeaders rbd { rbdHeaders = header : rbdHeaders rbd
} }
@ -524,13 +532,13 @@ addRequestHeader header = ST.modify $ \rbd -> rbd
-- | 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.
request :: Yesod site request :: Yesod site
=> RequestBuilder site () => RequestBuilder site p ()
-> YesodExample site () -> YesodExample site ()
request reqBuilder = do request reqBuilder = do
YesodExampleData app site oldCookies mRes <- ST.get YesodExampleData app site oldCookies mRes <- ST.get
RequestBuilderData {..} <- liftIO $ ST.execStateT reqBuilder RequestBuilderData RequestBuilderData {..} <- liftIO $ ST.execStateT reqBuilder RequestBuilderData
{ rbdPostData = MultipleItemsPostData [] { rbdPostData = Nothing
, rbdResponse = mRes , rbdResponse = mRes
, rbdMethod = "GET" , rbdMethod = "GET"
, rbdSite = site , rbdSite = site
@ -546,11 +554,12 @@ request reqBuilder = do
cookiesForPath = M.filter (checkCookiePath path) cookies cookiesForPath = M.filter (checkCookiePath path) cookies
let maker = case rbdPostData of let maker = case rbdPostData of
MultipleItemsPostData x -> Just (MultipleItemsPostData x) ->
if DL.any isFile x if DL.any isFile x
then makeMultipart then makeMultipart
else makeSinglepart else makeSinglepart
BinaryPostData _ -> makeSinglepart Just (BinaryPostData _) -> makeSinglepart
Nothing -> makeSinglepart
let req = maker cookiesForPath rbdPostData rbdMethod rbdHeaders path rbdGets let req = maker cookiesForPath rbdPostData rbdMethod rbdHeaders path rbdGets
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
@ -572,11 +581,19 @@ request reqBuilder = do
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 :: M.Map a0 Cookie.SetCookie
-> Maybe (RBDPostData [RequestPart])
-> H.Method
-> [H.Header]
-> T.Text
-> H.Query
-> SRequest
makeMultipart cookies rbdPostData method extraHeaders urlPath urlQuery = makeMultipart cookies rbdPostData method extraHeaders urlPath urlQuery =
SRequest simpleRequest' (simpleRequestBody' rbdPostData) SRequest simpleRequest' (simpleRequestBody' rbdPostData)
where simpleRequestBody' (MultipleItemsPostData x) = where simpleRequestBody' :: Maybe (RBDPostData [RequestPart]) -> BSL8.ByteString
simpleRequestBody' (Just (MultipleItemsPostData x)) =
BSL8.fromChunks [multiPartBody x] BSL8.fromChunks [multiPartBody x]
simpleRequestBody' (BinaryPostData _) = "" simpleRequestBody' Nothing = ""
simpleRequest' = mkRequest simpleRequest' = mkRequest
[ ("Cookie", cookieValue) [ ("Cookie", cookieValue)
, ("Content-Type", contentTypeValue)] , ("Content-Type", contentTypeValue)]
@ -600,7 +617,7 @@ request reqBuilder = do
-- For building the regular non-multipart requests -- For building the regular non-multipart requests
makeSinglepart :: M.Map a0 Cookie.SetCookie makeSinglepart :: M.Map a0 Cookie.SetCookie
-> RBDPostData -> Maybe (RBDPostData p)
-> H.Method -> H.Method
-> [H.Header] -> [H.Header]
-> T.Text -> T.Text
@ -613,10 +630,11 @@ request reqBuilder = do
[ ("Cookie", cookieValue) [ ("Cookie", cookieValue)
, ("Content-Type", "application/x-www-form-urlencoded")] , ("Content-Type", "application/x-www-form-urlencoded")]
method extraHeaders urlPath urlQuery) method extraHeaders urlPath urlQuery)
simpleRequestBody' (MultipleItemsPostData x) = simpleRequestBody' (Just (MultipleItemsPostData x)) =
BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&"
$ map singlepartPart x $ map singlepartPart x
simpleRequestBody' (BinaryPostData x) = x simpleRequestBody' (Just (BinaryPostData x)) = x
simpleRequestBody' Nothing = ""
cookieValue = Builder.toByteString $ Cookie.renderCookies cookiePairs cookieValue = Builder.toByteString $ Cookie.renderCookies cookiePairs
cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c) cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c)
| c <- map snd $ M.toList cookies ] | c <- map snd $ M.toList cookies ]