Merge pull request #1646 from yesodweb/requireJSONResponse

[yesod-test] Adds requireJSONResponse function

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

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
+    case fmap contentTypeHeaderIsJson mct of
-        Just "application/json" -> parseInsecureJsonBody
+        Just True -> parseInsecureJsonBody
         _ -> return $ J.Error $ "Non-JSON content type: " ++ show mct
 
 -- | Same as 'parseInsecureJsonBody', but return an invalid args response on a parse
@@ -218,3 +221,12 @@ acceptsJson =  (maybe False ((== "application/json") . B8.takeWhile (/= ';'))
             .  listToMaybe
             .  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 @<https://tools.ietf.org/html/rfc6839#section-3.1 xxx/yyy+json>@.
+--
+-- @since 1.6.17
+contentTypeHeaderIsJson :: B8.ByteString -> Bool
+contentTypeHeaderIsJson bs = B8.takeWhile (/= ';') bs == "application/json"

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 <michael@snoyman.com>

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
@@ -170,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)
@@ -195,6 +197,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 +603,37 @@ 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
+--
+-- > post UserR
+-- > (json :: Value) <- 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 contentTypeHeaderIsJson mContentType
+    unless
+        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]
+        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,8 +39,9 @@ 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 Network.HTTP.Types.Status (status200, status301, status303, status403, status422, unsupportedMediaType415)
-import UnliftIO.Exception (tryAny, SomeException, try)
+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
@@ -471,6 +473,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 +582,10 @@ 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)
 
 cookieApp :: LiteApp
 cookieApp = liteApp $ do
@@ -616,3 +636,12 @@ getIntegerR :: Handler Text
 getIntegerR = do
     app <- getYesod
     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