3 files changed, 51 insertions(+), 15 deletions(-)

M src/Internal.hs
M src/Internal/Forms.hs
M src/Internal/Load.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

@@ 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'

@@ 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