{-# 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 = 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 "en"

-- | Is the given input once normalized valid?
isInputValid' :: Input -> Bool
isInputValid' = null . inputErrorMessage' "en"

-- | Describe why a form input is invalid, or return the empty string.
inputErrorMessage :: String -> Input -> String
inputErrorMessage _ Input { inputType = "hidden" } = "" -- Don't validate hiddens!
inputErrorMessage lang self@Input { required = True }
    | inputType self == "checkbox", not $ checked self = i18n lang "err required"
    -- Not validating "radio", needs different API...
    | value self == "" = i18n lang "err required"
inputErrorMessage _ Input { value = "" } = "" -- Skip further checks for empty!
inputErrorMessage lang self@Input { pattern = Just re }
    | not $ re `matchTest` value self = i18n lang "err format"
inputErrorMessage lang Input { lengthRange = (Just min', _), value = val }
    | Txt.length val < min' = i18n' lang "err min chars" min'
inputErrorMessage lang Input { lengthRange = (_, Just max'), value = val }
    | Txt.length val > max' = i18n' lang "err max chars" max'
inputErrorMessage lang Input { range = (Just min', _), value = val }
    | Just x <- readMaybe' val :: Maybe Float, Just y <- readMaybe' min', x < y =
        i18n' lang "err min" min'
inputErrorMessage lang Input { range = (_, Just max'), value = val }
    | Just x <- readMaybe' val :: Maybe Float, Just y <- readMaybe' max', x > y =
        i18n' lang "err max" max'
inputErrorMessage lang 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 =
            i18n2 lang "err increments" step' min'
inputErrorMessage lang Input { range = (Just min', _), value = val }
    | Just x <- parseTime $ Txt.unpack val, Just y <- parseTime $ Txt.unpack min',
        x < y = i18n' lang "err min" min'
inputErrorMessage lang Input { range = (_, Just max'), value = val }
    | Just x <- parseTime $ Txt.unpack val, Just y <- parseTime $ Txt.unpack max',
        x > y = i18n' lang "err max" max'
inputErrorMessage lang 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 =
            i18n2 lang "err increments" step' 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 =
            i18n2 lang "err increments" step' min'

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

-- | Describe why an input, once normalized, is invalid? Or returns empty string.
inputErrorMessage' :: String -> Input -> [Char]
inputErrorMessage' lang = inputErrorMessage lang . 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' :: String -> Input -> String
isTime' lang x | isTime x = ""
    | otherwise = i18n lang "err time"
-- | 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 }