diff --git a/yesod-auth/Yesod/Auth/Hardcoded.hs b/yesod-auth/Yesod/Auth/Hardcoded.hs new file mode 100644 index 00000000..592c0cf2 --- /dev/null +++ b/yesod-auth/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} + + +
+