New YesodMessage stuff
This commit is contained in:
Michael Snoyman
parent
ba686f16e9
commit
f864ed4b06
@ -36,8 +36,8 @@ import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8With)
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import Data.Monoid (mconcat)
|
||||
import Web.Routes.Quasi (toSinglePiece, fromSinglePiece)
|
||||
import Yesod.Auth.Message (AuthMessage, defaultMessage)
|
||||
|
||||
data Auth = Auth
|
||||
|
||||
@ -82,53 +82,10 @@ class (Yesod m, SinglePiece (AuthId m)) => YesodAuth m where
|
||||
tm <- lift getRouteToMaster
|
||||
mapM_ (flip apLogin tm) authPlugins
|
||||
|
||||
----- Message strings. In theory in the future make this localizable
|
||||
----- See gist: https://gist.github.com/778712
|
||||
messageNoOpenID :: m -> Html
|
||||
messageNoOpenID _ = "No OpenID identifier found"
|
||||
messageLoginOpenID :: m -> Html
|
||||
messageLoginOpenID _ = "Login via OpenID"
|
||||
|
||||
messageEmail :: m -> Html
|
||||
messageEmail _ = "Email"
|
||||
messagePassword :: m -> Html
|
||||
messagePassword _ = "Password"
|
||||
messageRegister :: m -> Html
|
||||
messageRegister _ = "Register"
|
||||
messageRegisterLong :: m -> Html
|
||||
messageRegisterLong _ = "Register a new account"
|
||||
messageEnterEmail :: m -> Html
|
||||
messageEnterEmail _ = "Enter your e-mail address below, and a confirmation e-mail will be sent to you."
|
||||
messageConfirmationEmailSentTitle :: m -> Html
|
||||
messageConfirmationEmailSentTitle _ = "Confirmation e-mail sent"
|
||||
messageConfirmationEmailSent :: m -> Text -> Html
|
||||
messageConfirmationEmailSent _ email = toHtml $ mconcat
|
||||
["A confirmation e-mail has been sent to ", email, "."]
|
||||
messageAddressVerified :: m -> Html
|
||||
messageAddressVerified _ = "Address verified, please set a new password"
|
||||
messageInvalidKeyTitle :: m -> Html
|
||||
messageInvalidKeyTitle _ = "Invalid verification key"
|
||||
messageInvalidKey :: m -> Html
|
||||
messageInvalidKey _ = "I'm sorry, but that was an invalid verification key."
|
||||
messageInvalidEmailPass :: m -> Html
|
||||
messageInvalidEmailPass _ = "Invalid email/password combination"
|
||||
messageBadSetPass :: m -> Html
|
||||
messageBadSetPass _ = "You must be logged in to set a password"
|
||||
messageSetPassTitle :: m -> Html
|
||||
messageSetPassTitle _ = "Set password"
|
||||
messageSetPass :: m -> Html
|
||||
messageSetPass _ = "Set a new password"
|
||||
messageNewPass :: m -> Html
|
||||
messageNewPass _ = "New password"
|
||||
messageConfirmPass :: m -> Html
|
||||
messageConfirmPass _ = "Confirm"
|
||||
messagePassMismatch :: m -> Html
|
||||
messagePassMismatch _ = "Passwords did not match, please try again"
|
||||
messagePassUpdated :: m -> Html
|
||||
messagePassUpdated _ = "Password updated"
|
||||
|
||||
messageFacebook :: m -> Html
|
||||
messageFacebook _ = "Login with Facebook"
|
||||
renderAuthMessage :: m
|
||||
-> [Text] -- ^ languages
|
||||
-> AuthMessage -> Html
|
||||
renderAuthMessage _ _ = defaultMessage
|
||||
|
||||
type Texts = [Text]
|
||||
|
||||
@ -268,3 +225,7 @@ redirectLogin = do
|
||||
case authRoute y of
|
||||
Just z -> redirect RedirectTemporary z
|
||||
Nothing -> permissionDenied "Please configure authRoute"
|
||||
|
||||
instance YesodAuth m => YesodMessage Auth m where
|
||||
type Message Auth m = AuthMessage
|
||||
renderMessage = const renderAuthMessage
|
||||
|
||||
@ -30,10 +30,10 @@ import Yesod.Handler
|
||||
import Yesod.Content
|
||||
import Yesod.Widget
|
||||
import Yesod.Core
|
||||
import Text.Hamlet (hamlet)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Web.Routes.Quasi (toSinglePiece, fromSinglePiece)
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
|
||||
loginR, registerR, setpassR :: AuthRoute
|
||||
loginR = PluginR "email" ["login"]
|
||||
@ -80,24 +80,26 @@ authEmail :: YesodAuthEmail m => AuthPlugin m
|
||||
authEmail =
|
||||
AuthPlugin "email" dispatch $ \tm -> do
|
||||
y <- lift getYesod
|
||||
l <- lift languages
|
||||
let mr = renderMessage (getAuth 'x') y l
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
[whamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
[$whamlet|
|
||||
#endif
|
||||
<form method="post" action="@{tm loginR}">
|
||||
<table>
|
||||
<tr>
|
||||
<th>#{messageEmail y}
|
||||
<th>#{mr Msg.Email}
|
||||
<td>
|
||||
<input type="email" name="email">
|
||||
<tr>
|
||||
<th>#{messagePassword y}
|
||||
<th>#{mr Msg.Password}
|
||||
<td>
|
||||
<input type="password" name="password">
|
||||
<tr>
|
||||
<td colspan="2">
|
||||
<input type="submit" value="Login via email">
|
||||
<input type="submit" value=#{mr Msg.LoginViaEmail}>
|
||||
<a href="@{tm registerR}">I don't have an account
|
||||
|]
|
||||
where
|
||||
@ -114,21 +116,21 @@ authEmail =
|
||||
|
||||
getRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml
|
||||
getRegisterR = do
|
||||
y <- getYesod
|
||||
toMaster <- getRouteToMaster
|
||||
mr <- getMessageRender
|
||||
defaultLayout $ do
|
||||
setTitle $ messageRegisterLong y
|
||||
addHamlet
|
||||
setTitle $ mr Msg.RegisterLong
|
||||
addWidget
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
[whamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
[$whamlet|
|
||||
#endif
|
||||
<p>#{messageEnterEmail y}
|
||||
<p>_{Msg.EnterEmail}
|
||||
<form method="post" action="@{toMaster registerR}">
|
||||
<label for="email">#{messageEmail y}
|
||||
<label for="email">_{Msg.Email}
|
||||
<input type="email" name="email" width="150">
|
||||
<input type="submit" value="#{messageRegister y}">
|
||||
<input type="submit" value=_{Msg.Register}>
|
||||
|]
|
||||
|
||||
postRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml
|
||||
@ -151,15 +153,16 @@ postRegisterR = do
|
||||
tm <- getRouteToMaster
|
||||
let verUrl = render $ tm $ verify (toSinglePiece lid) verKey
|
||||
sendVerifyEmail email verKey verUrl
|
||||
mr <- getMessageRender
|
||||
defaultLayout $ do
|
||||
setTitle $ messageConfirmationEmailSentTitle y
|
||||
setTitle $ mr Msg.ConfirmationEmailSentTitle
|
||||
addWidget
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
[whamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
[$whamlet|
|
||||
#endif
|
||||
<p>#{messageConfirmationEmailSent y email}
|
||||
<p>_{Msg.ConfirmationEmailSent email}
|
||||
|]
|
||||
|
||||
getVerifyR :: YesodAuthEmail m
|
||||
@ -167,7 +170,6 @@ getVerifyR :: YesodAuthEmail m
|
||||
getVerifyR lid key = do
|
||||
realKey <- getVerifyKey lid
|
||||
memail <- getEmail lid
|
||||
y <- getYesod
|
||||
case (realKey == Just key, memail) of
|
||||
(True, Just email) -> do
|
||||
muid <- verifyAccount lid
|
||||
@ -176,18 +178,20 @@ getVerifyR lid key = do
|
||||
Just _uid -> do
|
||||
setCreds False $ Creds "email" email [("verifiedEmail", email)] -- FIXME uid?
|
||||
toMaster <- getRouteToMaster
|
||||
setMessage $ messageAddressVerified y
|
||||
mr <- getMessageRender
|
||||
setMessage $ mr Msg.AddressVerified
|
||||
redirect RedirectTemporary $ toMaster setpassR
|
||||
_ -> return ()
|
||||
mr <- getMessageRender
|
||||
defaultLayout $ do
|
||||
setTitle $ messageInvalidKey y
|
||||
addHtml
|
||||
setTitle $ mr Msg.InvalidKey
|
||||
addWidget
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
[whamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
[$whamlet|
|
||||
#endif
|
||||
<p>#{messageInvalidKey y}
|
||||
<p>_{Msg.InvalidKey}
|
||||
|]
|
||||
|
||||
postLoginR :: YesodAuthEmail master => GHandler Auth master ()
|
||||
@ -212,7 +216,8 @@ postLoginR = do
|
||||
setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid?
|
||||
Nothing -> do
|
||||
y <- getYesod
|
||||
setMessage $ messageInvalidEmailPass y
|
||||
mr <- getMessageRender
|
||||
setMessage $ mr Msg.InvalidEmailPass
|
||||
toMaster <- getRouteToMaster
|
||||
redirect RedirectTemporary $ toMaster LoginR
|
||||
|
||||
@ -220,34 +225,34 @@ getPasswordR :: YesodAuthEmail master => GHandler Auth master RepHtml
|
||||
getPasswordR = do
|
||||
toMaster <- getRouteToMaster
|
||||
maid <- maybeAuthId
|
||||
y <- getYesod
|
||||
mr <- getMessageRender
|
||||
case maid of
|
||||
Just _ -> return ()
|
||||
Nothing -> do
|
||||
setMessage $ messageBadSetPass y
|
||||
setMessage $ mr Msg.BadSetPass
|
||||
redirect RedirectTemporary $ toMaster loginR
|
||||
defaultLayout $ do
|
||||
setTitle $ messageSetPassTitle y
|
||||
addHamlet
|
||||
setTitle $ mr Msg.SetPassTitle
|
||||
addWidget
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
[whamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
[$whamlet|
|
||||
#endif
|
||||
<h3>#{messageSetPass y}
|
||||
<h3>_{Msg.SetPass}
|
||||
<form method="post" action="@{toMaster setpassR}">
|
||||
<table>
|
||||
<tr>
|
||||
<th>#{messageNewPass y}
|
||||
<th>_{Msg.NewPass}
|
||||
<td>
|
||||
<input type="password" name="new">
|
||||
<tr>
|
||||
<th>#{messageConfirmPass y}
|
||||
<th>_{Msg.ConfirmPass}
|
||||
<td>
|
||||
<input type="password" name="confirm">
|
||||
<tr>
|
||||
<td colspan="2">
|
||||
<input type="submit" value="#{messageSetPassTitle y}">
|
||||
<input type="submit" value="_{Msg.SetPassTitle}">
|
||||
|]
|
||||
|
||||
postPasswordR :: YesodAuthEmail master => GHandler Auth master ()
|
||||
@ -258,17 +263,20 @@ postPasswordR = do
|
||||
toMaster <- getRouteToMaster
|
||||
y <- getYesod
|
||||
when (new /= confirm) $ do
|
||||
setMessage $ messagePassMismatch y
|
||||
mr <- getMessageRender
|
||||
setMessage $ mr Msg.PassMismatch
|
||||
redirect RedirectTemporary $ toMaster setpassR
|
||||
maid <- maybeAuthId
|
||||
aid <- case maid of
|
||||
Nothing -> do
|
||||
setMessage $ messageBadSetPass y
|
||||
mr <- getMessageRender
|
||||
setMessage $ mr Msg.BadSetPass
|
||||
redirect RedirectTemporary $ toMaster loginR
|
||||
Just aid -> return aid
|
||||
salted <- liftIO $ saltPass new
|
||||
setPassword aid salted
|
||||
setMessage $ messagePassUpdated y
|
||||
mr <- getMessageRender
|
||||
setMessage $ mr Msg.PassUpdated
|
||||
redirect RedirectTemporary $ loginDest y
|
||||
|
||||
saltLength :: Int
|
||||
|
||||
@ -15,6 +15,7 @@ import Data.Maybe (fromMaybe)
|
||||
import Yesod.Form
|
||||
import Yesod.Handler
|
||||
import Yesod.Widget
|
||||
import Yesod.Request (languages)
|
||||
import Text.Hamlet (hamlet)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
@ -22,6 +23,7 @@ import Data.Text (Text)
|
||||
import Control.Monad (mzero)
|
||||
import Data.Monoid (mappend)
|
||||
import qualified Data.Aeson.Types
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
|
||||
facebookUrl :: AuthRoute
|
||||
facebookUrl = PluginR "facebook" ["forward"]
|
||||
@ -57,6 +59,8 @@ authFacebook cid secret perms =
|
||||
let fb = Facebook.Facebook cid secret $ render $ tm url
|
||||
let furl = Facebook.getForwardUrl fb $ perms
|
||||
y <- lift getYesod
|
||||
l <- lift languages
|
||||
let mr = renderMessage (getAuth 'x') y l
|
||||
addHtml
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
@ -64,7 +68,7 @@ authFacebook cid secret perms =
|
||||
[$hamlet|
|
||||
#endif
|
||||
<p>
|
||||
<a href="#{furl}">#{messageFacebook y}
|
||||
<a href="#{furl}">#{mr Msg.Facebook}
|
||||
|]
|
||||
|
||||
parseCreds :: Text -> Value -> Data.Aeson.Types.Parser (Creds m)
|
||||
|
||||
60
Yesod/Auth/Message.hs
Normal file
60
Yesod/Auth/Message.hs
Normal file
@ -0,0 +1,60 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Yesod.Auth.Message
|
||||
( AuthMessage (..)
|
||||
, defaultMessage
|
||||
) where
|
||||
|
||||
import Text.Blaze (Html, toHtml)
|
||||
import Data.Monoid (mappend)
|
||||
import Data.Text (Text)
|
||||
|
||||
data AuthMessage =
|
||||
NoOpenID
|
||||
| LoginOpenID
|
||||
| Email
|
||||
| Password
|
||||
| Register
|
||||
| RegisterLong
|
||||
| EnterEmail
|
||||
| ConfirmationEmailSentTitle
|
||||
| ConfirmationEmailSent Text
|
||||
| AddressVerified
|
||||
| InvalidKeyTitle
|
||||
| InvalidKey
|
||||
| InvalidEmailPass
|
||||
| BadSetPass
|
||||
| SetPassTitle
|
||||
| SetPass
|
||||
| NewPass
|
||||
| ConfirmPass
|
||||
| PassMismatch
|
||||
| PassUpdated
|
||||
| Facebook
|
||||
| LoginViaEmail
|
||||
|
||||
defaultMessage :: AuthMessage -> Html
|
||||
defaultMessage NoOpenID = "No OpenID identifier found"
|
||||
defaultMessage LoginOpenID = "Login via OpenID"
|
||||
defaultMessage Email = "Email"
|
||||
defaultMessage Password = "Password"
|
||||
defaultMessage Register = "Register"
|
||||
defaultMessage RegisterLong = "Register a new account"
|
||||
defaultMessage EnterEmail = "Enter your e-mail address below, and a confirmation e-mail will be sent to you."
|
||||
defaultMessage ConfirmationEmailSentTitle = "Confirmation e-mail sent"
|
||||
defaultMessage (ConfirmationEmailSent email) =
|
||||
"A confirmation e-mail has been sent to " `mappend`
|
||||
toHtml email `mappend`
|
||||
"."
|
||||
defaultMessage AddressVerified = "Address verified, please set a new password"
|
||||
defaultMessage InvalidKeyTitle = "Invalid verification key"
|
||||
defaultMessage InvalidKey = "I'm sorry, but that was an invalid verification key."
|
||||
defaultMessage InvalidEmailPass = "Invalid email/password combination"
|
||||
defaultMessage BadSetPass = "You must be logged in to set a password"
|
||||
defaultMessage SetPassTitle = "Set password"
|
||||
defaultMessage SetPass = "Set a new password"
|
||||
defaultMessage NewPass = "New password"
|
||||
defaultMessage ConfirmPass = "Confirm"
|
||||
defaultMessage PassMismatch = "Passwords did not match, please try again"
|
||||
defaultMessage PassUpdated = "Password updated"
|
||||
defaultMessage Facebook = "Login with Facebook"
|
||||
defaultMessage LoginViaEmail = "Login via email"
|
||||
@ -19,6 +19,7 @@ import Text.Cassius (cassius)
|
||||
import Text.Blaze (toHtml)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Data.Text (Text)
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
|
||||
forwardUrl :: AuthRoute
|
||||
forwardUrl = PluginR "openid" ["forward"]
|
||||
@ -41,6 +42,8 @@ authOpenId =
|
||||
background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%;
|
||||
padding-left: 18px;
|
||||
|]
|
||||
l <- lift languages
|
||||
let mr = renderMessage (getAuth 'x') y l
|
||||
addHamlet
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
@ -50,7 +53,7 @@ authOpenId =
|
||||
<form method="get" action="@{tm forwardUrl}">
|
||||
<label for="#{ident}">OpenID:
|
||||
<input id="#{ident}" type="text" name="#{name}" value="http://">
|
||||
<input type="submit" value="#{messageLoginOpenID y}">
|
||||
<input type="submit" value="#{mr Msg.LoginOpenID}">
|
||||
|]
|
||||
dispatch "GET" ["forward"] = do
|
||||
(roid, _, _) <- runFormGet $ stringInput name
|
||||
@ -70,7 +73,8 @@ authOpenId =
|
||||
res
|
||||
_ -> do
|
||||
toMaster <- getRouteToMaster
|
||||
setMessage $ messageNoOpenID y
|
||||
mr <- getMessageRender
|
||||
setMessage $ mr Msg.NoOpenID
|
||||
redirect RedirectTemporary $ toMaster LoginR
|
||||
dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
|
||||
dispatch "GET" ["complete"] = do
|
||||
|
||||
@ -51,6 +51,7 @@ library
|
||||
Yesod.Auth.OAuth
|
||||
Yesod.Auth.Rpxnow
|
||||
Yesod.Auth.HashDB
|
||||
Yesod.Auth.Message
|
||||
ghc-options: -Wall
|
||||
|
||||
source-repository head
|
||||
|
||||
Loading…
Reference in New Issue
Block a user