151 lines
4.4 KiB
Haskell
151 lines
4.4 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-|
|
|
Module : Yesod.Auth.Hardcoded
|
|
Description : Very simple auth plugin for harcoded 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 example usage instruction.
|
|
|
|
= Enable plugin
|
|
First of all, add plugin to 'authPlugins' list:
|
|
|
|
@
|
|
instance YesodAuth App where
|
|
authPlugins _ = [authHardcoded]
|
|
@
|
|
|
|
= Define a manager data type
|
|
|
|
@
|
|
data SiteManager = SiteManager
|
|
{ manUserName :: Text
|
|
, manPassWord :: Text }
|
|
|
|
siteManagers :: [SiteManager]
|
|
siteManagers = [SiteManager "content editor" "top secret"]
|
|
@
|
|
|
|
= Describe a plugin instance of your app
|
|
|
|
@
|
|
instance YesodAuthHardcoded App where
|
|
validatePassword u = return . validPassword u
|
|
isUserNameExists = return . lookupUser
|
|
|
|
lookupUser :: Text -> Bool
|
|
lookupUser username =
|
|
case find (\m -> manUserName m == username) siteManagers of
|
|
Just _ -> True
|
|
_ -> False
|
|
|
|
validPassword :: Text -> Text -> Bool
|
|
validPassword u p =
|
|
case find (\m -> manUserName m == u && manPassWord m == p) siteManagers of
|
|
Just _ -> True
|
|
_ -> False
|
|
@
|
|
|
|
= One caveat: 'authenticate' action of 'YesodAuth'.
|
|
|
|
You may want to store additional information for harcoded users in database, but
|
|
in this example let's cheat a bit:
|
|
|
|
@
|
|
instance YesodAuth App where
|
|
authenticate _ =
|
|
return (Authenticated (toSqlKey 0))
|
|
@
|
|
|
|
It is also possible to make 'authenticate' action smart enough to examine which
|
|
plugin was used to log in user, e.g.
|
|
|
|
@
|
|
authenticate creds =
|
|
case credsPlugin creds of
|
|
"hardcoded" -> -- ...
|
|
-- ...
|
|
@
|
|
-}
|
|
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
|
|
<form method="post" action="@{toMaster loginR}">
|
|
<table>
|
|
<tr>
|
|
<th>_{Msg.UserName}
|
|
<td>
|
|
<input type="text" name="username" required>
|
|
<tr>
|
|
<th>_{Msg.Password}
|
|
<td>
|
|
<input type="password" name="password" required>
|
|
<tr>
|
|
<td colspan="2">
|
|
<button type="submit" .btn .btn-success>_{Msg.LoginTitle}
|
|
|]
|
|
|
|
|
|
postLoginR :: (YesodAuthHardcoded master)
|
|
=> HandlerT Auth (HandlerT master IO) TypedContent
|
|
postLoginR =
|
|
do (username, password) <- lift (runInputPost
|
|
((,) <$> ireq textField "username"
|
|
<*> ireq textField "password"))
|
|
isValid <- lift (validatePassword username password)
|
|
if isValid
|
|
then lift (setCredsRedirect (Creds "hardcoded" username []))
|
|
else do isExists <- lift (doesUserNameExist username)
|
|
loginErrorMessageI LoginR
|
|
(if isExists
|
|
then Msg.InvalidUsernamePass
|
|
else Msg.IdentifierNotFound username)
|