webdriver (empty) → 0

raw patch · 14 files changed

+2167/−0 lines, 14 filesdep +Cabaldep +HTTPdep +aesonsetup-changed

Dependencies added: Cabal, HTTP, aeson, attoparsec, base, base64-bytestring, bytestring, data-default, directory, filepath, lifted-base, monad-control, mtl, network, temporary, text, time, transformers, transformers-base, unordered-containers, vector, zip-archive

Files

• LICENSE +25/−0
• README.md +41/−0
• Setup.hs +2/−0
• Test/WebDriver.hs +60/−0
• Test/WebDriver/Chrome/Extension.hs +23/−0
• Test/WebDriver/Commands.hs +498/−0
• Test/WebDriver/Commands/Internal.hs +64/−0
• Test/WebDriver/Commands/Wait.hs +106/−0
• Test/WebDriver/Firefox/Profile.hs +339/−0
• Test/WebDriver/Internal.hs +136/−0
• Test/WebDriver/JSON.hs +109/−0
• Test/WebDriver/Types.hs +669/−0
• Test/WebDriver/Types/Internal.hs +27/−0
• webdriver.cabal +68/−0

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

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

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

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

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

@@ -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 +-- <http://code.google.com/p/selenium/wiki/JsonWireProtocol#/status>+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 +-- <http://code.google.com/p/selenium/wiki/JsonWireProtocol#/session/:sessionId/element/:id/value>+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")+

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

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

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

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

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

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

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

@@ -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+        <http://seleniumhq.org/>+++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