{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveGeneric #-}
module Webdriver(serveWebdriver) where
import Happstack.Lite
import Control.Concurrent.MVar
import Data.Aeson
import Data.Text (Text, unpack)
import qualified Data.Text as Txt
import GHC.Generics
import Data.ByteString.Lazy (ByteString)
import qualified Data.HashMap.Strict as M
import qualified Data.Map.Strict as M'
import Data.UUID as ID
import Data.UUID.V4
import Control.Monad.IO.Class (liftIO)
import Control.Monad (mapM)
import Data.Maybe (fromMaybe, isJust)
import Data.String as Str
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
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
msum [
dir "status" serveStatus,
dir "session" $ postSession sessions,
dir "session" $ path $ serveSession sessions,
nullDir >> ok (toResponse ("This is a WebDriver endpoint. Please copy the URL to hand to Selenium." :: Text))
]
serveSession :: WD.Sessions -> String -> ServerPart Response
serveSession sessions = WD.withSession fail (\uuid session -> msum [
delSession sessions uuid,
dir "timeouts" $ getTimeout session,
dir "timeouts" $ setTimeout session,
dir "url" $ navigateTo session,
dir "url" $ getURL session,
dir "refresh" $ reloadPage session,
dir "back" $ sessionAction WD.back session,
dir "forward" $ sessionAction WD.next session,
dir "title" $ sessionTitle session,
dir "window" $ msum [ -- Noops
getWindowHandle uuid,
delSession sessions uuid, -- Closing the only window closes the session.
switchWindowHandle uuid,
dir "handles" $ getWindowHandles uuid,
dir "rect" $ unsupportedOp,
dir "maximize" $ unsupportedOp,
dir "minimize" $ unsupportedOp,
dir "fullscreen" $ unsupportedOp
],
dir "frame" $ msum [noSuchFrame, dir "parent" $ ok $ toResponse ()], -- Noops
dir "element" $ findFromRoot session,
dir "element" $ dir "active" noSuchEl,
dir "element" $ path $ serveElement 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" $ (
"Session " ++ uuid' ++ " was not found in active sessions")
| otherwise = errJSON 404 "invalid session ID" $ ("UUID " ++ uuid' ++ " is not a valid UUID")
data Status = Status {ready :: Bool, message :: Text} deriving Generic
instance ToJSON Status
serveStatus = okJSON $ Status True "Always ready to open new sessions"
data NewSession = NewSession {sessionId :: UUID, capabilities :: Object} deriving Generic
instance ToJSON NewSession
postSession sessions = do
method POST
nullDir
caps' <- getJSON
case processCaps caps' of
Just caps -> do
(uuid, _) <- liftIO $ WD.createSession sessions caps
okJSON $ NewSession uuid caps
Nothing -> errJSON 500 "session not created" "Invalid capabilities specified!"
delSession sessions uuid = do
method DELETE
nullDir
liftIO $ WD.delSession uuid sessions
ok $ toResponse ()
getTimeout session = do
method GET
nullDir
session' <- liftIO $ readMVar session
okJSON $ WD.timeouts session'
setTimeout session = do
method POST
nullDir
update' <- getJSON
session' <- liftIO $ readMVar session
case update' of
Just (Object update) | Object current <- toJSON $ WD.timeouts session',
Success new <- fromJSON $ toJSON $ M.union update current -> do
liftIO $ swapMVar session session' {WD.timeouts = new}
ok $ toResponse ()
_ -> errJSON 400 "invalid argument" "Failed to parse JSON input"
data NavigateTo = NavigateTo { url :: String } deriving Generic
instance FromJSON NavigateTo
navigateTo session = do
method POST
nullDir
target' <- getJSON
case target' of
Just target | Just url' <- URI.parseAbsoluteURI target -> do
liftIO $ WD.load session url'
ok $ toResponse ()
Just target -> errJSON 400 "invalid argument" (target ++ " is not an absolute URL")
Nothing -> errJSON 400 "invalid argument" "Failed to parse JSON input"
getURL session = do
method GET
nullDir
session' <- liftIO $ readMVar session
ok $ toResponse $ show $ WD.currentURL session'
reloadPage session = do
method POST
nullDir
session' <- liftIO $ readMVar session
liftIO $ WD.load' session $ WD.currentURL session'
ok $ toResponse ()
sessionAction cb session = do
method POST
nullDir
liftIO $ cb session
ok $ toResponse ()
sessionTitle session = do
method GET
nullDir
ret <- liftIO $ WDE.getTitle session
ok $ toResponse ret
---- Windowing noops
getWindowHandle uuid = do
method GET
nullDir
ok $ toResponse ("window-" ++ ID.toString uuid)
data WindowHandle = WindowHandle { handle :: String } deriving Generic
instance FromJSON WindowHandle
switchWindowHandle uuid = do
method POST
nullDir
handle <- getJSON
case handle of
Nothing -> errJSON 400 "invalid argument" "Failed to parse JSON input"
Just (WindowHandle handle') | handle' /= "window-" ++ ID.toString uuid ->
errJSON 404 "no such window" "Rhapsode isn't a multi-window or multi-tab browser"
_ -> ok $ toResponse ()
getWindowHandles uuid = do
method GET
nullDir
okJSON ["window-" ++ ID.toString uuid]
noSuchFrame = do
method POST
nullDir
errJSON 404 "no such frame" "Rhapsode doesn't support frames"
unsupportedOp = do
nullDir
errJSON 400 "unsupported operation" "Windowsize is meaningless to Rhapsode"
----
findAllFromRoot session = do
method POST
nullDir
req <- getJSON
session' <- liftIO $ readMVar session
case req of
Just req' -> case WDE.find req' $ XC.fromDocument $ WD.document session' of
Right res -> okJSON =<< mapM (liftIO . WD.serializeEl session) res
Left (True, msg) -> errJSON 400 "invalid selector" msg
Left (False, msg) -> errJSON 400 "invalid argument" msg
Nothing -> errJSON 400 "invalid argument" "Failed to parse JSON"
findFromRoot session = do
method POST
nullDir
req <- getJSON
session' <- liftIO $ readMVar session
case req of
Just req' -> case WDE.find req' $ XC.fromDocument $ WD.document session' of
Right (res:_) -> okJSON =<< liftIO (WD.serializeEl session res)
Right [] | WDE.Find using query <- req' -> errJSON 404 "No such element" (
"No elements match " ++ unpack using ++ " query: " ++ query)
Left (True, msg) -> errJSON 400 "invalid selector" msg
Left (False, msg) -> errJSON 400 "invalid argument" msg
Nothing -> errJSON 400 "invalid argument" "Failed to parse JSON"
serveElement session elUUID = do
session' <- liftIO $ readMVar session
case WD.getEl session' =<< ID.fromString elUUID of
Just el -> msum [
dir "element" $ findFromEl session el,
dir "elements" $ findAllFromEl session el,
dir "attribute" $ path $ getAttribute el,
dir "property" $ path $ getAttribute el, -- Don't want to implement the DOM abomination!
dir "css" $ path $ getStyle session' el,
dir "text" $ getElText el,
dir "name" $ getElName el,
dir "rect" $ unsupportedOp, -- Will be meaningful for Haphaestus!
dir "click" $ actionClickEl session el,
dir "reset" $ actionResetEl 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"
Nothing -> errJSON 404 "no such element" "Unknown UUID."
findFromEl session el = do
method POST
nullDir
req <- getJSON
case req of
Just req' -> case WDE.find req' el of
Right (res:_) -> okJSON =<< liftIO (WD.serializeEl session res)
Right [] | WDE.Find using query <- req' -> errJSON 404 "No such element" (
"No child elements match " ++ unpack using ++ " query: " ++ query)
Left (True, msg) -> errJSON 400 "invalid selector" msg
Left (False, msg) -> errJSON 400 "invalid argument" msg
Nothing -> errJSON 400 "invalid argument" "Failed to parse JSON"
findAllFromEl session el = do
method POST
nullDir
req <- getJSON
case req of
Just req' -> case WDE.find req' el of
Right res -> okJSON =<< mapM (liftIO . WD.serializeEl session) res
Left (True, msg) -> errJSON 400 "invalid selector" msg
Left (False, msg) -> errJSON 400 "invalid argument" msg
Nothing -> errJSON 400 "invalid argument" "Failed to parse JSON"
noSuchEl = do
method GET
nullDir
errJSON 404 "no such element" "Rhapsode does not have active elements."
getAttribute el name = do
method GET
nullDir
ok $ toResponse $ case XC.node el of
X.NodeElement (X.Element _ attrs _) ->
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
ok $ toResponse $ Txt.concat $ XC.content el
getElName el = do
method GET
nullDir
ok $ toResponse $ case XC.node el of
X.NodeElement (X.Element name _ _) -> name2text name
_ -> ""
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"
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."