module Yesod.Auth.Account(
Username
, newAccountR
, resetPasswordR
, accountPlugin
, LoginData(..)
, loginForm
, loginFormPostTargetR
, loginWidget
, verifyR
, NewAccountData(..)
, newAccountForm
, newAccountWidget
, createNewAccount
, resendVerifyEmailForm
, resendVerifyR
, resendVerifyEmailWidget
, newPasswordR
, newPasswordLoggedR
, 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 Data.Maybe
import Data.Monoid ((<>))
import Data.Proxy (Proxy(..))
import Network.HTTP.Types (unauthorized401)
import System.IO.Unsafe (unsafePerformIO)
import qualified Crypto.PasswordStore as PS
import qualified Crypto.Nonce as Nonce
import qualified Data.Aeson as A
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Database.Persist as P
import Text.Email.Validate
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
import Yesod.Auth.Account.Message
type Username = T.Text
type Email = 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 "GET" ["newpasswordlgd"] = getNewPasswordLoggedR >>= 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]
newPasswordLoggedR :: AuthRoute
newPasswordLoggedR = PluginR "account" ["newpasswordlgd"]
setPasswordR :: AuthRoute
setPasswordR = PluginR "account" ["setpassword"]
data LoginData = LoginData {
loginUsername :: T.Text
, loginPassword :: T.Text
} deriving Show
loginForm :: (MonadHandler m, YesodAuthAccount db master, HandlerSite m ~ master)
=> AForm m LoginData
loginForm = LoginData <$> areq (checkM checkValidLogin textField) userSettings Nothing
<*> areq passwordField pwdSettings Nothing
where userSettings = FieldSettings (SomeMessage MsgLoginName) Nothing (Just "username") Nothing []
pwdSettings = FieldSettings (SomeMessage Msg.Password) Nothing (Just "password") Nothing []
loginWidget :: YesodAuthAccount db master => (Route Auth -> Route master) -> WidgetT master IO ()
loginWidget tm = do
((_,widget), enctype) <- liftHandlerT $ 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 => HandlerT Auth (HandlerT master IO) TypedContent
postLoginR = do
((result, _), _) <- lift $ runFormPostNoToken $ renderDivs loginForm
muser <- case result of
FormMissing -> invalidArgs ["Form is missing"]
FormFailure _ -> return $ Left Msg.InvalidLogin
FormSuccess (LoginData uname pwd) -> do
mu <- lift $ runAccountDB $ loadUser uname
case mu of
Nothing -> return $ Left Msg.InvalidUsernamePass
Just u -> return $
if verifyPassword pwd (userPasswordHash u)
then Right u
else Left Msg.InvalidUsernamePass
case muser of
Left err -> loginErrorMessageI LoginR err
Right u -> if userEmailVerified u
then lift $ setCredsRedirect $ Creds "account" (username u) []
else unregisteredLogin u
data NewAccountData = NewAccountData {
newAccountUsername :: Username
, newAccountEmail :: T.Text
, newAccountPassword1 :: T.Text
, newAccountPassword2 :: T.Text
} deriving Show
newAccountForm :: (YesodAuthAccount db master
, MonadHandler m
, HandlerSite m ~ master
) => AForm m NewAccountData
newAccountForm = NewAccountData <$> areq (checkM checkValidUsername textField) userSettings Nothing
<*> areq (checkM checkValidEmail 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 :: YesodAuthAccount db master => (Route Auth -> Route master) -> WidgetT master IO ()
newAccountWidget tm = do
((_,widget), enctype) <- liftHandlerT $ 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) -> HandlerT master IO (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 ()
muser' <- runAccountDB $ loadUser email
case muser' of
Just _ -> do setMessageI $ MsgEmailExists email
redirect $ tm resetPasswordR
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 -> HandlerT Auth (HandlerT master IO) ()
getVerifyR uname k = do
muser <- lift $ runAccountDB $ loadUser uname
case muser of
Nothing -> do lift $ setMessageI Msg.InvalidKey
redirect LoginR
Just user -> do when ( userEmailVerifyKey user == ""
|| userEmailVerifyKey user /= k
|| userEmailVerified user
) $ do
lift $ setMessageI Msg.InvalidKey
redirect LoginR
lift $ runAccountDB $ verifyAccount user
lift $ setMessageI MsgEmailVerified
lift $ setCreds True $ Creds "account" uname []
resendVerifyEmailForm :: (RenderMessage master FormMessage
, MonadHandler m
, HandlerSite m ~ master
) => Username -> AForm m Username
resendVerifyEmailForm u = areq hiddenField "" $ Just u
resendVerifyEmailWidget :: YesodAuthAccount db master => Username -> (Route Auth -> Route master) -> WidgetT master IO ()
resendVerifyEmailWidget u tm = do
((_,widget), enctype) <- liftHandlerT $ 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 => HandlerT Auth (HandlerT master IO) ()
postResendVerifyEmailR = do
((result, _), _) <- lift $ runFormPost $ renderDivs $ resendVerifyEmailForm ""
muser <- case result of
FormMissing -> invalidArgs ["Form is missing"]
FormFailure msg -> invalidArgs msg
FormSuccess uname -> lift $ runAccountDB $ loadUser uname
case muser of
Nothing -> invalidArgs ["Invalid username"]
Just u -> do
key <- newVerifyKey
lift $ runAccountDB $ setVerifyKey u key
render <- getUrlRender
lift $ sendVerifyEmail (username u) (userEmail u) $ render $ verifyR (username u) key
lift $ setMessageI $ Msg.ConfirmationEmailSent (userEmail u)
redirect LoginR
resetPasswordForm :: (YesodAuthAccount db master
, MonadHandler m
, HandlerSite m ~ master
) => AForm m Username
resetPasswordForm = areq textField userSettings Nothing
where userSettings = FieldSettings (SomeMessage MsgLoginName) Nothing (Just "username") Nothing []
resetPasswordWidget :: YesodAuthAccount db master
=> (Route Auth -> Route master) -> WidgetT master IO ()
resetPasswordWidget tm = do
((_,widget), enctype) <- liftHandlerT $ runFormPost $ renderDivs resetPasswordForm
[whamlet|
<div .resetPasswordDiv>
<form method=post enctype=#{enctype} action=@{tm resetPasswordR}>
^{widget}
<input type=submit value=_{Msg.SendPasswordResetEmail}>
|]
postResetPasswordR :: YesodAuthAccount db master => HandlerT Auth (HandlerT master IO) Html
postResetPasswordR = do
allow <- allowPasswordReset <$> lift getYesod
unless allow notFound
((result, _), _) <- lift $ runFormPost $ renderDivs resetPasswordForm
mdata <- case result of
FormMissing -> invalidArgs ["Form is missing"]
FormFailure msg -> return $ Left msg
FormSuccess uname -> Right <$> lift (runAccountDB (loadUser uname))
case mdata of
Left errs -> do
setMessage $ toHtml $ T.concat errs
redirect LoginR
Right Nothing -> do
lift $ setMessageI MsgInvalidUsername
redirect resetPasswordR
Right (Just u) -> do key <- newVerifyKey
lift $ runAccountDB $ setNewPasswordKey u key
render <- getUrlRender
lift $ sendNewPasswordEmail (username u) (userEmail u) $ render $ newPasswordR (username u) key
lift $ setMessageI MsgResetPwdEmailSent
redirect LoginR
data NewPasswordData = NewPasswordData {
newPasswordUser :: Username
, newPasswordKey :: Maybe T.Text
, newPasswordOld :: Maybe T.Text
, newPasswordPwd1 :: T.Text
, newPasswordPwd2 :: T.Text
} deriving Show
newPasswordForm :: (YesodAuthAccount db master, MonadHandler m, HandlerSite m ~ master)
=> Username
-> Maybe T.Text
-> AForm m NewPasswordData
newPasswordForm u k = NewPasswordData <$> areq hiddenField "" (Just u)
<*> aopt hiddenField "" (Just k)
<*> (if isNothing k then aopt passwordField newPassword Nothing
else aopt hiddenField "" Nothing)
<*> 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 []
newPassword = FieldSettings (SomeMessage MsgCurrentPassword) Nothing Nothing Nothing []
newPasswordWidget :: YesodAuthAccount db master
=> Bool
->UserAccount db
-> (Route Auth -> Route master)
-> WidgetT master IO ()
newPasswordWidget withKey user tm = do
let key = if withKey
then Just $ userResetPwdKey user
else Nothing
((_,widget), enctype) <- liftHandlerT $ 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 -> HandlerT Auth (HandlerT master IO) Html
getNewPasswordR uname k = do
allow <- allowPasswordReset <$> lift getYesod
unless allow notFound
muser <- lift $ runAccountDB $ loadUser uname
case muser of
Just user | userResetPwdKey user /= "" && userResetPwdKey user == k ->
setPasswordHandler True user
_ -> do lift $ setMessageI Msg.InvalidKey
redirect LoginR
getNewPasswordLoggedR :: YesodAuthAccount db master => HandlerT Auth (HandlerT master IO) Html
getNewPasswordLoggedR = do
allow <- allowPasswordReset <$> lift getYesod
unless allow notFound
uname <- loggedInUser
muser <- lift $ runAccountDB $ loadUser uname
case muser of
Just user -> runIfLogged (setPasswordHandler False user)
_ -> notAuthenticated
postSetPasswordR :: YesodAuthAccount db master => HandlerT Auth (HandlerT master IO) ()
postSetPasswordR = do
allow <- allowPasswordReset <$> lift getYesod
unless allow notFound
((result,_), _) <- lift $ runFormPost $ renderDivs (newPasswordForm "" Nothing)
mnew <- case result of
FormMissing -> invalidArgs ["Form is missing"]
FormFailure msg -> return $ Left msg
FormSuccess d | newPasswordPwd1 d == newPasswordPwd2 d
&& ( isJust (newPasswordOld d)
|| isJust (newPasswordKey d)) -> return $ Right d
FormSuccess d -> do lift $ setMessageI Msg.PassMismatch
handleNullFields
where
handleNullFields | null (catMaybes [newPasswordOld d, newPasswordKey d]) =
invalidArgs ["Form is incorrect"]
| isNothing (newPasswordKey d) = redirect $ newPasswordLoggedR
| otherwise = redirect $ newPasswordR (newPasswordUser d)
(fromMaybe "" (newPasswordKey d))
case mnew of
Left errs -> do
setMessage $ toHtml $ T.concat errs
redirect LoginR
Right d -> do muser <- lift $ runAccountDB $ loadUser (newPasswordUser d)
case muser of
Nothing -> permissionDenied "Invalid username"
Just user -> do
case newPasswordOld d of
Nothing -> do
when (userResetPwdKey user == "") $ permissionDenied "Invalid key"
when (maybe True ((/=) (userResetPwdKey user)) (newPasswordKey d))
$ permissionDenied "Invalid key"
Just oldPassword ->
unless (verifyPassword oldPassword (userPasswordHash user))
(lift (setMessageI MsgInvalidPassword) >> redirect newPasswordLoggedR )
hashed <- hashPassword (newPasswordPwd1 d)
lift $ runAccountDB $ setNewPassword user hashed
lift $ setMessageI Msg.PassUpdated
lift $ 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
uniqueUsername :: T.Text -> P.Unique u
uniqueEmailaddress :: T.Text -> P.Unique u
userCreate :: Username
-> T.Text
-> T.Text
-> B.ByteString
-> u
class AccountDB m where
type UserAccount m
loadUser :: Username -> m (Maybe (UserAccount m))
addNewUser :: Username
-> T.Text
-> T.Text
-> B.ByteString
-> m (Either T.Text (UserAccount m))
verifyAccount :: UserAccount m -> m ()
setVerifyKey :: UserAccount m
-> T.Text
-> m ()
setNewPasswordKey :: UserAccount m
-> T.Text
-> m ()
setNewPassword :: UserAccount m
-> B.ByteString
-> m ()
class AccountSendEmail master where
sendVerifyEmail :: Username
-> T.Text
-> T.Text
-> HandlerT master IO ()
sendVerifyEmail uname email url =
$(logInfo) $ T.concat [ "Verification email for "
, uname
, " (", email, "): "
, url
]
sendNewPasswordEmail :: Username
-> T.Text
-> T.Text
-> HandlerT master IO ()
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 a -> HandlerT master IO a
checkValidUsername :: (MonadHandler m, HandlerSite m ~ master)
=> Username -> m (Either T.Text Username)
checkValidUsername u | T.all isAlphaNum u = return $ Right u
checkValidUsername _ = do
mr <- getMessageRender
return $ Left $ mr MsgInvalidUsername
checkValidEmail :: (MonadHandler m, HandlerSite m ~ master)
=> Email -> m (Either T.Text Email)
checkValidEmail u = do
mr <- getMessageRender
return . either (Left . (\e -> mr MsgInvalidEmail' <> ": " <> T.pack e))
(Right . TE.decodeUtf8 . toByteString)
. validate
$ TE.encodeUtf8 u
checkValidLogin :: (MonadHandler m, HandlerSite m ~ master)
=> Username -> m (Either T.Text Username)
checkValidLogin u = do
validUser <- checkValidUsername u
validEmail<- checkValidEmail u
return $ case validUser of
Left _ -> validEmail
Right _ -> validUser
unregisteredLogin :: UserAccount db -> HandlerT Auth (HandlerT master IO) TypedContent
unregisteredLogin u =
selectRep $ do
provideRep $ do
tm <- getRouteToParent
lift $ defaultLayout $ do
setTitleI MsgEmailUnverified
[whamlet|
<p>_{MsgEmailUnverified}
^{resendVerifyEmailWidget (username u) tm}
|]
provideRep $ do
let obj = A.object ["unverified" A..= True, "message" A..= msg]
msg = "User account has not been verified (check your e-mail)" :: T.Text
void $ sendResponseStatus unauthorized401 obj
return obj
getNewAccountR :: HandlerT Auth (HandlerT master IO) Html
getNewAccountR = do
tm <- getRouteToParent
lift $ defaultLayout $ do
setTitleI Msg.RegisterLong
newAccountWidget tm
postNewAccountR :: HandlerT Auth (HandlerT master IO) Html
postNewAccountR = do
tm <- getRouteToParent
mr <- lift getMessageRender
((result, _), _) <- lift $ 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 newAccountR
Right d -> do void $ lift $ createNewAccount d tm
redirect LoginR
allowPasswordReset :: master -> Bool
allowPasswordReset _ = True
getResetPasswordR :: HandlerT Auth (HandlerT master IO) Html
getResetPasswordR = do
tm <- getRouteToParent
lift $ defaultLayout $ do
setTitleI Msg.PasswordResetTitle
resetPasswordWidget tm
setPasswordHandler :: Bool -> UserAccount db -> HandlerT Auth (HandlerT master IO) Html
setPasswordHandler withKey u = do
tm <- getRouteToParent
lift $ defaultLayout $ do
setTitleI Msg.SetPassTitle
newPasswordWidget withKey u tm
getTextId :: Proxy master -> AuthId master -> HandlerT Auth (HandlerT master IO) T.Text
renderAccountMessage :: master -> [T.Text] -> AccountMsg -> T.Text
renderAccountMessage _ _ = defaultAccountMsg
instance YesodAuthAccount db master => RenderMessage master AccountMsg where
renderMessage = renderAccountMessage
loggedInUser :: (YesodAuthAccount db master) => HandlerT Auth (HandlerT master IO) T.Text
loggedInUser = do
y <- lift getYesod
getTextId (return y) =<< lift requireAuthId
runIfLogged :: YesodAuthAccount db master => HandlerT Auth (HandlerT master IO) b -> HandlerT Auth (HandlerT master IO) b
runIfLogged action = do
muser <- lift . runAccountDB . loadUser =<< loggedInUser
case muser of
Just u-> if userEmailVerified u
then action
else redirect LoginR
Nothing -> redirect LoginR
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)
nonceGen :: Nonce.Generator
nonceGen = unsafePerformIO Nonce.new
newVerifyKey :: MonadIO m => m T.Text
newVerifyKey = Nonce.nonce128urlT nonceGen
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 = PersistFuncs {
pGet :: T.Text -> HandlerT master IO (Maybe (P.Entity user))
, pInsert :: Username -> user -> HandlerT master IO (Either T.Text (P.Entity user))
, pUpdate :: P.Entity user -> [P.Update user] -> HandlerT master IO ()
}
newtype AccountPersistDB master user a = AccountPersistDB (ReaderT (PersistFuncs master user) (HandlerT master IO) a)
deriving (Monad, MonadIO, Functor, Applicative)
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 MIN_VERSION_persistent(2,1,0)
, b ~ PersistEntityBackend user
, PersistUnique b
#else
, PersistMonadBackend (b (HandlerT master IO)) ~ P.PersistEntityBackend user
, P.PersistUnique (b (HandlerT master IO))
, P.PersistQuery (b (HandlerT master IO))
#endif
, YesodAuthAccount db master
, db ~ AccountPersistDB master user
)
=> AccountPersistDB master user a -> HandlerT master IO a
runAccountPersistDB (AccountPersistDB m) = runReaderT m funcs
where funcs = PersistFuncs {
pGet = \u -> runDB $ do
byUser <- P.getBy . uniqueUsername $ u
maybe (P.getBy . uniqueEmailaddress $ u) (return . Just) byUser
, 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
}