module IHP.ValidationSupport.ValidateIsUnique
( validateIsUnique
, validateIsUniqueCaseInsensitive
, withCustomErrorMessageIO
) where

import IHP.Prelude
import Database.PostgreSQL.Simple.ToField
import IHP.ModelSupport
import IHP.ValidationSupport.Types
import IHP.QueryBuilder
import IHP.Fetch

-- | Validates that e.g. an email (or another field) is unique across all users before inserting.
--
-- This validator reads the given field name (e.g. email) from the record, and runs a database query
-- to check that there is no other record using the same field value (e.g. email value).
--
-- __Example:__ Validate that an email is unique
--
-- > action CreateUserAction = do
-- >     let user = newRecord @User
-- >     user
-- >         |> fill @'["email"]
-- >         |> validateIsUnique #email
-- >         >>= ifValid \case
-- >             Left user -> render NewView { .. }
-- >             Right user -> do
-- >                 createRecord user
-- >                 redirectTo UsersAction
validateIsUnique :: forall field model savedModel fieldValue modelId savedModelId. (
        savedModel ~ NormalizeModel model
        , ?modelContext :: ModelContext
        , FromRow savedModel
        , KnownSymbol field
        , HasField field model fieldValue
        , HasField field savedModel fieldValue
        , KnownSymbol (GetTableName savedModel)
        , ToField fieldValue
        , EqOrIsOperator fieldValue
        , HasField "meta" model MetaBag
        , SetField "meta" model MetaBag
        , HasField "id" savedModel savedModelId
        , HasField "id" model modelId
        , savedModelId ~ modelId
        , Eq modelId
        , GetModelByTableName (GetTableName savedModel) ~ savedModel
        , Table savedModel
    ) => Proxy field -> model -> IO model
validateIsUnique :: forall (field :: Symbol) model savedModel fieldValue modelId
       savedModelId.
(savedModel ~ NormalizeModel model, ?modelContext::ModelContext,
 FromRow savedModel, KnownSymbol field,
 HasField field model fieldValue,
 HasField field savedModel fieldValue,
 KnownSymbol (GetTableName savedModel), ToField fieldValue,
 EqOrIsOperator fieldValue, HasField "meta" model MetaBag,
 SetField "meta" model MetaBag,
 HasField "id" savedModel savedModelId, HasField "id" model modelId,
 savedModelId ~ modelId, Eq modelId,
 GetModelByTableName (GetTableName savedModel) ~ savedModel,
 Table savedModel) =>
Proxy field -> model -> IO model
validateIsUnique Proxy field
fieldProxy model
model = Proxy field -> model -> Bool -> IO model
forall (field :: Symbol) model savedModel fieldValue modelId
       savedModelId.
(savedModel ~ NormalizeModel model, ?modelContext::ModelContext,
 FromRow savedModel, KnownSymbol field,
 HasField field model fieldValue,
 HasField field savedModel fieldValue,
 KnownSymbol (GetTableName savedModel), ToField fieldValue,
 EqOrIsOperator fieldValue, HasField "meta" model MetaBag,
 SetField "meta" model MetaBag,
 HasField "id" savedModel savedModelId, HasField "id" model modelId,
 savedModelId ~ modelId, Eq modelId,
 GetModelByTableName (GetTableName savedModel) ~ savedModel,
 Table savedModel) =>
