diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,11 @@ +## 1.4.11 + +Add Yesod.Auth.Hardcoded + +## 1.4.9 + +* Expose defaultLoginHandler + ## 1.4.8 * GoogleEmail2: proper error message when permission denied diff --git a/Yesod/Auth.hs b/Yesod/Auth.hs --- a/Yesod/Auth.hs +++ b/Yesod/Auth.hs @@ -30,6 +30,7 @@ -- * User functions , AuthenticationResult (..) , defaultMaybeAuthId + , defaultLoginHandler , maybeAuthPair , maybeAuth , requireAuthId @@ -149,16 +150,25 @@ -- | What to show on the login page. -- - -- Default handler concatenates plugin widgets and wraps the result - -- in 'authLayout'. Override if you need fancy widget containers - -- or entirely custom page. + -- By default this calls 'defaultLoginHandler', which concatenates + -- plugin widgets and wraps the result in 'authLayout'. Override if + -- you need fancy widget containers, additional functionality, or an + -- entirely custom page. For example, in some applications you may + -- want to prevent the login page being displayed for a user who is + -- already logged in, even if the URL is visited explicitly; this can + -- be done by overriding 'loginHandler' in your instance declaration + -- with something like: + -- + -- > instance YesodAuth App where + -- > ... + -- > loginHandler = do + -- > ma <- lift maybeAuthId + -- > when (isJust ma) $ + -- > lift $ redirect HomeR -- or any other Handler code you want + -- > defaultLoginHandler + -- loginHandler :: AuthHandler master Html - loginHandler = do - tp <- getRouteToParent - lift $ authLayout $ do - setTitleI Msg.LoginTitle - master <- getYesod - mapM_ (flip apLogin tp) (authPlugins master) + loginHandler = defaultLoginHandler -- | Used for i18n of messages provided by this package. renderAuthMessage :: master @@ -253,6 +263,21 @@ . cached . fmap CachedMaybeAuth . getAuthEntity + + +-- | Default handler to show the login page. +-- +-- This is the default 'loginHandler'. It concatenates plugin widgets and +-- wraps the result in 'authLayout'. See 'loginHandler' for more details. +-- +-- Since 1.4.9 +defaultLoginHandler :: AuthHandler master Html +defaultLoginHandler = do + tp <- getRouteToParent + lift $ authLayout $ do + setTitleI Msg.LoginTitle + master <- getYesod + mapM_ (flip apLogin tp) (authPlugins master) loginErrorMessageI :: (MonadResourceBase m, YesodAuth master) diff --git a/Yesod/Auth/Hardcoded.hs b/Yesod/Auth/Hardcoded.hs new file mode 100644 --- /dev/null +++ b/Yesod/Auth/Hardcoded.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-| +Module : Yesod.Auth.Hardcoded +Description : Very simple auth plugin for hardcoded auth pairs. +Copyright : (c) Arthur Fayzrakhmanov, 2015 +License : MIT +Maintainer : heraldhoi@gmail.com +Stability : experimental + +Sometimes you may want to have some hardcoded set of users (e.g. site managers) +that allowed to log in and visit some specific sections of your website without +ability to register new managers. This simple plugin is designed exactly for +this purpose. + +Here is a quick usage example. + +== Define hardcoded users representation + +Let's assume, that we want to have some hardcoded managers with normal site +users. Let's define hardcoded user representation: + +@ +data SiteManager = SiteManager + { manUserName :: Text + , manPassWord :: Text } + deriving Show + +siteManagers :: [SiteManager] +siteManagers = [SiteManager "content editor" "top secret"] +@ + + +== Describe 'YesodAuth' instance + +Now we need to have some convenient 'AuthId' type representing both +cases: + +@ +instance YesodAuth App where + type AuthId App = Either UserId Text +@ + +Here, right @Text@ value will present hardcoded user name (which obviously must +be unique). + +'AuthId' must have an instance of 'PathPiece' class, this is needed to store +user identifier in session (this happens in 'setCreds' and 'setCredsRedirect' +actions) and to read that identifier from session (this happens in +`dafaultMaybeAuthId` action). So we have to define it: + +@ +import Text.Read (readMaybe) + +instance PathPiece (Either UserId Text) where + fromPathPiece = readMaybe . unpack + toPathPiece = pack . show +@ + +Quiet simple so far. Now let's add plugin to 'authPlugins' list, and define +'authenticate' method, it should return user identifier for given credentials, +for normal users it is usually persistent key, for hardcoded users we will +return user name again. + +@ +instance YesodAuth App where + -- .. + authPlugins _ = [authHardcoded] + + authenticate Creds{..} = + return + (case credsPlugin of + "hardcoded" -> + case lookupUser credsIdent of + Nothing -> UserError InvalidLogin + Just m -> Authenticated (Right (manUserName m))) +@ + +Here @lookupUser@ is just a helper function to lookup hardcoded users by name: + +@ +lookupUser :: Text -> Maybe SiteManager +lookupUser username = find (\m -> manUserName m == username) siteManagers +@ + + +== Describe an 'YesodAuthPersist' instance + +Now we need to manually define 'YesodAuthPersist' instance. + +> instance YesodAuthPersist App where +> type AuthEntity App = Either User SiteManager +> +> getAuthEntity (Left uid) = +> do x <- runDB (get uid) +> return (Left <$> x) +> getAuthEntity (Right username) = return (Right <$> lookupUser username) + + +== Define 'YesodAuthHardcoded' instance + +Finally, let's define an plugin instance + +@ +instance YesodAuthHardcoded App where + validatePassword u = return . validPassword u + doesUserNameExist = return . isJust . lookupUser + +validPassword :: Text -> Text -> Bool +validPassword u p = + case find (\m -> manUserName m == u && manPassWord m == p) siteManagers of + Just _ -> True + _ -> False +@ + + +== Conclusion + +Now we can use 'maybeAuthId', 'maybeAuthPair', 'requireAuthId', and +'requireAuthPair', moreover, the returned value makes possible to distinguish +normal users and site managers. +-} +module Yesod.Auth.Hardcoded + ( YesodAuthHardcoded(..) + , authHardcoded + , loginR ) + where + +import Yesod.Auth (Auth, AuthPlugin (..), AuthRoute, + Creds (..), Route (..), YesodAuth, + loginErrorMessageI, setCredsRedirect) +import qualified Yesod.Auth.Message as Msg +import Yesod.Core +import Yesod.Form (ireq, runInputPost, textField) + +import Control.Applicative ((<$>), (<*>)) +import Data.Text (Text) + + +loginR :: AuthRoute +loginR = PluginR "hardcoded" ["login"] + +class (YesodAuth site) => YesodAuthHardcoded site where + + -- | Check whether given user name exists among hardcoded names. + doesUserNameExist :: Text -> HandlerT site IO Bool + + -- | Validate given user name with given password. + validatePassword :: Text -> Text -> HandlerT site IO Bool + + +authHardcoded :: YesodAuthHardcoded m => AuthPlugin m +authHardcoded = + AuthPlugin "hardcoded" dispatch loginWidget + where + dispatch "POST" ["login"] = postLoginR >>= sendResponse + dispatch _ _ = notFound + loginWidget toMaster = + [whamlet| + $newline never +
+ + + + +
_{Msg.UserName} + + +
_{Msg.Password} + + +
+