diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2012, Adam Curtis +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Adam Curtis nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,41 @@ +# About +hs-webdriver is a Selenium WebDriver client for the Haskell programming language. You can use it to automate browser sessions for testing, system administration, etc. + +For more information about Selenium itself, see http://seleniumhq.org/ + +# Installation +hs-webdriver uses the Cabal build system to configure, build, install, and generate documentation on multiple platforms. + +For more information on using Cabal and its various installation options, see the Cabal User's Guide at http://www.haskell.org/cabal/users-guide/index.html + +## Installation from Hackage +hs-webdriver is hosted on Hackage under the name webdriver. Thus, the simplest way to download and install the most recent version of hs-webdriver is to run: + +```sh +cabal install webdriver +``` +There are also options to do system-wide installation, version selection, and other build options. See Cabal documentation. + +## Installation from this repository + +To build and install a git revision for a single user on your system, run these commands from within the repository directory + + +### using cabal-install + +```sh +cabal install +``` + +### using Cabal + +For systems without cabal-install available, you can also run the Setup.hs +script, as such: + +```sh +runhaskell Setup.hs configure --user +runhaskell Setup.hs build +runhaskell Setup.hs install +``` + +For more build options, please refer to the Cabal documentation. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Test/WebDriver.hs b/Test/WebDriver.hs new file mode 100644 --- /dev/null +++ b/Test/WebDriver.hs @@ -0,0 +1,60 @@ +{-| +This module serves as the top-level interface to the Haskell WebDriver bindings, +providing most of the functionality you're likely to want. +-} +module Test.WebDriver + ( -- * WebDriver sessions + WD(..), WDSession(..), defaultSession, SessionId(..) + -- * Running WebDriver tests + , module Test.WebDriver + -- * Capabilities and configuration + , Capabilities(..), defaultCaps, allCaps + , Platform(..), ProxyType(..) + -- ** Browser-specific configuration + , Browser(..), firefox, chrome, ie, opera, iPhone, iPad, android + -- * WebDriver commands + , module Test.WebDriver.Commands + -- * Exceptions + , InvalidURL(..), NoSessionId(..), BadJSON(..) + , HTTPStatusUnknown(..), HTTPConnError(..) + , UnknownCommand(..), ServerError(..) + , FailedCommand(..), FailedCommandType(..) + , FailedCommandInfo(..), StackFrame(..) + , mkFailedCommandInfo, failedCommand + ) where + +import Test.WebDriver.Types +import Test.WebDriver.Commands + +import Control.Applicative +import Control.Monad.State.Strict +import Control.Exception.Lifted + +import Prelude hiding (catch) + +-- |Executes a 'WD' computation within the 'IO' monad, using the given +-- 'WDSession'. +runWD :: WDSession -> WD a -> IO a +runWD sess (WD wd) = evalStateT wd sess + +-- |Like 'runWD', but automatically creates a session beforehand and closes it +-- afterwards. This is a very common use case. +runSession :: WDSession -> Capabilities -> WD a -> IO a +runSession s caps wd = runWD s $ createSession caps >> wd <* closeSession + +-- |Locally sets a 'WDSession' for use within the given 'WD' action. +-- The state of the outer action is unaffected by this function. +-- This function is useful if you need to work with multiple sessions at once. +withSession :: WDSession -> WD a -> WD a +withSession s' (WD wd) = WD . lift $ evalStateT wd s' + +-- |A finalizer ensuring that the session is always closed at the end of +-- the given 'WD' action, regardless of any exceptions. +finallyClose:: WD a -> WD a +finallyClose wd = closeOnException wd <* closeSession + +-- |A variant of 'finallyClose' that only closes the session when an +-- asynchronous exception is thrown, but otherwise leaves the session open +-- if the action was successful. +closeOnException :: WD a -> WD a +closeOnException wd = wd `onException` closeSession diff --git a/Test/WebDriver/Chrome/Extension.hs b/Test/WebDriver/Chrome/Extension.hs new file mode 100644 --- /dev/null +++ b/Test/WebDriver/Chrome/Extension.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Test.WebDriver.Chrome.Extension + ( ChromeExtension + , loadExtension + , loadRawExtension + ) where +import Data.ByteString as BS +import Data.ByteString.Base64 as B64 +import Data.Aeson +import Control.Applicative +import Control.Monad.IO.Class + +-- |An opaque type representing a Google Chrome extension. +newtype ChromeExtension = ChromeExtension ByteString + deriving (Eq, Show, Read, ToJSON, FromJSON) + +-- |Load a .crx file as a ChromeExtension +loadExtension :: MonadIO m => FilePath -> m ChromeExtension +loadExtension path = liftIO $ loadRawExtension <$> BS.readFile path + +-- |Load raw .crx data as a ChromeExtension +loadRawExtension :: ByteString -> ChromeExtension +loadRawExtension = ChromeExtension . B64.encode diff --git a/Test/WebDriver/Commands.hs b/Test/WebDriver/Commands.hs new file mode 100644 --- /dev/null +++ b/Test/WebDriver/Commands.hs @@ -0,0 +1,498 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +-- |This module exports basic WD actions that can be used to interact with a +-- browser session. +module Test.WebDriver.Commands + ( -- * Sessions + createSession, closeSession, sessions, getCaps + -- * Browser interaction + -- ** Web navigation + , openPage, forward, back, refresh + -- ** Page info + , getCurrentURL, getSource, getTitle, screenshot + -- * Timeouts + , setImplicitWait, setScriptTimeout + -- * Web elements + , Element(..), Selector(..) + -- ** Searching for elements + , findElem, findElems, findElemFrom, findElemsFrom + -- ** Interacting with elements + , click, submit, getText + , sendKeys, sendRawKeys, clearInput + -- ** Element information + , attr, cssProp, elemPos, elemSize + , isSelected, isEnabled, isDisplayed + , tagName, activeElem, elemInfo + -- ** Element equality + , (<==>), () + -- * Javascript + , executeJS, asyncJS + , JSArg(..) + -- * Windows + , WindowHandle(..), currentWindow + , getCurrentWindow, focusWindow, closeWindow, windows + , getWindowSize, setWindowSize, getWindowPos, setWindowPos + -- * Cookies + , Cookie(..) + , cookies, setCookie, deleteCookie, deleteVisibleCookies + -- * Alerts + , getAlertText, replyToAlert, acceptAlert, dismissAlert + -- * Mouse gestures + , moveTo, moveToCenter, moveToFrom + , clickWith, MouseButton(..) + , mouseDown, mouseUp, withMouseDown, doubleClick + -- * Touch gestures + , touchClick, touchDown, touchUp, touchMove + , touchScroll, touchScrollFrom, touchDoubleClick + , touchLongClick, touchFlick, touchFlickFrom + -- * Screen orientation + , Orientation(..) + , getOrientation, setOrientation + -- * Geo-location + , getLocation, setLocation + -- * IME support + , availableIMEEngines, activeIMEEngine, checkIMEActive + , activateIME, deactivateIME + -- * Server information + , serverStatus + ) where + +import Test.WebDriver.Types +import Test.WebDriver.Commands.Internal +import Test.WebDriver.JSON + +import Data.Aeson +import qualified Data.Text as T +import Data.Text (Text, splitOn, append) +import Data.ByteString (ByteString) +import Data.ByteString.Base64 as B64 +import Network.URI + +import Control.Applicative +import Control.Monad.State.Strict +import Control.Exception (SomeException) +import Control.Exception.Lifted (throwIO, catch, handle) +import Data.Word + +import Prelude hiding (catch) + + +-- |Get information from the server as a JSON 'Object'. For more information +-- about this object see +-- +serverStatus :: WD Value -- todo: make this a record type +serverStatus = doCommand GET "/status" () + + +-- |Create a new session with the given 'Capabilities'. This command +-- resets the current session ID to that of the new session. +createSession :: Capabilities -> WD WDSession +createSession caps = do + sessUrl <- doCommand POST "/session" . single "desiredCapabilities" $ caps + let sessId = SessionId . last . filter (not . T.null) . splitOn "/" $ sessUrl + modify $ \sess -> sess {wdSessId = Just sessId} + return =<< get + +-- |Retrieve a list of active sessions and their 'Capabilities'. +sessions :: WD [(SessionId, Capabilities)] +sessions = do + objs <- doCommand GET "/sessions" () + forM objs $ parsePair "id" "capabilities" "sessions" + +-- |Get the actual 'Capabilities' of the current session. +getCaps :: WD Capabilities +getCaps = doSessCommand GET "" () + +-- |Close the current session and the browser associated with it. +closeSession :: WD () +closeSession = do s <- get + doSessCommand DELETE "" () :: WD () + put s { wdSessId = Nothing } + +-- |Sets the amount of time we implicitly wait when searching for 'Elements'. +setImplicitWait :: Integer -> WD () +setImplicitWait ms = + doSessCommand POST "/timeouts/implicit_wait" (object msField) + `catch` \(_ :: SomeException) -> + doSessCommand POST "/timeouts" (object allFields) + where msField = ["ms" .= ms] + allFields = ["type" .= ("implicit" :: String)] ++ msField + +-- |Sets the amount of time we wait for an asynchronous script to return a +-- result +setScriptTimeout :: Integer -> WD () +setScriptTimeout ms = + doSessCommand POST "/timeouts/async_script" (object msField) + `catch` \(_ :: SomeException) -> + doSessCommand POST "/timeouts" (object allFields) + where msField = ["ms" .= ms] + allFields = ["type" .= ("script" :: String)] ++ msField + +-- |Gets the URL of the current page. +getCurrentURL :: WD String +getCurrentURL = doSessCommand GET "/url" () + +-- |Opens a new page by the given URL. +openPage :: String -> WD () +openPage url + | isURI url = doSessCommand POST "/url" . single "url" $ url + | otherwise = throwIO . InvalidURL $ url + +-- |Navigate forward in the browser history. +forward :: WD () +forward = doSessCommand POST "/forward" () + +-- |Navigate backward in the browser history. +back :: WD () +back = doSessCommand POST "/back" () + +-- |Refresh the current page +refresh :: WD () +refresh = doSessCommand POST "/refresh" () + +{- |Inject a snippet of Javascript into the page for execution in the +context of the currently selected frame. The executed script is +assumed to be synchronous and the result of evaluating the script is +returned and converted to an instance of FromJSON. + +The first parameter defines arguments to pass to the javascript +function. Arguments of type Element will be converted to the +corresponding DOM element. Likewise, any elements in the script result +will be returned to the client as Elements. + +The second parameter defines the script itself in the form of a +function body. The value returned by that function will be returned to +the client. The function will be invoked with the provided argument +list and the values may be accessed via the arguments object in the +order specified. +-} +executeJS :: FromJSON a => [JSArg] -> Text -> WD a +executeJS a s = fromJSON' =<< getResult + where + getResult = doSessCommand POST "/execute" . pair ("args", "script") $ (a,s) + +{- |Executes a snippet of Javascript code asynchronously. This function works +similarly to 'executeJS', except that the Javascript is passed a callback +function as its final argument. The script should call this function +to signal that it has finished executing, passing to it a value that will be +returned as the result of asyncJS. A result of Nothing indicates that the +Javascript function timed out (see 'setScriptTimeout') +-} +asyncJS :: FromJSON a => [JSArg] -> Text -> WD (Maybe a) +asyncJS a s = handle timeout $ fromJSON' =<< getResult + where + getResult = doSessCommand POST "/execute_async" . pair ("args", "script") + $ (a,s) + timeout (FailedCommand Timeout _) = return Nothing + timeout err = throwIO err + +-- |Grab a screenshot of the current page as a PNG image +screenshot :: WD ByteString +screenshot = B64.decodeLenient <$> doSessCommand GET "/screenshot" () + + +availableIMEEngines :: WD [Text] +availableIMEEngines = doSessCommand GET "/ime/available_engines" () + +activeIMEEngine :: WD Text +activeIMEEngine = doSessCommand GET "/ime/active_engine" () + +checkIMEActive :: WD Bool +checkIMEActive = doSessCommand GET "/ime/activated" () + +activateIME :: Text -> WD () +activateIME = doSessCommand POST "/ime/activate" . single "engine" + +deactivateIME :: WD () +deactivateIME = doSessCommand POST "/ime/deactivate" () + +--TODO!!! +--focusFrame :: Frame -> WD () +--focusFrame = undefined + +-- |Returns a handle to the currently focused window +getCurrentWindow :: WD WindowHandle +getCurrentWindow = doSessCommand GET "/window_handle" () + +-- |Returns a list of all windows available to the session +windows :: WD [WindowHandle] +windows = doSessCommand GET "/window_handles" () + +-- |Switches focus to a given window. +focusWindow :: WindowHandle -> WD () +focusWindow = doSessCommand POST "/window" . single "name" + +-- |Closes the given window +closeWindow :: WindowHandle -> WD () +closeWindow = doSessCommand DELETE "/window" . single "name" + +-- |Get the dimensions of the given window. +getWindowSize :: WindowHandle -> WD (Word, Word) +getWindowSize w = + doWinCommand GET w "/size" () >>= parsePair "width" "height" "getWindowSize" + +-- |Set the dimensions of the given window. +setWindowSize :: WindowHandle -> (Word, Word) -> WD () +setWindowSize win = doWinCommand POST win "/size" . pair ("width", "height") + +-- |Get the coordinates of the given window. +getWindowPos :: WindowHandle -> WD (Int, Int) +getWindowPos w = do + doWinCommand GET w "/position" () >>= parsePair "x" "y" "getWindowPos" + +-- |Set the coordinates of the given window. +setWindowPos :: WindowHandle -> (Int, Int) -> WD () +setWindowPos w = doWinCommand POST w "/position" . pair ("x","y") + +-- |Retrieve all cookies visible to the current page. +cookies :: WD [Cookie] +cookies = doSessCommand GET "/cookie" () + +-- |Set a cookie. If the cookie path is not specified, it will default to \"/\". +-- Likewise, if the domain is omitted, it will default to the current page's +-- domain +setCookie :: Cookie -> WD () +setCookie = doSessCommand POST "/cookie" . single "cookie" + +-- |Delete a cookie. This will do nothing is the cookie isn't visible to the +-- current page. +deleteCookie :: Cookie -> WD () +deleteCookie c = doSessCommand DELETE ("/cookie/" `append` cookName c) () + +-- |Delete all visible cookies on the current page. +deleteVisibleCookies :: WD () +deleteVisibleCookies = doSessCommand DELETE "/cookie" () + +-- |Get the current page source +getSource :: WD Text +getSource = doSessCommand GET "/source" () + +-- |Get the title of the current page. +getTitle :: WD Text +getTitle = doSessCommand GET "/title" () + +-- |Find an element on the page using the given element selector. +findElem :: Selector -> WD Element +findElem = doSessCommand POST "/element" + +-- |Find all elements on the page matching the given selector. +findElems :: Selector -> WD [Element] +findElems = doSessCommand POST "/elements" + +-- |Return the element that currently has focus. +activeElem :: WD Element +activeElem = doSessCommand POST "/element/active" () + +-- |Search for an element using the given element as root. +findElemFrom :: Element -> Selector -> WD Element +findElemFrom e = doElemCommand POST e "/element" + +-- |Find all elements matching a selector, using the given element as root. +findElemsFrom :: Element -> Selector -> WD [Element] +findElemsFrom e = doElemCommand POST e "/elements" + +-- |Describe the element. Returns a JSON object whose meaning is currently +-- undefined by the WebDriver protocol. +elemInfo :: Element -> WD Value +elemInfo e = doElemCommand GET e "" () + +-- |Click on an element. +click :: Element -> WD () +click e = doElemCommand POST e "/click" () + +-- |Submit a form element. This may be applied to descendents of a form element +-- as well. +submit :: Element -> WD () +submit e = doElemCommand POST e "/submit" () + +-- |Get all visible text within this element. +getText :: Element -> WD Text +getText e = doElemCommand GET e "/text" () + +-- |Send a sequence of keystrokes to an element. All modifier keys are released +-- at the end of the function. For more information about modifier keys, see +-- +sendKeys :: Text -> Element -> WD () +sendKeys t e = doElemCommand POST e "/value" . single "value" $ [t] + +-- |Similar to sendKeys, but doesn't implicitly release modifier keys +-- afterwards. This allows you to combine modifiers with mouse clicks. +sendRawKeys :: Text -> Element -> WD () +sendRawKeys t e = doElemCommand POST e "/keys" . single "value" $ [t] + +-- |Return the tag name of the given element. +tagName :: Element -> WD Text +tagName e = doElemCommand GET e "/name" () + +-- |Clear a textarea or text input element's value. +clearInput :: Element -> WD () +clearInput e = doElemCommand POST e "/clear" () + +-- |Determine if the element is selected. +isSelected :: Element -> WD Bool +isSelected e = doElemCommand GET e "/selected" () + +-- |Determine if the element is enabled. +isEnabled :: Element -> WD Bool +isEnabled e = doElemCommand GET e "/enabled" () + +-- |Determine if the element is displayed. +isDisplayed :: Element -> WD Bool +isDisplayed e = doElemCommand GET e "/displayed" () + +-- |Retrieve the value of an element's attribute +attr :: Element -> Text -> WD (Maybe Text) +attr e t = doElemCommand GET e ("/attribute/" `append` t) () + +-- |Retrieve the value of an element's computed CSS property +cssProp :: Element -> Text -> WD (Maybe Text) +cssProp e t = doElemCommand GET e ("/css/" `append` t) () + +-- |Retrieve an element's current position. +elemPos :: Element -> WD (Int, Int) +elemPos e = doElemCommand GET e "/location" () >>= parsePair "x" "y" "elemPos" + +-- |Retrieve an element's current size. +elemSize :: Element -> WD (Word, Word) +elemSize e = doElemCommand GET e "/size" () + >>= parsePair "width" "height" "elemSize" + +infix 4 <==> +-- |Determines if two element identifiers refer to the same element. +(<==>) :: Element -> Element -> WD Bool +e1 <==> (Element e2) = doElemCommand GET e1 ("/equals/" `append` e2) () + +-- |Determines if two element identifiers refer to different elements. +infix 4 +() :: Element -> Element -> WD Bool +e1 e2 = not <$> (e1 <==> e2) + +-- |Get the current screen orientation for rotatable display devices. +getOrientation :: WD Orientation +getOrientation = doSessCommand GET "/orientation" () + +-- |Set the current screen orientation for rotatable display devices. +setOrientation :: Orientation -> WD () +setOrientation = doSessCommand POST "/orientation" . single "orientation" + +-- |Get the text of an alert dialog. +getAlertText :: WD Text +getAlertText = doSessCommand GET "/alert_text" () + +-- |Sends keystrokes to Javascript prompt() dialog. +replyToAlert :: Text -> WD () +replyToAlert = doSessCommand POST "/alert_text" . single "text" + +-- |Accepts the currently displayed alert dialog. +acceptAlert :: WD () +acceptAlert = doSessCommand POST "/accept_alert" () + +-- |Dismisses the currently displayed alert dialog. +dismissAlert :: WD () +dismissAlert = doSessCommand POST "/dismiss_alert" () + +-- |Moves the mouse to the given position relative to the active element. +moveTo :: (Int, Int) -> WD () +moveTo = doSessCommand POST "/moveto" . pair ("xoffset","yoffset") + +-- |Moves the mouse to the center of a given element. +moveToCenter :: Element -> WD () +moveToCenter (Element e) = + doSessCommand POST "/moveto" . single "element" $ e + +-- |Moves the mouse to the given position relative to the given element. +moveToFrom :: (Int, Int) -> Element -> WD () +moveToFrom (x,y) (Element e) = + doSessCommand POST "/moveto" + . triple ("element","xoffset","yoffset") $ (e,x,y) + +-- |Click at the current mouse position with the given mouse button. +clickWith :: MouseButton -> WD () +clickWith = doSessCommand POST "/click" . single "button" + +-- |Perform the given action with the left mouse button held down. The mouse +-- is automatically released afterwards. +withMouseDown :: WD a -> WD a +withMouseDown wd = mouseDown >> wd <* mouseUp + +-- |Press and hold the left mouse button down. Note that undefined behavior +-- occurs if the next mouse command is not mouseUp. +mouseDown :: WD () +mouseDown = doSessCommand POST "/buttondown" () + +-- |Release the left mouse button. +mouseUp :: WD () +mouseUp = doSessCommand POST "/buttonup" () + +-- |Double click at the current mouse location. +doubleClick :: WD () +doubleClick = doSessCommand POST "/doubleclick" () + +-- |Single tap on the touch screen at the given element's location. +touchClick :: Element -> WD () +touchClick (Element e) = + doSessCommand POST "/touch/click" . single "element" $ e + +-- |Emulates pressing a finger down on the screen at the given location. +touchDown :: (Int, Int) -> WD () +touchDown = doSessCommand POST "/touch/down" . pair ("x","y") + +-- |Emulates removing a finger from the screen at the given location. +touchUp :: (Int, Int) -> WD () +touchUp = doSessCommand POST "/touch/up" . pair ("x","y") + +-- |Emulates moving a finger on the screen to the given location. +touchMove :: (Int, Int) -> WD () +touchMove = doSessCommand POST "/touch/move" . pair ("x","y") + +-- |Emulate finger-based touch scroll. Use this function if you don't care where +-- the scroll begins +touchScroll :: (Int, Int) -> WD () +touchScroll = doSessCommand POST "/touch/scroll" . pair ("xoffset","yoffset") + +-- |Emulate finger-based touch scroll, starting from the given location relative +-- to the given element. +touchScrollFrom :: (Int, Int) -> Element -> WD () +touchScrollFrom (x, y) (Element e) = + doSessCommand POST "/touch/scroll" + . triple ("xoffset", "yoffset", "element") + $ (x, y, e) + +-- |Emulate a double click on a touch device. +touchDoubleClick :: Element -> WD () +touchDoubleClick (Element e) = doSessCommand POST "/touch/doubleclick" + . single "element" $ e + +-- |Emulate a long click on a touch device. +touchLongClick :: Element -> WD () +touchLongClick (Element e) = doSessCommand POST "/touch/longclick" + . single "element" $ e +-- |Emulate a flick on the touch screen. The coordinates indicate x and y +-- velocity, respectively. Use this function if you don't care where the +-- flick starts. +touchFlick :: (Int, Int) -> WD () +touchFlick = doSessCommand POST "/touch/flick" . pair ("xSpeed", "ySpeed") + +-- |Emulate a flick on the touch screen. +touchFlickFrom :: Int -- ^ flick velocity + -> (Int, Int) -- ^ a location relative to the given element + -> Element -- ^ the given element + -> WD () +touchFlickFrom s (x,y) (Element e) = + doSessCommand POST "/touch/flick" . object $ + ["xoffset" .= x + ,"yoffset" .= y + ,"speed" .= s + ,"element" .= e + ] + +-- |Get the current geographical location of the device. +getLocation :: WD (Int, Int, Int) +getLocation = doSessCommand GET "/location" () + >>= parseTriple "latitude" "longitude" "altitude" "getLocation" + +-- |Set the current geographical location of the device. +setLocation :: (Int, Int, Int) -> WD () +setLocation = doSessCommand POST "/location" . triple ("latitude", + "longitude", + "altitude") + diff --git a/Test/WebDriver/Commands/Internal.hs b/Test/WebDriver/Commands/Internal.hs new file mode 100644 --- /dev/null +++ b/Test/WebDriver/Commands/Internal.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} +module Test.WebDriver.Commands.Internal + ( RequestMethod(..), Header(..) + , module Test.WebDriver.Commands.Internal + ) where + +import Test.WebDriver.Types +import Test.WebDriver.Internal +import Data.Aeson +import Network.HTTP (RequestMethod(..), Header(..)) + +import qualified Data.Text as T +import Data.Text (Text) + +import Control.Monad.State.Strict (get) +import Control.Exception.Lifted (throwIO) + + +doCommand :: (ToJSON a, FromJSON b) => RequestMethod -> Text -> a -> WD b +doCommand = doCommand' [] + +doSessCommand :: (ToJSON a, FromJSON b) => RequestMethod -> Text -> a -> WD b +doSessCommand = doSessCommand' [] + +doElemCommand :: (ToJSON a, FromJSON b) => + RequestMethod -> Element -> Text -> a -> WD b +doElemCommand = doElemCommand' [] + +doWinCommand :: (ToJSON a, FromJSON b) => + RequestMethod -> WindowHandle -> Text -> a -> WD b +doWinCommand = doWinCommand' [] + +doCommand' :: (ToJSON a, FromJSON b) => + [Header] -> RequestMethod -> Text -> a -> WD b +doCommand' headers method path args = do + r <- mkRequest headers method path args + --liftIO . print $ r + handleHTTPErr r + --liftIO . print . rspBody $ r + handleHTTPResp r + +doSessCommand' :: (ToJSON a, FromJSON b) => + [Header] -> RequestMethod -> Text -> a -> WD b +doSessCommand' headers method path args = do + WDSession { wdSessId = mSessId } <- get + case mSessId of + Nothing -> throwIO . NoSessionId $ msg + where + msg = "No session ID found when making request for relative URL " + ++ show path + Just (SessionId sId) -> doCommand' headers method + (T.concat ["/session/", sId, path]) args + +doWinCommand' :: (ToJSON a, FromJSON b) => + [Header] -> RequestMethod -> WindowHandle -> Text -> a + -> WD b +doWinCommand' h m (WindowHandle w) path a = + doSessCommand' h m (T.concat ["/window/", w, path]) a + +doElemCommand' :: (ToJSON a, FromJSON b) => + [Header] -> RequestMethod -> Element -> Text -> a -> WD b +doElemCommand' h m (Element e) path a = + doSessCommand' h m (T.concat ["/element/", e, path]) a + diff --git a/Test/WebDriver/Commands/Wait.hs b/Test/WebDriver/Commands/Wait.hs new file mode 100644 --- /dev/null +++ b/Test/WebDriver/Commands/Wait.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} +module Test.WebDriver.Commands.Wait + ( -- * Expected conditions + ExpectFailed, expect, unexpected + -- ** Convenience functions + , expectAny, expectAll + , (<||>), (<&&>) + + -- * Wait on expected conditions + , waitUntil, waitUntil' + , waitWhile, waitWhile' + ) where +import Test.WebDriver.Types +import Control.Monad +import Control.Monad.IO.Class +import Control.Exception.Lifted +import Control.Concurrent +import Data.Time.Clock +import Data.Typeable +import Prelude hiding (catch) + +instance Exception ExpectFailed +-- |An exception representing a failure of an expected condition. +data ExpectFailed = ExpectFailed deriving (Show, Eq, Typeable) + +-- |Raises ExpectFailed. +unexpected :: WD a +unexpected = throwIO ExpectFailed + +-- |An expected condition. This function allows you to express assertions in +-- your explicit wait. This function raises 'ExpectFailed' if the given +-- boolean is False, and otherwise does nothing. +expect :: Bool -> WD () +expect b + | b = return () + | otherwise = unexpected + + +-- |Lifted boolean and +(<&&>) :: Monad m => m Bool -> m Bool -> m Bool +(<&&>) = liftM2 (&&) + +-- |Lifted boolean or +(<||>) :: Monad m => m Bool -> m Bool -> m Bool +(<||>) = liftM2 (||) + +expectAny :: (a -> WD Bool) -> [a] -> WD () +expectAny p xs = expect . or =<< mapM p xs + +expectAll :: (a -> WD Bool) -> [a] -> WD () +expectAll p xs = expect . and =<< mapM p xs + +-- |Wait until either the given action succeeds or the timeout is reached. +-- The action will be retried every .25 seconds until no ExpectFailed or +-- NoSuchElement exceptions occur. The timeout value is expressed in seconds. +waitUntil :: Double -> WD a -> WD a +waitUntil = waitUntil' 250000 + +-- |Similar to waitUntil but allows you to also specify the poll frequency +-- of the WD action. The frequency is expressed as an integer in microseconds. +waitUntil' :: Int -> Double -> WD a -> WD a +waitUntil' = wait' handler + where + handler retry = (`catches` [Handler handleFailedCommand + ,Handler handleExpectFailed] + ) + where + handleFailedCommand (FailedCommand NoSuchElement _) = retry + handleFailedCommand err = throwIO err + + handleExpectFailed (_ :: ExpectFailed) = retry + +-- |Like waitWhile, but retries the action until it fails or until the timeout +-- is exceeded. +waitWhile :: Double -> WD a -> WD () +waitWhile = waitWhile' 250000 + +-- |Like waitWhile', but retries the action until it either fails or +-- until the timeout is exceeded. +waitWhile' :: Int -> Double -> WD a -> WD () +waitWhile' = wait' handler + where + handler retry wd = do + void wd `catches` [Handler handleFailedCommand + ,Handler handleExpectFailed + ] + retry + where + handleFailedCommand (FailedCommand NoSuchElement _) = return () + handleFailedCommand err = throwIO err + + handleExpectFailed (_ :: ExpectFailed) = return () + +wait' :: (WD b -> WD a -> WD b) -> Int -> Double -> WD a -> WD b +wait' handler waitAmnt t wd = waitLoop =<< liftIO getCurrentTime + where timeout = realToFrac t + waitLoop startTime = handler retry wd + where + retry = do + now <- liftIO getCurrentTime + if diffUTCTime now startTime >= timeout + then + failedCommand Timeout "waitUntil': explicit wait timed out." + else do + liftIO . threadDelay $ waitAmnt + waitLoop startTime diff --git a/Test/WebDriver/Firefox/Profile.hs b/Test/WebDriver/Firefox/Profile.hs new file mode 100644 --- /dev/null +++ b/Test/WebDriver/Firefox/Profile.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE CPP, TypeSynonymInstances, OverloadedStrings, + GeneralizedNewtypeDeriving, DeriveDataTypeable #-} +-- |A module for working with Firefox profiles. Firefox profiles are manipulated +-- in pure code and then \"prepared\" for network transmission. +module Test.WebDriver.Firefox.Profile + ( -- * Profiles + FirefoxProfile(..), PreparedFirefoxProfile + -- * Preferences + , FirefoxPref(..), ToFirefox(..) + , addPref, getPref, deletePref + -- * Extensions + , addExtension, deleteExtension + -- * Loading and preparing profiles + , loadProfile, prepareProfile + , prepareTempProfile, prepareLoadedProfile + ) where +import Data.Aeson +import Data.Attoparsec.Text as AP +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import Data.Text (Text, pack) +import Data.Text.IO as TIO +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as SBS +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.ByteString.Base64 as B64 + +import Data.Fixed +import Data.Ratio +import Data.Int +import Data.Word +import Data.Char + +import System.IO +import System.FilePath hiding (hasExtension, addExtension) +import System.Directory +import System.IO.Temp +import Codec.Archive.Zip +import Distribution.Simple.Utils +import Distribution.Verbosity + +import Control.Monad +import Control.Applicative +import Control.Monad.IO.Class +import Control.Exception.Lifted +import Data.Typeable + +-- |A pure representation of a FirefoxProfile. This structure allows you to +-- construct and manipulate Firefox profiles in pure code, deferring execution +-- of IO operations until the profile is \"prepared\" using either +-- 'prepareProfile' or one of the wrapper functions 'prepareTempProfile' and +-- 'prepareLoadedProfile'. +data FirefoxProfile = FirefoxProfile + { -- |Location of the profile in the file system + profileDir :: FilePath + -- |A set of filepaths pointing to Firefox extensions. + -- These paths can either refer to an .xpi file + -- or an extension directory + , profileExts :: HS.HashSet FilePath + -- |A map of Firefox preferences. These are the settings + -- found in the profile's prefs.js, and entries found in + -- about:config + , profilePrefs :: HM.HashMap Text FirefoxPref + } + deriving (Eq, Show) + +-- |A Firefox preference. This is the subset of JSON values that excludes +-- arrays and objects. +data FirefoxPref = PrefInteger !Integer + | PrefDouble !Double + | PrefString !Text + | PrefBool !Bool + deriving (Eq, Show) + +instance ToJSON FirefoxPref where + toJSON v = case v of + PrefInteger i -> toJSON i + PrefDouble d -> toJSON d + PrefString s -> toJSON s + PrefBool b -> toJSON b + + +-- |Represents a Firefox profile that has been prepared for +-- network transmission. The profile cannot be modified in this form. +newtype PreparedFirefoxProfile = PreparedFirefoxProfile ByteString + deriving (Eq, Show, ToJSON, FromJSON) + + +instance Exception ProfileParseError +-- |An error occured while attempting to parse a profile's prefs.js file +newtype ProfileParseError = ProfileParseError String + deriving (Eq, Show, Read, Typeable) + +-- |A typeclass to convert types to Firefox preference values +class ToFirefox a where + toFirefox :: a -> FirefoxPref + +instance ToFirefox Text where + toFirefox = PrefString + +instance ToFirefox String where + toFirefox = toFirefox . pack + +instance ToFirefox Bool where + toFirefox = PrefBool + +instance ToFirefox Integer where + toFirefox = PrefInteger + +#define I(t) instance ToFirefox t where toFirefox = PrefInteger . toInteger + +I(Int) +I(Int8) +I(Int16) +I(Int32) +I(Int64) +I(Word) +I(Word8) +I(Word16) +I(Word32) +I(Word64) + +instance ToFirefox Double where + toFirefox = PrefDouble + +instance ToFirefox Float where + toFirefox = PrefDouble . realToFrac + +instance (Integral a) => ToFirefox (Ratio a) where + toFirefox = PrefDouble . realToFrac + +instance (HasResolution r) => ToFirefox (Fixed r) where + toFirefox = PrefDouble . realToFrac + +-- |Retrieve a preference from a profile by key name. +getPref :: Text -> FirefoxProfile -> Maybe FirefoxPref +getPref k (FirefoxProfile _ _ m) = HM.lookup k m + +-- |Add a new preference entry to a profile, overwriting any existing entry +-- with the same key. +addPref :: ToFirefox a => Text -> a -> FirefoxProfile -> FirefoxProfile +addPref k v p = asMap p $ HM.insert k (toFirefox v) + +-- |Delete an existing preference entry from a profile. This operation is +-- silent if the preference wasn't found. +deletePref :: Text -> FirefoxProfile -> FirefoxProfile +deletePref k p = asMap p $ HM.delete k + +-- |Add a new extension to the profile. The file path should refer to +-- an .xpi file or an extension directory. This operation has no effect if +-- the same extension has already been added to this profile. +addExtension :: FilePath -> FirefoxProfile -> FirefoxProfile +addExtension path p = asSet p $ HS.insert path + +-- |Delete an existing extension from the profile. The file path should refer +-- to an .xpi file or an extension directory. This operation has no effect if +-- the extension was never added to the profile. +deleteExtension :: FilePath -> FirefoxProfile -> FirefoxProfile +deleteExtension path p = asSet p $ HS.delete path + +asMap :: FirefoxProfile + -> (HM.HashMap Text FirefoxPref -> HM.HashMap Text FirefoxPref) + -> FirefoxProfile +asMap (FirefoxProfile p hs hm) f = FirefoxProfile p hs (f hm) + +asSet :: FirefoxProfile + -> (HS.HashSet FilePath -> HS.HashSet FilePath) + -> FirefoxProfile +asSet (FirefoxProfile p hs hm) f = FirefoxProfile p (f hs) hm + + +tempProfile :: MonadIO m => m FirefoxProfile +tempProfile = liftIO $ defaultProfile <$> mkTemp + +-- |Load an existing profile from the file system. Any prepared changes made to +-- the FirefoxProfile will have no effect to the profile on disk. +loadProfile :: MonadIO m => FilePath -> m FirefoxProfile +loadProfile path = liftIO $ do + FirefoxProfile{ profileDir = d } <- tempProfile + FirefoxProfile <$> pure d <*> getExtensions <*> getPrefs + where + extD = path "extensions" + userPref = path "prefs" <.> "js" + getExtensions = HS.fromList . filter (`elem` [".",".."]) + <$> getDirectoryContents extD + getPrefs = HM.fromList <$> (parsePrefs =<< TIO.readFile userPref) + + parsePrefs s = either (throwIO . ProfileParseError) + return + $ parseOnly prefsParser s + +-- |Prepare a FirefoxProfile for network transmission. +-- +-- Internally, this function constructs a Firefox profile within a temp +-- directory, archives it as a zip file, and then base64 encodes the zipped +-- data. The temporary directory is deleted afterwards +prepareProfile :: MonadIO m => FirefoxProfile -> m PreparedFirefoxProfile +prepareProfile FirefoxProfile {profileDir = d, profileExts = s, + profilePrefs = m} + = liftIO $ do + createDirectoryIfMissing False extensionD + extPaths <- mapM canonicalizePath . HS.toList $ s + forM_ extPaths installExtension + withFile userPrefs WriteMode writeUserPrefs + prof <- PreparedFirefoxProfile . B64.encode . SBS.concat . LBS.toChunks + . fromArchive + <$> addFilesToArchive [OptRecursive] emptyArchive [d] + removeDirectoryRecursive d + return prof + where + extensionD = d "extensions" + userPrefs = d "prefs" <.> "js" + + installExtension ePath = + case splitExtension ePath of + (_,".xpi") -> installOrdinaryFile silent ePath dest + _ -> installDirectoryContents silent ePath dest + where + dest = extensionD eFile + (_,eFile) = splitFileName ePath + + writeUserPrefs h = + forM_ (HM.toList m) $ \(k, v) -> + LBS.hPut h . LBS.concat + $ [ "user_pref(", encode k, ", ", encode v, ");\n"] + + +-- |Apply a function on an automatically generated default profile, and +-- prepare the result. The FirefoxProfile passed to the handler function is +-- the same one used by sessions when no Firefox profile is specified +prepareTempProfile :: MonadIO m => + (FirefoxProfile -> FirefoxProfile) + -> m PreparedFirefoxProfile +prepareTempProfile f = liftM f tempProfile >>= prepareProfile + +-- |Convenience function to load an existing Firefox profile from disk, apply +-- a handler function, and then prepare the result for network transmission. +prepareLoadedProfile :: MonadIO m => + FilePath + -> (FirefoxProfile -> FirefoxProfile) + -> m PreparedFirefoxProfile +prepareLoadedProfile path f = liftM f (loadProfile path) >>= prepareProfile + +defaultProfile :: FilePath -> FirefoxProfile +defaultProfile d = + FirefoxProfile d HS.empty + $ HM.fromList [("app.update.auto", PrefBool False) + ,("app.update.enabled", PrefBool False) + ,("browser.startup.page" , PrefInteger 0) + ,("browser.download.manager.showWhenStarting", PrefBool False) + ,("browser.EULA.override", PrefBool True) + ,("browser.EULA.3.accepted", PrefBool True) + ,("browser.link.open_external", PrefInteger 2) + ,("browser.link.open_newwindow", PrefInteger 2) + ,("browser.offline", PrefBool False) + ,("browser.safebrowsing.enabled", PrefBool False) + ,("browser.search.update", PrefBool False) + ,("browser.sessionstore.resume_from_crash", PrefBool False) + ,("browser.shell.checkDefaultBrowser", PrefBool False) + ,("browser.tabs.warnOnClose", PrefBool False) + ,("browser.tabs.warnOnOpen", PrefBool False) + ,("browser.startup.page", PrefInteger 0) + ,("browser.safebrowsing.malware.enabled", PrefBool False) + ,("startup.homepage_welcome_url", PrefString "about:blank") + ,("devtools.errorconsole.enabled", PrefBool True) + ,("focusmanager.testmode", PrefBool True) + ,("dom.disable_open_during_load", PrefBool False) + ,("extensions.autoDisableScopes" , PrefInteger 10) + ,("extensions.logging.enabled", PrefBool True) + ,("extensions.update.enabled", PrefBool False) + ,("extensions.update.notifyUser", PrefBool False) + ,("network.manage-offline-status", PrefBool False) + ,("network.http.max-connections-per-server", PrefInteger 10) + ,("network.http.phishy-userpass-length", PrefInteger 255) + ,("offline-apps.allow_by_default", PrefBool True) + ,("prompts.tab_modal.enabled", PrefBool False) + ,("security.fileuri.origin_policy", PrefInteger 3) + ,("security.fileuri.strict_origin_policy", PrefBool False) + ,("security.warn_entering_secure", PrefBool False) + ,("security.warn_submit_insecure", PrefBool False) + ,("security.warn_entering_secure.show_once", PrefBool False) + ,("security.warn_entering_weak", PrefBool False) + ,("security.warn_entering_weak.show_once", PrefBool False) + ,("security.warn_leaving_secure", PrefBool False) + ,("security.warn_leaving_secure.show_once", PrefBool False) + ,("security.warn_submit_insecure", PrefBool False) + ,("security.warn_viewing_mixed", PrefBool False) + ,("security.warn_viewing_mixed.show_once", PrefBool False) + ,("signon.rememberSignons", PrefBool False) + ,("toolkit.networkmanager.disable", PrefBool True) + ,("toolkit.telemetry.enabled", PrefBool False) + ,("toolkit.telemetry.prompted", PrefInteger 2) + ,("toolkit.telemetry.rejected", PrefBool True) + ,("javascript.options.showInConsole", PrefBool True) + ,("browser.dom.window.dump.enabled", PrefBool True) + ,("webdriver_accept_untrusted_certs", PrefBool True) + ,("webdriver_enable_native_events", native_events) + ,("webdriver_assume_untrusted_issuer", PrefBool True) + ,("dom.max_script_run_time", PrefInteger 30) + ] + where +#ifdef darwin_HOST_OS + native_events = PrefBool False +#else + native_events = PrefBool True +#endif + +mkTemp :: IO FilePath +mkTemp = do + d <- getTemporaryDirectory + createTempDirectory d "" + +-- firefox prefs.js parser + +prefsParser = many prefLine + +prefLine = do + padSpaces $ string "user_pref(" + k <- prefKey + padSpaces $ char ',' + v <- prefVal + padSpaces $ string ");" + endOfLine + return (k,v) + where + spaces = AP.takeWhile isSpace + padSpaces p = spaces >> p >> spaces + +prefKey = str +prefVal = boolVal <|> stringVal <|> intVal <|> doubleVal + where + boolVal = boolTrue <|> boolFalse + boolTrue = string "true" >> return (PrefBool True) + boolFalse = string "false" >> return (PrefBool False) + stringVal = PrefString <$> str + intVal = PrefInteger <$> signed decimal + doubleVal = PrefDouble <$> double + +str = char '"' >> AP.takeWhile (not . (=='"')) <* char '"' diff --git a/Test/WebDriver/Internal.hs b/Test/WebDriver/Internal.hs new file mode 100644 --- /dev/null +++ b/Test/WebDriver/Internal.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} +module Test.WebDriver.Internal + ( mkWDUri, mkRequest + , handleHTTPErr, handleJSONErr, handleHTTPResp + ) where + +import Test.WebDriver.Types +import Test.WebDriver.Types.Internal +import Test.WebDriver.JSON + +import Network.HTTP (simpleHTTP, Request(..), Response(..), RequestMethod(..)) +import Network.HTTP.Headers (findHeader, Header(..), HeaderName(..)) +import Network.URI +import Data.Aeson +import Data.Aeson.Types (emptyArray) + +import Data.Text (Text) +import qualified Data.Text as T +import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Data.ByteString.Lazy.Char8 as BS +import qualified Data.ByteString.Base64 as B64 +import qualified Data.Vector as V + +import Control.Applicative +import Control.Exception.Lifted (throwIO) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.State.Class (get) +import Data.List (isInfixOf) +import Data.Maybe (fromJust) -- used with relativeTo +import Data.String (fromString) + +mkWDUri :: String -> WD URI --todo: remove String :( +mkWDUri path = do + WDSession{wdHost = host, + wdPort = port + } <- get + let urlStr = "http://" ++ host ++ ":" ++ show port + relPath = "/wd/hub" ++ path + mBaseURI = parseAbsoluteURI urlStr + mRelURI = parseRelativeReference relPath + case (mBaseURI, mRelURI) of + (Nothing, _) -> throwIO $ InvalidURL urlStr + (_, Nothing) -> throwIO $ InvalidURL relPath + (Just baseURI, Just relURI) -> return . fromJust $ relURI `relativeTo` baseURI + +mkRequest :: ToJSON a => [Header] -> RequestMethod -> Text -> a -> WD (Response ByteString) +mkRequest headers method path args = do + uri <- mkWDUri (T.unpack path) + let body = case toJSON args of + Array v | V.null v -> "" --an ugly corner case to allow empty requests + other -> encode other + req = Request { rqURI = uri --todo: normalization of headers + , rqMethod = method + , rqBody = body + , rqHeaders = headers ++ [ Header HdrAccept + "application/json;charset=UTF-8" + , Header HdrContentType + "application/json;charset=UTF-8" + , Header HdrContentLength + . show . BS.length $ body + ] + } +-- liftIO . print $ req + liftIO (simpleHTTP req) >>= either (throwIO . HTTPConnError) return + + +handleHTTPErr :: Response ByteString -> WD () +handleHTTPErr r@Response{rspBody = body, rspCode = code, rspReason = reason} = + case code of + (4,_,_) -> err UnknownCommand + (5,_,_) -> + case findHeader HdrContentType r of + Just ct + | "application/json;" `isInfixOf` ct -> parseJSON' body + >>= handleJSONErr + | otherwise -> err ServerError + Nothing -> + err (ServerError . ("Missing content type. Server response: "++)) + + (2,_,_) -> return () + (3,0,2) -> return () + _ -> err (HTTPStatusUnknown code) + where + err errType = throwIO $ errType reason + +handleHTTPResp :: FromJSON a => Response ByteString -> WD a +handleHTTPResp resp@Response{rspBody = body, rspCode = code} = + case code of + (2,0,4) -> returnEmptyArray + (3,0,2) -> fromJSON' =<< maybe statusErr (return . String . fromString) + (findHeader HdrLocation resp) + where + statusErr = throwIO . HTTPStatusUnknown code + $ (BS.unpack body) + other + | BS.null body -> returnEmptyArray + | otherwise -> fromJSON' . rspVal =<< parseJSON' body + where + returnEmptyArray = fromJSON' emptyArray + +handleJSONErr :: WDResponse -> WD () +handleJSONErr WDResponse{rspStatus = 0} = return () +handleJSONErr WDResponse{rspVal = val, rspStatus = status} = do + sess <- get + errInfo <- fromJSON' val + let screen = B64.decodeLenient <$> errScreen errInfo + errInfo' = errInfo { errSessId = wdSessId sess + , errScreen = screen } + e errType = throwIO $ FailedCommand errType errInfo' + case status of + 7 -> e NoSuchElement + 8 -> e NoSuchFrame + 9 -> throwIO . UnknownCommand . errMsg $ errInfo + 10 -> e StaleElementReference + 11 -> e ElementNotVisible + 12 -> e InvalidElementState + 13 -> e UnknownError + 15 -> e ElementIsNotSelectable + 17 -> e JavascriptError + 19 -> e XPathLookupError + 21 -> e Timeout + 23 -> e NoSuchWindow + 24 -> e InvalidCookieDomain + 25 -> e UnableToSetCookie + 26 -> e UnexpectedAlertOpen + 27 -> e NoAlertOpen + 28 -> e ScriptTimeout + 29 -> e InvalidElementCoordinates + 30 -> e IMENotAvailable + 31 -> e IMEEngineActivationFailed + 32 -> e InvalidSelector + 34 -> e MoveTargetOutOfBounds + 51 -> e InvalidXPathSelector + 52 -> e InvalidXPathSelectorReturnType + 405 -> e MethodNotAllowed + _ -> e UnknownError diff --git a/Test/WebDriver/JSON.hs b/Test/WebDriver/JSON.hs new file mode 100644 --- /dev/null +++ b/Test/WebDriver/JSON.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} +-- |A collection of convenience functions for using and parsing JSON valus +-- within 'WD'. All monadic parse errors are converted to asynchronous +-- 'BadJSON' exceptions. +module Test.WebDriver.JSON + ( -- * Access a JSON object key + (!:) + -- * Conversion from JSON within WD + -- |Apostrophes are used to disambiguate these functions + -- from their "Data.Aeson" counterparts. + , parseJSON', fromJSON' + -- * Tuple functions + -- |Convenience functions for working with tuples. + + -- ** JSON object constructors + , single, pair, triple + -- ** Extracting JSON objects into tuples + , parsePair, parseTriple + -- * Conversion from parser results to WD + -- |These functions are used to implement the other functions + -- in this module, and could be used to implement other JSON + -- convenience functions + , apResultToWD, aesonResultToWD + ) where +import Test.WebDriver.Types + +import Data.Aeson as Aeson +import Data.Aeson.Types +import Data.Text (Text) +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.Attoparsec.ByteString.Lazy (Result(..)) +import qualified Data.Attoparsec.ByteString.Lazy as AP + +import Control.Applicative +import Control.Exception.Lifted +import Data.String + +-- |Construct a singleton JSON 'object' from a key and value. +single :: ToJSON a => Text -> a -> Value +single a x = object [a .= x] + +-- |Construct a 2-element JSON 'object' from a pair of keys and a pair of +-- values. +pair :: (ToJSON a, ToJSON b) => (Text,Text) -> (a,b) -> Value +pair (a,b) (x,y) = object [a .= x, b .= y] + +-- |Construct a 3-element JSON 'object' from a triple of keys and a triple of +-- values. +triple :: (ToJSON a, ToJSON b, ToJSON c) => + (Text,Text,Text) -> (a,b,c) -> Value +triple (a,b,c) (x,y,z) = object [a .= x, b.= y, c .= z] + + +-- |Parse a lazy 'ByteString' as a top-level JSON 'Value', then convert it to an +-- instance of 'FromJSON'.. +parseJSON' :: FromJSON a => ByteString -> WD a +parseJSON' = apResultToWD . AP.parse json + +-- |Convert a JSON 'Value' to an instance of 'FromJSON'. +fromJSON' :: FromJSON a => Value -> WD a +fromJSON' = aesonResultToWD . fromJSON + + + +-- |This operator is a wrapper over Aeson's '.:' operator. +(!:) :: FromJSON a => Object -> Text -> WD a +o !: k = aesonResultToWD $ parse (.: k) o + + +-- |Parse a JSON 'Object' as a pair. The first two string arguments specify the +-- keys to extract from the object. The fourth string is the name of the +-- calling function, for better error reporting. +parsePair :: (FromJSON a, FromJSON b) => + String -> String -> String -> Value -> WD (a, b) +parsePair a b funcName v = + case v of + Object o -> (,) <$> o !: fromString a <*> o !: fromString b + _ -> throwIO . BadJSON $ funcName ++ + ": cannot parse non-object JSON response as a (" ++ a + ++ ", " ++ b ++ ") pair" ++ ")" + + +-- |Parse a JSON Object as a triple. The first three string arguments +-- specify the keys to extract from the object. The fourth string is the name +-- of the calling function, for better error reporting. +parseTriple :: (FromJSON a, FromJSON b, FromJSON c) => + String -> String -> String -> String -> Value -> WD (a, b, c) +parseTriple a b c funcName v = + case v of + Object o -> (,,) <$> o !: fromString a + <*> o !: fromString b + <*> o !: fromString c + _ -> throwIO . BadJSON $ funcName ++ + ": cannot parse non-object JSON response as a (" ++ a + ++ ", " ++ b ++ ", " ++ c ++ ") pair" + + + +-- |Convert an attoparsec parser result to 'WD'. +apResultToWD :: FromJSON a => AP.Result Value -> WD a +apResultToWD p = case p of + Done _ res -> fromJSON' res + Fail _ _ err -> throwIO $ BadJSON err + +-- |Convert an Aeson parser result to 'WD'. +aesonResultToWD :: Aeson.Result a -> WD a +aesonResultToWD r = case r of + Success val -> return val + Error err -> throwIO $ BadJSON err diff --git a/Test/WebDriver/Types.hs b/Test/WebDriver/Types.hs new file mode 100644 --- /dev/null +++ b/Test/WebDriver/Types.hs @@ -0,0 +1,669 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, + TemplateHaskell, OverloadedStrings, ExistentialQuantification, + MultiParamTypeClasses, TypeFamilies, NoMonoLocalBinds #-} +{-# OPTIONS_HADDOCK not-home #-} +module Test.WebDriver.Types + ( -- * WebDriver sessions + WD(..), WDSession(..), defaultSession, SessionId(..) + -- * Capabilities and configuration + , Capabilities(..), defaultCaps, allCaps + , Platform(..), ProxyType(..) + -- ** Browser-specific configuration + , Browser(..), firefox, chrome, ie, opera, iPhone, iPad, android + -- * WebDriver objects and command-specific types + , Element(..) + , WindowHandle(..), currentWindow + , Cookie(..) + , Orientation(..) + , MouseButton(..) + , Selector(..) + , JSArg(..) + -- * Exceptions + , InvalidURL(..), NoSessionId(..), BadJSON(..) + , HTTPStatusUnknown(..), HTTPConnError(..) + , UnknownCommand(..), ServerError(..) + , FailedCommand(..), FailedCommandType(..) + , FailedCommandInfo(..), StackFrame(..) + , mkFailedCommandInfo, failedCommand + ) where + +import Test.WebDriver.Firefox.Profile +import Test.WebDriver.Chrome.Extension + +import Data.Aeson +import Data.Aeson.TH +import Data.Aeson.Types +import Network.Stream (ConnError) + + +import Data.Text as Text (toLower, toUpper) +import Data.Text (Text) +import Data.ByteString (ByteString) + +import Control.Exception.Lifted +import Data.Typeable +import Control.Applicative +import Control.Monad.State.Strict +import Control.Monad.Base +import Control.Monad.Trans.Control +import Data.Word +import Data.String +import Data.Default +import qualified Data.Char as C + + +{- |A monadic interface to the WebDriver server. This monad is a simple, strict +wrapper over 'IO', threading session information between sequential commands +-} +newtype WD a = WD (StateT WDSession IO a) + deriving (Functor, Monad, MonadState WDSession, MonadIO + ,Applicative) + +instance MonadBase IO WD where + liftBase = WD . liftBase + +instance MonadBaseControl IO WD where + data StM WD a = StWD {unStWD :: StM (StateT WDSession IO) a} + + liftBaseWith f = WD $ + liftBaseWith $ \runInBase -> + f (\(WD sT) -> liftM StWD . runInBase $ sT) + + restoreM = WD . restoreM . unStWD + +{- |An opaque identifier for a WebDriver session. These handles are produced by +the server on session creation, and act to identify a session in progress. -} +newtype SessionId = SessionId Text + deriving (Eq, Ord, Show, Read, + FromJSON, ToJSON) + + +{- |An opaque identifier for a browser window -} +newtype WindowHandle = WindowHandle Text + deriving (Eq, Ord, Show, Read, + FromJSON, ToJSON) +{- |An opaque identifier for a web page element. -} +newtype Element = Element Text + deriving (Eq, Ord, Show, Read) + +-- |A special 'WindowHandle' that always refers to the currently focused window. +currentWindow :: WindowHandle +currentWindow = WindowHandle "current" + +{- |Information about a WebDriver session. This structure is passed +implicitly through all 'WD' computations, and is also used to configure the 'WD' +monad before execution. -} +data WDSession = WDSession { + -- |Host name of the WebDriver server for this + -- session + wdHost :: String + -- |Port number of the server + , wdPort :: Word16 + -- |An opaque reference identifying the session. + -- A value of Nothing indicates that a session + -- hasn't been created yet. To create new sessions, + -- use the 'Test.WebDriver.Commands.createSession' + -- and 'Test.WebDriver.runSession' functions. + , wdSessId :: Maybe SessionId + } deriving (Eq, Show) + +instance Default WDSession where + def = WDSession { wdHost = "127.0.0.1" + , wdPort = 4444 + , wdSessId = Nothing + } + +{- |A default session connects to localhost on port 4444, and hasn't been +created yet. This value is the same as the 'def' with a more specific type. -} +defaultSession :: WDSession +defaultSession = def + + +{- |A structure describing the capabilities of a session. This record +serves dual roles. + +* It's used to specify the desired capabilities for a session before +it's created. In this usage, fields that are set to Nothing indicate +that we have no preference for that capability. + +* When returned by 'Test.WebDriver.Commands.getCaps', it's used to +describe the actual capabilities given to us by the WebDriver +server. Here a value of Nothing indicates that the server doesn't +support the capability. Thus, for Maybe Bool fields, both Nothing and +Just False indicate a lack of support for the desired capability. +-} +data Capabilities = Capabilities { -- |Browser choice and browser specific + -- settings. + browser :: Browser + -- |Browser version to use. + , version :: Maybe String + -- |Platform on which the browser should/will + -- run. + , platform :: Platform + -- |Proxy configuration. + , proxy :: ProxyType + , javascriptEnabled :: Maybe Bool + , takesScreenshot :: Maybe Bool + , handlesAlerts :: Maybe Bool + , databaseEnabled :: Maybe Bool + , locationContextEnabled :: Maybe Bool + , applicationCacheEnabled :: Maybe Bool + , browserConnectionEnabled :: Maybe Bool + , cssSelectorsEnabled :: Maybe Bool + , webStorageEnabled :: Maybe Bool + , rotatable :: Maybe Bool + , acceptSSLCerts :: Maybe Bool + , nativeEvents :: Maybe Bool + } deriving (Eq, Show) + +instance Default Capabilities where + def = Capabilities { browser = firefox + , version = Nothing + , platform = Any + , javascriptEnabled = Nothing + , takesScreenshot = Nothing + , handlesAlerts = Nothing + , databaseEnabled = Nothing + , locationContextEnabled = Nothing + , applicationCacheEnabled = Nothing + , browserConnectionEnabled = Nothing + , cssSelectorsEnabled = Nothing + , webStorageEnabled = Nothing + , rotatable = Nothing + , acceptSSLCerts = Nothing + , nativeEvents = Nothing + , proxy = UseSystemSettings + } + +-- |Default capabilities. This is the same as the 'Default' instance, but with +-- a more specific type. By default we use Firefox of an unspecified version +-- with default settings on whatever platform is available. +-- All Maybe Bool capabilities are set to Nothing (no preference). +defaultCaps :: Capabilities +defaultCaps = def + +-- |Same as 'defaultCaps', but with all Maybe Bool capabilities set to +-- Just True. +allCaps :: Capabilities +allCaps = defaultCaps { javascriptEnabled = Just True + , takesScreenshot = Just True + , handlesAlerts = Just True + , databaseEnabled = Just True + , locationContextEnabled = Just True + , applicationCacheEnabled = Just True + , browserConnectionEnabled = Just True + , cssSelectorsEnabled = Just True + , webStorageEnabled = Just True + , rotatable = Just True + , acceptSSLCerts = Just True + , nativeEvents = Just True + } + + +-- |Browser setting and browser-specific capabilities. +data Browser = Firefox { -- |The firefox profile to use. If Nothing, a + -- a default temporary profile is automatically created + -- and used. + ffProfile :: Maybe PreparedFirefoxProfile + -- |Firefox logging preference + , ffLogPref :: Maybe FFLogPref + -- |Path to Firefox binary. If Nothing, use a sensible + -- system-based default. + , ffBinary :: Maybe FilePath + } + | Chrome { chromeDriverVersion :: Maybe String + -- |Path to Chrome binary. If Nothing, use a sensible + -- system-based default. + , chromeBinary :: Maybe FilePath + -- |A list of command-line options to pass to the + -- Chrome binary. + , chromeOptions :: [String] + -- |A list of extensions to use. + , chromeExtensions :: [ChromeExtension] + } + | IE { ignoreProtectedModeSettings :: Bool + --, useLegacyInternalServer :: Bool + } + | Opera -- ^ Opera-specific configuration coming soon! + | HTMLUnit + | IPhone + | IPad + | Android + deriving (Eq, Show) + +-- |Default Firefox settings. All fields are set to Nothing. +firefox :: Browser +firefox = Firefox Nothing Nothing Nothing + +-- |Default Chrome settings. All Maybe fields are set to Nothing, no options are +-- specified, and no extensions are used. +chrome :: Browser +chrome = Chrome Nothing Nothing [] [] + +-- |Default IE settings. 'ignoreProtectedModeSettings' is set to True. +ie :: Browser +ie = IE True + +opera :: Browser +opera = Opera + +--safari :: Browser +--safari = Safari + +htmlUnit :: Browser +htmlUnit = HTMLUnit + +iPhone :: Browser +iPhone = IPhone + +iPad :: Browser +iPad = IPad + +android :: Browser +android = Android + + +-- |Represents platform options supported by WebDriver. The value Any represents +-- no preference. +data Platform = Windows | XP | Vista | Mac | Linux | Unix | Any + deriving (Eq, Show, Ord, Bounded, Enum) + +-- |Available settings for the proxy 'Capabilities' field +data ProxyType = NoProxy + | UseSystemSettings + | AutoDetect + -- |Use a proxy auto-config file specified by URL + | PAC { autoConfigUrl :: String } + -- |Manually specify proxy hosts as hostname:port strings. + -- Note that behavior is undefined for empty strings. + | Manual { ftpProxy :: String + , sslProxy :: String + , httpProxy :: String + } + deriving (Eq, Show) + + +-- |For Firefox sessions; indicates Firefox's log level +data FFLogPref = LogOff | LogSevere | LogWarning | LogInfo | LogConfig + | LogFine | LogFiner | LogFinest | LogAll + deriving (Eq, Show, Ord, Bounded, Enum) + + +instance Exception InvalidURL +-- |An invalid URL was given +newtype InvalidURL = InvalidURL String + deriving (Eq, Show, Typeable) + +instance Exception NoSessionId +-- |A command requiring a session ID was attempted when no session ID was +-- available. +newtype NoSessionId = NoSessionId String + deriving (Eq, Show, Typeable) + +instance Exception BadJSON +-- |An error occured when parsing a JSON value. +newtype BadJSON = BadJSON String + deriving (Eq, Show, Typeable) + +instance Exception HTTPStatusUnknown +-- |An unexpected HTTP status was sent by the server. +data HTTPStatusUnknown = HTTPStatusUnknown (Int, Int, Int) String + deriving (Eq, Show, Typeable) + +instance Exception HTTPConnError +-- |HTTP connection errors. +newtype HTTPConnError = HTTPConnError ConnError + deriving (Eq, Show, Typeable) + +instance Exception UnknownCommand +-- |A command was sent to the WebDriver server that it didn't recognize. +newtype UnknownCommand = UnknownCommand String + deriving (Eq, Show, Typeable) + +instance Exception ServerError +-- |A server-side exception occured +newtype ServerError = ServerError String + deriving (Eq, Show, Typeable) + +instance Exception FailedCommand +-- |This exception encapsulates many different kinds of exceptions that can +-- occur when a command fails. +data FailedCommand = FailedCommand FailedCommandType FailedCommandInfo + deriving (Eq, Show, Typeable) + +-- |The type of failed command exception that occured. +data FailedCommandType = NoSuchElement + | NoSuchFrame + | UnknownFrame + | StaleElementReference + | ElementNotVisible + | InvalidElementState + | UnknownError + | ElementIsNotSelectable + | JavascriptError + | XPathLookupError + | Timeout + | NoSuchWindow + | InvalidCookieDomain + | UnableToSetCookie + | UnexpectedAlertOpen + | NoAlertOpen + | ScriptTimeout + | InvalidElementCoordinates + | IMENotAvailable + | IMEEngineActivationFailed + | InvalidSelector + | MoveTargetOutOfBounds + | InvalidXPathSelector + | InvalidXPathSelectorReturnType + | MethodNotAllowed + deriving (Eq, Ord, Enum, Bounded, Show) + +-- |Detailed information about the failed command provided by the server. +data FailedCommandInfo = FailedCommandInfo { errMsg :: String + , errSessId :: Maybe SessionId + , errScreen :: Maybe ByteString + , errClass :: Maybe String + , errStack :: [StackFrame] + } + deriving (Eq) + + +-- |Constructs a FailedCommandInfo from only an error message. +mkFailedCommandInfo :: String -> FailedCommandInfo +mkFailedCommandInfo m = FailedCommandInfo {errMsg = m + , errSessId = Nothing + , errScreen = Nothing + , errClass = Nothing + , errStack = [] + } + +-- |Convenience function to throw a 'FailedCommand' locally with no server-side +-- info present. +failedCommand :: FailedCommandType -> String -> WD a +failedCommand t m = throwIO . FailedCommand t =<< getCmdInfo + where getCmdInfo = do + sessId <- wdSessId <$> get + return $ (mkFailedCommandInfo m) { errSessId = sessId } + +-- |An individual stack frame from the stack trace provided by the server +-- during a FailedCommand. +data StackFrame = StackFrame { sfFileName :: String + , sfClassName :: String + , sfMethodName :: String + , sfLineNumber :: Word + } + deriving (Show, Eq) + +-- |Cookies are delicious delicacies. +data Cookie = Cookie { cookName :: Text + , cookValue :: Text + , cookPath :: Maybe Text + , cookDomain :: Maybe Text + , cookSecure :: Maybe Bool + , cookExpiry :: Maybe Integer + } deriving (Eq, Show) + +-- |Specifies element(s) within a DOM tree using various selection methods. +data Selector = ById Text + | ByName Text + | ByClass Text -- ^ (Note: multiple classes are not + -- allowed. For more control, use ByCSS) + | ByTag Text + | ByLinkText Text + | ByPartialLinkText Text + | ByCSS Text + | ByXPath Text + deriving (Eq, Show, Ord) + +-- |An existential wrapper for any 'ToJSON' instance. This allows us to pass +-- parameters of many different types to Javascript code. +data JSArg = forall a. ToJSON a => JSArg a + +-- |A screen orientation +data Orientation = Landscape | Portrait + deriving (Eq, Show, Ord, Bounded, Enum) + +-- |A mouse button +data MouseButton = LeftButton | MiddleButton | RightButton + deriving (Eq, Show, Ord, Bounded, Enum) + + + +instance Show FailedCommandInfo where --todo: pretty print + show i = showString "{errMsg = " . shows (errMsg i) + . showString ", errSessId = " . shows (errSessId i) + . showString ", errScreen = " . screen + . showString ", errClass = " . shows (errClass i) + . showString ", errStack = " . shows (errStack i) + $ "}" + where screen = showString $ case errScreen i of + Just _ -> "Just \"...\"" + Nothing -> "Nothing" + + +instance FromJSON Element where + parseJSON (Object o) = Element <$> o .: "ELEMENT" + parseJSON v = typeMismatch "Element" v + +instance ToJSON Element where + toJSON (Element e) = object ["ELEMENT" .= e] + + +instance ToJSON Capabilities where + toJSON c = object $ [ "browserName" .= browser' + , f version "version" + , f platform "platform" + , f proxy "proxy" + , f javascriptEnabled "javascriptEnabled" + , f takesScreenshot "takesScreenshot" + , f handlesAlerts "handlesAlerts" + , f databaseEnabled "databaseEnabled" + , f locationContextEnabled "locationContextEnabled" + , f applicationCacheEnabled "applicationCacheEnabled" + , f browserConnectionEnabled "browserConnectionEnabled" + , f cssSelectorsEnabled "cssSelectorsEnabled" + , f webStorageEnabled "webStorableEnabled" + , f rotatable "rotatable" + , f acceptSSLCerts "acceptSslCerts" + , f nativeEvents "nativeEvents" + ] + ++ browserInfo + where + browser' = browser c + browserInfo = case browser' of + Firefox {ffProfile = prof, ffLogPref = pref, ffBinary = bin } + -> ["firefox_profile" .= prof + ,"loggingPrefs" .= pref + ,"firefox_binary" .= bin + ] + Chrome {chromeDriverVersion = v, chromeBinary = b, + chromeOptions = o, chromeExtensions = e} + -> ["chrome.chromedriverVersion" .= v + ,"chrome.binary" .= b + ,"chrome.switches" .= o + ,"chrome.extensions" .= e + ] + IE {ignoreProtectedModeSettings = i{-, useLegacyInternalServer = u-}} + -> ["IgnoreProtectedModeSettings" .= i + --,"useLegacyInternalServer" .= u + ] + _ -> [] + f :: ToJSON a => (Capabilities -> a) -> Text -> Pair + f field key = key .= field c + +instance FromJSON Capabilities where + parseJSON (Object o) = Capabilities <$> req "browserName" + <*> opt "version" Nothing + <*> req "platform" + <*> opt "proxy" NoProxy + <*> b "javascriptEnabled" + <*> b "takesScreenshot" + <*> b "handlesAlerts" + <*> b "databaseEnabled" + <*> b "locationContextEnabled" + <*> b "applicationCacheEnabled" + <*> b "browserConnectionEnabled" + <*> b "cssSelectorEnabled" + <*> b "webStorageEnabled" + <*> b "rotatable" + <*> b "acceptSslCerts" + <*> b "nativeEvents" + where req :: FromJSON a => Text -> Parser a + req = (o .:) -- required field + opt :: FromJSON a => Text -> a -> Parser a + opt k d = o .:? k .!= d -- optional field + b :: Text -> Parser (Maybe Bool) + b k = opt k Nothing -- Maybe Bool field + parseJSON v = typeMismatch "Capabilities" v + +instance FromJSON FailedCommandInfo where + parseJSON (Object o) = + FailedCommandInfo <$> (req "message" >>= maybe (return "") return) + <*> pure Nothing + <*> opt "screen" Nothing + <*> opt "class" Nothing + <*> opt "stackTrace" [] + where --req :: FromJSON a => Text -> Parser a + req = (o .:) --required key + --opt :: FromJSON a => Text -> a -> Parser a + opt k d = o .:? k .!= d --optional key + parseJSON v = typeMismatch "FailedCommandInfo" v + +instance FromJSON StackFrame where + parseJSON (Object o) = StackFrame <$> reqStr "fileName" + <*> reqStr "className" + <*> reqStr "methodName" + <*> req "lineNumber" + where req :: FromJSON a => Text -> Parser a + req = (o .:) -- all keys are required + reqStr :: Text -> Parser String + reqStr k = req k >>= maybe (return "") return + parseJSON v = typeMismatch "StackFrame" v + +$( deriveToJSON (map C.toLower . drop 4) ''Cookie ) + +$( deriveJSON (map C.toUpper . drop 3) ''FFLogPref ) + +instance FromJSON Cookie where + parseJSON (Object o) = Cookie <$> req "name" + <*> req "value" + <*> opt "path" Nothing + <*> opt "domain" Nothing + <*> opt "secure" Nothing + <*> opt "expiry" Nothing + where + req :: FromJSON a => Text -> Parser a + req = (o .:) + opt :: FromJSON a => Text -> a -> Parser a + opt k d = o .:? k .!= d + parseJSON v = typeMismatch "Cookie" v + + +instance ToJSON Browser where + toJSON Firefox {} = String "firefox" + toJSON b = String . f . toLower . fromString . show $ b + where f "ie" = "internet explorer" + f x = x + +instance FromJSON Browser where + parseJSON (String jStr) = case toLower jStr of + "firefox" -> return firefox + "chrome" -> return chrome + "internet explorer" -> return ie + "opera" -> return opera + -- "safari" -> return safari + "iphone" -> return iPhone + "ipad" -> return iPad + "android" -> return android + "htmlunit" -> return htmlUnit + err -> fail $ "Invalid Browser string " ++ show err + parseJSON v = typeMismatch "Browser" v + +instance ToJSON Platform where + toJSON = String . toUpper . fromString . show + +instance FromJSON Platform where + parseJSON (String jStr) = case toLower jStr of + "windows" -> return Windows + "xp" -> return XP + "vista" -> return Vista + "mac" -> return Mac + "linux" -> return Linux + "unix" -> return Unix + "any" -> return Any + err -> fail $ "Invalid Platform string " ++ show err + parseJSON v = typeMismatch "Platform" v + +instance ToJSON Orientation where + toJSON = String . toUpper . fromString . show + +instance FromJSON Orientation where + parseJSON (String jStr) = case toLower jStr of + "landscape" -> return Landscape + "portrait" -> return Portrait + err -> fail $ "Invalid Orientation string " ++ show err + parseJSON v = typeMismatch "Orientation" v + +instance ToJSON MouseButton where + toJSON = String . toUpper . fromString . show + +instance FromJSON MouseButton where + parseJSON (String jStr) = case toLower jStr of + "left" -> return LeftButton + "middle" -> return MiddleButton + "right" -> return RightButton + err -> fail $ "Invalid MouseButton string " ++ show err + parseJSON v = typeMismatch "MouseButton" v + + +instance FromJSON ProxyType where + parseJSON (Object obj) = do + let f :: FromJSON a => Text -> Parser a + f = (obj .:) + pTyp <- f "proxyType" + case toLower pTyp of + "direct" -> return NoProxy + "system" -> return UseSystemSettings + "pac" -> PAC <$> f "autoConfigUrl" + "manual" -> Manual <$> f "ftpProxy" + <*> f "sslProxy" + <*> f "httpProxy" + _ -> fail $ "Invalid ProxyType " ++ show pTyp + parseJSON v = typeMismatch "ProxyType" v + +instance ToJSON ProxyType where + toJSON pt = object $ case pt of + NoProxy -> + ["proxyType" .= ("DIRECT" :: String)] + UseSystemSettings -> + ["proxyType" .= ("SYSTEM" :: String)] + AutoDetect -> + ["proxyType" .= ("AUTODETECT" :: String)] + PAC{autoConfigUrl = url} -> + ["proxyType" .= ("PAC" :: String) + ,"autoConfigUrl" .= url + ] + Manual{ftpProxy = ftp, sslProxy = ssl, httpProxy = http} -> + ["proxyType" .= ("MANUAL" :: String) + ,"ftpProxy" .= ftp + ,"sslProxy" .= ssl + ,"httpProxy" .= http + ] + +instance ToJSON Selector where + toJSON s = case s of + ById t -> selector "id" t + ByName t -> selector "name" t + ByClass t -> selector "class name" t + ByTag t -> selector "tag name" t + ByLinkText t -> selector "link text" t + ByPartialLinkText t -> selector "partial link text" t + ByCSS t -> selector "css selector" t + ByXPath t -> selector "xpath" t + where + selector :: Text -> Text -> Value + selector sn t = object ["using" .= sn, "value" .= t] + +instance ToJSON JSArg where + toJSON (JSArg a) = toJSON a diff --git a/Test/WebDriver/Types/Internal.hs b/Test/WebDriver/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/Test/WebDriver/Types/Internal.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction #-} +module Test.WebDriver.Types.Internal + ( WDResponse(..) + ) where + +import Test.WebDriver.Types + +import Data.Aeson +import Data.Aeson.Types + +import Control.Applicative +import Data.Word + + +data WDResponse = WDResponse { rspSessId :: Maybe SessionId + , rspStatus :: Word8 + , rspVal :: Value + } + deriving (Eq, Show) + +instance FromJSON WDResponse where + parseJSON (Object o) = WDResponse <$> req "sessionId" + <*> req "status" + <*> opt "value" Null + where req = (o .:) + opt k d = o .: k .!= d + parseJSON v = typeMismatch "WDResponse" v diff --git a/webdriver.cabal b/webdriver.cabal new file mode 100644 --- /dev/null +++ b/webdriver.cabal @@ -0,0 +1,68 @@ +Name: webdriver +Version: 0 +Stability: alpha +Cabal-Version: >= 1.6 +License: BSD3 +License-File: LICENSE +Author: Adam Curtis +Maintainer: acurtis@spsu.edu +Homepage: https://github.com/kallisti-dev/hs-webdriver +Category: Web, Browser, Testing +Synopsis: a Haskell client for the Selenium WebDriver protocol +Build-type: Simple +Extra-source-files: README.md +Description: + A Selenium WebDriver client for the Haskell + programming language. You can use it to automate browser + sessions for testing, system administration, etc. + + For more information about Selenium itself, see + + + +source-repository this + type: git + location: git://github.com/kallisti-dev/hs-webdriver.git + tag: 0 + +source-repository head + type: git + location: git://github.com/kallisti-dev/hs-webdriver.git + +library + build-depends: base == 4.* + , aeson == 0.6.* + , HTTP >= 4000.1 && < 4000.3 + , mtl >= 2.0 && < 2.2 + , network == 2.3.* + , bytestring == 0.9.* + , text >= 0.7 && < 0.12 + , time == 1.2.* + , transformers == 0.2.* + , Cabal >= 1.6 + , zip-archive >= 0.1.1.7 + , directory == 1.* + , filepath >=1.1 && <1.3 + , unordered-containers >= 0.1.3 + , attoparsec == 0.10.* + , monad-control == 0.3.* + , transformers-base == 0.4.* + , vector == 0.9.* + , lifted-base == 0.1.* + , data-default + , base64-bytestring + , temporary == 1.1.* + + exposed-modules: Test.WebDriver + Test.WebDriver.Commands + Test.WebDriver.Commands.Wait + Test.WebDriver.Commands.Internal + Test.WebDriver.Firefox.Profile + Test.WebDriver.Chrome.Extension + Test.WebDriver.Types + Test.WebDriver.JSON + + other-modules: Test.WebDriver.Internal + Test.WebDriver.Types.Internal + + ghc-options: -Wall