{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Yesod.Auth
    ( -- * Subsite
      Auth
    , AuthRoute
    , Route (..)
    , AuthPlugin (..)
    , getAuth
    , YesodAuth (..)
    , YesodAuthPersist (..)
      -- * Plugin interface
    , Creds (..)
    , setCreds
    , setCredsRedirect
    , clearCreds
    , loginErrorMessage
    , loginErrorMessageI
      -- * User functions
    , AuthenticationResult (..)
    , defaultMaybeAuthId
    , defaultLoginHandler
    , maybeAuthPair
    , maybeAuth
    , requireAuthId
    , requireAuthPair
    , requireAuth
      -- * Exception
    , AuthException (..)
      -- * Helper
    , MonadAuthHandler
    , AuthHandler
      -- * Internal
    , credsKey
    , provideJsonMessage
    , messageJson401
    , asHtml
    ) where

import Control.Monad                 (when)
import Control.Monad.Trans.Maybe
import UnliftIO                      (withRunInIO, MonadUnliftIO)

import Yesod.Auth.Routes
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.HashMap.Lazy as Map
import Data.Monoid (Endo)
import Network.HTTP.Client (Manager, Request, withResponse, Response, BodyReader)
import Network.HTTP.Client.TLS (getGlobalManager)

import qualified Network.Wai as W

import Yesod.Core
import Yesod.Persist
import Yesod.Auth.Message (AuthMessage, defaultMessage)
import qualified Yesod.Auth.Message as Msg
import Yesod.Form (FormMessage)
import Data.Typeable (Typeable)
import Control.Exception (Exception)
import Network.HTTP.Types (Status, internalServerError500, unauthorized401)
import qualified Control.Monad.Trans.Writer    as Writer
import Control.Monad (void)

type AuthRoute = Route Auth

type MonadAuthHandler master m = (MonadHandler m, YesodAuth master, master ~ HandlerSite m, Auth ~ SubHandlerSite m, MonadUnliftIO m)
type AuthHandler master a = forall m. MonadAuthHandler master m => m a

type Method = Text
type Piece = Text

-- | The result of an authentication based on credentials
--
-- @since 1.4.4
data AuthenticationResult master
    = Authenticated (AuthId master) -- ^ Authenticated successfully
    | UserError AuthMessage         -- ^ Invalid credentials provided by user
    | ServerError Text              -- ^ Some other error

data AuthPlugin master = AuthPlugin
    { AuthPlugin master -> Text
apName :: Text
    , AuthPlugin master
-> Text -> [Text] -> AuthHandler master TypedContent
apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent
    , AuthPlugin master
-> (Route Auth -> Route master) -> WidgetFor master ()
apLogin :: (Route Auth -> Route master) -> WidgetFor master ()
    }

getAuth :: a -> Auth
getAuth :: a -> Auth
getAuth = Auth -> a -> Auth
forall a b. a -> b -> a
const Auth
Auth

-- | User credentials
data Creds master = Creds
    { Creds master -> Text
credsPlugin :: Text -- ^ How the user was authenticated
    , Creds master -> Text
credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin.
    , Creds master -> [(Text, Text)]
credsExtra :: [(Text, Text)]
    } deriving (Int -> Creds master -> ShowS
[Creds master] -> ShowS
Creds master -> String
(Int -> Creds master -> ShowS)
-> (Creds master -> String)
-> ([Creds master] -> ShowS)
-> Show (Creds master)
forall master. Int -> Creds master -> ShowS
forall master. [Creds master] -> ShowS
forall master. Creds master -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Creds master] -> ShowS
$cshowList :: forall master. [Creds master] -> ShowS
show :: Creds master -> String
$cshow :: forall master. Creds master -> String
showsPrec :: Int -> Creds master -> ShowS
$cshowsPrec :: forall master. Int -> Creds master -> ShowS
Show)

class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage) => YesodAuth master where
    type AuthId master

    -- | specify the layout. Uses defaultLayout by default
    authLayout :: (MonadHandler m, HandlerSite m ~ master) => WidgetFor master () -> m Html
    authLayout = HandlerFor master Html -> m Html
forall (m :: * -> *) a.
MonadHandler m =>
HandlerFor (HandlerSite m) a -> m a
liftHandler (HandlerFor master Html -> m Html)
-> (WidgetFor master () -> HandlerFor master Html)
-> WidgetFor master ()
-> m Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WidgetFor master () -> HandlerFor master Html
forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Html
defaultLayout

    -- | Default destination on successful login, if no other
    -- destination exists.
    loginDest :: master -> Route master

    -- | Default destination on successful logout, if no other
    -- destination exists.
    logoutDest :: master -> Route master

    -- | Perform authentication based on the given credentials.
    --
    -- Default implementation is in terms of @'getAuthId'@
    --
    -- @since: 1.4.4
    authenticate :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (AuthenticationResult master)
    authenticate Creds master
creds = do
        Maybe (AuthId master)
muid <- Creds master -> m (Maybe (AuthId master))
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
Creds master -> m (Maybe (AuthId master))
getAuthId Creds master
creds

        AuthenticationResult master -> m (AuthenticationResult master)
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthenticationResult master -> m (AuthenticationResult master))
-> AuthenticationResult master -> m (AuthenticationResult master)
forall a b. (a -> b) -> a -> b
$ AuthenticationResult master
-> (AuthId master -> AuthenticationResult master)
-> Maybe (AuthId master)
-> AuthenticationResult master
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AuthMessage -> AuthenticationResult master
forall master. AuthMessage -> AuthenticationResult master
UserError AuthMessage
Msg.InvalidLogin) AuthId master -> AuthenticationResult master
forall master. AuthId master -> AuthenticationResult master
Authenticated Maybe (AuthId master)
muid

    -- | Determine the ID associated with the set of credentials.
    --
    -- Default implementation is in terms of @'authenticate'@
    --
    getAuthId :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (Maybe (AuthId master))
    getAuthId Creds master
creds = do
        AuthenticationResult master
