diff --git a/yesod-core/Yesod/Core/Json.hs b/yesod-core/Yesod/Core/Json.hs index 64cb7cc5..ce98fb96 100644 --- a/yesod-core/Yesod/Core/Json.hs +++ b/yesod-core/Yesod/Core/Json.hs @@ -45,7 +45,7 @@ import Data.Text.Lazy.Builder (fromLazyText) import Data.Text.Lazy.Encoding (decodeUtf8) import Data.Text.Lazy.Builder (toLazyText) import qualified Blaze.ByteString.Builder.Char.Utf8 as Blaze -import Data.Conduit (($$)) +import Data.Conduit import Network.Wai (requestBody, requestHeaders) import Network.Wai.Parse (parseHttpAccept) import qualified Data.ByteString.Char8 as B8 @@ -80,7 +80,13 @@ jsonToRepJson = return . RepJson . toContent . J.toJSON parseJsonBody :: J.FromJSON a => GHandler sub master (J.Result a) parseJsonBody = do req <- waiRequest - fmap J.fromJSON $ lift $ requestBody req $$ sinkParser JP.value' + eValue <- lift + $ runExceptionT + $ transPipe lift (requestBody req) + $$ sinkParser JP.value' + return $ case eValue of + Left e -> J.Error $ show e + Right value -> J.fromJSON value -- | Same as 'parseJsonBody', but return an invalid args response on a parse -- error. diff --git a/yesod-core/test/YesodCoreTest.hs b/yesod-core/test/YesodCoreTest.hs index 13c5e20e..37b5810e 100644 --- a/yesod-core/test/YesodCoreTest.hs +++ b/yesod-core/test/YesodCoreTest.hs @@ -13,6 +13,7 @@ import qualified YesodCoreTest.WaiSubsite as WaiSubsite import qualified YesodCoreTest.Redirect as Redirect import qualified YesodCoreTest.JsLoader as JsLoader import qualified YesodCoreTest.RequestBodySize as RequestBodySize +import qualified YesodCoreTest.Json as Json import Test.Hspec @@ -31,3 +32,4 @@ specs = do Redirect.specs JsLoader.specs RequestBodySize.specs + Json.specs diff --git a/yesod-core/test/YesodCoreTest/Json.hs b/yesod-core/test/YesodCoreTest/Json.hs new file mode 100644 index 00000000..67191790 --- /dev/null +++ b/yesod-core/test/YesodCoreTest/Json.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-} +module YesodCoreTest.Json (specs, Widget) where + +import Yesod.Core +import Test.Hspec +import qualified Data.Map as Map +import Network.Wai.Test +import Data.Text (Text) +import Data.ByteString.Lazy (ByteString) + +data App = App + +mkYesod "App" [parseRoutes| +/ HomeR GET +|] + +instance Yesod App + +getHomeR :: Handler RepPlain +getHomeR = do + val <- parseJsonBody_ + case Map.lookup ("foo" :: Text) val of + Nothing -> invalidArgs ["foo not found"] + Just foo -> return $ RepPlain $ toContent (foo :: Text) + +test :: String + -> ByteString + -> (SResponse -> Session ()) + -> Spec +test name rbody f = it name $ do + app <- toWaiApp App + flip runSession app $ do + sres <- srequest SRequest + { simpleRequest = defaultRequest + , simpleRequestBody = rbody + } + f sres + +specs :: Spec +specs = describe "Yesod.Json" $ do + test "parses valid content" "{\"foo\":\"bar\"}" $ \sres -> do + assertStatus 200 sres + assertBody "bar" sres + test "400 for bad JSON" "{\"foo\":\"bar\"" $ \sres -> do + assertStatus 400 sres + test "400 for bad structure" "{\"foo2\":\"bar\"}" $ \sres -> do + assertStatus 400 sres + assertBodyContains "foo not found" sres diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 3e6654fa..efdc4d89 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -22,6 +22,7 @@ extra-source-files: test/YesodCoreTest/ErrorHandling.hs test/YesodCoreTest/Exceptions.hs test/YesodCoreTest/InternalRequest.hs + test/YesodCoreTest/Json.hs test/YesodCoreTest/JsLoader.hs test/YesodCoreTest/JsLoaderSites/Bottom.hs test/YesodCoreTest/JsLoaderSites/HeadAsync.hs @@ -127,6 +128,7 @@ test-suite tests ,QuickCheck >= 2 && < 3 ,transformers , conduit + , containers ghc-options: -Wall source-repository head