From 67fedfd03f409cc041e50754fae747972dc6d573 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Tue, 20 Jul 2021 17:06:55 +1200
Subject: [PATCH] Implement (GET) form submission.

---
 src/Internal/Forms.hs | 35 ++++++++++++++++++++++++++++++++++-
 src/Internal/Load.hs  |  7 ++++++-
 2 files changed, 40 insertions(+), 2 deletions(-)

diff --git a/src/Internal/Forms.hs b/src/Internal/Forms.hs
index cd3c1ec..f9cef7c 100644
--- a/src/Internal/Forms.hs
+++ b/src/Internal/Forms.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
-module Internal.Forms(findForm, prefillForm, modifyForm) where
+module Internal.Forms(findForm, prefillForm, modifyForm, formAction) where
 
 import Text.XML
 import Text.XML.Cursor
@@ -8,6 +8,7 @@ import qualified Data.HashMap.Strict as HM
 import qualified Data.Text as Txt
 
 import Internal (Session, Session'(..))
+import Network.URI (URI(..), parseURIReference, relativeTo, nullURI)
 
 import Data.Maybe
 import Control.Concurrent.MVar
@@ -66,3 +67,35 @@ modifyForm cb name el session = modifyMVar_ session $ \session' -> do
         Element (Name "form" _ _) _ _ ->
             session' { forms = M.insert form new $ forms session' }
         _ -> session'
+
+serializeForm :: HM.HashMap Txt.Text [Txt.Text] -> Txt.Text
+serializeForm = Txt.intercalate "&" . map joinEntry . expandValues . HM.toList
+    where
+        expandValues ((a, (b:bs)):rest) = (a, b):expandValues ((a, bs):rest)
+        expandValues ((a, []):rest) = expandValues rest
+        expandValues [] = []
+        joinEntry (key, value) = key `Txt.append` Txt.cons '=' value
+
+formAction :: Cursor -> Session -> IO (URI, Txt.Text, Txt.Text)
+formAction el session = withMVar session $ \session' -> do
+    let form = findForm el $ id2els session'
+    let blanked = prefillForm form $ fromDocument $ document session'
+    let inputs = M.findWithDefault blanked form $ forms session'
+    let query = serializeForm inputs
+
+    let fAttrs' = M.mapKeys nameLocalName $ elementAttributes form
+    let iAttrs' = case node el of {
+        NodeElement (Element _ attrs _) -> M.mapKeys nameLocalName attrs;
+        _ -> M.empty
+    }
+    let action = case ("formaction" `M.lookup` iAttrs', "action" `M.lookup` fAttrs') of {
+        (Just action, _) -> parseURIReference $ Txt.unpack action;
+        (_, Just action) -> parseURIReference $ Txt.unpack action;
+        (_, _) -> Nothing
+    }
+    let method = case ("formmethod" `M.lookup` iAttrs', "action" `M.lookup` fAttrs') of {
+        (Just method, _) -> method;
+        (_, Just method) -> method;
+        (_, _) -> "GET"
+    }
+    return (fromMaybe nullURI action `relativeTo` currentURL session', query, method)
diff --git a/src/Internal/Load.hs b/src/Internal/Load.hs
index 7e07db8..a290680 100644
--- a/src/Internal/Load.hs
+++ b/src/Internal/Load.hs
@@ -175,7 +175,12 @@ clickEl' session (XML.Element (XML.Name name _ _) attrs _) cursor
         base <- withMVar session (return . Internal.currentURL)
         load session $ URI.relativeTo uri base
     -- FORMS
-    -- TODO type=submit
+    | name `elem` ["button", "input"], Just "submit" <- "type" `M.lookup` attrs' = do
+        case ("name" `M.lookup` attrs', "value" `M.lookup` attrs') of
+            (Just name, Just value) -> modifyForm ((:) value) name cursor session
+            _ -> return ()
+        (uri, query, method) <- formAction cursor session
+        load session uri { uriQuery = '?':Txt.unpack query }
     | name `elem` ["button", "input"], Just "reset" <- "type" `M.lookup` attrs' =
       modifyMVar_ session $ \session' -> do
         let form = findForm cursor $ id2els session'
-- 
2.30.2