{-# 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)

-- | 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
    , 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,
 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 ((?context::ControllerContext) => Text -> IO ()
Text -> IO ()
redirectToPath (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) =>
view -> IO ()
render NewView { record
user :: record
$sel:user:NewView :: 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
    , ?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
    ) => IO ()
createSessionAction :: forall record action.
(?theAction::action, ?context::ControllerContext,
 ?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) =>
IO ()
createSessionAction = do
    QueryBuilder (GetTableName record)
forall record.
(SessionsControllerConfig record,
 GetModelByTableName (GetTableName record) ~ record,
 Table record) =>
QueryBuilder (GetTableName record)
usersQueryBuilder
    QueryBuilder (GetTableName record)
-> (QueryBuilder (GetTableName record)
    -> QueryBuilder (GetTableName record))
-> QueryBuilder (GetTableName record)
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (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, ToField 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.
(?context::ControllerContext, ParamReader valueType) =>
ByteString -> valueType
param ByteString
"email")
    QueryBuilder (GetTableName record)
-> (QueryBuilder (GetTableName record) -> IO (Maybe record))
-> IO (Maybe record)
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> QueryBuilder (GetTableName record) -> IO (Maybe record)
forall fetchable model.
(Fetchable fetchable model, Table model, FromRow 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
            Bool
isLocked <- record -> IO Bool
forall user.
HasField "lockedAt" user (Maybe UTCTime) =>
user -> IO Bool
Lockable.isLocked record
user
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isLocked do
                (?context::ControllerContext) => Text -> IO ()
Text -> IO ()
setErrorMessage Text
"User is locked"
                action -> IO ()
forall action.
(?context::ControllerContext, HasPath action) =>
action -> IO ()
redirectTo action
forall controller.
(?theAction::controller, Data controller) =>
controller
buildNewSessionAction

            if record -> Text -> Bool
forall entity passwordField.
(HasField "passwordHash" entity passwordField,
 VerifiyPassword passwordField) =>
entity -> Text -> Bool
verifyPassword record
user (forall valueType.
(?context::ControllerContext, ParamReader valueType) =>
ByteString -> valueType
param @Text ByteString
"password")
                then do
                    record -> IO ()
forall record.
(SessionsControllerConfig record, ?context::ControllerContext,
 ?modelContext::ModelContext) =>
record -> IO ()
beforeLogin record
user
                    record -> IO ()
forall user id.
(?context::ControllerContext, KnownSymbol (GetModelName user),
 HasField "id" user id, Show id) =>
user -> IO ()
login record
user
                    record
user <- record
user
                            record -> (record -> record) -> record
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Proxy "failedLoginAttempts" -> Int -> record -> record
forall model (name :: Symbol) value.
(KnownSymbol name, SetField name model value) =>
Proxy name -> value -> model -> model
set Proxy "failedLoginAttempts"
#failedLoginAttempts Int
0
                            record -> (record -> IO record) -> IO record
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> record -> IO record
forall a. (CanUpdate a, ?modelContext::ModelContext) => a -> IO a
updateRecord
                    Maybe Text
redirectUrl <- ByteString -> IO (Maybe Text)
forall value.
(?context::ControllerContext, Serialize value) =>
ByteString -> IO (Maybe value)
getSessionAndClear ByteString
"IHP.LoginSupport.redirectAfterLogin"
                    (?context::ControllerContext) => Text -> IO ()
Text -> IO ()
redirectToPath (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (forall record. SessionsControllerConfig record => Text
afterLoginRedirectPath @record) Maybe Text
redirectUrl)
                else do
                    (?context::ControllerContext) => Text -> IO ()
Text -> IO ()
setErrorMessage Text
"Invalid Credentials"
                    record
user :: record <- record
user
                            record -> (record -> record) -> record
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Proxy "failedLoginAttempts" -> record -> record
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value,
 SetField name model value, Num value) =>
Proxy name -> model -> model
incrementField Proxy "failedLoginAttempts"
#failedLoginAttempts
                            record -> (record -> IO record) -> IO record
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> record -> IO record
forall a. (CanUpdate a, ?modelContext::ModelContext) => a -> IO a
updateRecord
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (record
user.failedLoginAttempts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= record -> Int
forall record. SessionsControllerConfig record => record -> Int
maxFailedLoginAttempts record
user) do
                        record -> IO record
forall user.
(?modelContext::ModelContext, CanUpdate user,
 UpdateField
   "lockedAt" user user (Maybe UTCTime) (Maybe UTCTime)) =>
user -> IO user
Lockable.lock record
user
                        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    action -> IO ()
forall action.
(?context::ControllerContext, HasPath action) =>
action -> IO ()
redirectTo action
forall controller.
(?theAction::controller, Data controller) =>
controller
buildNewSessionAction
        Maybe record
Nothing -> do
            (?context::ControllerContext) => Text -> IO ()
Text -> IO ()
setErrorMessage Text
"Invalid Credentials"
            action -> IO ()
forall action.
(?context::ControllerContext, 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
    , ?modelContext :: ModelContext
    , Data action
    , HasPath action
    , Show id
    , HasField "id" record id
    , SessionsControllerConfig record
    ) => IO ()
deleteSessionAction :: forall record action id.
(?theAction::action, ?context::ControllerContext,
 ?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) =>
record -> IO ()
beforeLogout record
user
            record -> IO ()
forall user.
(?context::ControllerContext, 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 ()
    (?context::ControllerContext) => Text -> IO ()
Text -> IO ()
redirectToPath (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)
    , FromRow 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) => 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) => 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 #-}