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 3ced0c56..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 @@ -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 @@. +-- +-- @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/ChangeLog.md b/yesod-test/ChangeLog.md index 681845b5..d1b592e1 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 [#1646](https://github.com/yesodweb/yesod/pull/1646) + ## 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..efa6b107 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 @@ -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 } -> diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index f0f5b8e4..1e07ae8c 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,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 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 @@ -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 @@ -615,4 +635,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