diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,14 +1,32 @@ #Change Log -##upcoming release +##0.5.2 ###API changes +* added many new Internet Explorer capabilities +* added additionalCaps to Capabilities, which allows support for non-standard capabilities +* Browser type now supports non-standard browsers via the new Browser constructor +* added support for the new unexpectedAlertBehaviour capability + +###new features +* new command getApplicationCacheStatus supported +* error reporting for unknown commands now slightly improved + +###bug fixes +* internal request URIs are now properly percent-encoded +* improved handling of browser-specific capabilities +* fixed incompatability with new session creation protocol changes introduced in selenium 2.35 +* updated to work with Aeson 0.6.2 and onward + +##hs-webdriver 0.5.1 +###API changes * Test.WebDriver.Internal.FailedCommandInfo now stores screenshots as lazy bytestrings * Test.WebDriver.Common.Profile now stores PreparedProfile as a lazy bytestring * Test.WebDriver.Chrome.Extension now stores ChromeExtension as a lazy bytestring * The LogPref type has been renamed to LogLevel to reflect its use within the new log interface ###new features -* a new log interface as specified by webdriver standard. This includes the functions getLogs and getLogTypes, and the types LogType and LogEntry. +* a new log interface as specified by the webdriver standard. This includes the functions getLogs and getLogTypes, and the types LogType and LogEntry. +* waitWhile and waitUntil now show more detailed information about why an explicit wait timed out. ##hs-webdriver 0.5.0.1 ###bug fixes diff --git a/src/Test/WebDriver/Capabilities.hs b/src/Test/WebDriver/Capabilities.hs --- a/src/Test/WebDriver/Capabilities.hs +++ b/src/Test/WebDriver/Capabilities.hs @@ -7,7 +7,8 @@ import Test.WebDriver.JSON import Data.Aeson -import Data.Aeson.Types (Parser, typeMismatch) +import Data.Aeson.Types (Parser, typeMismatch, Pair) +import qualified Data.HashMap.Strict as HM (delete, toList) import Data.Text (Text, toLower, toUpper) import Data.Default (Default(..)) @@ -17,7 +18,7 @@ import Control.Applicative import Control.Exception.Lifted (throw) - + {- |A structure describing the capabilities of a session. This record serves dual roles. @@ -75,6 +76,10 @@ -- |Whether the session is capable of generating native OS -- events when simulating user input. , nativeEvents :: Maybe Bool + -- |How the session should handle unexpected alerts. + , unexpectedAlertBehavior :: Maybe UnexpectedAlertBehavior + -- |A list of ('Text', 'Value') pairs specifying additional non-standard capabilities. + , additionalCaps :: [Pair] } deriving (Eq, Show) instance Default Capabilities where @@ -94,17 +99,19 @@ , acceptSSLCerts = Nothing , nativeEvents = Nothing , proxy = UseSystemSettings + , unexpectedAlertBehavior = Nothing + , additionalCaps = [] } -- |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). +-- . All 'Maybe' capabilities are set to 'Nothing' (no preference). defaultCaps :: Capabilities defaultCaps = def --- |Same as 'defaultCaps', but with all Maybe Bool capabilities set to --- Just True. +-- |Same as 'defaultCaps', but with all 'Maybe' 'Bool' capabilities set to +-- 'Just' 'True'. allCaps :: Capabilities allCaps = defaultCaps { javascriptEnabled = Just True , takesScreenshot = Just True @@ -139,7 +146,10 @@ , "rotatable" .= rotatable , "acceptSslCerts" .= acceptSSLCerts , "nativeEvents" .= nativeEvents - ] ++ browserInfo + , "unexpectedAlertBehavior" .= unexpectedAlertBehavior + ] + ++ browserInfo + ++ additionalCaps where browserInfo = case browser of Firefox {..} @@ -155,8 +165,21 @@ ,"chrome.extensions" .= chromeExtensions ] IE {..} - -> ["IgnoreProtectedModeSettings" .= ignoreProtectedModeSettings - --,"useLegacyInternalServer" .= u + -> ["ignoreProtectedModeSettings" .= ieIgnoreProtectedModeSettings + ,"ignoreZoomSetting" .= ieIgnoreZoomSetting + ,"initialBrowserUrl" .= ieInitialBrowserUrl + ,"elementScrollBehavior" .= ieElementScrollBehavior + ,"enablePersistentHover" .= ieEnablePersistentHover + ,"enableElementCacheCleanup" .= ieEnableElementCacheCleanup + ,"requireWindowFocus" .= ieRequireWindowFocus + ,"browserAttachTimeout" .= ieBrowserAttachTimeout + ,"logFile" .= ieLogFile + ,"logLevel" .= ieLogLevel + ,"host" .= ieHost + ,"extractPath" .= ieExtractPath + ,"silent" .= ieSilent + ,"forceCreateProcess" .= ieForceCreateProcess + ,"internetExplorerSwitches" .= ieSwitches ] Opera{..} -> catMaybes [ opt "opera.binary" operaBinary @@ -183,28 +206,92 @@ 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 + parseJSON (Object o) = do + browser <- req "browserName" + Capabilities <$> getBrowserCaps browser + <*> 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" + <*> opt "unexpectedAlertBehaviour" Nothing + <*> pure (additionalCapabilities browser) + + 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 + + knownCapabilities browser = + ["browserName", "version", "platform", "proxy" + ,"javascriptEnabled", "takesScreenshot", "handlesAlerts" + ,"databaseEnabled", "locationContextEnabled" + ,"applicationCacheEnabled", "browserConnectionEnabled" + , "cssSelectorEnabled","webStorageEnabled", "rotatable" + , "acceptSslCerts", "nativeEvents", "unexpectedBrowserBehaviour"] + ++ case browser of + Firefox {} -> ["firefox_profile", "loggingPrefs", "firefox_binary"] + Chrome {} -> ["chrome.chromedriverVersion", "chrome.extensions", "chrome.switches", "chrome.extensions"] + IE {} -> ["ignoreProtectedModeSettings", "ignoreZoomSettings", "initialBrowserUrl", "elementScrollBehavior" + ,"enablePersistentHover", "enableElementCacheCleanup", "requireWindowFocus", "browserAttachTimeout" + ,"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 + Firefox {} -> Firefox <$> opt "firefox_profile" Nothing + <*> opt "loggingPrefs" def + <*> opt "firefox_binary" Nothing + Chrome {} -> Chrome <$> opt "chrome.chromedriverVersion" Nothing + <*> opt "chrome.extensions" Nothing + <*> opt "chrome.switches" [] + <*> opt "chrome.extensions" [] + IE {} -> IE <$> opt "ignoreProtectedModeSettings" True + <*> opt "ignoreZoomSettings" False + <*> opt "initialBrowserUrl" Nothing + <*> opt "elementScrollBehavior" def + <*> opt "enablePersistentHover" True + <*> opt "enableElementCacheCleanup" True + <*> opt "requireWindowFocus" False + <*> opt "browserAttachTimeout" 0 + <*> opt "logFile" Nothing + <*> opt "logLevel" def + <*> opt "host" Nothing + <*> opt "extractPath" Nothing + <*> opt "silent" False + <*> opt "forceCreateProcess" False + <*> opt "internetExplorerSwitches" Nothing + Opera {} -> Opera <$> opt "opera.binary" Nothing + <*> opt "opera.product" Nothing + <*> opt "opera.no_quit" False + <*> opt "opera.autostart" True + <*> opt "opera.idle" False + <*> opt "opera.display" 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 @@ -243,8 +330,63 @@ -- 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 + ieIgnoreProtectedModeSettings :: Bool + -- |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 + -- starts. Intended to be used with ignoreProtectedModeSettings + -- 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 + -- 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 + -- moved to. + , ieEnablePersistentHover :: Bool + -- |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 + -- keyboard events). This capability is false by default, but + -- delivers much more accurate native events interactions. + , ieRequireWindowFocus :: Bool + -- |The timeout, in milliseconds, that the driver will attempt to + -- 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. + -- 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 + -- for commands. + , ieHost :: Maybe Text + -- |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. + -- If this option is not specified, IE is launched using the + -- 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 + -- forceCreateProcess. + , ieSwitches :: Maybe Text } | Opera { -- |Server-side path to the Opera binary operaBinary :: Maybe FilePath @@ -283,7 +425,7 @@ -- starting Opera manually you won't need this. , operaHost :: Maybe String -- |Command-line arguments to pass to Opera. - , operaOptions :: String + , operaOptions :: Maybe String -- |Where to send the log output. If Nothing, logging is -- disabled. , operaLogFile :: Maybe FilePath @@ -294,6 +436,8 @@ | IPhone | IPad | Android + -- |some other browser, specified by a string name + | Browser Text deriving (Eq, Show) instance Default Browser where @@ -301,11 +445,12 @@ 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 + toJSON Firefox {} = String "firefox" + toJSON Chrome {} = String "chrome" + toJSON Opera {} = String "opera" + toJSON IE {} = String "internet explorer" + toJSON (Browser b) = String b + toJSON b = String . toLower . fromString . show $ b instance FromJSON Browser where parseJSON (String jStr) = case toLower jStr of @@ -318,7 +463,7 @@ "ipad" -> return iPad "android" -> return android "htmlunit" -> return htmlUnit - err -> fail $ "Invalid Browser string " ++ show err + other -> return (Browser other) parseJSON v = typeMismatch "Browser" v @@ -332,9 +477,25 @@ chrome :: Browser chrome = Chrome Nothing Nothing [] [] --- |Default IE settings. 'ignoreProtectedModeSettings' is set to True. +-- |Default IE settings. See the 'IE' constructor for more details on +-- individual defaults ie :: Browser -ie = IE True +ie = IE { ieIgnoreProtectedModeSettings = True + , ieIgnoreZoomSetting = False + , ieInitialBrowserUrl = Nothing + , ieElementScrollBehavior = def + , ieEnablePersistentHover = True + , ieEnableElementCacheCleanup = True + , ieRequireWindowFocus = False + , ieBrowserAttachTimeout = 0 + , ieLogFile = Nothing + , ieLogLevel = def + , ieHost = Nothing + , ieExtractPath = Nothing + , ieSilent = False + , ieForceCreateProcess = False + , ieSwitches = Nothing + } -- |Default Opera settings. See the 'Opera' constructor for more details on -- individual defaults. @@ -350,7 +511,7 @@ , operaLauncher = Nothing , operaHost = Nothing , operaPort = Just 0 - , operaOptions = [] + , operaOptions = Nothing , operaLogFile = Nothing , operaLogPref = def } @@ -439,6 +600,24 @@ ,"httpProxy" .= http ] +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) = + return $ case s of + "accept" -> AcceptAlert + "dismiss" -> DismissAlert + "ignore" -> IgnoreAlert + err -> throw . BadJSON + $ "Invalid string value for UnexpectedAlertBehavior: " ++ show err + parseJSON v = typeMismatch "UnexpectedAlertBehavior" v + -- |Indicates a log verbosity level. Used in 'Firefox' and 'Opera' configuration. data LogLevel = LogOff | LogSevere | LogWarning | LogInfo | LogConfig | LogFine | LogFiner | LogFinest | LogAll @@ -472,3 +651,53 @@ "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 + deriving (Eq, Show, Read, Ord, Bounded, Enum) + +instance Default IELogLevel where + def = IELogFatal + + +instance ToJSON IELogLevel where + toJSON p= String $ case p of + IELogTrace -> "TRACE" + IELogDebug -> "DEBUG" + IELogInfo -> "INFO" + IELogWarn -> "WARN" + IELogError -> "ERROR" + IELogFatal -> "FATAL" + +instance FromJSON IELogLevel where + parseJSON (String s) = return $ case s of + "TRACE" -> IELogTrace + "DEBIG" -> IELogDebug + "INFO" -> IELogInfo + "WARN" -> IELogWarn + "ERROR" -> IELogError + "FATAL" -> IELogFatal + _ -> throw . BadJSON $ "Invalid logging preference: " ++ show s + parseJSON other = typeMismatch "IELogLevel" other + +-- |Specifies how elements scroll into the viewport. (see 'ieElementScrollBehavior') +data IEElementScrollBehavior = AlignTop | AlignBottom + deriving (Eq, Ord, Show, Read, Enum, Bounded) + +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 + 0 -> return AlignTop + 1 -> return AlignBottom + _ -> fail $ "Invalid integer for IEElementScrollBehavior: " ++ show n + diff --git a/src/Test/WebDriver/Classes.hs b/src/Test/WebDriver/Classes.hs --- a/src/Test/WebDriver/Classes.hs +++ b/src/Test/WebDriver/Classes.hs @@ -12,6 +12,8 @@ --import Test.WebDriver.Internal import Data.Aeson import Network.HTTP (RequestMethod(..)) +import Network.HTTP.Base (Request) +import Data.ByteString.Lazy (ByteString) import Data.Text (Text) @@ -77,13 +79,16 @@ -- and closed automatically with -- 'Test.WebDriver.runSession' , wdSessId :: Maybe SessionId - } deriving (Eq, Show) + -- |The last HTTP request issued by this session, if any. + , lastHTTPRequest :: Maybe (Request ByteString) + } deriving (Show) instance Default WDSession where - def = WDSession { wdHost = "127.0.0.1" - , wdPort = 4444 - , wdBasePath = "/wd/hub" - , wdSessId = Nothing + def = WDSession { wdHost = "127.0.0.1" + , wdPort = 4444 + , wdBasePath = "/wd/hub" + , wdSessId = Nothing + , lastHTTPRequest = Nothing } {- |A default session connects to localhost on port 4444, and hasn't been diff --git a/src/Test/WebDriver/Commands.hs b/src/Test/WebDriver/Commands.hs --- a/src/Test/WebDriver/Commands.hs +++ b/src/Test/WebDriver/Commands.hs @@ -47,6 +47,9 @@ -- * HTML 5 Web Storage , WebStorageType(..), storageSize, getAllKeys, deleteAllKeys , getKey, setKey, deleteKey + -- * HTML 5 Application Cache + , ApplicationCacheStatus(..) + , getApplicationCacheStatus -- * Mobile device support -- ** Screen orientation , Orientation(..) @@ -75,12 +78,13 @@ import Test.WebDriver.JSON import Test.WebDriver.Capabilities import Test.WebDriver.Internal +import Test.WebDriver.Utils (urlEncode) 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.Text (Text, append, toUpper, toLower) import Data.ByteString.Base64.Lazy as B64 import Data.ByteString.Lazy as LBS (ByteString) import Network.URI hiding (path) -- suppresses warnings @@ -90,26 +94,28 @@ import Control.Monad.State.Strict import Control.Monad.Base import Control.Exception (SomeException) -import Control.Exception.Lifted (throwIO, catch, handle) +import Control.Exception.Lifted (throwIO, handle) +import qualified Control.Exception.Lifted as L import Data.Word import Data.String (fromString) import Data.Maybe (fromMaybe) import qualified Data.Char as C -import Prelude hiding (catch) + -- |Convenience function to handle webdriver commands with no return value noReturn :: WebDriver wd => wd NoReturn -> wd () noReturn = void --- |Create a new session with the given 'Capabilities'. This command --- resets the current session ID to that of the new session. +-- |Convenience function to ignore result of a webdriver command +ignoreReturn :: WebDriver wd => wd Value -> wd () +ignoreReturn = void + +-- |Create a new session with the given 'Capabilities'. 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} + ignoreReturn . doCommand POST "/session" . single "desiredCapabilities" $ caps getSession -- |Retrieve a list of active sessions and their 'Capabilities'. @@ -132,7 +138,7 @@ setImplicitWait :: WebDriver wd => Integer -> wd () setImplicitWait ms = noReturn $ doSessCommand POST "/timeouts/implicit_wait" (object msField) - `catch` \(_ :: SomeException) -> + `L.catch` \(_ :: SomeException) -> doSessCommand POST "/timeouts" (object allFields) where msField = ["ms" .= ms] allFields = ["type" .= ("implicit" :: String)] ++ msField @@ -142,7 +148,7 @@ setScriptTimeout :: WebDriver wd => Integer -> wd () setScriptTimeout ms = noReturn $ doSessCommand POST "/timeouts/async_script" (object msField) - `catch` \(_ :: SomeException) -> + `L.catch` \(_ :: SomeException) -> doSessCommand POST "/timeouts" (object allFields) where msField = ["ms" .= ms] allFields = ["type" .= ("script" :: String)] ++ msField @@ -360,7 +366,7 @@ -- current page. deleteCookie :: WebDriver wd => Cookie -> wd () deleteCookie c = - noReturn $ doSessCommand DELETE ("/cookie/" `append` cookName c) Null + noReturn $ doSessCommand DELETE ("/cookie/" `append` urlEncode (cookName c)) Null -- |Delete all visible cookies on the current page. deleteVisibleCookies :: WebDriver wd => wd () @@ -471,11 +477,11 @@ -- |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) Null +attr e t = doElemCommand GET e ("/attribute/" `append` urlEncode t) Null -- |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) Null +cssProp e t = doElemCommand GET e ("/css/" `append` urlEncode t) Null -- |Retrieve an element's current position. elemPos :: WebDriver wd => Element -> wd (Int, Int) @@ -489,7 +495,7 @@ 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) Null +e1 <==> (Element e2) = doElemCommand GET e1 ("/equals/" `append` urlEncode e2) Null -- |Determines if two element identifiers refer to different elements. infix 4 @@ -709,7 +715,7 @@ -- 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) Null +getKey s k = doStorageCommand GET s ("/key/" `T.append` urlEncode k) Null -- |Set a key in the given web storage area. setKey :: WebDriver wd => WebStorageType -> Text -> Text -> wd Text @@ -717,7 +723,7 @@ "value" .= v ] -- |Delete a key in the given web storage area. deleteKey :: WebDriver wd => WebStorageType -> Text -> wd () -deleteKey s k = noReturn $ doStorageCommand POST s ("/key/" `T.append` k) Null +deleteKey s k = noReturn $ doStorageCommand POST s ("/key/" `T.append` urlEncode k) Null -- |A wrapper around 'doStorageCommand' to create web storage URLs. doStorageCommand :: (WebDriver wd, ToJSON a, FromJSON b) => @@ -731,7 +737,7 @@ -- about this object see -- serverStatus :: (WebDriver wd) => wd Value -- todo: make this a record type -serverStatus = doCommand GET "/status" () +serverStatus = doCommand GET "/status" Null -- |A record that represents a single log entry. data LogEntry = @@ -754,13 +760,33 @@ type LogType = String -- |Retrieve the log buffer for a given log type. The server-side log buffer is reset after each request. +-- +-- Which log types are available is server defined, but the wire protocol lists these as common log types: +-- client, driver, browser, server getLogs :: WebDriver wd => LogType -> wd [LogEntry] getLogs t = doSessCommand POST "/log" . object $ ["type" .= t] -- |Get a list of available log types. getLogTypes :: WebDriver wd => wd [LogType] -getLogTypes = doSessCommand GET "/log/types" () +getLogTypes = doSessCommand GET "/log/types" Null +data ApplicationCacheStatus = Uncached | Idle | Checking | Downloading | UpdateReady | Obsolete deriving (Eq, Enum, Bounded, Ord, Show, Read) + +instance FromJSON ApplicationCacheStatus where + parseJSON val = do + n <- parseJSON val + case n :: Integer of + 0 -> return Uncached + 1 -> return Idle + 2 -> return Checking + 3 -> return Downloading + 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 + -- 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 ) +$( deriveToJSON (defaultOptions{fieldLabelModifier = map C.toLower . drop 4}) ''Cookie ) diff --git a/src/Test/WebDriver/Commands/Internal.hs b/src/Test/WebDriver/Commands/Internal.hs --- a/src/Test/WebDriver/Commands/Internal.hs +++ b/src/Test/WebDriver/Commands/Internal.hs @@ -17,6 +17,7 @@ ) where import Test.WebDriver.Classes +import Test.WebDriver.Utils (urlEncode) import Data.Aeson import Data.Aeson.Types @@ -72,7 +73,7 @@ msg = "doSessCommand: No session ID found for relative URL " ++ show path Just (SessionId sId) -> doCommand method - (T.concat ["/session/", sId, path]) args + (T.concat ["/session/", urlEncode sId, path]) args -- |A wrapper around 'doSessCommand' to create element URLs. -- For example, passing a URL of "/active" will expand to @@ -81,7 +82,7 @@ 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 + doSessCommand m (T.concat ["/element/", urlEncode e, path]) a -- |A wrapper around 'doSessCommand' to create window handle URLS. -- For example, passing a URL of \"/size\" will expand to @@ -90,4 +91,4 @@ 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 + doSessCommand m (T.concat ["/window/", urlEncode w, path]) a diff --git a/src/Test/WebDriver/Common/Profile.hs b/src/Test/WebDriver/Common/Profile.hs --- a/src/Test/WebDriver/Common/Profile.hs +++ b/src/Test/WebDriver/Common/Profile.hs @@ -62,7 +62,7 @@ -- there is one unique source path going to each -- destination path. profileFiles :: HM.HashMap FilePath FilePath - -- |A map of Firefox preferences. These are the settings + -- |A map of profile preferences. These are the settings -- found in the profile's prefs.js, and entries found in -- about:config , profilePrefs :: HM.HashMap Text ProfilePref diff --git a/src/Test/WebDriver/Internal.hs b/src/Test/WebDriver/Internal.hs --- a/src/Test/WebDriver/Internal.hs +++ b/src/Test/WebDriver/Internal.hs @@ -20,7 +20,7 @@ import Data.Aeson import Data.Aeson.Types (Parser, typeMismatch) -import Data.Text as T (Text, unpack) +import Data.Text as T (Text, unpack, splitOn, null) import Data.ByteString.Lazy.Char8 (ByteString) import Data.ByteString.Lazy.Char8 as LBS (length, unpack, null) import qualified Data.ByteString.Base64.Lazy as B64 @@ -70,12 +70,16 @@ ] } r <- liftBase (simpleHTTP req) >>= either (throwIO . HTTPConnError) return + modifySession $ \s -> s {lastHTTPRequest = Just req} -- update lastHTTPRequest field return r handleHTTPErr :: SessionState s => Response ByteString -> s () handleHTTPErr r@Response{rspBody = body, rspCode = code, rspReason = reason} = case code of - (4,_,_) -> err UnknownCommand + (4,_,_) -> do + lastReq <- lastHTTPRequest <$> getSession + throwIO . UnknownCommand . maybe reason show + $ lastReq (5,_,_) -> case findHeader HdrContentType r of Just ct @@ -97,15 +101,30 @@ case code of (2,0,4) -> noReturn (3,0,x) - | x `elem` [2,3] -> - fromJSON' =<< maybe statusErr (return . String . fromString) - (findHeader HdrLocation resp) - where - statusErr = throwIO . HTTPStatusUnknown code - $ (LBS.unpack body) - other + | x `elem` [2,3] -> + case findHeader HdrLocation resp of + Nothing -> throwIO . HTTPStatusUnknown code + $ (LBS.unpack body) + Just loc -> do + let sessId = last . filter (not . T.null) . splitOn "/" . fromString $ loc + modifySession $ \sess -> sess {wdSessId = Just (SessionId sessId)} + fromJSON' . String $ sessId + _ | LBS.null body -> noReturn - | otherwise -> fromJSON' . rspVal =<< parseJSON' body + | otherwise -> do + sess@WDSession { wdSessId = sessId} <- getSession -- get current session state + WDResponse { rspSessId = sessId' + , rspVal = val} <- parseJSON' body -- parse response body + case (sessId, (==) <$> sessId <*> sessId') of + -- 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' + ++ ") does not match local session ID (" ++ show sessId ++ ")" + -- otherwise nothing needs to be done + _ -> return () + fromJSON' val + where noReturn = fromJSON' Null @@ -190,7 +209,7 @@ -- |This exception encapsulates a broad variety of exceptions that can -- occur when a command fails. data FailedCommand = FailedCommand FailedCommandType FailedCommandInfo - deriving (Eq, Show, Typeable) + deriving (Show, Typeable) -- |The type of failed command exception that occured. data FailedCommandType = NoSuchElement @@ -237,7 +256,6 @@ -- |A stack trace of the exception. , errStack :: [StackFrame] } - deriving (Eq) -- |Provides a readable printout of the error information, useful for -- logging. diff --git a/src/Test/WebDriver/Monad.hs b/src/Test/WebDriver/Monad.hs --- a/src/Test/WebDriver/Monad.hs +++ b/src/Test/WebDriver/Monad.hs @@ -19,8 +19,8 @@ import Control.Monad.CatchIO (MonadCatchIO) 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 +{- |A monadic interface to the WebDriver server. This monad is simply a + state monad transformer over 'IO', threading session information between sequential webdriver commands -} newtype WD a = WD (StateT WDSession IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO) diff --git a/src/Test/WebDriver/Types.hs b/src/Test/WebDriver/Types.hs --- a/src/Test/WebDriver/Types.hs +++ b/src/Test/WebDriver/Types.hs @@ -1,20 +1,15 @@ -{-# 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(..) + , Platform(..), ProxyType(..), UnexpectedAlertBehavior(..) -- ** Browser-specific configuration , Browser(..), -- ** Default settings for browsers firefox, chrome, ie, opera, iPhone, iPad, android - , LogLevel(..) + , LogLevel(..), IELogLevel(..), IEElementScrollBehavior(..) -- * WebDriver objects and command-specific types , Element(..) , WindowHandle(..), currentWindow @@ -25,6 +20,8 @@ , Orientation(..) , MouseButton(..) , WebStorageType(..) + , LogType, LogEntry(..) + , ApplicationCacheStatus(..) -- * Exceptions , InvalidURL(..), NoSessionId(..), BadJSON(..) , HTTPStatusUnknown(..), HTTPConnError(..) diff --git a/src/Test/WebDriver/Utils.hs b/src/Test/WebDriver/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Utils.hs @@ -0,0 +1,8 @@ +module Test.WebDriver.Utils where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Network.HTTP.Base as HTTP + +urlEncode :: Text -> Text +urlEncode = T.pack . HTTP.urlEncode . T.unpack diff --git a/test/search-baidu.hs b/test/search-baidu.hs new file mode 100644 --- /dev/null +++ b/test/search-baidu.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Concurrent +import Control.Parallel +import Control.Monad (void) +import Data.List +import qualified Data.Text as T +import Test.WebDriver +import Test.WebDriver.Classes +import Test.WebDriver.Commands.Wait + +capsChrome = defaultCaps { browser = chrome } +capsFF = defaultCaps + +-- Have no fun with baidu but only cause it is loading fast than google in China. +-- +baidu :: WD () +baidu = openPage "http://www.baidu.com/" + +searchBaidu :: WD Bool +searchBaidu = do + searchBox <- findElem (ByName "wd") + sendKeys "Cheese!" searchBox + submit searchBox + setImplicitWait 50 + waitUntil 2000 $ do + title <- getTitle + return ("cheese!" `T.isSuffixOf` title) + +testCase c = void $ runSession defaultSession c (baidu >> searchBaidu) + +testSuits = mapM_ testCase [capsFF, capsChrome] + +main = do + --testCase capsChrome `seq` testCase capsFF + --mapM_ (forkOS . testCase) [capsFF, capsChrome] + testSuits + print "done" diff --git a/webdriver.cabal b/webdriver.cabal --- a/webdriver.cabal +++ b/webdriver.cabal @@ -1,6 +1,6 @@ Name: webdriver -Version: 0.5.1 -Cabal-Version: >= 1.6 +Version: 0.5.2 +Cabal-Version: >= 1.8 License: BSD3 License-File: LICENSE Author: Adam Curtis @@ -30,7 +30,7 @@ hs-source-dirs: src ghc-options: -Wall build-depends: base == 4.* - , aeson >= 0.4 && < 0.7 + , aeson >= 0.6.2.0 && < 0.7 , HTTP >= 4000.1 && < 4000.3 , mtl >= 2.0 && < 2.2 , network == 2.4.* @@ -48,7 +48,7 @@ , vector >= 0.3 && < 0.11 , lifted-base >= 0.1 && < 0.3 , MonadCatchIO-transformers >= 0.3 && < 0.4 - , filesystem-trees >= 0.1.0.2 && < 0.2 + , filesystem-trees >= 0.1.0.5 && < 0.2 , data-default >= 0.2 && < 1.0 , temporary >= 1.0 && < 2.0 , base64-bytestring >= 1.0 && < 1.1 @@ -67,6 +67,15 @@ Test.WebDriver.Capabilities Test.WebDriver.Types Test.WebDriver.JSON + Test.WebDriver.Utils other-modules: Test.WebDriver.Internal +Test-Suite test-search-baidu + type: exitcode-stdio-1.0 + main-is: test/search-baidu.hs + ghc-options: -threaded + build-depends: base, + webdriver, + text, + parallel