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

getAuth :: a -> Auth
getAuth = const Auth

-- | User credentials
data Creds master = Creds
    { credsPlugin :: Text -- ^ How the user was authenticated
    , credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin.
    , credsExtra :: [(Text, Text)]
    } deriving (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 = liftHandler . 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 = do
        muid <- getAuthId 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 = do
        auth <- authenticate creds

        return $ case auth of
            Authenticated auid -> Just auid
            _ -> 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 = defaultLoginHandler

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

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

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

    -- | Called on logout. By default, does nothing
    onLogout :: (MonadHandler m, master ~ HandlerSite m) => m ()
    onLogout = 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 = 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 dest msg = do
        addMessage "error" $ toHtml msg
        fmap asHtml $ redirect 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 req inner = do
      man <- authHttpManager
      withRunInIO $ \run -> withResponse req man $ run . 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 = "_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 = runMaybeT $ do
    s   <- MaybeT $ lookupSession 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
    = fmap unCachedMaybeAuth
    . cached
    . fmap CachedMaybeAuth
    . 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 = do
    tp <- getRouteToParent
    authLayout $ do
        setTitleI Msg.LoginTitle
        master <- getYesod
        mapM_ (flip apLogin tp) (authPlugins master)


loginErrorMessageI
  :: Route Auth
  -> AuthMessage
  -> AuthHandler master TypedContent
loginErrorMessageI dest msg = do
  toParent <- getRouteToParent
  loginErrorMessageMasterI (toParent dest) msg


loginErrorMessageMasterI
  :: (MonadHandler m, HandlerSite m ~ master, YesodAuth master)
  => Route master
  -> AuthMessage
  -> m TypedContent
loginErrorMessageMasterI dest msg = do
  mr <- 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 dest msg = messageJson401 msg (onErrorHtml dest msg)

messageJson401
  :: MonadHandler m
  => Text
  -> m Html
  -> m TypedContent
messageJson401 = messageJsonStatus unauthorized401

messageJson500 :: MonadHandler m => Text -> m Html -> m TypedContent
messageJson500 = messageJsonStatus internalServerError500

messageJsonStatus
  :: MonadHandler m
  => Status
  -> Text
  -> m Html
  -> m TypedContent
messageJsonStatus status msg html = selectRep $ do
    provideRep html
    provideRep $ do
        let obj = object ["message" .= msg]
        void $ sendResponseStatus status obj
        return obj

provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) ()
provideJsonMessage msg = provideRep $ return $ object ["message" .= msg]


setCredsRedirect
  :: (MonadHandler m, YesodAuth (HandlerSite m))
  => Creds (HandlerSite m) -- ^ new credentials
  -> m TypedContent
setCredsRedirect creds = do
    y    <- getYesod
    auth <- authenticate creds
    case auth of
        Authenticated aid -> do
            setSession credsKey $ toPathPiece aid
            onLogin
            res <- selectRep $ do
                provideRepType typeHtml $
                    fmap asHtml $ redirectUltDest $ loginDest y
                provideJsonMessage "Login Successful"
            sendResponse res

        UserError msg ->
            case authRoute y of
                Nothing -> do
                    msg' <- renderMessage' msg
                    messageJson401 msg' $ authLayout $ -- TODO
                        toWidget [whamlet|<h1>_{msg}|]
                Just ar -> loginErrorMessageMasterI ar msg

        ServerError msg -> do
            $(logError) msg

            case authRoute y of
                Nothing -> do
                    msg' <- renderMessage' Msg.AuthError
                    messageJson500 msg' $ authLayout $
                        toWidget [whamlet|<h1>_{Msg.AuthError}|]
                Just ar -> loginErrorMessageMasterI ar Msg.AuthError

  where
    renderMessage' msg = do
        langs <- 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 doRedirects creds =
    if doRedirects
      then void $ setCredsRedirect creds
      else do auth <- authenticate creds
              case auth of
                  Authenticated aid -> setSession credsKey $ toPathPiece aid
                  _ -> return ()

-- | same as defaultLayoutJson, but uses authLayout
authLayoutJson
  :: (ToJSON j, MonadAuthHandler master m)
  => WidgetFor master ()  -- ^ HTML
  -> m j  -- ^ JSON
  -> m TypedContent
authLayoutJson w json = selectRep $ do
    provideRep $ authLayout w
    provideRep $ fmap toJSON 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 doRedirects = do
    onLogout
    deleteSession credsKey
    y  <- getYesod
    aj <- acceptsJson
    case (aj, doRedirects) of
      (True, _)               -> sendResponse successfulLogout
      (False, True)           -> redirectUltDest (logoutDest y)
      _                       -> return ()
    where successfulLogout = object ["message" .= msg]
          msg :: Text
          msg = "Logged out successfully!"

getCheckR :: AuthHandler master TypedContent
getCheckR = do
    creds <- maybeAuthId
    authLayoutJson (do
        setTitle "Authentication Status"
        toWidget $ html' creds) (return $ jsonCreds creds)
  where
    html' creds =
        [shamlet|
$newline never
<h1>Authentication Status
$maybe _ <- creds
    <p>Logged in.
$nothing
    <p>Not logged in.
|]
    jsonCreds creds =
        toJSON $ Map.fromList
            [ (T.pack "logged_in", Bool $ maybe False (const True) creds)
            ]

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

getLoginR :: AuthHandler master Html
getLoginR = setUltDestReferer' >> loginHandler

getLogoutR :: AuthHandler master ()
getLogoutR = do
  tp <- getRouteToParent
  setUltDestReferer' >> redirectToPost (tp LogoutR)

postLogoutR :: AuthHandler master ()
postLogoutR = clearCreds True

handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent
handlePluginR plugin pieces = do
    master <- getYesod
    env <- waiRequest
    let method = decodeUtf8With lenientDecode $ W.requestMethod env
    case filter (\x -> apName x == plugin) (authPlugins master) of
        [] -> notFound
        ap:_ -> apDispatch ap method 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 = fmap (fmap (uncurry Entity)) 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 = runMaybeT $ do
    aid <- MaybeT maybeAuthId
    ae  <- MaybeT $ cachedAuth aid
    return (aid, ae)


newtype CachedMaybeAuth val = CachedMaybeAuth { 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 = liftHandler . runDB . 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 = maybeAuthId >>= maybe handleAuthLack 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 = maybeAuth >>= maybe handleAuthLack 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 = maybeAuthPair >>= maybe handleAuthLack return

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

redirectLogin :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
redirectLogin = do
    y <- getYesod
    when (redirectToCurrent y) setUltDestCurrent
    case authRoute y of
        Just z -> redirect z
        Nothing -> permissionDenied "Please configure authRoute"

instance YesodAuth master => RenderMessage master AuthMessage where
    renderMessage = renderAuthMessage

data AuthException = InvalidFacebookResponse
    deriving Show
instance Exception AuthException

instance YesodAuth master => YesodSubDispatch Auth master where
    yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)

asHtml :: Html -> Html
asHtml = id