{-# 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)
import Data.Kind (Type)

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
    { forall master. AuthPlugin master -> Text
apName :: Text
    , forall master.
AuthPlugin master
-> Text -> [Text] -> AuthHandler master TypedContent
apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent
    , forall master.
AuthPlugin master
-> (Route Auth -> Route master) -> WidgetFor master ()
apLogin :: (Route Auth -> Route master) -> WidgetFor master ()
    }

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

-- | User credentials
data Creds master = Creds
    { forall master. Creds master -> Text
credsPlugin :: Text -- ^ How the user was authenticated
    , forall master. Creds master -> Text
credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin.
    , forall master. 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
$cshowsPrec :: forall master. Int -> Creds master -> ShowS
showsPrec :: Int -> Creds master -> ShowS
$cshow :: forall master. Creds master -> String
show :: Creds master -> String
$cshowList :: forall master. [Creds master] -> ShowS
showList :: [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
HandlerFor (HandlerSite m) Html -> m Html
forall a. HandlerFor (HandlerSite m) a -> m a
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
        muid <- Creds master -> m (Maybe (AuthId master))
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
Creds master -> m (Maybe (AuthId master))
forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ master) =>
Creds master -> m (Maybe (AuthId master))
getAuthId Creds master
creds

        return $ maybe (UserError Msg.InvalidLogin) Authenticated 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
        auth <- Creds master -> m (AuthenticationResult master)
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
Creds master -> m (AuthenticationResult master)
forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ master) =>
Creds master -> m (AuthenticationResult master)
authenticate Creds master
creds

        return $ case 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 (m :: * -> *). MonadAuthHandler master m => m 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 a. IO a -> m a
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 a. a -> m a
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 a b. (a -> b) -> m a -> m b
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
      man <- m Manager
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
m Manager
forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ master) =>
m Manager
authHttpManager
      withRunInIO $ \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 :: forall (m :: * -> *) master.
(MonadHandler m, HandlerSite m ~ master, YesodAuthPersist master,
 Typeable (AuthEntity master)) =>
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
    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
    aid <- MaybeT $ return $ fromPathPiece s
    _   <- MaybeT $ cachedAuth aid
    return aid

cachedAuth
    :: ( MonadHandler m
       , YesodAuthPersist master
       , Typeable (AuthEntity master)
       , HandlerSite m ~ master
       )
    => AuthId master
    -> m (Maybe (AuthEntity master))
cachedAuth :: forall (m :: * -> *) master.
(MonadHandler m, YesodAuthPersist master,
 Typeable (AuthEntity master), HandlerSite m ~ master) =>
AuthId master -> m (Maybe (AuthEntity master))
cachedAuth
    = (CachedMaybeAuth (AuthEntity master) -> Maybe (AuthEntity master))
-> m (CachedMaybeAuth (AuthEntity master))
-> m (Maybe (AuthEntity master))
forall a b. (a -> b) -> m a -> m b
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 a b. (a -> b) -> m a -> m b
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))
forall (m :: * -> *).
(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 :: forall master (m :: * -> *). MonadAuthHandler master m => m Html
defaultLoginHandler = do
    tp <- m (Route (SubHandlerSite m) -> Route (HandlerSite m))
m (Route Auth -> Route master)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
    authLayout $ do
        setTitleI Msg.LoginTitle
        master <- getYesod
        mapM_ (flip apLogin tp) (authPlugins master)


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


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

messageJson401
  :: MonadHandler m
  => Text
  -> m Html
  -> m TypedContent
messageJson401 :: forall (m :: * -> *).
MonadHandler m =>
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 :: forall (m :: * -> *).
MonadHandler m =>
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 :: forall (m :: * -> *).
MonadHandler m =>
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 v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
msg]
        m (ZonkAny 0) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (ZonkAny 0) -> m ()) -> m (ZonkAny 0) -> m ()
