haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Implement Login via JSON endpoint

Browse Source 
Add additional handling of JSON endpoint in addition to the HTML form
method.
This commit is contained in:
Sibi Prabakaran 2016-12-06 15:20:51 +05:30
parent 19840cdc89
commit b6cd72f49f
No known key found for this signature in database
GPG Key ID: D19E3E0EBB557613
1 changed files with 44 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
yesod-auth/Yesod/Auth/Email.hs
View File

@ -512,11 +512,28 @@ $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"
(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
@ -527,8 +544,7 @@ postLoginR = do
mrealpass <- lift $ getPassword aid
case mrealpass of
Nothing -> return Nothing
Just realpass -> return $
if isValidPass pass realpass
Just realpass -> return $ if isValidPass pass realpass
then Just email
else Nothing
_ -> return Nothing