{-# LANGUAGE OverloadedStrings #-}
module Text.HTML.Form.Validate(
        isInputValid, isFormValid, inputErrorMessage, normalizeInput) 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 = all isInputValid . inputs

isInputValid :: Input -> Bool
isInputValid = null . inputErrorMessage

inputErrorMessage :: Input -> [Char]
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" }
    | value self =~ ("#[0-9a-fA-F]{6}" :: String) = "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 _ = ""

parseTime :: String -> Maybe DateTime
parseTime = fmap localTimeUnwrap . localTimeParse ISO8601_DateAndTime
isTime :: Input -> Bool
isTime = isJust . parseTime . Txt.unpack . value
isTime' :: Input -> String
isTime' x | isTime x = ""
    | otherwise = "Invalid time format!"
readMaybe' :: Read a => Txt.Text -> Maybe a
readMaybe' = readMaybe . Txt.unpack
isURL :: Txt.Text -> Bool
isURL = isNothing . parseAbsoluteURI . Txt.unpack

normalizeInput :: Input -> Input
normalizeInput self@Input { inputType = "url", value = val }
    | not $ isURL val, isURL ("https://" `Txt.append` val) = self {
            value = "https://" `Txt.append` val
        }
-- Other aspects we wish to normalize?
normalizeInput self = self