packages feed

webdriver 0.2 → 0.3

raw patch · 28 files changed

+2555/−2203 lines, 28 files

Files

+ .ghci view
@@ -0,0 +1,2 @@+:set -XOverloadedStrings+:m Test.WebDriver Data.Default
CHANGELOG.md view
@@ -1,10 +1,26 @@ #Change Log +## hs-webdriver 0.3 ++### API changes+* 2 typeclasses were introduced. All WebDriver commands are now overloaded on WebDriver class, so that monad transformers with a WD base can be used conveniently.+* The MonadState instance of WD has been removed and replaced by SessionState.+* The Firefox profile code has been generalized to work with either Opera or Firefox profiles. A phantom type parameter is used to create a distinction between the two. See documentation on Common.Profile and Firefox.Profile to learn about the specific changes that were made.+* FFLogPref is now removed and replaced by the LogPref type, because both Firefox and Opera config use the same logging preference values.+* Several new modules have been created, including: Capabilities, Monad, Classes, Exceptions. Many of the definitions have been moved around, but the export lists of the pre-existing modules are the same.++### Bug fixes+* Various issues with the serialization of capabilities meant that Chrome, IE, and Opera weren't able to startup correctly with default capabilities. This is now fixed.++### new features+* General documentation improvements.+* Opera configuration is now implemented.+ ## hs-webdriver 0.2  ### API changes * FailedCommandInfo changed so that it stores a WDSession rather than just a Maybe SessionId, thus providing server host and port information as well as the session ID.-* As a result, mkFailedcommandInfo is now String -> WD FailedCommandInfo, since it requires access to the WDSession state.+* As a result, mkFailedCommandInfo is now String -> WD FailedCommandInfo, since it requires access to the WDSession state. * HTML5StorageType changed to the more accurate WebStorageType  ### new features
README.md view
@@ -14,7 +14,7 @@ ```sh cabal install webdriver ```-There are also options to do system-wide installation, version selection, and other build options. See Cabal documentation.+There are also options to do system-wide installation, version selection, and other build options; see cabal-install documentation.  ## Installation from this repository
TODO view
@@ -1,23 +1,16 @@-for next minor releases---- add special web-driver specific FF profile setters, either as special-functions or via documentation---- add opera config+for next release --- improve documentation. Document errors better. Provide more-module introductions+-- improve documentation. Document errors.   -- provide examples     -- basic runSession usage     -- intermediate usage+    -- exception handling with lifted-base     -- explicit waits usage     -- firefox profile usage     -- REPL usage - for 1.0 --- overload WD commands in typeclass -- add WDSettings, use WDSession as internal State type.  -- allow settings to automatically load drivers. add modules with driver loading functions@@ -25,9 +18,15 @@   -miscellaneous unsorted+distant future  -- use http-conduit and attoparsec-conduit to stream JSON data. use request methods from http-types  -- use ReaderT to store WDVersion for use with implicit configurations. ++misc. unsorted++-- remove temporary directory code from prepareProfile++--Use lazy ByteString where possible. patch base64-bytestring to work with lazy bytestrings
− Test/WebDriver.hs 
@@ -1,60 +0,0 @@-{-| -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
− Test/WebDriver/Chrome/Extension.hs 
@@ -1,23 +0,0 @@-{-# 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
− Test/WebDriver/Commands.hs 
@@ -1,565 +0,0 @@-{-# 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, setPageLoadTimeout-         -- * 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, closeWindow, windows, focusWindow,  maximize-       , getWindowSize, setWindowSize, getWindowPos, setWindowPos-         -- * Focusing on frames-       , focusFrame, FrameSelector(..)-         -- * Cookies-       , Cookie(..), mkCookie-       , cookies, setCookie, deleteCookie, deleteVisibleCookies-         -- * Alerts-       , getAlertText, replyToAlert, acceptAlert, dismissAlert-         -- * Mouse gestures                                          -       , moveTo, moveToCenter, moveToFrom-       , clickWith, MouseButton(..)-       , mouseDown, mouseUp, withMouseDown, doubleClick-         -- * Screen orientation-       , Orientation(..)-       , getOrientation, setOrientation-         -- * Geo-location-       , getLocation, setLocation-         -- * HTML 5 Web Storage-       , storageSize, getAllKeys, deleteAllKeys, getKey, setKey, deleteKey-         -- * Uploading files to remote server-         -- |These functions allow you to upload a file to a remote server. -         -- Note that this operation isn't supported by all WebDriver servers,-         -- and the location where the file is stored is not standardized.-       , uploadFile, uploadRawFile, uploadZipEntry-         -- * Touch gestures-       , touchClick, touchDown, touchUp, touchMove-       , touchScroll, touchScrollFrom, touchDoubleClick-       , touchLongClick, touchFlick, touchFlickFrom-         -- * 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 as SBS (ByteString, concat)-import Data.ByteString.Base64 as B64-import Data.ByteString.Lazy as LBS (ByteString, toChunks)-import Network.URI-import Codec.Archive.Zip--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---- |Sets the amount of time to wait for a page to finish loading before throwing a 'Timeout' exception-setPageLoadTimeout :: Integer -> WD ()-setPageLoadTimeout ms = doSessCommand POST "/timeouts" params-  where params = object ["type" .= ("page load" :: String)-                        ,"ms"   .= ms ]---- |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 SBS.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" ()---- |Switch focus to the frame specified by the FrameSelector.-focusFrame :: FrameSelector -> WD ()-focusFrame s = doSessCommand POST "/frame" . single "id" $ s ---- |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" ()--focusWindow :: WindowHandle -> WD ()-focusWindow w = doSessCommand POST "/window" . single "name" $ w---- |Closes the given window-closeWindow :: WindowHandle -> WD ()-closeWindow = doSessCommand DELETE "/window" . single "name"---- |Maximizes the current  window if not already maximized-maximize :: WD ()-maximize = doWinCommand GET currentWindow "/maximize" ()---- |Get the dimensions of the current window.-getWindowSize :: WD (Word, Word)-getWindowSize = doWinCommand GET currentWindow "/size" () -                >>= parsePair "width" "height" "getWindowSize"---- |Set the dimensions of the current window.-setWindowSize :: (Word, Word) -> WD ()-setWindowSize = doWinCommand POST currentWindow "/size" -                . pair ("width", "height")---- |Get the coordinates of the current window.-getWindowPos :: WD (Int, Int)-getWindowPos = doWinCommand GET currentWindow "/position" () -               >>= parsePair "x" "y" "getWindowPos"---- |Set the coordinates of the current window.-setWindowPos :: (Int, Int) -> WD ()-setWindowPos = doWinCommand POST currentWindow "/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")---- |Uploads a file from the local filesystem by its file path.-uploadFile :: FilePath -> WD ()-uploadFile path = uploadZipEntry =<< liftIO (readEntry [] path)-  --- |Uploads a raw bytestring with associated file info.-uploadRawFile :: FilePath          -- ^File path to use with this bytestring.-                 -> Integer        -- ^Modification time -                                   -- (in seconds since Unix epoch).-                 -> LBS.ByteString -- ^ The file contents as a lazy ByteString-                 -> WD ()-uploadRawFile path t str = uploadZipEntry (toEntry path t str)----- |Lowest level interface to the file uploading mechanism.--- This allows you to specify the exact details of--- the zip entry sent across network.-uploadZipEntry :: Entry -> WD ()-uploadZipEntry = doSessCommand POST "/file" . single "file" -                 . B64.encode . SBS.concat . toChunks -                 . fromArchive . (`addEntryToArchive` emptyArchive)---- |Get the current number of keys in a web storage area.-storageSize :: WebStorageType -> WD Integer-storageSize s = doStorageCommand GET s "/size" ()---- |Get a list of all keys from a web storage area.-getAllKeys :: WebStorageType -> WD [Text]-getAllKeys s = doStorageCommand GET s "" ()---- |Delete all keys within a given web storage area.-deleteAllKeys :: WebStorageType -> WD ()-deleteAllKeys s = doStorageCommand DELETE s "" ()---- |Get the value associated with a key in the given web storage area.--- Unset keys result in empty strings, since the Web Storage spec--- makes no distinction between the empty string and an undefined value.-getKey :: WebStorageType -> Text ->  WD Text-getKey s k = doStorageCommand GET s ("/key/" `T.append` k) ()---- |Set a key in the given web storage area.-setKey :: WebStorageType -> Text -> Text -> WD Text-setKey s k v = doStorageCommand POST s "" . object $ ["key"   .= k,-                                                      "value" .= v ]--- |Delete a key in the given web storage area. -deleteKey :: WebStorageType -> Text -> WD ()-deleteKey s k = doStorageCommand POST s ("/key/" `T.append` k) ()
− Test/WebDriver/Commands/Internal.hs 
@@ -1,75 +0,0 @@-{-# 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' []--doStorageCommand :: (ToJSON a, FromJSON b) =>-                    RequestMethod -> WebStorageType -> Text -> a -> WD b-doStorageCommand = doStorageCommand' []--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--doStorageCommand' :: (ToJSON a, FromJSON b) =>-                     [Header] -> RequestMethod -> WebStorageType -> Text -> a-                     -> WD b-doStorageCommand' h m s path a = doSessCommand' h m (T.concat ["/", s', path]) a-  where s' = case s of-          LocalStorage -> "local_storage"-          SessionStorage -> "session_storage"
− Test/WebDriver/Commands/Wait.hs 
@@ -1,112 +0,0 @@-{-# 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 the failure of an expected condition.-data ExpectFailed = ExpectFailed deriving (Show, Eq, Typeable)---- |throws 'ExpectFailed'. This is nice for writing your own abstractions.-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 (||)----- |Apply a predicate to every element in a list, and expect that at least one--- succeeds.-expectAny :: (a -> WD Bool) -> [a] -> WD ()-expectAny p xs = expect . or =<< mapM p xs---- |Apply a predicate to every element in a list, and expect that all succeed.-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. If the timeout is reached, then a --- 'Test.WebDriver.Timeout' exception will be raised. 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 'waitUntil', but retries the action until it fails or until the timeout--- is exceeded.-waitWhile :: Double -> WD a -> WD ()-waitWhile = waitWhile' 250000---- |Like 'waitUntil\'', 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
− Test/WebDriver/Firefox/Profile.hs 
@@ -1,340 +0,0 @@-{-# LANGUAGE CPP, TypeSynonymInstances, OverloadedStrings,-             GeneralizedNewtypeDeriving, DeriveDataTypeable,-             FlexibleInstances #-}--- |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---- |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 local 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)----- |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)---- |A Firefox preference value. 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----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 default profile used by sessions when Nothing 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 '"'
− Test/WebDriver/Internal.hs 
@@ -1,136 +0,0 @@-{-# 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 { errSess = 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
− Test/WebDriver/JSON.hs 
@@ -1,109 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- |A collection of convenience functions for using and parsing JSON values--- 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
− Test/WebDriver/Types.hs 
@@ -1,739 +0,0 @@-{-# 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(..), -         -- ** Default settings for browsers-         firefox, chrome, ie, opera, iPhone, iPad, android-       , FFLogPref-         -- * WebDriver objects and command-specific types-       , Element(..)-       , WindowHandle(..), currentWindow-       , Selector(..)-       , JSArg(..)-       , FrameSelector(..)-       , Cookie(..), mkCookie-       , Orientation(..)-       , MouseButton(..)-       , WebStorageType(..)-         -- * 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, unpack)-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.Maybe-import Data.Word-import Data.String-import Text.Show-import Data.Default-import qualified Data.Char as C---{- |A monadic interface to the WebDriver server. This monad is a simple, strict -layer 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"---- |Specifies the frame used by 'Test.WebDriver.Commands.focusFrame'-data FrameSelector = WithIndex Integer       -                     -- |focus on a frame by name or ID-                   | WithName Text-                     -- |focus on a frame Element-                   | WithElement Element-                     -- |focus on the first frame, or the main document-                     -- if iframes are used.-                   | DefaultFrame-                   deriving (Eq, Show, Read)--{- |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 to-                             -- use with 'WD' commands.-                             -- A value of Nothing indicates that a session -                             -- hasn't been created yet.-                             -- Sessions can be created within 'WD' via the-                             -- 'Test.WebDriver.createSession', or created-                             -- and closed automatically with -                             -- 'Test.WebDriver.runSession'-                           , 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 'def' but 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 received from the server , 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 --- less polymorphism. By default, we use 'firefox' of an unspecified 'version' --- with default system-wide proxy 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 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 { -- |Version of the Chrome Webdriver server server to use.-                        -- for more information on chromedriver see-                        -- <http://code.google.com/p/selenium/wiki/ChromeDriver>-                        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 a broad variety 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 { -- |The error message.-                                             errMsg    :: String-                                             -- |The session associated with -                                             -- the exception.-                                           , errSess :: WDSession -                                             -- |A screen shot of the focused window-                                             -- when the exception occured,-                                             -- if provided.-                                           , errScreen :: Maybe ByteString-                                             -- |The "class" in which the exception-                                             -- was raised, if provided.-                                           , errClass  :: Maybe String-                                             -- |A stack trace of the exception.-                                           , errStack  :: [StackFrame]-                                           }-                       deriving (Eq)----- |Constructs a FailedCommandInfo from only an error message.-mkFailedCommandInfo :: String -> WD FailedCommandInfo-mkFailedCommandInfo m = do-  sess <- get-  return $ FailedCommandInfo {errMsg = m , errSess = sess , 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 =<< mkFailedCommandInfo m---- |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 (Eq)---- |Cookies are delicious delicacies. When sending cookies to the server, a value--- of Nothing indicates that the server should use a default value. When receiving--- cookies from the server, a value of Nothing indicates that the server is unable--- to specify the value.-data Cookie = Cookie { cookName   :: Text-                     , cookValue  :: Text          -- ^ -                     , cookPath   :: Maybe Text    -- ^path of this cookie.-                                                   -- if Nothing, defaults to /-                     , cookDomain :: Maybe Text    -- ^domain of this cookie.-                                                   -- if Nothing, the current pages-                                                   -- domain is used-                     , cookSecure :: Maybe Bool    -- ^Is this cookie secure?-                     , cookExpiry :: Maybe Integer -- ^Expiry date expressed as-                                                   -- seconds since the Unix epoch-                                                   -- Nothing indicates that the -                                                   -- cookie never expires-                     } deriving (Eq, Show)              ---- |Creates a Cookie with only a name and value specified. All other--- fields are set to Nothing, which tells the server to use default values.-mkCookie :: Text -> Text -> Cookie-mkCookie name value = Cookie { cookName = name, cookValue = value,-                               cookPath = Nothing, cookDomain = Nothing,-                               cookSecure = Nothing, cookExpiry = Nothing-                             }---- |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)----- |An HTML 5 storage type-data WebStorageType = LocalStorage | SessionStorage -                    deriving (Eq, Show, Ord, Bounded, Enum)--instance Show FailedCommandInfo where --todo: pretty print-  show i = showChar '\n' -           . showString "Session: " . sess -           . showChar '\n'-           . showString className . showString ": " . showString (errMsg i)-           . showChar '\n'-           . foldl (\f s-> f . showString "  " . shows s) id (errStack i)-           $ ""-    where-      className = fromMaybe "<unknown exception>" . errClass $ i-      -      sess = showString sessId . showString " at " -             . showString host . showChar ':' . shows port-        where-          WDSession {wdHost = host, wdPort = port, wdSessId = msid } = errSess i-          sessId = case msid of-            Just (SessionId sid) -> unpack sid-            Nothing -> "<no session id>"--instance Show StackFrame where-  show f = showString (sfClassName f) . showChar '.' -           . showString (sfMethodName f) . showChar ' '-           . showParen True ( showString (sfFileName f) . showChar ':'-                              . shows (sfLineNumber f))-           $ "\n"--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 undefined-                      <*> 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--instance ToJSON FrameSelector where-  toJSON s = case s of-    WithIndex i -> toJSON i-    WithName n -> toJSON n-    WithElement e -> toJSON e-    DefaultFrame -> Null
− Test/WebDriver/Types/Internal.hs 
@@ -1,27 +0,0 @@-{-# 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
+ src/Test/WebDriver.hs view
@@ -0,0 +1,25 @@+{-| +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+       , runWD, runSession, withSession, finallyClose, closeOnException+         -- * Capabilities and configuration+       , Capabilities(..), defaultCaps, allCaps+       , Platform(..), ProxyType(..)+         -- ** Browser-specific configuration+       , Browser(..), LogPref(..)+       , firefox, chrome, ie, opera, iPhone, iPad, android+         -- * WebDriver commands+       , module Test.WebDriver.Commands+         -- * Exceptions+       , module Test.WebDriver.Exceptions+       ) where++import Test.WebDriver.Types+import Test.WebDriver.Commands+import Test.WebDriver.Monad+import Test.WebDriver.Exceptions
+ src/Test/WebDriver/Capabilities.hs view
@@ -0,0 +1,474 @@+{-# LANGUAGE OverloadedStrings, RecordWildCards+  #-}+module Test.WebDriver.Capabilities where++import Test.WebDriver.Firefox.Profile+import Test.WebDriver.Chrome.Extension+import Test.WebDriver.JSON++import Data.Aeson+import Data.Aeson.Types (Parser, typeMismatch)++import Data.Text (Text, toLower, toUpper)+import Data.Default (Default(..))+import Data.Word (Word16)+import Data.Maybe (fromMaybe, catMaybes)+import Data.String (fromString)++import Control.Applicative+import Control.Exception.Lifted (throw)++{- |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 received from the server , 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 run.   +               , platform                 :: Platform+                 -- |Proxy configuration settings.+               , proxy                    :: ProxyType+                 -- |Whether the session supports executing JavaScript via+                 -- 'executeJS' and 'asyncJS'.+               , javascriptEnabled        :: Maybe Bool+                 -- |Whether the session supports taking screenshots of the+                 -- current page with the 'screenshot' command+               , takesScreenshot          :: Maybe Bool+                 -- |Whether the session can interact with modal popups,+                 -- such as window.alert and window.confirm via +                 -- 'acceptAlerts', 'dismissAlerts', etc.+               , handlesAlerts            :: Maybe Bool+                 -- |Whether the session can interact with database storage.+               , databaseEnabled          :: Maybe Bool+                 -- |Whether the session can set and query the browser's+                 -- location context with 'setLocation' and 'getLocation'.+               , locationContextEnabled   :: Maybe Bool+                 -- |Whether the session can interact with the application cache+                 -- .+               , applicationCacheEnabled  :: Maybe Bool+                 -- |Whether the session can query for the browser's+                 -- connectivity and disable it if desired+               , browserConnectionEnabled :: Maybe Bool+                 -- |Whether the session supports CSS selectors when searching+                 -- for elements.+               , cssSelectorsEnabled      :: Maybe Bool+                 -- |Whether Web Storage ('getKey', 'setKey', etc) support is +                 -- enabled+               , webStorageEnabled        :: Maybe Bool+                 -- |Whether the session can rotate the current page's current+                 -- layout between 'Portrait' and 'Landscape' orientations.+               , rotatable                :: Maybe Bool+                 -- |Whether the session should accept all SSL certs by default+               , acceptSSLCerts           :: Maybe Bool+                 -- |Whether the session is capable of generating native OS+                 -- events when simulating user input.+               , 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 +-- less polymorphism. By default, we use 'firefox' of an unspecified 'version' +-- with default system-wide proxy 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+                      }+      ++instance ToJSON Capabilities where+  toJSON Capabilities{..} = +    object $ [ "browserName" .= browser+             , "version" .= version+             , "platform" .= platform+             , "proxy" .= proxy+             , "javascriptEnabled" .= javascriptEnabled+             , "takesScreenshot" .= takesScreenshot+             , "handlesAlerts" .= handlesAlerts+             , "databaseEnabled" .= databaseEnabled+             , "locationContextEnabled" .= locationContextEnabled+             , "applicationCacheEnabled" .= applicationCacheEnabled+             , "browserConnectionEnabled" .= browserConnectionEnabled+             , "cssSelectorsEnabled" .= cssSelectorsEnabled+             , "webStorageEnabled" .= webStorageEnabled+             , "rotatable" .= rotatable+             , "acceptSslCerts" .= acceptSSLCerts+             , "nativeEvents" .= nativeEvents+             ] ++ browserInfo+    where +      browserInfo = case browser of+        Firefox {..}+          -> ["firefox_profile" .= ffProfile+             ,"loggingPrefs" .= object ["driver" .= ffLogPref]+             ,"firefox_binary" .= ffBinary+             ]+        Chrome {..}+          -> catMaybes [ opt "chrome.chromedriverVersion" chromeDriverVersion+                       , opt "chrome.binary" chromeBinary +                       ]+             ++ ["chrome.switches" .= chromeOptions+                ,"chrome.extensions" .= chromeExtensions+                ]       +        IE {..}+          -> ["IgnoreProtectedModeSettings" .= ignoreProtectedModeSettings+             --,"useLegacyInternalServer" .= u+             ]+        Opera{..}+          -> catMaybes [ opt "opera.binary" operaBinary+                       , opt "opera.display" operaDisplay+                       , opt "opera.product" operaProduct+                       , opt "opera.launcher" operaLauncher+                       , opt "opera.host" operaHost+                       , opt "opera.logging.file" operaLogFile+                       ] +             ++ ["opera.detatch" .= operaDetach+                ,"opera.no_quit" .= operaDetach --backwards compatability+                ,"opera.autostart" .= operaAutoStart+                , "opera.idle" .= operaIdle+                -- ,"opera.profile" .= operaProfile+                ,"opera.port" .= fromMaybe (-1) operaPort+                 --note: consider replacing operaOptions with a list of options+                ,"opera.arguments" .= operaOptions+                ,"opera.logging.level" .= operaLogPref+                ]+        _ -> []+          +        where+          opt k = fmap (k .=)+++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++-- |This constructor simultaneously specifies which browser the session will +-- use, while also providing browser-specific configuration. Default+-- configuration is provided for each browser by 'firefox', 'chrome', 'opera',+-- 'ie', etc.+--+-- This library uses 'firefox' as its 'Default' browser configuration, when no+-- browser choice is specified.+data Browser = Firefox { -- |The firefox profile to use. If Nothing,+                         -- a default temporary profile is automatically created+                         -- and used.+                         ffProfile :: Maybe (PreparedProfile Firefox)+                         -- |Firefox logging preference+                       , ffLogPref :: LogPref+                         -- |Server-side path to Firefox binary. If Nothing, +                         -- use a sensible system-based default.+                       , ffBinary :: Maybe FilePath+                       }+             | Chrome { -- |Version of the Chrome Webdriver server server to use+                        --+                        -- for more information on chromedriver see+                        -- <http://code.google.com/p/selenium/wiki/ChromeDriver>+                        chromeDriverVersion :: Maybe String +                        -- |Server-side 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 { -- |Whether to skip the protected mode check. If set, tests +                    -- may become flaky, unresponsive, or browsers may hang. If +                    -- not set, and protected mode settings are not the same for+                    -- all zones, an exception will be thrown on driver +                    -- construction. +                    ignoreProtectedModeSettings :: Bool+                  --, useLegacyInternalServer     :: Bool+                  }+             | Opera { -- |Server-side path to the Opera binary+                       operaBinary    :: Maybe FilePath+                     --, operaNoRestart :: Maybe Bool +                       -- |Which Opera product 'were using, e.g. "desktop",+                       -- "core"+                     , operaProduct   :: Maybe String+                       -- |Whether the Opera instance should stay open after+                       -- we close the session. If False, closing the session+                       -- closes the browser.+                     , operaDetach    :: Bool+                       -- |Whether to auto-start the Opera binary. If false,+                       -- OperaDriver will wait for a connection from the+                       -- browser. By default this is True.+                     , operaAutoStart :: Bool+                       -- |Whether to use Opera's alternative implicit wait+                       -- implementation. It will use an in-browser heuristic+                       -- to guess when a page has finished loading. This+                       -- feature is experimental, and disabled by default.+                     , operaIdle      :: Bool+                       -- |(*nix only) which X display to use.+                     , operaDisplay   :: Maybe Int+                     --, operaProfile   :: Maybe (PreparedProfile Opera)+                       -- |Path to the launcher binary to use. The launcher+                       -- is a gateway between OperaDriver and the Opera+                       -- browser. If Nothing, OperaDriver will use the+                       -- launcher supplied with the package.+                     , operaLauncher  :: Maybe FilePath+                       -- |The port we should use to connect to Opera. If Just 0+                       -- , use a random port. If Nothing, use the default+                       -- Opera port. The default 'opera' constructor uses+                       -- Just 0, since Nothing is likely to cause "address+                       -- already in use" errors.+                     , operaPort      :: Maybe Word16+                       -- |The host Opera should connect to. Unless you're+                       -- starting Opera manually you won't need this.+                     , operaHost      :: Maybe String+                       -- |Command-line arguments to pass to Opera.+                     , operaOptions   :: String+                       -- |Where to send the log output. If Nothing, logging is +                       -- disabled.+                     , operaLogFile   :: Maybe FilePath+                       -- |Log level preference. Defaults to 'LogInfo'+                     , operaLogPref   :: LogPref+                     }+             | HTMLUnit+             | IPhone +             | IPad+             | Android+             deriving (Eq, Show)++instance Default Browser where+  def = firefox+++instance ToJSON Browser where+  toJSON Firefox {} = String "firefox"+  toJSON Chrome {}  = String "chrome"+  toJSON Opera {}   = String "opera"+  toJSON IE {}      = String "internet explorer"+  toJSON b = String . toLower . fromString . show $ b++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+++-- |Default Firefox settings. All Maybe fields are set to Nothing. ffLogPref+-- is set to 'LogInfo'.+firefox :: Browser+firefox = Firefox Nothing def 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++-- |Default Opera settings. See the 'Opera' constructor for more details on+-- individual defaults.+opera :: Browser+opera = Opera { operaBinary = Nothing+              --, operaNoRestart = Nothing+              , operaProduct = Nothing+              , operaDetach = False+              , operaAutoStart = True+              , operaDisplay = Nothing+              , operaIdle = False+--              , operaProfile = Nothing+              , operaLauncher = Nothing+              , operaHost = Nothing+              , operaPort = Just 0+              , operaOptions = []+              , operaLogFile = Nothing+              , operaLogPref = def+              }++--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)++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++-- |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)++instance FromJSON ProxyType where+  parseJSON (Object obj) = do+    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+    where+      f :: FromJSON a => Text -> Parser a +      f = (obj .:)+  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+      ]++-- |Indicates log verbosity. Used in 'Firefox' and 'Opera' configuration.+data LogPref = LogOff | LogSevere | LogWarning | LogInfo | LogConfig +             | LogFine | LogFiner | LogFinest | LogAll+             deriving (Eq, Show, Ord, Bounded, Enum)++instance Default LogPref where+  def = LogInfo++instance ToJSON LogPref where+  toJSON p= String $ case p of+    LogOff -> "OFF"+    LogSevere -> "SEVERE"+    LogWarning -> "WARNING"+    LogInfo -> "INFO"+    LogConfig -> "CONFIG"+    LogFine -> "FINE"+    LogFiner -> "FINER"+    LogFinest -> "FINEST"+    LogAll -> "ALL"+    +instance FromJSON LogPref where+  parseJSON (String s) = return $ case s of+    "OFF" -> LogOff+    "SEVERE" -> LogSevere+    "WARNING" -> LogWarning+    "INFO" -> LogInfo+    "CONFIG" -> LogConfig+    "FINE" -> LogFine+    "FINER" -> LogFiner+    "FINEST" -> LogFinest+    "ALL" -> LogAll+    _ -> throw . BadJSON $ "Invalid logging preference: " ++ show s+  parseJSON other = typeMismatch "LogPref" other
+ src/Test/WebDriver/Chrome/Extension.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}+-- |Functions and types for working with Google Chrome extensions.+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.Base++-- |An opaque type representing a Google Chrome extension. Values of this type+-- are passed to the 'Test.Webdriver.chromeExtensions' field. +newtype ChromeExtension = ChromeExtension ByteString+                        deriving (Eq, Show, Read, ToJSON, FromJSON)++-- |Load a .crx file as a 'ChromeExtension'.+loadExtension :: MonadBase IO m => FilePath -> m ChromeExtension+loadExtension path = liftBase $ loadRawExtension <$> BS.readFile path++-- |Load raw .crx data as a 'ChromeExtension'.+loadRawExtension :: ByteString -> ChromeExtension+loadRawExtension = ChromeExtension . B64.encode
+ src/Test/WebDriver/Classes.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, FlexibleContexts, +             GeneralizedNewtypeDeriving, StandaloneDeriving #-}+module Test.WebDriver.Classes+       ( WebDriver(..), RequestMethod(..),+         SessionState(..), modifySession+       , WDSession(..), SessionId(..), defaultSession+       , doSessCommand+         -- * No Session Exception+       , NoSessionId(..)+       ) where++--import Test.WebDriver.Internal+import Data.Aeson+import Network.HTTP (RequestMethod(..))++import qualified Data.Text as T+import Data.Text (Text)++import Control.Monad.Trans.Control+import Control.Exception.Lifted (Exception, throwIO)+import Data.Typeable++import Control.Monad.Trans.Maybe+import Control.Monad.List+import Control.Monad.Trans.Identity+import Control.Monad.Reader+import Control.Monad.Error+--import Control.Monad.Cont+import Control.Monad.Writer.Strict as SW+import Control.Monad.Writer.Lazy as LW+import Control.Monad.State.Strict as SS+import Control.Monad.State.Lazy as LS+import Control.Monad.RWS.Strict as SRWS+import Control.Monad.RWS.Lazy as LRWS++import Data.Default+import Data.Word+++-- |A class for monads that carry a WebDriver session with them. The+-- MonadBaseControl superclass is used for exception handling through+-- the lifted-base package.+class MonadBaseControl IO s => SessionState s where+  getSession :: s WDSession+  putSession :: WDSession -> s ()++-- |A class for monads that can handle wire protocol requests. This is the+-- operation underlying all of the high-level commands exported in+-- "Test.WebDriver.Commands". For more information on the wire protocol see+-- <http://code.google.com/p/selenium/wiki/JsonWireProtocol>+class SessionState wd => WebDriver wd where+  doCommand :: (ToJSON a, FromJSON b) => +                RequestMethod -- ^HTTP request method +                -> Text       -- ^URL of request +                -> a          -- ^JSON parameters passed in the body +                              -- of the request. Note that, as a special case,+                              -- () will result in an empty request body.+                -> wd b +++modifySession :: SessionState s => (WDSession -> WDSession) -> s ()+modifySession f = getSession >>= putSession . f++{- |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 to+                             -- use with 'WD' commands.+                             -- A value of Nothing indicates that a session +                             -- hasn't been created yet.+                             -- Sessions can be created within 'WD' via+                             -- 'Test.WebDriver.createSession', or created+                             -- and closed automatically with +                             -- 'Test.WebDriver.runSession'+                           , 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 +initialized server-side. This value is the same as 'def' but with a less+polymorphic type. -}+defaultSession :: WDSession+defaultSession = def+++{- |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)+++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)+++-- |This a convenient wrapper around doCommand that automatically prepends+-- the session URL parameter to the wire command URL. For example, passing+-- a URL of "/refresh" will expand to "/session/:sessionId/refresh".+doSessCommand :: (WebDriver wd, ToJSON a, FromJSON b) => +                  RequestMethod -> Text -> a -> wd b+doSessCommand method path args = do+  WDSession { wdSessId = mSessId } <- getSession+  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 method +                              (T.concat ["/session/", sId, path]) args+++instance SessionState m => SessionState (LS.StateT s m) where+  getSession = lift getSession+  putSession = lift . putSession++instance WebDriver wd => WebDriver (LS.StateT s wd) where+  doCommand rm t a = lift (doCommand rm t a)+++instance SessionState m => SessionState (SS.StateT s m) where+  getSession = lift getSession+  putSession = lift . putSession++instance WebDriver wd => WebDriver (SS.StateT s wd) where+  doCommand rm t a = lift (doCommand rm t a)++instance SessionState m => SessionState (MaybeT m) where+  getSession = lift getSession+  putSession = lift . putSession++instance WebDriver wd => WebDriver (MaybeT wd) where+  doCommand rm t a = lift (doCommand rm t a)+++instance SessionState m => SessionState (IdentityT m) where+  getSession = lift getSession+  putSession = lift . putSession++instance WebDriver wd => WebDriver (IdentityT wd) where+  doCommand rm t a = lift (doCommand rm t a)+++instance (Monoid w, SessionState m) => SessionState (LW.WriterT w m) where+  getSession = lift getSession+  putSession = lift . putSession++instance (Monoid w, WebDriver wd) => WebDriver (LW.WriterT w wd) where+  doCommand rm t a = lift (doCommand rm t a)+++instance SessionState m => SessionState (ReaderT r m) where+  getSession = lift getSession+  putSession = lift . putSession++instance WebDriver wd => WebDriver (ReaderT r wd) where+  doCommand rm t a = lift (doCommand rm t a)+++instance (Error e, SessionState m) => SessionState (ErrorT e m) where+  getSession = lift getSession+  putSession = lift . putSession++instance (Error e, WebDriver wd) => WebDriver (ErrorT e wd) where+  doCommand rm t a = lift (doCommand rm t a)+++--instance SessionState m => SessionState (ContT r m) where+--  getSession = lift getSession+--  putSession = lift . putSession++--instance WebDriver wd => WebDriver (ContT r wd) where+--  doCommand rm t a = lift (doCommand rm t a)+++instance (Monoid w, SessionState m) => SessionState (SRWS.RWST r w s m) where+  getSession = lift getSession+  putSession = lift . putSession++instance (Monoid w, WebDriver wd) => WebDriver (SRWS.RWST r w s wd) where+  doCommand rm t a = lift (doCommand rm t a)+++instance (Monoid w, SessionState m) => SessionState (LRWS.RWST r w s m) where+  getSession = lift getSession+  putSession = lift . putSession++instance (Monoid w, WebDriver wd) => WebDriver (LRWS.RWST r w s wd) where+  doCommand rm t a = lift (doCommand rm t a)+
+ src/Test/WebDriver/Commands.hs view
@@ -0,0 +1,750 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ExistentialQuantification,+             GeneralizedNewtypeDeriving, TemplateHaskell #-}+-- |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, setPageLoadTimeout+         -- * 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, closeWindow, windows, focusWindow,  maximize+       , getWindowSize, setWindowSize, getWindowPos, setWindowPos+         -- * Focusing on frames+       , focusFrame, FrameSelector(..)+         -- * Cookies+       , Cookie(..), mkCookie+       , cookies, setCookie, deleteCookie, deleteVisibleCookies+         -- * Alerts+       , getAlertText, replyToAlert, acceptAlert, dismissAlert+         -- * Mouse gestures                                          +       , moveTo, moveToCenter, moveToFrom+       , clickWith, MouseButton(..)+       , mouseDown, mouseUp, withMouseDown, doubleClick+         -- * HTML 5 Web Storage+         -- |As of Selenium 2.21, Web Storage is only supported on iOS and+         -- Android platforms+       , WebStorageType(..), storageSize, getAllKeys, deleteAllKeys+       , getKey, setKey, deleteKey+         -- * Mobile device support+         -- ** Screen orientation+       , Orientation(..)+       , getOrientation, setOrientation+         -- ** Geo-location+       , getLocation, setLocation+         -- ** Touch gestures+       , touchClick, touchDown, touchUp, touchMove+       , touchScroll, touchScrollFrom, touchDoubleClick+       , touchLongClick, touchFlick, touchFlickFrom+         -- * IME support              +       , availableIMEEngines, activeIMEEngine, checkIMEActive+       , activateIME, deactivateIME+         -- * Uploading files to remote server+         -- |These functions allow you to upload a file to a remote server. +         -- Note that this operation isn't supported by all WebDriver servers,+         -- and the location where the file is stored is not standardized.+       , uploadFile, uploadRawFile, uploadZipEntry+         -- * Server information+       , serverStatus+       ) where++import Test.WebDriver.Classes+import Test.WebDriver.JSON+import Test.WebDriver.Capabilities+import Test.WebDriver.Internal++import Data.Aeson+import Data.Aeson.Types+import Data.Aeson.TH+import qualified Data.Text as T+import Data.Text (Text, splitOn, append, toUpper, toLower)+import Data.ByteString as SBS (ByteString, concat)+import Data.ByteString.Base64 as B64+import Data.ByteString.Lazy as LBS (ByteString, toChunks)+import Network.URI+import Codec.Archive.Zip++import Control.Applicative+import Control.Monad.State.Strict+import Control.Monad.Base+import Control.Exception (SomeException)+import Control.Exception.Lifted (throwIO, catch, handle)+import Data.Word+import Data.String (fromString)+import Data.Default+import qualified Data.Char as C++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 :: (WebDriver wd) => 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 :: WebDriver wd => Capabilities -> wd WDSession+createSession caps = do+  sessUrl <- doCommand POST "/session" . single "desiredCapabilities" $ caps+  let sessId = SessionId . last . filter (not . T.null) . splitOn "/" $  sessUrl+  modifySession $ \sess -> sess {wdSessId = Just sessId}+  return =<< getSession++-- |Retrieve a list of active sessions and their 'Capabilities'.+sessions :: WebDriver wd => wd [(SessionId, Capabilities)]+sessions = do+  objs <- doCommand GET "/sessions" ()+  forM objs $ parsePair "id" "capabilities" "sessions"++-- |Get the actual 'Capabilities' of the current session.+getCaps :: WebDriver wd => wd Capabilities+getCaps = doSessCommand GET "" ()++-- |Close the current session and the browser associated with it.+closeSession :: WebDriver wd => wd ()+closeSession = do s <- getSession+                  doSessCommand DELETE "" () :: WebDriver wd => wd ()+                  putSession s { wdSessId = Nothing } ++-- |Sets the amount of time we implicitly wait when searching for elements.+setImplicitWait :: WebDriver wd => 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 :: WebDriver wd => 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++-- |Sets the amount of time to wait for a page to finish loading before throwing a 'Timeout' exception+setPageLoadTimeout :: WebDriver wd => Integer -> wd ()+setPageLoadTimeout ms = doSessCommand POST "/timeouts" params+  where params = object ["type" .= ("page load" :: String)+                        ,"ms"   .= ms ]++-- |Gets the URL of the current page.+getCurrentURL :: WebDriver wd => wd String+getCurrentURL = doSessCommand GET "/url" ()++-- |Opens a new page by the given URL.+openPage :: WebDriver wd => String -> wd ()+openPage url +  | isURI url = doSessCommand POST "/url" . single "url" $ url+  | otherwise = throwIO . InvalidURL $ url++-- |Navigate forward in the browser history.+forward :: WebDriver wd => wd ()+forward = doSessCommand POST "/forward" ()++-- |Navigate backward in the browser history.+back :: WebDriver wd => wd ()+back = doSessCommand POST "/back" ()++-- |Refresh the current page+refresh :: WebDriver wd => wd ()+refresh = doSessCommand POST "/refresh" ()++-- |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++instance ToJSON JSArg where+  toJSON (JSArg a) = toJSON a++{- |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 :: (WebDriver wd, 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 :: (WebDriver wd, 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 :: WebDriver wd => wd SBS.ByteString+screenshot = B64.decodeLenient <$> doSessCommand GET "/screenshot" () +++availableIMEEngines :: WebDriver wd => wd [Text]+availableIMEEngines = doSessCommand GET "/ime/available_engines" ()++activeIMEEngine :: WebDriver wd => wd Text+activeIMEEngine = doSessCommand GET "/ime/active_engine" ()++checkIMEActive :: WebDriver wd => wd Bool+checkIMEActive = doSessCommand GET "/ime/activated" ()++activateIME :: WebDriver wd => Text -> wd ()+activateIME = doSessCommand POST "/ime/activate" . single "engine"++deactivateIME :: WebDriver wd => wd ()+deactivateIME = doSessCommand POST "/ime/deactivate" ()+++-- |Specifies the frame used by 'Test.WebDriver.Commands.focusFrame'+data FrameSelector = WithIndex Integer       +                     -- |focus on a frame by name or ID+                   | WithName Text+                     -- |focus on a frame 'Element'+                   | WithElement Element+                     -- |focus on the first frame, or the main document+                     -- if iframes are used.+                   | DefaultFrame+                   deriving (Eq, Show, Read)++instance ToJSON FrameSelector where+  toJSON s = case s of+    WithIndex i -> toJSON i+    WithName n -> toJSON n+    WithElement e -> toJSON e+    DefaultFrame -> Null++-- |Switch focus to the frame specified by the FrameSelector.+focusFrame :: WebDriver wd => FrameSelector -> wd ()+focusFrame s = doSessCommand POST "/frame" . single "id" $ s ++{- |An opaque identifier for a browser window -}+newtype WindowHandle = WindowHandle Text+                     deriving (Eq, Ord, Show, Read, +                               FromJSON, ToJSON)+instance Default WindowHandle where+  def = currentWindow++-- |A special 'WindowHandle' that always refers to the currently focused window.+-- This is also used by the 'Default' instance.+currentWindow :: WindowHandle+currentWindow = WindowHandle "current"++-- |Returns a handle to the currently focused window+getCurrentWindow :: WebDriver wd => wd WindowHandle+getCurrentWindow = doSessCommand GET "/window_handle" ()++-- |Returns a list of all windows available to the session+windows :: WebDriver wd => wd [WindowHandle]+windows = doSessCommand GET "/window_handles" ()++focusWindow :: WebDriver wd => WindowHandle -> wd ()+focusWindow w = doSessCommand POST "/window" . single "name" $ w++-- |Closes the given window+closeWindow :: WebDriver wd => WindowHandle -> wd ()+closeWindow = doSessCommand DELETE "/window" . single "name"++-- |Maximizes the current  window if not already maximized+maximize :: WebDriver wd => wd ()+maximize = doWinCommand GET currentWindow "/maximize" ()++-- |Get the dimensions of the current window.+getWindowSize :: WebDriver wd => wd (Word, Word)+getWindowSize = doWinCommand GET currentWindow "/size" () +                >>= parsePair "width" "height" "getWindowSize"++-- |Set the dimensions of the current window.+setWindowSize :: WebDriver wd => (Word, Word) -> wd ()+setWindowSize = doWinCommand POST currentWindow "/size" +                . pair ("width", "height")++-- |Get the coordinates of the current window.+getWindowPos :: WebDriver wd => wd (Int, Int)+getWindowPos = doWinCommand GET currentWindow "/position" () +               >>= parsePair "x" "y" "getWindowPos"++-- |Set the coordinates of the current window.+setWindowPos :: WebDriver wd => (Int, Int) -> wd ()+setWindowPos = doWinCommand POST currentWindow "/position" . pair ("x","y")++doWinCommand :: (WebDriver wd, ToJSON a, FromJSON b) => +                 RequestMethod -> WindowHandle -> Text -> a -> wd b+doWinCommand m (WindowHandle w) path a = +  doSessCommand m (T.concat ["/window/", w, path]) a++-- |Cookies are delicious delicacies. When sending cookies to the server, a value+-- of Nothing indicates that the server should use a default value. When receiving+-- cookies from the server, a value of Nothing indicates that the server is unable+-- to specify the value.+data Cookie = Cookie { cookName   :: Text+                     , cookValue  :: Text          -- ^ +                     , cookPath   :: Maybe Text    -- ^path of this cookie.+                                                   -- if Nothing, defaults to /+                     , cookDomain :: Maybe Text    -- ^domain of this cookie.+                                                   -- if Nothing, the current pages+                                                   -- domain is used+                     , cookSecure :: Maybe Bool    -- ^Is this cookie secure?+                     , cookExpiry :: Maybe Integer -- ^Expiry date expressed as+                                                   -- seconds since the Unix epoch+                                                   -- Nothing indicates that the +                                                   -- cookie never expires+                     } deriving (Eq, Show)              ++-- |Creates a Cookie with only a name and value specified. All other+-- fields are set to Nothing, which tells the server to use default values.+mkCookie :: Text -> Text -> Cookie+mkCookie name value = Cookie { cookName = name, cookValue = value,+                               cookPath = Nothing, cookDomain = Nothing,+                               cookSecure = Nothing, cookExpiry = Nothing+                             }++-- This line causes a strange out of scope error. Moving to the bottom of the +-- file fixed it.+-- $( deriveToJSON (map C.toLower . drop 4) ''Cookie )++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++-- |Retrieve all cookies visible to the current page.+cookies :: WebDriver wd => 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 :: WebDriver wd => 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 :: WebDriver wd => Cookie -> wd ()+deleteCookie c = doSessCommand DELETE ("/cookie/" `append` cookName c) ()++-- |Delete all visible cookies on the current page.+deleteVisibleCookies :: WebDriver wd => wd ()+deleteVisibleCookies = doSessCommand DELETE "/cookie" ()++-- |Get the current page source+getSource :: WebDriver wd => wd Text+getSource = doSessCommand GET "/source" ()++-- |Get the title of the current page.+getTitle :: WebDriver wd => wd Text+getTitle = doSessCommand GET "/title" ()++{- |An opaque identifier for a web page element. -}+newtype Element = Element Text+                  deriving (Eq, Ord, Show, Read)++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]++-- |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)++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]++-- |Find an element on the page using the given element selector.+findElem :: WebDriver wd => Selector -> wd Element+findElem = doSessCommand POST "/element"++-- |Find all elements on the page matching the given selector.+findElems :: WebDriver wd => Selector -> wd [Element]+findElems = doSessCommand POST "/elements"++-- |Return the element that currently has focus.+activeElem :: WebDriver wd => wd Element+activeElem = doSessCommand POST "/element/active" () ++-- |Search for an element using the given element as root.+findElemFrom :: WebDriver wd => Element -> Selector -> wd Element+findElemFrom e = doElemCommand POST e "/element"++-- |Find all elements matching a selector, using the given element as root.+findElemsFrom :: WebDriver wd => 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 :: WebDriver wd => Element -> wd Value+elemInfo e = doElemCommand GET e "" ()++-- |Click on an element.+click :: WebDriver wd => 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 :: WebDriver wd => Element -> wd ()+submit e = doElemCommand POST e "/submit" ()++-- |Get all visible text within this element.+getText :: WebDriver wd => 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 :: WebDriver wd => 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 :: WebDriver wd => Text -> Element -> wd ()+sendRawKeys t e = doElemCommand POST e "/keys" . single "value" $ [t]++-- |Return the tag name of the given element.+tagName :: WebDriver wd => Element -> wd Text+tagName e = doElemCommand GET e "/name" ()++-- |Clear a textarea or text input element's value.+clearInput :: WebDriver wd => Element -> wd ()+clearInput e = doElemCommand POST e "/clear" ()++-- |Determine if the element is selected.+isSelected :: WebDriver wd => Element -> wd Bool+isSelected e = doElemCommand GET e "/selected" ()++-- |Determine if the element is enabled.+isEnabled :: WebDriver wd => Element -> wd Bool+isEnabled e = doElemCommand GET e "/enabled" ()++-- |Determine if the element is displayed.+isDisplayed :: WebDriver wd => Element -> wd Bool+isDisplayed e = doElemCommand GET e "/displayed" ()++-- |Retrieve the value of an element's attribute+attr :: WebDriver wd => 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 :: WebDriver wd => Element -> Text -> wd (Maybe Text)+cssProp e t = doElemCommand GET e ("/css/" `append` t) ()++-- |Retrieve an element's current position.+elemPos :: WebDriver wd => Element -> wd (Int, Int)+elemPos e = doElemCommand GET e "/location" () >>= parsePair "x" "y" "elemPos"++-- |Retrieve an element's current size.+elemSize :: WebDriver wd => 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.+(<==>) :: WebDriver wd => Element -> Element -> wd Bool+e1 <==> (Element e2) = doElemCommand GET e1 ("/equals/" `append` e2) ()++-- |Determines if two element identifiers refer to different elements.+infix 4 </=>+(</=>) :: WebDriver wd => Element -> Element -> wd Bool+e1 </=> e2 = not <$> (e1 <==> e2)++doElemCommand :: (WebDriver wd, ToJSON a, FromJSON b) => +                  RequestMethod -> Element -> Text -> a -> wd b+doElemCommand m (Element e) path a =+  doSessCommand m (T.concat ["/element/", e, path]) a++-- |A screen orientation+data Orientation = Landscape | Portrait+                 deriving (Eq, Show, Ord, Bounded, Enum)++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++-- |Get the current screen orientation for rotatable display devices.+getOrientation :: WebDriver wd => wd Orientation+getOrientation = doSessCommand GET "/orientation" ()++-- |Set the current screen orientation for rotatable display devices.+setOrientation :: WebDriver wd => Orientation -> wd ()+setOrientation = doSessCommand POST "/orientation" . single "orientation"++-- |Get the text of an alert dialog.+getAlertText :: WebDriver wd => wd Text+getAlertText = doSessCommand GET "/alert_text" ()++-- |Sends keystrokes to Javascript prompt() dialog.+replyToAlert :: WebDriver wd => Text -> wd ()+replyToAlert = doSessCommand POST "/alert_text" . single "text"++-- |Accepts the currently displayed alert dialog.+acceptAlert :: WebDriver wd => wd ()+acceptAlert = doSessCommand POST "/accept_alert" ()++-- |Dismisses the currently displayed alert dialog.+dismissAlert :: WebDriver wd => wd ()+dismissAlert = doSessCommand POST "/dismiss_alert" ()++-- |Moves the mouse to the given position relative to the active element.+moveTo :: WebDriver wd => (Int, Int) -> wd ()+moveTo = doSessCommand POST "/moveto" . pair ("xoffset","yoffset")++-- |Moves the mouse to the center of a given element.+moveToCenter :: WebDriver wd => Element -> wd ()+moveToCenter (Element e) = +  doSessCommand POST "/moveto" . single "element" $ e++-- |Moves the mouse to the given position relative to the given element.+moveToFrom :: WebDriver wd => (Int, Int) -> Element -> wd ()+moveToFrom (x,y) (Element e) = +  doSessCommand POST "/moveto" +  . triple ("element","xoffset","yoffset") $ (e,x,y)++-- |A mouse button+data MouseButton = LeftButton | MiddleButton | RightButton+                 deriving (Eq, Show, Ord, Bounded, Enum)++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++-- |Click at the current mouse position with the given mouse button.+clickWith :: WebDriver wd => 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 :: WebDriver wd => 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 :: WebDriver wd => wd ()+mouseDown = doSessCommand POST "/buttondown" ()++-- |Release the left mouse button.+mouseUp :: WebDriver wd => wd ()+mouseUp = doSessCommand POST "/buttonup" ()++-- |Double click at the current mouse location.+doubleClick :: WebDriver wd => wd ()+doubleClick = doSessCommand POST "/doubleclick" ()++-- |Single tap on the touch screen at the given element's location.+touchClick :: WebDriver wd => 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 :: WebDriver wd => (Int, Int) -> wd ()+touchDown = doSessCommand POST "/touch/down" . pair ("x","y")++-- |Emulates removing a finger from the screen at the given location.+touchUp :: WebDriver wd => (Int, Int) -> wd ()+touchUp = doSessCommand POST "/touch/up" . pair ("x","y")++-- |Emulates moving a finger on the screen to the given location.+touchMove :: WebDriver wd => (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 :: WebDriver wd => (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 :: WebDriver wd => (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 :: WebDriver wd => Element -> wd ()+touchDoubleClick (Element e) = doSessCommand POST "/touch/doubleclick"+                               . single "element" $ e++-- |Emulate a long click on a touch device.+touchLongClick :: WebDriver wd => 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 :: WebDriver wd => (Int, Int) -> wd ()+touchFlick = doSessCommand POST "/touch/flick" . pair ("xSpeed", "ySpeed")++-- |Emulate a flick on the touch screen.+touchFlickFrom :: WebDriver wd => +                  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 :: WebDriver wd => wd (Int, Int, Int)+getLocation = doSessCommand GET "/location" () +              >>= parseTriple "latitude" "longitude" "altitude" "getLocation"++-- |Set the current geographical location of the device.+setLocation :: WebDriver wd => (Int, Int, Int) -> wd ()+setLocation = doSessCommand POST "/location" . triple ("latitude",+                                                       "longitude",+                                                       "altitude")++-- |Uploads a file from the local filesystem by its file path.+uploadFile :: WebDriver wd => FilePath -> wd ()+uploadFile path = uploadZipEntry =<< liftBase (readEntry [] path)+  +-- |Uploads a raw bytestring with associated file info.+uploadRawFile :: WebDriver wd =>+                 FilePath          -- ^File path to use with this bytestring.+                 -> Integer        -- ^Modification time +                                   -- (in seconds since Unix epoch).+                 -> LBS.ByteString -- ^ The file contents as a lazy ByteString+                 -> wd ()+uploadRawFile path t str = uploadZipEntry (toEntry path t str)+++-- |Lowest level interface to the file uploading mechanism.+-- This allows you to specify the exact details of+-- the zip entry sent across network.+uploadZipEntry :: WebDriver wd => Entry -> wd ()+uploadZipEntry = doSessCommand POST "/file" . single "file" +                 . B64.encode . SBS.concat . toChunks +                 . fromArchive . (`addEntryToArchive` emptyArchive)+++-- |An HTML 5 storage type+data WebStorageType = LocalStorage | SessionStorage +                    deriving (Eq, Show, Ord, Bounded, Enum)++-- |Get the current number of keys in a web storage area.+storageSize :: WebDriver wd => WebStorageType -> wd Integer+storageSize s = doStorageCommand GET s "/size" ()++-- |Get a list of all keys from a web storage area.+getAllKeys :: WebDriver wd => WebStorageType -> wd [Text]+getAllKeys s = doStorageCommand GET s "" ()++-- |Delete all keys within a given web storage area.+deleteAllKeys :: WebDriver wd => WebStorageType -> wd ()+deleteAllKeys s = doStorageCommand DELETE s "" ()++-- |Get the value associated with a key in the given web storage area.+-- Unset keys result in empty strings, since the Web Storage spec+-- makes no distinction between the empty string and an undefined value.+getKey :: WebDriver wd => WebStorageType -> Text ->  wd Text+getKey s k = doStorageCommand GET s ("/key/" `T.append` k) ()++-- |Set a key in the given web storage area.+setKey :: WebDriver wd => WebStorageType -> Text -> Text -> wd Text+setKey s k v = doStorageCommand POST s "" . object $ ["key"   .= k,+                                                      "value" .= v ]+-- |Delete a key in the given web storage area. +deleteKey :: WebDriver wd => WebStorageType -> Text -> wd ()+deleteKey s k = doStorageCommand POST s ("/key/" `T.append` k) ()++doStorageCommand :: (WebDriver wd, ToJSON a, FromJSON b) =>+                     RequestMethod -> WebStorageType -> Text -> a -> wd b+doStorageCommand m s path a = doSessCommand m (T.concat ["/", s', path]) a+  where s' = case s of+          LocalStorage -> "local_storage"+          SessionStorage -> "session_storage"+          +$( deriveToJSON (map C.toLower . drop 4) ''Cookie )
+ src/Test/WebDriver/Commands/Wait.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, FlexibleContexts #-}+module Test.WebDriver.Commands.Wait +       ( -- * Wait on expected conditions+         waitUntil, waitUntil'+       , waitWhile, waitWhile'+         -- * Expected conditions+       , ExpectFailed, expect, unexpected+         -- ** Convenience functions+       , expectAny, expectAll+       , (<||>), (<&&>)+       ) where+import Test.WebDriver.Exceptions+import Test.WebDriver.Classes+import Control.Monad+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Exception.Lifted+import Control.Concurrent+import Data.Time.Clock+import Data.Typeable+import Prelude hiding (catch)++instance Exception ExpectFailed+-- |An exception representing the failure of an expected condition.+data ExpectFailed = ExpectFailed deriving (Show, Eq, Typeable)++-- |throws 'ExpectFailed'. This is nice for writing your own abstractions.+unexpected :: MonadBaseControl IO m => m 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 :: MonadBaseControl IO m => Bool -> m ()+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 (||)+++-- |Apply a predicate to every element in a list, and expect that at least one+-- succeeds.+expectAny :: MonadBaseControl IO m => (a -> m Bool) -> [a] -> m ()+expectAny p xs = expect . or =<< mapM p xs++-- |Apply a predicate to every element in a list, and expect that all succeed.+expectAll :: MonadBaseControl IO m => (a -> m Bool) -> [a] -> m ()+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+-- 'Test.WebDriver.NoSuchElement' exceptions occur. If the timeout is reached, +-- then a 'Test.WebDriver.Timeout' exception will be raised. The timeout value +-- is expressed in seconds.+waitUntil :: SessionState m => Double -> m a -> m 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' :: SessionState m => Int -> Double -> m a -> m 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 'waitUntil', but retries the action until it fails or until the timeout+-- is exceeded.+waitWhile :: SessionState m => Double -> m a -> m ()+waitWhile = waitWhile' 250000++-- |Like 'waitUntil'', but retries the action until it either fails or +-- until the timeout is exceeded.+waitWhile' :: SessionState m => Int -> Double -> m a -> m ()+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' :: SessionState m => +         (m b -> m a -> m b) -> Int -> Double -> m a -> m b+wait' handler waitAmnt t wd = waitLoop =<< liftBase getCurrentTime+  where timeout = realToFrac t+        waitLoop startTime = handler retry wd+          where +            retry = do+              now <- liftBase getCurrentTime+              if diffUTCTime now startTime >= timeout+                then +                  failedCommand Timeout "waitUntil': explicit wait timed out."+                else do+                  liftBase . threadDelay $ waitAmnt+                  waitLoop startTime
+ src/Test/WebDriver/Common/Profile.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE CPP, TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, +             GeneralizedNewtypeDeriving #-}+{-# OPTIONS_HADDOCK not-home #-}+-- |A type for profile preferences. These preference values are used by both +-- Firefox and Opera profiles.+module Test.WebDriver.Common.Profile+       ( Profile(..), PreparedProfile(..), ProfilePref(..), ToPref(..)+       , getPref, addPref, deletePref, addExtension, deleteExtension+       , ProfileParseError(..) ) where++import Data.Aeson+import Data.Aeson.Types+import Data.Attoparsec.Number (Number(..))+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import Data.Text (Text, pack)+import Data.ByteString (ByteString)++import Data.Fixed+import Data.Ratio+import Data.Int+import Data.Word++import Data.Typeable+import Control.Exception++-- |This structure allows you to construct and manipulate profiles in pure code,+-- deferring execution of IO operations until the profile is \"prepared\". This +-- type is shared by both Firefox and Opera profile code; when a distinction +-- must be made, the phantom type parameter is used to differentiate.+data Profile b = Profile +                 { -- |Location of the profile in the local file system+                   profileDir    :: FilePath+                   -- |A set of filepaths pointing to browser extensions.+                 , 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 ProfilePref+                 }+               deriving (Eq, Show)++-- |Represents a profile that has been prepared for +-- network transmission. The profile cannot be modified in this form.+newtype PreparedProfile b = PreparedProfile ByteString+  deriving (Eq, Show, ToJSON, FromJSON)++-- |A profile preference value. This is the subset of JSON values that excludes+-- arrays, objects, and null.+data ProfilePref = PrefInteger !Integer+                 | PrefDouble  !Double+                 | PrefString  !Text+                 | PrefBool    !Bool+                 deriving (Eq, Show)++instance ToJSON ProfilePref where+  toJSON v = case v of+    PrefInteger i -> toJSON i+    PrefDouble d  -> toJSON d+    PrefString s  -> toJSON s+    PrefBool  b   -> toJSON b++instance FromJSON ProfilePref where+  parseJSON (String s) = return $ PrefString s+  parseJSON (Bool b) = return $ PrefBool b+  parseJSON (Number (I i)) = return $ PrefInteger i+  parseJSON (Number (D d)) = return $ PrefDouble d+  parseJSON other = typeMismatch "ProfilePref" other++instance Exception ProfileParseError+-- |An error occured while attempting to parse a profile's preference file.+newtype ProfileParseError = ProfileParseError String+                          deriving  (Eq, Show, Read, Typeable)++-- |A typeclass to convert types to profile preference values+class ToPref a where+  toPref :: a -> ProfilePref++instance ToPref Text where+  toPref = PrefString+  +instance ToPref String where+  toPref = toPref . pack++instance ToPref Bool where+  toPref = PrefBool+  +instance ToPref Integer where+  toPref = PrefInteger++#define I(t) instance ToPref t where toPref = PrefInteger . toInteger++I(Int)+I(Int8)+I(Int16)+I(Int32)+I(Int64)+I(Word)+I(Word8)+I(Word16)+I(Word32)+I(Word64)++instance ToPref Double where+  toPref = PrefDouble++instance ToPref Float where+  toPref = PrefDouble . realToFrac+  +instance (Integral a) => ToPref (Ratio a) where+  toPref = PrefDouble . realToFrac+  +instance (HasResolution r) => ToPref (Fixed r) where+  toPref = PrefDouble . realToFrac+++-- |Retrieve a preference from a profile by key name.+getPref :: Text -> Profile b -> Maybe ProfilePref+getPref k (Profile _ _ m) = HM.lookup k m++-- |Add a new preference entry to a profile, overwriting any existing entry+-- with the same key.+addPref :: ToPref a => Text -> a -> Profile b -> Profile b+addPref k v p = asMap p $ HM.insert k (toPref v)++-- |Delete an existing preference entry from a profile. This operation is+-- silent if the preference wasn't found.+deletePref :: Text -> Profile b -> Profile b+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 -> Profile b -> Profile b+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 -> Profile b -> Profile b+deleteExtension path p = asSet p $ HS.delete path++asMap :: Profile b+         -> (HM.HashMap Text ProfilePref -> HM.HashMap Text ProfilePref)+         -> Profile b+asMap (Profile p hs hm) f = Profile p hs (f hm)++asSet :: Profile b+         -> (HS.HashSet FilePath -> HS.HashSet FilePath)+         -> Profile b+asSet (Profile p hs hm) f = Profile p (f hs) hm
+ src/Test/WebDriver/Exceptions.hs view
@@ -0,0 +1,11 @@+module Test.WebDriver.Exceptions +       ( InvalidURL(..), NoSessionId(..), BadJSON(..)+       , HTTPStatusUnknown(..), HTTPConnError(..)+       , UnknownCommand(..), ServerError(..)+       , FailedCommand(..), FailedCommandType(..)+       , FailedCommandInfo(..), StackFrame(..)+       , mkFailedCommandInfo, failedCommand+       )where+import Test.WebDriver.Internal+import Test.WebDriver.Classes+import Test.WebDriver.JSON
+ src/Test/WebDriver/Firefox/Profile.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE CPP, OverloadedStrings, FlexibleContexts, +             GeneralizedNewtypeDeriving, EmptyDataDecls #-}+-- |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+         Firefox, Profile(..), PreparedProfile+         -- * Preferences+       , ProfilePref(..), ToPref(..)+       , addPref, getPref, deletePref+         -- * Extensions+       , addExtension, deleteExtension+         -- * Loading and preparing profiles+       , loadProfile, prepareProfile+       , prepareTempProfile, prepareLoadedProfile+       ) where+import Test.WebDriver.Common.Profile++import Data.Aeson+import Data.Aeson.Parser (jstring, value')+import Data.Attoparsec.Char8 as AP+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import Data.Text (Text)+import Data.ByteString as BS (readFile)+import qualified Data.ByteString.Char8 as SBS+import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.ByteString.Base64 as B64++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.Monad.Base+import Control.Monad.Trans.Control+import Control.Applicative+import Control.Exception.Lifted+++-- |Phantom type used in the parameters of 'Profile' and 'PreparedProfile'+data Firefox++tempProfile :: MonadBase IO m => m (Profile Firefox)+tempProfile = liftBase $ defaultProfile <$> mkTemp++-- |Load an existing profile from the file system. Any prepared changes made to+-- the 'Profile' will have no effect to the profile on disk.+loadProfile :: MonadBaseControl IO m => FilePath -> m (Profile Firefox)+loadProfile path = liftBase $ do+  Profile{ profileDir = d } <- tempProfile+  Profile <$> pure d <*> getExtensions <*> getPrefs+  where+    extD = path </> "extensions"+    userPref = path </> "prefs" <.> "js"+    getExtensions = HS.fromList . filter (`elem` [".",".."]) +                    <$> getDirectoryContents extD+    getPrefs = HM.fromList <$> (parsePrefs =<< BS.readFile userPref)+    +    parsePrefs s = either (throwIO . ProfileParseError)+                          return+                   $ parseOnly prefsParser s++-- |Prepare a firefox profile 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 :: MonadBase IO m => +                  Profile Firefox -> m (PreparedProfile Firefox)+prepareProfile Profile {profileDir = d, profileExts = s, +                        profilePrefs = m} +  = liftBase $ do +      createDirectoryIfMissing False extensionD+      extPaths <- mapM canonicalizePath . HS.toList $ s+      forM_ extPaths installExtension+      withFile userPrefs WriteMode writeUserPrefs+      prof <- PreparedProfile . 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 Profile passed to the handler function is+-- the default profile used by sessions when Nothing is specified+prepareTempProfile :: MonadBase IO m => +                     (Profile Firefox -> Profile Firefox) +                     -> m (PreparedProfile Firefox)+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 :: MonadBaseControl IO m =>+                        FilePath+                        -> (Profile Firefox -> Profile Firefox)+                        -> m (PreparedProfile Firefox)+prepareLoadedProfile path f = liftM f (loadProfile path) >>= prepareProfile++defaultProfile :: FilePath -> Profile Firefox+defaultProfile d = +  Profile 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 :: Parser [(Text, ProfilePref)]+prefsParser = many $ do +  padSpaces $ string "user_pref("+  k <- prefKey <?> "preference key"+  padSpaces $ char ','+  v <- prefVal <?> "preference value"+  padSpaces $ string ");"+  endOfLine+  return (k,v)+  where+    prefKey = jstring+    prefVal = do +      v <- value'+      case fromJSON v of+        Error str -> fail str+        Success p -> return p+    spaces = AP.takeWhile isSpace+    padSpaces p = spaces >> p <* spaces
+ src/Test/WebDriver/Internal.hs view
@@ -0,0 +1,312 @@+{-# LANGUAGE FlexibleContexts, OverloadedStrings, DeriveDataTypeable #-}+module Test.WebDriver.Internal +       ( mkWDUri, mkRequest+       , handleHTTPErr, handleJSONErr, handleHTTPResp+       +       , InvalidURL(..), HTTPStatusUnknown(..), HTTPConnError(..)+       , UnknownCommand(..), ServerError(..)+       +       , FailedCommand(..), failedCommand, mkFailedCommandInfo+       , FailedCommandType(..), FailedCommandInfo(..), StackFrame(..)+       ) where+import Test.WebDriver.Classes+import Test.WebDriver.JSON++import Network.HTTP (simpleHTTP, Request(..), Response(..))+import Network.HTTP.Headers (findHeader, Header(..), HeaderName(..))+import Network.Stream (ConnError)+import Network.URI+import Data.Aeson+import Data.Aeson.Types (Parser, typeMismatch, emptyArray)++import Data.Text as T (Text, unpack)+import Data.ByteString.Lazy.Char8 (ByteString)+import Data.ByteString.Lazy.Char8 as BS (length, unpack, null)+import qualified Data.ByteString.Char8 as SBS (ByteString)+import qualified Data.ByteString.Base64 as B64+import qualified Data.Vector as V++import Control.Monad.Base+import Control.Exception.Lifted (throwIO)+import Control.Applicative++import Control.Exception (Exception)+import Data.Typeable (Typeable)+import Data.List (isInfixOf)+import Data.Maybe (fromJust, fromMaybe)+import Data.String (fromString)+import Data.Word (Word, Word8)++mkWDUri :: (SessionState s) => String -> s URI  --todo: remove String :(+mkWDUri path = do +  WDSession{wdHost = host, +            wdPort = port+           } <- getSession+  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 :: (SessionState s, ToJSON a) => +             [Header] -> RequestMethod -> Text -> a -> s (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+  liftBase (simpleHTTP req) >>= either (throwIO . HTTPConnError) return++handleHTTPErr :: SessionState s => Response ByteString -> s ()+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 ::  (SessionState s, FromJSON a) => Response ByteString -> s 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 :: SessionState s => WDResponse -> s ()+handleJSONErr WDResponse{rspStatus = 0} = return ()+handleJSONErr WDResponse{rspVal = val, rspStatus = status} = do+  sess <- getSession+  errInfo <- fromJSON' val+  let screen = B64.decodeLenient <$> errScreen errInfo +      errInfo' = errInfo { errSess = 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+++data WDResponse = WDResponse { rspSessId :: Maybe SessionId+                             , rspStatus :: Word8+                             , rspVal    :: Value+                             }+                  deriving (Eq, Show)+                           +instance FromJSON WDResponse where+  parseJSON (Object o) = WDResponse <$> o .: "sessionId"+                                    <*> o .: "status"+                                    <*> o .: "value" .!= Null+  parseJSON v = typeMismatch "WDResponse" v+++instance Exception InvalidURL+-- |An invalid URL was given+newtype InvalidURL = InvalidURL 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 a broad variety 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 { -- |The error message.+                      errMsg    :: String+                      -- |The session associated with +                      -- the exception.+                    , errSess :: WDSession +                      -- |A screen shot of the focused window+                      -- when the exception occured,+                      -- if provided.+                    , errScreen :: Maybe SBS.ByteString+                      -- |The "class" in which the exception+                      -- was raised, if provided.+                    , errClass  :: Maybe String+                      -- |A stack trace of the exception.+                    , errStack  :: [StackFrame]+                    }+  deriving (Eq)++instance Show FailedCommandInfo where+  show i = showChar '\n' +           . showString "Session: " . sess +           . showChar '\n'+           . showString className . showString ": " . showString (errMsg i)+           . showChar '\n'+           . foldl (\f s-> f . showString "  " . shows s) id (errStack i)+           $ ""+    where+      className = fromMaybe "<unknown exception>" . errClass $ i+      +      sess = showString sessId . showString " at " +             . showString host . showChar ':' . shows port+        where+          sessId = case msid of+            Just (SessionId sid) -> T.unpack sid+            Nothing -> "<no session id>"+          WDSession {wdHost = host, wdPort = port, wdSessId = msid } = errSess i+++-- |Constructs a FailedCommandInfo from only an error message.+mkFailedCommandInfo :: SessionState s => String -> s FailedCommandInfo+mkFailedCommandInfo m = do+  sess <- getSession+  return $ FailedCommandInfo {errMsg = m , errSess = sess , errScreen = Nothing+                             , errClass  = Nothing , errStack  = [] }++-- |Convenience function to throw a 'FailedCommand' locally with no server-side +-- info present.+failedCommand :: SessionState s => FailedCommandType -> String -> s a+failedCommand t m = throwIO . FailedCommand t =<< mkFailedCommandInfo m++-- |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 (Eq)+++instance Show StackFrame where+  show f = showString (sfClassName f) . showChar '.' +           . showString (sfMethodName f) . showChar ' '+           . showParen True ( showString (sfFileName f) . showChar ':'+                              . shows (sfLineNumber f))+           $ "\n"+++instance FromJSON FailedCommandInfo where+  parseJSON (Object o) = +    FailedCommandInfo <$> (req "message" >>= maybe (return "") return)+                      <*> pure undefined+                      <*> 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++
+ src/Test/WebDriver/JSON.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, DeriveDataTypeable #-}+-- |A collection of convenience functions for using and parsing JSON values+-- 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 +         -- * Parse exception+       , BadJSON(..)+       ) where++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.Monad.Trans.Control+import Control.Exception.Lifted+import Data.String+import Data.Typeable++instance Exception BadJSON+-- |An error occured when parsing a JSON value.+newtype BadJSON = BadJSON String +             deriving (Eq, Show, Typeable)++-- |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' :: MonadBaseControl IO wd => FromJSON a => ByteString -> wd a+parseJSON' = apResultToWD . AP.parse json++-- |Convert a JSON 'Value' to an instance of 'FromJSON'.+fromJSON' :: MonadBaseControl IO wd => FromJSON a => Value -> wd a+fromJSON' = aesonResultToWD . fromJSON++-- |This operator is a wrapper over Aeson's '.:' operator.+(!:) :: (MonadBaseControl IO wd, 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 third string is the name of the+-- calling function, for better error reporting.+parsePair :: (MonadBaseControl IO wd, 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 :: (MonadBaseControl IO wd, 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 :: (MonadBaseControl IO wd, 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 :: (MonadBaseControl IO wd) => Aeson.Result a -> wd a+aesonResultToWD r = case r of+  Success val -> return val+  Error err   -> throwIO $ BadJSON err
+ src/Test/WebDriver/Monad.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE FlexibleContexts, TypeFamilies, GeneralizedNewtypeDeriving,+             MultiParamTypeClasses #-}+module Test.WebDriver.Monad+       ( WD(..), runWD, runSession, withSession, finallyClose, closeOnException+       )where++import Test.WebDriver.Classes+import Test.WebDriver.Commands +import Test.WebDriver.Capabilities+import Test.WebDriver.Internal++import Control.Monad.Base (MonadBase, liftBase)+import Control.Monad (liftM)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Control (MonadBaseControl(..), StM)+import Control.Monad.State.Strict (StateT, MonadState, evalStateT, get, put)+import Control.Monad.IO.Class (MonadIO)+import Control.Exception.Lifted+import Control.Applicative++{- |A monadic interface to the WebDriver server. This monad is a simple, strict +layer over 'IO', threading session information between sequential commands+-}+newtype WD a = WD (StateT WDSession IO a)+  deriving (Functor, Monad, 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++instance SessionState WD where+  getSession = WD get+  putSession = WD . put++instance WebDriver WD where+  doCommand method path args = do+    r <- mkRequest [] method path args+    --liftIO . print $ r+    handleHTTPErr r+    --liftIO . print . rspBody $ r+    handleHTTPResp r++-- |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
+ src/Test/WebDriver/Types.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable,+    TemplateHaskell, OverloadedStrings, ExistentialQuantification, +    MultiParamTypeClasses, TypeFamilies, +    RecordWildCards+  #-}+{-# 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(..), +         -- ** Default settings for browsers+         firefox, chrome, ie, opera, iPhone, iPad, android+       , LogPref(..)+         -- * WebDriver objects and command-specific types+       , Element(..)+       , WindowHandle(..), currentWindow+       , Selector(..)+       , JSArg(..)+       , FrameSelector(..)+       , Cookie(..), mkCookie+       , Orientation(..)+       , MouseButton(..)+       , WebStorageType(..)+         -- * Exceptions+       , InvalidURL(..), NoSessionId(..), BadJSON(..)+       , HTTPStatusUnknown(..), HTTPConnError(..)+       , UnknownCommand(..), ServerError(..)+       , FailedCommand(..), FailedCommandType(..)+       , FailedCommandInfo(..), StackFrame(..)+       , mkFailedCommandInfo, failedCommand+       ) where++import Test.WebDriver.Monad+import Test.WebDriver.Classes+import Test.WebDriver.Commands+import Test.WebDriver.Exceptions+import Test.WebDriver.Capabilities++  +++++  +++
webdriver.cabal view
@@ -1,5 +1,5 @@ Name: webdriver-Version: 0.2+Version: 0.3 Cabal-Version: >= 1.6 License: BSD3 License-File: LICENSE@@ -9,7 +9,7 @@ Category: Web, Browser, Testing Synopsis: a Haskell client for the Selenium WebDriver protocol Build-type: Simple-Extra-source-files: README.md, TODO, CHANGELOG.md+Extra-source-files: README.md, TODO, CHANGELOG.md, .ghci Description:         A Selenium WebDriver client for Haskell.          You can use it to automate browser sessions @@ -27,6 +27,7 @@   location: git://github.com/kallisti-dev/hs-webdriver.git    library+  hs-source-dirs: src   ghc-options: -Wall       build-depends:   base == 4.*                  , aeson >= 0.4 && < 0.7@@ -52,13 +53,17 @@                  , temporary    exposed-modules: Test.WebDriver+                   Test.WebDriver.Classes+                   Test.WebDriver.Monad+                   Test.WebDriver.Exceptions                    Test.WebDriver.Commands                    Test.WebDriver.Commands.Wait-                   Test.WebDriver.Commands.Internal                    Test.WebDriver.Firefox.Profile+                   Test.WebDriver.Common.Profile                    Test.WebDriver.Chrome.Extension+                   Test.WebDriver.Capabilities                    Test.WebDriver.Types                    Test.WebDriver.JSON    other-modules:   Test.WebDriver.Internal-                   Test.WebDriver.Types.Internal+