{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
-- | Parse webforms out of webpages
module Text.HTML.Form (Form(..), Input(..), OptionGroup(..), Option(..),
    FileSelector(..), defaultFileData, ImageData(..), defaultImageData,
    TextArea(..), defaultTextArea, parseElement, parseElement',
    parseDocument, parseDocument', ensureButtons) where

import Data.Text (Text)
import qualified Data.Text as Txt
import Text.XML.Cursor
import Text.XML (Document, Name(..), Node(..))

import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.List (singleton)
import Text.Read (readMaybe)
import Data.Function (on)

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],
    -- | Which human language the form is written? To which additional messages should be localized?
    lang :: String
}

-- | 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),
    -- | 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 = parseElement' "en"
parseElement' :: Text -> Cursor -> Maybe Form
parseElement' language el | _:_ <- laxElement "form" el = Just Form {
        action = attr'' "action" el (fromMaybe nullURI . parseURIReference) ".",
        enctype = attr "enctype" el "",
        method = attr "method" el "GET",
        validate = null $ hasAttribute "novalidate" el,
        target = attr "target" el "_self",
        acceptCharset = attr' "accept-charset" el Txt.words "utf-8",
        autocomplete = hasAttr "autocomplete" el,
        formName = attr "name" el "",
        rel = attr "rel" el "",
        inputs = mapMaybe parseInput $ queryInputs el,
        lang = Txt.unpack $ fromMaybe language $ listToMaybe $
                mapMaybe (mAttr "lang") $ orSelf ancestor el
      }
    | 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
    allInputs = root >=> descendant >=> laxElements [
        "input", "textarea", "button", "select"]
    inForm = check (\x ->
        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
                -- Additional fallbacks are primarily for buttons
                (attr "name" el $ attr "value" el $ attr "alt" el $
                attr "type" el "text") $ 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",
        autofocus = hasAttr "autofocus" el,
        checked = hasAttr "checked" el,
        -- NOTE: No remaining harm in displaying hidden inputs,
        -- might be informative...
        disabled = hasAttr "disabled" el || attr "type" el "" == "hidden",
        readonly = hasAttr "readonly" el || attr "type" el "" == "hidden",
        multiple = hasAttr "multiple" el,
        dirname = attr "dirname" el "",
        inputName = attr "name" el "",
        formAction = if hasAttr "formaction" el
            then attr' "formaction" el (parseURIReference . Txt.unpack) ""
            else Nothing,
        formEnctype = mAttr "formenctype" el,
        formMethod = mAttr "formmethod" el,
        formValidate = not $ hasAttr "formnovalidate" el,
        formTarget = mAttr "formtarget" el,
        inputMode = attr "inputmode" el "text",
        list = fromMaybe [] $ fmap parseOptions (elByID =<< mAttr "list" el),
        range = (mAttr "min" el, mAttr "max" el),
        step = mAttr "step" el,
        lengthRange = (attr'' "minlength" el readMaybe "",
            attr'' "maxLength" el readMaybe ""),
        pattern = attr' "pattern" el
            (rightToMaybe . compile defaultCompOpt defaultExecOpt) ".*",
        required = hasAttr "required" el,
        placeholder = attr "placeholder" el "",
        title = attr "title" el "",
        size = attr'' "size" el readMaybe "",
        fileData = FileSelector {
            fileAccept = attr' "accept" el Txt.words "*",
            fileCapture = attr "capture" el ""
        },
        imageData = ImageData {
            imgAlt = mAttr "alt" el,
            imgSize = (attr'' "width" el readMaybe "",
                attr'' "height" el readMaybe ""),
            imgSrc = attr'' "src" el (parseURIReference) ""
        },
        textArea = defaultTextArea
      }
    | _:_ <- laxElement "textarea" el = Just Input {
        inputType = "<textarea>",
        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,
        size = attr'' "cols" el readMaybe "",
        dirname = attr "dirname" el "",
        disabled = hasAttr "disabled" el,
        lengthRange = (attr'' "minLength" el readMaybe "",
            attr'' "maxLength" el readMaybe ""),
        inputName = attr "name" el "",
        placeholder = attr "placeholder" el "",
        readonly = hasAttr "readonly" el,
        required = hasAttr "required" el,
        title = attr "title" el "",
        inputMode = attr "inputMode" el "text",
        textArea = TextArea {
            autocorrect = attr "autocorrect" el "on" /= "off",
            rows = attr'' "rows" el readMaybe "",
            spellcheck = attr' "spellcheck" el (\x -> case x of
                "true" -> Just True
                "false" -> Just False
                "default" -> Nothing
                _ -> Nothing) "default",
            textwrap = attr' "wrap" el (\x -> case x of
                "hard" -> Just True
                "soft" -> Just False
                "off" -> Nothing
                _ -> Just False) "soft"
        },

        checked = False,
        multiple = True,
        formAction = Nothing,
        formEnctype = Nothing,
        formMethod = Nothing,
        formValidate = False,
        formTarget = Nothing,
        list = [],
        range = (Nothing, Nothing),
        step = Nothing,
        pattern = Nothing,
        fileData = defaultFileData,
        imageData = defaultImageData
    }
    | _:_ <- 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 (text el) $ fmap text label',
        description = fromMaybe (node el) $ fmap node $
            elByID $ attr "aria-describedby" el "",

        autofocus = hasAttr "autofocus" el,
        disabled = hasAttr "disabled" el,
        formAction = if hasAttr "formaction" el
            then attr' "formaction" el (parseURIReference . Txt.unpack) ""
            else Nothing,
        formEnctype = mAttr "formenctype" el,
        formMethod = mAttr "formmethod" el,
        formValidate = not $ hasAttr "formnovalidate" el,
        formTarget = mAttr "formtarget" el,
        inputName = attr "name" el "",
        -- Popover buttons should be handled by HTML engine, not form engine.
        inputType = attr "type" el "submit",
        value = attr "value" el "",
        title = attr "title" el "",
        -- Placeholder makes sense as a place to put the label...
        placeholder = Txt.concat $ (descendant >=> content) el,

        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
    }
    | _:_ <- laxElement "select" el = Just Input {
        inputType = "<select>",
        label = fromMaybe (attr "name" el "") $ fmap Txt.concat $
            fmap filterSelect label',
        description = fromMaybe (mkEl $ attr "title" el "") $ fmap node $
            elByID $ attr "aria-describedby" el "",

        inputAutocomplete = attr "autocomplete" el "on",
        autofocus = hasAttr "autofocus" el,
        disabled = hasAttr "disabled" el,
        multiple = hasAttr "multiple" el,
        inputName = attr "name" el "",
        required = hasAttr "required" el,
        size = attr'' "size" el readMaybe "",
        list = parseOptions el,
        title = attr "title" el "",

        dirname = "",
        value = "", -- Sourced from list...
        checked = False,
        readonly = False,
        formAction = Nothing,
        formEnctype = Nothing,
        formMethod = Nothing,
        formValidate = False,
        formTarget = Nothing,
        inputMode = "",
        range = (Nothing, Nothing),
        step = Nothing,
        lengthRange = (Nothing, Nothing),
        pattern = Nothing,
        placeholder = "",
        fileData = defaultFileData,
        imageData = defaultImageData,
        textArea = defaultTextArea
      }
    | otherwise = Nothing
  where
    elByAttr k v = listToMaybe $ (root >=> descendant >=> attributeIs k v) el
    elByID = elByAttr "id"
    label' = elByAttr "for" (attr "id" el "") `orElse`
            listToMaybe $ (ancestor >=> laxElement "label") el
    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"] >=>
        checkNot (parent >=> laxElement "optgroup")) el]
  where
    parseGroup opt
        | _:_ <- laxElement "option" opt =
            OptGroup "" False [parseOption opt False]
        | _:_ <- laxElement "optgroup" opt = OptGroup {
            optsLabel = attr "label" opt "",
            optsDisabled = hasAttr "disabled" opt,
            subopts = [parseOption o $ hasAttr "disabled" opt | o <- child opt]
          }
        | otherwise = OptGroup "" True [] -- Shouldn't happen!
    parseOption opt disabledOverride = Option {
        optLabel = attr "label" opt $ text opt,
        optValue = attr "value" opt $ text opt,
        optSelected = hasAttr "selected" opt,
        optDisabled = hasAttr "disabled" opt || disabledOverride
      }

-- | Parse a named or numerically-indexed form from an HTML document.
parseDocument :: Document -> Text -> Maybe Form
parseDocument = parseDocument' "en"
parseDocument' :: Text -> Document -> Text -> Maybe Form
parseDocument' language doc n
    | Just n' <- readMaybe $ Txt.unpack n, n' < length (forms doc') =
        parseElement' language (forms doc' !! n')
    | el:_ <- (forms >=> attributeIs "name" n) doc' = parseElement' language el
    | otherwise = Nothing
  where
    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
    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
      }