diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index 681845b5..0bbcc0b6 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 [#164](https://github.com/yesodweb/yesod/pull/164) + ## 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..73333105 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 @@ -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 } -> diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index f0f5b8e4..327bc16b 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,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) \ 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