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:
parent
1cae0e38ab
commit
4963f562fe
@ -108,6 +108,7 @@ data EmailCreds site = EmailCreds
|
|||||||
}
|
}
|
||||||
|
|
||||||
data UserForm = UserForm { email :: Text }
|
data UserForm = UserForm { email :: Text }
|
||||||
|
data UserLoginForm = UserLoginForm { loginEmail :: Text, loginPassword :: Text }
|
||||||
|
|
||||||
class ( YesodAuth site
|
class ( YesodAuth site
|
||||||
, PathPiece (AuthEmailId site)
|
, PathPiece (AuthEmailId site)
|
||||||
@ -255,31 +256,62 @@ class ( YesodAuth site
|
|||||||
-> AuthHandler site TypedContent
|
-> AuthHandler site TypedContent
|
||||||
setPasswordHandler = defaultSetPasswordHandler
|
setPasswordHandler = defaultSetPasswordHandler
|
||||||
|
|
||||||
|
authEmail :: (YesodAuthEmail m) => AuthPlugin m
|
||||||
authEmail :: YesodAuthEmail m => AuthPlugin m
|
|
||||||
authEmail =
|
authEmail =
|
||||||
AuthPlugin "email" dispatch login
|
AuthPlugin "email" dispatch login
|
||||||
where
|
where
|
||||||
login tm =
|
login toParent = do
|
||||||
|
((_,widget),enctype) <- liftWidgetT $ runFormPost loginForm
|
||||||
|
|
||||||
[whamlet|
|
[whamlet|
|
||||||
<form method="post" action="@{tm loginR}">
|
<form method="post" action="@{toParent loginR}">
|
||||||
<table>
|
^{widget}
|
||||||
<tr>
|
<div>
|
||||||
<th>_{Msg.Email}
|
<button type=submit .btn .btn-success>
|
||||||
<td>
|
_{Msg.LoginViaEmail}
|
||||||
<input type="email" name="email" required>
|
|
||||||
<tr>
|
<a href="@{toParent registerR}" .btn .btn-default>
|
||||||
<th>_{Msg.Password}
|
_{Msg.RegisterLong}
|
||||||
<td>
|
|
||||||
<input type="password" name="password" required>
|
|
||||||
<tr>
|
|
||||||
<td colspan="2">
|
|
||||||
<button type=submit .btn .btn-success>
|
|
||||||
_{Msg.LoginViaEmail}
|
|
||||||
|
|
||||||
<a href="@{tm 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 "GET" ["register"] = getRegisterR >>= sendResponse
|
||||||
dispatch "POST" ["register"] = postRegisterR >>= sendResponse
|
dispatch "POST" ["register"] = postRegisterR >>= sendResponse
|
||||||
dispatch "GET" ["forgot-password"] = getForgotPasswordR >>= sendResponse
|
dispatch "GET" ["forgot-password"] = getForgotPasswordR >>= sendResponse
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user