From b72e3a0dc9a0989e095e813cc1bc50ab79b9ba02 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Thu, 7 Dec 2023 17:01:48 +1300
Subject: [PATCH] Add validation APIs.

---
 src/Text/HTML/Form/Validate.hs | 103 +++++++++++++++++++++++++++++++++
 1 file changed, 103 insertions(+)
 create mode 100644 src/Text/HTML/Form/Validate.hs

diff --git a/src/Text/HTML/Form/Validate.hs b/src/Text/HTML/Form/Validate.hs
new file mode 100644
index 0000000..09b028c
--- /dev/null
+++ b/src/Text/HTML/Form/Validate.hs
@@ -0,0 +1,103 @@
+{-# 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
-- 
2.30.2