    {-# 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 =
      Text
    -> (Text -> Texts -> AuthHandler m TypedContent)
    -> ((AuthRoute -> Route m) -> WidgetFor m ())
    -> AuthPlugin m
    forall master.
    Text
    -> (Text -> Texts -> AuthHandler master TypedContent)
    -> ((AuthRoute -> Route master) -> WidgetFor master ())
    -> AuthPlugin master
    AuthPlugin Text
    "hardcoded" Text -> Texts -> m TypedContent
    Text -> Texts -> AuthHandler m TypedContent
    forall m.
    YesodAuthHardcoded m =>
    Text -> Texts -> AuthHandler m TypedContent
    dispatch (AuthRoute -> Route m) -> WidgetFor m ()
    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"] = m TypedContent
    forall site.
    YesodAuthHardcoded site =>
    AuthHandler site TypedContent
    AuthHandler m TypedContent
    postLoginR m TypedContent
    -> (TypedContent -> m TypedContent) -> m TypedContent
    forall a b. m a -> (a -> m b) -> m b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= TypedContent -> m TypedContent
    forall (m :: * -> *) c a.
    (MonadHandler m, ToTypedContent c) =>
    c -> m a
    sendResponse
        dispatch Text
    _ Texts
    _              = m TypedContent
    forall (m :: * -> *) a. MonadHandler m => m a
    notFound
        loginWidget :: (AuthRoute -> Route site) -> WidgetFor site ()
    loginWidget AuthRoute -> Route site
    toMaster = do
          request <- WidgetFor site YesodRequest
    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 (username, password) <- FormInput m (Text, Text) -> m (Text, Text)
    forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
    runInputPost
           ((,) (Text -> Text -> (Text, Text))
    -> FormInput m Text -> FormInput m (Text -> (Text, Text))
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    Control.Applicative.<$> Field m Text -> Text -> FormInput m Text
    forall (m :: * -> *) a.
    (Monad m, RenderMessage (HandlerSite m) FormMessage) =>
    Field m a -> Text -> FormInput m a
    ireq Field m Text
    forall (m :: * -> *).
    (Monad m, RenderMessage (HandlerSite m) FormMessage) =>
    Field m Text
    textField Text
    "username"
                FormInput m (Text -> (Text, Text))
    -> FormInput m Text -> FormInput m (Text, Text)
    forall a b. FormInput m (a -> b) -> FormInput m a -> FormInput m b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    Control.Applicative.<*> Field m Text -> Text -> FormInput m Text
    forall (m :: * -> *) a.
    (Monad m, RenderMessage (HandlerSite m) FormMessage) =>
    Field m a -> Text -> FormInput m a
    ireq Field m Text
    forall (m :: * -> *).
    (Monad m, RenderMessage (HandlerSite m) FormMessage) =>
    Field m Text
    textField Text
    "password")
         isValid <- validatePassword username password
         if isValid
            then setCredsRedirect (Creds "hardcoded" username [])
            else do isExists <- doesUserNameExist username
                    loginErrorMessageI LoginR
                                       (if isExists
                                           then Msg.InvalidUsernamePass
                                           else Msg.IdentifierNotFound username)