Proxy field -> model -> Bool -> IO model
validateIsUniqueCaseAware Proxy field
fieldProxy model
model Bool
True
{-# INLINE validateIsUnique #-}


-- | Case insensitive version of 'validateIsUnique'.
--
-- Uses a comparison like @LOWER(field) = LOWER(value)@ internally, so it's best to have an index for @LOWER(field)@ in your Schema.sql
--
-- >>> CREATE UNIQUE INDEX users_email_index ON users ((LOWER(email)));
--
-- __Example:__ Validate that an email is unique, ignoring case
--
-- > action CreateUserAction = do
-- >     let user = newRecord @User
-- >     user
-- >         |> fill @'["email"]
-- >         |> validateIsUniqueCaseInsensitive #email
-- >         >>= ifValid \case
-- >             Left user -> render NewView { .. }
-- >             Right user -> do
-- >                 createRecord user
-- >                 redirectTo UsersAction
validateIsUniqueCaseInsensitive :: forall field model savedModel fieldValue modelId savedModelId. (
        savedModel ~ NormalizeModel model
        , ?modelContext :: ModelContext
        , FromRow savedModel
        , KnownSymbol field
        , HasField field model fieldValue
        , HasField field savedModel fieldValue
        , KnownSymbol (GetTableName savedModel)
        , ToField fieldValue
        , EqOrIsOperator fieldValue
        , HasField "meta" model MetaBag
        , SetField "meta" model MetaBag
        , HasField "id" savedModel savedModelId
        , HasField "id" model modelId
        , savedModelId ~ modelId
        , Eq modelId
        , GetModelByTableName (GetTableName savedModel) ~ savedModel
        , Table savedModel
    ) => Proxy field -> model -> IO model
validateIsUniqueCaseInsensitive :: forall (field :: Symbol) model savedModel fieldValue modelId
       savedModelId.
(savedModel ~ NormalizeModel model, ?modelContext::ModelContext,
 FromRow savedModel, KnownSymbol field,
 HasField field model fieldValue,
 HasField field savedModel fieldValue,
 KnownSymbol (GetTableName savedModel), ToField fieldValue,
 EqOrIsOperator fieldValue, HasField "meta" model MetaBag,
 SetField "meta" model MetaBag,
 HasField "id" savedModel savedModelId, HasField "id" model modelId,
 savedModelId ~ modelId, Eq modelId,
 GetModelByTableName (GetTableName savedModel) ~ savedModel,
 Table savedModel) =>
Proxy field -> model -> IO model
validateIsUniqueCaseInsensitive Proxy field
fieldProxy model
model = Proxy field -> model -> Bool -> IO model
forall (field :: Symbol) model savedModel fieldValue modelId
       savedModelId.
(savedModel ~ NormalizeModel model, ?modelContext::ModelContext,
 FromRow savedModel, KnownSymbol field,
 HasField field model fieldValue,
 HasField field savedModel fieldValue,
 KnownSymbol (GetTableName savedModel), ToField fieldValue,
 EqOrIsOperator fieldValue, HasField "meta" model MetaBag,
 SetField "meta" model MetaBag,
 HasField "id" savedModel savedModelId, HasField "id" model modelId,
 savedModelId ~ modelId, Eq modelId,
 GetModelByTableName (GetTableName savedModel) ~ savedModel,
 Table savedModel) =>
Proxy field -> model -> Bool -> IO model
validateIsUniqueCaseAware Proxy field
fieldProxy model
model Bool
False
{-# INLINE validateIsUniqueCaseInsensitive #-}

-- | Internal helper for 'validateIsUnique' and 'validateIsUniqueCaseInsensitive'
validateIsUniqueCaseAware :: forall field model savedModel fieldValue modelId savedModelId. (
        savedModel ~ NormalizeModel model
        , ?modelContext :: ModelContext
        , FromRow savedModel
        , KnownSymbol field
        , HasField field model fieldValue
        , HasField field savedModel fieldValue
        , KnownSymbol (GetTableName savedModel)
        , ToField fieldValue
        , EqOrIsOperator fieldValue
        , HasField "meta" model MetaBag
        , SetField "meta" model MetaBag
        , HasField "id" savedModel savedModelId
        , HasField "id" model modelId
        , savedModelId ~ modelId
        , Eq modelId
        , GetModelByTableName (GetTableName savedModel) ~ savedModel
        , Table savedModel
    ) => Proxy field -> model -> Bool -> IO model
validateIsUniqueCaseAware :: forall (field :: Symbol) model savedModel fieldValue modelId
       savedModelId.
(savedModel ~ NormalizeModel model, ?modelContext::ModelContext,
 FromRow savedModel, KnownSymbol field,
 HasField field model fieldValue,
 HasField field savedModel fieldValue,
 KnownSymbol (GetTableName savedModel), ToField fieldValue,
 EqOrIsOperator fieldValue, HasField "meta" model MetaBag,
 SetField "meta" model MetaBag,
 HasField "id" savedModel savedModelId, HasField "id" model modelId,
 savedModelId ~ modelId, Eq modelId,
 GetModelByTableName (GetTableName savedModel) ~ savedModel,
 Table savedModel) =>
Proxy field -> model -> Bool -> IO model
validateIsUniqueCaseAware Proxy field
fieldProxy model
model Bool
caseSensitive = do
    let value :: fieldValue
value = forall {k} (x :: k) r a. HasField x r a => r -> a
forall (x :: Symbol) r a. HasField x r a => r -> a
getField @field model
model
    Maybe savedModel
result <- forall model (table :: Symbol).
(table ~ GetTableName model, Table model, DefaultScope table) =>
QueryBuilder table
query @savedModel
        QueryBuilder (GetTableName savedModel)
-> (QueryBuilder (GetTableName savedModel)
    -> QueryBuilder (GetTableName savedModel))
-> QueryBuilder (GetTableName savedModel)
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (if Bool
caseSensitive
                then (Proxy field, fieldValue)
-> QueryBuilder (GetTableName savedModel)
-> QueryBuilder (GetTableName savedModel)
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
filterWhere (Proxy field
fieldProxy, fieldValue
value)
                else (Proxy field, fieldValue)
-> QueryBuilder (GetTableName savedModel)
-> QueryBuilder (GetTableName savedModel)
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 field
fieldProxy, fieldValue
value)
            )
        QueryBuilder (GetTableName savedModel)
-> (QueryBuilder (GetTableName savedModel)
    -> IO (Maybe savedModel))
-> IO (Maybe savedModel)
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> QueryBuilder (GetTableName savedModel) -> IO (Maybe savedModel)
forall fetchable model.
(Fetchable fetchable model, Table model, FromRow model,
 ?modelContext::ModelContext) =>
fetchable -> IO (Maybe model)
fetchOneOrNothing
    case Maybe savedModel
result of
        Just savedModel
value | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ model
model.id modelId -> modelId -> Bool
forall a. Eq a => a -> a -> Bool
== savedModel
value.id -> model -> IO model
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Proxy field -> ValidatorResult -> model -> model
forall (field :: Symbol) model.
(KnownSymbol field, HasField "meta" model MetaBag,
 SetField "meta" model MetaBag) =>
Proxy field -> ValidatorResult -> model -> model
attachValidatorResult Proxy field
fieldProxy (Text -> ValidatorResult
Failure Text
"This is already in use") model
model)
        Maybe savedModel
