yesod-auth-account-1.2.2/0000755000000000000000000000000012203724523013416 5ustar0000000000000000yesod-auth-account-1.2.2/LICENSE0000644000000000000000000000203512203724523014423 0ustar0000000000000000Copyright (c) 2013 John Lenz Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. yesod-auth-account-1.2.2/example.hs0000644000000000000000000000446212203724523015413 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances, TemplateHaskell, OverloadedStrings #-} {-# LANGUAGE GADTs, MultiParamTypeClasses, TypeSynonymInstances #-} import Data.Text (Text) import Data.ByteString (ByteString) import Database.Persist.Sqlite import Control.Monad.Logger (runStderrLoggingT) import Yesod import Yesod.Auth import Yesod.Auth.Account share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| User username Text UniqueUsername username password ByteString emailAddress Text verified Bool verifyKey Text resetPasswordKey Text deriving Show |] instance PersistUserCredentials User where userUsernameF = UserUsername userPasswordHashF = UserPassword userEmailF = UserEmailAddress userEmailVerifiedF = UserVerified userEmailVerifyKeyF = UserVerifyKey userResetPwdKeyF = UserResetPasswordKey uniqueUsername = UniqueUsername userCreate name email key pwd = User name pwd email False key "" data MyApp = MyApp ConnectionPool mkYesod "MyApp" [parseRoutes| / HomeR GET /auth AuthR Auth getAuth |] instance Yesod MyApp instance RenderMessage MyApp FormMessage where renderMessage _ _ = defaultFormMessage instance YesodPersist MyApp where type YesodPersistBackend MyApp = SqlPersistT runDB action = do MyApp pool <- getYesod runSqlPool action pool instance YesodAuth MyApp where type AuthId MyApp = Username getAuthId = return . Just . credsIdent loginDest _ = HomeR logoutDest _ = HomeR authPlugins _ = [accountPlugin] authHttpManager _ = error "No manager needed" onLogin = return () maybeAuthId = lookupSession "_ID" instance AccountSendEmail MyApp instance YesodAuthAccount (AccountPersistDB MyApp User) MyApp where runAccountDB = runAccountPersistDB getHomeR :: Handler Html getHomeR = do maid <- maybeAuthId case maid of Nothing -> defaultLayout $ [whamlet|

