Implement Login via JSON endpoint

Add additional handling of JSON endpoint in addition to the HTML form
method.

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
+    (creds :: Result Value) <- lift parseJsonBody
-    maid <-
+    let midentifier = case result of
-        case ( mecreds >>= emailCredsAuthId
+                        FormSuccess (iden, pass) -> Just (iden, pass)
-             , emailCredsEmail <$> mecreds
+                        _ -> case creds of
-             , emailCredsStatus <$> mecreds
+                               Error _ -> Nothing
-             ) of
+                               Success val -> parseMaybe parseCreds val
-            (Just aid, Just email, Just True) -> do
+                                              
-                mrealpass <- lift $ getPassword aid
+    case midentifier of
-                case mrealpass of
+      Nothing -> loginErrorMessageI LoginR Msg.NoIdentifierProvided
-                    Nothing -> return Nothing
+      Just (identifier, pass) -> do
-                    Just realpass -> return $
+          mecreds <- lift $ getEmailCreds identifier
-                        if isValidPass pass realpass
+          maid <-
-                            then Just email
+              case ( mecreds >>= emailCredsAuthId
-                            else Nothing
+                   , emailCredsEmail <$> mecreds
-            _ -> return Nothing
+                   , emailCredsStatus <$> mecreds
-    let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier
+                   ) of
-    case maid of
+                (Just aid, Just email, Just True) -> do
-        Just email ->
+                       mrealpass <- lift $ getPassword aid
-            lift $ setCredsRedirect $ Creds
+                       case mrealpass of
-                (if isEmail then "email" else "username")
+                         Nothing -> return Nothing
-                email
+                         Just realpass -> return $ if isValidPass pass realpass
-                [("verifiedEmail", email)]
+                                                   then Just email
-        Nothing ->
+                                                   else Nothing
-            loginErrorMessageI LoginR $
+                _ -> return Nothing
-                if isEmail
+          let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier
-                    then Msg.InvalidEmailPass
+          case maid of
-                    else Msg.InvalidUsernamePass
+            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