webdriver 0.4 → 0.5
raw patch · 16 files changed
+331/−329 lines, 16 filesdep ~base64-bytestringdep ~network
Dependency ranges changed: base64-bytestring, network
Files
- CHANGELOG.md +9/−0
- src/Test/WebDriver.hs +2/−2
- src/Test/WebDriver/Capabilities.hs +40/−40
- src/Test/WebDriver/Chrome/Extension.hs +3/−3
- src/Test/WebDriver/Classes.hs +22/−20
- src/Test/WebDriver/Commands.hs +70/−69
- src/Test/WebDriver/Commands/Internal.hs +16/−16
- src/Test/WebDriver/Commands/Wait.hs +21/−19
- src/Test/WebDriver/Common/Profile.hs +25/−26
- src/Test/WebDriver/Exceptions.hs +1/−1
- src/Test/WebDriver/Firefox/Profile.hs +33/−33
- src/Test/WebDriver/Internal.hs +50/−51
- src/Test/WebDriver/JSON.hs +19/−19
- src/Test/WebDriver/Monad.hs +8/−8
- src/Test/WebDriver/Types.hs +4/−14
- webdriver.cabal +8/−8
CHANGELOG.md view
@@ -1,5 +1,14 @@ #Change Log +##hs-webdriver 0.5+###API changes+* Test.WebDriver.Commands.Wait.unexpected now accepts a String argument, which is used as an error message+* screenshot and uploadZipEntry from Test.WebDriver.Commands now use lazy bytestrings+*wdBasePath field added to WDSession. This allows you to specify a custom base path for all WebDriver requests. The default, as specified in the WebDriver standard, is "/wd/hub"++###new features+* added Test.WebDriver.Commands.screenshotBase64+ ##hs-webdriver 0.4 ###API changes
src/Test/WebDriver.hs view
@@ -1,8 +1,8 @@-{-| +{-| 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 +module Test.WebDriver ( -- * WebDriver sessions WD(..), WDSession(..), defaultSession, SessionId(..) -- * Running WebDriver tests
src/Test/WebDriver/Capabilities.hs view
@@ -19,7 +19,7 @@ import Control.Exception.Lifted (throw) {- |A structure describing the capabilities of a session. This record-serves dual roles. +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@@ -31,12 +31,12 @@ support the capability. Thus, for Maybe Bool fields, both Nothing and Just False indicate a lack of support for the desired capability. -}-data Capabilities = +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 on which the browser should run. , platform :: Platform -- |Proxy configuration settings. , proxy :: ProxyType@@ -47,7 +47,7 @@ -- 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 + -- such as window.alert and window.confirm via -- 'acceptAlerts', 'dismissAlerts', etc. , handlesAlerts :: Maybe Bool -- |Whether the session can interact with database storage.@@ -64,7 +64,7 @@ -- |Whether the session supports CSS selectors when searching -- for elements. , cssSelectorsEnabled :: Maybe Bool- -- |Whether Web Storage ('getKey', 'setKey', etc) support is + -- |Whether Web Storage ('getKey', 'setKey', etc) support is -- enabled , webStorageEnabled :: Maybe Bool -- |Whether the session can rotate the current page's current@@ -96,14 +96,14 @@ , 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' +-- |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 +-- |Same as 'defaultCaps', but with all Maybe Bool capabilities set to -- Just True. allCaps :: Capabilities allCaps = defaultCaps { javascriptEnabled = Just True@@ -119,10 +119,10 @@ , acceptSSLCerts = Just True , nativeEvents = Just True }- + instance ToJSON Capabilities where- toJSON Capabilities{..} = + toJSON Capabilities{..} = object $ [ "browserName" .= browser , "version" .= version , "platform" .= platform@@ -140,7 +140,7 @@ , "acceptSslCerts" .= acceptSSLCerts , "nativeEvents" .= nativeEvents ] ++ browserInfo- where + where browserInfo = case browser of Firefox {..} -> ["firefox_profile" .= ffProfile@@ -149,11 +149,11 @@ ] Chrome {..} -> catMaybes [ opt "chrome.chromedriverVersion" chromeDriverVersion- , opt "chrome.binary" chromeBinary + , opt "chrome.binary" chromeBinary ] ++ ["chrome.switches" .= chromeOptions ,"chrome.extensions" .= chromeExtensions- ] + ] IE {..} -> ["IgnoreProtectedModeSettings" .= ignoreProtectedModeSettings --,"useLegacyInternalServer" .= u@@ -165,7 +165,7 @@ , 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@@ -177,12 +177,12 @@ ,"opera.logging.level" .= operaLogPref ] _ -> []- + where opt k = fmap (k .=) -instance FromJSON Capabilities where +instance FromJSON Capabilities where parseJSON (Object o) = Capabilities <$> req "browserName" <*> opt "version" Nothing <*> req "platform"@@ -207,7 +207,7 @@ b k = opt k Nothing -- Maybe Bool field parseJSON v = typeMismatch "Capabilities" v --- |This constructor simultaneously specifies which browser the session will +-- |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.@@ -220,7 +220,7 @@ ffProfile :: Maybe (PreparedProfile Firefox) -- |Firefox logging preference , ffLogPref :: LogPref- -- |Server-side path to Firefox binary. If Nothing, + -- |Server-side path to Firefox binary. If Nothing, -- use a sensible system-based default. , ffBinary :: Maybe FilePath }@@ -228,27 +228,27 @@ -- -- 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, + 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 + -- |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 + }+ | 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. + -- 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 + --, operaNoRestart :: Maybe Bool -- |Which Opera product we're using, e.g. \"desktop\", -- \"core\" , operaProduct :: Maybe String@@ -284,14 +284,14 @@ , operaHost :: Maybe String -- |Command-line arguments to pass to Opera. , operaOptions :: String- -- |Where to send the log output. If Nothing, logging is + -- |Where to send the log output. If Nothing, logging is -- disabled. , operaLogFile :: Maybe FilePath -- |Log level preference. Defaults to 'LogInfo' , operaLogPref :: LogPref } | HTMLUnit- | IPhone + | IPhone | IPad | Android deriving (Eq, Show)@@ -385,13 +385,13 @@ "vista" -> return Vista "mac" -> return Mac "linux" -> return Linux- "unix" -> return Unix + "unix" -> return Unix "any" -> return Any- err -> fail $ "Invalid Platform string " ++ show err + err -> fail $ "Invalid Platform string " ++ show err parseJSON v = typeMismatch "Platform" v -- |Available settings for the proxy 'Capabilities' field-data ProxyType = NoProxy +data ProxyType = NoProxy | UseSystemSettings | AutoDetect -- |Use a proxy auto-config file specified by URL@@ -411,24 +411,24 @@ "direct" -> return NoProxy "system" -> return UseSystemSettings "pac" -> PAC <$> f "autoConfigUrl"- "manual" -> Manual <$> f "ftpProxy" + "manual" -> Manual <$> f "ftpProxy" <*> f "sslProxy" <*> f "httpProxy" _ -> fail $ "Invalid ProxyType " ++ show pTyp where- f :: FromJSON a => Text -> Parser a + f :: FromJSON a => Text -> Parser a f = (obj .:) parseJSON v = typeMismatch "ProxyType" v- + instance ToJSON ProxyType where toJSON pt = object $ case pt of- NoProxy -> + NoProxy -> ["proxyType" .= ("DIRECT" :: String)]- UseSystemSettings -> + UseSystemSettings -> ["proxyType" .= ("SYSTEM" :: String)] AutoDetect -> ["proxyType" .= ("AUTODETECT" :: String)]- PAC{autoConfigUrl = url} -> + PAC{autoConfigUrl = url} -> ["proxyType" .= ("PAC" :: String) ,"autoConfigUrl" .= url ]@@ -440,7 +440,7 @@ ] -- |Indicates log verbosity. Used in 'Firefox' and 'Opera' configuration.-data LogPref = LogOff | LogSevere | LogWarning | LogInfo | LogConfig +data LogPref = LogOff | LogSevere | LogWarning | LogInfo | LogConfig | LogFine | LogFiner | LogFinest | LogAll deriving (Eq, Show, Ord, Bounded, Enum) @@ -458,7 +458,7 @@ LogFiner -> "FINER" LogFinest -> "FINEST" LogAll -> "ALL"- + instance FromJSON LogPref where parseJSON (String s) = return $ case s of "OFF" -> LogOff
src/Test/WebDriver/Chrome/Extension.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-} -- |Functions and types for working with Google Chrome extensions.-module Test.WebDriver.Chrome.Extension +module Test.WebDriver.Chrome.Extension ( ChromeExtension , loadExtension- , loadRawExtension + , loadRawExtension ) where import Data.ByteString as BS import Data.ByteString.Base64 as B64@@ -12,7 +12,7 @@ import Control.Monad.Base -- |An opaque type representing a Google Chrome extension. Values of this type--- are passed to the 'Test.Webdriver.chromeExtensions' field. +-- are passed to the 'Test.Webdriver.chromeExtensions' field. newtype ChromeExtension = ChromeExtension ByteString deriving (Eq, Show, Read, ToJSON, FromJSON)
src/Test/WebDriver/Classes.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, FlexibleContexts, +{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, FlexibleContexts, GeneralizedNewtypeDeriving #-} module Test.WebDriver.Classes ( -- * WebDriver class@@ -45,10 +45,10 @@ -- "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 + 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 -- ^The JSON result of the HTTP request.@@ -59,40 +59,43 @@ {- |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 +data WDSession = WDSession {+ -- |Host name of the WebDriver server for this -- session- wdHost :: String+ wdHost :: String -- |Port number of the server- , wdPort :: Word16+ , wdPort :: Word16+ -- |Base path (usually "/wd/hub")+ , wdBasePath :: String -- |An opaque reference identifying the session to -- use with 'WD' commands.- -- A value of Nothing indicates that a session + -- 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 + -- and closed automatically with -- 'Test.WebDriver.runSession'- , wdSessId :: Maybe SessionId + , wdSessId :: Maybe SessionId } deriving (Eq, Show) instance Default WDSession where- def = WDSession { wdHost = "127.0.0.1"- , wdPort = 4444- , wdSessId = Nothing+ def = WDSession { wdHost = "127.0.0.1"+ , wdPort = 4444+ , wdBasePath = "/wd/hub"+ , wdSessId = Nothing } -{- |A default session connects to localhost on port 4444, and hasn't been +{- |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. -} +{- |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, + deriving (Eq, Ord, Show, Read, FromJSON, ToJSON) @@ -171,4 +174,3 @@ 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
@@ -2,14 +2,14 @@ TemplateHaskell #-} -- |This module exports basic WD actions that can be used to interact with a -- browser session.-module Test.WebDriver.Commands +module Test.WebDriver.Commands ( -- * Sessions createSession, closeSession, sessions, getCaps -- * Browser interaction -- ** Web navigation , openPage, forward, back, refresh -- ** Page info- , getCurrentURL, getSource, getTitle, screenshot + , getCurrentURL, getSource, getTitle, screenshot, screenshotBase64 -- * Timeouts , setImplicitWait, setScriptTimeout, setPageLoadTimeout -- * Web elements@@ -26,10 +26,10 @@ , tagName, activeElem, elemInfo -- ** Element equality , (<==>), (</=>)- -- * Javascript + -- * Javascript , executeJS, asyncJS , JSArg(..)- -- * Windows + -- * Windows , WindowHandle(..), currentWindow , getCurrentWindow, closeWindow, windows, focusWindow, maximize , getWindowSize, setWindowSize, getWindowPos, setWindowPos@@ -40,7 +40,7 @@ , cookies, setCookie, deleteCookie, deleteVisibleCookies -- * Alerts , getAlertText, replyToAlert, acceptAlert, dismissAlert- -- * Mouse gestures + -- * Mouse gestures , moveTo, moveToCenter, moveToFrom , clickWith, MouseButton(..) , mouseDown, mouseUp, withMouseDown, doubleClick@@ -59,11 +59,11 @@ , touchClick, touchDown, touchUp, touchMove , touchScroll, touchScrollFrom, touchDoubleClick , touchLongClick, touchFlick, touchFlickFrom- -- * IME support + -- * IME support , availableIMEEngines, activeIMEEngine, checkIMEActive , activateIME, deactivateIME -- * Uploading files to remote server- -- |These functions allow you to upload a file to a 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@@ -82,9 +82,8 @@ 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 Data.ByteString.Base64.Lazy as B64+import Data.ByteString.Lazy as LBS (ByteString) import Network.URI hiding (path) -- suppresses warnings import Codec.Archive.Zip @@ -99,8 +98,8 @@ import Prelude hiding (catch) --- |Get information from the server as a JSON 'Object'. For more information --- about this object see +-- |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" ()@@ -129,23 +128,23 @@ closeSession :: WebDriver wd => wd () closeSession = do s <- getSession doSessCommand DELETE "" () :: WebDriver wd => wd ()- putSession s { wdSessId = Nothing } + putSession s { wdSessId = Nothing } -- |Sets the amount of time we implicitly wait when searching for elements. setImplicitWait :: WebDriver wd => Integer -> wd ()-setImplicitWait ms = +setImplicitWait ms = doSessCommand POST "/timeouts/implicit_wait" (object msField)- `catch` \(_ :: SomeException) -> + `catch` \(_ :: SomeException) -> doSessCommand POST "/timeouts" (object allFields)- where msField = ["ms" .= ms] + where msField = ["ms" .= ms] allFields = ["type" .= ("implicit" :: String)] ++ msField --- |Sets the amount of time we wait for an asynchronous script to return a +-- |Sets the amount of time we wait for an asynchronous script to return a -- result.-setScriptTimeout :: WebDriver wd => Integer -> wd () +setScriptTimeout :: WebDriver wd => Integer -> wd () setScriptTimeout ms = doSessCommand POST "/timeouts/async_script" (object msField)- `catch` \(_ :: SomeException) -> + `catch` \(_ :: SomeException) -> doSessCommand POST "/timeouts" (object allFields) where msField = ["ms" .= ms] allFields = ["type" .= ("script" :: String)] ++ msField@@ -162,7 +161,7 @@ -- |Opens a new page by the given URL. openPage :: WebDriver wd => String -> wd ()-openPage url +openPage url | isURI url = doSessCommand POST "/url" . single "url" $ url | otherwise = throwIO . InvalidURL $ url @@ -203,28 +202,31 @@ -} executeJS :: (WebDriver wd, FromJSON a) => [JSArg] -> Text -> wd a executeJS a s = fromJSON' =<< getResult- where + 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 +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") + 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" () +screenshot :: WebDriver wd => wd LBS.ByteString+screenshot = B64.decodeLenient <$> screenshotBase64 +-- |Grab a screenshot as a base-64 encoded PNG image. This is the protocol-defined format.+screenshotBase64 :: WebDriver wd => wd LBS.ByteString+screenshotBase64 = doSessCommand GET "/screenshot" () availableIMEEngines :: WebDriver wd => wd [Text] availableIMEEngines = doSessCommand GET "/ime/available_engines" ()@@ -243,7 +245,7 @@ -- |Specifies the frame used by 'Test.WebDriver.Commands.focusFrame'-data FrameSelector = WithIndex Integer +data FrameSelector = WithIndex Integer -- |focus on a frame by name or ID | WithName Text -- |focus on a frame 'Element'@@ -262,7 +264,7 @@ -- |Switch focus to the frame specified by the FrameSelector. focusFrame :: WebDriver wd => FrameSelector -> wd ()-focusFrame s = doSessCommand POST "/frame" . single "id" $ s +focusFrame s = doSessCommand POST "/frame" . single "id" $ s -- |Returns a handle to the currently focused window getCurrentWindow :: WebDriver wd => wd WindowHandle@@ -285,17 +287,17 @@ -- |Get the dimensions of the current window. getWindowSize :: WebDriver wd => wd (Word, Word)-getWindowSize = doWinCommand GET currentWindow "/size" () +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" +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" () +getWindowPos = doWinCommand GET currentWindow "/position" () >>= parsePair "x" "y" "getWindowPos" -- |Set the coordinates of the current window.@@ -307,7 +309,7 @@ -- 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 -- ^ + , cookValue :: Text -- ^ , cookPath :: Maybe Text -- ^path of this cookie. -- if Nothing, defaults to / , cookDomain :: Maybe Text -- ^domain of this cookie.@@ -316,9 +318,9 @@ , cookSecure :: Maybe Bool -- ^Is this cookie secure? , cookExpiry :: Maybe Integer -- ^Expiry date expressed as -- seconds since the Unix epoch- -- Nothing indicates that the + -- Nothing indicates that the -- cookie never expires- } deriving (Eq, Show) + } 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.@@ -328,7 +330,7 @@ cookSecure = Nothing, cookExpiry = Nothing } --- This line causes a strange out of scope error. Moving to the bottom of the +-- 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 ) @@ -339,7 +341,7 @@ <*> opt "domain" Nothing <*> opt "secure" Nothing <*> opt "expiry" Nothing- where + where req :: FromJSON a => Text -> Parser a req = (o .:) opt :: FromJSON a => Text -> a -> Parser a@@ -351,12 +353,12 @@ 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 +-- 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 +-- |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) ()@@ -374,12 +376,12 @@ getTitle = doSessCommand GET "/title" () -- |Specifies element(s) within a DOM tree using various selection methods.-data Selector = ById Text +data Selector = ById Text | ByName Text- | ByClass Text -- ^ (Note: multiple classes are not + | ByClass Text -- ^ (Note: multiple classes are not -- allowed. For more control, use 'ByCSS')- | ByTag Text - | ByLinkText Text + | ByTag Text+ | ByLinkText Text | ByPartialLinkText Text | ByCSS Text | ByXPath Text@@ -409,7 +411,7 @@ -- |Return the element that currently has focus. activeElem :: WebDriver wd => wd Element-activeElem = doSessCommand POST "/element/active" () +activeElem = doSessCommand POST "/element/active" () -- |Search for an element using the given element as root. findElemFrom :: WebDriver wd => Element -> Selector -> wd Element@@ -419,7 +421,7 @@ findElemsFrom :: WebDriver wd => Element -> Selector -> wd [Element] findElemsFrom e = doElemCommand POST e "/elements" --- |Describe the element. Returns a JSON object whose meaning is currently +-- |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 "" ()@@ -438,7 +440,7 @@ 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 +-- 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]@@ -482,7 +484,7 @@ -- |Retrieve an element's current size. elemSize :: WebDriver wd => Element -> wd (Word, Word)-elemSize e = doElemCommand GET e "/size" () +elemSize e = doElemCommand GET e "/size" () >>= parsePair "width" "height" "elemSize" infix 4 <==>@@ -539,13 +541,13 @@ -- |Moves the mouse to the center of a given element. moveToCenter :: WebDriver wd => Element -> wd ()-moveToCenter (Element e) = +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" +moveToFrom (x,y) (Element e) =+ doSessCommand POST "/moveto" . triple ("element","xoffset","yoffset") $ (e,x,y) -- |A mouse button@@ -554,7 +556,7 @@ instance ToJSON MouseButton where toJSON = toJSON . fromEnum- + instance FromJSON MouseButton where parseJSON v = do n <- parseJSON v@@ -574,7 +576,7 @@ withMouseDown :: WebDriver wd => wd a -> wd a withMouseDown wd = mouseDown >> wd <* mouseUp --- |Press and hold the left mouse button down. Note that undefined behavior +-- |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" ()@@ -589,8 +591,8 @@ -- |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 +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 ()@@ -612,7 +614,7 @@ -- |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) = +touchScrollFrom (x, y) (Element e) = doSessCommand POST "/touch/scroll" . triple ("xoffset", "yoffset", "element") $ (x, y, e)@@ -626,29 +628,29 @@ 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 +-- |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 => +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) = +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" () +getLocation = doSessCommand GET "/location" () >>= parseTriple "latitude" "longitude" "altitude" "getLocation" -- |Set the current geographical location of the device.@@ -660,11 +662,11 @@ -- |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 + -> Integer -- ^Modification time -- (in seconds since Unix epoch). -> LBS.ByteString -- ^ The file contents as a lazy ByteString -> wd ()@@ -675,9 +677,8 @@ -- 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)+uploadZipEntry = doSessCommand POST "/file" . single "file"+ . B64.encode . fromArchive . (`addEntryToArchive` emptyArchive) -- |Get the current number of keys in a web storage area.@@ -693,9 +694,9 @@ deleteAllKeys s = doStorageCommand DELETE s "" () -- |An HTML 5 storage type-data WebStorageType = LocalStorage | SessionStorage +data WebStorageType = LocalStorage | SessionStorage deriving (Eq, Show, Ord, Bounded, Enum)- + -- |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.@@ -706,7 +707,7 @@ 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. +-- |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) () @@ -719,6 +720,6 @@ SessionStorage -> "session_storage" --- Moving this closer to the definition of Cookie seems to cause strange compile +-- Moving this closer to the definition of Cookie seems to cause strange compile -- errors, so I'm leaving it here for now. $( deriveToJSON (map C.toLower . drop 4) ''Cookie )
src/Test/WebDriver/Commands/Internal.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE OverloadedStrings, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} {-# OPTIONS_HADDOCK not-home #-}--- |Internal functions used to implement the functions exported by --- "Test.WebDriver.Commands". These may be useful for implementing non-standard +-- |Internal functions used to implement the functions exported by+-- "Test.WebDriver.Commands". These may be useful for implementing non-standard -- webdriver commands.-module Test.WebDriver.Commands.Internal +module Test.WebDriver.Commands.Internal (-- * Low-level webdriver functions doCommand -- ** Commands with :sessionId URL parameter@@ -41,7 +41,7 @@ {- |An opaque identifier for a browser window -} newtype WindowHandle = WindowHandle Text- deriving (Eq, Ord, Show, Read, + deriving (Eq, Ord, Show, Read, FromJSON, ToJSON) instance Default WindowHandle where def = currentWindow@@ -52,42 +52,42 @@ currentWindow = WindowHandle "current" instance Exception NoSessionId--- |A command requiring a session ID was attempted when no session ID was +-- |A command requiring a session ID was attempted when no session ID was -- available.-newtype NoSessionId = NoSessionId String +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\", where--- :sessionId is a URL parameter as described in +-- :sessionId is a URL parameter as described in -- <http://code.google.com/p/selenium/wiki/JsonWireProtocol>-doSessCommand :: (WebDriver wd, ToJSON a, FromJSON b) => +doSessCommand :: (WebDriver wd, ToJSON a, FromJSON b) => RequestMethod -> Text -> a -> wd b doSessCommand method path args = do WDSession { wdSessId = mSessId } <- getSession- case mSessId of + case mSessId of Nothing -> throwIO . NoSessionId $ msg- where + where msg = "doSessCommand: No session ID found for relative URL " ++ show path- Just (SessionId sId) -> doCommand method + Just (SessionId sId) -> doCommand method (T.concat ["/session/", sId, path]) args -- |A wrapper around 'doSessCommand' to create element URLs.--- For example, passing a URL of "/active" will expand to +-- For example, passing a URL of "/active" will expand to -- \"/session/:sessionId/element/:id/active\", where :sessionId and :id are URL -- parameters as described in the wire protocol.-doElemCommand :: (WebDriver wd, ToJSON a, FromJSON b) => +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 wrapper around 'doSessCommand' to create window handle URLS. -- For example, passing a URL of \"/size\" will expand to--- \"/session/:sessionId/window/:windowHandle/\", where :sessionId and +-- \"/session/:sessionId/window/:windowHandle/\", where :sessionId and -- :windowHandle are URL parameters as described in the wire protocol-doWinCommand :: (WebDriver wd, ToJSON a, FromJSON b) => +doWinCommand :: (WebDriver wd, ToJSON a, FromJSON b) => RequestMethod -> WindowHandle -> Text -> a -> wd b-doWinCommand m (WindowHandle w) path a = +doWinCommand m (WindowHandle w) path a = doSessCommand m (T.concat ["/window/", w, path]) a
src/Test/WebDriver/Commands/Wait.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, FlexibleContexts #-}-module Test.WebDriver.Commands.Wait +module Test.WebDriver.Commands.Wait ( -- * Wait on expected conditions waitUntil, waitUntil' , waitWhile, waitWhile'@@ -24,11 +24,13 @@ instance Exception ExpectFailed -- |An exception representing the failure of an expected condition.-data ExpectFailed = ExpectFailed deriving (Show, Eq, Typeable)+data ExpectFailed = ExpectFailed String deriving (Show, Eq, Typeable) -- |throws 'ExpectFailed'. This is nice for writing your own abstractions.-unexpected :: MonadBaseControl IO m => m a-unexpected = throwIO ExpectFailed+unexpected :: MonadBaseControl IO m =>+ String -- ^ Reason why the expected condition failed.+ -> 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@@ -36,22 +38,22 @@ expect :: MonadBaseControl IO m => Bool -> m () expect b | b = return ()- | otherwise = unexpected+ | otherwise = unexpected "Test.WebDriver.Commands.Wait.expect" --- |Apply a monadic predicate to every element in a list, and 'expect' that +-- |Apply a monadic 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 monadic predicate to every element in a list, and 'expect' that all +-- |Apply a monadic 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 .5 seconds until no 'ExpectFailed' or--- 'FailedCommand' 'NoSuchElement' exceptions occur. If the timeout is reached, --- then a 'Timeout' exception will be raised. The timeout value +-- 'FailedCommand' 'NoSuchElement' exceptions occur. If the timeout is reached,+-- then a 'Timeout' exception will be raised. The timeout value -- is expressed in seconds. waitUntil :: SessionState m => Double -> m a -> m a waitUntil = waitUntil' 500000@@ -67,7 +69,7 @@ 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@@ -75,12 +77,12 @@ waitWhile :: SessionState m => Double -> m a -> m () waitWhile = waitWhile' 500000 --- |Like 'waitUntil'', but retries the action until it either fails or +-- |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 + handler retry wd = do b <- (wd >> return True) `catches` [Handler handleFailedCommand ,Handler handleExpectFailed ]@@ -88,25 +90,25 @@ where handleFailedCommand (FailedCommand NoSuchElement _) = return False handleFailedCommand err = throwIO err- + handleExpectFailed (_ :: ExpectFailed) = return False- -wait' :: SessionState m => ++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 + where retry = do now <- liftBase getCurrentTime if diffUTCTime now startTime >= timeout- then + then failedCommand Timeout "wait': explicit wait timed out."- else do + else do liftBase . threadDelay $ waitAmnt waitLoop startTime --- |Convenience function to catch 'FailedCommand' 'Timeout' exceptions +-- |Convenience function to catch 'FailedCommand' 'Timeout' exceptions -- and perform some action. -- -- Example:
src/Test/WebDriver/Common/Profile.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE CPP, TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, +{-# LANGUAGE CPP, TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, GeneralizedNewtypeDeriving, OverloadedStrings, FlexibleContexts #-} {-# OPTIONS_HADDOCK not-home #-}--- |A type for profile preferences. These preference values are used by both +-- |A type for profile preferences. These preference values are used by both -- Firefox and Opera profiles. module Test.WebDriver.Common.Profile ( -- *Profiles and profile preferences@@ -20,7 +20,7 @@ , prepareZippedProfile, prepareZipArchive, prepareRawZip -- *Profile errors- , ProfileParseError(..) + , ProfileParseError(..) ) where import System.Directory@@ -49,16 +49,16 @@ import Control.Monad.Base -- |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 profiles; when a distinction +-- deferring execution of IO operations until the profile is \"prepared\". This+-- type is shared by both Firefox and Opera profiles; when a distinction -- must be made, the phantom type parameter is used to differentiate.-data Profile b = Profile +data Profile b = Profile { -- |A mapping from relative destination filepaths to source- -- filepaths found on the filesystem. When the profile is + -- filepaths found on the filesystem. When the profile is -- prepared, these source filepaths will be moved to their -- destinations within the profile directory. --- -- Using the destination path as the key ensures that + -- Using the destination path as the key ensures that -- there is one unique source path going to each -- destination path. profileFiles :: HM.HashMap FilePath FilePath@@ -69,14 +69,14 @@ } deriving (Eq, Show) --- |Represents a profile that has been prepared for +-- |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) instance FromJSON (PreparedProfile s) where parseJSON v = PreparedProfile <$> parseJSON v- + instance ToJSON (PreparedProfile s) where toJSON (PreparedProfile s) = toJSON s @@ -113,13 +113,13 @@ 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 @@ -141,10 +141,10 @@ 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 @@ -164,7 +164,7 @@ deletePref k p = onProfilePrefs p $ HM.delete k -- |Add a file to the profile directory. The first argument is the source--- of the file on the local filesystem. The second argument is the destination +-- of the file on the local filesystem. The second argument is the destination -- as a path relative to a profile directory. Overwrites any file that -- previously pointed to the same destination addFile :: FilePath -> FilePath -> Profile b -> Profile b@@ -186,35 +186,35 @@ addExtension path = addFile path ("extensions" </> name) where (_, name) = splitFileName path --- |Delete an existing extension from the profile. The string parameter --- should refer to an .xpi file or directory located within the extensions --- directory of the profile. This operation has no effect if the extension was +-- |Delete an existing extension from the profile. The string parameter+-- should refer to an .xpi file or directory located within the extensions+-- directory of the profile. This operation has no effect if the extension was -- never added to the profile. deleteExtension :: String -> Profile b -> Profile b deleteExtension name = deleteFile ("extensions" </> name) --- |Determines if a profile contains the given extension. specified as an +-- |Determines if a profile contains the given extension. specified as an -- .xpi file or directory name hasExtension :: String -> Profile b -> Bool hasExtension name prof = hasFile ("extensions" </> name) prof --- |Takes the union of two profiles. This is the union of their 'HashMap' +-- |Takes the union of two profiles. This is the union of their 'HashMap' -- fields. unionProfiles :: Profile b -> Profile b -> Profile b-unionProfiles (Profile f1 p1) (Profile f2 p2) +unionProfiles (Profile f1 p1) (Profile f2 p2) = Profile (f1 `HM.union` f2) (p1 `HM.union` p2) -- |Modifies the 'profilePrefs' field of a profile. onProfilePrefs :: Profile b- -> (HM.HashMap Text ProfilePref + -> (HM.HashMap Text ProfilePref -> HM.HashMap Text ProfilePref) -> Profile b onProfilePrefs (Profile hs hm) f = Profile hs (f hm) -- |Modifies the 'profileFiles' field of a profile onProfileFiles :: Profile b- -> (HM.HashMap FilePath FilePath + -> (HM.HashMap FilePath FilePath -> HM.HashMap FilePath FilePath) -> Profile b onProfileFiles (Profile ls hm) f = Profile (f ls) hm@@ -228,13 +228,13 @@ oldWd <- getCurrentDirectory setCurrentDirectory path prepareZipArchive <$>- liftBase (addFilesToArchive [OptRecursive] + liftBase (addFilesToArchive [OptRecursive] emptyArchive ["."]) <* setCurrentDirectory oldWd -- |Prepare a zip file of a profile on disk for network transmission. -- This function is very efficient at loading large profiles from disk.-prepareZippedProfile :: MonadBase IO m => +prepareZippedProfile :: MonadBase IO m => FilePath -> m (PreparedProfile a) prepareZippedProfile path = prepareRawZip <$> liftBase (LBS.readFile path) @@ -245,4 +245,3 @@ -- |Prepare a ByteString of raw zip data for network transmission prepareRawZip :: LBS.ByteString -> PreparedProfile a prepareRawZip = PreparedProfile . B64.encode . SBS.concat . LBS.toChunks-
src/Test/WebDriver/Exceptions.hs view
@@ -1,4 +1,4 @@-module Test.WebDriver.Exceptions +module Test.WebDriver.Exceptions ( InvalidURL(..), NoSessionId(..), BadJSON(..) , HTTPStatusUnknown(..), HTTPConnError(..) , UnknownCommand(..), ServerError(..)
src/Test/WebDriver/Firefox/Profile.hs view
@@ -1,10 +1,10 @@-{-# LANGUAGE CPP, OverloadedStrings, FlexibleContexts, - GeneralizedNewtypeDeriving, EmptyDataDecls, +{-# LANGUAGE CPP, OverloadedStrings, FlexibleContexts,+ GeneralizedNewtypeDeriving, EmptyDataDecls, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- suppress warnings from attoparsec -- |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 +-- in pure code and then \"prepared\" for network transmission.+module Test.WebDriver.Firefox.Profile ( -- * Profiles Firefox, Profile(..), PreparedProfile , defaultProfile@@ -55,7 +55,7 @@ -- |Default Firefox Profile, used when no profile is supplied. defaultProfile :: Profile Firefox-defaultProfile = +defaultProfile = Profile HM.empty $ HM.fromList [("app.update.auto", PrefBool False) ,("app.update.enabled", PrefBool False)@@ -112,7 +112,7 @@ ,("dom.max_script_run_time", PrefInteger 30) ] where-#ifdef darwin_HOST_OS +#ifdef darwin_HOST_OS native_events = PrefBool False #else native_events = PrefBool True@@ -123,38 +123,38 @@ -- the 'Profile' will have no effect to the profile on disk. -- -- To make automated browser run smoothly, preferences found in--- 'defaultProfile' are automatically merged into the preferences of the on-disk-- profile. The on-disk profile's preference will override those found in the +-- 'defaultProfile' are automatically merged into the preferences of the on-disk-- profile. The on-disk profile's preference will override those found in the -- default profile. loadProfile :: MonadBaseControl IO m => FilePath -> m (Profile Firefox) loadProfile path = liftBase $ do unionProfiles defaultProfile <$> (Profile <$> getFiles <*> getPrefs) where userPrefFile = path </> "prefs" <.> "js"- + getFiles = HM.fromList . map (id &&& (path </>)) . filter isNotIgnored <$> getDirectoryContents path- where isNotIgnored = (`notElem` + where isNotIgnored = (`notElem` [".", "..", "OfflineCache", "Cache" ,"parent.lock", ".parentlock", ".lock" ,userPrefFile])- + getPrefs = HM.fromList <$> (parsePrefs =<< BS.readFile userPrefFile)- where parsePrefs s = either (throwIO . ProfileParseError) return + where 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 +-- 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. ----- NOTE: because this function has to copy the profile files into a +-- NOTE: because this function has to copy the profile files into a -- a temp directory before zip archiving them, this operation is likely to be slow--- for large profiles. In such a case, consider using 'prepareLoadedProfile_' or +-- for large profiles. In such a case, consider using 'prepareLoadedProfile_' or -- 'prepareZippedProfile' instead.-prepareProfile :: MonadBaseControl IO m => +prepareProfile :: MonadBaseControl IO m => Profile Firefox -> m (PreparedProfile Firefox)-prepareProfile Profile {profileFiles = files, profilePrefs = prefs} - = liftBase $ do +prepareProfile Profile {profileFiles = files, profilePrefs = prefs}+ = liftBase $ do tmpdir <- mkTemp mapM_ (installPath tmpdir) . HM.toList $ files installUserPrefs tmpdir@@ -167,7 +167,7 @@ if isDir then do createDirectoryIfMissing True dest `catch` ignoreIOException- FS.getDirectory src + FS.getDirectory src >>= handle ignoreIOException . FS.copyTo_ dest else do let dir = takeDirectory dest@@ -176,20 +176,20 @@ copyFile src dest `catch` ignoreIOException where ignoreIOException :: IOException -> IO ()- ignoreIOException = print - + ignoreIOException = print+ installUserPrefs d = LBS.writeFile (d </> "user" <.> "js") str where str = LBS.concat- . map (\(k, v) -> LBS.concat [ "user_pref(", encode k, - ", ", encode v, ");\n"]) - . HM.toList $ prefs + . map (\(k, v) -> LBS.concat [ "user_pref(", encode k,+ ", ", encode v, ");\n"])+ . HM.toList $ prefs -- |Apply a function on a 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 :: MonadBaseControl IO m => - (Profile Firefox -> Profile Firefox) +prepareTempProfile :: MonadBaseControl IO m =>+ (Profile Firefox -> Profile Firefox) -> m (PreparedProfile Firefox) prepareTempProfile f = prepareProfile . f $ defaultProfile @@ -202,11 +202,11 @@ -> (Profile Firefox -> Profile Firefox) -> m (PreparedProfile Firefox) prepareLoadedProfile path f = liftM f (loadProfile path) >>= prepareProfile- + -- firefox prefs.js parser prefsParser :: Parser [(Text, ProfilePref)]-prefsParser = many1 $ do +prefsParser = many1 $ do padSpaces $ string "user_pref(" k <- prefKey <?> "preference key" padSpaces $ char ','@@ -215,20 +215,20 @@ return (k,v) where prefKey = jstring- prefVal = do + prefVal = do v <- value' case fromJSON v of Error str -> fail str Success p -> return p- + padSpaces p = spaces >> p <* spaces- spaces = many (endOfLine <|> void space <|> void comment) + spaces = many (endOfLine <|> void space <|> void comment) where comment = inlineComment <|> lineComment lineComment = char '#' *> manyTill anyChar endOfLine inlineComment = string "/*" *> manyTill anyChar (string "*/")- - ++ mkTemp :: IO FilePath mkTemp = do d <- getTemporaryDirectory
src/Test/WebDriver/Internal.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE FlexibleContexts, OverloadedStrings, DeriveDataTypeable #-}-module Test.WebDriver.Internal +module Test.WebDriver.Internal ( mkWDUri, mkRequest , handleHTTPErr, handleJSONErr, handleHTTPResp- + , InvalidURL(..), HTTPStatusUnknown(..), HTTPConnError(..) , UnknownCommand(..), ServerError(..)- + , FailedCommand(..), failedCommand, mkFailedCommandInfo , FailedCommandType(..), FailedCommandInfo(..), StackFrame(..) ) where@@ -33,87 +33,88 @@ import Control.Exception (Exception) import Data.Typeable (Typeable) import Data.List (isInfixOf)-import Data.Maybe (fromJust, fromMaybe)+import Data.Maybe (fromMaybe) import Data.String (fromString) import Data.Word (Word, Word8) -mkWDUri :: (SessionState s) => String -> s URI --todo: remove String :(+mkWDUri :: (SessionState s) => String -> s URI mkWDUri path = do WDSession{wdHost = host, - wdPort = port+ wdPort = port,+ wdBasePath = basePath } <- getSession let urlStr = "http://" ++ host ++ ":" ++ show port- relPath = "/wd/hub" ++ path+ relPath = basePath ++ path mBaseURI = parseAbsoluteURI urlStr mRelURI = parseRelativeReference relPath case (mBaseURI, mRelURI) of- (Nothing, _) -> throwIO $ InvalidURL urlStr + (Nothing, _) -> throwIO $ InvalidURL urlStr (_, Nothing) -> throwIO $ InvalidURL relPath- (Just baseURI, Just relURI) -> return . fromJust $ relURI `relativeTo` baseURI- -mkRequest :: (SessionState s, ToJSON a) => + (Just baseURI, Just relURI) -> return $ 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 + other -> encode other req = Request { rqURI = uri --todo: normalization of headers , rqMethod = method , rqBody = body- , rqHeaders = headers ++ [ Header HdrAccept + , rqHeaders = headers ++ [ Header HdrAccept "application/json;charset=UTF-8"- , Header HdrContentType + , Header HdrContentType "application/json;charset=UTF-8"- , Header HdrContentLength - . show . BS.length $ body + , Header HdrContentLength+ . show . BS.length $ body ] } r <- liftBase (simpleHTTP req) >>= either (throwIO . HTTPConnError) return return r handleHTTPErr :: SessionState s => Response ByteString -> s ()-handleHTTPErr r@Response{rspBody = body, rspCode = code, rspReason = reason} = - case code of +handleHTTPErr r@Response{rspBody = body, rspCode = code, rspReason = reason} =+ case code of (4,_,_) -> err UnknownCommand- (5,_,_) -> + (5,_,_) -> case findHeader HdrContentType r of Just ct- | "application/json;" `isInfixOf` ct -> parseJSON' body - >>= handleJSONErr + | "application/json;" `isInfixOf` ct -> parseJSON' body+ >>= handleJSONErr | otherwise -> err ServerError- Nothing -> + Nothing -> err (ServerError . ("Missing content type. Server response: "++)) (2,_,_) -> return () (3,0,2) -> return () _ -> err (HTTPStatusUnknown code)- where + where err errType = throwIO $ errType reason- + handleHTTPResp :: (SessionState s, FromJSON a) => Response ByteString -> s a-handleHTTPResp resp@Response{rspBody = body, rspCode = code} = +handleHTTPResp resp@Response{rspBody = body, rspCode = code} = case code of (2,0,4) -> returnEmptyArray- (3,0,2) -> fromJSON' =<< maybe statusErr (return . String . fromString) + (3,0,2) -> fromJSON' =<< maybe statusErr (return . String . fromString) (findHeader HdrLocation resp)- where - statusErr = throwIO . HTTPStatusUnknown code + where+ statusErr = throwIO . HTTPStatusUnknown code $ (BS.unpack body)- other + 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 } + let screen = B64.decodeLenient <$> errScreen errInfo+ errInfo' = errInfo { errSess = sess+ , errScreen = screen } e errType = throwIO $ FailedCommand errType errInfo' case status of 7 -> e NoSuchElement@@ -135,7 +136,7 @@ 28 -> e ScriptTimeout 29 -> e InvalidElementCoordinates 30 -> e IMENotAvailable- 31 -> e IMEEngineActivationFailed + 31 -> e IMEEngineActivationFailed 32 -> e InvalidSelector 34 -> e MoveTargetOutOfBounds 51 -> e InvalidXPathSelector@@ -149,7 +150,7 @@ , rspVal :: Value } deriving (Eq, Show)- + instance FromJSON WDResponse where parseJSON (Object o) = WDResponse <$> o .:? "sessionId" .!= Nothing <*> o .: "status"@@ -159,7 +160,7 @@ instance Exception InvalidURL -- |An invalid URL was given-newtype InvalidURL = InvalidURL String +newtype InvalidURL = InvalidURL String deriving (Eq, Show, Typeable) instance Exception HTTPStatusUnknown@@ -174,7 +175,7 @@ instance Exception UnknownCommand -- |A command was sent to the WebDriver server that it didn't recognize.-newtype UnknownCommand = UnknownCommand String +newtype UnknownCommand = UnknownCommand String deriving (Eq, Show, Typeable) instance Exception ServerError@@ -217,12 +218,12 @@ deriving (Eq, Ord, Enum, Bounded, Show) -- |Detailed information about the failed command provided by the server.-data FailedCommandInfo = +data FailedCommandInfo = FailedCommandInfo { -- |The error message. errMsg :: String- -- |The session associated with + -- |The session associated with -- the exception.- , errSess :: WDSession + , errSess :: WDSession -- |A screen shot of the focused window -- when the exception occured, -- if provided.@@ -238,8 +239,8 @@ -- |Provides a readable printout of the error information, useful for -- logging. instance Show FailedCommandInfo where- show i = showChar '\n' - . showString "Session: " . sess + show i = showChar '\n'+ . showString "Session: " . sess . showChar '\n' . showString className . showString ": " . showString (errMsg i) . showChar '\n'@@ -247,8 +248,8 @@ $ "" where className = fromMaybe "<unknown exception>" . errClass $ i- - sess = showString sessId . showString " at " ++ sess = showString sessId . showString " at " . showString host . showChar ':' . shows port where sessId = case msid of@@ -264,12 +265,12 @@ return $ FailedCommandInfo {errMsg = m , errSess = sess , errScreen = Nothing , errClass = Nothing , errStack = [] } --- |Convenience function to throw a 'FailedCommand' locally with no server-side +-- |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 +-- |An individual stack frame from the stack trace provided by the server -- during a FailedCommand. data StackFrame = StackFrame { sfFileName :: String , sfClassName :: String@@ -280,7 +281,7 @@ instance Show StackFrame where- show f = showString (sfClassName f) . showChar '.' + show f = showString (sfClassName f) . showChar '.' . showString (sfMethodName f) . showChar ' ' . showParen True ( showString (sfFileName f) . showChar ':' . shows (sfLineNumber f))@@ -288,13 +289,13 @@ instance FromJSON FailedCommandInfo where- parseJSON (Object o) = + 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 + 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@@ -310,5 +311,3 @@ reqStr :: Text -> Parser String reqStr k = req k >>= maybe (return "") return parseJSON v = typeMismatch "StackFrame" v--
src/Test/WebDriver/JSON.hs view
@@ -2,10 +2,10 @@ -- |A collection of convenience functions for using and parsing JSON values -- within 'WD'. All monadic parse errors are converted to asynchronous -- 'BadJSON' exceptions.--- +-- -- These functions are used internally to implement webdriver commands, and may -- be useful for implementing non-standard commands.-module Test.WebDriver.JSON +module Test.WebDriver.JSON ( -- * Access a JSON object key (!:) -- * Conversion from JSON within WD@@ -14,16 +14,16 @@ , parseJSON', fromJSON' -- * Tuple functions -- |Convenience functions for working with tuples.- + -- ** JSON object constructors , single, pair, triple -- ** Extracting JSON objects into tuples- , parsePair, parseTriple + , 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 + -- in this module, and could be used to implement other JSON -- convenience functions- , apResultToWD, aesonResultToWD + , apResultToWD, aesonResultToWD -- * Parse exception , BadJSON(..) ) where@@ -43,21 +43,21 @@ instance Exception BadJSON -- |An error occured when parsing a JSON value.-newtype BadJSON = BadJSON String +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. +-- |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) => +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] @@ -79,25 +79,25 @@ -- |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) => +parsePair :: (MonadBaseControl IO wd, FromJSON a, FromJSON b) => String -> String -> String -> Value -> wd (a, b)-parsePair a b funcName v = +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 + _ -> 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 +-- 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 = +parseTriple a b c funcName v = case v of- Object o -> (,,) <$> o !: fromString a - <*> o !: fromString b + Object o -> (,,) <$> o !: fromString a+ <*> o !: fromString b <*> o !: fromString c _ -> throwIO . BadJSON $ funcName ++ ": cannot parse non-object JSON response as a (" ++ a@@ -105,7 +105,7 @@ --- |Convert an attoparsec parser result to 'WD'. +-- |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
src/Test/WebDriver/Monad.hs view
@@ -5,7 +5,7 @@ )where import Test.WebDriver.Classes-import Test.WebDriver.Commands +import Test.WebDriver.Commands import Test.WebDriver.Capabilities import Test.WebDriver.Internal @@ -19,7 +19,7 @@ import Control.Monad.CatchIO (MonadCatchIO) import Control.Applicative -{- |A monadic interface to the WebDriver server. This monad is a simple, strict +{- |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)@@ -30,8 +30,8 @@ instance MonadBaseControl IO WD where data StM WD a = StWD {unStWD :: StM (StateT WDSession IO) a}- - liftBaseWith f = WD $ ++ liftBaseWith f = WD $ liftBaseWith $ \runInBase -> f (\(WD sT) -> liftM StWD . runInBase $ sT) @@ -47,7 +47,7 @@ handleHTTPErr r handleHTTPResp r --- |Executes a 'WD' computation within the 'IO' monad, using the given +-- |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@@ -63,12 +63,12 @@ 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 +-- |A finalizer ensuring that the session is always closed at the end of -- the given 'WD' action, regardless of any exceptions.-finallyClose:: WebDriver wd => wd a -> wd a +finallyClose:: WebDriver wd => wd a -> wd a finallyClose wd = closeOnException wd <* closeSession --- |A variant of 'finallyClose' that only closes the session when an +-- |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 :: WebDriver wd => wd a -> wd a
src/Test/WebDriver/Types.hs view
@@ -1,17 +1,17 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable,- TemplateHaskell, OverloadedStrings, ExistentialQuantification, - MultiParamTypeClasses, TypeFamilies, + TemplateHaskell, OverloadedStrings, ExistentialQuantification,+ MultiParamTypeClasses, TypeFamilies, RecordWildCards #-} {-# OPTIONS_HADDOCK not-home #-}-module Test.WebDriver.Types +module Test.WebDriver.Types ( -- * WebDriver sessions WD(..), WDSession(..), defaultSession, SessionId(..) -- * Capabilities and configuration , Capabilities(..), defaultCaps, allCaps , Platform(..), ProxyType(..) -- ** Browser-specific configuration- , Browser(..), + , Browser(..), -- ** Default settings for browsers firefox, chrome, ie, opera, iPhone, iPad, android , LogPref(..)@@ -39,13 +39,3 @@ import Test.WebDriver.Commands import Test.WebDriver.Exceptions import Test.WebDriver.Capabilities-- ----- ---
webdriver.cabal view
@@ -1,5 +1,5 @@ Name: webdriver-Version: 0.4+Version: 0.5 Cabal-Version: >= 1.6 License: BSD3 License-File: LICENSE@@ -11,29 +11,29 @@ Build-type: Simple Extra-source-files: README.md, TODO, CHANGELOG.md, .ghci Description:- A Selenium WebDriver client for Haskell. - You can use it to automate browser sessions + A Selenium WebDriver client for Haskell.+ You can use it to automate browser sessions for testing, system administration, etc. . For more information about Selenium itself, see <http://seleniumhq.org/> . To find out what's been changed in this version and others,- see the change log at + see the change log at <https://github.com/kallisti-dev/hs-webdriver/blob/master/CHANGELOG.md> source-repository head type: git- location: git://github.com/kallisti-dev/hs-webdriver.git + location: git://github.com/kallisti-dev/hs-webdriver.git library hs-source-dirs: src- ghc-options: -Wall + ghc-options: -Wall build-depends: base == 4.* , aeson >= 0.4 && < 0.7 , HTTP >= 4000.1 && < 4000.3 , mtl >= 2.0 && < 2.2- , network == 2.*+ , network == 2.4.* , bytestring == 0.9.* , text >= 0.7 && < 0.12 , time == 1.*@@ -51,7 +51,7 @@ , filesystem-trees >= 0.1.0.2 && < 0.2 , data-default >= 0.2 && < 1.0 , temporary >= 1.0 && < 2.0- , base64-bytestring == 0.1.*+ , base64-bytestring >= 1.0 && < 1.1 , cond >= 0.3 && < 0.5 exposed-modules: Test.WebDriver