{-# 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 = all isInputValid . inputs

isFormValid' :: Form -> Bool
isFormValid' = all isInputValid' . inputs

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

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 _ = ""

inputErrorMessage' :: Input -> [Char]
inputErrorMessage' = inputErrorMessage . normalizeInput

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

normalizeForm :: Form -> Form
normalizeForm self = self { inputs = map normalizeInput $ inputs self }