module Yesod.Auth.Account(
Username
, newAccountR
, resetPasswordR
, accountPlugin
, LoginData(..)
, loginForm
, loginFormPostTargetR
, loginWidget
, verifyR
, NewAccountData(..)
, newAccountForm
, newAccountWidget
, createNewAccount
, resendVerifyEmailForm
, resendVerifyR
, resendVerifyEmailWidget
, newPasswordR
, resetPasswordForm
, resetPasswordWidget
, NewPasswordData(..)
, newPasswordForm
, setPasswordR
, newPasswordWidget
, UserCredentials(..)
, PersistUserCredentials(..)
, AccountDB(..)
, AccountSendEmail(..)
, AccountPersistDB
, runAccountPersistDB
, YesodAuthAccount(..)
, hashPassword
, verifyPassword
, newVerifyKey
) where
import Control.Applicative
import Control.Monad.Reader hiding (lift)
import Data.Char (isAlphaNum)
import System.Random (newStdGen, randoms)
import Text.Blaze.Html (toHtml)
import qualified Crypto.PasswordStore as PS
import qualified Data.ByteString as B
import qualified Data.ByteString.Base64.URL as B64
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Database.Persist as P
import qualified Database.Persist.Query.Internal as P (Update)
import Yesod.Core
import Yesod.Form
import Yesod.Auth
import Yesod.Persist hiding (get, replace, insertKey, Entity, entityVal)
import qualified Yesod.Auth.Message as Msg
type Username = T.Text
accountPlugin :: YesodAuthAccount db master => AuthPlugin master
accountPlugin = AuthPlugin "account" dispatch loginWidget
where dispatch "POST" ["login"] = postLoginR >>= sendResponse
dispatch "GET" ["newaccount"] = getNewAccountR >>= sendResponse
dispatch "POST" ["newaccount"] = postNewAccountR >>= sendResponse
dispatch "GET" ["resetpassword"] = getResetPasswordR >>= sendResponse
dispatch "POST" ["resetpassword"] = postResetPasswordR >>= sendResponse
dispatch "GET" ["verify", u, k] = getVerifyR u k >>= sendResponse
dispatch "GET" ["newpassword", u, k] = getNewPasswordR u k >>= sendResponse
dispatch "POST" ["setpassword"] = postSetPasswordR >>= sendResponse
dispatch "POST" ["resendverifyemail"] = postResendVerifyEmailR >>= sendResponse
dispatch _ _ = notFound
loginFormPostTargetR :: AuthRoute
loginFormPostTargetR = PluginR "account" ["login"]
newAccountR :: AuthRoute
newAccountR = PluginR "account" ["newaccount"]
resetPasswordR :: AuthRoute
resetPasswordR = PluginR "account" ["resetpassword"]
verifyR :: Username
-> T.Text
-> AuthRoute
verifyR u k = PluginR "account" ["verify", u, k]
resendVerifyR :: AuthRoute
resendVerifyR = PluginR "account" ["resendverifyemail"]
newPasswordR :: Username
-> T.Text
-> AuthRoute
newPasswordR u k = PluginR "account" ["newpassword", u, k]
setPasswordR :: AuthRoute
setPasswordR = PluginR "account" ["setpassword"]
data AccountMsg = MsgUsername
| MsgForgotPassword
| MsgInvalidUsername
| MsgInvalidUserOrPwd
| MsgUsernameExists T.Text
| MsgResendVerifyEmail
| MsgResetPwdTitle
| MsgSendResetPwdEmail
| MsgResetPwdEmailSent
| MsgEmailVerified
| MsgEmailUnverified
instance RenderMessage m AccountMsg where
renderMessage _ _ MsgUsername = "Username"
renderMessage _ _ MsgForgotPassword = "Forgot password?"
renderMessage _ _ MsgInvalidUsername = "Invalid username"
renderMessage _ _ MsgInvalidUserOrPwd = "Invalid username or password"
renderMessage _ _ (MsgUsernameExists u) =
T.concat ["The username ", u, " already exists. Please choose an alternate username."]
renderMessage _ _ MsgResendVerifyEmail = "Resend verification email"
renderMessage _ _ MsgResetPwdTitle = "Reset your password"
renderMessage _ _ MsgSendResetPwdEmail = "Send email to reset password"
renderMessage _ _ MsgResetPwdEmailSent = "A password reset email has been sent to your email address."
renderMessage _ _ MsgEmailVerified = "Your email has been verified."
renderMessage _ _ MsgEmailUnverified = "Your email has not yet been verified."
data LoginData = LoginData {
loginUsername :: T.Text
, loginPassword :: T.Text
} deriving Show
loginForm :: YesodAuthAccount db master => AForm s master LoginData
loginForm = LoginData <$> areq (checkM checkValidUsername textField) userSettings Nothing
<*> areq passwordField pwdSettings Nothing
where userSettings = FieldSettings (SomeMessage MsgUsername) Nothing (Just "username") Nothing []
pwdSettings = FieldSettings (SomeMessage Msg.Password) Nothing (Just "password") Nothing []
loginWidget :: YesodAuthAccount db master => (Route Auth -> Route master) -> GWidget s master ()
loginWidget tm = do
((_,widget), enctype) <- lift $ runFormPostNoToken $ renderDivs loginForm
[whamlet|
<div .loginDiv>
<form method=post enctype=#{enctype} action=@{tm loginFormPostTargetR}>
^{widget}
<input type=submit value=_{Msg.LoginTitle}>
<p>
<a href="@{tm newAccountR}">_{Msg.RegisterLong}
<a href="@{tm resetPasswordR}">_{MsgForgotPassword}
|]
postLoginR :: YesodAuthAccount db master => GHandler Auth master RepHtml
postLoginR = do
((result, _), _) <- runFormPostNoToken $ renderDivs loginForm
mr <- getMessageRender
muser <- case result of
FormMissing -> invalidArgs ["Form is missing"]
FormFailure msg -> return $ Left msg
FormSuccess (LoginData uname pwd) -> do
mu <- runAccountDB $ loadUser uname
case mu of
Nothing -> return $ Left [mr MsgInvalidUserOrPwd]
Just u -> return $
if verifyPassword pwd (userPasswordHash u)
then Right u
else Left [mr MsgInvalidUserOrPwd]
tm <- getRouteToMaster
case muser of
Left errs -> do
setMessage $ toHtml $ T.concat errs
redirect $ tm LoginR
Right u -> if userEmailVerified u
then do setCreds True $ Creds "account" (username u) []
badMethod
else unregisteredLogin u
data NewAccountData = NewAccountData {
newAccountUsername :: Username
, newAccountEmail :: T.Text
, newAccountPassword1 :: T.Text
, newAccountPassword2 :: T.Text
} deriving Show
newAccountForm :: (YesodAuth m, RenderMessage m FormMessage) => AForm s m NewAccountData
newAccountForm = NewAccountData <$> areq textField userSettings Nothing
<*> areq emailField emailSettings Nothing
<*> areq passwordField pwdSettings1 Nothing
<*> areq passwordField pwdSettings2 Nothing
where userSettings = FieldSettings (SomeMessage MsgUsername) Nothing Nothing Nothing []
emailSettings = FieldSettings (SomeMessage Msg.Email) Nothing Nothing Nothing []
pwdSettings1 = FieldSettings (SomeMessage Msg.Password) Nothing Nothing Nothing []
pwdSettings2 = FieldSettings (SomeMessage Msg.ConfirmPass) Nothing Nothing Nothing []
newAccountWidget :: (YesodAuth m, RenderMessage m FormMessage) => (Route Auth -> Route m) -> GWidget s m ()
newAccountWidget tm = do
((_,widget), enctype) <- lift $ runFormPost $ renderDivs newAccountForm
[whamlet|
<div .newaccountDiv>
<form method=post enctype=#{enctype} action=@{tm newAccountR}>
^{widget}
<input type=submit value=_{Msg.Register}>
|]
createNewAccount :: YesodAuthAccount db master => NewAccountData -> (Route Auth -> Route master) -> GHandler s master (UserAccount db)
createNewAccount (NewAccountData u email pwd _) tm = do
muser <- runAccountDB $ loadUser u
case muser of
Just _ -> do setMessageI $ MsgUsernameExists u
redirect $ tm newAccountR
Nothing -> return ()
key <- newVerifyKey
hashed <- hashPassword pwd
mnew <- runAccountDB $ addNewUser u email key hashed
new <- case mnew of
Left err -> do setMessage $ toHtml err
redirect $ tm newAccountR
Right x -> return x
render <- getUrlRender
sendVerifyEmail u email $ render $ tm $ verifyR u key
setMessageI $ Msg.ConfirmationEmailSent email
return new
getVerifyR :: YesodAuthAccount db master => Username -> T.Text -> GHandler Auth master ()
getVerifyR uname k = do
tm <- getRouteToMaster
muser <- runAccountDB $ loadUser uname
case muser of
Nothing -> do setMessageI Msg.InvalidKey
redirect $ tm LoginR
Just user -> do when ( userEmailVerifyKey user == ""
|| userEmailVerifyKey user /= k
|| userEmailVerified user
) $ do
setMessageI Msg.InvalidKey
redirect $ tm LoginR
runAccountDB $ verifyAccount user
setMessageI MsgEmailVerified
setCreds True $ Creds "account" uname []
resendVerifyEmailForm :: RenderMessage m FormMessage => Username -> AForm s m Username
resendVerifyEmailForm u = areq hiddenField "" $ Just u
resendVerifyEmailWidget :: RenderMessage m FormMessage => Username -> (Route Auth -> Route m) -> GWidget s m ()
resendVerifyEmailWidget u tm = do
((_,widget), enctype) <- lift $ runFormPost $ renderDivs $ resendVerifyEmailForm u
[whamlet|
<div .resendVerifyEmailDiv>
<form method=post enctype=#{enctype} action=@{tm resendVerifyR}>
^{widget}
<input type=submit value=_{MsgResendVerifyEmail}>
|]
postResendVerifyEmailR :: YesodAuthAccount db master => GHandler Auth master ()
postResendVerifyEmailR = do
((result, _), _) <- runFormPost $ renderDivs $ resendVerifyEmailForm ""
muser <- case result of
FormMissing -> invalidArgs ["Form is missing"]
FormFailure msg -> invalidArgs msg
FormSuccess uname -> runAccountDB $ loadUser uname
case muser of
Nothing -> invalidArgs ["Invalid username"]
Just u -> do
key <- newVerifyKey
tm <- getRouteToMaster
runAccountDB $ setVerifyKey u key
render <- getUrlRender
sendVerifyEmail (username u) (userEmail u) $ render $ tm $ verifyR (username u) key
setMessageI $ Msg.ConfirmationEmailSent (userEmail u)
redirect $ tm LoginR
resetPasswordForm :: RenderMessage m FormMessage => AForm s m Username
resetPasswordForm = areq textField userSettings Nothing
where userSettings = FieldSettings (SomeMessage MsgUsername) Nothing (Just "username") Nothing []
resetPasswordWidget :: RenderMessage m FormMessage => (Route Auth -> Route m) -> GWidget s m ()
resetPasswordWidget tm = do
((_,widget), enctype) <- lift $ runFormPost $ renderDivs resetPasswordForm
[whamlet|
<div .resetPasswordDiv>
<form method=post enctype=#{enctype} action=@{tm resetPasswordR}>
^{widget}
<input type=submit value=_{MsgSendResetPwdEmail}>
|]
postResetPasswordR :: YesodAuthAccount db master => GHandler Auth master RepHtml
postResetPasswordR = do
allow <- allowPasswordReset <$> getYesod
unless allow notFound
tm <- getRouteToMaster
((result, _), _) <- runFormPost $ renderDivs resetPasswordForm
mdata <- case result of
FormMissing -> invalidArgs ["Form is missing"]
FormFailure msg -> return $ Left msg
FormSuccess uname -> Right <$> runAccountDB (loadUser uname)
case mdata of
Left errs -> do
setMessage $ toHtml $ T.concat errs
redirect $ tm LoginR
Right Nothing -> do
setMessageI MsgInvalidUsername
redirect $ tm resetPasswordR
Right (Just u) -> do key <- newVerifyKey
runAccountDB $ setNewPasswordKey u key
render <- getUrlRender
sendNewPasswordEmail (username u) (userEmail u) $ render $ tm $ newPasswordR (username u) key
setMessageI MsgResetPwdEmailSent
redirect $ tm LoginR
data NewPasswordData = NewPasswordData {
newPasswordUser :: Username
, newPasswordKey :: T.Text
, newPasswordPwd1 :: T.Text
, newPasswordPwd2 :: T.Text
} deriving Show
newPasswordForm :: (YesodAuth m, RenderMessage m FormMessage)
=> Username
-> T.Text
-> AForm s m NewPasswordData
newPasswordForm u k = NewPasswordData <$> areq hiddenField "" (Just u)
<*> areq hiddenField "" (Just k)
<*> areq passwordField pwdSettings1 Nothing
<*> areq passwordField pwdSettings2 Nothing
where pwdSettings1 = FieldSettings (SomeMessage Msg.NewPass) Nothing Nothing Nothing []
pwdSettings2 = FieldSettings (SomeMessage Msg.ConfirmPass) Nothing Nothing Nothing []
newPasswordWidget :: YesodAuthAccount db master => UserAccount db -> (Route Auth -> Route master) -> GWidget s master ()
newPasswordWidget user tm = do
let key = userResetPwdKey user
((_,widget), enctype) <- lift $ runFormPost $ renderDivs (newPasswordForm (username user) key)
[whamlet|
<div .newpassDiv>
<p>_{Msg.SetPass}
<form method=post enctype=#{enctype} action=@{tm setPasswordR}>
^{widget}
<input type=submit value=_{Msg.SetPassTitle}>
|]
getNewPasswordR :: YesodAuthAccount db master => Username -> T.Text -> GHandler Auth master RepHtml
getNewPasswordR uname k = do
allow <- allowPasswordReset <$> getYesod
unless allow notFound
muser <- runAccountDB $ loadUser uname
tm <- getRouteToMaster
case muser of
Just user | userResetPwdKey user /= "" && userResetPwdKey user == k ->
setPasswordHandler user
_ -> do setMessageI Msg.InvalidKey
redirect $ tm LoginR
postSetPasswordR :: YesodAuthAccount db master => GHandler Auth master ()
postSetPasswordR = do
allow <- allowPasswordReset <$> getYesod
unless allow notFound
tm <- getRouteToMaster
((result,_), _) <- runFormPost $ renderDivs (newPasswordForm "" "")
mnew <- case result of
FormMissing -> invalidArgs ["Form is missing"]
FormFailure msg -> return $ Left msg
FormSuccess d | newPasswordPwd1 d == newPasswordPwd2 d -> return $ Right d
FormSuccess d -> do setMessageI Msg.PassMismatch
redirect $ tm $ newPasswordR (newPasswordUser d) (newPasswordKey d)
case mnew of
Left errs -> do
setMessage $ toHtml $ T.concat errs
redirect $ tm LoginR
Right d -> do muser <- runAccountDB $ loadUser (newPasswordUser d)
case muser of
Nothing -> permissionDenied "Invalid username"
Just user -> do
when (userResetPwdKey user == "") $ permissionDenied "Invalid key"
when (newPasswordKey d /= userResetPwdKey user) $ permissionDenied "Invalid key"
hashed <- hashPassword (newPasswordPwd1 d)
runAccountDB $ setNewPassword user hashed
setMessageI Msg.PassUpdated
setCreds True $ Creds "account" (newPasswordUser d) []
class UserCredentials u where
username :: u -> Username
userPasswordHash :: u -> B.ByteString
userEmail :: u -> T.Text
userEmailVerified :: u -> Bool
userEmailVerifyKey :: u -> T.Text
userResetPwdKey :: u -> T.Text
class PersistUserCredentials u where
userUsernameF :: P.EntityField u Username
userPasswordHashF :: P.EntityField u B.ByteString
userEmailF :: P.EntityField u T.Text
userEmailVerifiedF :: P.EntityField u Bool
userEmailVerifyKeyF :: P.EntityField u T.Text
userResetPwdKeyF :: P.EntityField u T.Text
#if 1
uniqueUsername :: T.Text -> P.Unique u
#else
uniqueUsername :: T.Text -> P.Unique u (P.PersistEntityBackend u)
#endif
userCreate :: Username
-> T.Text
-> T.Text
-> B.ByteString
-> u
class AccountDB b where
type UserAccount b
loadUser :: Username -> b sub (Maybe (UserAccount b))
addNewUser :: Username
-> T.Text
-> T.Text
-> B.ByteString
-> b sub (Either T.Text (UserAccount b))
verifyAccount :: UserAccount b -> b sub ()
setVerifyKey :: UserAccount b
-> T.Text
-> b sub ()
setNewPasswordKey :: UserAccount b
-> T.Text
-> b sub ()
setNewPassword :: UserAccount b
-> B.ByteString
-> b sub ()
class AccountSendEmail master where
sendVerifyEmail :: Username
-> T.Text
-> T.Text
-> GHandler s master ()
sendVerifyEmail uname email url =
$(logInfo) $ T.concat [ "Verification email for "
, uname
, " (", email, "): "
, url
]
sendNewPasswordEmail :: Username
-> T.Text
-> T.Text
-> GHandler s master ()
sendNewPasswordEmail uname email url =
$(logInfo) $ T.concat [ "Reset password email for "
, uname
, " (", email, "): "
, url
]
class (YesodAuth master
, AccountSendEmail master
, AccountDB db
, UserCredentials (UserAccount db)
, RenderMessage master FormMessage
) => YesodAuthAccount db master | master -> db where
runAccountDB :: db sub a -> GHandler sub master a
checkValidUsername :: Username -> GHandler s master (Either T.Text Username)
checkValidUsername u | T.all isAlphaNum u = return $ Right u
checkValidUsername _ = do
mr <- getMessageRender
return $ Left $ mr MsgInvalidUsername
unregisteredLogin :: UserAccount db -> GHandler Auth master RepHtml
unregisteredLogin u = do
tm <- getRouteToMaster
defaultLayout $ do
setTitleI MsgEmailUnverified
[whamlet|
<p>_{MsgEmailUnverified}
^{resendVerifyEmailWidget (username u) tm}
|]
getNewAccountR :: GHandler Auth master RepHtml
getNewAccountR = do
tm <- getRouteToMaster
defaultLayout $ do
setTitleI Msg.RegisterLong
newAccountWidget tm
postNewAccountR :: GHandler Auth master RepHtml
postNewAccountR = do
tm <- getRouteToMaster
mr <- getMessageRender
((result, _), _) <- runFormPost $ renderDivs newAccountForm
mdata <- case result of
FormMissing -> invalidArgs ["Form is missing"]
FormFailure msg -> return $ Left msg
FormSuccess d -> return $ if newAccountPassword1 d == newAccountPassword2 d
then Right d
else Left [mr Msg.PassMismatch]
case mdata of
Left errs -> do
setMessage $ toHtml $ T.concat errs
redirect $ tm newAccountR
Right d -> do void $ createNewAccount d tm
redirect $ tm LoginR
allowPasswordReset :: master -> Bool
allowPasswordReset _ = True
getResetPasswordR :: GHandler Auth master RepHtml
getResetPasswordR = do
tm <- getRouteToMaster
defaultLayout $ do
setTitleI MsgResetPwdTitle
resetPasswordWidget tm
setPasswordHandler :: UserAccount db -> GHandler Auth master RepHtml
setPasswordHandler u = do
tm <- getRouteToMaster
defaultLayout $ do
setTitleI Msg.SetPassTitle
newPasswordWidget u tm
hashPassword :: MonadIO m => T.Text -> m B.ByteString
hashPassword pwd = liftIO $ PS.makePassword (TE.encodeUtf8 pwd) 12
verifyPassword :: T.Text
-> B.ByteString
-> Bool
verifyPassword pwd = PS.verifyPassword (TE.encodeUtf8 pwd)
newVerifyKey :: MonadIO m => m T.Text
newVerifyKey = do
g <- liftIO newStdGen
let bs = B.pack $ take 32 $ randoms g
return $ TE.decodeUtf8 $ B64.encode bs
infixl 8 ^.
(^.) :: a -> ((b -> Const b b') -> a -> Const b a') -> b
x ^. l = getConst $ l Const x
instance (P.PersistEntity u, PersistUserCredentials u) => UserCredentials (P.Entity u) where
username u = u ^. fieldLens userUsernameF
userPasswordHash u = u ^. fieldLens userPasswordHashF
userEmail u = u ^. fieldLens userEmailF
userEmailVerified u = u ^. fieldLens userEmailVerifiedF
userEmailVerifyKey u = u ^. fieldLens userEmailVerifyKeyF
userResetPwdKey u = u ^. fieldLens userResetPwdKeyF
data PersistFuncs master user sub = PersistFuncs {
pGet :: T.Text -> GHandler sub master (Maybe (P.Entity user))
, pInsert :: Username -> user -> GHandler sub master (Either T.Text (P.Entity user))
, pUpdate :: P.Entity user -> [P.Update user] -> GHandler sub master ()
}
newtype AccountPersistDB master user sub a = AccountPersistDB (ReaderT (PersistFuncs master user sub) (GHandler sub master) a)
deriving (Monad, MonadIO)
instance (Yesod master, PersistUserCredentials user) => AccountDB (AccountPersistDB master user) where
type UserAccount (AccountPersistDB master user) = P.Entity user
loadUser name = AccountPersistDB $ do
f <- ask
lift $ pGet f name
addNewUser name email key pwd = AccountPersistDB $ do
f <- ask
lift $ pInsert f name $ userCreate name email key pwd
verifyAccount u = AccountPersistDB $ do
f <- ask
lift $ pUpdate f u [ userEmailVerifiedF P.=. True
, userEmailVerifyKeyF P.=. ""]
setVerifyKey u key = AccountPersistDB $ do
f <- ask
lift $ pUpdate f u [userEmailVerifyKeyF P.=. key]
setNewPasswordKey u key = AccountPersistDB $ do
f <- ask
lift $ pUpdate f u [userResetPwdKeyF P.=. key]
setNewPassword u pwd = AccountPersistDB $ do
f <- ask
lift $ pUpdate f u [ userPasswordHashF P.=. pwd
, userResetPwdKeyF P.=. ""]
runAccountPersistDB :: ( Yesod master
, YesodPersist master
, P.PersistEntity user
, PersistUserCredentials user
, b ~ YesodPersistBackend master
#if 1
, P.PersistMonadBackend (b (GHandler sub master)) ~ P.PersistEntityBackend user
, P.PersistUnique (b (GHandler sub master))
, P.PersistQuery (b (GHandler sub master))
#else
, b ~ P.PersistEntityBackend user
, P.PersistUnique b (GHandler sub master)
, P.PersistQuery b (GHandler sub master)
#endif
)
=> AccountPersistDB master user sub a -> GHandler sub master a
runAccountPersistDB (AccountPersistDB m) = runReaderT m funcs
where funcs = PersistFuncs {
pGet = runDB . P.getBy . uniqueUsername
, pInsert = \name u -> do mentity <- runDB $ P.insertBy u
mr <- getMessageRender
case mentity of
Left _ -> return $ Left $ mr $ MsgUsernameExists name
Right k -> return $ Right $ P.Entity k u
, pUpdate = \(P.Entity key _) u -> runDB $ P.update key u
}