From 6d0b723eb17ffcb81b69195b616a788b3d11e82e Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Sun, 24 Nov 2019 15:31:05 -0500 Subject: [PATCH 1/8] [yesod-test] Adds requireJSONResponse function MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This function checks that a response body is JSON, and parses it into a Haskell value. Having something like this function is pretty essential to using Yesod as a JSON API server, so I think it's a good addition. You can use it to parse a Haskell record directly (usually by adding FromJSON classes to your response types), or parse a Value and pull out individual fields, maybe using something like `aeson-lens` (though probably a testing-specific library would be better). I debated over these things: 1. The name. I was thinking of something like [assert/require/decode/parse]JSON[Response/Body]. I ultimately went with requireJSONResponse: - decode/parse sound like the aeson functions that return Either or Maybe, and I wanted this function to throw an error if it failed - I'm open to using `assertJSONResponse`—it matches the other functions (`assertEq`) better—but I think it reads less like English. - I chose Response over Body because (a) It also checks the content-type header, which is not in the body (b) "Body" felt slightly in-the-weeds of HTTP; I think "response" is more approachable. 2. Should it require the JSON content type? You can definitely have a server that returns JSON without JSON content types, but I think that's a such a bad idea, it's more likely requiring it helps people if they accidentally don't add the header. 3. Should it take a String parameter to add to the error message? This would match `assertEq`, but other functions like `statusIs` don't take a message. Ultimately I went without it, because the messages felt like I was repeating myself: `(comment :: Comment) <- requireJSONResponse "the response has a comment"` --- yesod-test/ChangeLog.md | 4 ++++ yesod-test/Yesod/Test.hs | 25 +++++++++++++++++++++++++ yesod-test/test/main.hs | 37 ++++++++++++++++++++++++++++++++++--- yesod-test/yesod-test.cabal | 4 +++- 4 files changed, 66 insertions(+), 4 deletions(-) diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index 681845b5..0bbcc0b6 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-test +## 1.6.9 + +Add `requireJSONResponse` function [#164](https://github.com/yesodweb/yesod/pull/164) + ## 1.6.8 Add `testModifySite` function [#1642](https://github.com/yesodweb/yesod/pull/1642) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 80b814f8..73333105 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -125,6 +125,7 @@ module Yesod.Test , htmlAnyContain , htmlNoneContain , htmlCount + , requireJSONResponse -- * Grab information , getTestYesod @@ -195,6 +196,9 @@ import GHC.Exts (Constraint) type HasCallStack = (() :: Constraint) #endif import Data.ByteArray.Encoding (convertToBase, Base(..)) +import Network.HTTP.Types.Header (hContentType) +import Data.Aeson (FromJSON, eitherDecode') +import Control.Monad (unless) {-# 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" #-} @@ -598,6 +602,27 @@ htmlCount query count = do liftIO $ flip HUnit.assertBool (matches == count) ("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. +-- +-- This function also checks that the @Content-Type@ of the response is @application/json@. +-- +-- ==== __Examples__ +-- +-- > get CommentR +-- > (comment :: Comment) <- requireJSONResponse +requireJSONResponse :: (HasCallStack, FromJSON a) => YesodExample site a +requireJSONResponse = do + withResponse $ \(SResponse _status headers body) -> do + let mContentType = lookup hContentType headers + isJSONContentType = maybe False (\contentType -> BS8.takeWhile (/= ';') contentType == "application/json") mContentType + unless + isJSONContentType + (failure $ T.pack $ "Expected `Content-Type: application/json` in the headers, got: " ++ show headers) + case eitherDecode' body of + -- TODO: include full body in error message? + Left err -> failure $ T.concat ["Failed to parse JSON response; error: ", T.pack err] + Right v -> return v + -- | Outputs the last response body to stderr (So it doesn't get captured by HSpec) printBody :: YesodExample site () printBody = withResponse $ \ SResponse { simpleBody = b } -> diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index f0f5b8e4..327bc16b 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -20,6 +20,7 @@ module Main import Test.HUnit hiding (Test) import Test.Hspec +import qualified Test.Hspec as Hspec import Yesod.Core import Yesod.Form @@ -38,11 +39,13 @@ import Data.Either (isLeft, isRight) import Data.ByteString.Lazy.Char8 () import qualified Data.Map as Map import qualified Text.HTML.DOM as HD -import Network.HTTP.Types.Status (status301, status303, status403, status422, unsupportedMediaType415) -import UnliftIO.Exception (tryAny, SomeException, try) +import Network.HTTP.Types.Status (status200, status301, status303, status403, status422, unsupportedMediaType415) +import UnliftIO.Exception (tryAny, SomeException, try, Exception) +import Control.Monad.IO.Unlift (toIO) import qualified Web.Cookie as Cookie import Data.Maybe (isNothing) import qualified Data.Text as T +-- import qualified Data.Aeson as A parseQuery_ :: Text -> [[SelectorGroup]] parseQuery_ = either error id . parseQuery @@ -471,6 +474,20 @@ main = hspec $ do setUrl ("checkBasicAuth" :: Text) addBasicAuthHeader "Aladdin" "OpenSesame" statusIs 200 + describe "JSON parsing" $ yesodSpec app $ do + yit "checks for a json array" $ do + get ("get-json-response" :: Text) + statusIs 200 + xs <- requireJSONResponse + assertEq "The value is [1]" xs [1 :: Integer] + yit "checks for valid content-type" $ do + get ("get-json-wrong-content-type" :: Text) + statusIs 200 + (requireJSONResponse :: YesodExample site [Integer]) `liftedShouldThrow` (\(e :: SomeException) -> True) + yit "checks for valid JSON parse" $ do + get ("get-json-response" :: Text) + statusIs 200 + (requireJSONResponse :: YesodExample site [Text]) `liftedShouldThrow` (\(e :: SomeException) -> True) instance RenderMessage LiteApp FormMessage where renderMessage _ _ = defaultFormMessage @@ -566,6 +583,11 @@ app = liteApp $ do if authHeader == Just "Basic QWxhZGRpbjpPcGVuU2VzYW1l" then return () else sendResponseStatus status403 () + onStatic "get-json-response" $ dispatchTo $ do + (sendStatusJSON status200 ([1] :: [Integer])) :: LiteHandler Value + onStatic "get-json-wrong-content-type" $ dispatchTo $ do + return ("[1]" :: Text) + -- (sendResponse "[1]") :: LiteHandler Text cookieApp :: LiteApp cookieApp = liteApp $ do @@ -615,4 +637,13 @@ getResourceR i = defaultLayout getIntegerR :: Handler Text getIntegerR = do app <- getYesod - pure $ T.pack $ show (routedAppInteger app) \ No newline at end of file + pure $ T.pack $ show (routedAppInteger app) + + +-- infix Copied from HSpec's version +infix 1 `liftedShouldThrow` + +liftedShouldThrow :: (MonadUnliftIO m, HasCallStack, Exception e) => m a -> Hspec.Selector e -> m () +liftedShouldThrow action sel = do + ioAction <- toIO action + liftIO $ ioAction `shouldThrow` sel diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index ac770758..fba339ae 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 1.6.8 +version: 1.6.9 license: MIT license-file: LICENSE author: Nubis @@ -15,6 +15,7 @@ extra-source-files: README.md, LICENSE, test/main.hs, ChangeLog.md library build-depends: HUnit >= 1.2 + , aeson , attoparsec >= 0.10 , base >= 4.3 && < 5 , blaze-builder @@ -65,6 +66,7 @@ test-suite test , http-types , unliftio , cookie + , unliftio-core source-repository head type: git From 596db81d7ab1666be8bfb79fbb628d5e84f34deb Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Sun, 24 Nov 2019 15:55:58 -0500 Subject: [PATCH 2/8] .. --- yesod-test/ChangeLog.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index 0bbcc0b6..d1b592e1 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -2,7 +2,7 @@ ## 1.6.9 -Add `requireJSONResponse` function [#164](https://github.com/yesodweb/yesod/pull/164) +Add `requireJSONResponse` function [#1646](https://github.com/yesodweb/yesod/pull/1646) ## 1.6.8 From 92afb1150a794448527e8137cf447a456e5d27ba Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Sun, 24 Nov 2019 15:56:42 -0500 Subject: [PATCH 3/8] .. --- yesod-test/Yesod/Test.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 73333105..a9eeef28 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -610,6 +610,8 @@ htmlCount query count = do -- -- > get CommentR -- > (comment :: Comment) <- requireJSONResponse +-- +-- @since 1.6.9 requireJSONResponse :: (HasCallStack, FromJSON a) => YesodExample site a requireJSONResponse = do withResponse $ \(SResponse _status headers body) -> do From 91b75741dd6eca44d05b4947de42339383c9c42b Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Sun, 24 Nov 2019 16:11:50 -0500 Subject: [PATCH 4/8] .. --- yesod-test/Yesod/Test.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index a9eeef28..cb2d9fb2 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -611,6 +611,9 @@ htmlCount query count = do -- > get CommentR -- > (comment :: Comment) <- requireJSONResponse -- +-- > post UserR +-- > (json :: Value) <- requireJSONResponse +-- -- @since 1.6.9 requireJSONResponse :: (HasCallStack, FromJSON a) => YesodExample site a requireJSONResponse = do From 0025226af6299c0340a976e0860205a584f283fa Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Thu, 28 Nov 2019 22:32:42 -0500 Subject: [PATCH 5/8] Print preview of JSON body in case of parse failure --- yesod-core/src/Yesod/Core/Json.hs | 1 + yesod-test/Yesod/Test.hs | 9 +++++++-- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Json.hs b/yesod-core/src/Yesod/Core/Json.hs index 3ced0c56..5fe75ccf 100644 --- a/yesod-core/src/Yesod/Core/Json.hs +++ b/yesod-core/src/Yesod/Core/Json.hs @@ -218,3 +218,4 @@ acceptsJson = (maybe False ((== "application/json") . B8.takeWhile (/= ';')) . listToMaybe . reqAccept) `liftM` getRequest + diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index cb2d9fb2..1bd999e8 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -624,8 +624,13 @@ requireJSONResponse = do isJSONContentType (failure $ T.pack $ "Expected `Content-Type: application/json` in the headers, got: " ++ show headers) case eitherDecode' body of - -- TODO: include full body in error message? - Left err -> failure $ T.concat ["Failed to parse JSON response; error: ", T.pack err] + 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] Right v -> return v -- | Outputs the last response body to stderr (So it doesn't get captured by HSpec) From 42d41f77de8e379c9f4e14950f817d72c6acf021 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Fri, 29 Nov 2019 10:43:11 -0500 Subject: [PATCH 6/8] .. --- yesod-core/ChangeLog.md | 4 ++++ yesod-core/src/Yesod/Core/Json.hs | 15 +++++++++++++-- yesod-core/yesod-core.cabal | 2 +- yesod-test/Yesod/Test.hs | 5 +++-- 4 files changed, 21 insertions(+), 5 deletions(-) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 9f35d9df..f4923073 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-core +## 1.6.17 + +Adds `contentTypeIsJson` [#1646](https://github.com/yesodweb/yesod/pull/1646) + ## 1.6.16.1 * Compiles with GHC 8.8.1 diff --git a/yesod-core/src/Yesod/Core/Json.hs b/yesod-core/src/Yesod/Core/Json.hs index 5fe75ccf..a51f5928 100644 --- a/yesod-core/src/Yesod/Core/Json.hs +++ b/yesod-core/src/Yesod/Core/Json.hs @@ -32,6 +32,9 @@ module Yesod.Core.Json , jsonOrRedirect , jsonEncodingOrRedirect , acceptsJson + + -- * Checking if data is JSON + , contentTypeHeaderIsJson ) where import Yesod.Core.Handler (HandlerFor, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep, lookupHeader) @@ -134,8 +137,8 @@ parseInsecureJsonBody = do parseCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a) parseCheckJsonBody = do mct <- lookupHeader "content-type" - case fmap (B8.takeWhile (/= ';')) mct of - Just "application/json" -> parseInsecureJsonBody + case fmap contentTypeHeaderIsJson mct of + Just True -> parseInsecureJsonBody _ -> return $ J.Error $ "Non-JSON content type: " ++ show mct -- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse @@ -219,3 +222,11 @@ acceptsJson = (maybe False ((== "application/json") . B8.takeWhile (/= ';')) . reqAccept) `liftM` getRequest +-- | Given the @Content-Type@ header, returns if it is JSON. +-- +-- This function is currently a simple check for @application/json@, but in the future may check for +-- alternative representations such as @@. +-- +-- @since 1.6.17 +contentTypeHeaderIsJson :: B8.ByteString -> Bool +contentTypeHeaderIsJson bs = B8.takeWhile (/= ';') bs == "application/json" diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index d0596efb..a5b6af51 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.6.16.1 +version: 1.6.17 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 1bd999e8..d7a704f4 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -171,6 +171,7 @@ 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) @@ -604,7 +605,7 @@ htmlCount query count = do -- | Parses the response body from JSON into a Haskell value, throwing an error if parsing fails. -- --- This function also checks that the @Content-Type@ of the response is @application/json@. +-- This function also checks that the @Content-Type@ of the response is @application\/json@. -- -- ==== __Examples__ -- @@ -619,7 +620,7 @@ requireJSONResponse :: (HasCallStack, FromJSON a) => YesodExample site a requireJSONResponse = do withResponse $ \(SResponse _status headers body) -> do let mContentType = lookup hContentType headers - isJSONContentType = maybe False (\contentType -> BS8.takeWhile (/= ';') contentType == "application/json") mContentType + isJSONContentType = maybe False contentTypeHeaderIsJson mContentType unless isJSONContentType (failure $ T.pack $ "Expected `Content-Type: application/json` in the headers, got: " ++ show headers) From 561adc2e175ad4cc142d1d9997eba5594d793bd0 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Fri, 29 Nov 2019 10:44:49 -0500 Subject: [PATCH 7/8] .. --- 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 d7a704f4..efa6b107 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -605,7 +605,7 @@ htmlCount query count = do -- | Parses the response body from JSON into a Haskell value, throwing an error if parsing fails. -- --- This function also checks that the @Content-Type@ of the response is @application\/json@. +-- This function also checks that the @Content-Type@ of the response is @application/json@. -- -- ==== __Examples__ -- From 8ee771896cd4484d59c69b12216bdb7e6ee302d2 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Fri, 29 Nov 2019 10:46:25 -0500 Subject: [PATCH 8/8] .. --- yesod-test/test/main.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index 327bc16b..1e07ae8c 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -45,7 +45,6 @@ import Control.Monad.IO.Unlift (toIO) import qualified Web.Cookie as Cookie import Data.Maybe (isNothing) import qualified Data.Text as T --- import qualified Data.Aeson as A parseQuery_ :: Text -> [[SelectorGroup]] parseQuery_ = either error id . parseQuery @@ -587,7 +586,6 @@ app = liteApp $ do (sendStatusJSON status200 ([1] :: [Integer])) :: LiteHandler Value onStatic "get-json-wrong-content-type" $ dispatchTo $ do return ("[1]" :: Text) - -- (sendResponse "[1]") :: LiteHandler Text cookieApp :: LiteApp cookieApp = liteApp $ do