{-# LANGUAGE OverloadedStrings #-}
-- | Does the form contain valid data according to specified rules?
-- Can we normalize it to be more likely to do so?
module Text.HTML.Form.Validate(isInputValid, isInputValid', isFormValid, isFormValid',
        inputErrorMessage, inputErrorMessage', normalizeInput, normalizeForm) where

import Text.HTML.Form hiding (lang)
import Text.HTML.Form.I18n
import qualified Data.Text as Txt
import Text.Read (readMaybe)
import Data.Hourglass
import Network.URI (parseAbsoluteURI)
import Data.Maybe (isJust, isNothing)
import Text.Regex.TDFA ((=~), matchTest)

-- | Are all inputs in a form valid according to their rules?
isFormValid :: Form -> Bool
isFormValid :: Form -> Bool
isFormValid = (Input -> Bool) -> [Input] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Input -> Bool
isInputValid ([Input] -> Bool) -> (Form -> [Input]) -> Form -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Form -> [Input]
inputs

-- | Are all inputs in a form valid according to their rules, once normalized?
isFormValid' :: Form -> Bool
isFormValid' :: Form -> Bool
isFormValid' = (Input -> Bool) -> [Input] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Input -> Bool
isInputValid' ([Input] -> Bool) -> (Form -> [Input]) -> Form -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Form -> [Input]
inputs

-- | Is the given input valid?
isInputValid :: Input -> Bool
isInputValid :: Input -> Bool
isInputValid = String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> (Input -> String) -> Input -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Input -> String
inputErrorMessage String
"en"

-- | Is the given input once normalized valid?
isInputValid' :: Input -> Bool
isInputValid' :: Input -> Bool
isInputValid' = String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> (Input -> String) -> Input -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Input -> String
inputErrorMessage' String
"en"

-- | Describe why a form input is invalid, or return the empty string.
inputErrorMessage :: String -> Input -> String
inputErrorMessage :: String -> Input -> String
inputErrorMessage String
_ Input { inputType :: Input -> Text
inputType = Text
"hidden" } = String
"" -- Don't validate hiddens!
inputErrorMessage String
lang self :: Input
self@Input { required :: Input -> Bool
required = Bool
True }
    | Input -> Text
inputType Input
self Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"checkbox", Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Input -> Bool
checked Input
self = String -> String -> String
i18n String
lang String
"err required"
    -- Not validating "radio", needs different API...
    | Input -> Text
value Input
self Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" = String -> String -> String
i18n String
lang String
"err required"
inputErrorMessage String
_ Input { value :: Input -> Text
value = Text
"" } = String
"" -- Skip further checks for empty!
inputErrorMessage String
lang self :: Input
self@Input { pattern :: Input -> Maybe Regex
pattern = Just Regex
re }
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Regex
re Regex -> Text -> Bool
forall regex source.
RegexLike regex source =>
regex -> source -> Bool
`matchTest` Input -> Text
value Input
self = String -> String -> String
i18n String
lang String
"err format"
inputErrorMessage String
lang Input { lengthRange :: Input -> (Maybe Int, Maybe Int)
lengthRange = (Just Int
min', Maybe Int
_), value :: Input -> Text
value = Text
val }
    | Text -> Int
Txt.length Text
val Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
min' = String -> String -> Int -> String
forall a. Show a => String -> String -> a -> String
i18n' String
lang String
"err min chars" Int
min'
inputErrorMessage String
lang Input { lengthRange :: Input -> (Maybe Int, Maybe Int)
lengthRange = (Maybe Int
_, Just Int
max'), value :: Input -> Text
value = Text
val }
    | Text -> Int
Txt.length Text
val Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
max' = String -> String -> Int -> String
forall a. Show a => String -> String -> a -> String
i18n' String
lang String
"err max chars" Int
max'
inputErrorMessage String
lang Input { range :: Input -> (Maybe Text, Maybe Text)
range = (Just Text
min', Maybe Text
_), value :: Input -> Text
value = Text
val }
    | Just Float
x <- Text -> Maybe Float
forall a. Read a => Text -> Maybe a
readMaybe' Text
val :: Maybe Float, Just Float
y <- Text -> Maybe Float
forall a. Read a => Text -> Maybe a
readMaybe' Text
min', Float
x Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
y =
        String -> String -> Text -> String
forall a. Show a => String -> String -> a -> String
i18n' String
lang String
"err min" Text
min'
inputErrorMessage String
lang Input { range :: Input -> (Maybe Text, Maybe Text)
range = (Maybe Text
_, Just Text
max'), value :: Input -> Text
value = Text
val }
    | Just Float
x <- Text -> Maybe Float
forall a. Read a => Text -> Maybe a
readMaybe' Text
val :: Maybe Float, Just Float
y <- Text -> Maybe Float
forall a. Read a => Text -> Maybe a
readMaybe' Text
max', Float
x Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
y =
        String -> String -> Text -> String
forall a. Show a => String -> String -> a -> String
i18n' String
lang String
"err max" Text
max'
inputErrorMessage String
lang Input { range :: Input -> (Maybe Text, Maybe Text)
range = (Just Text
min', Maybe Text
_), step :: Input -> Maybe Text
step = Just Text
step', value :: Input -> Text
value = Text
val }
    | Just Integer
x <- Text -> Maybe Integer
forall a. Read a => Text -> Maybe a
readMaybe' Text
val :: Maybe Integer, Just Integer
y <- Text -> Maybe Integer
forall a. Read a => Text -> Maybe a
readMaybe' Text
min',
        Just Integer
z <- Text -> Maybe Integer
forall a. Read a => Text -> Maybe a
readMaybe' Text
step', Integer
z Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
0, Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem (Integer
x Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
y) Integer
z Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 =
            String -> String -> Text -> Text -> String
forall a b.
(Show a, Show b) =>
String -> String -> a -> b -> String
i18n2 String
lang String
"err increments" Text
step' Text
min'
inputErrorMessage String
lang Input { range :: Input -> (Maybe Text, Maybe Text)
range = (Just Text
min', Maybe Text
_), value :: Input -> Text
value = Text
val }
    | Just DateTime
x <- String -> Maybe DateTime
parseTime (String -> Maybe DateTime) -> String -> Maybe DateTime
forall a b. (a -> b) -> a -> b
$ Text -> String
Txt.unpack Text
val, Just DateTime
y <- String -> Maybe DateTime
parseTime (String -> Maybe DateTime) -> String -> Maybe DateTime
forall a b. (a -> b) -> a -> b
$ Text -> String
Txt.unpack Text
min',
        DateTime
x DateTime -> DateTime -> Bool
forall a. Ord a => a -> a -> Bool
< DateTime
y = String -> String -> Text -> String
forall a. Show a => String -> String -> a -> String
i18n' String
lang String
"err min" Text
min'
inputErrorMessage String
lang Input { range :: Input -> (Maybe Text, Maybe Text)
range = (Maybe Text
_, Just Text
max'), value :: Input -> Text
value = Text
val }
    | Just DateTime
x <- String -> Maybe DateTime
parseTime (String -> Maybe DateTime) -> String -> Maybe DateTime
forall a b. (a -> b) -> a -> b
$ Text -> String
Txt.unpack Text
val, Just DateTime
y <- String -> Maybe DateTime
parseTime (String -> Maybe DateTime) -> String -> Maybe DateTime
forall a b. (a -> b) -> a -> b
$ Text -> String
Txt.unpack Text
max',
        DateTime
x DateTime -> DateTime -> Bool
forall a. Ord a => a -> a -> Bool
> DateTime
y = String -> String -> Text -> String
forall a. Show a => String -> String -> a -> String
i18n' String
lang String
"err max" Text
max'
inputErrorMessage String
lang Input {
        range :: Input -> (Maybe Text, Maybe Text)
range = (Just Text
min', Maybe Text
_), step :: Input -> Maybe Text
step = Just Text
step',
        inputType :: Input -> Text
inputType = Text
ty, value :: Input -> Text
value = Text
val
      }
    | Text
ty Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"date", Just DateTime
x <- String -> Maybe DateTime
parseTime (String -> Maybe DateTime) -> String -> Maybe DateTime
forall a b. (a -> b) -> a -> b
$ Text -> String
Txt.unpack Text
val,
        Just DateTime
y <- String -> Maybe DateTime
parseTime (String -> Maybe DateTime) -> String -> Maybe DateTime
forall a b. (a -> b) -> a -> b
$ Text -> String
Txt.unpack Text
min', Just Seconds
z <- Text -> Maybe Seconds
forall a. Read a => Text -> Maybe a
readMaybe' Text
step',
        DateTime -> DateTime -> Seconds
forall t1 t2. (Timeable t1, Timeable t2) => t1 -> t2 -> Seconds
timeDiff DateTime
x DateTime
y Seconds -> Seconds -> Seconds
forall a. Integral a => a -> a -> a
`rem` Duration -> Seconds
forall i. TimeInterval i => i -> Seconds
toSeconds Duration
forall a. Monoid a => a
mempty { durationSeconds = 24*z } Seconds -> Seconds -> Bool
forall a. Eq a => a -> a -> Bool
== Int64 -> Seconds
Seconds Int64
0 =
            String -> String -> Text -> Text -> String
forall a b.
(Show a, Show b) =>
String -> String -> a -> b -> String
i18n2 String
lang String
"err increments" Text
step' Text
min'
    | Text
ty Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"month" = String
"" -- Not prepared to properly validate this...
    | Just DateTime
x <- String -> Maybe DateTime
parseTime (String -> Maybe DateTime) -> String -> Maybe DateTime
forall a b. (a -> b) -> a -> b
$ Text -> String
Txt.unpack Text
val, Just DateTime
y <- String -> Maybe DateTime
parseTime (String -> Maybe DateTime) -> String -> Maybe DateTime
forall a b. (a -> b) -> a -> b
$ Text -> String
Txt.unpack Text
min',
        Just Int64
z <- Text -> Maybe Int64
forall a. Read a => Text -> Maybe a
readMaybe' Text
step', DateTime -> DateTime -> Seconds
forall t1 t2. (Timeable t1, Timeable t2) => t1 -> t2 -> Seconds
timeDiff DateTime
x DateTime
y Seconds -> Seconds -> Seconds
forall a. Integral a => a -> a -> a
`rem` Int64 -> Seconds
Seconds Int64
z Seconds -> Seconds -> Bool
forall a. Eq a => a -> a -> Bool
== Int64 -> Seconds
Seconds Int64
0 =
            String -> String -> Text -> Text -> String
forall a b.
(Show a, Show b) =>
String -> String -> a -> b -> String
i18n2 String
lang String
"err increments" Text
step' Text
min'

-- Validation specific to input types
inputErrorMessage String
lang self :: Input
self@Input { inputType :: Input -> Text
inputType = Text
"color" }
    | (String
"#[0-9a-fA-F]{6}" :: String) String -> Text -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ Input -> Text
value Input
self = String -> String -> String
i18n String
lang String
"err colour"
inputErrorMessage String
lang self :: Input
self@Input { inputType :: Input -> Text
inputType = Text
"date" } = String -> Input -> String
isTime' String
lang Input
self
inputErrorMessage String
lang self :: Input
self@Input { inputType :: Input -> Text
inputType = Text
"datetime" } = String -> Input -> String
isTime' String
lang Input
self
inputErrorMessage String
l self :: Input
self@Input { inputType :: Input -> Text
inputType = Text
"datetime-local" } = String -> Input -> String
isTime' String
l Input
self
-- This validation is less strict than many sites expect, but don't over-validate...
inputErrorMessage String
lang self :: Input
self@Input { inputType :: Input -> Text
inputType = Text
"email" }
    | Char
'@' Char -> Text -> Bool
`Txt.elem` Input -> Text
value Input
self = String -> String -> String
i18n String
lang String
"err email"
inputErrorMessage String
lang self :: Input
self@Input { inputType :: Input -> Text
inputType = Text
"month" } = String -> Input -> String
isTime' String
lang Input
self
inputErrorMessage String
lang Input { inputType :: Input -> Text
inputType = Text
"number", value :: Input -> Text
value = Text
val }
    | Maybe Float -> Bool
forall a. Maybe a -> Bool
isNothing (Text -> Maybe Float
forall a. Read a => Text -> Maybe a
readMaybe' Text
val :: Maybe Float) = String -> String -> String
i18n String
lang String
"err number"
inputErrorMessage String
lang Input { inputType :: Input -> Text
inputType = Text
"range", value :: Input -> Text
value = Text
val }
    | Maybe Float -> Bool
forall a. Maybe a -> Bool
isNothing (Text -> Maybe Float
forall a. Read a => Text -> Maybe a
readMaybe' Text
val :: Maybe Float) = String -> String -> String
i18n String
lang String
"err number"
inputErrorMessage String
lang self :: Input
self@Input { inputType :: Input -> Text
inputType = Text
"time" } = String -> Input -> String
isTime' String
lang Input
self
inputErrorMessage String
lang self :: Input
self@Input { inputType :: Input -> Text
inputType = Text
"url" }
    | Text -> Bool
isURL (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Input -> Text
value Input
self = String -> String -> String
i18n String
lang String
"err URL"
inputErrorMessage String
lang self :: Input
self@Input { inputType :: Input -> Text
inputType = Text
"week" } = String -> Input -> String
isTime' String
lang Input
self
inputErrorMessage String
_ Input
_ = String
""

-- | Describe why an input, once normalized, is invalid? Or returns empty string.
inputErrorMessage' :: String -> Input -> [Char]
inputErrorMessage' :: String -> Input -> String
inputErrorMessage' String
lang = String -> Input -> String
inputErrorMessage String
lang (Input -> String) -> (Input -> Input) -> Input -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> Input
normalizeInput

-- | Helper to parse the time stored in an input.
parseTime :: String -> Maybe DateTime
parseTime :: String -> Maybe DateTime
parseTime = (LocalTime DateTime -> DateTime)
-> Maybe (LocalTime DateTime) -> Maybe DateTime
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocalTime DateTime -> DateTime
forall t. LocalTime t -> t
localTimeUnwrap (Maybe (LocalTime DateTime) -> Maybe DateTime)
-> (String -> Maybe (LocalTime DateTime))
-> String
-> Maybe DateTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ISO8601_DateAndTime -> String -> Maybe (LocalTime DateTime)
forall format.
TimeFormat format =>
format -> String -> Maybe (LocalTime DateTime)
localTimeParse ISO8601_DateAndTime
ISO8601_DateAndTime
-- | Does the input store a time?
isTime :: Input -> Bool
isTime :: Input -> Bool
isTime = Maybe DateTime -> Bool
forall a. Maybe a -> Bool
isJust (Maybe DateTime -> Bool)
-> (Input -> Maybe DateTime) -> Input -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe DateTime
parseTime (String -> Maybe DateTime)
-> (Input -> String) -> Input -> Maybe DateTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Txt.unpack (Text -> String) -> (Input -> Text) -> Input -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> Text
value
-- | Emit an error message if an input doesn't store a valid time.
isTime' :: String -> Input -> String
isTime' :: String -> Input -> String
isTime' String
lang Input
x | Input -> Bool
isTime Input
x = String
""
    | Bool
otherwise = String -> String -> String
i18n String
lang String
"err time"
-- | Parse a Text into any type that can be parsed from strings.
readMaybe' :: Read a => Txt.Text -> Maybe a
readMaybe' :: forall a. Read a => Text -> Maybe a
readMaybe' = String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe a) -> (Text -> String) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Txt.unpack
-- | Does the input store a valid URL?
isURL :: Txt.Text -> Bool
isURL :: Text -> Bool
isURL = Maybe URI -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe URI -> Bool) -> (Text -> Maybe URI) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe URI
parseAbsoluteURI (String -> Maybe URI) -> (Text -> String) -> Text -> Maybe URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Txt.unpack

-- | Implicitly tweak the input to make it more likely to be valid.
normalizeInput :: Input -> Input
normalizeInput :: Input -> Input
normalizeInput self :: Input
self@Input { inputType :: Input -> Text
inputType = Text
"url", value :: Input -> Text
value = Text
val }
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char
':' Char -> Text -> Bool
`Txt.elem` Text
val = Input
self { -- Is there a better check?
            value = "https://" `Txt.append` val
        }
-- Other aspects we wish to normalize?
normalizeInput Input
self = Input
self

-- | Implicitly tweak all of a form's inputs to make them more likely to be valid.
normalizeForm :: Form -> Form
normalizeForm :: Form -> Form
normalizeForm Form
self = Form
self { inputs = map normalizeInput $ inputs self }