auth <- Creds master -> m (AuthenticationResult master)
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
Creds master -> m (AuthenticationResult master)
authenticate Creds master
creds

        Maybe (AuthId master) -> m (Maybe (AuthId master))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (AuthId master) -> m (Maybe (AuthId master)))
-> Maybe (AuthId master) -> m (Maybe (AuthId master))
forall a b. (a -> b) -> a -> b
$ case AuthenticationResult master
auth of
            Authenticated AuthId master
auid -> AuthId master -> Maybe (AuthId master)
forall a. a -> Maybe a
Just AuthId master
auid
            AuthenticationResult master
_ -> Maybe (AuthId master)
forall a. Maybe a
Nothing

    -- | Which authentication backends to use.
    authPlugins :: master -> [AuthPlugin master]

    -- | What to show on the login 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 = m Html
forall master. AuthHandler master Html
defaultLoginHandler

    -- | Used for i18n of messages provided by this package.
    renderAuthMessage :: master
                      -> [Text] -- ^ languages
                      -> AuthMessage
                      -> Text
    renderAuthMessage master
_ [Text]
_ = AuthMessage -> Text
defaultMessage

    -- | After login and logout, redirect to the referring page, instead of
    -- 'loginDest' and 'logoutDest'. Default is 'False'.
    redirectToReferer :: master -> Bool
    redirectToReferer master
_ = Bool
False

    -- | When being redirected to the login page should the current page
    -- be set to redirect back to. Default is 'True'.
    --
    -- @since 1.4.21
    redirectToCurrent :: master -> Bool
    redirectToCurrent master
_ = Bool
True

    -- | Return an HTTP connection manager that is stored in the foundation
    -- type. This allows backends to reuse persistent connections. If none of
    -- the backends you're using use HTTP connections, you can safely return
    -- @error \"authHttpManager\"@ here.
    authHttpManager :: (MonadHandler m, HandlerSite m ~ master) => m Manager
    authHttpManager = IO Manager -> m Manager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Manager
getGlobalManager

    -- | Called on a successful login. By default, calls
    -- @addMessageI "success" NowLoggedIn@.
    onLogin :: (MonadHandler m, master ~ HandlerSite m) => m ()
    onLogin = Text -> AuthMessage -> m ()
forall (m :: * -> *) msg.
(MonadHandler m, RenderMessage (HandlerSite m) msg) =>
Text -> msg -> m ()
addMessageI Text
"success" AuthMessage
Msg.NowLoggedIn

    -- | Called on logout. By default, does nothing
    onLogout :: (MonadHandler m, master ~ HandlerSite m) => m ()
    onLogout = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- | Retrieves user credentials, if user is authenticated.
    --
    -- By default, this calls 'defaultMaybeAuthId' to get the user ID from the
    -- session. This can be overridden to allow authentication via other means,
    -- such as checking for a special token in a request header. This is
    -- especially useful for creating an API to be accessed via some means
    -- other than a browser.
    --
    -- @since 1.2.0
    maybeAuthId :: (MonadHandler m, master ~ HandlerSite m) => m (Maybe (AuthId master))

    default maybeAuthId
        :: (MonadHandler m, master ~ HandlerSite m, YesodAuthPersist master, Typeable (AuthEntity master))
        => m (Maybe (AuthId master))
    maybeAuthId = m (Maybe (AuthId master))
forall (m :: * -> *) master.
(MonadHandler m, HandlerSite m ~ master, YesodAuthPersist master,
 Typeable (AuthEntity master)) =>
m (Maybe (AuthId master))
defaultMaybeAuthId

    -- | Called on login error for HTTP requests. By default, calls
    -- @addMessage@ with "error" as status and redirects to @dest@.
    onErrorHtml :: (MonadHandler m, HandlerSite m ~ master) => Route master -> Text -> m Html
    onErrorHtml Route master
dest Text
msg = do
        Text -> Html -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Html -> m ()
addMessage Text
"error" (Html -> m ()) -> Html -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
toHtml Text
msg
        (Html -> Html) -> m Html -> m Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Html -> Html
asHtml (m Html -> m Html) -> m Html -> m Html
forall a b. (a -> b) -> a -> b
$ Route master -> m Html
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect Route master
dest

    -- | runHttpRequest gives you a chance to handle an HttpException and retry
    --  The default behavior is to simply execute the request which will throw an exception on failure
    --
    --  The HTTP 'Request' is given in case it is useful to change behavior based on inspecting the request.
    --  This is an experimental API that is not broadly used throughout the yesod-auth code base
    runHttpRequest
      :: (MonadHandler m, HandlerSite m ~ master, MonadUnliftIO m)
      => Request
      -> (Response BodyReader -> m a)
      -> m a
    runHttpRequest Request
req Response BodyReader -> m a
inner = do
      Manager
man <- m Manager
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
m Manager
authHttpManager
      ((forall a. m a -> IO a) -> IO a) -> m a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> Request -> Manager -> (Response BodyReader -> IO a) -> IO a
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
req Manager
man ((Response BodyReader -> IO a) -> IO a)
-> (Response BodyReader -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ m a -> IO a
forall a. m a -> IO a
run (m a -> IO a)
-> (Response BodyReader -> m a) -> Response BodyReader -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response BodyReader -> m a
inner

    {-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins #-}

{-# DEPRECATED getAuthId "Define 'authenticate' instead; 'getAuthId' will be removed in the next major version" #-}

-- | Internal session key used to hold the authentication information.
--
-- @since 1.2.3
credsKey :: Text
credsKey :: Text
credsKey = Text
"_ID"

-- | Retrieves user credentials from the session, if user is authenticated.
--
-- This function does /not/ confirm that the credentials are valid, see
-- 'maybeAuthIdRaw' for more information. The first call in a request
-- does a database request to make sure that the account is still in the database.
--
-- @since 1.1.2
defaultMaybeAuthId
    :: (MonadHandler m, HandlerSite m ~ master, YesodAuthPersist master, Typeable (AuthEntity master))
    => m (Maybe (AuthId master))
defaultMaybeAuthId :: m (Maybe (AuthId master))
defaultMaybeAuthId = MaybeT m (AuthId master) -> m (Maybe (AuthId master))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m (AuthId master) -> m (Maybe (AuthId master)))
-> MaybeT m (AuthId master) -> m (Maybe (AuthId master))
forall a b. (a -> b) -> a -> b
$ do
    Text
s   <- m (Maybe Text) -> MaybeT m Text
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe Text) -> MaybeT m Text)
-> m (Maybe Text) -> MaybeT m Text
forall a b. (a -> b) -> a -> b
$ Text -> m (Maybe Text)
forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupSession Text
credsKey
    AuthId master
