diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index 91fe802e..032be807 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -1,5 +1,10 @@ # ChangeLog for yesod-test +## 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) +* Adds an `Yesod.Test.Internal`, which exposes functions that yesod-test uses. These functions do _not_ constitute a stable API. + ## 1.6.9.1 * Improve documentation [#1676](https://github.com/yesodweb/yesod/pull/1676) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index fbe7b64f..6c319234 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -249,7 +249,6 @@ import System.IO import Yesod.Core.Unsafe (runFakeHandler) import Yesod.Test.TransversingCSS import Yesod.Core -import Yesod.Core.Json (contentTypeHeaderIsJson) import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With) import Text.XML.Cursor hiding (element) @@ -279,6 +278,8 @@ import Network.HTTP.Types.Header (hContentType) import Data.Aeson (FromJSON, eitherDecode') import Control.Monad (unless) +import Yesod.Test.Internal (getBodyTextPreview, contentTypeHeaderIsUtf8) + {-# DEPRECATED byLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use byLabelExact, byLabelContain, byLabelPrefix or byLabelSuffix instead" #-} {-# DEPRECATED fileByLabel "This function seems to have multiple bugs (ref: https://github.com/yesodweb/yesod/pull/1459). Use fileByLabelExact, fileByLabelContain, fileByLabelPrefix or fileByLabelSuffix instead" #-} @@ -569,17 +570,25 @@ assertEqualNoShow :: (HasCallStack, Eq a) => String -> a -> a -> YesodExample si assertEqualNoShow msg a b = liftIO $ HUnit.assertBool msg (a == b) -- | Assert the last response status is as expected. +-- If the status code doesn't match, a portion of the body is also printed to aid in debugging. -- -- ==== __Examples__ -- -- > get HomeR -- > statusIs 200 statusIs :: HasCallStack => Int -> YesodExample site () -statusIs number = withResponse $ \ SResponse { simpleStatus = s } -> - liftIO $ flip HUnit.assertBool (H.statusCode s == number) $ concat - [ "Expected status was ", show number - , " but received status was ", show $ H.statusCode s - ] +statusIs number = do + withResponse $ \(SResponse status headers body) -> do + let mContentType = lookup hContentType headers + isUTF8ContentType = maybe False contentTypeHeaderIsUtf8 mContentType + + liftIO $ flip HUnit.assertBool (H.statusCode status == number) $ concat + [ "Expected status was ", show number + , " but received status was ", show $ H.statusCode status + , if isUTF8ContentType + then ". For debugging, the body was: " <> (T.unpack $ getBodyTextPreview body) + else "" + ] -- | Assert the given header key/value pair was returned. -- @@ -774,13 +783,7 @@ requireJSONResponse = do isJSONContentType (failure $ T.pack $ "Expected `Content-Type: application/json` in the headers, got: " ++ show headers) case eitherDecode' body of - Left err -> do - let characterLimit = 1024 - textBody = TL.toStrict $ decodeUtf8 body - bodyPreview = if T.length textBody < characterLimit - then textBody - else T.take characterLimit textBody <> "... (use `printBody` to see complete response body)" - failure $ T.concat ["Failed to parse JSON response; error: ", T.pack err, "JSON: ", bodyPreview] + Left err -> failure $ T.concat ["Failed to parse JSON response; error: ", T.pack err, "JSON: ", getBodyTextPreview body] Right v -> return v -- | Outputs the last response body to stderr (So it doesn't get captured by HSpec). Useful for debugging. diff --git a/yesod-test/Yesod/Test/Internal.hs b/yesod-test/Yesod/Test/Internal.hs new file mode 100644 index 00000000..366f9cb1 --- /dev/null +++ b/yesod-test/Yesod/Test/Internal.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | This module exposes functions that are used internally by yesod-test. +-- The functions exposed here are _not_ a stable API—they may be changed or removed without any major version bump. +-- +-- That said, you may find them useful if your application can accept API breakage. +module Yesod.Test.Internal + ( getBodyTextPreview + , contentTypeHeaderIsUtf8 + , assumedUTF8ContentTypes + ) where + +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +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. +-- +-- @since 1.6.10 +getBodyTextPreview :: LBS.ByteString -> T.Text +getBodyTextPreview body = + let characterLimit = 1024 + textBody = TL.toStrict $ DTLE.decodeUtf8 body + in if T.length textBody < characterLimit + then textBody + else T.take characterLimit textBody <> "... (use `printBody` to see complete response body)" + +-- | Helper function to determine if we can print a body as plain text, for debugging purposes. +-- +-- @since 1.6.10 +contentTypeHeaderIsUtf8 :: BS8.ByteString -> Bool +contentTypeHeaderIsUtf8 contentTypeBS = + -- Convert to Text, so we can use T.splitOn + let contentTypeText = T.toLower $ TE.decodeUtf8 contentTypeBS + isUTF8FromCharset = case T.splitOn "charset=" contentTypeText of + -- Either a specific designation as UTF-8, or ASCII (which is a subset of UTF-8) + [_, charSet] -> any (`T.isInfixOf` charSet) ["utf-8", "us-ascii"] + _ -> False + + isInferredUTF8FromContentType = BS8.takeWhile (/= ';') contentTypeBS `Set.member` assumedUTF8ContentTypes + + in isUTF8FromCharset || isInferredUTF8FromContentType + +-- | List of Content-Types that are assumed to be UTF-8 (e.g. JSON). +-- +-- @since 1.6.10 +assumedUTF8ContentTypes :: Set.Set BS8.ByteString +assumedUTF8ContentTypes = Set.fromList $ map Content.simpleContentType + [ Content.typeHtml + , Content.typePlain + , Content.typeJson + , Content.typeXml + , Content.typeAtom + , Content.typeRss + , Content.typeSvg + , Content.typeJavascript + , Content.typeCss + ] diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index 1e07ae8c..16acdf79 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -45,6 +45,7 @@ import Control.Monad.IO.Unlift (toIO) import qualified Web.Cookie as Cookie import Data.Maybe (isNothing) import qualified Data.Text as T +import Yesod.Test.Internal (contentTypeHeaderIsUtf8) parseQuery_ :: Text -> [[SelectorGroup]] parseQuery_ = either error id . parseQuery @@ -125,6 +126,19 @@ main = hspec $ do ] ] in HD.parseLBS html @?= doc + describe "identifying text-based bodies" $ do + it "matches content-types with an explicit UTF-8 charset" $ do + contentTypeHeaderIsUtf8 "application/custom; charset=UTF-8" @?= True + contentTypeHeaderIsUtf8 "application/custom; charset=utf-8" @?= True + it "matches content-types with an ASCII charset" $ do + contentTypeHeaderIsUtf8 "application/custom; charset=us-ascii" @?= True + it "matches content-types that we assume are UTF-8" $ do + contentTypeHeaderIsUtf8 "text/html" @?= True + contentTypeHeaderIsUtf8 "application/json" @?= True + it "doesn't match content-type headers that are binary data" $ do + contentTypeHeaderIsUtf8 "image/gif" @?= False + contentTypeHeaderIsUtf8 "application/pdf" @?= False + describe "basic usage" $ yesodSpec app $ do ydescribe "tests1" $ do yit "tests1a" $ do diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index f1868579..5427594a 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 1.6.9.1 +version: 1.6.10 license: MIT license-file: LICENSE author: Nubis @@ -45,6 +45,7 @@ library exposed-modules: Yesod.Test Yesod.Test.CssQuery Yesod.Test.TransversingCSS + Yesod.Test.Internal ghc-options: -Wall test-suite test