From 1030d237866bf99999711515fa46dd9fdf729324 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Thu, 11 Jan 2024 14:07:06 +1300 Subject: [PATCH] Internationalize form validation. --- src/Text/HTML/Form/Validate.hs | 105 ++++++++++++++-------------- src/Text/HTML/Form/WebApp/Ginger.hs | 11 +-- 2 files changed, 57 insertions(+), 59 deletions(-) diff --git a/src/Text/HTML/Form/Validate.hs b/src/Text/HTML/Form/Validate.hs index beb7b51..19414e4 100644 --- a/src/Text/HTML/Form/Validate.hs +++ b/src/Text/HTML/Form/Validate.hs @@ -4,7 +4,8 @@ module Text.HTML.Form.Validate(isInputValid, isInputValid', isFormValid, isFormValid', inputErrorMessage, inputErrorMessage', normalizeInput, normalizeForm) where -import Text.HTML.Form +import Text.HTML.Form hiding (lang) +import Text.HTML.Form.I18n import qualified Data.Text as Txt import Text.Read (readMaybe) import Data.Hourglass @@ -22,82 +23,78 @@ isFormValid' = all isInputValid' . inputs -- | Is the given input valid? isInputValid :: Input -> Bool -isInputValid = null . inputErrorMessage +isInputValid = null . inputErrorMessage "en" -- | Is the given input once normalized valid? isInputValid' :: Input -> Bool -isInputValid' = null . inputErrorMessage' +isInputValid' = null . inputErrorMessage' "en" -- | 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!" +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 == "" = "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 } + | 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 = - "Must be at least " ++ Txt.unpack min' ++ "!" -inputErrorMessage Input { range = (_, Just max'), value = val } + 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 = - "Must be at most " ++ Txt.unpack max' ++ "!" -inputErrorMessage Input { range = (Just min', _), step = Just step', value = val } + 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 = - ("Must be in increments of " ++ Txt.unpack step' ++ " from " - ++ Txt.unpack min' ++ "!") -inputErrorMessage Input { range = (Just min', _), value = val } + 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 = "Must be at least " ++ Txt.unpack min' ++ "!" -inputErrorMessage Input { range = (_, Just max'), value = val } + 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 = "Must be at most " ++ Txt.unpack max' ++ "!" -inputErrorMessage Input { + 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 = - ("Must be in increments of " ++ Txt.unpack step' ++ " days from " ++ - Txt.unpack min' ++ "!") + 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 = - ("Must be in increments of " ++ Txt.unpack step' ++ "s from " ++ - Txt.unpack min' ++ "!") + i18n2 lang "err increments" step' 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 +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 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 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' :: Input -> [Char] -inputErrorMessage' = inputErrorMessage . normalizeInput +inputErrorMessage' :: String -> Input -> [Char] +inputErrorMessage' lang = inputErrorMessage lang . normalizeInput -- | Helper to parse the time stored in an input. parseTime :: String -> Maybe DateTime @@ -106,9 +103,9 @@ parseTime = fmap localTimeUnwrap . localTimeParse ISO8601_DateAndTime 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!" +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 diff --git a/src/Text/HTML/Form/WebApp/Ginger.hs b/src/Text/HTML/Form/WebApp/Ginger.hs index 539cfd4..2934cc5 100644 --- a/src/Text/HTML/Form/WebApp/Ginger.hs +++ b/src/Text/HTML/Form/WebApp/Ginger.hs @@ -52,14 +52,15 @@ template' name form ix input query ctxt' ctxt :: Text -> GVal (Run SourcePos (Writer Html) Html) ctxt "Q" = query2gval query ctxt "form" = form2gval form - ctxt "inputs" = list' $ Prelude.map (flip input2gval query) $ + ctxt "inputs" = list' $ Prelude.map (\x -> input2gval language x query) $ Prelude.zip [0..] $ inputs form - ctxt "input" = input2gval (ix, input) query + ctxt "input" = input2gval language (ix, input) query ctxt "xURI" = fromFunction xURI ctxt x = ctxt' x xURI [(_, uri)] = let uri' = Txt.unpack $ asText uri in return$toGVal$Txt.pack $ escapeURIString isUnescapedInURIComponent uri' xURI _ = return $ toGVal () + language = lang form -- | Lookup the given template from a compiled-in directory. resolveSource :: FilePath -> Maybe (Maybe [Char]) @@ -97,11 +98,11 @@ form2gval form = orderedDict [ ] -- | Convert an input to Ginger's datamodel. -input2gval :: (Int, Input) -> Query -> GVal m -input2gval (ix, input) query = orderedDict [ +input2gval :: String -> (Int, Input) -> Query -> GVal m +input2gval language (ix, input) query = orderedDict [ "index" ~> ix, "label" ~> label input, - "error" ~> inputErrorMessage' (applyQuery input + "error" ~> inputErrorMessage' language (applyQuery input [(B8.unpack k, B8.unpack $ fromMaybe "" v) | (k, v) <- query]), "description" ~> html (description input), "inputType" ~> inputType input, -- 2.30.2