From e7e16d8e1a667715d0bda0332254d6d6e05f399b Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 20 Dec 2021 17:43:41 +1300 Subject: [PATCH] Implement WebDriver forms, viewsource, & noops. --- amphiarao.cabal | 8 +++--- src/Internal/Forms.hs | 22 ++++++++++++++-- src/Internal/Load.hs | 11 +++++--- src/Main.hs | 57 ++++++++++++++++++++++++++++++++---------- src/Messages.hs | 7 ++++-- src/UI/Templates.hs | 10 +++++++- src/Webdriver.hs | 58 +++++++++++++++++++++++++++++++++++++++++-- 7 files changed, 145 insertions(+), 28 deletions(-) diff --git a/amphiarao.cabal b/amphiarao.cabal index 47464d1..b59bbdf 100644 --- a/amphiarao.cabal +++ b/amphiarao.cabal @@ -64,16 +64,16 @@ executable amphiarao -- other-extensions: -- Other library packages from which modules are imported. - build-depends: base >=4.9 && <4.10, happstack-lite >=7.3.7 && <7.4, happstack-server, + build-depends: base >=4.9 && <4.10, happstack-lite >=7.3.7, happstack-server, -- For JSON/HTTP APIs - aeson >= 1.5.0 && <1.6, text, bytestring, unordered-containers, vector, - containers >=0.5 && <0.7, uuid >=1.3 && <1.4, file-embed >= 0.0.9 && < 0.1, + aeson >= 1.5.0, text, bytestring, unordered-containers, vector, + containers >=0.5, uuid >=1.3, file-embed >= 0.0.9, -- For HTML UIs blaze-html, blaze-markup, -- Network input 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, + xml-conduit >= 1.8, html-conduit >= 1.3, css-syntax, array >=0.4, attoparsec, time build-tools: happy diff --git a/src/Internal/Forms.hs b/src/Internal/Forms.hs index 8159660..00fc4d9 100644 --- a/src/Internal/Forms.hs +++ b/src/Internal/Forms.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings, DeriveGeneric #-} -module Internal.Forms(findForm, prefillForm, modifyForm, formAction, clearForm, sendText, typable) where +module Internal.Forms(findForm, prefillForm, modifyForm, formAction, clearForm, + readInput, readInput', sendText, SendText(..), isTypableEl) where import Text.XML import Text.XML.Cursor @@ -113,6 +114,21 @@ clearForm session el = modifyMVar_ session $ \session' -> do session' { forms = M.delete form $ forms session' } _ -> session' +readInput session el = withMVar session $ \session' -> do + let form = findForm el $ id2els session' + return $ case (form, node el) of + (Element (Name "form" _ _) _ _, NodeElement (Element _ attrs _)) + | Just name <- "name" `M.lookup` M.mapKeys nameLocalName attrs, + Just form <- form `M.lookup` forms session' -> + name `HM.lookup` form + _ -> Nothing + +readInput' session el = do + res <- readInput session el + return $ case res of + Just (ret:_) -> ret + _ -> "" + data SendText = SendText { text :: Txt.Text } deriving Generic instance FromJSON SendText instance ToJSON SendText @@ -150,4 +166,6 @@ sendText' input (Element (Name "textarea" _ _) attrs _) cursor session | otherwise = return () where attrs' = M.mapKeys nameLocalName attrs -typable (Element (Name n _ _) _ _) = n `elem` ["input", "select", "textarea"] +isTypableEl cursor | NodeElement el' <- node cursor = isTypableEl' el' + | otherwise = False +isTypableEl' (Element (Name n _ _) _ _) = n `elem` ["input", "select", "textarea"] diff --git a/src/Internal/Load.hs b/src/Internal/Load.hs index e221322..a306245 100644 --- a/src/Internal/Load.hs +++ b/src/Internal/Load.hs @@ -33,8 +33,11 @@ mime = words "text/html text/xml application/xml application/xhtml+xml text/plai load' :: Internal.Session -> URI -> IO () load' session uri = modifyMVar_ session $ \session' -> maybeTimeout session' uri $ do - resp@(redirected, _, _) <- fetchURL' (loader session') mime uri + putStrLn "a" + resp@(redirected, _, _) <- URI.fetchURL' (loader session') mime uri + putStrLn "b" let doc = parseDocument resp + putStrLn "c" return $ session' { currentURL = redirected, document = doc, knownEls = HM.empty, id2els = HM.fromList $ indexedIDs doc } @@ -46,9 +49,9 @@ submit' session (uri, query, method) = modifyMVar_ session $ \session' -> maybeT 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. - fromMaybe session <$> timeout (delay * 1000) act +---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. +--- fromMaybe session <$> timeout (delay * 1000) act maybeTimeout _ _ act = act --- diff --git a/src/Main.hs b/src/Main.hs index 2b3cabe..63cc388 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,6 +3,8 @@ module Main where import Happstack.Lite import Happstack.Server.RqData +import Happstack.Server.Monads (askRq) +import Happstack.Server.Types (rqUri) import Control.Concurrent.MVar import Data.HashMap.Strict as M import Data.FileEmbed @@ -26,6 +28,7 @@ import Happstack.Server.I18N import Internal import Internal.Load as Load import Internal.Elements as El +import Internal.Forms as Forms import Control.Monad.IO.Class (liftIO) import Control.Monad (forM) @@ -35,15 +38,19 @@ import qualified UI.Search as Q main :: IO () main = do sessions <- initSessions - serve Nothing $ msum [ - dir "assets" $ path $ ok . toResponse . fromMaybe "Not Found" . flip Prelude.lookup $(embedDir "assets"), - dir "webdriver" $ dir "v1" $ serveWebdriver sessions, - postHome sessions, - serveHome, - dir "preview-prompt" servePreviewPrompt, - dir "close" $ path $ deleteSession sessions, - path $ serveSession sessions - ] + putStrLn "Serving http://localhost:8000/" + serve Nothing $ do + req <- askRq + liftIO $ putStrLn $ rqUri req + msum [ + dir "assets" $ path $ ok . toResponse . fromMaybe "Not Found" . flip Prelude.lookup $(embedDir "assets"), + dir "webdriver" $ dir "v1" $ serveWebdriver sessions, + postHome sessions, + serveHome, + dir "preview-prompt" servePreviewPrompt, + dir "close" $ path $ deleteSession sessions, + path $ serveSession sessions + ] serveHome :: ServerPart Response serveHome = do @@ -56,12 +63,15 @@ serveHome = do postHome sessions = do nullDir method POST + liftIO $ putStrLn "Creating new session!" (uuid, session) <- liftIO $ createSession sessions M.empty target <- looks "target" -- Not much point of a blank session, so allow loading here. + liftIO $ putStrLn "Allocated new session!" case target of (target':_) | Just url <- Load.parseAbsoluteURI target' -> liftIO $ Load.load' session url _ -> return () + liftIO $ putStrLn "Created new session!" seeOther ('/' : ID.toString uuid) $ toResponse () deleteSession sessions uuid = do @@ -91,7 +101,8 @@ serveSession = withSession session404 $ \uuid session -> msum [ dir "next" $ sessionAction' uuid session Load.next ], dir "el" $ path $ serveEl uuid session, - dir "click" $ clickElement uuid session + dir "click" $ clickElement uuid session, + dir "type" $ typeElement uuid session ] sessionHome uuid session = do @@ -101,7 +112,7 @@ sessionHome uuid session = do session' <- liftIO $ readMVar session let el = XC.fromDocument $ document session' related <- liftIO $ getRelatedEls session el - Tpl.inspector ok ":root" session' $ Tpl.elPage uuid el related + Tpl.inspector ok ":root" session' $ Tpl.elPage uuid el related "" session404 uuid = do Tpl.page notFound ["404", "Amphiarao"] "" $ \langs -> do @@ -192,14 +203,17 @@ serveEl' uuid session session' el = do method GET let title = toStrict $ renderMarkup $ contents $ Tpl.xmlNode' $ XC.node el related <- liftIO $ getRelatedEls session el - Tpl.inspector ok title session' $ Tpl.elPage uuid el related + elValue <- liftIO $ Forms.readInput' session el + Tpl.inspector ok title session' $ Tpl.elPage uuid el related elValue serveElPreview uuid session el = do nullDir method GET let title = toStrict $ renderMarkup $ contents $ Tpl.xmlNode' $ XC.node el related <- liftIO $ getRelatedEls session el - Tpl.page ok [title, Txt.pack $ ID.toString uuid, "Amphiarao"] "fill" $ Tpl.elPage uuid el related + elValue <- liftIO $ Forms.readInput' session el + Tpl.page ok [title, Txt.pack $ ID.toString uuid, "Amphiarao"] "fill" $ + Tpl.elPage uuid el related elValue clickElement uuid session = do nullDir @@ -212,3 +226,20 @@ clickElement uuid session = do seeOther ('/':ID.toString uuid) $ toResponse () Nothing -> Tpl.inspector notFound "404" session' $ \langs -> H.h1 $ l langs ElementNotFound + +typeElement uuid session = do + nullDir + method POST + elUUID <- look "el" + newValue <- lookText' "text" + isReset <- looks "reset" + session' <- liftIO $ readMVar session + case getEl session' =<< ID.fromString elUUID of + Just el | Prelude.null isReset -> do + liftIO $ Forms.sendText (Forms.SendText newValue) el session + seeOther ('/':ID.toString uuid) $ toResponse () + Just el -> do + liftIO $ Forms.clearForm session el + seeOther ('/':ID.toString uuid) $ toResponse () + Nothing -> Tpl.inspector notFound "404" session' $ \langs -> + H.h1 $ l langs ElementNotFound diff --git a/src/Messages.hs b/src/Messages.hs index 8934d31..5062254 100644 --- a/src/Messages.hs +++ b/src/Messages.hs @@ -17,7 +17,7 @@ data Message = PromptPreview | ErrURL | LinkSearchExact | LinkSearch | - Click + Click | SetValue | ResetValue deriving Show l :: [Text] -> Message -> Html @@ -46,6 +46,8 @@ l ("en":_) ErrURL = do l ("en":_) LinkSearchExact = "Links (Exact)" l ("en":_) LinkSearch = "Links" l ("en":_) Click = "Click" +l ("en":_) SetValue = "Set" +l ("en":_) ResetValue = "Reset" ---- End localizations l (_:langs) msg = l langs msg l [] msg = string $ show msg @@ -60,7 +62,7 @@ data AttrMessage = Back' | Next' | SearchChildren' | - Click' deriving Show + Click' | EnterValue' deriving Show l' :: [Text] -> AttrMessage -> AttributeValue ---- Begin localization @@ -74,6 +76,7 @@ l' ("en":_) Back' = "Previous inspected page" l' ("en":_) Next' = "Next inspected page" l' ("en":_) SearchChildren' = "Search Children…" l' ("en":_) Click' = "Click" +l' ("en":_) EnterValue' = "Enter input value" ---- End localization l' (_:langs) msg = l' langs msg l' [] msg = stringValue $ show msg diff --git a/src/UI/Templates.hs b/src/UI/Templates.hs index 1aa8f9d..fd519e4 100644 --- a/src/UI/Templates.hs +++ b/src/UI/Templates.hs @@ -10,6 +10,7 @@ import Data.Text as Txt import Internal import Internal.Load (isClickableEl) +import Internal.Forms (isTypableEl, readInput') import Control.Monad.IO.Class (liftIO) import Control.Monad (unless, when, forM) import Control.Concurrent.MVar @@ -121,7 +122,7 @@ elSelector (Element (Name name _ ns) attrs _) = do tok val' | otherwise = return [] -elPage uuid cursor links langs = blockquote $ do +elPage uuid cursor links elValue langs = blockquote $ do nav $ do forM (Prelude.reverse $ XC.ancestor cursor) $ \el -> do link el $ xmlNode' $ XC.node el -- Should all be elements... @@ -138,6 +139,13 @@ elPage uuid cursor links langs = blockquote $ do button $ l langs Click link cursor $ p $ xmlNode $ XC.node cursor ol $ void $ forM (XC.child cursor) $ \el -> li $ link el $ xmlNode $ XC.node el + when (isTypableEl cursor) $ H.form ! target "_top" ! alt (l' langs EnterValue') ! + action (stringValue ('/':ID.toString uuid ++ "/type")) ! A.method "POST" $ do + input ! type_ "hidden" ! name "el" ! + value (stringValue $ fromMaybe "" $ ID.toString <$> Prelude.lookup (XC.node cursor) links) + input ! type_ "text" ! name "text" ! placeholder (l' langs EnterValue') ! value (textValue elValue) + button $ l langs SetValue + button ! name "reset" $ l langs ResetValue where link el | Just uuid' <- Prelude.lookup (XC.node el) links = a ! target "_top" ! href (stringValue $ href' uuid') diff --git a/src/Webdriver.hs b/src/Webdriver.hs index 573bcd8..382643b 100644 --- a/src/Webdriver.hs +++ b/src/Webdriver.hs @@ -64,7 +64,19 @@ serveSession sessions = WD.withSession fail (\uuid session -> msum [ dir "element" $ findFromRoot session, dir "element" $ dir "active" noSuchEl, dir "element" $ path $ serveElement session, - dir "elements" $ findAllFromRoot session + dir "elements" $ findAllFromRoot session, + dir "source" $ viewSource session, + dir "execute" $ dir "sync" unsupportedOp, + dir "execute" $ dir "async" unsupportedOp, + dir "cookie" $ msum [getCookies, addCookie, deleteCookies], + dir "cookie" $ path $ \cookie -> msum [getCookie cookie, deleteCookie cookie], + dir "actions" unsupportedOp, -- I avoid dealing in terms of mouse/keyboard/touchscreen. + dir "alert" $ msum [ + dir "dismiss" $ handleAlert, + dir "accept" $ handleAlert, + dir "text" $ alertText + ], + dir "screenshot" $ unsupportedOp -- Will implement for Haphaestus. ]) sessions where fail uuid'| Just _ <- ID.fromString uuid' = errJSON 404 "invalid session ID" $ ( @@ -223,7 +235,8 @@ serveElement session elUUID = do dir "rect" $ unsupportedOp, -- Will be meaningful for Haphaestus! dir "click" $ actionClickEl session el, dir "reset" $ actionResetEl session el, - dir "value" $ actionTypeEl session el + dir "value" $ actionTypeEl session el, + dir "screenshot" unsupportedOp -- Will be meaningful for Haphaestus! ] Nothing | Nothing <- ID.fromString elUUID -> errJSON 404 "no such element" "Invalid UUID" @@ -302,3 +315,44 @@ actionTypeEl session el = do liftIO $ WDF.sendText req' el session ok $ toResponse () Nothing -> errJSON 400 "invalid argument" "Failed to parse JSON" + +viewSource session = do + method GET + nullDir + WD.Session { WD.document = doc } <- liftIO $ readMVar session + ok $ toResponse $ X.renderLBS X.def doc + +-- TODO Expose cookies from HURL, until then emulate Rhapsodes existing behaviour of not supporting cookies. +getCookies = do + method GET + nullDir + let res :: [Value] = [] + okJSON res +getCookie :: String -> ServerPart Response +getCookie cookie = do + method GET + nullDir + errJSON 404 "no such cookie" "Cookie access is as yet unsupported" +addCookie = do + method POST + nullDir + ok $ toResponse () +deleteCookie :: String -> ServerPart Response +deleteCookie cookie = do + method DELETE + nullDir + ok $ toResponse () +deleteCookies = do + method DELETE + nullDir + ok $ toResponse () + +-- I don't ever open alerts, they're terrible UX! +handleAlert = do + method POST + nullDir + errJSON 404 "no such alert" "Rhapsode doesn't open alerts." +alertText = do + method [GET, POST] + nullDir + errJSON 404 "no such alert" "Rhapsode doesn't open alerts." -- 2.30.2