{-# LANGUAGE AllowAmbiguousTypes #-}

module IHP.LoginSupport.Helper.Controller
( currentUser
, currentUserOrNothing
, currentUserId
, currentUserIdOrNothing
, ensureIsUser
, HasNewSessionUrl
, currentAdmin
, currentAdminOrNothing
, currentAdminId
, currentAdminIdOrNothing
, ensureIsAdmin
, login
, sessionKey
, logout
, CurrentUserRecord
, CurrentAdminRecord
, module IHP.AuthSupport.Authentication
, enableRowLevelSecurityIfLoggedIn
) where

import IHP.Prelude
import IHP.Controller.Redirect
import IHP.Controller.Session
import IHP.LoginSupport.Types
import IHP.FlashMessages
import qualified IHP.ModelSupport as ModelSupport
import IHP.ControllerSupport
import IHP.RequestVault.Helper (lookupRequestVault)
import System.IO.Unsafe (unsafePerformIO)
import IHP.AuthSupport.Authentication
import qualified IHP.FrameworkConfig as FrameworkConfig
import qualified Data.UUID as UUID

-- | Returns the current user or 'Nothing' if not logged in.
--
-- Reads from the WAI request vault, populated by 'authMiddleware'.
--
-- Requires @AuthMiddleware (authMiddleware \@User)@ in Config.hs.
currentUserOrNothing :: forall user. (?request :: Request, user ~ CurrentUserRecord, Typeable user) => Maybe user
currentUserOrNothing :: forall user.
(?request::Request, user ~ CurrentUserRecord, Typeable user) =>
Maybe user
currentUserOrNothing = Key (Maybe user) -> Request -> Maybe user
forall user. Key (Maybe user) -> Request -> Maybe user
lookupAuthVault Key (Maybe user)
Key (Maybe CurrentUserRecord)
currentUserVaultKey ?request::Request
Request
?request
{-# INLINE currentUserOrNothing #-}

-- | Returns the current user. Redirects to login if not logged in.
currentUser :: forall user. (?context :: ControllerContext, ?request :: Request, ?respond :: Respond, HasNewSessionUrl user, Typeable user, user ~ CurrentUserRecord) => user
currentUser :: forall user.
(?context::ControllerContext, ?request::Request, ?respond::Respond,
 HasNewSessionUrl user, Typeable user, user ~ CurrentUserRecord) =>
user
currentUser = user -> Maybe user -> user
forall a. a -> Maybe a -> a
fromMaybe (Text -> user
forall a. (?request::Request, ?respond::Respond) => Text -> a
redirectToLogin (Proxy user -> Text
forall {k} (user :: k). HasNewSessionUrl user => Proxy user -> Text
newSessionUrl (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @user))) Maybe user
forall user.
(?request::Request, user ~ CurrentUserRecord, Typeable user) =>
Maybe user
currentUserOrNothing
{-# INLINABLE currentUser #-}

-- | Returns the ID of the current user. Redirects to login if not logged in.
currentUserId :: forall user userId. (?context :: ControllerContext, ?request :: Request, ?respond :: Respond, HasNewSessionUrl user, HasField "id" user userId, Typeable user, user ~ CurrentUserRecord) => userId
currentUserId :: forall user userId.
(?context::ControllerContext, ?request::Request, ?respond::Respond,
 HasNewSessionUrl user, HasField "id" user userId, Typeable user,
 user ~ CurrentUserRecord) =>
userId
currentUserId = (forall user.
(?context::ControllerContext, ?request::Request, ?respond::Respond,
 HasNewSessionUrl user, Typeable user, user ~ CurrentUserRecord) =>
user
currentUser @user).id
{-# INLINABLE currentUserId #-}

-- | Ensures that a user is logged in. Redirects to login page if not.
ensureIsUser :: forall user. (?context :: ControllerContext, ?request :: Request, ?respond :: Respond, HasNewSessionUrl user, Typeable user, user ~ CurrentUserRecord) => IO ()
ensureIsUser :: forall user.
(?context::ControllerContext, ?request::Request, ?respond::Respond,
 HasNewSessionUrl user, Typeable user, user ~ CurrentUserRecord) =>
IO ()
ensureIsUser =
    case forall user.
(?request::Request, user ~ CurrentUserRecord, Typeable user) =>
Maybe user
currentUserOrNothing @user of
        Just user
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Maybe user
Nothing -> (?request::Request, ?respond::Respond) => Text -> IO ()
Text -> IO ()
redirectToLoginWithMessage (Proxy user -> Text
forall {k} (user :: k). HasNewSessionUrl user => Proxy user -> Text
newSessionUrl (Proxy user
forall {k} (t :: k). Proxy t
Proxy :: Proxy user))
{-# INLINABLE ensureIsUser #-}

-- | Returns the current user's UUID or 'Nothing' if not logged in.
--
-- This only requires 'userIdMiddleware', no database query is needed.
--
-- > userId <- currentUserIdOrNothing
currentUserIdOrNothing :: (?request :: Request, ModelSupport.PrimaryKey (ModelSupport.GetTableName CurrentUserRecord) ~ UUID) => Maybe (ModelSupport.Id CurrentUserRecord)
currentUserIdOrNothing :: (?request::Request,
 PrimaryKey (GetTableName CurrentUserRecord) ~ UUID) =>
Maybe (Id CurrentUserRecord)
currentUserIdOrNothing = UUID -> Id CurrentUserRecord
PrimaryKey (GetTableName CurrentUserRecord) -> Id CurrentUserRecord
forall (table :: Symbol). PrimaryKey table -> Id' table
ModelSupport.Id (UUID -> Id CurrentUserRecord)
-> Maybe UUID -> Maybe (Id CurrentUserRecord)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key (Maybe UUID) -> Request -> Maybe UUID
forall user. Key (Maybe user) -> Request -> Maybe user
lookupAuthVault Key (Maybe UUID)
currentUserIdVaultKey ?request::Request
Request
?request
{-# INLINE currentUserIdOrNothing #-}

-- | Returns the current admin or 'Nothing' if not logged in.
--
-- Reads from the WAI request vault, populated by 'authMiddleware'.
--
-- Requires @AdminAuthMiddleware (adminAuthMiddleware \@Admin)@ in Config.hs.
currentAdminOrNothing :: forall admin. (?request :: Request, admin ~ CurrentAdminRecord, Typeable admin) => Maybe admin
currentAdminOrNothing :: forall admin.
(?request::Request, admin ~ CurrentAdminRecord, Typeable admin) =>
Maybe admin
currentAdminOrNothing = Key (Maybe admin) -> Request -> Maybe admin
forall user. Key (Maybe user) -> Request -> Maybe user
lookupAuthVault Key (Maybe admin)
Key (Maybe CurrentAdminRecord)
currentAdminVaultKey ?request::Request
Request
?request
{-# INLINE currentAdminOrNothing #-}

-- | Returns the current admin. Redirects to login if not logged in.
currentAdmin :: forall admin. (?context :: ControllerContext, ?request :: Request, ?respond :: Respond, HasNewSessionUrl admin, Typeable admin, admin ~ CurrentAdminRecord) => admin
currentAdmin :: forall admin.
(?context::ControllerContext, ?request::Request, ?respond::Respond,
 HasNewSessionUrl admin, Typeable admin,
 admin ~ CurrentAdminRecord) =>
admin
currentAdmin = admin -> Maybe admin -> admin
forall a. a -> Maybe a -> a
fromMaybe (Text -> admin
forall a. (?request::Request, ?respond::Respond) => Text -> a
redirectToLogin (Proxy admin -> Text
forall {k} (user :: k). HasNewSessionUrl user => Proxy user -> Text
newSessionUrl (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @admin))) Maybe admin
forall admin.
(?request::Request, admin ~ CurrentAdminRecord, Typeable admin) =>
Maybe admin
currentAdminOrNothing
{-# INLINABLE currentAdmin #-}

-- | Returns the ID of the current admin. Redirects to login if not logged in.
currentAdminId :: forall admin adminId. (?context :: ControllerContext, ?request :: Request, ?respond :: Respond, HasNewSessionUrl admin, HasField "id" admin adminId, Typeable admin, admin ~ CurrentAdminRecord) => adminId
currentAdminId :: forall admin adminId.
(?context::ControllerContext, ?request::Request, ?respond::Respond,
 HasNewSessionUrl admin, HasField "id" admin adminId,
 Typeable admin, admin ~ CurrentAdminRecord) =>
adminId
currentAdminId = (forall admin.
(?context::ControllerContext, ?request::Request, ?respond::Respond,
 HasNewSessionUrl admin, Typeable admin,
 admin ~ CurrentAdminRecord) =>
admin
currentAdmin @admin).id
{-# INLINABLE currentAdminId #-}

-- | Returns the current admin's UUID or 'Nothing' if not logged in.
--
-- This only requires 'adminIdMiddleware', no database query is needed.
currentAdminIdOrNothing :: (?request :: Request, ModelSupport.PrimaryKey (ModelSupport.GetTableName CurrentAdminRecord) ~ UUID) => Maybe (ModelSupport.Id CurrentAdminRecord)
currentAdminIdOrNothing :: (?request::Request,
 PrimaryKey (GetTableName CurrentAdminRecord) ~ UUID) =>
Maybe (Id CurrentAdminRecord)
currentAdminIdOrNothing = UUID -> Id CurrentAdminRecord
PrimaryKey (GetTableName CurrentAdminRecord)
-> Id CurrentAdminRecord
forall (table :: Symbol). PrimaryKey table -> Id' table
ModelSupport.Id (UUID -> Id CurrentAdminRecord)
-> Maybe UUID -> Maybe (Id CurrentAdminRecord)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key (Maybe UUID) -> Request -> Maybe UUID
forall user. Key (Maybe user) -> Request -> Maybe user
lookupAuthVault Key (Maybe UUID)
currentAdminIdVaultKey ?request::Request
Request
?request
{-# INLINE currentAdminIdOrNothing #-}

-- | Ensures that an admin is logged in. Redirects to login page if not.
ensureIsAdmin :: forall (admin :: Type). (?context :: ControllerContext, ?request :: Request, ?respond :: Respond, HasNewSessionUrl admin, Typeable admin, admin ~ CurrentAdminRecord) => IO ()
ensureIsAdmin :: forall admin.
(?context::ControllerContext, ?request::Request, ?respond::Respond,
 HasNewSessionUrl admin, Typeable admin,
 admin ~ CurrentAdminRecord) =>
IO ()
ensureIsAdmin =
    case forall admin.
(?request::Request, admin ~ CurrentAdminRecord, Typeable admin) =>
Maybe admin
currentAdminOrNothing @admin of
        Just admin
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Maybe admin
Nothing -> (?request::Request, ?respond::Respond) => Text -> IO ()
Text -> IO ()
redirectToLoginWithMessage (Proxy admin -> Text
forall {k} (user :: k). HasNewSessionUrl user => Proxy user -> Text
newSessionUrl (Proxy admin
forall {k} (t :: k). Proxy t
Proxy :: Proxy admin))
{-# INLINABLE ensureIsAdmin #-}

-- | Log in a user
--
-- Stores the user's UUID in the session as raw ASCII bytes (36 bytes).
--
-- Examples:
--
-- > action ExampleAction = do
-- >     user <- query @User |> fetchOne
-- >     login user
-- >
-- >     redirectToPath "/"
--
login :: forall user.
    ( ?request :: Request
    , KnownSymbol (ModelSupport.GetModelName user)
    , HasField "id" user (ModelSupport.Id user)
    , ModelSupport.PrimaryKey (ModelSupport.GetTableName user) ~ UUID
    ) => user -> IO ()
login :: forall user.
(?request::Request, KnownSymbol (GetModelName user),
 HasField "id" user (Id user),
 PrimaryKey (GetTableName user) ~ UUID) =>
user -> IO ()
login user
user = (?request::Request) => ByteString -> ByteString -> IO ()
ByteString -> ByteString -> IO ()
sessionInsert (forall user. KnownSymbol (GetModelName user) => ByteString
sessionKey @user) (UUID -> ByteString
UUID.toASCIIBytes (Id user -> PrimaryKey (GetTableName user)
forall (model :: Symbol). Id' model -> PrimaryKey model
ModelSupport.unpackId user
user.id))
{-# INLINABLE login #-}

-- | Log out a user
--
-- Example:
--
-- > action LogoutAction = do
-- >     let user = currentUser
-- >     logout user
-- >
-- >     redirectToPath "/"
--
logout :: forall user. (?request :: Request, KnownSymbol (ModelSupport.GetModelName user)) => user -> IO ()
logout :: forall user.
(?request::Request, KnownSymbol (GetModelName user)) =>
user -> IO ()
logout user
user = (?request::Request) => ByteString -> IO ()
ByteString -> IO ()
deleteSession (forall user. KnownSymbol (GetModelName user) => ByteString
sessionKey @user)
{-# INLINABLE logout #-}

sessionKey :: forall user. (KnownSymbol (ModelSupport.GetModelName user)) => ByteString
sessionKey :: forall user. KnownSymbol (GetModelName user) => ByteString
sessionKey = ByteString
"login." ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (forall model. KnownSymbol (GetModelName model) => Text
ModelSupport.getModelName @user)
{-# INLINABLE sessionKey #-}

redirectToLoginWithMessage :: (?request :: Request, ?respond :: Respond) => Text -> IO ()
redirectToLoginWithMessage :: (?request::Request, ?respond::Respond) => Text -> IO ()
redirectToLoginWithMessage Text
newSessionPath = do
    (?request::Request) => Text -> IO ()
Text -> IO ()
setSuccessMessage Text
"Please log in to access this page"
    ByteString -> ByteString -> IO ()
forall value.
(?request::Request, Serialize value) =>
ByteString -> value -> IO ()
setSession ByteString
"IHP.LoginSupport.redirectAfterLogin" ByteString
(?request::Request) => ByteString
getRequestPathAndQuery
    IO ResponseReceived -> IO ()
forall a. IO ResponseReceived -> IO a
earlyReturn (IO ResponseReceived -> IO ()) -> IO ResponseReceived -> IO ()
forall a b. (a -> b) -> a -> b
$ (?request::Request, ?respond::Respond) =>
Text -> IO ResponseReceived
Text -> IO ResponseReceived
redirectToPath Text
newSessionPath


redirectToLogin :: (?request :: Request, ?respond :: Respond) => Text -> a
redirectToLogin :: forall a. (?request::Request, ?respond::Respond) => Text -> a
redirectToLogin Text
newSessionPath = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ do
    IO ResponseReceived -> IO (ZonkAny 0)
forall a. IO ResponseReceived -> IO a
earlyReturn (IO ResponseReceived -> IO (ZonkAny 0))
-> IO ResponseReceived -> IO (ZonkAny 0)
forall a b. (a -> b) -> a -> b
$ (?request::Request, ?respond::Respond) =>
Text -> IO ResponseReceived
Text -> IO ResponseReceived
redirectToPath Text
newSessionPath
    Text -> IO a
forall a. Text -> a
error Text
"Unreachable"

-- | After this call the security policies defined in your Schema.sql will be applied to the controller actions called after this
--
-- __Example:__
--
-- > instance InitControllerContext WebApplication where
-- >     initContext = do
-- >         enableRowLevelSecurityIfLoggedIn
--
-- Let's assume we have a policy defined in our Schema.sql that only allows users to see and edit rows in the projects table that have @projects.user_id = current_user_id@:
--
-- > CREATE POLICY "Users can manage their projects" ON projects USING (user_id = ihp_user_id()) WITH CHECK (user_id = ihp_user_id());
--
-- Now any database queries to our @projects@ table will have this policy applied.
--
-- E.g. this action will now only show the users projects, even though no explicit @filterWhere (#userId, currentUserId)@ is specified on the query:
--
-- > action ProjectsAction = do
-- >     projects <- query @Project |> fetch
--
enableRowLevelSecurityIfLoggedIn ::
    ( ?context :: ControllerContext
    , ?request :: Request
    , ModelSupport.PrimaryKey (ModelSupport.GetTableName CurrentUserRecord) ~ UUID
    ) => IO ()
enableRowLevelSecurityIfLoggedIn :: (?context::ControllerContext, ?request::Request,
 PrimaryKey (GetTableName CurrentUserRecord) ~ UUID) =>
IO ()
enableRowLevelSecurityIfLoggedIn = do
    case Maybe (Id CurrentUserRecord)
(?request::Request,
 PrimaryKey (GetTableName CurrentUserRecord) ~ UUID) =>
Maybe (Id CurrentUserRecord)
currentUserIdOrNothing of
        Just Id CurrentUserRecord
userId -> do
            let rlsAuthenticatedRole :: Text
rlsAuthenticatedRole = ?context::ControllerContext
ControllerContext
?context.frameworkConfig.rlsAuthenticatedRole
            let rlsUserId :: Text
rlsUserId = Id CurrentUserRecord -> Text
forall a. Show a => a -> Text
tshow Id CurrentUserRecord
userId
            let rlsContext :: RowLevelSecurityContext
rlsContext = ModelSupport.RowLevelSecurityContext { Text
rlsAuthenticatedRole :: Text
rlsAuthenticatedRole :: Text
rlsAuthenticatedRole, Text
rlsUserId :: Text
rlsUserId :: Text
rlsUserId}
            IORef (Maybe RowLevelSecurityContext)
-> Maybe RowLevelSecurityContext -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Key (IORef (Maybe RowLevelSecurityContext))
-> Request -> IORef (Maybe RowLevelSecurityContext)
forall value. Typeable value => Key value -> Request -> value
lookupRequestVault Key (IORef (Maybe RowLevelSecurityContext))
rlsContextVaultKey ?request::Request
Request
?request) (RowLevelSecurityContext -> Maybe RowLevelSecurityContext
forall a. a -> Maybe a
Just RowLevelSecurityContext
rlsContext)
        Maybe (Id CurrentUserRecord)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()