From 19840cdc8908e9ff2157031f083de8876445e638 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Mon, 5 Dec 2016 19:32:23 +0530 Subject: [PATCH 1/9] Add json support for postRegisterR --- yesod-auth/Yesod/Auth/Email.hs | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 26fb9c5a..f946d174 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -4,6 +4,7 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables#-} {-# LANGUAGE TypeFamilies #-} -- | A Yesod plugin for Authentication via e-mail -- @@ -70,6 +71,8 @@ import Data.Time (addUTCTime, getCurrentTime) import Safe (readMay) import System.IO.Unsafe (unsafePerformIO) import qualified Text.Email.Validate +import Network.HTTP.Types.Status (status400) +import Data.Aeson.Types (Parser(..), Result(..), parseMaybe, withObject) loginR, registerR, forgotPasswordR, setpassR :: AuthRoute loginR = PluginR "email" ["login"] @@ -376,6 +379,11 @@ defaultRegisterHandler = do return (userRes, widget) +parseEmail :: Value -> Parser Text +parseEmail = withObject "email" (\obj -> do + email' <- obj .: "email" + return email') + registerHelper :: YesodAuthEmail master => Bool -- ^ allow usernames? -> Route Auth @@ -383,7 +391,14 @@ registerHelper :: YesodAuthEmail master registerHelper allowUsername dest = do y <- lift getYesod checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName - midentifier <- lookupPostParam "email" + pidentifier <- lookupPostParam "email" + (jidentifier :: Result Value) <- lift parseJsonBody + let midentifier = case pidentifier of + Nothing -> case jidentifier of + Error _ -> Nothing + Success val -> parseMaybe parseEmail val + Just _ -> pidentifier + let eidentifier = case midentifier of Nothing -> Left Msg.NoIdentifierProvided Just x From b6cd72f49ff1e8e5eef09da969159059492c15fc Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 6 Dec 2016 15:20:51 +0530 Subject: [PATCH 2/9] Implement Login via JSON endpoint Add additional handling of JSON endpoint in addition to the HTML form method. --- yesod-auth/Yesod/Auth/Email.hs | 72 +++++++++++++++++++++------------- 1 file changed, 44 insertions(+), 28 deletions(-) diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index f946d174..ef7ed607 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -512,38 +512,54 @@ $newline never |] +parseCreds :: Value -> Parser (Text, Text) +parseCreds = withObject "creds" (\obj -> do + email' <- obj .: "email" + pass <- obj .: "password" + return (email', pass)) + + postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent postLoginR = do - (identifier, pass) <- lift $ runInputPost $ (,) + result <- lift $ runInputPostResult $ (,) <$> ireq textField "email" <*> ireq textField "password" - mecreds <- lift $ getEmailCreds identifier - maid <- - case ( mecreds >>= emailCredsAuthId - , emailCredsEmail <$> mecreds - , emailCredsStatus <$> mecreds - ) of - (Just aid, Just email, Just True) -> do - mrealpass <- lift $ getPassword aid - case mrealpass of - Nothing -> return Nothing - Just realpass -> return $ - if isValidPass pass realpass - then Just email - else Nothing - _ -> return Nothing - let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier - case maid of - Just email -> - lift $ setCredsRedirect $ Creds - (if isEmail then "email" else "username") - email - [("verifiedEmail", email)] - Nothing -> - loginErrorMessageI LoginR $ - if isEmail - then Msg.InvalidEmailPass - else Msg.InvalidUsernamePass + (creds :: Result Value) <- lift parseJsonBody + let midentifier = case result of + FormSuccess (iden, pass) -> Just (iden, pass) + _ -> case creds of + Error _ -> Nothing + Success val -> parseMaybe parseCreds val + + case midentifier of + Nothing -> loginErrorMessageI LoginR Msg.NoIdentifierProvided + Just (identifier, pass) -> do + mecreds <- lift $ getEmailCreds identifier + maid <- + case ( mecreds >>= emailCredsAuthId + , emailCredsEmail <$> mecreds + , emailCredsStatus <$> mecreds + ) of + (Just aid, Just email, Just True) -> do + mrealpass <- lift $ getPassword aid + case mrealpass of + Nothing -> return Nothing + Just realpass -> return $ if isValidPass pass realpass + then Just email + else Nothing + _ -> return Nothing + let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier + case maid of + Just email -> + lift $ setCredsRedirect $ Creds + (if isEmail then "email" else "username") + email + [("verifiedEmail", email)] + Nothing -> + loginErrorMessageI LoginR $ + if isEmail + then Msg.InvalidEmailPass + else Msg.InvalidUsernamePass getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent getPasswordR = do From 85bd15d109e33f79d36e8d692e4dad67a47b2628 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 6 Dec 2016 18:17:19 +0530 Subject: [PATCH 3/9] Add json support for postPasswordR --- yesod-auth/Yesod/Auth/Email.hs | 78 +++++++++++++++++++++++----------- 1 file changed, 53 insertions(+), 25 deletions(-) diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index ef7ed607..84858a5e 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -72,7 +72,8 @@ import Safe (readMay) import System.IO.Unsafe (unsafePerformIO) import qualified Text.Email.Validate import Network.HTTP.Types.Status (status400) -import Data.Aeson.Types (Parser(..), Result(..), parseMaybe, withObject) +import Data.Aeson.Types (Parser(..), Result(..), parseMaybe, withObject, (.:?)) +import Data.Maybe (isJust, isNothing, fromJust) loginR, registerR, forgotPasswordR, setpassR :: AuthRoute loginR = PluginR "email" ["login"] @@ -645,54 +646,81 @@ defaultSetPasswordHandler needOld = do fsAttrs = [("autofocus", "")] } - +parsePassword :: Value -> Parser (Text, Text, Maybe Text) +parsePassword = withObject "password" (\obj -> do + email' <- obj .: "new" + pass <- obj .: "confirm" + curr <- obj .:? "current" + return (email', pass, curr)) postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent postPasswordR = do maid <- lift maybeAuthId + (creds :: Result Value) <- lift parseJsonBody + let jcreds = case creds of + Error _ -> Nothing + Success val -> parseMaybe parsePassword val + let doJsonParsing = isJust jcreds case maid of Nothing -> loginErrorMessageI LoginR Msg.BadSetPass Just aid -> do tm <- getRouteToParent - needOld <- lift $ needOldPassword aid - if not needOld then confirmPassword aid tm else do - current <- lift $ runInputPost $ ireq textField "current" + if not needOld then confirmPassword aid tm jcreds else do + res <- lift $ runInputPostResult $ ireq textField "current" + let fcurrent = case res of + FormSuccess currentPass -> Just currentPass + _ -> Nothing + let current = if doJsonParsing + then getThird jcreds + else fcurrent mrealpass <- lift $ getPassword aid case mrealpass of Nothing -> lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account" Just realpass - | isValidPass current realpass -> confirmPassword aid tm + | isNothing current -> loginErrorMessageI LoginR Msg.BadSetPass + | isValidPass (fromJust current) realpass -> confirmPassword aid tm jcreds | otherwise -> lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again" where msgOk = Msg.PassUpdated - confirmPassword aid tm = do - (new, confirm) <- lift $ runInputPost $ (,) + getThird (Just (_,_,t)) = t + getThird Nothing = Nothing + getNewConfirm (Just (a,b,_)) = Just (a,b) + getNewConfirm _ = Nothing + confirmPassword aid tm jcreds = do + res <- lift $ runInputPostResult $ (,) <$> ireq textField "new" <*> ireq textField "confirm" - - if new /= confirm - then loginErrorMessageI setpassR Msg.PassMismatch - else do - isSecure <- lift $ checkPasswordSecurity aid new - case isSecure of + let creds = if (isJust jcreds) + then getNewConfirm jcreds + else case res of + FormSuccess res' -> Just res' + _ -> Nothing + case creds of + Nothing -> loginErrorMessageI setpassR Msg.PassMismatch + Just (new, confirm) -> + if new /= confirm + then loginErrorMessageI setpassR Msg.PassMismatch + else do + isSecure <- lift $ checkPasswordSecurity aid new + case isSecure of Left e -> lift $ loginErrorMessage (tm setpassR) e Right () -> do - salted <- liftIO $ saltPass new - y <- lift $ do - setPassword aid salted - deleteSession loginLinkKey - addMessageI "success" msgOk - getYesod + salted <- liftIO $ saltPass new + y <- lift $ do + setPassword aid salted + deleteSession loginLinkKey + addMessageI "success" msgOk + getYesod - mr <- lift getMessageRender - selectRep $ do - provideRep $ - fmap asHtml $ lift $ redirect $ afterPasswordRoute y - provideJsonMessage (mr msgOk) + mr <- lift getMessageRender + selectRep $ do + provideRep $ + fmap asHtml $ lift $ redirect $ afterPasswordRoute y + provideJsonMessage (mr msgOk) saltLength :: Int saltLength = 5 From 83575e92a008df979821d244783ad16de9c665ac Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 6 Dec 2016 18:20:18 +0530 Subject: [PATCH 4/9] Fix typo: /s/interoprate/interoperate --- yesod-auth/Yesod/Auth/Email.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 84858a5e..53ad3434 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -8,10 +8,13 @@ {-# LANGUAGE TypeFamilies #-} -- | A Yesod plugin for Authentication via e-mail -- --- This plugin works out of the box by only setting a few methods on the type class --- that tell the plugin how to interoprate with your user data storage (your database). --- However, almost everything is customizeable by setting more methods on the type class. --- In addition, you can send all the form submissions via JSON and completely control the user's flow. +-- This plugin works out of the box by only setting a few methods on +-- the type class that tell the plugin how to interoperate with your +-- user data storage (your database). However, almost everything is +-- customizeable by setting more methods on the type class. In +-- addition, you can send all the form submissions via JSON and +-- completely control the user's flow. +-- -- This is a standard registration e-mail flow -- -- 1) A user registers a new e-mail address, and an e-mail is sent there From 75df4e0468d0718346facf4a0d313d1be0ab4820 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 6 Dec 2016 18:21:36 +0530 Subject: [PATCH 5/9] Use @since for proper haddock rendering --- yesod-auth/Yesod/Auth/Email.hs | 48 +++++++++++++++++----------------- 1 file changed, 24 insertions(+), 24 deletions(-) diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 53ad3434..8580f321 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -86,7 +86,7 @@ setpassR = PluginR "email" ["set-password"] -- | -- --- Since 1.4.5 +-- @since 1.4.5 verifyR :: Text -> Text -> AuthRoute -- FIXME verifyR eid verkey = PluginR "email" ["verify", eid, verkey] @@ -101,7 +101,7 @@ type VerStatus = Bool -- -- Note that any of these other identifiers must not be valid email addresses. -- --- Since 1.2.0 +-- @since 1.2.0 type Identifier = Text -- | Data stored in a database for each e-mail address. @@ -128,22 +128,22 @@ class ( YesodAuth site -- | Add a new email address to the database, but indicate that the address -- has not yet been verified. -- - -- Since 1.1.0 + -- @since 1.1.0 addUnverified :: Email -> VerKey -> HandlerT site IO (AuthEmailId site) -- | Send an email to the given address to verify ownership. -- - -- Since 1.1.0 + -- @since 1.1.0 sendVerifyEmail :: Email -> VerKey -> VerUrl -> HandlerT site IO () -- | Get the verification key for the given email ID. -- - -- Since 1.1.0 + -- @since 1.1.0 getVerifyKey :: AuthEmailId site -> HandlerT site IO (Maybe VerKey) -- | Set the verification key for the given email ID. -- - -- Since 1.1.0 + -- @since 1.1.0 setVerifyKey :: AuthEmailId site -> VerKey -> HandlerT site IO () -- | Verify the email address on the given account. @@ -154,39 +154,39 @@ class ( YesodAuth site -- -- See . -- - -- Since 1.1.0 + -- @since 1.1.0 verifyAccount :: AuthEmailId site -> HandlerT site IO (Maybe (AuthId site)) -- | Get the salted password for the given account. -- - -- Since 1.1.0 + -- @since 1.1.0 getPassword :: AuthId site -> HandlerT site IO (Maybe SaltedPass) -- | Set the salted password for the given account. -- - -- Since 1.1.0 + -- @since 1.1.0 setPassword :: AuthId site -> SaltedPass -> HandlerT site IO () -- | Get the credentials for the given @Identifier@, which may be either an -- email address or some other identification (e.g., username). -- - -- Since 1.2.0 + -- @since 1.2.0 getEmailCreds :: Identifier -> HandlerT site IO (Maybe (EmailCreds site)) -- | Get the email address for the given email ID. -- - -- Since 1.1.0 + -- @since 1.1.0 getEmail :: AuthEmailId site -> HandlerT site IO (Maybe Email) -- | Generate a random alphanumeric string. -- - -- Since 1.1.0 + -- @since 1.1.0 randomKey :: site -> IO Text randomKey _ = Nonce.nonce128urlT defaultNonceGen -- | Route to send user to after password has been set correctly. -- - -- Since 1.2.0 + -- @since 1.2.0 afterPasswordRoute :: site -> Route site -- | Does the user need to provide the current password in order to set a @@ -194,7 +194,7 @@ class ( YesodAuth site -- -- Default: if the user logged in via an email link do not require a password. -- - -- Since 1.2.1 + -- @since 1.2.1 needOldPassword :: AuthId site -> HandlerT site IO Bool needOldPassword aid' = do mkey <- lookupSession loginLinkKey @@ -214,7 +214,7 @@ class ( YesodAuth site -- | Response after sending a confirmation email. -- - -- Since 1.2.2 + -- @since 1.2.2 confirmationEmailSentResponse :: Text -> HandlerT site IO TypedContent confirmationEmailSentResponse identifier = do mr <- getMessageRender @@ -230,7 +230,7 @@ class ( YesodAuth site -- -- Default: Lower case the email address. -- - -- Since 1.2.3 + -- @since 1.2.3 normalizeEmailAddress :: site -> Text -> Text normalizeEmailAddress _ = TS.toLower @@ -240,7 +240,7 @@ class ( YesodAuth site -- -- Default: 'defaultRegisterHandler'. -- - -- Since: 1.2.6. + -- @since: 1.2.6. registerHandler :: AuthHandler site Html registerHandler = defaultRegisterHandler @@ -250,7 +250,7 @@ class ( YesodAuth site -- -- Default: 'defaultForgotPasswordHandler'. -- - -- Since: 1.2.6. + -- @since: 1.2.6. forgotPasswordHandler :: AuthHandler site Html forgotPasswordHandler = defaultForgotPasswordHandler @@ -260,7 +260,7 @@ class ( YesodAuth site -- -- Default: 'defaultSetPasswordHandler'. -- - -- Since: 1.2.6. + -- @since: 1.2.6. setPasswordHandler :: Bool -- ^ Whether the old password is needed. If @True@, a @@ -347,7 +347,7 @@ emailLoginHandler toParent = do return $ renderAuthMessage master langs msg -- | Default implementation of 'registerHandler'. -- --- Since: 1.2.6 +-- @since: 1.2.6 defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html defaultRegisterHandler = do (widget, enctype) <- lift $ generateFormPost registrationForm @@ -444,7 +444,7 @@ getForgotPasswordR = forgotPasswordHandler -- | Default implementation of 'forgotPasswordHandler'. -- --- Since: 1.2.6 +-- @since: 1.2.6 defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html defaultForgotPasswordHandler = do (widget, enctype) <- lift $ generateFormPost forgotPasswordForm @@ -576,7 +576,7 @@ getPasswordR = do -- | Default implementation of 'setPasswordHandler'. -- --- Since: 1.2.6 +-- @since: 1.2.6 defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent defaultSetPasswordHandler needOld = do messageRender <- lift getMessageRender @@ -757,13 +757,13 @@ isValidPass' clear' salted' = -- | Session variable set when user logged in via a login link. See -- 'needOldPassword'. -- --- Since 1.2.1 +-- @since 1.2.1 loginLinkKey :: Text loginLinkKey = "_AUTH_EMAIL_LOGIN_LINK" -- | Set 'loginLinkKey' to the current time. -- --- Since 1.2.1 +-- @since 1.2.1 setLoginLinkKey :: (YesodAuthEmail site, MonadHandler m, HandlerSite m ~ site) => AuthId site -> m () setLoginLinkKey aid = do now <- liftIO getCurrentTime From 47b2877c796e26cc580159ae8018fc56f69a8219 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 6 Dec 2016 18:44:38 +0530 Subject: [PATCH 6/9] More Haddock fixes --- yesod-auth/Yesod/Auth/Email.hs | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 8580f321..44ad119a 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -17,14 +17,17 @@ -- -- This is a standard registration e-mail flow -- --- 1) A user registers a new e-mail address, and an e-mail is sent there --- 2) The user clicks on the registration link in the e-mail --- Note that at this point they are actually logged in (without a password) --- That means that when they log out they will need to reset their password --- 3) The user sets their password and is redirected to the site. --- 4) The user can now --- * logout and sign in --- * reset their password +-- 1. A user registers a new e-mail address, and an e-mail is sent there +-- 2. The user clicks on the registration link in the e-mail. Note that +-- at this point they are actually logged in (without a +-- password). That means that when they log out they will need to +-- reset their password. +-- 3. The user sets their password and is redirected to the site. +-- 4. The user can now +-- +-- * logout and sign in +-- * reset their password +-- module Yesod.Auth.Email ( -- * Plugin authEmail @@ -240,7 +243,7 @@ class ( YesodAuth site -- -- Default: 'defaultRegisterHandler'. -- - -- @since: 1.2.6. + -- @since: 1.2.6 registerHandler :: AuthHandler site Html registerHandler = defaultRegisterHandler @@ -250,7 +253,7 @@ class ( YesodAuth site -- -- Default: 'defaultForgotPasswordHandler'. -- - -- @since: 1.2.6. + -- @since: 1.2.6 forgotPasswordHandler :: AuthHandler site Html forgotPasswordHandler = defaultForgotPasswordHandler @@ -260,7 +263,7 @@ class ( YesodAuth site -- -- Default: 'defaultSetPasswordHandler'. -- - -- @since: 1.2.6. + -- @since: 1.2.6 setPasswordHandler :: Bool -- ^ Whether the old password is needed. If @True@, a @@ -347,7 +350,7 @@ emailLoginHandler toParent = do return $ renderAuthMessage master langs msg -- | Default implementation of 'registerHandler'. -- --- @since: 1.2.6 +-- @since 1.2.6 defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html defaultRegisterHandler = do (widget, enctype) <- lift $ generateFormPost registrationForm @@ -444,7 +447,7 @@ getForgotPasswordR = forgotPasswordHandler -- | Default implementation of 'forgotPasswordHandler'. -- --- @since: 1.2.6 +-- @since 1.2.6 defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html defaultForgotPasswordHandler = do (widget, enctype) <- lift $ generateFormPost forgotPasswordForm @@ -576,7 +579,7 @@ getPasswordR = do -- | Default implementation of 'setPasswordHandler'. -- --- @since: 1.2.6 +-- @since 1.2.6 defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent defaultSetPasswordHandler needOld = do messageRender <- lift getMessageRender From 0255f93c22c14473679cf7f9289691e94d7a26ca Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Tue, 6 Dec 2016 18:44:46 +0530 Subject: [PATCH 7/9] Export croatianMessage --- yesod-auth/Yesod/Auth/Message.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/yesod-auth/Yesod/Auth/Message.hs b/yesod-auth/Yesod/Auth/Message.hs index 83123898..c87afbf8 100644 --- a/yesod-auth/Yesod/Auth/Message.hs +++ b/yesod-auth/Yesod/Auth/Message.hs @@ -13,6 +13,7 @@ module Yesod.Auth.Message , japaneseMessage , finnishMessage , chineseMessage + , croatianMessage , spanishMessage , czechMessage , russianMessage From 8f8c99db88c3276d752a6886a8830c13d927661f Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Wed, 7 Dec 2016 14:08:37 +0530 Subject: [PATCH 8/9] Do parseJsonBody only when form data is not found --- yesod-auth/Yesod/Auth/Email.hs | 29 ++++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 44ad119a..9fa12d52 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -399,13 +399,14 @@ registerHelper allowUsername dest = do y <- lift getYesod checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName pidentifier <- lookupPostParam "email" - (jidentifier :: Result Value) <- lift parseJsonBody - let midentifier = case pidentifier of - Nothing -> case jidentifier of - Error _ -> Nothing - Success val -> parseMaybe parseEmail val - Just _ -> pidentifier - + midentifier <- case pidentifier of + Nothing -> do + (jidentifier :: Result Value) <- lift parseJsonBody + case jidentifier of + Error _ -> return Nothing + Success val -> return $ parseMaybe parseEmail val + Just _ -> return pidentifier + let eidentifier = case midentifier of Nothing -> Left Msg.NoIdentifierProvided Just x @@ -531,12 +532,14 @@ postLoginR = do result <- lift $ runInputPostResult $ (,) <$> ireq textField "email" <*> ireq textField "password" - (creds :: Result Value) <- lift parseJsonBody - let midentifier = case result of - FormSuccess (iden, pass) -> Just (iden, pass) - _ -> case creds of - Error _ -> Nothing - Success val -> parseMaybe parseCreds val + + midentifier <- case result of + FormSuccess (iden, pass) -> return $ Just (iden, pass) + _ -> do + (creds :: Result Value) <- lift parseJsonBody + case creds of + Error _ -> return Nothing + Success val -> return $ parseMaybe parseCreds val case midentifier of Nothing -> loginErrorMessageI LoginR Msg.NoIdentifierProvided From 60f66b4c3a8b1c911d28fb7f14f7d302e678f6e7 Mon Sep 17 00:00:00 2001 From: Sibi Prabakaran Date: Wed, 7 Dec 2016 14:09:01 +0530 Subject: [PATCH 9/9] Add relevant changelog --- yesod-auth/ChangeLog.md | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/yesod-auth/ChangeLog.md b/yesod-auth/ChangeLog.md index 28488334..1948fc24 100644 --- a/yesod-auth/ChangeLog.md +++ b/yesod-auth/ChangeLog.md @@ -1,6 +1,13 @@ +## 1.4.14.1 + +* Add JSON endpoints to Yesod.Auth.Email module +* Export croatianMessage from Message module +* Minor Haddock rendering fixes at Auth.Email module + ## 1.4.14 * Remove Google OpenID link [#1309](https://github.com/yesodweb/yesod/pull/1309) +* Add CSRF Security check in `registerHelperFunction` [#1302](https://github.com/yesodweb/yesod/pull/1302) ## 1.4.13.5