Check mime-type for JSON bodies #1330

yesod-auth/ChangeLog.md

@@ -1,3 +1,7 @@
+## 1.4.16
+
+* Fix email provider [#1330](https://github.com/yesodweb/yesod/issues/1330)
+
 ## 1.4.15
 
 * Add JSON endpoints to Yesod.Auth.Email module

yesod-auth/Yesod/Auth/Email.hs

@@ -455,7 +455,7 @@ registerHelper allowUsername dest = do
     pidentifier <- lookupPostParam "email"
     midentifier <- case pidentifier of
                      Nothing -> do
-                       (jidentifier :: Result Value) <- lift parseJsonBody
+                       (jidentifier :: Result Value) <- lift parseCheckJsonBody
                        case jidentifier of
                          Error _ -> return Nothing
                          Success val -> return $ parseMaybe parseEmail val
@@ -589,7 +589,7 @@ postLoginR = do
     midentifier <- case result of
                      FormSuccess (iden, pass) -> return $ Just (iden, pass)
                      _ -> do
-                       (creds :: Result Value) <- lift parseJsonBody
+                       (creds :: Result Value) <- lift parseCheckJsonBody
                        case creds of
                          Error _ -> return Nothing
                          Success val -> return $ parseMaybe parseCreds val
@@ -718,7 +718,7 @@ parsePassword = withObject "password" (\obj -> do
 postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent
 postPasswordR = do
     maid <- lift maybeAuthId
-    (creds :: Result Value) <- lift parseJsonBody
+    (creds :: Result Value) <- lift parseCheckJsonBody
     let jcreds = case creds of
                    Error _ -> Nothing
                    Success val -> parseMaybe parsePassword val

yesod-auth/yesod-auth.cabal

@@ -1,5 +1,5 @@
 name:            yesod-auth
-version:         1.4.15
+version:         1.4.16
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin
@@ -23,7 +23,7 @@ library
     build-depends:   base                    >= 4         && < 5
                    , authenticate            >= 1.3
                    , bytestring              >= 0.9.1.4
-                   , yesod-core              >= 1.4.20    && < 1.5
+                   , yesod-core              >= 1.4.31    && < 1.5
                    , wai                     >= 1.4
                    , template-haskell
                    , base16-bytestring

yesod-core/ChangeLog.md

@@ -1,3 +1,7 @@
+## 1.4.31
+
+* Add `parseCheckJsonBody` and `requireCheckJsonBody`
+
 ## 1.4.30
 
 * Add `defaultMessageWidget`

yesod-core/Yesod/Core/Json.hs

@@ -13,8 +13,10 @@ module Yesod.Core.Json
 
       -- * Convert to a JSON value
     , parseJsonBody
+    , parseCheckJsonBody
     , parseJsonBody_
     , requireJsonBody
+    , requireCheckJsonBody
 
       -- * Produce JSON values
     , J.Value (..)
@@ -33,7 +35,7 @@ module Yesod.Core.Json
     , acceptsJson
     ) where
 
-import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep)
+import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep, lookupHeader)
 import Control.Monad.Trans.Writer (Writer)
 import Data.Monoid (Endo)
 import Yesod.Core.Content (TypedContent)
@@ -121,6 +123,15 @@ parseJsonBody = do
         Left e -> J.Error $ show e
         Right value -> J.fromJSON value
 
+-- | Same as 'parseJsonBody', but ensures that the mime type indicates
+-- JSON content.
+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" -> parseJsonBody
+        _ -> return $ J.Error $ "Non-JSON content type: " ++ show mct
+
 -- | Same as 'parseJsonBody', but return an invalid args response on a parse
 -- error.
 parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a
@@ -136,6 +147,15 @@ requireJsonBody = do
         J.Error s -> invalidArgs [pack s]
         J.Success a -> return a
 
+-- | Same as 'requireJsonBody', but ensures that the mime type
+-- indicates JSON content.
+requireCheckJsonBody :: (MonadHandler m, J.FromJSON a) => m a
+requireCheckJsonBody = do
+    ra <- parseCheckJsonBody
+    case ra of
+        J.Error s -> invalidArgs [pack s]
+        J.Success a -> return a
+
 -- | Convert a list of values to an 'J.Array'.
 array :: J.ToJSON a => [a] -> J.Value
 array = J.Array . V.fromList . map J.toJSON

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.4.30
+version:         1.4.31
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>