{-# 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
import IHP.AuthSupport.View.Sessions.New
import IHP.ViewSupport (View)
import Data.Data
import qualified IHP.AuthSupport.Lockable as Lockable
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
    , KnownSymbol (GetModelName record)
    ) => IO ResponseReceived
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,
 KnownSymbol (GetModelName record)) =>
IO ResponseReceived
newSessionAction = do
    alreadyLoggedIn <- Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Text -> Bool) -> IO (Maybe Text) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall value.
(?request::Request, Serialize value) =>
ByteString -> IO (Maybe value)
getSession @Text (forall user. KnownSymbol (GetModelName user) => ByteString
sessionKey @record)
    if alreadyLoggedIn
        then redirectToPathSeeOther (afterLoginRedirectPath @record)
        else do
            let user = forall model. Record model => model
newRecord @record
            render NewView { .. }
{-# 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
    , PrimaryKey (GetTableName record) ~ UUID
    , record ~ GetModelByTableName (GetTableName record)
    , Table record
    , FromRowHasql record
    ) => IO ResponseReceived
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,
 PrimaryKey (GetTableName record) ~ UUID,
 record ~ GetModelByTableName (GetTableName record), Table record,
 FromRowHasql record) =>
IO ResponseReceived
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 (name :: Symbol) (table :: Symbol) model value.
(KnownSymbol table, KnownSymbol name, DefaultParamEncoder value,
 HasField name model value, EqOrIsOperator value,
 model ~ GetModelByTableName table, Table model) =>
(Proxy name, value) -> QueryBuilder table -> QueryBuilder 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 ResponseReceived) -> IO ResponseReceived
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
            if isLocked
                then do
                    setErrorMessage "User is locked"
                    redirectTo buildNewSessionAction
                else 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 ResponseReceived
forall action.
(?request::Request, ?respond::Respond, HasPath action) =>
action -> IO ResponseReceived
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.
    ( ?theAction :: action
    , ?context :: ControllerContext
    , ?request :: Request
    , ?respond :: Respond
    , ?modelContext :: ModelContext
    , Data action
    , HasPath action
    , SessionsControllerConfig record
    , KnownSymbol (GetModelName record)
    ) => IO ResponseReceived
deleteSessionAction :: forall record action.
(?theAction::action, ?context::ControllerContext,
 ?request::Request, ?respond::Respond, ?modelContext::ModelContext,
 Data action, HasPath action, SessionsControllerConfig record,
 KnownSymbol (GetModelName record)) =>
IO ResponseReceived
deleteSessionAction = do
    (?request::Request) => ByteString -> IO ()
ByteString -> IO ()
deleteSession (forall user. KnownSymbol (GetModelName user) => ByteString
sessionKey @record)
    -- Note: beforeLogout callback is not called because we no longer
    -- fetch the user record during logout. If you need beforeLogout,
    -- implement custom logout logic in your controller.
    (?request::Request, ?respond::Respond) =>
Text -> IO ResponseReceived
Text -> IO ResponseReceived
redirectToPathSeeOther (forall record action.
(SessionsControllerConfig record, ?theAction::action, Data action,
 HasPath action) =>
Text
afterLogoutRedirectPath @record)
{-# INLINE deleteSessionAction #-}

-- | 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 #-}