From c4c655a0b5376c0c70010bf8aee54b5940e186df Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Thu, 26 Aug 2021 20:11:37 +1200 Subject: [PATCH] Implement forms in WebDriver API. --- amphiarao.cabal | 2 +- src/Internal.hs | 4 ++- src/Internal/Forms.hs | 60 ++++++++++++++++++++++++++++++++++++++++--- src/Internal/Load.hs | 19 ++++++++++++-- src/Webdriver.hs | 28 +++++++++++++++++++- 5 files changed, 104 insertions(+), 9 deletions(-) diff --git a/amphiarao.cabal b/amphiarao.cabal index e469242..47464d1 100644 --- a/amphiarao.cabal +++ b/amphiarao.cabal @@ -71,7 +71,7 @@ executable amphiarao -- For HTML UIs blaze-html, blaze-markup, -- Network input - hurl >= 2.1 && <3, network-uri, + hurl >= 2.1.1 && <3, network-uri, http-client, -- Parse & query XML/HTML xml-conduit >= 1.8 && < 1.9, html-conduit >= 1.3 && <1.4, css-syntax, array >=0.4, attoparsec, time diff --git a/src/Internal.hs b/src/Internal.hs index 360a35e..721bbd6 100644 --- a/src/Internal.hs +++ b/src/Internal.hs @@ -20,6 +20,7 @@ import qualified Network.URI.Fetch as URI import qualified Text.XML as XML import qualified Text.XML.Cursor as XML import qualified Data.Map as M' +import qualified Network.HTTP.Client.MultipartFormData as HTTP type Sessions = MVar (M.HashMap UUID Session) type Session = MVar Session' @@ -33,6 +34,7 @@ data Session' = Session { document :: XML.Document, knownEls :: M.HashMap UUID XML.Cursor, forms :: M'.Map XML.Element (M.HashMap Text [Text]), + multipartForms :: M'.Map XML.Element [HTTP.Part], id2els :: M.HashMap Text XML.Cursor } @@ -61,7 +63,7 @@ createSession sessions caps = do XML.documentEpilogue = [] }, knownEls = M.empty, - forms = M'.empty, + forms = M'.empty, multipartForms = M'.empty, id2els = M.empty } session' <- newMVar session diff --git a/src/Internal/Forms.hs b/src/Internal/Forms.hs index f9cef7c..8159660 100644 --- a/src/Internal/Forms.hs +++ b/src/Internal/Forms.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} -module Internal.Forms(findForm, prefillForm, modifyForm, formAction) where +{-# LANGUAGE OverloadedStrings, DeriveGeneric #-} +module Internal.Forms(findForm, prefillForm, modifyForm, formAction, clearForm, sendText, typable) where import Text.XML import Text.XML.Cursor @@ -7,12 +7,17 @@ import qualified Data.Map as M 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 qualified Network.HTTP.Client.MultipartFormData as HTTP -import Data.Maybe +import Internal (Session, Session'(..)) +import Data.Aeson +import GHC.Generics import Control.Concurrent.MVar +import Data.Maybe +import Data.List + findForm :: Cursor -> HM.HashMap Txt.Text Cursor -> Element findForm cursor id2els | NodeElement el@(Element (Name "form" _ _) _ _) <- node cursor = el @@ -98,4 +103,51 @@ formAction el session = withMVar session $ \session' -> do (_, Just method) -> method; (_, _) -> "GET" } + return (fromMaybe nullURI action `relativeTo` currentURL session', query, method) + +clearForm session el = modifyMVar_ session $ \session' -> do + let form = findForm el $ id2els session' + return $ case form of + Element (Name "form" _ _) _ _ -> + session' { forms = M.delete form $ forms session' } + _ -> session' + +data SendText = SendText { text :: Txt.Text } deriving Generic +instance FromJSON SendText +instance ToJSON SendText + +sendText input cursor session + | NodeElement el <- node cursor = sendText' input el cursor session + | otherwise = return () +sendText' input (Element (Name "input" _ _) attrs _) cursor session +-- | Just "file" <- "type" `M.lookup` attrs' = return ()-- TODO define a place in HURL to store files to be uploaded... + | Just "radio" <- "type" `M.lookup` attrs', Just value <- "value" `M.lookup` attrs', + Just name <- "name" `M.lookup` attrs' = modifyForm (const [value]) name cursor session + | Just "checkbox" <- "type" `M.lookup` attrs', Just value <- "value" `M.lookup` attrs', + Just name <- "name" `M.lookup` attrs' = modifyForm (toggleOption value) name cursor session + | Just name <- "name" `M.lookup` attrs' = modifyForm (const [text input]) name cursor session + | otherwise = return () + where + attrs' = M.mapKeys nameLocalName attrs + toggleOption value old | value `elem` old = delete value old + | otherwise = value:old +sendText' input (Element (Name "select" _ _) attrs childs) cursor session + | Just name <- "name" `M.lookup` attrs', "multiple" `M.member` attrs' = + let value = mapMaybe findOption $ Txt.lines $ text input + in modifyForm (const value) name cursor session + | Just name <- "name" `M.lookup` attrs', Just value <- findOption $ text input = + modifyForm (const [value]) name cursor session + | otherwise = return () + where + attrs' = M.mapKeys nameLocalName attrs + findOption prefix = (M.lookup "value" . M.mapKeys nameLocalName . elementAttributes) =<< + find (Txt.isPrefixOf prefix . innerText) [ + el | NodeElement el@(Element (Name "option" _ _) _ _) <- childs] + innerText (Element _ _ childs) = Txt.concat [txt | NodeContent txt <- childs] +sendText' input (Element (Name "textarea" _ _) attrs _) cursor session + | Just name <- "name" `M.lookup` attrs' = modifyForm (const [text input]) name cursor session + | otherwise = return () + where attrs' = M.mapKeys nameLocalName attrs + +typable (Element (Name n _ _) _ _) = n `elem` ["input", "select", "textarea"] diff --git a/src/Internal/Load.hs b/src/Internal/Load.hs index 99c125f..e221322 100644 --- a/src/Internal/Load.hs +++ b/src/Internal/Load.hs @@ -38,6 +38,13 @@ load' session uri = modifyMVar_ session $ \session' -> maybeTimeout session' uri return $ session' { currentURL = redirected, document = doc, knownEls = HM.empty, id2els = HM.fromList $ indexedIDs doc } +submit' :: Internal.Session -> (URI, Txt.Text, Txt.Text) -> IO () +submit' session (uri, query, method) = modifyMVar_ session $ \session' -> maybeTimeout session' uri $ do + resp@(redirected, _, _) <- submitURL (loader session') mime uri method $ Txt.unpack query + let doc = parseDocument resp + return $ session' { currentURL = redirected, document = doc, + knownEls = HM.empty, id2els = HM.fromList $ indexedIDs doc } + maybeTimeout :: Session' -> URI -> IO Session' -> IO Session' maybeTimeout session uri act | currentURL session /= uri, Just delay <- pageLoad $ timeouts session = -- WebDriver deals in terms of milliseconds, I think?, Haskell deals in terms of microseconds. @@ -54,6 +61,14 @@ load session uri = do inner session'@Session {backStack = backStack', currentURL = currentURL' } = session' { backStack = currentURL' : backStack' } +submit :: Internal.Session -> (URI, Txt.Text, Txt.Text) -> IO () +submit session form = do + modifyMVar_ session $ return . inner + submit' session form + where + inner session'@Session {backStack = backStack', currentURL = currentURL' } = + session' { backStack = currentURL' : backStack' } + back :: Internal.Session -> IO () back session = do uri <- modifyMVar session $ return . inner @@ -179,8 +194,8 @@ clickEl' session (XML.Element (XML.Name name _ _) attrs _) cursor 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 } + form <- formAction cursor session + submit session form | name `elem` ["button", "input"], Just "reset" <- "type" `M.lookup` attrs' = modifyMVar_ session $ \session' -> do let form = findForm cursor $ id2els session' diff --git a/src/Webdriver.hs b/src/Webdriver.hs index cce2828..573bcd8 100644 --- a/src/Webdriver.hs +++ b/src/Webdriver.hs @@ -29,6 +29,7 @@ import JSON import qualified Internal as WD import qualified Internal.Load as WD import qualified Internal.Elements as WDE +import qualified Internal.Forms as WDF serveWebdriver :: WD.Sessions -> ServerPart Response serveWebdriver sessions = do @@ -219,7 +220,10 @@ serveElement session elUUID = do -- TODO integrate CSS dir "text" $ getElText el, dir "name" $ getElName el, - dir "rect" $ unsupportedOp -- Will be meaningful for Haphaestus! + dir "rect" $ unsupportedOp, -- Will be meaningful for Haphaestus! + dir "click" $ actionClickEl session el, + dir "reset" $ actionResetEl session el, + dir "value" $ actionTypeEl session el ] Nothing | Nothing <- ID.fromString elUUID -> errJSON 404 "no such element" "Invalid UUID" @@ -276,3 +280,25 @@ getElName el = do name2text (X.Name name _ (Just prefix)) = Txt.concat [prefix, ":", name] name2text (X.Name name _ Nothing) = name + +actionClickEl session el = do + method POST + nullDir + liftIO $ WD.clickEl session el + ok $ toResponse () + +actionResetEl session el = do + method POST + nullDir + liftIO $ WDF.clearForm session el + ok $ toResponse () + +actionTypeEl session el = do + method POST + nullDir + req <- getJSON + case req of + Just req' -> do + liftIO $ WDF.sendText req' el session + ok $ toResponse () + Nothing -> errJSON 400 "invalid argument" "Failed to parse JSON" -- 2.30.2