[yesod-test] Adds requireJSONResponse function

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

@@ -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)

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 } ->

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)
+    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

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 <nubis@woobiz.com.ar>
@@ -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