aid <- m (Maybe (AuthId master)) -> MaybeT m (AuthId master)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe (AuthId master)) -> MaybeT m (AuthId master))
-> m (Maybe (AuthId master)) -> MaybeT m (AuthId master)
forall a b. (a -> b) -> a -> b
$ Maybe (AuthId master) -> m (Maybe (AuthId master))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (AuthId master) -> m (Maybe (AuthId master)))
-> Maybe (AuthId master) -> m (Maybe (AuthId master))
forall a b. (a -> b) -> a -> b
$ Text -> Maybe (AuthId master)
forall s. PathPiece s => Text -> Maybe s
fromPathPiece Text
s
    AuthEntity master
_   <- m (Maybe (AuthEntity master)) -> MaybeT m (AuthEntity master)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe (AuthEntity master)) -> MaybeT m (AuthEntity master))
-> m (Maybe (AuthEntity master)) -> MaybeT m (AuthEntity master)
forall a b. (a -> b) -> a -> b
$ AuthId master -> m (Maybe (AuthEntity master))
forall (m :: * -> *) master.
(MonadHandler m, YesodAuthPersist master,
 Typeable (AuthEntity master), HandlerSite m ~ master) =>
AuthId master -> m (Maybe (AuthEntity master))
cachedAuth AuthId master
aid
    AuthId master -> MaybeT m (AuthId master)
forall (m :: * -> *) a. Monad m => a -> m a
return AuthId master
aid

cachedAuth
    :: ( MonadHandler m
       , YesodAuthPersist master
       , Typeable (AuthEntity master)
       , HandlerSite m ~ master
       )
    => AuthId master
    -> m (Maybe (AuthEntity master))
cachedAuth :: AuthId master -> m (Maybe (AuthEntity master))
cachedAuth
    = (CachedMaybeAuth (AuthEntity master) -> Maybe (AuthEntity master))
-> m (CachedMaybeAuth (AuthEntity master))
-> m (Maybe (AuthEntity master))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CachedMaybeAuth (AuthEntity master) -> Maybe (AuthEntity master)
forall val. CachedMaybeAuth val -> Maybe val
unCachedMaybeAuth
    (m (CachedMaybeAuth (AuthEntity master))
 -> m (Maybe (AuthEntity master)))
-> (AuthId master -> m (CachedMaybeAuth (AuthEntity master)))
-> AuthId master
-> m (Maybe (AuthEntity master))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (CachedMaybeAuth (AuthEntity master))
-> m (CachedMaybeAuth (AuthEntity master))
forall (m :: * -> *) a. (MonadHandler m, Typeable a) => m a -> m a
cached
    (m (CachedMaybeAuth (AuthEntity master))
 -> m (CachedMaybeAuth (AuthEntity master)))
-> (AuthId master -> m (CachedMaybeAuth (AuthEntity master)))
-> AuthId master
-> m (CachedMaybeAuth (AuthEntity master))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (AuthEntity master) -> CachedMaybeAuth (AuthEntity master))
-> m (Maybe (AuthEntity master))
-> m (CachedMaybeAuth (AuthEntity master))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (AuthEntity master) -> CachedMaybeAuth (AuthEntity master)
forall val. Maybe val -> CachedMaybeAuth val
CachedMaybeAuth
    (m (Maybe (AuthEntity master))
 -> m (CachedMaybeAuth (AuthEntity master)))
-> (AuthId master -> m (Maybe (AuthEntity master)))
-> AuthId master
-> m (CachedMaybeAuth (AuthEntity master))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthId master -> m (Maybe (AuthEntity master))
forall master (m :: * -> *).
(YesodAuthPersist master, MonadHandler m,
 HandlerSite m ~ master) =>
AuthId master -> m (Maybe (AuthEntity master))
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 :: m Html
defaultLoginHandler = do
    Route Auth -> Route master
tp <- m (Route Auth -> Route master)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
    WidgetFor master () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor master () -> m Html) -> WidgetFor master () -> m Html
forall a b. (a -> b) -> a -> b
$ do
        AuthMessage -> WidgetFor master ()
forall (m :: * -> *) msg.
(MonadWidget m, RenderMessage (HandlerSite m) msg) =>
msg -> m ()
setTitleI AuthMessage
Msg.LoginTitle
        master
master <- WidgetFor master master
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
        (AuthPlugin master -> WidgetFor master ())
-> [AuthPlugin master] -> WidgetFor master ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((AuthPlugin master
 -> (Route Auth -> Route master) -> WidgetFor master ())
-> (Route Auth -> Route master)
-> AuthPlugin master
-> WidgetFor master ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip AuthPlugin master
-> (Route Auth -> Route master) -> WidgetFor master ()
forall master.
AuthPlugin master
-> (Route Auth -> Route master) -> WidgetFor master ()
apLogin Route Auth -> Route master
tp) (master -> [AuthPlugin master]
forall master. YesodAuth master => master -> [AuthPlugin master]
authPlugins master
master)


loginErrorMessageI
  :: Route Auth
  -> AuthMessage
  -> AuthHandler master TypedContent
loginErrorMessageI :: Route Auth -> AuthMessage -> AuthHandler master TypedContent
loginErrorMessageI Route Auth
dest AuthMessage
msg = do
  Route Auth -> Route master
