yesod-test 1.6.23 → 1.7.0.3
raw patch · 9 files changed
Files
- ChangeLog.md +23/−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/PRGSpec.hs +248/−0
- test/main.hs +44/−13
- yesod-test.cabal +7/−5
ChangeLog.md view
@@ -1,5 +1,28 @@ # ChangeLog for yesod-test +## 1.7.0.3++* Adopt the `runFormPRG` integration tests from yesod-form's test+ suite, whose yesod-test dependency created a package-level cycle+ that broke the Stackage build plan. No library changes.+ [#1928](https://github.com/yesodweb/yesod/issues/1928)++## 1.7.0.2++* Support `yesod-core` 1.7++## 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/PRGSpec.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | Integration tests for yesod-form's 'runFormPRG'.+--+-- These live in yesod-test rather than yesod-form: a yesod-test+-- dependency in yesod-form's test suite creates a package-level+-- dependency cycle that Stackage's build planner rejects, see+-- <https://github.com/yesodweb/yesod/issues/1928>.+module PRGSpec (spec) where++import qualified Data.ByteString.Lazy as BL+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Network.Wai.Test (simpleBody)+import Test.Hspec (Spec)+import qualified Web.ClientSession as CS+import Yesod.Core+import Yesod.Form+import Yesod.Test++data App = App++mkYesod "App" [parseRoutes|+/form FormR GET POST+/two TwoR GET POST+/corrupt CorruptR GET+/stale StaleR GET+|]++instance Yesod App where+ -- A random key per test run, so no client_session_key.aes file is+ -- written into the repository.+ makeSessionBackend _ = do+ key <- snd `fmap` CS.randomKey+ (getCachedDate, _closeDateCacher) <- clientSessionDateCacher (120 * 60)+ return $ Just $ clientSessionBackend key getCachedDate++instance RenderMessage App FormMessage where+ renderMessage _ _ = defaultFormMessage++fs :: Text -> FieldSettings App+fs name = FieldSettings (SomeMessage name) Nothing Nothing (Just name) []++personForm :: Html -> MForm Handler (FormResult (Text, Int), Widget)+personForm csrf = do+ (nameRes, nameView) <- mreq textField (fs "name") Nothing+ (ageRes, ageView) <- mreq ageField (fs "age") Nothing+ let widget = [whamlet|+ #{csrf}+ ^{fvInput nameView}+ $maybe err <- fvErrors nameView+ <p .error>#{err}+ ^{fvInput ageView}+ $maybe err <- fvErrors ageView+ <p .error>#{err}+ |]+ return ((,) <$> nameRes <*> ageRes, widget)+ where+ ageField = checkBool (>= (18 :: Int)) ("Too young" :: Text) intField++-- | A one-field form for the two-forms-on-a-page tests; submitting+-- non-numeric input fails with the input preserved.+numForm :: Text -> Html -> MForm Handler (FormResult Int, Widget)+numForm name csrf = do+ (res, view) <- mreq intField (fs name) Nothing+ let widget = [whamlet|+ #{csrf}+ ^{fvInput view}+ $maybe err <- fvErrors view+ <p .error>#{name}: #{err}+ |]+ return (res, widget)++getFormR :: Handler Html+getFormR = do+ mmsg <- getMessage+ ((_res, widget), enctype) <- runFormPRG personForm+ defaultLayout [whamlet|+ $maybe msg <- mmsg+ <p .message>#{msg}+ <form method=post action=@{FormR} enctype=#{enctype}>+ ^{widget}+ <button>go+ |]++postFormR :: Handler Html+postFormR = do+ ((res, _widget), _enctype) <- runFormPRG personForm+ case res of+ FormSuccess _ -> setMessage "registered" >> redirect FormR+ _ -> redirect FormR++getTwoR :: Handler Html+getTwoR = do+ mmsg <- getMessage+ ((_, fooW), fooE) <- runFormPRG $ identifyForm "foo" $ numForm "foonum"+ ((_, barW), barE) <- runFormPRG $ identifyForm "bar" $ numForm "barnum"+ defaultLayout [whamlet|+ $maybe msg <- mmsg+ <p .message>#{msg}+ <form method=post action=@{TwoR} enctype=#{fooE}>+ ^{fooW}+ <button>foo+ <form method=post action=@{TwoR} enctype=#{barE}>+ ^{barW}+ <button>bar+ |]++postTwoR :: Handler Html+postTwoR = do+ ((fooRes, _), _) <- runFormPRG $ identifyForm "foo" $ numForm "foonum"+ ((barRes, _), _) <- runFormPRG $ identifyForm "bar" $ numForm "barnum"+ case (fooRes, barRes) of+ (FormSuccess _, _) -> setMessage "foo ok" >> redirect TwoR+ (_, FormSuccess _) -> setMessage "bar ok" >> redirect TwoR+ _ -> redirect TwoR++-- | Plant garbage bytes where the stash for \/form lives.+getCorruptR :: Handler ()+getCorruptR = setSessionBS "_PRG:/form" "definitely not json"++-- | Plant a decodable stash for \/form, as if a submission with+-- name=stale had failed earlier.+getStaleR :: Handler ()+getStaleR = setSessionBS "_PRG:/form" "{\"name\":[\"stale\"],\"age\":[\"12\"]}"++-- | The CSRF token stays constant for a session, so grab it once from the+-- current response body and reuse it across requests. This avoids+-- 'addToken', which can only read the token from the /previous/ response.+extractToken :: YesodExample App Text+extractToken = do+ mres <- getResponse+ let body = maybe "" (TE.decodeUtf8 . BL.toStrict . simpleBody) mres+ (_, rest) = T.breakOn "name=\"_token\" value=\"" body+ case T.splitOn "\"" (T.drop (T.length "name=\"_token\" value=\"") rest) of+ (token:_) | not (T.null token) -> return token+ _ -> error "no _token in response body"++postParams :: Route App -> Text -> [(Text, Text)] -> YesodExample App ()+postParams route token params = request $ do+ setMethod "POST"+ setUrl route+ addPostParam "_token" token+ mapM_ (uncurry addPostParam) params++spec :: Spec+spec = yesodSpec App $+ ydescribe "runFormPRG" $ do+ yit "renders a blank form when nothing is stashed" $ do+ get FormR+ statusIs 200+ bodyContains "name=\"name\""+ bodyNotContains "error"++ yit "replays invalid input and errors after the redirect, once" $ do+ get FormR+ token <- extractToken+ postParams FormR token [("name", "alice"), ("age", "12")]+ statusIs 303+ get FormR+ statusIs 200+ bodyContains "value=\"alice\""+ bodyContains "value=\"12\""+ bodyContains "Too young"+ get FormR+ statusIs 200+ bodyNotContains "alice"+ bodyNotContains "Too young"++ yit "does not stash on success" $ do+ get FormR+ token <- extractToken+ postParams FormR token [("name", "alice"), ("age", "30")]+ statusIs 303+ get FormR+ statusIs 200+ bodyContains "registered"+ bodyNotContains "value=\"alice\""++ yit "success clears a stale stash" $ do+ get FormR+ token <- extractToken+ get StaleR+ postParams FormR token [("name", "alice"), ("age", "30")]+ statusIs 303+ get FormR+ statusIs 200+ bodyContains "registered"+ bodyNotContains "stale"++ yit "still enforces CSRF on POST" $ do+ get FormR+ postParams FormR "wrong-token" [("name", "alice"), ("age", "30")]+ statusIs 303+ get FormR+ statusIs 200+ bodyNotContains "registered"+ bodyContains "value=\"alice\""++ yit "replays only the submitted one of two identified forms" $ do+ get TwoR+ token <- extractToken+ postParams TwoR token+ [("_formid", "identify-foo"), ("foonum", "foo-banana")]+ statusIs 303+ get TwoR+ statusIs 200+ bodyContains "value=\"foo-banana\""+ bodyContains "foonum: "+ bodyNotContains "barnum: "++ yit "replays the second form on the page too" $ do+ get TwoR+ token <- extractToken+ postParams TwoR token+ [("_formid", "identify-bar"), ("barnum", "bar-banana")]+ statusIs 303+ get TwoR+ statusIs 200+ bodyContains "value=\"bar-banana\""+ bodyContains "barnum: "+ bodyNotContains "foonum: "++ yit "treats an undecodable stash as absent" $ do+ get CorruptR+ statusIs 200+ get FormR+ statusIs 200+ bodyContains "name=\"name\""++ yit "keys the stash by path" $ do+ get FormR+ token <- extractToken+ postParams FormR token [("name", "alice"), ("age", "12")]+ statusIs 303+ get TwoR+ statusIs 200+ bodyNotContains "alice"+ get FormR+ statusIs 200+ bodyContains "value=\"alice\""
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,7 +46,10 @@ import qualified Data.Text as T import qualified Data.ByteString.Char8 as B8 import Yesod.Test.Internal (contentTypeHeaderIsUtf8)+import Data.Foldable (traverse_) +import qualified PRGSpec+ parseQuery_ :: Text -> [[SelectorGroup]] parseQuery_ = either error id . parseQuery @@ -66,10 +66,12 @@ /resources ResourcesR POST /resources/#Text ResourceR GET /get-integer IntegerR GET+/multi-param MultiParamR GET POST |] main :: IO () main = hspec $ do+ PRGSpec.spec describe "CSS selector parsing" $ do it "elements" $ parseQuery_ "strong" @?= [[DeepChildren [ByTagName "strong"]]] it "child elements" $ parseQuery_ "strong > i" @?= [[DeepChildren [ByTagName "strong"], DirectChildren [ByTagName "i"]]]@@ -329,7 +331,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 +577,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 +618,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 +629,7 @@ (field2F, field2V) <- mreq fileField "Some MFile" Nothing return- ( (,) Control.Applicative.<$> field1F <*> field2F+ ( (,) <$> field1F <*> field2F , [field1V, field2V] ) case mfoo of@@ -625,7 +640,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 +791,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.3 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,13 +44,13 @@ , 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+ , yesod-core >= 1.6.17 && < 1.8 exposed-modules: Yesod.Test@@ -66,9 +66,11 @@ type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: test+ other-modules: PRGSpec build-depends: base , bytestring+ , clientsession , containers , cookie , hspec