diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index b7cdead9..385ca1a4 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -42,6 +42,7 @@ module Yesod.Test -- , get , post + , postBody , request , addRequestHeader , setMethod @@ -176,7 +177,8 @@ data RequestBuilderData site = RequestBuilderData -- | Request parts let us discern regular key/values from files sent in the request. data RequestPart - = ReqPlainPart T.Text T.Text + = ReqKvPart T.Text T.Text + | ReqTextPart T.Text | ReqFilePart T.Text FilePath BSL8.ByteString T.Text -- | The RequestBuilder state monad constructs an url encoded string of arguments @@ -371,7 +373,7 @@ printMatches query = do addPostParam :: T.Text -> T.Text -> RequestBuilder site () addPostParam name value = ST.modify $ \rbd -> rbd - { rbdPosts = ReqPlainPart name value : rbdPosts rbd + { rbdPosts = ReqKvPart name value : rbdPosts rbd } addGetParam :: T.Text -> T.Text -> RequestBuilder site () @@ -458,9 +460,17 @@ addNonce = addNonce_ "" post :: (Yesod site, RedirectUrl site url) => url -> YesodExample site () -post url = request $ do - setMethod "POST" - setUrl url +post url = postBody url "" + +-- | Perform a POST request to url with sending a body into it. +postBody :: (Yesod site, RedirectUrl site url) + => url + -> T.Text + -> YesodExample site () +postBody url body = request $ do + setRequestBody body + setMethod "POST" + setUrl url -- | Perform a GET request to url, using params get :: (Yesod site, RedirectUrl site url) @@ -494,6 +504,12 @@ setUrl url' = do , rbdGets = rbdGets rbd ++ H.parseQuery (TE.encodeUtf8 urlQuery) } +-- | Simple way to set HTTP request body +setRequestBody :: (Yesod site) + => T.Text + -> RequestBuilder site () +setRequestBody body = ST.modify $ \rbd -> rbd { rbdPosts = [ ReqTextPart body ] } + addRequestHeader :: H.Header -> RequestBuilder site () addRequestHeader header = ST.modify $ \rbd -> rbd { rbdHeaders = header : rbdHeaders rbd @@ -556,10 +572,12 @@ request reqBuilder = do ] method extraHeaders urlPath urlQuery multiPartBody parts = BS8.concat $ separator : [BS8.concat [multipartPart p, separator] | p <- parts] - multipartPart (ReqPlainPart k v) = BS8.concat + multipartPart (ReqKvPart k v) = BS8.concat [ "Content-Disposition: form-data; " , "name=\"", TE.encodeUtf8 k, "\"\r\n\r\n" , TE.encodeUtf8 v, "\r\n"] + multipartPart (ReqTextPart v) = BS8.concat + [ TE.encodeUtf8 v, "\r\n" ] multipartPart (ReqFilePart k v bytes mime) = BS8.concat [ "Content-Disposition: form-data; " , "name=\"", TE.encodeUtf8 k, "\"; " @@ -568,15 +586,29 @@ request reqBuilder = do , BS8.concat $ BSL8.toChunks bytes, "\r\n"] -- 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 - - singlepartPart (ReqFilePart _ _ _ _) = "" - singlepartPart (ReqPlainPart k v) = T.concat [k,"=",v] + makeSinglepart :: M.Map a0 Cookie.SetCookie + -> [RequestPart] + -> H.Method + -> [H.Header] + -> T.Text + -> H.Query + -> SRequest + makeSinglepart cookies parts method extraHeaders urlPath urlQuery = + SRequest simpleRequest' simpleRequestBody' + where + simpleRequest' = (mkRequest + [ ("Cookie", cookieValue) + , ("Content-Type", "application/x-www-form-urlencoded")] + method extraHeaders urlPath urlQuery) + simpleRequestBody' = BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" + $ map singlepartPart parts + cookieValue = Builder.toByteString + $ Cookie.renderCookies cookiePairs + cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c) + | c <- map snd $ M.toList cookies ] + singlepartPart (ReqFilePart _ _ _ _) = "" + singlepartPart (ReqKvPart k v) = T.concat [k,"=",v] + singlepartPart (ReqTextPart v) = v -- General request making mkRequest headers method extraHeaders urlPath urlQuery = defaultRequest