[yesod-test] Adds requireJSONResponse function

yesod-test/ChangeLog.md

@@ -1,5 +1,9 @@
 # ChangeLog for yesod-test
 
+## 1.6.9
+
+Add `requireJSONResponse` function [#1646](https://github.com/yesodweb/yesod/pull/1646)
+
 ## 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,29 @@ 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
+--
+-- @since 1.6.9
+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