New YesodMessage stuff

Yesod/Auth.hs

@@ -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
+    renderAuthMessage :: m
-    ----- See gist: https://gist.github.com/778712
+                      -> [Text] -- ^ languages
-    messageNoOpenID :: m -> Html
+                      -> AuthMessage -> Html
-    messageNoOpenID _ = "No OpenID identifier found"
+    renderAuthMessage _ _ = defaultMessage
-    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"
 
 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

Yesod/Auth/Email.hs

@@ -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
+        setTitle $ mr Msg.RegisterLong
-        addHamlet
+        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
+        setTitle $ mr Msg.InvalidKey
-        addHtml
+        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
+        setTitle $ mr Msg.SetPassTitle
-        addHamlet
+        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

Yesod/Auth/Facebook.hs

@@ -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)

Yesod/Auth/Message.hs

@@ -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"

Yesod/Auth/OpenId.hs

@@ -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

yesod-auth.cabal

@@ -51,6 +51,7 @@ library
                      Yesod.Auth.OAuth
                      Yesod.Auth.Rpxnow
                      Yesod.Auth.HashDB
+                     Yesod.Auth.Message
     ghc-options:     -Wall
 
 source-repository head