packages feed

webdriver 0.9.0.1 → 0.15.0.0

raw patch · 92 files changed

Files

− .ghci 
@@ -1,2 +0,0 @@-:set -XOverloadedStrings -XScopedTypeVariables-:m Test.WebDriver Data.Default.Class
CHANGELOG.md view
@@ -1,38 +1,91 @@ # Change Log -##0.9.0.1-* Fixed build errors when building against aeson-1.4.3.0+## 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.++## 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.++## 0.10.0.1+* 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.++## 0.9.0.1+* 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.@@ -42,22 +95,22 @@ * 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.  +* 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. +* findElems and and findElemsFrom were accidentally changed to return a single Element in the last release. This has been fixed.  ## 0.8 @@ -87,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 @@ -105,98 +158,98 @@  ### 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.-      +       ```hs         -- |A function used to append new requests/responses to session history.         type SessionHistoryConfig = SessionHistory -> [SessionHistory] -> [SessionHistory]       ```     * The new field can be configured using several new constants: `noHistory`, `onlyMostRecentHistory`, and `unlimitedHistory`. Note: `unlimitedHistory` is now the default configuration for history. For the old behavior, use `onlyMostRecentHistory`.     * New top-level functions for accessing session history-      +       ```hs         -- |Gets the command history for the current session.         getSessionHistory :: WDSessionState wd => wd [SessionHistory]-        +         -- |Prints a history of API requests to stdout after computing the given action         --  or after an exception is thrown         dumpSessionHistory :: WDSessionStateControl wd => wd a -> wd a       ```  ### 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.   * For convenience the following constraint aliases were added (requires `ConstraintKinds` extension to use). Several existing API functions have been updated to use these new constraints where appropriate.-    +     ```hs       type WDSessionStateIO s = (WDSessionState s, MonadBase IO s)       type WDSessionStateControl s = (WDSessionState s, MonadBaseControl IO s)     ```-    +   * The `WDSessionStateControl` constraint is equivalent to the previous `WDSessionState` constraint.   * The `WebDriver` class is unaffected (it is now a superclass of `WDSessionStateControl`), so code using the basic `Test.WebDriver` API will not be affected.  * New typeclasses added to `Test.WebDriver.Capabilities`: `GetCapabilities` and `SetCapabilities`; for convenience a constraint alias `HasCapabilities` has been added to work with both of these classes (requires `ConstraintKinds` extension to use)-      +       ```hs         -- |A typeclass for readable 'Capabilities'         class GetCapabilities t where           getCaps :: t -> Capabilities-        +         -- |A typeclass for writable 'Capabilities'         class SetCapabilities t where           setCaps :: Capabilities -> t -> t-        +         -- |Read/write 'Capabilities'         type HasCapabilities t = (GetCapabilities t, SetCapabilities t)       ```-      + ### 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.@@ -204,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.@@ -217,53 +270,53 @@ * 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. +* a new log interface as specified by the webdriver standard. This includes the functions getLogs and getLogTypes, and the types LogType and LogEntry. * waitWhile and waitUntil now show more detailed information about why an explicit wait timed out.  ## hs-webdriver 0.5.0.1@@ -289,8 +342,8 @@ * NoSessionId and doSessCommand were moved from Test.WebDriver.Classes to Test.WebDriver.Commands.Internal  ### 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 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.  ### 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.@@ -307,30 +360,30 @@ ### known issues * Because of the way loadProfile currently adds directories to the profileFiles HashMap, it's possible for extensions added via addExtension to be overriden by the extensions originally listed in the on-disk extensions directory. -### new features +### new features * 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 * new Common.Profile functions: hasExtension, hasFile -## hs-webdriver 0.3.1 +## hs-webdriver 0.3.1  ### API changes * The representation of Profiles has changed, allowing it to store arbitrary files as well as extensions. The functional API for working with preferences and extensions ismostly unchanged, except for the behavior of calling addExtension consecutively with the same filepath argument.@@ -344,7 +397,7 @@ * An issue involving lazy bytestring IO in the zip-archive package means that unusually large profiles might exceed the OSes open file limit.  ### new features-* several new functions for working with Firefox/Opera profiles have been added. This includes functions for loading large profiles from disk, functions for working with zipped profiles, and functions for adding arbitrary files to a profile in pure code. +* several new functions for working with Firefox/Opera profiles have been added. This includes functions for loading large profiles from disk, functions for working with zipped profiles, and functions for adding arbitrary files to a profile in pure code. * new helper functions were added to Test.WebDriver.Commands.Wait, exported from the cond package.  ## hs-webdriver 0.3.0.1@@ -354,7 +407,7 @@ * major bux fixes in the Firefox profile code. Note that loadProfile is unlikely to work as expected, but prepareTempProfile should. -## hs-webdriver 0.3 +## hs-webdriver 0.3  ### API changes * 2 typeclasses were introduced. All WebDriver commands are now overloaded on WebDriver class, so that monad transformers with a WD base can be used conveniently.@@ -375,20 +428,20 @@ ### 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  ### API changes-* 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. +* 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,4 +1,5 @@ Copyright (c) 2012-2015, Adam Curtis+Copyright (c) 2022-2024, Tom McLaughlin All rights reserved.  Redistribution and use in source and binary forms, with or without
README.md view
@@ -1,91 +1,10 @@-[![Build Status](https://travis-ci.org/kallisti-dev/hs-webdriver.svg?branch=master)](https://travis-ci.org/kallisti-dev/hs-webdriver) -hs-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-hs-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-hs-webdriver is hosted on Hackage under the name webdriver. Thus, the simplest way to download and install the most recent version of hs-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 hs-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 hs-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, `hs-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+# Welcome to `webdriver` -This package does not provide utilities to integrate with popular Haskell testing frameworks. However, other packages exist for this purpose:+[![Hackage](https://img.shields.io/hackage/v/webdriver.svg)](https://hackage.haskell.org/package/webdriver) ![webdriver](https://github.com/haskell-webdriver/haskell-webdriver/workflows/ci/badge.svg) -* [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 hs-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>.
− TODO.md 
@@ -1,18 +0,0 @@-#known issues-- fix loadProfile so that it doesn't cause an overlap with user addExtension calls--#features-- support new w3c webdriver spec: http://www.w3.org/TR/webdriver/-  - try to support backwards compatibility with old wire protocol, otherwise provide legacy API in submodule (?) -  - mock-up example of actions API: http://lpaste.net/3484676197546196992-- allow WDConfig to automatically load drivers. add modules with driver loading functions-- overload URL inputs/outputs to implicitly support structured URL types-- add support for Opera profiles-- POST "/session/{sessionId}/phantom/execute"--#documentation-- document errors.---#considerations-- consider adding withSession to SessionState so that it can be overloaded easily, or rewriting it so that it's overloaded but not a method itself.
+ 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,41 +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++module Test.WebDriver (+  -- * 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 Test.WebDriver.Types+import Data.Aeson as A+import Test.WebDriver.Capabilities+import Test.WebDriver.Capabilities.Proxy import Test.WebDriver.Commands-import Test.WebDriver.Monad import Test.WebDriver.Exceptions-import Test.WebDriver.Config-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,771 +1,193 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards, ConstraintKinds-  #-}-module Test.WebDriver.Capabilities where--import Test.WebDriver.Firefox.Profile-import Test.WebDriver.Chrome.Extension-import Test.WebDriver.JSON--import Data.Aeson-import Data.Aeson.Types (Parser, typeMismatch, Pair)-import qualified Data.HashMap.Strict as HM (delete, toList, empty)--import Data.Text (Text, toLower, toUpper)-import Data.Default.Class (Default(..))-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---- |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 ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# 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 .:)            -- 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 .:)-  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)--instance Default LogLevel where-  def = LogInfo+-- 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 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"+  -- * Vendor-specific stuff+  -- | Chrome options+  , _capabilitiesGoogChromeOptions :: Maybe ChromeOptions+  -- | Firefox options+  , _capabilitiesMozFirefoxOptions :: Maybe FirefoxOptions -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+  , _capabilitiesWebSocketUrl :: Maybe Bool +  } deriving (Eq, Show)+deriveJSON capabilitiesOptions ''Capabilities+makeLenses ''Capabilities --- |Logging levels for Internet Explorer-data IELogLevel = IELogTrace | IELogDebug | IELogInfo | IELogWarn | IELogError-                | IELogFatal-                deriving (Eq, Show, Read, Ord, Bounded, Enum)+-- | Default capabilities.+defaultCaps :: Capabilities+defaultCaps = Capabilities {+  _capabilitiesBrowserName = Nothing+  , _capabilitiesBrowserVersion = Nothing -instance Default IELogLevel where-  def = IELogFatal+  , _capabilitiesPlatformName = Nothing +  , _capabilitiesAcceptInsecureCerts = Nothing -instance ToJSON IELogLevel where-  toJSON p= String $ case p of-    IELogTrace -> "TRACE"-    IELogDebug -> "DEBUG"-    IELogInfo -> "INFO"-    IELogWarn -> "WARN"-    IELogError -> "ERROR"-    IELogFatal -> "FATAL"+  , _capabilitiesPageLoadStrategy = 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+  , _capabilitiesProxy = Nothing --- |Specifies how elements scroll into the viewport. (see 'ieElementScrollBehavior')-data IEElementScrollBehavior = AlignTop | AlignBottom-                             deriving (Eq, Ord, Show, Read, Enum, Bounded)+  , _capabilitiesSetWindowRect = Nothing -instance Default IEElementScrollBehavior where-  def = AlignTop+  , _capabilitiesTimeouts = Nothing -instance ToJSON IEElementScrollBehavior where-  toJSON AlignTop    = toJSON (0 :: Int)-  toJSON AlignBottom = toJSON (1 :: Int)+  , _capabilitiesUnhandledPromptBehavior = 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+  , _capabilitiesGoogChromeOptions = Nothing+  , _capabilitiesMozFirefoxOptions = Nothing +  , _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,29 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}--- |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,85 +0,0 @@-{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, FlexibleContexts, CPP,-             GeneralizedNewtypeDeriving, RecordWildCards, ConstraintKinds #-}-#ifndef CABAL_BUILD_DEVELOPER-{-# OPTIONS_GHC  -fno-warn-warnings-deprecations #-}-#endif-module Test.WebDriver.Class-       ( -- * WebDriver class-         WebDriver(..), Method, methodDelete, methodGet, methodPost,-       ) where-import Test.WebDriver.Session--import Data.Aeson-import Data.Text (Text)-#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--import Network.HTTP.Types.Method (methodDelete, methodGet, methodPost, Method)--import Control.Monad.Trans.Class-import Control.Monad.Trans.Error-import Control.Monad.Trans.Except-import Control.Monad.Trans.Identity-import Control.Monad.Trans.List-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---- |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 WebDriver wd => WebDriver (ListT 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 (Error e, WebDriver wd) => WebDriver (ErrorT e 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,822 +1,127 @@-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ExistentialQuantification,-             TemplateHaskell, RecordWildCards, FlexibleContexts #-}--- |This module exports basic WD 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.TH-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.Char as C-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.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 "name" $ 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 = noReturn . 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 = noReturn . doWinCommand methodPost currentWindow "/position" . pair ("x","y")---- |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)---- |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 FromJSON Cookie where-  parseJSON (Object o) = Cookie <$> req "name"-                                <*> req "value"-                                <*> opt "path" Nothing-                                <*> opt "domain" Nothing-                                <*> opt "secure" Nothing-                                <*> opt "expiry" Nothing-    where-      req :: FromJSON a => Text -> Parser a-      req = (o .:)-      opt :: FromJSON a => Text -> a -> Parser a-      opt k d = o .:?? k .!= d-  parseJSON v = typeMismatch "Cookie" v---- |Retrieve all cookies visible to the current page.-cookies :: (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---- |Get a list of all keys from a web storage area.-getAllKeys :: (HasCallStack, WebDriver wd) => WebStorageType -> wd [Text]-getAllKeys s = doStorageCommand methodGet s "" Null+-- | This module exports all the actions that can be used to interact with a+-- browser session.+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 --- |Delete all keys within a given web storage area.-deleteAllKeys :: (HasCallStack, WebDriver wd) => WebStorageType -> wd ()-deleteAllKeys s = noReturn $ doStorageCommand methodDelete 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 --- |An HTML 5 storage type-data WebStorageType = LocalStorage | SessionStorage-                    deriving (Eq, Show, Ord, Bounded, Enum)+  -- * 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 --- |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 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 --- |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 State+  --+  -- See https://www.w3.org/TR/webdriver1/#element-state.+  , module Test.WebDriver.Commands.ElementState --- |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"+  -- * Element Interaction+  --+  -- See https://www.w3.org/TR/webdriver1/#element-interaction.+  , module Test.WebDriver.Commands.ElementInteraction --- |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+  -- * Document handling+  --+  -- See https://www.w3.org/TR/webdriver1/#document-handling.+  , module Test.WebDriver.Commands.DocumentHandling+  , ignoreReturn --- |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)+  -- * Cookies+  --+  -- See https://www.w3.org/TR/webdriver1/#cookies.+  , module Test.WebDriver.Commands.Cookies +  -- * Actions+  --+  -- See https://www.w3.org/TR/webdriver1/#actions.+  , module Test.WebDriver.Commands.Actions -instance FromJSON LogEntry where-  parseJSON (Object o) =-    LogEntry <$> o .: "timestamp"-             <*> o .: "level"-             <*> (fromMaybe "" <$> o .: "message")-  parseJSON v = typeMismatch "LogEntry" v+  -- * User Prompts+  --+  -- See https://www.w3.org/TR/webdriver1/#user-prompts.+  , module Test.WebDriver.Commands.UserPrompts -type LogType = String+  -- * Screen capture+  --+  -- See https://www.w3.org/TR/webdriver1/#screen-capture.+  , module Test.WebDriver.Commands.ScreenCapture --- |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]+  -- * Browser logs+  -- | Retrieve browser console logs and other log types.+  , module Test.WebDriver.Commands.Logs --- |Get a list of available log types.-getLogTypes :: (HasCallStack, WebDriver wd) => wd [LogType]-getLogTypes = doSessCommand methodGet "/log/types" Null+  -- * BiDi sessions (experimental)+  -- | Low-level BiDi session establishment.+  , module Test.WebDriver.Commands.BiDi.Session -data ApplicationCacheStatus = Uncached | Idle | Checking | Downloading | UpdateReady | Obsolete deriving (Eq, Enum, Bounded, Ord, Show, Read)+  -- * Network activity (experimental)+  -- | Use BiDi to track network activity events.+  , module Test.WebDriver.Commands.BiDi.NetworkActivity -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+  -- * 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 -getApplicationCacheStatus :: (WebDriver wd) => wd ApplicationCacheStatus-getApplicationCacheStatus = doSessCommand methodGet "/application_cache/status" Null+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 --- Moving this closer to the definition of Cookie seems to cause strange compile--- errors, so I'm leaving it here for now.-$( deriveToJSON (defaultOptions{fieldLabelModifier = map C.toLower . drop 4}) ''Cookie )+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,106 +0,0 @@-{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}-{-# 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.Class-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
+ src/Test/WebDriver/Commands/Navigation.hs view
@@ -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,151 +0,0 @@-{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables, FlexibleContexts, 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,200 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- |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,262 +0,0 @@-{-# LANGUAGE CPP, TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances,-             GeneralizedNewtypeDeriving, OverloadedStrings, FlexibleContexts #-}-{-# 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 System.Directory-import System.FilePath hiding (addExtension, hasExtension)-import Codec.Archive.Zip-import Data.Aeson-import Data.Aeson.Types--#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 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleContexts #-}-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.Class (Default(..))-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/Exceptions.hs view
@@ -1,11 +1,119 @@-module Test.WebDriver.Exceptions-       ( InvalidURL(..), NoSessionId(..), BadJSON(..)-       , HTTPStatusUnknown(..), HTTPConnError(..)-       , UnknownCommand(..), ServerError(..)-       , FailedCommand(..), FailedCommandType(..)-       , FailedCommandInfo(..), StackFrame(..)-       , mkFailedCommandInfo, failedCommand-       ) where+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-deriving-typeable #-}++module Test.WebDriver.Exceptions (+  InvalidURL(..)+  , NoSessionId(..)+  , BadJSON(..)++  , HTTPStatusUnknown(..)++  , ServerError(..)++  , FailedCommand(..)+  , FailedCommandError(..)++  , StackFrame(..)+  ) where++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.Commands.Internal-import Test.WebDriver.Exceptions.Internal+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,200 +0,0 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable, ConstraintKinds, FlexibleContexts, NamedFieldPuns #-}-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 .:)            --required key-          opt :: FromJSON a => Text -> a -> Parser a-          opt k d = o .:?? k .!= d --optional key-  parseJSON v = typeMismatch "FailedCommandInfo" v--instance FromJSON StackFrame where-  parseJSON (Object o) = StackFrame <$> reqStr "fileName"-                                    <*> reqStr "className"-                                    <*> reqStr "methodName"-                                    <*> req    "lineNumber"-    where req :: FromJSON a => Text -> Parser a-          req = (o .:) -- all keys are required-          reqStr :: Text -> Parser String-          reqStr k = req k >>= maybe (return "") return-  parseJSON v = typeMismatch "StackFrame" v---callStackItemToStackFrame :: (String, SrcLoc) -> StackFrame-callStackItemToStackFrame (functionName, SrcLoc {..}) = StackFrame { sfFileName = srcLocFile-                                                                   , sfClassName = srcLocModule-                                                                   , sfMethodName = functionName-                                                                   , sfLineNumber = srcLocStartLine-                                                                   }
− src/Test/WebDriver/Firefox/Profile.hs 
@@ -1,241 +0,0 @@-{-# LANGUAGE CPP, OverloadedStrings, FlexibleContexts,-             GeneralizedNewtypeDeriving, EmptyDataDecls,-             ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- suppress warnings from attoparsec--- |A module for working with Firefox profiles. Firefox profiles are manipulated--- in pure code and then \"prepared\" for network transmission.-module Test.WebDriver.Firefox.Profile-       ( -- * 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/Internal.hs 
@@ -1,229 +0,0 @@-{-# LANGUAGE FlexibleContexts, OverloadedStrings, RecordWildCards, ScopedTypeVariables, ConstraintKinds, PatternGuards, 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.Class-#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,60 +1,86 @@-{-# LANGUAGE OverloadedStrings, FlexibleContexts, DeriveDataTypeable #-}--- |A collection of convenience functions for using and parsing JSON values+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-deriving-typeable #-}++-- | 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-       ) where-import Test.WebDriver.Class (WebDriver)+  -- * Conversion from JSON within WD+  -- | Apostrophes are used to disambiguate these functions+  -- from their "Data.Aeson" counterparts.+  , parseJSON'+  , fromJSON' +  -- * Tuple functions+  -- | Convenience functions for working with tuples.+   -- ** JSON object constructors+  , single+  , pair+  , triple+  -- ** Extracting JSON objects into tuples+  , 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 qualified Data.HashMap.Strict as HM--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 -instance Exception BadJSON--- |An error occured when parsing a JSON value.-newtype BadJSON = BadJSON String-             deriving (Eq, Show, Typeable)+#if MIN_VERSION_aeson(2,2,0)+-- This comes from the attoparsec-aeson package+import Data.Aeson.Parser (json)+#endif +#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap          as HM+#else+import qualified Data.HashMap.Strict        as HM+#endif --- |A type indicating that we expect no return value from the webdriver request.++-- | An error occured when parsing a JSON value.+newtype BadJSON = BadJSON String+  deriving (Eq, Show, Typeable)+instance Exception BadJSON++-- | 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@@ -65,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 [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 [a .= x, 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 [a .= x, b.= y, 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 (.: 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 .:? 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@@ -136,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,99 +0,0 @@-{-# LANGUAGE FlexibleContexts, TypeFamilies, GeneralizedNewtypeDeriving,-             MultiParamTypeClasses, CPP, UndecidableInstances, ConstraintKinds #-}-module Test.WebDriver.Monad-       ( WD(..), runWD, runSession, finallyClose, closeOnException, getSessionHistory, dumpSessionHistory-       ) where--import Test.WebDriver.Class-import Test.WebDriver.Session-import Test.WebDriver.Config-import Test.WebDriver.Commands-import Test.WebDriver.Internal--import Control.Monad.Base (MonadBase, liftBase)-import Control.Monad.IO.Class-import Control.Monad.Fix-import Control.Monad.Trans.Control (MonadBaseControl(..), StM)-import Control.Monad.Trans.State.Strict (StateT, evalStateT, get, put)---import Control.Monad.IO.Class (MonadIO)-import Control.Exception.Lifted-import Control.Monad.Catch (MonadThrow, MonadCatch)-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)--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,211 +0,0 @@-{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, FlexibleContexts, ScopedTypeVariables,-             GeneralizedNewtypeDeriving, RecordWildCards, ConstraintKinds, CPP #-}--#ifndef CABAL_BUILD_DEVELOPER-{-# OPTIONS_GHC  -fno-warn-warnings-deprecations #-}-#endif--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.List-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Error-import Control.Monad.Trans.Except---import Control.Monad.Cont-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.Types.Header (RequestHeaders)-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 WDSessionState m => WDSessionState (ListT 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 (Error e, WDSessionState m) => WDSessionState (ErrorT e 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,13 +0,0 @@-module Test.WebDriver.Session.History where--import Data.ByteString.Lazy (ByteString)-import Network.HTTP.Client (Request, Response)-import Control.Exception (SomeException)---data SessionHistory = SessionHistory -    { histRequest :: Request-    , histResponse :: Either SomeException (Response ByteString)-    , histRetryCount :: Int-    }-    deriving (Show)
src/Test/WebDriver/Types.hs view
@@ -1,41 +1,225 @@-{-# OPTIONS_HADDOCK not-home #-}-module Test.WebDriver.Types-       ( -- * WebDriver sessions-         WD(..), WDSession(..), SessionId(..), SessionHistory-         -- * WebDriver configuration-       , WDConfig(..), defaultConfig, SessionHistoryConfig-         -- * Capabilities-       , Capabilities(..), defaultCaps, allCaps-       , Platform(..), ProxyType(..), UnexpectedAlertBehavior(..)-         -- ** Browser-specific capabilities-       , Browser(..),-         -- ** Default settings for browsers-         firefox, chrome, ie, opera, iPhone, iPad, android-       , LogLevel(..), IELogLevel(..), IEElementScrollBehavior(..)-         -- * WebDriver objects and command-specific types-       , Element(..)-       , WindowHandle(..), currentWindow-       , Selector(..)-       , JSArg(..)-       , FrameSelector(..)-       , Cookie(..), mkCookie-       , Orientation(..)-       , MouseButton(..)-       , WebStorageType(..)-       , LogType, LogEntry(..)-       , ApplicationCacheStatus(..)-         -- * Exceptions-       , InvalidURL(..), NoSessionId(..), BadJSON(..)-       , HTTPStatusUnknown(..), HTTPConnError(..)-       , UnknownCommand(..), ServerError(..)-       , FailedCommand(..), FailedCommandType(..)-       , FailedCommandInfo(..), StackFrame(..)-       , mkFailedCommandInfo, failedCommand-       ) where+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -import Test.WebDriver.Monad-import Test.WebDriver.Session-import Test.WebDriver.Config-import Test.WebDriver.Commands-import Test.WebDriver.Exceptions-import Test.WebDriver.Capabilities+module Test.WebDriver.Types (+  WebDriverContext(..)+  -- , HasWebDriverContext+  , mkEmptyWebDriverContext++  , Driver(..)+  , DriverConfig(..)+  , SeleniumVersion(..)++  -- * SessionState class+  , SessionState(..)+  , SessionStatePut(..)++  -- ** WebDriver sessions+  , SessionId(..)+  , Session(..)++  -- * Exceptions+  , SessionException(..)++  -- * Stack frames+  , StackFrame(..)+  , callStackItemToStackFrame++  -- * WebDriver class+  , WebDriver+  , WebDriverBase(..)+  , Method+  , methodDelete+  , methodGet+  , methodPost+  ) where++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,8 +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 ()
+ tests/Spec/Navigation.hs view
@@ -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,95 +1,240 @@-Name: webdriver-Version: 0.9.0.1-Cabal-Version: >= 1.10-License: BSD3-License-File: LICENSE-Author: Adam Curtis-Maintainer: kallisti.dev@gmail.com-Homepage: https://github.com/kallisti-dev/hs-webdriver-Bug-Reports: https://github.com/kallisti-dev/hs-webdriver/issues-Category: Web, Browser, Testing, WebDriver, Selenium-Synopsis: a Haskell client for the Selenium WebDriver protocol-Build-Type: Simple-Extra-Source-Files: README.md, TODO.md, CHANGELOG.md, .ghci-Tested-With: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1-Description:-        A Selenium WebDriver client for Haskell.-        You can use it to automate browser sessions-        for testing, system administration, etc.-        .-        For more information about Selenium itself, see-        <http://seleniumhq.org/>-        .-        To find out what's been changed in this version and others,-        see the change log at-        <https://github.com/kallisti-dev/hs-webdriver/blob/master/CHANGELOG.md>+cabal-version: 1.12 -Source-Repository head-  type: git-  location: git://github.com/kallisti-dev/hs-webdriver.git-  -Flag network-uri-  description: Get Network.URI from the network-uri package-  default: True+-- This file has been generated from package.yaml by hpack version 0.39.1.+--+-- see: https://github.com/sol/hpack -Flag developer-  description: Package development mode-  default: False-  manual: True+name:           webdriver+version:        0.15.0.0+synopsis:       a Haskell client for the Selenium WebDriver protocol+description:    A WebDriver client for Haskell.+                You can use it to automate browser sessions for testing, system administration, etc.+                Here are some relevant links:+                .+                * <https://www.w3.org/TR/webdriver2/>+                * <https://www.selenium.dev/>+                * <https://github.com/mozilla/geckodriver>+                * <https://developer.chrome.com/docs/chromedriver>+                .+                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+author:         Adam Curtis <kallisti.dev@gmail.com>+maintainer:     Tom McLaughlin <tom@codedown.io>+license:        BSD3+license-file:   LICENSE+build-type:     Simple+tested-with:+    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 -Library-  hs-source-dirs: src+source-repository head+  type: git+  location: https://github.com/haskell-webdriver/haskell-webdriver++library+  exposed-modules:+      Test.WebDriver+      Test.WebDriver.Capabilities+      Test.WebDriver.Commands+      Test.WebDriver.Keys+      Test.WebDriver.Profile+      Test.WebDriver.Types+      Test.WebDriver.Waits+      Test.WebDriver.WD+  other-modules:+      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:+      FlexibleContexts+      FlexibleInstances+      LambdaCase+      NamedFieldPuns+      OverloadedStrings+      QuasiQuotes+      RecordWildCards+      ScopedTypeVariables+  ghc-options: -Wall -Wredundant-constraints -Wunused-packages+  build-depends:+      aeson >=1.4.1.0 && <2.3+    , attoparsec >=0.10+    , attoparsec-aeson >=2.1.0.0 && <2.3+    , base ==4.*+    , base64-bytestring >=1.0+    , bytestring >=0.9+    , containers+    , directory >1.0+    , exceptions >=0.4+    , filepath >1.0+    , http-client >=0.3+    , http-types >=0.8+    , microlens-th >=0.4.0.0+    , monad-logger+    , mtl+    , network+    , network-uri >=2.6+    , random+    , retry+    , safe-exceptions+    , scientific >=0.2+    , stm+    , string-interpolate+    , text >=0.11.3+    , time >1.0+    , unliftio+    , unliftio-core+    , unordered-containers >=0.1.3+    , websockets >=0.13+    , zip-archive >=0.1.1.8   default-language: Haskell2010-  ghc-options: -Wall-  if flag(developer)-    cpp-options: -DCABAL_BUILD_DEVELOPER-  build-depends:   base == 4.*-                 , aeson >= 0.6.2.0-                 , http-client >= 0.3-                 , http-types >= 0.8-                 , text >= 0.11.3-                 , bytestring >= 0.9-                 , attoparsec >= 0.10-                 , base64-bytestring >= 1.0-                 , transformers >= 0.4-                 , monad-control >= 0.3-                 , transformers-base >= 0.1-                 , lifted-base >= 0.1-                 , zip-archive >= 0.1.1.8-                 , directory > 1.0-                 , filepath > 1.0-                 , directory-tree >= 0.11-                 , temporary >= 1.0-                 , time > 1.0-                 , unordered-containers >= 0.1.3-                 , vector >= 0.3-                 , exceptions >= 0.4-                 , scientific >= 0.2-                 , data-default-class-                 , call-stack -  if flag(network-uri)-      build-depends: network-uri >= 2.6, network >= 2.6-  else-      build-depends: network-uri < 2.6, network >= 2.4 && < 2.6+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 -  exposed-modules: Test.WebDriver-                   Test.WebDriver.Class-                   Test.WebDriver.Monad-                   Test.WebDriver.Session-                   Test.WebDriver.Session.History-                   Test.WebDriver.Config-                   Test.WebDriver.Exceptions-                   Test.WebDriver.Commands-                   Test.WebDriver.Commands.Wait-                   Test.WebDriver.Commands.Internal-                   Test.WebDriver.Common.Profile-                   Test.WebDriver.Common.Keys-                   Test.WebDriver.Firefox.Profile-                   Test.WebDriver.Chrome.Extension-                   Test.WebDriver.Capabilities-                   Test.WebDriver.Types-                   Test.WebDriver.JSON-                   Test.WebDriver.Utils-                   Test.WebDriver.Internal-                   Test.WebDriver.Exceptions.Internal+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