From 703b307333f90115a7512efcd660615a64a75700 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 11 Sep 2023 11:06:51 +1200 Subject: [PATCH] Implement radio inputs, upload missing files, make space for descriptions & richer form controls to use. --- src/Text/HTML/Form/Query.hs | 19 ++++ src/Text/HTML/Form/WebApp.hs | 18 ++-- src/Text/HTML/Form/WebApp/Ginger.hs | 149 ++++++++++++++++++++++++++++ tpl/base.html | 42 ++++++++ tpl/checkbox.html | 1 + tpl/radio.html | 1 + 6 files changed, 222 insertions(+), 8 deletions(-) create mode 100644 src/Text/HTML/Form/Query.hs create mode 100644 src/Text/HTML/Form/WebApp/Ginger.hs create mode 100644 tpl/base.html create mode 100644 tpl/checkbox.html create mode 100644 tpl/radio.html diff --git a/src/Text/HTML/Form/Query.hs b/src/Text/HTML/Form/Query.hs new file mode 100644 index 0000000..11d1e55 --- /dev/null +++ b/src/Text/HTML/Form/Query.hs @@ -0,0 +1,19 @@ +module Text.HTML.Form.Query( + renderQueryString, renderQueryString', renderQuery') where + +import Text.HTML.Form (Form(..), Input(..)) +import Network.URI (escapeURIString, isUnescapedInURIComponent) +import Data.List (intercalate) +import Data.Text (unpack) + +renderQueryString :: Form -> String +renderQueryString = renderQueryString' . renderQuery' +renderQueryString' query = intercalate "&" [ + escape key ++ '=':escape value | (key, value) <- query + ] + +renderQuery' :: Form -> [(String, String)] +renderQuery' form = [(unpack $ inputName input, unpack $ value input) + | input <- inputs form, checked input] + +escape = escapeURIString isUnescapedInURIComponent diff --git a/src/Text/HTML/Form/WebApp.hs b/src/Text/HTML/Form/WebApp.hs index 6d7d9ee..986bca7 100644 --- a/src/Text/HTML/Form/WebApp.hs +++ b/src/Text/HTML/Form/WebApp.hs @@ -13,24 +13,26 @@ import Text.HTML.Form.Query (renderQueryString) renderPage :: Form -> [Text] -> [(ByteString, Maybe ByteString)] -> IO (Maybe Text) renderPage form (n:path) query | Just ix <- readMaybe $ Txt.unpack n, ix < Prelude.length (inputs form) = - renderInput form (inputs form !! ix) path query + renderInput form ix (inputs form !! ix) path query renderPage form [] _ = return $ Just $ Txt.concat [ "Start!"] renderPage _ _ _ = return Nothing -renderInput :: Form -> Input -> [Text] -> [(ByteString, Maybe ByteString)] -> +renderInput :: Form -> Int -> Input -> [Text] -> [(ByteString, Maybe ByteString)] -> IO (Maybe Text) -renderInput form input@Input {inputType = "checkbox", inputName = k', value = v'} - [] qs +renderInput form ix input@Input {inputType="checkbox", inputName=k', value=v'} [] qs | (utf8 k', Just $ utf8 v') `Prelude.elem` qs = - template "checkbox.html" form input qs [ + template "checkbox.html" form ix input [ 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 [ + template "checkbox.html" form ix input [ 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 + template "checkbox.html" form ix input $ (utf8 k', Just $ utf8 v'):qs +renderInput form ix input@Input {inputType="radio", inputName=k', value=v'} [] qs = + template "checkbox.html" form ix input $ + (utf8 k', Just $ utf8 v'):[q | q@(k, _) <- qs, k /= utf8 k'] +renderInput _ _ _ _ _ = return Nothing utf8 :: Text -> ByteString utf8 = Txt.encodeUtf8 diff --git a/src/Text/HTML/Form/WebApp/Ginger.hs b/src/Text/HTML/Form/WebApp/Ginger.hs new file mode 100644 index 0000000..418be96 --- /dev/null +++ b/src/Text/HTML/Form/WebApp/Ginger.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE TemplateHaskell, OverloadedStrings, FlexibleContexts #-} +module Text.HTML.Form.WebApp.Ginger(template) where + +import Text.HTML.Form +import Text.HTML.Form.Query (renderQueryString') + +import FileEmbedLzma +import Data.FileEmbed +import System.FilePath + +import Text.Ginger.Parse (parseGingerFile, SourcePos) +import Text.Ginger.Run (runGinger, makeContextHtml, Run) +import Text.Ginger.GVal as V (GVal(..), toGVal, ToGVal, orderedDict, (~>)) +import Text.Ginger.Html (Html, htmlSource, unsafeRawHtml) +import Control.Monad.Writer.Lazy (Writer) + +import Data.Text as Txt +import Data.Text.Encoding as Txt +import Data.Text.Lazy as Txt (toStrict) +import Data.ByteString.Char8 as B8 +import Network.URI (uriToString) +import Text.XML (Document(..), Element(..), Prologue(..), Node, def, renderText) + +import Data.List (nub) +import Data.Maybe (fromMaybe, isJust) +import qualified Data.Map as M + +type Query = [(ByteString, Maybe ByteString)] +template :: Monad m => String -> Form -> Int -> Input -> Query -> m (Maybe Text) +template name form ix input query + | Just (Right tpl) <- parseGingerFile resolveSource name = + return $ Just $ htmlSource $ flip runGinger tpl $ makeContextHtml ctxt + | Just (Left err) <- parseGingerFile resolveSource name = + return $ Just $ Txt.pack $ show err + | otherwise = return $ Just "Unexpected error!" + where + ctxt :: Text -> GVal (Run SourcePos (Writer Html) Html) + ctxt "Q" = query2gval query + ctxt "form" = form2gval form + ctxt "inputs" = list' $ Prelude.map (flip input2gval query) $ + Prelude.zip [0..] $ inputs form + ctxt "input" = input2gval (ix, input) query + ctxt _ = toGVal () + +resolveSource :: FilePath -> Maybe (Maybe [Char]) +resolveSource = Just . fmap B8.unpack . + flip lookup $(makeRelativeToProject "tpl" >>= embedRecursiveDir) . + ('/':) . normalise + +query2gval :: Query -> GVal m +query2gval qs = + (orderedDict [(Txt.decodeUtf8 k, list1 vs) | (k, vs) <- groupSort qs]) { + asText = Txt.pack q, + asHtml = unsafeRawHtml $ Txt.pack q + } + where + q = '?':renderQueryString' [(utf8 k, utf8 $ fromMaybe "" v) | (k, v) <- qs] + utf8 = Txt.unpack . Txt.decodeUtf8 + +form2gval :: Form -> GVal m +form2gval form = orderedDict [ + "action" ~> uriToString id (action form) "", + "enctype" ~> enctype form, + "method" ~> method form, + "validate" ~> validate form, + "target" ~> target form, + "charset" ~> acceptCharset form, + "autocomplete"~>autocomplete form, + "name" ~> formName form, + "rel" ~> rel form + ] + +input2gval :: (Int, Input) -> Query -> GVal m +input2gval (ix, input) query = orderedDict [ + "index" ~> ix, + "label" ~> label input, + "description" ~> html (description input), + "inputType" ~> inputType input, + "dirName" ~> dirname input, + "name" ~> inputName input, + "value" ~> value input, + "autocomplete"~> inputAutocomplete input, + "autofocus" ~> autofocus input, + "checked" ~> if value input == "" + then isJust $ Prelude.lookup (Txt.encodeUtf8 $ inputName input) query + else (Txt.encodeUtf8 $ inputName input, + Just $ Txt.encodeUtf8 $ value input) `Prelude.elem` query, + "disabled" ~> disabled input, + "readonly" ~> readonly input, + "multiple" ~> multiple input, + ("form", orderedDict [ + "action" ~> (flip (uriToString id) "" <$> formAction input), + "enctype" ~> formEnctype input, + "method" ~> formMethod input, + "validate"~> formValidate input, + "target" ~> formTarget input + ]), + "inputmode" ~> inputMode input, + ("list", list' $ Prelude.map optgroup2gval $ list input), + "min" ~> fst (range input), + "max" ~> snd (range input), + "step" ~> step input, + "minlength" ~> fst (lengthRange input), + "maxLength" ~> snd (lengthRange input), + "required" ~> required input, + "placeholder" ~> placeholder input, + "title" ~> title input, + "size" ~> size input, + "accept" ~> fileAccept (fileData input), + "capture" ~> fileCapture (fileData input), + "alt" ~> imgAlt (imageData input), + "width" ~> fst (imgSize $ imageData input), + "height" ~> snd (imgSize $ imageData input), + "src" ~> imgSrc (imageData input), + "autocorrect" ~> autocorrect (textArea input), + "cols" ~> size input, + "rows" ~> rows (textArea input), + "spellcheck" ~> spellcheck (textArea input), + "textwrap" ~> textwrap (textArea input) + ] +html :: Node -> Html +html node = unsafeRawHtml $ Txt.toStrict $ renderText def ( + Document (Prologue [] Nothing []) (Element "div" M.empty [node]) [] + ) +optgroup2gval :: OptionGroup -> GVal m +optgroup2gval optgroup = orderedDict [ + "label" ~> optsLabel optgroup, + "disabled" ~> optsDisabled optgroup, + ("opts", list' $ Prelude.map opt2gval $ subopts optgroup) + ] +opt2gval :: Option -> GVal m +opt2gval opt = orderedDict [ + "label" ~> optLabel opt, + "value" ~> optValue opt, + "selected" ~> optSelected opt, + "disabled" ~> optDisabled opt + ] + +list1 :: ToGVal m a => [a] -> GVal m +list1 vs@(v:_) = (toGVal v) { + asList = Just $ Prelude.map toGVal vs, + V.length = Just $ Prelude.length vs + } +list1 [] = (toGVal True) { asList = Just [], V.length = Just 0 } +list' :: [GVal m] -> GVal m +list' = toGVal + +groupSort :: Eq k => [(k, Maybe v)] -> [(k, [v])] +groupSort q = [(k, [v | (k', Just v) <- q, k == k']) | k <- nub $ Prelude.map fst q] diff --git a/tpl/base.html b/tpl/base.html new file mode 100644 index 0000000..0140e23 --- /dev/null +++ b/tpl/base.html @@ -0,0 +1,42 @@ + + + + {{form.method}} {{form.action}} + + + +

{{form.method}} {{form.action}}

+
+ {% set selected=input.index %} + + + {% block main %} +
+ {{ input.description }} +
+ {% endblock %} +
+ + diff --git a/tpl/checkbox.html b/tpl/checkbox.html new file mode 100644 index 0000000..94d9808 --- /dev/null +++ b/tpl/checkbox.html @@ -0,0 +1 @@ +{% extends "base.html" %} diff --git a/tpl/radio.html b/tpl/radio.html new file mode 100644 index 0000000..94d9808 --- /dev/null +++ b/tpl/radio.html @@ -0,0 +1 @@ +{% extends "base.html" %} -- 2.30.2