Please visit the Login page |] Just u -> defaultLayout $ [whamlet|

You are logged in as #{u}

Logout |] main :: IO () main = withSqlitePool "test.db3" 10 $ \pool -> do runStderrLoggingT $ runSqlPool (runMigration migrateAll) pool warp 3000 $ MyApp pool yesod-auth-account-1.2.2/README.md0000644000000000000000000000227412203724523014702 0ustar0000000000000000This package provides a [Yesod](http://www.yesodweb.com/) authentication plugin for accounts. Each account consists of an username, email, and password. When initially creating an account, the email is verified by sending a link in an email. The plugin also supports password reset via email. The plugin provides default pages implementing all of this functionality, but it has been designed to allow all the pages (new account page, password reset, etc.) to be customized or for the forms to be embedded into your own pages allowing you to just ignore the routes inside the plugin. The details are contained in the [haddock documentation](http://hackage.haskell.org/package/yesod-auth-account). The plugin supports any form data storage by requiring you to implement a couple of interfaces for data access. The plugin has instances of these interfaces using persistent, but you can create your own implementation if you are not using persistent or want more control over user data access and storage. A complete working example using persistent is [example.hs](/wuzzeb/yesod-auth-account/src/tip/example.hs). Also, see the [haddock documentation](http://hackage.haskell.org/package/yesod-auth-account). yesod-auth-account-1.2.2/Setup.hs0000644000000000000000000000005612203724523015053 0ustar0000000000000000import Distribution.Simple main = defaultMain yesod-auth-account-1.2.2/yesod-auth-account.cabal0000644000000000000000000000457512203724523020131 0ustar0000000000000000name: yesod-auth-account version: 1.2.2 cabal-version: >= 1.8 build-type: Simple synopsis: An account authentication plugin for Yesod category: Web author: John Lenz maintainer: John Lenz license: MIT license-file: LICENSE homepage: https://bitbucket.org/wuzzeb/yesod-auth-account stability: Experimental description: An auth plugin for accounts. Each account consists of a username, email, and password. The plugin provides new account, email verification, and password reset pages that can be customized to enhance the user experience. -- Temp workaround for http://hackage.haskell.org/trac/hackage/ticket/792 extra-source-files: example.hs , README.md , tests/BasicTests.hs , tests/Foundation.hs , tests/NewAccount.hs source-repository head type: mercurial location: https://bitbucket.org/wuzzeb/yesod-auth-account library hs-source-dirs: . exposed-modules: Yesod.Auth.Account ghc-options: -Wall -O2 build-depends: base >= 4 && < 5 , base64-bytestring >= 1.0 , bytestring >= 0.10 , blaze-html >= 0.6 , mtl >= 2.1 , text >= 0.11 , persistent >= 1.2 && < 1.3 , pwstore-fast >= 2.0 , random >= 1.0 , yesod-auth >= 1.2 && < 1.3 , yesod-core >= 1.2 && < 1.3 , yesod-form >= 1.3 && < 1.4 , yesod-persistent >= 1.2 test-suite test type: exitcode-stdio-1.0 main-is: main.hs hs-source-dirs: tests ghc-options: -Wall build-depends: base , bytestring , hspec , monad-logger >= 0.3 , mtl , persistent-sqlite , resourcet , text , xml-conduit , yesod >= 1.2 && < 1.3 , yesod-test >= 1.2 , yesod-auth >= 1.2 && < 1.3 , yesod-auth-account yesod-auth-account-1.2.2/Yesod/0000755000000000000000000000000012203724523014501 5ustar0000000000000000yesod-auth-account-1.2.2/Yesod/Auth/0000755000000000000000000000000012203724523015402 5ustar0000000000000000yesod-auth-account-1.2.2/Yesod/Auth/Account.hs0000644000000000000000000012447012203724523017342 0ustar0000000000000000{- Copyright (c) 2013 John Lenz Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- | An auth plugin for accounts. Each account consists of a username, email, and password. -- -- This module is designed so that you can use the default pages for login, account -- creation, change password, etc. But the module also exports some forms which you -- can embed into your own pages, customizing the account process. The minimal requirements -- to use this module are: -- -- * If you are not using persistent or just want more control over the user data, you can use -- any datatype for user information and make it an instance of 'UserCredentials'. You must -- also create an instance of 'AccountDB'. -- -- * You may use a user datatype created by persistent, in which case you can make the datatype -- an instance of 'PersistUserCredentials' instead of 'UserCredentials'. In this case, -- 'AccountPersistDB' from this module already implements the 'AccountDB' interface for you. -- -- * Make your master site an instance of 'AccountSendEmail'. By default, this class -- just logs a message so during development this class requires no implementation. -- -- * Make your master site and database an instance of 'YesodAuthAccount'. There is only -- one required function which must be implemented ('runAccountDB') although there -- are several functions you can override in this class to customize the behavior of this -- module. -- -- * Include 'accountPlugin' in the list of plugins in your instance of 'YesodAuth'. module Yesod.Auth.Account( -- * Plugin Username , newAccountR , resetPasswordR , accountPlugin -- * Login , LoginData(..) , loginForm , loginFormPostTargetR , loginWidget -- * New Account -- $newaccount , verifyR , NewAccountData(..) , newAccountForm , newAccountWidget , createNewAccount , resendVerifyEmailForm , resendVerifyR , resendVerifyEmailWidget -- * Password Reset -- $passwordreset , newPasswordR , resetPasswordForm , resetPasswordWidget , NewPasswordData(..) , newPasswordForm , setPasswordR , newPasswordWidget -- * Database and Email , UserCredentials(..) , PersistUserCredentials(..) , AccountDB(..) , AccountSendEmail(..) -- * Persistent , AccountPersistDB , runAccountPersistDB -- * Customization , YesodAuthAccount(..) -- * Helpers , hashPassword , verifyPassword , newVerifyKey ) where import Control.Applicative import Control.Monad.Reader hiding (lift) import Data.Char (isAlphaNum) import System.Random (newStdGen, randoms) 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 Yesod.Core import Yesod.Form import Yesod.Auth import Yesod.Persist hiding (get, replace, insertKey, Entity, entityVal) import qualified Yesod.Auth.Message as Msg -- | Each user is uniquely identified by a username. type Username = T.Text -- | The account authentication plugin. Here is a complete example using persistent. -- -- >{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-} -- >{-# LANGUAGE FlexibleContexts, FlexibleInstances, TemplateHaskell, OverloadedStrings #-} -- >{-# LANGUAGE GADTs, MultiParamTypeClasses, TypeSynonymInstances #-} -- > -- >import Data.Text (Text) -- >import Data.ByteString (ByteString) -- >import Database.Persist.Sqlite -- >import Control.Monad.Logger (runStderrLoggingT) -- >import Yesod -- >import Yesod.Auth -- >import Yesod.Auth.Account -- > -- >share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| -- >User -- > username Text -- > UniqueUsername username -- > password ByteString -- > emailAddress Text -- > verified Bool -- > verifyKey Text -- > resetPasswordKey Text -- > deriving Show -- >|] -- > -- >instance PersistUserCredentials User where -- > userUsernameF = UserUsername -- > userPasswordHashF = UserPassword -- > userEmailF = UserEmailAddress -- > userEmailVerifiedF = UserVerified -- > userEmailVerifyKeyF = UserVerifyKey -- > userResetPwdKeyF = UserResetPasswordKey -- > uniqueUsername = UniqueUsername -- > -- > userCreate name email key pwd = User name pwd email False key "" -- > -- >data MyApp = MyApp ConnectionPool -- > -- >mkYesod "MyApp" [parseRoutes| -- >/ HomeR GET -- >/auth AuthR Auth getAuth -- >|] -- > -- >instance Yesod MyApp -- > -- >instance RenderMessage MyApp FormMessage where -- > renderMessage _ _ = defaultFormMessage -- > -- >instance YesodPersist MyApp where -- > type YesodPersistBackend MyApp = SqlPersistT -- > runDB action = do -- > MyApp pool <- getYesod -- > runSqlPool action pool -- > -- >instance YesodAuth MyApp where -- > type AuthId MyApp = Username -- > getAuthId = return . Just . credsIdent -- > loginDest _ = HomeR -- > logoutDest _ = HomeR -- > authPlugins _ = [accountPlugin] -- > authHttpManager _ = error "No manager needed" -- > onLogin = return () -- > maybeAuthId = lookupSession "_ID" -- > -- >instance AccountSendEmail MyApp -- > -- >instance YesodAuthAccount (AccountPersistDB MyApp User) MyApp where -- > runAccountDB = runAccountPersistDB -- > -- >getHomeR :: Handler Html -- >getHomeR = do -- > maid <- maybeAuthId -- > case maid of -- > Nothing -> defaultLayout $ [whamlet| -- >

Please visit the Login page -- >|] -- > Just u -> defaultLayout $ [whamlet| -- >

You are logged in as #{u} -- >

Logout -- >|] -- > -- >main :: IO () -- >main = withSqlitePool "test.db3" 10 $ \pool -> do -- > runStderrLoggingT $ runSqlPool (runMigration migrateAll) pool -- > warp 3000 $ MyApp pool -- 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 -- | The POST target for the 'loginForm'. loginFormPostTargetR :: AuthRoute loginFormPostTargetR = PluginR "account" ["login"] -- | Route for the default new account page. -- -- See the New Account section below for customizing the new account process. newAccountR :: AuthRoute newAccountR = PluginR "account" ["newaccount"] -- | Route for the reset password page. -- -- This page allows the user to reset their password by requesting an email with a -- reset URL be sent to them. See the Password Reset section below for customization. resetPasswordR :: AuthRoute resetPasswordR = PluginR "account" ["resetpassword"] -- | The URL sent in an email for email verification verifyR :: Username -> T.Text -- ^ The verification key -> AuthRoute verifyR u k = PluginR "account" ["verify", u, k] -- | The POST target for resending a verification email resendVerifyR :: AuthRoute resendVerifyR = PluginR "account" ["resendverifyemail"] -- | The URL sent in an email when the user requests to reset their password newPasswordR :: Username -> T.Text -- ^ The verification key -> AuthRoute newPasswordR u k = PluginR "account" ["newpassword", u, k] -- | The POST target for reseting the password setPasswordR :: AuthRoute setPasswordR = PluginR "account" ["setpassword"] -- | TODO: move these into Yesod.Auth.Message data AccountMsg = MsgUsername | MsgForgotPassword | MsgInvalidUsername | MsgUsernameExists T.Text | MsgResendVerifyEmail | MsgResetPwdEmailSent | MsgEmailVerified | MsgEmailUnverified instance RenderMessage m AccountMsg where renderMessage _ _ MsgUsername = "Username" renderMessage _ _ MsgForgotPassword = "Forgot password?" renderMessage _ _ MsgInvalidUsername = "Invalid username" renderMessage _ _ (MsgUsernameExists u) = T.concat ["The username ", u, " already exists. Please choose an alternate username."] renderMessage _ _ MsgResendVerifyEmail = "Resend verification email" 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." --------------------------------------------------------------------------------------------------- -- | The data collected in the login form. data LoginData = LoginData { loginUsername :: T.Text , loginPassword :: T.Text } deriving Show -- | The login form. -- -- You can embed this form into your own pages if you want a custom rendering of this -- form or to include a login form on your own pages. The form submission should be -- posted to 'loginFormPostTargetR'. 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 [] -- | A default rendering of 'loginForm' using renderDivs. -- -- This is the widget used in the default implementation of 'loginHandler'. -- The widget also includes links to the new account and reset password pages. loginWidget :: YesodAuthAccount db master => (Route Auth -> Route master) -> WidgetT master IO () loginWidget tm = do ((_,widget), enctype) <- liftHandlerT $ runFormPostNoToken $ renderDivs loginForm [whamlet|

