{-# LANGUAGE OverloadedStrings #-}
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)
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
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
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
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'
inputErrorMessage :: Input -> String
inputErrorMessage :: Input -> [Char]
inputErrorMessage Input { inputType :: Input -> Text
inputType = Text
"hidden" } = [Char]
""
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!"
| 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]
""
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]
""
| 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]
"!")
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
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]
""
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
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
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
isTime' :: Input -> String
isTime' :: Input -> [Char]
isTime' Input
x | Input -> Bool
isTime Input
x = [Char]
""
| Bool
otherwise = [Char]
"Invalid time format!"
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
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
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 {
value :: Text
value = Text
"https://" Text -> Text -> Text
`Txt.append` Text
val
}
normalizeInput Input
self = Input
self
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 }