toParent <- m (Route Auth -> Route master)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
  Route master -> AuthMessage -> m TypedContent
forall (m :: * -> *) master.
(MonadHandler m, HandlerSite m ~ master, YesodAuth master) =>
Route master -> AuthMessage -> m TypedContent
loginErrorMessageMasterI (Route Auth -> Route master
toParent Route Auth
dest) AuthMessage
msg


loginErrorMessageMasterI
  :: (MonadHandler m, HandlerSite m ~ master, YesodAuth master)
  => Route master
  -> AuthMessage
  -> m TypedContent
loginErrorMessageMasterI :: Route master -> AuthMessage -> m TypedContent
loginErrorMessageMasterI Route master
dest AuthMessage
msg = do
  AuthMessage -> Text
mr <- m (AuthMessage -> Text)
forall (m :: * -> *) message.
(MonadHandler m, RenderMessage (HandlerSite m) message) =>
m (message -> Text)
getMessageRender
  Route (HandlerSite m) -> Text -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Route (HandlerSite m) -> Text -> m TypedContent
loginErrorMessage Route master
Route (HandlerSite m)
dest (AuthMessage -> Text
mr AuthMessage
msg)

-- | For HTML, set the message and redirect to the route.
-- For JSON, send the message and a 401 status
loginErrorMessage
         :: (MonadHandler m, YesodAuth (HandlerSite m))
         => Route (HandlerSite m)
         -> Text
         -> m TypedContent
loginErrorMessage :: Route (HandlerSite m) -> Text -> m TypedContent
loginErrorMessage Route (HandlerSite m)
dest Text
msg = Text -> m Html -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Text -> m Html -> m TypedContent
messageJson401 Text
msg (Route (HandlerSite m) -> Text -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
Route master -> Text -> m Html
onErrorHtml Route (HandlerSite m)
dest Text
msg)

messageJson401
  :: MonadHandler m
  => Text
  -> m Html
  -> m TypedContent
messageJson401 :: Text -> m Html -> m TypedContent
messageJson401 = Status -> Text -> m Html -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Status -> Text -> m Html -> m TypedContent
messageJsonStatus Status
unauthorized401

messageJson500 :: MonadHandler m => Text -> m Html -> m TypedContent
messageJson500 :: Text -> m Html -> m TypedContent
messageJson500 = Status -> Text -> m Html -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Status -> Text -> m Html -> m TypedContent
messageJsonStatus Status
internalServerError500

messageJsonStatus
  :: MonadHandler m
  => Status
  -> Text
  -> m Html
  -> m TypedContent
messageJsonStatus :: Status -> Text -> m Html -> m TypedContent
messageJsonStatus Status
status Text
msg m Html
html = Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
    m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep m Html
html
    m Value -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Value -> Writer (Endo [ProvidedRep m]) ())
-> m Value -> Writer (Endo [ProvidedRep m]) ()
forall a b. (a -> b) -> a -> b
$ do
        let obj :: Value
obj = [Pair] -> Value
object [Key
"message" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
msg]
        m Any -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Any -> m ()) -> m Any -> m ()
forall a b. (a -> b) -> a -> b
$ Status -> Value -> m Any
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
Status -> c -> m a
sendResponseStatus Status
status Value
obj
        Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
obj

provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) ()
provideJsonMessage :: Text -> Writer (Endo [ProvidedRep m]) ()
provideJsonMessage Text
msg = m Value -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Value -> Writer (Endo [ProvidedRep m]) ())
-> m Value -> Writer (Endo [ProvidedRep m]) ()
forall a b. (a -> b) -> a -> b
$ Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Key
"message" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
msg]


setCredsRedirect
  :: (MonadHandler m, YesodAuth (HandlerSite m))
  => Creds (HandlerSite m) -- ^ new credentials
  -> m TypedContent
setCredsRedirect :: Creds (HandlerSite m) -> m TypedContent
setCredsRedirect Creds (HandlerSite m)
creds = do
    HandlerSite m
y    <- m (HandlerSite m)
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    AuthenticationResult (HandlerSite m)
auth <- Creds (HandlerSite m) -> m (AuthenticationResult (HandlerSite m))
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
Creds master -> m (AuthenticationResult master)
authenticate Creds (HandlerSite m)
creds
    case AuthenticationResult (HandlerSite m)
auth of
        Authenticated AuthId (HandlerSite m)
aid -> do
            Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
credsKey (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ AuthId (HandlerSite m) -> Text
forall s. PathPiece s => s -> Text
toPathPiece AuthId (HandlerSite m)
aid
            m ()
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, master ~ HandlerSite m) =>
m ()
onLogin
            TypedContent
res <- Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
                ContentType -> m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, ToContent a) =>
ContentType -> m a -> Writer (Endo [ProvidedRep m]) ()
provideRepType ContentType
typeHtml (m Html -> Writer (Endo [ProvidedRep m]) ())
-> m Html -> Writer (Endo [ProvidedRep m]) ()
forall a b. (a -> b) -> a -> b
$
                    (Html -> Html) -> m Html -> m Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Html -> Html
asHtml (m Html -> m Html) -> m Html -> m Html
forall a b. (a -> b) -> a -> b
$ Route (HandlerSite m) -> m Html
forall (m :: * -> *) url a.
(RedirectUrl (HandlerSite m) url, MonadHandler m) =>
url -> m a
redirectUltDest (Route (HandlerSite m) -> m Html)
-> Route (HandlerSite m) -> m Html
forall a b. (a -> b) -> a -> b
$ HandlerSite m -> Route (HandlerSite m)
forall master. YesodAuth master => master -> Route master
loginDest HandlerSite m
y
                Text -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *).
Monad m =>
Text -> Writer (Endo [ProvidedRep m]) ()
provideJsonMessage Text
"Login Successful"
            TypedContent -> m TypedContent
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse TypedContent
res

        UserError AuthMessage
msg ->
            case HandlerSite m -> Maybe (Route (HandlerSite m))
