Converted yesod login screen to monadic form

The form helpers weren't being used which caused the CSRF tokens to not
be present. This also allows for a bit more flexability and
cleans up the code as well.
This commit is contained in:
Alex Kardos 2016-03-03 20:47:13 -07:00
parent 1cae0e38ab
commit 4963f562fe

View File

@ -108,6 +108,7 @@ data EmailCreds site = EmailCreds
}
data UserForm = UserForm { email :: Text }
data UserLoginForm = UserLoginForm { loginEmail :: Text, loginPassword :: Text }
class ( YesodAuth site
, PathPiece (AuthEmailId site)
@ -255,31 +256,62 @@ class ( YesodAuth site
-> AuthHandler site TypedContent
setPasswordHandler = defaultSetPasswordHandler
authEmail :: YesodAuthEmail m => AuthPlugin m
authEmail :: (YesodAuthEmail m) => AuthPlugin m
authEmail =
AuthPlugin "email" dispatch login
where
login tm =
login toParent = do
((_,widget),enctype) <- liftWidgetT $ runFormPost loginForm
[whamlet|
<form method="post" action="@{tm loginR}">
<table>
<tr>
<th>_{Msg.Email}
<td>
<input type="email" name="email" required>
<tr>
<th>_{Msg.Password}
<td>
<input type="password" name="password" required>
<tr>
<td colspan="2">
<button type=submit .btn .btn-success>
_{Msg.LoginViaEmail}
&nbsp;
<a href="@{tm registerR}" .btn .btn-default>
_{Msg.RegisterLong}
<form method="post" action="@{toParent loginR}">
^{widget}
<div>
<button type=submit .btn .btn-success>
_{Msg.LoginViaEmail}
&nbsp;
<a href="@{toParent registerR}" .btn .btn-default>
_{Msg.RegisterLong}
|]
loginForm extra = do
emailMsg <- renderMessage' Msg.Email
let emailSettings = FieldSettings {
fsLabel = SomeMessage Msg.Email,
fsTooltip = Nothing,
fsId = Just "email",
fsName = Just "email",
fsAttrs = [("autofocus", ""), ("placeholder", emailMsg)]
}
(emailRes, emailView) <- mreq emailField emailSettings Nothing
passwordMsg <- renderMessage' Msg.Password
let passwordSettings = FieldSettings {
fsLabel = SomeMessage Msg.Password,
fsTooltip = Nothing,
fsId = Just "password",
fsName = Just "password",
fsAttrs = [("placeholder", passwordMsg)]
}
(passwordRes, passwordView) <- mreq passwordField passwordSettings Nothing
let userRes = UserLoginForm <$> emailRes <*> passwordRes
let widget = do
[whamlet|
#{extra}
<div>
^{fvInput emailView}
<div>
^{fvInput passwordView}
|]
return (userRes, widget)
renderMessage' msg = do
langs <- languages
master <- getYesod
return $ renderAuthMessage master langs msg
dispatch "GET" ["register"] = getRegisterR >>= sendResponse
dispatch "POST" ["register"] = postRegisterR >>= sendResponse
dispatch "GET" ["forgot-password"] = getForgotPasswordR >>= sendResponse