Merge branch 'master' into yesod1.2

Conflicts:
	yesod-json/yesod-json.cabal

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.

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

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

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