^{widget}

_{Msg.RegisterLong} _{MsgForgotPassword} |] postLoginR :: YesodAuthAccount db master => HandlerT Auth (HandlerT master IO) Html postLoginR = do ((result, _), _) <- lift $ runFormPostNoToken $ renderDivs loginForm mr <- lift getMessageRender 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) [] -- setCreds should redirect so we will never get here badMethod else unregisteredLogin u --------------------------------------------------------------------------------------------------- -- $newaccount -- The new account process works as follows. -- -- * A GET to 'newAccountR' displays a form requesting account information -- from the user. The specific page to display can be customized by implementing -- 'getNewAccountR'. By default, this is the content of 'newAccountForm' which -- consists of an username, email, and a password. The target for the form is a -- POST to 'newAccountR'. -- -- * A POST to 'newAccountR' handles the account creation. By default, 'postNewAccountR' -- processes 'newAccountForm' and then calls 'createNewAccount' to create the account -- in the database, generate a random key, and send an email with the verification key. -- If you have modified 'getNewAccountR' to add additional fields to the new account -- form (for example CAPTCHA or other account info), you can override 'postNewAccountR' -- to handle the form. You should still call 'createNewAccount' from your own processing -- function. -- -- * The verification email includes a URL to 'verifyR'. A GET to 'verifyR' checks -- if the key matches, and if so updates the database and uses 'setCreds' to log the -- user in and redirects to 'loginDest'. If an error occurs, a message is set and the -- user is redirected to 'LoginR'. -- -- * A POST to 'resendVerifyR' of 'resendVerifyEmailForm' will generate a new verification key -- and resend the email. By default, 'unregisteredLogin' displays the form for resending -- the email. -- | The data collected in the new account form. data NewAccountData = NewAccountData { newAccountUsername :: Username , newAccountEmail :: T.Text , newAccountPassword1 :: T.Text , newAccountPassword2 :: T.Text } deriving Show -- | The new account form. -- -- You can embed this form into your own pages or into 'getNewAccountR'. The form -- submission should be posted to 'newAccountR'. Alternatively, you could embed this -- form into a larger form where you prompt for more information during account -- creation. In this case, the NewAccountData should be passed to 'createNewAccount' -- from inside 'postNewAccountR'. newAccountForm :: (YesodAuth master , RenderMessage master FormMessage , MonadHandler m , HandlerSite m ~ master ) => AForm 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 [] -- | A default rendering of the 'newAccountForm' using renderDivs. newAccountWidget :: (YesodAuth master, RenderMessage master FormMessage) => (Route Auth -> Route master) -> WidgetT master IO () newAccountWidget tm = do ((_,widget), enctype) <- liftHandlerT $ runFormPost $ renderDivs newAccountForm [whamlet|

^{widget} |] -- | An action to create a new account. -- -- You can use this action inside your own implementation of 'postNewAccountR' if you -- add additional fields to the new account creation. This action assumes the user has -- not yet been created in the database and will create the user, so this action should -- be run first in your handler. Note that this action does not check if the passwords -- are equal. If an error occurs (username exists, etc.) this will set a message and -- redirect to 'newAccountR'. 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 setMessageI MsgEmailVerified lift $ setCreds True $ Creds "account" uname [] -- | A form to allow the user to request the email validation be resent. -- -- Intended for use in 'unregisteredLogin'. The result should be posted to -- 'resendVerifyR'. resendVerifyEmailForm :: (RenderMessage master FormMessage , MonadHandler m , HandlerSite m ~ master ) => Username -> AForm m Username resendVerifyEmailForm u = areq hiddenField "" $ Just u -- | A default rendering of 'resendVerifyEmailForm' resendVerifyEmailWidget :: RenderMessage master FormMessage => Username -> (Route Auth -> Route master) -> WidgetT master IO () resendVerifyEmailWidget u tm = do ((_,widget), enctype) <- liftHandlerT $ runFormPost $ renderDivs $ resendVerifyEmailForm u [whamlet|
^{widget} |] 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 -- The username is a hidden field so it should be correct. No need to set a message or redirect. 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 --------------------------------------------------------------------------------------------------- -- $passwordreset -- This plugin implements password reset by sending the user an email containing a URL. When -- the user visits this URL, they are prompted for a new password. This works as follows: -- -- * A GET to 'resetPasswordR' displays a form prompting for username, which when submitted sends -- a post to 'resetPasswordR'. You can customize this page by overriding 'getResetPasswordR' -- or by embedding 'resetPasswordForm' into your own page and not linking your users to this URL. -- -- * A POST to 'resetPasswordR' of 'resetPasswordForm' creates a new key, stores it in the database, -- and sends an email. It then sets a message and redirects to the login page. You can redirect -- somewhere else (or carry out other actions) at the end of 'sendNewPasswordEmail'. The URL sent -- in the email is 'setPasswordR'. -- -- * A GET to 'newPasswordR' checks if the key in the URL is correct and if so displays a form -- where the user can set a new password. The key is set as a hidden field in this form. You -- can customize the look of this page by overriding 'setPasswordHandler'. -- -- * A POST to 'setPasswordR' of 'resetPasswordForm' checks if the key is correct and if so, -- resets the password. It then calls 'setCreds' to successfully log in and so redirects to -- 'loginDest'. -- -- * You can set 'allowPasswordReset' to False, in which case the relevant routes in this -- plugin return 404. You can then implement password reset yourself. -- | A form for the user to request that an email be sent to them to allow them to reset -- their password. This form contains a field for the username (plus the CSRF token). -- The form should be posted to 'resetPasswordR'. resetPasswordForm :: (RenderMessage master FormMessage , MonadHandler m , HandlerSite m ~ master ) => AForm m Username resetPasswordForm = areq textField userSettings Nothing where userSettings = FieldSettings (SomeMessage MsgUsername) Nothing (Just "username") Nothing [] -- | A default rendering of 'resetPasswordForm'. resetPasswordWidget :: (YesodAuth master, RenderMessage master FormMessage) => (Route Auth -> Route master) -> WidgetT master IO () resetPasswordWidget tm = do ((_,widget), enctype) <- liftHandlerT $ runFormPost $ renderDivs resetPasswordForm [whamlet|
^{widget} |] 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 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 -- Don't display the email in the message since anybody can request the resend. setMessageI MsgResetPwdEmailSent redirect LoginR -- | The data for setting a new password. data NewPasswordData = NewPasswordData { newPasswordUser :: Username , newPasswordKey :: T.Text , newPasswordPwd1 :: T.Text , newPasswordPwd2 :: T.Text } deriving Show -- | The form for setting a new password. It contains hidden fields for the username and key and prompts -- for the passwords. This form should be posted to 'setPasswordR'. newPasswordForm :: (YesodAuth master, RenderMessage master FormMessage, MonadHandler m, HandlerSite m ~ master) => Username -> T.Text -- ^ key -> 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 [] -- | A default rendering of 'newPasswordForm'. 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|

