{-# 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
`defaultMaybeAuthId` 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          (AuthHandler, 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 :: AuthRoute
loginR = Text -> Texts -> AuthRoute
PluginR Text
"hardcoded" [Text
"login"]

class (YesodAuth site) => YesodAuthHardcoded site where

  -- | Check whether given user name exists among hardcoded names.
  doesUserNameExist :: Text -> AuthHandler site Bool

  -- | Validate given user name with given password.
  validatePassword :: Text -> Text -> AuthHandler site Bool


authHardcoded :: YesodAuthHardcoded m => AuthPlugin m
authHardcoded :: forall m. YesodAuthHardcoded m => AuthPlugin m
authHardcoded =
  forall master.
Text
-> (Text -> Texts -> AuthHandler master TypedContent)
-> ((AuthRoute -> Route master) -> WidgetFor master ())
-> AuthPlugin master
AuthPlugin Text
"hardcoded" forall m.
YesodAuthHardcoded m =>
Text -> Texts -> AuthHandler m TypedContent
dispatch forall {site}.
YesodAuth site =>
(AuthRoute -> Route site) -> WidgetFor site ()
loginWidget
  where
    dispatch :: YesodAuthHardcoded m => Text -> [Text] -> AuthHandler m TypedContent
    dispatch :: forall m.
YesodAuthHardcoded m =>
Text -> Texts -> AuthHandler m TypedContent
dispatch Text
"POST" [Text
"login"] = forall site.
YesodAuthHardcoded site =>
AuthHandler site TypedContent
postLoginR forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse
    dispatch Text
_ Texts
_              = forall (m :: * -> *) a. MonadHandler m => m a
notFound
    loginWidget :: (AuthRoute -> Route site) -> WidgetFor site ()
loginWidget AuthRoute -> Route site
toMaster = do
      YesodRequest
request <- forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
      [whamlet|
        $newline never
        <form method="post" action="@{toMaster loginR}">
          $maybe t <- reqToken request
            <input type=hidden name=#{defaultCsrfParamName} value=#{t}>
          <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 site
           => AuthHandler site TypedContent
postLoginR :: forall site.
YesodAuthHardcoded site =>
AuthHandler site TypedContent
postLoginR =
  do (Text
username, Text
password) <- forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputPost
       ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Control.Applicative.<$> forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"username"
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
Control.Applicative.<*> forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"password")
     Bool
isValid <- forall site.
YesodAuthHardcoded site =>
Text -> Text -> AuthHandler site Bool
validatePassword Text
username Text
password
     if Bool
isValid
        then forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect (forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
"hardcoded" Text
username [])
        else do Bool
isExists <- forall site.
YesodAuthHardcoded site =>
Text -> AuthHandler site Bool
doesUserNameExist Text
username
                forall master.
AuthRoute -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI AuthRoute
LoginR
                                   (if Bool
isExists
                                       then AuthMessage
Msg.InvalidUsernamePass
                                       else Text -> AuthMessage
Msg.IdentifierNotFound Text
username)