{-# 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 = all isInputValid . inputs -- | Are all inputs in a form valid according to their rules, once normalized? isFormValid' :: Form -> Bool isFormValid' = all isInputValid' . inputs -- | Is the given input valid? isInputValid :: Input -> Bool isInputValid = null . inputErrorMessage -- | Is the given input once normalized valid? isInputValid' :: Input -> Bool isInputValid' = null . inputErrorMessage' -- | Describe why a form input is invalid, or return the empty string. inputErrorMessage :: Input -> String inputErrorMessage Input { inputType = "hidden" } = "" -- Don't validate hiddens! inputErrorMessage self@Input { required = True } | inputType self == "checkbox", not $ checked self = "Required!" -- Not validating "radio", needs different API... | value self == "" = "Required!" inputErrorMessage Input { value = "" } = "" -- Skip further checks for empty! inputErrorMessage self@Input { pattern = Just re } | not $ re `matchTest` value self = "Invalid format!" inputErrorMessage Input { lengthRange = (Just min', _), value = val } | Txt.length val < min' = "Must be at least " ++ show min' ++ " characters!" inputErrorMessage Input { lengthRange = (_, Just max'), value = val } | Txt.length val > max' = "Must be at most " ++ show max' ++ " characters!" inputErrorMessage Input { range = (Just min', _), value = val } | Just x <- readMaybe' val :: Maybe Float, Just y <- readMaybe' min', x < y = "Must be at least " ++ Txt.unpack min' ++ "!" inputErrorMessage Input { range = (_, Just max'), value = val } | Just x <- readMaybe' val :: Maybe Float, Just y <- readMaybe' max', x > y = "Must be at most " ++ Txt.unpack max' ++ "!" inputErrorMessage Input { range = (Just min', _), step = Just step', value = val } | Just x <- readMaybe' val :: Maybe Integer, Just y <- readMaybe' min', Just z <- readMaybe' step', z /= 0, rem (x - y) z == 0 = ("Must be in increments of " ++ Txt.unpack step' ++ " from " ++ Txt.unpack min' ++ "!") inputErrorMessage Input { range = (Just min', _), value = val } | Just x <- parseTime $ Txt.unpack val, Just y <- parseTime $ Txt.unpack min', x < y = "Must be at least " ++ Txt.unpack min' ++ "!" inputErrorMessage Input { range = (_, Just max'), value = val } | Just x <- parseTime $ Txt.unpack val, Just y <- parseTime $ Txt.unpack max', x > y = "Must be at most " ++ Txt.unpack max' ++ "!" inputErrorMessage Input { range = (Just min', _), step = Just step', inputType = ty, value = val } | ty == "date", Just x <- parseTime $ Txt.unpack val, Just y <- parseTime $ Txt.unpack min', Just z <- readMaybe' step', timeDiff x y `rem` toSeconds mempty { durationSeconds = 24*z } == Seconds 0 = ("Must be in increments of " ++ Txt.unpack step' ++ " days from " ++ Txt.unpack min' ++ "!") | ty == "month" = "" -- Not prepared to properly validate this... | Just x <- parseTime $ Txt.unpack val, Just y <- parseTime $ Txt.unpack min', Just z <- readMaybe' step', timeDiff x y `rem` Seconds z == Seconds 0 = ("Must be in increments of " ++ Txt.unpack step' ++ "s from " ++ Txt.unpack min' ++ "!") -- Validation specific to input types inputErrorMessage self@Input { inputType = "color" } | ("#[0-9a-fA-F]{6}" :: String) =~ value self = "Invalid colour value!" inputErrorMessage self@Input { inputType = "date" } = isTime' self inputErrorMessage self@Input { inputType = "datetime" } = isTime' self inputErrorMessage self@Input { inputType = "datetime-local" } = isTime' self -- This validation is less strict than many sites expect, but don't over-validate... inputErrorMessage self@Input { inputType = "email" } | '@' `Txt.elem` value self = "Obviously invalid email address, needs an '@'!" inputErrorMessage self@Input { inputType = "month" } = isTime' self inputErrorMessage Input { inputType = "number", value = val } | isNothing (readMaybe' val :: Maybe Float) = "Invalid number!" inputErrorMessage Input { inputType = "range", value = val } | isNothing (readMaybe' val :: Maybe Float) = "Invalid number!" inputErrorMessage self@Input { inputType = "time" } = isTime' self inputErrorMessage self@Input { inputType = "url" } | isURL $ value self = "Invalid web address!" inputErrorMessage self@Input { inputType = "week" } = isTime' self inputErrorMessage _ = "" -- | Describe why an input, once normalized, is invalid? Or returns empty string. inputErrorMessage' :: Input -> [Char] inputErrorMessage' = inputErrorMessage . normalizeInput -- | Helper to parse the time stored in an input. parseTime :: String -> Maybe DateTime parseTime = fmap localTimeUnwrap . localTimeParse ISO8601_DateAndTime -- | Does the input store a time? isTime :: Input -> Bool isTime = isJust . parseTime . Txt.unpack . value -- | Emit an error message if an input doesn't store a valid time. isTime' :: Input -> String isTime' x | isTime x = "" | otherwise = "Invalid time format!" -- | Parse a Text into any type that can be parsed from strings. readMaybe' :: Read a => Txt.Text -> Maybe a readMaybe' = readMaybe . Txt.unpack -- | Does the input store a valid URL? isURL :: Txt.Text -> Bool isURL = isNothing . parseAbsoluteURI . Txt.unpack -- | Implicitly tweak the input to make it more likely to be valid. normalizeInput :: Input -> Input normalizeInput self@Input { inputType = "url", value = val } | not $ ':' `Txt.elem` val = self { -- Is there a better check? value = "https://" `Txt.append` val } -- Other aspects we wish to normalize? normalizeInput self = self -- | Implicitly tweak all of a form's inputs to make them more likely to be valid. normalizeForm :: Form -> Form normalizeForm self = self { inputs = map normalizeInput $ inputs self }