diff --git a/Yesod/Test.hs b/Yesod/Test.hs --- a/Yesod/Test.hs +++ b/Yesod/Test.hs @@ -27,6 +27,7 @@ ( -- * Declaring and running your test suite yesodSpec , YesodSpec + , yesodSpecWithSiteGenerator , YesodExample , YesodSpecTree (..) , ydescribe @@ -41,12 +42,14 @@ -- , get , post + , postBody , request , addRequestHeader , setMethod , addPostParam , addGetParam , addFile + , setRequestBody , RequestBuilder , setUrl @@ -164,7 +167,7 @@ getResponse = fmap yedResponse ST.get data RequestBuilderData site = RequestBuilderData - { rbdPosts :: [RequestPart] + { rbdPostData :: RBDPostData , rbdResponse :: (Maybe SResponse) , rbdMethod :: H.Method , rbdSite :: site @@ -173,9 +176,12 @@ , 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 @@ -205,6 +211,28 @@ , yedResponse = Nothing } +-- | Same as yesodSpec, but instead of taking already built site it +-- takes an action which produces site for each test. +yesodSpecWithSiteGenerator :: YesodDispatch site + => IO site + -> YesodSpec site + -> Hspec.Spec +yesodSpecWithSiteGenerator getSiteAction yspecs = + Core.fromSpecList $ map (unYesod getSiteAction) $ execWriter yspecs + where + unYesod :: YesodDispatch t + => IO t -> YesodSpecTree t -> Core.SpecTree + unYesod getSiteAction' (YesodSpecGroup x y) = Core.SpecGroup x $ map (unYesod getSiteAction') y + unYesod getSiteAction' (YesodSpecItem x y) = Core.it x $ do + site <- getSiteAction' + app <- toWaiAppPlain site + ST.evalStateT y YesodExampleData + { yedApp = app + , yedSite = site + , yedCookies = M.empty + , yedResponse = Nothing + } + -- | Describe a single test that keeps cookies, and a reference to the last response. yit :: String -> YesodExample site () -> YesodSpec site yit label example = tell [YesodSpecItem label example] @@ -347,9 +375,10 @@ -- | 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 @@ -363,9 +392,10 @@ 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 @@ -436,9 +466,19 @@ => 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) => url @@ -471,6 +511,12 @@ , 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 @@ -485,7 +531,7 @@ YesodExampleData app site oldCookies mRes <- ST.get RequestBuilderData {..} <- liftIO $ ST.execStateT reqBuilder RequestBuilderData - { rbdPosts = [] + { rbdPostData = MultipleItemsPostData [] , rbdResponse = mRes , rbdMethod = "GET" , rbdSite = site @@ -500,11 +546,21 @@ 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 @@ -525,15 +581,28 @@ 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"] @@ -545,15 +614,29 @@ , 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 diff --git a/yesod-test.cabal b/yesod-test.cabal --- a/yesod-test.cabal +++ b/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 1.2.0 +version: 1.2.1 license: MIT license-file: LICENSE author: Nubis