From a3d5ae5407b47e008d51490223faa19649bfd90f Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Fri, 8 Sep 2023 15:19:37 +1200
Subject: [PATCH] Add support for checkboxes, along with supporting
 infrastructure.

---
 app/Main.hs                  |  4 +--
 bureaucromancy.cabal         |  7 +++--
 src/Text/HTML/Form.hs        | 53 ++++++++++++++++++------------------
 src/Text/HTML/Form/WebApp.hs | 30 +++++++++++++-------
 tpl/.keep                    |  0
 5 files changed, 52 insertions(+), 42 deletions(-)
 delete mode 100644 tpl/.keep

diff --git a/app/Main.hs b/app/Main.hs
index 4c76ac8..77a980c 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -12,7 +12,7 @@ import Text.HTML.Form
 import Data.Text.Lazy.Encoding (encodeUtf8)
 import Data.Text.Lazy (fromStrict)
 import qualified Data.Text as Txt
-import Text.XML (readFile, def)
+import qualified Text.HTML.DOM as HTML
 import Data.Maybe (fromJust)
 
 main :: IO ()
@@ -22,7 +22,7 @@ main = do
         n:anchor:_ -> (n, anchor)
         [n] -> (n, "0")
         [] -> ("form.html", "0")
-  doc <- Text.XML.readFile def filename
+  doc <- HTML.readFile filename
   runEnv 2018 $ servePage $ fromJust $ parseDocument doc $ Txt.pack ident
 
 servePage :: Form -> Application
diff --git a/bureaucromancy.cabal b/bureaucromancy.cabal
index c7ab7ee..82121a4 100644
--- a/bureaucromancy.cabal
+++ b/bureaucromancy.cabal
@@ -62,7 +62,7 @@ library
     import:           warnings
 
     -- Modules exported by the library.
-    exposed-modules:  Text.HTML.Form,
+    exposed-modules:  Text.HTML.Form, Text.HTML.Form.Query,
         Text.HTML.Form.WebApp, Text.HTML.Form.WebApp.Ginger
 
     -- Modules included in this library but not exported.
@@ -73,7 +73,8 @@ library
 
     -- Other library packages from which modules are imported.
     build-depends:    base ^>=4.16.4.0, ginger, file-embed-lzma, file-embed, mtl,
-            bytestring, text, xml-conduit, network-uri, regex-tdfa, containers
+            bytestring, text, xml-conduit, network-uri, regex-tdfa, containers,
+            filepath
 
     -- Directories containing source files.
     hs-source-dirs:   src
@@ -97,7 +98,7 @@ executable bureaucromancy
     -- Other library packages from which modules are imported.
     build-depends:
         base ^>=4.16.4.0,
-        bureaucromancy, warp, wai, http-types, text, xml-conduit
+        bureaucromancy, warp, wai, http-types, text, html-conduit
 
     -- Directories containing source files.
     hs-source-dirs:   app
diff --git a/src/Text/HTML/Form.hs b/src/Text/HTML/Form.hs
index 4db6dc1..4eb0bd2 100644
--- a/src/Text/HTML/Form.hs
+++ b/src/Text/HTML/Form.hs
@@ -9,7 +9,6 @@ import Text.XML.Cursor
 import Text.XML (Document, Name(..), Node(..))
 
 import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
-import Data.Char (isDigit)
 import Data.List (singleton)
 import Text.Read (readMaybe)
 import Data.Function (on)