_{Msg.SetPass} ^{widget} |] 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 -- username is a hidden field so it should be correct. No need to set a message and redirect. Nothing -> permissionDenied "Invalid username" Just user -> do -- the key is a hidden field, no need to set a message and redirect. 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) [] --------------------------------------------------------------------------------------------------- -- | Interface for the data type which stores the user info when not using persistent. -- -- You must make a data type that is either an instance of this class or of -- 'PersistUserCredentials', depending on if you are using persistent or not. -- -- Users are uniquely identified by their username, and for each user we must store the email, -- the verify status, a hashed user password, and a reset password key. The format for the -- hashed password is the format from "Crypto.PasswordStore". If the email has been verified -- and no password reset is in progress, the relevent keys should be the empty string. class UserCredentials u where username :: u -> Username userPasswordHash :: u -> B.ByteString -- ^ see "Crypto.PasswordStore" for the format userEmail :: u -> T.Text userEmailVerified :: u -> Bool -- ^ the status of the user's email verification userEmailVerifyKey :: u -> T.Text -- ^ the verification key which is sent in an email. userResetPwdKey :: u -> T.Text -- ^ the reset password key which is sent in an email. -- | Interface for the data type which stores the user info when using persistent. -- -- You must make a data type that is either an instance of this class or of -- 'UserCredentials', depending on if you are using persistent or not. 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 -- | Creates a new user for use during 'addNewUser'. The starting reset password -- key should be the empty string. userCreate :: Username -> T.Text -- ^ unverified email -> T.Text -- ^ email verification key -> B.ByteString -- ^ hashed and salted password -> u -- | These are the database operations to load and update user data. -- -- Persistent users can use 'AccountPersistDB' and don't need to create their own instance. -- If you are not using persistent or are using persistent but want to customize the database -- activity, you must manually make a monad an instance of this class. You can use any monad -- for which you can write 'runAccountDB', but typically the monad will be a newtype of HandlerT. -- For example, -- -- > newtype MyAccountDB a = MyAccountDB {runMyAccountDB :: HandlerT MyApp IO a} -- > deriving (Monad, MonadIO) -- > instance AccountDB MyAccountDB where -- > .... -- class AccountDB m where -- | The data type which stores the user. Must be an instance of 'UserCredentials'. type UserAccount m -- | Load a user by username loadUser :: Username -> m (Maybe (UserAccount m)) -- | Create new account. The password reset key should be added as an empty string. -- The creation can fail with an error message, in which case the error is set in a -- message and the post handler redirects to 'newAccountR'. addNewUser :: Username -- ^ username -> T.Text -- ^ unverified email -> T.Text -- ^ the email verification key -> B.ByteString -- ^ hashed and salted password -> m (Either T.Text (UserAccount m)) -- | Mark the account as successfully verified. This should reset the email validation key -- to the empty string. verifyAccount :: UserAccount m -> m () -- | Change/set the users email verification key. setVerifyKey :: UserAccount m -> T.Text -- ^ the verification key -> m () -- | Change/set the users password reset key. setNewPasswordKey :: UserAccount m -> T.Text -- ^ the key -> m () -- | Set a new hashed password. This should also set the password reset key to the empty -- string. setNewPassword :: UserAccount m -> B.ByteString -- ^ hashed password -> m () -- | A class to send email. -- -- Both of the methods are implemented by default to just log a message, -- so during development there are no required methods. For production, -- I recommend . class AccountSendEmail master where sendVerifyEmail :: Username -> T.Text -- ^ email address -> T.Text -- ^ verification URL -> HandlerT master IO () sendVerifyEmail uname email url = $(logInfo) $ T.concat [ "Verification email for " , uname , " (", email, "): " , url ] sendNewPasswordEmail :: Username -> T.Text -- ^ email address -> T.Text -- ^ new password URL -> HandlerT master IO () sendNewPasswordEmail uname email url = $(logInfo) $ T.concat [ "Reset password email for " , uname , " (", email, "): " , url ] -- | The main class controlling the account plugin. -- -- You must make your database instance of 'AccountDB' and your master site -- an instance of this class. The only required method is 'runAccountDB', although -- this class contains many other methods to customize the behavior of the account plugin. -- -- Continuing the example from the manual creation of 'AccountDB', a minimal instance is -- -- > instance YesodAuthAccount MyAccountDB MyApp where -- > runAccountDB = runMyAccountDB -- -- If instead you are using persistent and have made an instance of 'PersistUserCredentials', -- a minimal instance is -- -- > instance YesodAuthAccount (AccountPersistDB MyApp User) MyApp where -- > runAccountDB = runAccountPersistDB -- class (YesodAuth master , AccountSendEmail master , AccountDB db , UserCredentials (UserAccount db) , RenderMessage master FormMessage ) => YesodAuthAccount db master | master -> db where -- | Run a database action. This is the only required method. runAccountDB :: db a -> HandlerT master IO a -- | A form validator for valid usernames during new account creation. -- -- By default this allows usernames made up of 'isAlphaNum'. You can also ignore -- this validation and instead validate in 'addNewUser', but validating here -- allows the validation to occur before database activity (checking existing -- username) and before random salt creation (requires IO). 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 -- | What to do when the user logs in and the email has not yet been verified. -- -- By default, this displays a message and contains 'resendVerifyEmailForm', allowing -- the user to resend the verification email. The handler is run inside the post -- handler for login, so you can call 'setCreds' to preform a successful login. unregisteredLogin :: UserAccount db -> HandlerT Auth (HandlerT master IO) Html unregisteredLogin u = do tm <- getRouteToParent lift $ defaultLayout $ do setTitleI MsgEmailUnverified [whamlet|

_{MsgEmailUnverified} ^{resendVerifyEmailWidget (username u) tm} |] -- | The new account page. -- -- This is the page which is displayed on a GET to 'newAccountR', and defaults to -- an embedding of 'newAccountWidget'. getNewAccountR :: HandlerT Auth (HandlerT master IO) Html getNewAccountR = do tm <- getRouteToParent lift $ defaultLayout $ do setTitleI Msg.RegisterLong newAccountWidget tm -- | Handles new account creation. -- -- By default, this processes 'newAccountForm', calls 'createNewAccount', sets a message -- and redirects to LoginR. If an error occurs, a message is set and the user is -- redirected to 'newAccountR'. 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 -- | Should the password reset inside this plugin be allowed? Defaults to True allowPasswordReset :: master -> Bool allowPasswordReset _ = True -- | The page which prompts for a username and sends an email allowing password reset. -- By default, it embeds 'resetPasswordWidget'. getResetPasswordR :: HandlerT Auth (HandlerT master IO) Html getResetPasswordR = do tm <- getRouteToParent lift $ defaultLayout $ do setTitleI Msg.PasswordResetTitle resetPasswordWidget tm -- | The page which allows the user to set a new password. -- -- This is called only when the email key has been verified as correct. By default, it embeds -- 'newPasswordWidget'. setPasswordHandler :: UserAccount db -> HandlerT Auth (HandlerT master IO) Html setPasswordHandler u = do tm <- getRouteToParent lift $ defaultLayout $ do setTitleI Msg.SetPassTitle newPasswordWidget u tm -- | Salt and hash a password. hashPassword :: MonadIO m => T.Text -> m B.ByteString hashPassword pwd = liftIO $ PS.makePassword (TE.encodeUtf8 pwd) 12 -- | Verify a password verifyPassword :: T.Text -- ^ password -> B.ByteString -- ^ hashed password -> Bool verifyPassword pwd = PS.verifyPassword (TE.encodeUtf8 pwd) -- | Randomly create a new verification key. 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 --------------------------------------------------------------------------------------------------- -- | Lens getter 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 -- | Internal state for the AccountPersistDB monad. 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 () } -- | A newtype which when using persistent is an instance of 'AccountDB'. newtype AccountPersistDB master user a = AccountPersistDB (ReaderT (PersistFuncs master user) (HandlerT master IO) 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.=. ""] -- | Use this for 'runAccountDB' if you are using 'AccountPersistDB' as your database type. runAccountPersistDB :: ( Yesod master , YesodPersist master , P.PersistEntity user , PersistUserCredentials user , b ~ YesodPersistBackend master , PersistMonadBackend (b (HandlerT master IO)) ~ P.PersistEntityBackend user , P.PersistUnique (b (HandlerT master IO)) , P.PersistQuery (b (HandlerT master IO)) ) => 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 } yesod-auth-account-1.2.2/tests/0000755000000000000000000000000012203724523014560 5ustar0000000000000000yesod-auth-account-1.2.2/tests/main.hs0000644000000000000000000000117312203724523016042 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Main where import Yesod import Foundation import Test.Hspec import Yesod.Test import Database.Persist.Sqlite import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT) import Control.Monad.Trans.Resource (runResourceT) import BasicTests import NewAccount main :: IO () main = withSqlitePool "test.db3" 10 $ \pool -> do runStderrLoggingT $ runSqlPool (runMigration migrateAll) pool runResourceT $ runNoLoggingT $ runSqlPool (deleteWhere ([] :: [Filter User])) pool hspec $ yesodSpec (MyApp pool) $ do basicSpecs newAccountSpecs yesod-auth-account-1.2.2/tests/BasicTests.hs0000644000000000000000000000501712203724523017163 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module BasicTests (basicSpecs) where import Yesod.Test import Foundation basicSpecs :: YesodSpec MyApp basicSpecs = ydescribe "Basic tests" $ do yit "checks the home page is not logged in" $ do get' "/" statusIs 200 bodyContains "Please visit the Login page" yit "tests an invalid login" $ do get' "/auth/login" statusIs 200 post' "/auth/page/account/login" $ do byLabel "Username" "abc" byLabel "Password" "xxx" statusIs 303 get' "/auth/login" statusIs 200 bodyContains "Invalid username/password combination" yit "new account page looks ok" $ do get' "/auth/page/account/newaccount" statusIs 200 htmlAllContain "title" "Register a new account" bodyContains "Register" yit "reset password page looks ok" $ do get' "/auth/page/account/resetpassword" statusIs 200 bodyContains "Send password reset email" post' "/auth/page/account/resetpassword" $ do byLabel "Username" "abc" addNonce statusIs 303 get' "/" statusIs 200 bodyContains "Invalid username" yit "verify page returns an error" $ do get' "/auth/page/account/verify/abc/xxxxxx" statusIs 303 get' "/" statusIs 200 bodyContains "invalid verification key" yit "new password returns an error" $ do get' "/auth/page/account/newpassword/abc/xxxxxx" statusIs 303 get' "/" statusIs 200 bodyContains "invalid verification key" yit "set password returns an error" $ do post' "/auth/page/account/setpassword" $ do addPostParam "f1" "xxx" addPostParam "f2" "xxx" addPostParam "f3" "xxx" addPostParam "f4" "xxx" addPostParam "f5" "xxx" statusIs 303 get' "/" statusIs 200 bodyContains "As a protection against cross-site" yit "resend verify email returns an error" $ do post' "/auth/page/account/resendverifyemail" $ do addPostParam "f1" "xxx" addPostParam "f2" "xxx" statusIs 400 bodyContains "As a protection against cross-site" yesod-auth-account-1.2.2/tests/Foundation.hs0000644000000000000000000000637012203724523017230 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances, TemplateHaskell, OverloadedStrings #-} {-# LANGUAGE GADTs, MultiParamTypeClasses, TypeSynonymInstances #-} module Foundation where import Data.Text (Text) import Data.ByteString (ByteString) import Database.Persist.Sqlite import Data.IORef import System.IO.Unsafe (unsafePerformIO) import Yesod import Yesod.Auth import Yesod.Auth.Account import Yesod.Test share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| User username Text UniqueUsername username password ByteString emailAddress Text verified Bool verifyKey Text resetPasswordKey Text deriving Show |] instance PersistUserCredentials User where userUsernameF = UserUsername userPasswordHashF = UserPassword userEmailF = UserEmailAddress userEmailVerifiedF = UserVerified userEmailVerifyKeyF = UserVerifyKey userResetPwdKeyF = UserResetPasswordKey uniqueUsername = UniqueUsername userCreate name email key pwd = User name pwd email False key "" data MyApp = MyApp ConnectionPool lastVerifyEmailR :: IORef (Username, Text, Text) -- ^ (username, email, verify url) {-# NOINLINE lastVerifyEmailR #-} lastVerifyEmailR = unsafePerformIO (newIORef ("", "", "")) lastNewPwdEmailR :: IORef (Username, Text, Text) -- ^ (username, email, verify url) {-# NOINLINE lastNewPwdEmailR #-} lastNewPwdEmailR = unsafePerformIO (newIORef ("", "", "")) lastVerifyEmail :: MonadIO m => m (Username, Text, Text) lastVerifyEmail = liftIO $ readIORef lastVerifyEmailR lastNewPwdEmail :: MonadIO m => m (Username, Text, Text) lastNewPwdEmail = liftIO $ readIORef lastNewPwdEmailR mkYesod "MyApp" [parseRoutes| / HomeR GET /auth AuthR Auth getAuth |] instance Yesod MyApp instance RenderMessage MyApp FormMessage where renderMessage _ _ = defaultFormMessage instance YesodPersist MyApp where type YesodPersistBackend MyApp = SqlPersistT runDB action = do MyApp pool <- getYesod runSqlPool action pool instance YesodAuth MyApp where type AuthId MyApp = Username getAuthId = return . Just . credsIdent loginDest _ = HomeR logoutDest _ = HomeR authPlugins _ = [accountPlugin] authHttpManager _ = error "No manager needed" onLogin = return () maybeAuthId = lookupSession "_ID" instance AccountSendEmail MyApp where sendVerifyEmail name email url = liftIO $ writeIORef lastVerifyEmailR (name, email, url) sendNewPasswordEmail name email url = liftIO $ writeIORef lastNewPwdEmailR (name, email, url) instance YesodAuthAccount (AccountPersistDB MyApp User) MyApp where runAccountDB = runAccountPersistDB getHomeR :: Handler Html getHomeR = do maid <- maybeAuthId case maid of Nothing -> defaultLayout $ [whamlet|

