{-# 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
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 = [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Char] -> Bool) -> (Input -> [Char]) -> Input -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> [Char]
inputErrorMessage

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

-- | Describe why a form input is invalid, or return the empty string.
inputErrorMessage :: Input -> String
inputErrorMessage :: Input -> [Char]
inputErrorMessage Input { inputType :: Input -> Text
inputType = Text
"hidden" } = [Char]
"" -- Don't validate hiddens!
inputErrorMessage 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 = [Char]
"Required!"
    -- Not validating "radio", needs different API...
    | Input -> Text
value Input
self Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" = [Char]
"Required!"
inputErrorMessage Input { value :: Input -> Text
value = Text
"" } = [Char]
"" -- Skip further checks for empty!
inputErrorMessage 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 = [Char]
"Invalid format!"
inputErrorMessage 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' = [Char]
"Must be at least " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
min' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" characters!"
inputErrorMessage 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' = [Char]
"Must be at most " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
max' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" characters!"
inputErrorMessage 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 =
        [Char]
"Must be at least " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Txt.unpack Text
min' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!"
inputErrorMessage 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 =
        [Char]
"Must be at most " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Txt.unpack Text
max' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!"
inputErrorMessage 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 =
            ([Char]
"Must be in increments of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Txt.unpack Text
step' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" from "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Txt.unpack Text
min' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!")
inputErrorMessage Input { range :: Input -> (Maybe Text, Maybe Text)
range = (Just Text
min', Maybe Text
_), value :: Input -> Text
value = Text
val }
    | Just DateTime
x <- [Char] -> Maybe DateTime
parseTime ([Char] -> Maybe DateTime) -> [Char] -> Maybe DateTime
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Txt.unpack Text
val, Just DateTime
y <- [Char] -> Maybe DateTime
parseTime ([Char] -> Maybe DateTime) -> [Char] -> Maybe DateTime
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Txt.unpack Text
min',
        DateTime
x DateTime -> DateTime -> Bool
forall a. Ord a => a -> a -> Bool
< DateTime
y = [Char]
"Must be at least " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Txt.unpack Text
min' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!"
inputErrorMessage Input { range :: Input -> (Maybe Text, Maybe Text)
range = (Maybe Text
_, Just Text
max'), value :: Input -> Text
value = Text
val }
    | Just DateTime
x <- [Char] -> Maybe DateTime
parseTime ([Char] -> Maybe DateTime) -> [Char] -> Maybe DateTime
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Txt.unpack Text
val, Just DateTime
y <- [Char] -> Maybe DateTime
parseTime ([Char] -> Maybe DateTime) -> [Char] -> Maybe DateTime
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Txt.unpack Text
max',
        DateTime
x DateTime -> DateTime -> Bool
forall a. Ord a => a -> a -> Bool
> DateTime
y = [Char]
"Must be at most " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Txt.unpack Text
max' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!"
inputErrorMessage 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 <- [Char] -> Maybe DateTime
parseTime ([Char] -> Maybe DateTime) -> [Char] -> Maybe DateTime
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Txt.unpack Text
val,
        Just DateTime
y <- [Char] -> Maybe DateTime
parseTime ([Char] -> Maybe DateTime) -> [Char] -> Maybe DateTime
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
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 :: Seconds
durationSeconds = Seconds
24Seconds -> Seconds -> Seconds
forall a. Num a => a -> a -> a
*Seconds
z } Seconds -> Seconds -> Bool
forall a. Eq a => a -> a -> Bool
== Int64 -> Seconds
Seconds Int64
0 =
            ([Char]
"Must be in increments of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Txt.unpack Text
step' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" days from " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
            Text -> [Char]
Txt.unpack Text
min' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!")
    | Text
ty Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"month" = [Char]
"" -- Not prepared to properly validate this...
    | Just DateTime
x <- [Char] -> Maybe DateTime
parseTime ([Char] -> Maybe DateTime) -> [Char] -> Maybe DateTime
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Txt.unpack Text
val, Just DateTime
y <- [Char] -> Maybe DateTime
parseTime ([Char] -> Maybe DateTime) -> [Char] -> Maybe DateTime
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
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 =
            ([Char]
"Must be in increments of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
Txt.unpack Text
step' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"s from " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
            Text -> [Char]
Txt.unpack Text
min' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"!")

-- Validation specific to input types
inputErrorMessage self :: Input
self@Input { inputType :: Input -> Text
inputType = Text
"color" }
    | ([Char]
"#[0-9a-fA-F]{6}" :: String) [Char] -> Text -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ Input -> Text
value Input
self = [Char]
"Invalid colour value!"
inputErrorMessage self :: Input
self@Input { inputType :: Input -> Text
inputType = Text
"date" } = Input -> [Char]
isTime' Input
self
inputErrorMessage self :: Input
self@Input { inputType :: Input -> Text
inputType = Text
"datetime" } = Input -> [Char]
isTime' Input
self
inputErrorMessage self :: Input
self@Input { inputType :: Input -> Text
inputType = Text
"datetime-local" } = Input -> [Char]
isTime' Input
self
-- This validation is less strict than many sites expect, but don't over-validate...
inputErrorMessage self :: Input
self@Input { inputType :: Input -> Text
inputType = Text
"email" }
    | Char
'@' Char -> Text -> Bool
`Txt.elem` Input -> Text
value Input
self =
        [Char]
"Obviously invalid email address, needs an '@'!"
inputErrorMessage self :: Input
self@Input { inputType :: Input -> Text
inputType = Text
"month" } = Input -> [Char]
isTime' Input
self
inputErrorMessage 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) = [Char]
"Invalid number!"
inputErrorMessage 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) = [Char]
"Invalid number!"
inputErrorMessage self :: Input
self@Input { inputType :: Input -> Text
inputType = Text
"time" } = Input -> [Char]
isTime' Input
self
inputErrorMessage 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 = [Char]
"Invalid web address!"
inputErrorMessage self :: Input
self@Input { inputType :: Input -> Text
inputType = Text
"week" } = Input -> [Char]
isTime' Input
self
inputErrorMessage Input
_ = [Char]
""

-- | Describe why an input, once normalized, is invalid? Or returns empty string.
inputErrorMessage' :: Input -> [Char]
inputErrorMessage' :: Input -> [Char]
inputErrorMessage' = Input -> [Char]
inputErrorMessage (Input -> [Char]) -> (Input -> Input) -> Input -> [Char]
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 :: [Char] -> 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)
-> ([Char] -> Maybe (LocalTime DateTime))
-> [Char]
-> Maybe DateTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ISO8601_DateAndTime -> [Char] -> Maybe (LocalTime DateTime)
forall format.
TimeFormat format =>
format -> [Char] -> 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
. [Char] -> Maybe DateTime
parseTime ([Char] -> Maybe DateTime)
-> (Input -> [Char]) -> Input -> Maybe DateTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
Txt.unpack (Text -> [Char]) -> (Input -> Text) -> Input -> [Char]
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' :: Input -> String
isTime' :: Input -> [Char]
isTime' Input
x | Input -> Bool
isTime Input
x = [Char]
""
    | Bool
otherwise = [Char]
"Invalid time format!"
-- | 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' = [Char] -> Maybe a
forall a. Read a => [Char] -> Maybe a
readMaybe ([Char] -> Maybe a) -> (Text -> [Char]) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
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
. [Char] -> Maybe URI
parseAbsoluteURI ([Char] -> Maybe URI) -> (Text -> [Char]) -> Text -> Maybe URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
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 :: Text
value = Text
"https://" Text -> Text -> Text
`Txt.append` Text
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 :: [Input]
inputs = (Input -> Input) -> [Input] -> [Input]
forall a b. (a -> b) -> [a] -> [b]
map Input -> Input
normalizeInput ([Input] -> [Input]) -> [Input] -> [Input]
forall a b. (a -> b) -> a -> b
$ Form -> [Input]
inputs Form
self }