{-|
Module: IHP.ValidationSupport.ValidateField
Description: Validation for records
Copyright: (c) digitally induced GmbH, 2020

Use 'validateField' and 'validateFieldIO' together with the validation functions to do simple validations.

Also take a look at 'IHP.ValidationSupport.ValidateIsUnique.validateIsUnique' for e.g. checking that an email is unique.
-}
module IHP.ValidationSupport.ValidateField where

import ClassyPrelude
import Data.Proxy
import IHP.ValidationSupport.Types
import GHC.TypeLits (KnownSymbol, Symbol)
import GHC.Records
import IHP.ModelSupport
import IHP.HaskellSupport
import Text.Regex.TDFA
import Data.List ((!!))

-- | A function taking some value and returning a 'ValidatorResult'
--
-- >>> Validator Text
-- Text -> ValidatorResult
--
-- >>> Validator Int
-- Int -> ValidatorResult
type Validator valueType = valueType -> ValidatorResult

-- | Validates a record field using a given validator function.
--
-- When the validation fails, the validation error is saved inside the @meta :: MetaBag@ field of the record.
-- You can retrieve a possible validation error using 'IHP.ValidationSupport.Types.getValidationFailure'.
--
-- __Example:__ 'nonEmpty' validation for a record
--
-- > let project :: Project = newRecord
-- > project
-- >     |> validateField #name nonEmpty
-- >     |> getValidationFailure #name -- Just "This field cannot be empty"
-- >
-- >
-- > project
-- >     |> set #name "Hello World"
-- >     |> validateField #name nonEmpty
-- >     |> getValidationFailure #name -- Nothing
--
--
-- __Example:__ Using 'IHP.Controller.Param.ifValid' for branching
--
-- > let project :: Project = newRecord
-- >
-- > project
-- >     |> validateField #name nonEmpty
-- >     |> ifValid \case
-- >         Left project -> do
-- >             putStrLn "Invalid project. Please try again"
-- >         Right project -> do
-- >             putStrLn "Project is valid. Saving to database."
-- >             createRecord project
validateField :: forall field fieldValue validator model. (
        KnownSymbol field
        , HasField field model fieldValue
        , HasField "meta" model MetaBag
        , SetField "meta" model MetaBag
    ) => Proxy field -> Validator fieldValue -> model -> model