forall site. Yesod site => site -> Maybe (Route site)
authRoute HandlerSite m
y of
                Maybe (Route (HandlerSite m))
Nothing -> do
                    Text
msg' <- AuthMessage -> m Text
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
AuthMessage -> m Text
renderMessage' AuthMessage
msg
                    Text -> m Html -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Text -> m Html -> m TypedContent
messageJson401 Text
msg' (m Html -> m TypedContent) -> m Html -> m TypedContent
forall a b. (a -> b) -> a -> b
$ WidgetFor (HandlerSite m) () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor (HandlerSite m) () -> m Html)
-> WidgetFor (HandlerSite m) () -> m Html
forall a b. (a -> b) -> a -> b
$ -- TODO
                        WidgetFor (HandlerSite m) () -> WidgetFor (HandlerSite m) ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [whamlet|<h1>_{msg}|]
                Just Route (HandlerSite m)
ar -> Route (HandlerSite m) -> AuthMessage -> m TypedContent
forall (m :: * -> *) master.
(MonadHandler m, HandlerSite m ~ master, YesodAuth master) =>
Route master -> AuthMessage -> m TypedContent
loginErrorMessageMasterI Route (HandlerSite m)
ar AuthMessage
msg

        ServerError Text
msg -> do
            $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> m ()
(Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
pack :: String -> Text
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logError) Text
msg

            case HandlerSite m -> Maybe (Route (HandlerSite m))
forall site. Yesod site => site -> Maybe (Route site)
authRoute HandlerSite m
y of
                Maybe (Route (HandlerSite m))
Nothing -> do
                    Text
msg' <- AuthMessage -> m Text
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
AuthMessage -> m Text
renderMessage' AuthMessage
Msg.AuthError
                    Text -> m Html -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Text -> m Html -> m TypedContent
messageJson500 Text
msg' (m Html -> m TypedContent) -> m Html -> m TypedContent
forall a b. (a -> b) -> a -> b
$ WidgetFor (HandlerSite m) () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout (WidgetFor (HandlerSite m) () -> m Html)
-> WidgetFor (HandlerSite m) () -> m Html
forall a b. (a -> b) -> a -> b
$
                        WidgetFor (HandlerSite m) () -> WidgetFor (HandlerSite m) ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [whamlet|<h1>_{Msg.AuthError}|]
                Just Route (HandlerSite m)
ar -> Route (HandlerSite m) -> AuthMessage -> m TypedContent
forall (m :: * -> *) master.
(MonadHandler m, HandlerSite m ~ master, YesodAuth master) =>
Route master -> AuthMessage -> m TypedContent
loginErrorMessageMasterI Route (HandlerSite m)
ar AuthMessage
Msg.AuthError

  where
    renderMessage' :: AuthMessage -> m Text
renderMessage' AuthMessage
msg = do
        [Text]
langs <- m [Text]
forall (m :: * -> *). MonadHandler m => m [Text]
languages
        HandlerSite m
master <- m (HandlerSite m)
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
        Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ HandlerSite m -> [Text] -> AuthMessage -> Text
forall master.
YesodAuth master =>
master -> [Text] -> AuthMessage -> Text
renderAuthMessage HandlerSite m
master [Text]
langs AuthMessage
msg

-- | Sets user credentials for the session after checking them with authentication backends.
setCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
         => Bool                  -- ^ if HTTP redirects should be done
         -> Creds (HandlerSite m) -- ^ new credentials
         -> m ()
setCreds :: Bool -> Creds (HandlerSite m) -> m ()
setCreds Bool
doRedirects Creds (HandlerSite m)
creds =
    if Bool
doRedirects
      then m TypedContent -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m TypedContent -> m ()) -> m TypedContent -> m ()
forall a b. (a -> b) -> a -> b
$ Creds (HandlerSite m) -> m TypedContent
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect Creds (HandlerSite m)
creds
      else do AuthenticationResult (HandlerSite m)
auth <- Creds (HandlerSite m) -> m (AuthenticationResult (HandlerSite m))
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
Creds master -> m (AuthenticationResult master)
authenticate Creds (HandlerSite m)
creds
              case AuthenticationResult (HandlerSite m)
auth of
                  Authenticated AuthId (HandlerSite m)
aid -> Text -> Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> Text -> m ()
setSession Text
credsKey (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ AuthId (HandlerSite m) -> Text
forall s. PathPiece s => s -> Text
toPathPiece AuthId (HandlerSite m)
aid
                  AuthenticationResult (HandlerSite m)
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | same as defaultLayoutJson, but uses authLayout
authLayoutJson
  :: (ToJSON j, MonadAuthHandler master m)
  => WidgetFor master ()  -- ^ HTML
  -> m j  -- ^ JSON
  -> m TypedContent
authLayoutJson :: WidgetFor master () -> m j -> m TypedContent
authLayoutJson WidgetFor master ()
w m j
json = Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep (Writer (Endo [ProvidedRep m]) () -> m TypedContent)
-> Writer (Endo [ProvidedRep m]) () -> m TypedContent
forall a b. (a -> b) -> a -> b
$ do
    m Html -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Html -> Writer (Endo [ProvidedRep m]) ())
-> m Html -> Writer (Endo [ProvidedRep m]) ()
forall a b. (a -> b) -> a -> b
$ WidgetFor master () -> m Html
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
WidgetFor master () -> m Html
authLayout WidgetFor master ()
w
    m Value -> Writer (Endo [ProvidedRep m]) ()
forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (m Value -> Writer (Endo [ProvidedRep m]) ())
-> m Value -> Writer (Endo [ProvidedRep m]) ()
forall a b. (a -> b) -> a -> b
$ (j -> Value) -> m j -> m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap j -> Value
forall a. ToJSON a => a -> Value
toJSON m j
json

-- | Clears current user credentials for the session.
--
-- @since 1.1.7
clearCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
           => Bool -- ^ if HTTP, redirect to 'logoutDest'
           -> m ()
