From d6349351d838372d9199a690c5997382d13269c7 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Fri, 8 Dec 2023 17:22:24 +1300
Subject: [PATCH] Validate form before submitting, ensure submit & reset
 buttons are present!

---
 app/Main.hs                  |  3 ++-
 src/Text/HTML/Form.hs        | 41 +++++++++++++++++++++++++++++++++++-
 src/Text/HTML/Form/Query.hs  |  6 ++++--
 src/Text/HTML/Form/WebApp.hs | 12 +++++++++--
 tpl/submit.html              |  4 ++++
 5 files changed, 60 insertions(+), 6 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index f753263..7ea76d0 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -25,7 +25,8 @@ main = do
         [n] -> (n, "0")
         [] -> ("form.html", "0")
   doc <- HTML.readFile filename
-  runEnv 2018 $ servePage $ fromJust $ parseDocument doc $ Txt.pack ident
+  let form = ensureButtons $ fromJust $ parseDocument doc $ Txt.pack ident
+  runEnv 2018 $ servePage form
 
 servePage :: Form -> Application
 servePage form req respond = do
diff --git a/src/Text/HTML/Form.hs b/src/Text/HTML/Form.hs
index 3cb16c5..5469986 100644
--- a/src/Text/HTML/Form.hs
+++ b/src/Text/HTML/Form.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
 module Text.HTML.Form (Form(..), Input(..), OptionGroup(..), Option(..),
     FileSelector(..), defaultFileData, ImageData(..), defaultImageData,
-    TextArea(..), defaultTextArea, parseElement, parseDocument) where
+    TextArea(..), defaultTextArea, parseElement, parseDocument, ensureButtons) where
 
 import Data.Text (Text)
 import qualified Data.Text as Txt
@@ -373,3 +373,42 @@ text :: Cursor -> Text
 text = Txt.concat . (descendant >=> content)
 mkEl :: Text -> Node
 mkEl = NodeContent
+
+ensureButtons :: Form -> Form
+ensureButtons = ensureButton "submit" "Submit" . ensureButton "reset" "Reset"
+  where
+    ensureButton typ label' form
+        | any (\x -> inputType x == typ) $ inputs form = form
+        | otherwise = form { inputs = inputs form ++ [button typ label'] }
+    button typ label' = Input {
+        label = label',
+        description = mkEl "",
+        autofocus = False,
+        disabled = False,
+        formAction = Nothing,
+        formMethod = Nothing,
+        formEnctype = Nothing,
+        formValidate = True,
+        formTarget = Nothing,
+        inputName = "",
+        inputType = typ,
+        value = "",
+        title = "",
+        placeholder = "",
+        dirname = "",
+        inputAutocomplete = "",
+        checked = False, -- Switch to true for the activated button!
+        readonly = False,
+        multiple = False,
+        inputMode = "",
+        list = [],
+        range = (Nothing, Nothing),
+        step = Nothing,
+        lengthRange = (Nothing, Nothing),
+        pattern = Nothing,
+        required = False,
+        size = Nothing,
+        fileData = defaultFileData,
+        imageData = defaultImageData,
+        textArea = defaultTextArea
+      }
diff --git a/src/Text/HTML/Form/Query.hs b/src/Text/HTML/Form/Query.hs
index 24c2a85..faff178 100644
--- a/src/Text/HTML/Form/Query.hs
+++ b/src/Text/HTML/Form/Query.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
-module Text.HTML.Form.Query(
-    renderQueryString, renderQueryString', renderQuery', applyQuery) where
+module Text.HTML.Form.Query(renderQueryString, renderQueryString', renderQuery',
+        applyQuery, applyQuery') where
 
 import Text.HTML.Form (Form(..), Input(..), OptionGroup(..), Option(..))
 import Network.URI (escapeURIString, isUnescapedInURIComponent)
@@ -41,3 +41,5 @@ 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
+applyQuery' :: Form -> [(String, String)] -> Form
+applyQuery' form qs = form { inputs = flip applyQuery qs `map` inputs form }
diff --git a/src/Text/HTML/Form/WebApp.hs b/src/Text/HTML/Form/WebApp.hs
index 1c22079..27c26bd 100644
--- a/src/Text/HTML/Form/WebApp.hs
+++ b/src/Text/HTML/Form/WebApp.hs
@@ -2,9 +2,11 @@
 module Text.HTML.Form.WebApp (renderPage, Form(..)) where
 
 import Data.ByteString as BS
+import Data.ByteString.Char8 as B8
 import Data.Text as Txt
 import Data.Text.Encoding as Txt
 import Data.List as L
+import Data.Maybe (fromMaybe)
 import Text.Read (readMaybe)
 import Network.URI (unEscapeString)
 import System.IO (readFile')
@@ -14,7 +16,8 @@ import System.Directory (XdgDirectory(..), getXdgDirectory, doesFileExist,
 
 import Text.HTML.Form (Form(..), Input(..))
 import Text.HTML.Form.WebApp.Ginger (template, template', resolveSource, list')
-import Text.HTML.Form.Query (renderQueryString, renderQuery')
+import Text.HTML.Form.Query (renderQueryString, renderQuery', applyQuery')
+import Text.HTML.Form.Validate (isFormValid')
 import Text.HTML.Form.WebApp.Ginger.Hourglass (timeData, modifyTime', timeParseOrNow,
         gSeqTo, gPad2)
 import Text.HTML.Form.WebApp.Ginger.TZ (tzdata, continents)
@@ -107,7 +110,10 @@ renderInput form ix input@Input {inputType="radio", inputName=k', value=v'} [] q
 renderInput form ix input@Input { inputType="<select>" } [] qs =
     template "select.html" form ix input qs
 renderInput form ix input@Input { inputType="submit" } [] qs =
-    template "submit.html" form ix input qs
+    template' "submit.html" form ix input qs $ \x -> case x of
+        "isFormValid" -> toGVal $ formValidate input &&
+                isFormValid' (applyQuery' form $ strQuery qs)
+        _ -> toGVal ()
 renderInput _ _ input@Input { inputType="submit" } ["_"] qs =
     return $ Just $ Left $ set (inputName input) (value input) qs
 renderInput form ix input@Input { inputType="image" } [] qs =
@@ -231,6 +237,8 @@ get k' qs
     | Just (Just ret) <- utf8 k' `lookup` qs =
         Txt.unpack $ Txt.decodeUtf8 ret
     | otherwise = ""
+strQuery :: [(ByteString, Maybe ByteString)] -> [(String, String)]
+strQuery qs = [(B8.unpack k, B8.unpack $ fromMaybe "" v) | (k, v) <- qs]
 
 partitionM :: Monad f => (a -> f Bool) -> [a] -> f ([a], [a])
 partitionM _ [] = pure ([], [])
diff --git a/tpl/submit.html b/tpl/submit.html
index cc64171..f6c7200 100644
--- a/tpl/submit.html
+++ b/tpl/submit.html
@@ -3,8 +3,12 @@
 {%- block main -%}<section>
   <div>{{ input.description }}</div>
   <hr />
+  {% if isFormValid %}
   <!-- TODO: Internationalize! -->
   <p><a href="_{{Q}}">Upload</a> to
     <code>{{ input.form.action|default(form.action) }}
         ({{ input.form.method|default(form.method) }})</code></p>
+  {% else %}
+  <p>Please correct errors listed in sidebar before submitting this form!</p>
+  {% endif %}
 </section>{%- endblock -%}
-- 
2.30.2