From b48eccb144e10f6f81f361afaf06507037730eb3 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Thu, 7 Dec 2023 17:57:07 +1300 Subject: [PATCH] Integrate & fix error messages; TODO: Block invalid submits --- form.html | 4 ++-- src/Text/HTML/Form/Query.hs | 9 ++++++++- src/Text/HTML/Form/Validate.hs | 4 ++-- src/Text/HTML/Form/WebApp.hs | 2 +- src/Text/HTML/Form/WebApp/Ginger.hs | 5 +++++ tpl/base.html | 3 +++ 6 files changed, 21 insertions(+), 6 deletions(-) diff --git a/form.html b/form.html index 25e8cdf..68cf1f4 100644 --- a/form.html +++ b/form.html @@ -6,7 +6,7 @@
- + @@ -18,7 +18,7 @@ - +
diff --git a/src/Text/HTML/Form/Query.hs b/src/Text/HTML/Form/Query.hs index 2a235f2..24c2a85 100644 --- a/src/Text/HTML/Form/Query.hs +++ b/src/Text/HTML/Form/Query.hs @@ -1,11 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} module Text.HTML.Form.Query( - renderQueryString, renderQueryString', renderQuery') where + renderQueryString, renderQueryString', renderQuery', applyQuery) where import Text.HTML.Form (Form(..), Input(..), OptionGroup(..), Option(..)) import Network.URI (escapeURIString, isUnescapedInURIComponent) import Data.List (intercalate) import Data.Text (unpack) +import qualified Data.Text as Txt renderQueryString :: Form -> String renderQueryString = renderQueryString' . renderQuery' @@ -34,3 +35,9 @@ renderInput' Input { inputName = k, value = v } = [(unpack k, unpack v)] escape :: String -> String escape = escapeURIString isUnescapedInURIComponent + +applyQuery :: Input -> [(String, String)] -> Input +applyQuery input@Input { inputName = n } qs + | inputType input `notElem` ["submit", "reset", "button", "checkbox", "radio"], + Just val' <- unpack n `lookup` qs = input { value = Txt.pack val' } + | otherwise = input diff --git a/src/Text/HTML/Form/Validate.hs b/src/Text/HTML/Form/Validate.hs index 448fd48..a641296 100644 --- a/src/Text/HTML/Form/Validate.hs +++ b/src/Text/HTML/Form/Validate.hs @@ -69,7 +69,7 @@ inputErrorMessage Input { -- Validation specific to input types inputErrorMessage self@Input { inputType = "color" } - | value self =~ ("#[0-9a-fA-F]{6}" :: String) = "Invalid colour value!" + | ("#[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 @@ -105,7 +105,7 @@ isURL = isNothing . parseAbsoluteURI . Txt.unpack normalizeInput :: Input -> Input normalizeInput self@Input { inputType = "url", value = val } - | not $ isURL val, isURL ("https://" `Txt.append` val) = self { + | not $ ':' `Txt.elem` val = self { -- Is there a better check? value = "https://" `Txt.append` val } -- Other aspects we wish to normalize? diff --git a/src/Text/HTML/Form/WebApp.hs b/src/Text/HTML/Form/WebApp.hs index 41f2413..1c22079 100644 --- a/src/Text/HTML/Form/WebApp.hs +++ b/src/Text/HTML/Form/WebApp.hs @@ -172,7 +172,7 @@ renderInput form ix input@Input { inputType = "color" } [] qs = "shades" -> toGVal False "subfolder" -> toGVal False _ -> toGVal () -renderInput form ix input@Input { inputType = "color", inputName = n } [c, ""] qs = +renderInput form ix input@Input { inputType = "color" } [c, ""] qs = template' "color.html" form ix input qs $ \x -> case x of "colours" -> V.list $ L.map colourGVal tailwindColours "shades" -> case Txt.unpack c `lookup` tailwindColours of diff --git a/src/Text/HTML/Form/WebApp/Ginger.hs b/src/Text/HTML/Form/WebApp/Ginger.hs index db8f873..e574a3f 100644 --- a/src/Text/HTML/Form/WebApp/Ginger.hs +++ b/src/Text/HTML/Form/WebApp/Ginger.hs @@ -26,6 +26,9 @@ import Data.List (nub) import Data.Maybe (fromMaybe, isJust) import qualified Data.Map as M +import Text.HTML.Form.Validate (inputErrorMessage') +import Text.HTML.Form.Query (applyQuery) + type Query = [(ByteString, Maybe ByteString)] template :: Monad m => String -> Form -> Int -> Input -> Query -> m (Maybe (Either Query Text)) @@ -90,6 +93,8 @@ input2gval :: (Int, Input) -> Query -> GVal m input2gval (ix, input) query = orderedDict [ "index" ~> ix, "label" ~> label input, + "error" ~> inputErrorMessage' (applyQuery input + [(B8.unpack k, B8.unpack $ fromMaybe "" v) | (k, v) <- query]), "description" ~> html (description input), "inputType" ~> inputType input, "dirName" ~> dirname input, diff --git a/tpl/base.html b/tpl/base.html index ecc1b01..02cd4d3 100644 --- a/tpl/base.html +++ b/tpl/base.html @@ -26,6 +26,8 @@ table td:not([colspan]) { width: 25% } table td { text-align: center } + + .error { color: red; } @@ -39,6 +41,7 @@ {% if input.disabled %}{{ input.label }} {% else %}{{ input.label }} {% endif %} + {% if input.error %}
⚠️ {{ input.error }}
{% endif %} {% if input.type != 'password' %}
-- 2.30.2