validateField :: Proxy field -> Validator fieldValue -> model -> model
validateField field :: Proxy field
field validator :: Validator fieldValue
validator model :: model
model = 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
field (Validator fieldValue
validator (model -> fieldValue
forall k (x :: k) r a. HasField x r a => r -> a
getField @field model
model)) model
model
{-# INLINE validateField #-}


-- | A function taking some value and returning a 'IO ValidatorResult'
--
-- >>> ValidatorIO Text
-- Text -> IO ValidatorResult
--
-- >>> ValidatorIO Int
-- Int -> IO ValidatorResult
type ValidatorIO value = value -> IO ValidatorResult

-- | Validates a record field using a given validator function.
--
-- The same as 'validateField', but works with IO and can e.g. access the database.
--
-- When the validation fails, the validation error is saved inside the @meta :: MetaBag@ field of the record.
-- You can retrieve a possible validation error using 'IHP.ValidationSupport.Types.getValidationFailure'.
--
validateFieldIO :: forall field model fieldValue. (
        ?modelContext :: ModelContext
        , KnownSymbol field
        , HasField field model fieldValue
        , HasField "meta" model MetaBag
        , SetField "meta" model MetaBag
    ) => Proxy field -> ValidatorIO fieldValue -> model -> IO model
validateFieldIO :: Proxy field -> ValidatorIO fieldValue -> model -> IO model
validateFieldIO fieldProxy :: Proxy field
fieldProxy customValidation :: ValidatorIO fieldValue
customValidation model :: model
model = do
    let fieldValue
value :: fieldValue = model -> fieldValue
forall k (x :: k) r a. HasField x r a => r -> a
getField @field model
model
    ValidatorResult
result <- ValidatorIO fieldValue
customValidation fieldValue
value
    model -> IO model
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
result model
model)
{-# INLINE validateFieldIO #-}

-- | Overrides the error message of a given validator function.
--
-- >>> (nonEmpty |> withCustomErrorMessage "Custom error message") ""
-- Failure "Custom error message"
--
--
-- >>> (isEmail |> withCustomErrorMessage "We only accept valid email addresses") "not valid email"
-- Failure "We only accept valid email addresses"
withCustomErrorMessage :: Text -> (value -> ValidatorResult) -> value -> ValidatorResult
withCustomErrorMessage :: Text -> (value -> ValidatorResult) -> value -> ValidatorResult
withCustomErrorMessage errorMessage :: Text
errorMessage validator :: value -> ValidatorResult
validator value :: value
value =
    case value -> ValidatorResult
validator value
value of
        Failure _ -> Text -> ValidatorResult
Failure Text
errorMessage
        Success -> ValidatorResult
Success
{-# INLINE withCustomErrorMessage #-}


-- | Validates that value passes at least one of the given validators
--
-- >>> "ihp@example.com" |> validateAny([isEmptyValue, isEmail])
-- Success
--
-- >>> "" |> validateAny([isEmptyValue, isEmail])
-- Success
--
-- >>> "no spam plz" |> validateAny([empty, isEmail])
-- Failure "did not pass any validators"
validateAny :: [value -> ValidatorResult] -> value -> ValidatorResult
validateAny :: [value -> ValidatorResult] -> value -> ValidatorResult
validateAny validators :: [value -> ValidatorResult]
validators text :: value
text =
  case (Element [ValidatorResult] -> Bool) -> [ValidatorResult] -> Bool
forall mono.
MonoFoldable mono =>
(Element mono -> Bool) -> mono -> Bool
any Element [ValidatorResult] -> Bool
ValidatorResult -> Bool
isSuccess ([ValidatorResult] -> Bool) -> [ValidatorResult] -> Bool
forall a b. (a -> b) -> a -> b
$ ((value -> ValidatorResult) -> ValidatorResult)
-> [value -> ValidatorResult] -> [ValidatorResult]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ((value -> ValidatorResult) -> value -> ValidatorResult
forall a b. (a -> b) -> a -> b
$ value
text) [value -> ValidatorResult]
validators of
    True -> ValidatorResult
Success
    False -> Text -> ValidatorResult
Failure "did not pass any validators"


-- | Validates that value passes all of the given validators
--
-- In case of multiple failures, the first Failure is returned.
--
-- >>> 2016 |> validateAll([isGreaterThan(1900), isLessThan(2020)])
-- Success
--
-- >>> 1899 |> validateAll([isGreaterThan(1900), isLessThan(2020)])
-- Failure "has to be greater than 1900"
validateAll :: [value -> ValidatorResult] -> value -> ValidatorResult
validateAll :: [value -> ValidatorResult] -> value -> ValidatorResult
validateAll validators :: [value -> ValidatorResult]
validators text :: value
text =
  let results :: [ValidatorResult]
results = ((value -> ValidatorResult) -> ValidatorResult)
-> [value -> ValidatorResult] -> [ValidatorResult]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ((value -> ValidatorResult) -> value -> ValidatorResult
forall a b. (a -> b) -> a -> b
$ value
text) [value -> ValidatorResult]
validators
  in case (Element [ValidatorResult] -> Bool) -> [ValidatorResult] -> Bool
forall mono.
MonoFoldable mono =>
(Element mono -> Bool) -> mono -> Bool
all Element [ValidatorResult] -> Bool
ValidatorResult -> Bool
isSuccess [ValidatorResult]
results of
    True -> ValidatorResult
Success
    False -> ((Element [ValidatorResult] -> Bool)
-> [ValidatorResult] -> [ValidatorResult]
forall seq. IsSequence seq => (Element seq -> Bool) -> seq -> seq
filter Element [ValidatorResult] -> Bool
ValidatorResult -> Bool
isFailure [ValidatorResult]
results) [ValidatorResult] -> Int -> ValidatorResult
forall a. [a] -> Int -> a
!! 0


-- | Validates that value is not empty
--
-- >>> nonEmpty "hello world"
-- Success
--
-- >>> nonEmpty ""
-- Failure "This field cannot be empty"
--
-- >>> nonEmpty (Just "hello")
-- Success
--
-- >>> nonEmpty Nothing
-- Failure "This field cannot be empty"
nonEmpty :: MonoFoldable value => value -> ValidatorResult
nonEmpty :: value -> ValidatorResult
nonEmpty value :: value
value | value -> Bool
forall mono. MonoFoldable mono => mono -> Bool
null value
value = Text -> ValidatorResult
Failure "This field cannot be empty"
nonEmpty _ = ValidatorResult
Success
{-# INLINE nonEmpty #-}


-- | Validates that value is empty
--
-- >>> isEmptyValue "hello world"
-- Failure "This field must be empty"
--
-- >>> ieEmptyValue ""
-- Success
--
-- >>> isEmptyValue (Just "hello")
-- Failure "This field must be empty"
--
-- >>> isEmptyValue Nothing
-- Success
isEmptyValue :: MonoFoldable value => value -> ValidatorResult
isEmptyValue :: value -> ValidatorResult
isEmptyValue value :: value
value | value -> Bool
forall mono. MonoFoldable mono => mono -> Bool
null value
value = ValidatorResult
Success
isEmptyValue _ = Text -> ValidatorResult
Failure "This field must be empty"
{-# INLINE isEmptyValue #-}


-- | Validates that value looks like a phone number
--
-- Values needs to start with @\+@ and has to have atleast 5 characters
--
-- >>> isPhoneNumber "1337"
-- Failure ".."
--
-- >>> isPhoneNumber "+49123456789"
-- Success
isPhoneNumber :: Text -> ValidatorResult
isPhoneNumber :: Text -> ValidatorResult
isPhoneNumber text :: Text
text | "+" Text -> Text -> Bool
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`isPrefixOf` Text
text Bool -> Bool -> Bool
&& Text -> Int
forall mono. MonoFoldable mono => mono -> Int
length Text
text Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 5 = ValidatorResult
Success
isPhoneNumber text :: Text
text = Text -> ValidatorResult
Failure "is not a valid phone number (has to start with +, at least 5 characters)"
{-# INLINE isPhoneNumber #-}


-- | Validates that value is an email address
--
-- The validation is not meant to be compliant with RFC 822. Its purpose is to
-- reject obviously invalid values without false-negatives.
--
-- >>> isEmail "marc@digitallyinduced.com"
-- Success
--
-- >>> isEmail "marc@secret.digitallyinduced.com" -- subdomains are fine
-- Success
--
-- >>> isEmail "ॐ@मणिपद्मे.हूँ"
-- Success
--
-- >>> isEmail "marc@localhost" -- Although discouraged by ICANN, dotless TLDs are legal. See https://www.icann.org/news/announcement-2013-08-30-en
-- Success
--
-- >>> isEmail "loremipsum"
-- Failure "is not a valid email"
--
-- >>> isEmail "A@b@c@domain.com"
-- Failure "is not a valid email"
isEmail :: Text -> ValidatorResult
isEmail :: Text -> ValidatorResult
isEmail text :: Text
text | Text
text Text -> Text -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ ("^[^ @]+@[^ @_+]+\\.?[^ @_+-]+$" :: Text) = ValidatorResult
Success
isEmail text :: Text
text = Text -> ValidatorResult
Failure "is not a valid email"
{-# INLINE isEmail #-}


-- | Validates that value is between min and max
--
-- >>> isInRange (0, 10) 5
-- Success
--
-- >>> isInRange (0, 10) 0
-- Success
--
-- >>> isInRange (0, 10) 1337
-- Failure "has to be between 0 and 10"
--
-- >>> let isHumanAge = isInRange (0, 100)
-- >>> isHumanAge 22
-- Success
isInRange :: (Show value, Ord value) => (value, value) -> value -> ValidatorResult
isInRange :: (value, value) -> value -> ValidatorResult
isInRange (min :: value
min, max :: value
max) value :: value
value | value
value value -> value -> Bool
forall a. Ord a => a -> a -> Bool
>= value
min Bool -> Bool -> Bool
&& value
value value -> value -> Bool
forall a. Ord a => a -> a -> Bool
<= value
max = ValidatorResult
Success
isInRange (min :: value
min, max :: value
max) value :: value
value = Text -> ValidatorResult
Failure ("has to be between " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> value -> Text
forall a. Show a => a -> Text
tshow value
min Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " and " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> value -> Text
forall a. Show a => a -> Text
tshow value
max)
{-# INLINE isInRange #-}


-- | Validates that value is less than a max value
--
-- >>> isLessThan 10 5
-- Success
--
-- >>> isLessThan 10 20
-- Failure "has to be less than 10"
isLessThan :: (Show value, Ord value) => value -> value -> ValidatorResult
isLessThan :: value -> value -> ValidatorResult
isLessThan max :: value
max value :: value
value | value
value value -> value -> Bool
forall a. Ord a => a -> a -> Bool
< value
max = ValidatorResult
Success
isLessThan max :: value
max value :: value
value = Text -> ValidatorResult
Failure ("has to be less than " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> value -> Text
forall a. Show a => a -> Text
tshow value
max)
{-# INLINE isLessThan #-}


-- | Validates that value is greater than a min value
--
-- >>> isGreaterThan 10 20
-- Success
--
-- >>> isGreaterThan 10 5
-- Failure "has to be greater than 10"
isGreaterThan :: (Show value, Ord value) => value -> value -> ValidatorResult
isGreaterThan :: value -> value -> ValidatorResult
isGreaterThan min :: value
min value :: value
value | value
value value -> value -> Bool
forall a. Ord a => a -> a -> Bool
> value
min = ValidatorResult
Success
isGreaterThan min :: value
min value :: value
value = Text -> ValidatorResult
Failure ("has to be greater than " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> value -> Text
forall a. Show a => a -> Text
tshow value
min)
{-# INLINE isGreaterThan #-}


-- | Validates that value has a max length
--
-- >>> hasMaxLength 10 "IHP"
-- Success
--
-- >>> hasMaxLength 2 "IHP"
-- Failure "is longer than 2 characters"
hasMaxLength :: Int -> Text -> ValidatorResult
hasMaxLength :: Int -> Text -> ValidatorResult
hasMaxLength max :: Int
max text :: Text
text | Text -> Int
forall mono. MonoFoldable mono => mono -> Int
length Text
text Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
max = ValidatorResult
Success
hasMaxLength max :: Int
max text :: Text
text = Text -> ValidatorResult
Failure ("is longer than " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
max Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " characters")
{-# INLINE hasMaxLength #-}


-- | Validates that value has a min length
--
-- >>> hasMinLength 2 "IHP"
-- Success
--
-- >>> hasMinLength 10 "IHP"
-- Failure "is shorter than 10 characters"
hasMinLength :: Int -> Text -> ValidatorResult
hasMinLength :: Int -> Text -> ValidatorResult
hasMinLength min :: Int
min text :: Text
text | Text -> Int
forall mono. MonoFoldable mono => mono -> Int
length Text
text Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
min = ValidatorResult
Success
hasMinLength min :: Int
min text :: Text
text = Text -> ValidatorResult
Failure ("is shorter than " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
min Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " characters")
{-# INLINE hasMinLength #-}


-- | Validates that value is a hex-based rgb color string
--
-- >>> isRgbHexColor "#ffffff"
-- Success
--
-- >>> isRgbHexColor "#fff"
-- Success
--
-- >>> isRgbHexColor "rgb(0, 0, 0)"
-- Failure "is not a valid rgb hex color"
isRgbHexColor :: Text -> ValidatorResult
isRgbHexColor :: Text -> ValidatorResult
isRgbHexColor text :: Text
text | Text
text Text -> Text -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ ("^#([0-9a-f]{3}|[0-9a-f]{6})$" :: Text) = ValidatorResult
Success
isRgbHexColor text :: Text
text = Text -> ValidatorResult
Failure "is not a valid rgb hex color"
{-# INLINE isRgbHexColor #-}


-- | Validates that value is a hex-based rgb color string
--
-- >>> isRgbaHexColor "#ffffffff"
-- Success
--
-- >>> isRgbaHexColor "#ffff"
-- Success
--
-- >>> isRgbaHexColor "rgb(0, 0, 0, 1)"
-- Failure "is not a valid rgba hex color"
isRgbaHexColor :: Text -> ValidatorResult
isRgbaHexColor :: Text -> ValidatorResult
isRgbaHexColor text :: Text
text | Text
text Text -> Text -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ ("^#([0-9a-f]{4}|[0-9a-f]{8})$" :: Text) = ValidatorResult
Success
isRgbaHexColor text :: Text
text = Text -> ValidatorResult
Failure "is not a valid rgba hex color"
{-# INLINE isRgbaHexColor #-}


-- | Validates that value is a hex-based rgb(a) color string
--
-- >>> isHexColor "#ffffff"
-- Success
--
-- >>> isHexColor "#ffffffff"
-- Success
--
-- >>> isHexColor "rgb(0, 0, 0)"
-- Failure "is not a valid hex color"
isHexColor :: Text -> ValidatorResult
isHexColor :: Text -> ValidatorResult
isHexColor = [Text -> ValidatorResult] -> Text -> ValidatorResult
forall value.
[value -> ValidatorResult] -> value -> ValidatorResult
validateAny [Text -> ValidatorResult
isRgbHexColor, Text -> ValidatorResult
isRgbaHexColor]
  (Text -> ValidatorResult)
-> ((Text -> ValidatorResult) -> Text -> ValidatorResult)
-> Text
-> ValidatorResult
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Text -> (Text -> ValidatorResult) -> Text -> ValidatorResult
forall value.
Text -> (value -> ValidatorResult) -> value -> ValidatorResult
withCustomErrorMessage "is not a valid hex color"
{-# INLINE isHexColor #-}


-- | Validates that value is a rgb() color string
--
-- >>> isRgbColor "rgb(255, 0, 0)"
-- Success
--
-- >>> isRgbColor "#f00"
-- Failure "is not a valid rgb() color"
isRgbColor :: Text -> ValidatorResult
isRgbColor :: Text -> ValidatorResult
isRgbColor text :: Text
text | Text
text Text -> Text -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ ("^rgb\\( *([0-9]*\\.)?[0-9]+ *, *([0-9]*\\.)?[0-9]+ *, *([0-9]*\\.)?[0-9]+ *\\)$" :: Text) = ValidatorResult
Success
isRgbColor text :: Text
text = Text -> ValidatorResult
Failure "is not a valid rgb() color"
{-# INLINE isRgbColor #-}


-- | Validates that value is a rgba() color string
--
-- >>> isRgbaColor "rgb(255, 0, 0, 1.0)"
-- Success
--
-- >>> isRgbaColor "#f00f"
-- Failure "is not a valid rgba() color"
isRgbaColor :: Text -> ValidatorResult
isRgbaColor :: Text -> ValidatorResult
isRgbaColor text :: Text
text | Text
text Text -> Text -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ ("^rgba\\( *([0-9]*\\.)?[0-9]+ *, *([0-9]*\\.)?[0-9]+ *, *([0-9]*\\.)?[0-9]+ *, *([0-9]*\\.)?[0-9]+ *\\)$" :: Text) = ValidatorResult
Success
isRgbaColor text :: Text
text = Text -> ValidatorResult
Failure "is not a valid rgba() color"
{-# INLINE isRgbaColor #-}


-- | Validates that value is a hex-based or rgb(a) color string
--
-- >>> isColor "#ffffff"
-- Success
--
-- >>> isColor "rgba(255, 0, 0, 0.5)"
-- Success
--
-- >>> isColor "rgb(0, 0, 0)"
-- Failure "is not a valid color"
isColor :: Text -> ValidatorResult
isColor :: Text -> ValidatorResult
isColor = [Text -> ValidatorResult] -> Text -> ValidatorResult
forall value.
[value -> ValidatorResult] -> value -> ValidatorResult
validateAny [Text -> ValidatorResult
isRgbHexColor, Text -> ValidatorResult
isRgbaHexColor, Text -> ValidatorResult
isRgbColor, Text -> ValidatorResult
isRgbaColor]
  (Text -> ValidatorResult)
-> ((Text -> ValidatorResult) -> Text -> ValidatorResult)
-> Text
-> ValidatorResult
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Text -> (Text -> ValidatorResult) -> Text -> ValidatorResult
forall value.
Text -> (value -> ValidatorResult) -> value -> ValidatorResult
withCustomErrorMessage "is not a valid color"
{-# INLINE isColor #-}

-- | Validates string starts with @http://@ or @https://@
--
-- >>> isUrl "https://digitallyinduced.com"
-- Success
--
-- >>> isUrl "digitallyinduced.com"
-- Failure "is not a valid url. It needs to start with http:// or https://"
isUrl :: Text -> ValidatorResult
isUrl :: Text -> ValidatorResult
isUrl text :: Text
text | "http://" Text -> Text -> Bool
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`isPrefixOf` Text
text Bool -> Bool -> Bool
|| "https://" Text -> Text -> Bool
forall seq.
(IsSequence seq, Eq (Element seq)) =>
seq -> seq -> Bool
`isPrefixOf` Text
text = ValidatorResult
Success
isUrl text :: Text
text = Text -> ValidatorResult
Failure "is not a valid url. It needs to start with http:// or https://"
{-# INLINE isUrl #-}


isInList :: (Eq value, Show value) => [value] -> value -> ValidatorResult
isInList :: [value] -> value -> ValidatorResult
isInList list :: [value]
list value :: value
value | [value]
list [value] -> ([value] -> Bool) -> Bool
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Element [value] -> [value] -> Bool
forall container.
(MonoFoldable container, Eq (Element container)) =>
Element container -> container -> Bool
includes value
Element [value]
value = ValidatorResult
Success
isInList list :: [value]
list value :: value
value = Text -> ValidatorResult
Failure ("is not allowed. It needs to be one of the following: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ([value] -> Text
forall a. Show a => a -> Text
tshow [value]
list))