diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index b7cdead9..5e4884a2 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -42,12 +42,14 @@ module Yesod.Test -- , get , post + , postBody , request , addRequestHeader , setMethod , addPostParam , addGetParam , addFile + , setRequestBody , RequestBuilder , setUrl @@ -165,7 +167,7 @@ getResponse :: YesodExample site (Maybe SResponse) getResponse = fmap yedResponse ST.get data RequestBuilderData site = RequestBuilderData - { rbdPosts :: [RequestPart] + { rbdPostData :: RBDPostData , rbdResponse :: (Maybe SResponse) , rbdMethod :: H.Method , rbdSite :: site @@ -174,9 +176,12 @@ data RequestBuilderData site = RequestBuilderData , rbdHeaders :: H.RequestHeaders } +data RBDPostData = MultipleItemsPostData [RequestPart] + | BinaryPostData BSL8.ByteString + -- | 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 | ReqFilePart T.Text FilePath BSL8.ByteString T.Text -- | The RequestBuilder state monad constructs an url encoded string of arguments @@ -370,9 +375,10 @@ printMatches query = do -- | Add a parameter with the given name and value. addPostParam :: T.Text -> T.Text -> RequestBuilder site () addPostParam name value = - ST.modify $ \rbd -> rbd - { rbdPosts = ReqPlainPart name value : rbdPosts rbd - } + ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) } + where addPostData (BinaryPostData _) = error "Trying to add post param to binary content." + addPostData (MultipleItemsPostData posts) = + MultipleItemsPostData $ ReqKvPart name value : posts addGetParam :: T.Text -> T.Text -> RequestBuilder site () addGetParam name value = ST.modify $ \rbd -> rbd @@ -386,9 +392,10 @@ addGetParam name value = ST.modify $ \rbd -> rbd addFile :: T.Text -> FilePath -> T.Text -> RequestBuilder site () addFile name path mimetype = do contents <- liftIO $ BSL8.readFile path - ST.modify $ \rbd -> rbd - { rbdPosts = ReqFilePart name path contents mimetype : rbdPosts rbd - } + ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) } + where addPostData (BinaryPostData _) _ = error "Trying to add file after setting binary content." + addPostData (MultipleItemsPostData posts) contents = + MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts -- 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 @@ -459,8 +466,18 @@ post :: (Yesod site, RedirectUrl site url) => url -> YesodExample site () post url = request $ do - setMethod "POST" - setUrl url + setMethod "POST" + setUrl url + +-- | Perform a POST request to url with sending a body into it. +postBody :: (Yesod site, RedirectUrl site url) + => url + -> BSL8.ByteString + -> YesodExample site () +postBody url body = request $ do + setMethod "POST" + setUrl url + setRequestBody body -- | Perform a GET request to url, using params get :: (Yesod site, RedirectUrl site url) @@ -494,6 +511,12 @@ setUrl url' = do , rbdGets = rbdGets rbd ++ H.parseQuery (TE.encodeUtf8 urlQuery) } +-- | Simple way to set HTTP request body +setRequestBody :: (Yesod site) + => BSL8.ByteString + -> RequestBuilder site () +setRequestBody body = ST.modify $ \rbd -> rbd { rbdPostData = BinaryPostData body } + addRequestHeader :: H.Header -> RequestBuilder site () addRequestHeader header = ST.modify $ \rbd -> rbd { rbdHeaders = header : rbdHeaders rbd @@ -508,7 +531,7 @@ request reqBuilder = do YesodExampleData app site oldCookies mRes <- ST.get RequestBuilderData {..} <- liftIO $ ST.execStateT reqBuilder RequestBuilderData - { rbdPosts = [] + { rbdPostData = MultipleItemsPostData [] , rbdResponse = mRes , rbdMethod = "GET" , rbdSite = site @@ -523,11 +546,21 @@ request reqBuilder = do let cookies = M.filter (checkCookieTime currentUtc) oldCookies cookiesForPath = M.filter (checkCookiePath path) cookies - let maker - | DL.any isFile rbdPosts = makeMultipart - | otherwise = makeSinglepart - req = maker cookiesForPath rbdPosts rbdMethod rbdHeaders path rbdGets - + let req = case rbdPostData of + MultipleItemsPostData x -> + if DL.any isFile x + then (multipart x) + else singlepart + BinaryPostData _ -> singlepart + where singlepart = makeSinglepart cookiesForPath rbdPostData rbdMethod rbdHeaders path rbdGets + multipart x = makeMultipart cookiesForPath x rbdMethod rbdHeaders path rbdGets + -- let maker = case rbdPostData of + -- MultipleItemsPostData x -> + -- if DL.any isFile x + -- then makeMultipart + -- else makeSinglepart + -- BinaryPostData _ -> makeSinglepart + -- let req = maker cookiesForPath rbdPostData rbdMethod rbdHeaders path rbdGets 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 @@ -548,15 +581,28 @@ request reqBuilder = do boundary :: String boundary = "*******noneedtomakethisrandom" separator = BS8.concat ["--", BS8.pack boundary, "\r\n"] + makeMultipart :: M.Map a0 Cookie.SetCookie + -> [RequestPart] + -> H.Method + -> [H.Header] + -> T.Text + -> H.Query + -> SRequest 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 + SRequest simpleRequest' (simpleRequestBody' parts) + where simpleRequestBody' x = + BSL8.fromChunks [multiPartBody x] + simpleRequest' = mkRequest + [ ("Cookie", cookieValue) + , ("Content-Type", contentTypeValue)] + method extraHeaders urlPath urlQuery + cookieValue = Builder.toByteString $ Cookie.renderCookies cookiePairs + cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c) + | c <- map snd $ M.toList cookies ] + contentTypeValue = BS8.pack $ "multipart/form-data; boundary=" ++ boundary 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"] @@ -568,15 +614,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 + -> RBDPostData + -> H.Method + -> [H.Header] + -> T.Text + -> H.Query + -> SRequest + makeSinglepart cookies rbdPostData method extraHeaders urlPath urlQuery = + SRequest simpleRequest' (simpleRequestBody' rbdPostData) + where + simpleRequest' = (mkRequest + [ ("Cookie", cookieValue) + , ("Content-Type", "application/x-www-form-urlencoded")] + method extraHeaders urlPath urlQuery) + simpleRequestBody' (MultipleItemsPostData x) = + BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" + $ map singlepartPart x + simpleRequestBody' (BinaryPostData x) = x + 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] -- General request making mkRequest headers method extraHeaders urlPath urlQuery = defaultRequest