clearCreds :: Bool -> m ()
clearCreds Bool
doRedirects = do
    m ()
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, master ~ HandlerSite m) =>
m ()
onLogout
    Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
credsKey
    HandlerSite m
y  <- m (HandlerSite m)
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    Bool
aj <- m Bool
forall (m :: * -> *). MonadHandler m => m Bool
acceptsJson
    case (Bool
aj, Bool
doRedirects) of
      (Bool
True, Bool
_)               -> Value -> m ()
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
c -> m a
sendResponse Value
successfulLogout
      (Bool
False, Bool
True)           -> Route (HandlerSite m) -> m ()
forall (m :: * -> *) url a.
(RedirectUrl (HandlerSite m) url, MonadHandler m) =>
url -> m a
redirectUltDest (HandlerSite m -> Route (HandlerSite m)
forall master. YesodAuth master => master -> Route master
logoutDest HandlerSite m
y)
      (Bool, Bool)
_                       -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    where successfulLogout :: Value
successfulLogout = [Pair] -> Value
object [Key
"message" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
msg]
          msg :: Text
          msg :: Text
msg = Text
"Logged out successfully!"

getCheckR :: AuthHandler master TypedContent
getCheckR :: m TypedContent
getCheckR = do
    Maybe (AuthId master)
creds <- m (Maybe (AuthId master))
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, master ~ HandlerSite m) =>
m (Maybe (AuthId master))
maybeAuthId
    WidgetFor master () -> m Value -> m TypedContent
forall j master (m :: * -> *).
(ToJSON j, MonadAuthHandler master m) =>
WidgetFor master () -> m j -> m TypedContent
authLayoutJson (do
        Html -> WidgetFor master ()
forall (m :: * -> *). MonadWidget m => Html -> m ()
setTitle Html
"Authentication Status"
        Html -> WidgetFor master ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget (Html -> WidgetFor master ()) -> Html -> WidgetFor master ()
forall a b. (a -> b) -> a -> b
$ Maybe (AuthId master) -> Html
forall v. Maybe v -> Html
html' Maybe (AuthId master)
creds) (Value -> m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Maybe (AuthId master) -> Value
forall b. Maybe b -> Value
jsonCreds Maybe (AuthId master)
creds)
  where
    html' :: Maybe v -> Html
html' Maybe v
creds =
        [shamlet|
$newline never
<h1>Authentication Status
$maybe _ <- creds
    <p>Logged in.
$nothing
    <p>Not logged in.
|]
    jsonCreds :: Maybe b -> Value
jsonCreds Maybe b
creds =
        HashMap Text Value -> Value
forall a. ToJSON a => a -> Value
toJSON (HashMap Text Value -> Value) -> HashMap Text Value -> Value
forall a b. (a -> b) -> a -> b
$ [(Text, Value)] -> HashMap Text Value
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList
            [ (String -> Text
T.pack String
"logged_in", Bool -> Value
Bool (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Bool -> (b -> Bool) -> Maybe b -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
True) Maybe b
creds)
            ]

setUltDestReferer' :: (MonadHandler m, YesodAuth (HandlerSite m)) => m ()
setUltDestReferer' :: m ()
setUltDestReferer' = do
    HandlerSite m
master <- m (HandlerSite m)
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HandlerSite m -> Bool
forall master. YesodAuth master => master -> Bool
redirectToReferer HandlerSite m
master) m ()
forall (m :: * -> *). MonadHandler m => m ()
setUltDestReferer

getLoginR :: AuthHandler master Html
getLoginR :: m Html
getLoginR = m ()
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
m ()
setUltDestReferer' m () -> m Html -> m Html
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m Html
forall master. YesodAuth master => AuthHandler master Html
loginHandler

getLogoutR :: AuthHandler master ()
getLogoutR :: m ()
getLogoutR = do
  Route Auth -> Route master
tp <- m (Route Auth -> Route master)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
  m ()
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
m ()
setUltDestReferer' m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Route master -> m ()
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirectToPost (Route Auth -> Route master
tp Route Auth
LogoutR)

postLogoutR :: AuthHandler master ()
postLogoutR :: m ()
postLogoutR = Bool -> m ()
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Bool -> m ()
clearCreds Bool
True

handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent
handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent
handlePluginR Text
plugin [Text]
pieces = do
    master
master <- m master
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    Request
env <- m Request
forall (m :: * -> *). MonadHandler m => m Request
waiRequest
    let method :: Text
method = OnDecodeError -> ContentType -> Text
decodeUtf8With OnDecodeError
lenientDecode (ContentType -> Text) -> ContentType -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ContentType
W.requestMethod Request
env
    case (AuthPlugin master -> Bool)
-> [AuthPlugin master] -> [AuthPlugin master]
forall a. (a -> Bool) -> [a] -> [a]
filter (\AuthPlugin master
x -> AuthPlugin master -> Text
forall master. AuthPlugin master -> Text
apName AuthPlugin master
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
plugin) (master -> [AuthPlugin master]
forall master. YesodAuth master => master -> [AuthPlugin master]
authPlugins master
master) of
        [] -> m TypedContent
forall (m :: * -> *) a. MonadHandler m => m a
notFound
        AuthPlugin master
ap:[AuthPlugin master]
_ -> AuthPlugin master
-> Text -> [Text] -> AuthHandler master TypedContent
forall master.
AuthPlugin master
-> Text -> [Text] -> AuthHandler master TypedContent
apDispatch AuthPlugin master
ap Text
method [Text]
pieces

-- | Similar to 'maybeAuthId', but additionally look up the value associated
-- with the user\'s database identifier to get the value in the database. This
-- assumes that you are using a Persistent database.
--
-- @since 1.1.0
maybeAuth :: ( YesodAuthPersist master
             , val ~ AuthEntity master
             , Key val ~ AuthId master
             , PersistEntity val
             , Typeable val
             , MonadHandler m
             , HandlerSite m ~ master
             ) => m (Maybe (Entity val))
