diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,5 +1,17 @@
# ChangeLog for yesod-test
+## 1.7.0.1
+
+* When `bodyContains` or `bodyNotContains` fail and the content is UTF-8, a partial body is printed to aid debugging. This matches the behavior of `statusIs`. [#1900](https://github.com/yesodweb/yesod/pull/1900)
+
+## 1.7.0
+
+* Make post params be added in addition order like normal forms. [#1867](https://github.com/yesodweb/yesod/pull/1867)
+
+## 1.6.23.1
+
+* Set `base >= 4.11` for less CPP and imports [#1876](https://github.com/yesodweb/yesod/pull/1876)
+
## 1.6.23
* Add `MonadFail` to `SIO` so tests can fail on pattern match failure. [#1874](https://github.com/yesodweb/yesod/pull/1874)
diff --git a/Yesod/Test.hs b/Yesod/Test.hs
--- a/Yesod/Test.hs
+++ b/Yesod/Test.hs
@@ -1,13 +1,13 @@
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
{-|
Yesod.Test is a pragmatic framework for testing web applications built
@@ -266,18 +266,8 @@
import qualified Web.Cookie as Cookie
import qualified Blaze.ByteString.Builder as Builder
import Data.Time.Clock (getCurrentTime)
-import Control.Applicative ((<$>))
import Text.Show.Pretty (ppShow)
-import Data.Monoid (mempty)
-#if MIN_VERSION_base(4,9,0)
import GHC.Stack (HasCallStack)
-#elif MIN_VERSION_base(4,8,1)
-import GHC.Stack (CallStack)
-type HasCallStack = (?callStack :: CallStack)
-#else
-import GHC.Exts (Constraint)
-type HasCallStack = (() :: Constraint)
-#endif
import Data.ByteArray.Encoding (convertToBase, Base(..))
import Network.HTTP.Types.Header (hContentType)
import Data.Aeson (eitherDecode')
@@ -285,6 +275,7 @@
import Yesod.Test.Internal (getBodyTextPreview, contentTypeHeaderIsUtf8)
import Yesod.Test.Internal.SIO
+import qualified Data.Maybe as Maybe
import System.Directory (getTemporaryDirectory)
import System.Info (os)
@@ -683,10 +674,19 @@
-- > get HomeR
-- > bodyContains "Foo
"
bodyContains :: HasCallStack => String -> YesodExample site ()
-bodyContains text = withResponse $ \ res ->
- liftIO $ HUnit.assertBool ("Expected body to contain " ++ text) $
- (simpleBody res) `contains` text
+bodyContains text = withResponse $ \(SResponse status headers body) -> do
+ let mContentType = lookup hContentType headers
+ isUTF8ContentType = maybe False contentTypeHeaderIsUtf8 mContentType
+ liftIO $ flip HUnit.assertBool (body `contains` text) $ concat
+ [ "Expected body to contain `"
+ , text
+ , "`"
+ , if isUTF8ContentType
+ then ". For debugging, the body was: " <> (T.unpack $ getBodyTextPreview body)
+ else ""
+ ]
+
-- | Assert the last response doesn't have the given text. The check is performed using the response
-- body in full text form.
--
@@ -697,10 +697,19 @@
--
-- @since 1.5.3
bodyNotContains :: HasCallStack => String -> YesodExample site ()
-bodyNotContains text = withResponse $ \ res ->
- liftIO $ HUnit.assertBool ("Expected body not to contain " ++ text) $
- not $ contains (simpleBody res) text
+bodyNotContains text = withResponse $ \(SResponse status headers body) -> do
+ let mContentType = lookup hContentType headers
+ isUTF8ContentType = maybe False contentTypeHeaderIsUtf8 mContentType
+ liftIO $ flip HUnit.assertBool (not $ body `contains` text) $ concat
+ [ "Expected body to not contain `"
+ , text
+ , "`"
+ , if isUTF8ContentType
+ then ". For debugging, the body was: " <> (T.unpack $ getBodyTextPreview body)
+ else ""
+ ]
+
contains :: BSL8.ByteString -> String -> Bool
contains a b = DL.isInfixOf b (TL.unpack $ decodeUtf8 a)
@@ -721,7 +730,7 @@
matches <- htmlQuery query
case matches of
[] -> failure $ "Nothing matched css query: " <> query
- _ -> liftIO $ HUnit.assertBool ("Not all "++T.unpack query++" contain "++search ++ " matches: " ++ show matches) $
+ _ -> liftIO $ HUnit.assertBool ("Not all " ++ T.unpack query ++ " contain " ++ search ++ " matches: " ++ show matches) $
DL.all (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches)
-- | puts the search trough the same escaping as the matches are.
@@ -744,7 +753,7 @@
matches <- htmlQuery query
case matches of
[] -> failure $ "Nothing matched css query: " <> query
- _ -> liftIO $ HUnit.assertBool ("None of "++T.unpack query++" contain "++search ++ " matches: " ++ show matches) $
+ _ -> liftIO $ HUnit.assertBool ("None of " ++ T.unpack query ++ " contain " ++ search ++ " matches: " ++ show matches) $
DL.any (DL.isInfixOf (escape search)) (map (TL.unpack . decodeUtf8) matches)
-- | Queries the HTML using a CSS selector, and fails if any matched
@@ -778,7 +787,7 @@
htmlCount query count = do
matches <- fmap DL.length $ htmlQuery query
liftIO $ flip HUnit.assertBool (matches == count)
- ("Expected "++(show count)++" elements to match "++T.unpack query++", found "++(show matches))
+ ("Expected " ++ (show count) ++ " elements to match " ++ T.unpack query ++ ", found " ++ (show matches))
-- | Parses the response body from JSON into a Haskell value, throwing an error if parsing fails.
--
@@ -1254,10 +1263,15 @@
-- > addToken_ "#formID"
addToken_ :: HasCallStack => Query -> RequestBuilder site ()
addToken_ scope = do
- matches <- htmlQuery' rbdResponse ["Tried to get CSRF token with addToken'"] $ scope <> " input[name=_token][type=hidden][value]"
+ matches <-
+ htmlQuery' rbdResponse ["Tried to get CSRF token with addToken'"] $
+ scope <> " input[name=_token][type=hidden][value]"
case matches of
+ [element] ->
+ case attribute "value" $ parseHTML element of
+ [] -> failure "Expected at least one value in 'value' attribute"
+ valAttr : _ -> addPostParam "_token" valAttr
[] -> failure $ "No CSRF token found in the current page"
- element:[] -> addPostParam "_token" $ head $ attribute "value" $ parseHTML element
_ -> failure $ "More than one CSRF token found in the page"
-- | For responses that display a single form, just lookup the only CSRF token available.
@@ -1322,7 +1336,7 @@
getRequestCookies :: HasCallStack => RequestBuilder site Cookies
getRequestCookies = do
requestBuilderData <- getSIO
- headers <- case simpleHeaders Control.Applicative.<$> rbdResponse requestBuilderData of
+ headers <- case simpleHeaders <$> rbdResponse requestBuilderData of
Just h -> return h
Nothing -> failure "getRequestCookies: No request has been made yet; the cookies can't be looked up."
@@ -1424,10 +1438,10 @@
Just h -> case parseRoute $ decodePath h of
Nothing -> return $ Left "getLocation called, but couldn’t parse it into a route"
Just l -> return $ Right l
- where decodePath b = let (x, y) = BS8.break (=='?') b
+ where decodePath b = let (x, y) = BS8.break (== '?') b
in (H.decodePathSegments x, unJust <$> H.parseQueryText y)
unJust (a, Just b) = (a, b)
- unJust (a, Nothing) = (a, Data.Monoid.mempty)
+ unJust (a, Nothing) = (a, mempty)
-- | Sets the HTTP method used by the request.
--
@@ -1466,7 +1480,7 @@
let (urlPath, urlQuery) = T.break (== '?') url
modifySIO $ \rbd -> rbd
{ rbdPath =
- case DL.filter (/="") $ H.decodePathSegments $ TE.encodeUtf8 urlPath of
+ case DL.filter (/= "") $ H.decodePathSegments $ TE.encodeUtf8 urlPath of
("http:":_:rest) -> rest
("https:":_:rest) -> rest
x -> x
@@ -1652,23 +1666,22 @@
SRequest simpleRequest' (simpleRequestBody' rbdPostData)
where
simpleRequest' = (mkRequest
- ([ ("Cookie", cookieValue) ] ++ headersForPostData rbdPostData)
+ (headersForPostData rbdPostData [ ("Cookie", cookieValue) ])
method extraHeaders urlPath urlQuery)
simpleRequestBody' (MultipleItemsPostData x) =
BSL8.fromChunks $ return $ H.renderSimpleQuery False
- $ concatMap singlepartPart x
+ $ reverse $ Maybe.mapMaybe 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) = [(TE.encodeUtf8 k, TE.encodeUtf8 v)]
+ singlepartPart (ReqFilePart _ _ _ _) = Nothing
+ singlepartPart (ReqKvPart k v) = Just (TE.encodeUtf8 k, TE.encodeUtf8 v)
-- If the request appears to be submitting a form (has key-value pairs) give it the form-urlencoded Content-Type.
-- The previous behavior was to always use the form-urlencoded Content-Type https://github.com/yesodweb/yesod/issues/1063
- headersForPostData (MultipleItemsPostData []) = []
- headersForPostData (MultipleItemsPostData _ ) = [("Content-Type", "application/x-www-form-urlencoded")]
- headersForPostData (BinaryPostData _ ) = []
+ headersForPostData (MultipleItemsPostData (_:_)) = (("Content-Type", "application/x-www-form-urlencoded"):)
+ headersForPostData _ = id
-- General request making
@@ -1684,7 +1697,7 @@
parseSetCookies :: [H.Header] -> [Cookie.SetCookie]
-parseSetCookies headers = map (Cookie.parseSetCookie . snd) $ DL.filter (("Set-Cookie"==) . fst) $ headers
+parseSetCookies headers = map (Cookie.parseSetCookie . snd) $ DL.filter (("Set-Cookie" ==) . fst) $ headers
-- Yes, just a shortcut
failure :: (HasCallStack, MonadIO a) => T.Text -> a b
diff --git a/Yesod/Test/CssQuery.hs b/Yesod/Test/CssQuery.hs
--- a/Yesod/Test/CssQuery.hs
+++ b/Yesod/Test/CssQuery.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+
-- | Parsing CSS selectors into queries.
module Yesod.Test.CssQuery
( SelectorGroup (..)
@@ -9,7 +10,7 @@
import Prelude hiding (takeWhile)
import Data.Text (Text)
import Data.Attoparsec.Text
-import Control.Applicative
+import Control.Applicative (many, (<|>))
import Data.Char
import qualified Data.Text as T
diff --git a/Yesod/Test/Internal.hs b/Yesod/Test/Internal.hs
--- a/Yesod/Test/Internal.hs
+++ b/Yesod/Test/Internal.hs
@@ -18,7 +18,6 @@
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as DTLE
import qualified Yesod.Core.Content as Content
-import Data.Semigroup (Semigroup(..))
-- | Helper function to get the first 1024 characters of the body, assuming it is UTF-8.
-- This function is used to preview the body in case of an assertion failure.
diff --git a/Yesod/Test/Internal/SIO.hs b/Yesod/Test/Internal/SIO.hs
--- a/Yesod/Test/Internal/SIO.hs
+++ b/Yesod/Test/Internal/SIO.hs
@@ -1,14 +1,8 @@
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
-- | The 'SIO' type is used by "Yesod.Test" to provide exception-safe
-- environment between requests and assertions.
@@ -24,7 +18,9 @@
import qualified Control.Monad.State.Class as MS
import Yesod.Core
import Data.IORef
+#if MIN_VERSION_base(4,13,0)
import GHC.Stack (HasCallStack)
+#endif
-- | State + IO
--
@@ -32,10 +28,12 @@
newtype SIO s a = SIO (ReaderT (IORef s) IO a)
deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO)
+#if MIN_VERSION_base(4,13,0)
-- | @since 1.6.23
instance MonadFail (SIO s) where
fail :: HasCallStack => String -> SIO s a
fail = error
+#endif
instance MS.MonadState s (SIO s)
where
diff --git a/Yesod/Test/TransversingCSS.hs b/Yesod/Test/TransversingCSS.hs
--- a/Yesod/Test/TransversingCSS.hs
+++ b/Yesod/Test/TransversingCSS.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE CPP #-}
+
{- |
This module uses HXT to transverse an HTML document using CSS selectors.
@@ -42,7 +42,6 @@
import Yesod.Test.CssQuery
import qualified Data.Text as T
-import qualified Control.Applicative
import Text.XML
import Text.XML.Cursor
import qualified Data.ByteString.Lazy as L
@@ -60,7 +59,7 @@
-- * Right: List of matching Html fragments.
findBySelector :: HtmlLBS -> Query -> Either String [String]
findBySelector html query =
- map (renderHtml . toHtml . node) Control.Applicative.<$> findCursorsBySelector html query
+ map (renderHtml . toHtml . node) <$> findCursorsBySelector html query
-- | Perform a css 'Query' on 'Html'. Returns Either
--
@@ -69,8 +68,7 @@
-- * Right: List of matching Cursors
findCursorsBySelector :: HtmlLBS -> Query -> Either String [Cursor]
findCursorsBySelector html query =
- runQuery (fromDocument $ HD.parseLBS html)
- Control.Applicative.<$> parseQuery query
+ runQuery (fromDocument $ HD.parseLBS html) <$> parseQuery query
-- | Perform a css 'Query' on 'Html'. Returns Either
--
@@ -81,7 +79,7 @@
-- @since 1.5.7
findAttributeBySelector :: HtmlLBS -> Query -> T.Text -> Either String [[T.Text]]
findAttributeBySelector html query attr =
- map (laxAttribute attr) Control.Applicative.<$> findCursorsBySelector html query
+ map (laxAttribute attr) <$> findCursorsBySelector html query
-- Run a compiled query on Html, returning a list of matching Html fragments.
diff --git a/test/main.hs b/test/main.hs
--- a/test/main.hs
+++ b/test/main.hs
@@ -1,16 +1,15 @@
--- Ignore warnings about using deprecated byLabel/fileByLabel functions
-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
-
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
+-- Ignore warnings about using deprecated byLabel/fileByLabel functions
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
+
module Main
( main
-- avoid warnings
@@ -30,8 +29,6 @@
import Text.XML
import Data.Text (Text, pack)
import Data.Char (toUpper)
-import Data.Monoid ((<>))
-import Control.Applicative
import Network.Wai (pathInfo, rawQueryString, requestHeaders)
import Network.Wai.Test (SResponse(simpleBody))
import Numeric (showHex)
@@ -49,6 +46,7 @@
import qualified Data.Text as T
import qualified Data.ByteString.Char8 as B8
import Yesod.Test.Internal (contentTypeHeaderIsUtf8)
+import Data.Foldable (traverse_)
parseQuery_ :: Text -> [[SelectorGroup]]
parseQuery_ = either error id . parseQuery
@@ -66,6 +64,7 @@
/resources ResourcesR POST
/resources/#Text ResourceR GET
/get-integer IntegerR GET
+/multi-param MultiParamR GET POST
|]
main :: IO ()
@@ -329,7 +328,7 @@
checkByLabel "Red"
checkByLabel "Gray"
addToken
- bodyContains "colorCheckBoxes = [Gray,Red]"
+ bodyContains "colorCheckBoxes = [Red,Gray]"
yit "can select from select list" $ do
get ("/labels-select" :: Text)
request $ do
@@ -575,6 +574,19 @@
statusIs 200
(requireJSONResponse :: YesodExample site [Text]) `liftedShouldThrow` (\(e :: SomeException) -> True)
+ describe "'addPostParam' order is correct" $ yesodSpec defaultRoutedApp $ do
+ yit "should add the parameters in the order they were added" $ do
+ let params = [("foo", "foobarbaz"), ("bar", "barbaz"), ("baz", "bazqux")]
+ get MultiParamR
+ statusIs 200
+ request $ do
+ setMethod "POST"
+ setUrl MultiParamR
+ addToken
+ traverse_ (uncurry addPostParam) params
+ statusIs 200
+ bodyContains $ T.unpack $ T.intercalate " -- " $ map (\(k, v) -> k <> ": " <> v) params
+
instance RenderMessage LiteApp FormMessage where
renderMessage _ _ = defaultFormMessage
@@ -603,7 +615,7 @@
((mfoo, widget), _) <- runFormPost
$ renderDivs
$ (,)
- Control.Applicative.<$> areqMsg textField "Some Label" ("Missing Label" :: SomeMessage LiteApp) Nothing
+ <$> areqMsg textField "Some Label" ("Missing Label" :: SomeMessage LiteApp) Nothing
<*> areq fileField "Some File" Nothing
case mfoo of
FormSuccess (foo, _) -> return $ toHtml foo
@@ -614,7 +626,7 @@
(field2F, field2V) <- mreq fileField "Some MFile" Nothing
return
- ( (,) Control.Applicative.<$> field1F <*> field2F
+ ( (,) <$> field1F <*> field2F
, [field1V, field2V]
)
case mfoo of
@@ -625,7 +637,7 @@
field1F <- wreqMsg textField "Some WLabel" ("Missing WLabel" :: SomeMessage LiteApp) Nothing
field2F <- wreq fileField "Some WFile" Nothing
- return $ (,) Control.Applicative.<$> field1F <*> field2F
+ return $ (,) <$> field1F <*> field2F
case mfoo of
FormSuccess (foo, _) -> return $ toHtml foo
_ -> defaultLayout widget
@@ -776,6 +788,22 @@
app <- getYesod
pure $ T.pack $ show (routedAppInteger app)
+getMultiParamR :: Handler Html
+getMultiParamR = do
+ req <- getRequest
+ defaultLayout [whamlet|
+