{-# LANGUAGE AllowAmbiguousTypes #-}
{-|
Module: IHP.AuthSupport.Controller.Sessions
Description: Provides action implementations for SessionControllers
Copyright: (c) digitally induced GmbH, 2020
-}
module IHP.AuthSupport.Controller.Sessions
( newSessionAction
, createSessionAction
, deleteSessionAction
, SessionsControllerConfig (..)
)
where

import IHP.Prelude
import IHP.ControllerPrelude hiding (Success, currentUserOrNothing)
import IHP.AuthSupport.View.Sessions.New
import IHP.ViewSupport (View)
import Data.Data
import qualified IHP.AuthSupport.Lockable as Lockable
import System.IO.Unsafe (unsafePerformIO)
import IHP.Hasql.FromRow (FromRowHasql)

-- | Displays the login form.
--
-- In case the user is already logged in, redirects to the home page ('afterLoginRedirectPath').
newSessionAction :: forall record action.
    ( ?theAction :: action
    , ?context :: ControllerContext
    , ?request :: Request
    , ?respond :: Respond
    , HasNewSessionUrl record
    , ?modelContext :: ModelContext
    , Typeable record
    , View (NewView record)
    , Data action
    , Record record
    , HasPath action
    , SessionsControllerConfig record
    ) => IO ()
newSessionAction :: forall record action.
(?theAction::action, ?context::ControllerContext,
 ?request::Request, ?respond::Respond, HasNewSessionUrl record,
 ?modelContext::ModelContext, Typeable record,
 View (NewView record), Data action, Record record, HasPath action,
 SessionsControllerConfig record) =>
IO ()
newSessionAction = do
    let alreadyLoggedIn :: Bool
alreadyLoggedIn = Maybe record -> Bool
forall a. Maybe a -> Bool
isJust (forall user.
(?context::ControllerContext, HasNewSessionUrl user,
 Typeable user) =>
Maybe user
currentUserOrNothing @record)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
alreadyLoggedIn ((?request::Request) => Text -> IO ()
Text -> IO ()
redirectToPathSeeOther (forall record. SessionsControllerConfig record => Text
afterLoginRedirectPath @record))

    let user :: record
user = forall model. Record model => model
newRecord @record
    NewView record -> IO ()
forall view.
(View view, ?context::ControllerContext, ?request::Request,
 ?respond::Respond) =>
view -> IO ()
render NewView { record
user :: record
user :: record
.. }
{-# INLINE newSessionAction #-}

-- | Logs in a user when a valid email and password is given
--
-- After 10 failed attempts, the user is locked for an hours. See 'maxFailedLoginAttempts' to customize this.
--
-- After a successful login, the user is redirect to 'afterLoginRedirectPath'.
createSessionAction :: forall record action.
    (?theAction :: action
    , ?context :: ControllerContext
    , ?request :: Request
    , ?respond :: Respond
    , ?modelContext :: ModelContext
    , Data action
    , HasField "email" record Text
    , HasPath action
    , HasField "id" record (Id record)
    , HasField "passwordHash" record Text
    , SessionsControllerConfig record
    , UpdateField "lockedAt" record record (Maybe UTCTime) (Maybe UTCTime)
    , HasField "failedLoginAttempts" record Int
    , SetField "failedLoginAttempts" record Int
    , CanUpdate record
    , Show (PrimaryKey (GetTableName record))
    , record ~ GetModelByTableName (GetTableName record)
    , Table record
    , FromRowHasql record
    ) => IO ()
createSessionAction :: forall record action.
(?theAction::action, ?context::ControllerContext,
 ?request::Request, ?respond::Respond, ?modelContext::ModelContext,
 Data action, HasField "email" record Text, HasPath action,
 HasField "id" record (Id record),
 HasField "passwordHash" record Text,
 SessionsControllerConfig record,
 UpdateField
   "lockedAt" record record (Maybe UTCTime) (Maybe UTCTime),
 HasField "failedLoginAttempts" record Int,
 SetField "failedLoginAttempts" record Int, CanUpdate record,
 Show (PrimaryKey (GetTableName record)),
 record ~ GetModelByTableName (GetTableName record), Table record,
 FromRowHasql record) =>
IO ()
createSessionAction = do
    usersQueryBuilder
    QueryBuilder (GetTableName record)
-> (QueryBuilder (GetTableName record)
    -> QueryBuilder (GetTableName record))
-> QueryBuilder (GetTableName record)
forall a b. a -> (a -> b) -> b
|> (Proxy "email", Text)
-> QueryBuilder (GetTableName record)
-> QueryBuilder (GetTableName record)
forall {k} (name :: Symbol) (table :: Symbol) model value
       (queryBuilderProvider :: Symbol -> *) (joinRegister :: k).
(KnownSymbol table, KnownSymbol name, DefaultParamEncoder value,
 HasField name model value, EqOrIsOperator value,
 model ~ GetModelByTableName table,
 HasQueryBuilder queryBuilderProvider joinRegister, Table model) =>
(Proxy name, value)
-> queryBuilderProvider table -> queryBuilderProvider table
filterWhereCaseInsensitive (Proxy "email"
#email, ByteString -> Text
forall valueType.
(?request::Request, ParamReader valueType) =>
ByteString -> valueType
param ByteString
"email")
    QueryBuilder (GetTableName record)
-> (QueryBuilder (GetTableName record) -> IO (Maybe record))
-> IO (Maybe record)
forall a b. a -> (a -> b) -> b
|> QueryBuilder (GetTableName record) -> IO (Maybe record)
forall fetchable model.
(Fetchable fetchable model, Table model, FromRowHasql model,
 ?modelContext::ModelContext) =>
fetchable -> IO (Maybe model)
fetchOneOrNothing
    IO (Maybe record) -> (Maybe record -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just (record
user :: record) -> do
            isLocked <- record -> IO Bool
forall user.
HasField "lockedAt" user (Maybe UTCTime) =>
user -> IO Bool
Lockable.isLocked record
user
            when isLocked do
                setErrorMessage "User is locked"
                redirectTo buildNewSessionAction

            if verifyPassword user (param @Text "password")
                then do
                    beforeLogin user
                    login user
                    user <- user
                            |> set #failedLoginAttempts 0
                            |> updateRecord
                    redirectUrl <- getSessionAndClear "IHP.LoginSupport.redirectAfterLogin"
                    redirectToPathSeeOther (fromMaybe (afterLoginRedirectPath @record) redirectUrl)
                else do
                    setErrorMessage "Invalid Credentials"
                    user :: record <- user
                            |> incrementField #failedLoginAttempts
                            |> updateRecord
                    when (user.failedLoginAttempts >= maxFailedLoginAttempts user) do
                        Lockable.lock user
                        pure ()
                    redirectTo buildNewSessionAction
        Maybe record
Nothing -> do
            (?request::Request) => Text -> IO ()
Text -> IO ()
setErrorMessage Text
"Invalid Credentials"
            action -> IO ()
forall action.
(?request::Request, HasPath action) =>
action -> IO ()
redirectTo action
forall controller.
(?theAction::controller, Data controller) =>
controller
buildNewSessionAction
{-# INLINE createSessionAction #-}

-- | Logs out the user and redirects to `afterLogoutRedirectPath` or login page by default
deleteSessionAction :: forall record action id.
    ( ?theAction :: action
    , ?context :: ControllerContext
    , ?request :: Request
    , ?respond :: Respond
    , ?modelContext :: ModelContext
    , Data action
    , HasPath action
    , Show id
    , HasField "id" record id
    , SessionsControllerConfig record
    ) => IO ()
deleteSessionAction :: forall record action id.
(?theAction::action, ?context::ControllerContext,
 ?request::Request, ?respond::Respond, ?modelContext::ModelContext,
 Data action, HasPath action, Show id, HasField "id" record id,
 SessionsControllerConfig record) =>
IO ()
deleteSessionAction = do
    case forall user.
(?context::ControllerContext, HasNewSessionUrl user,
 Typeable user) =>
Maybe user
currentUserOrNothing @record of
        Just record
user -> do
            record -> IO ()
forall record.
(SessionsControllerConfig record, ?context::ControllerContext,
 ?modelContext::ModelContext, ?request::Request) =>
record -> IO ()
beforeLogout record
user
            record -> IO ()
forall user.
(?request::Request, KnownSymbol (GetModelName user)) =>
user -> IO ()
logout record
user
        Maybe record
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    (?request::Request) => Text -> IO ()
Text -> IO ()
redirectToPathSeeOther (forall record action.
(SessionsControllerConfig record, ?theAction::action, Data action,
 HasPath action) =>
Text
afterLogoutRedirectPath @record)
{-# INLINE deleteSessionAction #-}

currentUserOrNothing :: forall user. (?context :: ControllerContext, HasNewSessionUrl user, Typeable user) => (Maybe user)
currentUserOrNothing :: forall user.
(?context::ControllerContext, HasNewSessionUrl user,
 Typeable user) =>
Maybe user
currentUserOrNothing =
    case IO (Maybe (Maybe user)) -> Maybe (Maybe user)
forall a. IO a -> a
unsafePerformIO (forall value.
(?context::ControllerContext, Typeable value) =>
IO (Maybe value)
maybeFromContext @(Maybe user)) of
        Just Maybe user
user -> Maybe user
user
        Maybe (Maybe user)
Nothing -> Text -> Maybe user
forall a. Text -> a
error Text
"currentUserOrNothing: initAuthentication has not been called in initContext inside FrontController of this application"
{-# INLINE currentUserOrNothing #-}

-- | Returns the NewSessionAction action for the given SessionsController
buildNewSessionAction :: forall controller. (?theAction :: controller, Data controller) => controller
buildNewSessionAction :: forall controller.
(?theAction::controller, Data controller) =>
controller
buildNewSessionAction = Constr -> controller
forall a. Data a => Constr -> a
fromConstr Constr
createConstructor
    where
        createConstructor :: Constr
        (Just Constr
createConstructor) = (Constr -> Bool) -> [Constr] -> Maybe Constr
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Constr -> Bool
isNewSessionConstructor [Constr]
allConstructors

        allConstructors :: [Constr]
        allConstructors :: [Constr]
allConstructors = DataType -> [Constr]
dataTypeConstrs (controller -> DataType
forall a. Data a => a -> DataType
dataTypeOf controller
?theAction::controller
?theAction)

        isNewSessionConstructor :: Constr -> Bool
        isNewSessionConstructor :: Constr -> Bool
isNewSessionConstructor Constr
constructor = String
"NewSessionAction" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Constr -> String
showConstr Constr
constructor
{-# INLINE buildNewSessionAction #-}

-- | Configuration for the session controller actions
class ( Typeable record
    , Show record
    , KnownSymbol (GetModelName record)
    , HasNewSessionUrl record
    , KnownSymbol (GetTableName record)
    , FromRowHasql record
    ) => SessionsControllerConfig record where

    -- | Your home page, where the user is redirect after login, by default it's @/@
    afterLoginRedirectPath :: Text
    afterLoginRedirectPath = Text
"/"

    -- | Where the user is redirected after logout, by default it's @/NewSession@
    afterLogoutRedirectPath :: forall action. (?theAction :: action, Data action, HasPath action) => Text
    afterLogoutRedirectPath = action -> Text
forall controller. HasPath controller => controller -> Text
pathTo action
forall controller.
(?theAction::controller, Data controller) =>
controller
buildNewSessionAction

    -- | After 10 failed login attempts the user will be locked for an hour
    maxFailedLoginAttempts :: record -> Int
    maxFailedLoginAttempts record
_ = Int
10

    -- | Callback that is executed just before the user is logged in
    --
    -- This is called only after checking that the password is correct. When a wrong password is given this callback is not executed.
    --
    -- __Example: Disallow login until user is confirmed__
    --
    -- > beforeLogin user = do
    -- >     unless (user.isConfirmed) do
    -- >         setErrorMessage "Please click the confirmation link we sent to your email before you can use the App"
    -- >         redirectTo NewSessionAction
    beforeLogin :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?request :: Request) => record -> IO ()
    beforeLogin record
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    -- | Callback that is executed just before the user is logged out
    --
    -- This is called only if user session exists
    beforeLogout :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?request :: Request) => record -> IO ()
    beforeLogout record
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    -- | Return's the @query\ \@User@ used by the controller. Customize this to e.g. exclude guest users from logging in.
    --
    -- __Example: Exclude guest users from login__
    --
    -- > usersQueryBuilder = query @User |> filterWhere (#isGuest, False)
    --
    usersQueryBuilder :: (GetModelByTableName (GetTableName record) ~ record, Table record) => QueryBuilder (GetTableName record)
    usersQueryBuilder = forall model (table :: Symbol).
(table ~ GetTableName model, Table model, DefaultScope table) =>
QueryBuilder table
query @record
    {-# INLINE usersQueryBuilder #-}