forall a b. (a -> b) -> a -> b
$ Status -> Value -> m (ZonkAny 0)
forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
Status -> c -> m a
sendResponseStatus Status
status Value
obj
        Value -> m Value
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
obj

provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) ()
provideJsonMessage :: forall (m :: * -> *).
Monad m =>
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 a. a -> m a
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 v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
msg]


setCredsRedirect
  :: (MonadHandler m, YesodAuth (HandlerSite m))
  => Creds (HandlerSite m) -- ^ new credentials
  -> m TypedContent
setCredsRedirect :: forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect Creds (HandlerSite m)
creds = do
    y    <- m (HandlerSite m)
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    auth <- authenticate creds
    case 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 ()
forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ HandlerSite m) =>
m ()
onLogin
            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 a b. (a -> b) -> m a -> m b
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"
            sendResponse 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
                    msg' <- AuthMessage -> m Text
forall {m :: * -> *}.
(MonadHandler m, YesodAuth (HandlerSite m)) =>
AuthMessage -> m Text
renderMessage' AuthMessage
msg
                    messageJson401 msg' $ authLayout $ -- TODO
                        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
            $(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
                    msg' <- AuthMessage -> m Text
forall {m :: * -> *}.
(MonadHandler m, YesodAuth (HandlerSite m)) =>
AuthMessage -> m Text
renderMessage' AuthMessage
Msg.AuthError
                    messageJson500 msg' $ authLayout $
                        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
        langs <- m [Text]
forall (m :: * -> *). MonadHandler m => m [Text]
languages
        master <- getYesod
        return $ renderAuthMessage master langs 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 :: forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
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 auth <- Creds (HandlerSite m) -> m (AuthenticationResult (HandlerSite m))
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, HandlerSite m ~ master) =>
Creds master -> m (AuthenticationResult master)
forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ HandlerSite m) =>
Creds (HandlerSite m) -> m (AuthenticationResult (HandlerSite m))
authenticate Creds (HandlerSite m)
creds
              case 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 a. a -> m a
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 :: forall j master (m :: * -> *).
(ToJSON j, MonadAuthHandler master m) =>
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
forall (m :: * -> *).
(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 a b. (a -> b) -> m a -> m b
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 :: forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Bool -> m ()
clearCreds Bool
doRedirects = do
    m ()
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, master ~ HandlerSite m) =>
m ()
forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ HandlerSite m) =>
m ()
onLogout
    Text -> m ()
forall (m :: * -> *). MonadHandler m => Text -> m ()
deleteSession Text
credsKey
    y  <- m (HandlerSite m)
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    aj <- acceptsJson
    case (aj, 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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    where successfulLogout :: Value
successfulLogout = [Pair] -> Value
object [Key
"message" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
msg]
          msg :: Text
          msg :: Text
msg = Text
"Logged out successfully!"

getCheckR :: AuthHandler master TypedContent
getCheckR :: forall master (m :: * -> *).
MonadAuthHandler master m =>
m TypedContent
getCheckR = do
    creds <- m (Maybe (AuthId master))
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, master ~ HandlerSite m) =>
m (Maybe (AuthId master))
forall (m :: * -> *).
(MonadHandler m, master ~ HandlerSite m) =>
m (Maybe (AuthId master))
maybeAuthId
    authLayoutJson (do
        setTitle "Authentication Status"
        toWidget $ html' creds) (return $ jsonCreds 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 a -> Value
jsonCreds Maybe a
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 -> (a -> Bool) -> Maybe a -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True) Maybe a
creds)
            ]

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

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

getLogoutR :: AuthHandler master ()
getLogoutR :: forall master (m :: * -> *). MonadAuthHandler master m => m ()
getLogoutR = do
  tp <- m (Route (SubHandlerSite m) -> Route (HandlerSite m))
m (Route Auth -> Route master)
forall (m :: * -> *).
MonadHandler m =>
m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getRouteToParent
  setUltDestReferer' >> redirectToPost (tp LogoutR)

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

handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent
handlePluginR :: forall master. Text -> [Text] -> AuthHandler master TypedContent
handlePluginR Text
plugin [Text]
pieces = do
    master <- m master
m (HandlerSite m)
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    env <- waiRequest
    let 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 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) (authPlugins 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 :: 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 = (Maybe (Key val, val) -> Maybe (Entity val))
-> m (Maybe (Key val, val)) -> m (Maybe (Entity val))
forall a b. (a -> b) -> m a -> m b
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 a b. (a -> b) -> Maybe a -> Maybe b
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))
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

-- | 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 :: forall master (m :: * -> *).
(YesodAuthPersist master, Typeable (AuthEntity master),
 MonadHandler m, HandlerSite m ~ master) =>
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
    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))
forall (m :: * -> *).
(MonadHandler m, master ~ HandlerSite m) =>
m (Maybe (AuthId master))
maybeAuthId
    ae  <- MaybeT $ cachedAuth aid
    return (aid, ae)


newtype CachedMaybeAuth val = CachedMaybeAuth { forall val. 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
    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))
HandlerFor (HandlerSite m) (Maybe (AuthEntity master))
-> m (Maybe (AuthEntity master))
forall a. HandlerFor (HandlerSite m) a -> m a
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 backend (HandlerFor master) (Maybe (AuthEntity master))
-> HandlerFor master (Maybe (AuthEntity master))
YesodDB master (Maybe (AuthEntity master))
-> HandlerFor master (Maybe (AuthEntity master))
forall a. YesodDB master a -> HandlerFor master a
forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB (ReaderT backend (HandlerFor master) (Maybe (AuthEntity master))
 -> HandlerFor master (Maybe (AuthEntity master)))
-> (Key (AuthEntity master)
    -> ReaderT backend (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 backend (HandlerFor master) (Maybe (AuthEntity master))
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
forall record (m :: * -> *).
(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 :: forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
m (AuthId (HandlerSite m))
requireAuthId = m (Maybe (AuthId (HandlerSite m)))
forall master (m :: * -> *).
(YesodAuth master, MonadHandler m, master ~ HandlerSite m) =>
m (Maybe (AuthId master))
forall (m :: * -> *).
(MonadHandler m, HandlerSite m ~ HandlerSite m) =>
m (Maybe (AuthId (HandlerSite m)))
maybeAuthId m (Maybe (AuthId (HandlerSite m)))
-> (Maybe (AuthId (HandlerSite m)) -> m (AuthId (HandlerSite m)))
-> m (AuthId (HandlerSite m))
forall a b. m a -> (a -> m b) -> m b
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 a. a -> m a
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 :: forall master val (m :: * -> *).
(YesodAuthPersist master, val ~ AuthEntity master,
 Key val ~ AuthId master, PersistEntity val, Typeable val,
 MonadHandler m, HandlerSite m ~ master) =>
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 a b. m a -> (a -> m b) -> m b
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 a. a -> m a
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 :: forall master (m :: * -> *).
(YesodAuthPersist master, Typeable (AuthEntity master),
 MonadHandler m, HandlerSite m ~ master) =>
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 a b. m a -> (a -> m b) -> m b
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

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

redirectLogin :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
redirectLogin :: forall (m :: * -> *) a.
(YesodAuth (HandlerSite m), MonadHandler m) =>
m a
redirectLogin = do
    y <- m (HandlerSite m)
forall (m :: * -> *). MonadHandler m => m (HandlerSite m)
getYesod
    when (redirectToCurrent y) setUltDestCurrent
    case authRoute 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
$cshowsPrec :: Int -> AuthException -> ShowS
showsPrec :: Int -> AuthException -> ShowS
$cshow :: AuthException -> String
show :: AuthException -> String
$cshowList :: [AuthException] -> ShowS
showList :: [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