maybeAuth :: m (Maybe (Entity val))
maybeAuth = (Maybe (Key val, val) -> Maybe (Entity val))
-> m (Maybe (Key val, val)) -> m (Maybe (Entity val))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Key val, val) -> Entity val)
-> Maybe (Key val, val) -> Maybe (Entity val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Key val -> val -> Entity val) -> (Key val, val) -> Entity val
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key val -> val -> Entity val
forall record. Key record -> record -> Entity record
Entity)) m (Maybe (Key val, val))
forall master (m :: * -> *).
(YesodAuthPersist master, Typeable (AuthEntity master),
 MonadHandler m, HandlerSite m ~ master) =>
m (Maybe (AuthId master, AuthEntity master))
maybeAuthPair

-- | Similar to 'maybeAuth', but doesn’t assume that you are using a
-- Persistent database.
--
-- @since 1.4.0
maybeAuthPair
  :: ( YesodAuthPersist master
     , Typeable (AuthEntity master)
     , MonadHandler m
     , HandlerSite m ~ master
     )
  => m (Maybe (AuthId master, AuthEntity master))
maybeAuthPair :: m (Maybe (AuthId master, AuthEntity master))
maybeAuthPair = MaybeT m (AuthId master, AuthEntity master)
-> m (Maybe (AuthId master, AuthEntity master))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m (AuthId master, AuthEntity master)
 -> m (Maybe (AuthId master, AuthEntity master)))
-> MaybeT m (AuthId master, AuthEntity master)
-> m (Maybe (AuthId master, AuthEntity master))
forall a b. (a -> b) -> a -> b
$ do
    AuthId master
aid <- m (Maybe (AuthId master)) -> MaybeT m (AuthId master)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT m (Maybe (AuthId master))
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, master ~ HandlerSite m) =>
m (Maybe (AuthId master))
maybeAuthId
    AuthEntity master
ae  <- m (Maybe (AuthEntity master)) -> MaybeT m (AuthEntity master)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe (AuthEntity master)) -> MaybeT m (AuthEntity master))
-> m (Maybe (AuthEntity master)) -> MaybeT m (AuthEntity master)
forall a b. (a -> b) -> a -> b
$ AuthId master -> m (Maybe (AuthEntity master))
forall (m :: * -> *) master.
(MonadHandler m, YesodAuthPersist master,
 Typeable (AuthEntity master), HandlerSite m ~ master) =>
AuthId master -> m (Maybe (AuthEntity master))
cachedAuth AuthId master
aid
    (AuthId master, AuthEntity master)
-> MaybeT m (AuthId master, AuthEntity master)
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthId master
aid, AuthEntity master
ae)


newtype CachedMaybeAuth val = CachedMaybeAuth { CachedMaybeAuth val -> Maybe val
unCachedMaybeAuth :: Maybe val }

-- | Class which states that the given site is an instance of @YesodAuth@
-- and that its @AuthId@ is a lookup key for the full user information in
-- a @YesodPersist@ database.
--
-- The default implementation of @getAuthEntity@ assumes that the @AuthId@
-- for the @YesodAuth@ superclass is in fact a persistent @Key@ for the
-- given value.  This is the common case in Yesod, and means that you can
-- easily look up the full information on a given user.
--
-- @since 1.4.0
class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
    -- | If the @AuthId@ for a given site is a persistent ID, this will give the
    -- value for that entity. E.g.:
    --
    -- > type AuthId MySite = UserId
    -- > AuthEntity MySite ~ User
    --
    -- @since 1.2.0
    type AuthEntity master :: *
    type AuthEntity master = KeyEntity (AuthId master)

    getAuthEntity :: (MonadHandler m, HandlerSite m ~ master)
                  => AuthId master -> m (Maybe (AuthEntity master))

    default getAuthEntity
        :: ( YesodPersistBackend master ~ backend
           , PersistRecordBackend (AuthEntity master) backend
           , Key (AuthEntity master) ~ AuthId master
           , PersistStore backend
           , MonadHandler m
           , HandlerSite m ~ master
           )
        => AuthId master -> m (Maybe (AuthEntity master))
    getAuthEntity = HandlerFor master (Maybe (AuthEntity master))
-> m (Maybe (AuthEntity master))
forall (m :: * -> *) a.
MonadHandler m =>
HandlerFor (HandlerSite m) a -> m a
liftHandler (HandlerFor master (Maybe (AuthEntity master))
 -> m (Maybe (AuthEntity master)))
-> (Key (AuthEntity master)
    -> HandlerFor master (Maybe (AuthEntity master)))
-> Key (AuthEntity master)
-> m (Maybe (AuthEntity master))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT
  (YesodPersistBackend master)
  (HandlerFor master)
  (Maybe (AuthEntity master))
-> HandlerFor master (Maybe (AuthEntity master))
forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB (ReaderT
   (YesodPersistBackend master)
   (HandlerFor master)
   (Maybe (AuthEntity master))
 -> HandlerFor master (Maybe (AuthEntity master)))
-> (Key (AuthEntity master)
    -> ReaderT
         (YesodPersistBackend master)
         (HandlerFor master)
         (Maybe (AuthEntity master)))
-> Key (AuthEntity master)
-> HandlerFor master (Maybe (AuthEntity master))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key (AuthEntity master)
-> ReaderT
     (YesodPersistBackend master)
     (HandlerFor master)
     (Maybe (AuthEntity master))
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get


type family KeyEntity key
type instance KeyEntity (Key x) = x

