webdriver 0.12.0.1 → 0.15.0.0
raw patch · 92 files changed
Files
- CHANGELOG.md +119/−90
- LICENSE +1/−1
- README.md +2/−86
- app/Main.hs +44/−0
- src/Test/WebDriver.hs +253/−31
- src/Test/WebDriver/Capabilities.hs +157/−741
- src/Test/WebDriver/Capabilities/Aeson.hs +93/−0
- src/Test/WebDriver/Capabilities/ChromeOptions.hs +187/−0
- src/Test/WebDriver/Capabilities/FirefoxOptions.hs +90/−0
- src/Test/WebDriver/Capabilities/Platform.hs +35/−0
- src/Test/WebDriver/Capabilities/Proxy.hs +22/−0
- src/Test/WebDriver/Capabilities/Timeouts.hs +15/−0
- src/Test/WebDriver/Capabilities/UserPromptHandler.hs +16/−0
- src/Test/WebDriver/Chrome/Extension.hs +0/−30
- src/Test/WebDriver/Class.hs +0/−73
- src/Test/WebDriver/Commands.hs +109/−759
- src/Test/WebDriver/Commands/Actions.hs +182/−0
- src/Test/WebDriver/Commands/BiDi/NetworkActivity.hs +312/−0
- src/Test/WebDriver/Commands/BiDi/Session.hs +193/−0
- src/Test/WebDriver/Commands/CommandContexts.hs +120/−0
- src/Test/WebDriver/Commands/Cookies.hs +100/−0
- src/Test/WebDriver/Commands/DocumentHandling.hs +95/−0
- src/Test/WebDriver/Commands/ElementInteraction.hs +33/−0
- src/Test/WebDriver/Commands/ElementRetrieval.hs +58/−0
- src/Test/WebDriver/Commands/ElementState.hs +51/−0
- src/Test/WebDriver/Commands/Internal.hs +0/−108
- src/Test/WebDriver/Commands/Logs.hs +48/−0
- src/Test/WebDriver/Commands/Logs/BiDi.hs +65/−0
- src/Test/WebDriver/Commands/Logs/Chrome.hs +70/−0
- src/Test/WebDriver/Commands/Logs/Common.hs +102/−0
- src/Test/WebDriver/Commands/Logs/Firefox.hs +25/−0
- src/Test/WebDriver/Commands/Logs/Selenium.hs +21/−0
- src/Test/WebDriver/Commands/Navigation.hs +47/−0
- src/Test/WebDriver/Commands/ScreenCapture.hs +30/−0
- src/Test/WebDriver/Commands/SeleniumSpecific/HTML5.hs +95/−0
- src/Test/WebDriver/Commands/SeleniumSpecific/Misc.hs +39/−0
- src/Test/WebDriver/Commands/SeleniumSpecific/Mobile.hs +133/−0
- src/Test/WebDriver/Commands/SeleniumSpecific/Uploads.hs +50/−0
- src/Test/WebDriver/Commands/Sessions.hs +74/−0
- src/Test/WebDriver/Commands/UserPrompts.hs +31/−0
- src/Test/WebDriver/Commands/Wait.hs +0/−154
- src/Test/WebDriver/Common/Keys.hs +0/−199
- src/Test/WebDriver/Common/Profile.hs +0/−265
- src/Test/WebDriver/Config.hs +0/−96
- src/Test/WebDriver/Cookies.hs +0/−60
- src/Test/WebDriver/Exceptions.hs +103/−9
- src/Test/WebDriver/Exceptions/Internal.hs +0/−202
- src/Test/WebDriver/Firefox/Profile.hs +0/−243
- src/Test/WebDriver/IO.hs +0/−17
- src/Test/WebDriver/Internal.hs +0/−232
- src/Test/WebDriver/JSON.hs +89/−94
- src/Test/WebDriver/Keys.hs +201/−0
- src/Test/WebDriver/LaunchDriver.hs +261/−0
- src/Test/WebDriver/Monad.hs +0/−108
- src/Test/WebDriver/Profile.hs +411/−0
- src/Test/WebDriver/Session.hs +0/−193
- src/Test/WebDriver/Session/History.hs +0/−14
- src/Test/WebDriver/Types.hs +215/−38
- src/Test/WebDriver/Util/Aeson.hs +35/−0
- src/Test/WebDriver/Util/Commands.hs +148/−0
- src/Test/WebDriver/Util/Ports.hs +114/−0
- src/Test/WebDriver/Util/Sockets.hs +62/−0
- src/Test/WebDriver/Utils.hs +0/−9
- src/Test/WebDriver/WD.hs +102/−0
- src/Test/WebDriver/Waits.hs +173/−0
- tests/Main.hs +156/−0
- tests/Spec.hs +16/−0
- tests/Spec/Actions.hs +79/−0
- tests/Spec/CommandContexts.hs +63/−0
- tests/Spec/Cookies.hs +49/−0
- tests/Spec/DocumentHandling.hs +37/−0
- tests/Spec/ElementInteraction.hs +37/−0
- tests/Spec/ElementRetrieval.hs +50/−0
- tests/Spec/ElementState.hs +60/−0
- tests/Spec/Logs.hs +35/−0
- tests/Spec/LogsBiDi.hs +44/−0
- tests/Spec/Navigation.hs +48/−0
- tests/Spec/ScreenCapture.hs +27/−0
- tests/Spec/SeleniumSpecific/Mobile.hs +18/−0
- tests/Spec/SeleniumSpecific/Uploads.hs +29/−0
- tests/Spec/Sessions.hs +62/−0
- tests/Spec/UserPrompts.hs +15/−0
- tests/TestLib/Contexts/BrowserDependencies.hs +34/−0
- tests/TestLib/Contexts/Selenium4.hs +55/−0
- tests/TestLib/Contexts/Session.hs +120/−0
- tests/TestLib/Contexts/StaticServer.hs +91/−0
- tests/TestLib/Contexts/WebDriver.hs +28/−0
- tests/TestLib/Mouse.hs +72/−0
- tests/TestLib/Types.hs +167/−0
- tests/TestLib/Types/Cli.hs +40/−0
- tests/TestLib/Waits.hs +59/−0
- webdriver.cabal +184/−50
CHANGELOG.md view
@@ -1,62 +1,91 @@ # Change Log +## 0.15.0.0+* Add `Test.WebDriver.Commands.BiDi.NetworkActivity` with tools for working with browser network activity.+* Add support for starting BiDi sessions and watching events.+* Add `_firefoxOptionsEnv` to set Firefox environment variables. Useful to pass MOZ_ENABLE_WAYLAND=0 to make window positioning work better.+* Fix some missed teardown of geckodriver processes.+* Add flags to pass environment variables to drivers.++## 0.14.0.0+* Fix MVar bug in teardownWebDriverContext.+* Make driverConfigLogDir optional (#206).+* Add "Test.WebDriver.WD" module for simple usage.++## 0.13.0.0+* Added support for Selenium 3 and 4 with W3C WebDriver protocol compatibility.+* Dropped legacy Selenium JSON wire protocol support.+* Reworked [createSession](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:createSession) into [startSession](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver.html#v:startSession), which uses [WebDriverContext](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Types.html#t:WebDriverContext) for process lifecycle management.+* Replaced [WebDriver](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Class.html#t:WebDriver) class with [WebDriverBase](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Types.html#t:WebDriverBase) and switched from `MonadBaseControl IO` to `MonadUnliftIO`.+* Simplified module hierarchy with centralized imports under `Test.WebDriver`.+* Enhanced browser profile handling with in-memory zip archiving instead of on-disk preparation.+* Added comprehensive test suite with matrix testing across Selenium versions and browsers.+* Added browser log retrieval functions: [withRecordLogsViaBiDi](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:withRecordLogsViaBiDi) and [getLogs](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:getLogs).+* Now you can manage the script, page load, and implicit wait timeouts in a single operation with [getTimeouts](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:getTimeouts)/[setTimeouts](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:setTimeouts).+* The [getWindowSize](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:getWindowSize)/[setWindowSize](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:setWindowSize)/[getWindowPos](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:getWindowPos)/[setWindowPos](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:setWindowPos) functions have been replaced with [getWindowRect](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:getWindowRect)/[setWindowRect](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:setWindowRect).+* The [elemPos](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:elemPos)/[elemSize](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:elemSize) functions have been replaced with [elemRect](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:elemRect).+* [deleteCookieByName](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:deleteCookieByName) has been renamed to [deleteCookie](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:deleteCookie) and the pointless old [deleteCookie](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:deleteCookie) removed.+* [screenshotBase64](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:screenshotBase64) has been removed and [screenshotElement](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:screenshotElement) added.+* [deleteVisibleCookies](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:deleteVisibleCookies) renamed to [deleteCookies](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:deleteCookies).+* Deprecated function [elemInfo](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:elemInfo) removed.+ ## 0.12.0.1 * Switch from `data-default-class` to `data-default` to address https://github.com/commercialhaskell/stackage/issues/7545. This is weirdly complicated: it looks like versions of `data-default` from `0.5.2` to `0.8.0.0` may pull in unnecessary (to us) `data-default-instances-*` dependencies. However, what we've done here should build with all versions, so we won't worry about it. At the next breaking change I'd like to remove `data-default` entirely. ## 0.12.0.0-* Support aeson-2.2.0+* Support aeson-2.2.0. ## 0.11.0.0-* Support GHC 9.6-* Fix a link to the wrong GitHub branch in package description-* Remove instances for deprecated ListT and ErrorT+* Support GHC 9.6.+* Fix a link to the wrong GitHub branch in package description.+* Remove instances for deprecated ListT and ErrorT. ## 0.10.0.1-* Update links to reflect this package's new home at https://github.com/haskell-webdriver/haskell-webdriver/+* Update links to reflect this package's new home at https://github.com/haskell-webdriver/haskell-webdriver/. ## 0.10.0.0-* Add Aeson 2 compatibility to support GHC 9.0 and 9.2-* Derive MonadMask instance for the WD monad-* Fix parameter name in the `focusWindow` function-* Fix Cookie ToJSON instance-* Convert a couple noReturn calls to ignoreReturn to avoid a crash-* Switch to hpack-* Switch to GitHub Actions CI-* Remove cabal flags and shorten extra-source-files+* Add Aeson 2 compatibility to support GHC 9.0 and 9.2.+* Derive MonadMask instance for the WD monad.+* Fix parameter name in the `focusWindow` function.+* Fix Cookie ToJSON instance.+* Convert a couple noReturn calls to ignoreReturn to avoid a crash.+* Switch to hpack.+* Switch to GitHub Actions CI.+* Remove cabal flags and shorten extra-source-files. ## 0.9.0.1-* Fixed build errors when building against aeson-1.4.3.0+* Fixed build errors when building against aeson-1.4.3.0. ## 0.9 ### Breaking API changes-* Changed the type of the `cookExpiry` field of `Cookie` from `Maybe Integer` to `Maybe Double`. This fixes parsing issues with some Selenium server implementations+* Changed the type of the `cookExpiry` field of `Cookie` from `Maybe Integer` to `Maybe Double`. This fixes parsing issues with some Selenium server implementations. * Changed `elemPos` and `elemSize` to return `Float` pairs instead of `Int` pairs. This fixes parsing issues with some Selemium server implementations. * Removed the `Element` argument from the `sendRawKeys` function. This argument is not used in modern Selenium versions. ### New API features * Added a `LogDebug` constructor to the `LogLevel` type. * Added `ffAccpetInsecureCerts` capability for `Firefox` geckodriver.-* The constructor for `ExpectFailed` is now exported so that it can be caught properly by exception handlers+* The constructor for `ExpectFailed` is now exported so that it can be caught properly by exception handlers. * Added GHC callstack support. `BadJSON` exceptions are now caught and rethrown with `error` calls to improve stack traces. ### W3C standard compatibility fixes-* Fixed `ToJSON Element` instance so that it accepts both old OSS and new W3C element format (fixes compatibility issue with Selenium 3+ versions)-* Changed the `maximize` API call to use POST instead of GET+* Fixed `ToJSON Element` instance so that it accepts both old OSS and new W3C element format (fixes compatibility issue with Selenium 3+ versions).+* Changed the `maximize` API call to use POST instead of GET. ### Other Selenium compatibility fixes-* Fixed an error with some versions of chromedriver when using `closeWindow`+* Fixed an error with some versions of chromedriver when using `closeWindow`. ## 0.8.5-* Added support for experimental Chrome options that are not part of the API-* Added a Phantomjs constructor for the Browser type-* Changed the type of StackFrame line numbers from Word to Int to avoid parse errors in newer Aeson versions (sometimes the server returns negative line numbers)-* Fixed support for http-client > 0.5+* Added support for experimental Chrome options that are not part of the API.+* Added a Phantomjs constructor for the Browser type.+* Changed the type of StackFrame line numbers from Word to Int to avoid parse errors in newer Aeson versions (sometimes the server returns negative line numbers).+* Fixed support for http-client > 0.5. ## 0.8.4 * Added a new `Test.WebDriver.Common.Keys` module with named constants for use with `sendKeys`-* Updated old URLs in documentation-* Introduced support for http-client 5.0+* Updated old URLs in documentation.+* Introduced support for http-client 5.0. ## 0.8.3 * Removed most upper bounds on dependencies in our cabal file to avoid stackage version madness.@@ -66,19 +95,19 @@ * Added new `WebDriver` instance for `ExceptT`. ## 0.8.1-* Previously internal convenience functions `noReturn` and `ignoreReturn` are now exported in Test.WebDriver.JSON+* Previously internal convenience functions `noReturn` and `ignoreReturn` are now exported in Test.WebDriver.JSON. * `elemInfo` is now deprecated due to it being phased out in the Marionette (Firefox) driver. It will likely be removed once Selenium 4 is released. * Fixed an issue causing PAC settings to not work. ## 0.8.0.4-* Quick fix to parse "unsupported command" errors when using Marionette driver (Selenium + Marionette has nonstandard behavior when reporting that error type)+* Quick fix to parse "unsupported command" errors when using Marionette driver (Selenium + Marionette has nonstandard behavior when reporting that error type). ## 0.8.0.3-* Fixed build errors for GHC < 7.10. webdriver now builds with GHC stable releases 7.4.2, 7.6.3, and 7.8.4+* Fixed build errors for GHC < 7.10. webdriver now builds with GHC stable releases 7.4.2, 7.6.3, and 7.8.4. * Fixed support for bytestring 0.9.* ## 0.8.0.2-* Fixed issue introduced in 0.8 that caused build failure when using aeson < 0.10+* Fixed issue introduced in 0.8 that caused build failure when using aeson < 0.10. ## 0.8.0.1 * findElems and and findElemsFrom were accidentally changed to return a single Element in the last release. This has been fixed.@@ -111,15 +140,15 @@ ### Reworked custom HTTP headers interface * Support for custom request headers was added rather hastily, resulting in several functions having explicit `RequestHeaders` parameters. The interface has been reworked now so that custom request headers are stored inside `WDSession` and explicit `RequestHeaders` parameters have been removed.-* There's also now a distinction in configuration between `wdAuthHeaders` which are used only during initial session creation, and `wdRequestHeaders`, which are used with all other HTTP requests-* Two new utility functions were added to make working with custom HTTP headers easier: `withRequestHeaders` and `withAuthHeaders`+* There's also now a distinction in configuration between `wdAuthHeaders` which are used only during initial session creation, and `wdRequestHeaders`, which are used with all other HTTP requests.+* Two new utility functions were added to make working with custom HTTP headers easier: `withRequestHeaders` and `withAuthHeaders`. ### Clean-up and dependency changes * Removed a whole mess of unusued import and deprecation warnings when building with GHC 7.10 * We now enforce an attoparsec lower bound of 0.10 (there was no lower bound before) * The unnecessary dependency on mtl is now removed.-* Added some monad transformer instances for WebDriver and WDSessionState that were mysteriously missing: strict WriterT, ReaderT, ListT-* data-default dependency was changed to data-default-class+* Added some monad transformer instances for WebDriver and WDSessionState that were mysteriously missing: strict WriterT, ReaderT, ListT.+* data-default dependency was changed to data-default-class. ## 0.7 @@ -129,8 +158,8 @@ ### Top-level API (exposed by`Test.WebDriver` module) * `withSession` is now overloaded over the new constraint alias `WDSessionStateControl` ([see below](#typeclass-api)). This means that it can be used with monad transformer stacks over `WD` without any lifting required.- * Added several new `WDConfig` convenience functions: `modifyCaps`, `useBrowser`, `useVersion`, `usePlatform`, `useProxy`; these functions are overloaded over the new `HasCapabilities` constraint alias ([see below](#typeclass-api))- * Reworked and improved session history API+ * Added several new `WDConfig` convenience functions: `modifyCaps`, `useBrowser`, `useVersion`, `usePlatform`, `useProxy`; these functions are overloaded over the new `HasCapabilities` constraint alias ([see below](#typeclass-api)).+ * Reworked and improved session history API. * Added a `SessionHistory` record type to replace the old `(Request, Response ByteString)` type. The new type has the same data as the previous tuple, but additionally records the number of attempted HTTP retries, and instead of `Response ByteString` uses `Either SomeException (Response ByteString)` so that HTTP request errors can be logged. * Removed `wdKeepSessHist` field from `WDConfig` and replaced it with `wdHistoryConfig`, which uses a new `SessionHistoryConfig` type. @@ -151,7 +180,7 @@ ``` ### Implicit waits API (`Test.WebDriver.Commands.Wait`)-* Added functions for checking some expected conditions in explicit waits: `expectNotStale`, `expectAlertOpen`, `catchFailedCommand`+* Added functions for checking some expected conditions in explicit waits: `expectNotStale`, `expectAlertOpen`, `catchFailedCommand`. ### Typeclass API * `WDSessionState` is now a superclass of `Monad` and `Applicative` instead of `MonadBaseControl IO`. This makes the class significantly more flexible in how it can be used, as it no longer requires `IO` as a base monad.@@ -182,45 +211,45 @@ ### Minor API changes (not exposed to `Test.WebDriver` module) * `Test.WebDriver.Session` changes- * new function `mostRecentHistory` added- * `lastHTTPRequest` renamed to `mostRecentHTTPRequest` (for consistency)- * `mkSession` moved from `Test.WebDriver.Config` to `Test.WebDriver.Session`+ * new function `mostRecentHistory` added.+ * `lastHTTPRequest` renamed to `mostRecentHTTPRequest` (for consistency).+ * `mkSession` moved from `Test.WebDriver.Config` to `Test.WebDriver.Session`. * `Test.WebDriver.Internal` changes * `sendHTTPRequest` now returns `(Either SomeException (Response ByteString))` and catches any exceptions that occur during the request. When using default configuration, the exceptions are also saved in 'wdSessHist'. * `Test.WebDriver.Internal` no longer defines and exports exception types. All exception defined here previously have been moved to an unexposed `Test.WebDriver.Exceptions.Internal` module. These types are still exported in the usual places. ### Dependencies-* Now supports http-types up to 0.9+* Now supports http-types up to 0.9. ## 0.6.3.1-* Fixed an issue with aeson 0.10 support+* Fixed an issue with aeson 0.10 support. ## 0.6.3-* Support aeson 0.10-* Added support for multiple HTTP attempts per command request, using the new WDConfig field wdHTTPRetryCount+* Support aeson 0.10.+* Added support for multiple HTTP attempts per command request, using the new WDConfig field wdHTTPRetryCount. ## 0.6.2.1-* Supports vector 0.11, aeson 0.9, attoparsec 0.13+* Supports vector 0.11, aeson 0.9, attoparsec 0.13. ## 0.6.2-* Supports GHC 7.10-* Supports reworked Chrome capabilities used by newer versions of WebDriver-* Servers that return empty JSON strings for commands with no return value will no longer cause parse errors+* Supports GHC 7.10.+* Supports reworked Chrome capabilities used by newer versions of WebDriver.+* Servers that return empty JSON strings for commands with no return value will no longer cause parse errors. ## 0.6.1-* Added the ability to pass HTTP request headers at session creation-* Fixed an issue involving an obsolete JSON representation of Chrome capabilities-* Relax upper bound on exceptions dependency+* Added the ability to pass HTTP request headers at session creation.+* Fixed an issue involving an obsolete JSON representation of Chrome capabilities.+* Relax upper bound on exceptions dependency. ## 0.6.0.4-* Support for monad-control 1.0+* Support for monad-control 1.0. ## 0.6.0.3-* Relaxed upper bounds on text and http-client versions+* Relaxed upper bounds on text and http-client versions. ## 0.6.0.2-* Added support for aeson > 0.8 and network > 2.6-* Added support for the "X-Response-Body-Start" HTTP header used for error responses in newer http-client versions+* Added support for aeson > 0.8 and network > 2.6.+* Added support for the "X-Response-Body-Start" HTTP header used for error responses in newer http-client versions. ## 0.6.0.1 * Fixed Haddock parse errors. No code changes introduced in this version.@@ -228,10 +257,10 @@ ## 0.6 * Rather than WDSession serving dual roles as configuration and state, its functionality has been split into 2 respective types: WDConfig and WDSession. * runSession now takes a WDConfig instead of WDSession and Capabilities parameters.-* runSession no longer closes its session on successful completion; use finallyClose or closeOnException for this behavior-* The old Test.WebDriver.Classes module has been split into Test.WebDriver.Session and Test.WebDriver.Class-* SessionState typeclass renamed to WDSessionState-* We now use the http-client package instead of HTTP. This is reflected in the addition of Manager fields in both WDConfig and WDSession+* runSession no longer closes its session on successful completion; use finallyClose or closeOnException for this behavior.+* The old Test.WebDriver.Classes module has been split into Test.WebDriver.Session and Test.WebDriver.Class.+* SessionState typeclass renamed to WDSessionState.+* We now use the http-client package instead of HTTP. This is reflected in the addition of Manager fields in both WDConfig and WDSession. ## 0.5.5 * Added optional HTTP history tracking for debugging purposes.@@ -241,50 +270,50 @@ * Relaxed dependencies on mtl, network and scientific. ## 0.5.3.3-* Relaxed text dependency up to 1.2+* Relaxed text dependency up to 1.2. ## 0.5.3.2 ### bug fixes-* fixed remaining compilation problems with aeson. now supports aeson >= 0.6.2.0 && < 0.8+* fixed remaining compilation problems with aeson. now supports aeson >= 0.6.2.0 && < 0.8. * now depends on directory-tree instead of filesystem-trees. this fixes several problems with firefox/chrome profile support. ## 0.5.3.1 ### bug fixes-* fixed compilation error with aeson 0.7 and greater+* fixed compilation error with aeson 0.7 and greater. ## 0.5.3 ### new features-* SessionNotCreated constructor added to FailedCommandType-* new command deleteCookieByName added+* SessionNotCreated constructor added to FailedCommandType.+* new command deleteCookieByName added. ###b ug fixes-* asyncJS now properly distinguishes between a null return and a script timeout-* fixed a change in waitWhile causing the opposite of expected behavior+* asyncJS now properly distinguishes between a null return and a script timeout.+* fixed a change in waitWhile causing the opposite of expected behavior. ## 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+* 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+* 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+* 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+* 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 the webdriver standard. This includes the functions getLogs and getLogTypes, and the types LogType and LogEntry.@@ -314,7 +343,7 @@ ### bug fixes * fixed a typo in the export list of Firefox.Profile; deleteFile is now correctly exported instead of removeFile from System.Directory-* fixed an error in the JSON representation of MouseButton+* fixed an error in the JSON representation of MouseButton. ### new features * A new module, Test.WebDriver.Commands.Internal, which exports some low-level functions used to implement the high-level interface. This makes it possible for library users to extend hs-webdriver with nonstandard or unimplemented features.@@ -335,20 +364,20 @@ * It's now possible to add entire directories to a profile in pure code using addFile and addExtension. * new functions in Common.Profile: unionProfiles, onProfileFiles, onProfilePrefs * new function in Commands.Wait: onTimeout-* the WD monad now has a MonadCatchIO instance, as an alternative to lifted-base for exception handling+* the WD monad now has a MonadCatchIO instance, as an alternative to lifted-base for exception handling. ## hs-webdriver 0.3.2.1 ### bug fixes-* Removed a bug in waitWhile' that resulted in an infinite loop-* Fixed the incorrect representation of JSON profiles-* Fixed relative path issues when zipping profile directories from disk+* Removed a bug in waitWhile' that resulted in an infinite loop.+* Fixed the incorrect representation of JSON profiles.+* Fixed relative path issues when zipping profile directories from disk. ## hs-webdriver 0.3.2 ### bug fixes-* Changed the constraint on filesystrem-trees to avoid a broken version+* Changed the constraint on filesystrem-trees to avoid a broken version. * Added the missing exports for addFile and deleteFile in Common.Profile and Firefox.Profile ### new features@@ -399,11 +428,11 @@ ### API changes * FailedCommandInfo changed so that it stores a WDSession rather than just a Maybe SessionId, thus providing server host and port information as well as the session ID. * As a result, mkFailedCommandInfo is now String -> WD FailedCommandInfo, since it requires access to the WDSession state.-* HTML5StorageType changed to the more accurate WebStorageType+* HTML5StorageType changed to the more accurate WebStorageType. ### new features-* general documentation improvements-* the uploadFile, uploadRawFile, and uploadZipEntry functions, which support uploading file contents to the remote server+* general documentation improvements.+* the uploadFile, uploadRawFile, and uploadZipEntry functions, which support uploading file contents to the remote server. ## hs-webdriver 0.1 @@ -411,8 +440,8 @@ * getWindowSize, setWindowSize, getWindowPos, and setWindowPos have all been deprived of their WindowHandle argument. This is due to the fact that using unfocused windows with those commands causes undefined behavior. ### new features-* the mkCookie function for convenient cookie construction-* the focusFrame function for focusing to individual frames-* the setPageLoadTimeout function-* the maximize function for maximizing windows-* support for HTML 5 web storage+* the mkCookie function for convenient cookie construction.+* the focusFrame function for focusing to individual frames.+* the setPageLoadTimeout function.+* the maximize function for maximizing windows.+* support for HTML 5 web storage.
LICENSE view
@@ -1,5 +1,5 @@ Copyright (c) 2012-2015, Adam Curtis-Copyright (c) 2022-2023, Tom McLaughlin+Copyright (c) 2022-2024, Tom McLaughlin All rights reserved. Redistribution and use in source and binary forms, with or without
README.md view
@@ -3,92 +3,8 @@ [](https://hackage.haskell.org/package/webdriver)  -haskell-webdriver is a Selenium WebDriver client for the Haskell programming language. You can use it to automate browser sessions for testing, system administration, etc.--For more information about Selenium itself, see http://seleniumhq.org/--# Contents-* [Installation](#installation)- * [Installation from Hackage](#installation-from-hackage)- * [Installation from This Repository](#installation-from-this-repository)-* [Getting Started](#getting-started)- * [Using the Selenium Server](#using-the-selenium-server)- * [Hello, World!](#hello-world)-* [Integration with Haskell Testing Frameworks](#integration-with-haskell-testing-frameworks)-* [Documentation](#documentation)--# Installation-haskell-webdriver uses the Cabal build system to configure, build, install, and generate documentation on multiple platforms.--For more information on using Cabal and its various installation options, see the Cabal User's Guide at http://www.haskell.org/cabal/users-guide/index.html--## Installation from Hackage-haskell-webdriver is hosted on Hackage under the name webdriver. Thus, the simplest way to download and install the most recent version of haskell-webdriver is to run:--```sh-cabal install webdriver-```-There are also options to do system-wide installation, version selection, and other build options; see cabal-install documentation.--## Installation from this repository--To build and install a git revision for a single user on your system, run these commands from within the repository directory---### Using cabal-install--```sh-cabal install-```--### Using Cabal--For systems without cabal-install available, you can also run the Setup.hs-script, as such:--```sh-runhaskell Setup.hs configure --user-runhaskell Setup.hs build-runhaskell Setup.hs install-```--For more build options, please refer to the Cabal documentation.---# Getting Started--WebDriver is a client-server protocol. Since haskell-webdriver only implements a WebDriver client, you must have a WebDriver server to which you can connect in order to make use of this library.--## Using the Selenium Server-While you can use any WebDriver server out there, probably the simplest server to use with haskell-webdriver is [Selenium Server](http://docs.seleniumhq.org/download/). You'll need an installation of the Java runtime to use this server. Once you've downloaded Selenium Server to your current working directory, you can start the server with this shell command:-- java -jar selenium-server-standalone-*.jar--The server should now be listening at localhost on port 4444.--Currently, `haskell-webdriver` only supports selenium version 2.-The [beginner example](/examples/readme-example-beginner.md) was-tested with `selenium-server-standalone-2.53.1`.--## Hello, World!-With the Selenium server running locally, you're ready to write browser automation scripts in Haskell.--A [simple example can be found here](/examples/readme-example-beginner.md), written in literate Haskell so that you can compile it with GHC yourself. It is very beginner friendly and assumes no prior knowledge of Haskell. For other examples see the [examples](examples/) and [test/etc](test/etc/) directory.---# Integration with Haskell Testing Frameworks--This package does not provide utilities to integrate with popular Haskell testing frameworks. However, other packages exist for this purpose:--* [hspec-webdriver](https://hackage.haskell.org/package/hspec-webdriver)-* [quickcheck-webdriver](https://hackage.haskell.org/package/quickcheck-webdriver)+haskell-webdriver is a WebDriver client for the Haskell programming language. You can use it to automate browser sessions for testing, system administration, etc. # Documentation -Documentation for haskell-webdriver is available on Hackage at <http://hackage.haskell.org/package/webdriver>. You can also generate local HTML documentation from this source revision with the following shell command:--```sh-runhaskell Setup.hs haddock-```--Haddock will generate documentation and save it in `dist/doc/html/webdriver`+Documentation for haskell-webdriver is available on Hackage at <http://hackage.haskell.org/package/webdriver>.
+ app/Main.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE NumericUnderscores #-}++module Main where++import Control.Monad.IO.Class+import Control.Monad.Logger+import Test.WebDriver+import Test.WebDriver.Capabilities+import Test.WebDriver.WD+import UnliftIO.Concurrent (threadDelay)+import UnliftIO.Directory+import UnliftIO.Exception+++main :: IO ()+main = do+ -- You must have a compatible chrome/chromedriver on your PATH for this to work+ Just chromedriverBin <- findExecutable "chromedriver"+ Just chromeBin <- findExecutable "google-chrome-stable"++ let caps = defaultCaps {+ _capabilitiesGoogChromeOptions = Just $ defaultChromeOptions {+ _chromeOptionsBinary = Just chromeBin+ }+ }++ let driverConfig = DriverConfigChromedriver {+ driverConfigChromedriver = chromedriverBin+ , driverConfigChromedriverFlags = []+ , driverConfigChromedriverExtraEnv = Nothing+ , driverConfigChrome = chromeBin+ , driverConfigLogDir = Nothing+ }++ runStdoutLoggingT $ bracket mkEmptyWebDriverContext teardownWebDriverContext $ \wdc -> do+ sess <- startSession wdc driverConfig caps "session1"+ runWD sess $ do+ openPage "http://www.xkcd.com"+ liftIO $ threadDelay 5_000_000++ sess2 <- startSession wdc driverConfig caps "session2"+ runWD sess2 $ do+ openPage "http://www.smbc-comics.com"+ liftIO $ threadDelay 5_000_000
src/Test/WebDriver.hs view
@@ -1,42 +1,264 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ViewPatterns #-}+ {-|-This module serves as the top-level interface to the Haskell WebDriver bindings,-providing most of the functionality you're likely to want.++Once upon a time, the main browser automation tool was Selenium. Users of+this package had to start a Selenium session themselves, making sure to+configure it with a browser-specific driver program like @chromedriver@ or+@geckodriver@, and provide a hostname\/port. Then, this package would connect to+Selenium and use its wire protocol to control browsers.++Nowadays, there is an official W3C spec (<https://www.w3.org/TR/webdriver1>)+specifying the protocol, and a number of implementations. Selenium still exists,+but Chromedriver and Geckodriver can both serve as standalone WebDriver servers.+This library now helps you start up a driver in one of these supported+configurations:++1. Selenium.jar with one or more supported sub-drivers (@chromedriver@,+@geckodriver@). This is similar to the traditional picture.+2. Chromedriver standalone.+3. Geckodriver standalone.++You can pick the configuration you want by passing a 'DriverConfig' to the+'startSession' function. The WebDriver implementations have a few differences+between them, which this library tries to smooth over. For example, a single+Geckodriver instance can't start multiple Firefox sessions (see+<https://github.com/mozilla/geckodriver/issues/1946>). So, this library will spin+up a separate @geckodriver@ process for every session.++For an example of using this package by itself, see "Test.WebDriver.WD". For a+full test framework integrated with this package, see+[sandwich-webdriver](https://hackage.haskell.org/package/sandwich-webdriver).+ -} module Test.WebDriver (- -- * WebDriver monad- WD(..)- -- * Running WebDriver commands- , runSession, withSession, runWD- -- * WebDriver configuration- , WDConfig(..), defaultConfig- -- ** Configuration helper functions- -- | Instead of working with the 'Capabilities' record directly, you can use- -- these config modifier functions to specify common options.- , useBrowser, useProxy, useVersion, usePlatform- -- ** Session history configuration- , SessionHistoryConfig, noHistory, unlimitedHistory, onlyMostRecentHistory- -- ** HTTP request header utilities- , withRequestHeaders, withAuthHeaders- -- * WebDriver commands+ -- * WebDriverContext+ WebDriverContext+ , mkEmptyWebDriverContext+ , teardownWebDriverContext++ -- * Managed sessions+ , startSession+ , closeSession+ , DriverConfig(..)++ -- * Lower-level session management+ , startSession'+ , closeSession'+ , mkManualDriver++ -- * Capabilities+ , defaultCaps+ , defaultChromeOptions+ , defaultFirefoxOptions+ , Capabilities(..)+ , Platform(..)+ , ProxyType(..)++ -- * Commands , module Test.WebDriver.Commands- -- * Capabilities (advanced configuration)- , Capabilities(..), defaultCaps, allCaps, modifyCaps- , Platform(..), ProxyType(..)- -- ** Browser-specific capabilities- , Browser(..), LogLevel(..)- -- *** Browser defaults- , firefox, chrome, ie, opera, iPhone, iPad, android- -- * Exception handling- , finallyClose, closeOnException++ , mkDriverRequest+ , _driverManager++ -- * WebDriver monad+ , WebDriver+ , WebDriverBase++ , Session++ -- * Exceptions , module Test.WebDriver.Exceptions- -- * Accessing session history- , SessionHistory(..), getSessionHistory, dumpSessionHistory ) where +import Data.Aeson as A+import Test.WebDriver.Capabilities+import Test.WebDriver.Capabilities.Proxy import Test.WebDriver.Commands-import Test.WebDriver.Config import Test.WebDriver.Exceptions-import Test.WebDriver.Monad-import Test.WebDriver.Session+import Test.WebDriver.JSON+import Test.WebDriver.LaunchDriver import Test.WebDriver.Types++import Data.Map as M+import Control.Monad.Catch (MonadMask)+import Control.Monad+import Control.Monad.IO.Class+import Data.String.Interpolate+import qualified Data.Text as T+import Test.WebDriver.Util.Aeson (aesonLookup)+import Control.Monad.Logger+import Network.HTTP.Client+import Network.HTTP.Types (RequestHeaders, statusCode)+import UnliftIO.Concurrent+import UnliftIO.Exception+import UnliftIO.STM+++-- | Start a WebDriver session, with a given 'WebDriverContext' and+-- 'DriverConfig'.+--+-- You need to provide the WebDriver 'Capabilities' for the session. You should+-- make sure the browser-specific fields of your 'Capabilities' are filled in+-- correctly to match the given 'DriverConfig'. For example, if you're using+-- 'DriverConfigChromedriver', you should make sure to fill in+-- '_capabilitiesGoogChromeOptions' and in particular the '_chromeOptionsBinary'+-- field.++startSession :: (WebDriverBase m, MonadMask m, MonadLogger m) => WebDriverContext -> DriverConfig -> Capabilities -> String -> m Session+startSession wdc dc@(DriverConfigSeleniumJar {}) caps sessionName = do+ driver <- modifyMVar (_webDriverSelenium wdc) $ \maybeSelenium -> do+ driver <- maybe (launchDriver dc) return maybeSelenium+ return (Just driver, driver)++ launchSessionInDriver wdc driver caps sessionName+startSession wdc dc@(DriverConfigChromedriver {}) caps sessionName = do+ driver <- modifyMVar (_webDriverChromedriver wdc) $ \maybeChromedriver -> do+ driver <- maybe (launchDriver dc) return maybeChromedriver+ return (Just driver, driver)++ launchSessionInDriver wdc driver caps sessionName+startSession wdc dc@(DriverConfigGeckodriver {}) caps sessionName = do+ driver <- launchDriver dc+ onException (launchSessionInDriver wdc driver caps sessionName)+ (teardownDriver driver)++launchSessionInDriver :: (WebDriverBase m, MonadLogger m) => WebDriverContext -> Driver -> Capabilities -> String -> m Session+launchSessionInDriver wdc driver caps sessionName = do+ sess <- startSession' driver caps sessionName++ modifyMVar (_webDriverSessions wdc) $ \sessionMap ->+ case M.lookup sessionName sessionMap of+ Just _ -> throwIO SessionNameAlreadyExists+ Nothing -> return (M.insert sessionName sess sessionMap, sess)++-- | Lower-level version of 'startSession'. This one allows you to construct a+-- driver instance manually and pass it in. Does not manage process lifecycles.+startSession' :: (WebDriverBase m, MonadLogger m) => Driver -> Capabilities -> String -> m Session+startSession' driver caps sessionName = do+ response <- doCommandBase driver methodPost "/session" $ single "capabilities" $ single "alwaysMatch" caps++ if | statusCode (responseStatus response) == 200 -> do+ case A.eitherDecode (responseBody response) of+ Right x@(A.Object (aesonLookup "value" -> Just value@(A.Object (aesonLookup "sessionId" -> Just (A.String sessId))))) -> do+ logInfoN [i|Got capabilities from driver: #{A.encode x}|]++ let maybeWebSocketUrl = case value of+ A.Object (aesonLookup "capabilities" -> Just (A.Object (aesonLookup "webSocketUrl" -> Just (A.String url)))) -> Just url+ _ -> Nothing++ idCounterVar <- newTVarIO 1++ return $ Session {+ sessionDriver = driver+ , sessionId = SessionId sessId+ , sessionName = sessionName+ , sessionWebSocketUrl = T.unpack <$> maybeWebSocketUrl+ , sessionIdCounter = idCounterVar+ }+ _ -> throwIO $ SessionCreationResponseHadNoSessionId response+ | otherwise -> throwIO SessionNameAlreadyExists++-- | Close the given WebDriver session. This sends the @DELETE+-- \/session\/:sessionId@ command to the WebDriver API, and then shuts down the+-- process if necessary.+closeSession :: (WebDriverBase m, MonadLogger m) => WebDriverContext -> Session -> m ()+closeSession wdc sess@(Session {..}) = do+ -- For geckodriver, we own the process (one per session), so we must always+ -- tear it down -- even if the HTTP DELETE to close the session fails.+ let teardownGecko = case _driverConfig sessionDriver of+ DriverConfigGeckodriver {} -> teardownDriver sessionDriver+ _ -> return ()++ flip finally teardownGecko $ do+ closeSession' sess+ modifyMVar_ (_webDriverSessions wdc) (return . M.delete sessionName)++-- | Close the given WebDriver session. This is a lower-level version of+-- 'closeSession', which manages the driver lifecycle for you. This version will+-- only issue the @DELETE \/session\/:sessionId@ command to the driver, but will+-- not shut down driver processes.+closeSession' :: (WebDriverBase m, MonadLogger m) => Session -> m ()+closeSession' (Session { sessionId=(SessionId sessId), .. }) = do+ _response <- doCommandBase sessionDriver methodDelete ("/session/" <> sessId) Null+ -- TODO: throw an exception if this failed?+ return ()++-- | Create a manual 'Driver' to use with 'startSession''/'closeSession''.+mkManualDriver :: MonadIO m =>+ -- | Host name+ String+ -- | Port+ -> Int+ -- | Base HTTP path (use "\/wd\/hub" for Selenium)+ -> String+ -- | Headers to send with every request+ -> RequestHeaders+ -> m Driver+mkManualDriver hostname port basePath requestHeaders = do+ manager <- liftIO $ newManager defaultManagerSettings++ return $ Driver {+ _driverHostname = hostname+ , _driverPort = port+ , _driverBasePath = basePath+ , _driverRequestHeaders = requestHeaders+ , _driverManager = manager+ , _driverProcess = Nothing+ , _driverLogAsync = Nothing+ , _driverConfig = DriverConfigChromedriver "" [] Nothing "" Nothing -- Not used+ }++-- | Tear down all sessions and processes associated with a 'WebDriverContext'.+teardownWebDriverContext :: (WebDriverBase m, MonadLogger m) => WebDriverContext -> m ()+teardownWebDriverContext (WebDriverContext {..}) = do+ -- Atomically take all sessions and clear the map, so we can clean up each+ -- one without holding the MVar (and without modifyMVar_ restoring the old+ -- value if any individual cleanup throws).+ sessions <- modifyMVar _webDriverSessions $ \s -> return (mempty, M.toList s)++ forM_ sessions $ \(_name, sess) -> do+ catch (closeSession' sess)+ (\(e :: SomeException) -> logWarnN [i|Exception closing session during teardown: #{e}|])+ -- Geckodriver runs one process per session; tear it down here since+ -- closeSession' only sends the HTTP DELETE and doesn't manage processes.+ case _driverConfig (sessionDriver sess) of+ DriverConfigGeckodriver {} ->+ catch (teardownDriver (sessionDriver sess))+ (\(e :: SomeException) -> logWarnN [i|Exception tearing down geckodriver during teardown: #{e}|])+ _ -> return ()++ modifyMVar_ _webDriverSelenium $ \case+ Nothing -> return Nothing+ Just driver -> teardownDriver driver >> return Nothing++ modifyMVar_ _webDriverChromedriver $ \case+ Nothing -> return Nothing+ Just driver -> teardownDriver driver >> return Nothing++-- -- | Set a temporary list of custom 'RequestHeaders' to use within the given action.+-- -- All previous custom headers are temporarily removed, and then restored at the end.+-- withRequestHeaders :: (SessionStatePut m) => RequestHeaders -> m a -> m a+-- withRequestHeaders _h _action = undefined -- do+-- -- withModifiedSession (\s -> s { wdSessRequestHeaders = h }) action++-- -- | Makes all webdriver HTTP requests in the given action use the session\'s auth headers, typically+-- -- configured by setting the 'wdAuthHeaders' config. This is useful if you want to temporarily use+-- -- the same auth headers you used for session creation with other HTTP requests.+-- withAuthHeaders :: (Monad m, SessionStatePut m) => m a -> m a+-- withAuthHeaders _wd = undefined -- do+-- -- authHeaders <- fmap wdSessAuthHeaders getSession+-- -- withRequestHeaders authHeaders wd++-- -- | A finalizer ensuring that the session is always closed at the end of+-- -- the given 'WD' action, regardless of any exceptions.+-- finallyClose :: (HasCallStack, WebDriver wd, MonadMask wd) => wd a -> wd a+-- finallyClose wd = closeOnException wd <* closeSession++-- -- | Exception handler that closes the session when an+-- -- asynchronous exception is thrown, but otherwise leaves the session open+-- -- if the action was successful.+-- closeOnException :: (HasCallStack, MonadMask wd) => WebDriver wd => wd a -> wd a+-- closeOnException wd = wd `onException` closeSession
src/Test/WebDriver/Capabilities.hs view
@@ -1,777 +1,193 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-}--module Test.WebDriver.Capabilities where--import Test.WebDriver.Chrome.Extension-import Test.WebDriver.Firefox.Profile-import Test.WebDriver.JSON--import Data.Aeson-import Data.Aeson.Types (Parser, typeMismatch, Pair)--import Data.Text (Text, toLower, toUpper)-import Data.Default (Default, def)-import Data.Word (Word16)-import Data.Maybe (fromMaybe, catMaybes)-import Data.String (fromString)--import Control.Applicative-import Control.Exception.Lifted (throw)--import Prelude -- hides some "unused import" warnings--#if MIN_VERSION_aeson(2,0,0)-import qualified Data.Aeson.KeyMap as HM (delete, toList, empty)-#else-import qualified Data.HashMap.Strict as HM (delete, toList, empty)-#endif----- |A typeclass for readable 'Capabilities'-class GetCapabilities t where- getCaps :: t -> Capabilities--instance GetCapabilities Capabilities where- getCaps = id---- |A typeclass for writable 'Capabilities'-class SetCapabilities t where- setCaps :: Capabilities -> t -> t---- |Read/write 'Capabilities'-type HasCapabilities t = (GetCapabilities t, SetCapabilities t)---- |Modifies the 'wdCapabilities' field of a 'WDConfig' by applying the given function. Overloaded to work with any 'HasCapabilities' instance.-modifyCaps :: HasCapabilities t => (Capabilities -> Capabilities) -> t -> t-modifyCaps f c = setCaps (f (getCaps c)) c---- |A helper function for setting the 'browser' capability of a 'HasCapabilities' instance-useBrowser :: HasCapabilities t => Browser -> t -> t-useBrowser b = modifyCaps $ \c -> c { browser = b }---- |A helper function for setting the 'version' capability of a 'HasCapabilities' instance-useVersion :: HasCapabilities t => String -> t -> t-useVersion v = modifyCaps $ \c -> c { version = Just v }---- |A helper function for setting the 'platform' capability of a 'HasCapabilities' instance-usePlatform :: HasCapabilities t => Platform -> t -> t-usePlatform p = modifyCaps $ \c -> c { platform = p }+{-# LANGUAGE TemplateHaskell #-} --- |A helper function for setting the 'useProxy' capability of a 'HasCapabilities' instance-useProxy :: HasCapabilities t => ProxyType -> t -> t-useProxy p = modifyCaps $ \c -> c { proxy = p }+{-| +This module contains the types for working with WebDriver Capabilities.+Capabilities are used to configure and communicate the features supported by a+session. -{- |A structure describing the capabilities of a session. This record-serves dual roles.+Some settings, like '_capabilitiesTimeouts', are browser-agnostic. But the+'Capabilities' object is also where browser-specific settings can be added,+under '_capabilitiesGoogChromeOptions', '_capabilitiesMozFirefoxOptions', etc. -* It's used to specify the desired capabilities for a session before-it's created. In this usage, fields that are set to Nothing indicate-that we have no preference for that capability.+This module provides lenses for all of the fields it defines, to make it easier+to manipulate nested values. -* When received from the server , it's used to-describe the actual capabilities given to us by the WebDriver-server. Here a value of Nothing indicates that the server doesn't-support the capability. Thus, for Maybe Bool fields, both Nothing and-Just False indicate a lack of support for the desired capability. -}-data Capabilities =- Capabilities { -- |Browser choice and browser specific settings.- browser :: Browser- -- |Browser version to use.- , version :: Maybe String- -- |Platform on which the browser should run.- , platform :: Platform- -- |Proxy configuration settings.- , proxy :: ProxyType- -- |Whether the session supports executing JavaScript via- -- 'executeJS' and 'asyncJS'.- , javascriptEnabled :: Maybe Bool- -- |Whether the session supports taking screenshots of the- -- current page with the 'screenshot' command- , takesScreenshot :: Maybe Bool- -- |Whether the session can interact with modal popups,- -- such as window.alert and window.confirm via- -- 'acceptAlerts', 'dismissAlerts', etc.- , handlesAlerts :: Maybe Bool- -- |Whether the session can interact with database storage.- , databaseEnabled :: Maybe Bool- -- |Whether the session can set and query the browser's- -- location context with 'setLocation' and 'getLocation'.- , locationContextEnabled :: Maybe Bool- -- |Whether the session can interact with the application cache- -- .- , applicationCacheEnabled :: Maybe Bool- -- |Whether the session can query for the browser's- -- connectivity and disable it if desired- , browserConnectionEnabled :: Maybe Bool- -- |Whether the session supports CSS selectors when searching- -- for elements.- , cssSelectorsEnabled :: Maybe Bool- -- |Whether Web Storage ('getKey', 'setKey', etc) support is- -- enabled- , webStorageEnabled :: Maybe Bool- -- |Whether the session can rotate the current page's current- -- layout between 'Portrait' and 'Landscape' orientations.- , rotatable :: Maybe Bool- -- |Whether the session should accept all SSL certs by default- , acceptSSLCerts :: Maybe Bool- -- |Whether the session is capable of generating native OS- -- events when simulating user input.- , nativeEvents :: Maybe Bool- -- |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- def = Capabilities { browser = firefox- , version = Nothing- , platform = Any- , javascriptEnabled = Nothing- , takesScreenshot = Nothing- , handlesAlerts = Nothing- , databaseEnabled = Nothing- , locationContextEnabled = Nothing- , applicationCacheEnabled = Nothing- , browserConnectionEnabled = Nothing- , cssSelectorsEnabled = Nothing- , webStorageEnabled = Nothing- , rotatable = Nothing- , acceptSSLCerts = Nothing- , nativeEvents = Nothing- , proxy = UseSystemSettings- , unexpectedAlertBehavior = Nothing- , additionalCaps = []- }+module Test.WebDriver.Capabilities (+ -- * Capabilities+ Capabilities(..)+ , defaultCaps --- |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' capabilities are set to 'Nothing' (no preference).-defaultCaps :: Capabilities-defaultCaps = def+ -- ** Lenses+ , capabilitiesBrowserName+ , capabilitiesBrowserVersion+ , capabilitiesPlatformName+ , capabilitiesAcceptInsecureCerts+ , capabilitiesPageLoadStrategy+ , capabilitiesProxy+ , capabilitiesSetWindowRect+ , capabilitiesTimeouts+ , capabilitiesUnhandledPromptBehavior+ , capabilitiesGoogChromeOptions+ , capabilitiesMozFirefoxOptions+ , capabilitiesWebSocketUrl --- |Same as 'defaultCaps', but with all 'Maybe' 'Bool' capabilities set to--- 'Just' 'True'.-allCaps :: Capabilities-allCaps = defaultCaps { javascriptEnabled = Just True- , takesScreenshot = Just True- , handlesAlerts = Just True- , databaseEnabled = Just True- , locationContextEnabled = Just True- , applicationCacheEnabled = Just True- , browserConnectionEnabled = Just True- , cssSelectorsEnabled = Just True- , webStorageEnabled = Just True- , rotatable = Just True- , acceptSSLCerts = Just True- , nativeEvents = Just True- }+ -- ** Types+ , Timeouts(..)+ , UserPromptHandler(..)+ , Platform(..) -instance ToJSON Capabilities where- toJSON Capabilities{..} =- object $ filter (\p -> snd p /= Null)- $ [ "browserName" .= browser- , "version" .= version- , "platform" .= platform- , "proxy" .= proxy- , "javascriptEnabled" .= javascriptEnabled- , "takesScreenshot" .= takesScreenshot- , "handlesAlerts" .= handlesAlerts- , "databaseEnabled" .= databaseEnabled- , "locationContextEnabled" .= locationContextEnabled- , "applicationCacheEnabled" .= applicationCacheEnabled- , "browserConnectionEnabled" .= browserConnectionEnabled- , "cssSelectorsEnabled" .= cssSelectorsEnabled- , "webStorageEnabled" .= webStorageEnabled- , "rotatable" .= rotatable- , "acceptSslCerts" .= acceptSSLCerts- , "nativeEvents" .= nativeEvents- , "unexpectedAlertBehavior" .= unexpectedAlertBehavior- ]- ++ browserInfo- ++ additionalCaps- where- browserInfo = case browser of- Firefox {..}- -> ["firefox_profile" .= ffProfile- ,"loggingPrefs" .= object ["driver" .= ffLogPref]- ,"firefox_binary" .= ffBinary- ,"acceptInsecureCerts" .= fromMaybe False ffAcceptInsecureCerts- ]- Chrome {..}- -> catMaybes [ opt "chrome.chromedriverVersion" chromeDriverVersion ]- ++ [ "chromeOptions" .= object (catMaybes- [ opt "binary" chromeBinary- ] ++- [ "args" .= chromeOptions- , "extensions" .= chromeExtensions- ] ++ HM.toList chromeExperimentalOptions- )]- IE {..}- -> ["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- , opt "opera.display" operaDisplay- , opt "opera.product" operaProduct- , opt "opera.launcher" operaLauncher- , opt "opera.host" operaHost- , opt "opera.logging.file" operaLogFile- ]- ++ ["opera.detatch" .= operaDetach- ,"opera.no_quit" .= operaDetach --backwards compatability- ,"opera.autostart" .= operaAutoStart- , "opera.idle" .= operaIdle- -- ,"opera.profile" .= operaProfile- ,"opera.port" .= fromMaybe maxBound {- (-1) -} operaPort- --note: consider replacing operaOptions with a list of options- ,"opera.arguments" .= operaOptions- ,"opera.logging.level" .= operaLogPref- ]+ -- * Chrome+ , ChromeOptions(..)+ , defaultChromeOptions+ -- *** Lenses+ , chromeOptionsWindowTypes+ , chromeOptionsPrefs+ , chromeOptionsPerfLoggingPrefs+ , chromeOptionsMobileEmulation+ , chromeOptionsMinidumpPath+ , chromeOptionsLocalState+ , chromeOptionsExtensions+ , chromeOptionsExcludeSwitches+ , chromeOptionsDetach+ , chromeOptionsDebuggerAddress+ , chromeOptionsBinary+ , chromeOptionsArgs - Phantomjs {..}- -> catMaybes [ opt "phantomjs.binary.path" phantomjsBinary- ] ++- [ "phantomjs.cli.args" .= phantomjsOptions- ]+ -- ** Client hints+ , ChromeClientHints(..)+ , mkChromeClientHints+ , chromeClientHintsWow64+ , chromeClientHintsPlatformVersion+ , chromeClientHintsPlatform+ , chromeClientHintsModel+ , chromeClientHintsMobile+ , chromeClientHintsFullVersionList+ , chromeClientHintsBrands+ , chromeClientHintsBitness+ , chromeClientHintsArchitecture+ , BrandAndVersion(..) - _ -> []+ -- ** Device metrics+ , ChromeDeviceMetrics(..)+ , chromeDeviceMetricsWidth+ , chromeDeviceMetricsTouch+ , chromeDeviceMetricsPixelRatio+ , chromeDeviceMetricsMobile+ , chromeDeviceMetricsHeight - where- opt k = fmap (k .=)+ -- ** Extensions+ , ChromeExtension+ , loadExtension+ , loadRawExtension + -- ** Mobile emulation+ , ChromeMobileEmulation(..)+ , chromeMobileEmulationUserAgent+ , chromeMobileEmulationDeviceName+ , chromeMobileEmulationDeviceMetrics+ , chromeMobileEmulationClientHints -instance FromJSON Capabilities where- 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)+ -- * Firefox+ , FirefoxOptions(..)+ , emptyFirefoxOptions+ , defaultFirefoxOptions - where --some helpful JSON accessor shorthands- req :: FromJSON a => Text -> Parser a- req = (o .:) . fromText -- 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+ -- ** Lenses+ , firefoxOptionsBinary+ , firefoxOptionsArgs+ , firefoxOptionsProfile+ , firefoxOptionsLog+ , firefoxOptionsPrefs+ , firefoxOptionsEnv - -- produce additionalCaps by removing known capabilities from the JSON object- additionalCapabilities = HM.toList . foldr HM.delete o . knownCapabilities+ -- ** Log level+ , FirefoxLogLevel(..)+ , FirefoxLogLevelType(..)+ ) where - 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", "acceptInsecureCerts"]- 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- <*> opt "acceptInsecureCerts" Nothing- Chrome {} -> Chrome <$> opt "chrome.chromedriverVersion" Nothing- <*> opt "chrome.binary" Nothing- <*> opt "chrome.switches" []- <*> opt "chrome.extensions" []- <*> pure HM.empty- 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+import Data.Aeson.TH+import Lens.Micro.TH+import Test.WebDriver.Capabilities.Aeson+import Test.WebDriver.Capabilities.ChromeOptions+import Test.WebDriver.Capabilities.FirefoxOptions+import Test.WebDriver.Capabilities.Platform+import Test.WebDriver.Capabilities.Proxy+import Test.WebDriver.Capabilities.Timeouts+import Test.WebDriver.Capabilities.UserPromptHandler - parseJSON v = typeMismatch "Capabilities" v --- |This constructor simultaneously specifies which browser the session will--- use, while also providing browser-specific configuration. Default--- configuration is provided for each browser by 'firefox', 'chrome', 'opera',--- 'ie', etc.+-- | A structure describing the capabilities of a session. This record+-- serves dual roles. ----- This library uses 'firefox' as its 'Default' browser configuration, when no--- browser choice is specified.-data Browser = Firefox { -- |The firefox profile to use. If Nothing,- -- a default temporary profile is automatically created- -- and used.- ffProfile :: Maybe (PreparedProfile Firefox)- -- |Firefox logging preference- , ffLogPref :: LogLevel- -- |Server-side path to Firefox binary. If Nothing,- -- use a sensible system-based default.- , ffBinary :: Maybe FilePath- -- |Available after Firefox 52, and required only for Firefox- -- geckodriver. Indicates whether untrusted and self-signed TLS- -- certificates are implicitly trusted on navigation for the- -- duration of the session.- , ffAcceptInsecureCerts :: Maybe Bool- }- | Chrome { -- |Version of the Chrome Webdriver server server to use- --- -- for more information on chromedriver see- -- <https://github.com/SeleniumHQ/selenium/wiki/ChromeDriver>- chromeDriverVersion :: Maybe String- -- |Server-side path to Chrome binary. If Nothing,- -- use a sensible system-based default.- , chromeBinary :: Maybe FilePath- -- |A list of command-line options to pass to the- -- Chrome binary.- , chromeOptions :: [String]- -- |A list of extensions to use.- , chromeExtensions :: [ChromeExtension]- -- | Experimental options not yet exposed through a standard API.- , chromeExperimentalOptions :: Object- }- | 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.- 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- --, operaNoRestart :: Maybe Bool- -- |Which Opera product we're using, e.g. \"desktop\",- -- \"core\"- , operaProduct :: Maybe String- -- |Whether the Opera instance should stay open after- -- we close the session. If false, closing the session- -- closes the browser.- , operaDetach :: Bool- -- |Whether to auto-start the Opera binary. If false,- -- OperaDriver will wait for a connection from the- -- browser. By default this is True.- , operaAutoStart :: Bool- -- |Whether to use Opera's alternative implicit wait- -- implementation. It will use an in-browser heuristic- -- to guess when a page has finished loading. This- -- feature is experimental, and disabled by default.- , operaIdle :: Bool- -- |(*nix only) which X display to use.- , operaDisplay :: Maybe Int- --, operaProfile :: Maybe (PreparedProfile Opera)- -- |Path to the launcher binary to use. The launcher- -- is a gateway between OperaDriver and the Opera- -- browser. If Nothing, OperaDriver will use the- -- launcher supplied with the package.- , operaLauncher :: Maybe FilePath- -- |The port we should use to connect to Opera. If Just 0- -- , use a random port. If Nothing, use the default- -- Opera port. The default 'opera' constructor uses- -- Just 0, since Nothing is likely to cause "address- -- already in use" errors.- , operaPort :: Maybe Word16- -- |The host Opera should connect to. Unless you're- -- starting Opera manually you won't need this.- , operaHost :: Maybe String- -- |Command-line arguments to pass to Opera.- , operaOptions :: Maybe String- -- |Where to send the log output. If Nothing, logging is- -- disabled.- , operaLogFile :: Maybe FilePath- -- |Log level preference. Defaults to 'LogInfo'- , operaLogPref :: LogLevel- }-- | Phantomjs { phantomjsBinary :: Maybe FilePath- , phantomjsOptions :: [String]- }-- | HTMLUnit- | IPhone- | IPad- | Android- -- |some other browser, specified by a string name- | Browser Text- deriving (Eq, Show)--instance Default Browser where- def = firefox---instance ToJSON Browser where- toJSON Firefox {} = String "firefox"- toJSON Chrome {} = String "chrome"- toJSON Opera {} = String "opera"- toJSON IE {} = String "internet explorer"- toJSON Phantomjs {} = String "phantomjs"- toJSON (Browser b) = String b- toJSON b = String . toLower . fromString . show $ b--instance FromJSON Browser where- parseJSON (String jStr) = case toLower jStr of- "firefox" -> return firefox- "chrome" -> return chrome- "internet explorer" -> return ie- "opera" -> return opera- "phantomjs" -> return phantomjs- -- "safari" -> return safari- "iphone" -> return iPhone- "ipad" -> return iPad- "android" -> return android- "htmlunit" -> return htmlUnit- other -> return (Browser other)- parseJSON v = typeMismatch "Browser" v----- |Default Firefox settings. All Maybe fields are set to Nothing. ffLogPref--- is set to 'LogInfo'.-firefox :: Browser-firefox = Firefox Nothing def Nothing Nothing---- |Default Chrome settings. All Maybe fields are set to Nothing, no options are--- specified, and no extensions are used.-chrome :: Browser-chrome = Chrome Nothing Nothing [] [] HM.empty---- |Default IE settings. See the 'IE' constructor for more details on--- individual defaults-ie :: Browser-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.-opera :: Browser-opera = Opera { operaBinary = Nothing- --, operaNoRestart = Nothing- , operaProduct = Nothing- , operaDetach = False- , operaAutoStart = True- , operaDisplay = Nothing- , operaIdle = False--- , operaProfile = Nothing- , operaLauncher = Nothing- , operaHost = Nothing- , operaPort = Just 0- , operaOptions = Nothing- , operaLogFile = Nothing- , operaLogPref = def- }--phantomjs :: Browser-phantomjs = Phantomjs Nothing []----safari :: Browser---safari = Safari--htmlUnit :: Browser-htmlUnit = HTMLUnit--iPhone :: Browser-iPhone = IPhone--iPad :: Browser-iPad = IPad--android :: Browser-android = Android---- |Represents platform options supported by WebDriver. The value Any represents--- no preference.-data Platform = Windows | XP | Vista | Mac | Linux | Unix | Any- deriving (Eq, Show, Ord, Bounded, Enum)--instance ToJSON Platform where- toJSON = String . toUpper . fromString . show--instance FromJSON Platform where- parseJSON (String jStr) = case toLower jStr of- "windows" -> return Windows- "xp" -> return XP- "vista" -> return Vista- "mac" -> return Mac- "linux" -> return Linux- "unix" -> return Unix- "any" -> return Any- err -> fail $ "Invalid Platform string " ++ show err- parseJSON v = typeMismatch "Platform" v---- |Available settings for the proxy 'Capabilities' field-data ProxyType = NoProxy- | UseSystemSettings- | AutoDetect- -- |Use a proxy auto-config file specified by URL- | PAC { autoConfigUrl :: String }- -- |Manually specify proxy hosts as hostname:port strings.- -- Note that behavior is undefined for empty strings.- | Manual { ftpProxy :: String- , sslProxy :: String- , httpProxy :: String- }- deriving (Eq, Show)--instance FromJSON ProxyType where- parseJSON (Object obj) = do- pTyp <- f "proxyType"- case toLower pTyp of- "direct" -> return NoProxy- "system" -> return UseSystemSettings- "pac" -> PAC <$> f "autoConfigUrl"- "manual" -> Manual <$> f "ftpProxy"- <*> f "sslProxy"- <*> f "httpProxy"- _ -> fail $ "Invalid ProxyType " ++ show pTyp- where- f :: FromJSON a => Text -> Parser a- f = (obj .:) . fromText- parseJSON v = typeMismatch "ProxyType" v--instance ToJSON ProxyType where- toJSON pt = object $ case pt of- NoProxy ->- ["proxyType" .= ("DIRECT" :: String)]- UseSystemSettings ->- ["proxyType" .= ("SYSTEM" :: String)]- AutoDetect ->- ["proxyType" .= ("AUTODETECT" :: String)]- PAC{autoConfigUrl = url} ->- ["proxyType" .= ("PAC" :: String)- ,"proxyAutoconfigUrl" .= url- ]- Manual{ftpProxy = ftp, sslProxy = ssl, httpProxy = http} ->- ["proxyType" .= ("MANUAL" :: String)- ,"ftpProxy" .= ftp- ,"sslProxy" .= ssl- ,"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 | LogDebug | LogAll- deriving (Eq, Show, Read, Ord, Bounded, Enum)+-- It's used to specify the desired capabilities for a session before+-- it's created. In this usage, fields that are set to Nothing indicate+-- that we have no preference for that capability.+--+-- When received from the server , it's used to describe the actual+-- capabilities given to us by the WebDriver server. Here a value of+-- Nothing indicates that the server doesn't support the capability.+-- Thus, for Maybe Bool fields, both Nothing and Just False indicate+-- a lack of support for the desired capability.+data Capabilities = Capabilities {+ -- | Identifies the user agent.+ _capabilitiesBrowserName :: Maybe String+ -- | Identifies the version of the user agent.+ , _capabilitiesBrowserVersion :: Maybe String+ -- | Identifies the operating system of the endpoint node.+ , _capabilitiesPlatformName :: Maybe Platform+ -- | Indicates whether untrusted and self-signed TLS certificates are implicitly trusted on navigation for the+ -- duration of the session.+ , _capabilitiesAcceptInsecureCerts :: Maybe Bool+ -- | Defines the current session’s page load strategy.+ , _capabilitiesPageLoadStrategy :: Maybe String+ -- | Defines the current session’s proxy configuration.+ , _capabilitiesProxy :: Maybe Proxy+ -- | Indicates whether the remote end supports all of the commands in Resizing and Positioning Windows.+ , _capabilitiesSetWindowRect :: Maybe Bool+ -- | Describes the timeouts imposed on certain session operations.+ , _capabilitiesTimeouts :: Maybe Timeouts+ -- | Describes the current session’s user prompt handler.+ , _capabilitiesUnhandledPromptBehavior :: Maybe UserPromptHandler -instance Default LogLevel where- def = LogInfo+ -- * Vendor-specific stuff+ -- | Chrome options+ , _capabilitiesGoogChromeOptions :: Maybe ChromeOptions+ -- | Firefox options+ , _capabilitiesMozFirefoxOptions :: Maybe FirefoxOptions -instance ToJSON LogLevel where- toJSON p= String $ case p of- LogOff -> "OFF"- LogSevere -> "SEVERE"- LogWarning -> "WARNING"- LogInfo -> "INFO"- LogConfig -> "CONFIG"- LogFine -> "FINE"- LogFiner -> "FINER"- LogFinest -> "FINEST"- LogDebug -> "DEBUG"- LogAll -> "ALL"+ , _capabilitiesWebSocketUrl :: Maybe Bool -instance FromJSON LogLevel where- parseJSON (String s) = return $ case s of- "OFF" -> LogOff- "SEVERE" -> LogSevere- "WARNING" -> LogWarning- "INFO" -> LogInfo- "CONFIG" -> LogConfig- "FINE" -> LogFine- "FINER" -> LogFiner- "FINEST" -> LogFinest- "DEBUG" -> LogDebug- "ALL" -> LogAll- _ -> throw . BadJSON $ "Invalid logging preference: " ++ show s- parseJSON other = typeMismatch "LogLevel" other+ } deriving (Eq, Show)+deriveJSON capabilitiesOptions ''Capabilities+makeLenses ''Capabilities +-- | Default capabilities.+defaultCaps :: Capabilities+defaultCaps = Capabilities {+ _capabilitiesBrowserName = Nothing+ , _capabilitiesBrowserVersion = Nothing --- |Logging levels for Internet Explorer-data IELogLevel = IELogTrace | IELogDebug | IELogInfo | IELogWarn | IELogError- | IELogFatal- deriving (Eq, Show, Read, Ord, Bounded, Enum)+ , _capabilitiesPlatformName = Nothing -instance Default IELogLevel where- def = IELogFatal+ , _capabilitiesAcceptInsecureCerts = Nothing + , _capabilitiesPageLoadStrategy = Nothing -instance ToJSON IELogLevel where- toJSON p= String $ case p of- IELogTrace -> "TRACE"- IELogDebug -> "DEBUG"- IELogInfo -> "INFO"- IELogWarn -> "WARN"- IELogError -> "ERROR"- IELogFatal -> "FATAL"+ , _capabilitiesProxy = Nothing -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+ , _capabilitiesSetWindowRect = Nothing --- |Specifies how elements scroll into the viewport. (see 'ieElementScrollBehavior')-data IEElementScrollBehavior = AlignTop | AlignBottom- deriving (Eq, Ord, Show, Read, Enum, Bounded)+ , _capabilitiesTimeouts = Nothing -instance Default IEElementScrollBehavior where- def = AlignTop+ , _capabilitiesUnhandledPromptBehavior = Nothing -instance ToJSON IEElementScrollBehavior where- toJSON AlignTop = toJSON (0 :: Int)- toJSON AlignBottom = toJSON (1 :: Int)+ , _capabilitiesGoogChromeOptions = Nothing+ , _capabilitiesMozFirefoxOptions = Nothing -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+ , _capabilitiesWebSocketUrl = Nothing+ }
+ src/Test/WebDriver/Capabilities/Aeson.hs view
@@ -0,0 +1,93 @@++module Test.WebDriver.Capabilities.Aeson where++import Data.Aeson as A+import Data.Char+import Data.Function+import qualified Data.List as L+++baseOptions :: A.Options+baseOptions = A.defaultOptions { omitNothingFields = True }++toCamel1, toCamel2, toCamel3 :: A.Options+toCamel1 = baseOptions { A.fieldLabelModifier = snakeToCamelCase . toSnakeAndDropN 1 . dropLeadingUnderscore }+toCamel2 = baseOptions { A.fieldLabelModifier = snakeToCamelCase . toSnakeAndDropN 2 . dropLeadingUnderscore }+toCamel3 = baseOptions { A.fieldLabelModifier = snakeToCamelCase . toSnakeAndDropN 3 . dropLeadingUnderscore }++toCamelC1, toCamelC2, toCamelC3, toCamelC4 :: A.Options+toCamelC1 = baseOptions { A.constructorTagModifier = snakeToCamelCase . toSnakeAndDropN 1 }+toCamelC2 = baseOptions { A.constructorTagModifier = snakeToCamelCase . toSnakeAndDropN 2 }+toCamelC3 = baseOptions { A.constructorTagModifier = snakeToCamelCase . toSnakeAndDropN 3 }+toCamelC4 = baseOptions { A.constructorTagModifier = snakeToCamelCase . toSnakeAndDropN 4 }++-- | For 'UserPromptHandler', which maps things like+-- UserPromptHandlerAcceptAndNotify -> "accept and notify"+toSpacedC3 :: A.Options+toSpacedC3 = baseOptions { A.constructorTagModifier = snakeToSpaced . toSnakeAndDropN 3 }++-- | For FailedCommandError+toSpacedC0 :: A.Options+toSpacedC0 = baseOptions {+ A.constructorTagModifier = snakeToSpaced . toSnakeAndDropN 0+ , A.sumEncoding = A.UntaggedValue+ }++capabilitiesOptions :: A.Options+capabilitiesOptions = baseOptions {+ A.fieldLabelModifier = specialCases . snakeToCamelCase . toSnakeAndDropN 1 . dropLeadingUnderscore+ }+ where+ specialCases "googChromeOptions" = "goog:chromeOptions"+ specialCases "mozFirefoxOptions" = "moz:firefoxOptions"+ specialCases x = x+++-- * Util++toSnakeAndDropN :: Int -> String -> String+toSnakeAndDropN n s = L.intercalate "_" snakeParts+ where+ snakeParts :: [String]+ snakeParts = s+ & dropLeadingUnderscore+ & splitR isUpper+ & L.drop n+ & fmap (fmap toLower)++splitR :: (Char -> Bool) -> String -> [String]+splitR _ [] = []+splitR p s =+ let+ go :: Char -> String -> [String]+ go m s' = case L.break p s' of+ (b', []) -> [ m:b' ]+ (b', x:xs) -> ( m:b' ) : go x xs+ in case L.break p s of+ (b, []) -> [ b ]+ ([], h:t) -> go h t+ (b, h:t) -> b : go h t++snakeToCamelCase :: String -> String+snakeToCamelCase s = case parts of+ (x:xs) -> x <> concatMap capitalize xs+ [] -> ""+ where+ parts = case splitR (== '_') s of+ (x:xs) -> x : (fmap (L.drop 1) xs)+ [] -> []++snakeToSpaced :: String -> String+snakeToSpaced s = L.intercalate " " parts+ where+ parts = case splitR (== '_') s of+ (x:xs) -> x : (fmap (L.drop 1) xs)+ [] -> []++dropLeadingUnderscore :: [Char] -> [Char]+dropLeadingUnderscore ('_':xs) = xs+dropLeadingUnderscore xs = xs++capitalize :: String -> String+capitalize (x:xs) = toUpper x : (fmap toLower xs)+capitalize x = x
+ src/Test/WebDriver/Capabilities/ChromeOptions.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}++module Test.WebDriver.Capabilities.ChromeOptions where++import Control.Monad.IO.Class+import Data.Aeson+import Data.Aeson as A+import Data.Aeson.TH+import Data.ByteString.Base64.Lazy as B64+import Data.ByteString.Lazy as LBS+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy.Encoding (decodeLatin1)+import Lens.Micro.TH+import Test.WebDriver.Capabilities.Aeson+++-- | See https://developer.chrome.com/docs/chromedriver/mobile-emulation+data ChromeDeviceMetrics = ChromeDeviceMetrics {+ -- | The width in pixels of the device's screen.+ _chromeDeviceMetricsWidth :: Maybe Int+ -- | The height in pixels of the device's screen.+ , _chromeDeviceMetricsHeight :: Maybe Int+ -- | The device's pixel ratio.+ , _chromeDeviceMetricsPixelRatio :: Maybe Double+ -- | Whether to emulate touch events. The value defaults to true and usually+ -- can be omitted.+ , _chromeDeviceMetricsTouch :: Maybe Bool+ -- | Whether the browser must behave as a mobile user agent (overlay+ -- scrollbars, emit orientation events, shrink the content to fit the+ -- viewport, etc.). The value defaults to true and usually can be omitted.+ , _chromeDeviceMetricsMobile :: Maybe Bool+ } deriving (Show, Eq)+deriveJSON toCamel3 ''ChromeDeviceMetrics+makeLenses ''ChromeDeviceMetrics++data BrandAndVersion = BrandAndVersion {+ brandAndVersionBrand :: String+ , brandAndVersionVersion :: String+ } deriving (Show, Eq)+deriveJSON toCamel3 ''BrandAndVersion+makeLenses ''BrandAndVersion++-- | See https://developer.chrome.com/docs/chromedriver/mobile-emulation+data ChromeClientHints = ChromeClientHints {+ -- | The operating system. It can be either a known value ("Android", "Chrome+ -- OS", "Chromium OS", "Fuchsia", "Linux", "macOS", "Windows"), that exactly+ -- matches the value returned by Chrome running on the given platform, or it+ -- can be a user defined value. This value is mandatory.+ _chromeClientHintsPlatform :: String+ -- | Whether the browser should request a mobile or desktop resource version.+ -- Usually Chrome running on a mobile phone with Android sets this value to+ -- true. Chrome on a tablet Android device sets this value to false. Chrome on+ -- a desktop device also sets this value to false. You can use this+ -- information to specify a realistic emulation. This value is mandatory.+ , _chromeClientHintsMobile :: Bool+ -- | List of brand / major version pairs. If omitted the browser uses its own+ -- values.+ , _chromeClientHintsBrands :: Maybe [BrandAndVersion]+ -- | List of brand / version pairs. It omitted the browser uses its own+ -- values.+ , _chromeClientHintsFullVersionList :: Maybe [BrandAndVersion]+ -- | OS version. Defaults to empty string.+ , _chromeClientHintsPlatformVersion :: Maybe String+ -- | Device model. Defaults to empty string.+ , _chromeClientHintsModel :: Maybe String+ -- | CPU architecture. Known values are "x86" and "arm". The user is free to+ -- provide any string value. Defaults to empty string.+ , _chromeClientHintsArchitecture :: Maybe String+ -- | Platform bitness. Known values are "32" and "64". The user is free to+ -- provide any string value. Defaults to empty string.+ , _chromeClientHintsBitness :: Maybe String+ -- | Emulation of windows 32 on windows 64. A boolean value that defaults to+ -- false.+ , _chromeClientHintsWow64 :: Maybe Bool+ } deriving (Show, Eq)+deriveJSON toCamel3 ''ChromeClientHints+makeLenses ''ChromeClientHints+mkChromeClientHints :: String -> Bool -> ChromeClientHints+mkChromeClientHints platform mobile = ChromeClientHints {+ _chromeClientHintsPlatform = platform+ , _chromeClientHintsMobile = mobile+ , _chromeClientHintsBrands = Nothing+ , _chromeClientHintsFullVersionList = Nothing+ , _chromeClientHintsPlatformVersion = Nothing+ , _chromeClientHintsModel = Nothing+ , _chromeClientHintsArchitecture = Nothing+ , _chromeClientHintsBitness = Nothing+ , _chromeClientHintsWow64 = Nothing+ }++-- | See https://developer.chrome.com/docs/chromedriver/mobile-emulation+data ChromeMobileEmulation =+ -- | Specify a known device. To enable device emulation with a specific+ -- device, the "mobileEmulation" dictionary must contain a "deviceName." Use a+ -- valid device name from the DevTools Emulated Devices settings as the value+ -- for "deviceName."+ ChromeMobileEmulationSpecificDevice {+ _chromeMobileEmulationDeviceName :: String+ }+ -- | Specify individual device attributes.+ | ChromeMobileEmulationIndividualAttributes {+ _chromeMobileEmulationDeviceMetrics :: Maybe ChromeDeviceMetrics+ , _chromeMobileEmulationClientHints :: Maybe ChromeClientHints+ -- | ChromeDriver is capable to infer "userAgent" value from "clientHints" on+ -- the following platforms: "Android", "Chrome OS", "Chromium OS", "Fuchsia",+ -- "Linux", "macOS", "Windows". Therefore this value can be omitted.+ --+ -- If "clientHints" dictionary is omitted (legacy mode) ChromeDriver does its+ -- best to infer the "clientHints" from "userAgent". This feature is not+ -- reliable, due to internal ambiguities of "userAgent" value format.+ , _chromeMobileEmulationUserAgent :: Maybe String+ }+ deriving (Show, Eq)+deriveJSON (toCamel3 { sumEncoding = UntaggedValue }) ''ChromeMobileEmulation+makeLenses ''ChromeMobileEmulation++-- | A packed Google Chrome extension (.crx), as base64-encoded 'Text'.+newtype ChromeExtension = ChromeExtension TL.Text+ deriving (Eq, Show, Read, ToJSON, FromJSON)++-- | Load a .crx file as a 'ChromeExtension'.+loadExtension :: MonadIO m => FilePath -> m ChromeExtension+loadExtension path = liftIO $ loadRawExtension <$> LBS.readFile path++-- | Load raw .crx data as a 'ChromeExtension'.+loadRawExtension :: ByteString -> ChromeExtension+loadRawExtension = ChromeExtension . decodeLatin1 . B64.encode++-- | See https://developer.chrome.com/docs/chromedriver/capabilities#chromeoptions_object+data ChromeOptions = ChromeOptions {+ -- | List of command-line arguments to use when starting Chrome. Arguments with an associated value should be separated+ -- by a '=' sign (such as, ['start-maximized', 'user-data-dir=/tmp/temp_profile']). See a list of Chrome arguments:+ -- https://peter.sh/experiments/chromium-command-line-switches/+ _chromeOptionsArgs :: Maybe [String]+ -- | Path to the Chrome executable to use. On macOS X, this should be the actual binary, not just the app, such as,+ -- /Applications/Google Chrome.app/Contents/MacOS/Google Chrome.+ , _chromeOptionsBinary :: Maybe FilePath+ -- | A list of Chrome extensions to install on startup. Each item in the list should be a base-64 encoded packed Chrome+ -- extension (.crx)+ , _chromeOptionsExtensions :: Maybe [ChromeExtension]+ -- | A dictionary with each entry consisting of the name of the preference and its value. These preferences are applied+ -- to the Local State file in the user data folder.+ , _chromeOptionsLocalState :: Maybe A.Object+ -- | A dictionary with each entry consisting of the name of the preference and its value. These preferences are only+ -- applied to the user profile in use. See the 'Preferences' file in Chrome's user data directory for examples.+ , _chromeOptionsPrefs :: Maybe A.Object+ -- | If false, Chrome is quit when ChromeDriver is killed, regardless of whether the session is quit.+ -- If true, Chrome only quits if the session is quit or closed. If true and the session isn't quit, ChromeDriver+ -- cannot clean up the temporary user data directory that the running Chrome instance is using.+ , _chromeOptionsDetach :: Maybe Bool+ -- | An address of a Chrome debugger server to connect to, in the form of @<hostname/ip:port>@, such as '127.0.0.1:38947'+ , _chromeOptionsDebuggerAddress :: Maybe String+ -- | List of Chrome command line switches to exclude that ChromeDriver by default passes when starting Chrome. Don't+ -- prefix switches with --.+ , _chromeOptionsExcludeSwitches :: Maybe [String]+ -- | Directory to store Chrome minidumps. (Supported only on Linux.)+ , _chromeOptionsMinidumpPath :: Maybe FilePath+ -- | A dictionary with either a value for "deviceName," or values for "deviceMetrics", and "userAgent." Refer to Mobile+ -- Emulation for more information.+ , _chromeOptionsMobileEmulation :: Maybe ChromeMobileEmulation+ -- | An optional dictionary that specifies performance logging preferences.+ , _chromeOptionsPerfLoggingPrefs :: Maybe A.Object+ -- | A list of window types that appear in the list of window handles. For access to webview elements, include "webview"+ -- in this list.+ , _chromeOptionsWindowTypes :: Maybe [String]+ }+ deriving (Show, Eq)+deriveJSON toCamel2 ''ChromeOptions+makeLenses ''ChromeOptions++-- | Empty 'ChromeOptions'.+defaultChromeOptions :: ChromeOptions+defaultChromeOptions = ChromeOptions {+ _chromeOptionsArgs = Nothing+ , _chromeOptionsBinary = Nothing+ , _chromeOptionsExtensions = Nothing+ , _chromeOptionsLocalState = Nothing+ , _chromeOptionsPrefs = Nothing+ , _chromeOptionsDetach = Nothing+ , _chromeOptionsDebuggerAddress = Nothing+ , _chromeOptionsExcludeSwitches = Nothing+ , _chromeOptionsMinidumpPath = Nothing+ , _chromeOptionsMobileEmulation = Nothing+ , _chromeOptionsPerfLoggingPrefs = Nothing+ , _chromeOptionsWindowTypes = Nothing+ }
+ src/Test/WebDriver/Capabilities/FirefoxOptions.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.WebDriver.Capabilities.FirefoxOptions where++import Data.Aeson as A+import Data.Aeson.TH+import Data.Map (Map)+import Lens.Micro.TH+import Test.WebDriver.Capabilities.Aeson+import Test.WebDriver.Profile+++data FirefoxLogLevelType =+ FirefoxLogLevelTypeTrace+ | FirefoxLogLevelTypeDebug+ | FirefoxLogLevelTypeConfig+ | FirefoxLogLevelTypeInfo+ | FirefoxLogLevelTypeWarn+ | FirefoxLogLevelTypeError+ | FirefoxLogLevelTypeFatal+ deriving (Show, Eq)+deriveJSON toCamelC4 ''FirefoxLogLevelType+makeLenses ''FirefoxLogLevelType++data FirefoxLogLevel = FirefoxLogLevel {+ _firefoxLogLevelLevel :: FirefoxLogLevelType+ }+ deriving (Show, Eq)+deriveJSON toCamel3 ''FirefoxLogLevel+makeLenses ''FirefoxLogLevel++-- | See https://developer.mozilla.org/en-US/docs/Web/WebDriver/Capabilities/firefoxOptions+data FirefoxOptions = FirefoxOptions {+ -- | Absolute path to the custom Firefox binary to use.+ --+ -- On macOS you may either give the path to the application bundle, i.e.+ -- @\/Applications\/Firefox.app@, or the absolute path to the executable+ -- binary inside this bundle, for example+ -- @\/Applications\/Firefox.app\/Contents\/MacOS\/firefox-bin@.+ --+ -- geckodriver will attempt to deduce the default location of Firefox on the+ -- current system if left undefined.+ _firefoxOptionsBinary :: Maybe String+ -- | Command line arguments to pass to the Firefox binary. These must include+ -- the leading dash (-) where required, e.g. ["-headless"].+ --+ -- To have geckodriver pick up an existing profile on the local filesystem,+ -- you may pass @["-profile", -- "\/path\/to\/profile"]@. But if a profile has+ -- to be transferred to a target machine it is recommended to use the profile+ -- entry.+ , _firefoxOptionsArgs :: Maybe [String]+ -- | Base64-encoded ZIP of a profile directory to use for the Firefox+ -- instance. This may be used to e.g. install extensions or custom+ -- certificates, but for setting custom preferences we recommend using the+ -- prefs entry instead.+ , _firefoxOptionsProfile :: Maybe (Profile Firefox)+ -- | To increase the logging verbosity of geckodriver and Firefox, you may+ -- pass a log object that may look like {"log": {"level": "trace"}} to include+ -- all trace-level logs and above.+ , _firefoxOptionsLog :: Maybe FirefoxLogLevel+ -- | Map of preference name to preference value, which can be a string, a+ -- boolean or an integer.+ , _firefoxOptionsPrefs :: Maybe A.Object+ -- | Map of environment variable name to environment variable value, both of+ -- which must be strings.+ --+ -- On Desktop, the Firefox under test will launch with given variable in its+ -- environment. On Android, the GeckoView-based App will have the given+ -- variable added to the env block in its configuration YAML.+ , _firefoxOptionsEnv :: Maybe (Map String String)++ -- TODO: Android options+ }+ deriving (Show, Eq)+deriveJSON toCamel2 ''FirefoxOptions+makeLenses ''FirefoxOptions++emptyFirefoxOptions :: FirefoxOptions+emptyFirefoxOptions = FirefoxOptions {+ _firefoxOptionsBinary = Nothing+ , _firefoxOptionsArgs = Nothing+ , _firefoxOptionsProfile = Nothing+ , _firefoxOptionsLog = Nothing+ , _firefoxOptionsPrefs = Nothing+ , _firefoxOptionsEnv = Nothing+ }++-- | Empty 'FirefoxOptions'.+defaultFirefoxOptions :: FirefoxOptions+defaultFirefoxOptions = emptyFirefoxOptions
+ src/Test/WebDriver/Capabilities/Platform.hs view
@@ -0,0 +1,35 @@++module Test.WebDriver.Capabilities.Platform where++import Data.Aeson+import Data.Aeson.Types (typeMismatch)+import Data.String (fromString)+import Data.Text (Text, toLower, toUpper)++-- | Represents the platformName option of the primary capabilities+data Platform =+ Windows+ | XP+ | Vista+ | Mac+ | Linux+ | Unix+ | Any+ | Other Text+ deriving (Eq, Show, Ord)++instance ToJSON Platform where+ toJSON (Other t) = String t+ toJSON x = String $ toUpper $ fromString $ show x++instance FromJSON Platform where+ parseJSON (String jStr) = case toLower jStr of+ "windows" -> return Windows+ "xp" -> return XP+ "vista" -> return Vista+ "mac" -> return Mac+ "linux" -> return Linux+ "unix" -> return Unix+ "any" -> return Any+ t -> return $ Other t+ parseJSON v = typeMismatch "Platform" v
+ src/Test/WebDriver/Capabilities/Proxy.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.WebDriver.Capabilities.Proxy where++import Data.Aeson.TH+import Test.WebDriver.Capabilities.Aeson+++data ProxyType =+ ProxyTypePac+ | ProxyTypeDirect+ | ProxyTypeAutodetect+ | ProxyTypeSystem+ | ProxyTypeManual+ deriving (Show, Eq)+deriveJSON toCamelC2 ''ProxyType++data Proxy = Proxy {+ proxyType :: ProxyType+ }+ deriving (Show, Eq)+deriveJSON baseOptions ''Proxy
+ src/Test/WebDriver/Capabilities/Timeouts.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.WebDriver.Capabilities.Timeouts where++import Data.Aeson.TH+import Test.WebDriver.Capabilities.Aeson+++data Timeouts = Timeouts {+ timeoutsScriptMs :: Maybe Int+ , timeoutsPageLoadMs :: Maybe Int+ , timeoutsImplicitMs :: Maybe Int+ }+ deriving (Show, Eq)+deriveJSON toCamelC2 ''Timeouts
+ src/Test/WebDriver/Capabilities/UserPromptHandler.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.WebDriver.Capabilities.UserPromptHandler where++import Data.Aeson.TH+import Test.WebDriver.Capabilities.Aeson+++data UserPromptHandler =+ UserPromptHandlerDismiss+ | UserPromptHandlerAccept+ | UserPromptHandlerDismissAndNotify+ | UserPromptHandlerAcceptAndNotify+ | UserPromptHandlerIgnore+ deriving (Show, Eq)+deriveJSON toSpacedC3 ''UserPromptHandler
− src/Test/WebDriver/Chrome/Extension.hs
@@ -1,30 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}---- | Functions and types for working with Google Chrome extensions.-module Test.WebDriver.Chrome.Extension- ( ChromeExtension- , loadExtension- , loadRawExtension- ) where-import Data.ByteString.Lazy as LBS-import Data.ByteString.Base64.Lazy as B64-import Data.Text.Lazy-import Data.Text.Lazy.Encoding (decodeLatin1)-import Data.Aeson-import Control.Applicative-import Control.Monad.Base--import Prelude -- hides some "unused import" warnings---- |An opaque type representing a Google Chrome extension. Values of this type--- are passed to the 'Test.Webdriver.chromeExtensions' field.-newtype ChromeExtension = ChromeExtension Text- deriving (Eq, Show, Read, ToJSON, FromJSON)---- |Load a .crx file as a 'ChromeExtension'.-loadExtension :: MonadBase IO m => FilePath -> m ChromeExtension-loadExtension path = liftBase $ loadRawExtension <$> LBS.readFile path---- |Load raw .crx data as a 'ChromeExtension'.-loadRawExtension :: ByteString -> ChromeExtension-loadRawExtension = ChromeExtension . decodeLatin1 . B64.encode
− src/Test/WebDriver/Class.hs
@@ -1,73 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}--module Test.WebDriver.Class (- -- * WebDriver class- WebDriver(..), Method, methodDelete, methodGet, methodPost,- ) where-import Test.WebDriver.Session--import Data.Aeson-import Data.Text (Text)-import Network.HTTP.Types.Method (methodDelete, methodGet, methodPost, Method)-import Control.Monad.Trans.Class-import Control.Monad.Trans.Except-import Control.Monad.Trans.Identity-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.RWS.Lazy as LRWS-import Control.Monad.Trans.RWS.Strict as SRWS-import Control.Monad.Trans.Reader-import Control.Monad.Trans.State.Lazy as LS-import Control.Monad.Trans.State.Strict as SS-import Control.Monad.Trans.Writer.Lazy as LW-import Control.Monad.Trans.Writer.Strict as SW-import Data.CallStack--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid) -- for some reason "import Prelude" trick doesn't work with "import Data.Monoid"-#endif----- |A class for monads that can handle wire protocol requests. This is the--- operation underlying all of the high-level commands exported in--- "Test.WebDriver.Commands". For more information on the wire protocol see--- <https://github.com/SeleniumHQ/selenium/wiki/JsonWireProtocol>-class (WDSessionStateControl wd) => WebDriver wd where- doCommand :: (HasCallStack, ToJSON a, FromJSON b) =>- Method -- ^HTTP request method- -> 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- -- result in an empty request body.- -> wd b -- ^The JSON result of the HTTP request.--instance WebDriver wd => WebDriver (SS.StateT s wd) where- doCommand rm t a = lift (doCommand rm t a)--instance WebDriver wd => WebDriver (LS.StateT s wd) where- doCommand rm t a = lift (doCommand rm t a)--instance WebDriver wd => WebDriver (MaybeT wd) where- doCommand rm t a = lift (doCommand rm t a)--instance WebDriver wd => WebDriver (IdentityT wd) where- doCommand rm t a = lift (doCommand rm t a)--instance (Monoid w, WebDriver wd) => WebDriver (LW.WriterT w wd) where- doCommand rm t a = lift (doCommand rm t a)--instance (Monoid w, WebDriver wd) => WebDriver (SW.WriterT w wd) where- doCommand rm t a = lift (doCommand rm t a)--instance WebDriver wd => WebDriver (ReaderT r wd) where- doCommand rm t a = lift (doCommand rm t a)--instance WebDriver wd => WebDriver (ExceptT e wd) where- doCommand rm t a = lift (doCommand rm t a)--instance (Monoid w, WebDriver wd) => WebDriver (SRWS.RWST r w s wd) where- doCommand rm t a = lift (doCommand rm t a)--instance (Monoid w, 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
@@ -1,777 +1,127 @@-{-# LANGUAGE ExistentialQuantification #-} --- | This module exports basic WD actions that can be used to interact with a+-- | This module exports all the actions that can be used to interact with a -- browser session.-module Test.WebDriver.Commands- ( -- * Sessions- createSession, closeSession, sessions, getActualCaps- -- * Browser interaction- -- ** Web navigation- , openPage, forward, back, refresh- -- ** Page info- , getCurrentURL, getSource, getTitle, saveScreenshot, screenshot, screenshotBase64- -- * Timeouts- , setImplicitWait, setScriptTimeout, setPageLoadTimeout- -- * Web elements- , Element(..), Selector(..)- -- ** Searching for elements- , findElem, findElems, findElemFrom, findElemsFrom- -- ** Interacting with elements- , click, submit, getText- -- *** Sending key inputs to elements- , sendKeys, sendRawKeys, clearInput- -- ** Element information- , attr, cssProp, elemPos, elemSize- , isSelected, isEnabled, isDisplayed- , tagName, activeElem, elemInfo- -- ** Element equality- , (<==>), (</=>)- -- * Javascript- , executeJS, asyncJS- , JSArg(..)- -- * Windows- , WindowHandle(..), currentWindow- , getCurrentWindow, closeWindow, windows, focusWindow, maximize- , getWindowSize, setWindowSize, getWindowPos, setWindowPos- -- * Focusing on frames- , focusFrame, FrameSelector(..)- -- * Cookies- , Cookie(..), mkCookie- , cookies, setCookie, deleteCookie, deleteVisibleCookies, deleteCookieByName- -- * Alerts- , getAlertText, replyToAlert, acceptAlert, dismissAlert- -- * Mouse gestures- , moveTo, moveToCenter, moveToFrom- , clickWith, MouseButton(..)- , mouseDown, mouseUp, withMouseDown, doubleClick- -- * HTML 5 Web Storage- , WebStorageType(..), storageSize, getAllKeys, deleteAllKeys- , getKey, setKey, deleteKey- -- * HTML 5 Application Cache- , ApplicationCacheStatus(..)- , getApplicationCacheStatus- -- * Mobile device support- -- ** Screen orientation- , Orientation(..)- , getOrientation, setOrientation- -- ** Geo-location- , getLocation, setLocation- -- ** Touch gestures- , touchClick, touchDown, touchUp, touchMove- , touchScroll, touchScrollFrom, touchDoubleClick- , touchLongClick, touchFlick, touchFlickFrom- -- * IME support- , availableIMEEngines, activeIMEEngine, checkIMEActive- , activateIME, deactivateIME- -- * Uploading files to remote server- -- |These functions allow you to upload a file to a remote server.- -- Note that this operation isn't supported by all WebDriver servers,- -- and the location where the file is stored is not standardized.- , uploadFile, uploadRawFile, uploadZipEntry- -- * Server information and logs- , serverStatus- , getLogs, getLogTypes, LogType, LogEntry(..), LogLevel(..)- ) where--import Codec.Archive.Zip-import Control.Applicative-import Control.Exception (SomeException)-import Control.Exception.Lifted (throwIO, handle)-import qualified Control.Exception.Lifted as L-import Control.Monad-import Control.Monad.Base-import Data.Aeson-import Data.Aeson.Types-import Data.ByteString.Base64.Lazy as B64-import Data.ByteString.Lazy as LBS (ByteString, writeFile)-import Data.CallStack-import qualified Data.Foldable as F-import Data.Maybe-import Data.String (fromString)-import Data.Text (Text, append, toUpper, toLower)-import qualified Data.Text as T-import qualified Data.Text.Lazy.Encoding as TL-import Data.Word-import Network.URI hiding (path) -- suppresses warnings-import Test.WebDriver.Capabilities-import Test.WebDriver.Class-import Test.WebDriver.Commands.Internal-import Test.WebDriver.Cookies-import Test.WebDriver.Exceptions.Internal-import Test.WebDriver.JSON-import Test.WebDriver.Session-import Test.WebDriver.Utils (urlEncode)--import Prelude -- hides some "unused import" warnings---- |Create a new session with the given 'Capabilities'. The returned session becomes the \"current session\" for this action.------ Note: if you're using 'runSession' to run your WebDriver commands, you don't need to call this explicitly.-createSession :: (HasCallStack, WebDriver wd) => Capabilities -> wd WDSession-createSession caps = do- ignoreReturn . withAuthHeaders . doCommand methodPost "/session" . single "desiredCapabilities" $ caps- getSession---- |Retrieve a list of active sessions and their 'Capabilities'.-sessions :: (HasCallStack, WebDriver wd) => wd [(SessionId, Capabilities)]-sessions = do- objs <- doCommand methodGet "/sessions" Null- mapM (parsePair "id" "capabilities" "sessions") objs---- |Get the actual server-side 'Capabilities' of the current session.-getActualCaps :: (HasCallStack, WebDriver wd) => wd Capabilities-getActualCaps = doSessCommand methodGet "" Null---- |Close the current session and the browser associated with it.-closeSession :: (HasCallStack, WebDriver wd) => wd ()-closeSession = do s@WDSession {} <- getSession- noReturn $ doSessCommand methodDelete "" Null- putSession s { wdSessId = Nothing }----- |Sets the amount of time (ms) we implicitly wait when searching for elements.-setImplicitWait :: (HasCallStack, WebDriver wd) => Integer -> wd ()-setImplicitWait ms =- noReturn $ doSessCommand methodPost "/timeouts/implicit_wait" (object msField)- `L.catch` \(_ :: SomeException) ->- doSessCommand methodPost "/timeouts" (object allFields)- where msField = ["ms" .= ms]- allFields = ["type" .= ("implicit" :: String)] ++ msField---- |Sets the amount of time (ms) we wait for an asynchronous script to return a--- result.-setScriptTimeout :: (HasCallStack, WebDriver wd) => Integer -> wd ()-setScriptTimeout ms =- noReturn $ doSessCommand methodPost "/timeouts/async_script" (object msField)- `L.catch` \( _ :: SomeException) ->- doSessCommand methodPost "/timeouts" (object allFields)- where msField = ["ms" .= ms]- allFields = ["type" .= ("script" :: String)] ++ msField---- |Sets the amount of time (ms) to wait for a page to finish loading before throwing a 'Timeout' exception.-setPageLoadTimeout :: (HasCallStack, WebDriver wd) => Integer -> wd ()-setPageLoadTimeout ms = noReturn $ doSessCommand methodPost "/timeouts" params- where params = object ["type" .= ("page load" :: String)- ,"ms" .= ms ]---- |Gets the URL of the current page.-getCurrentURL :: (HasCallStack, WebDriver wd) => wd String-getCurrentURL = doSessCommand methodGet "/url" Null---- |Opens a new page by the given URL.-openPage :: (HasCallStack, WebDriver wd) => String -> wd ()-openPage url- | isURI url = noReturn . doSessCommand methodPost "/url" . single "url" $ url- | otherwise = throwIO . InvalidURL $ url---- |Navigate forward in the browser history.-forward :: (HasCallStack, WebDriver wd) => wd ()-forward = noReturn $ doSessCommand methodPost "/forward" Null---- |Navigate backward in the browser history.-back :: (HasCallStack, WebDriver wd) => wd ()-back = noReturn $ doSessCommand methodPost "/back" Null---- |Refresh the current page-refresh :: (HasCallStack, WebDriver wd) => wd ()-refresh = noReturn $ doSessCommand methodPost "/refresh" Null---- |An existential wrapper for any 'ToJSON' instance. This allows us to pass--- parameters of many different types to Javascript code.-data JSArg = forall a. ToJSON a => JSArg a--instance ToJSON JSArg where- toJSON (JSArg a) = toJSON a--{- |Inject a snippet of Javascript into the page for execution in the-context of the currently selected frame. The executed script is-assumed to be synchronous and the result of evaluating the script is-returned and converted to an instance of FromJSON.--The first parameter defines a sequence of arguments to pass to the javascript-function. Arguments of type Element will be converted to the-corresponding DOM element. Likewise, any elements in the script result-will be returned to the client as Elements.--The second parameter defines the script itself in the form of a-function body. The value returned by that function will be returned to-the client. The function will be invoked with the provided argument-list and the values may be accessed via the arguments object in the-order specified.--When using 'executeJS', GHC might complain about an ambiguous type in-situations where the result of the executeJS call is ignored/discard.-Consider the following example:--@- jsExample = do- e <- findElem (ById "foo")- executeJS [] "someAction()"- return e-@--Because the result of the 'executeJS' is discarded, GHC cannot resolve-which instance of the 'fromJSON' class to use when parsing the-Selenium server response. In such cases, we can use the 'ignoreReturn'-helper function located in "Test.WebDriver.JSON". 'ignoreReturn' has-no runtime effect; it simply helps the type system by expicitly providing-a `fromJSON` instance to use.--@- import Test.WebDriver.JSON (ignoreReturn)- jsExample = do- e <- findElem (ById "foo")- ignoreReturn $ executeJS [] "someAction()"- return e-@--}-executeJS :: (F.Foldable f, FromJSON a, WebDriver wd) => f JSArg -> Text -> wd a-executeJS a s = fromJSON' =<< getResult- where- getResult = doSessCommand methodPost "/execute" . pair ("args", "script") $ (F.toList a,s)--{- |Executes a snippet of Javascript code asynchronously. This function works-similarly to 'executeJS', except that the Javascript is passed a callback-function as its final argument. The script should call this function-to signal that it has finished executing, passing to it a value that will be-returned as the result of asyncJS. A result of Nothing indicates that the-Javascript function timed out (see 'setScriptTimeout')--}-asyncJS :: (HasCallStack, F.Foldable f, FromJSON a, WebDriver wd) => f JSArg -> Text -> wd (Maybe a)-asyncJS a s = handle timeout $ Just <$> (fromJSON' =<< getResult)- where- getResult = doSessCommand methodPost "/execute_async" . pair ("args", "script")- $ (F.toList a,s)- timeout (FailedCommand Timeout _) = return Nothing- timeout (FailedCommand ScriptTimeout _) = return Nothing- timeout err = throwIO err---- |Save a screenshot to a particular location-saveScreenshot :: (HasCallStack, WebDriver wd) => FilePath -> wd ()-saveScreenshot path = screenshot >>= liftBase . LBS.writeFile path---- |Grab a screenshot of the current page as a PNG image-screenshot :: (HasCallStack, 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 :: (HasCallStack, WebDriver wd) => wd LBS.ByteString-screenshotBase64 = TL.encodeUtf8 <$> doSessCommand methodGet "/screenshot" Null--availableIMEEngines :: (HasCallStack, WebDriver wd) => wd [Text]-availableIMEEngines = doSessCommand methodGet "/ime/available_engines" Null--activeIMEEngine :: (HasCallStack, WebDriver wd) => wd Text-activeIMEEngine = doSessCommand methodGet "/ime/active_engine" Null--checkIMEActive :: (HasCallStack, WebDriver wd) => wd Bool-checkIMEActive = doSessCommand methodGet "/ime/activated" Null--activateIME :: (HasCallStack, WebDriver wd) => Text -> wd ()-activateIME = noReturn . doSessCommand methodPost "/ime/activate" . single "engine"--deactivateIME :: (HasCallStack, WebDriver wd) => wd ()-deactivateIME = noReturn $ doSessCommand methodPost "/ime/deactivate" Null----- |Specifies the frame used by 'Test.WebDriver.Commands.focusFrame'-data FrameSelector = WithIndex Integer- -- |focus on a frame by name or ID- | WithName Text- -- |focus on a frame 'Element'- | WithElement Element- -- |focus on the first frame, or the main document- -- if iframes are used.- | DefaultFrame- deriving (Eq, Show, Read)--instance ToJSON FrameSelector where- toJSON s = case s of- WithIndex i -> toJSON i- WithName n -> toJSON n- WithElement e -> toJSON e- DefaultFrame -> Null---- |Switch focus to the frame specified by the FrameSelector.-focusFrame :: (HasCallStack, WebDriver wd) => FrameSelector -> wd ()-focusFrame s = noReturn $ doSessCommand methodPost "/frame" . single "id" $ s---- |Returns a handle to the currently focused window-getCurrentWindow :: (HasCallStack, WebDriver wd) => wd WindowHandle-getCurrentWindow = doSessCommand methodGet "/window_handle" Null---- |Returns a list of all windows available to the session-windows :: (HasCallStack, WebDriver wd) => wd [WindowHandle]-windows = doSessCommand methodGet "/window_handles" Null--focusWindow :: (HasCallStack, WebDriver wd) => WindowHandle -> wd ()-focusWindow w = noReturn $ doSessCommand methodPost "/window" . single "handle" $ w---- |Closes the given window-closeWindow :: (HasCallStack, WebDriver wd) => WindowHandle -> wd ()-closeWindow w = do- cw <- getCurrentWindow- focusWindow w- ignoreReturn $ doSessCommand methodDelete "/window" Null- unless (w == cw) $ focusWindow cw---- |Maximizes the current window if not already maximized-maximize :: (HasCallStack, WebDriver wd) => wd ()-maximize = ignoreReturn $ doWinCommand methodPost currentWindow "/maximize" Null---- |Get the dimensions of the current window.-getWindowSize :: (HasCallStack, WebDriver wd) => wd (Word, Word)-getWindowSize = doWinCommand methodGet currentWindow "/size" Null- >>= parsePair "width" "height" "getWindowSize"---- |Set the dimensions of the current window.-setWindowSize :: (HasCallStack, WebDriver wd) => (Word, Word) -> wd ()-setWindowSize = ignoreReturn . doWinCommand methodPost currentWindow "/size"- . pair ("width", "height")---- |Get the coordinates of the current window.-getWindowPos :: (HasCallStack, WebDriver wd) => wd (Int, Int)-getWindowPos = doWinCommand methodGet currentWindow "/position" Null- >>= parsePair "x" "y" "getWindowPos"---- |Set the coordinates of the current window.-setWindowPos :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()-setWindowPos = ignoreReturn . doWinCommand methodPost currentWindow "/position" . pair ("x","y")---- |Retrieve all cookies visible to the current page.-cookies :: (HasCallStack, WebDriver wd) => wd [Cookie]-cookies = doSessCommand methodGet "/cookie" Null---- |Set a cookie. If the cookie path is not specified, it will default to \"/\".--- Likewise, if the domain is omitted, it will default to the current page's--- domain-setCookie :: (HasCallStack, WebDriver wd) => Cookie -> wd ()-setCookie = noReturn . doSessCommand methodPost "/cookie" . single "cookie"---- |Delete a cookie. This will do nothing is the cookie isn't visible to the--- current page.-deleteCookie :: (HasCallStack, WebDriver wd) => Cookie -> wd ()-deleteCookie c = noReturn $ doSessCommand methodDelete ("/cookie/" `append` urlEncode (cookName c)) Null--deleteCookieByName :: (HasCallStack, WebDriver wd) => Text -> wd ()-deleteCookieByName n = noReturn $ doSessCommand methodDelete ("/cookie/" `append` n) Null---- |Delete all visible cookies on the current page.-deleteVisibleCookies :: (HasCallStack, WebDriver wd) => wd ()-deleteVisibleCookies = noReturn $ doSessCommand methodDelete "/cookie" Null---- |Get the current page source-getSource :: (HasCallStack, WebDriver wd) => wd Text-getSource = doSessCommand methodGet "/source" Null---- |Get the title of the current page.-getTitle :: (HasCallStack, WebDriver wd) => wd Text-getTitle = doSessCommand methodGet "/title" Null---- |Specifies element(s) within a DOM tree using various selection methods.-data Selector = ById Text- | ByName Text- | ByClass Text -- ^ (Note: multiple classes are not- -- allowed. For more control, use 'ByCSS')- | ByTag Text- | ByLinkText Text- | ByPartialLinkText Text- | ByCSS Text- | ByXPath Text- deriving (Eq, Show, Ord)--instance ToJSON Selector where- toJSON s = case s of- ById t -> selector "id" t- ByName t -> selector "name" t- ByClass t -> selector "class name" t- ByTag t -> selector "tag name" t- ByLinkText t -> selector "link text" t- ByPartialLinkText t -> selector "partial link text" t- ByCSS t -> selector "css selector" t- ByXPath t -> selector "xpath" t- where- selector :: Text -> Text -> Value- selector sn t = object ["using" .= sn, "value" .= t]---- |Find an element on the page using the given element selector.-findElem :: (HasCallStack, WebDriver wd) => Selector -> wd Element-findElem = doSessCommand methodPost "/element"---- |Find all elements on the page matching the given selector.-findElems :: (HasCallStack, WebDriver wd) => Selector -> wd [Element]-findElems = doSessCommand methodPost "/elements"---- |Return the element that currently has focus.-activeElem :: (HasCallStack, WebDriver wd) => wd Element-activeElem = doSessCommand methodPost "/element/active" Null---- |Search for an element using the given element as root.-findElemFrom :: (HasCallStack, WebDriver wd) => Element -> Selector -> wd Element-findElemFrom e = doElemCommand methodPost e "/element"---- |Find all elements matching a selector, using the given element as root.-findElemsFrom :: (HasCallStack, WebDriver wd) => Element -> Selector -> wd [Element]-findElemsFrom e = doElemCommand methodPost e "/elements"---- |Describe the element. Returns a JSON object whose meaning is currently--- undefined by the WebDriver protocol.-elemInfo :: (HasCallStack, WebDriver wd) => Element -> wd Value-elemInfo e = doElemCommand methodGet e "" Null-{-# DEPRECATED elemInfo "This command does not work with Marionette (Firefox) driver, and is likely to be completely removed in Selenium 4" #-}---- |Click on an element.-click :: (HasCallStack, WebDriver wd) => Element -> wd ()-click e = noReturn $ doElemCommand methodPost e "/click" Null---- |Submit a form element. This may be applied to descendents of a form element--- as well.-submit :: (HasCallStack, WebDriver wd) => Element -> wd ()-submit e = noReturn $ doElemCommand methodPost e "/submit" Null---- |Get all visible text within this element.-getText :: (HasCallStack, WebDriver wd) => Element -> wd Text-getText e = doElemCommand methodGet e "/text" Null---- |Send a sequence of keystrokes to an element. All modifier keys are released--- at the end of the function. Named constants for special modifier keys can be found--- in "Test.WebDriver.Common.Keys"-sendKeys :: (HasCallStack, WebDriver wd) => Text -> Element -> wd ()-sendKeys t e = noReturn . doElemCommand methodPost e "/value" . single "value" $ [t]---- |Similar to sendKeys, but doesn't implicitly release modifier keys--- afterwards. This allows you to combine modifiers with mouse clicks.-sendRawKeys :: (HasCallStack, WebDriver wd) => Text -> wd ()-sendRawKeys t = noReturn . doSessCommand methodPost "/keys" . single "value" $ [t]---- |Return the tag name of the given element.-tagName :: (HasCallStack, WebDriver wd) => Element -> wd Text-tagName e = doElemCommand methodGet e "/name" Null---- |Clear a textarea or text input element's value.-clearInput :: (HasCallStack, WebDriver wd) => Element -> wd ()-clearInput e = noReturn $ doElemCommand methodPost e "/clear" Null---- |Determine if the element is selected.-isSelected :: (HasCallStack, WebDriver wd) => Element -> wd Bool-isSelected e = doElemCommand methodGet e "/selected" Null---- |Determine if the element is enabled.-isEnabled :: (HasCallStack, WebDriver wd) => Element -> wd Bool-isEnabled e = doElemCommand methodGet e "/enabled" Null---- |Determine if the element is displayed.-isDisplayed :: (HasCallStack, WebDriver wd) => Element -> wd Bool-isDisplayed e = doElemCommand methodGet e "/displayed" Null---- |Retrieve the value of an element's attribute-attr :: (HasCallStack, WebDriver wd) => Element -> Text -> wd (Maybe Text)-attr e t = doElemCommand methodGet e ("/attribute/" `append` urlEncode t) Null---- |Retrieve the value of an element's computed CSS property-cssProp :: (HasCallStack, WebDriver wd) => Element -> Text -> wd (Maybe Text)-cssProp e t = doElemCommand methodGet e ("/css/" `append` urlEncode t) Null---- |Retrieve an element's current position.-elemPos :: (HasCallStack, WebDriver wd) => Element -> wd (Float, Float)-elemPos e = doElemCommand methodGet e "/location" Null >>= parsePair "x" "y" "elemPos"---- |Retrieve an element's current size.-elemSize :: (HasCallStack, WebDriver wd) => Element -> wd (Float, Float)-elemSize e = doElemCommand methodGet e "/size" Null- >>= parsePair "width" "height" "elemSize"--infix 4 <==>--- |Determines if two element identifiers refer to the same element.-(<==>) :: (HasCallStack, WebDriver wd) => Element -> Element -> wd Bool-e1 <==> (Element e2) = doElemCommand methodGet e1 ("/equals/" `append` urlEncode e2) Null---- |Determines if two element identifiers refer to different elements.-infix 4 </=>-(</=>) :: (HasCallStack, WebDriver wd) => Element -> Element -> wd Bool-e1 </=> e2 = not <$> (e1 <==> e2)---- |A screen orientation-data Orientation = Landscape | Portrait- deriving (Eq, Show, Ord, Bounded, Enum)--instance ToJSON Orientation where- toJSON = String . toUpper . fromString . show--instance FromJSON Orientation where- parseJSON (String jStr) = case toLower jStr of- "landscape" -> return Landscape- "portrait" -> return Portrait- err -> fail $ "Invalid Orientation string " ++ show err- parseJSON v = typeMismatch "Orientation" v---- |Get the current screen orientation for rotatable display devices.-getOrientation :: (HasCallStack, WebDriver wd) => wd Orientation-getOrientation = doSessCommand methodGet "/orientation" Null---- |Set the current screen orientation for rotatable display devices.-setOrientation :: (HasCallStack, WebDriver wd) => Orientation -> wd ()-setOrientation = noReturn . doSessCommand methodPost "/orientation" . single "orientation"---- |Get the text of an alert dialog.-getAlertText :: (HasCallStack, WebDriver wd) => wd Text-getAlertText = doSessCommand methodGet "/alert_text" Null---- |Sends keystrokes to Javascript prompt() dialog.-replyToAlert :: (HasCallStack, WebDriver wd) => Text -> wd ()-replyToAlert = noReturn . doSessCommand methodPost "/alert_text" . single "text"---- |Accepts the currently displayed alert dialog.-acceptAlert :: (HasCallStack, WebDriver wd) => wd ()-acceptAlert = noReturn $ doSessCommand methodPost "/accept_alert" Null---- |Dismisses the currently displayed alert dialog.-dismissAlert :: (HasCallStack, WebDriver wd) => wd ()-dismissAlert = noReturn $ doSessCommand methodPost "/dismiss_alert" Null---- |Moves the mouse to the given position relative to the active element.-moveTo :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()-moveTo = noReturn . doSessCommand methodPost "/moveto" . pair ("xoffset","yoffset")---- |Moves the mouse to the center of a given element.-moveToCenter :: (HasCallStack, WebDriver wd) => Element -> wd ()-moveToCenter (Element e) =- noReturn . doSessCommand methodPost "/moveto" . single "element" $ e---- |Moves the mouse to the given position relative to the given element.-moveToFrom :: (HasCallStack, WebDriver wd) => (Int, Int) -> Element -> wd ()-moveToFrom (x,y) (Element e) =- noReturn . doSessCommand methodPost "/moveto"- . triple ("element","xoffset","yoffset") $ (e,x,y)---- |A mouse button-data MouseButton = LeftButton | MiddleButton | RightButton- deriving (Eq, Show, Ord, Bounded, Enum)--instance ToJSON MouseButton where- toJSON = toJSON . fromEnum--instance FromJSON MouseButton where- parseJSON v = do- n <- parseJSON v- case n :: Integer of- 0 -> return LeftButton- 1 -> return MiddleButton- 2 -> return RightButton- err -> fail $ "Invalid JSON for MouseButton: " ++ show err---- |Click at the current mouse position with the given mouse button.-clickWith :: (HasCallStack, WebDriver wd) => MouseButton -> wd ()-clickWith = noReturn . doSessCommand methodPost "/click" . single "button"---- |Perform the given action with the left mouse button held down. The mouse--- is automatically released afterwards.-withMouseDown :: (HasCallStack, WebDriver wd) => wd a -> wd a-withMouseDown wd = mouseDown >> wd <* mouseUp---- |Press and hold the left mouse button down. Note that undefined behavior--- occurs if the next mouse command is not mouseUp.-mouseDown :: (HasCallStack, WebDriver wd) => wd ()-mouseDown = noReturn $ doSessCommand methodPost "/buttondown" Null---- |Release the left mouse button.-mouseUp :: (HasCallStack, WebDriver wd) => wd ()-mouseUp = noReturn $ doSessCommand methodPost "/buttonup" Null---- |Double click at the current mouse location.-doubleClick :: (HasCallStack, WebDriver wd) => wd ()-doubleClick = noReturn $ doSessCommand methodPost "/doubleclick" Null---- |Single tap on the touch screen at the given element's location.-touchClick :: (HasCallStack, WebDriver wd) => Element -> wd ()-touchClick (Element e) =- noReturn . doSessCommand methodPost "/touch/click" . single "element" $ e---- |Emulates pressing a finger down on the screen at the given location.-touchDown :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()-touchDown = noReturn . doSessCommand methodPost "/touch/down" . pair ("x","y")---- |Emulates removing a finger from the screen at the given location.-touchUp :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()-touchUp = noReturn . doSessCommand methodPost "/touch/up" . pair ("x","y")---- |Emulates moving a finger on the screen to the given location.-touchMove :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()-touchMove = noReturn . doSessCommand methodPost "/touch/move" . pair ("x","y")---- |Emulate finger-based touch scroll. Use this function if you don't care where--- the scroll begins-touchScroll :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()-touchScroll = noReturn . doSessCommand methodPost "/touch/scroll" . pair ("xoffset","yoffset")---- |Emulate finger-based touch scroll, starting from the given location relative--- to the given element.-touchScrollFrom :: (HasCallStack, WebDriver wd) => (Int, Int) -> Element -> wd ()-touchScrollFrom (x, y) (Element e) =- noReturn- . doSessCommand methodPost "/touch/scroll"- . triple ("xoffset", "yoffset", "element")- $ (x, y, e)---- |Emulate a double click on a touch device.-touchDoubleClick :: (HasCallStack, WebDriver wd) => Element -> wd ()-touchDoubleClick (Element e) =- noReturn- . doSessCommand methodPost "/touch/doubleclick"- . single "element" $ e---- |Emulate a long click on a touch device.-touchLongClick :: (HasCallStack, WebDriver wd) => Element -> wd ()-touchLongClick (Element e) =- noReturn- . doSessCommand methodPost "/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 :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()-touchFlick =- noReturn- . doSessCommand methodPost "/touch/flick"- . pair ("xSpeed", "ySpeed")---- |Emulate a flick on the touch screen.-touchFlickFrom :: (HasCallStack, 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) =- noReturn- . doSessCommand methodPost "/touch/flick" . object $- ["xoffset" .= x- ,"yoffset" .= y- ,"speed" .= s- ,"element" .= e- ]---- |Get the current geographical location of the device.-getLocation :: (HasCallStack, WebDriver wd) => wd (Int, Int, Int)-getLocation = doSessCommand methodGet "/location" Null- >>= parseTriple "latitude" "longitude" "altitude" "getLocation"---- |Set the current geographical location of the device.-setLocation :: (HasCallStack, WebDriver wd) => (Int, Int, Int) -> wd ()-setLocation = noReturn . doSessCommand methodPost "/location"- . triple ("latitude",- "longitude",- "altitude")---- |Uploads a file from the local filesystem by its file path.-uploadFile :: (HasCallStack, WebDriver wd) => FilePath -> wd ()-uploadFile path = uploadZipEntry =<< liftBase (readEntry [] path)---- |Uploads a raw bytestring with associated file info.-uploadRawFile :: (HasCallStack, WebDriver wd) =>- FilePath -- ^File path to use with this bytestring.- -> Integer -- ^Modification time- -- (in seconds since Unix epoch).- -> LBS.ByteString -- ^ The file contents as a lazy ByteString- -> wd ()-uploadRawFile path t str = uploadZipEntry (toEntry path t str)----- |Lowest level interface to the file uploading mechanism.--- This allows you to specify the exact details of--- the zip entry sent across network.-uploadZipEntry :: (HasCallStack, WebDriver wd) => Entry -> wd ()-uploadZipEntry = noReturn . doSessCommand methodPost "/file" . single "file"- . TL.decodeUtf8 . B64.encode . fromArchive . (`addEntryToArchive` emptyArchive)----- |Get the current number of keys in a web storage area.-storageSize :: (HasCallStack, WebDriver wd) => WebStorageType -> wd Integer-storageSize s = doStorageCommand methodGet s "/size" Null+module Test.WebDriver.Commands (+ -- * Sessions+ -- | A session is equivalent to a single instantiation of a+ -- particular user agent, including all its child browsers. WebDriver gives+ -- each session a unique session ID that can be used to differentiate one+ -- session from another, allowing multiple user agents to be controlled from a+ -- single HTTP server, and allowing sessions to be routed via a multiplexer+ -- (known as an intermediary node).+ --+ -- See https://www.w3.org/TR/webdriver1/#sessions.+ module Test.WebDriver.Commands.Sessions --- |Get a list of all keys from a web storage area.-getAllKeys :: (HasCallStack, WebDriver wd) => WebStorageType -> wd [Text]-getAllKeys s = doStorageCommand methodGet s "" Null+ -- * Navigation+ -- | The commands in this section allow navigation of the current top-level+ -- browsing context to new URLs and introspection of the document currently+ -- loaded in this browsing context.+ --+ -- See https://www.w3.org/TR/webdriver1/#navigation.+ , module Test.WebDriver.Commands.Navigation --- |Delete all keys within a given web storage area.-deleteAllKeys :: (HasCallStack, WebDriver wd) => WebStorageType -> wd ()-deleteAllKeys s = noReturn $ doStorageCommand methodDelete s "" Null+ -- * Command contexts+ -- | Many WebDriver commands happen in the context of either the current+ -- browsing context or current top-level browsing context. The current+ -- top-level browsing context is represented in the protocol by its associated+ -- window handle. When a top-level browsing context is selected using the+ -- Switch To Window command, a specific browsing context can be selected using+ -- the Switch to Frame command.+ --+ -- See https://www.w3.org/TR/webdriver1/#command-contexts.+ , module Test.WebDriver.Commands.CommandContexts --- |An HTML 5 storage type-data WebStorageType = LocalStorage | SessionStorage- deriving (Eq, Show, Ord, Bounded, Enum)+ -- * Element Retrieval+ -- | The Find Element, Find Elements, Find Element From Element, and Find+ -- Elements From Element commands allow lookup of individual elements and+ -- collections of elements. Element retrieval searches are performed using+ -- pre-order traversal of the document’s nodes that match the provided+ -- selector’s expression. Elements are serialized and returned as web+ -- elements.+ --+ -- See https://www.w3.org/TR/webdriver1/#element-retrieval.+ , module Test.WebDriver.Commands.ElementRetrieval --- |Get the value associated with a key in the given web storage area.--- Unset keys result in empty strings, since the Web Storage spec--- makes no distinction between the empty string and an undefined value.-getKey :: (HasCallStack, WebDriver wd) => WebStorageType -> Text -> wd Text-getKey s k = doStorageCommand methodGet s ("/key/" `T.append` urlEncode k) Null+ -- * Element State+ --+ -- See https://www.w3.org/TR/webdriver1/#element-state.+ , module Test.WebDriver.Commands.ElementState --- |Set a key in the given web storage area.-setKey :: (HasCallStack, WebDriver wd) => WebStorageType -> Text -> Text -> wd Text-setKey s k v = doStorageCommand methodPost s "" . object $ ["key" .= k,- "value" .= v ]--- |Delete a key in the given web storage area.-deleteKey :: (HasCallStack, WebDriver wd) => WebStorageType -> Text -> wd ()-deleteKey s k = noReturn $ doStorageCommand methodPost s ("/key/" `T.append` urlEncode k) Null+ -- * Element Interaction+ --+ -- See https://www.w3.org/TR/webdriver1/#element-interaction.+ , module Test.WebDriver.Commands.ElementInteraction --- |A wrapper around 'doSessCommand' to create web storage requests.-doStorageCommand :: (WebDriver wd, ToJSON a, FromJSON b) =>- Method -> WebStorageType -> Text -> a -> wd b-doStorageCommand m s path a = doSessCommand m (T.concat ["/", s', path]) a- where s' = case s of- LocalStorage -> "local_storage"- SessionStorage -> "session_storage"+ -- * Document handling+ --+ -- See https://www.w3.org/TR/webdriver1/#document-handling.+ , module Test.WebDriver.Commands.DocumentHandling+ , ignoreReturn --- |Get information from the server as a JSON 'Object'. For more information--- about this object see--- <https://github.com/SeleniumHQ/selenium/wiki/JsonWireProtocol#status>-serverStatus :: (WebDriver wd) => wd Value -- todo: make this a record type-serverStatus = doCommand methodGet "/status" Null+ -- * Cookies+ --+ -- See https://www.w3.org/TR/webdriver1/#cookies.+ , module Test.WebDriver.Commands.Cookies --- |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- -- time.- , logLevel :: LogLevel -- ^ log verbosity level- , logMsg :: Text- }- deriving (Eq, Ord, Show, Read)+ -- * Actions+ --+ -- See https://www.w3.org/TR/webdriver1/#actions.+ , module Test.WebDriver.Commands.Actions + -- * User Prompts+ --+ -- See https://www.w3.org/TR/webdriver1/#user-prompts.+ , module Test.WebDriver.Commands.UserPrompts -instance FromJSON LogEntry where- parseJSON (Object o) =- LogEntry <$> o .: "timestamp"- <*> o .: "level"- <*> (fromMaybe "" <$> o .: "message")- parseJSON v = typeMismatch "LogEntry" v+ -- * Screen capture+ --+ -- See https://www.w3.org/TR/webdriver1/#screen-capture.+ , module Test.WebDriver.Commands.ScreenCapture -type LogType = String+ -- * Browser logs+ -- | Retrieve browser console logs and other log types.+ , module Test.WebDriver.Commands.Logs --- |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 :: (HasCallStack, WebDriver wd) => LogType -> wd [LogEntry]-getLogs t = doSessCommand methodPost "/log" . object $ ["type" .= t]+ -- * BiDi sessions (experimental)+ -- | Low-level BiDi session establishment.+ , module Test.WebDriver.Commands.BiDi.Session --- |Get a list of available log types.-getLogTypes :: (HasCallStack, WebDriver wd) => wd [LogType]-getLogTypes = doSessCommand methodGet "/log/types" Null+ -- * Network activity (experimental)+ -- | Use BiDi to track network activity events.+ , module Test.WebDriver.Commands.BiDi.NetworkActivity -data ApplicationCacheStatus = Uncached | Idle | Checking | Downloading | UpdateReady | Obsolete deriving (Eq, Enum, Bounded, Ord, Show, Read)+ -- * Selenium-specific+ -- ** Mobile device support+ , module Test.WebDriver.Commands.SeleniumSpecific.Mobile+ -- ** Uploading files to remote server+ -- | These functions allow you to upload a file to a remote server.+ -- Note that this operation isn't supported by all WebDriver servers,+ -- and the location where the file is stored is not standardized.+ , module Test.WebDriver.Commands.SeleniumSpecific.Uploads+ -- ** HTML5+ , module Test.WebDriver.Commands.SeleniumSpecific.HTML5+ -- ** Misc+ , module Test.WebDriver.Commands.SeleniumSpecific.Misc+ ) where -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+import Test.WebDriver.Commands.Actions+import Test.WebDriver.Commands.BiDi.NetworkActivity+import Test.WebDriver.Commands.BiDi.Session+import Test.WebDriver.Commands.CommandContexts+import Test.WebDriver.Commands.Cookies+import Test.WebDriver.Commands.DocumentHandling+import Test.WebDriver.Commands.ElementInteraction+import Test.WebDriver.Commands.ElementRetrieval+import Test.WebDriver.Commands.ElementState+import Test.WebDriver.Commands.Logs+import Test.WebDriver.Commands.Navigation+import Test.WebDriver.Commands.ScreenCapture+import Test.WebDriver.Commands.SeleniumSpecific.HTML5+import Test.WebDriver.Commands.SeleniumSpecific.Misc+import Test.WebDriver.Commands.SeleniumSpecific.Mobile+import Test.WebDriver.Commands.SeleniumSpecific.Uploads+import Test.WebDriver.Commands.Sessions+import Test.WebDriver.Commands.UserPrompts -getApplicationCacheStatus :: (WebDriver wd) => wd ApplicationCacheStatus-getApplicationCacheStatus = doSessCommand methodGet "/application_cache/status" Null+import Test.WebDriver.JSON (ignoreReturn)
+ src/Test/WebDriver/Commands/Actions.hs view
@@ -0,0 +1,182 @@+module Test.WebDriver.Commands.Actions (+ moveTo+ , moveToCenter+ , moveToFrom+ , clickCenter+ , doubleClickCenter++ -- * Lower-level actions API+ , performActions+ , releaseActions+ , Action(..)+ , ActionSource(..)+ , PointerAction(..)+ , KeyAction(..)+ , PointerOrigin(..)++ -- * Types+ , MouseButton(..)+ ) where++import Data.Aeson as A+import GHC.Stack+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands++-- | A mouse button+data MouseButton = LeftButton | MiddleButton | RightButton+ deriving (Eq, Show, Ord, Bounded, Enum)++instance ToJSON MouseButton where+ toJSON = toJSON . fromEnum++instance FromJSON MouseButton where+ parseJSON v = parseJSON v >>= \case+ (0 :: Int) -> return LeftButton+ 1 -> return MiddleButton+ 2 -> return RightButton+ err -> fail $ "Invalid JSON for MouseButton: " ++ show err++-- -----------------------------------------------------------------------------+-- Legacy API (Wire Protocol)+-- -----------------------------------------------------------------------------++movementTimeMs :: Int+movementTimeMs = 50++-- | Moves the mouse to the given position relative to the current pointer position.+moveTo :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()+moveTo (x, y) = performActions [PointerSource "mouse1" [ActionPointer $ PointerMove PointerCurrent x y movementTimeMs]]++-- | Moves the mouse to the center of a given element.+moveToCenter :: (HasCallStack, WebDriver wd) => Element -> wd ()+moveToCenter el = performActions [PointerSource "mouse1" [ActionPointer $ PointerMove (PointerElement el) 0 0 movementTimeMs]]++-- | Moves the mouse to the given position relative to the given element.+moveToFrom :: (HasCallStack, WebDriver wd) => (Int, Int) -> Element -> wd ()+moveToFrom (x, y) el = performActions [PointerSource "mouse1" [ActionPointer $ PointerMove (PointerElement el) x y movementTimeMs]]++-- | Helper to click the center of an element.+clickCenter :: (HasCallStack, WebDriver wd) => Element -> wd ()+clickCenter el = performActions [PointerSource "mouse1" [+ ActionPointer $ PointerMove (PointerElement el) 0 0 movementTimeMs+ , ActionPointer $ PointerDown LeftButton+ , ActionPointer $ PointerUp LeftButton+ ]]++-- | Helper to double click the center of an element.+doubleClickCenter :: (HasCallStack, WebDriver wd) => Element -> wd ()+doubleClickCenter el = performActions [PointerSource "mouse1" [+ ActionPointer $ PointerMove (PointerElement el) 0 0 movementTimeMs+ , ActionPointer $ PointerDown LeftButton+ , ActionPointer $ PointerUp LeftButton+ , ActionPause 100+ , ActionPointer $ PointerDown LeftButton+ , ActionPointer $ PointerUp LeftButton+ ]]++-- -----------------------------------------------------------------------------+-- Modern Actions API+-- -----------------------------------------------------------------------------++-- | Origin for pointer actions+data PointerOrigin+ = PointerViewport+ | PointerCurrent+ | PointerElement Element+ deriving (Eq, Show)++-- | Individual pointer actions+data PointerAction+ = PointerMove { moveOrigin :: PointerOrigin, moveX :: Int, moveY :: Int, moveDuration :: Int }+ | PointerDown { downButton :: MouseButton }+ | PointerUp { upButton :: MouseButton }+ | PointerCancel+ deriving (Eq, Show)++-- | Individual key actions+data KeyAction+ = KeyDown { keyValue :: String }+ | KeyUp { keyValue :: String }+ deriving (Eq, Show)++-- | Generic action that can be pause, pointer, or key+data Action+ = ActionPause { pauseDuration :: Int }+ | ActionPointer { pointerAction :: PointerAction }+ | ActionKey { keyAction :: KeyAction }+ deriving (Eq, Show)++-- | Action source (input device)+data ActionSource+ = PointerSource { sourceId :: String, actions :: [Action] }+ | KeySource { sourceId :: String, actions :: [Action] }+ deriving (Eq, Show)++-- | Perform a sequence of actions from multiple input sources+performActions :: (HasCallStack, WebDriver wd) => [ActionSource] -> wd ()+performActions sources = noReturn $ doSessCommand methodPost "/actions"+ (A.object ["actions" A..= map sourceToJSON sources])++-- | Release all currently pressed keys and buttons+releaseActions :: (HasCallStack, WebDriver wd) => wd ()+releaseActions = noReturn $ doSessCommand methodDelete "/actions" noObject++-- -----------------------------------------------------------------------------+-- Internal helpers+-- -----------------------------------------------------------------------------++sourceToJSON :: ActionSource -> A.Value+sourceToJSON (PointerSource sid acts) = A.object [+ "type" A..= ("pointer" :: String)+ , "id" A..= sid+ , "actions" A..= map actionToJSON acts+ ]+sourceToJSON (KeySource sid acts) = A.object [+ "type" A..= ("key" :: String)+ , "id" A..= sid+ , "actions" A..= map actionToJSON acts+ ]++actionToJSON :: Action -> A.Value+actionToJSON (ActionPause dur) = A.object [+ "type" A..= ("pause" :: String)+ , "duration" A..= dur+ ]+actionToJSON (ActionPointer pact) = pointerActionToJSON pact+actionToJSON (ActionKey kact) = keyActionToJSON kact++pointerActionToJSON :: PointerAction -> A.Value+pointerActionToJSON (PointerMove orig x y dur) = A.object ([+ "type" A..= ("pointerMove" :: String)+ , "duration" A..= dur+ , "x" A..= x+ , "y" A..= y+ ] <> originToJSON orig)+ where+ originToJSON :: PointerOrigin -> [(Key, A.Value)]+ originToJSON PointerViewport = [("origin", A.String "viewport")]+ originToJSON PointerCurrent = [("origin", A.String "pointer")]+ originToJSON (PointerElement (Element e)) = [("origin", A.object ["element-6066-11e4-a52e-4f735466cecf" A..= e])]+pointerActionToJSON (PointerDown btn) = A.object [+ "type" A..= ("pointerDown" :: String)+ , "button" A..= btn+ ]+pointerActionToJSON (PointerUp btn) = A.object [+ "type" A..= ("pointerUp" :: String)+ , "button" A..= btn+ ]+pointerActionToJSON PointerCancel = A.object [+ "type" A..= ("pointerCancel" :: String)+ ]++keyActionToJSON :: KeyAction -> A.Value+keyActionToJSON (KeyDown val) = A.object [+ "type" A..= ("keyDown" :: String)+ , "value" A..= val+ ]+keyActionToJSON (KeyUp val) = A.object [+ "type" A..= ("keyUp" :: String)+ , "value" A..= val+ ]
+ src/Test/WebDriver/Commands/BiDi/NetworkActivity.hs view
@@ -0,0 +1,312 @@+{-# LANGUAGE StrictData #-}+{-# LANGUAGE MultiWayIf #-}++module Test.WebDriver.Commands.BiDi.NetworkActivity (+ withRecordNetworkActivityViaBiDi+ , withRecordNetworkActivityViaBiDi'++ , readNetworkActivity+ , waitForNetworkIdle+ , waitForNetworkIdleForPeriod+ , withWaitForNetworkIdleForPeriod++ -- * Types+ , RequestInfo+ , requestInfoRequestId+ , requestInfoMethod+ , requestInfoUrl+ , requestInfoTimestamp+ , requestInfoRequestHeaders+ , requestInfoResponseHeaders+ , requestInfoResponseText+ , requestInfoErrorText+ , requestInfoCompleted+ , RequestId+ ) where++import Control.Applicative ((<|>))+import Control.Concurrent.STM (retry)+import Control.Monad (unless)+import Control.Monad.IO.Unlift+import Control.Monad.Logger (MonadLogger, logDebugN, logWarnN)+import Data.Aeson+import Data.Aeson.Types (parseEither, Parser)+import Data.Foldable (toList)+import Data.Map (Map)+import qualified Data.Map as M+import Data.String.Interpolate+import Data.Text (Text)+import Data.Time+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import qualified Network.URI as URI+import Test.WebDriver.Commands.BiDi.Session+import Test.WebDriver.Types+import UnliftIO.Concurrent+import UnliftIO.STM+++networkEvents :: [Text]+networkEvents = [+ "network.beforeRequestSent"+ , "network.responseCompleted"+ , "network.responseStarted"+ , "network.fetchError"+ ]++type RequestId = Text++data RequestInfo = RequestInfo {+ requestInfoRequestId :: RequestId+ , requestInfoMethod :: Text+ , requestInfoUrl :: Text+ , requestInfoTimestamp :: UTCTime+ , requestInfoRequestHeaders :: Maybe (Map Text Text)+ , requestInfoResponseHeaders :: Maybe (Map Text Text)+ , requestInfoResponseStatus :: Maybe Int+ , requestInfoResponseText :: Maybe Text+ , requestInfoErrorText :: Maybe Text+ , requestInfoCompleted :: Bool+ } deriving (Show, Eq)++data NetworkActivity = NetworkActivity {+ networkActivityRequests :: Map RequestId RequestInfo+ , networkActivityLastActivityTime :: UTCTime+ } deriving (Eq)++type NetworkActivityVar = TVar NetworkActivity++-- | Wrapper around 'withRecordNetworkActivityViaBiDi'' which uses the WebSocket URL from+-- the current 'Session'. You must make sure to pass '_capabilitiesWebSocketUrl'+-- = @Just True@ to enable this. This will not work with Selenium 3.+withRecordNetworkActivityViaBiDi :: (WebDriver m, MonadLogger m) => BiDiOptions -> (NetworkActivityVar -> m a) -> m a+withRecordNetworkActivityViaBiDi biDiOptions action = do+ networkActivityVar <- newNetworkActivityVar+ withBiDiSession biDiOptions networkEvents (mkCallback networkActivityVar) (action networkActivityVar)++-- | Connect to WebSocket URL and subscribe to network events using the W3C BiDi protocol; see+-- <https://w3c.github.io/webdriver-bidi/>.+withRecordNetworkActivityViaBiDi' :: forall m a. (MonadUnliftIO m, MonadLogger m) => BiDiOptions -> Int -> URI.URI -> (NetworkActivityVar -> m a) -> m a+withRecordNetworkActivityViaBiDi' biDiOptions bidiSessionId uri action = do+ networkActivityVar <- newNetworkActivityVar+ withBiDiSession' biDiOptions bidiSessionId uri networkEvents (mkCallback networkActivityVar) (action networkActivityVar)++mkCallback :: (MonadIO m, MonadLogger m) => NetworkActivityVar -> BiDiEvent -> m ()+mkCallback nav (BiDiEvent "event" "network.beforeRequestSent" params) = do+ case parseBeforeRequestSent params of+ Just (requestId, method, url, timestamp, headers) -> do+ now <- liftIO getCurrentTime+ atomically $ modifyTVar nav $ \na -> na {+ networkActivityRequests = M.insert requestId (RequestInfo {+ requestInfoRequestId = requestId+ , requestInfoMethod = method+ , requestInfoUrl = url+ , requestInfoTimestamp = timestamp+ , requestInfoRequestHeaders = headers+ , requestInfoResponseHeaders = Nothing+ , requestInfoResponseStatus = Nothing+ , requestInfoResponseText = Nothing+ , requestInfoErrorText = Nothing+ , requestInfoCompleted = False+ }) (networkActivityRequests na)+ , networkActivityLastActivityTime = now+ }+ logDebugN [i|BiDi: Network request started: #{requestId} #{method} #{url}|]+ Nothing -> logWarnN "BiDi: Failed to parse network.beforeRequestSent event"++mkCallback nav (BiDiEvent "event" "network.responseStarted" params) = do+ case parseResponseStarted params of+ Just (requestId, status, headers) -> do+ now <- liftIO getCurrentTime+ maybeRequestInfo <- atomically $ do+ na <- readTVar nav++ let (ret, requests') = adjustAndReturnNew requestId (networkActivityRequests na) $ \ri -> ri {+ requestInfoResponseStatus = Just status+ , requestInfoResponseHeaders = headers+ }++ modifyTVar nav $ \na' -> na' {+ networkActivityRequests = requests'+ , networkActivityLastActivityTime = now+ }++ return ret+ logDebugN [i|BiDi: Network response started: #{requestId} status #{status} (#{maybe "<unknown>" requestInfoUrl maybeRequestInfo})|]+ Nothing -> logWarnN "BiDi: Failed to parse network.responseStarted event"++mkCallback nav (BiDiEvent "event" "network.responseCompleted" params) = do+ case parseResponseCompleted params of+ Just (requestId, responseText) -> do+ now <- liftIO getCurrentTime+ maybeRequestInfo <- atomically $ do+ na <- readTVar nav++ let (ret, requests') = adjustAndReturnNew requestId (networkActivityRequests na) $ \ri -> ri {+ requestInfoResponseText = responseText+ , requestInfoCompleted = True+ }++ modifyTVar nav $ \na' -> na' {+ networkActivityRequests = requests'+ , networkActivityLastActivityTime = now+ }++ return ret++ logDebugN [i|BiDi: Network response completed: #{requestId} (#{maybe "<unknown>" requestInfoUrl maybeRequestInfo})|]+ Nothing -> logWarnN "BiDi: Failed to parse network.responseCompleted event"++mkCallback nav (BiDiEvent "event" "network.fetchError" params) = do+ case parseFetchError params of+ Just (requestId, errorText) -> do+ now <- liftIO getCurrentTime+ maybeRequestInfo <- atomically $ do+ na <- readTVar nav++ let (ret, requests') = adjustAndReturnNew requestId (networkActivityRequests na) $ \ri -> ri {+ requestInfoErrorText = Just errorText+ , requestInfoCompleted = True+ }++ modifyTVar nav $ \na' -> na' {+ networkActivityRequests = requests'+ , networkActivityLastActivityTime = now+ }++ return ret++ logDebugN [i|BiDi: Network fetch error: #{requestId} - #{errorText} (#{maybe "<unknown>" requestInfoUrl maybeRequestInfo})|]+ Nothing -> logWarnN "BiDi: Failed to parse network.fetchError event"++mkCallback _nav x = logDebugN [i|BiDi: Ignoring event: #{x}|]++parseBeforeRequestSent :: Value -> Maybe (RequestId, Text, Text, UTCTime, Maybe (Map Text Text))+parseBeforeRequestSent (Object o) = case parseEither parseRequest o of+ Right result -> Just result+ Left _ -> Nothing+ where+ parseRequest o' = do+ request <- o' .: "request"+ requestId <- request .: "request" -- The requestId is in request.request+ method <- request .: "method"+ url <- request .: "url"+ timestamp <- o' .: "timestamp" :: Parser Integer+ headers <- optional (request .: "headers") >>= \case+ Just headerList -> Just <$> parseHeaders headerList+ Nothing -> pure Nothing+ let utcTime = posixSecondsToUTCTime (realToFrac timestamp / 1000)+ pure (requestId, method, url, utcTime, headers)+parseBeforeRequestSent _ = Nothing++parseResponseStarted :: Value -> Maybe (RequestId, Int, Maybe (Map Text Text))+parseResponseStarted (Object o) = case parseEither parseResponse o of+ Right result -> Just result+ Left _ -> Nothing+ where+ parseResponse o' = do+ request <- o' .: "request"+ requestId <- request .: "request" -- The requestId is in request.request+ response <- o' .: "response"+ status <- response .: "status"+ headers <- optional (response .: "headers") >>= \case+ Just headerList -> Just <$> parseHeaders headerList+ Nothing -> pure Nothing+ pure (requestId, status, headers)+parseResponseStarted _ = Nothing++parseResponseCompleted :: Value -> Maybe (RequestId, Maybe Text)+parseResponseCompleted (Object o) = case parseEither parseResponse o of+ Right result -> Just result+ Left _ -> Nothing+ where+ parseResponse o' = do+ request <- o' .: "request"+ requestId <- request .: "request" -- The requestId is in request.request+ responseText <- optional (o' .: "response" >>= (.: "body") >>= (.: "value"))+ pure (requestId, responseText)+parseResponseCompleted _ = Nothing++parseFetchError :: Value -> Maybe (RequestId, Text)+parseFetchError (Object o) = case parseEither parseError o of+ Right result -> Just result+ Left _ -> Nothing+ where+ parseError o' = do+ request <- o' .: "request"+ requestId <- request .: "request" -- The requestId is in request.request+ errorText <- o' .: "errorText"+ pure (requestId, errorText)+parseFetchError _ = Nothing++parseHeaders :: Value -> Parser (Map Text Text)+parseHeaders (Array headers) = do+ headerPairs <- mapM parseHeader (toList headers)+ pure $ M.fromList headerPairs+ where+ parseHeader (Object h) = do+ name <- h .: "name"+ valueObj <- h .: "value"+ value <- case valueObj of+ Object vo -> vo .: "value" -- Extract value from {type: "string", value: "..."}+ String s -> pure s -- Fallback for direct string values+ _ -> fail "Invalid header value format"+ pure (name, value)+ parseHeader _ = fail "Invalid header format"+parseHeaders _ = fail "Headers should be an array"++optional :: Parser a -> Parser (Maybe a)+optional p = (Just <$> p) <|> pure Nothing++newNetworkActivityVar :: MonadIO m => m NetworkActivityVar+newNetworkActivityVar = do+ now <- liftIO getCurrentTime+ newTVarIO $ NetworkActivity M.empty now++-- | Read the current network activity map.+readNetworkActivity :: MonadIO m => NetworkActivityVar -> m (Map RequestId RequestInfo)+readNetworkActivity nav = networkActivityRequests <$> readTVarIO nav++-- | Wait for network to be idle (no pending requests).+waitForNetworkIdle :: MonadIO m => NetworkActivityVar -> m ()+waitForNetworkIdle nav = atomically $ do+ na <- readTVar nav+ let pending = filter (not . requestInfoCompleted) (M.elems (networkActivityRequests na))+ unless (null pending) retry++-- | Wait for network to be idle with a delay after the last activity+-- This waits until:+--+-- 1. There are no outstanding requests AND+-- 2. No request has started or finished in the last time period given by the 'NominalDiffTime'.+waitForNetworkIdleForPeriod :: MonadIO m => NetworkActivityVar -> NominalDiffTime -> m ()+waitForNetworkIdleForPeriod nav idleTime = do+ lastActivityTime <- atomically $ do+ na <- readTVar nav+ let pending = filter (not . requestInfoCompleted) (M.elems (networkActivityRequests na))+ unless (null pending) retry++ return (networkActivityLastActivityTime na)++ now <- liftIO getCurrentTime+ let timeSinceLastActivity = diffUTCTime now lastActivityTime+ if | timeSinceLastActivity >= idleTime ->+ return ()+ | otherwise -> do+ threadDelay $ nominalDiffTimeToMicroseconds (idleTime - timeSinceLastActivity)+ waitForNetworkIdleForPeriod nav idleTime+ where+ nominalDiffTimeToMicroseconds :: NominalDiffTime -> Int+ nominalDiffTimeToMicroseconds t = round (t * 1000000)++withWaitForNetworkIdleForPeriod :: (WebDriver m, MonadLogger m) => BiDiOptions -> NominalDiffTime -> m a -> m a+withWaitForNetworkIdleForPeriod biDiOptions dt action = do+ withRecordNetworkActivityViaBiDi biDiOptions $ \nav -> do+ ret <- action+ waitForNetworkIdleForPeriod nav dt+ return ret++adjustAndReturnNew :: Ord k => k -> M.Map k a -> (a -> a) -> (Maybe a, M.Map k a)+adjustAndReturnNew k m f = M.alterF alter k m+ where+ alter Nothing = (Nothing, Nothing)+ alter (Just v) = let v' = f v in (Just v', Just v')
+ src/Test/WebDriver/Commands/BiDi/Session.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}++module Test.WebDriver.Commands.BiDi.Session (+ withBiDiSession+ , withBiDiSession'++ , BiDiEvent(..)+ , BiDiResponse(..)++ , BiDiOptions(..)+ , defaultBiDiOptions+ ) where++import Control.Monad (forever)+import Control.Monad.Fix (fix)+import Control.Monad.IO.Unlift+import Control.Monad.Logger (MonadLogger, logDebugN, logErrorN)+import Data.Aeson+import Data.Aeson.TH+import qualified Data.List as L+import Data.String.Interpolate+import Data.Text (Text)+import qualified Network.URI as URI+import qualified Network.WebSockets as WS+import Test.WebDriver.Capabilities.Aeson+import Test.WebDriver.Types+import Text.Read (readMaybe)+import UnliftIO.Async (withAsync)+import UnliftIO.Exception+import UnliftIO.STM (atomically, stateTVar)+import UnliftIO.Timeout (timeout)+++data BiDiEvent = BiDiEvent {+ biDiType :: Text+ , biDiMethod :: Text+ , biDiParams :: Value+ } deriving Show+deriveFromJSON toCamel2 ''BiDiEvent++data BiDiResponse = BiDiResponse {+ biDiResponseType :: Text+ , biDiResponseId :: Int+ , biDiResponseResult :: Maybe Value+ , biDiResponseError :: Maybe Value+ } deriving Show+deriveFromJSON toCamel3 ''BiDiResponse++-- | Options controlling BiDi session establishment.+data BiDiOptions = BiDiOptions {+ biDiSubscriptionRequestTimeoutUs :: Int+ }+-- | Default BiDi options.+defaultBiDiOptions :: BiDiOptions+defaultBiDiOptions = BiDiOptions {+ biDiSubscriptionRequestTimeoutUs = 15_000_000+ }++-- | Wrapper around 'withBiDiSession'' which uses the WebSocket URL from+-- the current 'Session'. You must make sure to pass '_capabilitiesWebSocketUrl'+-- = @Just True@ to enable this. This will not work with Selenium 3.+withBiDiSession :: (WebDriver m, MonadLogger m) => BiDiOptions -> [Text] -> (BiDiEvent -> m ()) -> m a -> m a+withBiDiSession biDiOptions events cb action = do+ Session {..} <- getSession+ webSocketUrl <- case sessionWebSocketUrl of+ Nothing -> throwIO $ userError [i|Session wasn't configured with a BiDi WebSocket URL when trying to record logs. Make sure to enable _capabilitiesWebSocketUrl.|]+ Just x -> pure x++ uri <- case URI.parseURI webSocketUrl of+ Just x -> pure x+ Nothing -> throwIO $ userError [i|Couldn't parse WebSocket URL: #{webSocketUrl}|]++ bidiSessionId <- atomically $ stateTVar sessionIdCounter (\x -> (x, x + 1))++ withBiDiSession' biDiOptions bidiSessionId uri events cb action++-- | Connect to WebSocket URL and subscribe to the given events using the W3C BiDi protocol; see+-- <https://w3c.github.io/webdriver-bidi/>.+withBiDiSession' :: (MonadUnliftIO m, MonadLogger m) => BiDiOptions -> Int -> URI.URI -> [Text] -> (BiDiEvent -> m ()) -> m a -> m a+withBiDiSession' biDiOptions bidiSessionId uri@(URI.URI { uriAuthority=(Just (URI.URIAuth {uriPort=(readMaybe . L.drop 1 -> Just (port :: Int)), ..})), .. }) events cb action = do+ logDebugN [i|BiDi: Connecting to #{uriRegName}:#{port}#{uriPath}|]++ withRunInIO $ \runInIO -> liftIO $ WS.runClient uriRegName port uriPath $ \conn -> runInIO $ do+ logDebugN [i|BiDi: Connected successfully, sending subscription request with ID #{bidiSessionId}|]+ liftIO $ WS.sendTextData conn $ encode $ object [+ "id" .= bidiSessionId+ , "method" .= ("session.subscribe" :: Text)+ , "params" .= object [+ "events" .= (events :: [Text])+ ]+ ]++ logDebugN "BiDi: Sent subscription request, waiting for response..."+ timeout (biDiSubscriptionRequestTimeoutUs biDiOptions) (waitForSubscriptionResult bidiSessionId conn) >>= \case+ Nothing -> throwIO $ userError "BiDi: Subscription response timed out"+ Just (Left err) ->+ throwIO $ userError [i|BiDi: got exception (URI #{uri}): #{err}|]+ Just (Right ()) -> do+ logDebugN "BiDi: Starting log event listener"+ withAsync (messageListener conn) $ \_messageListenerAsy -> do+ finally action $ do+ logDebugN [i|BiDi: finished wrapped action|]+ liftIO $ WS.sendClose conn ([i|Finishing session #{bidiSessionId}|] :: Text)+ where+ messageListener conn =+ forever $+ (decode <$>) (liftIO $ WS.receiveData conn) >>= \case+ Just (x :: BiDiEvent) -> cb x+ x -> logDebugN [i|BiDi: Ignoring non-log event message: #{x}|]+withBiDiSession' _ _ uri _events _cb _action =+ throwIO $ userError [i|WebSocket URL didn't contain an authority: #{uri}|]+++waitForSubscriptionResult :: (+ MonadIO m, MonadLogger m+ ) => Int -> WS.Connection -> m (Either SomeException ())+waitForSubscriptionResult bidiSessionId conn = fix $ \loop -> do+ msg <- liftIO $ WS.receiveData conn+ logDebugN [i|BiDi: Waiting for subscription response: #{msg}|]+ case decode msg of+ Just response@(BiDiResponse responseType responseId _ _)+ | responseType == "success" && responseId == bidiSessionId -> do+ logDebugN "BiDi: Subscription successful!"+ return $ Right ()+ | responseType == "error" && responseId == bidiSessionId -> do+ let errMsg = "BiDi subscription failed: " ++ show response+ logErrorN [i|BiDi: #{errMsg}|]+ return $ Left (toException (userError errMsg))+ | otherwise -> do+ logDebugN [i|BiDi: Ignoring response with type #{responseType}, ID #{responseId}|]+ loop+ Nothing -> do+ logDebugN [i|BiDi: Not a BiDiResponse, continuing to wait for subscription response (#{msg})|]+ loop++-- * Better WebSocket ping/pong+-- | I've run into problems with the ping/pong support in the websockets+-- library, so I came up with this alternative version that I use in my+-- websockets projects.+--+-- But, according to some searching, it seems that the BiDi client doesn't need+-- to do ping/pong, as we can count on the browser driver to do it. So leaving+-- this unused for now. It might still be useful to use at some point to catch+-- dead drivers etc.++-- data BetterPongTimeout =+-- BetterPongTimeoutUnexpectedResponse BL.ByteString+-- | BetterPongTimeoutNoResponse+-- deriving Show+-- instance Exception BetterPongTimeout++-- data PingPongOptions = PingPongOptions {+-- pingInterval :: Int -- ^ Interval in seconds+-- , pongTimeout :: Int -- ^ Timeout in seconds+-- , pingAction :: Int -> IO () -- ^ Action to perform after sending a ping+-- , pingMessage :: Text -> IO () -- ^ Message to log+-- }+-- defaultPingPongOptions :: PingPongOptions+-- defaultPingPongOptions = PingPongOptions {+-- pingInterval = 15+-- , pongTimeout = 30+-- , pingAction = const $ return ()+-- , pingMessage = const $ return ()+-- }++-- withBetterPingPong :: MonadUnliftIO m => PingPongOptions -> WS.Connection -> (WS.Connection -> m ()) -> m ()+-- withBetterPingPong (PingPongOptions {..}) connection app = void $+-- withAsync (app connection) $ \appAsync -> do+-- withAsync (liftIO pingPongThread) $ \pingAsync -> do+-- waitAnyCancel [appAsync, pingAsync]+-- where+-- pingPongThread = do+-- -- Make sure the heartbeat MVar is empty+-- _ <- tryTakeMVar (WS.connectionHeartbeat connection)++-- flip withException reportPingPongException $ flip fix (0 :: Int) $ \loop n -> do+-- let bytes :: BL.ByteString = Builder.toLazyByteString $ Builder.int64BE $ fromIntegral n++-- WS.sendPing connection bytes++-- timeout (pongTimeout * 1000 * 1000) (takeMVar (WS.connectionHeartbeat connection)) >>= \case+-- Just _ -> return ()+-- Nothing -> throwIO $ BetterPongTimeoutNoResponse++-- threadDelay (pongTimeout * 1000 * 1000)+-- loop (n + 1)++-- reportPingPongException :: SomeException -> IO ()+-- reportPingPongException (fromException -> Just (AsyncCancelled {})) = return ()+-- reportPingPongException e = pingMessage [i|Ping pong thread had exception: #{e}|]
+ src/Test/WebDriver/Commands/CommandContexts.hs view
@@ -0,0 +1,120 @@++module Test.WebDriver.Commands.CommandContexts (+ getCurrentWindow+ , closeWindow+ , focusWindow+ , windows+ , focusFrame+ , focusParentFrame++ -- * Resizing and positioning windows+ , getWindowRect+ , setWindowRect+ , maximize+ , minimize+ , fullscreen++ -- * Types+ , FrameSelector(..)+ , Rect(..)+ , WindowHandle(..)+ ) where++import Control.Monad+import Data.Aeson as A+import Data.Aeson.Types+import Data.Text (Text)+import GHC.Stack+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Returns a handle to the currently focused window+getCurrentWindow :: (HasCallStack, WebDriver wd) => wd WindowHandle+getCurrentWindow = doSessCommand methodGet "/window" Null++-- | Closes the given window+closeWindow :: (HasCallStack, WebDriver wd) => WindowHandle -> wd ()+closeWindow w = do+ cw <- getCurrentWindow+ focusWindow w+ ignoreReturn $ doSessCommand methodDelete "/window" Null+ unless (w == cw) $ focusWindow cw++-- | Switch to a given window+focusWindow :: (HasCallStack, WebDriver wd) => WindowHandle -> wd ()+focusWindow w = noReturn $ doSessCommand methodPost "/window" . single "handle" $ w++-- | Returns a list of all windows available to the session+windows :: (HasCallStack, WebDriver wd) => wd [WindowHandle]+windows = doSessCommand methodGet "/window/handles" Null++-- | Switch focus to the frame specified by the FrameSelector.+focusFrame :: (HasCallStack, WebDriver wd) => FrameSelector -> wd ()+focusFrame s = noReturn $ doSessCommand methodPost "/frame" . single "id" $ s++-- | Switch focus to the frame specified by the FrameSelector.+focusParentFrame :: (HasCallStack, WebDriver wd) => wd ()+focusParentFrame = ignoreReturn $ doSessCommand methodPost "/frame/parent" (A.object [])++-- | Get the dimensions of the current window.+getWindowRect :: (HasCallStack, WebDriver wd) => wd Rect+getWindowRect = doSessCommand methodGet "/window/rect" Null++-- | Set the dimensions of the current window.+setWindowRect :: (HasCallStack, WebDriver wd) => Rect -> wd ()+setWindowRect = ignoreReturn . doSessCommand methodPost "/window/rect"++-- | Maximizes the current window+maximize :: (HasCallStack, WebDriver wd) => wd ()+maximize = ignoreReturn $ doSessCommand methodPost "/window/maximize" (A.object [])++-- | Minimizes the current window+minimize :: (HasCallStack, WebDriver wd) => wd ()+minimize = ignoreReturn $ doSessCommand methodPost "/window/minimize" (A.object [])++-- | Fullscreens the current window+fullscreen :: (HasCallStack, WebDriver wd) => wd ()+fullscreen = ignoreReturn $ doSessCommand methodPost "/window/fullscreen" (A.object [])+++-- | Specifies the frame used by 'Test.WebDriver.Commands.focusFrame'+data FrameSelector =+ WithIndex Integer+ -- | Focus on a frame by name or ID+ | WithName Text+ -- | Focus on a frame 'Element'+ | WithElement Element+ -- | Focus on the first frame, or the main document if iframes are used.+ | DefaultFrame+ deriving (Eq, Show, Read)++instance ToJSON FrameSelector where+ toJSON s = case s of+ WithIndex i -> toJSON i+ WithName n -> toJSON n+ WithElement e -> toJSON e+ DefaultFrame -> Null++data Rect = Rect {+ rectX :: Float+ , rectY :: Float+ , rectWidth :: Float+ , rectHeight :: Float+ } deriving (Eq, Ord, Show)++instance FromJSON Rect where+ parseJSON (Object o) = Rect <$> o .: "x"+ <*> o .: "y"+ <*> o .: "width"+ <*> o .: "height"+ parseJSON j = typeMismatch "Rect" j++instance ToJSON Rect where+ toJSON (Rect x y width height)+ = object [ "x" .= x+ , "y" .= y+ , "width" .= width+ , "height" .= height+ ]
+ src/Test/WebDriver/Commands/Cookies.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE DeriveGeneric #-}++module Test.WebDriver.Commands.Cookies (+ cookies+ , cookie+ , setCookie+ , deleteCookie+ , deleteCookies++ -- * Types+ , mkCookie+ , Cookie(..)+ ) where++import Data.Aeson as A+import Data.Aeson.Types+import qualified Data.Char as C+import Data.Text (Text)+import GHC.Generics+import GHC.Stack+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Retrieve all cookies.+cookies :: (HasCallStack, WebDriver wd) => wd [Cookie]+cookies = doSessCommand methodGet "/cookie" Null++-- | Retrieve a specific cookie by name.+cookie :: (HasCallStack, WebDriver wd) => Text -> wd Cookie+cookie n = doSessCommand methodGet ("/cookie/" <> n) Null++-- | Set a cookie. If the cookie path is not specified, it will default to \"/\".+-- Likewise, if the domain is omitted, it will default to the current page's domain.+setCookie :: (HasCallStack, WebDriver wd) => Cookie -> wd ()+setCookie = noReturn . doSessCommand methodPost "/cookie" . single "cookie"++-- | Delete a cookie by name.+deleteCookie :: (HasCallStack, WebDriver wd) => Text -> wd ()+deleteCookie n = noReturn $ doSessCommand methodDelete ("/cookie/" <> urlEncode n) Null++-- | Delete all visible cookies on the current page.+deleteCookies :: (HasCallStack, WebDriver wd) => wd ()+deleteCookies = noReturn $ doSessCommand methodDelete "/cookie" Null++-- * Types++-- | Cookies are delicious delicacies. When sending cookies to the server, a value+-- of Nothing indicates that the server should use a default value. When receiving+-- cookies from the server, a value of Nothing indicates that the server is unable+-- to specify the value.+data Cookie = Cookie {+ cookName :: Text+ , cookValue :: Text+ -- | Path of this cookie. If Nothing, defaults to /+ , cookPath :: Maybe Text+ -- | Domain of this cookie. If Nothing, the current page's domain is used.+ , cookDomain :: Maybe Text+ -- | Is this cookie secure?+ , cookSecure :: Maybe Bool+ -- | Expiry date expressed as seconds since the Unix epoch.+ -- 'Nothing' indicates that the cookie never expires.+ , cookExpiry :: Maybe Double+ } deriving (Eq, Show, Generic)++aesonOptionsCookie :: Options+aesonOptionsCookie = defaultOptions {+ omitNothingFields = True+ , fieldLabelModifier = map C.toLower . drop 4+ }++-- | Creates a Cookie with only a name and value specified. All other+-- fields are set to Nothing, which tells the server to use default values.+mkCookie :: Text -> Text -> Cookie+mkCookie name value = Cookie {+ cookName = name+ , cookValue = value+ , cookPath = Nothing+ , cookDomain = Nothing+ , cookSecure = Nothing+ , cookExpiry = Nothing+ }++instance ToJSON Cookie where+ toJSON = genericToJSON aesonOptionsCookie+ toEncoding = genericToEncoding aesonOptionsCookie+instance FromJSON Cookie where+ parseJSON (Object o) = Cookie <$> req "name"+ <*> req "value"+ <*> opt "path" Nothing+ <*> opt "domain" Nothing+ <*> opt "secure" Nothing+ <*> opt "expiry" Nothing+ where+ req :: FromJSON a => Text -> Parser a+ req = (o .:) . aesonKeyFromText+ opt :: FromJSON a => Text -> a -> Parser a+ opt k d = o .:?? k .!= d+ parseJSON v = typeMismatch "Cookie" v
+ src/Test/WebDriver/Commands/DocumentHandling.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE ExistentialQuantification #-}++module Test.WebDriver.Commands.DocumentHandling (+ getSource+ , executeJS+ , asyncJS+ , JSArg(..)+ ) where++import Data.Aeson as A+import qualified Data.Foldable as F+import qualified Data.List as L+import Data.Text (Text)+import GHC.Stack+import Test.WebDriver.Exceptions+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+import UnliftIO.Exception (handle, throwIO)+++-- | Get the current page source+getSource :: (HasCallStack, WebDriver wd) => wd Text+getSource = doSessCommand methodGet "/source" Null++{- | Inject a snippet of Javascript into the page for execution in the+context of the currently selected frame. The executed script is+assumed to be synchronous and the result of evaluating the script is+returned and converted to an instance of FromJSON.++The first parameter defines a sequence of arguments to pass to the javascript+function. Arguments of type Element will be converted to the+corresponding DOM element. Likewise, any elements in the script result+will be returned to the client as Elements.++The second parameter defines the script itself in the form of a+function body. The value returned by that function will be returned to+the client. The function will be invoked with the provided argument+list and the values may be accessed via the arguments object in the+order specified.++When using 'executeJS', GHC might complain about an ambiguous type in+situations where the result of the executeJS call is ignored/discard.+Consider the following example:++@+ jsExample = do+ e <- findElem (ByCSS "#foo")+ executeJS [] "someAction()"+ return e+@++Because the result of the 'executeJS' is discarded, GHC cannot resolve+which instance of the 'fromJSON' class to use when parsing the+Selenium server response. In such cases, we can use the 'ignoreReturn'+helper function located in "Test.WebDriver.JSON". 'ignoreReturn' has+no runtime effect; it simply helps the type system by expicitly providing+a `fromJSON` instance to use.++@+ import Test.WebDriver.JSON (ignoreReturn)+ jsExample = do+ e <- findElem (ByCSS "#foo")+ ignoreReturn $ executeJS [] "someAction()"+ return e+@+-}+executeJS :: (HasCallStack, F.Foldable f, FromJSON a, WebDriver wd) => f JSArg -> Text -> wd a+executeJS a s = do+ (doSessCommand methodPost "/execute/sync" . pair ("args", "script") $ (F.toList a,s))+ >>= fromJSON'++-- | Executes a snippet of Javascript code asynchronously. This function works+-- similarly to 'executeJS', except that the Javascript is passed a callback+-- function as its final argument. The script should call this function+-- to signal that it has finished executing, passing to it a value that will be+-- returned as the result of asyncJS. A result of Nothing indicates that the+-- Javascript function timed out (see 'setScriptTimeout')+asyncJS :: (HasCallStack, F.Foldable f, FromJSON a, WebDriver wd) => f JSArg -> Text -> wd (Maybe a)+asyncJS a s = handle timeout $ do+ Just <$> (fromJSON' =<< getResult "/execute/async")++ where+ getResult endpoint = doSessCommand methodPost endpoint . pair ("args", "script") $ (F.toList a,s)++ timeout (FailedCommand {rspError})+ | rspError `L.elem` [Timeout, ScriptTimeout] = return Nothing+ timeout err = throwIO err++-- | An existential wrapper for any 'ToJSON' instance. This allows us to pass+-- parameters of many different types to Javascript code.+data JSArg = forall a. ToJSON a => JSArg a++instance ToJSON JSArg where+ toJSON (JSArg a) = toJSON a
+ src/Test/WebDriver/Commands/ElementInteraction.hs view
@@ -0,0 +1,33 @@++module Test.WebDriver.Commands.ElementInteraction (+ click+ , clearInput+ , sendKeys+ -- , sendRawKeys+ ) where++import Data.Text (Text)+import GHC.Stack+import Test.WebDriver.JSON (noObject, noReturn, single)+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Click on an element.+click :: (HasCallStack, WebDriver wd) => Element -> wd ()+click e = noReturn $ doElemCommand methodPost e "/click" noObject++-- | Clear a textarea or text input element's value.+clearInput :: (HasCallStack, WebDriver wd) => Element -> wd ()+clearInput e = noReturn $ doElemCommand methodPost e "/clear" noObject++-- | Send a sequence of keystrokes to an element. All modifier keys are released+-- at the end of the function. Named constants for special modifier keys can be found+-- in "Test.WebDriver.Keys"+sendKeys :: (HasCallStack, WebDriver wd) => Text -> Element -> wd ()+sendKeys t e = noReturn . doElemCommand methodPost e "/value" . single "text" $ t++-- -- | Similar to sendKeys, but doesn't implicitly release modifier keys+-- -- afterwards. This allows you to combine modifiers with mouse clicks.+-- sendRawKeys :: (HasCallStack, WebDriver wd) => Text -> wd ()+-- sendRawKeys t = noReturn . doSessCommand methodPost "/keys" . single "text" $ t
+ src/Test/WebDriver/Commands/ElementRetrieval.hs view
@@ -0,0 +1,58 @@++module Test.WebDriver.Commands.ElementRetrieval (+ findElem+ , findElems+ , findElemFrom+ , findElemsFrom+ , activeElem++ , Selector(..)+ , Element(..)+ ) where++import Data.Aeson as A+import Data.Text (Text)+import GHC.Stack+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Find an element on the page using the given element selector.+findElem :: (HasCallStack, WebDriver wd) => Selector -> wd Element+findElem = doSessCommand methodPost "/element"++-- | Find all elements on the page matching the given selector.+findElems :: (HasCallStack, WebDriver wd) => Selector -> wd [Element]+findElems = doSessCommand methodPost "/elements"++-- | Search for an element using the given element as root.+findElemFrom :: (HasCallStack, WebDriver wd) => Element -> Selector -> wd Element+findElemFrom e = doElemCommand methodPost e "/element"++-- | Find all elements matching a selector, using the given element as root.+findElemsFrom :: (HasCallStack, WebDriver wd) => Element -> Selector -> wd [Element]+findElemsFrom e = doElemCommand methodPost e "/elements"++-- | Return the element that currently has focus.+activeElem :: (HasCallStack, WebDriver wd) => wd Element+activeElem = doSessCommand methodGet "/element/active" Null++-- | Specifies element(s) within a DOM tree using various selection methods.+data Selector =+ ByCSS Text+ | ByLinkText Text+ | ByPartialLinkText Text+ | ByTag Text+ | ByXPath Text+ deriving (Eq, Show, Ord)++instance ToJSON Selector where+ toJSON s = case s of+ ByTag t -> selector "tag name" t+ ByLinkText t -> selector "link text" t+ ByPartialLinkText t -> selector "partial link text" t+ ByCSS t -> selector "css selector" t+ ByXPath t -> selector "xpath" t+ where+ selector :: Text -> Text -> Value+ selector sn t = object ["using" .= sn, "value" .= t]
+ src/Test/WebDriver/Commands/ElementState.hs view
@@ -0,0 +1,51 @@++module Test.WebDriver.Commands.ElementState (+ isSelected+ , attr+ , prop+ , cssProp+ , getText+ , tagName+ , elemRect+ , isEnabled+ ) where++import Data.Aeson as A+import Data.Text (Text, append)+import GHC.Stack+import Test.WebDriver.Commands.CommandContexts+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Determine if the element is selected.+isSelected :: (HasCallStack, WebDriver wd) => Element -> wd Bool+isSelected e = doElemCommand methodGet e "/selected" Null++-- | Retrieve the value of an element's attribute+attr :: (HasCallStack, WebDriver wd) => Element -> Text -> wd (Maybe Text)+attr e t = doElemCommand methodGet e ("/attribute/" `append` urlEncode t) Null++-- | Retrieve the value of an element's property+prop :: (HasCallStack, WebDriver wd) => Element -> Text -> wd (Maybe Value)+prop e t = doElemCommand methodGet e ("/property/" `append` urlEncode t) Null++-- | Retrieve the value of an element's computed CSS property+cssProp :: (HasCallStack, WebDriver wd) => Element -> Text -> wd (Maybe Text)+cssProp e t = doElemCommand methodGet e ("/css/" `append` urlEncode t) Null++-- | Get all visible text within this element.+getText :: (HasCallStack, WebDriver wd) => Element -> wd Text+getText e = doElemCommand methodGet e "/text" Null++-- | Return the tag name of the given element.+tagName :: (HasCallStack, WebDriver wd) => Element -> wd Text+tagName e = doElemCommand methodGet e "/name" Null++-- | Retrieve an element's current position.+elemRect :: (HasCallStack, WebDriver wd) => Element -> wd Rect+elemRect e = doElemCommand methodGet e "/rect" Null++-- | Determine if the element is enabled.+isEnabled :: (HasCallStack, WebDriver wd) => Element -> wd Bool+isEnabled e = doElemCommand methodGet e "/enabled" Null
− src/Test/WebDriver/Commands/Internal.hs
@@ -1,108 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE 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--- webdriver commands.-module Test.WebDriver.Commands.Internal- (-- * Low-level webdriver functions- doCommand- -- ** Commands with :sessionId URL parameter- , doSessCommand, SessionId(..)- -- ** Commands with element :id URL parameters- , doElemCommand, Element(..)- -- ** Commands with :windowHandle URL parameters- , doWinCommand, WindowHandle(..), currentWindow- -- * Exceptions- , NoSessionId(..)- ) where--import Test.WebDriver.Class-import Test.WebDriver.JSON-import Test.WebDriver.Session-import Test.WebDriver.Utils (urlEncode)--import Control.Applicative-import Control.Exception.Lifted-import Data.Aeson-import Data.Aeson.Types-import Data.CallStack-import Data.Default (Default, def)-import Data.Text (Text)-import qualified Data.Text as T-import Data.Typeable--import Prelude -- hides some "unused import" warnings--{- |An opaque identifier for a web page element. -}-newtype Element = Element Text- deriving (Eq, Ord, Show, Read)--instance FromJSON Element where- parseJSON (Object o) = Element <$> (o .: "ELEMENT" <|> o .: "element-6066-11e4-a52e-4f735466cecf")- parseJSON v = typeMismatch "Element" v--instance ToJSON Element where- toJSON (Element e) = object ["ELEMENT" .= e]---{- |An opaque identifier for a browser window -}-newtype WindowHandle = WindowHandle Text- deriving (Eq, Ord, Show, Read,- FromJSON, ToJSON)-instance Default WindowHandle where- def = currentWindow---- |A special 'WindowHandle' that always refers to the currently focused window.--- This is also used by the 'Default' instance.-currentWindow :: WindowHandle-currentWindow = WindowHandle "current"--instance Exception NoSessionId--- |A command requiring a session ID was attempted when no session ID was--- available.-newtype NoSessionId = NoSessionId String- deriving (Eq, Show, Typeable)---- |This a convenient wrapper around 'doCommand' that automatically prepends--- the session URL parameter to the wire command URL. For example, passing--- a URL of \"/refresh\" will expand to \"/session/:sessionId/refresh\", where--- :sessionId is a URL parameter as described in--- <https://github.com/SeleniumHQ/selenium/wiki/JsonWireProtocol>-doSessCommand :: (HasCallStack, WebDriver wd, ToJSON a, FromJSON b) =>- Method -> Text -> a -> wd b-doSessCommand method path args = do- WDSession { wdSessId = mSessId } <- getSession- case mSessId of- Nothing -> throwIO . NoSessionId $ msg- where- msg = "doSessCommand: No session ID found for relative URL "- ++ show path- Just (SessionId sId) ->- -- Catch BadJSON exceptions here, since most commands go through this function.- -- Then, re-throw them with "error", which automatically appends a callstack- -- to the message in modern GHCs.- -- This callstack makes it easy to see which command caused the BadJSON exception,- -- without exposing too many internals.- catch- (doCommand method (T.concat ["/session/", urlEncode sId, path]) args)- (\(e :: BadJSON) -> error $ show e)---- |A wrapper around 'doSessCommand' to create element URLs.--- 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 :: (HasCallStack, WebDriver wd, ToJSON a, FromJSON b) =>- Method -> Element -> Text -> a -> wd b-doElemCommand m (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--- \"/session/:sessionId/window/:windowHandle/\", where :sessionId and--- :windowHandle are URL parameters as described in the wire protocol-doWinCommand :: (HasCallStack, WebDriver wd, ToJSON a, FromJSON b) =>- Method -> WindowHandle -> Text -> a -> wd b-doWinCommand m (WindowHandle w) path a =- doSessCommand m (T.concat ["/window/", urlEncode w, path]) a
+ src/Test/WebDriver/Commands/Logs.hs view
@@ -0,0 +1,48 @@+module Test.WebDriver.Commands.Logs (+ -- * Main log retrieval functions+ withRecordLogsViaBiDi+ , withRecordLogsViaBiDi'++ , getLogs++ -- * Driver-specific implementations+ -- , getChromeLogs+ -- , getFirefoxLogs+ -- , getSeleniumLogs+ -- , getSeleniumLogTypes++ -- * Types+ , LogType+ , LogEntry(..)+ , LogLevel(..)+ ) where++import GHC.Stack+import Test.WebDriver.Commands.Logs.BiDi+import Test.WebDriver.Commands.Logs.Chrome+import Test.WebDriver.Commands.Logs.Common+import Test.WebDriver.Commands.Logs.Firefox+import Test.WebDriver.Commands.Logs.Selenium+import Test.WebDriver.Types+++-- | Retrieve logs of a specific type from the browser. The W3C spec doesn't+-- define how to do this natively, so we automatically detect the browser and+-- try to use an appropriate method:+--+-- * Chrome/Chromium: Chrome DevTools Protocol (CDP)+-- * Firefox: legacy log endpoint (/log)+-- * Selenium: legacy log endpoint (/log)+-- * Other browsers: returns empty list+--+-- Common log types: @browser@, @driver@, @performance@, @server@.+--+-- However, the modern way to do this is via 'withRecordLogsViaBiDi'.+getLogs :: (HasCallStack, WebDriver wd) => LogType -> wd [LogEntry]+getLogs logType = do+ Session { sessionDriver = Driver { _driverConfig = driverConfig } } <- getSession+ case detectBrowserFromDriver driverConfig of+ Just BrowserChrome -> getChromeLogs logType+ Just BrowserFirefox -> getFirefoxLogs logType+ Just BrowserSelenium -> getSeleniumLogs logType+ Nothing -> return [] -- Return empty for unsupported browsers
+ src/Test/WebDriver/Commands/Logs/BiDi.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module Test.WebDriver.Commands.Logs.BiDi (+ withRecordLogsViaBiDi+ , withRecordLogsViaBiDi'+ ) where++import Control.Monad.IO.Unlift+import Control.Monad.Logger (MonadLogger, logDebugN, logWarnN)+import Data.Aeson+import Data.Aeson.Types (parseEither)+import Data.String.Interpolate+import Data.Text (Text)+import qualified Network.URI as URI+import Test.WebDriver.Commands.BiDi.Session+import Test.WebDriver.Commands.Logs.Common+import Test.WebDriver.Types+++logEvents :: [Text]+logEvents = ["log.entryAdded"]++-- | Wrapper around 'withRecordLogsViaBiDi'' which uses the WebSocket URL from+-- the current 'Session'. You must make sure to pass '_capabilitiesWebSocketUrl'+-- = @Just True@ to enable this. This will not work with Selenium 3.+withRecordLogsViaBiDi :: (WebDriver m, MonadLogger m) => BiDiOptions -> (LogEntry -> m ()) -> m a -> m a+withRecordLogsViaBiDi biDiOptions cb action = do+ withBiDiSession biDiOptions logEvents (mkLogCallback cb) action++-- | Connect to WebSocket URL and subscribe to log events using the W3C BiDi protocol; see+-- <https://w3c.github.io/webdriver-bidi/>.+withRecordLogsViaBiDi' :: forall m a. (MonadUnliftIO m, MonadLogger m) => BiDiOptions -> Int -> URI.URI -> (LogEntry -> m ()) -> m a -> m a+withRecordLogsViaBiDi' biDiOptions bidiSessionId uri cb action =+ withBiDiSession' biDiOptions bidiSessionId uri logEvents (mkLogCallback cb) action++mkLogCallback :: (MonadLogger m) => (LogEntry -> m ()) -> BiDiEvent -> m ()+mkLogCallback cb (BiDiEvent "event" "log.entryAdded" params) = case parseBiDiLogEntry params of+ Just logEntry -> cb logEntry+ Nothing -> logWarnN [i|BiDi: Failed to parse log entry: #{params}|]+mkLogCallback _cb x =+ logDebugN [i|BiDi: Ignoring non-log event message: #{x}|]++parseBiDiLogEntry :: Value -> Maybe LogEntry+parseBiDiLogEntry (Object o) = case parseEither parseLogEntry o of+ Right entry -> Just entry+ Left _ -> Nothing+ where+ parseLogEntry o' = do+ timestamp <- o' .: "timestamp"+ levelText <- o' .: "level"+ message <- o' .: "text"+ level <- case parseLogLevel levelText of+ Just l -> pure l+ Nothing -> fail "Invalid log level"+ pure $ LogEntry (round (timestamp :: Double)) level message++ parseLogLevel :: Text -> Maybe LogLevel+ parseLogLevel "debug" = Just LogDebug+ parseLogLevel "info" = Just LogInfo+ parseLogLevel "warn" = Just LogWarning+ parseLogLevel "error" = Just LogSevere+ parseLogLevel _ = Nothing+parseBiDiLogEntry _ = Nothing
+ src/Test/WebDriver/Commands/Logs/Chrome.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module Test.WebDriver.Commands.Logs.Chrome (+ getChromeLogs+ ) where++import Data.Aeson+import qualified Data.Foldable as F+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Stack+import Test.WebDriver.Commands.Logs.Common+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Aeson+import Test.WebDriver.Util.Commands+import UnliftIO.Exception+++getChromeLogs :: (HasCallStack, WebDriver wd) => LogType -> wd [LogEntry]+getChromeLogs logType =+ tryAny (getChromeLogsViaCDP logType) >>= \case+ Right entries -> return entries+ Left (_ :: SomeException) -> getLegacyChromeLogs logType++getChromeLogsViaCDP :: (HasCallStack, WebDriver wd) => LogType -> wd [LogEntry]+getChromeLogsViaCDP _logType = do+ result <- doSessCommand methodPost "/goog/cdp/execute" $ object [+ "cmd" .= ("Runtime.getConsoleEntries" :: Text)+ , "params" .= object []+ ]+ case result of+ (Object (aesonLookup "value" -> Just (Object (aesonLookup "result" -> Just (Object (aesonLookup "entries" -> Just (Array entries))))))) ->+ mapM parseChromeLogEntry (F.toList entries)+ _ -> return []++ where+ parseChromeLogEntry :: (WebDriver wd) => Value -> wd LogEntry+ parseChromeLogEntry (Object obj) = do+ timestamp :: Double <- obj !: "timestamp"+ level :: Text <- obj !: "level"+ message :: Text <- obj !: "text"+ return $ LogEntry {+ logTime = round timestamp+ , logLevel = parseChromeLogLevel level+ , logMsg = message+ }+ parseChromeLogEntry v = return $ LogEntry {+ logTime = 0+ , logLevel = LogInfo+ , logMsg = "Failed to parse log entry: " <> T.pack (show v)+ }++ parseChromeLogLevel :: Text -> LogLevel+ parseChromeLogLevel level = case level of+ "verbose" -> LogDebug+ "debug" -> LogDebug+ "log" -> LogInfo+ "info" -> LogInfo+ "warning" -> LogWarning+ "error" -> LogSevere+ _ -> LogInfo++getLegacyChromeLogs :: (HasCallStack, WebDriver wd) => LogType -> wd [LogEntry]+getLegacyChromeLogs logType = do+ tryAny (doSessCommand methodPost "/log" $ object ["type" .= logType]) >>= \case+ Right (Array logs) -> mapM fromJSON' (F.toList logs)+ Right _ -> return []+ Left (_ :: SomeException) -> return []
+ src/Test/WebDriver/Commands/Logs/Common.hs view
@@ -0,0 +1,102 @@+module Test.WebDriver.Commands.Logs.Common (+ Browser(..)+ , detectBrowserFromDriver++ -- * Re-exports+ , LogType+ , LogEntry(..)+ , LogLevel(..)+ ) where++import Data.Aeson as A+import Data.Aeson.Types (typeMismatch)+import Data.Maybe+import Data.Text (Text)+import Test.WebDriver.Types++-- | Supported browsers for log retrieval+data Browser =+ BrowserChrome+ | BrowserFirefox+ | BrowserSelenium+ deriving (Eq, Show)++detectBrowserFromDriver :: DriverConfig -> Maybe Browser+detectBrowserFromDriver driverConfig = case driverConfig of+ DriverConfigSeleniumJar { driverConfigSubDrivers = subDrivers } ->+ case subDrivers of+ (subDriver:_) -> detectBrowserFromDriver subDriver+ [] -> Just BrowserSelenium+ DriverConfigGeckodriver {} -> Just BrowserFirefox+ DriverConfigChromedriver {} -> Just BrowserChrome+++-- | A record that represents a single log entry.+data LogEntry = LogEntry {+ -- | Timestamp for the log entry. The standard does not specify the epoch or+ -- the unit of time.+ logTime :: Integer+ -- | Log verbosity level.+ , logLevel :: LogLevel+ , logMsg :: Text+ }+ deriving (Eq, Ord, Show, Read)++instance FromJSON LogEntry where+ parseJSON (Object o) =+ LogEntry <$> o .: "timestamp"+ <*> o .: "level"+ <*> (fromMaybe "" <$> o .: "message")+ parseJSON v = typeMismatch "LogEntry" v++instance ToJSON LogEntry where+ toJSON (LogEntry {..}) = A.object [+ ("timestamp", A.Number (fromIntegral logTime))+ , ("level", toJSON logLevel)+ , ("message", A.String logMsg)+ ]++type LogType = String++-- | Indicates a log verbosity level.+data LogLevel =+ LogOff+ | LogSevere+ | LogWarning+ | LogInfo+ | LogConfig+ | LogFine+ | LogFiner+ | LogFinest+ | LogDebug+ | LogAll+ deriving (Eq, Show, Read, Ord, Bounded, Enum)++instance ToJSON LogLevel where+ toJSON p= String $ case p of+ LogOff -> "OFF"+ LogSevere -> "SEVERE"+ LogWarning -> "WARNING"+ LogInfo -> "INFO"+ LogConfig -> "CONFIG"+ LogFine -> "FINE"+ LogFiner -> "FINER"+ LogFinest -> "FINEST"+ LogDebug -> "DEBUG"+ LogAll -> "ALL"++instance FromJSON LogLevel where+ parseJSON (String s) = case s of+ "OFF" -> return LogOff+ "SEVERE" -> return LogSevere+ "WARNING" -> return LogWarning+ "INFO" -> return LogInfo+ "CONFIG" -> return LogConfig+ "FINE" -> return LogFine+ "FINER" -> return LogFiner+ "FINEST" -> return LogFinest+ "DEBUG" -> return LogDebug+ "ALL" -> return LogAll+ _ -> fail ("Invalid logging preference: " ++ show s)++ parseJSON other = typeMismatch "LogLevel" other
+ src/Test/WebDriver/Commands/Logs/Firefox.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.WebDriver.Commands.Logs.Firefox (+ getFirefoxLogs+ ) where++import Data.Aeson+import qualified Data.Foldable as F+import GHC.Stack+import Test.WebDriver.Commands.Logs.Common+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+import UnliftIO.Exception+++getFirefoxLogs :: (HasCallStack, WebDriver wd) => LogType -> wd [LogEntry]+getFirefoxLogs logType = getLegacyFirefoxLogs logType++-- | Try legacy Firefox log endpoints (typically not supported)+getLegacyFirefoxLogs :: (HasCallStack, WebDriver wd) => LogType -> wd [LogEntry]+getLegacyFirefoxLogs logType = do+ tryAny (doSessCommand methodPost "/log" $ object ["type" .= logType]) >>= \case+ Right (Array logs) -> mapM fromJSON' (F.toList logs)+ _ -> return []
+ src/Test/WebDriver/Commands/Logs/Selenium.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.WebDriver.Commands.Logs.Selenium (+ getSeleniumLogs+ , getSeleniumLogTypes+ ) where++import Data.Aeson+import GHC.Stack+import Test.WebDriver.Commands.Logs.Common+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Get logs from Selenium using the legacy /log endpoint+getSeleniumLogs :: (HasCallStack, WebDriver wd) => LogType -> wd [LogEntry]+getSeleniumLogs logType = doSessCommand methodPost "/log" $ object ["type" .= logType]++-- | Get a list of available log types.+getSeleniumLogTypes :: (HasCallStack, WebDriver wd) => wd [LogType]+getSeleniumLogTypes = doSessCommand methodGet "/log/types" Null
@@ -0,0 +1,47 @@++module Test.WebDriver.Commands.Navigation (+ openPage+ , getCurrentURL+ , back+ , forward+ , refresh+ , getTitle+ ) where++import Data.Aeson as A+import Data.Text (Text)+import GHC.Stack+import Network.URI hiding (path) -- suppresses warnings+import Prelude -- hides some "unused import" warnings+import Test.WebDriver.Exceptions+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+import UnliftIO.Exception (throwIO)+++-- | Opens a new page by the given URL.+openPage :: (HasCallStack, WebDriver wd) => String -> wd ()+openPage url+ | isURI url = noReturn . doSessCommand methodPost "/url" . single "url" $ url+ | otherwise = throwIO . InvalidURL $ url++-- | Gets the URL of the current page.+getCurrentURL :: (HasCallStack, WebDriver wd) => wd String+getCurrentURL = doSessCommand methodGet "/url" Null++-- | Navigate backward in the browser history.+back :: (HasCallStack, WebDriver wd) => wd ()+back = noReturn $ doSessCommand methodPost "/back" noObject++-- | Navigate forward in the browser history.+forward :: (HasCallStack, WebDriver wd) => wd ()+forward = noReturn $ doSessCommand methodPost "/forward" noObject++-- | Refresh the current page+refresh :: (HasCallStack, WebDriver wd) => wd ()+refresh = noReturn $ doSessCommand methodPost "/refresh" noObject++-- | Get the title of the current page.+getTitle :: (HasCallStack, WebDriver wd) => wd Text+getTitle = doSessCommand methodGet "/title" Null
+ src/Test/WebDriver/Commands/ScreenCapture.hs view
@@ -0,0 +1,30 @@++module Test.WebDriver.Commands.ScreenCapture (+ screenshot+ , screenshotElement++ -- * Convenience functions+ , saveScreenshot+ ) where++import Control.Monad.IO.Class+import Data.Aeson as A+import Data.ByteString.Base64.Lazy as B64+import Data.ByteString.Lazy as LBS (ByteString, writeFile)+import qualified Data.Text.Lazy.Encoding as TL+import GHC.Stack+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Grab a screenshot of the current page as a PNG image.+screenshot :: (HasCallStack, WebDriver wd) => wd LBS.ByteString+screenshot = (B64.decodeLenient . TL.encodeUtf8) <$> doSessCommand methodGet "/screenshot" Null++-- | Grab a screenshot of the current page as a PNG image.+screenshotElement :: (HasCallStack, WebDriver wd) => Element -> wd LBS.ByteString+screenshotElement e = (B64.decodeLenient . TL.encodeUtf8) <$> doElemCommand methodGet e "/screenshot" Null++-- | Save a screenshot to a particular location.+saveScreenshot :: (HasCallStack, WebDriver wd) => FilePath -> wd ()+saveScreenshot path = screenshot >>= liftIO . LBS.writeFile path
+ src/Test/WebDriver/Commands/SeleniumSpecific/HTML5.hs view
@@ -0,0 +1,95 @@++module Test.WebDriver.Commands.SeleniumSpecific.HTML5 (+ -- * HTML 5 Web Storage+ storageSize+ , getAllKeys+ , deleteAllKeys+ , getKey+ , setKey+ , deleteKey+ , WebStorageType(..)++ -- * HTML 5 Application Cache+ , ApplicationCacheStatus(..)+ , getApplicationCacheStatus+ ) where++import Data.Aeson as A+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Stack+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Get the current number of keys in a web storage area.+storageSize :: (HasCallStack, WebDriver wd) => WebStorageType -> wd Integer+storageSize s = doStorageCommand methodGet s "/size" Null++-- | Get a list of all keys from a web storage area.+getAllKeys :: (HasCallStack, WebDriver wd) => WebStorageType -> wd [Text]+getAllKeys s = doStorageCommand methodGet s "" Null++-- | Delete all keys within a given web storage area.+deleteAllKeys :: (HasCallStack, WebDriver wd) => WebStorageType -> wd ()+deleteAllKeys s = noReturn $ doStorageCommand methodDelete s "" Null++-- | An HTML 5 storage type+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.+getKey :: (HasCallStack, WebDriver wd) => WebStorageType -> Text -> wd Text+getKey s k = doStorageCommand methodGet s ("/key/" `T.append` urlEncode k) Null++-- | Set a key in the given web storage area.+setKey :: (HasCallStack, WebDriver wd) => WebStorageType -> Text -> Text -> wd Text+setKey s k v = doStorageCommand methodPost s "" . object $ ["key" .= k,+ "value" .= v ]+-- | Delete a key in the given web storage area.+deleteKey :: (HasCallStack, WebDriver wd) => WebStorageType -> Text -> wd ()+deleteKey s k = noReturn $ doStorageCommand methodPost s ("/key/" `T.append` urlEncode k) Null++-- | A wrapper around 'doSessCommand' to create web storage requests.+doStorageCommand :: (+ HasCallStack, WebDriver wd, ToJSON a, FromJSON b+ ) => Method -> WebStorageType -> Text -> a -> wd b+doStorageCommand m s path a = doSessCommand m (T.concat ["/", s', path]) a+ where s' = case s of+ LocalStorage -> "local_storage"+ SessionStorage -> "session_storage"++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++instance ToJSON ApplicationCacheStatus where+ toJSON Uncached = A.Number 0+ toJSON Idle = A.Number 1+ toJSON Checking = A.Number 2+ toJSON Downloading = A.Number 3+ toJSON UpdateReady = A.Number 4+ toJSON Obsolete = A.Number 5++getApplicationCacheStatus :: (HasCallStack, WebDriver wd) => wd ApplicationCacheStatus+getApplicationCacheStatus = doSessCommand methodGet "/application_cache/status" Null
+ src/Test/WebDriver/Commands/SeleniumSpecific/Misc.hs view
@@ -0,0 +1,39 @@++module Test.WebDriver.Commands.SeleniumSpecific.Misc (+ -- * Interacting with elements+ submit+ , isDisplayed++ -- * Element equality+ , (<==>)+ , (</=>)+ ) where++import Data.Aeson as A+import GHC.Stack+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Submit a form element. This may be applied to descendents of a form element+-- as well.+submit :: (HasCallStack, WebDriver wd) => Element -> wd ()+submit e = noReturn $ doElemCommand methodPost e "/submit" Null++-- | Determine if the element is displayed.+-- This function isn't guaranteed to be implemented by the WebDriver spec,+-- but it is found in Selenium.+-- See https://www.w3.org/TR/webdriver1/#element-displayedness.+isDisplayed :: (HasCallStack, WebDriver wd) => Element -> wd Bool+isDisplayed e = doElemCommand methodGet e "/displayed" Null++infix 4 <==>+-- | Determines if two element identifiers refer to the same element.+(<==>) :: (HasCallStack, WebDriver wd) => Element -> Element -> wd Bool+e1 <==> (Element e2) = doElemCommand methodGet e1 ("/equals/" <> urlEncode e2) Null++-- | Determines if two element identifiers refer to different elements.+infix 4 </=>+(</=>) :: (HasCallStack, WebDriver wd) => Element -> Element -> wd Bool+e1 </=> e2 = not <$> (e1 <==> e2)
+ src/Test/WebDriver/Commands/SeleniumSpecific/Mobile.hs view
@@ -0,0 +1,133 @@++module Test.WebDriver.Commands.SeleniumSpecific.Mobile (+ -- ** Screen orientation+ getOrientation+ , setOrientation+ , Orientation(..)+ -- ** Geo-location+ , getLocation+ , setLocation+ -- ** Touch gestures+ , touchClick+ , touchDown+ , touchUp+ , touchMove+ , touchScroll+ , touchScrollFrom+ , touchDoubleClick+ , touchLongClick+ , touchFlick+ , touchFlickFrom+ ) where++import Data.Aeson as A+import Data.Aeson.Types+import Data.String (fromString)+import Data.Text (toUpper, toLower)+import GHC.Stack+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | A screen orientation+data Orientation = Landscape | Portrait+ deriving (Eq, Show, Ord, Bounded, Enum)++instance ToJSON Orientation where+ toJSON = String . toUpper . fromString . show++instance FromJSON Orientation where+ parseJSON (String jStr) = case toLower jStr of+ "landscape" -> return Landscape+ "portrait" -> return Portrait+ err -> fail $ "Invalid Orientation string " ++ show err+ parseJSON v = typeMismatch "Orientation" v++-- | Get the current screen orientation for rotatable display devices.+getOrientation :: (HasCallStack, WebDriver wd) => wd Orientation+getOrientation = doSessCommand methodGet "/orientation" Null++-- | Set the current screen orientation for rotatable display devices.+setOrientation :: (HasCallStack, WebDriver wd) => Orientation -> wd ()+setOrientation = noReturn . doSessCommand methodPost "/orientation" . single "orientation"++-- | Single tap on the touch screen at the given element's location.+touchClick :: (HasCallStack, WebDriver wd) => Element -> wd ()+touchClick (Element e) =+ noReturn . doSessCommand methodPost "/touch/click" . single "element" $ e++-- | Emulates pressing a finger down on the screen at the given location.+touchDown :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()+touchDown = noReturn . doSessCommand methodPost "/touch/down" . pair ("x","y")++-- | Emulates removing a finger from the screen at the given location.+touchUp :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()+touchUp = noReturn . doSessCommand methodPost "/touch/up" . pair ("x","y")++-- | Emulates moving a finger on the screen to the given location.+touchMove :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()+touchMove = noReturn . doSessCommand methodPost "/touch/move" . pair ("x","y")++-- | Emulate finger-based touch scroll. Use this function if you don't care where+-- the scroll begins+touchScroll :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()+touchScroll = noReturn . doSessCommand methodPost "/touch/scroll" . pair ("xoffset","yoffset")++-- | Emulate finger-based touch scroll, starting from the given location relative+-- to the given element.+touchScrollFrom :: (HasCallStack, WebDriver wd) => (Int, Int) -> Element -> wd ()+touchScrollFrom (x, y) (Element e) =+ noReturn+ . doSessCommand methodPost "/touch/scroll"+ . triple ("xoffset", "yoffset", "element")+ $ (x, y, e)++-- | Emulate a double click on a touch device.+touchDoubleClick :: (HasCallStack, WebDriver wd) => Element -> wd ()+touchDoubleClick (Element e) =+ noReturn+ . doSessCommand methodPost "/touch/doubleclick"+ . single "element" $ e++-- | Emulate a long click on a touch device.+touchLongClick :: (HasCallStack, WebDriver wd) => Element -> wd ()+touchLongClick (Element e) =+ noReturn+ . doSessCommand methodPost "/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 :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()+touchFlick =+ noReturn+ . doSessCommand methodPost "/touch/flick"+ . pair ("xSpeed", "ySpeed")++-- | Emulate a flick on the touch screen.+touchFlickFrom :: (HasCallStack, 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) =+ noReturn+ . doSessCommand methodPost "/touch/flick" . object $+ ["xoffset" .= x+ ,"yoffset" .= y+ ,"speed" .= s+ ,"element" .= e+ ]++-- | Get the current geographical location of the device.+getLocation :: (HasCallStack, WebDriver wd) => wd (Int, Int, Int)+getLocation = doSessCommand methodGet "/location" Null+ >>= parseTriple "latitude" "longitude" "altitude" "getLocation"++-- | Set the current geographical location of the device.+setLocation :: (HasCallStack, WebDriver wd) => (Int, Int, Int) -> wd ()+setLocation = noReturn . doSessCommand methodPost "/location"+ . triple ("latitude",+ "longitude",+ "altitude")
+ src/Test/WebDriver/Commands/SeleniumSpecific/Uploads.hs view
@@ -0,0 +1,50 @@++module Test.WebDriver.Commands.SeleniumSpecific.Uploads (+ seleniumUploadFile+ , seleniumUploadRawFile+ , seleniumUploadZipEntry+ ) where++import Codec.Archive.Zip+import Control.Monad.IO.Class+import Data.ByteString.Base64.Lazy as B64+import Data.ByteString.Lazy as LBS (ByteString)+import Data.Function ((&))+import Data.Text (Text)+import qualified Data.Text.Lazy.Encoding as TL+import GHC.Stack+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Uploads a file from the local filesystem by its file path. Returns the+-- remote filepath of the file.+seleniumUploadFile :: (HasCallStack, WebDriver wd) => FilePath -> wd Text+seleniumUploadFile path = seleniumUploadZipEntry =<< liftIO (readEntry [] path)++-- | Uploads a raw 'LBS.ByteString' with associated file info. Returns the+-- remote filepath of the file.+seleniumUploadRawFile :: (+ HasCallStack, WebDriver wd+ )+ -- | File path to use with this bytestring.+ => FilePath+ -- | Modification time (in seconds since Unix epoch).+ -> Integer+ -- | The file contents as a lazy ByteString.+ -> LBS.ByteString+ -> wd Text+seleniumUploadRawFile path t str = seleniumUploadZipEntry (toEntry path t str)++-- | Lowest level interface to the file uploading mechanism. This allows you to+-- specify the exact details of the zip entry sent across network. Returns the+-- remote filepath of the extracted file+seleniumUploadZipEntry :: (HasCallStack, WebDriver wd) => Entry -> wd Text+seleniumUploadZipEntry entry = doSessCommand methodPost "/se/file" $ single "file" file+ where+ file = entry+ & (`addEntryToArchive` emptyArchive)+ & fromArchive+ & B64.encode+ & TL.decodeUtf8
+ src/Test/WebDriver/Commands/Sessions.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.WebDriver.Commands.Sessions (+ -- * Server information+ serverStatus++ -- * Timeouts+ , getTimeouts+ , setTimeouts++ -- ** Set individual timeouts+ , setScriptTimeout+ , setPageLoadTimeout+ , setImplicitWait++ -- * Types+ , Timeouts(..)+ , emptyTimeouts++ -- , sessions+ -- , getActualCaps+ ) where++import Data.Aeson as A+import Data.Aeson.TH as A+import GHC.Stack+import Test.WebDriver.Capabilities.Aeson+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Get information from the server as a JSON 'Object'. For more information+-- about this object see+-- <https://github.com/SeleniumHQ/selenium/wiki/JsonWireProtocol#status>+serverStatus :: (HasCallStack, WebDriver wd) => wd Value -- todo: make this a record type+serverStatus = doCommand methodGet "/status" Null++-- -- | Get the actual server-side 'Capabilities' of the current session.+-- -- TODO: remove, seems not to exist in the W3C spec+-- getActualCaps :: (HasCallStack, WebDriver wd) => wd Capabilities+-- getActualCaps = doSessCommand methodGet "" Null++data Timeouts = Timeouts {+ -- | Determines when to interrupt a script that is being evaluated.+ timeoutsScript :: Maybe Integer+ -- | Provides the timeout limit used to interrupt navigation of the browsing context.+ , timeoutsPageLoad :: Maybe Integer+ -- | Gives the timeout of when to abort locating an element.+ , timeoutsImplicit :: Maybe Integer+ } deriving (Show, Eq)+deriveJSON toCamel1 ''Timeouts+emptyTimeouts :: Timeouts+emptyTimeouts = Timeouts Nothing Nothing Nothing++-- | Get all the 'Timeouts' simultaneously.+getTimeouts :: (HasCallStack, WebDriver wd) => wd Timeouts+getTimeouts = doSessCommand methodGet "/timeouts" Null++-- | Set all the 'Timeouts' simultaneously.+setTimeouts :: (HasCallStack, WebDriver wd) => Timeouts -> wd ()+setTimeouts timeouts = doSessCommand methodPost "/timeouts" (A.toJSON timeouts)++-- | Set the "script" value of the 'Timeouts'.+-- Selenium 3 and 4 accept @null@ for this value, which unsets it. The spec doesn't mention this.+setScriptTimeout :: (HasCallStack, WebDriver wd) => Maybe Integer -> wd ()+setScriptTimeout x = doSessCommand methodPost "/timeouts" (A.object [("script", maybe A.Null (A.Number . fromIntegral) x)])++-- | Set the "pageLoad" value of the 'Timeouts'.+setPageLoadTimeout :: (HasCallStack, WebDriver wd) => Integer -> wd ()+setPageLoadTimeout x = doSessCommand methodPost "/timeouts" (A.object [("pageLoad", A.Number $ fromIntegral x)])++-- | Set the "implicit" value of the 'Timeouts'.+setImplicitWait :: (HasCallStack, WebDriver wd) => Integer -> wd ()+setImplicitWait x = doSessCommand methodPost "/timeouts" (A.object [("implicit", A.Number $ fromIntegral x)])
+ src/Test/WebDriver/Commands/UserPrompts.hs view
@@ -0,0 +1,31 @@++module Test.WebDriver.Commands.UserPrompts (+ dismissAlert+ , acceptAlert+ , getAlertText+ , replyToAlert+ ) where++import Data.Aeson as A+import Data.Text (Text)+import GHC.Stack+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Dismisses the currently displayed alert dialog.+dismissAlert :: (HasCallStack, WebDriver wd) => wd ()+dismissAlert = noReturn $ doSessCommand methodPost "/alert/dismiss" noObject++-- | Accepts the currently displayed alert dialog.+acceptAlert :: (HasCallStack, WebDriver wd) => wd ()+acceptAlert = noReturn $ doSessCommand methodPost "/alert/accept" noObject++-- | Get the text of an alert dialog.+getAlertText :: (HasCallStack, WebDriver wd) => wd Text+getAlertText = doSessCommand methodGet "/alert/text" Null++-- | Sends keystrokes to Javascript prompt() dialog.+replyToAlert :: (HasCallStack, WebDriver wd) => Text -> wd ()+replyToAlert = noReturn . doSessCommand methodPost "/alert/text" . single "text"
− src/Test/WebDriver/Commands/Wait.hs
@@ -1,154 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ConstraintKinds #-}--module Test.WebDriver.Commands.Wait- ( -- * Wait on expected conditions- waitUntil, waitUntil'- , waitWhile, waitWhile'- -- * Expected conditions- , ExpectFailed (..), expect, unexpected- , expectAny, expectAll- , expectNotStale, expectAlertOpen- , catchFailedCommand- -- ** Convenience functions- , onTimeout- ) where-import Test.WebDriver.Commands-import Test.WebDriver.Class-import Test.WebDriver.Exceptions-import Test.WebDriver.Session--import Control.Concurrent-import Control.Exception.Lifted-import Control.Monad.Base-import Control.Monad.Trans.Control--import Data.CallStack-import qualified Data.Foldable as F-import Data.Text (Text)-import Data.Time.Clock-import Data.Typeable--#if !MIN_VERSION_base(4,6,0) || defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706-import Prelude hiding (catch)-#endif--instance Exception ExpectFailed--- |An exception representing the failure of an expected condition.-data ExpectFailed = ExpectFailed String deriving (Show, Eq, Typeable)---- |throws 'ExpectFailed'. This is nice for writing your own abstractions.-unexpected :: (MonadBaseControl IO m, HasCallStack) =>- 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--- boolean is False, and otherwise does nothing.-expect :: (MonadBaseControl IO m, HasCallStack) => Bool -> m ()-expect b- | b = return ()- | otherwise = unexpected "Test.WebDriver.Commands.Wait.expect"---- |Apply a monadic predicate to every element in a list, and 'expect' that--- at least one succeeds.-expectAny :: (F.Foldable f, MonadBaseControl IO m, HasCallStack) => (a -> m Bool) -> f a -> m ()-expectAny p xs = expect . F.or =<< mapM p (F.toList xs)---- |Apply a monadic predicate to every element in a list, and 'expect' that all--- succeed.-expectAll :: (F.Foldable f, MonadBaseControl IO m, HasCallStack) => (a -> m Bool) -> f a -> m ()-expectAll p xs = expect . F.and =<< mapM p (F.toList xs)---- | 'expect' the given 'Element' to not be stale and returns it-expectNotStale :: (WebDriver wd, HasCallStack) => Element -> wd Element-expectNotStale e = catchFailedCommand StaleElementReference $ do- _ <- isEnabled e -- Any command will force a staleness check- return e---- | 'expect' an alert to be present on the page, and returns its text.-expectAlertOpen :: (WebDriver wd, HasCallStack) => wd Text-expectAlertOpen = catchFailedCommand NoAlertOpen getAlertText---- |Catches any `FailedCommand` exceptions with the given `FailedCommandType` and rethrows as 'ExpectFailed'-catchFailedCommand :: (MonadBaseControl IO m, HasCallStack) => FailedCommandType -> m a -> m a-catchFailedCommand t1 m = m `catch` handler- where- handler e@(FailedCommand t2 _)- | t1 == t2 = unexpected . show $ e- handler e = throwIO e---- |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--- is expressed in seconds.-waitUntil :: (WDSessionStateControl m, HasCallStack) => Double -> m a -> m a-waitUntil = waitUntil' 500000---- |Similar to 'waitUntil' but allows you to also specify the poll frequency--- of the 'WD' action. The frequency is expressed as an integer in microseconds.-waitUntil' :: (WDSessionStateControl m, HasCallStack) => Int -> Double -> m a -> m a-waitUntil' = waitEither id (\_ -> return)---- |Like 'waitUntil', but retries the action until it fails or until the timeout--- is exceeded.-waitWhile :: (WDSessionStateControl m, HasCallStack) => Double -> m a -> m ()-waitWhile = waitWhile' 500000---- |Like 'waitUntil'', but retries the action until it either fails or--- until the timeout is exceeded.-waitWhile' :: (WDSessionStateControl m, HasCallStack) => Int -> Double -> m a -> m ()-waitWhile' =- waitEither (\_ _ -> return ())- (\retry _ -> retry "waitWhile: action did not fail")----- |Internal function used to implement explicit wait commands using success and failure continuations-waitEither :: (WDSessionStateControl m, HasCallStack) =>- ((String -> m b) -> String -> m b)- -> ((String -> m b) -> a -> m b)- -> Int -> Double -> m a -> m b-waitEither failure success = wait' handler- where- handler retry wd = do- e <- fmap Right wd `catches` [Handler handleFailedCommand- ,Handler handleExpectFailed- ]- either (failure retry) (success retry) e- where- handleFailedCommand e@(FailedCommand NoSuchElement _) = return . Left . show $ e- handleFailedCommand err = throwIO err-- handleExpectFailed (e :: ExpectFailed) = return . Left . show $ e--wait' :: (WDSessionStateIO m, HasCallStack) =>- ((String -> m b) -> m a -> m b) -> Int -> Double -> m a -> m b-wait' handler waitAmnt t wd = waitLoop =<< liftBase getCurrentTime- where- timeout = realToFrac t- waitLoop startTime = handler retry wd- where- retry why = do- now <- liftBase getCurrentTime- if diffUTCTime now startTime >= timeout- then- failedCommand Timeout $ "wait': explicit wait timed out (" ++ why ++ ")."- else do- liftBase . threadDelay $ waitAmnt- waitLoop startTime---- |Convenience function to catch 'FailedCommand' 'Timeout' exceptions--- and perform some action.------ Example:------ > waitUntil 5 (getText <=< findElem $ ByCSS ".class")--- > `onTimeout` return ""-onTimeout :: (MonadBaseControl IO m, HasCallStack) => m a -> m a -> m a-onTimeout m r = m `catch` handler- where- handler (FailedCommand Timeout _) = r- handler other = throwIO other
− src/Test/WebDriver/Common/Keys.hs
@@ -1,199 +0,0 @@---- | This module contains named constants corresponding to the special characters recognized by 'sendKeys'.--- For more details on these special characters, consult the Selenium documentation at--- <https://github.com/SeleniumHQ/selenium/wiki/JsonWireProtocol#sessionsessionidelementidvalue>-module Test.WebDriver.Common.Keys where--import Data.Text (Text)--add :: Text-add = "\xe025"--alt :: Text-alt = "\xe00a"--arrowDown :: Text-arrowDown = "\xe015"--arrowLeft :: Text-arrowLeft = "\xe012"--arrowRight :: Text-arrowRight = "\xe014"--arrowUp :: Text-arrowUp = "\xe013"--backspace :: Text-backspace = "\xe003"--backSpace :: Text-backSpace = "\xe003"--cancel :: Text-cancel = "\xe001"--clear :: Text-clear = "\xe005"--command :: Text-command = "\xe03d"--control :: Text-control = "\xe009"--decimal :: Text-decimal = "\xe028"--delete :: Text-delete = "\xe017"--divide :: Text-divide = "\xe029"--down :: Text-down = "\xe015"--end :: Text-end = "\xe010"--enter :: Text-enter = "\xe007"--equals :: Text-equals = "\xe019"--escape :: Text-escape = "\xe00c"--f1 :: Text-f1 = "\xe031"--f2 :: Text-f2 = "\xe032"--f3 :: Text-f3 = "\xe033"--f4 :: Text-f4 = "\xe034"--f5 :: Text-f5 = "\xe035"--f6 :: Text-f6 = "\xe036"--f7 :: Text-f7 = "\xe037"--f8 :: Text-f8 = "\xe038"--f9 :: Text-f9 = "\xe039"--f10 :: Text-f10 = "\xe03a"--f11 :: Text-f11 = "\xe03b"--f12 :: Text-f12 = "\xe03c"--help :: Text-help = "\xe002"--home :: Text-home = "\xe011"--insert :: Text-insert = "\xe016"--left :: Text-left = "\xe012"--leftAlt :: Text-leftAlt = "\xe00a"--leftControl :: Text-leftControl = "\xe009"--leftShift :: Text-leftShift = "\xe008"--meta :: Text-meta = "\xe03d"--multiply :: Text-multiply = "\xe024"--null :: Text-null = "\xe000"--numpad0 :: Text-numpad0 = "\xe01a"--numpad1 :: Text-numpad1 = "\xe01b"--numpad2 :: Text-numpad2 = "\xe01c"--numpad3 :: Text-numpad3 = "\xe01d"--numpad4 :: Text-numpad4 = "\xe01e"--numpad5 :: Text-numpad5 = "\xe01f"--numpad6 :: Text-numpad6 = "\xe020"--numpad7 :: Text-numpad7 = "\xe021"--numpad8 :: Text-numpad8 = "\xe022"--numpad9 :: Text-numpad9 = "\xe023"--pageDown :: Text-pageDown = "\xe00f"--pageUp :: Text-pageUp = "\xe00e"--pause :: Text-pause = "\xe00b"--return :: Text-return = "\xe006"--right :: Text-right = "\xe014"--semicolon :: Text-semicolon = "\xe018"--separator :: Text-separator = "\xe026"--shift :: Text-shift = "\xe008"--space :: Text-space = "\xe00d"--subtract :: Text-subtract = "\xe027"--tab :: Text-tab = "\xe004"--up :: Text-up = "\xe013"
− src/Test/WebDriver/Common/Profile.hs
@@ -1,265 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_HADDOCK not-home #-}---- | A type for profile preferences. These preference values are used by both--- Firefox and Opera profiles.-module Test.WebDriver.Common.Profile- ( -- *Profiles and profile preferences- Profile(..), PreparedProfile(..), ProfilePref(..), ToPref(..)- -- * Preferences- , getPref, addPref, deletePref- -- * Extensions- , addExtension, deleteExtension, hasExtension- -- * Other files and directories- , addFile, deleteFile, hasFile- -- * Miscellaneous profile operations- , unionProfiles, onProfileFiles, onProfilePrefs- -- *Preparing profiles from disk- , prepareLoadedProfile_- -- *Preparing zipped profiles- , prepareZippedProfile, prepareZipArchive,- prepareRawZip- -- *Profile errors- , ProfileParseError(..)- ) where--import Codec.Archive.Zip-import Data.Aeson-import Data.Aeson.Types-import System.Directory-import System.FilePath hiding (addExtension, hasExtension)--#if MIN_VERSION_aeson(0,7,0)-import Data.Scientific-#else-import Data.Attoparsec.Number (Number(..))-#endif--import qualified Data.HashMap.Strict as HM-import Data.Text (Text, pack)-import Data.ByteString.Lazy (ByteString)---import qualified Data.ByteString as SBS-import qualified Data.ByteString.Lazy as LBS-import qualified Data.ByteString.Base64.Lazy as B64-import qualified Data.Text.Lazy.Encoding as TL---import Data.Fixed-import Data.Ratio-import Data.Int-import Data.Word-import Data.Typeable--import Control.Exception-import Control.Applicative-import Control.Monad.Base--import Prelude -- hides some "unused import" warnings---- |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--- must be made, the phantom type parameter is used to differentiate.-data Profile b = Profile- { -- |A mapping from relative destination filepaths to source- -- 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- -- there is one unique source path going to each- -- destination path.- profileFiles :: HM.HashMap FilePath FilePath- -- |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- }- deriving (Eq, Show)---- |Represents a profile that has been prepared for--- network transmission. The profile cannot be modified in this form.-newtype PreparedProfile b = PreparedProfile ByteString- deriving (Eq, Show)--instance FromJSON (PreparedProfile s) where- parseJSON v = PreparedProfile . TL.encodeUtf8 <$> parseJSON v--instance ToJSON (PreparedProfile s) where- toJSON (PreparedProfile s) = toJSON $ TL.decodeUtf8 s---- |A profile preference value. This is the subset of JSON values that excludes--- arrays, objects, and null.-data ProfilePref = PrefInteger !Integer- | PrefDouble !Double- | PrefString !Text- | PrefBool !Bool- deriving (Eq, Show)--instance ToJSON ProfilePref where- toJSON v = case v of- PrefInteger i -> toJSON i- PrefDouble d -> toJSON d- PrefString s -> toJSON s- PrefBool b -> toJSON b--instance FromJSON ProfilePref where- parseJSON (String s) = return $ PrefString s- parseJSON (Bool b) = return $ PrefBool b-#if MIN_VERSION_aeson(0,7,0)- parseJSON (Number s) | base10Exponent s >= 0 = return $ PrefInteger (coefficient s * 10^(base10Exponent s))- | otherwise = return $ PrefDouble $ realToFrac s-#else- parseJSON (Number (I i)) = return $ PrefInteger i- parseJSON (Number (D d)) = return $ PrefDouble d-#endif- parseJSON other = typeMismatch "ProfilePref" other--instance Exception ProfileParseError--- |An error occured while attempting to parse a profile's preference file.-newtype ProfileParseError = ProfileParseError String- deriving (Eq, Show, Read, Typeable)---- |A typeclass to convert types to profile preference values-class ToPref a where- toPref :: a -> ProfilePref--instance ToPref Text where- toPref = PrefString--instance ToPref String where- toPref = toPref . pack--instance ToPref Bool where- toPref = PrefBool--instance ToPref Integer where- toPref = PrefInteger--#define I(t) instance ToPref t where toPref = PrefInteger . toInteger--I(Int)-I(Int8)-I(Int16)-I(Int32)-I(Int64)-I(Word)-I(Word8)-I(Word16)-I(Word32)-I(Word64)--instance ToPref Double where- toPref = PrefDouble--instance ToPref Float where- toPref = PrefDouble . realToFrac--instance (Integral a) => ToPref (Ratio a) where- toPref = PrefDouble . realToFrac--instance (HasResolution r) => ToPref (Fixed r) where- toPref = PrefDouble . realToFrac--instance ToPref ProfilePref where- toPref = id---- |Retrieve a preference from a profile by key name.-getPref :: Text -> Profile b -> Maybe ProfilePref-getPref k (Profile _ m) = HM.lookup k m---- |Add a new preference entry to a profile, overwriting any existing entry--- with the same key.-addPref :: ToPref a => Text -> a -> Profile b -> Profile b-addPref k v p = onProfilePrefs p $ HM.insert k (toPref v)---- |Delete an existing preference entry from a profile. This operation is--- silent if the preference wasn't found.-deletePref :: Text -> Profile b -> Profile b-deletePref k p = 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--- 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-addFile src dest p = onProfileFiles p $ HM.insert dest src---- |Delete a file from the profile directory. The first argument is the name of--- file within the profile directory.-deleteFile :: FilePath -> Profile b -> Profile b-deleteFile path prof = onProfileFiles prof $ HM.delete path---- |Determines if a profile contains the given file, specified as a path--- relative to the profile directory.-hasFile :: String -> Profile b -> Bool-hasFile path (Profile files _) = path `HM.member` files---- |Add a new extension to the profile. The file path should refer to--- a .xpi file or an extension directory on the filesystem.-addExtension :: FilePath -> Profile b -> Profile b-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--- 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--- .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'--- fields.-unionProfiles :: Profile b -> Profile b -> Profile b-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)- -> 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)- -> Profile b-onProfileFiles (Profile ls hm) f = Profile (f ls) hm----- |Efficiently load an existing profile from disk and prepare it for network--- transmission.-prepareLoadedProfile_ :: MonadBase IO m =>- FilePath -> m (PreparedProfile a)-prepareLoadedProfile_ path = liftBase $ do- oldWd <- getCurrentDirectory- setCurrentDirectory path- prepareZipArchive <$>- 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 =>- FilePath -> m (PreparedProfile a)-prepareZippedProfile path = prepareRawZip <$> liftBase (LBS.readFile path)---- |Prepare a zip archive of a profile for network transmission.-prepareZipArchive :: Archive -> PreparedProfile a-prepareZipArchive = prepareRawZip . fromArchive---- |Prepare a ByteString of raw zip data for network transmission-prepareRawZip :: ByteString -> PreparedProfile a-prepareRawZip = PreparedProfile . B64.encode
− src/Test/WebDriver/Config.hs
@@ -1,96 +0,0 @@--module Test.WebDriver.Config(- -- * WebDriver configuration- WDConfig(..), defaultConfig- -- * Capabilities helpers- , modifyCaps, useBrowser, useVersion, usePlatform, useProxy- -- * SessionHistoryConfig options- , SessionHistoryConfig, noHistory, unlimitedHistory, onlyMostRecentHistory- -- * Overloadable configuration- , WebDriverConfig(..)- ) where-import Test.WebDriver.Capabilities-import Test.WebDriver.Session--import Data.Default (Default, def)-import Data.String (fromString)--import Control.Monad.Base--import Network.HTTP.Client (Manager, newManager, defaultManagerSettings)-import Network.HTTP.Types (RequestHeaders)---- |WebDriver session configuration-data WDConfig = WDConfig {- -- |Host name of the WebDriver server for this- -- session (default 127.0.0.1)- wdHost :: String- -- |Port number of the server (default 4444)- , wdPort :: Int- -- |Capabilities to use for this session- , wdCapabilities :: Capabilities- -- |Base path for all API requests (default "\/wd\/hub")- , wdBasePath :: String- -- |Custom request headers to add to every HTTP request.- , wdRequestHeaders :: RequestHeaders- -- |Custom request headers to add *only* to session creation requests. This is usually done- -- when a WebDriver server requires HTTP auth.- , wdAuthHeaders :: RequestHeaders- -- |Specifies behavior of HTTP request/response history. By default we use 'unlimitedHistory'.- , wdHistoryConfig :: SessionHistoryConfig- -- |Use the given http-client 'Manager' instead of automatically creating one.- , wdHTTPManager :: Maybe Manager- -- |Number of times to retry a HTTP request if it times out (default 0)- , wdHTTPRetryCount :: Int-}--instance GetCapabilities WDConfig where- getCaps = wdCapabilities--instance SetCapabilities WDConfig where- setCaps caps conf = conf { wdCapabilities = caps }--instance Default WDConfig where- def = WDConfig {- wdHost = "127.0.0.1"- , wdPort = 4444- , wdRequestHeaders = []- , wdAuthHeaders = []- , wdCapabilities = def- , wdHistoryConfig = unlimitedHistory- , wdBasePath = "/wd/hub"- , wdHTTPManager = Nothing- , wdHTTPRetryCount = 0- }--{- |A default session config 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. -}-defaultConfig :: WDConfig-defaultConfig = def---- |Class of types that can configure a WebDriver session.-class WebDriverConfig c where- -- |Produces a 'Capabilities' from the given configuration.- mkCaps :: MonadBase IO m => c -> m Capabilities-- -- |Produces a 'WDSession' from the given configuration.- mkSession :: MonadBase IO m => c -> m WDSession--instance WebDriverConfig WDConfig where- mkCaps = return . getCaps-- mkSession WDConfig{..} = do- manager <- maybe createManager return wdHTTPManager- return WDSession { wdSessHost = fromString $ wdHost- , wdSessPort = wdPort- , wdSessRequestHeaders = wdRequestHeaders- , wdSessAuthHeaders = wdAuthHeaders- , wdSessBasePath = fromString $ wdBasePath- , wdSessId = Nothing- , wdSessHist = []- , wdSessHistUpdate = wdHistoryConfig- , wdSessHTTPManager = manager- , wdSessHTTPRetryCount = wdHTTPRetryCount }- where- createManager = liftBase $ newManager defaultManagerSettings
− src/Test/WebDriver/Cookies.hs
@@ -1,60 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--module Test.WebDriver.Cookies where--import Data.Aeson-import Data.Aeson.Types-import qualified Data.Char as C-import Data.Text (Text)-import GHC.Generics-import Test.WebDriver.JSON---- | Cookies are delicious delicacies. When sending cookies to the server, a value--- of Nothing indicates that the server should use a default value. When receiving--- cookies from the server, a value of Nothing indicates that the server is unable--- to specify the value.-data Cookie = Cookie {- cookName :: Text- , cookValue :: Text -- ^- , cookPath :: Maybe Text -- ^path of this cookie.- -- if Nothing, defaults to /- , cookDomain :: Maybe Text -- ^domain of this cookie.- -- if Nothing, the current pages- -- domain is used- , cookSecure :: Maybe Bool -- ^Is this cookie secure?- , cookExpiry :: Maybe Double -- ^Expiry date expressed as- -- seconds since the Unix epoch- -- Nothing indicates that the- -- cookie never expires- } deriving (Eq, Show, Generic)--aesonOptionsCookie :: Options-aesonOptionsCookie = defaultOptions {- omitNothingFields = True- , fieldLabelModifier = map C.toLower . drop 4- }---- |Creates a Cookie with only a name and value specified. All other--- fields are set to Nothing, which tells the server to use default values.-mkCookie :: Text -> Text -> Cookie-mkCookie name value = Cookie { cookName = name, cookValue = value,- cookPath = Nothing, cookDomain = Nothing,- cookSecure = Nothing, cookExpiry = Nothing- }--instance ToJSON Cookie where- toJSON = genericToJSON aesonOptionsCookie- toEncoding = genericToEncoding aesonOptionsCookie-instance FromJSON Cookie where- parseJSON (Object o) = Cookie <$> req "name"- <*> req "value"- <*> opt "path" Nothing- <*> opt "domain" Nothing- <*> opt "secure" Nothing- <*> opt "expiry" Nothing- where- req :: FromJSON a => Text -> Parser a- req = (o .:) . fromText- opt :: FromJSON a => Text -> a -> Parser a- opt k d = o .:?? k .!= d- parseJSON v = typeMismatch "Cookie" v
src/Test/WebDriver/Exceptions.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-deriving-typeable #-} module Test.WebDriver.Exceptions ( InvalidURL(..)@@ -5,21 +7,113 @@ , BadJSON(..) , HTTPStatusUnknown(..)- , HTTPConnError(..) - , UnknownCommand(..) , ServerError(..) , FailedCommand(..)- , FailedCommandType(..)+ , FailedCommandError(..) - , FailedCommandInfo(..) , StackFrame(..)-- , mkFailedCommandInfo- , failedCommand ) where -import Test.WebDriver.Commands.Internal-import Test.WebDriver.Exceptions.Internal+import Control.Exception (Exception)+import Data.Aeson+import Data.Aeson.TH+import Data.Text (Text)+import Data.Typeable (Typeable)+import GHC.Stack+import Prelude -- hides some "unused import" warnings+import Test.WebDriver.Capabilities.Aeson import Test.WebDriver.JSON+import Test.WebDriver.Types+++-- | An invalid URL was given+newtype InvalidURL = InvalidURL String+ deriving (Eq, Show, Typeable)+instance Exception InvalidURL++-- | An unexpected HTTP status was sent by the server.+data HTTPStatusUnknown = HTTPStatusUnknown Int String+ deriving (Eq, Show, Typeable)+instance Exception HTTPStatusUnknown++-- | An unidentified server-side exception occured+newtype ServerError = ServerError String+ deriving (Eq, Show, Typeable)+instance Exception ServerError++data FailedCommandError =+ -- | The Element Click command could not be completed because the element receiving the events is obscuring the element that was requested clicked.+ ElementClickIntercepted+ -- | A command could not be completed because the element is not pointer- or keyboard interactable.+ | ElementNotInteractable+ -- | Navigation caused the user agent to hit a certificate warning, which is usually the result of an expired or invalid TLS certificate.+ | InsecureCertificate+ -- | The arguments passed to a command are either invalid or malformed.+ | InvalidArgument+ -- | An illegal attempt was made to set a cookie under a different domain than the current page.+ | InvalidCookieDomain+ -- | A command could not be completed because the element is in an invalid state, e.g. attempting to clear an element that isn't both editable and resettable.+ | InvalidElementState+ -- | Argument was an invalid selector.+ | InvalidSelector+ -- | Occurs if the given session id is not in the list of active sessions, meaning the session either does not exist or that it’s not active.+ | InvalidSessionId+ -- | An error occurred while executing JavaScript supplied by the user.+ | JavascriptError+ -- | The target for mouse interaction is not in the browser’s viewport and cannot be brought into that viewport.+ | MoveTargetOutOfBounds+ -- | An attempt was made to operate on a modal dialog when one was not open.+ | NoSuchAlert+ -- | No cookie matching the given path name was found amongst the associated cookies of the current browsing context’s active document.+ | NoSuchCookie+ -- | An element could not be located on the page using the given search parameters.+ | NoSuchElement+ -- | A command to switch to a frame could not be satisfied because the frame could not be found.+ | NoSuchFrame+ -- | A command to switch to a window could not be satisfied because the window could not be found.+ | NoSuchWindow+ -- | A script did not complete before its timeout expired.+ | ScriptTimeout+ -- | A new session could not be created.+ | SessionNotCreated+ -- | A command failed because the referenced element is no longer attached to the DOM.+ | StaleElementReference+ -- | An operation did not complete before its timeout expired.+ | Timeout+ -- | A command to set a cookie’s value could not be satisfied.+ | UnableToSetCookie+ -- | A screen capture was made impossible.+ | UnableToCaptureScreen+ -- | A modal dialog was open, blocking this operation.+ | UnexpectedAlertOpen+ -- | A command could not be executed because the remote end is not aware of it.+ | UnknownCommand+ -- | An unknown error occurred in the remote end while processing the command.+ | UnknownError+ -- | The requested command matched a known URL but did not match an method for that URL.+ | UnknownMethod+ -- | Indicates that a command that should have executed properly cannot be supported for some reason.+ | UnsupportedOperation+ -- | Some error string we weren't able to parse.+ | UnparsedError Text+ deriving (Show, Eq)+deriveFromJSON toSpacedC0 ''FailedCommandError+deriveToJSON toSpacedC0 ''FailedCommandError++-- | Internal type representing the JSON response object.+data FailedCommand = FailedCommand {+ rspError :: FailedCommandError+ , rspMessage :: Text+ , rspStacktrace :: Text+ , rspData :: Maybe Value+ } deriving (Eq, Show)+instance Exception FailedCommand+deriveFromJSON toCamel1 ''FailedCommand++-- | A command requiring a session ID was attempted when no session ID was+-- available.+data NoSessionId = NoSessionId String CallStack+ deriving (Show, Typeable)+instance Exception NoSessionId
− src/Test/WebDriver/Exceptions/Internal.hs
@@ -1,202 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ConstraintKinds #-}--module Test.WebDriver.Exceptions.Internal- ( InvalidURL(..), HTTPStatusUnknown(..), HTTPConnError(..)- , UnknownCommand(..), ServerError(..)-- , FailedCommand(..), failedCommand, mkFailedCommandInfo- , FailedCommandType(..), FailedCommandInfo(..), StackFrame(..)- , externalCallStack, callStackItemToStackFrame- ) where-import Test.WebDriver.Session-import Test.WebDriver.JSON--import Data.Aeson-import Data.Aeson.Types (Parser, typeMismatch)-import Data.ByteString.Lazy.Char8 (ByteString)-import Data.CallStack-import qualified Data.List as L-import Data.Text (Text)-import qualified Data.Text.Lazy.Encoding as TLE--import Control.Applicative-import Control.Exception (Exception)-import Control.Exception.Lifted (throwIO)--import Data.Maybe (fromMaybe, catMaybes)-import Data.Typeable (Typeable)--import Prelude -- hides some "unused import" warnings--instance Exception InvalidURL--- |An invalid URL was given-newtype InvalidURL = InvalidURL String- deriving (Eq, Show, Typeable)--instance Exception HTTPStatusUnknown--- |An unexpected HTTP status was sent by the server.-data HTTPStatusUnknown = HTTPStatusUnknown Int String- deriving (Eq, Show, Typeable)--instance Exception HTTPConnError--- |HTTP connection errors.-data HTTPConnError = HTTPConnError String Int- deriving (Eq, Show, Typeable)--instance Exception UnknownCommand--- |A command was sent to the WebDriver server that it didn't recognize.-newtype UnknownCommand = UnknownCommand String- deriving (Eq, Show, Typeable)--instance Exception ServerError--- |A server-side exception occured-newtype ServerError = ServerError String- deriving (Eq, Show, Typeable)--instance Exception FailedCommand--- |This exception encapsulates a broad variety of exceptions that can--- occur when a command fails.-data FailedCommand = FailedCommand FailedCommandType FailedCommandInfo- deriving (Show, Typeable)---- |The type of failed command exception that occured.-data FailedCommandType = NoSuchElement- | NoSuchFrame- | UnknownFrame- | StaleElementReference- | ElementNotVisible- | InvalidElementState- | UnknownError- | ElementIsNotSelectable- | JavascriptError- | XPathLookupError- | Timeout- | NoSuchWindow- | InvalidCookieDomain- | UnableToSetCookie- | UnexpectedAlertOpen- | NoAlertOpen- | ScriptTimeout- | InvalidElementCoordinates- | IMENotAvailable- | IMEEngineActivationFailed- | InvalidSelector- | SessionNotCreated- | MoveTargetOutOfBounds- | InvalidXPathSelector- | InvalidXPathSelectorReturnType- deriving (Eq, Ord, Enum, Bounded, Show)---- |Detailed information about the failed command provided by the server.-data FailedCommandInfo =- FailedCommandInfo { -- |The error message.- errMsg :: String- -- |The session associated with- -- the exception.- , errSess :: Maybe WDSession- -- |A screen shot of the focused window- -- when the exception occured,- -- if provided.- , errScreen :: Maybe ByteString- -- |The "class" in which the exception- -- was raised, if provided.- , errClass :: Maybe String- -- |A stack trace of the exception.- , errStack :: [StackFrame]- }---- |Provides a readable printout of the error information, useful for--- logging.-instance Show FailedCommandInfo where- show i = showChar '\n'- . showString "Session: " . sess- . showChar '\n'- . showString className . showString ": " . showString (errMsg i)- . showChar '\n'- . foldl (\f s-> f . showString " " . shows s) id (errStack i)- $ ""- where- className = fromMaybe "<unknown exception>" . errClass $ i-- sess = case errSess i of- Nothing -> showString "None"- Just WDSession{..} ->- let sessId = maybe "<no session id>" show wdSessId- in showString sessId . showString " at "- . shows wdSessHost . showChar ':' . shows wdSessPort----- |Constructs a FailedCommandInfo from only an error message.-mkFailedCommandInfo :: (WDSessionState s) => String -> CallStack -> s FailedCommandInfo-mkFailedCommandInfo m cs = do- sess <- getSession- return $ FailedCommandInfo { errMsg = m- , errSess = Just sess- , errScreen = Nothing- , errClass = Nothing- , errStack = fmap callStackItemToStackFrame cs }---- |Use GHC's CallStack capabilities to return a callstack to help debug a FailedCommand.--- Drops all stack frames inside Test.WebDriver modules, so the first frame on the stack--- should be where the user called into Test.WebDriver-externalCallStack :: (HasCallStack) => CallStack-externalCallStack = dropWhile isWebDriverFrame callStack- where isWebDriverFrame :: ([Char], SrcLoc) -> Bool- isWebDriverFrame (_, SrcLoc {srcLocModule}) = "Test.WebDriver" `L.isPrefixOf` srcLocModule---- |Convenience function to throw a 'FailedCommand' locally with no server-side--- info present.-failedCommand :: (HasCallStack, WDSessionStateIO s) => FailedCommandType -> String -> s a-failedCommand t m = do- throwIO . FailedCommand t =<< mkFailedCommandInfo m externalCallStack---- |An individual stack frame from the stack trace provided by the server--- during a FailedCommand.-data StackFrame = StackFrame { sfFileName :: String- , sfClassName :: String- , sfMethodName :: String- , sfLineNumber :: Int- }- deriving (Eq)---instance Show StackFrame where- show f = showString (sfClassName f) . showChar '.'- . showString (sfMethodName f) . showChar ' '- . showParen True ( showString (sfFileName f) . showChar ':'- . shows (sfLineNumber f))- $ "\n"---instance FromJSON FailedCommandInfo where- parseJSON (Object o) =- FailedCommandInfo <$> (req "message" >>= maybe (return "") return)- <*> pure Nothing- <*> (fmap TLE.encodeUtf8 <$> opt "screen" Nothing)- <*> opt "class" Nothing- <*> (catMaybes <$> opt "stackTrace" [])- where req :: FromJSON a => Text -> Parser a- req = (o .:) . fromText --required key- opt :: FromJSON a => Text -> a -> Parser a- opt k d = o .:?? k .!= d --optional key- parseJSON v = typeMismatch "FailedCommandInfo" v--instance FromJSON StackFrame where- parseJSON (Object o) = StackFrame <$> reqStr "fileName"- <*> reqStr "className"- <*> reqStr "methodName"- <*> req "lineNumber"- where req :: FromJSON a => Text -> Parser a- req = (o .:) . fromText -- all keys are required- reqStr :: Text -> Parser String- reqStr k = req k >>= maybe (return "") return- parseJSON v = typeMismatch "StackFrame" v---callStackItemToStackFrame :: (String, SrcLoc) -> StackFrame-callStackItemToStackFrame (functionName, SrcLoc {..}) = StackFrame { sfFileName = srcLocFile- , sfClassName = srcLocModule- , sfMethodName = functionName- , sfLineNumber = srcLocStartLine- }
− src/Test/WebDriver/Firefox/Profile.hs
@@ -1,243 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# 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- ( -- * Profiles- Firefox, Profile(..), PreparedProfile- , defaultProfile- -- * Preferences- , ProfilePref(..), ToPref(..)- , addPref, getPref, deletePref- -- * Extensions- , addExtension, deleteExtension, hasExtension- -- * Other files and directories- , addFile, deleteFile, hasFile- -- * Miscellaneous profile operations- , unionProfiles, onProfileFiles, onProfilePrefs- -- * Loading and preparing profiles- , prepareProfile, prepareTempProfile- -- ** Preparing profiles from disk- , loadProfile, prepareLoadedProfile, prepareLoadedProfile_- -- ** Preparing zip archives- , prepareZippedProfile, prepareZipArchive, prepareRawZip- -- ** Preferences parsing error- , ProfileParseError(..)- ) where-import Test.WebDriver.Common.Profile-import Data.Aeson (Result(..), encode, fromJSON)-import Data.Aeson.Parser (jstring, value')-import Data.Attoparsec.ByteString.Char8 as AP-import qualified Data.HashMap.Strict as HM-import Data.Text (Text)-import Data.ByteString as BS (readFile)-import qualified Data.ByteString.Lazy.Char8 as LBS--import System.FilePath hiding (addExtension, hasExtension)-import System.Directory-import System.IO.Temp (createTempDirectory)-import qualified System.Directory.Tree as DS--import Control.Monad-import Control.Monad.Base-import Control.Monad.Trans.Control-import Control.Exception.Lifted hiding (try)-import Control.Applicative-import Control.Arrow--#if !MIN_VERSION_base(4,6,0) || defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706-import Prelude hiding (catch)-#endif---- |Phantom type used in the parameters of 'Profile' and 'PreparedProfile'-data Firefox---- |Default Firefox Profile, used when no profile is supplied.-defaultProfile :: Profile Firefox-defaultProfile =- Profile HM.empty- $ HM.fromList [("app.update.auto", PrefBool False)- ,("app.update.enabled", PrefBool False)- ,("browser.startup.page" , PrefInteger 0)- ,("browser.download.manager.showWhenStarting", PrefBool False)- ,("browser.EULA.override", PrefBool True)- ,("browser.EULA.3.accepted", PrefBool True)- ,("browser.link.open_external", PrefInteger 2)- ,("browser.link.open_newwindow", PrefInteger 2)- ,("browser.offline", PrefBool False)- ,("browser.safebrowsing.enabled", PrefBool False)- ,("browser.search.update", PrefBool False)- ,("browser.sessionstore.resume_from_crash", PrefBool False)- ,("browser.shell.checkDefaultBrowser", PrefBool False)- ,("browser.tabs.warnOnClose", PrefBool False)- ,("browser.tabs.warnOnOpen", PrefBool False)- ,("browser.startup.page", PrefInteger 0)- ,("browser.safebrowsing.malware.enabled", PrefBool False)- ,("startup.homepage_welcome_url", PrefString "about:blank")- ,("devtools.errorconsole.enabled", PrefBool True)- ,("focusmanager.testmode", PrefBool True)- ,("dom.disable_open_during_load", PrefBool False)- ,("extensions.autoDisableScopes" , PrefInteger 10)- ,("extensions.logging.enabled", PrefBool True)- ,("extensions.update.enabled", PrefBool False)- ,("extensions.update.notifyUser", PrefBool False)- ,("network.manage-offline-status", PrefBool False)- ,("network.http.max-connections-per-server", PrefInteger 10)- ,("network.http.phishy-userpass-length", PrefInteger 255)- ,("offline-apps.allow_by_default", PrefBool True)- ,("prompts.tab_modal.enabled", PrefBool False)- ,("security.fileuri.origin_policy", PrefInteger 3)- ,("security.fileuri.strict_origin_policy", PrefBool False)- ,("security.warn_entering_secure", PrefBool False)- ,("security.warn_submit_insecure", PrefBool False)- ,("security.warn_entering_secure.show_once", PrefBool False)- ,("security.warn_entering_weak", PrefBool False)- ,("security.warn_entering_weak.show_once", PrefBool False)- ,("security.warn_leaving_secure", PrefBool False)- ,("security.warn_leaving_secure.show_once", PrefBool False)- ,("security.warn_submit_insecure", PrefBool False)- ,("security.warn_viewing_mixed", PrefBool False)- ,("security.warn_viewing_mixed.show_once", PrefBool False)- ,("signon.rememberSignons", PrefBool False)- ,("toolkit.networkmanager.disable", PrefBool True)- ,("toolkit.telemetry.enabled", PrefBool False)- ,("toolkit.telemetry.prompted", PrefInteger 2)- ,("toolkit.telemetry.rejected", PrefBool True)- ,("javascript.options.showInConsole", PrefBool True)- ,("browser.dom.window.dump.enabled", PrefBool True)- ,("webdriver_accept_untrusted_certs", PrefBool True)- ,("webdriver_enable_native_events", native_events)- ,("webdriver_assume_untrusted_issuer", PrefBool True)- ,("dom.max_script_run_time", PrefInteger 30)- ]- where-#ifdef darwin_HOST_OS- native_events = PrefBool False-#else- native_events = PrefBool True-#endif----- |Load an existing profile from the file system. Any prepared changes made to--- 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--- 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`- [".", "..", "OfflineCache", "Cache"- ,"parent.lock", ".parentlock", ".lock"- ,userPrefFile])-- getPrefs = do- prefFileExists <- doesFileExist userPrefFile- if prefFileExists- then HM.fromList <$> (parsePrefs =<< BS.readFile userPrefFile)- else return HM.empty- 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--- data. The temporary directory is deleted afterwards.------ 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--- 'prepareZippedProfile' instead.-prepareProfile :: MonadBaseControl IO m =>- Profile Firefox -> m (PreparedProfile Firefox)-prepareProfile Profile {profileFiles = files, profilePrefs = prefs}- = liftBase $ do- tmpdir <- mkTemp- mapM_ (installPath tmpdir) . HM.toList $ files- installUserPrefs tmpdir- prepareLoadedProfile_ tmpdir--- <* removeDirectoryRecursive tmpdir- where- installPath destDir (destPath, src) = do- let dest = destDir </> destPath- isDir <- doesDirectoryExist src- if isDir- then do- createDirectoryIfMissing True dest `catch` ignoreIOException- (_ DS.:/ dir) <- DS.readDirectoryWithL LBS.readFile src- handle ignoreIOException . void- $ DS.writeDirectoryWith LBS.writeFile (dest DS.:/ dir)- else do- let dir = takeDirectory dest- when (not . null $ dir) $- createDirectoryIfMissing True dir `catch` ignoreIOException- copyFile src dest `catch` ignoreIOException- where- ignoreIOException :: IOException -> IO ()- 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---- |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)- -> m (PreparedProfile Firefox)-prepareTempProfile f = prepareProfile . f $ defaultProfile---- |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- -> (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- void . padSpaces $ string "user_pref("- k <- prefKey <?> "preference key"- void . padSpaces $ char ','- v <- prefVal <?> "preference value"- void . padSpaces $ string ");"- return (k,v)- where- prefKey = jstring- 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)- where- comment = inlineComment <|> lineComment- lineComment = char '#' *> manyTill anyChar endOfLine- inlineComment = string "/*" *> manyTill anyChar (string "*/")---mkTemp :: IO FilePath-mkTemp = do- d <- getTemporaryDirectory- createTempDirectory d ""
− src/Test/WebDriver/IO.hs
@@ -1,17 +0,0 @@--module Test.WebDriver.IO where--import Control.Concurrent (threadDelay)-import Control.Monad.IO.Class (liftIO, MonadIO)-import Test.WebDriver-import Test.WebDriver.Class (WebDriver)---sleepIO :: Double -> IO ()-sleepIO seconds = Control.Concurrent.threadDelay (round (seconds * 1e6))--sleepWD :: (MonadIO wd, WebDriver wd) => Double -> wd ()-sleepWD = liftIO . sleepIO--printWD :: Show s => s -> WD ()-printWD = liftIO . print
− src/Test/WebDriver/Internal.hs
@@ -1,232 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE CPP #-}---- | The HTTP/JSON plumbing used to implement the 'WD' monad.------ These functions can be used to create your own 'WebDriver' instances, providing extra functionality for your application if desired. All exports--- of this module are subject to change at any point.-module Test.WebDriver.Internal- ( mkRequest, sendHTTPRequest- , getJSONResult, handleJSONErr, handleRespSessionId- , WDResponse(..)- ) where-import Test.WebDriver.Class-import Test.WebDriver.JSON-import Test.WebDriver.Session-import Test.WebDriver.Exceptions.Internal--import Network.HTTP.Client (httpLbs, Request(..), RequestBody(..), Response(..))-import qualified Network.HTTP.Client as HTTPClient--import Data.Aeson-import Data.Aeson.Types (typeMismatch)-import Network.HTTP.Types.Header-import Network.HTTP.Types.Status (Status(..))--import qualified Data.ByteString.Base64.Lazy as B64-import qualified Data.ByteString.Char8 as BS-import Data.ByteString.Lazy.Char8 (ByteString)-import Data.ByteString.Lazy.Char8 as LBS (unpack, null)-import qualified Data.ByteString.Lazy.Internal as LBS (ByteString(..))-import Data.CallStack-import Data.Text as T (Text, splitOn, null)-import qualified Data.Text.Encoding as TE--import Control.Applicative-import Control.Exception (Exception, SomeException(..), toException, fromException, try)-import Control.Exception.Lifted (throwIO)-import Control.Monad.Base--import Data.String (fromString)-import Data.Word (Word8)--#if !MIN_VERSION_http_client(0,4,30)-import Data.Default (def)-#endif--import Prelude -- hides some "unused import" warnings----This is the defintion of fromStrict used by bytestring >= 0.10; we redefine it here to support bytestring < 0.10-fromStrict :: BS.ByteString -> LBS.ByteString-fromStrict bs | BS.null bs = LBS.Empty- | otherwise = LBS.Chunk bs LBS.Empty-----Compatability function to support http-client < 0.4.30-defaultRequest :: Request-#if MIN_VERSION_http_client(0,4,30)-defaultRequest = HTTPClient.defaultRequest-#else-defaultRequest = def-#endif---- |Constructs an HTTP 'Request' value when given a list of headers, HTTP request method, and URL fragment-mkRequest :: (WDSessionState s, ToJSON a) =>- Method -> Text -> a -> s Request-mkRequest meth wdPath args = do- WDSession {..} <- getSession- let body = case toJSON args of- Null -> "" --passing Null as the argument indicates no request body- other -> encode other- return defaultRequest- { host = wdSessHost- , port = wdSessPort- , path = wdSessBasePath `BS.append` TE.encodeUtf8 wdPath- , requestBody = RequestBodyLBS body- , requestHeaders = wdSessRequestHeaders- ++ [ (hAccept, "application/json;charset=UTF-8")- , (hContentType, "application/json;charset=UTF-8") ]- , method = meth-#if !MIN_VERSION_http_client(0,5,0)- , checkStatus = \_ _ _ -> Nothing-#endif- }---- |Sends an HTTP request to the remote WebDriver server-sendHTTPRequest :: (WDSessionStateIO s) => Request -> s (Either SomeException (Response ByteString))-sendHTTPRequest req = do- s@WDSession{..} <- getSession- (nRetries, tryRes) <- liftBase . retryOnTimeout wdSessHTTPRetryCount $ httpLbs req wdSessHTTPManager- let h = SessionHistory { histRequest = req- , histResponse = tryRes- , histRetryCount = nRetries- }- putSession s { wdSessHist = wdSessHistUpdate h wdSessHist }- return tryRes--retryOnTimeout :: Int -> IO a -> IO (Int, (Either SomeException a))-retryOnTimeout maxRetry go = retry' 0- where- retry' nRetries = do- eitherV <- try go- case eitherV of- (Left e)-#if MIN_VERSION_http_client(0,5,0)- | Just (HTTPClient.HttpExceptionRequest _ HTTPClient.ResponseTimeout) <- fromException e-#else- | Just HTTPClient.ResponseTimeout <- fromException e-#endif- , maxRetry > nRetries- -> retry' (succ nRetries)- other -> return (nRetries, other)---- |Parses a 'WDResponse' object from a given HTTP response.-getJSONResult :: (HasCallStack, WDSessionStateControl s, FromJSON a) => Response ByteString -> s (Either SomeException a)-getJSONResult r- --malformed request errors- | code >= 400 && code < 500 = do- lastReq <- mostRecentHTTPRequest <$> getSession- returnErr . UnknownCommand . maybe reason show $ lastReq- --server-side errors- | code >= 500 && code < 600 =- case lookup hContentType headers of- Just ct- | "application/json" `BS.isInfixOf` ct ->- parseJSON'- (maybe body fromStrict $ lookup "X-Response-Body-Start" headers)- >>= handleJSONErr- >>= maybe returnNull returnErr- | otherwise ->- returnHTTPErr ServerError- Nothing ->- returnHTTPErr (ServerError . ("HTTP response missing content type. Server reason was: "++))- --redirect case (used as a response to createSession requests)- | code == 302 || code == 303 =- case lookup hLocation headers of- Nothing -> returnErr . HTTPStatusUnknown code $ LBS.unpack body- Just loc -> do- let sessId = last . filter (not . T.null) . splitOn "/" . fromString $ BS.unpack loc- modifySession $ \sess -> sess {wdSessId = Just (SessionId sessId)}- returnNull- -- No Content response- | code == 204 = returnNull- -- HTTP Success- | code >= 200 && code < 300 =- if LBS.null body- then returnNull- else do- rsp@WDResponse {rspVal = val} <- parseJSON' body- handleJSONErr rsp >>= maybe- (handleRespSessionId rsp >> Right <$> fromJSON' val)- returnErr- -- other status codes: return error- | otherwise = returnHTTPErr (HTTPStatusUnknown code)- where- --helper functions- returnErr :: (Exception e, Monad m) => e -> m (Either SomeException a)- returnErr = return . Left . toException- returnHTTPErr errType = returnErr . errType $ reason- returnNull = Right <$> fromJSON' Null- --HTTP response variables- code = statusCode status- reason = BS.unpack $ statusMessage status- status = responseStatus r- body = responseBody r- headers = responseHeaders r--handleRespSessionId :: (HasCallStack, WDSessionStateIO s) => WDResponse -> s ()-handleRespSessionId WDResponse{rspSessId = sessId'} = do- sess@WDSession { wdSessId = sessId} <- getSession- 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 ++ ")"- _ -> return ()--handleJSONErr :: (HasCallStack, WDSessionStateControl s) => WDResponse -> s (Maybe SomeException)-handleJSONErr WDResponse{rspStatus = 0} = return Nothing-handleJSONErr WDResponse{rspVal = val, rspStatus = status} = do- sess <- getSession- errInfo <- fromJSON' val- let screen = B64.decodeLenient <$> errScreen errInfo- seleniumStack = errStack errInfo- errInfo' = errInfo { errSess = Just sess- -- Append the Haskell stack frames to the ones returned from Selenium- , errScreen = screen- , errStack = seleniumStack ++ (fmap callStackItemToStackFrame externalCallStack) }- e errType = toException $ FailedCommand errType errInfo'- return . Just $ case status of- 7 -> e NoSuchElement- 8 -> e NoSuchFrame- 9 -> toException . UnknownCommand . errMsg $ errInfo- 10 -> e StaleElementReference- 11 -> e ElementNotVisible- 12 -> e InvalidElementState- 13 -> e UnknownError- 15 -> e ElementIsNotSelectable- 17 -> e JavascriptError- 19 -> e XPathLookupError- 21 -> e Timeout- 23 -> e NoSuchWindow- 24 -> e InvalidCookieDomain- 25 -> e UnableToSetCookie- 26 -> e UnexpectedAlertOpen- 27 -> e NoAlertOpen- 28 -> e ScriptTimeout- 29 -> e InvalidElementCoordinates- 30 -> e IMENotAvailable- 31 -> e IMEEngineActivationFailed- 32 -> e InvalidSelector- 33 -> e SessionNotCreated- 34 -> e MoveTargetOutOfBounds- 51 -> e InvalidXPathSelector- 52 -> e InvalidXPathSelectorReturnType- _ -> e UnknownError----- |Internal type representing the JSON response object-data WDResponse = WDResponse {- rspSessId :: Maybe SessionId- , rspStatus :: Word8- , rspVal :: Value- }- deriving (Eq, Show)--instance FromJSON WDResponse where- parseJSON (Object o) = WDResponse <$> o .:?? "sessionId" .!= Nothing- <*> o .: "status"- <*> o .:?? "value" .!= Null- parseJSON v = typeMismatch "WDResponse" v
src/Test/WebDriver/JSON.hs view
@@ -1,55 +1,67 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-deriving-typeable #-} --- |A collection of convenience functions for using and parsing JSON values+-- | 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- ( -- * Access a JSON object key- (!:), (.:??)- -- * Conversion from JSON within WD- -- |Apostrophes are used to disambiguate these functions- -- from their "Data.Aeson" counterparts.- , parseJSON', fromJSON'- -- * Tuple functions- -- |Convenience functions for working with tuples.+module Test.WebDriver.JSON (+ -- * Access a JSON object key+ (!:)+ , (.:??) - -- ** JSON object constructors- , single, pair, triple- -- ** Extracting JSON objects into tuples- , parsePair, parseTriple- -- * Conversion from parser results to WD- -- |These functions are used to implement the other functions- -- in this module, and could be used to implement other JSON- -- convenience functions- , apResultToWD, aesonResultToWD- -- * Parse exception- , BadJSON(..)- -- * parsing commands with no return value- , NoReturn(..), noReturn, ignoreReturn+ -- * Conversion from JSON within WD+ -- | Apostrophes are used to disambiguate these functions+ -- from their "Data.Aeson" counterparts.+ , parseJSON'+ , fromJSON' - , fromText- ) where-import Test.WebDriver.Class (WebDriver)+ -- * Tuple functions+ -- | Convenience functions for working with tuples.+ -- ** JSON object constructors+ , single+ , pair+ , triple+ -- ** Extracting JSON objects into tuples+ , parseTriple + -- * Conversion from parser results to WD+ -- | These functions are used to implement the other functions+ -- in this module, and could be used to implement other JSON+ -- convenience functions+ , apResultToWD+ , aesonResultToWD++ -- * Parse exception+ , BadJSON(..)++ -- * parsing commands with no return value+ , noReturn+ , ignoreReturn+ , aesonKeyFromText+ , NoReturn(..)++ -- * JSON helpers+ , noObject+ ) where++import Control.Applicative+import Control.Monad (join, void)+import Control.Monad.IO.Class import Data.Aeson as Aeson import Data.Aeson.Types-import Data.Text (Text)-import Data.ByteString.Lazy.Char8 (ByteString) import Data.Attoparsec.ByteString.Lazy (Result(..)) import qualified Data.Attoparsec.ByteString.Lazy as AP--import Control.Monad (join, void)-import Control.Applicative-import Control.Monad.Trans.Control-import Control.Exception.Lifted+import Data.ByteString.Lazy.Char8 (ByteString) import Data.String-import Data.Typeable-+import Data.Text (Text) import Prelude -- hides some "unused import" warnings+import Test.WebDriver.Types (WebDriver)+import Test.WebDriver.Util.Aeson (aesonKeyFromText)+import UnliftIO.Exception #if MIN_VERSION_aeson(2,2,0) -- This comes from the attoparsec-aeson package@@ -57,24 +69,18 @@ #endif #if MIN_VERSION_aeson(2,0,0)-import qualified Data.Aeson.Key as A import qualified Data.Aeson.KeyMap as HM-fromText :: Text -> A.Key-fromText = A.fromText #else import qualified Data.HashMap.Strict as HM-fromText :: Text -> Text-fromText = id #endif -instance Exception BadJSON--- |An error occured when parsing a JSON value.+-- | An error occured when parsing a JSON value. newtype BadJSON = BadJSON String- deriving (Eq, Show, Typeable)-+ deriving (Eq, Show, Typeable)+instance Exception BadJSON --- |A type indicating that we expect no return value from the webdriver request.+-- | A type indicating that we expect no return value from the webdriver request. -- Its FromJSON instance parses successfully for any values that indicate lack of -- a return value (a notion that varies from server to server). data NoReturn = NoReturn@@ -85,68 +91,55 @@ parseJSON (String "") = return NoReturn parseJSON other = typeMismatch "no return value" other --- |Convenience function to handle webdriver commands with no return value.-noReturn :: WebDriver wd => wd NoReturn -> wd ()+instance ToJSON NoReturn where+ toJSON NoReturn = Aeson.String "<no return>"++-- | Convenience function to handle webdriver commands with no return value.+noReturn :: WebDriver m => m NoReturn -> m () noReturn = void --- |Convenience function to ignore result of a webdriver command.-ignoreReturn :: WebDriver wd => wd Value -> wd ()+-- | Convenience function to ignore result of a webdriver command.+ignoreReturn :: WebDriver m => m Value -> m () ignoreReturn = void ---- |Construct a singleton JSON 'object' from a key and value.+-- | Construct a singleton JSON 'object' from a key and value. single :: ToJSON a => Text -> a -> Value-single a x = object [(fromText a) .= x]+single a x = object [aesonKeyFromText a .= x] --- |Construct a 2-element JSON 'object' from a pair of keys and a pair of+-- | 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 [fromText a .= x, fromText b .= y]+pair :: (ToJSON a, ToJSON b) => (Text, Text) -> (a, b) -> Value+pair (a, b) (x,y) = object [aesonKeyFromText a .= x, aesonKeyFromText b .= y] --- |Construct a 3-element JSON 'object' from a triple of keys and a triple of+-- | Construct a 3-element JSON 'object' from a triple of keys and a triple of -- values.-triple :: (ToJSON a, ToJSON b, ToJSON c) =>- (Text,Text,Text) -> (a,b,c) -> Value-triple (a,b,c) (x,y,z) = object [fromText a .= x, fromText b.= y, fromText c .= z]-+triple :: (ToJSON a, ToJSON b, ToJSON c) => (Text, Text, Text) -> (a, b, c) -> Value+triple (a, b, c) (x, y, z) = object [aesonKeyFromText a .= x, aesonKeyFromText b.= y, aesonKeyFromText c .= z] --- |Parse a lazy 'ByteString' as a top-level JSON 'Value', then convert it to an+-- | Parse a lazy 'ByteString' as a top-level JSON 'Value', then convert it to an -- instance of 'FromJSON'..-parseJSON' :: MonadBaseControl IO wd => FromJSON a => ByteString -> wd a+parseJSON' :: MonadIO m => FromJSON a => ByteString -> m a parseJSON' = apResultToWD . AP.parse json --- |Convert a JSON 'Value' to an instance of 'FromJSON'.-fromJSON' :: MonadBaseControl IO wd => FromJSON a => Value -> wd a+-- | Convert a JSON 'Value' to an instance of 'FromJSON'.+fromJSON' :: MonadIO m => FromJSON a => Value -> m a fromJSON' = aesonResultToWD . fromJSON --- |This operator is a wrapper over Aeson's '.:' operator.-(!:) :: (MonadBaseControl IO wd, FromJSON a) => Object -> Text -> wd a-o !: k = aesonResultToWD $ parse (.: fromText k) o+-- | This operator is a wrapper over Aeson's '.:' operator.+(!:) :: (MonadIO m, FromJSON a) => Object -> Text -> m a+o !: k = aesonResultToWD $ parse (.: aesonKeyFromText k) o --- |Due to a breaking change in the '.:?' operator of aeson 0.10 (see <https://github.com/bos/aeson/issues/287>) that was subsequently reverted, this operator+-- | Due to a breaking change in the '.:?' operator of aeson 0.10 (see <https://github.com/bos/aeson/issues/287>) that was subsequently reverted, this operator -- was added to provide consistent behavior compatible with all aeson versions. If the field is either missing or `Null`, this operator should return a `Nothing` result. (.:??) :: FromJSON a => Object -> Text -> Parser (Maybe a)-o .:?? k = fmap join (o .:? fromText k)----- |Parse a JSON 'Object' as a pair. The first two string arguments specify the--- keys to extract from the object. The third string is the name of the--- calling function, for better error reporting.-parsePair :: (MonadBaseControl IO wd, FromJSON a, FromJSON b) =>- String -> String -> String -> Value -> wd (a, b)-parsePair a b funcName v =- case v of- Object o -> (,) <$> o !: fromString a <*> o !: fromString b- _ -> throwIO . BadJSON $ funcName ++- ": cannot parse non-object JSON response as a (" ++ a- ++ ", " ++ b ++ ") pair" ++ ")"-+o .:?? k = fmap join (o .:? aesonKeyFromText k) --- |Parse a JSON Object as a triple. The first three string arguments+-- | Parse a JSON Object as a triple. The first three string arguments -- specify the keys to extract from the object. The fourth string is the name -- of the calling function, for better error reporting.-parseTriple :: (MonadBaseControl IO wd, FromJSON a, FromJSON b, FromJSON c) =>- String -> String -> String -> String -> Value -> wd (a, b, c)+parseTriple :: (+ MonadIO m, FromJSON a, FromJSON b, FromJSON c+ ) => String -> String -> String -> String -> Value -> m (a, b, c) parseTriple a b c funcName v = case v of Object o -> (,,) <$> o !: fromString a@@ -156,16 +149,18 @@ ": cannot parse non-object JSON response as a (" ++ a ++ ", " ++ b ++ ", " ++ c ++ ") pair" ----- |Convert an attoparsec parser result to 'WD'.-apResultToWD :: (MonadBaseControl IO wd, FromJSON a) => AP.Result Value -> wd a+-- | Convert an attoparsec parser result to 'WD'.+apResultToWD :: (MonadIO m, FromJSON a) => AP.Result Value -> m a apResultToWD p = case p of Done _ res -> fromJSON' res Fail _ _ err -> throwIO $ BadJSON err --- |Convert an Aeson parser result to 'WD'.-aesonResultToWD :: (MonadBaseControl IO wd) => Aeson.Result a -> wd a+-- | Convert an Aeson parser result to 'WD'.+aesonResultToWD :: (MonadIO m) => Aeson.Result a -> m a aesonResultToWD r = case r of Success val -> return val- Error err -> throwIO $ BadJSON err+ Error err -> throwIO $ BadJSON err++-- Selenium 3.x doesn't seem to like receiving Null for click parameter+noObject :: Value+noObject = Object mempty
+ src/Test/WebDriver/Keys.hs view
@@ -0,0 +1,201 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++-- | This module contains named constants corresponding to the special characters recognized by 'sendKeys'.+-- See https://www.w3.org/TR/webdriver2/#keyboard-actions.+module Test.WebDriver.Keys where++import Data.Text (Text)+import Test.WebDriver.Commands (sendKeys)+++add :: Text+add = "\xe025"++alt :: Text+alt = "\xe00a"++arrowDown :: Text+arrowDown = "\xe015"++arrowLeft :: Text+arrowLeft = "\xe012"++arrowRight :: Text+arrowRight = "\xe014"++arrowUp :: Text+arrowUp = "\xe013"++backspace :: Text+backspace = "\xe003"++backSpace :: Text+backSpace = "\xe003"++cancel :: Text+cancel = "\xe001"++clear :: Text+clear = "\xe005"++command :: Text+command = "\xe03d"++control :: Text+control = "\xe009"++decimal :: Text+decimal = "\xe028"++delete :: Text+delete = "\xe017"++divide :: Text+divide = "\xe029"++down :: Text+down = "\xe015"++end :: Text+end = "\xe010"++enter :: Text+enter = "\xe007"++equals :: Text+equals = "\xe019"++escape :: Text+escape = "\xe00c"++f1 :: Text+f1 = "\xe031"++f2 :: Text+f2 = "\xe032"++f3 :: Text+f3 = "\xe033"++f4 :: Text+f4 = "\xe034"++f5 :: Text+f5 = "\xe035"++f6 :: Text+f6 = "\xe036"++f7 :: Text+f7 = "\xe037"++f8 :: Text+f8 = "\xe038"++f9 :: Text+f9 = "\xe039"++f10 :: Text+f10 = "\xe03a"++f11 :: Text+f11 = "\xe03b"++f12 :: Text+f12 = "\xe03c"++help :: Text+help = "\xe002"++home :: Text+home = "\xe011"++insert :: Text+insert = "\xe016"++left :: Text+left = "\xe012"++leftAlt :: Text+leftAlt = "\xe00a"++leftControl :: Text+leftControl = "\xe009"++leftShift :: Text+leftShift = "\xe008"++meta :: Text+meta = "\xe03d"++multiply :: Text+multiply = "\xe024"++null :: Text+null = "\xe000"++numpad0 :: Text+numpad0 = "\xe01a"++numpad1 :: Text+numpad1 = "\xe01b"++numpad2 :: Text+numpad2 = "\xe01c"++numpad3 :: Text+numpad3 = "\xe01d"++numpad4 :: Text+numpad4 = "\xe01e"++numpad5 :: Text+numpad5 = "\xe01f"++numpad6 :: Text+numpad6 = "\xe020"++numpad7 :: Text+numpad7 = "\xe021"++numpad8 :: Text+numpad8 = "\xe022"++numpad9 :: Text+numpad9 = "\xe023"++pageDown :: Text+pageDown = "\xe00f"++pageUp :: Text+pageUp = "\xe00e"++pause :: Text+pause = "\xe00b"++returnKey :: Text+returnKey = "\xe006"++right :: Text+right = "\xe014"++semicolon :: Text+semicolon = "\xe018"++separator :: Text+separator = "\xe026"++shift :: Text+shift = "\xe008"++space :: Text+space = "\xe00d"++subtract :: Text+subtract = "\xe027"++tab :: Text+tab = "\xe004"++up :: Text+up = "\xe013"
+ src/Test/WebDriver/LaunchDriver.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ViewPatterns #-}++module Test.WebDriver.LaunchDriver (+ launchDriver+ , teardownDriver+ , mkDriverRequest+ ) where++import Control.Monad+import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Retry+import Data.Aeson+import qualified Data.ByteString.Char8 as BS+import Data.Function+import qualified Data.List as L+import Data.Maybe+import Data.String.Interpolate+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.IO as T+import Data.Time+import Network.HTTP.Client+import Network.HTTP.Types (hAccept, hContentType, statusCode)+import Network.Socket+import System.FilePath+import System.IO+import Test.WebDriver.Types+import Test.WebDriver.Util.Ports+import Test.WebDriver.Util.Sockets+import Text.Read (readMaybe)+import UnliftIO.Async+import UnliftIO.Environment+import UnliftIO.Exception+import UnliftIO.Process+import UnliftIO.Timeout+++launchDriver :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => DriverConfig -> m Driver+launchDriver driverConfig = do+ manager <- liftIO $ newManager defaultManagerSettings+ let requestHeaders = mempty++ port <- findFreePortOrException++ (programName, args, maybeEnv) <- getArguments port driverConfig+ logDebugN [i|#{programName} #{T.unwords $ fmap T.pack args}|]++ (hRead, hWrite) <- createPipe++ envToUse <- case maybeEnv of+ Nothing -> pure Nothing+ Just extraEnv -> do+ env <- getEnvironment+ return $ Just (extraEnv <> env)++ let cp = (proc programName args) {+ create_group = True+ , std_out = UseHandle hWrite+ , std_err = UseHandle hWrite+ , env = envToUse+ }++ (_, _, _, p) <- createProcess cp++ let hostname = "localhost"++ maybeLogFileHandle <- case driverConfigLogDir driverConfig of+ Nothing -> return Nothing+ Just logDir -> do+ (logFilePath, logFileHandle) <- liftIO $ openTempFile logDir ((driverBaseName driverConfig) <> ".log")+ logDebugN [i|Logging driver output to #{logFilePath}|]+ return $ Just logFileHandle++ let handler (e :: SomeException) = do+ terminateProcess p+ now <- liftIO getCurrentTime+ whenJust maybeLogFileHandle $ \logFileHandle -> do+ liftIO (T.hPutStrLn logFileHandle [i|(#{now}) haskell-webdriver: process ending with exception: #{e}|])+ liftIO (hClose logFileHandle)++ flip withException handler $ do+ -- Read from the (combined) output stream until we see the up and running message+ maybeReady <- timeout 30_000_000 $ fix $ \loop -> do+ line <- fmap T.pack $ liftIO $ hGetLine hRead+ whenJust maybeLogFileHandle $ \logFileHandle ->+ liftIO $ T.hPutStrLn logFileHandle line+ unless (Prelude.any (`T.isInfixOf` line) (needles driverConfig)) loop+ when (isNothing maybeReady) $+ throwIO DriverNoReadyMessage++ logAsync <- async $ flip finally (liftIO $ whenJust maybeLogFileHandle hClose) $ forever $ do+ line <- liftIO (T.hGetLine hRead)+ whenJust maybeLogFileHandle $ \logFileHandle ->+ liftIO $ T.hPutStrLn logFileHandle line++ flip onException (cancel logAsync) $ do+ -- Wait for a successful connection to the server socket+ addr <- liftIO (getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just (show port))) >>= \case+ addr:_ -> return addr+ _ -> throwIO DriverGetAddrInfoFailed+ let policy = limitRetriesByCumulativeDelay (120 * 1_000_000) $ capDelay 1_000_000 $ exponentialBackoff 1000++ waitForSocket policy addr++ logDebugN [i|Finished wait for driver socket|]++ let basePath = case driverConfig of+ DriverConfigSeleniumJar {} -> "/wd/hub"+ _ -> ""++ let driver = Driver {+ _driverHostname = hostname+ , _driverPort = fromIntegral port+ , _driverBasePath = basePath+ , _driverRequestHeaders = requestHeaders+ , _driverManager = manager+ , _driverProcess = Just p+ , _driverLogAsync = Just logAsync+ , _driverConfig = driverConfig+ }++ -- Wait for a successful call to /status+ recoverAll policy $ \retryStatus -> do+ let req = mkDriverRequest driver methodGet "/status" Null+ resp <- liftIO $ httpLbs req manager+ let code = statusCode (responseStatus resp)+ if | code >= 200 && code < 300 -> return ()+ | otherwise -> do+ logWarnN [i|(#{retryStatus}) Invalid response from /status: #{resp}|]+ throwIO DriverStatusEndpointNotReady++ logInfoN [i|Finished wait for driver /status endpoint. Driver is running on #{hostname}:#{port}|]++ return driver++getArguments :: (MonadIO m, MonadLogger m) => PortNumber -> DriverConfig -> m (FilePath, [String], Maybe [(String, String)])+getArguments port (DriverConfigSeleniumJar {..}) = do+ javaArgs :: [String] <- mconcat <$> mapM getSubDriverArgs driverConfigSubDrivers++ let maybeSeleniumVersion = case driverConfigSeleniumVersion of+ Just x -> Just x+ Nothing -> autodetectSeleniumVersionByFileName driverConfigSeleniumJar+ logInfoN [i|Detected Selenium version: #{maybeSeleniumVersion}|]+ let extraArgs = case maybeSeleniumVersion of+ Just Selenium3 -> ["-port", show port]+ Just Selenium4 -> ["standalone", "--port", show port, "--host", "localhost"]+ Nothing -> ["-port", show port]++ let fullArgs = javaArgs+ <> ["-jar", driverConfigSeleniumJar]+ <> extraArgs+ return (driverConfigJava, fullArgs <> driverConfigJavaFlags, driverConfigJavaExtraEnv)+getArguments port (DriverConfigChromedriver {..}) = do+ return (driverConfigChromedriver, ["--port=" <> show port] <> driverConfigChromedriverFlags, driverConfigChromedriverExtraEnv)+getArguments port (DriverConfigGeckodriver {..}) = do+ return (driverConfigGeckodriver, ["--port", show port] <> driverConfigGeckodriverFlags, driverConfigGeckodriverExtraEnv)++autodetectSeleniumVersionByFileName :: FilePath -> Maybe SeleniumVersion+autodetectSeleniumVersionByFileName (takeFileName -> seleniumJar) = case autodetectSeleniumMajorVersionByFileName of+ Just 3 -> Just Selenium3+ Just 4 -> Just Selenium4+ _ -> Nothing+ where+ autodetectSeleniumMajorVersionByFileName :: Maybe Int+ autodetectSeleniumMajorVersionByFileName+ | not ("selenium-server-" `L.isPrefixOf` seleniumJar) = Nothing+ | not (".jar" `L.isSuffixOf` seleniumJar) = Nothing+ | otherwise = do+ let parts = seleniumJar+ & drop (length ("selenium-server-" :: String))+ & T.dropEnd (length (".jar" :: String)) . T.pack+ & T.splitOn "."+ & fmap T.unpack+ & fmap readMaybe++ case any isNothing parts of+ True -> Nothing+ False -> case catMaybes parts of+ [x, _, _, _] -> Just x+ [x, _, _] -> Just x+ [x, _] -> Just x+ [x] -> Just x+ _ -> Nothing++getSubDriverArgs :: Monad m => DriverConfig -> m [FilePath]+getSubDriverArgs (DriverConfigChromedriver {..}) = do+ let logArgs = case driverConfigLogDir of+ Just d -> ["-Dwebdriver.chrome.logfile=" <> (d </> "chromedriver.log")+ , "-Dwebdriver.chrome.verboseLogging=true"+ ]+ Nothing -> []+ return (["-Dwebdriver.chrome.driver=" <> driverConfigChromedriver] <> logArgs)+getSubDriverArgs (DriverConfigGeckodriver {..}) = do+ return [+ "-Dwebdriver.gecko.driver=" <> driverConfigGeckodriver+ ]+getSubDriverArgs _ = return []++needles :: DriverConfig -> [T.Text]+needles (DriverConfigSeleniumJar {}) = ["Selenium Server is up and running", "Started Selenium Standalone"]+needles (DriverConfigChromedriver {}) = ["ChromeDriver was started successfully"]+needles (DriverConfigGeckodriver {}) = ["Listening on"]++driverBaseName :: DriverConfig -> String+driverBaseName (DriverConfigSeleniumJar {}) = "selenium"+driverBaseName (DriverConfigChromedriver {}) = "chromedriver"+driverBaseName (DriverConfigGeckodriver {}) = "geckodriver"++data DriverException =+ DriverGetAddrInfoFailed+ | DriverNoReadyMessage+ | DriverStatusEndpointNotReady+ deriving (Show, Eq)++instance Exception DriverException++mkDriverRequest :: (ToJSON a) => Driver -> Method -> T.Text -> a -> Request+mkDriverRequest (Driver {..}) meth wdPath args =+ defaultRequest {+ host = BS.pack _driverHostname+ , port = _driverPort+ , path = BS.pack _driverBasePath `BS.append` TE.encodeUtf8 wdPath+ , requestBody = RequestBodyLBS body+ , requestHeaders = _driverRequestHeaders ++ extraHeaders+ , method = meth+#if !MIN_VERSION_http_client(0,5,0)+ , checkStatus = \_ _ _ -> Nothing+#endif+ }+ where+ body = case toJSON args of+ Null -> "" -- Passing Null as the argument indicates no request body+ other -> encode other++ extraHeaders = [+ (hAccept, "application/json;charset=UTF-8")+ , (hContentType, "application/json;charset=UTF-8")+ ]+++teardownDriver :: (MonadUnliftIO m, MonadLogger m) => Driver -> m ()+teardownDriver (Driver {..}) = do+ case _driverProcess of+ Just p -> do+ terminateProcess p+ -- Reap the child process to avoid leaving zombies.+ void $ liftIO $ waitForProcess p+ Nothing -> return ()+ case _driverLogAsync of+ Just x -> cancel x+ Nothing -> return ()++whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()+whenJust mg f = maybe (pure ()) f mg
− src/Test/WebDriver/Monad.hs
@@ -1,108 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ConstraintKinds #-}--module Test.WebDriver.Monad (- WD(..)- , runWD- , runSession- , finallyClose- , closeOnException- , getSessionHistory- , dumpSessionHistory- ) where--import Test.WebDriver.Class-import Test.WebDriver.Commands-import Test.WebDriver.Config-import Test.WebDriver.Internal-import Test.WebDriver.Session--import Control.Monad.Base (MonadBase, liftBase)-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Control (MonadBaseControl(..), StM)-import Control.Monad.Trans.State.Strict (StateT, evalStateT, get, put)-import Control.Exception.Lifted-import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)-import Control.Applicative--import Prelude -- hides some "unused import" warnings---{- | A state monad for WebDriver commands. -}-newtype WD a = WD (StateT WDSession IO a)- deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadFix, MonadMask)--instance MonadBase IO WD where- liftBase = WD . liftBase--instance MonadBaseControl IO WD where-#if MIN_VERSION_monad_control(1,0,0)- type StM WD a = StM (StateT WDSession IO) a-- liftBaseWith f = WD $- liftBaseWith $ \runInBase ->- f (\(WD sT) -> runInBase $ sT)-- restoreM = WD . restoreM-#else- data StM WD a = StWD {unStWD :: StM (StateT WDSession IO) a}-- liftBaseWith f = WD $- liftBaseWith $ \runInBase ->- f (\(WD sT) -> liftM StWD . runInBase $ sT)-- restoreM = WD . restoreM . unStWD-#endif--instance WDSessionState WD where- getSession = WD get- putSession = WD . put--instance WebDriver WD where- doCommand method path args =- mkRequest method path args- >>= sendHTTPRequest- >>= either throwIO return- >>= getJSONResult- >>= either throwIO return---- |Executes a 'WD' computation within the 'IO' monad, using the given--- 'WDSession' as state for WebDriver requests.-runWD :: WDSession -> WD a -> IO a-runWD sess (WD wd) = evalStateT wd sess---- |Executes a 'WD' computation within the 'IO' monad, automatically creating a new session beforehand.------ NOTE: session is not automatically closed when complete. If you want this behavior, use 'finallyClose'.--- Example:------ > runSessionThenClose action = runSession myConfig . finallyClose $ action-runSession :: WebDriverConfig conf => conf -> WD a -> IO a-runSession conf wd = do- sess <- mkSession conf- caps <- mkCaps conf- runWD sess $ createSession caps >> wd---- |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 wd = closeOnException wd <* closeSession---- |Exception handler that 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-closeOnException wd = wd `onException` closeSession---- |Gets the command history for the current session.-getSessionHistory :: WDSessionState wd => wd [SessionHistory]-getSessionHistory = fmap wdSessHist getSession---- |Prints a history of API requests to stdout after computing the given action.-dumpSessionHistory :: WDSessionStateControl wd => wd a -> wd a-dumpSessionHistory = (`finally` (getSession >>= liftBase . print . wdSessHist))
+ src/Test/WebDriver/Profile.hs view
@@ -0,0 +1,411 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-deriving-typeable #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | A type for profile preferences. These preference values are used by both+-- Firefox and Opera profiles.+module Test.WebDriver.Profile (+ -- * Profiles and profile preferences+ Profile(..)+ , ProfilePref(..)+ , ToPref(..)++ -- * Preferences+ , getPref+ , addPref+ , deletePref++ -- * Extensions+ -- , addExtension+ -- , deleteExtension+ , hasExtension++ -- * Miscellaneous profile operations+ , unionProfiles+ , onProfileFiles+ , onProfilePrefs++ -- * Profile errors+ , ProfileParseError(..)++ -- * Firefox+ , Firefox+ , defaultFirefoxProfile+ , loadFirefoxProfile+ , saveFirefoxProfile+ , firefoxProfileToArchive+ ) where++import Codec.Archive.Zip+import Control.Applicative+import Control.Exception.Safe hiding (try)+import Control.Monad+import Control.Monad.IO.Class+import Data.Aeson (Result(..), encode, fromJSON)+import qualified Data.Aeson as A+import Data.Aeson.Parser (jstring, value')+import Data.Aeson.Types (FromJSON, ToJSON, Value(..), parseJSON, toJSON, typeMismatch)+import Data.Attoparsec.ByteString.Char8 as AP+import Data.ByteString as BS (readFile)+import qualified Data.ByteString.Base64.Lazy as B64L+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Fixed+import Data.Function ((&))+import qualified Data.HashMap.Strict as HM+import Data.Int+import qualified Data.List as L+import Data.Maybe+import Data.Ratio+import Data.Text (Text, pack)+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import Data.Word+import Prelude -- hides some "unused import" warnings+import System.Directory+import System.FilePath ((</>), (<.>), takeFileName)++#if MIN_VERSION_aeson(0,7,0)+import Data.Scientific+#else+import Data.Attoparsec.Number (Number(..))+#endif+++-- | This structure allows you to construct and manipulate profiles. 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 {+ -- | A mapping from relative destination filepaths to source contents.+ profileFiles :: HM.HashMap FilePath ByteString+ -- | 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+ }+ deriving (Eq, Show)++-- | A profile preference value. This is the subset of JSON values that excludes+-- arrays, objects, and null.+data ProfilePref = PrefInteger !Integer+ | PrefDouble !Double+ | PrefString !Text+ | PrefBool !Bool+ deriving (Eq, Show)++instance ToJSON ProfilePref where+ toJSON v = case v of+ PrefInteger i -> toJSON i+ PrefDouble d -> toJSON d+ PrefString s -> toJSON s+ PrefBool b -> toJSON b++instance FromJSON ProfilePref where+ parseJSON (String s) = return $ PrefString s+ parseJSON (Bool b) = return $ PrefBool b+#if MIN_VERSION_aeson(0,7,0)+ parseJSON (Number s)+ | base10Exponent s >= 0 = return $ PrefInteger (coefficient s * 10^(base10Exponent s))+ | otherwise = return $ PrefDouble $ realToFrac s+#else+ parseJSON (Number (I i)) = return $ PrefInteger i+ parseJSON (Number (D d)) = return $ PrefDouble d+#endif+ parseJSON other = typeMismatch "ProfilePref" other++instance Exception ProfileParseError+-- | An error occured while attempting to parse a profile's preference file.+newtype ProfileParseError = ProfileParseError String+ deriving (Eq, Show, Read, Typeable)++-- | A typeclass to convert types to profile preference values+class ToPref a where+ toPref :: a -> ProfilePref++instance ToPref Text where+ toPref = PrefString++instance ToPref String where+ toPref = toPref . pack++instance ToPref Bool where+ toPref = PrefBool++instance ToPref Integer where+ toPref = PrefInteger++#define I(t) instance ToPref t where toPref = PrefInteger . toInteger++I(Int)+I(Int8)+I(Int16)+I(Int32)+I(Int64)+I(Word)+I(Word8)+I(Word16)+I(Word32)+I(Word64)++instance ToPref Double where+ toPref = PrefDouble++instance ToPref Float where+ toPref = PrefDouble . realToFrac++instance (Integral a) => ToPref (Ratio a) where+ toPref = PrefDouble . realToFrac++instance (HasResolution r) => ToPref (Fixed r) where+ toPref = PrefDouble . realToFrac++instance ToPref ProfilePref where+ toPref = id++-- | Retrieve a preference from a profile by key name.+getPref :: Text -> Profile b -> Maybe ProfilePref+getPref k (Profile _ m) = HM.lookup k m++-- | Add a new preference entry to a profile, overwriting any existing entry+-- with the same key.+addPref :: ToPref a => Text -> a -> Profile b -> Profile b+addPref k v p = onProfilePrefs p $ HM.insert k (toPref v)++-- | Delete an existing preference entry from a profile. This operation is+-- silent if the preference wasn't found.+deletePref :: Text -> Profile b -> Profile b+deletePref k p = onProfilePrefs p $ HM.delete k++-- | Determines if a profile contains the given file, specified as a path+-- relative to the profile directory.+hasFile :: String -> Profile b -> Bool+hasFile path (Profile files _) = path `HM.member` files++-- | Determines if a profile contains the given extension. specified as an+-- .xpi file or directory name+hasExtension :: String -> Profile b -> Bool+hasExtension name = hasFile ("extensions" </> name)++-- | 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)+ = 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)+ -> Profile b+onProfilePrefs (Profile hs hm) f = Profile hs (f hm)++-- | Modifies the 'profileFiles' field of a profile+onProfileFiles ::+ Profile b+ -> (HM.HashMap FilePath ByteString -> HM.HashMap FilePath ByteString)+ -> Profile b+onProfileFiles (Profile ls hm) f = Profile (f ls) hm++-- -- | Prepare a zip file of a profile on disk for network transmission.+-- -- This function is very efficient at loading large profiles from disk.+-- prepareZippedProfile :: MonadIO m => FilePath -> m (PreparedProfile a)+-- prepareZippedProfile path = prepareRawZip <$> liftIO (LBS.readFile path)++-- -- | Prepare a zip archive of a profile for network transmission.+-- prepareZipArchive :: Archive -> PreparedProfile a+-- prepareZipArchive = prepareRawZip . fromArchive++-- -- | Prepare a 'ByteString' of raw zip data for network transmission.+-- prepareRawZip :: ByteString -> PreparedProfile a+-- prepareRawZip = PreparedProfile . B64.encode++-- * Firefox+++-- | Phantom type used in the parameters of 'Profile' and 'PreparedProfile'+data Firefox++-- | Default Firefox Profile, used when no profile is supplied.+defaultFirefoxProfile :: Profile Firefox+defaultFirefoxProfile = Profile HM.empty $ HM.fromList [+ ("app.update.auto", PrefBool False)+ ,("app.update.enabled", PrefBool False)+ ,("browser.startup.page" , PrefInteger 0)+ ,("browser.download.manager.showWhenStarting", PrefBool False)+ ,("browser.EULA.override", PrefBool True)+ ,("browser.EULA.3.accepted", PrefBool True)+ ,("browser.link.open_external", PrefInteger 2)+ ,("browser.link.open_newwindow", PrefInteger 2)+ ,("browser.offline", PrefBool False)+ ,("browser.safebrowsing.enabled", PrefBool False)+ ,("browser.search.update", PrefBool False)+ ,("browser.sessionstore.resume_from_crash", PrefBool False)+ ,("browser.shell.checkDefaultBrowser", PrefBool False)+ ,("browser.tabs.warnOnClose", PrefBool False)+ ,("browser.tabs.warnOnOpen", PrefBool False)+ ,("browser.startup.page", PrefInteger 0)+ ,("browser.safebrowsing.malware.enabled", PrefBool False)+ ,("startup.homepage_welcome_url", PrefString "about:blank")+ ,("devtools.errorconsole.enabled", PrefBool True)+ ,("focusmanager.testmode", PrefBool True)+ ,("dom.disable_open_during_load", PrefBool False)+ ,("extensions.autoDisableScopes" , PrefInteger 10)+ ,("extensions.logging.enabled", PrefBool True)+ ,("extensions.update.enabled", PrefBool False)+ ,("extensions.update.notifyUser", PrefBool False)+ ,("network.manage-offline-status", PrefBool False)+ ,("network.http.max-connections-per-server", PrefInteger 10)+ ,("network.http.phishy-userpass-length", PrefInteger 255)+ ,("offline-apps.allow_by_default", PrefBool True)+ ,("prompts.tab_modal.enabled", PrefBool False)+ ,("security.fileuri.origin_policy", PrefInteger 3)+ ,("security.fileuri.strict_origin_policy", PrefBool False)+ ,("security.warn_entering_secure", PrefBool False)+ ,("security.warn_submit_insecure", PrefBool False)+ ,("security.warn_entering_secure.show_once", PrefBool False)+ ,("security.warn_entering_weak", PrefBool False)+ ,("security.warn_entering_weak.show_once", PrefBool False)+ ,("security.warn_leaving_secure", PrefBool False)+ ,("security.warn_leaving_secure.show_once", PrefBool False)+ ,("security.warn_submit_insecure", PrefBool False)+ ,("security.warn_viewing_mixed", PrefBool False)+ ,("security.warn_viewing_mixed.show_once", PrefBool False)+ ,("signon.rememberSignons", PrefBool False)+ ,("toolkit.networkmanager.disable", PrefBool True)+ ,("toolkit.telemetry.enabled", PrefBool False)+ ,("toolkit.telemetry.prompted", PrefInteger 2)+ ,("toolkit.telemetry.rejected", PrefBool True)+ ,("javascript.options.showInConsole", PrefBool True)+ ,("browser.dom.window.dump.enabled", PrefBool True)+ ,("webdriver_accept_untrusted_certs", PrefBool True)+ ,("webdriver_enable_native_events", native_events)+ ,("webdriver_assume_untrusted_issuer", PrefBool True)+ ,("dom.max_script_run_time", PrefInteger 30)+ ]+ where+#ifdef darwin_HOST_OS+ native_events = PrefBool False+#else+ native_events = PrefBool True+#endif+++-- | Load an existing profile from the file system. Any prepared changes made to+-- the 'Profile' will have no effect to the profile on disk.+--+-- To make automated browser run smoothly, preferences found in+-- 'defaultFirefoxProfile' 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.+loadFirefoxProfile :: forall m. MonadIO m => FilePath -> m (Profile Firefox)+loadFirefoxProfile path = unionProfiles defaultFirefoxProfile <$> (Profile <$> getFiles path <*> getPrefs)+ where+ userPrefFile = path </> "prefs" <.> "js"++ getFiles :: FilePath -> m (HM.HashMap FilePath ByteString)+ getFiles dir = liftIO $ do+ allFiles <- getAllFiles dir+ foldM (\acc p -> HM.insert p <$> LBS.readFile p <*> pure acc) HM.empty $+ filter ((`notElem` filesToIgnore) . takeFileName) allFiles++ getAllFiles :: FilePath -> IO [FilePath]+ getAllFiles dir = do+ exists <- doesDirectoryExist dir+ if not exists then return [] else do+ contents <- map (dir </>) <$> listDirectory dir+ files <- filterM doesFileExist contents+ dirs <- filterM doesDirectoryExist contents+ subFiles <- concat <$> mapM getAllFiles dirs+ return (files ++ subFiles)++ filesToIgnore = [".", "..", "OfflineCache", "Cache", "parent.lock", ".parentlock", ".lock", userPrefFile]++ getPrefs = liftIO $ do+ doesFileExist userPrefFile >>= \case+ True -> HM.fromList <$> (parsePrefs =<< BS.readFile userPrefFile)+ False -> return HM.empty+ where+ parsePrefs s = either (throwIO . ProfileParseError) return+ $ AP.parseOnly prefsParser s++-- | Save a Firefox profile to a destination directory. This directory should+-- already exist.+saveFirefoxProfile :: MonadIO m => Profile Firefox -> FilePath -> m ()+saveFirefoxProfile (firefoxProfileToArchive -> archive) dest = liftIO $ flip extractFilesFromArchive archive [+ OptRecursive+ , OptDestination dest+ ]++-- | Prepare a Firefox profile for network transmission.+firefoxProfileToArchive :: Profile Firefox -> Archive+firefoxProfileToArchive (Profile {profileFiles = files, profilePrefs = prefs}) =+ foldl addProfileFile baseArchive (HM.toList files)++ where+ baseArchive = emptyArchive+ & addEntryToArchive (toEntry ("user" <.> "js") 0 userJsContents)++ userJsContents = prefs+ & HM.toList+ & map (\(k, v) -> LBS.concat [ "user_pref(", encode k, ", ", encode v, ");\n"])+ & LBS.concat++ addProfileFile :: Archive -> (FilePath, ByteString) -> Archive+ addProfileFile archive (dest, bytes) = addEntryToArchive (toEntry dest 0 bytes) archive++instance ToJSON (Profile Firefox) where+ toJSON prof = firefoxProfileToArchive prof+ & fromArchive+ & B64L.encode+ & LBS.toStrict+ & T.decodeUtf8+ & A.String++instance FromJSON (Profile Firefox) where+ parseJSON (String t) = case B64L.decode (TL.encodeUtf8 (TL.fromStrict t)) of+ Left err -> fail ("Couldn't decode Firefox profile archive: " <> err)+ Right bytes -> case toArchiveOrFail bytes of+ Left err -> fail ("Couldn't unzip Firefox profile archive: " <> err)+ Right archive -> return $ Profile {+ profileFiles = HM.fromList [(eRelativePath, fromEntry e) | e@(Entry {..}) <- otherFiles]+ , profilePrefs = prefs+ }+ where+ prefs = case L.find (\(Entry {..}) -> eRelativePath == "prefs.js") (zEntries archive) of+ Nothing -> mempty+ Just entry -> case AP.parseOnly prefsParser (BL.toStrict $ fromEntry entry) of+ Left _err -> mempty+ Right p -> HM.fromList p++ otherFiles = [e | e@(Entry {..}) <- zEntries archive, eRelativePath /= "prefs.js"]+ parseJSON other = typeMismatch "Profile Firefox" other++-- Firefox prefs.js parser++prefsParser :: AP.Parser [(Text, ProfilePref)]+prefsParser = AP.many1 $ do+ void . padSpaces $ AP.string "user_pref("+ k <- prefKey <?> "preference key"+ void . padSpaces $ AP.char ','+ v <- prefVal <?> "preference value"+ void . padSpaces $ AP.string ");"+ return (k,v)+ where+ prefKey = jstring+ prefVal = do+ v <- value'+ case fromJSON v of+ Error str -> fail str+ Success p -> return p++ padSpaces p = spaces >> p <* spaces+ spaces = many (AP.endOfLine <|> void AP.space <|> void comment)+ where+ comment = inlineComment <|> lineComment+ lineComment = AP.char '#' *> AP.manyTill AP.anyChar AP.endOfLine+ inlineComment = AP.string "/*" *> AP.manyTill AP.anyChar (AP.string "*/")
− src/Test/WebDriver/Session.hs
@@ -1,193 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-}--module Test.WebDriver.Session (- -- * WDSessionState class- WDSessionState(..), WDSessionStateIO, WDSessionStateControl, modifySession, withSession- -- ** WebDriver sessions- , WDSession(..), mostRecentHistory, mostRecentHTTPRequest, SessionId(..), SessionHistory(..)- -- * SessionHistoryConfig options- , SessionHistoryConfig, noHistory, unlimitedHistory, onlyMostRecentHistory- -- * Using custom HTTP request headers- , withRequestHeaders, withAuthHeaders- ) where--import Test.WebDriver.Session.History--import Data.Aeson-import Data.ByteString as BS(ByteString)-import Data.Text (Text)-import Data.Maybe (listToMaybe)-import Data.Monoid-import Control.Applicative-import Control.Monad.Base-import Control.Monad.Trans.Class-import Control.Monad.Trans.Control-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Identity-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Except-import Control.Monad.Trans.Writer.Strict as SW-import Control.Monad.Trans.Writer.Lazy as LW-import Control.Monad.Trans.State.Strict as SS-import Control.Monad.Trans.State.Lazy as LS-import Control.Monad.Trans.RWS.Strict as SRWS-import Control.Monad.Trans.RWS.Lazy as LRWS-import Control.Exception.Lifted (SomeException, try, throwIO)-import Network.HTTP.Client (Manager, Request)-import Network.HTTP.Types (RequestHeaders)-import Prelude -- hides some "redundant import" warnings---{- |An opaque identifier for a WebDriver session. These handles are produced by-the server on session creation, and act to identify a session in progress. -}-newtype SessionId = SessionId Text- deriving (Eq, Ord, Show, Read, FromJSON, ToJSON)--{- |The local state of a WebDriver session. This structure is passed-implicitly through all 'WD' computations -}-data WDSession = WDSession {- -- server hostname- wdSessHost :: BS.ByteString- -- server port- , wdSessPort :: Int- -- Base path for API requests- , wdSessBasePath :: BS.ByteString- -- |An opaque reference identifying the session to- -- use with 'WD' commands.- -- A value of Nothing indicates that a session- -- hasn't been created yet.- -- Sessions can be created within 'WD' via- -- 'Test.WebDriver.createSession', or created- -- automatically with 'Test.WebDriver.runSession'- , wdSessId :: Maybe SessionId- -- |The complete history of HTTP requests and- -- responses, most recent first.- , wdSessHist :: [SessionHistory]- -- |Update function used to append new entries to session history- , wdSessHistUpdate :: SessionHistoryConfig- -- |HTTP 'Manager' used for connection pooling by the http-client library.- , wdSessHTTPManager :: Manager- -- |Number of times to retry a HTTP request if it times out- , wdSessHTTPRetryCount :: Int- -- |Custom request headers to add to every HTTP request.- , wdSessRequestHeaders :: RequestHeaders- -- |Custom request headers to add *only* to session creation requests. This is usually done- -- when a WebDriver server requires HTTP auth.- , wdSessAuthHeaders :: RequestHeaders- }----- |A function used by 'wdHistoryConfig' to append new entries to session history.-type SessionHistoryConfig = SessionHistory -> [SessionHistory] -> [SessionHistory]---- |No session history is saved.-noHistory :: SessionHistoryConfig-noHistory _ _ = []---- |Keep unlimited history-unlimitedHistory :: SessionHistoryConfig-unlimitedHistory = (:)---- |Saves only the most recent history-onlyMostRecentHistory :: SessionHistoryConfig-onlyMostRecentHistory h _ = [h]---- |A class for monads that carry a WebDriver session with them. The--- MonadBaseControl superclass is used for exception handling through--- the lifted-base package.-class (Monad m, Applicative m) => WDSessionState m where-- -- |Retrieves the current session state of the monad- getSession :: m WDSession-- -- |Sets a new session state for the monad- putSession :: WDSession -> m ()---- |Constraint synonym for the common pairing of 'WDSessionState' and 'MonadBase' 'IO'.-type WDSessionStateIO s = (WDSessionState s, MonadBase IO s)---- |Constraint synonym for another common pairing of 'WDSessionState' and 'MonadBaseControl' 'IO'. This--- is commonly used in library types to indicate use of lifted exception handling.-type WDSessionStateControl s = (WDSessionState s, MonadBaseControl IO s)--modifySession :: WDSessionState s => (WDSession -> WDSession) -> s ()-modifySession f = getSession >>= putSession . f---- |Locally sets a session state for use within the given action.--- The state of any outside action is unaffected by this function.--- This function is useful if you need to work with multiple sessions simultaneously.-withSession :: WDSessionStateControl m => WDSession -> m a -> m a-withSession s m = do- s' <- getSession- putSession s- (a :: Either SomeException a) <- try m- putSession s'- either throwIO return a---- |The most recent SessionHistory entry recorded by this session, if any.-mostRecentHistory :: WDSession -> Maybe SessionHistory-mostRecentHistory = listToMaybe . wdSessHist---- |The most recent HTTP request issued by this session, if any.-mostRecentHTTPRequest :: WDSession -> Maybe Request-mostRecentHTTPRequest = fmap histRequest . mostRecentHistory---- |Set a temporary list of custom 'RequestHeaders' to use within the given action.--- All previous custom headers are temporarily removed, and then restored at the end.-withRequestHeaders :: WDSessionStateControl m => RequestHeaders -> m a -> m a-withRequestHeaders h m = do- h' <- fmap wdSessRequestHeaders getSession- modifySession $ \s -> s { wdSessRequestHeaders = h }- (a :: Either SomeException a) <- try m- modifySession $ \s -> s { wdSessRequestHeaders = h' }- either throwIO return a---- |Makes all webdriver HTTP requests in the given action use the session\'s auth headers, typically--- configured by setting the 'wdAuthHeaders' config. This is useful if you want to temporarily use--- the same auth headers you used for session creation with other HTTP requests.-withAuthHeaders :: WDSessionStateControl m => m a -> m a-withAuthHeaders wd = do- authHeaders <- fmap wdSessAuthHeaders getSession- withRequestHeaders authHeaders wd--instance WDSessionState m => WDSessionState (LS.StateT s m) where- getSession = lift getSession- putSession = lift . putSession--instance WDSessionState m => WDSessionState (SS.StateT s m) where- getSession = lift getSession- putSession = lift . putSession--instance WDSessionState m => WDSessionState (MaybeT m) where- getSession = lift getSession- putSession = lift . putSession--instance WDSessionState m => WDSessionState (IdentityT m) where- getSession = lift getSession- putSession = lift . putSession--instance (Monoid w, WDSessionState m) => WDSessionState (LW.WriterT w m) where- getSession = lift getSession- putSession = lift . putSession--instance (Monoid w, WDSessionState m) => WDSessionState (SW.WriterT w m) where- getSession = lift getSession- putSession = lift . putSession--instance WDSessionState m => WDSessionState (ReaderT r m) where- getSession = lift getSession- putSession = lift . putSession--instance WDSessionState m => WDSessionState (ExceptT r m) where- getSession = lift getSession- putSession = lift . putSession--instance (Monoid w, WDSessionState m) => WDSessionState (SRWS.RWST r w s m) where- getSession = lift getSession- putSession = lift . putSession--instance (Monoid w, WDSessionState wd) => WDSessionState (LRWS.RWST r w s wd) where- getSession = lift getSession- putSession = lift . putSession
− src/Test/WebDriver/Session/History.hs
@@ -1,14 +0,0 @@--module Test.WebDriver.Session.History where--import Control.Exception (SomeException)-import Data.ByteString.Lazy (ByteString)-import Network.HTTP.Client (Request, Response)---data SessionHistory = SessionHistory- { histRequest :: Request- , histResponse :: Either SomeException (Response ByteString)- , histRetryCount :: Int- }- deriving (Show)
src/Test/WebDriver/Types.hs view
@@ -1,48 +1,225 @@-{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.WebDriver.Types (- -- * WebDriver sessions- WD(..), WDSession(..), SessionId(..), SessionHistory+ WebDriverContext(..)+ -- , HasWebDriverContext+ , mkEmptyWebDriverContext - -- * WebDriver configuration- , WDConfig(..), defaultConfig, SessionHistoryConfig+ , Driver(..)+ , DriverConfig(..)+ , SeleniumVersion(..) - -- * Capabilities- , Capabilities(..), defaultCaps, allCaps- , Platform(..), ProxyType(..), UnexpectedAlertBehavior(..)+ -- * SessionState class+ , SessionState(..)+ , SessionStatePut(..) - -- ** Browser-specific capabilities- , Browser(..),+ -- ** WebDriver sessions+ , SessionId(..)+ , Session(..) - -- ** Default settings for browsers- firefox, chrome, ie, opera, iPhone, iPad, android- , LogLevel(..), IELogLevel(..), IEElementScrollBehavior(..)+ -- * Exceptions+ , SessionException(..) - -- * WebDriver objects and command-specific types- , Element(..)- , WindowHandle(..), currentWindow- , Selector(..)- , JSArg(..)- , FrameSelector(..)- , Cookie(..), mkCookie- , Orientation(..)- , MouseButton(..)- , WebStorageType(..)- , LogType, LogEntry(..)- , ApplicationCacheStatus(..)+ -- * Stack frames+ , StackFrame(..)+ , callStackItemToStackFrame - -- * Exceptions- , InvalidURL(..), NoSessionId(..), BadJSON(..)- , HTTPStatusUnknown(..), HTTPConnError(..)- , UnknownCommand(..), ServerError(..)- , FailedCommand(..), FailedCommandType(..)- , FailedCommandInfo(..), StackFrame(..)- , mkFailedCommandInfo, failedCommand+ -- * WebDriver class+ , WebDriver+ , WebDriverBase(..)+ , Method+ , methodDelete+ , methodGet+ , methodPost ) where -import Test.WebDriver.Capabilities-import Test.WebDriver.Commands-import Test.WebDriver.Config-import Test.WebDriver.Exceptions-import Test.WebDriver.Monad-import Test.WebDriver.Session+import Control.Monad.IO.Unlift+import Data.Aeson+import Data.Aeson.Types (Parser, typeMismatch)+import qualified Data.ByteString.Lazy as LBS+import Data.Map as M+import Data.String+import Data.String.Interpolate+import Data.Text as T+import GHC.Stack+import Network.HTTP.Client+import Network.HTTP.Types (RequestHeaders)+import Network.HTTP.Types.Method (methodDelete, methodGet, methodPost, Method)+import Test.WebDriver.Util.Aeson (aesonKeyFromText)+import UnliftIO.Async+import UnliftIO.Concurrent+import UnliftIO.Exception+import UnliftIO.Process+import UnliftIO.STM+++-- | The 'WebDriverContext' is an opaque type used by this library for+-- bookkeeping purposes. It tracks all the processes we spin up and all the+-- sessions we create.+--+-- Currently, we will create at most 1 Selenium or Chromedriver process per+-- 'WebDriverContext', and N Geckodriver processes, where N is the number of+-- Firefox sessions you request.+data WebDriverContext = WebDriverContext {+ _webDriverSessions :: MVar (Map String Session)+ , _webDriverSelenium :: MVar (Maybe Driver)+ , _webDriverChromedriver :: MVar (Maybe Driver)+ }++-- | Create a new 'WebDriverContext'.+mkEmptyWebDriverContext :: MonadIO m => m WebDriverContext+mkEmptyWebDriverContext = WebDriverContext+ <$> newMVar mempty+ <*> newMVar Nothing+ <*> newMVar Nothing++data Driver = Driver {+ _driverHostname :: String+ , _driverPort :: Int+ , _driverBasePath :: String+ , _driverRequestHeaders :: RequestHeaders+ , _driverManager :: Manager+ , _driverProcess :: Maybe ProcessHandle+ , _driverLogAsync :: Maybe (Async ())+ , _driverConfig :: DriverConfig+ }++data SeleniumVersion =+ Selenium3+ | Selenium4+ deriving (Show, Eq)++-- | Configuration for how to launch a given driver.+data DriverConfig =+ -- | For launching a WebDriver via "java -jar selenium.jar".+ -- Selenium can launch other drivers on your behalf. You should pass these as 'driverConfigSubDrivers'.+ DriverConfigSeleniumJar {+ -- | Path to @java@ binary.+ driverConfigJava :: FilePath+ -- | Extra flags to pass to @java@.+ , driverConfigJavaFlags :: [String]+ -- | Extra flags to pass to @java@.+ , driverConfigJavaExtraEnv :: Maybe [(String, String)]+ -- | Path to @selenium.jar@ file.+ , driverConfigSeleniumJar :: FilePath+ -- | Specify if this is Selenium 3 or 4. If this is not provided, we'll try to autodetect.+ , driverConfigSeleniumVersion :: Maybe SeleniumVersion+ -- | Drivers to configure Selenium to use.+ , driverConfigSubDrivers :: [DriverConfig]+ -- | Directory in which to place driver logs.+ , driverConfigLogDir :: Maybe FilePath+ }+ | DriverConfigGeckodriver {+ -- | Path to @geckodriver@ binary.+ driverConfigGeckodriver :: FilePath+ -- | Extra flags to pass to @geckodriver@.+ , driverConfigGeckodriverFlags :: [String]+ -- | Extra environment variables to pass to @geckodriver@.+ , driverConfigGeckodriverExtraEnv :: Maybe [(String, String)]+ -- | Path to @firefox@ binary.+ , driverConfigFirefox :: FilePath+ -- | Directory in which to place driver logs.+ , driverConfigLogDir :: Maybe FilePath+ }+ | DriverConfigChromedriver {+ -- | Path to @chromedriver@ binary.+ driverConfigChromedriver :: FilePath+ -- | Extra flags to pass to @chromedriver@.+ , driverConfigChromedriverFlags :: [String]+ -- | Extra environment variables to pass to @chromedriver@.+ , driverConfigChromedriverExtraEnv :: Maybe [(String, String)]+ -- | Path to @chrome@ binary.+ , driverConfigChrome :: FilePath+ -- | Directory in which to place driver logs.+ , driverConfigLogDir :: Maybe FilePath+ }++-- | 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 T.Text+ deriving (Eq, Ord, Show, Read, FromJSON, ToJSON)+instance IsString SessionId where+ fromString s = SessionId (T.pack s)++data Session = Session {+ sessionDriver :: Driver+ , sessionId :: SessionId+ , sessionName :: String+ , sessionWebSocketUrl :: Maybe String+ -- | Used to generate IDs for BiDi.+ , sessionIdCounter :: TVar Int+ }+instance Show Session where+ show (Session {sessionDriver=(Driver {..}), ..}) = [i|Session<[#{sessionId}] at #{_driverHostname}:#{_driverPort}#{_driverBasePath}>|]++-- class HasLens ctx a where+-- getLens :: Lens' ctx a++data SessionException =+ SessionNameAlreadyExists+ | SessionCreationFailed (Response LBS.ByteString)+ | SessionCreationResponseHadNoSessionId (Response LBS.ByteString)+ deriving (Show)+instance Exception SessionException+++class SessionState m where+ getSession :: m Session++class (SessionState m) => SessionStatePut m where+ withModifiedSession :: (Session -> Session) -> m a -> m a++type WebDriver m = (WebDriverBase m, SessionState m)++-- | A class for monads that can handle wire protocol requests. This is the+-- operation underlying all of the high-level commands exported in+-- "Test.WebDriver.Commands".+class (MonadUnliftIO m) => WebDriverBase m where+ doCommandBase :: (+ HasCallStack, ToJSON a+ )+ => Driver+ -- | HTTP request method+ -> Method+ -- | URL of request+ -> Text+ -- | JSON parameters passed in the body of the request. Note that, as a+ -- special case, anything that converts to Data.Aeson.Null will result in an+ -- empty request body.+ -> a+ -- | The response of the HTTP request.+ -> m (Response LBS.ByteString)++-- | An individual stack frame from the stack trace provided by the server+-- during a FailedCommand.+data StackFrame = StackFrame {+ sfFileName :: String+ , sfClassName :: String+ , sfMethodName :: String+ , sfLineNumber :: Int+ } deriving (Eq)+instance Show StackFrame where+ show f = showString (sfClassName f) . showChar '.'+ . showString (sfMethodName f) . showChar ' '+ . showParen True ( showString (sfFileName f) . showChar ':'+ . shows (sfLineNumber f))+ $ "\n"+instance FromJSON StackFrame where+ parseJSON (Object o) = StackFrame <$> reqStr "fileName"+ <*> reqStr "className"+ <*> reqStr "methodName"+ <*> req "lineNumber"+ where req :: FromJSON a => Text -> Parser a+ req = (o .:) . aesonKeyFromText -- all keys are required+ reqStr :: Text -> Parser String+ reqStr k = req k >>= maybe (return "") return+ parseJSON v = typeMismatch "StackFrame" v++callStackItemToStackFrame :: (String, SrcLoc) -> StackFrame+callStackItemToStackFrame (functionName, SrcLoc {..}) = StackFrame {+ sfFileName = srcLocFile+ , sfClassName = srcLocModule+ , sfMethodName = functionName+ , sfLineNumber = srcLocStartLine+ }
+ src/Test/WebDriver/Util/Aeson.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE CPP #-}++module Test.WebDriver.Util.Aeson (+ aesonToList+ , aesonLookup+ , aesonKeyFromText+ ) where++import Data.Text (Text)+++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as A+import qualified Data.Aeson.KeyMap as KM++aesonToList :: KM.KeyMap v -> [(A.Key, v)]+aesonToList = KM.toList++aesonLookup :: Text -> KM.KeyMap v -> Maybe v+aesonLookup = KM.lookup . A.fromText++aesonKeyFromText :: Text -> A.Key+aesonKeyFromText = A.fromText+#else+import qualified Data.HashMap.Strict as HM++aesonToList :: HM.KeyMap v -> [(A.Key, v)]+aesonToList = HM.toList++aesonLookup :: (Eq k, Hashable k) => k -> HM.HashMap k v -> Maybe v+aesonLookup = HM.lookup++aesonKeyFromText :: Text -> Text+aesonKeyFromText = id+#endif
+ src/Test/WebDriver/Util/Commands.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-deriving-typeable #-}++{-# OPTIONS_HADDOCK not-home #-}+-- | 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.Util.Commands (+ -- * Low-level webdriver functions+ doCommand+ -- ** Commands with :sessionId URL parameter+ , doSessCommand+ , SessionId(..)+ -- ** Commands with element :id URL parameters+ , doElemCommand+ , Element(..)+ -- ** Commands with :windowHandle URL parameters+ , WindowHandle(..)++ -- * Helpers+ , urlEncode+ ) where++import Control.Applicative+import Control.Monad.IO.Class+import Data.Aeson+import Data.Aeson.TH+import Data.Aeson.Types+import qualified Data.ByteString.Char8 as BS+import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding as TE+import GHC.Stack+import Network.HTTP.Client (Response(..))+import Network.HTTP.Types.Header+import Network.HTTP.Types.Status (Status(..))+import qualified Network.HTTP.Types.URI as HTTP+import Prelude -- hides some "unused import" warnings+import Test.WebDriver.Capabilities.Aeson+import Test.WebDriver.Exceptions+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Aeson+import UnliftIO.Exception+++data SuccessResponse a = SuccessResponse {+ successValue :: a+ }+deriveFromJSON toCamel1 ''SuccessResponse++-- | An opaque identifier for a web page element+newtype Element = Element Text+ deriving (Eq, Ord, Show, Read)++instance FromJSON Element where+ parseJSON (Object o) = case fmap snd (aesonToList o) of+ (String id' : _) -> pure $ Element id'+ _ -> fail "No elements returned"+ parseJSON v = typeMismatch "Element" v++instance ToJSON Element where+ toJSON (Element e) = object ["element-6066-11e4-a52e-4f735466cecf" .= e]+++-- | An opaque identifier for a browser window+newtype WindowHandle = WindowHandle Text+ deriving (Eq, Ord, Show, Read, FromJSON, ToJSON)++-- | 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+-- <https://github.com/SeleniumHQ/selenium/wiki/JsonWireProtocol>+doSessCommand :: (+ HasCallStack, WebDriver wd, ToJSON a, FromJSON b+ ) => Method -> Text -> a -> wd b+doSessCommand method path args = do+ Session { sessionId = SessionId sId } <- getSession+ -- Catch BadJSON exceptions here, since most commands go through this function.+ -- Then, re-throw them with "error", which automatically appends a callstack+ -- to the message in modern GHCs.+ -- This callstack makes it easy to see which command caused the BadJSON exception,+ -- without exposing too many internals.+ catch+ (doCommand method (T.concat ["/session/", urlEncode sId, path]) args)+ (\(e :: BadJSON) -> error $ show e)++-- | A wrapper around 'doSessCommand' to create element URLs.+-- 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 :: (+ HasCallStack, WebDriver wd, ToJSON a, FromJSON b+ ) => Method -> Element -> Text -> a -> wd b+doElemCommand m (Element e) path a =+ doSessCommand m (T.concat ["/element/", urlEncode e, path]) a++urlEncode :: Text -> Text+urlEncode = TE.decodeUtf8 . HTTP.urlEncode False . TE.encodeUtf8++-- | Parse a 'FailedCommand' object from a given HTTP response.+getJSONResult :: (MonadIO m, FromJSON a) => Response ByteString -> m (Either SomeException a)+getJSONResult r+ | code >= 400 && code < 600 =+ case lookup hContentType headers of+ Just ct+ | "application/json" `BS.isInfixOf` ct -> do+ SuccessResponse {..} :: SuccessResponse FailedCommand <- parseJSON' body+ throwIO successValue+ | otherwise ->+ return $ Left $ toException $ ServerError reason+ Nothing ->+ return $ Left $ toException $ ServerError ("HTTP response missing content type. Server reason was: " <> reason)+ | code >= 200 && code < 300 = do+ SuccessResponse {successValue} <- parseJSON' body+ return $ Right successValue+ | otherwise = return $ Left $ toException $ (HTTPStatusUnknown code) reason+ where+ code = statusCode status+ reason = BS.unpack $ statusMessage status+ status = responseStatus r+ body = responseBody r+ headers = responseHeaders r+++doCommand :: (+ HasCallStack, WebDriver m, ToJSON a, FromJSON b+ )+ -- | HTTP request method+ => Method+ -- | URL of request+ -> Text+ -- | JSON parameters passed in the body of the request. Note that, as a+ -- special case, anything that converts to Data.Aeson.Null will result in an+ -- empty request body.+ -> a+ -- | The JSON result of the HTTP request.+ -> m b+doCommand method url params = do+ Session {sessionDriver} <- getSession+ doCommandBase sessionDriver method url params+ >>= getJSONResult+ >>= either throwIO return
+ src/Test/WebDriver/Util/Ports.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++{-|+Helper module for finding free ports, with various options for port ranges, retries, and excluded ports.+-}++module Test.WebDriver.Util.Ports (+ findFreePort++ -- * Exception-throwing versions+ , findFreePortOrException+ , findFreePortOrException'++ -- * Lower-level+ , findFreePortInRange+ , findFreePortInRange'++ -- * Lower-level+ , isPortFree+ , tryOpenAndClosePort+ , ephemeralPortRange+ ) where++import Control.Monad.Catch (MonadCatch, catch)+import Control.Monad.IO.Class+import Control.Retry+import Data.Maybe+import Network.Socket+import System.Random (randomRIO)+import UnliftIO.Exception (SomeException)+++-- | Find an unused port in the ephemeral port range.+-- See https://en.wikipedia.org/wiki/List_of_TCP_and_UDP_port_numbers.+findFreePort :: (MonadIO m, MonadCatch m) => m (Maybe PortNumber)+findFreePort = findFreePortInRange ephemeralPortRange []++-- | Find a free port in the ephemeral range, throwing an exception if one isn't found.+findFreePortOrException :: (MonadIO m, MonadCatch m) => m PortNumber+findFreePortOrException = findFreePortOrException' (const True)++-- | Same as 'findFreePortOrException', but with a callback to test if the port is acceptable or not.+findFreePortOrException' :: (MonadIO m, MonadCatch m) => (PortNumber -> Bool) -> m PortNumber+findFreePortOrException' isAcceptable = findFreePort >>= \case+ Just port+ | isAcceptable port -> return port+ | otherwise -> findFreePortOrException' isAcceptable+ Nothing -> error "Couldn't find free port"++-- | Find an unused port in a given range, excluding certain ports.+-- If the retries time out, returns 'Nothing'.+findFreePortInRange :: (+ MonadIO m, MonadCatch m+ )+ -- | Candidate port range+ => (PortNumber, PortNumber)+ -- | Ports to exclude+ -> [PortNumber]+ -> m (Maybe PortNumber)+findFreePortInRange = findFreePortInRange' (limitRetries 50)++-- | Same as 'findFreePortInRange', but with a configurable retry policy.+findFreePortInRange' :: forall m. (+ MonadIO m, MonadCatch m+ )+ -- | Retry policy+ => RetryPolicy+ -- | Candidate port range+ -> (PortNumber, PortNumber)+ -- | Ports to exclude+ -> [PortNumber]+ -> m (Maybe PortNumber)+findFreePortInRange' retryPolicy (start, end) blacklist = retrying retryPolicy callback (const findFreePortInRange')+ where+ callback _retryStatus result = return $ isNothing result++ getAcceptableCandidate :: m PortNumber+ getAcceptableCandidate = do+ candidate <- liftIO (fromInteger <$> randomRIO (fromIntegral start, fromIntegral end))+ if | candidate `elem` blacklist -> getAcceptableCandidate+ | otherwise -> return candidate++ findFreePortInRange' :: m (Maybe PortNumber)+ findFreePortInRange' = do+ candidate <- getAcceptableCandidate+ isPortFree candidate >>= \case+ False -> return Nothing+ True -> return $ Just candidate++-- | Test if a given 'PortNumber' is currently available.+isPortFree :: (MonadIO m, MonadCatch m) => PortNumber -> m Bool+isPortFree candidate = catch (tryOpenAndClosePort candidate >> return True)+ (\(_ :: SomeException) -> return False)++-- | Test a given 'PortNumber' availability by trying to open and close a socket on it.+-- Throws an exception on failure.+tryOpenAndClosePort :: MonadIO m => PortNumber -> m PortNumber+tryOpenAndClosePort port = liftIO $ do+ sock <- socket AF_INET Stream 0+ setSocketOption sock ReuseAddr 1+ let hints = defaultHints { addrSocketType = Stream, addrFamily = AF_INET }+ getAddrInfo (Just hints) (Just "127.0.0.1") (Just $ show port) >>= \case+ ((AddrInfo {addrAddress=addr}):_) -> do+ bind sock addr+ close sock+ return $ fromIntegral port+ [] -> error "Couldn't resolve address 127.0.0.1"++-- | The ephemeral port range.+-- See https://en.wikipedia.org/wiki/List_of_TCP_and_UDP_port_numbers.+ephemeralPortRange :: (PortNumber, PortNumber)+ephemeralPortRange = (49152, 65535)
+ src/Test/WebDriver/Util/Sockets.hs view
@@ -0,0 +1,62 @@++module Test.WebDriver.Util.Sockets (+ waitForSocket+ , connectRetryPolicy+ ) where++import Control.Exception.Safe+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Retry+import Data.String.Interpolate+import Network.Socket+import UnliftIO.Timeout++++-- * Socket waits++-- | Each individual connect attempt needs a timeout to prevent it from hanging+-- indefinitely. This policy allows us to make that timeout length adaptive,+-- based on the 'RetryStatus' of the outer retry policy.+--+-- Thus, the first attempt to connect will have a short timeout (currently 100ms),+-- and then successive attempts will get longer timeouts via "FullJitter" backoff.+-- The goals of this are twofold:+--+-- 1) If a connect call hangs during the first few attempts, it is timed out quickly+-- and re-attempted, so on a healthy network you aren't penalized too much by the hang.+-- The outer retry policy can control the time between attempts, so the user can set+-- it high enough to make this be the case.+--+-- 2) If the network is slow, we will eventually reach the maximum timeout of 3 seconds,+-- which should be long enough. Note that the popular wait-for script uses 1 second+-- timeouts, so this is extra conservative:+-- https://github.com/eficode/wait-for/blob/7586b3622f010808bb2027c19aaf367221b4ad54/wait-for#L72+connectRetryPolicy :: MonadIO m => RetryPolicyM m+connectRetryPolicy = capDelay (3000000) (fullJitterBackoff 100000)++waitForSocket :: (+ MonadUnliftIO m, MonadLogger m, MonadMask m+ )+ => RetryPolicyM m+ -> AddrInfo+ -> m ()+waitForSocket policy addr = recoverAll policy $ \retryStatus@(RetryStatus {..}) -> do+ flip withException (\(e :: SomeException) -> logErrorN [i|waitForSocket: failed to connect to #{addr}: #{e}|]) $ do+ when (rsIterNumber > 0) $+ logDebugN [i|waitForSocket: attempt \##{rsIterNumber} to connect to #{addr}|]++ bracket (liftIO initSocket) (liftIO . close) $ \sock -> do+ connectTimeoutUs <- (getRetryPolicyM connectRetryPolicy) retryStatus >>= \case+ Nothing -> throwIO $ userError "Timeout due to connect retry policy"+ Just us -> pure us++ timeout connectTimeoutUs (liftIO $ connect sock (addrAddress addr)) >>= \case+ Nothing -> throwIO $ userError "Timeout in connect attempt"+ Just () -> pure ()++ where+ initSocket = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
− src/Test/WebDriver/Utils.hs
@@ -1,9 +0,0 @@--module Test.WebDriver.Utils where--import Data.Text (Text)-import Data.Text.Encoding as TE-import qualified Network.HTTP.Types.URI as HTTP--urlEncode :: Text -> Text-urlEncode = TE.decodeUtf8 . HTTP.urlEncode False . TE.encodeUtf8
+ src/Test/WebDriver/WD.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-|++This module contains the 'WD' monad, which serves as an example of how to use+this library in a standalone fashion.++For more complex usage, you'll probably want to skip this module and write+'WebDriverBase' and 'SessionState' instances for your own monads.++You can find a full example in the project repo at+<https://github.com/haskell-webdriver/haskell-webdriver/blob/main/app/Main.hs>.++-}++module Test.WebDriver.WD (+ WD(..)+ , runWD+ ) where++import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Monad.Reader+import qualified Data.Aeson as A+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.String.Interpolate+import qualified Data.Text as T+import qualified Network.HTTP.Client as HC+import Network.HTTP.Types.Status as N+import Test.WebDriver+import Test.WebDriver.Types+import UnliftIO.Exception++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as A+import qualified Data.Aeson.KeyMap as KM++aesonLookup :: T.Text -> KM.KeyMap v -> Maybe v+aesonLookup = KM.lookup . A.fromText+#else+import qualified Data.HashMap.Strict as HM++aesonLookup :: (Eq k, Hashable k) => k -> HM.HashMap k v -> Maybe v+aesonLookup = HM.lookup+#endif++newtype WD a = WD (ReaderT Session (LoggingT IO) a)+ deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO, MonadReader Session, MonadLogger)++doCommandBaseWithLogging :: (+ MonadLogger m, MonadUnliftIO m, A.ToJSON p+ ) => Driver -> Method -> T.Text -> p -> m (HC.Response BL.ByteString)+doCommandBaseWithLogging driver method path args = do+ let req = mkDriverRequest driver method path args+ logDebugN [i|--> #{HC.method req} #{HC.path req}#{HC.queryString req} (#{showRequestBody (HC.requestBody req)})|]+ response <- tryAny (liftIO $ HC.httpLbs req (_driverManager driver)) >>= either throwIO return+ let (N.Status code _) = HC.responseStatus response++ if | code >= 200 && code < 300 -> case A.eitherDecode (HC.responseBody response) of+ -- For successful responses, try to pull out the "value" and show it+ Right (A.Object (aesonLookup "value" -> Just value)) -> logDebugN [i|<-- #{code} #{A.encode value}|]+ _ -> logDebugN [i|<-- #{code} #{HC.responseBody response}|]+ -- For non-successful responses, log the entire response.+ -- Reading the WebDriver spec, it would probably be sufficient to just show the "value" as above,+ -- plus the HTTP status message.+ | otherwise -> logDebugN [i|<-- #{code} #{response}|]+ return response++ where+ showRequestBody :: HC.RequestBody -> B.ByteString+ showRequestBody (HC.RequestBodyLBS bytes) = BL.toStrict bytes+ showRequestBody (HC.RequestBodyBS bytes) = bytes+ showRequestBody _ = "<request body>"++instance WebDriverBase WD where+ doCommandBase = doCommandBaseWithLogging++instance WebDriverBase (LoggingT IO) where+ doCommandBase = doCommandBaseWithLogging++instance SessionState WD where+ getSession = ask++-- The following is a more general SessionState for MonadReader monads, but it+-- requires UndecidableInstances+-- class HasSession a where+-- extractSession :: a -> Session+-- instance HasSession Session where+-- extractSession = id+-- instance (HasSession a, MonadReader a m) => SessionState m where+-- getSession = asks extractSession++runWD :: Session -> WD a -> LoggingT IO a+runWD sess (WD wd) = runReaderT wd sess
+ src/Test/WebDriver/Waits.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-deriving-typeable #-}++module Test.WebDriver.Waits (+ -- * Wait on expected conditions+ waitUntil+ , waitUntil'+ , waitWhile+ , waitWhile'++ -- * Expected conditions+ , ExpectFailed (..)+ , expect+ , unexpected+ , expectAny+ , expectAll+ , expectNotStale+ , expectAlertOpen+ , catchFailedCommand++ -- ** Convenience functions+ , onTimeout+ ) where++import Control.Concurrent+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import qualified Data.Foldable as F+import qualified Data.List as L+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time.Clock+import GHC.Stack+import Test.WebDriver.Commands+import Test.WebDriver.Exceptions+import Test.WebDriver.Types+import UnliftIO.Exception+++instance Exception ExpectFailed+-- | An exception representing the failure of an expected condition.+data ExpectFailed = ExpectFailed String deriving (Show, Eq, Typeable)++-- | Throws 'ExpectFailed'. This is nice for writing your own abstractions.+unexpected :: (+ MonadIO 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+-- boolean is False, and otherwise does nothing.+expect :: (MonadIO m) => Bool -> m ()+expect b+ | b = return ()+ | otherwise = unexpected "Test.WebDriver.Commands.Wait.expect"++-- |Apply a monadic predicate to every element in a list, and 'expect' that+-- at least one succeeds.+expectAny :: (F.Foldable f, MonadIO m) => (a -> m Bool) -> f a -> m ()+expectAny p xs = expect . F.or =<< mapM p (F.toList xs)++-- |Apply a monadic predicate to every element in a list, and 'expect' that all+-- succeed.+expectAll :: (F.Foldable f, MonadIO m) => (a -> m Bool) -> f a -> m ()+expectAll p xs = expect . F.and =<< mapM p (F.toList xs)++-- | 'expect' the given 'Element' to not be stale and return it.+expectNotStale :: (HasCallStack, WebDriver wd) => Element -> wd Element+expectNotStale e = catchFailedCommand StaleElementReference $ do+ _ <- isEnabled e -- Any command will force a staleness check+ return e++-- | 'expect' an alert to be present on the page, and returns its text.+expectAlertOpen :: (HasCallStack, WebDriver wd) => wd Text+expectAlertOpen = catchFailedCommand NoSuchAlert getAlertText++-- | Catches any `FailedCommand` exceptions with the given `FailedCommandType` and rethrows as 'ExpectFailed'.+catchFailedCommand :: (MonadUnliftIO m) => FailedCommandError -> m a -> m a+catchFailedCommand needle m = m `catch` handler+ where+ handler e@(FailedCommand {rspError})+ | rspError == needle = unexpected . show $ e+ handler e = throwIO e++-- | 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+-- is expressed in seconds.+waitUntil :: (MonadUnliftIO m, HasCallStack) => Double -> m a -> m a+waitUntil = waitUntil' 500000++-- |Similar to 'waitUntil' but allows you to also specify the poll frequency+-- of the 'WD' action. The frequency is expressed as an integer in microseconds.+waitUntil' :: (MonadUnliftIO m, HasCallStack) => Int -> Double -> m a -> m a+waitUntil' = waitEither id (\_ -> return)++-- |Like 'waitUntil', but retries the action until it fails or until the timeout+-- is exceeded.+waitWhile :: (MonadUnliftIO m, HasCallStack) => Double -> m a -> m ()+waitWhile = waitWhile' 500000++-- |Like 'waitUntil'', but retries the action until it either fails or+-- until the timeout is exceeded.+waitWhile' :: (MonadUnliftIO m, HasCallStack) => Int -> Double -> m a -> m ()+waitWhile' =+ waitEither (\_ _ -> return ())+ (\retry _ -> retry "waitWhile: action did not fail")+++-- | Internal function used to implement explicit wait commands using success and failure continuations+waitEither :: (+ HasCallStack, MonadUnliftIO m+ )+ => ((String -> m b) -> String -> m b) -> ((String -> m b) -> a -> m b)+ -> Int+ -> Double+ -> m a+ -> m b+waitEither failure success = wait' handler+ where+ handler retry wd = do+ e <- fmap Right wd `catches` [Handler handleFailedCommand+ , Handler handleExpectFailed+ ]+ either (failure retry) (success retry) e+ where+ handleFailedCommand e@(FailedCommand {rspError})+ | rspError == NoSuchElement = return . Left . show $ e+ handleFailedCommand err = throwIO err++ handleExpectFailed (e :: ExpectFailed) = return . Left . show $ e++wait' :: (+ HasCallStack, MonadIO m+ ) => ((String -> m b) -> m a -> m b) -> Int -> Double -> m a -> m b+wait' handler waitAmnt t wd = waitLoop =<< liftIO getCurrentTime+ where+ timeout = realToFrac t+ waitLoop startTime = handler retry wd+ where+ retry why = do+ now <- liftIO getCurrentTime+ if diffUTCTime now startTime >= timeout+ then+ throwIO $ FailedCommand {+ rspError = Timeout+ , rspMessage = "wait': explicit wait timed out (" <> T.pack why <> ")."+ , rspStacktrace = T.pack $ show (popCallStack callStack)+ , rspData = Nothing+ }+ else do+ liftIO . threadDelay $ waitAmnt+ waitLoop startTime++-- | Convenience function to catch 'FailedCommand' 'Timeout' exceptions+-- and perform some action.+--+-- Example:+--+-- > waitUntil 5 (getText <=< findElem $ ByCSS ".class")+-- > `onTimeout` return ""+onTimeout :: (MonadUnliftIO m) => m a -> m a -> m a+onTimeout m r = m `catch` handler+ where+ handler (FailedCommand {rspError})+ | rspError `L.elem` [Timeout, ScriptTimeout] = r+ handler other = throwIO other
+ tests/Main.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Main where++import Control.Monad+import Control.Monad.Reader+import Data.String.Interpolate+import qualified Data.Text as T+import qualified Spec as Spec+import System.Environment+import Test.Sandwich hiding (BrowserToUse(..))+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Nix+import Test.WebDriver+import TestLib.Contexts.BrowserDependencies+import TestLib.Contexts.Selenium4+import TestLib.Contexts.StaticServer+import TestLib.Contexts.WebDriver+import TestLib.Types+import TestLib.Types.Cli+import UnliftIO.Process+++main :: IO ()+main = do+ args <- getArgs+ putStrLn [i|args: #{args}|]++ clo <- parseCommandLineArgs userOptions (return ())++ let introduceSelenium3 :: forall ctx. (HasBaseContext ctx, HasNixContext ctx, HasBrowserDependencies ctx) => SpecFree (LabelValue "driverConfig" DriverConfig :> ctx) IO () -> SpecFree ctx IO ()+ introduceSelenium3 = introduce "Introduce Selenium 3" driverConfig alloc (const $ return ())+ where+ alloc = do+ Just dir <- getCurrentFolder+ java <- getBinaryViaNixPackage @"java" "jre"+ seleniumJar <- getFileViaNixPackage "selenium-server-standalone" tryFindSeleniumJar+ subDrivers <- getSubDrivers dir+ return $ DriverConfigSeleniumJar {+ driverConfigJava = java+ , driverConfigSeleniumJar = seleniumJar+ , driverConfigSubDrivers = subDrivers+ , driverConfigLogDir = Just dir+ , driverConfigJavaFlags = []+ , driverConfigJavaExtraEnv = Nothing+ , driverConfigSeleniumVersion = Just Selenium3+ }++ let introduceSelenium4 :: forall ctx. (HasBaseContext ctx, HasNixContext ctx, HasBrowserDependencies ctx) => SpecFree (LabelValue "driverConfig" DriverConfig :> ctx) IO () -> SpecFree ctx IO ()+ introduceSelenium4 = introduce "Introduce Selenium 4" driverConfig alloc (const $ return ())+ where+ alloc = do+ Just dir <- getCurrentFolder+ java <- getBinaryViaNixPackage @"java" "jre"+ seleniumJar <- getFileViaNixDerivation selenium4Derivation tryFindSeleniumJar+ subDrivers <- getSubDrivers dir+ return $ DriverConfigSeleniumJar {+ driverConfigJava = java+ , driverConfigSeleniumJar = seleniumJar+ , driverConfigSubDrivers = subDrivers+ , driverConfigLogDir = Just dir+ , driverConfigJavaFlags = []+ , driverConfigJavaExtraEnv = Nothing+ , driverConfigSeleniumVersion = Just Selenium4+ }++ let introduceChromedriver :: forall ctx. (HasBaseContext ctx, HasNixContext ctx) => SpecFree (LabelValue "driverConfig" DriverConfig :> ctx) IO () -> SpecFree ctx IO ()+ introduceChromedriver = introduce "Introduce chromedriver" driverConfig alloc (const $ return ())+ where+ alloc = do+ Just dir <- getCurrentFolder+ chrome <- getBinaryViaNixPackage @"google-chrome-stable" "google-chrome"+ chromedriver <- getBinaryViaNixPackage @"chromedriver" "chromedriver"+ return $ DriverConfigChromedriver {+ driverConfigChromedriver = chromedriver+ , driverConfigChrome = chrome+ , driverConfigLogDir = Just dir+ , driverConfigChromedriverFlags = []+ , driverConfigChromedriverExtraEnv = Nothing+ }++ let introduceGeckodriver :: forall ctx. (HasBaseContext ctx, HasNixContext ctx) => SpecFree (LabelValue "driverConfig" DriverConfig :> ctx) IO () -> SpecFree ctx IO ()+ introduceGeckodriver = introduce "Introduce geckodriver" driverConfig alloc (const $ return ())+ where+ alloc = do+ Just dir <- getCurrentFolder+ firefox <- getBinaryViaNixPackage @"firefox" "firefox"+ geckodriver <- getBinaryViaNixPackage @"geckodriver" "geckodriver"+ return $ DriverConfigGeckodriver {+ driverConfigGeckodriver = geckodriver+ , driverConfigFirefox = firefox+ , driverConfigLogDir = Just dir+ , driverConfigGeckodriverFlags = []+ , driverConfigGeckodriverExtraEnv = Nothing+ }++ let UserOptions {optBrowserToUse} = optUserOptions clo++ runSandwichWithCommandLineArgs' defaultOptions userOptions $+ introduceNixContext nixpkgsRelease $+ introduceStaticServer $+ introduceBrowserDependencies $ do+ describe "Selenium 3" $ introduceSelenium3 $ introduceWebDriverContext $ Spec.spec++ describe "Selenium 4" $ introduceSelenium4 $ introduceWebDriverContext $ Spec.spec++ when (optBrowserToUse == UseChrome) $+ describe "chromedriver direct" $ introduceChromedriver $ introduceWebDriverContext Spec.spec++ when (optBrowserToUse == UseFirefox) $+ describe "geckodriver direct" $ introduceGeckodriver $ introduceWebDriverContext Spec.spec+++-- | Nixpkgs nixos-unstable, accessed 6\/2\/2026 (provides google-chrome 148.0.7778.215).+-- You can compute updated values for this release (or others) by running+-- nix-prefetch-github NixOS nixpkgs --rev nixos-unstable+-- We pin this here rather than using 'nixpkgsReleaseDefault' from sandwich-contexts+-- so that sandwich updates can't break this. Note that 'google-chrome' fetches a+-- versioned .deb from Google, which gets removed once a newer Chrome stable ships, so+-- this rev needs bumping periodically to a Nixpkgs whose google-chrome is current.+nixpkgsRelease :: NixpkgsDerivation+nixpkgsRelease = NixpkgsDerivationFetchFromGitHub {+ nixpkgsDerivationOwner = "NixOS"+ , nixpkgsDerivationRepo = "nixpkgs"+ , nixpkgsDerivationRev = "331800de5053fcebacf6813adb5db9c9dca22a0c"+ , nixpkgsDerivationSha256 = "sha256-x5UQuRsH3MqI0U9afaXSNqzTPSeZlRLvFAav2Ux1pNw="+ , nixpkgsDerivationAllowUnfree = True+ }++getSubDrivers :: (MonadReader ctx m, HasBrowserDependencies ctx) => FilePath -> m [DriverConfig]+getSubDrivers dir = getContext browserDependencies >>= \case+ BrowserDependenciesChrome {..} -> return [+ DriverConfigChromedriver {+ driverConfigChromedriver = browserDependenciesChromeChromedriver+ , driverConfigChrome = browserDependenciesChromeChrome+ , driverConfigLogDir = Just dir+ , driverConfigChromedriverFlags = []+ , driverConfigChromedriverExtraEnv = Nothing+ }]+ BrowserDependenciesFirefox {..} -> return [+ DriverConfigGeckodriver {+ driverConfigGeckodriver = browserDependenciesFirefoxGeckodriver+ , driverConfigFirefox = browserDependenciesFirefoxFirefox+ , driverConfigLogDir = Just dir+ , driverConfigGeckodriverFlags = []+ , driverConfigGeckodriverExtraEnv = Nothing+ }]+++tryFindSeleniumJar :: FilePath -> IO FilePath+tryFindSeleniumJar path = (T.unpack . T.strip . T.pack) <$> readCreateProcess (proc "find" [path, "-name", "*.jar"]) ""
+ tests/Spec.hs view
@@ -0,0 +1,16 @@+{-# OPTIONS_GHC -F -pgmF sandwich-discover #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++module Spec where++import Test.Sandwich hiding (BrowserToUse(..))+import TestLib.Types++#insert_test_imports+++spec :: SpecWithWebDriver+spec = describe "Selenium tests" $ do+ $(getSpecFromFolder defaultGetSpecFromFolderOptions)
+ tests/Spec/Actions.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NumericUnderscores #-}++module Spec.Actions where++import Data.Aeson as A+import Data.String.Interpolate+import qualified Data.Text.Lazy.Encoding as TLE+import System.FilePath+import Test.Sandwich+import Test.WebDriver+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Mouse+import TestLib.Types++-- import Control.Monad.IO.Unlift+-- import Control.Concurrent+++setUp :: (+ HasStaticServerContext context, HasSession context+ ) => SpecFree context IO () -> SpecFree context IO ()+setUp x = before "Open test page" openSimpleTestPage $ before "scroll to clickable box" scrollToClickableBox x++tests :: SessionSpec+tests = introduceSession $ describe "Actions" $ setUp $ do+ it "moveToCenter" $ do+ Just dir <- getCurrentFolder+ saveScreenshot (dir </> "before.png")++ -- TODO: how to test this? Might need to detect mouseover events+ pending++ -- box <- findElem (ByCSS "#clickable-box")+ -- clickCenter box+ -- getBoundingClientRect "#clickable-box" >>= \bcr -> info [i|bcr: #{bcr}|]+ -- getLastMouseEvent >>= \lme -> info [i|lme: #{lme}|]++ it "clickCenter" $ do+ findElem (ByCSS "#clickable-box") >>= clickCenter+ center <- getElementCenter "#clickable-box"+ Just MouseEvent { eventType=MouseEventTypeClick, .. } <- getLastMouseEvent++ -- liftIO $ threadDelay 2_000_000+ -- Just dir <- getCurrentFolder+ -- saveScreenshot (dir </> "click.png")+ -- ignoreReturn $ executeJS [] [i|document.querySelectorAll('div.magic').forEach(div => div.remove());|]+ -- liftIO $ threadDelay 2_000_000++ assertWithinPixels center (fromIntegral clientX, fromIntegral clientY) 25++ it "doubleClick" $ do+ findElem (ByCSS "#clickable-box") >>= doubleClickCenter++ -- liftIO $ threadDelay 2_000_000+ -- Just dir <- getCurrentFolder+ -- saveScreenshot (dir </> "doubleclick.png")+ -- ignoreReturn $ executeJS [] [i|document.querySelectorAll('div.magic').forEach(div => div.remove());|]+ -- liftIO $ threadDelay 2_000_000++ center <- getElementCenter "#clickable-box"+ Just MouseEvent { eventType=MouseEventTypeDoubleClick, .. } <- getLastMouseEvent+ assertWithinPixels center (fromIntegral clientX, fromIntegral clientY) 25+++scrollToClickableBox :: (HasSession ctx) => ExampleT ctx IO ()+scrollToClickableBox = do+ -- { behavior: 'smooth', block: 'nearest', inline: 'nearest' }+ executeJS [] [i|document.querySelector("\#clickable-box").scrollIntoView()|]++getLastMouseEvent :: (HasSession ctx) => ExampleT ctx IO (Maybe MouseEvent)+getLastMouseEvent = do+ executeJS [] [i|return document.querySelector("\#last-mouse-event").innerText|] >>= \case+ "{}" -> return Nothing+ json -> case A.eitherDecode (TLE.encodeUtf8 json) of+ Left err -> expectationFailure [i|Failed to decode last mouse event: #{err}|]+ Right x -> pure x
+ tests/Spec/CommandContexts.hs view
@@ -0,0 +1,63 @@++module Spec.CommandContexts where++import Data.String.Interpolate+import Test.Sandwich+import Test.Sandwich.Waits+import Test.WebDriver.Commands+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Command contexts" $ before "Open test page" openSimpleTestPage $ do+ it "getCurrentWindow / focusWindow" $ do+ h <- getCurrentWindow+ info [i|Got current window: #{h}|]++ it "focusWindow" $ do+ getCurrentWindow >>= focusWindow++ it "windows" $ do+ ws <- windows+ info [i|windows: #{ws}|]++ it "focusFrame" $ do+ (length <$> findElems (ByCSS ".input-box")) >>= (`shouldBe` 3)++ findElem (ByCSS "#frame1") >>= focusFrame . WithElement+ (length <$> findElems (ByCSS ".input-box")) >>= (`shouldBe` 1)++ it "focusParentFrame" $ do+ focusParentFrame+ (length <$> findElems (ByCSS ".input-box")) >>= (`shouldBe` 3)++ it "maximize" $ do+ maximize++ it "minimize" $ do+ minimize++ it "fullscreen" $ do+ fullscreen++ describe "rect" $ do+ it "getWindowRect" $ do+ rect <- getWindowRect+ info [i|Got rect: #{rect}|]++ it "setWindowRect" $ do+ -- TODO: modify the rect+ getWindowRect >>= setWindowRect++ it "windows / closeWindow" $ do+ findElem (ByCSS "#openWindowButton") >>= click++ waitUntil 30 $ do+ (length <$> windows) >>= (`shouldBe` 2)++ getCurrentWindow >>= closeWindow++ waitUntil 30 $ do+ (length <$> windows) >>= (`shouldBe` 1)
+ tests/Spec/Cookies.hs view
@@ -0,0 +1,49 @@++module Spec.Cookies where++import qualified Data.List as L+import Data.Ord (comparing)+import Data.Text+import Test.Sandwich+import Test.WebDriver.Commands+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Cookies" $ before "Open test page" openSimpleTestPage $ do+ it "cookies" $ do+ cookies >>= (`shouldBe` [])++ setCookie (mkCookie "cookie1" "value1")+ (getCookieBasics <$> cookies) >>= (`shouldBe` [("cookie1", "value1")])++ it "cookie" $ do+ c <- cookie "cookie1"+ getCookieBasics [c] `shouldBe` [("cookie1", "value1")]++ it "setCookie" $ do+ setCookie (mkCookie "cookie1" "value1")+ (getCookieBasics <$> cookies) >>= (`shouldBe` [("cookie1", "value1")])++ it "deleteCookie" $ do+ deleteCookie "cookie1"+ cookies >>= (`shouldBe` [])++ it "deleteCookies" $ do+ setCookie (mkCookie "cookie1" "value1")+ setCookie (mkCookie "cookie2" "value2")+ (getCookieBasics <$> cookies) >>= (`shouldBe` [+ ("cookie1", "value1")+ , ("cookie2", "value2")+ ])++ deleteCookies+ cookies >>= (`shouldBe` [])+++getCookieBasics :: [Cookie] -> [(Text, Text)]+getCookieBasics = L.sortBy (comparing fst) . fmap go+ where+ go (Cookie {..}) = (cookName, cookValue)
+ tests/Spec/DocumentHandling.hs view
@@ -0,0 +1,37 @@++module Spec.DocumentHandling where++import Data.Aeson as A+import Data.String.Interpolate+import Data.Text+import Test.Sandwich+import Test.Sandwich.Waits+import Test.WebDriver.Commands+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Document handling" $ before "Open test page" openSimpleTestPage $ do+ it "getSource" $ do+ src <- getSource+ src `textShouldContain` "Test page"+ src `textShouldContain` [i|<a id="click-here-link" href="\#foo">Click here</a>|]++ it "executeJS" $ do+ () <- executeJS [] [i|document.querySelector("\#input1").value = "asdf";|]++ waitUntil 5 $ do+ findElem (ByCSS "#input1") >>= (`prop` "value") >>= (`shouldBe` (Just (A.String "asdf")))++ executeJS [] [i|return document.querySelector("\#input1").value;|]+ >>= (`shouldBe` ("asdf" :: Text))++ executeJS [] [i|return document.title;|] >>= (`shouldBe` ("Test page" :: String))++ it "asyncJS" $ do+ asyncJS [] [i|setTimeout(() => arguments[0](42), 5);|]+ >>= (`shouldBe` (Just (42 :: Int)))++ asyncJS [] [i|arguments[0](document.title);|] >>= (`shouldBe` (Just ("Test page" :: String)))
+ tests/Spec/ElementInteraction.hs view
@@ -0,0 +1,37 @@++module Spec.ElementInteraction where++import Data.Aeson as A+import Data.String.Interpolate+import Test.Sandwich+import Test.Sandwich.Waits+import Test.WebDriver.Commands+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Element interaction" $ before "Open test page" openSimpleTestPage $ do+ it "click" $ do+ findElem (ByCSS "#numberLabel") >>= getText >>= (`shouldBe` "0")++ findElem (ByCSS "#incrementButton") >>= click+ findElem (ByCSS "#numberLabel") >>= getText >>= (`shouldBe` "1")++ findElem (ByCSS "#incrementButton") >>= click+ findElem (ByCSS "#numberLabel") >>= getText >>= (`shouldBe` "2")++ it "clearInput" $ do+ () <- executeJS [] [i|document.querySelector("\#input1").value = "asdf";|]+ waitUntil 5 $ do+ findElem (ByCSS "#input1") >>= (`prop` "value") >>= (`shouldBe` (Just (A.String "asdf")))++ findElem (ByCSS "#input1") >>= clearInput+ waitUntil 5 $ do+ findElem (ByCSS "#input1") >>= (`prop` "value") >>= (`shouldBe` (Just (A.String "")))++ it "sendKeys" $ do+ findElem (ByCSS "#input1") >>= sendKeys "fdsa"+ waitUntil 5 $ do+ findElem (ByCSS "#input1") >>= (`prop` "value") >>= (`shouldBe` (Just (A.String "fdsa")))
+ tests/Spec/ElementRetrieval.hs view
@@ -0,0 +1,50 @@++module Spec.ElementRetrieval where++import Test.Sandwich+import Test.WebDriver+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+import UnliftIO.Exception+++tests :: SessionSpec+tests = introduceSession $ describe "Element retrieval" $ before "Open test page" openSimpleTestPage $ do+ describe "findElem" $ do+ it "ByCSS" $ do+ findElem (ByCSS "#incrementButton") >>= getText >>= (`shouldBe` "Increment")++ it "ByLinkText" $ do+ findElem (ByLinkText "Click here") >>= (`attr` "id") >>= (`shouldBe` (Just "click-here-link"))++ it "ByPartialLinkText" $ do+ findElem (ByPartialLinkText "here") >>= (`attr` "id") >>= (`shouldBe` (Just "click-here-link"))++ it "ByTag" $ do+ findElem (ByTag "label") >>= (`attr` "id") >>= (`shouldBe` (Just "numberLabel"))++ it "ByXPath" $ do+ findElem (ByXPath "//a[@id='click-here-link']") >>= getText >>= (`shouldBe` "Click here")++ it "Nonexistent" $ do+ Left (FailedCommand {..}) <- try $ findElem (ByCSS ".nonexistent-element")+ rspError `shouldBe` NoSuchElement++ it "findElems" $ do+ (length <$> findElems (ByCSS ".input-box")) >>= (`shouldBe` 3)++ it "findElemFrom" $ do+ container <- findElem (ByCSS ".input-boxes")+ findElemFrom container (ByCSS "#input1") >>= (`attr` "class") >>= (`shouldBe` (Just "input-box"))++ it "findElemsFrom" $ do+ container <- findElem (ByCSS ".input-boxes")+ (length <$> findElemsFrom container (ByCSS ".input-box")) >>= (`shouldBe` 2)++ it "activeElem" $ do+ container <- findElem (ByCSS "#input1")+ click container++ el <- activeElem+ el `shouldBe` container
+ tests/Spec/ElementState.hs view
@@ -0,0 +1,60 @@++module Spec.ElementState where++import Data.Aeson as A+import Data.String.Interpolate+import Data.Text as T+import Test.Sandwich+import Test.WebDriver.Commands+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Element state" $ before "Open test page" openSimpleTestPage $ do+ it "isSelected" $ do+ findElem (ByCSS "#checkbox") >>= isSelected >>= (`shouldBe` False)++ findElem (ByCSS "#checkbox") >>= click+ findElem (ByCSS "#checkbox") >>= isSelected >>= (`shouldBe` True)++ findElem (ByCSS "#checkbox") >>= click+ findElem (ByCSS "#checkbox") >>= isSelected >>= (`shouldBe` False)++ it "attr" $ do+ findElem (ByTag "label") >>= (`attr` "id") >>= (`shouldBe` (Just "numberLabel"))++ it "prop" $ do+ findElem (ByCSS "#checkbox") >>= isSelected >>= (`shouldBe` False)+ findElem (ByCSS "#checkbox") >>= (`prop` "checked") >>= (`shouldBe` (Just (A.Bool False)))++ findElem (ByCSS "#checkbox") >>= click+ findElem (ByCSS "#checkbox") >>= isSelected >>= (`shouldBe` True)+ findElem (ByCSS "#checkbox") >>= (`prop` "checked") >>= (`shouldBe` (Just (A.Bool True)))++ it "cssProp" $ do+ Just color <- findElem (ByCSS "#input-red") >>= (`cssProp` "color")+ -- Depending on browser, this can produce a couple different values+ ["rgb(255,0,0)", "rgba(255,0,0,1)"] `shouldContain` [T.filter (/= ' ') color]++ it "getText" $ do+ findElem (ByCSS "#click-here-link") >>= getText >>= (`shouldBe` "Click here")++ it "tagName" $ do+ findElem (ByCSS "#incrementButton") >>= tagName >>= (`shouldBe` "button")+ findElem (ByCSS "#numberLabel") >>= tagName >>= (`shouldBe` "label")+ findElem (ByCSS "a") >>= tagName >>= (`shouldBe` "a")++ it "elemRect" $ do+ rect1 <- findElem (ByCSS "#input1") >>= elemRect+ info [i|rect1: #{rect1}|]+ rect2 <- findElem (ByCSS "#input2") >>= elemRect+ info [i|rect2: #{rect2}|]++ rectX rect1 `shouldBe` rectX rect2+ (rectY rect1 < rectY rect2) `shouldBe` True++ it "isEnabled" $ do+ findElem (ByCSS "#input1") >>= isEnabled >>= (`shouldBe` True)+ findElem (ByCSS "#input-disabled") >>= isEnabled >>= (`shouldBe` False)
+ tests/Spec/Logs.hs view
@@ -0,0 +1,35 @@+module Spec.Logs where++import Data.String.Interpolate+import qualified Data.Text as T+import Test.Sandwich+import Test.Sandwich.Waits+import Test.WebDriver.Commands+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Browser logs" $ before "Open test page" openSimpleTestPage $ do+ it "captures different log levels" $ do+ pendingOnFirefox++ ignoreReturn $ executeJS [] [i|+ console.log('info message');+ console.warn('warning message');+ console.error('error message');+ |]+ waitUntil 15 $ do+ logs <- getLogs "server"+ info [i|logs: #{logs}|]++ consoleLogs <- getLogs "browser"+ info [i|consoleLogs: #{consoleLogs}|]++ let logMessages = map logMsg consoleLogs+ let hasInfo = any (T.isInfixOf "info message") logMessages+ let hasWarning = any (T.isInfixOf "warning message") logMessages+ let hasError = any (T.isInfixOf "error message") logMessages++ (hasInfo || hasWarning || hasError) `shouldBe` True
+ tests/Spec/LogsBiDi.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE NumericUnderscores #-}++module Spec.LogsBiDi where++import Control.Monad.IO.Class+import Data.Foldable (toList)+import Data.Sequence+import Data.String.Interpolate+import Data.Text (Text)+import qualified Data.Text as T+import Test.Sandwich+import Test.Sandwich.Waits+import Test.WebDriver.Commands+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+import UnliftIO.IORef+++tests :: SessionSpec+tests = introduceSession $ describe "Browser logs via BiDi" $ before "Open test page" openSimpleTestPage $ do+ it "captures console.log messages" $ do+ -- This test should pass on Selenium 4, but we get an error connecting to the BiDi socket.+ pendingOnSelenium++ allLogEntries <- newIORef (mempty :: Seq LogEntry)++ let cb logEntry = atomicModifyIORef' allLogEntries (\x -> (x |> logEntry, ()))+ withRecordLogsViaBiDi defaultBiDiOptions cb $ do+ ignoreReturn $ executeJS [] [i|console.log('log message from haskell-webdriver');|]+ ignoreReturn $ executeJS [] [i|console.warn('warn message from haskell-webdriver');|]+ ignoreReturn $ executeJS [] [i|console.error('error message from haskell-webdriver');|]++ waitUntil 15 $ do+ entries <- toList <$> readIORef allLogEntries+ someMessageShouldContain entries "log message"+ someMessageShouldContain entries "warn message"+ someMessageShouldContain entries "error message"+++someMessageShouldContain :: MonadIO m => [LogEntry] -> Text -> m ()+someMessageShouldContain entries needle = case [x | x@(LogEntry {..}) <- entries, needle `T.isInfixOf` logMsg] of+ [] -> expectationFailure [i|Couldn't find a log message containing needle '#{needle}'|]+ _ -> return ()
@@ -0,0 +1,48 @@++module Spec.Navigation where++import Data.String.Interpolate+import Data.Text (Text)+import qualified Data.Text as T+import Network.URI+import Test.Sandwich+import Test.WebDriver.Commands+import Test.WebDriver.Types+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Navigation" $ before "Open test page" openSimpleTestPage $ do+ it "getCurrentURL / getTitle" $ do+ urlShouldEndWith "test.html"+ getTitle >>= (`shouldBe` "Test page")++ it "openPage / getCurrentURL / getTitle" $ do+ url <- parseAbsoluteURI <$> getCurrentURL >>= \case+ Nothing -> expectationFailure [i|Couldn't parse URI|]+ Just u -> pure u+ openPage $ show (url { uriPath = "/test2.html" })+ urlShouldEndWith "test2.html"+ getTitle >>= (`shouldBe` "Test page 2")++ it "back" $ do+ back+ urlShouldEndWith "test.html"++ it "forward" $ do+ forward+ urlShouldEndWith "test2.html"++ it "refresh" $ do+ refresh++ it "getTitle" $ do+ getTitle >>= (`shouldBe` "Test page 2")+++urlShouldEndWith :: (WebDriver m) => Text -> m ()+urlShouldEndWith suffix = do+ url <- getCurrentURL+ (suffix `T.isSuffixOf` (T.pack url)) `shouldBe` True
+ tests/Spec/ScreenCapture.hs view
@@ -0,0 +1,27 @@++module Spec.ScreenCapture where++import Control.Monad.IO.Class+import qualified Data.ByteString.Lazy as BL+import System.FilePath+import Test.Sandwich+import Test.WebDriver.Commands+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Screen capture" $ before "Open test page" openSimpleTestPage $ do+ it "screenshot" $ do+ Just dir <- getCurrentFolder+ screenshot >>= liftIO . BL.writeFile (dir </> "screenshot.png")++ it "screenshotElement" $ do+ Just dir <- getCurrentFolder+ e <- findElem (ByCSS ".frame-container")+ screenshotElement e >>= liftIO . BL.writeFile (dir </> "screenshotElement.png")++ it "saveScreenshot" $ do+ Just dir <- getCurrentFolder+ saveScreenshot (dir </> "saveScreenshot.png")
+ tests/Spec/SeleniumSpecific/Mobile.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++module Spec.SeleniumSpecific.Mobile where++import Test.Sandwich+-- import Test.WebDriver+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+-- import UnliftIO.Concurrent+++tests :: SessionSpec+tests = introduceMobileSession $ describe "Mobile" $ before "Open test page" openSimpleTestPage $ do+ it "Pauses" $ do+ -- threadDelay 999_999_000_000+ pending
+ tests/Spec/SeleniumSpecific/Uploads.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}++module Spec.SeleniumSpecific.Uploads where++import Control.Monad.IO.Class+import qualified Data.Text as T+import System.FilePath+import Test.Sandwich+import Test.WebDriver+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Uploads" $ before "Open test page" (openStaticServerUrl "/test_file_upload.html") $ do+ it "Upload file with sendKeys" $ do+ Just dir <- getCurrentFolder+ let fp = dir </> "test-file.txt"+ liftIO $ writeFile fp "file contents"+ findElem (ByCSS "input") >>= sendKeys (T.pack fp)+ findElem (ByCSS "#contents") >>= getText >>= (`shouldBe` "test-file.txt 13")++ describe "Selenium specific" $ do+ it "upload file to grid and use sendKeys to upload to browser" $ do+ pendingOnNonSelenium+ filePath <- seleniumUploadRawFile "/shopping.txt" 0 "Eggs, Ham, Cheese"+ findElem (ByCSS "input") >>= sendKeys filePath+ findElem (ByCSS "#contents") >>= getText >>= (`shouldBe` "shopping.txt 17")
+ tests/Spec/Sessions.hs view
@@ -0,0 +1,62 @@++module Spec.Sessions where++import Data.String.Interpolate+import Test.Sandwich+import Test.WebDriver.Commands+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Sessions" $ before "Open test page" openSimpleTestPage $ do+ -- createSession is already tested in introduceSession++ it "status" $ do+ status <- serverStatus+ info [i|Got status: #{status}|]++ -- TODO: test closeSession without breaking the context+ it "closeSession" $ do+ pending++ describe "Timeouts" $ do+ describe "Bulk timeout functions" $ do+ it "getTimeouts" $ do+ timeouts <- getTimeouts+ info [i|Got timeouts: #{timeouts}|]++ it "setTimeouts" $ do+ let timeouts = Timeouts {+ timeoutsScript = Just 1+ , timeoutsPageLoad = Just 2+ , timeoutsImplicit = Just 3+ }+ setTimeouts timeouts++ getTimeouts >>= (`shouldBe` timeouts)++ describe "Individual timeout functions" $ do+ it "setScriptTimeout" $ do+ setScriptTimeout (Just 11)+ getTimeouts >>= (`shouldBe` (Timeouts (Just 11) (Just 2) (Just 3)))++ setScriptTimeout Nothing+ getTimeouts >>= (`shouldBe` (Timeouts Nothing (Just 2) (Just 3)))++ it "setPageLoadTimeout" $ do+ setPageLoadTimeout 12+ getTimeouts >>= (`shouldBe` (Timeouts Nothing (Just 12) (Just 3)))++ it "setImplicitWait" $ do+ setImplicitWait 13+ getTimeouts >>= (`shouldBe` (Timeouts Nothing (Just 12) (Just 13)))++ -- it "sessions" $ do+ -- xs <- sessions+ -- info [i|Got sessions: #{xs}|]++ -- it "getActualCaps" $ do+ -- caps <- getActualCaps+ -- info [i|Got actual caps: #{caps}|]
+ tests/Spec/UserPrompts.hs view
@@ -0,0 +1,15 @@++module Spec.UserPrompts where++import Test.Sandwich+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "User prompts" $ before "Open test page" openSimpleTestPage $ do+ it "dismissAlert" $ pending+ it "acceptAlert" $ pending+ it "getAlertText" $ pending+ it "replyToAlert" $ pending
+ tests/TestLib/Contexts/BrowserDependencies.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module TestLib.Contexts.BrowserDependencies where++import Control.Monad.IO.Unlift+import Data.String.Interpolate+import Test.Sandwich hiding (BrowserToUse(..))+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Nix+import TestLib.Types+import TestLib.Types.Cli+++introduceBrowserDependencies :: forall m context. (+ MonadUnliftIO m, HasBaseContext context, HasNixContext context, HasCommandLineOptions context UserOptions+ ) => SpecFree (LabelValue "browserDependencies" BrowserDependencies :> context) m () -> SpecFree context m ()+introduceBrowserDependencies = introduce "Introduce browser dependencies" browserDependencies alloc (const $ return ())+ where+ alloc = do+ UserOptions {..} <- getUserCommandLineOptions++ deps <- case optBrowserToUse of+ UseChrome ->+ BrowserDependenciesChrome <$> getBinaryViaNixPackage @"google-chrome-stable" "google-chrome"+ <*> getBinaryViaNixPackage @"chromedriver" "chromedriver"+ <*> pure optChromeNoSandbox+ UseFirefox ->+ BrowserDependenciesFirefox <$> getBinaryViaNixPackage @"firefox" "firefox"+ <*> getBinaryViaNixPackage @"geckodriver" "geckodriver"+ debug [i|Got browser dependencies: #{deps}|]+ return deps
+ tests/TestLib/Contexts/Selenium4.hs view
@@ -0,0 +1,55 @@++module TestLib.Contexts.Selenium4 where++import Data.String.Interpolate+import Data.Text+++selenium4Derivation :: Text+selenium4Derivation = [i|+{+ lib,+ stdenv,+ fetchurl,+ makeWrapper,+ jre,+}:++let+ minorVersion = "4.29";+ patchVersion = "0";++in+stdenv.mkDerivation rec {+ pname = "selenium-server";+ version = "${minorVersion}.${patchVersion}";++ src = fetchurl {+ url = "https://github.com/SeleniumHQ/selenium/releases/download/selenium-${version}/selenium-server-${version}.jar";+ hash = "sha256-og3RlPbRU7Mj5F+QJ1cU3klbXSLxWH4ZcNjgphHBkMU=";+ };++ dontUnpack = true;++ nativeBuildInputs = [ makeWrapper ];+ buildInputs = [ jre ];++ installPhase = ''+ mkdir -p $out/share/lib/${pname}-${version}+ cp $src $out/share/lib/${pname}-${version}/${pname}-${version}.jar+ makeWrapper ${jre}/bin/java $out/bin/selenium-server+ '';++ meta = with lib; {+ homepage = "http://www.seleniumhq.org/";+ description = "Selenium Server for remote WebDriver";+ sourceProvenance = with sourceTypes; [ binaryBytecode ];+ license = licenses.asl20;+ maintainers = with maintainers; [+ thomasjm+ ];+ mainProgram = "selenium-server";+ platforms = platforms.all;+ };+}+|]
+ tests/TestLib/Contexts/Session.hs view
@@ -0,0 +1,120 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}++module TestLib.Contexts.Session (+ introduceSession+ , introduceSession'++ , introduceMobileSession++ , pendingOnSelenium+ , pendingOnNonSelenium+ , pendingOnSelenium3+ , pendingOnFirefox+ ) where++import Control.Exception.Safe+import Control.Monad.IO.Unlift+import Control.Monad.Reader+import Data.Function+import Data.Maybe+import Lens.Micro+import Test.Sandwich+import Test.WebDriver+import Test.WebDriver.Capabilities+import TestLib.Types+import TestLib.Types.Cli++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KM+#else+import qualified Data.HashMap.Strict as KM+#endif+++introduceSession :: forall m context. (+ MonadUnliftIO m, MonadMask m+ , HasBrowserDependencies context, HasWebDriverContext context, HasDriverConfig context, HasCommandLineOptions context UserOptions+ ) => SpecFree (LabelValue "session" Session :> context) m () -> SpecFree context m ()+introduceSession = introduceSession' enableBiDi+ where+ enableBiDi :: Capabilities -> ExampleT context m Capabilities+ enableBiDi x = do+ getContext driverConfig >>= \case+ DriverConfigSeleniumJar { driverConfigSeleniumVersion=(Just Selenium3) } -> return x+ _ -> x+ & set capabilitiesWebSocketUrl (Just True)+ & return++introduceSession' :: forall m context. (+ MonadUnliftIO m, MonadMask m+ , HasBrowserDependencies context, HasWebDriverContext context, HasDriverConfig context, HasCommandLineOptions context UserOptions+ ) => (Capabilities -> ExampleT context m Capabilities) -> SpecFree (LabelValue "session" Session :> context) m () -> SpecFree context m ()+introduceSession' modifyCaps = introduce "Introduce session" session alloc cleanup+ where+ alloc = do+ browserDeps <- getContext browserDependencies+ wdc <- getContext webdriverContext++ UserOptions {..} <- getUserCommandLineOptions+ caps <- getCapabilities (fromMaybe False optHeadlessTests) browserDeps >>= modifyCaps++ dc <- getContext driverConfig++ startSession wdc dc caps "session1"++ cleanup sess = do+ wdc <- getContext webdriverContext+ closeSession wdc sess+++introduceMobileSession :: forall m context. (+ MonadUnliftIO m, MonadMask m+ , HasBrowserDependencies context, HasWebDriverContext context, HasDriverConfig context, HasCommandLineOptions context UserOptions+ ) => SpecFree (LabelValue "session" Session :> context) m () -> SpecFree context m ()+introduceMobileSession = introduceSession' modifyCaps+ where+ modifyCaps :: Capabilities -> ExampleT context m Capabilities+ modifyCaps x = x+ & over (capabilitiesGoogChromeOptions . _Just) modifyChromeOptions+ & over (capabilitiesMozFirefoxOptions . _Just) modifyFirefoxOptions+ & return++ modifyChromeOptions :: ChromeOptions -> ChromeOptions+ modifyChromeOptions x = x+ & set chromeOptionsMobileEmulation (Just (ChromeMobileEmulationSpecificDevice "Pixel 7"))++ modifyFirefoxOptions :: FirefoxOptions -> FirefoxOptions+ modifyFirefoxOptions x = x+ & over firefoxOptionsPrefs (Just . fromMaybe mempty)+ & over (firefoxOptionsPrefs . _Just) (KM.insert "general.useragent.override" "Mozilla/5.0 (iPhone; CPU iPhone OS 14_0 like Mac OS X)")++ & over firefoxOptionsArgs (Just . fromMaybe [])+ & over (firefoxOptionsArgs . _Just) (\xs -> "--width=375" : "--height=667" : xs)++pendingOnNonSelenium :: (MonadReader ctx m, HasDriverConfig ctx, MonadIO m) => m ()+pendingOnNonSelenium = do+ getContext driverConfig >>= \case+ DriverConfigSeleniumJar {} -> return ()+ _ -> pending++pendingOnSelenium :: (MonadReader ctx m, HasDriverConfig ctx, MonadIO m) => m ()+pendingOnSelenium = do+ getContext driverConfig >>= \case+ DriverConfigSeleniumJar {} -> pending+ _ -> return ()++pendingOnSelenium3 :: (MonadReader ctx m, HasDriverConfig ctx, MonadIO m) => m ()+pendingOnSelenium3 = do+ getContext driverConfig >>= \case+ DriverConfigSeleniumJar {driverConfigSeleniumVersion=(Just Selenium3)} -> pending+ _ -> return ()++pendingOnFirefox :: (MonadReader ctx m, HasDriverConfig ctx, MonadIO m) => m ()+pendingOnFirefox = do+ getContext driverConfig >>= \case+ DriverConfigGeckodriver {} -> pending+ DriverConfigSeleniumJar {driverConfigSubDrivers=[DriverConfigGeckodriver {}]} -> pending+ _ -> return ()
+ tests/TestLib/Contexts/StaticServer.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++module TestLib.Contexts.StaticServer (+ introduceStaticServer++ , staticServer+ , HasStaticServerContext+ , StaticServerContext(..)++ , openStaticServerUrl+ , openSimpleTestPage+ ) where++import Control.Monad+import Control.Monad.Catch (MonadCatch)+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Reader+import Data.Function+import Data.String.Interpolate+import GHC.Stack+import Network.Wai.Application.Static+import Network.Wai.Handler.Warp+import System.FilePath+import Test.Sandwich hiding (BrowserToUse(..))+import Test.Sandwich.Contexts.Util.Ports+import Test.WebDriver.Commands+import Test.WebDriver.Types+import TestLib.Types+import UnliftIO.Async+import UnliftIO.Directory+import UnliftIO.Exception+import UnliftIO.MVar+++introduceStaticServer :: forall context m. (+ HasCallStack, MonadUnliftIO m, MonadCatch m+ )+ => SpecFree (LabelValue "staticServer" StaticServerContext :> context) m ()+ -> SpecFree context m ()+introduceStaticServer = introduceWith "Introduce static server" staticServer withAlloc+ where+ withAlloc action = do+ staticDir <- getCurrentDirectory >>= findGitRoot >>= \case+ Just dir -> pure (dir </> "test-static")+ Nothing -> expectationFailure [i|Couldn't find test-static directory|]+ info [i|Got static dir: #{staticDir}|]+ let serverStaticConf = defaultFileServerSettings staticDir++ port <- findFreePortOrException++ baton <- newEmptyMVar++ let serverConf = defaultSettings+ & setPort (fromIntegral port)+ & setBeforeMainLoop (putMVar baton ())++ bracket+ (do+ asy <- async $ liftIO $ runSettings serverConf (staticApp serverStaticConf)+ takeMVar baton+ info [i|Started static server on http://localhost:#{port}|]+ return asy+ )+ cancel+ (\_ -> void $ action (StaticServerContext "localhost" port))++findGitRoot :: MonadIO m => FilePath -> m (Maybe FilePath)+findGitRoot dir = do+ let gitDir = dir </> ".git"+ doesDirectoryExist gitDir >>= \case+ True -> return (Just dir)+ False -> do+ let parent = takeDirectory dir+ if parent == dir+ then return Nothing+ else findGitRoot parent++openStaticServerUrl :: (+ MonadReader context m, HasStaticServerContext context, WebDriver m+ ) => FilePath -> m ()+openStaticServerUrl url = do+ StaticServerContext {..} <- getContext staticServer+ openPage [i|http://#{staticServerHostname}:#{staticServerPort}#{url}|]++openSimpleTestPage :: (+ MonadReader context m, HasStaticServerContext context, WebDriver m+ ) => m ()+openSimpleTestPage = openStaticServerUrl "/test.html"
+ tests/TestLib/Contexts/WebDriver.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}++module TestLib.Contexts.WebDriver (+ introduceWebDriverContext+ ) where++import Control.Monad+import Control.Monad.Catch (MonadCatch)+import Control.Monad.IO.Unlift+import GHC.Stack+import Test.Sandwich hiding (BrowserToUse(..))+import Test.WebDriver+import TestLib.Types+import UnliftIO.Exception+++introduceWebDriverContext :: forall context m. (+ HasCallStack, MonadUnliftIO m, MonadCatch m+ )+ => SpecFree (LabelValue "webdriver" WebDriverContext :> context) m ()+ -> SpecFree context m ()+introduceWebDriverContext = introduceWith "Introduce WebDriver" webdriverContext withAlloc+ where+ withAlloc action = bracket mkEmptyWebDriverContext teardownWebDriverContext (void . action)
+ tests/TestLib/Mouse.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiWayIf #-}++module TestLib.Mouse (+ assertWithinPixels+ , getBoundingClientRect+ , getElementCenter++ , MouseEventType(..)+ , MouseEvent(..)+ , ClientRect(..)+ ) where++import Control.Monad.IO.Class+import Data.Aeson as A+import Data.String.Interpolate+import qualified Data.Text as T+import GHC.Generics+import Test.Sandwich+import Test.WebDriver+import TestLib.Types+++data MouseEventType =+ MouseEventTypeClick+ | MouseEventTypeDoubleClick+ | MouseEventTypeContextMenu+ deriving (Show, Eq)+instance FromJSON MouseEventType where+ parseJSON (String "click") = pure MouseEventTypeClick+ parseJSON (String "dblclick") = pure MouseEventTypeDoubleClick+ parseJSON (String "contextmenu") = pure MouseEventTypeContextMenu+ parseJSON x = fail [i|Unexpected mouse event type: #{x}|]++data MouseEvent = MouseEvent {+ eventType :: MouseEventType+ , screenX :: Int+ , screenY :: Int+ , clientX :: Int+ , clientY :: Int+ , pageX :: Int+ , pageY :: Int+ , button :: Int+ } deriving (Show, Eq, Generic, FromJSON)++data ClientRect = ClientRect {+ bottom :: Double+ , height :: Double+ , left :: Double+ , right :: Double+ , top :: Double+ , width :: Double+ , x :: Double+ , y :: Double+ } deriving (Show, Eq, Generic, FromJSON)++assertWithinPixels :: (MonadIO m) => (Double, Double) -> (Double, Double) -> Double -> m ()+assertWithinPixels (x1, y1) (x2, y2) tolerance =+ if | d <= tolerance -> return ()+ | otherwise -> expectationFailure [i|Points were supposed to be within #{tolerance}, but distance was #{d}|]+ where+ d = sqrt ((x2 - x1)**2 + (y2 - y1)**2)++getBoundingClientRect :: (HasSession ctx) => T.Text -> ExampleT ctx IO ClientRect+getBoundingClientRect cssSelector =+ executeJS [JSArg cssSelector] [i|return document.querySelector(arguments[0]).getBoundingClientRect()|]++getElementCenter :: (HasSession ctx) => T.Text -> ExampleT ctx IO (Double, Double)+getElementCenter cssSelector = do+ ClientRect {..} <- getBoundingClientRect cssSelector+ return (left + (width / 2.0), top + (height / 2.0))
+ tests/TestLib/Types.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module TestLib.Types (+ StaticServerContext(..)+ , staticServer+ , HasStaticServerContext++ , BrowserDependencies(..)+ , browserDependencies+ , HasBrowserDependencies++ , driverConfig+ , HasDriverConfig++ , webdriverContext+ , HasWebDriverContext++ , getCapabilities++ , session+ , HasSession++ , SeleniumVersion(..)++ , SessionSpec+ , SpecWithWebDriver+ ) where++import Control.Exception.Safe+import Control.Monad.IO.Unlift+import Data.ByteString+import qualified Data.ByteString.Lazy as BL+import Data.String.Interpolate+import Lens.Micro+import qualified Network.HTTP.Client as HC+import Network.HTTP.Types.Status as N+import Network.Socket (PortNumber)+import Test.Sandwich+import Test.Sandwich.Contexts.Nix+import Test.WebDriver+import Test.WebDriver.Capabilities+import Test.WebDriver.Types+import TestLib.Types.Cli+++-- * StaticServer++data StaticServerContext = StaticServerContext {+ staticServerHostname :: String+ , staticServerPort :: PortNumber+ }++staticServer :: Label "staticServer" StaticServerContext+staticServer = Label++type HasStaticServerContext context = HasLabel context "staticServer" StaticServerContext++-- * BrowserDependencies++data BrowserDependencies = BrowserDependenciesChrome {+ browserDependenciesChromeChrome :: FilePath+ , browserDependenciesChromeChromedriver :: FilePath+ , browserDependenciesChromeNoSandbox :: Maybe Bool+ }+ | BrowserDependenciesFirefox {+ browserDependenciesFirefoxFirefox :: FilePath+ , browserDependenciesFirefoxGeckodriver :: FilePath+ }+ deriving (Show)++browserDependencies :: Label "browserDependencies" BrowserDependencies+browserDependencies = Label++type HasBrowserDependencies context = HasLabel context "browserDependencies" BrowserDependencies++-- * WebDriver++driverConfig :: Label "driverConfig" DriverConfig+driverConfig = Label++type HasDriverConfig context = HasLabel context "driverConfig" DriverConfig++-- * WebDriver++webdriverContext :: Label "webdriver" WebDriverContext+webdriverContext = Label++type HasWebDriverContext context = HasLabel context "webdriver" WebDriverContext++-- * Session++session :: Label "session" Session+session = Label++type HasSession context = HasLabel context "session" Session++-- * Instances++instance (HasSession context, MonadIO m) => SessionState (ExampleT context m) where+ getSession = getContext session++ -- putSession sess = do+ -- sessVar <- getContext wdSession+ -- writeIORef sessVar sess++instance (MonadUnliftIO m, MonadCatch m) => WebDriverBase (ExampleT context m) where+ doCommandBase driver method path args = do+ let req = mkDriverRequest driver method path args+ -- debug [i|--> Full request: #{req} (#{showRequestBody (HC.requestBody req)})|]+ debug [i|--> #{HC.method req} #{HC.path req}#{HC.queryString req} (#{showRequestBody (HC.requestBody req)})|]+ response <- tryAny (liftIO $ HC.httpLbs req (_driverManager driver)) >>= either throwIO return+ let (N.Status code _) = HC.responseStatus response+ debug [i|<-- #{code} #{response}|]+ return response++ where+ showRequestBody :: HC.RequestBody -> ByteString+ showRequestBody (HC.RequestBodyLBS bytes) = BL.toStrict bytes+ showRequestBody (HC.RequestBodyBS bytes) = bytes+ showRequestBody _ = "<request body>"++-- * Config++getCapabilities :: MonadIO m => Bool -> BrowserDependencies -> m Capabilities+getCapabilities headless (BrowserDependenciesChrome {..}) = pure $ defaultCaps {+ _capabilitiesBrowserName = Just "chrome"+ , _capabilitiesGoogChromeOptions = Just $+ defaultChromeOptions+ & over (chromeOptionsArgs . non []) (if headless then (\xs -> "--headless" : [i|--window-size=1920,1080|] : xs) else id)+ & over (chromeOptionsArgs . non []) (if browserDependenciesChromeNoSandbox == Just True then ("--no-sandbox" :) else id)+ & set chromeOptionsBinary (Just browserDependenciesChromeChrome)+ }+getCapabilities headless (BrowserDependenciesFirefox {..}) = pure $ defaultCaps {+ _capabilitiesBrowserName = Just "firefox"+ , _capabilitiesMozFirefoxOptions = Just $+ defaultFirefoxOptions+ & set firefoxOptionsBinary (Just browserDependenciesFirefoxFirefox)+ & over (firefoxOptionsArgs . non []) (if headless then ("-headless" :) else id)+ }++-- * Spec types++type SpecWithWebDriver = forall context. (+ HasBaseContext context+ , HasCommandLineOptions context UserOptions+ , HasBrowserDependencies context+ , HasDriverConfig context+ , HasWebDriverContext context+ , HasStaticServerContext context+ , HasNixContext context+ ) => SpecFree context IO ()++type SessionSpec = forall context. (+ HasBaseContext context+ , HasCommandLineOptions context UserOptions+ , HasBrowserDependencies context+ , HasDriverConfig context+ , HasWebDriverContext context+ , HasStaticServerContext context+ ) => SpecFree context IO ()
+ tests/TestLib/Types/Cli.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE RankNTypes #-}++module TestLib.Types.Cli where++import Options.Applicative+++data BrowserToUse = UseChrome | UseFirefox+ deriving (Show, Eq)++browserToUse :: (forall f a. Mod f a) -> Parser BrowserToUse+browserToUse maybeInternal =+ flag' UseFirefox (long "use-firefox" <> help "Use Firefox" <> maybeInternal)+ <|> flag UseChrome UseChrome (long "use-chrome" <> help "Use Chrome (default)" <> maybeInternal)++data UserOptions = UserOptions {+ optChromeBinary :: Maybe FilePath+ , optChromeDriver :: Maybe FilePath+ , optChromeNoSandbox :: Maybe Bool++ , optFirefoxBinary :: Maybe FilePath+ , optGeckoDriver :: Maybe FilePath++ , optBrowserToUse :: BrowserToUse++ , optHeadlessTests :: Maybe Bool+ } deriving (Show)++userOptions :: Parser UserOptions+userOptions = UserOptions+ <$> optional (strOption (long "webdriver-chrome" <> help "Path to Chrome binary"))+ <*> optional (strOption (long "webdriver-chromedriver" <> help "Path to chromedriver"))+ <*> optional (flag False True (long "webdriver-chrome-no-sandbox" <> help "Pass the --no-sandbox flag to Chrome (useful in GitHub Actions when installing Chrome via Nix)"))++ <*> optional (strOption (long "webdriver-firefox" <> help "Path to Firefox binary"))+ <*> optional (strOption (long "webdriver-geckodriver" <> help "Path to geckodriver"))++ <*> browserToUse mempty++ <*> optional (flag False True (long "headless-tests" <> help "Run the test browser in headless mode"))
+ tests/TestLib/Waits.hs view
@@ -0,0 +1,59 @@++module TestLib.Waits where++import Control.Exception.Safe+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Retry+import Data.String.Interpolate+import Network.Socket+import UnliftIO.Timeout++++-- * Socket waits++-- | Each individual connect attempt needs a timeout to prevent it from hanging+-- indefinitely. This policy allows us to make that timeout length adaptive,+-- based on the 'RetryStatus' of the outer retry policy.+--+-- Thus, the first attempt to connect will have a short timeout (currently 100ms),+-- and then successive attempts will get longer timeouts via "FullJitter" backoff.+-- The goals of this are twofold:+--+-- 1) If a connect call hangs during the first few attempts, it is timed out quickly+-- and re-attempted, so on a healthy network you aren't penalized too much by the hang.+-- The outer retry policy can control the time between attempts, so the user can set+-- it high enough to make this be the case.+--+-- 2) If the network is slow, we will eventually reach the maximum timeout of 3 seconds,+-- which should be long enough. Note that the popular wait-for script uses 1 second+-- timeouts, so this is extra conservative:+-- https://github.com/eficode/wait-for/blob/7586b3622f010808bb2027c19aaf367221b4ad54/wait-for#L72+connectRetryPolicy :: MonadIO m => RetryPolicyM m+connectRetryPolicy = capDelay (3000000) (fullJitterBackoff 100000)++waitForSocket :: (+ MonadUnliftIO m, MonadLogger m, MonadMask m+ )+ => RetryPolicyM m+ -> AddrInfo+ -> m ()+waitForSocket policy addr = recoverAll policy $ \retryStatus@(RetryStatus {..}) -> do+ flip withException (\(e :: SomeException) -> logErrorN [i|waitForSocket: failed to connect to #{addr}: #{e}|]) $ do+ when (rsIterNumber > 0) $+ logDebugN [i|waitForSocket: attempt \##{rsIterNumber} to connect to #{addr}|]++ bracket (liftIO initSocket) (liftIO . close) $ \sock -> do+ connectTimeoutUs <- (getRetryPolicyM connectRetryPolicy) retryStatus >>= \case+ Nothing -> throwIO $ userError "Timeout due to connect retry policy"+ Just us -> pure us++ timeout connectTimeoutUs (liftIO $ connect sock (addrAddress addr)) >>= \case+ Nothing -> throwIO $ userError "Timeout in connect attempt"+ Just () -> pure ()++ where+ initSocket = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
webdriver.cabal view
@@ -1,22 +1,22 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0.+-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack name: webdriver-version: 0.12.0.1+version: 0.15.0.0 synopsis: a Haskell client for the Selenium WebDriver protocol-description: A Selenium WebDriver client for Haskell.- You can use it to automate browser sessions- for testing, system administration, etc.+description: A WebDriver client for Haskell.+ You can use it to automate browser sessions for testing, system administration, etc.+ Here are some relevant links: .- For more information about Selenium itself, see- <http://seleniumhq.org/>+ * <https://www.w3.org/TR/webdriver2/>+ * <https://www.selenium.dev/>+ * <https://github.com/mozilla/geckodriver>+ * <https://developer.chrome.com/docs/chromedriver> .- To find out what's been changed in this version and others,- see the change log at- <https://github.com/haskell-webdriver/haskell-webdriver/blob/main/CHANGELOG.md>+ See the announcement blog post [here](https://thomasjm.github.io/posts/webdriver-13) to learn about the changes in @0.13.0.0@. category: Web, Browser, Testing, WebDriver, Selenium homepage: https://github.com/haskell-webdriver/haskell-webdriver#readme bug-reports: https://github.com/haskell-webdriver/haskell-webdriver/issues@@ -26,12 +26,13 @@ license-file: LICENSE build-type: Simple tested-with:- GHC == 8.6.5- , GHC == 8.8.4- , GHC == 8.10.7- , GHC == 9.0.2- , GHC == 9.2.7- , GHC == 9.4.4+ GHC == 9.0.2+ , GHC == 9.2.8+ , GHC == 9.4.8+ , GHC == 9.6.7+ , GHC == 9.8.4+ , GHC == 9.10.2+ , GHC == 9.12.2 extra-source-files: README.md CHANGELOG.md@@ -44,63 +45,196 @@ exposed-modules: Test.WebDriver Test.WebDriver.Capabilities- Test.WebDriver.Chrome.Extension- Test.WebDriver.Class Test.WebDriver.Commands- Test.WebDriver.Commands.Internal- Test.WebDriver.Commands.Wait- Test.WebDriver.Common.Keys- Test.WebDriver.Common.Profile- Test.WebDriver.Config- Test.WebDriver.Cookies- Test.WebDriver.Exceptions- Test.WebDriver.Exceptions.Internal- Test.WebDriver.Firefox.Profile- Test.WebDriver.Internal- Test.WebDriver.JSON- Test.WebDriver.Monad- Test.WebDriver.Session- Test.WebDriver.Session.History+ Test.WebDriver.Keys+ Test.WebDriver.Profile Test.WebDriver.Types- Test.WebDriver.Utils+ Test.WebDriver.Waits+ Test.WebDriver.WD other-modules:- Test.WebDriver.IO+ Test.WebDriver.Capabilities.Aeson+ Test.WebDriver.Capabilities.ChromeOptions+ Test.WebDriver.Capabilities.FirefoxOptions+ Test.WebDriver.Capabilities.Platform+ Test.WebDriver.Capabilities.Proxy+ Test.WebDriver.Capabilities.Timeouts+ Test.WebDriver.Capabilities.UserPromptHandler+ Test.WebDriver.Commands.Actions+ Test.WebDriver.Commands.BiDi.NetworkActivity+ Test.WebDriver.Commands.BiDi.Session+ Test.WebDriver.Commands.CommandContexts+ Test.WebDriver.Commands.Cookies+ Test.WebDriver.Commands.DocumentHandling+ Test.WebDriver.Commands.ElementInteraction+ Test.WebDriver.Commands.ElementRetrieval+ Test.WebDriver.Commands.ElementState+ Test.WebDriver.Commands.Logs+ Test.WebDriver.Commands.Logs.BiDi+ Test.WebDriver.Commands.Logs.Chrome+ Test.WebDriver.Commands.Logs.Common+ Test.WebDriver.Commands.Logs.Firefox+ Test.WebDriver.Commands.Logs.Selenium+ Test.WebDriver.Commands.Navigation+ Test.WebDriver.Commands.ScreenCapture+ Test.WebDriver.Commands.SeleniumSpecific.HTML5+ Test.WebDriver.Commands.SeleniumSpecific.Misc+ Test.WebDriver.Commands.SeleniumSpecific.Mobile+ Test.WebDriver.Commands.SeleniumSpecific.Uploads+ Test.WebDriver.Commands.Sessions+ Test.WebDriver.Commands.UserPrompts+ Test.WebDriver.Exceptions+ Test.WebDriver.JSON+ Test.WebDriver.LaunchDriver+ Test.WebDriver.Util.Aeson+ Test.WebDriver.Util.Commands+ Test.WebDriver.Util.Ports+ Test.WebDriver.Util.Sockets+ Paths_webdriver hs-source-dirs: src default-extensions:- ScopedTypeVariables- OverloadedStrings FlexibleContexts FlexibleInstances- RecordWildCards+ LambdaCase NamedFieldPuns- ghc-options: -Wall+ OverloadedStrings+ QuasiQuotes+ RecordWildCards+ ScopedTypeVariables+ ghc-options: -Wall -Wredundant-constraints -Wunused-packages build-depends:- aeson >=0.6.2.0+ aeson >=1.4.1.0 && <2.3 , attoparsec >=0.10- , attoparsec-aeson >=2+ , attoparsec-aeson >=2.1.0.0 && <2.3 , base ==4.* , base64-bytestring >=1.0 , bytestring >=0.9- , call-stack- , data-default+ , containers , directory >1.0- , directory-tree >=0.11 , exceptions >=0.4 , filepath >1.0 , http-client >=0.3 , http-types >=0.8- , lifted-base >=0.1- , monad-control >=0.3- , network >=2.6+ , microlens-th >=0.4.0.0+ , monad-logger+ , mtl+ , network , network-uri >=2.6+ , random+ , retry+ , safe-exceptions , scientific >=0.2- , temporary >=1.0+ , stm+ , string-interpolate , text >=0.11.3 , time >1.0- , transformers >=0.4- , transformers-base >=0.1+ , unliftio+ , unliftio-core , unordered-containers >=0.1.3- , vector >=0.3+ , websockets >=0.13 , zip-archive >=0.1.1.8+ default-language: Haskell2010++executable demo+ main-is: Main.hs+ other-modules:+ Paths_webdriver+ hs-source-dirs:+ app+ default-extensions:+ FlexibleContexts+ FlexibleInstances+ LambdaCase+ NamedFieldPuns+ OverloadedStrings+ QuasiQuotes+ RecordWildCards+ ScopedTypeVariables+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -W+ build-depends:+ aeson+ , base+ , bytestring+ , exceptions+ , http-client+ , http-types+ , monad-logger+ , mtl+ , string-interpolate+ , text+ , unliftio+ , unliftio-core+ , webdriver+ default-language: Haskell2010++test-suite tests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Spec+ Spec.Actions+ Spec.CommandContexts+ Spec.Cookies+ Spec.DocumentHandling+ Spec.ElementInteraction+ Spec.ElementRetrieval+ Spec.ElementState+ Spec.Logs+ Spec.LogsBiDi+ Spec.Navigation+ Spec.ScreenCapture+ Spec.SeleniumSpecific.Mobile+ Spec.SeleniumSpecific.Uploads+ Spec.Sessions+ Spec.UserPrompts+ TestLib.Contexts.BrowserDependencies+ TestLib.Contexts.Selenium4+ TestLib.Contexts.Session+ TestLib.Contexts.StaticServer+ TestLib.Contexts.WebDriver+ TestLib.Mouse+ TestLib.Types+ TestLib.Types.Cli+ TestLib.Waits+ Paths_webdriver+ hs-source-dirs:+ tests+ default-extensions:+ FlexibleContexts+ FlexibleInstances+ LambdaCase+ NamedFieldPuns+ OverloadedStrings+ QuasiQuotes+ RecordWildCards+ ScopedTypeVariables+ ghc-options: -threaded -Wall -Wredundant-constraints -Wunused-packages+ build-tool-depends:+ sandwich:sandwich-discover+ build-depends:+ aeson+ , base+ , bytestring+ , containers+ , exceptions+ , filepath+ , http-client+ , http-types+ , microlens+ , monad-logger+ , mtl+ , network+ , network-uri+ , optparse-applicative+ , retry+ , safe-exceptions+ , sandwich+ , sandwich-contexts+ , string-interpolate+ , text+ , unliftio+ , unliftio-core+ , wai-app-static+ , warp+ , webdriver default-language: Haskell2010