From 696da319f63881a1482a71ef5d7c067fb471b61e Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Thu, 4 Jan 2024 15:04:33 +1300 Subject: [PATCH] Document & add missing files. --- bureaucromancy.cabal | 18 ++-- i18n/en | 0 src/Text/HTML/Form.hs | 92 ++++++++++++++++++- src/Text/HTML/Form/Colours.hs | 8 +- src/Text/HTML/Form/Query.hs | 8 ++ src/Text/HTML/Form/Validate.hs | 17 +++- src/Text/HTML/Form/WebApp.hs | 19 +++- src/Text/HTML/Form/WebApp/Ginger.hs | 20 +++- src/Text/HTML/Form/WebApp/Ginger/Hourglass.hs | 15 +++ src/Text/HTML/Form/WebApp/Ginger/TZ.hs | 4 + 10 files changed, 187 insertions(+), 14 deletions(-) create mode 100644 i18n/en diff --git a/bureaucromancy.cabal b/bureaucromancy.cabal index a5aae98..16ca592 100644 --- a/bureaucromancy.cabal +++ b/bureaucromancy.cabal @@ -20,7 +20,7 @@ name: bureaucromancy -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.0 +version: 0.1.0.1 -- A short (one-line) description of the package. synopsis: Parse webforms & render to interactive hypertext @@ -74,9 +74,12 @@ library -- other-extensions: -- 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, - filepath, directory, hourglass >= 0.2.12 && < 0.3, tz >= 0.1 && < 0.2, + build-depends: base >=4.16.4.0 && <5, ginger>0.10 && <1, + file-embed-lzma >=0.0.1 && <1, file-embed >=0.0.15 && < 0.1, mtl >2 && <3, + bytestring >=0.11 && <1, text >=2 && <3, containers >=0.6 && <1, + xml-conduit >= 1.9 && <2, network-uri >=2.6 && <3, regex-tdfa >=1.3 && <2, + filepath >=1.4 && <2, directory >=1.2 && <2, + hourglass >= 0.2.12 && < 0.3, tz >= 0.1 && < 0.2 -- Directories containing source files. hs-source-dirs: src @@ -99,8 +102,9 @@ executable bureaucromancy -- Other library packages from which modules are imported. build-depends: - base ^>=4.16.4.0, - bureaucromancy, warp, wai, http-types, text, html-conduit + base >=4.16.4.0 && <5, bureaucromancy, + warp >= 3.3.31 && < 3.4, wai >= 3.2.3 && < 3.3, http-types >= 0.12.3 && < 0.13, + text >= 2.0.1 && < 2.1, html-conduit >= 1.3.2 && < 1.4 -- Directories containing source files. hs-source-dirs: app @@ -132,5 +136,5 @@ test-suite bureaucromancy-test -- Test dependencies. build-depends: - base ^>=4.16.4.0, + base >=4.16.4.0 && <5, bureaucromancy diff --git a/i18n/en b/i18n/en new file mode 100644 index 0000000..e69de29 diff --git a/src/Text/HTML/Form.hs b/src/Text/HTML/Form.hs index 5469986..c147b69 100644 --- a/src/Text/HTML/Form.hs +++ b/src/Text/HTML/Form.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} +-- | Parse webforms out of webpages module Text.HTML.Form (Form(..), Input(..), OptionGroup(..), Option(..), FileSelector(..), defaultFileData, ImageData(..), defaultImageData, TextArea(..), defaultTextArea, parseElement, parseDocument, ensureButtons) where @@ -17,101 +18,176 @@ import Network.URI (parseURIReference, URI, nullURI) import Text.Regex.TDFA (Regex, defaultCompOpt, defaultExecOpt) import Text.Regex.TDFA.Text (compile) +-- | A collection of controls intended to be handle by a particular URL endpoint. data Form = Form { + -- | The URL which should receive valid input from this form. action :: URI, + -- | How to encode the data to be received by the URL. enctype :: Text, + -- | Which HTTP method to use. method :: Text, + -- | Whether to validate the form data before submitting it to the endpoint. validate :: Bool, + -- | Where to display the response. target :: Text, + -- | Which character sets to encode the data in. acceptCharset :: [Text], + -- | Whether to offer autocompletions for all controls. autocomplete :: Bool, + -- | The name of this form. formName :: Text, + -- | The purpose of this form, typically using an external vocabulary. rel :: Text, + -- | What data should be sent to the endpoint. inputs :: [Input] } +-- | Individual piece of data to send to a webservice. data Input = Input { -- Core attributes + -- | Human-legible yet brief description of this input. label :: Text, + -- | Human-legible longer-form description of this input. description :: Node, + -- | How this control should be presented to the user, supporting all the HTML5 input types. + -- Support for more types may be added in the future, with any unsupported types + -- fallingback to text entry. inputType :: Text, + -- | In which query parameter should we store the text direction? dirname :: Text, + -- | In which query parameter should we store this value? inputName :: Text, -- State + -- | The user-provided value or caller-provided default to upload to the server. value :: Text, + -- | Whether to autocomplete this input, if its enabled on the form. inputAutocomplete :: Text, + -- | Whether this input has initial focus. autofocus :: Bool, + -- | Whether (for certain types) to upload the data for this input. checked :: Bool, + -- | Whether to temporarily-disallow users from editting this value. disabled :: Bool, + -- | Whether to permanantly-disallow users from editting this value. readonly :: Bool, -- Input behaviour + -- | Whether to allow entering multiple values. multiple :: Bool, + -- | If this control is used to submit the form, where to upload it. formAction :: Maybe URI, + -- | If this control is used to submit the form, which text encoding to use in the upload. formEnctype :: Maybe Text, + -- | If this control is used to submit the form, which HTTP method to use. formMethod :: Maybe Text, + -- | If this control is used to submit the form, whether to enforce validation. formValidate :: Bool, + -- | If this control is used to submit the form, where to render the response. formTarget :: Maybe Text, + -- | Suggests which keyboard to use for the input. inputMode :: Text, + -- | Autocompletion values provided by caller. list :: [OptionGroup], -- Validation + -- | The minimum & maximum values for the value of this input. range :: (Maybe Text, Maybe Text), + -- | In which period from start do valid values occur? step :: Maybe Text, + -- | The minimum & maximum lengths for the value of this input. lengthRange :: (Maybe Int, Maybe Int), + -- | Optional regex to enforce on the value of this input. pattern :: Maybe Regex, + -- | Whether this control must have a value for it to be considered valid. required :: Bool, -- Presentation + -- | Sample value, often visual clarity of its role incurs inaccessibility. + -- Make sure to communicate what's implied here elsewhere. placeholder :: Text, -- sort by tabindex? + -- | Longform clarifications. title :: Text, + -- | How wide the control should be. size :: Maybe Int, + -- | Additional data for inputs of type "file". fileData :: FileSelector, + -- | Additional data for inputs of type "image". imageData :: ImageData, + -- | Additional data for inputs of type "textarea". textArea :: TextArea } +-- | A labelled-group of options, that can be collectively disabled. data OptionGroup = OptGroup { + -- | A brief human-legible description of the options on this group. optsLabel :: Text, + -- | Whether these options can be selected. optsDisabled :: Bool, + -- | The options in this group. subopts :: [Option] } +-- | A possible value for an input. data Option = Option { + -- | Human-legible text identifying this option. optLabel :: Text, + -- | Machine-legible text identifying this option. optValue :: Text, + -- | Whether the option is selected. optSelected :: Bool, + -- | Whether the option can be selected. optDisabled :: Bool } +-- | Data specific to "file" inputs. data FileSelector = FileSelector { + -- | The MIMEtypes of the files which can be validly entered into this control. fileAccept :: [Text], + -- | Whether options for capturing from a camera should be offered. fileCapture :: Text } +-- | Empty values for file data. defaultFileData :: FileSelector defaultFileData = FileSelector [] "" +-- | Data specific to "image" inputs. data ImageData = ImageData { + -- | Text describing the image, in case the reader can't view it. imgAlt :: Maybe Text, + -- | How much screenspace the image takes up. imgSize :: (Maybe Int, Maybe Int), - imgSrc :: Maybe Text + -- | The link to the image. + imgSrc :: Maybe URI } +-- | Empty values for image data. defaultImageData :: ImageData defaultImageData = ImageData Nothing (Nothing, Nothing) Nothing +-- | Data specific to textarea inputs. data TextArea = TextArea { + -- | Whether to enable autocorrect. autocorrect :: Bool, + -- | Number of rows to display. rows :: Maybe Int, + -- | Whether to enable spellcheck. spellcheck :: Maybe Bool, + -- | Whether to enable text-wrap. textwrap :: Maybe Bool } +-- | Empty values for textarea data. defaultTextArea :: TextArea defaultTextArea = TextArea True Nothing Nothing Nothing +-- | Helper for looking up attributes on a selected element, with fallback. attr :: Text -> Cursor -> Text -> Text attr n el def | [ret] <- n `laxAttribute` el = ret | otherwise = def +-- | Helper for looking up attributes on a selected element, with fallback & callback. attr' :: Text -> Cursor -> (Text -> a) -> Text -> a attr' n el cb def = cb $ attr n el def +-- | Variant of `attr'` which passes which unpacks the callback's argument to a string. attr'' :: Text -> Cursor -> (String -> a) -> Text -> a attr'' n el cb def = attr' n el (cb . Txt.unpack) def +-- | Helper for checking whether an attribute is present. hasAttr :: Name -> Cursor -> Bool hasAttr n = not . null . hasAttribute n +-- | Helper for looking up an attribute on a selected element if present. mAttr :: Text -> Cursor -> Maybe Text mAttr n = listToMaybe . laxAttribute n +-- | Parse a form from the selected HTML element. parseElement :: Cursor -> Maybe Form parseElement el | _:_ <- laxElement "form" el = Just Form { action = attr'' "action" el (fromMaybe nullURI . parseURIReference) ".", @@ -127,11 +203,14 @@ parseElement el | _:_ <- laxElement "form" el = Just Form { } | otherwise = Nothing +-- | Helper to retrieve the root node of a document. root :: Axis root = singleton . last . orSelf ancestor +-- | Case-insensitive element selection. laxElements :: [Text] -> Axis laxElements ns = checkName (\x -> or [ on (==) Txt.toCaseFold n $ nameLocalName x | n <- ns]) +-- | Retrieve all the inputs associated with a form element. queryInputs :: Cursor -> [Cursor] queryInputs form = (allInputs >=> inForm) form where @@ -141,6 +220,7 @@ queryInputs form = (allInputs >=> inForm) form laxAttribute "form" x == laxAttribute "id" form || nestedInForm x) nestedInForm x = listToMaybe ((ancestor >=> laxElement "form") x) == Just form +-- | Parse an input from the selected element. parseInput :: Cursor -> Maybe Input parseInput el | _:_ <- laxElement "input" el = Just Input { label = fromMaybe @@ -188,7 +268,7 @@ parseInput el | _:_ <- laxElement "input" el = Just Input { imgAlt = mAttr "alt" el, imgSize = (attr'' "width" el readMaybe "", attr'' "height" el readMaybe ""), - imgSrc = mAttr "src" el + imgSrc = attr'' "src" el (parseURIReference) "" }, textArea = defaultTextArea } @@ -327,6 +407,7 @@ parseInput el | _:_ <- laxElement "input" el = Just Input { filterSelect = descendant >=> checkNot (orSelf ancestor >=> laxElement "select") >=> content +-- | Parse the options beneath a selected element. parseOptions :: Cursor -> [OptionGroup] parseOptions el = [parseGroup opt | opt <- (descendant >=> laxElements ["option", "optgroup"] >=> @@ -348,6 +429,7 @@ parseOptions el = [parseGroup opt optDisabled = hasAttr "disabled" opt || disabledOverride } +-- | Parse a named or numerically-indexed form from an HTML document. parseDocument :: Document -> Text -> Maybe Form parseDocument doc n | Just n' <- readMaybe $ Txt.unpack n, n' < length (forms doc') = @@ -358,22 +440,28 @@ parseDocument doc n forms = orSelf descendant >=> laxElement "form" doc' = fromDocument doc +-- | Helper to select elements which fail a test. checkNot :: Boolean b => (Cursor -> b) -> Axis checkNot test = check (not . bool . test) +-- | Helper to maybe-get the right side of an either. rightToMaybe :: Either a b -> Maybe b rightToMaybe (Left _) = Nothing rightToMaybe (Right x) = Just x instance Eq Cursor where a == b = node a == node b +-- | Helper to return the 1st Just from its 2 arguments. orElse :: Maybe a -> Maybe a -> Maybe a orElse ret@(Just _) _ = ret orElse _ ret = ret infixr 0 `orElse` +-- | Helper to retrieve the concatenated text under a selected element. text :: Cursor -> Text text = Txt.concat . (descendant >=> content) +-- | Concise synonym for an XML text node. mkEl :: Text -> Node mkEl = NodeContent +-- | Add submit & reset buttons to a form if they were missing! ensureButtons :: Form -> Form ensureButtons = ensureButton "submit" "Submit" . ensureButton "reset" "Reset" where diff --git a/src/Text/HTML/Form/Colours.hs b/src/Text/HTML/Form/Colours.hs index 23a4090..cd53282 100644 --- a/src/Text/HTML/Form/Colours.hs +++ b/src/Text/HTML/Form/Colours.hs @@ -1,8 +1,14 @@ +-- | A decent colour-pallet for users to select between, +-- for where we can't provide free-form colour selection. module Text.HTML.Form.Colours(tailwindColours, Colour) where -- Finally a good use for Tailwind! +-- Otherwise it strikes me as little more than an illegible alternative to +-- the `style` attribute! -type Colour = String -- Stores a hexcode, with preceding "#" +-- | Stores a CSS hexcode, with preceding "#" +type Colour = String +-- | The Tailwind colour pallet: https://v1.tailwindcss.com/docs/customizing-colors#default-color-palette tailwindColours :: [(String, [(Int, Colour)])] tailwindColours = [ "Slate"~>[50~>"#f8fafc", 100~>"#f1f5f9", 200~>"#e2e8f0", 300~>"#cbd5e1", diff --git a/src/Text/HTML/Form/Query.hs b/src/Text/HTML/Form/Query.hs index faff178..f9d1649 100644 --- a/src/Text/HTML/Form/Query.hs +++ b/src/Text/HTML/Form/Query.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +-- | Convert query data between parsed form data, multi-maps, & URI query strings. module Text.HTML.Form.Query(renderQueryString, renderQueryString', renderQuery', applyQuery, applyQuery') where @@ -8,15 +9,19 @@ import Data.List (intercalate) import Data.Text (unpack) import qualified Data.Text as Txt +-- | Serialize a form to a URI query string. renderQueryString :: Form -> String renderQueryString = renderQueryString' . renderQuery' +-- | Serialize a key-value multi-map to a URI query string. renderQueryString' :: [(String, String)] -> String renderQueryString' query = intercalate "&" [ escape key ++ '=':escape val | (key, val) <- query ] +-- | Serialize a form to a key-value multi-map. renderQuery' :: Form -> [(String, String)] renderQuery' form = concatMap renderInput' $ inputs form +-- | Serialize an input to a key-value multi-map. renderInput' :: Input -> [(String, String)] renderInput' Input { inputType = inputType' } | inputType' `elem` ["submit", "reset", "button", "file"] = [] @@ -33,13 +38,16 @@ renderInput' Input { inputType = "