From 24acd4e3b72240725b5ffd02f62636f6ab818c21 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Tue, 1 Dec 2020 11:49:29 -0500 Subject: [PATCH 1/4] Add missing HasCallStack Even though functions that use this one all have HasCallStack, the fact that this function itself doesn't means that all errors are reported as from this line anyway: Failures: ./Yesod/Test.hs:1571:28: 1) ... This should correct that. --- yesod-test/Yesod/Test.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 6c319234..3262b208 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -1567,7 +1567,7 @@ parseSetCookies :: [H.Header] -> [Cookie.SetCookie] parseSetCookies headers = map (Cookie.parseSetCookie . snd) $ DL.filter (("Set-Cookie"==) . fst) $ headers -- 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 "" type TestApp site = (site, Middleware) From 07d76095a77e71e0622e74a86c4f7ee6af81d811 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Tue, 1 Dec 2020 11:56:37 -0500 Subject: [PATCH 2/4] Add missing HasCallStack As far as I could tell, all of these functions call failure, or call things that call failure. --- yesod-test/Yesod/Test.hs | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 3262b208..026eb61b 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -500,7 +500,8 @@ testClearCookies = do -- Performs a given action using the last response. Use this to create -- response-level assertions -withResponse' :: (state -> Maybe SResponse) +withResponse' :: HasCallStack + => (state -> Maybe SResponse) -> [T.Text] -> (SResponse -> 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 -- response-level assertions -withResponse :: (SResponse -> YesodExample site a) -> YesodExample site a +withResponse :: HasCallStack => (SResponse -> YesodExample site a) -> YesodExample site a withResponse = withResponse' yedResponse [] -- | Use HXT to parse a value from an HTML tag. @@ -523,7 +524,8 @@ parseHTML :: HtmlLBS -> Cursor parseHTML html = fromDocument $ HD.parseLBS html -- | Query the last response using CSS selectors, returns a list of matched fragments -htmlQuery' :: (state -> Maybe SResponse) +htmlQuery' :: HasCallStack + => (state -> Maybe SResponse) -> [T.Text] -> Query -> 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 -- | 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 [] -- | Asserts that the two given values are equal. @@ -803,7 +805,7 @@ printBody = withResponse $ \ SResponse { simpleBody = b } -> -- > {-# LANGUAGE OverloadedStrings #-} -- > get HomeR -- > printMatches "h1" -- Prints all h1 tags -printMatches :: Query -> YesodExample site () +printMatches :: HasCallStack => Query -> YesodExample site () printMatches query = do matches <- htmlQuery query 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. -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 mres <- fmap rbdResponse getSIO res <- @@ -1135,7 +1137,7 @@ fileByLabelSuffix = fileByLabelWithMatch T.isSuffixOf -- -- > request $ do -- > addToken_ "#formID" -addToken_ :: Query -> RequestBuilder site () +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]" case matches of @@ -1149,7 +1151,7 @@ addToken_ scope = do -- -- > request $ do -- > addToken -addToken :: RequestBuilder site () +addToken :: HasCallStack => RequestBuilder site () addToken = addToken_ "" -- | Calls 'addTokenFromCookieNamedToHeaderNamed' with the 'defaultCsrfCookieName' and 'defaultCsrfHeaderName'. @@ -1162,7 +1164,7 @@ addToken = addToken_ "" -- > addTokenFromCookie -- -- Since 1.4.3.2 -addTokenFromCookie :: RequestBuilder site () +addTokenFromCookie :: HasCallStack => RequestBuilder site () 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. @@ -1178,7 +1180,8 @@ addTokenFromCookie = addTokenFromCookieNamedToHeaderNamed defaultCsrfCookieName -- > addTokenFromCookieNamedToHeaderNamed "cookieName" (CI "headerName") -- -- 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 -> RequestBuilder site () addTokenFromCookieNamedToHeaderNamed cookieName headerName = do @@ -1201,7 +1204,7 @@ addTokenFromCookieNamedToHeaderNamed cookieName headerName = do -- > liftIO $ putStrLn $ "Cookies are: " ++ show cookies -- -- Since 1.4.3.2 -getRequestCookies :: RequestBuilder site Cookies +getRequestCookies :: HasCallStack => RequestBuilder site Cookies getRequestCookies = do requestBuilderData <- getSIO headers <- case simpleHeaders Control.Applicative.<$> rbdResponse requestBuilderData of @@ -1363,7 +1366,7 @@ setUrl url' = do -- > clickOn "a#idofthelink" -- -- @since 1.5.7 -clickOn :: Yesod site => Query -> YesodExample site () +clickOn :: (HasCallStack, Yesod site) => Query -> YesodExample site () clickOn query = do withResponse' yedResponse ["Tried to invoke clickOn in order to read HTML of a previous response."] $ \ res -> case findAttributeBySelector (simpleBody res) query "href" of From cb0600404418ebf444be60e72b761e002a825052 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Tue, 1 Dec 2020 11:57:46 -0500 Subject: [PATCH 3/4] yesod-test version bump --- yesod-test/yesod-test.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 3092dfb4..e2c6334e 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 1.6.10 +version: 1.6.11 license: MIT license-file: LICENSE author: Nubis From 761dbc7753b13e4ee1f6211acc7378fc137d5b66 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Tue, 1 Dec 2020 12:00:45 -0500 Subject: [PATCH 4/4] Update yesod-test ChangeLog --- yesod-test/ChangeLog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index 032be807..de377caf 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-test +## 1.6.11 + +* Add missing `HasCallStack`s [#1710](https://github.com/yesodweb/yesod/pull/1710) + ## 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)