-- | Similar to 'maybeAuthId', but redirects to a login page if user is not
-- authenticated or responds with error 401 if this is an API client (expecting JSON).
--
-- @since 1.1.0
requireAuthId :: (MonadHandler m, YesodAuth (HandlerSite m)) => m (AuthId (HandlerSite m))
requireAuthId :: m (AuthId (HandlerSite m))
requireAuthId = m (Maybe (AuthId (HandlerSite m)))
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, master ~ HandlerSite m) =>
m (Maybe (AuthId master))
maybeAuthId m (Maybe (AuthId (HandlerSite m)))
-> (Maybe (AuthId (HandlerSite m)) -> m (AuthId (HandlerSite m)))
-> m (AuthId (HandlerSite m))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (AuthId (HandlerSite m))
-> (AuthId (HandlerSite m) -> m (AuthId (HandlerSite m)))
-> Maybe (AuthId (HandlerSite m))
-> m (AuthId (HandlerSite m))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m (AuthId (HandlerSite m))
forall (m :: * -> *) a.
(YesodAuth (HandlerSite m), MonadHandler m) =>
m a
handleAuthLack AuthId (HandlerSite m) -> m (AuthId (HandlerSite m))
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Similar to 'maybeAuth', but redirects to a login page if user is not
-- authenticated or responds with error 401 if this is an API client (expecting JSON).
--
-- @since 1.1.0
requireAuth :: ( YesodAuthPersist master
               , val ~ AuthEntity master
               , Key val ~ AuthId master
               , PersistEntity val
               , Typeable val
               , MonadHandler m
               , HandlerSite m ~ master
               ) => m (Entity val)
requireAuth :: m (Entity val)
requireAuth = m (Maybe (Entity val))
forall master val (m :: * -> *).
(YesodAuthPersist master, val ~ AuthEntity master,
 Key val ~ AuthId master, PersistEntity val, Typeable val,
 MonadHandler m, HandlerSite m ~ master) =>
m (Maybe (Entity val))
maybeAuth m (Maybe (Entity val))
-> (Maybe (Entity val) -> m (Entity val)) -> m (Entity val)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (Entity val)
-> (Entity val -> m (Entity val))
-> Maybe (Entity val)
-> m (Entity val)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m (Entity val)
forall (m :: * -> *) a.
(YesodAuth (HandlerSite m), MonadHandler m) =>
m a
handleAuthLack Entity val -> m (Entity val)
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Similar to 'requireAuth', but not tied to Persistent's 'Entity' type.
-- Instead, the 'AuthId' and 'AuthEntity' are returned in a tuple.
--
-- @since 1.4.0
requireAuthPair
  :: ( YesodAuthPersist master
     , Typeable (AuthEntity master)
     , MonadHandler m
     , HandlerSite m ~ master
     )
  => m (AuthId master, AuthEntity master)
requireAuthPair :: m (AuthId master, AuthEntity master)
requireAuthPair = m (Maybe (AuthId master, AuthEntity master))
forall master (m :: * -> *).
(YesodAuthPersist master, Typeable (AuthEntity master),
 MonadHandler m, HandlerSite m ~ master) =>
m (Maybe (AuthId master, AuthEntity master))
maybeAuthPair m (Maybe (AuthId master, AuthEntity master))
-> (Maybe (AuthId master, AuthEntity master)
    -> m (AuthId master, AuthEntity master))
-> m (AuthId master, AuthEntity master)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m (AuthId master, AuthEntity master)
-> ((AuthId master, AuthEntity master)
    -> m (AuthId master, AuthEntity master))
-> Maybe (AuthId master, AuthEntity master)
-> m (AuthId master, AuthEntity master)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m (AuthId master, AuthEntity master)
forall (m :: * -> *) a.
(YesodAuth (HandlerSite m), MonadHandler m) =>
m a
handleAuthLack (AuthId master, AuthEntity master)
-> m (AuthId master, AuthEntity master)
forall (m :: * -> *) a. Monad m => a -> m a
return

handleAuthLack :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
handleAuthLack :: m a
handleAuthLack = do
    Bool
aj <- m Bool
forall (m :: * -> *). MonadHandler m => m Bool
acceptsJson
    if Bool
aj then m a
forall (m :: * -> *) a. MonadHandler m => m a
notAuthenticated else m a
forall (m :: * -> *) a.
(YesodAuth (HandlerSite m), MonadHandler m) =>
m a
redirectLogin

redirectLogin :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
redirectLogin :: m a
redirectLogin = do
    HandlerSite m
y <- m (HandlerSite m)
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HandlerSite m -> Bool
forall master. YesodAuth master => master -> Bool
redirectToCurrent HandlerSite m
y) m ()
forall (m :: * -> *). MonadHandler m => m ()
setUltDestCurrent
    case HandlerSite m -> Maybe (Route (HandlerSite m))
forall site. Yesod site => site -> Maybe (Route site)
authRoute HandlerSite m
y of
        Just Route (HandlerSite m)
z -> Route (HandlerSite m) -> m a
forall (m :: * -> *) url a.
(MonadHandler m, RedirectUrl (HandlerSite m) url) =>
url -> m a
redirect Route (HandlerSite m)
z
        Maybe (Route (HandlerSite m))
Nothing -> Text -> m a
forall (m :: * -> *) a. MonadHandler m => Text -> m a
permissionDenied Text
"Please configure authRoute"

instance YesodAuth master => RenderMessage master AuthMessage where
    renderMessage :: master -> [Text] -> AuthMessage -> Text
renderMessage = master -> [Text] -> AuthMessage -> Text
forall master.
YesodAuth master =>
master -> [Text] -> AuthMessage -> Text
renderAuthMessage

data AuthException = InvalidFacebookResponse
    deriving Int -> AuthException -> ShowS
[AuthException] -> ShowS
AuthException -> String
(Int -> AuthException -> ShowS)
-> (AuthException -> String)
-> ([AuthException] -> ShowS)
-> Show AuthException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthException] -> ShowS
$cshowList :: [AuthException] -> ShowS
show :: AuthException -> String
$cshow :: AuthException -> String
showsPrec :: Int -> AuthException -> ShowS
$cshowsPrec :: Int -> AuthException -> ShowS
Show
instance Exception AuthException

instance YesodAuth master => YesodSubDispatch Auth master where
    yesodSubDispatch :: YesodSubRunnerEnv Auth master -> Application
yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)

asHtml :: Html -> Html
asHtml :: Html -> Html
asHtml = Html -> Html
forall a. a -> a
id