_ -> model -> IO model
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Proxy field -> ValidatorResult -> model -> model
forall (field :: Symbol) model.
(KnownSymbol field, HasField "meta" model MetaBag,
 SetField "meta" model MetaBag) =>
Proxy field -> ValidatorResult -> model -> model
attachValidatorResult Proxy field
fieldProxy ValidatorResult
Success model
model)
{-# INLINE validateIsUniqueCaseAware #-}

-- | Overrides the error message of a given IO validator function.
--
-- __Example:__ Validate that an email is unique with a custom error message
--
-- > action CreateUserAction = do
-- >     let user = newRecord @User
-- >     user
-- >         |> fill @'["email"]
-- >         |> withCustomErrorMessageIO "Email Has Already Been Used" validateIsUnique #email
-- >         >>= ifValid \case
-- >             Left user -> render NewView { .. }
-- >             Right user -> do
-- >                 createRecord user
-- >                 redirectTo UsersAction
withCustomErrorMessageIO :: forall field model savedModel fieldValue modelId savedModelId. (
        savedModel ~ NormalizeModel model
        , ?modelContext :: ModelContext
        , FromRow savedModel
        , KnownSymbol field
        , HasField field model fieldValue
        , HasField field savedModel fieldValue
        , KnownSymbol (GetTableName savedModel)
        , ToField fieldValue
        , EqOrIsOperator fieldValue
        , HasField "meta" model MetaBag
        , SetField "meta" model MetaBag
        , HasField "id" savedModel savedModelId
        , HasField "id" model modelId
        , savedModelId ~ modelId
        , Eq modelId
        , GetModelByTableName (GetTableName savedModel) ~ savedModel
    ) => Text -> (Proxy field -> model -> IO model) -> Proxy field -> model -> IO model
withCustomErrorMessageIO :: forall (field :: Symbol) model savedModel fieldValue modelId
       savedModelId.
(savedModel ~ NormalizeModel model, ?modelContext::ModelContext,
 FromRow savedModel, KnownSymbol field,
 HasField field model fieldValue,
 HasField field savedModel fieldValue,
 KnownSymbol (GetTableName savedModel), ToField fieldValue,
 EqOrIsOperator fieldValue, HasField "meta" model MetaBag,
 SetField "meta" model MetaBag,
 HasField "id" savedModel savedModelId, HasField "id" model modelId,
 savedModelId ~ modelId, Eq modelId,
 GetModelByTableName (GetTableName savedModel) ~ savedModel) =>
Text
-> (Proxy field -> model -> IO model)
-> Proxy field
-> model
-> IO model
withCustomErrorMessageIO Text
message Proxy field -> model -> IO model
validator Proxy field
field model
model = do
    Proxy field -> model -> IO model
validator Proxy field
field model
model IO model -> (model -> IO model) -> IO model
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\model
model ->
                                let maybeFailure :: Maybe Text
maybeFailure = Proxy field -> model -> Maybe Text
forall (field :: Symbol) model.
(KnownSymbol field, HasField "meta" model MetaBag) =>
Proxy field -> model -> Maybe Text
getValidationFailure Proxy field
field model
model
                                in case Maybe Text
maybeFailure of
                                    Just Text
_ -> model -> IO model
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (model -> IO model) -> model -> IO model
forall a b. (a -> b) -> a -> b
$ Proxy field -> Text -> model -> model
forall (field :: Symbol) model.
(KnownSymbol field, HasField "meta" model MetaBag,
 SetField "meta" model MetaBag) =>
Proxy field -> Text -> model -> model
attachFailure Proxy field
field Text
message model
model
                                    Maybe Text
Nothing -> model -> IO model
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure model
model)
{-# INLINABLE withCustomErrorMessageIO #-}