{-|
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)
import GHC.Records
import IHP.ModelSupport
import IHP.HaskellSupport
import Text.Regex.TDFA
import Data.List ((!!))
import Network.URI (parseURI, uriScheme)

-- | 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 model. (
        KnownSymbol field
        , HasField field model fieldValue
        , HasField "meta" model MetaBag
        , SetField "meta" model MetaBag
    ) => Proxy field -> Validator fieldValue -> model -> model
validateField :: forall (field :: Symbol) fieldValue model.
(KnownSymbol field, HasField field model fieldValue,
 HasField "meta" model MetaBag, SetField "meta" model MetaBag) =>
Proxy field -> Validator fieldValue -> model -> model
validateField Proxy field
field Validator fieldValue
validator 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 (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)) 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 :: forall (field :: Symbol) 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
fieldProxy ValidatorIO fieldValue
customValidation model
model = do
    let fieldValue
value :: fieldValue = 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
    ValidatorResult
result <- ValidatorIO fieldValue
customValidation fieldValue
value
    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
result model
model)
{-# INLINE validateFieldIO #-}

-- | Validate a Maybe field.
--
-- Validate a Maybe field using a given validator function.
-- >>> validateMaybe nonEmpty (Just "foo")
-- Success
--
-- >>> validateMaybe nonEmpty (Just "")
-- Failure "This field cannot be empty"
--
-- If the value is 'Nothing', the validation will succeed.
-- >>> validateMaybe nonEmpty Nothing
-- Success
--
-- This function is useful when you want to validate a field that is optional.
-- >>> buildPost :: Post -> Post
-- >>> buildPost post = post
-- >>>     |> validateField #title nonEmpty
-- >>>     -- Assuming sourceUrl is optional.
-- >>>     |> validateField #sourceUrl (validateMaybe nonEmpty)
validateMaybe :: (val -> ValidatorResult) -> Maybe val -> ValidatorResult
validateMaybe :: forall val.
(val -> ValidatorResult) -> Maybe val -> ValidatorResult
validateMaybe val -> ValidatorResult
_ Maybe val
Nothing = ValidatorResult
Success
validateMaybe val -> ValidatorResult
validator (Just val
value) = val -> ValidatorResult
validator val
value
{-# INLINE validateMaybe #-}

-- | 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 :: forall value.
Text -> (value -> ValidatorResult) -> value -> ValidatorResult
withCustomErrorMessage Text
errorMessage value -> ValidatorResult
validator value
value =
    case value -> ValidatorResult
validator value
value of
        Failure Text
_ -> Text -> ValidatorResult
Failure Text
errorMessage
        ValidatorResult
Success -> ValidatorResult
Success
{-# INLINABLE 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 :: forall value.
[value -> ValidatorResult] -> value -> ValidatorResult
validateAny [value -> ValidatorResult]
validators 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
    Bool
True -> ValidatorResult
Success
    Bool
False -> Text -> ValidatorResult
Failure Text
"did not pass any validators"
{-# INLINABLE validateAny #-}


-- | 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 :: forall value.
[value -> ValidatorResult] -> value -> ValidatorResult
validateAll [value -> ValidatorResult]
validators 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
    Bool
True -> ValidatorResult
Success
    Bool
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. HasCallStack => [a] -> Int -> a
!! Int
0
{-# INLINABLE validateAll #-}


-- | 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 :: IsEmpty value => value -> ValidatorResult
nonEmpty :: forall value. IsEmpty value => value -> ValidatorResult
nonEmpty value
value | value -> Bool
forall value. IsEmpty value => value -> Bool
isEmpty value
value = Text -> ValidatorResult
Failure Text
"This field cannot be empty"
nonEmpty value
_ = ValidatorResult
Success
{-# INLINABLE 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 :: IsEmpty value => value -> ValidatorResult
isEmptyValue :: forall value. IsEmpty value => value -> ValidatorResult
isEmptyValue value
value | value -> Bool
forall value. IsEmpty value => value -> Bool
isEmpty value
value = ValidatorResult
Success
isEmptyValue value
_ = Text -> ValidatorResult
Failure Text
"This field must be empty"
{-# INLINABLE 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
> Int
5 = ValidatorResult
Success
isPhoneNumber Text
text = Text -> ValidatorResult
Failure Text
"is not a valid phone number (has to start with +, at least 5 characters)"
{-# INLINABLE 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 -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ (Text
"^[^ @]+@[^ @_+]+\\.?[^ @_+-]+$" :: Text) = ValidatorResult
Success
isEmail Text
text = Text -> ValidatorResult
Failure Text
"is not a valid email"
{-# INLINABLE 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 :: forall value.
(Show value, Ord value) =>
(value, value) -> value -> ValidatorResult
isInRange (value
min, value
max) 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 (value
min, value
max) value
value = Text -> ValidatorResult
Failure (Text
"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
<> Text
" and " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> value -> Text
forall a. Show a => a -> Text
tshow value
max)
{-# INLINABLE 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 :: forall value.
(Show value, Ord value) =>
value -> value -> ValidatorResult
isLessThan value
max value
value | value
value value -> value -> Bool
forall a. Ord a => a -> a -> Bool
< value
max = ValidatorResult
Success
isLessThan value
max value
value = Text -> ValidatorResult
Failure (Text
"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)
{-# INLINABLE 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 :: forall value.
(Show value, Ord value) =>
value -> value -> ValidatorResult
isGreaterThan value
min value
value | value
value value -> value -> Bool
forall a. Ord a => a -> a -> Bool
> value
min = ValidatorResult
Success
isGreaterThan value
min value
value = Text -> ValidatorResult
Failure (Text
"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)
{-# INLINABLE isGreaterThan #-}


-- | Validates that value is equal to another value
--
-- >>> isEqual "foo" "foo"
-- Success
--
-- >>> isEqual "foo" "bar"
-- Failure "has to be equal to \"foo\""
isEqual :: (Show value, Eq value) => value -> value -> ValidatorResult
isEqual :: forall value.
(Show value, Eq value) =>
value -> value -> ValidatorResult
isEqual value
expected value
value | value
value value -> value -> Bool
forall a. Eq a => a -> a -> Bool
== value
expected = ValidatorResult
Success
isEqual value
expected value
value = Text -> ValidatorResult
Failure (Text
"has to be equal to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> value -> Text
forall a. Show a => a -> Text
tshow value
expected)
{-# INLINABLE isEqual #-}

-- | 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 Int
max 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 Int
max Text
text = Text -> ValidatorResult
Failure (Text
"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
<> Text
" characters")
{-# INLINABLE 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 Int
min 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 Int
min Text
text = Text -> ValidatorResult
Failure (Text
"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
<> Text
" characters")
{-# INLINABLE 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 -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ (Text
"^#([0-9a-f]{3}|[0-9a-f]{6})$" :: Text) = ValidatorResult
Success
isRgbHexColor Text
text = Text -> ValidatorResult
Failure Text
"is not a valid rgb hex color"
{-# INLINABLE 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 -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ (Text
"^#([0-9a-f]{4}|[0-9a-f]{8})$" :: Text) = ValidatorResult
Success
isRgbaHexColor Text
text = Text -> ValidatorResult
Failure Text
"is not a valid rgba hex color"
{-# INLINABLE 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 Text
"is not a valid hex color"
{-# INLINABLE 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 -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ (Text
"^rgb\\( *([0-9]*\\.)?[0-9]+ *, *([0-9]*\\.)?[0-9]+ *, *([0-9]*\\.)?[0-9]+ *\\)$" :: Text) = ValidatorResult
Success
isRgbColor Text
text = Text -> ValidatorResult
Failure Text
"is not a valid rgb() color"
{-# INLINABLE 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 -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ (Text
"^rgba\\( *([0-9]*\\.)?[0-9]+ *, *([0-9]*\\.)?[0-9]+ *, *([0-9]*\\.)?[0-9]+ *, *([0-9]*\\.)?[0-9]+ *\\)$" :: Text) = ValidatorResult
Success
isRgbaColor Text
text = Text -> ValidatorResult
Failure Text
"is not a valid rgba() color"
{-# INLINABLE 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 Text
"is not a valid color"
{-# INLINABLE isColor #-}


-- | Validates string starts with @http://@ or @https://@
--
-- >>> isUrl "https://digitallyinduced.com"
-- Success
--
-- >>> isUrl "digitallyinduced.com"
-- Failure "URL must start with http:// or https://"
isUrl :: Text -> ValidatorResult
isUrl :: Text -> ValidatorResult
isUrl Text
url =
    case String -> Maybe URI
parseURI (Text -> [Element Text]
forall mono. MonoFoldable mono => mono -> [Element mono]
unpack Text
url) of
        Just URI
uri ->
            if URI -> String
uriScheme URI
uri Element [String] -> [String] -> Bool
forall mono.
(MonoFoldable mono, Eq (Element mono)) =>
Element mono -> mono -> Bool
`elem` [String
"http:", String
"https:"]
                then ValidatorResult
Success
                else Text -> ValidatorResult
Failure Text
"URL must start with http:// or https://"
        Maybe URI
Nothing  -> Text -> ValidatorResult
Failure Text
"Invalid URL"
{-# INLINABLE isUrl #-}


isInList :: (Eq value, Show value) => [value] -> value -> ValidatorResult
isInList :: forall value.
(Eq value, Show value) =>
[value] -> value -> ValidatorResult
isInList [value]
list value
value | [value]
list [value] -> ([value] -> Bool) -> Bool
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Element [value] -> [value] -> Bool
forall mono.
(MonoFoldable mono, Eq (Element mono)) =>
Element mono -> mono -> Bool
includes value
Element [value]
value = ValidatorResult
Success
isInList [value]
list value
value = Text -> ValidatorResult
Failure (Text
"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))
{-# INLINABLE isInList #-}

-- | Validates that value is True
--
-- >>> isTrue True
-- Success
--
-- >>> isTrue False
-- Failure "This field cannot be false"
isTrue :: Bool -> ValidatorResult
isTrue :: Bool -> ValidatorResult
isTrue Bool
value = if Bool
value then ValidatorResult
Success else Text -> ValidatorResult
Failure Text
"This field cannot be false"
{-# INLINABLE isTrue #-}


-- | Validates that value is False
--
-- >>> isFalse False
-- Success
--
-- >>> isFalse True
-- Failure "This field cannot be true"
isFalse :: Bool -> ValidatorResult
isFalse :: Bool -> ValidatorResult
isFalse Bool
value = if Bool -> Bool
not Bool
value then ValidatorResult
Success else Text -> ValidatorResult
Failure Text
"This field cannot be true"
{-# INLINABLE isFalse #-}


-- | Validates that value is matched by the regular expression
--
-- >>> matchesRegex "^[0-9]{4}$" "2016"
-- Success
--
-- >>> matchesRegex "^[0-9]{4}$" "16"
-- Failure "This field does not match the regular expression \"^[0-9]{4}$\""
--
-- >>> matchesRegex "[0-9]{4}" "xx2016xx"
-- Success -- regex is missing ^ and $
--
matchesRegex :: Text -> Text -> ValidatorResult
matchesRegex :: Text -> Text -> ValidatorResult
matchesRegex Text
regex Text
text = if Text
text Text -> Text -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ Text
regex then ValidatorResult
Success else Text -> ValidatorResult
Failure (Text -> ValidatorResult) -> Text -> ValidatorResult
forall a b. (a -> b) -> a -> b
$ Text
"This field does not match the regular expression \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
regex Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
{-# INLINABLE matchesRegex #-}


-- | Validates that value is a valid slug
--
-- >>> isSlug "i-am-a-slug"
-- Success
--
-- >>> isSlug "I-AM-A-Slug (Copy)"
-- Failure "is not a valid slug (consisting of only letters, numbers, underscores or hyphens)"
isSlug :: Text -> ValidatorResult
isSlug :: Text -> ValidatorResult
isSlug Text
text | Text
text Text -> Text -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ (Text
"^[a-zA-Z0-9_-]+$" :: Text) = ValidatorResult
Success
isSlug Text
text = Text -> ValidatorResult
Failure Text
"is not a valid slug (consisting of only letters, numbers, underscores or hyphens)"
{-# INLINABLE isSlug #-}