module IHP.ValidationSupport.Types where
import IHP.Prelude
import qualified Data.Text as Text
import IHP.ModelSupport (Violation (..))
import Text.Blaze.Html5 (Html)
import qualified Text.Blaze.Html.Renderer.Text as Blaze
import qualified Data.List as List
data ValidatorResult
= Success
| Failure !Text
| FailureHtml !Text
deriving (Eq, Show)
{-# INLINE isSuccess #-}
isSuccess Success = True
isSuccess _ = False
{-# INLINE isFailure #-}
isFailure Failure {} = True
isFailure FailureHtml {} = True
isFailure _ = False
{-# INLINE attachValidatorResult #-}
attachValidatorResult :: (KnownSymbol field, HasField "meta" model MetaBag, SetField "meta" model MetaBag) => Proxy field -> ValidatorResult -> model -> model
attachValidatorResult field Success record = record
attachValidatorResult field (Failure message) record = modify #meta prependAnnotation record
where
prependAnnotation :: MetaBag -> MetaBag
prependAnnotation = modify #annotations (\a -> annotation:a)
annotation = (Text.pack (symbolVal field), TextViolation message)
attachValidatorResult field (FailureHtml message) record = modify #meta prependAnnotation record
where
prependAnnotation :: MetaBag -> MetaBag
prependAnnotation = modify #annotations (\a -> annotation:a)
annotation = (Text.pack (symbolVal field), HtmlViolation message)
-- | Adds a plain-text validation error to a record
--
-- __Example:__
--
-- >>> record |> attachFailure #email "should be a valid email"
-- User { .., meta = MetaBag { .., annotations = [ ("email", TextViolation "should be a valid email") ] } }
--
-- You can use this together with 'getValidationFailure'
--
-- > user
-- > |> attachFailure #email "cannot be empty"
-- > |> getValidationFailure #email
-- >
-- > -- Returns: Just "cannot be empty"
--
-- If your error message uses HTML code, use 'attachFailureHtml'.
attachFailure :: (KnownSymbol field, HasField "meta" model MetaBag, SetField "meta" model MetaBag) => Proxy field -> Text -> model -> model
attachFailure field !message = attachValidatorResult field (Failure message)
{-# INLINE attachFailure #-}
-- | Adds a validation error to a record. The error message can contain HTML code.
--
-- __Example:__
--
-- >>> record |> attachFailureHtml #email [hsx|should be a valid email. Check out the documentation|]
-- User { .., meta = MetaBag { .., annotations = [ ("email", HtmlViolation "should be a valid email. Check out the documentation") ] } }
--
-- You can use this together with 'getValidationViolation'
--
-- > user
-- > |> attachFailure #email "cannot be empty"
-- > |> getValidationViolation #email
-- >
-- > -- Returns: Just (HtmlViolation "should be a valid email. Check out the documentation")
attachFailureHtml :: (KnownSymbol field, HasField "meta" model MetaBag, SetField "meta" model MetaBag) => Proxy field -> Html -> model -> model
attachFailureHtml field !message = attachValidatorResult field (FailureHtml renderedHtml)
where
renderedHtml = message
|> Blaze.renderHtml
|> cs
{-# INLINE attachFailureHtml #-}
-- | Returns the validation failure for a field or Nothing
--
-- > user
-- > |> attachFailure #email "cannot be empty"
-- > |> getValidationFailure #email
-- >
-- > -- Returns: Just "cannot be empty"
--
-- When 'attachFailureHtml' is used, this function will return HTML code:
--
-- > user
-- > |> attachFailureHtml #url [hsx|Invalid value, check the documentation|]
-- > |> getValidationFailure #url
-- >
-- > -- Returns: Just "Invalid value, check the documentation"
--
--
-- If you need to special-case validation errors with HTML code, use 'getValidationViolation'
getValidationFailure :: (KnownSymbol field, HasField "meta" model MetaBag) => Proxy field -> model -> Maybe Text
getValidationFailure field model = (.message) <$> getValidationViolation field model
{-# INLINE getValidationFailure #-}
-- | Similar to 'getValidationFailure', but exposes the information whether the error message contains HTML code
--
-- >>> user |> getValidationViolation #email
-- Just (TextViolation "cannot be empty")
--
getValidationViolation :: (KnownSymbol field, HasField "meta" model MetaBag) => Proxy field -> model -> Maybe Violation
getValidationViolation field model =
List.lookup fieldName model.meta.annotations
where
fieldName = Text.pack (symbolVal field)