Please visit the Login page |] Just u -> defaultLayout $ [whamlet|

You are logged in as #{u}

Logout |] -- Temporary helpers for testing get' :: Yesod site => Text -> YesodExample site () get' url = Yesod.Test.get url post' :: Yesod site => Text -> RequestBuilder site () -> YesodExample site () post' url builder = request $ do setUrl url setMethod "POST" builder yesod-auth-account-1.2.2/tests/NewAccount.hs0000644000000000000000000001302512203724523017163 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module NewAccount (newAccountSpecs) where import Yesod.Auth import Yesod.Test import Foundation import Text.XML.Cursor (attribute) newAccountSpecs :: YesodSpec MyApp newAccountSpecs = ydescribe "New account tests" $ do yit "new account with mismatched passwords" $ do get' "/auth/page/account/newaccount" statusIs 200 bodyContains "Register" post'"/auth/page/account/newaccount" $ do addNonce byLabel "Username" "abc" byLabel "Email" "test@example.com" byLabel "Password" "xxx" byLabel "Confirm" "yyy" statusIs 303 get' "/" statusIs 200 bodyContains "Passwords did not match" yit "creates a new account" $ do get' "/auth/page/account/newaccount" statusIs 200 post'"/auth/page/account/newaccount" $ do addNonce byLabel "Username" "abc" byLabel "Email" "test@example.com" byLabel "Password" "xxx" byLabel "Confirm" "xxx" statusIs 303 get' "/" statusIs 200 bodyContains "A confirmation e-mail has been sent to test@example.com" (username, email, verify) <- lastVerifyEmail assertEqual "username" username "abc" assertEqual "email" email "test@example.com" get' "/auth/page/account/verify/abc/zzzzzz" statusIs 303 get' "/" statusIs 200 bodyContains "invalid verification key" -- try login get' "/auth/login" statusIs 200 post'"/auth/page/account/login" $ do byLabel "Username" "abc" byLabel "Password" "yyy" statusIs 303 get' "/auth/login" statusIs 200 bodyContains "Invalid username/password combination" -- valid login post'"/auth/page/account/login" $ do byLabel "Username" "abc" byLabel "Password" "xxx" statusIs 200 bodyContains "Your email has not yet been verified" -- resend verify email post'"/auth/page/account/resendverifyemail" $ do addNonce addPostParam "f2" "abc" -- username is also a hidden field statusIs 303 get' "/" bodyContains "A confirmation e-mail has been sent to test@example.com" (username', email', verify') <- lastVerifyEmail assertEqual "username" username' "abc" assertEqual "email" email' "test@example.com" assertEqual "verify" True (verify /= verify') -- verify email get' verify' statusIs 303 get' "/" statusIs 200 bodyContains "You are logged in as abc" post $ AuthR LogoutR statusIs 303 get' "/" statusIs 200 bodyContains "Please visit the Login page" -- valid login get' "/auth/login" post'"/auth/page/account/login" $ do byLabel "Username" "abc" byLabel "Password" "xxx" statusIs 303 get' "/" bodyContains "You are logged in as abc" -- logout post $ AuthR LogoutR -- reset password get' "/auth/page/account/resetpassword" statusIs 200 bodyContains "Send password reset email" post'"/auth/page/account/resetpassword" $ do byLabel "Username" "abc" addNonce statusIs 303 get' "/" statusIs 200 bodyContains "A password reset email has been sent to your email address" (username'', email'', newpwd) <- lastNewPwdEmail assertEqual "User" username'' "abc" assertEqual "Email" email'' "test@example.com" -- bad key get' newpwd statusIs 200 post'"/auth/page/account/setpassword" $ do addNonce byLabel "New password" "www" byLabel "Confirm" "www" addPostParam "f2" "abc" addPostParam "f3" "qqqqqqqqqqqqqq" statusIs 403 bodyContains "Invalid key" -- good key get' newpwd statusIs 200 matches <- htmlQuery "input[name=f3][type=hidden][value]" post'"/auth/page/account/setpassword" $ do addNonce byLabel "New password" "www" byLabel "Confirm" "www" addPostParam "f2" "abc" key <- case matches of [] -> error "Unable to find set password key" element:_ -> return $ head $ attribute "value" $ parseHTML element addPostParam "f3" key statusIs 303 get' "/" statusIs 200 bodyContains "Password updated" bodyContains "You are logged in as abc" post $ AuthR LogoutR -- check new password get' "/auth/login" post'"/auth/page/account/login" $ do byLabel "Username" "abc" byLabel "Password" "www" statusIs 303 get' "/" statusIs 200 bodyContains "You are logged in as abc"