webdriver 0.5.4 → 0.5.5
raw patch · 10 files changed
+102/−77 lines, 10 files
Files
- src/Test/WebDriver.hs +1/−1
- src/Test/WebDriver/Capabilities.hs +41/−41
- src/Test/WebDriver/Classes.hs +19/−6
- src/Test/WebDriver/Commands.hs +11/−11
- src/Test/WebDriver/Commands/Wait.hs +3/−3
- src/Test/WebDriver/Firefox/Profile.hs +1/−1
- src/Test/WebDriver/Internal.hs +11/−11
- src/Test/WebDriver/Monad.hs +13/−1
- src/Test/WebDriver/Utils.hs +1/−1
- webdriver.cabal +1/−1
src/Test/WebDriver.hs view
@@ -6,7 +6,7 @@ ( -- * WebDriver sessions WD(..), WDSession(..), defaultSession, SessionId(..) -- * Running WebDriver tests- , runWD, runSession, withSession, finallyClose, closeOnException+ , runWD, runSession, withSession, finallyClose, closeOnException, dumpSessionHistory -- * WebDriver commands , module Test.WebDriver.Commands -- * Capabilities and configuration
src/Test/WebDriver/Capabilities.hs view
@@ -18,7 +18,7 @@ import Control.Applicative import Control.Exception.Lifted (throw)- + {- |A structure describing the capabilities of a session. This record serves dual roles. @@ -147,7 +147,7 @@ , "acceptSslCerts" .= acceptSSLCerts , "nativeEvents" .= nativeEvents , "unexpectedAlertBehavior" .= unexpectedAlertBehavior- ] + ] ++ browserInfo ++ additionalCaps where@@ -226,15 +226,15 @@ <*> b "nativeEvents" <*> opt "unexpectedAlertBehaviour" Nothing <*> pure (additionalCapabilities browser)- - where --some helpful JSON accessor shorthands ++ where --some helpful JSON accessor shorthands 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- + -- produce additionalCaps by removing known capabilities from the JSON object additionalCapabilities = HM.toList . foldr HM.delete o . knownCapabilities @@ -253,9 +253,9 @@ ,"logFile", "logLevel", "host", "extractPath", "silent", "forceCreateProcess", "internetExplorerSwitches"] Opera {} -> ["opera.binary", "opera.product", "opera.no_quit", "opera.autostart", "opera.idle", "opera.display" ,"opera.launcher", "opera.port", "opera.host", "opera.arguments", "opera.logging.file", "opera.logging.level"]- _ -> [] + _ -> [] getBrowserCaps browser =- case browser of + case browser of Firefox {} -> Firefox <$> opt "firefox_profile" Nothing <*> opt "loggingPrefs" def <*> opt "firefox_binary" Nothing@@ -284,14 +284,14 @@ <*> opt "opera.autostart" True <*> opt "opera.idle" False <*> opt "opera.display" Nothing- <*> opt "opera.launcher" Nothing + <*> opt "opera.launcher" Nothing <*> opt "opera.port" (Just 0) <*> opt "opera.host" Nothing <*> opt "opera.arguments" Nothing <*> opt "opera.logging.file" Nothing <*> opt "opera.logging.level" def _ -> return browser- + parseJSON v = typeMismatch "Capabilities" v -- |This constructor simultaneously specifies which browser the session will@@ -334,30 +334,30 @@ -- |Indicates whether to skip the check that the browser's zoom -- level is set to 100%. Value is set to false by default. , ieIgnoreZoomSetting :: Bool- -- |Allows the user to specify the initial URL loaded when IE + -- |Allows the user to specify the initial URL loaded when IE -- starts. Intended to be used with ignoreProtectedModeSettings- -- to allow the user to initialize IE in the proper Protected Mode + -- to allow the user to initialize IE in the proper Protected Mode -- zone. Using this capability may cause browser instability or -- flaky and unresponsive code. Only \"best effort\" support is -- provided when using this capability. , ieInitialBrowserUrl :: Maybe Text- -- |Allows the user to specify whether elements are scrolled into - -- the viewport for interaction to align with the top or bottom - -- of the viewport. The default value is to align with the top of + -- |Allows the user to specify whether elements are scrolled into+ -- the viewport for interaction to align with the top or bottom+ -- of the viewport. The default value is to align with the top of -- the viewport. , ieElementScrollBehavior :: IEElementScrollBehavior- -- |Determines whether persistent hovering is enabled (true by - -- default). Persistent hovering is achieved by continuously firing - -- mouse over events at the last location the mouse cursor has been + -- |Determines whether persistent hovering is enabled (true by+ -- default). Persistent hovering is achieved by continuously firing+ -- mouse over events at the last location the mouse cursor has been -- moved to. , ieEnablePersistentHover :: Bool- -- |Determines whether the driver should attempt to remove obsolete - -- elements from the element cache on page navigation (true by + -- |Determines whether the driver should attempt to remove obsolete+ -- elements from the element cache on page navigation (true by -- default). This is to help manage the IE driver's memory footprint -- , removing references to invalid elements. , ieEnableElementCacheCleanup :: Bool- -- |Determines whether to require that the IE window have focus - -- before performing any user interaction operations (mouse or + -- |Determines whether to require that the IE window have focus+ -- before performing any user interaction operations (mouse or -- keyboard events). This capability is false by default, but -- delivers much more accurate native events interactions. , ieRequireWindowFocus :: Bool@@ -365,26 +365,26 @@ -- locate and attach to a newly opened instance of Internet Explorer -- . The default is zero, which indicates waiting indefinitely. , ieBrowserAttachTimeout :: Integer- -- |The path to file where server should write log messages to. + -- |The path to file where server should write log messages to. -- By default it writes to stdout. , ieLogFile :: Maybe FilePath -- |The log level used by the server. Defaults to 'IELogFatal' , ieLogLevel :: IELogLevel- -- |The address of the host adapter on which the server will listen + -- |The address of the host adapter on which the server will listen -- for commands. , ieHost :: Maybe Text- -- |The path to the directory used to extract supporting files used + -- |The path to the directory used to extract supporting files used -- by the server. Defaults to the TEMP directory if not specified. , ieExtractPath :: Maybe Text -- |Suppresses diagnostic output when the server is started. , ieSilent :: Bool- -- |Forces launching Internet Explorer using the CreateProcess API. + -- |Forces launching Internet Explorer using the CreateProcess API. -- If this option is not specified, IE is launched using the- -- IELaunchURL, if it is available. For IE 8 and above, this option + -- IELaunchURL, if it is available. For IE 8 and above, this option -- requires the TabProcGrowth registry value to be set to 0. , ieForceCreateProcess :: Bool- -- |Specifies command-line switches with which to launch Internet - -- Explorer. This is only valid when used with the + -- |Specifies command-line switches with which to launch Internet+ -- Explorer. This is only valid when used with the -- forceCreateProcess. , ieSwitches :: Maybe Text }@@ -477,7 +477,7 @@ chrome :: Browser chrome = Chrome Nothing Nothing [] [] --- |Default IE settings. See the 'IE' constructor for more details on +-- |Default IE settings. See the 'IE' constructor for more details on -- individual defaults ie :: Browser ie = IE { ieIgnoreProtectedModeSettings = True@@ -600,21 +600,21 @@ ,"httpProxy" .= http ] -data UnexpectedAlertBehavior = AcceptAlert | DismissAlert | IgnoreAlert +data UnexpectedAlertBehavior = AcceptAlert | DismissAlert | IgnoreAlert deriving (Bounded, Enum, Eq, Ord, Read, Show)- + instance ToJSON UnexpectedAlertBehavior where toJSON AcceptAlert = String "accept" toJSON DismissAlert = String "dismiss" toJSON IgnoreAlert = String "ignore"- + instance FromJSON UnexpectedAlertBehavior where- parseJSON (String s) = + parseJSON (String s) = return $ case s of "accept" -> AcceptAlert "dismiss" -> DismissAlert "ignore" -> IgnoreAlert- err -> throw . BadJSON + err -> throw . BadJSON $ "Invalid string value for UnexpectedAlertBehavior: " ++ show err parseJSON v = typeMismatch "UnexpectedAlertBehavior" v @@ -651,8 +651,8 @@ "ALL" -> LogAll _ -> throw . BadJSON $ "Invalid logging preference: " ++ show s parseJSON other = typeMismatch "LogLevel" other- + -- |Logging levels for Internet Explorer data IELogLevel = IELogTrace | IELogDebug | IELogInfo | IELogWarn | IELogError | IELogFatal@@ -685,19 +685,19 @@ -- |Specifies how elements scroll into the viewport. (see 'ieElementScrollBehavior') data IEElementScrollBehavior = AlignTop | AlignBottom deriving (Eq, Ord, Show, Read, Enum, Bounded)- -instance Default IEElementScrollBehavior where ++instance Default IEElementScrollBehavior where def = AlignTop- + instance ToJSON IEElementScrollBehavior where toJSON AlignTop = toJSON (0 :: Int) toJSON AlignBottom = toJSON (1 :: Int)- + instance FromJSON IEElementScrollBehavior where parseJSON v = do n <- parseJSON v- case n :: Integer of + case n :: Integer of 0 -> return AlignTop 1 -> return AlignBottom _ -> fail $ "Invalid integer for IEElementScrollBehavior: " ++ show n- +
src/Test/WebDriver/Classes.hs view
@@ -6,13 +6,14 @@ -- * SessionState class SessionState(..), modifySession -- ** WebDriver sessions- , WDSession(..), SessionId(..), defaultSession+ , WDSession(..), lastHTTPRequest, SessionId(..), defaultSession ) where --import Test.WebDriver.Internal import Data.Aeson+import Data.Maybe import Network.HTTP (RequestMethod(..))-import Network.HTTP.Base (Request)+import Network.HTTP.Base (Request, Response) import Data.ByteString.Lazy (ByteString) import Data.Text (Text)@@ -52,7 +53,7 @@ -> Text -- ^URL of request -> a -- ^JSON parameters passed in the body -- of the request. Note that, as a special case,- -- anything that converts to Data.Aeson.Null will + -- anything that converts to Data.Aeson.Null will -- result in an empty request body. -> wd b -- ^The JSON result of the HTTP request. @@ -79,16 +80,28 @@ -- and closed automatically with -- 'Test.WebDriver.runSession' , wdSessId :: Maybe SessionId- -- |The last HTTP request issued by this session, if any. - , lastHTTPRequest :: Maybe (Request ByteString)+ -- |The complete history of HTTP requests and+ -- responses (updated in 'doCommand', most recent+ -- first).+ , wdSessHist :: [(Request ByteString, Response ByteString)]+ -- |If 'wdKeepSessHist' is 'True', 'wdSessHist'+ -- contains the full session history.+ -- Otherwise, only the last request/response+ -- pair is stored (O(1) heap consumption).+ , wdKeepSessHist :: Bool } deriving (Show) +-- |The last HTTP request issued by this session, if any.+lastHTTPRequest :: WDSession -> Maybe (Request ByteString)+lastHTTPRequest = fmap fst . listToMaybe . wdSessHist+ instance Default WDSession where def = WDSession { wdHost = "127.0.0.1" , wdPort = 4444 , wdBasePath = "/wd/hub" , wdSessId = Nothing- , lastHTTPRequest = Nothing+ , wdSessHist = []+ , wdKeepSessHist = False } {- |A default session connects to localhost on port 4444, and hasn't been
src/Test/WebDriver/Commands.hs view
@@ -623,30 +623,30 @@ -- to the given element. touchScrollFrom :: WebDriver wd => (Int, Int) -> Element -> wd () touchScrollFrom (x, y) (Element e) =- noReturn + noReturn . 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) = +touchDoubleClick (Element e) = noReturn . doSessCommand POST "/touch/doubleclick" . single "element" $ e -- |Emulate a long click on a touch device. touchLongClick :: WebDriver wd => Element -> wd ()-touchLongClick (Element e) = - noReturn +touchLongClick (Element e) =+ noReturn . 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 = - noReturn +touchFlick =+ noReturn . doSessCommand POST "/touch/flick" . pair ("xSpeed", "ySpeed") @@ -672,7 +672,7 @@ -- |Set the current geographical location of the device. setLocation :: WebDriver wd => (Int, Int, Int) -> wd ()-setLocation = noReturn . doSessCommand POST "/location" +setLocation = noReturn . doSessCommand POST "/location" . triple ("latitude", "longitude", "altitude")@@ -744,9 +744,9 @@ serverStatus = doCommand GET "/status" Null -- |A record that represents a single log entry.-data LogEntry = - LogEntry { logTime :: Integer -- ^ timestamp for the log entry. The standard - -- does not specify the epoch or the unit of +data LogEntry =+ LogEntry { logTime :: Integer -- ^ timestamp for the log entry. The standard+ -- does not specify the epoch or the unit of -- time. , logLevel :: LogLevel -- ^ log verbosity level , logMsg :: Text@@ -787,7 +787,7 @@ 4 -> return UpdateReady 5 -> return Obsolete err -> fail $ "Invalid JSON for ApplicationCacheStatus: " ++ show err- + getApplicationCacheStatus :: (WebDriver wd) => wd ApplicationCacheStatus getApplicationCacheStatus = doSessCommand GET "/application_cache/status" Null
src/Test/WebDriver/Commands/Wait.hs view
@@ -99,14 +99,14 @@ wait' :: SessionState m => ((String -> m b) -> m a -> m b) -> Int -> Double -> m a -> m b wait' handler waitAmnt t wd = waitLoop =<< liftBase getCurrentTime- where + where timeout = realToFrac t waitLoop startTime = handler retry wd where retry why = do now <- liftBase getCurrentTime- if diffUTCTime now startTime >= timeout - then + if diffUTCTime now startTime >= timeout+ then failedCommand Timeout $ "wait': explicit wait timed out (" ++ why ++ ")." else do liftBase . threadDelay $ waitAmnt
src/Test/WebDriver/Firefox/Profile.hs view
@@ -197,7 +197,7 @@ -- |Convenience function to load an existing Firefox profile from disk, apply -- a handler function, and then prepare the result for network transmission.--- +-- -- NOTE: like 'prepareProfile', the same caveat about large profiles applies. prepareLoadedProfile :: MonadBaseControl IO m => FilePath
src/Test/WebDriver/Internal.hs view
@@ -39,8 +39,8 @@ -- |Take a URL path and construct a full URL using the current session state mkWDUri :: (SessionState s) => String -> s URI-mkWDUri wdPath = do - WDSession{wdHost = host, +mkWDUri wdPath = do+ WDSession{wdHost = host, wdPort = port, wdBasePath = basePath } <- getSession@@ -75,18 +75,18 @@ -sendHTTPRequest :: SessionState s => Request ByteString -> s (Response ByteString) +sendHTTPRequest :: SessionState s => Request ByteString -> s (Response ByteString) sendHTTPRequest req = do- r <- liftBase (simpleHTTP req) >>= either (throwIO . HTTPConnError) return- modifySession $ \s -> s {lastHTTPRequest = Just req} -- update lastHTTPRequest field- return r+ res <- liftBase (simpleHTTP req) >>= either (throwIO . HTTPConnError) return+ modifySession $ \s -> s {wdSessHist = (req, res) : if wdKeepSessHist s then wdSessHist s else []} -- update httpScript field+ return res handleHTTPErr :: SessionState s => Response ByteString -> s () handleHTTPErr r@Response{rspBody = body, rspCode = code, rspReason = reason} = case code of (4,_,_) -> do- lastReq <- lastHTTPRequest <$> getSession - throwIO . UnknownCommand . maybe reason show + lastReq <- lastHTTPRequest <$> getSession+ throwIO . UnknownCommand . maybe reason show $ lastReq (5,_,_) -> case findHeader HdrContentType r of@@ -98,7 +98,7 @@ err (ServerError . ("Missing content type. Server response: "++)) (2,_,_) -> return ()- (3,0,x) | x `elem` [2,3] + (3,0,x) | x `elem` [2,3] -> return () _ -> err (HTTPStatusUnknown code) where@@ -110,7 +110,7 @@ (2,0,4) -> noReturn (3,0,x) | x `elem` [2,3] ->- case findHeader HdrLocation resp of + case findHeader HdrLocation resp of Nothing -> throwIO . HTTPStatusUnknown code $ (LBS.unpack body) Just loc -> do@@ -127,7 +127,7 @@ -- if our monad has an uninitialized session ID, initialize it from the response object (Nothing, _) -> putSession sess { wdSessId = sessId' } -- if the response ID doesn't match our local ID, throw an error.- (_, Just False) -> throwIO . ServerError $ "Server response session ID (" ++ show sessId' + (_, Just False) -> throwIO . ServerError $ "Server response session ID (" ++ show sessId' ++ ") does not match local session ID (" ++ show sessId ++ ")" -- otherwise nothing needs to be done _ -> return ()
src/Test/WebDriver/Monad.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts, TypeFamilies, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} module Test.WebDriver.Monad- ( WD(..), runWD, runSession, withSession, finallyClose, closeOnException+ ( WD(..), runWD, runSession, withSession, finallyClose, closeOnException, dumpSessionHistory )where import Test.WebDriver.Classes@@ -11,6 +11,7 @@ import Control.Monad.Base (MonadBase, liftBase) import Control.Monad (liftM)+import Control.Monad.IO.Class import Control.Monad.Trans (lift) import Control.Monad.Trans.Control (MonadBaseControl(..), StM) import Control.Monad.State.Strict (StateT, MonadState, evalStateT, get, put)@@ -74,3 +75,14 @@ -- if the action was successful. closeOnException :: WebDriver wd => wd a -> wd a closeOnException wd = wd `onException` closeSession++-- |Can be called before 'closeOnException' to get more information on+-- stdout. about what was going wrong. (Note that the 'Show'+-- instances in package HTTP are not very generous with the 'Response'+-- and 'Request' type. You might want to write your own variant of+-- this function.)+dumpSessionHistory :: (MonadIO wd, WebDriver wd) => wd a -> wd a+dumpSessionHistory wd = do+ v <- wd+ getSession >>= liftIO . print . wdSessHist+ return v
src/Test/WebDriver/Utils.hs view
@@ -5,4 +5,4 @@ import qualified Network.HTTP.Base as HTTP urlEncode :: Text -> Text-urlEncode = T.pack . HTTP.urlEncode . T.unpack +urlEncode = T.pack . HTTP.urlEncode . T.unpack
webdriver.cabal view
@@ -1,5 +1,5 @@ Name: webdriver-Version: 0.5.4+Version: 0.5.5 Cabal-Version: >= 1.8 License: BSD3 License-File: LICENSE