From 1067e7dade93a5f4193da768bf2e3d6a771c65db Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Wed, 22 Dec 2021 09:35:56 +1300 Subject: [PATCH] Integrate Haskell Stylist for CSS debugging. Export WebDriver interface. --- amphiarao.cabal | 6 ++++-- src/Internal.hs | 8 ++++++-- src/Internal/Load.hs | 46 +++++++++++++++++++++++++++++++++++++------- src/Webdriver.hs | 10 +++++++++- 4 files changed, 58 insertions(+), 12 deletions(-) diff --git a/amphiarao.cabal b/amphiarao.cabal index 3830ff6..9b82b16 100644 --- a/amphiarao.cabal +++ b/amphiarao.cabal @@ -55,7 +55,7 @@ executable amphiarao -- Modules included in this executable, other than Main. other-modules: Webdriver, Capabilities, JSON, Messages, - Internal, Internal.Load, Internal.Elements, Internal.Forms, + Internal, Internal.Load, Internal.Elements, Internal.Forms, Internal.Style, UI.Templates, UI.Search, XML.Selectors.CSS, XML.Selectors.CSS.Parse, XML.Selectors.CSS.Tokens, XML.Selectors.CSS.Types @@ -73,7 +73,9 @@ executable amphiarao hurl >= 2.1.1 && <3, network-uri, http-client, -- Parse & query XML/HTML xml-conduit >= 1.8, html-conduit >= 1.3, css-syntax, array >=0.4, - attoparsec, time, hxt-xpath, hxt + attoparsec, time, hxt-xpath, hxt, + -- For styling + xml-conduit-stylist >= 2.3, stylist >= 2.4.0.2, css-syntax build-tools: happy diff --git a/src/Internal.hs b/src/Internal.hs index 721bbd6..3b61731 100644 --- a/src/Internal.hs +++ b/src/Internal.hs @@ -22,6 +22,8 @@ import qualified Text.XML.Cursor as XML import qualified Data.Map as M' import qualified Network.HTTP.Client.MultipartFormData as HTTP +import Data.CSS.Style (TrivialPropertyParser, QueryableStyleSheet, queryableStyleSheet) + type Sessions = MVar (M.HashMap UUID Session) type Session = MVar Session' data Session' = Session { @@ -35,7 +37,8 @@ data Session' = Session { 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 + id2els :: M.HashMap Text XML.Cursor, + css :: QueryableStyleSheet TrivialPropertyParser } initSessions :: IO Sessions @@ -64,7 +67,8 @@ createSession sessions caps = do }, knownEls = M.empty, forms = M'.empty, multipartForms = M'.empty, - id2els = M.empty + id2els = M.empty, + css = queryableStyleSheet } session' <- newMVar session modifyMVar_ sessions (return . M.insert uuid session') diff --git a/src/Internal/Load.hs b/src/Internal/Load.hs index a306245..41b6a3d 100644 --- a/src/Internal/Load.hs +++ b/src/Internal/Load.hs @@ -8,7 +8,7 @@ import System.Timeout (timeout) import Control.Monad.IO.Class import Data.Aeson -import Data.Text (Text, pack) +import Data.Text (Text, pack, unpack) import qualified Data.Text as Txt import Data.Text.Lazy (fromStrict) import GHC.Generics @@ -20,26 +20,43 @@ import Data.List (delete) import Network.URI as URI import Network.URI.Fetch as URI -import Network.URI.Charset (convertCharset) +import Network.URI.Charset (convertCharset, charsets) import qualified Text.HTML.DOM as HTML import qualified Text.XML as XML import qualified Text.XML.Cursor as XC import qualified Text.XML.Cursor ((>=>)) import qualified Data.Map as M +import Data.HTML2CSS (html2css) +import Data.CSS.Preprocessor.Conditions as CSS +import Data.CSS.Preprocessor.PsuedoClasses as CSS +import Data.CSS.Style (queryableStyleSheet, TrivialPropertyParser) +import Data.CSS.Syntax.Tokens as CSS + import Internal.Forms mime = words "text/html text/xml application/xml application/xhtml+xml text/plain" load' :: Internal.Session -> URI -> IO () load' session uri = modifyMVar_ session $ \session' -> maybeTimeout session' uri $ do - 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 } + css' <- CSS.loadImports (loadText $ loader session') false false + (html2css doc uri :: ConditionalStyles TrivialPropertyParser) [] + let css'' = CSS.inner $ resolve false false (htmlPsuedoFilter queryableStyleSheet) css' + return $ session' { + currentURL = redirected, document = doc, css = css'', + knownEls = HM.empty, id2els = HM.fromList $ indexedIDs doc + } + where + loadText manager url = do + response <- fetchURL manager ["text/css"] url + let charsets' = map unpack charsets + return $ case response of + ("text/css", Left text) -> text + ("text/css", Right bytes) -> applyCSScharset charsets' $ B.toStrict bytes + (_, _) -> "" + false = const $ CSS.B False submit' :: Internal.Session -> (URI, Txt.Text, Txt.Text) -> IO () submit' session (uri, query, method) = modifyMVar_ session $ \session' -> maybeTimeout session' uri $ do @@ -260,3 +277,18 @@ indexedIDs doc = mapMaybe extractId $ XC.orSelf XC.descendant $ XC.fromDocument extractId cursor | XML.NodeElement el@(XML.Element _ attrs _) <- XC.node cursor, Just id <- "id" `M.lookup` M.mapKeys XML.nameLocalName attrs = Just (id, cursor) | otherwise = Nothing + +-------- +---- CSS charset sniffing +-------- +applyCSScharset (charset:charsets) bytes + | cssCharset (tokenize text) == pack charset = text + | otherwise = applyCSScharset charsets bytes + where + text = convertCharset charset bytes +applyCSScharset _ bytes = convertCharset "utf-8" bytes +cssCharset toks | (AtKeyword "charset":toks') <- skipCSSspace toks, + (CSS.String charset:_) <- skipCSSspace toks' = charset + | otherwise = "" +skipCSSspace (Whitespace:toks) = skipCSSspace toks +skipCSSspace toks = toks diff --git a/src/Webdriver.hs b/src/Webdriver.hs index 382643b..c6e707d 100644 --- a/src/Webdriver.hs +++ b/src/Webdriver.hs @@ -23,6 +23,7 @@ import qualified Network.URI as URI import qualified Network.URI.Fetch as URI import qualified Text.XML.Cursor as XC import qualified Text.XML as X +import qualified Data.CSS.Syntax.Tokens as CSS import Capabilities (processCaps) import JSON @@ -30,6 +31,7 @@ import qualified Internal as WD import qualified Internal.Load as WD import qualified Internal.Elements as WDE import qualified Internal.Forms as WDF +import qualified Internal.Style as WDS serveWebdriver :: WD.Sessions -> ServerPart Response serveWebdriver sessions = do @@ -229,7 +231,7 @@ serveElement session elUUID = do dir "elements" $ findAllFromEl session el, dir "attribute" $ path $ getAttribute el, dir "property" $ path $ getAttribute el, -- Don't want to implement the DOM abomination! - -- TODO integrate CSS + dir "css" $ path $ getStyle session' el, dir "text" $ getElText el, dir "name" $ getElName el, dir "rect" $ unsupportedOp, -- Will be meaningful for Haphaestus! @@ -279,6 +281,12 @@ getAttribute el name = do fromMaybe "" $ M'.lookup (Str.fromString name) attrs _ -> "" +getStyle session el name = do + method GET + nullDir + let res = M.lookupDefault [] name $ WDS.styleCursor session el + ok $ toResponse $ CSS.serialize res + getElText el = do -- TODO allow CSS to impact the response. method GET nullDir -- 2.30.2