@@ -33,7 +32,7 @@ data Form = Form {
 
 data Input = Input {
     -- Core attributes
-    label :: Node,
+    label :: Text,
     description :: Node,
     inputType :: Text,
     dirname :: Text,
@@ -144,11 +143,9 @@ queryInputs form = (allInputs >=> inForm) form
     nestedInForm x = listToMaybe ((ancestor >=> laxElement "form") x) == Just form
 parseInput :: Cursor -> Maybe Input
 parseInput el | _:_ <- laxElement "input" el = Just Input {
-        label = fromMaybe (mkEl $ attr "name" el "") $ fmap node $
-            listToMaybe ((ancestor >=> laxElement "label") el) *>
-            elByAttr "for" (attr "id" el ""),
-        description = fromMaybe (mkEl "") $ fmap node $
-            elByID $ attr "aria-describedby" el "",
+        label = fromMaybe (attr "name" el "") $ fmap text label',
+        description = fromMaybe (mkEl $ attr "title" el "") $ fmap node $
+            elByID (attr "aria-describedby" el "") `orElse` label',
         inputType = attr "type" el "text",
         value = attr "value" el "",
         inputAutocomplete = attr "autocomplete" el "on",
@@ -192,12 +189,10 @@ parseInput el | _:_ <- laxElement "input" el = Just Input {
       }
     | _:_ <- laxElement "textarea" el = Just Input {
         inputType = "<textarea>",
-        label = fromMaybe (mkEl $ attr "name" el "") $ fmap node $
-            listToMaybe ((ancestor >=> laxElement "label") el) *>
-            elByAttr "for" (attr "id" el ""),
-        description = fromMaybe (mkEl "") $ fmap node $
-            elByID $ attr "aria-describedby" el "",
-        value = Txt.concat $ (descendant >=> content) el,
+        label = fromMaybe (attr "name" el "") $ fmap text label',
+        description = fromMaybe (mkEl $ attr "title" el "") $ fmap node $
+            elByID (attr "aria-describedby" el "") `orElse` label',
+        value = text el,
 
         inputAutocomplete = attr "autocomplete" el "on",
         autofocus = hasAttr "autofocus" el,
@@ -244,9 +239,7 @@ parseInput el | _:_ <- laxElement "input" el = Just Input {
     | _:_ <- laxElement "button" el = Just Input {
         -- Fallingback to the input itself as its label allow for
         -- the full richness of its children to be rendered!
-        label = fromMaybe (node el) $ fmap node $
-            listToMaybe ((ancestor >=> laxElement "label") el) *>
-            elByAttr "for" (attr "id" el ""),
+        label = fromMaybe (text el) $ fmap text label',
         description = fromMaybe (node el) $ fmap node $
             elByID $ attr "aria-describedby" el "",
 
@@ -286,10 +279,8 @@ parseInput el | _:_ <- laxElement "input" el = Just Input {
     }
     | _:_ <- laxElement "select" el = Just Input {
         inputType = "<select>",
-        label = fromMaybe (mkEl $ attr "name" el "") $ fmap node $
-            listToMaybe ((ancestor >=> laxElement "label") el) *>
-            elByAttr "for" (attr "id" el ""),
-        description = fromMaybe (mkEl "") $ fmap node $
+        label = fromMaybe (attr "name" el "") $ fmap text label',
+        description = fromMaybe (mkEl $ attr "title" el "") $ fmap node $
             elByID $ attr "aria-describedby" el "",
 
         inputAutocomplete = attr "autocomplete" el "on",
@@ -325,7 +316,8 @@ parseInput el | _:_ <- laxElement "input" el = Just Input {
   where
     elByAttr k v = listToMaybe $ (root >=> descendant >=> attributeIs k v) el
     elByID = elByAttr "id"
-    mkEl txt = NodeContent txt
+    label' = elByAttr "for" (attr "id" el "") `orElse`
+            listToMaybe $ (ancestor >=> laxElement "label") el
 parseOptions :: Cursor -> [OptionGroup]
 parseOptions el = [parseGroup opt
     | opt <- (descendant >=> laxElements ["option", "optgroup"] >=>
@@ -342,17 +334,16 @@ parseOptions el = [parseGroup opt
           }
         | otherwise = OptGroup "" True [] -- Shouldn't happen!
     parseOption opt disabledOverride = Option {
-        optLabel = attr "label" opt text,
-        optValue = attr "value" opt text,
+        optLabel = attr "label" opt $ text opt,
+        optValue = attr "value" opt $ text opt,
         optSelected = hasAttr "selected" opt,
         optDisabled = hasAttr "disabled" opt || disabledOverride
-      } where text = Txt.concat $ (descendant >=> content) opt
+      }
 
-read' :: Read a => Text -> a
-read' = read . Txt.unpack
 parseDocument :: Document -> Text -> Maybe Form
 parseDocument doc n
-    | Txt.all isDigit n = parseElement (forms doc' !! read' n)
+    | Just n' <- readMaybe $ Txt.unpack n, n' < length (forms doc') =
+        parseElement (forms doc' !! n')
     | el:_ <- (forms >=> attributeIs "name" n) doc' = parseElement el
     | otherwise = Nothing
   where
@@ -364,3 +355,11 @@ rightToMaybe (Left _)  = Nothing
 rightToMaybe (Right x) = Just x
 instance Eq Cursor where
     a == b = node a == node b
+orElse :: Maybe a -> Maybe a -> Maybe a
+orElse ret@(Just _) _ = ret
+orElse _ ret = ret
+infixr 0 `orElse`
+text :: Cursor -> Text
+text = Txt.concat . (descendant >=> content)
+mkEl :: Text -> Node
+mkEl = NodeContent
diff --git a/src/Text/HTML/Form/WebApp.hs b/src/Text/HTML/Form/WebApp.hs
index 9a8f186..6d7d9ee 100644
--- a/src/Text/HTML/Form/WebApp.hs
+++ b/src/Text/HTML/Form/WebApp.hs
@@ -3,24 +3,34 @@ module Text.HTML.Form.WebApp (renderPage, Form(..)) where
 
 import Data.ByteString as BS
 import Data.Text as Txt
+import Data.Text.Encoding as Txt
 import Text.Read (readMaybe)
 
 import Text.HTML.Form (Form(..), Input(..))
 import Text.HTML.Form.WebApp.Ginger (template)
+import Text.HTML.Form.Query (renderQueryString)
 
 renderPage :: Form -> [Text] -> [(ByteString, Maybe ByteString)] -> IO (Maybe Text)
-renderPage form (n:ix:path) query
-    | Just ix' <- readMaybe $ Txt.unpack ix, ix' < Prelude.length inputs' =
-        renderInput form (inputs' !! ix') path query
-    | input:_ <- inputs' = renderInput form input (ix:path) query
-  where inputs' = Prelude.filter (\x -> inputName x == n) $ inputs form
-renderPage form [n] query
-    | input:_ <- Prelude.filter (\x -> inputName x == n) $ inputs form =
-        renderInput form input [] query
+renderPage form (n:path) query
+    | Just ix <- readMaybe $ Txt.unpack n, ix < Prelude.length (inputs form) =
+        renderInput form (inputs form !! ix) path query
+renderPage form [] _ = return $ Just $ Txt.concat [
+    "<a href='/0?", Txt.pack $ renderQueryString form, "'>Start!</a>"]
 renderPage _ _ _ = return Nothing
 
 renderInput :: Form -> Input -> [Text] -> [(ByteString, Maybe ByteString)] ->
     IO (Maybe Text)
-renderInput form input@Input {inputType = "checkbox"} [] q =
-    template "checkbox" form input q
+renderInput form input@Input {inputType = "checkbox", inputName = k', value = v'}
+        [] qs
+    | (utf8 k', Just $ utf8 v') `Prelude.elem` qs =
+        template "checkbox.html" form input qs [
+            q | q@(k, v) <- qs, k /= utf8 k', v /= Just (utf8 v')]
+    | v' == "", (utf8 k', Nothing) `Prelude.elem` qs =
+        template "checkbox.html" form input qs [
+            q | q@(k, v) <- qs, k /= utf8 k', v /= Nothing]
+    | otherwise =
+        template "checkbox.html" form input qs ((utf8 k', Just $ utf8 v'):qs)
 renderInput _ _ _ _ = return Nothing
+
+utf8 :: Text -> ByteString
+utf8 = Txt.encodeUtf8
diff --git a/tpl/.keep b/tpl/.keep
deleted file mode 100644
index e69de29..0000000
-- 
2.30.2