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.IO.Unsafe (unsafePerformIO)
import qualified Crypto.PasswordStore as PS
import qualified Crypto.Nonce as Nonce
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 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
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 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 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) -> 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) Html
postLoginR = do
mr <- lift getMessageRender
((result, _), _) <- lift $ runFormPostNoToken $ renderDivs loginForm
muser <- case result of
FormMissing -> invalidArgs ["Form is missing"]
FormFailure msg -> return $ Left msg
FormSuccess (LoginData uname pwd) -> do
mu <- lift $ runAccountDB $ loadUser uname
case mu of
Nothing -> return $ Left [mr Msg.InvalidUsernamePass]
Just u -> return $
if verifyPassword pwd (userPasswordHash u)
then Right u
else Left [mr Msg.InvalidUsernamePass]
case muser of
Left errs -> do
setMessage $ toHtml $ T.concat errs
redirect LoginR
Right u -> if userEmailVerified u
then do lift $ 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 :: (YesodAuthAccount db master
, MonadHandler m
, HandlerSite m ~ master
) => AForm m NewAccountData
newAccountForm = NewAccountData <$> areq (checkM checkValidUsername 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 :: 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 ()
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 MsgUsername) 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 :: T.Text
, newPasswordPwd1 :: T.Text
, newPasswordPwd2 :: T.Text
} deriving Show
newPasswordForm :: (YesodAuth master, RenderMessage master FormMessage, MonadHandler m, HandlerSite m ~ master)
=> Username
-> T.Text
-> AForm 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) -> WidgetT master IO ()
newPasswordWidget user tm = do
let key = userResetPwdKey user
((_,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 user
_ -> do lift $ setMessageI Msg.InvalidKey
redirect LoginR
postSetPasswordR :: YesodAuthAccount db master => HandlerT Auth (HandlerT master IO) ()
postSetPasswordR = do
allow <- allowPasswordReset <$> lift getYesod
unless allow notFound
((result,_), _) <- lift $ 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 lift $ setMessageI Msg.PassMismatch
redirect $ newPasswordR (newPasswordUser d) (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
when (userResetPwdKey user == "") $ permissionDenied "Invalid key"
when (newPasswordKey d /= userResetPwdKey user) $ permissionDenied "Invalid key"
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
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
unregisteredLogin :: UserAccount db -> HandlerT Auth (HandlerT master IO) Html
unregisteredLogin u = do
tm <- getRouteToParent
lift $ defaultLayout $ do
setTitleI MsgEmailUnverified
[whamlet|
<p>_{MsgEmailUnverified}
^{resendVerifyEmailWidget (username u) tm}
|]
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 :: UserAccount db -> HandlerT Auth (HandlerT master IO) Html
setPasswordHandler u = do
tm <- getRouteToParent
lift $ defaultLayout $ do
setTitleI Msg.SetPassTitle
newPasswordWidget u tm
renderAccountMessage :: master -> [T.Text] -> AccountMsg -> T.Text
renderAccountMessage _ _ = defaultAccountMsg
instance YesodAuthAccount db master => RenderMessage master AccountMsg where
renderMessage = renderAccountMessage
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 = 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
}