..

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