From c2bd1a216e8d50e7795404017c350b6a6839b189 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 19 Jul 2021 19:56:00 +1200 Subject: [PATCH] Add initial form support --- src/Internal.hs | 4 ++-- src/Internal/Forms.hs | 33 ++++++++++++++++++++++++--------- src/Internal/Load.hs | 29 +++++++++++++++++++++++++---- 3 files changed, 51 insertions(+), 15 deletions(-) diff --git a/src/Internal.hs b/src/Internal.hs index 270c95c..360a35e 100644 --- a/src/Internal.hs +++ b/src/Internal.hs @@ -32,7 +32,7 @@ data Session' = Session { nextStack :: [URI.URI], document :: XML.Document, knownEls :: M.HashMap UUID XML.Cursor, - forms :: M.HashMap XML.Element (M.HashMap Text [Text]), + forms :: M'.Map XML.Element (M.HashMap Text [Text]), id2els :: M.HashMap Text XML.Cursor } @@ -61,7 +61,7 @@ createSession sessions caps = do XML.documentEpilogue = [] }, knownEls = M.empty, - forms = M.empty, + forms = M'.empty, id2els = M.empty } session' <- newMVar session diff --git a/src/Internal/Forms.hs b/src/Internal/Forms.hs index f27094e..cd3c1ec 100644 --- a/src/Internal/Forms.hs +++ b/src/Internal/Forms.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -module Internal.Forms(findForm, prefillForm) where +module Internal.Forms(findForm, prefillForm, modifyForm) where import Text.XML import Text.XML.Cursor @@ -7,19 +7,24 @@ import qualified Data.Map as M import qualified Data.HashMap.Strict as HM import qualified Data.Text as Txt +import Internal (Session, Session'(..)) + import Data.Maybe +import Control.Concurrent.MVar +findForm :: Cursor -> HM.HashMap Txt.Text Cursor -> Element findForm cursor id2els - | Just (NodeElement el@(Element (Name "form" _ _) _ _)) <- node cursor = el - | Just (NodeElement el) <- node cursor, Just el' <- findForm' el id2els = el' + | NodeElement el@(Element (Name "form" _ _) _ _) <- node cursor = el + | NodeElement el <- node cursor, Just el' <- findForm' el id2els = el' | (form:_) <- parent cursor = findForm form id2els -- Propagate id2els for the sake of event dispatch. | otherwise = Element "fail" M.empty [] -- Tombstone value +findForm' :: Element -> HM.HashMap Txt.Text Cursor -> Maybe Element findForm' (Element (Name name _ _) attrs _) id2els | name == "label", Just for <- "for" `M.lookup` attrs', - Just input <- for `M.lookup` id2els = Just $ findForm input id2els - | Just form <- "form" `M.lookup` attrs', Just cursor <- form `M.lookup` id2els, - Just (NodeElement ret) <- node cursor = Just ret + Just input <- for `HM.lookup` id2els = Just $ findForm input id2els + | Just form <- "form" `M.lookup` attrs', Just cursor <- form `HM.lookup` id2els, + NodeElement ret <- node cursor = Just ret | otherwise = Nothing where attrs' = M.mapKeys nameLocalName attrs @@ -30,12 +35,12 @@ prefillForm (Element (Name "form" _ _) attrs children) root = HM.fromListWith (+ isForForm (Element _ attrs' _) | Just id <- "id" `M.lookup` M.mapKeys nameLocalName attrs, Just form <- "form" `M.lookup` M.mapKeys nameLocalName attrs' = id == form isForForm _ = False +prefillForm _ _ = HM.empty prefillForm' (NodeElement (Element (Name "input" _ _) attrs _):nodes) | Just type_ <- "type" `M.lookup` attrs', Just name <- "name" `M.lookup` attrs', Just value <- "value" `M.lookup` attrs', type_ `notElem` ["radio", "checkbox", "reset", "submit", "button"] || "checked" `M.member` attrs' = (name, [value]):prefillForm' nodes - | otherwise = prefillForm' nodes where attrs' = M.mapKeys nameLocalName attrs prefillForm' (NodeElement (Element (Name "select" _ _) attrs childs):nodes) | Just name <- "name" `M.lookup` attrs' = @@ -44,10 +49,20 @@ prefillForm' (NodeElement (Element (Name "select" _ _) attrs childs):nodes) [] -> prefillForm' nodes values | "multiple" `M.member` attrs' -> (name, values):prefillForm' nodes (value:_) -> (name, [value]):prefillForm' nodes - | otherwise = prefillForm' nodes where attrs' = M.mapKeys nameLocalName attrs prefillForm' (NodeElement (Element (Name "textarea" _ _) attrs childs):nodes) | Just name <- "name" `M.lookup` attrs = (name, [Txt.concat [value | NodeContent value <- childs]]):prefillForm' nodes - | otherwise = prefillForm' nodes +prefillForm' (_:nodes) = prefillForm' nodes +prefillForm' [] = [] +modifyForm :: ([Txt.Text] -> [Txt.Text]) -> Txt.Text -> Cursor -> Session -> IO () +modifyForm cb name el session = modifyMVar_ session $ \session' -> do + let form = findForm el $ id2els session' + let blanked = prefillForm form $ fromDocument $ document session' + let old = M.findWithDefault blanked form $ forms session' + let new = HM.insert name (cb $ HM.lookupDefault [] name old) old + return $ case form of + Element (Name "form" _ _) _ _ -> + session' { forms = M.insert form new $ forms session' } + _ -> session' diff --git a/src/Internal/Load.hs b/src/Internal/Load.hs index 21e9ede..76e86fd 100644 --- a/src/Internal/Load.hs +++ b/src/Internal/Load.hs @@ -16,6 +16,7 @@ import GHC.Generics import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.ByteString.Lazy as B (toStrict) import qualified Data.HashMap.Strict as HM +import Data.List (delete) import Network.URI as URI import Network.URI.Fetch as URI @@ -161,19 +162,39 @@ parseGemini' [] = [] ---- clickEl :: Internal.Session -> XC.Cursor -> IO () -clickEl session el | XML.NodeElement el' <- XC.node el = clickEl' session el' +clickEl session el | XML.NodeElement el' <- XC.node el = clickEl' session el' el | otherwise = return () -clickEl' session (XML.Element _ attrs _) +clickEl' session (XML.Element (XML.Name name _ _) attrs _) cursor + -- LINKS + -- There's more nuances to links in Rhapsode, but that covered most of them. | Just href <- "href" `M.lookup` attrs', Just uri <- URI.parseURIReference $ Txt.unpack href = do base <- withMVar session (return . Internal.currentURL) load session $ URI.relativeTo uri base | Just src <- "src" `M.lookup` attrs', Just uri <- URI.parseURIReference $ Txt.unpack src = do base <- withMVar session (return . Internal.currentURL) load session $ URI.relativeTo uri base - -- There's more nuances to links in Rhapsode, but that covered most of them. + -- FORMS + -- TODO type=submit + | name `elem` ["button", "input"], Just "reset" <- "type" `M.lookup` attrs' = + modifyMVar_ session $ \session' -> do + let form = findForm cursor $ id2els session' + let blanked = prefillForm form $ XC.fromDocument $ document session' + return $ case form of + XML.Element (XML.Name "form" _ _) _ _ -> + session' { forms = M.insert form blanked $ forms session' } + _ -> session' + | name == "input", Just "radio" <- "type" `M.lookup` attrs', + Just name <- "name" `M.lookup` attrs', Just value <- "value" `M.lookup` attrs' = + modifyForm (const [value]) name cursor session + | name == "input", Just "checkbox" <- "type" `M.lookup` attrs', + Just name <- "name" `M.lookup` attrs', Just value <- "value" `M.lookup` attrs' = + modifyForm (toggleOption value) name cursor session | otherwise = return () - where attrs' = M.mapKeys XML.nameLocalName attrs + where + attrs' = M.mapKeys XML.nameLocalName attrs + toggleOption value old | value `elem` old = delete value old + | otherwise = value:old -- Keep inline with clickEl isClickableEl :: XC.Cursor -> Bool -- 2.30.2