{-# 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 }