yesod-test 1.6.23 → 1.7.0.1
raw patch · 8 files changed
+119/−70 lines, 8 filesdep ~basedep ~timedep ~xml-conduit
Dependency ranges changed: base, time, xml-conduit
Files
- ChangeLog.md +12/−0
- Yesod/Test.hs +51/−38
- Yesod/Test/CssQuery.hs +2/−1
- Yesod/Test/Internal.hs +0/−1
- Yesod/Test/Internal/SIO.hs +5/−7
- Yesod/Test/TransversingCSS.hs +4/−6
- test/main.hs +41/−13
- yesod-test.cabal +4/−4
ChangeLog.md view
@@ -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)
Yesod/Test.hs view
@@ -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 "<h1>Foo</h1>" 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
Yesod/Test/CssQuery.hs view
@@ -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
Yesod/Test/Internal.hs view
@@ -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.
Yesod/Test/Internal/SIO.hs view
@@ -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
Yesod/Test/TransversingCSS.hs view
@@ -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.
test/main.hs view
@@ -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|+ <form method=post action=@{MultiParamR}>+ <input type=hidden name=#{defaultCsrfParamName} value=#{fromMaybe mempty (reqToken req)}>+ |]++postMultiParamR :: Handler Html+postMultiParamR = do+ (reqParts,_) <- runRequestBody+ pure [shamlet|+ $forall (name, part) <- reqParts+ $if name /= "_token"+ #{name}: #{part} -- #+ |] -- infix Copied from HSpec's version infix 1 `liftedShouldThrow`
yesod-test.cabal view
@@ -1,5 +1,5 @@ name: yesod-test-version: 1.6.23+version: 1.7.0.1 license: MIT license-file: LICENSE author: Nubis <nubis@woobiz.com.ar>@@ -24,7 +24,7 @@ build-depends: aeson >= 1.0 && < 2.3 , attoparsec >= 0.10 && < 0.15- , base >= 4.10 && < 5+ , base >= 4.11 && < 5 , blaze-builder >= 0.3.1 && < 0.5 , blaze-html >= 0.5 && < 0.10 , blaze-markup >= 0.6 && < 0.9@@ -44,11 +44,11 @@ , pretty-show >= 1.6 && < 1.11 , process >= 1.6 && < 1.7 , text >= 1.2 && < 2.2- , time >= 1.5 && < 1.13+ , time >= 1.5 && < 1.15 , transformers >= 0.2.2 && < 0.7 , wai >= 3.0 && < 3.3 , wai-extra >= 3.0 && < 3.2- , xml-conduit >= 1.0 && < 1.10+ , xml-conduit >= 1.0 && < 1.11 , xml-types >= 0.3 && < 0.4 , yesod-core >= 1.6.17 && < 1.7