4 files changed, 58 insertions(+), 12 deletions(-)

M amphiarao.cabal
M src/Internal.hs
M src/Internal/Load.hs
M src/Webdriver.hs

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

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

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

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