{- Copyright (c) 2014 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 #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- Only orphan instance is RenderMessage AccountMessage -- | 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. -- Currently the persistent option requires both an unique username and email. -- -- * 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 , newPasswordLoggedR , 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 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 -- | Each user is uniquely identified by a username. type Username = T.Text -- | And email (for now just in the Persistent backend). type Email = T.Text -- | The account authentication plugin. Here is a complete example using persistent 2.1 -- and yesod 1.4. -- -- >{-# 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 -- > UniqueEmailAddress emailAddress -- > 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 -- > uniqueEmailaddress = UniqueEmailAddress -- > -- > 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 = SqlBackend -- > 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 credsKey -- > -- >instance AccountSendEmail MyApp -- > -- >instance YesodAuthAccount (AccountPersistDB MyApp User) MyApp where -- > runAccountDB = runAccountPersistDB -- > getTextId _ = return -- > -- >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 = runStderrLoggingT $ withSqlitePool "test.db3" 10 $ \pool -> do -- > runSqlPool (runMigration migrateAll) pool -- > liftIO $ 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 "GET" ["newpasswordlgd"] = getNewPasswordLoggedR >>= 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] -- | Choose a new password while logged in newPasswordLoggedR :: AuthRoute newPasswordLoggedR = PluginR "account" ["newpasswordlgd"] -- | The POST target for reseting the password setPasswordR :: AuthRoute setPasswordR = PluginR "account" ["setpassword"] --------------------------------------------------------------------------------------------------- -- | 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 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 [] -- | 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|