From ee168c7829cb6362bf17dfe497af680ab268dfc5 Mon Sep 17 00:00:00 2001 From: Konstantine Rybnikov Date: Mon, 29 Jul 2013 11:26:32 +0300 Subject: [PATCH 1/9] Add postBody and setRequestBody functions to POST some data in a test. --- yesod-test/Yesod/Test.hs | 62 ++++++++++++++++++++++++++++++---------- 1 file changed, 47 insertions(+), 15 deletions(-) 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 From 8664c010da13bd890be79931de63e9578b94c3ee Mon Sep 17 00:00:00 2001 From: Konstantine Rybnikov Date: Mon, 29 Jul 2013 16:57:13 +0300 Subject: [PATCH 2/9] Second attempt to write a good postBody and setRequestBody. --- yesod-test/Yesod/Test.hs | 78 +++++++++++++++++++++++----------------- 1 file changed, 45 insertions(+), 33 deletions(-) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 385ca1a4..0587cac8 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -166,7 +166,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 @@ -175,10 +175,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 = 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 @@ -372,9 +374,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 = ReqKvPart name value : rbdPosts rbd - } + ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) } + where addPostData x@(BinaryPostData _) = x + addPostData (MultipleItemsPostData posts) = + MultipleItemsPostData $ ReqKvPart name value : posts addGetParam :: T.Text -> T.Text -> RequestBuilder site () addGetParam name value = ST.modify $ \rbd -> rbd @@ -388,9 +391,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 x@(BinaryPostData _) _ = x + 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 @@ -465,7 +469,7 @@ 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 + -> BSL8.ByteString -> YesodExample site () postBody url body = request $ do setRequestBody body @@ -506,9 +510,9 @@ setUrl url' = do -- | Simple way to set HTTP request body setRequestBody :: (Yesod site) - => T.Text + => BSL8.ByteString -> RequestBuilder site () -setRequestBody body = ST.modify $ \rbd -> rbd { rbdPosts = [ ReqTextPart body ] } +setRequestBody body = ST.modify $ \rbd -> rbd { rbdPostData = BinaryPostData body } addRequestHeader :: H.Header -> RequestBuilder site () addRequestHeader header = ST.modify $ \rbd -> rbd @@ -524,7 +528,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 @@ -539,11 +543,13 @@ 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 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 @@ -564,20 +570,26 @@ request reqBuilder = do 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 + makeMultipart cookies rbdPostData method extraHeaders urlPath urlQuery = + SRequest simpleRequest' (simpleRequestBody' rbdPostData) + where simpleRequestBody' (MultipleItemsPostData x) = + BSL8.fromChunks [multiPartBody x] + simpleRequestBody' (BinaryPostData _) = "" + 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 (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 (ReqBinaryPart v) = undefined multipartPart (ReqFilePart k v bytes mime) = BS8.concat [ "Content-Disposition: form-data; " , "name=\"", TE.encodeUtf8 k, "\"; " @@ -587,28 +599,28 @@ request reqBuilder = do -- For building the regular non-multipart requests makeSinglepart :: M.Map a0 Cookie.SetCookie - -> [RequestPart] + -> RBDPostData -> H.Method -> [H.Header] -> T.Text -> H.Query -> SRequest - makeSinglepart cookies parts method extraHeaders urlPath urlQuery = - SRequest simpleRequest' simpleRequestBody' + 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' = BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" - $ map singlepartPart parts - cookieValue = Builder.toByteString - $ Cookie.renderCookies cookiePairs + 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] - singlepartPart (ReqTextPart v) = v -- General request making mkRequest headers method extraHeaders urlPath urlQuery = defaultRequest From fdb564abfedfa2600b15398fe4c83d423d817f32 Mon Sep 17 00:00:00 2001 From: Konstantine Rybnikov Date: Mon, 29 Jul 2013 17:00:32 +0300 Subject: [PATCH 3/9] Get post function back without overwriting content --- yesod-test/Yesod/Test.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 0587cac8..f1a6655f 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -464,7 +464,9 @@ addNonce = addNonce_ "" post :: (Yesod site, RedirectUrl site url) => url -> YesodExample site () -post url = postBody url "" +post url = request $ do + setMethod "POST" + setUrl url -- | Perform a POST request to url with sending a body into it. postBody :: (Yesod site, RedirectUrl site url) @@ -472,9 +474,9 @@ postBody :: (Yesod site, RedirectUrl site url) -> BSL8.ByteString -> YesodExample site () postBody url body = request $ do - setRequestBody body setMethod "POST" setUrl url + setRequestBody body -- | Perform a GET request to url, using params get :: (Yesod site, RedirectUrl site url) From a46a6fa39922c3275d5da4a65575013fb22a5f5e Mon Sep 17 00:00:00 2001 From: Konstantine Rybnikov Date: Mon, 29 Jul 2013 17:01:20 +0300 Subject: [PATCH 4/9] Small spacing fix --- yesod-test/Yesod/Test.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index f1a6655f..6f0c34fa 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -464,7 +464,7 @@ addNonce = addNonce_ "" post :: (Yesod site, RedirectUrl site url) => url -> YesodExample site () -post url = request $ do +post url = request $ do setMethod "POST" setUrl url From eb7ad4e480cc65e75f886a4b7fb4099ecb0f3801 Mon Sep 17 00:00:00 2001 From: Konstantine Rybnikov Date: Mon, 29 Jul 2013 17:03:37 +0300 Subject: [PATCH 5/9] Remove unused comment --- yesod-test/Yesod/Test.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 6f0c34fa..74bdcc02 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -591,7 +591,6 @@ request reqBuilder = do [ "Content-Disposition: form-data; " , "name=\"", TE.encodeUtf8 k, "\"\r\n\r\n" , TE.encodeUtf8 v, "\r\n"] - -- multipartPart (ReqBinaryPart v) = undefined multipartPart (ReqFilePart k v bytes mime) = BS8.concat [ "Content-Disposition: form-data; " , "name=\"", TE.encodeUtf8 k, "\"; " From 3655af11d3be0fdece443706bbc96ea9c52b458d Mon Sep 17 00:00:00 2001 From: Konstantine Rybnikov Date: Tue, 30 Jul 2013 11:11:34 +0300 Subject: [PATCH 6/9] Use GADTs for static guarantee you use right type of post data. --- yesod-test/Yesod/Test.hs | 84 ++++++++++++++++++++++++---------------- 1 file changed, 51 insertions(+), 33 deletions(-) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 74bdcc02..0d589104 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} {-| Yesod.Test is a pragmatic framework for testing web applications built using wai and persistent. @@ -165,8 +166,8 @@ getTestYesod = fmap yedSite ST.get getResponse :: YesodExample site (Maybe SResponse) getResponse = fmap yedResponse ST.get -data RequestBuilderData site = RequestBuilderData - { rbdPostData :: RBDPostData +data RequestBuilderData site p = RequestBuilderData + { rbdPostData :: Maybe (RBDPostData p) , rbdResponse :: (Maybe SResponse) , rbdMethod :: H.Method , rbdSite :: site @@ -175,8 +176,9 @@ data RequestBuilderData site = RequestBuilderData , rbdHeaders :: H.RequestHeaders } -data RBDPostData = MultipleItemsPostData [RequestPart] - | BinaryPostData BSL8.ByteString +data RBDPostData a where + MultipleItemsPostData :: [RequestPart] -> RBDPostData [RequestPart] + BinaryPostData :: BSL8.ByteString -> RBDPostData BSL8.ByteString -- | Request parts let us discern regular key/values from files sent in the request. data RequestPart @@ -186,7 +188,7 @@ data RequestPart -- | 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 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' -- and 'ConnectionPool' @@ -372,14 +374,16 @@ printMatches query = do liftIO $ hPutStrLn stderr $ show matches -- | 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 = ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) } - where addPostData x@(BinaryPostData _) = x - addPostData (MultipleItemsPostData posts) = - MultipleItemsPostData $ ReqKvPart name value : posts + where addPostData :: Maybe (RBDPostData [RequestPart]) + -> Maybe (RBDPostData [RequestPart]) + 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 { rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value) : rbdGets rbd @@ -388,16 +392,20 @@ addGetParam name value = ST.modify $ \rbd -> 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 -addFile :: T.Text -> FilePath -> T.Text -> RequestBuilder site () +addFile :: T.Text -> FilePath -> T.Text -> RequestBuilder site [RequestPart] () addFile name path mimetype = do contents <- liftIO $ BSL8.readFile path ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) } - where addPostData x@(BinaryPostData _) _ = x - addPostData (MultipleItemsPostData posts) contents = - MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts + where addPostData :: Maybe (RBDPostData [RequestPart]) + -> BSL8.ByteString + -> 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. -nameFromLabel :: T.Text -> RequestBuilder site T.Text +nameFromLabel :: T.Text -> RequestBuilder site p T.Text nameFromLabel label = do mres <- fmap rbdResponse ST.get res <- @@ -436,19 +444,19 @@ nameFromLabel label = do (<>) :: T.Text -> T.Text -> T.Text (<>) = T.append -byLabel :: T.Text -> T.Text -> RequestBuilder site () +byLabel :: T.Text -> T.Text -> RequestBuilder site [RequestPart] () byLabel label value = do name <- nameFromLabel label 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 name <- nameFromLabel label addFile name path mime -- | 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 site () +addNonce_ :: Query -> RequestBuilder site [RequestPart] () addNonce_ scope = do matches <- htmlQuery' rbdResponse $ scope <> "input[name=_token][type=hidden][value]" case matches of @@ -457,7 +465,7 @@ addNonce_ scope = do _ -> failure $ "More than one nonce found in the page" -- | For responses that display a single form, just lookup the only nonce available. -addNonce :: RequestBuilder site () +addNonce :: RequestBuilder site [RequestPart] () addNonce = addNonce_ "" -- | Perform a POST request to url @@ -486,12 +494,12 @@ get url = request $ do setMethod "GET" setUrl url -setMethod :: H.Method -> RequestBuilder site () +setMethod :: H.Method -> RequestBuilder site p () setMethod m = ST.modify $ \rbd -> rbd { rbdMethod = m } setUrl :: (Yesod site, RedirectUrl site url) => url - -> RequestBuilder site () + -> RequestBuilder site p () setUrl url' = do site <- fmap rbdSite ST.get eurl <- runFakeHandler @@ -513,10 +521,10 @@ setUrl url' = do -- | Simple way to set HTTP request body setRequestBody :: (Yesod site) => BSL8.ByteString - -> RequestBuilder site () -setRequestBody body = ST.modify $ \rbd -> rbd { rbdPostData = BinaryPostData body } + -> RequestBuilder site BSL8.ByteString () +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 { rbdHeaders = header : rbdHeaders rbd } @@ -524,13 +532,13 @@ addRequestHeader header = ST.modify $ \rbd -> rbd -- | General interface to performing requests, allowing you to add extra -- headers as well as letting you specify the request method. request :: Yesod site - => RequestBuilder site () + => RequestBuilder site p () -> YesodExample site () request reqBuilder = do YesodExampleData app site oldCookies mRes <- ST.get RequestBuilderData {..} <- liftIO $ ST.execStateT reqBuilder RequestBuilderData - { rbdPostData = MultipleItemsPostData [] + { rbdPostData = Nothing , rbdResponse = mRes , rbdMethod = "GET" , rbdSite = site @@ -546,11 +554,12 @@ request reqBuilder = do cookiesForPath = M.filter (checkCookiePath path) cookies let maker = case rbdPostData of - MultipleItemsPostData x -> + Just (MultipleItemsPostData x) -> if DL.any isFile x then makeMultipart else makeSinglepart - BinaryPostData _ -> makeSinglepart + Just (BinaryPostData _) -> makeSinglepart + Nothing -> 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 @@ -572,11 +581,19 @@ request reqBuilder = do boundary :: String boundary = "*******noneedtomakethisrandom" 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 = SRequest simpleRequest' (simpleRequestBody' rbdPostData) - where simpleRequestBody' (MultipleItemsPostData x) = + where simpleRequestBody' :: Maybe (RBDPostData [RequestPart]) -> BSL8.ByteString + simpleRequestBody' (Just (MultipleItemsPostData x)) = BSL8.fromChunks [multiPartBody x] - simpleRequestBody' (BinaryPostData _) = "" + simpleRequestBody' Nothing = "" simpleRequest' = mkRequest [ ("Cookie", cookieValue) , ("Content-Type", contentTypeValue)] @@ -600,7 +617,7 @@ request reqBuilder = do -- For building the regular non-multipart requests makeSinglepart :: M.Map a0 Cookie.SetCookie - -> RBDPostData + -> Maybe (RBDPostData p) -> H.Method -> [H.Header] -> T.Text @@ -613,10 +630,11 @@ request reqBuilder = do [ ("Cookie", cookieValue) , ("Content-Type", "application/x-www-form-urlencoded")] method extraHeaders urlPath urlQuery) - simpleRequestBody' (MultipleItemsPostData x) = + simpleRequestBody' (Just (MultipleItemsPostData x)) = BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" $ map singlepartPart x - simpleRequestBody' (BinaryPostData x) = x + simpleRequestBody' (Just (BinaryPostData x)) = x + simpleRequestBody' Nothing = "" cookieValue = Builder.toByteString $ Cookie.renderCookies cookiePairs cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies ] From 441842ae12e46b128029e9aa236d0659bf7cd479 Mon Sep 17 00:00:00 2001 From: Konstantine Rybnikov Date: Fri, 9 Aug 2013 22:48:09 +0300 Subject: [PATCH 7/9] Revert "Use GADTs for static guarantee you use right type of post data." This reverts commit 3655af11d3be0fdece443706bbc96ea9c52b458d. --- yesod-test/Yesod/Test.hs | 84 ++++++++++++++++------------------------ 1 file changed, 33 insertions(+), 51 deletions(-) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 0d589104..74bdcc02 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -2,7 +2,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GADTs #-} {-| Yesod.Test is a pragmatic framework for testing web applications built using wai and persistent. @@ -166,8 +165,8 @@ getTestYesod = fmap yedSite ST.get getResponse :: YesodExample site (Maybe SResponse) getResponse = fmap yedResponse ST.get -data RequestBuilderData site p = RequestBuilderData - { rbdPostData :: Maybe (RBDPostData p) +data RequestBuilderData site = RequestBuilderData + { rbdPostData :: RBDPostData , rbdResponse :: (Maybe SResponse) , rbdMethod :: H.Method , rbdSite :: site @@ -176,9 +175,8 @@ data RequestBuilderData site p = RequestBuilderData , rbdHeaders :: H.RequestHeaders } -data RBDPostData a where - MultipleItemsPostData :: [RequestPart] -> RBDPostData [RequestPart] - BinaryPostData :: BSL8.ByteString -> RBDPostData BSL8.ByteString +data RBDPostData = MultipleItemsPostData [RequestPart] + | BinaryPostData BSL8.ByteString -- | Request parts let us discern regular key/values from files sent in the request. data RequestPart @@ -188,7 +186,7 @@ data RequestPart -- | 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 site p = ST.StateT (RequestBuilderData site p) IO +type RequestBuilder site = ST.StateT (RequestBuilderData site) IO -- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application' -- and 'ConnectionPool' @@ -374,16 +372,14 @@ printMatches query = do liftIO $ hPutStrLn stderr $ show matches -- | Add a parameter with the given name and value. -addPostParam :: T.Text -> T.Text -> RequestBuilder site [RequestPart] () +addPostParam :: T.Text -> T.Text -> RequestBuilder site () addPostParam name value = ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) } - where addPostData :: Maybe (RBDPostData [RequestPart]) - -> Maybe (RBDPostData [RequestPart]) - addPostData (Just (MultipleItemsPostData posts)) = - Just $ MultipleItemsPostData $ ReqKvPart name value : posts - addPostData Nothing = Just $ MultipleItemsPostData $ [ReqKvPart name value] + where addPostData x@(BinaryPostData _) = x + addPostData (MultipleItemsPostData posts) = + MultipleItemsPostData $ ReqKvPart name value : posts -addGetParam :: T.Text -> T.Text -> RequestBuilder site p () +addGetParam :: T.Text -> T.Text -> RequestBuilder site () addGetParam name value = ST.modify $ \rbd -> rbd { rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value) : rbdGets rbd @@ -392,20 +388,16 @@ addGetParam name value = ST.modify $ \rbd -> 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 -addFile :: T.Text -> FilePath -> T.Text -> RequestBuilder site [RequestPart] () +addFile :: T.Text -> FilePath -> T.Text -> RequestBuilder site () addFile name path mimetype = do contents <- liftIO $ BSL8.readFile path ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) } - where addPostData :: Maybe (RBDPostData [RequestPart]) - -> BSL8.ByteString - -> 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] + where addPostData x@(BinaryPostData _) _ = x + 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 p T.Text +nameFromLabel :: T.Text -> RequestBuilder site T.Text nameFromLabel label = do mres <- fmap rbdResponse ST.get res <- @@ -444,19 +436,19 @@ nameFromLabel label = do (<>) :: T.Text -> T.Text -> T.Text (<>) = T.append -byLabel :: T.Text -> T.Text -> RequestBuilder site [RequestPart] () +byLabel :: T.Text -> T.Text -> RequestBuilder site () byLabel label value = do name <- nameFromLabel label addPostParam name value -fileByLabel :: T.Text -> FilePath -> T.Text -> RequestBuilder site [RequestPart] () +fileByLabel :: T.Text -> FilePath -> T.Text -> RequestBuilder site () fileByLabel label path mime = do name <- nameFromLabel label addFile name path mime -- | 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 site [RequestPart] () +addNonce_ :: Query -> RequestBuilder site () addNonce_ scope = do matches <- htmlQuery' rbdResponse $ scope <> "input[name=_token][type=hidden][value]" case matches of @@ -465,7 +457,7 @@ addNonce_ scope = do _ -> failure $ "More than one nonce found in the page" -- | For responses that display a single form, just lookup the only nonce available. -addNonce :: RequestBuilder site [RequestPart] () +addNonce :: RequestBuilder site () addNonce = addNonce_ "" -- | Perform a POST request to url @@ -494,12 +486,12 @@ get url = request $ do setMethod "GET" setUrl url -setMethod :: H.Method -> RequestBuilder site p () +setMethod :: H.Method -> RequestBuilder site () setMethod m = ST.modify $ \rbd -> rbd { rbdMethod = m } setUrl :: (Yesod site, RedirectUrl site url) => url - -> RequestBuilder site p () + -> RequestBuilder site () setUrl url' = do site <- fmap rbdSite ST.get eurl <- runFakeHandler @@ -521,10 +513,10 @@ setUrl url' = do -- | Simple way to set HTTP request body setRequestBody :: (Yesod site) => BSL8.ByteString - -> RequestBuilder site BSL8.ByteString () -setRequestBody body = ST.modify $ \rbd -> rbd { rbdPostData = Just (BinaryPostData body) } + -> RequestBuilder site () +setRequestBody body = ST.modify $ \rbd -> rbd { rbdPostData = BinaryPostData body } -addRequestHeader :: H.Header -> RequestBuilder site p () +addRequestHeader :: H.Header -> RequestBuilder site () addRequestHeader header = ST.modify $ \rbd -> rbd { rbdHeaders = header : rbdHeaders rbd } @@ -532,13 +524,13 @@ addRequestHeader header = ST.modify $ \rbd -> rbd -- | General interface to performing requests, allowing you to add extra -- headers as well as letting you specify the request method. request :: Yesod site - => RequestBuilder site p () + => RequestBuilder site () -> YesodExample site () request reqBuilder = do YesodExampleData app site oldCookies mRes <- ST.get RequestBuilderData {..} <- liftIO $ ST.execStateT reqBuilder RequestBuilderData - { rbdPostData = Nothing + { rbdPostData = MultipleItemsPostData [] , rbdResponse = mRes , rbdMethod = "GET" , rbdSite = site @@ -554,12 +546,11 @@ request reqBuilder = do cookiesForPath = M.filter (checkCookiePath path) cookies let maker = case rbdPostData of - Just (MultipleItemsPostData x) -> + MultipleItemsPostData x -> if DL.any isFile x then makeMultipart else makeSinglepart - Just (BinaryPostData _) -> makeSinglepart - Nothing -> 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 @@ -581,19 +572,11 @@ request reqBuilder = do boundary :: String boundary = "*******noneedtomakethisrandom" 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 = SRequest simpleRequest' (simpleRequestBody' rbdPostData) - where simpleRequestBody' :: Maybe (RBDPostData [RequestPart]) -> BSL8.ByteString - simpleRequestBody' (Just (MultipleItemsPostData x)) = + where simpleRequestBody' (MultipleItemsPostData x) = BSL8.fromChunks [multiPartBody x] - simpleRequestBody' Nothing = "" + simpleRequestBody' (BinaryPostData _) = "" simpleRequest' = mkRequest [ ("Cookie", cookieValue) , ("Content-Type", contentTypeValue)] @@ -617,7 +600,7 @@ request reqBuilder = do -- For building the regular non-multipart requests makeSinglepart :: M.Map a0 Cookie.SetCookie - -> Maybe (RBDPostData p) + -> RBDPostData -> H.Method -> [H.Header] -> T.Text @@ -630,11 +613,10 @@ request reqBuilder = do [ ("Cookie", cookieValue) , ("Content-Type", "application/x-www-form-urlencoded")] method extraHeaders urlPath urlQuery) - simpleRequestBody' (Just (MultipleItemsPostData x)) = + simpleRequestBody' (MultipleItemsPostData x) = BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" $ map singlepartPart x - simpleRequestBody' (Just (BinaryPostData x)) = x - simpleRequestBody' Nothing = "" + simpleRequestBody' (BinaryPostData x) = x cookieValue = Builder.toByteString $ Cookie.renderCookies cookiePairs cookiePairs = [ (Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies ] From 59eb67e087f52b07175ede0fafd199969d29f665 Mon Sep 17 00:00:00 2001 From: Konstantine Rybnikov Date: Fri, 9 Aug 2013 23:13:56 +0300 Subject: [PATCH 8/9] Add error-reporting when trying to add file or post-param after binary content is set. --- yesod-test/Yesod/Test.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 74bdcc02..591e660d 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -49,6 +49,7 @@ module Yesod.Test , addPostParam , addGetParam , addFile + , setRequestBody , RequestBuilder , setUrl @@ -375,7 +376,7 @@ printMatches query = do addPostParam :: T.Text -> T.Text -> RequestBuilder site () addPostParam name value = ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) } - where addPostData x@(BinaryPostData _) = x + where addPostData (BinaryPostData _) = error "Trying to add post param to binary content." addPostData (MultipleItemsPostData posts) = MultipleItemsPostData $ ReqKvPart name value : posts @@ -392,7 +393,7 @@ addFile :: T.Text -> FilePath -> T.Text -> RequestBuilder site () addFile name path mimetype = do contents <- liftIO $ BSL8.readFile path ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) } - where addPostData x@(BinaryPostData _) _ = x + where addPostData (BinaryPostData _) _ = error "Trying to add file after setting binary content." addPostData (MultipleItemsPostData posts) contents = MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts @@ -576,7 +577,7 @@ request reqBuilder = do SRequest simpleRequest' (simpleRequestBody' rbdPostData) where simpleRequestBody' (MultipleItemsPostData x) = BSL8.fromChunks [multiPartBody x] - simpleRequestBody' (BinaryPostData _) = "" + -- simpleRequestBody' (BinaryPostData _) = "" simpleRequest' = mkRequest [ ("Cookie", cookieValue) , ("Content-Type", contentTypeValue)] From 928be6991e1d0c58d137cc8d61485bb034afff29 Mon Sep 17 00:00:00 2001 From: Konstantine Rybnikov Date: Sun, 11 Aug 2013 09:53:41 +0300 Subject: [PATCH 9/9] Refactor a bit to make pattern matching happy and makeMultipart only work on multipart data. --- yesod-test/Yesod/Test.hs | 32 +++++++++++++++++++++++--------- 1 file changed, 23 insertions(+), 9 deletions(-) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 591e660d..5e4884a2 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -546,13 +546,21 @@ request reqBuilder = do let cookies = M.filter (checkCookieTime currentUtc) oldCookies cookiesForPath = M.filter (checkCookiePath path) cookies - let maker = case rbdPostData of + let req = 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 + 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 @@ -573,11 +581,17 @@ request reqBuilder = do boundary :: String boundary = "*******noneedtomakethisrandom" separator = BS8.concat ["--", BS8.pack boundary, "\r\n"] - makeMultipart cookies rbdPostData method extraHeaders urlPath urlQuery = - SRequest simpleRequest' (simpleRequestBody' rbdPostData) - where simpleRequestBody' (MultipleItemsPostData x) = + makeMultipart :: M.Map a0 Cookie.SetCookie + -> [RequestPart] + -> H.Method + -> [H.Header] + -> T.Text + -> H.Query + -> SRequest + makeMultipart cookies parts method extraHeaders urlPath urlQuery = + SRequest simpleRequest' (simpleRequestBody' parts) + where simpleRequestBody' x = BSL8.fromChunks [multiPartBody x] - -- simpleRequestBody' (BinaryPostData _) = "" simpleRequest' = mkRequest [ ("Cookie", cookieValue) , ("Content-Type", contentTypeValue)]