{-|
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 field validator model = attachValidatorResult field (validator (getField @field 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 fieldProxy customValidation model = do
    let value :: fieldValue = getField @field model
    result <- customValidation value
    pure (attachValidatorResult fieldProxy result 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 _ Nothing = Success
validateMaybe validator (Just value) = validator 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 errorMessage validator value =
    case validator value of
        Failure _ -> Failure errorMessage
        Success -> 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 validators text =
  case any isSuccess $ map ($ text) validators of
    True -> Success
    False -> Failure "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 validators text =
  let results = map ($ text) validators
  in case all isSuccess results of
    True -> Success
    False -> (filter isFailure results) !! 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 value | isEmpty value = Failure "This field cannot be empty"
nonEmpty _ = 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 value | isEmpty value = Success
isEmptyValue _ = Failure "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 | "+" `isPrefixOf` text && length text > 5 = Success
isPhoneNumber text = Failure "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 | text =~ ("^[^ @]+@[^ @_+]+\\.?[^ @_+-]+$" :: Text) = Success
isEmail text = Failure "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 (min, max) value | value >= min && value <= max = Success
isInRange (min, max) value = Failure ("has to be between " <> tshow min <> " and " <> tshow 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 max value | value < max = Success
isLessThan max value = Failure ("has to be less than " <> tshow 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 min value | value > min = Success
isGreaterThan min value = Failure ("has to be greater than " <> tshow 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 expected value | value == expected = Success
isEqual expected value = Failure ("has to be equal to " <> tshow 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 max text | length text <= max = Success
hasMaxLength max text = Failure ("is longer than " <> tshow max <> " 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 min text | length text >= min = Success
hasMinLength min text = Failure ("is shorter than " <> tshow min <> " 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 | text =~ ("^#([0-9a-f]{3}|[0-9a-f]{6})$" :: Text) = Success
isRgbHexColor text = Failure "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 | text =~ ("^#([0-9a-f]{4}|[0-9a-f]{8})$" :: Text) = Success
isRgbaHexColor text = Failure "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 = validateAny [isRgbHexColor, isRgbaHexColor]
  |> withCustomErrorMessage "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 | text =~ ("^rgb\\( *([0-9]*\\.)?[0-9]+ *, *([0-9]*\\.)?[0-9]+ *, *([0-9]*\\.)?[0-9]+ *\\)$" :: Text) = Success
isRgbColor text = Failure "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 | text =~ ("^rgba\\( *([0-9]*\\.)?[0-9]+ *, *([0-9]*\\.)?[0-9]+ *, *([0-9]*\\.)?[0-9]+ *, *([0-9]*\\.)?[0-9]+ *\\)$" :: Text) = Success
isRgbaColor text = Failure "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 = validateAny [isRgbHexColor, isRgbaHexColor, isRgbColor, isRgbaColor]
  |> withCustomErrorMessage "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 url =
    case parseURI (unpack url) of
        Just uri ->
            if uriScheme uri `elem` ["http:", "https:"]
                then Success
                else Failure "URL must start with http:// or https://"
        Nothing  -> Failure "Invalid URL"
{-# INLINABLE isUrl #-}


isInList :: (Eq value, Show value) => [value] -> value -> ValidatorResult
isInList list value | list |> includes value = Success
isInList list value = Failure ("is not allowed. It needs to be one of the following: " <> (tshow list))
{-# INLINABLE isInList #-}

-- | Validates that value is True
--
-- >>> isTrue True
-- Success
--
-- >>> isTrue False
-- Failure "This field cannot be false"
isTrue :: Bool -> ValidatorResult
isTrue value = if value then Success else Failure "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 value = if not value then Success else Failure "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 regex text = if text =~ regex then Success else Failure $ "This field does not match the regular expression \"" <> regex <> "\""
{-# 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 | text =~ ("^[a-zA-Z0-9_-]+$" :: Text) = Success
isSlug text = Failure "is not a valid slug (consisting of only letters, numbers, underscores or hyphens)"
{-# INLINABLE isSlug #-}