haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge pull request #1710 from yesodweb/pb/has-callstack

Browse Source 
Fix up missing HasCallStack
This commit is contained in:
Michael Snoyman 2020-12-02 08:37:52 +02:00 committed by GitHub
commit c6c2cd2252
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
3 changed files with 21 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
yesod-test/ChangeLog.md
View File

@ -1,5 +1,9 @@
# ChangeLog for yesod-test # ChangeLog for yesod-test
## 1.6.11
* Add missing `HasCallStack`s [#1710](https://github.com/yesodweb/yesod/pull/1710)
## 1.6.10 ## 1.6.10
* `statusIs` assertion failures now print a preview of the response body, if the response body is UTF-8 or ASCII. [#1680](https://github.com/yesodweb/yesod/pull/1680/files) * `statusIs` assertion failures now print a preview of the response body, if the response body is UTF-8 or ASCII. [#1680](https://github.com/yesodweb/yesod/pull/1680/files)

29
yesod-test/Yesod/Test.hs
View File

@ -500,7 +500,8 @@ testClearCookies = do
-- Performs a given action using the last response. Use this to create -- Performs a given action using the last response. Use this to create
-- response-level assertions -- response-level assertions
withResponse' :: (state -> Maybe SResponse) withResponse' :: HasCallStack
=> (state -> Maybe SResponse)
-> [T.Text] -> [T.Text]
-> (SResponse -> SIO state a) -> (SResponse -> SIO state a)
-> SIO state a -> SIO state a
@ -514,7 +515,7 @@ withResponse' getter errTrace f = maybe err f . getter =<< getSIO
-- | Performs a given action using the last response. Use this to create -- | Performs a given action using the last response. Use this to create
-- response-level assertions -- response-level assertions
withResponse :: (SResponse -> YesodExample site a) -> YesodExample site a withResponse :: HasCallStack => (SResponse -> YesodExample site a) -> YesodExample site a
withResponse = withResponse' yedResponse [] withResponse = withResponse' yedResponse []
-- | Use HXT to parse a value from an HTML tag. -- | Use HXT to parse a value from an HTML tag.
@ -523,7 +524,8 @@ parseHTML :: HtmlLBS -> Cursor
parseHTML html = fromDocument $ HD.parseLBS html parseHTML html = fromDocument $ HD.parseLBS html
-- | Query the last response using CSS selectors, returns a list of matched fragments -- | Query the last response using CSS selectors, returns a list of matched fragments
htmlQuery' :: (state -> Maybe SResponse) htmlQuery' :: HasCallStack
=> (state -> Maybe SResponse)
-> [T.Text] -> [T.Text]
-> Query -> Query
-> SIO state [HtmlLBS] -> SIO state [HtmlLBS]
@ -533,7 +535,7 @@ htmlQuery' getter errTrace query = withResponse' getter ("Tried to invoke htmlQu
Right matches -> return $ map (encodeUtf8 . TL.pack) matches Right matches -> return $ map (encodeUtf8 . TL.pack) matches
-- | Query the last response using CSS selectors, returns a list of matched fragments -- | Query the last response using CSS selectors, returns a list of matched fragments
htmlQuery :: Query -> YesodExample site [HtmlLBS] htmlQuery :: HasCallStack => Query -> YesodExample site [HtmlLBS]
htmlQuery = htmlQuery' yedResponse [] htmlQuery = htmlQuery' yedResponse []
-- | Asserts that the two given values are equal. -- | Asserts that the two given values are equal.
@ -803,7 +805,7 @@ printBody = withResponse $ \ SResponse { simpleBody = b } ->
-- > {-# LANGUAGE OverloadedStrings #-} -- > {-# LANGUAGE OverloadedStrings #-}
-- > get HomeR -- > get HomeR
-- > printMatches "h1" -- Prints all h1 tags -- > printMatches "h1" -- Prints all h1 tags
printMatches :: Query -> YesodExample site () printMatches :: HasCallStack => Query -> YesodExample site ()
printMatches query = do printMatches query = do
matches <- htmlQuery query matches <- htmlQuery query
liftIO $ hPutStrLn stderr $ show matches liftIO $ hPutStrLn stderr $ show matches
@ -863,7 +865,7 @@ addFile name path mimetype = do
-- | -- |
-- This looks up the name of a field based on the contents of the label pointing to it. -- This looks up the name of a field based on the contents of the label pointing to it.
genericNameFromLabel :: (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text genericNameFromLabel :: HasCallStack => (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
genericNameFromLabel match label = do genericNameFromLabel match label = do
mres <- fmap rbdResponse getSIO mres <- fmap rbdResponse getSIO
res <- res <-
@ -1135,7 +1137,7 @@ fileByLabelSuffix = fileByLabelWithMatch T.isSuffixOf
-- --
-- > request $ do -- > request $ do
-- > addToken_ "#formID" -- > addToken_ "#formID"
addToken_ :: Query -> RequestBuilder site () addToken_ :: HasCallStack => Query -> RequestBuilder site ()
addToken_ scope = do 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 case matches of
@ -1149,7 +1151,7 @@ addToken_ scope = do
-- --
-- > request $ do -- > request $ do
-- > addToken -- > addToken
addToken :: RequestBuilder site () addToken :: HasCallStack => RequestBuilder site ()
addToken = addToken_ "" addToken = addToken_ ""
-- | Calls 'addTokenFromCookieNamedToHeaderNamed' with the 'defaultCsrfCookieName' and 'defaultCsrfHeaderName'. -- | Calls 'addTokenFromCookieNamedToHeaderNamed' with the 'defaultCsrfCookieName' and 'defaultCsrfHeaderName'.
@ -1162,7 +1164,7 @@ addToken = addToken_ ""
-- > addTokenFromCookie -- > addTokenFromCookie
-- --
-- Since 1.4.3.2 -- Since 1.4.3.2
addTokenFromCookie :: RequestBuilder site () addTokenFromCookie :: HasCallStack => RequestBuilder site ()
addTokenFromCookie = addTokenFromCookieNamedToHeaderNamed defaultCsrfCookieName defaultCsrfHeaderName addTokenFromCookie = addTokenFromCookieNamedToHeaderNamed defaultCsrfCookieName defaultCsrfHeaderName
-- | Looks up the CSRF token stored in the cookie with the given name and adds it to the request headers. An error is thrown if the cookie can't be found. -- | Looks up the CSRF token stored in the cookie with the given name and adds it to the request headers. An error is thrown if the cookie can't be found.
@ -1178,7 +1180,8 @@ addTokenFromCookie = addTokenFromCookieNamedToHeaderNamed defaultCsrfCookieName
-- > addTokenFromCookieNamedToHeaderNamed "cookieName" (CI "headerName") -- > addTokenFromCookieNamedToHeaderNamed "cookieName" (CI "headerName")
-- --
-- Since 1.4.3.2 -- Since 1.4.3.2
addTokenFromCookieNamedToHeaderNamed :: ByteString -- ^ The name of the cookie addTokenFromCookieNamedToHeaderNamed :: HasCallStack
=> ByteString -- ^ The name of the cookie
-> CI ByteString -- ^ The name of the header -> CI ByteString -- ^ The name of the header
-> RequestBuilder site () -> RequestBuilder site ()
addTokenFromCookieNamedToHeaderNamed cookieName headerName = do addTokenFromCookieNamedToHeaderNamed cookieName headerName = do
@ -1201,7 +1204,7 @@ addTokenFromCookieNamedToHeaderNamed cookieName headerName = do
-- > liftIO $ putStrLn $ "Cookies are: " ++ show cookies -- > liftIO $ putStrLn $ "Cookies are: " ++ show cookies
-- --
-- Since 1.4.3.2 -- Since 1.4.3.2
getRequestCookies :: RequestBuilder site Cookies getRequestCookies :: HasCallStack => RequestBuilder site Cookies
getRequestCookies = do getRequestCookies = do
requestBuilderData <- getSIO requestBuilderData <- getSIO
headers <- case simpleHeaders Control.Applicative.<$> rbdResponse requestBuilderData of headers <- case simpleHeaders Control.Applicative.<$> rbdResponse requestBuilderData of
@ -1363,7 +1366,7 @@ setUrl url' = do
-- > clickOn "a#idofthelink" -- > clickOn "a#idofthelink"
-- --
-- @since 1.5.7 -- @since 1.5.7
clickOn :: Yesod site => Query -> YesodExample site () clickOn :: (HasCallStack, Yesod site) => Query -> YesodExample site ()
clickOn query = do clickOn query = do
withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res -> withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res ->
case findAttributeBySelector (simpleBody res) query "href" of case findAttributeBySelector (simpleBody res) query "href" of
@ -1567,7 +1570,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 -- Yes, just a shortcut
failure :: (MonadIO a) => T.Text -> a b failure :: (HasCallStack, MonadIO a) => T.Text -> a b
failure reason = (liftIO $ HUnit.assertFailure $ T.unpack reason) >> error "" failure reason = (liftIO $ HUnit.assertFailure $ T.unpack reason) >> error ""
type TestApp site = (site, Middleware) type TestApp site = (site, Middleware)

2
yesod-test/yesod-test.cabal
View File

@ -1,5 +1,5 @@
name: yesod-test name: yesod-test
version: 1.6.10 version: 1.6.11
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Nubis <nubis@woobiz.com.ar> author: Nubis <nubis@woobiz.com.ar>