diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,62 +1,91 @@ # Change Log +## 0.15.0.0 +* Add `Test.WebDriver.Commands.BiDi.NetworkActivity` with tools for working with browser network activity. +* Add support for starting BiDi sessions and watching events. +* Add `_firefoxOptionsEnv` to set Firefox environment variables. Useful to pass MOZ_ENABLE_WAYLAND=0 to make window positioning work better. +* Fix some missed teardown of geckodriver processes. +* Add flags to pass environment variables to drivers. + +## 0.14.0.0 +* Fix MVar bug in teardownWebDriverContext. +* Make driverConfigLogDir optional (#206). +* Add "Test.WebDriver.WD" module for simple usage. + +## 0.13.0.0 +* Added support for Selenium 3 and 4 with W3C WebDriver protocol compatibility. +* Dropped legacy Selenium JSON wire protocol support. +* Reworked [createSession](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:createSession) into [startSession](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver.html#v:startSession), which uses [WebDriverContext](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Types.html#t:WebDriverContext) for process lifecycle management. +* Replaced [WebDriver](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Class.html#t:WebDriver) class with [WebDriverBase](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Types.html#t:WebDriverBase) and switched from `MonadBaseControl IO` to `MonadUnliftIO`. +* Simplified module hierarchy with centralized imports under `Test.WebDriver`. +* Enhanced browser profile handling with in-memory zip archiving instead of on-disk preparation. +* Added comprehensive test suite with matrix testing across Selenium versions and browsers. +* Added browser log retrieval functions: [withRecordLogsViaBiDi](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:withRecordLogsViaBiDi) and [getLogs](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:getLogs). +* Now you can manage the script, page load, and implicit wait timeouts in a single operation with [getTimeouts](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:getTimeouts)/[setTimeouts](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:setTimeouts). +* The [getWindowSize](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:getWindowSize)/[setWindowSize](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:setWindowSize)/[getWindowPos](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:getWindowPos)/[setWindowPos](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:setWindowPos) functions have been replaced with [getWindowRect](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:getWindowRect)/[setWindowRect](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:setWindowRect). +* The [elemPos](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:elemPos)/[elemSize](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:elemSize) functions have been replaced with [elemRect](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:elemRect). +* [deleteCookieByName](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:deleteCookieByName) has been renamed to [deleteCookie](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:deleteCookie) and the pointless old [deleteCookie](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:deleteCookie) removed. +* [screenshotBase64](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:screenshotBase64) has been removed and [screenshotElement](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:screenshotElement) added. +* [deleteVisibleCookies](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:deleteVisibleCookies) renamed to [deleteCookies](https://hackage-content.haskell.org/package/webdriver-0.13.0.0/docs/Test-WebDriver-Commands.html#v:deleteCookies). +* Deprecated function [elemInfo](https://hackage.haskell.org/package/webdriver-0.12.0.0/docs/Test-WebDriver-Commands.html#v:elemInfo) removed. + ## 0.12.0.1 * Switch from `data-default-class` to `data-default` to address https://github.com/commercialhaskell/stackage/issues/7545. This is weirdly complicated: it looks like versions of `data-default` from `0.5.2` to `0.8.0.0` may pull in unnecessary (to us) `data-default-instances-*` dependencies. However, what we've done here should build with all versions, so we won't worry about it. At the next breaking change I'd like to remove `data-default` entirely. ## 0.12.0.0 -* Support aeson-2.2.0 +* Support aeson-2.2.0. ## 0.11.0.0 -* Support GHC 9.6 -* Fix a link to the wrong GitHub branch in package description -* Remove instances for deprecated ListT and ErrorT +* Support GHC 9.6. +* Fix a link to the wrong GitHub branch in package description. +* Remove instances for deprecated ListT and ErrorT. ## 0.10.0.1 -* Update links to reflect this package's new home at https://github.com/haskell-webdriver/haskell-webdriver/ +* Update links to reflect this package's new home at https://github.com/haskell-webdriver/haskell-webdriver/. ## 0.10.0.0 -* Add Aeson 2 compatibility to support GHC 9.0 and 9.2 -* Derive MonadMask instance for the WD monad -* Fix parameter name in the `focusWindow` function -* Fix Cookie ToJSON instance -* Convert a couple noReturn calls to ignoreReturn to avoid a crash -* Switch to hpack -* Switch to GitHub Actions CI -* Remove cabal flags and shorten extra-source-files +* Add Aeson 2 compatibility to support GHC 9.0 and 9.2. +* Derive MonadMask instance for the WD monad. +* Fix parameter name in the `focusWindow` function. +* Fix Cookie ToJSON instance. +* Convert a couple noReturn calls to ignoreReturn to avoid a crash. +* Switch to hpack. +* Switch to GitHub Actions CI. +* Remove cabal flags and shorten extra-source-files. ## 0.9.0.1 -* Fixed build errors when building against aeson-1.4.3.0 +* Fixed build errors when building against aeson-1.4.3.0. ## 0.9 ### Breaking API changes -* Changed the type of the `cookExpiry` field of `Cookie` from `Maybe Integer` to `Maybe Double`. This fixes parsing issues with some Selenium server implementations +* Changed the type of the `cookExpiry` field of `Cookie` from `Maybe Integer` to `Maybe Double`. This fixes parsing issues with some Selenium server implementations. * Changed `elemPos` and `elemSize` to return `Float` pairs instead of `Int` pairs. This fixes parsing issues with some Selemium server implementations. * Removed the `Element` argument from the `sendRawKeys` function. This argument is not used in modern Selenium versions. ### New API features * Added a `LogDebug` constructor to the `LogLevel` type. * Added `ffAccpetInsecureCerts` capability for `Firefox` geckodriver. -* The constructor for `ExpectFailed` is now exported so that it can be caught properly by exception handlers +* The constructor for `ExpectFailed` is now exported so that it can be caught properly by exception handlers. * Added GHC callstack support. `BadJSON` exceptions are now caught and rethrown with `error` calls to improve stack traces. ### W3C standard compatibility fixes -* Fixed `ToJSON Element` instance so that it accepts both old OSS and new W3C element format (fixes compatibility issue with Selenium 3+ versions) -* Changed the `maximize` API call to use POST instead of GET +* Fixed `ToJSON Element` instance so that it accepts both old OSS and new W3C element format (fixes compatibility issue with Selenium 3+ versions). +* Changed the `maximize` API call to use POST instead of GET. ### Other Selenium compatibility fixes -* Fixed an error with some versions of chromedriver when using `closeWindow` +* Fixed an error with some versions of chromedriver when using `closeWindow`. ## 0.8.5 -* Added support for experimental Chrome options that are not part of the API -* Added a Phantomjs constructor for the Browser type -* Changed the type of StackFrame line numbers from Word to Int to avoid parse errors in newer Aeson versions (sometimes the server returns negative line numbers) -* Fixed support for http-client > 0.5 +* Added support for experimental Chrome options that are not part of the API. +* Added a Phantomjs constructor for the Browser type. +* Changed the type of StackFrame line numbers from Word to Int to avoid parse errors in newer Aeson versions (sometimes the server returns negative line numbers). +* Fixed support for http-client > 0.5. ## 0.8.4 * Added a new `Test.WebDriver.Common.Keys` module with named constants for use with `sendKeys` -* Updated old URLs in documentation -* Introduced support for http-client 5.0 +* Updated old URLs in documentation. +* Introduced support for http-client 5.0. ## 0.8.3 * Removed most upper bounds on dependencies in our cabal file to avoid stackage version madness. @@ -66,19 +95,19 @@ * Added new `WebDriver` instance for `ExceptT`. ## 0.8.1 -* Previously internal convenience functions `noReturn` and `ignoreReturn` are now exported in Test.WebDriver.JSON +* Previously internal convenience functions `noReturn` and `ignoreReturn` are now exported in Test.WebDriver.JSON. * `elemInfo` is now deprecated due to it being phased out in the Marionette (Firefox) driver. It will likely be removed once Selenium 4 is released. * Fixed an issue causing PAC settings to not work. ## 0.8.0.4 -* Quick fix to parse "unsupported command" errors when using Marionette driver (Selenium + Marionette has nonstandard behavior when reporting that error type) +* Quick fix to parse "unsupported command" errors when using Marionette driver (Selenium + Marionette has nonstandard behavior when reporting that error type). ## 0.8.0.3 -* Fixed build errors for GHC < 7.10. webdriver now builds with GHC stable releases 7.4.2, 7.6.3, and 7.8.4 +* Fixed build errors for GHC < 7.10. webdriver now builds with GHC stable releases 7.4.2, 7.6.3, and 7.8.4. * Fixed support for bytestring 0.9.* ## 0.8.0.2 -* Fixed issue introduced in 0.8 that caused build failure when using aeson < 0.10 +* Fixed issue introduced in 0.8 that caused build failure when using aeson < 0.10. ## 0.8.0.1 * findElems and and findElemsFrom were accidentally changed to return a single Element in the last release. This has been fixed. @@ -111,15 +140,15 @@ ### Reworked custom HTTP headers interface * Support for custom request headers was added rather hastily, resulting in several functions having explicit `RequestHeaders` parameters. The interface has been reworked now so that custom request headers are stored inside `WDSession` and explicit `RequestHeaders` parameters have been removed. -* There's also now a distinction in configuration between `wdAuthHeaders` which are used only during initial session creation, and `wdRequestHeaders`, which are used with all other HTTP requests -* Two new utility functions were added to make working with custom HTTP headers easier: `withRequestHeaders` and `withAuthHeaders` +* There's also now a distinction in configuration between `wdAuthHeaders` which are used only during initial session creation, and `wdRequestHeaders`, which are used with all other HTTP requests. +* Two new utility functions were added to make working with custom HTTP headers easier: `withRequestHeaders` and `withAuthHeaders`. ### Clean-up and dependency changes * Removed a whole mess of unusued import and deprecation warnings when building with GHC 7.10 * We now enforce an attoparsec lower bound of 0.10 (there was no lower bound before) * The unnecessary dependency on mtl is now removed. -* Added some monad transformer instances for WebDriver and WDSessionState that were mysteriously missing: strict WriterT, ReaderT, ListT -* data-default dependency was changed to data-default-class +* Added some monad transformer instances for WebDriver and WDSessionState that were mysteriously missing: strict WriterT, ReaderT, ListT. +* data-default dependency was changed to data-default-class. ## 0.7 @@ -129,8 +158,8 @@ ### Top-level API (exposed by`Test.WebDriver` module) * `withSession` is now overloaded over the new constraint alias `WDSessionStateControl` ([see below](#typeclass-api)). This means that it can be used with monad transformer stacks over `WD` without any lifting required. - * Added several new `WDConfig` convenience functions: `modifyCaps`, `useBrowser`, `useVersion`, `usePlatform`, `useProxy`; these functions are overloaded over the new `HasCapabilities` constraint alias ([see below](#typeclass-api)) - * Reworked and improved session history API + * Added several new `WDConfig` convenience functions: `modifyCaps`, `useBrowser`, `useVersion`, `usePlatform`, `useProxy`; these functions are overloaded over the new `HasCapabilities` constraint alias ([see below](#typeclass-api)). + * Reworked and improved session history API. * Added a `SessionHistory` record type to replace the old `(Request, Response ByteString)` type. The new type has the same data as the previous tuple, but additionally records the number of attempted HTTP retries, and instead of `Response ByteString` uses `Either SomeException (Response ByteString)` so that HTTP request errors can be logged. * Removed `wdKeepSessHist` field from `WDConfig` and replaced it with `wdHistoryConfig`, which uses a new `SessionHistoryConfig` type. @@ -151,7 +180,7 @@ ``` ### Implicit waits API (`Test.WebDriver.Commands.Wait`) -* Added functions for checking some expected conditions in explicit waits: `expectNotStale`, `expectAlertOpen`, `catchFailedCommand` +* Added functions for checking some expected conditions in explicit waits: `expectNotStale`, `expectAlertOpen`, `catchFailedCommand`. ### Typeclass API * `WDSessionState` is now a superclass of `Monad` and `Applicative` instead of `MonadBaseControl IO`. This makes the class significantly more flexible in how it can be used, as it no longer requires `IO` as a base monad. @@ -182,45 +211,45 @@ ### Minor API changes (not exposed to `Test.WebDriver` module) * `Test.WebDriver.Session` changes - * new function `mostRecentHistory` added - * `lastHTTPRequest` renamed to `mostRecentHTTPRequest` (for consistency) - * `mkSession` moved from `Test.WebDriver.Config` to `Test.WebDriver.Session` + * new function `mostRecentHistory` added. + * `lastHTTPRequest` renamed to `mostRecentHTTPRequest` (for consistency). + * `mkSession` moved from `Test.WebDriver.Config` to `Test.WebDriver.Session`. * `Test.WebDriver.Internal` changes * `sendHTTPRequest` now returns `(Either SomeException (Response ByteString))` and catches any exceptions that occur during the request. When using default configuration, the exceptions are also saved in 'wdSessHist'. * `Test.WebDriver.Internal` no longer defines and exports exception types. All exception defined here previously have been moved to an unexposed `Test.WebDriver.Exceptions.Internal` module. These types are still exported in the usual places. ### Dependencies -* Now supports http-types up to 0.9 +* Now supports http-types up to 0.9. ## 0.6.3.1 -* Fixed an issue with aeson 0.10 support +* Fixed an issue with aeson 0.10 support. ## 0.6.3 -* Support aeson 0.10 -* Added support for multiple HTTP attempts per command request, using the new WDConfig field wdHTTPRetryCount +* Support aeson 0.10. +* Added support for multiple HTTP attempts per command request, using the new WDConfig field wdHTTPRetryCount. ## 0.6.2.1 -* Supports vector 0.11, aeson 0.9, attoparsec 0.13 +* Supports vector 0.11, aeson 0.9, attoparsec 0.13. ## 0.6.2 -* Supports GHC 7.10 -* Supports reworked Chrome capabilities used by newer versions of WebDriver -* Servers that return empty JSON strings for commands with no return value will no longer cause parse errors +* Supports GHC 7.10. +* Supports reworked Chrome capabilities used by newer versions of WebDriver. +* Servers that return empty JSON strings for commands with no return value will no longer cause parse errors. ## 0.6.1 -* Added the ability to pass HTTP request headers at session creation -* Fixed an issue involving an obsolete JSON representation of Chrome capabilities -* Relax upper bound on exceptions dependency +* Added the ability to pass HTTP request headers at session creation. +* Fixed an issue involving an obsolete JSON representation of Chrome capabilities. +* Relax upper bound on exceptions dependency. ## 0.6.0.4 -* Support for monad-control 1.0 +* Support for monad-control 1.0. ## 0.6.0.3 -* Relaxed upper bounds on text and http-client versions +* Relaxed upper bounds on text and http-client versions. ## 0.6.0.2 -* Added support for aeson > 0.8 and network > 2.6 -* Added support for the "X-Response-Body-Start" HTTP header used for error responses in newer http-client versions +* Added support for aeson > 0.8 and network > 2.6. +* Added support for the "X-Response-Body-Start" HTTP header used for error responses in newer http-client versions. ## 0.6.0.1 * Fixed Haddock parse errors. No code changes introduced in this version. @@ -228,10 +257,10 @@ ## 0.6 * Rather than WDSession serving dual roles as configuration and state, its functionality has been split into 2 respective types: WDConfig and WDSession. * runSession now takes a WDConfig instead of WDSession and Capabilities parameters. -* runSession no longer closes its session on successful completion; use finallyClose or closeOnException for this behavior -* The old Test.WebDriver.Classes module has been split into Test.WebDriver.Session and Test.WebDriver.Class -* SessionState typeclass renamed to WDSessionState -* We now use the http-client package instead of HTTP. This is reflected in the addition of Manager fields in both WDConfig and WDSession +* runSession no longer closes its session on successful completion; use finallyClose or closeOnException for this behavior. +* The old Test.WebDriver.Classes module has been split into Test.WebDriver.Session and Test.WebDriver.Class. +* SessionState typeclass renamed to WDSessionState. +* We now use the http-client package instead of HTTP. This is reflected in the addition of Manager fields in both WDConfig and WDSession. ## 0.5.5 * Added optional HTTP history tracking for debugging purposes. @@ -241,50 +270,50 @@ * Relaxed dependencies on mtl, network and scientific. ## 0.5.3.3 -* Relaxed text dependency up to 1.2 +* Relaxed text dependency up to 1.2. ## 0.5.3.2 ### bug fixes -* fixed remaining compilation problems with aeson. now supports aeson >= 0.6.2.0 && < 0.8 +* fixed remaining compilation problems with aeson. now supports aeson >= 0.6.2.0 && < 0.8. * now depends on directory-tree instead of filesystem-trees. this fixes several problems with firefox/chrome profile support. ## 0.5.3.1 ### bug fixes -* fixed compilation error with aeson 0.7 and greater +* fixed compilation error with aeson 0.7 and greater. ## 0.5.3 ### new features -* SessionNotCreated constructor added to FailedCommandType -* new command deleteCookieByName added +* SessionNotCreated constructor added to FailedCommandType. +* new command deleteCookieByName added. ###b ug fixes -* asyncJS now properly distinguishes between a null return and a script timeout -* fixed a change in waitWhile causing the opposite of expected behavior +* asyncJS now properly distinguishes between a null return and a script timeout. +* fixed a change in waitWhile causing the opposite of expected behavior. ## 0.5.2 ### API changes -* added many new Internet Explorer capabilities -* added additionalCaps to Capabilities, which allows support for non-standard capabilities -* Browser type now supports non-standard browsers via the new Browser constructor -* added support for the new unexpectedAlertBehaviour capability +* added many new Internet Explorer capabilities. +* added additionalCaps to Capabilities, which allows support for non-standard capabilities. +* Browser type now supports non-standard browsers via the new Browser constructor. +* added support for the new unexpectedAlertBehaviour capability. ### new features -* new command getApplicationCacheStatus supported -* error reporting for unknown commands now slightly improved +* new command getApplicationCacheStatus supported. +* error reporting for unknown commands now slightly improved. ### bug fixes -* internal request URIs are now properly percent-encoded -* improved handling of browser-specific capabilities -* fixed incompatability with new session creation protocol changes introduced in selenium 2.35 -* updated to work with Aeson 0.6.2 and onward +* internal request URIs are now properly percent-encoded. +* improved handling of browser-specific capabilities. +* fixed incompatability with new session creation protocol changes introduced in selenium 2.35. +* updated to work with Aeson 0.6.2 and onward. ## hs-webdriver 0.5.1 ### API changes * Test.WebDriver.Internal.FailedCommandInfo now stores screenshots as lazy bytestrings * Test.WebDriver.Common.Profile now stores PreparedProfile as a lazy bytestring * Test.WebDriver.Chrome.Extension now stores ChromeExtension as a lazy bytestring -* The LogPref type has been renamed to LogLevel to reflect its use within the new log interface +* The LogPref type has been renamed to LogLevel to reflect its use within the new log interface. ### new features * a new log interface as specified by the webdriver standard. This includes the functions getLogs and getLogTypes, and the types LogType and LogEntry. @@ -314,7 +343,7 @@ ### bug fixes * fixed a typo in the export list of Firefox.Profile; deleteFile is now correctly exported instead of removeFile from System.Directory -* fixed an error in the JSON representation of MouseButton +* fixed an error in the JSON representation of MouseButton. ### new features * A new module, Test.WebDriver.Commands.Internal, which exports some low-level functions used to implement the high-level interface. This makes it possible for library users to extend hs-webdriver with nonstandard or unimplemented features. @@ -335,20 +364,20 @@ * It's now possible to add entire directories to a profile in pure code using addFile and addExtension. * new functions in Common.Profile: unionProfiles, onProfileFiles, onProfilePrefs * new function in Commands.Wait: onTimeout -* the WD monad now has a MonadCatchIO instance, as an alternative to lifted-base for exception handling +* the WD monad now has a MonadCatchIO instance, as an alternative to lifted-base for exception handling. ## hs-webdriver 0.3.2.1 ### bug fixes -* Removed a bug in waitWhile' that resulted in an infinite loop -* Fixed the incorrect representation of JSON profiles -* Fixed relative path issues when zipping profile directories from disk +* Removed a bug in waitWhile' that resulted in an infinite loop. +* Fixed the incorrect representation of JSON profiles. +* Fixed relative path issues when zipping profile directories from disk. ## hs-webdriver 0.3.2 ### bug fixes -* Changed the constraint on filesystrem-trees to avoid a broken version +* Changed the constraint on filesystrem-trees to avoid a broken version. * Added the missing exports for addFile and deleteFile in Common.Profile and Firefox.Profile ### new features @@ -399,11 +428,11 @@ ### API changes * FailedCommandInfo changed so that it stores a WDSession rather than just a Maybe SessionId, thus providing server host and port information as well as the session ID. * As a result, mkFailedCommandInfo is now String -> WD FailedCommandInfo, since it requires access to the WDSession state. -* HTML5StorageType changed to the more accurate WebStorageType +* HTML5StorageType changed to the more accurate WebStorageType. ### new features -* general documentation improvements -* the uploadFile, uploadRawFile, and uploadZipEntry functions, which support uploading file contents to the remote server +* general documentation improvements. +* the uploadFile, uploadRawFile, and uploadZipEntry functions, which support uploading file contents to the remote server. ## hs-webdriver 0.1 @@ -411,8 +440,8 @@ * getWindowSize, setWindowSize, getWindowPos, and setWindowPos have all been deprived of their WindowHandle argument. This is due to the fact that using unfocused windows with those commands causes undefined behavior. ### new features -* the mkCookie function for convenient cookie construction -* the focusFrame function for focusing to individual frames -* the setPageLoadTimeout function -* the maximize function for maximizing windows -* support for HTML 5 web storage +* the mkCookie function for convenient cookie construction. +* the focusFrame function for focusing to individual frames. +* the setPageLoadTimeout function. +* the maximize function for maximizing windows. +* support for HTML 5 web storage. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,5 @@ Copyright (c) 2012-2015, Adam Curtis -Copyright (c) 2022-2023, Tom McLaughlin +Copyright (c) 2022-2024, Tom McLaughlin All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,92 +3,8 @@ [![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) -haskell-webdriver is a Selenium WebDriver client for the Haskell programming language. You can use it to automate browser sessions for testing, system administration, etc. - -For more information about Selenium itself, see http://seleniumhq.org/ - -# Contents -* [Installation](#installation) - * [Installation from Hackage](#installation-from-hackage) - * [Installation from This Repository](#installation-from-this-repository) -* [Getting Started](#getting-started) - * [Using the Selenium Server](#using-the-selenium-server) - * [Hello, World!](#hello-world) -* [Integration with Haskell Testing Frameworks](#integration-with-haskell-testing-frameworks) -* [Documentation](#documentation) - -# Installation -haskell-webdriver uses the Cabal build system to configure, build, install, and generate documentation on multiple platforms. - -For more information on using Cabal and its various installation options, see the Cabal User's Guide at http://www.haskell.org/cabal/users-guide/index.html - -## Installation from Hackage -haskell-webdriver is hosted on Hackage under the name webdriver. Thus, the simplest way to download and install the most recent version of haskell-webdriver is to run: - -```sh -cabal install webdriver -``` -There are also options to do system-wide installation, version selection, and other build options; see cabal-install documentation. - -## Installation from this repository - -To build and install a git revision for a single user on your system, run these commands from within the repository directory - - -### Using cabal-install - -```sh -cabal install -``` - -### Using Cabal - -For systems without cabal-install available, you can also run the Setup.hs -script, as such: - -```sh -runhaskell Setup.hs configure --user -runhaskell Setup.hs build -runhaskell Setup.hs install -``` - -For more build options, please refer to the Cabal documentation. - - -# Getting Started - -WebDriver is a client-server protocol. Since haskell-webdriver only implements a WebDriver client, you must have a WebDriver server to which you can connect in order to make use of this library. - -## Using the Selenium Server -While you can use any WebDriver server out there, probably the simplest server to use with haskell-webdriver is [Selenium Server](http://docs.seleniumhq.org/download/). You'll need an installation of the Java runtime to use this server. Once you've downloaded Selenium Server to your current working directory, you can start the server with this shell command: - - java -jar selenium-server-standalone-*.jar - -The server should now be listening at localhost on port 4444. - -Currently, `haskell-webdriver` only supports selenium version 2. -The [beginner example](/examples/readme-example-beginner.md) was -tested with `selenium-server-standalone-2.53.1`. - -## Hello, World! -With the Selenium server running locally, you're ready to write browser automation scripts in Haskell. - -A [simple example can be found here](/examples/readme-example-beginner.md), written in literate Haskell so that you can compile it with GHC yourself. It is very beginner friendly and assumes no prior knowledge of Haskell. For other examples see the [examples](examples/) and [test/etc](test/etc/) directory. - - -# Integration with Haskell Testing Frameworks - -This package does not provide utilities to integrate with popular Haskell testing frameworks. However, other packages exist for this purpose: - -* [hspec-webdriver](https://hackage.haskell.org/package/hspec-webdriver) -* [quickcheck-webdriver](https://hackage.haskell.org/package/quickcheck-webdriver) +haskell-webdriver is a WebDriver client for the Haskell programming language. You can use it to automate browser sessions for testing, system administration, etc. # Documentation -Documentation for haskell-webdriver is available on Hackage at . 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 . diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/src/Test/WebDriver.hs b/src/Test/WebDriver.hs --- a/src/Test/WebDriver.hs +++ b/src/Test/WebDriver.hs @@ -1,42 +1,264 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ViewPatterns #-} + {-| -This module serves as the top-level interface to the Haskell WebDriver bindings, -providing most of the functionality you're likely to want. + +Once upon a time, the main browser automation tool was Selenium. Users of +this package had to start a Selenium session themselves, making sure to +configure it with a browser-specific driver program like @chromedriver@ or +@geckodriver@, and provide a hostname\/port. Then, this package would connect to +Selenium and use its wire protocol to control browsers. + +Nowadays, there is an official W3C spec () +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 +). So, this library will spin +up a separate @geckodriver@ process for every session. + +For an example of using this package by itself, see "Test.WebDriver.WD". For a +full test framework integrated with this package, see +[sandwich-webdriver](https://hackage.haskell.org/package/sandwich-webdriver). + -} module Test.WebDriver ( - -- * WebDriver monad - WD(..) - -- * Running WebDriver commands - , runSession, withSession, runWD - -- * WebDriver configuration - , WDConfig(..), defaultConfig - -- ** Configuration helper functions - -- | Instead of working with the 'Capabilities' record directly, you can use - -- these config modifier functions to specify common options. - , useBrowser, useProxy, useVersion, usePlatform - -- ** Session history configuration - , SessionHistoryConfig, noHistory, unlimitedHistory, onlyMostRecentHistory - -- ** HTTP request header utilities - , withRequestHeaders, withAuthHeaders - -- * WebDriver commands + -- * WebDriverContext + WebDriverContext + , mkEmptyWebDriverContext + , teardownWebDriverContext + + -- * Managed sessions + , startSession + , closeSession + , DriverConfig(..) + + -- * Lower-level session management + , startSession' + , closeSession' + , mkManualDriver + + -- * Capabilities + , defaultCaps + , defaultChromeOptions + , defaultFirefoxOptions + , Capabilities(..) + , Platform(..) + , ProxyType(..) + + -- * Commands , module Test.WebDriver.Commands - -- * Capabilities (advanced configuration) - , Capabilities(..), defaultCaps, allCaps, modifyCaps - , Platform(..), ProxyType(..) - -- ** Browser-specific capabilities - , Browser(..), LogLevel(..) - -- *** Browser defaults - , firefox, chrome, ie, opera, iPhone, iPad, android - -- * Exception handling - , finallyClose, closeOnException + + , mkDriverRequest + , _driverManager + + -- * WebDriver monad + , WebDriver + , WebDriverBase + + , Session + + -- * Exceptions , module Test.WebDriver.Exceptions - -- * Accessing session history - , SessionHistory(..), getSessionHistory, dumpSessionHistory ) where +import Data.Aeson as A +import Test.WebDriver.Capabilities +import Test.WebDriver.Capabilities.Proxy import Test.WebDriver.Commands -import Test.WebDriver.Config import Test.WebDriver.Exceptions -import Test.WebDriver.Monad -import Test.WebDriver.Session +import Test.WebDriver.JSON +import Test.WebDriver.LaunchDriver import Test.WebDriver.Types + +import Data.Map as M +import Control.Monad.Catch (MonadMask) +import Control.Monad +import Control.Monad.IO.Class +import Data.String.Interpolate +import qualified Data.Text as T +import Test.WebDriver.Util.Aeson (aesonLookup) +import Control.Monad.Logger +import Network.HTTP.Client +import Network.HTTP.Types (RequestHeaders, statusCode) +import UnliftIO.Concurrent +import UnliftIO.Exception +import UnliftIO.STM + + +-- | Start a WebDriver session, with a given 'WebDriverContext' and +-- 'DriverConfig'. +-- +-- You need to provide the WebDriver 'Capabilities' for the session. You should +-- make sure the browser-specific fields of your 'Capabilities' are filled in +-- correctly to match the given 'DriverConfig'. For example, if you're using +-- 'DriverConfigChromedriver', you should make sure to fill in +-- '_capabilitiesGoogChromeOptions' and in particular the '_chromeOptionsBinary' +-- field. + +startSession :: (WebDriverBase m, MonadMask m, MonadLogger m) => WebDriverContext -> DriverConfig -> Capabilities -> String -> m Session +startSession wdc dc@(DriverConfigSeleniumJar {}) caps sessionName = do + driver <- modifyMVar (_webDriverSelenium wdc) $ \maybeSelenium -> do + driver <- maybe (launchDriver dc) return maybeSelenium + return (Just driver, driver) + + launchSessionInDriver wdc driver caps sessionName +startSession wdc dc@(DriverConfigChromedriver {}) caps sessionName = do + driver <- modifyMVar (_webDriverChromedriver wdc) $ \maybeChromedriver -> do + driver <- maybe (launchDriver dc) return maybeChromedriver + return (Just driver, driver) + + launchSessionInDriver wdc driver caps sessionName +startSession wdc dc@(DriverConfigGeckodriver {}) caps sessionName = do + driver <- launchDriver dc + onException (launchSessionInDriver wdc driver caps sessionName) + (teardownDriver driver) + +launchSessionInDriver :: (WebDriverBase m, MonadLogger m) => WebDriverContext -> Driver -> Capabilities -> String -> m Session +launchSessionInDriver wdc driver caps sessionName = do + sess <- startSession' driver caps sessionName + + modifyMVar (_webDriverSessions wdc) $ \sessionMap -> + case M.lookup sessionName sessionMap of + Just _ -> throwIO SessionNameAlreadyExists + Nothing -> return (M.insert sessionName sess sessionMap, sess) + +-- | Lower-level version of 'startSession'. This one allows you to construct a +-- driver instance manually and pass it in. Does not manage process lifecycles. +startSession' :: (WebDriverBase m, MonadLogger m) => Driver -> Capabilities -> String -> m Session +startSession' driver caps sessionName = do + response <- doCommandBase driver methodPost "/session" $ single "capabilities" $ single "alwaysMatch" caps + + if | statusCode (responseStatus response) == 200 -> do + case A.eitherDecode (responseBody response) of + Right x@(A.Object (aesonLookup "value" -> Just value@(A.Object (aesonLookup "sessionId" -> Just (A.String sessId))))) -> do + logInfoN [i|Got capabilities from driver: #{A.encode x}|] + + let maybeWebSocketUrl = case value of + A.Object (aesonLookup "capabilities" -> Just (A.Object (aesonLookup "webSocketUrl" -> Just (A.String url)))) -> Just url + _ -> Nothing + + idCounterVar <- newTVarIO 1 + + return $ Session { + sessionDriver = driver + , sessionId = SessionId sessId + , sessionName = sessionName + , sessionWebSocketUrl = T.unpack <$> maybeWebSocketUrl + , sessionIdCounter = idCounterVar + } + _ -> throwIO $ SessionCreationResponseHadNoSessionId response + | otherwise -> throwIO SessionNameAlreadyExists + +-- | Close the given WebDriver session. This sends the @DELETE +-- \/session\/:sessionId@ command to the WebDriver API, and then shuts down the +-- process if necessary. +closeSession :: (WebDriverBase m, MonadLogger m) => WebDriverContext -> Session -> m () +closeSession wdc sess@(Session {..}) = do + -- For geckodriver, we own the process (one per session), so we must always + -- tear it down -- even if the HTTP DELETE to close the session fails. + let teardownGecko = case _driverConfig sessionDriver of + DriverConfigGeckodriver {} -> teardownDriver sessionDriver + _ -> return () + + flip finally teardownGecko $ do + closeSession' sess + modifyMVar_ (_webDriverSessions wdc) (return . M.delete sessionName) + +-- | Close the given WebDriver session. This is a lower-level version of +-- 'closeSession', which manages the driver lifecycle for you. This version will +-- only issue the @DELETE \/session\/:sessionId@ command to the driver, but will +-- not shut down driver processes. +closeSession' :: (WebDriverBase m, MonadLogger m) => Session -> m () +closeSession' (Session { sessionId=(SessionId sessId), .. }) = do + _response <- doCommandBase sessionDriver methodDelete ("/session/" <> sessId) Null + -- TODO: throw an exception if this failed? + return () + +-- | Create a manual 'Driver' to use with 'startSession''/'closeSession''. +mkManualDriver :: MonadIO m => + -- | Host name + String + -- | Port + -> Int + -- | Base HTTP path (use "\/wd\/hub" for Selenium) + -> String + -- | Headers to send with every request + -> RequestHeaders + -> m Driver +mkManualDriver hostname port basePath requestHeaders = do + manager <- liftIO $ newManager defaultManagerSettings + + return $ Driver { + _driverHostname = hostname + , _driverPort = port + , _driverBasePath = basePath + , _driverRequestHeaders = requestHeaders + , _driverManager = manager + , _driverProcess = Nothing + , _driverLogAsync = Nothing + , _driverConfig = DriverConfigChromedriver "" [] Nothing "" Nothing -- Not used + } + +-- | Tear down all sessions and processes associated with a 'WebDriverContext'. +teardownWebDriverContext :: (WebDriverBase m, MonadLogger m) => WebDriverContext -> m () +teardownWebDriverContext (WebDriverContext {..}) = do + -- Atomically take all sessions and clear the map, so we can clean up each + -- one without holding the MVar (and without modifyMVar_ restoring the old + -- value if any individual cleanup throws). + sessions <- modifyMVar _webDriverSessions $ \s -> return (mempty, M.toList s) + + forM_ sessions $ \(_name, sess) -> do + catch (closeSession' sess) + (\(e :: SomeException) -> logWarnN [i|Exception closing session during teardown: #{e}|]) + -- Geckodriver runs one process per session; tear it down here since + -- closeSession' only sends the HTTP DELETE and doesn't manage processes. + case _driverConfig (sessionDriver sess) of + DriverConfigGeckodriver {} -> + catch (teardownDriver (sessionDriver sess)) + (\(e :: SomeException) -> logWarnN [i|Exception tearing down geckodriver during teardown: #{e}|]) + _ -> return () + + modifyMVar_ _webDriverSelenium $ \case + Nothing -> return Nothing + Just driver -> teardownDriver driver >> return Nothing + + modifyMVar_ _webDriverChromedriver $ \case + Nothing -> return Nothing + Just driver -> teardownDriver driver >> return Nothing + +-- -- | Set a temporary list of custom 'RequestHeaders' to use within the given action. +-- -- All previous custom headers are temporarily removed, and then restored at the end. +-- withRequestHeaders :: (SessionStatePut m) => RequestHeaders -> m a -> m a +-- withRequestHeaders _h _action = undefined -- do +-- -- withModifiedSession (\s -> s { wdSessRequestHeaders = h }) action + +-- -- | Makes all webdriver HTTP requests in the given action use the session\'s auth headers, typically +-- -- configured by setting the 'wdAuthHeaders' config. This is useful if you want to temporarily use +-- -- the same auth headers you used for session creation with other HTTP requests. +-- withAuthHeaders :: (Monad m, SessionStatePut m) => m a -> m a +-- withAuthHeaders _wd = undefined -- do +-- -- authHeaders <- fmap wdSessAuthHeaders getSession +-- -- withRequestHeaders authHeaders wd + +-- -- | A finalizer ensuring that the session is always closed at the end of +-- -- the given 'WD' action, regardless of any exceptions. +-- finallyClose :: (HasCallStack, WebDriver wd, MonadMask wd) => wd a -> wd a +-- finallyClose wd = closeOnException wd <* closeSession + +-- -- | Exception handler that closes the session when an +-- -- asynchronous exception is thrown, but otherwise leaves the session open +-- -- if the action was successful. +-- closeOnException :: (HasCallStack, MonadMask wd) => WebDriver wd => wd a -> wd a +-- closeOnException wd = wd `onException` closeSession diff --git a/src/Test/WebDriver/Capabilities.hs b/src/Test/WebDriver/Capabilities.hs --- a/src/Test/WebDriver/Capabilities.hs +++ b/src/Test/WebDriver/Capabilities.hs @@ -1,777 +1,193 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} - -module Test.WebDriver.Capabilities where - -import Test.WebDriver.Chrome.Extension -import Test.WebDriver.Firefox.Profile -import Test.WebDriver.JSON - -import Data.Aeson -import Data.Aeson.Types (Parser, typeMismatch, Pair) - -import Data.Text (Text, toLower, toUpper) -import Data.Default (Default, def) -import Data.Word (Word16) -import Data.Maybe (fromMaybe, catMaybes) -import Data.String (fromString) - -import Control.Applicative -import Control.Exception.Lifted (throw) - -import Prelude -- hides some "unused import" warnings - -#if MIN_VERSION_aeson(2,0,0) -import qualified Data.Aeson.KeyMap as HM (delete, toList, empty) -#else -import qualified Data.HashMap.Strict as HM (delete, toList, empty) -#endif - - --- |A typeclass for readable 'Capabilities' -class GetCapabilities t where - getCaps :: t -> Capabilities - -instance GetCapabilities Capabilities where - getCaps = id - --- |A typeclass for writable 'Capabilities' -class SetCapabilities t where - setCaps :: Capabilities -> t -> t - --- |Read/write 'Capabilities' -type HasCapabilities t = (GetCapabilities t, SetCapabilities t) - --- |Modifies the 'wdCapabilities' field of a 'WDConfig' by applying the given function. Overloaded to work with any 'HasCapabilities' instance. -modifyCaps :: HasCapabilities t => (Capabilities -> Capabilities) -> t -> t -modifyCaps f c = setCaps (f (getCaps c)) c - --- |A helper function for setting the 'browser' capability of a 'HasCapabilities' instance -useBrowser :: HasCapabilities t => Browser -> t -> t -useBrowser b = modifyCaps $ \c -> c { browser = b } - --- |A helper function for setting the 'version' capability of a 'HasCapabilities' instance -useVersion :: HasCapabilities t => String -> t -> t -useVersion v = modifyCaps $ \c -> c { version = Just v } - --- |A helper function for setting the 'platform' capability of a 'HasCapabilities' instance -usePlatform :: HasCapabilities t => Platform -> t -> t -usePlatform p = modifyCaps $ \c -> c { platform = p } +{-# LANGUAGE TemplateHaskell #-} --- |A helper function for setting the 'useProxy' capability of a 'HasCapabilities' instance -useProxy :: HasCapabilities t => ProxyType -> t -> t -useProxy p = modifyCaps $ \c -> c { proxy = p } +{-| +This module contains the types for working with WebDriver Capabilities. +Capabilities are used to configure and communicate the features supported by a +session. -{- |A structure describing the capabilities of a session. This record -serves dual roles. +Some settings, like '_capabilitiesTimeouts', are browser-agnostic. But the +'Capabilities' object is also where browser-specific settings can be added, +under '_capabilitiesGoogChromeOptions', '_capabilitiesMozFirefoxOptions', etc. -* It's used to specify the desired capabilities for a session before -it's created. In this usage, fields that are set to Nothing indicate -that we have no preference for that capability. +This module provides lenses for all of the fields it defines, to make it easier +to manipulate nested values. -* When received from the server , it's used to -describe the actual capabilities given to us by the WebDriver -server. Here a value of Nothing indicates that the server doesn't -support the capability. Thus, for Maybe Bool fields, both Nothing and -Just False indicate a lack of support for the desired capability. -} -data Capabilities = - Capabilities { -- |Browser choice and browser specific settings. - browser :: Browser - -- |Browser version to use. - , version :: Maybe String - -- |Platform on which the browser should run. - , platform :: Platform - -- |Proxy configuration settings. - , proxy :: ProxyType - -- |Whether the session supports executing JavaScript via - -- 'executeJS' and 'asyncJS'. - , javascriptEnabled :: Maybe Bool - -- |Whether the session supports taking screenshots of the - -- current page with the 'screenshot' command - , takesScreenshot :: Maybe Bool - -- |Whether the session can interact with modal popups, - -- such as window.alert and window.confirm via - -- 'acceptAlerts', 'dismissAlerts', etc. - , handlesAlerts :: Maybe Bool - -- |Whether the session can interact with database storage. - , databaseEnabled :: Maybe Bool - -- |Whether the session can set and query the browser's - -- location context with 'setLocation' and 'getLocation'. - , locationContextEnabled :: Maybe Bool - -- |Whether the session can interact with the application cache - -- . - , applicationCacheEnabled :: Maybe Bool - -- |Whether the session can query for the browser's - -- connectivity and disable it if desired - , browserConnectionEnabled :: Maybe Bool - -- |Whether the session supports CSS selectors when searching - -- for elements. - , cssSelectorsEnabled :: Maybe Bool - -- |Whether Web Storage ('getKey', 'setKey', etc) support is - -- enabled - , webStorageEnabled :: Maybe Bool - -- |Whether the session can rotate the current page's current - -- layout between 'Portrait' and 'Landscape' orientations. - , rotatable :: Maybe Bool - -- |Whether the session should accept all SSL certs by default - , acceptSSLCerts :: Maybe Bool - -- |Whether the session is capable of generating native OS - -- events when simulating user input. - , nativeEvents :: Maybe Bool - -- |How the session should handle unexpected alerts. - , unexpectedAlertBehavior :: Maybe UnexpectedAlertBehavior - -- |A list of ('Text', 'Value') pairs specifying additional non-standard capabilities. - , additionalCaps :: [Pair] - } deriving (Eq, Show) -instance Default Capabilities where - def = Capabilities { browser = firefox - , version = Nothing - , platform = Any - , javascriptEnabled = Nothing - , takesScreenshot = Nothing - , handlesAlerts = Nothing - , databaseEnabled = Nothing - , locationContextEnabled = Nothing - , applicationCacheEnabled = Nothing - , browserConnectionEnabled = Nothing - , cssSelectorsEnabled = Nothing - , webStorageEnabled = Nothing - , rotatable = Nothing - , acceptSSLCerts = Nothing - , nativeEvents = Nothing - , proxy = UseSystemSettings - , unexpectedAlertBehavior = Nothing - , additionalCaps = [] - } +module Test.WebDriver.Capabilities ( + -- * Capabilities + Capabilities(..) + , defaultCaps --- |Default capabilities. This is the same as the 'Default' instance, but with --- less polymorphism. By default, we use 'firefox' of an unspecified 'version' --- with default system-wide 'proxy' settings on whatever 'platform' is available --- . All 'Maybe' capabilities are set to 'Nothing' (no preference). -defaultCaps :: Capabilities -defaultCaps = def + -- ** Lenses + , capabilitiesBrowserName + , capabilitiesBrowserVersion + , capabilitiesPlatformName + , capabilitiesAcceptInsecureCerts + , capabilitiesPageLoadStrategy + , capabilitiesProxy + , capabilitiesSetWindowRect + , capabilitiesTimeouts + , capabilitiesUnhandledPromptBehavior + , capabilitiesGoogChromeOptions + , capabilitiesMozFirefoxOptions + , capabilitiesWebSocketUrl --- |Same as 'defaultCaps', but with all 'Maybe' 'Bool' capabilities set to --- 'Just' 'True'. -allCaps :: Capabilities -allCaps = defaultCaps { javascriptEnabled = Just True - , takesScreenshot = Just True - , handlesAlerts = Just True - , databaseEnabled = Just True - , locationContextEnabled = Just True - , applicationCacheEnabled = Just True - , browserConnectionEnabled = Just True - , cssSelectorsEnabled = Just True - , webStorageEnabled = Just True - , rotatable = Just True - , acceptSSLCerts = Just True - , nativeEvents = Just True - } + -- ** Types + , Timeouts(..) + , UserPromptHandler(..) + , Platform(..) -instance ToJSON Capabilities where - toJSON Capabilities{..} = - object $ filter (\p -> snd p /= Null) - $ [ "browserName" .= browser - , "version" .= version - , "platform" .= platform - , "proxy" .= proxy - , "javascriptEnabled" .= javascriptEnabled - , "takesScreenshot" .= takesScreenshot - , "handlesAlerts" .= handlesAlerts - , "databaseEnabled" .= databaseEnabled - , "locationContextEnabled" .= locationContextEnabled - , "applicationCacheEnabled" .= applicationCacheEnabled - , "browserConnectionEnabled" .= browserConnectionEnabled - , "cssSelectorsEnabled" .= cssSelectorsEnabled - , "webStorageEnabled" .= webStorageEnabled - , "rotatable" .= rotatable - , "acceptSslCerts" .= acceptSSLCerts - , "nativeEvents" .= nativeEvents - , "unexpectedAlertBehavior" .= unexpectedAlertBehavior - ] - ++ browserInfo - ++ additionalCaps - where - browserInfo = case browser of - Firefox {..} - -> ["firefox_profile" .= ffProfile - ,"loggingPrefs" .= object ["driver" .= ffLogPref] - ,"firefox_binary" .= ffBinary - ,"acceptInsecureCerts" .= fromMaybe False ffAcceptInsecureCerts - ] - Chrome {..} - -> catMaybes [ opt "chrome.chromedriverVersion" chromeDriverVersion ] - ++ [ "chromeOptions" .= object (catMaybes - [ opt "binary" chromeBinary - ] ++ - [ "args" .= chromeOptions - , "extensions" .= chromeExtensions - ] ++ HM.toList chromeExperimentalOptions - )] - IE {..} - -> ["ignoreProtectedModeSettings" .= ieIgnoreProtectedModeSettings - ,"ignoreZoomSetting" .= ieIgnoreZoomSetting - ,"initialBrowserUrl" .= ieInitialBrowserUrl - ,"elementScrollBehavior" .= ieElementScrollBehavior - ,"enablePersistentHover" .= ieEnablePersistentHover - ,"enableElementCacheCleanup" .= ieEnableElementCacheCleanup - ,"requireWindowFocus" .= ieRequireWindowFocus - ,"browserAttachTimeout" .= ieBrowserAttachTimeout - ,"logFile" .= ieLogFile - ,"logLevel" .= ieLogLevel - ,"host" .= ieHost - ,"extractPath" .= ieExtractPath - ,"silent" .= ieSilent - ,"forceCreateProcess" .= ieForceCreateProcess - ,"internetExplorerSwitches" .= ieSwitches - ] - Opera{..} - -> catMaybes [ opt "opera.binary" operaBinary - , opt "opera.display" operaDisplay - , opt "opera.product" operaProduct - , opt "opera.launcher" operaLauncher - , opt "opera.host" operaHost - , opt "opera.logging.file" operaLogFile - ] - ++ ["opera.detatch" .= operaDetach - ,"opera.no_quit" .= operaDetach --backwards compatability - ,"opera.autostart" .= operaAutoStart - , "opera.idle" .= operaIdle - -- ,"opera.profile" .= operaProfile - ,"opera.port" .= fromMaybe maxBound {- (-1) -} operaPort - --note: consider replacing operaOptions with a list of options - ,"opera.arguments" .= operaOptions - ,"opera.logging.level" .= operaLogPref - ] + -- * Chrome + , ChromeOptions(..) + , defaultChromeOptions + -- *** Lenses + , chromeOptionsWindowTypes + , chromeOptionsPrefs + , chromeOptionsPerfLoggingPrefs + , chromeOptionsMobileEmulation + , chromeOptionsMinidumpPath + , chromeOptionsLocalState + , chromeOptionsExtensions + , chromeOptionsExcludeSwitches + , chromeOptionsDetach + , chromeOptionsDebuggerAddress + , chromeOptionsBinary + , chromeOptionsArgs - Phantomjs {..} - -> catMaybes [ opt "phantomjs.binary.path" phantomjsBinary - ] ++ - [ "phantomjs.cli.args" .= phantomjsOptions - ] + -- ** Client hints + , ChromeClientHints(..) + , mkChromeClientHints + , chromeClientHintsWow64 + , chromeClientHintsPlatformVersion + , chromeClientHintsPlatform + , chromeClientHintsModel + , chromeClientHintsMobile + , chromeClientHintsFullVersionList + , chromeClientHintsBrands + , chromeClientHintsBitness + , chromeClientHintsArchitecture + , BrandAndVersion(..) - _ -> [] + -- ** Device metrics + , ChromeDeviceMetrics(..) + , chromeDeviceMetricsWidth + , chromeDeviceMetricsTouch + , chromeDeviceMetricsPixelRatio + , chromeDeviceMetricsMobile + , chromeDeviceMetricsHeight - where - opt k = fmap (k .=) + -- ** Extensions + , ChromeExtension + , loadExtension + , loadRawExtension + -- ** Mobile emulation + , ChromeMobileEmulation(..) + , chromeMobileEmulationUserAgent + , chromeMobileEmulationDeviceName + , chromeMobileEmulationDeviceMetrics + , chromeMobileEmulationClientHints -instance FromJSON Capabilities where - parseJSON (Object o) = do - browser <- req "browserName" - Capabilities <$> getBrowserCaps browser - <*> opt "version" Nothing - <*> req "platform" - <*> opt "proxy" NoProxy - <*> b "javascriptEnabled" - <*> b "takesScreenshot" - <*> b "handlesAlerts" - <*> b "databaseEnabled" - <*> b "locationContextEnabled" - <*> b "applicationCacheEnabled" - <*> b "browserConnectionEnabled" - <*> b "cssSelectorEnabled" - <*> b "webStorageEnabled" - <*> b "rotatable" - <*> b "acceptSslCerts" - <*> b "nativeEvents" - <*> opt "unexpectedAlertBehaviour" Nothing - <*> pure (additionalCapabilities browser) + -- * Firefox + , FirefoxOptions(..) + , emptyFirefoxOptions + , defaultFirefoxOptions - where --some helpful JSON accessor shorthands - req :: FromJSON a => Text -> Parser a - req = (o .:) . fromText -- required field - opt :: FromJSON a => Text -> a -> Parser a - opt k d = o .:?? k .!= d -- optional field - b :: Text -> Parser (Maybe Bool) - b k = opt k Nothing -- Maybe Bool field + -- ** Lenses + , firefoxOptionsBinary + , firefoxOptionsArgs + , firefoxOptionsProfile + , firefoxOptionsLog + , firefoxOptionsPrefs + , firefoxOptionsEnv - -- produce additionalCaps by removing known capabilities from the JSON object - additionalCapabilities = HM.toList . foldr HM.delete o . knownCapabilities + -- ** Log level + , FirefoxLogLevel(..) + , FirefoxLogLevelType(..) + ) where - knownCapabilities browser = - [ "browserName", "version", "platform", "proxy" - , "javascriptEnabled", "takesScreenshot", "handlesAlerts" - , "databaseEnabled", "locationContextEnabled" - , "applicationCacheEnabled", "browserConnectionEnabled" - , "cssSelectorEnabled","webStorageEnabled", "rotatable" - , "acceptSslCerts", "nativeEvents", "unexpectedBrowserBehaviour"] - ++ case browser of - Firefox {} -> ["firefox_profile", "loggingPrefs", "firefox_binary", "acceptInsecureCerts"] - Chrome {} -> ["chrome.chromedriverVersion", "chrome.extensions", "chrome.switches", "chrome.extensions"] - IE {} -> ["ignoreProtectedModeSettings", "ignoreZoomSettings", "initialBrowserUrl", "elementScrollBehavior" - ,"enablePersistentHover", "enableElementCacheCleanup", "requireWindowFocus", "browserAttachTimeout" - ,"logFile", "logLevel", "host", "extractPath", "silent", "forceCreateProcess", "internetExplorerSwitches"] - Opera {} -> ["opera.binary", "opera.product", "opera.no_quit", "opera.autostart", "opera.idle", "opera.display" - ,"opera.launcher", "opera.port", "opera.host", "opera.arguments", "opera.logging.file", "opera.logging.level"] - _ -> [] - getBrowserCaps browser = - case browser of - Firefox {} -> Firefox <$> opt "firefox_profile" Nothing - <*> opt "loggingPrefs" def - <*> opt "firefox_binary" Nothing - <*> opt "acceptInsecureCerts" Nothing - Chrome {} -> Chrome <$> opt "chrome.chromedriverVersion" Nothing - <*> opt "chrome.binary" Nothing - <*> opt "chrome.switches" [] - <*> opt "chrome.extensions" [] - <*> pure HM.empty - IE {} -> IE <$> opt "ignoreProtectedModeSettings" True - <*> opt "ignoreZoomSettings" False - <*> opt "initialBrowserUrl" Nothing - <*> opt "elementScrollBehavior" def - <*> opt "enablePersistentHover" True - <*> opt "enableElementCacheCleanup" True - <*> opt "requireWindowFocus" False - <*> opt "browserAttachTimeout" 0 - <*> opt "logFile" Nothing - <*> opt "logLevel" def - <*> opt "host" Nothing - <*> opt "extractPath" Nothing - <*> opt "silent" False - <*> opt "forceCreateProcess" False - <*> opt "internetExplorerSwitches" Nothing - Opera {} -> Opera <$> opt "opera.binary" Nothing - <*> opt "opera.product" Nothing - <*> opt "opera.no_quit" False - <*> opt "opera.autostart" True - <*> opt "opera.idle" False - <*> opt "opera.display" Nothing - <*> opt "opera.launcher" Nothing - <*> opt "opera.port" (Just 0) - <*> opt "opera.host" Nothing - <*> opt "opera.arguments" Nothing - <*> opt "opera.logging.file" Nothing - <*> opt "opera.logging.level" def - _ -> return browser +import Data.Aeson.TH +import Lens.Micro.TH +import Test.WebDriver.Capabilities.Aeson +import Test.WebDriver.Capabilities.ChromeOptions +import Test.WebDriver.Capabilities.FirefoxOptions +import Test.WebDriver.Capabilities.Platform +import Test.WebDriver.Capabilities.Proxy +import Test.WebDriver.Capabilities.Timeouts +import Test.WebDriver.Capabilities.UserPromptHandler - parseJSON v = typeMismatch "Capabilities" v --- |This constructor simultaneously specifies which browser the session will --- use, while also providing browser-specific configuration. Default --- configuration is provided for each browser by 'firefox', 'chrome', 'opera', --- 'ie', etc. +-- | A structure describing the capabilities of a session. This record +-- serves dual roles. -- --- This library uses 'firefox' as its 'Default' browser configuration, when no --- browser choice is specified. -data Browser = Firefox { -- |The firefox profile to use. If Nothing, - -- a default temporary profile is automatically created - -- and used. - ffProfile :: Maybe (PreparedProfile Firefox) - -- |Firefox logging preference - , ffLogPref :: LogLevel - -- |Server-side path to Firefox binary. If Nothing, - -- use a sensible system-based default. - , ffBinary :: Maybe FilePath - -- |Available after Firefox 52, and required only for Firefox - -- geckodriver. Indicates whether untrusted and self-signed TLS - -- certificates are implicitly trusted on navigation for the - -- duration of the session. - , ffAcceptInsecureCerts :: Maybe Bool - } - | Chrome { -- |Version of the Chrome Webdriver server server to use - -- - -- for more information on chromedriver see - -- - chromeDriverVersion :: Maybe String - -- |Server-side path to Chrome binary. If Nothing, - -- use a sensible system-based default. - , chromeBinary :: Maybe FilePath - -- |A list of command-line options to pass to the - -- Chrome binary. - , chromeOptions :: [String] - -- |A list of extensions to use. - , chromeExtensions :: [ChromeExtension] - -- | Experimental options not yet exposed through a standard API. - , chromeExperimentalOptions :: Object - } - | IE { -- |Whether to skip the protected mode check. If set, tests - -- may become flaky, unresponsive, or browsers may hang. If - -- not set, and protected mode settings are not the same for - -- all zones, an exception will be thrown on driver - -- construction. - ieIgnoreProtectedModeSettings :: Bool - -- |Indicates whether to skip the check that the browser's zoom - -- level is set to 100%. Value is set to false by default. - , ieIgnoreZoomSetting :: Bool - -- |Allows the user to specify the initial URL loaded when IE - -- starts. Intended to be used with ignoreProtectedModeSettings - -- to allow the user to initialize IE in the proper Protected Mode - -- zone. Using this capability may cause browser instability or - -- flaky and unresponsive code. Only \"best effort\" support is - -- provided when using this capability. - , ieInitialBrowserUrl :: Maybe Text - -- |Allows the user to specify whether elements are scrolled into - -- the viewport for interaction to align with the top or bottom - -- of the viewport. The default value is to align with the top of - -- the viewport. - , ieElementScrollBehavior :: IEElementScrollBehavior - -- |Determines whether persistent hovering is enabled (true by - -- default). Persistent hovering is achieved by continuously firing - -- mouse over events at the last location the mouse cursor has been - -- moved to. - , ieEnablePersistentHover :: Bool - -- |Determines whether the driver should attempt to remove obsolete - -- elements from the element cache on page navigation (true by - -- default). This is to help manage the IE driver's memory footprint - -- , removing references to invalid elements. - , ieEnableElementCacheCleanup :: Bool - -- |Determines whether to require that the IE window have focus - -- before performing any user interaction operations (mouse or - -- keyboard events). This capability is false by default, but - -- delivers much more accurate native events interactions. - , ieRequireWindowFocus :: Bool - -- |The timeout, in milliseconds, that the driver will attempt to - -- locate and attach to a newly opened instance of Internet Explorer - -- . The default is zero, which indicates waiting indefinitely. - , ieBrowserAttachTimeout :: Integer - -- |The path to file where server should write log messages to. - -- By default it writes to stdout. - , ieLogFile :: Maybe FilePath - -- |The log level used by the server. Defaults to 'IELogFatal' - , ieLogLevel :: IELogLevel - -- |The address of the host adapter on which the server will listen - -- for commands. - , ieHost :: Maybe Text - -- |The path to the directory used to extract supporting files used - -- by the server. Defaults to the TEMP directory if not specified. - , ieExtractPath :: Maybe Text - -- |Suppresses diagnostic output when the server is started. - , ieSilent :: Bool - -- |Forces launching Internet Explorer using the CreateProcess API. - -- If this option is not specified, IE is launched using the - -- IELaunchURL, if it is available. For IE 8 and above, this option - -- requires the TabProcGrowth registry value to be set to 0. - , ieForceCreateProcess :: Bool - -- |Specifies command-line switches with which to launch Internet - -- Explorer. This is only valid when used with the - -- forceCreateProcess. - , ieSwitches :: Maybe Text - } - | Opera { -- |Server-side path to the Opera binary - operaBinary :: Maybe FilePath - --, operaNoRestart :: Maybe Bool - -- |Which Opera product we're using, e.g. \"desktop\", - -- \"core\" - , operaProduct :: Maybe String - -- |Whether the Opera instance should stay open after - -- we close the session. If false, closing the session - -- closes the browser. - , operaDetach :: Bool - -- |Whether to auto-start the Opera binary. If false, - -- OperaDriver will wait for a connection from the - -- browser. By default this is True. - , operaAutoStart :: Bool - -- |Whether to use Opera's alternative implicit wait - -- implementation. It will use an in-browser heuristic - -- to guess when a page has finished loading. This - -- feature is experimental, and disabled by default. - , operaIdle :: Bool - -- |(*nix only) which X display to use. - , operaDisplay :: Maybe Int - --, operaProfile :: Maybe (PreparedProfile Opera) - -- |Path to the launcher binary to use. The launcher - -- is a gateway between OperaDriver and the Opera - -- browser. If Nothing, OperaDriver will use the - -- launcher supplied with the package. - , operaLauncher :: Maybe FilePath - -- |The port we should use to connect to Opera. If Just 0 - -- , use a random port. If Nothing, use the default - -- Opera port. The default 'opera' constructor uses - -- Just 0, since Nothing is likely to cause "address - -- already in use" errors. - , operaPort :: Maybe Word16 - -- |The host Opera should connect to. Unless you're - -- starting Opera manually you won't need this. - , operaHost :: Maybe String - -- |Command-line arguments to pass to Opera. - , operaOptions :: Maybe String - -- |Where to send the log output. If Nothing, logging is - -- disabled. - , operaLogFile :: Maybe FilePath - -- |Log level preference. Defaults to 'LogInfo' - , operaLogPref :: LogLevel - } - - | Phantomjs { phantomjsBinary :: Maybe FilePath - , phantomjsOptions :: [String] - } - - | HTMLUnit - | IPhone - | IPad - | Android - -- |some other browser, specified by a string name - | Browser Text - deriving (Eq, Show) - -instance Default Browser where - def = firefox - - -instance ToJSON Browser where - toJSON Firefox {} = String "firefox" - toJSON Chrome {} = String "chrome" - toJSON Opera {} = String "opera" - toJSON IE {} = String "internet explorer" - toJSON Phantomjs {} = String "phantomjs" - toJSON (Browser b) = String b - toJSON b = String . toLower . fromString . show $ b - -instance FromJSON Browser where - parseJSON (String jStr) = case toLower jStr of - "firefox" -> return firefox - "chrome" -> return chrome - "internet explorer" -> return ie - "opera" -> return opera - "phantomjs" -> return phantomjs - -- "safari" -> return safari - "iphone" -> return iPhone - "ipad" -> return iPad - "android" -> return android - "htmlunit" -> return htmlUnit - other -> return (Browser other) - parseJSON v = typeMismatch "Browser" v - - --- |Default Firefox settings. All Maybe fields are set to Nothing. ffLogPref --- is set to 'LogInfo'. -firefox :: Browser -firefox = Firefox Nothing def Nothing Nothing - --- |Default Chrome settings. All Maybe fields are set to Nothing, no options are --- specified, and no extensions are used. -chrome :: Browser -chrome = Chrome Nothing Nothing [] [] HM.empty - --- |Default IE settings. See the 'IE' constructor for more details on --- individual defaults -ie :: Browser -ie = IE { ieIgnoreProtectedModeSettings = True - , ieIgnoreZoomSetting = False - , ieInitialBrowserUrl = Nothing - , ieElementScrollBehavior = def - , ieEnablePersistentHover = True - , ieEnableElementCacheCleanup = True - , ieRequireWindowFocus = False - , ieBrowserAttachTimeout = 0 - , ieLogFile = Nothing - , ieLogLevel = def - , ieHost = Nothing - , ieExtractPath = Nothing - , ieSilent = False - , ieForceCreateProcess = False - , ieSwitches = Nothing - } - --- |Default Opera settings. See the 'Opera' constructor for more details on --- individual defaults. -opera :: Browser -opera = Opera { operaBinary = Nothing - --, operaNoRestart = Nothing - , operaProduct = Nothing - , operaDetach = False - , operaAutoStart = True - , operaDisplay = Nothing - , operaIdle = False --- , operaProfile = Nothing - , operaLauncher = Nothing - , operaHost = Nothing - , operaPort = Just 0 - , operaOptions = Nothing - , operaLogFile = Nothing - , operaLogPref = def - } - -phantomjs :: Browser -phantomjs = Phantomjs Nothing [] - ---safari :: Browser ---safari = Safari - -htmlUnit :: Browser -htmlUnit = HTMLUnit - -iPhone :: Browser -iPhone = IPhone - -iPad :: Browser -iPad = IPad - -android :: Browser -android = Android - --- |Represents platform options supported by WebDriver. The value Any represents --- no preference. -data Platform = Windows | XP | Vista | Mac | Linux | Unix | Any - deriving (Eq, Show, Ord, Bounded, Enum) - -instance ToJSON Platform where - toJSON = String . toUpper . fromString . show - -instance FromJSON Platform where - parseJSON (String jStr) = case toLower jStr of - "windows" -> return Windows - "xp" -> return XP - "vista" -> return Vista - "mac" -> return Mac - "linux" -> return Linux - "unix" -> return Unix - "any" -> return Any - err -> fail $ "Invalid Platform string " ++ show err - parseJSON v = typeMismatch "Platform" v - --- |Available settings for the proxy 'Capabilities' field -data ProxyType = NoProxy - | UseSystemSettings - | AutoDetect - -- |Use a proxy auto-config file specified by URL - | PAC { autoConfigUrl :: String } - -- |Manually specify proxy hosts as hostname:port strings. - -- Note that behavior is undefined for empty strings. - | Manual { ftpProxy :: String - , sslProxy :: String - , httpProxy :: String - } - deriving (Eq, Show) - -instance FromJSON ProxyType where - parseJSON (Object obj) = do - pTyp <- f "proxyType" - case toLower pTyp of - "direct" -> return NoProxy - "system" -> return UseSystemSettings - "pac" -> PAC <$> f "autoConfigUrl" - "manual" -> Manual <$> f "ftpProxy" - <*> f "sslProxy" - <*> f "httpProxy" - _ -> fail $ "Invalid ProxyType " ++ show pTyp - where - f :: FromJSON a => Text -> Parser a - f = (obj .:) . fromText - parseJSON v = typeMismatch "ProxyType" v - -instance ToJSON ProxyType where - toJSON pt = object $ case pt of - NoProxy -> - ["proxyType" .= ("DIRECT" :: String)] - UseSystemSettings -> - ["proxyType" .= ("SYSTEM" :: String)] - AutoDetect -> - ["proxyType" .= ("AUTODETECT" :: String)] - PAC{autoConfigUrl = url} -> - ["proxyType" .= ("PAC" :: String) - ,"proxyAutoconfigUrl" .= url - ] - Manual{ftpProxy = ftp, sslProxy = ssl, httpProxy = http} -> - ["proxyType" .= ("MANUAL" :: String) - ,"ftpProxy" .= ftp - ,"sslProxy" .= ssl - ,"httpProxy" .= http - ] - -data UnexpectedAlertBehavior = AcceptAlert | DismissAlert | IgnoreAlert - deriving (Bounded, Enum, Eq, Ord, Read, Show) - -instance ToJSON UnexpectedAlertBehavior where - toJSON AcceptAlert = String "accept" - toJSON DismissAlert = String "dismiss" - toJSON IgnoreAlert = String "ignore" - -instance FromJSON UnexpectedAlertBehavior where - parseJSON (String s) = - return $ case s of - "accept" -> AcceptAlert - "dismiss" -> DismissAlert - "ignore" -> IgnoreAlert - err -> throw . BadJSON - $ "Invalid string value for UnexpectedAlertBehavior: " ++ show err - parseJSON v = typeMismatch "UnexpectedAlertBehavior" v - --- |Indicates a log verbosity level. Used in 'Firefox' and 'Opera' configuration. -data LogLevel = LogOff | LogSevere | LogWarning | LogInfo | LogConfig - | LogFine | LogFiner | LogFinest | LogDebug | LogAll - deriving (Eq, Show, Read, Ord, Bounded, Enum) +-- It's used to specify the desired capabilities for a session before +-- it's created. In this usage, fields that are set to Nothing indicate +-- that we have no preference for that capability. +-- +-- When received from the server , it's used to describe the actual +-- capabilities given to us by the WebDriver server. Here a value of +-- Nothing indicates that the server doesn't support the capability. +-- Thus, for Maybe Bool fields, both Nothing and Just False indicate +-- a lack of support for the desired capability. +data Capabilities = Capabilities { + -- | Identifies the user agent. + _capabilitiesBrowserName :: Maybe String + -- | Identifies the version of the user agent. + , _capabilitiesBrowserVersion :: Maybe String + -- | Identifies the operating system of the endpoint node. + , _capabilitiesPlatformName :: Maybe Platform + -- | Indicates whether untrusted and self-signed TLS certificates are implicitly trusted on navigation for the + -- duration of the session. + , _capabilitiesAcceptInsecureCerts :: Maybe Bool + -- | Defines the current session’s page load strategy. + , _capabilitiesPageLoadStrategy :: Maybe String + -- | Defines the current session’s proxy configuration. + , _capabilitiesProxy :: Maybe Proxy + -- | Indicates whether the remote end supports all of the commands in Resizing and Positioning Windows. + , _capabilitiesSetWindowRect :: Maybe Bool + -- | Describes the timeouts imposed on certain session operations. + , _capabilitiesTimeouts :: Maybe Timeouts + -- | Describes the current session’s user prompt handler. + , _capabilitiesUnhandledPromptBehavior :: Maybe UserPromptHandler -instance Default LogLevel where - def = LogInfo + -- * Vendor-specific stuff + -- | Chrome options + , _capabilitiesGoogChromeOptions :: Maybe ChromeOptions + -- | Firefox options + , _capabilitiesMozFirefoxOptions :: Maybe FirefoxOptions -instance ToJSON LogLevel where - toJSON p= String $ case p of - LogOff -> "OFF" - LogSevere -> "SEVERE" - LogWarning -> "WARNING" - LogInfo -> "INFO" - LogConfig -> "CONFIG" - LogFine -> "FINE" - LogFiner -> "FINER" - LogFinest -> "FINEST" - LogDebug -> "DEBUG" - LogAll -> "ALL" + , _capabilitiesWebSocketUrl :: Maybe Bool -instance FromJSON LogLevel where - parseJSON (String s) = return $ case s of - "OFF" -> LogOff - "SEVERE" -> LogSevere - "WARNING" -> LogWarning - "INFO" -> LogInfo - "CONFIG" -> LogConfig - "FINE" -> LogFine - "FINER" -> LogFiner - "FINEST" -> LogFinest - "DEBUG" -> LogDebug - "ALL" -> LogAll - _ -> throw . BadJSON $ "Invalid logging preference: " ++ show s - parseJSON other = typeMismatch "LogLevel" other + } deriving (Eq, Show) +deriveJSON capabilitiesOptions ''Capabilities +makeLenses ''Capabilities +-- | Default capabilities. +defaultCaps :: Capabilities +defaultCaps = Capabilities { + _capabilitiesBrowserName = Nothing + , _capabilitiesBrowserVersion = Nothing --- |Logging levels for Internet Explorer -data IELogLevel = IELogTrace | IELogDebug | IELogInfo | IELogWarn | IELogError - | IELogFatal - deriving (Eq, Show, Read, Ord, Bounded, Enum) + , _capabilitiesPlatformName = Nothing -instance Default IELogLevel where - def = IELogFatal + , _capabilitiesAcceptInsecureCerts = Nothing + , _capabilitiesPageLoadStrategy = Nothing -instance ToJSON IELogLevel where - toJSON p= String $ case p of - IELogTrace -> "TRACE" - IELogDebug -> "DEBUG" - IELogInfo -> "INFO" - IELogWarn -> "WARN" - IELogError -> "ERROR" - IELogFatal -> "FATAL" + , _capabilitiesProxy = Nothing -instance FromJSON IELogLevel where - parseJSON (String s) = return $ case s of - "TRACE" -> IELogTrace - "DEBIG" -> IELogDebug - "INFO" -> IELogInfo - "WARN" -> IELogWarn - "ERROR" -> IELogError - "FATAL" -> IELogFatal - _ -> throw . BadJSON $ "Invalid logging preference: " ++ show s - parseJSON other = typeMismatch "IELogLevel" other + , _capabilitiesSetWindowRect = Nothing --- |Specifies how elements scroll into the viewport. (see 'ieElementScrollBehavior') -data IEElementScrollBehavior = AlignTop | AlignBottom - deriving (Eq, Ord, Show, Read, Enum, Bounded) + , _capabilitiesTimeouts = Nothing -instance Default IEElementScrollBehavior where - def = AlignTop + , _capabilitiesUnhandledPromptBehavior = Nothing -instance ToJSON IEElementScrollBehavior where - toJSON AlignTop = toJSON (0 :: Int) - toJSON AlignBottom = toJSON (1 :: Int) + , _capabilitiesGoogChromeOptions = Nothing + , _capabilitiesMozFirefoxOptions = Nothing -instance FromJSON IEElementScrollBehavior where - parseJSON v = do - n <- parseJSON v - case n :: Integer of - 0 -> return AlignTop - 1 -> return AlignBottom - _ -> fail $ "Invalid integer for IEElementScrollBehavior: " ++ show n + , _capabilitiesWebSocketUrl = Nothing + } diff --git a/src/Test/WebDriver/Capabilities/Aeson.hs b/src/Test/WebDriver/Capabilities/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Capabilities/Aeson.hs @@ -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 diff --git a/src/Test/WebDriver/Capabilities/ChromeOptions.hs b/src/Test/WebDriver/Capabilities/ChromeOptions.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Capabilities/ChromeOptions.hs @@ -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 @@, 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 + } diff --git a/src/Test/WebDriver/Capabilities/FirefoxOptions.hs b/src/Test/WebDriver/Capabilities/FirefoxOptions.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Capabilities/FirefoxOptions.hs @@ -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 diff --git a/src/Test/WebDriver/Capabilities/Platform.hs b/src/Test/WebDriver/Capabilities/Platform.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Capabilities/Platform.hs @@ -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 diff --git a/src/Test/WebDriver/Capabilities/Proxy.hs b/src/Test/WebDriver/Capabilities/Proxy.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Capabilities/Proxy.hs @@ -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 diff --git a/src/Test/WebDriver/Capabilities/Timeouts.hs b/src/Test/WebDriver/Capabilities/Timeouts.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Capabilities/Timeouts.hs @@ -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 diff --git a/src/Test/WebDriver/Capabilities/UserPromptHandler.hs b/src/Test/WebDriver/Capabilities/UserPromptHandler.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Capabilities/UserPromptHandler.hs @@ -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 diff --git a/src/Test/WebDriver/Chrome/Extension.hs b/src/Test/WebDriver/Chrome/Extension.hs deleted file mode 100644 --- a/src/Test/WebDriver/Chrome/Extension.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- | Functions and types for working with Google Chrome extensions. -module Test.WebDriver.Chrome.Extension - ( ChromeExtension - , loadExtension - , loadRawExtension - ) where -import Data.ByteString.Lazy as LBS -import Data.ByteString.Base64.Lazy as B64 -import Data.Text.Lazy -import Data.Text.Lazy.Encoding (decodeLatin1) -import Data.Aeson -import Control.Applicative -import Control.Monad.Base - -import Prelude -- hides some "unused import" warnings - --- |An opaque type representing a Google Chrome extension. Values of this type --- are passed to the 'Test.Webdriver.chromeExtensions' field. -newtype ChromeExtension = ChromeExtension Text - deriving (Eq, Show, Read, ToJSON, FromJSON) - --- |Load a .crx file as a 'ChromeExtension'. -loadExtension :: MonadBase IO m => FilePath -> m ChromeExtension -loadExtension path = liftBase $ loadRawExtension <$> LBS.readFile path - --- |Load raw .crx data as a 'ChromeExtension'. -loadRawExtension :: ByteString -> ChromeExtension -loadRawExtension = ChromeExtension . decodeLatin1 . B64.encode diff --git a/src/Test/WebDriver/Class.hs b/src/Test/WebDriver/Class.hs deleted file mode 100644 --- a/src/Test/WebDriver/Class.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} - -module Test.WebDriver.Class ( - -- * WebDriver class - WebDriver(..), Method, methodDelete, methodGet, methodPost, - ) where -import Test.WebDriver.Session - -import Data.Aeson -import Data.Text (Text) -import Network.HTTP.Types.Method (methodDelete, methodGet, methodPost, Method) -import Control.Monad.Trans.Class -import Control.Monad.Trans.Except -import Control.Monad.Trans.Identity -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.RWS.Lazy as LRWS -import Control.Monad.Trans.RWS.Strict as SRWS -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State.Lazy as LS -import Control.Monad.Trans.State.Strict as SS -import Control.Monad.Trans.Writer.Lazy as LW -import Control.Monad.Trans.Writer.Strict as SW -import Data.CallStack - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid (Monoid) -- for some reason "import Prelude" trick doesn't work with "import Data.Monoid" -#endif - - --- |A class for monads that can handle wire protocol requests. This is the --- operation underlying all of the high-level commands exported in --- "Test.WebDriver.Commands". For more information on the wire protocol see --- -class (WDSessionStateControl wd) => WebDriver wd where - doCommand :: (HasCallStack, ToJSON a, FromJSON b) => - Method -- ^HTTP request method - -> Text -- ^URL of request - -> a -- ^JSON parameters passed in the body - -- of the request. Note that, as a special case, - -- anything that converts to Data.Aeson.Null will - -- result in an empty request body. - -> wd b -- ^The JSON result of the HTTP request. - -instance WebDriver wd => WebDriver (SS.StateT s wd) where - doCommand rm t a = lift (doCommand rm t a) - -instance WebDriver wd => WebDriver (LS.StateT s wd) where - doCommand rm t a = lift (doCommand rm t a) - -instance WebDriver wd => WebDriver (MaybeT wd) where - doCommand rm t a = lift (doCommand rm t a) - -instance WebDriver wd => WebDriver (IdentityT wd) where - doCommand rm t a = lift (doCommand rm t a) - -instance (Monoid w, WebDriver wd) => WebDriver (LW.WriterT w wd) where - doCommand rm t a = lift (doCommand rm t a) - -instance (Monoid w, WebDriver wd) => WebDriver (SW.WriterT w wd) where - doCommand rm t a = lift (doCommand rm t a) - -instance WebDriver wd => WebDriver (ReaderT r wd) where - doCommand rm t a = lift (doCommand rm t a) - -instance WebDriver wd => WebDriver (ExceptT e wd) where - doCommand rm t a = lift (doCommand rm t a) - -instance (Monoid w, WebDriver wd) => WebDriver (SRWS.RWST r w s wd) where - doCommand rm t a = lift (doCommand rm t a) - -instance (Monoid w, WebDriver wd) => WebDriver (LRWS.RWST r w s wd) where - doCommand rm t a = lift (doCommand rm t a) diff --git a/src/Test/WebDriver/Commands.hs b/src/Test/WebDriver/Commands.hs --- a/src/Test/WebDriver/Commands.hs +++ b/src/Test/WebDriver/Commands.hs @@ -1,777 +1,127 @@ -{-# LANGUAGE ExistentialQuantification #-} --- | This module exports basic WD actions that can be used to interact with a +-- | This module exports all the actions that can be used to interact with a -- browser session. -module Test.WebDriver.Commands - ( -- * Sessions - createSession, closeSession, sessions, getActualCaps - -- * Browser interaction - -- ** Web navigation - , openPage, forward, back, refresh - -- ** Page info - , getCurrentURL, getSource, getTitle, saveScreenshot, screenshot, screenshotBase64 - -- * Timeouts - , setImplicitWait, setScriptTimeout, setPageLoadTimeout - -- * Web elements - , Element(..), Selector(..) - -- ** Searching for elements - , findElem, findElems, findElemFrom, findElemsFrom - -- ** Interacting with elements - , click, submit, getText - -- *** Sending key inputs to elements - , sendKeys, sendRawKeys, clearInput - -- ** Element information - , attr, cssProp, elemPos, elemSize - , isSelected, isEnabled, isDisplayed - , tagName, activeElem, elemInfo - -- ** Element equality - , (<==>), () - -- * Javascript - , executeJS, asyncJS - , JSArg(..) - -- * Windows - , WindowHandle(..), currentWindow - , getCurrentWindow, closeWindow, windows, focusWindow, maximize - , getWindowSize, setWindowSize, getWindowPos, setWindowPos - -- * Focusing on frames - , focusFrame, FrameSelector(..) - -- * Cookies - , Cookie(..), mkCookie - , cookies, setCookie, deleteCookie, deleteVisibleCookies, deleteCookieByName - -- * Alerts - , getAlertText, replyToAlert, acceptAlert, dismissAlert - -- * Mouse gestures - , moveTo, moveToCenter, moveToFrom - , clickWith, MouseButton(..) - , mouseDown, mouseUp, withMouseDown, doubleClick - -- * HTML 5 Web Storage - , WebStorageType(..), storageSize, getAllKeys, deleteAllKeys - , getKey, setKey, deleteKey - -- * HTML 5 Application Cache - , ApplicationCacheStatus(..) - , getApplicationCacheStatus - -- * Mobile device support - -- ** Screen orientation - , Orientation(..) - , getOrientation, setOrientation - -- ** Geo-location - , getLocation, setLocation - -- ** Touch gestures - , touchClick, touchDown, touchUp, touchMove - , touchScroll, touchScrollFrom, touchDoubleClick - , touchLongClick, touchFlick, touchFlickFrom - -- * IME support - , availableIMEEngines, activeIMEEngine, checkIMEActive - , activateIME, deactivateIME - -- * Uploading files to remote server - -- |These functions allow you to upload a file to a remote server. - -- Note that this operation isn't supported by all WebDriver servers, - -- and the location where the file is stored is not standardized. - , uploadFile, uploadRawFile, uploadZipEntry - -- * Server information and logs - , serverStatus - , getLogs, getLogTypes, LogType, LogEntry(..), LogLevel(..) - ) where - -import Codec.Archive.Zip -import Control.Applicative -import Control.Exception (SomeException) -import Control.Exception.Lifted (throwIO, handle) -import qualified Control.Exception.Lifted as L -import Control.Monad -import Control.Monad.Base -import Data.Aeson -import Data.Aeson.Types -import Data.ByteString.Base64.Lazy as B64 -import Data.ByteString.Lazy as LBS (ByteString, writeFile) -import Data.CallStack -import qualified Data.Foldable as F -import Data.Maybe -import Data.String (fromString) -import Data.Text (Text, append, toUpper, toLower) -import qualified Data.Text as T -import qualified Data.Text.Lazy.Encoding as TL -import Data.Word -import Network.URI hiding (path) -- suppresses warnings -import Test.WebDriver.Capabilities -import Test.WebDriver.Class -import Test.WebDriver.Commands.Internal -import Test.WebDriver.Cookies -import Test.WebDriver.Exceptions.Internal -import Test.WebDriver.JSON -import Test.WebDriver.Session -import Test.WebDriver.Utils (urlEncode) - -import Prelude -- hides some "unused import" warnings - --- |Create a new session with the given 'Capabilities'. The returned session becomes the \"current session\" for this action. --- --- Note: if you're using 'runSession' to run your WebDriver commands, you don't need to call this explicitly. -createSession :: (HasCallStack, WebDriver wd) => Capabilities -> wd WDSession -createSession caps = do - ignoreReturn . withAuthHeaders . doCommand methodPost "/session" . single "desiredCapabilities" $ caps - getSession - --- |Retrieve a list of active sessions and their 'Capabilities'. -sessions :: (HasCallStack, WebDriver wd) => wd [(SessionId, Capabilities)] -sessions = do - objs <- doCommand methodGet "/sessions" Null - mapM (parsePair "id" "capabilities" "sessions") objs - --- |Get the actual server-side 'Capabilities' of the current session. -getActualCaps :: (HasCallStack, WebDriver wd) => wd Capabilities -getActualCaps = doSessCommand methodGet "" Null - --- |Close the current session and the browser associated with it. -closeSession :: (HasCallStack, WebDriver wd) => wd () -closeSession = do s@WDSession {} <- getSession - noReturn $ doSessCommand methodDelete "" Null - putSession s { wdSessId = Nothing } - - --- |Sets the amount of time (ms) we implicitly wait when searching for elements. -setImplicitWait :: (HasCallStack, WebDriver wd) => Integer -> wd () -setImplicitWait ms = - noReturn $ doSessCommand methodPost "/timeouts/implicit_wait" (object msField) - `L.catch` \(_ :: SomeException) -> - doSessCommand methodPost "/timeouts" (object allFields) - where msField = ["ms" .= ms] - allFields = ["type" .= ("implicit" :: String)] ++ msField - --- |Sets the amount of time (ms) we wait for an asynchronous script to return a --- result. -setScriptTimeout :: (HasCallStack, WebDriver wd) => Integer -> wd () -setScriptTimeout ms = - noReturn $ doSessCommand methodPost "/timeouts/async_script" (object msField) - `L.catch` \( _ :: SomeException) -> - doSessCommand methodPost "/timeouts" (object allFields) - where msField = ["ms" .= ms] - allFields = ["type" .= ("script" :: String)] ++ msField - --- |Sets the amount of time (ms) to wait for a page to finish loading before throwing a 'Timeout' exception. -setPageLoadTimeout :: (HasCallStack, WebDriver wd) => Integer -> wd () -setPageLoadTimeout ms = noReturn $ doSessCommand methodPost "/timeouts" params - where params = object ["type" .= ("page load" :: String) - ,"ms" .= ms ] - --- |Gets the URL of the current page. -getCurrentURL :: (HasCallStack, WebDriver wd) => wd String -getCurrentURL = doSessCommand methodGet "/url" Null - --- |Opens a new page by the given URL. -openPage :: (HasCallStack, WebDriver wd) => String -> wd () -openPage url - | isURI url = noReturn . doSessCommand methodPost "/url" . single "url" $ url - | otherwise = throwIO . InvalidURL $ url - --- |Navigate forward in the browser history. -forward :: (HasCallStack, WebDriver wd) => wd () -forward = noReturn $ doSessCommand methodPost "/forward" Null - --- |Navigate backward in the browser history. -back :: (HasCallStack, WebDriver wd) => wd () -back = noReturn $ doSessCommand methodPost "/back" Null - --- |Refresh the current page -refresh :: (HasCallStack, WebDriver wd) => wd () -refresh = noReturn $ doSessCommand methodPost "/refresh" Null - --- |An existential wrapper for any 'ToJSON' instance. This allows us to pass --- parameters of many different types to Javascript code. -data JSArg = forall a. ToJSON a => JSArg a - -instance ToJSON JSArg where - toJSON (JSArg a) = toJSON a - -{- |Inject a snippet of Javascript into the page for execution in the -context of the currently selected frame. The executed script is -assumed to be synchronous and the result of evaluating the script is -returned and converted to an instance of FromJSON. - -The first parameter defines a sequence of arguments to pass to the javascript -function. Arguments of type Element will be converted to the -corresponding DOM element. Likewise, any elements in the script result -will be returned to the client as Elements. - -The second parameter defines the script itself in the form of a -function body. The value returned by that function will be returned to -the client. The function will be invoked with the provided argument -list and the values may be accessed via the arguments object in the -order specified. - -When using 'executeJS', GHC might complain about an ambiguous type in -situations where the result of the executeJS call is ignored/discard. -Consider the following example: - -@ - jsExample = do - e <- findElem (ById "foo") - executeJS [] "someAction()" - return e -@ - -Because the result of the 'executeJS' is discarded, GHC cannot resolve -which instance of the 'fromJSON' class to use when parsing the -Selenium server response. In such cases, we can use the 'ignoreReturn' -helper function located in "Test.WebDriver.JSON". 'ignoreReturn' has -no runtime effect; it simply helps the type system by expicitly providing -a `fromJSON` instance to use. - -@ - import Test.WebDriver.JSON (ignoreReturn) - jsExample = do - e <- findElem (ById "foo") - ignoreReturn $ executeJS [] "someAction()" - return e -@ --} -executeJS :: (F.Foldable f, FromJSON a, WebDriver wd) => f JSArg -> Text -> wd a -executeJS a s = fromJSON' =<< getResult - where - getResult = doSessCommand methodPost "/execute" . pair ("args", "script") $ (F.toList a,s) - -{- |Executes a snippet of Javascript code asynchronously. This function works -similarly to 'executeJS', except that the Javascript is passed a callback -function as its final argument. The script should call this function -to signal that it has finished executing, passing to it a value that will be -returned as the result of asyncJS. A result of Nothing indicates that the -Javascript function timed out (see 'setScriptTimeout') --} -asyncJS :: (HasCallStack, F.Foldable f, FromJSON a, WebDriver wd) => f JSArg -> Text -> wd (Maybe a) -asyncJS a s = handle timeout $ Just <$> (fromJSON' =<< getResult) - where - getResult = doSessCommand methodPost "/execute_async" . pair ("args", "script") - $ (F.toList a,s) - timeout (FailedCommand Timeout _) = return Nothing - timeout (FailedCommand ScriptTimeout _) = return Nothing - timeout err = throwIO err - --- |Save a screenshot to a particular location -saveScreenshot :: (HasCallStack, WebDriver wd) => FilePath -> wd () -saveScreenshot path = screenshot >>= liftBase . LBS.writeFile path - --- |Grab a screenshot of the current page as a PNG image -screenshot :: (HasCallStack, WebDriver wd) => wd LBS.ByteString -screenshot = B64.decodeLenient <$> screenshotBase64 - --- |Grab a screenshot as a base-64 encoded PNG image. This is the protocol-defined format. -screenshotBase64 :: (HasCallStack, WebDriver wd) => wd LBS.ByteString -screenshotBase64 = TL.encodeUtf8 <$> doSessCommand methodGet "/screenshot" Null - -availableIMEEngines :: (HasCallStack, WebDriver wd) => wd [Text] -availableIMEEngines = doSessCommand methodGet "/ime/available_engines" Null - -activeIMEEngine :: (HasCallStack, WebDriver wd) => wd Text -activeIMEEngine = doSessCommand methodGet "/ime/active_engine" Null - -checkIMEActive :: (HasCallStack, WebDriver wd) => wd Bool -checkIMEActive = doSessCommand methodGet "/ime/activated" Null - -activateIME :: (HasCallStack, WebDriver wd) => Text -> wd () -activateIME = noReturn . doSessCommand methodPost "/ime/activate" . single "engine" - -deactivateIME :: (HasCallStack, WebDriver wd) => wd () -deactivateIME = noReturn $ doSessCommand methodPost "/ime/deactivate" Null - - --- |Specifies the frame used by 'Test.WebDriver.Commands.focusFrame' -data FrameSelector = WithIndex Integer - -- |focus on a frame by name or ID - | WithName Text - -- |focus on a frame 'Element' - | WithElement Element - -- |focus on the first frame, or the main document - -- if iframes are used. - | DefaultFrame - deriving (Eq, Show, Read) - -instance ToJSON FrameSelector where - toJSON s = case s of - WithIndex i -> toJSON i - WithName n -> toJSON n - WithElement e -> toJSON e - DefaultFrame -> Null - --- |Switch focus to the frame specified by the FrameSelector. -focusFrame :: (HasCallStack, WebDriver wd) => FrameSelector -> wd () -focusFrame s = noReturn $ doSessCommand methodPost "/frame" . single "id" $ s - --- |Returns a handle to the currently focused window -getCurrentWindow :: (HasCallStack, WebDriver wd) => wd WindowHandle -getCurrentWindow = doSessCommand methodGet "/window_handle" Null - --- |Returns a list of all windows available to the session -windows :: (HasCallStack, WebDriver wd) => wd [WindowHandle] -windows = doSessCommand methodGet "/window_handles" Null - -focusWindow :: (HasCallStack, WebDriver wd) => WindowHandle -> wd () -focusWindow w = noReturn $ doSessCommand methodPost "/window" . single "handle" $ w - --- |Closes the given window -closeWindow :: (HasCallStack, WebDriver wd) => WindowHandle -> wd () -closeWindow w = do - cw <- getCurrentWindow - focusWindow w - ignoreReturn $ doSessCommand methodDelete "/window" Null - unless (w == cw) $ focusWindow cw - --- |Maximizes the current window if not already maximized -maximize :: (HasCallStack, WebDriver wd) => wd () -maximize = ignoreReturn $ doWinCommand methodPost currentWindow "/maximize" Null - --- |Get the dimensions of the current window. -getWindowSize :: (HasCallStack, WebDriver wd) => wd (Word, Word) -getWindowSize = doWinCommand methodGet currentWindow "/size" Null - >>= parsePair "width" "height" "getWindowSize" - --- |Set the dimensions of the current window. -setWindowSize :: (HasCallStack, WebDriver wd) => (Word, Word) -> wd () -setWindowSize = ignoreReturn . doWinCommand methodPost currentWindow "/size" - . pair ("width", "height") - --- |Get the coordinates of the current window. -getWindowPos :: (HasCallStack, WebDriver wd) => wd (Int, Int) -getWindowPos = doWinCommand methodGet currentWindow "/position" Null - >>= parsePair "x" "y" "getWindowPos" - --- |Set the coordinates of the current window. -setWindowPos :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd () -setWindowPos = ignoreReturn . doWinCommand methodPost currentWindow "/position" . pair ("x","y") - --- |Retrieve all cookies visible to the current page. -cookies :: (HasCallStack, WebDriver wd) => wd [Cookie] -cookies = doSessCommand methodGet "/cookie" Null - --- |Set a cookie. If the cookie path is not specified, it will default to \"/\". --- Likewise, if the domain is omitted, it will default to the current page's --- domain -setCookie :: (HasCallStack, WebDriver wd) => Cookie -> wd () -setCookie = noReturn . doSessCommand methodPost "/cookie" . single "cookie" - --- |Delete a cookie. This will do nothing is the cookie isn't visible to the --- current page. -deleteCookie :: (HasCallStack, WebDriver wd) => Cookie -> wd () -deleteCookie c = noReturn $ doSessCommand methodDelete ("/cookie/" `append` urlEncode (cookName c)) Null - -deleteCookieByName :: (HasCallStack, WebDriver wd) => Text -> wd () -deleteCookieByName n = noReturn $ doSessCommand methodDelete ("/cookie/" `append` n) Null - --- |Delete all visible cookies on the current page. -deleteVisibleCookies :: (HasCallStack, WebDriver wd) => wd () -deleteVisibleCookies = noReturn $ doSessCommand methodDelete "/cookie" Null - --- |Get the current page source -getSource :: (HasCallStack, WebDriver wd) => wd Text -getSource = doSessCommand methodGet "/source" Null - --- |Get the title of the current page. -getTitle :: (HasCallStack, WebDriver wd) => wd Text -getTitle = doSessCommand methodGet "/title" Null - --- |Specifies element(s) within a DOM tree using various selection methods. -data Selector = ById Text - | ByName Text - | ByClass Text -- ^ (Note: multiple classes are not - -- allowed. For more control, use 'ByCSS') - | ByTag Text - | ByLinkText Text - | ByPartialLinkText Text - | ByCSS Text - | ByXPath Text - deriving (Eq, Show, Ord) - -instance ToJSON Selector where - toJSON s = case s of - ById t -> selector "id" t - ByName t -> selector "name" t - ByClass t -> selector "class name" t - ByTag t -> selector "tag name" t - ByLinkText t -> selector "link text" t - ByPartialLinkText t -> selector "partial link text" t - ByCSS t -> selector "css selector" t - ByXPath t -> selector "xpath" t - where - selector :: Text -> Text -> Value - selector sn t = object ["using" .= sn, "value" .= t] - --- |Find an element on the page using the given element selector. -findElem :: (HasCallStack, WebDriver wd) => Selector -> wd Element -findElem = doSessCommand methodPost "/element" - --- |Find all elements on the page matching the given selector. -findElems :: (HasCallStack, WebDriver wd) => Selector -> wd [Element] -findElems = doSessCommand methodPost "/elements" - --- |Return the element that currently has focus. -activeElem :: (HasCallStack, WebDriver wd) => wd Element -activeElem = doSessCommand methodPost "/element/active" Null - --- |Search for an element using the given element as root. -findElemFrom :: (HasCallStack, WebDriver wd) => Element -> Selector -> wd Element -findElemFrom e = doElemCommand methodPost e "/element" - --- |Find all elements matching a selector, using the given element as root. -findElemsFrom :: (HasCallStack, WebDriver wd) => Element -> Selector -> wd [Element] -findElemsFrom e = doElemCommand methodPost e "/elements" - --- |Describe the element. Returns a JSON object whose meaning is currently --- undefined by the WebDriver protocol. -elemInfo :: (HasCallStack, WebDriver wd) => Element -> wd Value -elemInfo e = doElemCommand methodGet e "" Null -{-# DEPRECATED elemInfo "This command does not work with Marionette (Firefox) driver, and is likely to be completely removed in Selenium 4" #-} - --- |Click on an element. -click :: (HasCallStack, WebDriver wd) => Element -> wd () -click e = noReturn $ doElemCommand methodPost e "/click" Null - --- |Submit a form element. This may be applied to descendents of a form element --- as well. -submit :: (HasCallStack, WebDriver wd) => Element -> wd () -submit e = noReturn $ doElemCommand methodPost e "/submit" Null - --- |Get all visible text within this element. -getText :: (HasCallStack, WebDriver wd) => Element -> wd Text -getText e = doElemCommand methodGet e "/text" Null - --- |Send a sequence of keystrokes to an element. All modifier keys are released --- at the end of the function. Named constants for special modifier keys can be found --- in "Test.WebDriver.Common.Keys" -sendKeys :: (HasCallStack, WebDriver wd) => Text -> Element -> wd () -sendKeys t e = noReturn . doElemCommand methodPost e "/value" . single "value" $ [t] - --- |Similar to sendKeys, but doesn't implicitly release modifier keys --- afterwards. This allows you to combine modifiers with mouse clicks. -sendRawKeys :: (HasCallStack, WebDriver wd) => Text -> wd () -sendRawKeys t = noReturn . doSessCommand methodPost "/keys" . single "value" $ [t] - --- |Return the tag name of the given element. -tagName :: (HasCallStack, WebDriver wd) => Element -> wd Text -tagName e = doElemCommand methodGet e "/name" Null - --- |Clear a textarea or text input element's value. -clearInput :: (HasCallStack, WebDriver wd) => Element -> wd () -clearInput e = noReturn $ doElemCommand methodPost e "/clear" Null - --- |Determine if the element is selected. -isSelected :: (HasCallStack, WebDriver wd) => Element -> wd Bool -isSelected e = doElemCommand methodGet e "/selected" Null - --- |Determine if the element is enabled. -isEnabled :: (HasCallStack, WebDriver wd) => Element -> wd Bool -isEnabled e = doElemCommand methodGet e "/enabled" Null - --- |Determine if the element is displayed. -isDisplayed :: (HasCallStack, WebDriver wd) => Element -> wd Bool -isDisplayed e = doElemCommand methodGet e "/displayed" Null - --- |Retrieve the value of an element's attribute -attr :: (HasCallStack, WebDriver wd) => Element -> Text -> wd (Maybe Text) -attr e t = doElemCommand methodGet e ("/attribute/" `append` urlEncode t) Null - --- |Retrieve the value of an element's computed CSS property -cssProp :: (HasCallStack, WebDriver wd) => Element -> Text -> wd (Maybe Text) -cssProp e t = doElemCommand methodGet e ("/css/" `append` urlEncode t) Null - --- |Retrieve an element's current position. -elemPos :: (HasCallStack, WebDriver wd) => Element -> wd (Float, Float) -elemPos e = doElemCommand methodGet e "/location" Null >>= parsePair "x" "y" "elemPos" - --- |Retrieve an element's current size. -elemSize :: (HasCallStack, WebDriver wd) => Element -> wd (Float, Float) -elemSize e = doElemCommand methodGet e "/size" Null - >>= parsePair "width" "height" "elemSize" - -infix 4 <==> --- |Determines if two element identifiers refer to the same element. -(<==>) :: (HasCallStack, WebDriver wd) => Element -> Element -> wd Bool -e1 <==> (Element e2) = doElemCommand methodGet e1 ("/equals/" `append` urlEncode e2) Null - --- |Determines if two element identifiers refer to different elements. -infix 4 -() :: (HasCallStack, WebDriver wd) => Element -> Element -> wd Bool -e1 e2 = not <$> (e1 <==> e2) - --- |A screen orientation -data Orientation = Landscape | Portrait - deriving (Eq, Show, Ord, Bounded, Enum) - -instance ToJSON Orientation where - toJSON = String . toUpper . fromString . show - -instance FromJSON Orientation where - parseJSON (String jStr) = case toLower jStr of - "landscape" -> return Landscape - "portrait" -> return Portrait - err -> fail $ "Invalid Orientation string " ++ show err - parseJSON v = typeMismatch "Orientation" v - --- |Get the current screen orientation for rotatable display devices. -getOrientation :: (HasCallStack, WebDriver wd) => wd Orientation -getOrientation = doSessCommand methodGet "/orientation" Null - --- |Set the current screen orientation for rotatable display devices. -setOrientation :: (HasCallStack, WebDriver wd) => Orientation -> wd () -setOrientation = noReturn . doSessCommand methodPost "/orientation" . single "orientation" - --- |Get the text of an alert dialog. -getAlertText :: (HasCallStack, WebDriver wd) => wd Text -getAlertText = doSessCommand methodGet "/alert_text" Null - --- |Sends keystrokes to Javascript prompt() dialog. -replyToAlert :: (HasCallStack, WebDriver wd) => Text -> wd () -replyToAlert = noReturn . doSessCommand methodPost "/alert_text" . single "text" - --- |Accepts the currently displayed alert dialog. -acceptAlert :: (HasCallStack, WebDriver wd) => wd () -acceptAlert = noReturn $ doSessCommand methodPost "/accept_alert" Null - --- |Dismisses the currently displayed alert dialog. -dismissAlert :: (HasCallStack, WebDriver wd) => wd () -dismissAlert = noReturn $ doSessCommand methodPost "/dismiss_alert" Null - --- |Moves the mouse to the given position relative to the active element. -moveTo :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd () -moveTo = noReturn . doSessCommand methodPost "/moveto" . pair ("xoffset","yoffset") - --- |Moves the mouse to the center of a given element. -moveToCenter :: (HasCallStack, WebDriver wd) => Element -> wd () -moveToCenter (Element e) = - noReturn . doSessCommand methodPost "/moveto" . single "element" $ e - --- |Moves the mouse to the given position relative to the given element. -moveToFrom :: (HasCallStack, WebDriver wd) => (Int, Int) -> Element -> wd () -moveToFrom (x,y) (Element e) = - noReturn . doSessCommand methodPost "/moveto" - . triple ("element","xoffset","yoffset") $ (e,x,y) - --- |A mouse button -data MouseButton = LeftButton | MiddleButton | RightButton - deriving (Eq, Show, Ord, Bounded, Enum) - -instance ToJSON MouseButton where - toJSON = toJSON . fromEnum - -instance FromJSON MouseButton where - parseJSON v = do - n <- parseJSON v - case n :: Integer of - 0 -> return LeftButton - 1 -> return MiddleButton - 2 -> return RightButton - err -> fail $ "Invalid JSON for MouseButton: " ++ show err - --- |Click at the current mouse position with the given mouse button. -clickWith :: (HasCallStack, WebDriver wd) => MouseButton -> wd () -clickWith = noReturn . doSessCommand methodPost "/click" . single "button" - --- |Perform the given action with the left mouse button held down. The mouse --- is automatically released afterwards. -withMouseDown :: (HasCallStack, WebDriver wd) => wd a -> wd a -withMouseDown wd = mouseDown >> wd <* mouseUp - --- |Press and hold the left mouse button down. Note that undefined behavior --- occurs if the next mouse command is not mouseUp. -mouseDown :: (HasCallStack, WebDriver wd) => wd () -mouseDown = noReturn $ doSessCommand methodPost "/buttondown" Null - --- |Release the left mouse button. -mouseUp :: (HasCallStack, WebDriver wd) => wd () -mouseUp = noReturn $ doSessCommand methodPost "/buttonup" Null - --- |Double click at the current mouse location. -doubleClick :: (HasCallStack, WebDriver wd) => wd () -doubleClick = noReturn $ doSessCommand methodPost "/doubleclick" Null - --- |Single tap on the touch screen at the given element's location. -touchClick :: (HasCallStack, WebDriver wd) => Element -> wd () -touchClick (Element e) = - noReturn . doSessCommand methodPost "/touch/click" . single "element" $ e - --- |Emulates pressing a finger down on the screen at the given location. -touchDown :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd () -touchDown = noReturn . doSessCommand methodPost "/touch/down" . pair ("x","y") - --- |Emulates removing a finger from the screen at the given location. -touchUp :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd () -touchUp = noReturn . doSessCommand methodPost "/touch/up" . pair ("x","y") - --- |Emulates moving a finger on the screen to the given location. -touchMove :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd () -touchMove = noReturn . doSessCommand methodPost "/touch/move" . pair ("x","y") - --- |Emulate finger-based touch scroll. Use this function if you don't care where --- the scroll begins -touchScroll :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd () -touchScroll = noReturn . doSessCommand methodPost "/touch/scroll" . pair ("xoffset","yoffset") - --- |Emulate finger-based touch scroll, starting from the given location relative --- to the given element. -touchScrollFrom :: (HasCallStack, WebDriver wd) => (Int, Int) -> Element -> wd () -touchScrollFrom (x, y) (Element e) = - noReturn - . doSessCommand methodPost "/touch/scroll" - . triple ("xoffset", "yoffset", "element") - $ (x, y, e) - --- |Emulate a double click on a touch device. -touchDoubleClick :: (HasCallStack, WebDriver wd) => Element -> wd () -touchDoubleClick (Element e) = - noReturn - . doSessCommand methodPost "/touch/doubleclick" - . single "element" $ e - --- |Emulate a long click on a touch device. -touchLongClick :: (HasCallStack, WebDriver wd) => Element -> wd () -touchLongClick (Element e) = - noReturn - . doSessCommand methodPost "/touch/longclick" - . single "element" $ e --- |Emulate a flick on the touch screen. The coordinates indicate x and y --- velocity, respectively. Use this function if you don't care where the --- flick starts. -touchFlick :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd () -touchFlick = - noReturn - . doSessCommand methodPost "/touch/flick" - . pair ("xSpeed", "ySpeed") - --- |Emulate a flick on the touch screen. -touchFlickFrom :: (HasCallStack, WebDriver wd) => - Int -- ^ flick velocity - -> (Int, Int) -- ^ a location relative to the given element - -> Element -- ^ the given element - -> wd () -touchFlickFrom s (x,y) (Element e) = - noReturn - . doSessCommand methodPost "/touch/flick" . object $ - ["xoffset" .= x - ,"yoffset" .= y - ,"speed" .= s - ,"element" .= e - ] - --- |Get the current geographical location of the device. -getLocation :: (HasCallStack, WebDriver wd) => wd (Int, Int, Int) -getLocation = doSessCommand methodGet "/location" Null - >>= parseTriple "latitude" "longitude" "altitude" "getLocation" - --- |Set the current geographical location of the device. -setLocation :: (HasCallStack, WebDriver wd) => (Int, Int, Int) -> wd () -setLocation = noReturn . doSessCommand methodPost "/location" - . triple ("latitude", - "longitude", - "altitude") - --- |Uploads a file from the local filesystem by its file path. -uploadFile :: (HasCallStack, WebDriver wd) => FilePath -> wd () -uploadFile path = uploadZipEntry =<< liftBase (readEntry [] path) - --- |Uploads a raw bytestring with associated file info. -uploadRawFile :: (HasCallStack, WebDriver wd) => - FilePath -- ^File path to use with this bytestring. - -> Integer -- ^Modification time - -- (in seconds since Unix epoch). - -> LBS.ByteString -- ^ The file contents as a lazy ByteString - -> wd () -uploadRawFile path t str = uploadZipEntry (toEntry path t str) - - --- |Lowest level interface to the file uploading mechanism. --- This allows you to specify the exact details of --- the zip entry sent across network. -uploadZipEntry :: (HasCallStack, WebDriver wd) => Entry -> wd () -uploadZipEntry = noReturn . doSessCommand methodPost "/file" . single "file" - . TL.decodeUtf8 . B64.encode . fromArchive . (`addEntryToArchive` emptyArchive) - - --- |Get the current number of keys in a web storage area. -storageSize :: (HasCallStack, WebDriver wd) => WebStorageType -> wd Integer -storageSize s = doStorageCommand methodGet s "/size" Null +module Test.WebDriver.Commands ( + -- * Sessions + -- | A session is equivalent to a single instantiation of a + -- particular user agent, including all its child browsers. WebDriver gives + -- each session a unique session ID that can be used to differentiate one + -- session from another, allowing multiple user agents to be controlled from a + -- single HTTP server, and allowing sessions to be routed via a multiplexer + -- (known as an intermediary node). + -- + -- See https://www.w3.org/TR/webdriver1/#sessions. + module Test.WebDriver.Commands.Sessions --- |Get a list of all keys from a web storage area. -getAllKeys :: (HasCallStack, WebDriver wd) => WebStorageType -> wd [Text] -getAllKeys s = doStorageCommand methodGet s "" Null + -- * Navigation + -- | The commands in this section allow navigation of the current top-level + -- browsing context to new URLs and introspection of the document currently + -- loaded in this browsing context. + -- + -- See https://www.w3.org/TR/webdriver1/#navigation. + , module Test.WebDriver.Commands.Navigation --- |Delete all keys within a given web storage area. -deleteAllKeys :: (HasCallStack, WebDriver wd) => WebStorageType -> wd () -deleteAllKeys s = noReturn $ doStorageCommand methodDelete s "" Null + -- * Command contexts + -- | Many WebDriver commands happen in the context of either the current + -- browsing context or current top-level browsing context. The current + -- top-level browsing context is represented in the protocol by its associated + -- window handle. When a top-level browsing context is selected using the + -- Switch To Window command, a specific browsing context can be selected using + -- the Switch to Frame command. + -- + -- See https://www.w3.org/TR/webdriver1/#command-contexts. + , module Test.WebDriver.Commands.CommandContexts --- |An HTML 5 storage type -data WebStorageType = LocalStorage | SessionStorage - deriving (Eq, Show, Ord, Bounded, Enum) + -- * Element Retrieval + -- | The Find Element, Find Elements, Find Element From Element, and Find + -- Elements From Element commands allow lookup of individual elements and + -- collections of elements. Element retrieval searches are performed using + -- pre-order traversal of the document’s nodes that match the provided + -- selector’s expression. Elements are serialized and returned as web + -- elements. + -- + -- See https://www.w3.org/TR/webdriver1/#element-retrieval. + , module Test.WebDriver.Commands.ElementRetrieval --- |Get the value associated with a key in the given web storage area. --- Unset keys result in empty strings, since the Web Storage spec --- makes no distinction between the empty string and an undefined value. -getKey :: (HasCallStack, WebDriver wd) => WebStorageType -> Text -> wd Text -getKey s k = doStorageCommand methodGet s ("/key/" `T.append` urlEncode k) Null + -- * Element State + -- + -- See https://www.w3.org/TR/webdriver1/#element-state. + , module Test.WebDriver.Commands.ElementState --- |Set a key in the given web storage area. -setKey :: (HasCallStack, WebDriver wd) => WebStorageType -> Text -> Text -> wd Text -setKey s k v = doStorageCommand methodPost s "" . object $ ["key" .= k, - "value" .= v ] --- |Delete a key in the given web storage area. -deleteKey :: (HasCallStack, WebDriver wd) => WebStorageType -> Text -> wd () -deleteKey s k = noReturn $ doStorageCommand methodPost s ("/key/" `T.append` urlEncode k) Null + -- * Element Interaction + -- + -- See https://www.w3.org/TR/webdriver1/#element-interaction. + , module Test.WebDriver.Commands.ElementInteraction --- |A wrapper around 'doSessCommand' to create web storage requests. -doStorageCommand :: (WebDriver wd, ToJSON a, FromJSON b) => - Method -> WebStorageType -> Text -> a -> wd b -doStorageCommand m s path a = doSessCommand m (T.concat ["/", s', path]) a - where s' = case s of - LocalStorage -> "local_storage" - SessionStorage -> "session_storage" + -- * Document handling + -- + -- See https://www.w3.org/TR/webdriver1/#document-handling. + , module Test.WebDriver.Commands.DocumentHandling + , ignoreReturn --- |Get information from the server as a JSON 'Object'. For more information --- about this object see --- -serverStatus :: (WebDriver wd) => wd Value -- todo: make this a record type -serverStatus = doCommand methodGet "/status" Null + -- * Cookies + -- + -- See https://www.w3.org/TR/webdriver1/#cookies. + , module Test.WebDriver.Commands.Cookies --- |A record that represents a single log entry. -data LogEntry = - LogEntry { logTime :: Integer -- ^ timestamp for the log entry. The standard - -- does not specify the epoch or the unit of - -- time. - , logLevel :: LogLevel -- ^ log verbosity level - , logMsg :: Text - } - deriving (Eq, Ord, Show, Read) + -- * Actions + -- + -- See https://www.w3.org/TR/webdriver1/#actions. + , module Test.WebDriver.Commands.Actions + -- * User Prompts + -- + -- See https://www.w3.org/TR/webdriver1/#user-prompts. + , module Test.WebDriver.Commands.UserPrompts -instance FromJSON LogEntry where - parseJSON (Object o) = - LogEntry <$> o .: "timestamp" - <*> o .: "level" - <*> (fromMaybe "" <$> o .: "message") - parseJSON v = typeMismatch "LogEntry" v + -- * Screen capture + -- + -- See https://www.w3.org/TR/webdriver1/#screen-capture. + , module Test.WebDriver.Commands.ScreenCapture -type LogType = String + -- * Browser logs + -- | Retrieve browser console logs and other log types. + , module Test.WebDriver.Commands.Logs --- |Retrieve the log buffer for a given log type. The server-side log buffer is reset after each request. --- --- Which log types are available is server defined, but the wire protocol lists these as common log types: --- client, driver, browser, server -getLogs :: (HasCallStack, WebDriver wd) => LogType -> wd [LogEntry] -getLogs t = doSessCommand methodPost "/log" . object $ ["type" .= t] + -- * BiDi sessions (experimental) + -- | Low-level BiDi session establishment. + , module Test.WebDriver.Commands.BiDi.Session --- |Get a list of available log types. -getLogTypes :: (HasCallStack, WebDriver wd) => wd [LogType] -getLogTypes = doSessCommand methodGet "/log/types" Null + -- * Network activity (experimental) + -- | Use BiDi to track network activity events. + , module Test.WebDriver.Commands.BiDi.NetworkActivity -data ApplicationCacheStatus = Uncached | Idle | Checking | Downloading | UpdateReady | Obsolete deriving (Eq, Enum, Bounded, Ord, Show, Read) + -- * Selenium-specific + -- ** Mobile device support + , module Test.WebDriver.Commands.SeleniumSpecific.Mobile + -- ** Uploading files to remote server + -- | These functions allow you to upload a file to a remote server. + -- Note that this operation isn't supported by all WebDriver servers, + -- and the location where the file is stored is not standardized. + , module Test.WebDriver.Commands.SeleniumSpecific.Uploads + -- ** HTML5 + , module Test.WebDriver.Commands.SeleniumSpecific.HTML5 + -- ** Misc + , module Test.WebDriver.Commands.SeleniumSpecific.Misc + ) where -instance FromJSON ApplicationCacheStatus where - parseJSON val = do - n <- parseJSON val - case n :: Integer of - 0 -> return Uncached - 1 -> return Idle - 2 -> return Checking - 3 -> return Downloading - 4 -> return UpdateReady - 5 -> return Obsolete - err -> fail $ "Invalid JSON for ApplicationCacheStatus: " ++ show err +import Test.WebDriver.Commands.Actions +import Test.WebDriver.Commands.BiDi.NetworkActivity +import Test.WebDriver.Commands.BiDi.Session +import Test.WebDriver.Commands.CommandContexts +import Test.WebDriver.Commands.Cookies +import Test.WebDriver.Commands.DocumentHandling +import Test.WebDriver.Commands.ElementInteraction +import Test.WebDriver.Commands.ElementRetrieval +import Test.WebDriver.Commands.ElementState +import Test.WebDriver.Commands.Logs +import Test.WebDriver.Commands.Navigation +import Test.WebDriver.Commands.ScreenCapture +import Test.WebDriver.Commands.SeleniumSpecific.HTML5 +import Test.WebDriver.Commands.SeleniumSpecific.Misc +import Test.WebDriver.Commands.SeleniumSpecific.Mobile +import Test.WebDriver.Commands.SeleniumSpecific.Uploads +import Test.WebDriver.Commands.Sessions +import Test.WebDriver.Commands.UserPrompts -getApplicationCacheStatus :: (WebDriver wd) => wd ApplicationCacheStatus -getApplicationCacheStatus = doSessCommand methodGet "/application_cache/status" Null +import Test.WebDriver.JSON (ignoreReturn) diff --git a/src/Test/WebDriver/Commands/Actions.hs b/src/Test/WebDriver/Commands/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/Actions.hs @@ -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 + ] diff --git a/src/Test/WebDriver/Commands/BiDi/NetworkActivity.hs b/src/Test/WebDriver/Commands/BiDi/NetworkActivity.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/BiDi/NetworkActivity.hs @@ -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 +-- . +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 "" 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 "" 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 "" 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') diff --git a/src/Test/WebDriver/Commands/BiDi/Session.hs b/src/Test/WebDriver/Commands/BiDi/Session.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/BiDi/Session.hs @@ -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 +-- . +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}|] diff --git a/src/Test/WebDriver/Commands/CommandContexts.hs b/src/Test/WebDriver/Commands/CommandContexts.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/CommandContexts.hs @@ -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 + ] diff --git a/src/Test/WebDriver/Commands/Cookies.hs b/src/Test/WebDriver/Commands/Cookies.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/Cookies.hs @@ -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 diff --git a/src/Test/WebDriver/Commands/DocumentHandling.hs b/src/Test/WebDriver/Commands/DocumentHandling.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/DocumentHandling.hs @@ -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 diff --git a/src/Test/WebDriver/Commands/ElementInteraction.hs b/src/Test/WebDriver/Commands/ElementInteraction.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/ElementInteraction.hs @@ -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 diff --git a/src/Test/WebDriver/Commands/ElementRetrieval.hs b/src/Test/WebDriver/Commands/ElementRetrieval.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/ElementRetrieval.hs @@ -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] diff --git a/src/Test/WebDriver/Commands/ElementState.hs b/src/Test/WebDriver/Commands/ElementState.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/ElementState.hs @@ -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 diff --git a/src/Test/WebDriver/Commands/Internal.hs b/src/Test/WebDriver/Commands/Internal.hs deleted file mode 100644 --- a/src/Test/WebDriver/Commands/Internal.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -{-# OPTIONS_HADDOCK not-home #-} --- | Internal functions used to implement the functions exported by --- "Test.WebDriver.Commands". These may be useful for implementing non-standard --- webdriver commands. -module Test.WebDriver.Commands.Internal - (-- * Low-level webdriver functions - doCommand - -- ** Commands with :sessionId URL parameter - , doSessCommand, SessionId(..) - -- ** Commands with element :id URL parameters - , doElemCommand, Element(..) - -- ** Commands with :windowHandle URL parameters - , doWinCommand, WindowHandle(..), currentWindow - -- * Exceptions - , NoSessionId(..) - ) where - -import Test.WebDriver.Class -import Test.WebDriver.JSON -import Test.WebDriver.Session -import Test.WebDriver.Utils (urlEncode) - -import Control.Applicative -import Control.Exception.Lifted -import Data.Aeson -import Data.Aeson.Types -import Data.CallStack -import Data.Default (Default, def) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Typeable - -import Prelude -- hides some "unused import" warnings - -{- |An opaque identifier for a web page element. -} -newtype Element = Element Text - deriving (Eq, Ord, Show, Read) - -instance FromJSON Element where - parseJSON (Object o) = Element <$> (o .: "ELEMENT" <|> o .: "element-6066-11e4-a52e-4f735466cecf") - parseJSON v = typeMismatch "Element" v - -instance ToJSON Element where - toJSON (Element e) = object ["ELEMENT" .= e] - - -{- |An opaque identifier for a browser window -} -newtype WindowHandle = WindowHandle Text - deriving (Eq, Ord, Show, Read, - FromJSON, ToJSON) -instance Default WindowHandle where - def = currentWindow - --- |A special 'WindowHandle' that always refers to the currently focused window. --- This is also used by the 'Default' instance. -currentWindow :: WindowHandle -currentWindow = WindowHandle "current" - -instance Exception NoSessionId --- |A command requiring a session ID was attempted when no session ID was --- available. -newtype NoSessionId = NoSessionId String - deriving (Eq, Show, Typeable) - --- |This a convenient wrapper around 'doCommand' that automatically prepends --- the session URL parameter to the wire command URL. For example, passing --- a URL of \"/refresh\" will expand to \"/session/:sessionId/refresh\", where --- :sessionId is a URL parameter as described in --- -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 diff --git a/src/Test/WebDriver/Commands/Logs.hs b/src/Test/WebDriver/Commands/Logs.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/Logs.hs @@ -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 diff --git a/src/Test/WebDriver/Commands/Logs/BiDi.hs b/src/Test/WebDriver/Commands/Logs/BiDi.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/Logs/BiDi.hs @@ -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 +-- . +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 diff --git a/src/Test/WebDriver/Commands/Logs/Chrome.hs b/src/Test/WebDriver/Commands/Logs/Chrome.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/Logs/Chrome.hs @@ -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 [] diff --git a/src/Test/WebDriver/Commands/Logs/Common.hs b/src/Test/WebDriver/Commands/Logs/Common.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/Logs/Common.hs @@ -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 diff --git a/src/Test/WebDriver/Commands/Logs/Firefox.hs b/src/Test/WebDriver/Commands/Logs/Firefox.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/Logs/Firefox.hs @@ -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 [] diff --git a/src/Test/WebDriver/Commands/Logs/Selenium.hs b/src/Test/WebDriver/Commands/Logs/Selenium.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/Logs/Selenium.hs @@ -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 diff --git a/src/Test/WebDriver/Commands/Navigation.hs b/src/Test/WebDriver/Commands/Navigation.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/Navigation.hs @@ -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 diff --git a/src/Test/WebDriver/Commands/ScreenCapture.hs b/src/Test/WebDriver/Commands/ScreenCapture.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/ScreenCapture.hs @@ -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 diff --git a/src/Test/WebDriver/Commands/SeleniumSpecific/HTML5.hs b/src/Test/WebDriver/Commands/SeleniumSpecific/HTML5.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/SeleniumSpecific/HTML5.hs @@ -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 diff --git a/src/Test/WebDriver/Commands/SeleniumSpecific/Misc.hs b/src/Test/WebDriver/Commands/SeleniumSpecific/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/SeleniumSpecific/Misc.hs @@ -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) diff --git a/src/Test/WebDriver/Commands/SeleniumSpecific/Mobile.hs b/src/Test/WebDriver/Commands/SeleniumSpecific/Mobile.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/SeleniumSpecific/Mobile.hs @@ -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") diff --git a/src/Test/WebDriver/Commands/SeleniumSpecific/Uploads.hs b/src/Test/WebDriver/Commands/SeleniumSpecific/Uploads.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/SeleniumSpecific/Uploads.hs @@ -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 diff --git a/src/Test/WebDriver/Commands/Sessions.hs b/src/Test/WebDriver/Commands/Sessions.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/Sessions.hs @@ -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 +-- +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)]) diff --git a/src/Test/WebDriver/Commands/UserPrompts.hs b/src/Test/WebDriver/Commands/UserPrompts.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Commands/UserPrompts.hs @@ -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" diff --git a/src/Test/WebDriver/Commands/Wait.hs b/src/Test/WebDriver/Commands/Wait.hs deleted file mode 100644 --- a/src/Test/WebDriver/Commands/Wait.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ConstraintKinds #-} - -module Test.WebDriver.Commands.Wait - ( -- * Wait on expected conditions - waitUntil, waitUntil' - , waitWhile, waitWhile' - -- * Expected conditions - , ExpectFailed (..), expect, unexpected - , expectAny, expectAll - , expectNotStale, expectAlertOpen - , catchFailedCommand - -- ** Convenience functions - , onTimeout - ) where -import Test.WebDriver.Commands -import Test.WebDriver.Class -import Test.WebDriver.Exceptions -import Test.WebDriver.Session - -import Control.Concurrent -import Control.Exception.Lifted -import Control.Monad.Base -import Control.Monad.Trans.Control - -import Data.CallStack -import qualified Data.Foldable as F -import Data.Text (Text) -import Data.Time.Clock -import Data.Typeable - -#if !MIN_VERSION_base(4,6,0) || defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706 -import Prelude hiding (catch) -#endif - -instance Exception ExpectFailed --- |An exception representing the failure of an expected condition. -data ExpectFailed = ExpectFailed String deriving (Show, Eq, Typeable) - --- |throws 'ExpectFailed'. This is nice for writing your own abstractions. -unexpected :: (MonadBaseControl IO m, HasCallStack) => - String -- ^ Reason why the expected condition failed. - -> m a -unexpected = throwIO . ExpectFailed - --- |An expected condition. This function allows you to express assertions in --- your explicit wait. This function raises 'ExpectFailed' if the given --- boolean is False, and otherwise does nothing. -expect :: (MonadBaseControl IO m, HasCallStack) => Bool -> m () -expect b - | b = return () - | otherwise = unexpected "Test.WebDriver.Commands.Wait.expect" - --- |Apply a monadic predicate to every element in a list, and 'expect' that --- at least one succeeds. -expectAny :: (F.Foldable f, MonadBaseControl IO m, HasCallStack) => (a -> m Bool) -> f a -> m () -expectAny p xs = expect . F.or =<< mapM p (F.toList xs) - --- |Apply a monadic predicate to every element in a list, and 'expect' that all --- succeed. -expectAll :: (F.Foldable f, MonadBaseControl IO m, HasCallStack) => (a -> m Bool) -> f a -> m () -expectAll p xs = expect . F.and =<< mapM p (F.toList xs) - --- | 'expect' the given 'Element' to not be stale and returns it -expectNotStale :: (WebDriver wd, HasCallStack) => Element -> wd Element -expectNotStale e = catchFailedCommand StaleElementReference $ do - _ <- isEnabled e -- Any command will force a staleness check - return e - --- | 'expect' an alert to be present on the page, and returns its text. -expectAlertOpen :: (WebDriver wd, HasCallStack) => wd Text -expectAlertOpen = catchFailedCommand NoAlertOpen getAlertText - --- |Catches any `FailedCommand` exceptions with the given `FailedCommandType` and rethrows as 'ExpectFailed' -catchFailedCommand :: (MonadBaseControl IO m, HasCallStack) => FailedCommandType -> m a -> m a -catchFailedCommand t1 m = m `catch` handler - where - handler e@(FailedCommand t2 _) - | t1 == t2 = unexpected . show $ e - handler e = throwIO e - --- |Wait until either the given action succeeds or the timeout is reached. --- The action will be retried every .5 seconds until no 'ExpectFailed' or --- 'FailedCommand' 'NoSuchElement' exceptions occur. If the timeout is reached, --- then a 'Timeout' exception will be raised. The timeout value --- is expressed in seconds. -waitUntil :: (WDSessionStateControl m, HasCallStack) => Double -> m a -> m a -waitUntil = waitUntil' 500000 - --- |Similar to 'waitUntil' but allows you to also specify the poll frequency --- of the 'WD' action. The frequency is expressed as an integer in microseconds. -waitUntil' :: (WDSessionStateControl m, HasCallStack) => Int -> Double -> m a -> m a -waitUntil' = waitEither id (\_ -> return) - --- |Like 'waitUntil', but retries the action until it fails or until the timeout --- is exceeded. -waitWhile :: (WDSessionStateControl m, HasCallStack) => Double -> m a -> m () -waitWhile = waitWhile' 500000 - --- |Like 'waitUntil'', but retries the action until it either fails or --- until the timeout is exceeded. -waitWhile' :: (WDSessionStateControl m, HasCallStack) => Int -> Double -> m a -> m () -waitWhile' = - waitEither (\_ _ -> return ()) - (\retry _ -> retry "waitWhile: action did not fail") - - --- |Internal function used to implement explicit wait commands using success and failure continuations -waitEither :: (WDSessionStateControl m, HasCallStack) => - ((String -> m b) -> String -> m b) - -> ((String -> m b) -> a -> m b) - -> Int -> Double -> m a -> m b -waitEither failure success = wait' handler - where - handler retry wd = do - e <- fmap Right wd `catches` [Handler handleFailedCommand - ,Handler handleExpectFailed - ] - either (failure retry) (success retry) e - where - handleFailedCommand e@(FailedCommand NoSuchElement _) = return . Left . show $ e - handleFailedCommand err = throwIO err - - handleExpectFailed (e :: ExpectFailed) = return . Left . show $ e - -wait' :: (WDSessionStateIO m, HasCallStack) => - ((String -> m b) -> m a -> m b) -> Int -> Double -> m a -> m b -wait' handler waitAmnt t wd = waitLoop =<< liftBase getCurrentTime - where - timeout = realToFrac t - waitLoop startTime = handler retry wd - where - retry why = do - now <- liftBase getCurrentTime - if diffUTCTime now startTime >= timeout - then - failedCommand Timeout $ "wait': explicit wait timed out (" ++ why ++ ")." - else do - liftBase . threadDelay $ waitAmnt - waitLoop startTime - --- |Convenience function to catch 'FailedCommand' 'Timeout' exceptions --- and perform some action. --- --- Example: --- --- > waitUntil 5 (getText <=< findElem $ ByCSS ".class") --- > `onTimeout` return "" -onTimeout :: (MonadBaseControl IO m, HasCallStack) => m a -> m a -> m a -onTimeout m r = m `catch` handler - where - handler (FailedCommand Timeout _) = r - handler other = throwIO other diff --git a/src/Test/WebDriver/Common/Keys.hs b/src/Test/WebDriver/Common/Keys.hs deleted file mode 100644 --- a/src/Test/WebDriver/Common/Keys.hs +++ /dev/null @@ -1,199 +0,0 @@ - --- | This module contains named constants corresponding to the special characters recognized by 'sendKeys'. --- For more details on these special characters, consult the Selenium documentation at --- -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" diff --git a/src/Test/WebDriver/Common/Profile.hs b/src/Test/WebDriver/Common/Profile.hs deleted file mode 100644 --- a/src/Test/WebDriver/Common/Profile.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS_HADDOCK not-home #-} - --- | A type for profile preferences. These preference values are used by both --- Firefox and Opera profiles. -module Test.WebDriver.Common.Profile - ( -- *Profiles and profile preferences - Profile(..), PreparedProfile(..), ProfilePref(..), ToPref(..) - -- * Preferences - , getPref, addPref, deletePref - -- * Extensions - , addExtension, deleteExtension, hasExtension - -- * Other files and directories - , addFile, deleteFile, hasFile - -- * Miscellaneous profile operations - , unionProfiles, onProfileFiles, onProfilePrefs - -- *Preparing profiles from disk - , prepareLoadedProfile_ - -- *Preparing zipped profiles - , prepareZippedProfile, prepareZipArchive, - prepareRawZip - -- *Profile errors - , ProfileParseError(..) - ) where - -import Codec.Archive.Zip -import Data.Aeson -import Data.Aeson.Types -import System.Directory -import System.FilePath hiding (addExtension, hasExtension) - -#if MIN_VERSION_aeson(0,7,0) -import Data.Scientific -#else -import Data.Attoparsec.Number (Number(..)) -#endif - -import qualified Data.HashMap.Strict as HM -import Data.Text (Text, pack) -import Data.ByteString.Lazy (ByteString) ---import qualified Data.ByteString as SBS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Base64.Lazy as B64 -import qualified Data.Text.Lazy.Encoding as TL - - -import Data.Fixed -import Data.Ratio -import Data.Int -import Data.Word -import Data.Typeable - -import Control.Exception -import Control.Applicative -import Control.Monad.Base - -import Prelude -- hides some "unused import" warnings - --- |This structure allows you to construct and manipulate profiles in pure code, --- deferring execution of IO operations until the profile is \"prepared\". This --- type is shared by both Firefox and Opera profiles; when a distinction --- must be made, the phantom type parameter is used to differentiate. -data Profile b = Profile - { -- |A mapping from relative destination filepaths to source - -- filepaths found on the filesystem. When the profile is - -- prepared, these source filepaths will be moved to their - -- destinations within the profile directory. - -- - -- Using the destination path as the key ensures that - -- there is one unique source path going to each - -- destination path. - profileFiles :: HM.HashMap FilePath FilePath - -- |A map of profile preferences. These are the settings - -- found in the profile's prefs.js, and entries found in - -- about:config - , profilePrefs :: HM.HashMap Text ProfilePref - } - deriving (Eq, Show) - --- |Represents a profile that has been prepared for --- network transmission. The profile cannot be modified in this form. -newtype PreparedProfile b = PreparedProfile ByteString - deriving (Eq, Show) - -instance FromJSON (PreparedProfile s) where - parseJSON v = PreparedProfile . TL.encodeUtf8 <$> parseJSON v - -instance ToJSON (PreparedProfile s) where - toJSON (PreparedProfile s) = toJSON $ TL.decodeUtf8 s - --- |A profile preference value. This is the subset of JSON values that excludes --- arrays, objects, and null. -data ProfilePref = PrefInteger !Integer - | PrefDouble !Double - | PrefString !Text - | PrefBool !Bool - deriving (Eq, Show) - -instance ToJSON ProfilePref where - toJSON v = case v of - PrefInteger i -> toJSON i - PrefDouble d -> toJSON d - PrefString s -> toJSON s - PrefBool b -> toJSON b - -instance FromJSON ProfilePref where - parseJSON (String s) = return $ PrefString s - parseJSON (Bool b) = return $ PrefBool b -#if MIN_VERSION_aeson(0,7,0) - parseJSON (Number s) | base10Exponent s >= 0 = return $ PrefInteger (coefficient s * 10^(base10Exponent s)) - | otherwise = return $ PrefDouble $ realToFrac s -#else - parseJSON (Number (I i)) = return $ PrefInteger i - parseJSON (Number (D d)) = return $ PrefDouble d -#endif - parseJSON other = typeMismatch "ProfilePref" other - -instance Exception ProfileParseError --- |An error occured while attempting to parse a profile's preference file. -newtype ProfileParseError = ProfileParseError String - deriving (Eq, Show, Read, Typeable) - --- |A typeclass to convert types to profile preference values -class ToPref a where - toPref :: a -> ProfilePref - -instance ToPref Text where - toPref = PrefString - -instance ToPref String where - toPref = toPref . pack - -instance ToPref Bool where - toPref = PrefBool - -instance ToPref Integer where - toPref = PrefInteger - -#define I(t) instance ToPref t where toPref = PrefInteger . toInteger - -I(Int) -I(Int8) -I(Int16) -I(Int32) -I(Int64) -I(Word) -I(Word8) -I(Word16) -I(Word32) -I(Word64) - -instance ToPref Double where - toPref = PrefDouble - -instance ToPref Float where - toPref = PrefDouble . realToFrac - -instance (Integral a) => ToPref (Ratio a) where - toPref = PrefDouble . realToFrac - -instance (HasResolution r) => ToPref (Fixed r) where - toPref = PrefDouble . realToFrac - -instance ToPref ProfilePref where - toPref = id - --- |Retrieve a preference from a profile by key name. -getPref :: Text -> Profile b -> Maybe ProfilePref -getPref k (Profile _ m) = HM.lookup k m - --- |Add a new preference entry to a profile, overwriting any existing entry --- with the same key. -addPref :: ToPref a => Text -> a -> Profile b -> Profile b -addPref k v p = onProfilePrefs p $ HM.insert k (toPref v) - --- |Delete an existing preference entry from a profile. This operation is --- silent if the preference wasn't found. -deletePref :: Text -> Profile b -> Profile b -deletePref k p = onProfilePrefs p $ HM.delete k - --- |Add a file to the profile directory. The first argument is the source --- of the file on the local filesystem. The second argument is the destination --- as a path relative to a profile directory. Overwrites any file that --- previously pointed to the same destination -addFile :: FilePath -> FilePath -> Profile b -> Profile b -addFile src dest p = onProfileFiles p $ HM.insert dest src - --- |Delete a file from the profile directory. The first argument is the name of --- file within the profile directory. -deleteFile :: FilePath -> Profile b -> Profile b -deleteFile path prof = onProfileFiles prof $ HM.delete path - --- |Determines if a profile contains the given file, specified as a path --- relative to the profile directory. -hasFile :: String -> Profile b -> Bool -hasFile path (Profile files _) = path `HM.member` files - --- |Add a new extension to the profile. The file path should refer to --- a .xpi file or an extension directory on the filesystem. -addExtension :: FilePath -> Profile b -> Profile b -addExtension path = addFile path ("extensions" name) - where (_, name) = splitFileName path - --- |Delete an existing extension from the profile. The string parameter --- should refer to an .xpi file or directory located within the extensions --- directory of the profile. This operation has no effect if the extension was --- never added to the profile. -deleteExtension :: String -> Profile b -> Profile b -deleteExtension name = deleteFile ("extensions" name) - --- |Determines if a profile contains the given extension. specified as an --- .xpi file or directory name -hasExtension :: String -> Profile b -> Bool -hasExtension name prof = hasFile ("extensions" name) prof - - --- |Takes the union of two profiles. This is the union of their 'HashMap' --- fields. -unionProfiles :: Profile b -> Profile b -> Profile b -unionProfiles (Profile f1 p1) (Profile f2 p2) - = Profile (f1 `HM.union` f2) (p1 `HM.union` p2) - --- |Modifies the 'profilePrefs' field of a profile. -onProfilePrefs :: Profile b - -> (HM.HashMap Text ProfilePref - -> HM.HashMap Text ProfilePref) - -> Profile b -onProfilePrefs (Profile hs hm) f = Profile hs (f hm) - --- |Modifies the 'profileFiles' field of a profile -onProfileFiles :: Profile b - -> (HM.HashMap FilePath FilePath - -> HM.HashMap FilePath FilePath) - -> Profile b -onProfileFiles (Profile ls hm) f = Profile (f ls) hm - - --- |Efficiently load an existing profile from disk and prepare it for network --- transmission. -prepareLoadedProfile_ :: MonadBase IO m => - FilePath -> m (PreparedProfile a) -prepareLoadedProfile_ path = liftBase $ do - oldWd <- getCurrentDirectory - setCurrentDirectory path - prepareZipArchive <$> - liftBase (addFilesToArchive [OptRecursive] - emptyArchive ["."]) - <* setCurrentDirectory oldWd - --- |Prepare a zip file of a profile on disk for network transmission. --- This function is very efficient at loading large profiles from disk. -prepareZippedProfile :: MonadBase IO m => - FilePath -> m (PreparedProfile a) -prepareZippedProfile path = prepareRawZip <$> liftBase (LBS.readFile path) - --- |Prepare a zip archive of a profile for network transmission. -prepareZipArchive :: Archive -> PreparedProfile a -prepareZipArchive = prepareRawZip . fromArchive - --- |Prepare a ByteString of raw zip data for network transmission -prepareRawZip :: ByteString -> PreparedProfile a -prepareRawZip = PreparedProfile . B64.encode diff --git a/src/Test/WebDriver/Config.hs b/src/Test/WebDriver/Config.hs deleted file mode 100644 --- a/src/Test/WebDriver/Config.hs +++ /dev/null @@ -1,96 +0,0 @@ - -module Test.WebDriver.Config( - -- * WebDriver configuration - WDConfig(..), defaultConfig - -- * Capabilities helpers - , modifyCaps, useBrowser, useVersion, usePlatform, useProxy - -- * SessionHistoryConfig options - , SessionHistoryConfig, noHistory, unlimitedHistory, onlyMostRecentHistory - -- * Overloadable configuration - , WebDriverConfig(..) - ) where -import Test.WebDriver.Capabilities -import Test.WebDriver.Session - -import Data.Default (Default, def) -import Data.String (fromString) - -import Control.Monad.Base - -import Network.HTTP.Client (Manager, newManager, defaultManagerSettings) -import Network.HTTP.Types (RequestHeaders) - --- |WebDriver session configuration -data WDConfig = WDConfig { - -- |Host name of the WebDriver server for this - -- session (default 127.0.0.1) - wdHost :: String - -- |Port number of the server (default 4444) - , wdPort :: Int - -- |Capabilities to use for this session - , wdCapabilities :: Capabilities - -- |Base path for all API requests (default "\/wd\/hub") - , wdBasePath :: String - -- |Custom request headers to add to every HTTP request. - , wdRequestHeaders :: RequestHeaders - -- |Custom request headers to add *only* to session creation requests. This is usually done - -- when a WebDriver server requires HTTP auth. - , wdAuthHeaders :: RequestHeaders - -- |Specifies behavior of HTTP request/response history. By default we use 'unlimitedHistory'. - , wdHistoryConfig :: SessionHistoryConfig - -- |Use the given http-client 'Manager' instead of automatically creating one. - , wdHTTPManager :: Maybe Manager - -- |Number of times to retry a HTTP request if it times out (default 0) - , wdHTTPRetryCount :: Int -} - -instance GetCapabilities WDConfig where - getCaps = wdCapabilities - -instance SetCapabilities WDConfig where - setCaps caps conf = conf { wdCapabilities = caps } - -instance Default WDConfig where - def = WDConfig { - wdHost = "127.0.0.1" - , wdPort = 4444 - , wdRequestHeaders = [] - , wdAuthHeaders = [] - , wdCapabilities = def - , wdHistoryConfig = unlimitedHistory - , wdBasePath = "/wd/hub" - , wdHTTPManager = Nothing - , wdHTTPRetryCount = 0 - } - -{- |A default session config connects to localhost on port 4444, and hasn't been -initialized server-side. This value is the same as 'def' but with a less -polymorphic type. -} -defaultConfig :: WDConfig -defaultConfig = def - --- |Class of types that can configure a WebDriver session. -class WebDriverConfig c where - -- |Produces a 'Capabilities' from the given configuration. - mkCaps :: MonadBase IO m => c -> m Capabilities - - -- |Produces a 'WDSession' from the given configuration. - mkSession :: MonadBase IO m => c -> m WDSession - -instance WebDriverConfig WDConfig where - mkCaps = return . getCaps - - mkSession WDConfig{..} = do - manager <- maybe createManager return wdHTTPManager - return WDSession { wdSessHost = fromString $ wdHost - , wdSessPort = wdPort - , wdSessRequestHeaders = wdRequestHeaders - , wdSessAuthHeaders = wdAuthHeaders - , wdSessBasePath = fromString $ wdBasePath - , wdSessId = Nothing - , wdSessHist = [] - , wdSessHistUpdate = wdHistoryConfig - , wdSessHTTPManager = manager - , wdSessHTTPRetryCount = wdHTTPRetryCount } - where - createManager = liftBase $ newManager defaultManagerSettings diff --git a/src/Test/WebDriver/Cookies.hs b/src/Test/WebDriver/Cookies.hs deleted file mode 100644 --- a/src/Test/WebDriver/Cookies.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Test.WebDriver.Cookies where - -import Data.Aeson -import Data.Aeson.Types -import qualified Data.Char as C -import Data.Text (Text) -import GHC.Generics -import Test.WebDriver.JSON - --- | Cookies are delicious delicacies. When sending cookies to the server, a value --- of Nothing indicates that the server should use a default value. When receiving --- cookies from the server, a value of Nothing indicates that the server is unable --- to specify the value. -data Cookie = Cookie { - cookName :: Text - , cookValue :: Text -- ^ - , cookPath :: Maybe Text -- ^path of this cookie. - -- if Nothing, defaults to / - , cookDomain :: Maybe Text -- ^domain of this cookie. - -- if Nothing, the current pages - -- domain is used - , cookSecure :: Maybe Bool -- ^Is this cookie secure? - , cookExpiry :: Maybe Double -- ^Expiry date expressed as - -- seconds since the Unix epoch - -- Nothing indicates that the - -- cookie never expires - } deriving (Eq, Show, Generic) - -aesonOptionsCookie :: Options -aesonOptionsCookie = defaultOptions { - omitNothingFields = True - , fieldLabelModifier = map C.toLower . drop 4 - } - --- |Creates a Cookie with only a name and value specified. All other --- fields are set to Nothing, which tells the server to use default values. -mkCookie :: Text -> Text -> Cookie -mkCookie name value = Cookie { cookName = name, cookValue = value, - cookPath = Nothing, cookDomain = Nothing, - cookSecure = Nothing, cookExpiry = Nothing - } - -instance ToJSON Cookie where - toJSON = genericToJSON aesonOptionsCookie - toEncoding = genericToEncoding aesonOptionsCookie -instance FromJSON Cookie where - parseJSON (Object o) = Cookie <$> req "name" - <*> req "value" - <*> opt "path" Nothing - <*> opt "domain" Nothing - <*> opt "secure" Nothing - <*> opt "expiry" Nothing - where - req :: FromJSON a => Text -> Parser a - req = (o .:) . fromText - opt :: FromJSON a => Text -> a -> Parser a - opt k d = o .:?? k .!= d - parseJSON v = typeMismatch "Cookie" v diff --git a/src/Test/WebDriver/Exceptions.hs b/src/Test/WebDriver/Exceptions.hs --- a/src/Test/WebDriver/Exceptions.hs +++ b/src/Test/WebDriver/Exceptions.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-deriving-typeable #-} module Test.WebDriver.Exceptions ( InvalidURL(..) @@ -5,21 +7,113 @@ , BadJSON(..) , HTTPStatusUnknown(..) - , HTTPConnError(..) - , UnknownCommand(..) , ServerError(..) , FailedCommand(..) - , FailedCommandType(..) + , FailedCommandError(..) - , FailedCommandInfo(..) , StackFrame(..) - - , mkFailedCommandInfo - , failedCommand ) where -import Test.WebDriver.Commands.Internal -import Test.WebDriver.Exceptions.Internal +import Control.Exception (Exception) +import Data.Aeson +import Data.Aeson.TH +import Data.Text (Text) +import Data.Typeable (Typeable) +import GHC.Stack +import Prelude -- hides some "unused import" warnings +import Test.WebDriver.Capabilities.Aeson import Test.WebDriver.JSON +import Test.WebDriver.Types + + +-- | An invalid URL was given +newtype InvalidURL = InvalidURL String + deriving (Eq, Show, Typeable) +instance Exception InvalidURL + +-- | An unexpected HTTP status was sent by the server. +data HTTPStatusUnknown = HTTPStatusUnknown Int String + deriving (Eq, Show, Typeable) +instance Exception HTTPStatusUnknown + +-- | An unidentified server-side exception occured +newtype ServerError = ServerError String + deriving (Eq, Show, Typeable) +instance Exception ServerError + +data FailedCommandError = + -- | The Element Click command could not be completed because the element receiving the events is obscuring the element that was requested clicked. + ElementClickIntercepted + -- | A command could not be completed because the element is not pointer- or keyboard interactable. + | ElementNotInteractable + -- | Navigation caused the user agent to hit a certificate warning, which is usually the result of an expired or invalid TLS certificate. + | InsecureCertificate + -- | The arguments passed to a command are either invalid or malformed. + | InvalidArgument + -- | An illegal attempt was made to set a cookie under a different domain than the current page. + | InvalidCookieDomain + -- | A command could not be completed because the element is in an invalid state, e.g. attempting to clear an element that isn't both editable and resettable. + | InvalidElementState + -- | Argument was an invalid selector. + | InvalidSelector + -- | Occurs if the given session id is not in the list of active sessions, meaning the session either does not exist or that it’s not active. + | InvalidSessionId + -- | An error occurred while executing JavaScript supplied by the user. + | JavascriptError + -- | The target for mouse interaction is not in the browser’s viewport and cannot be brought into that viewport. + | MoveTargetOutOfBounds + -- | An attempt was made to operate on a modal dialog when one was not open. + | NoSuchAlert + -- | No cookie matching the given path name was found amongst the associated cookies of the current browsing context’s active document. + | NoSuchCookie + -- | An element could not be located on the page using the given search parameters. + | NoSuchElement + -- | A command to switch to a frame could not be satisfied because the frame could not be found. + | NoSuchFrame + -- | A command to switch to a window could not be satisfied because the window could not be found. + | NoSuchWindow + -- | A script did not complete before its timeout expired. + | ScriptTimeout + -- | A new session could not be created. + | SessionNotCreated + -- | A command failed because the referenced element is no longer attached to the DOM. + | StaleElementReference + -- | An operation did not complete before its timeout expired. + | Timeout + -- | A command to set a cookie’s value could not be satisfied. + | UnableToSetCookie + -- | A screen capture was made impossible. + | UnableToCaptureScreen + -- | A modal dialog was open, blocking this operation. + | UnexpectedAlertOpen + -- | A command could not be executed because the remote end is not aware of it. + | UnknownCommand + -- | An unknown error occurred in the remote end while processing the command. + | UnknownError + -- | The requested command matched a known URL but did not match an method for that URL. + | UnknownMethod + -- | Indicates that a command that should have executed properly cannot be supported for some reason. + | UnsupportedOperation + -- | Some error string we weren't able to parse. + | UnparsedError Text + deriving (Show, Eq) +deriveFromJSON toSpacedC0 ''FailedCommandError +deriveToJSON toSpacedC0 ''FailedCommandError + +-- | Internal type representing the JSON response object. +data FailedCommand = FailedCommand { + rspError :: FailedCommandError + , rspMessage :: Text + , rspStacktrace :: Text + , rspData :: Maybe Value + } deriving (Eq, Show) +instance Exception FailedCommand +deriveFromJSON toCamel1 ''FailedCommand + +-- | A command requiring a session ID was attempted when no session ID was +-- available. +data NoSessionId = NoSessionId String CallStack + deriving (Show, Typeable) +instance Exception NoSessionId diff --git a/src/Test/WebDriver/Exceptions/Internal.hs b/src/Test/WebDriver/Exceptions/Internal.hs deleted file mode 100644 --- a/src/Test/WebDriver/Exceptions/Internal.hs +++ /dev/null @@ -1,202 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ConstraintKinds #-} - -module Test.WebDriver.Exceptions.Internal - ( InvalidURL(..), HTTPStatusUnknown(..), HTTPConnError(..) - , UnknownCommand(..), ServerError(..) - - , FailedCommand(..), failedCommand, mkFailedCommandInfo - , FailedCommandType(..), FailedCommandInfo(..), StackFrame(..) - , externalCallStack, callStackItemToStackFrame - ) where -import Test.WebDriver.Session -import Test.WebDriver.JSON - -import Data.Aeson -import Data.Aeson.Types (Parser, typeMismatch) -import Data.ByteString.Lazy.Char8 (ByteString) -import Data.CallStack -import qualified Data.List as L -import Data.Text (Text) -import qualified Data.Text.Lazy.Encoding as TLE - -import Control.Applicative -import Control.Exception (Exception) -import Control.Exception.Lifted (throwIO) - -import Data.Maybe (fromMaybe, catMaybes) -import Data.Typeable (Typeable) - -import Prelude -- hides some "unused import" warnings - -instance Exception InvalidURL --- |An invalid URL was given -newtype InvalidURL = InvalidURL String - deriving (Eq, Show, Typeable) - -instance Exception HTTPStatusUnknown --- |An unexpected HTTP status was sent by the server. -data HTTPStatusUnknown = HTTPStatusUnknown Int String - deriving (Eq, Show, Typeable) - -instance Exception HTTPConnError --- |HTTP connection errors. -data HTTPConnError = HTTPConnError String Int - deriving (Eq, Show, Typeable) - -instance Exception UnknownCommand --- |A command was sent to the WebDriver server that it didn't recognize. -newtype UnknownCommand = UnknownCommand String - deriving (Eq, Show, Typeable) - -instance Exception ServerError --- |A server-side exception occured -newtype ServerError = ServerError String - deriving (Eq, Show, Typeable) - -instance Exception FailedCommand --- |This exception encapsulates a broad variety of exceptions that can --- occur when a command fails. -data FailedCommand = FailedCommand FailedCommandType FailedCommandInfo - deriving (Show, Typeable) - --- |The type of failed command exception that occured. -data FailedCommandType = NoSuchElement - | NoSuchFrame - | UnknownFrame - | StaleElementReference - | ElementNotVisible - | InvalidElementState - | UnknownError - | ElementIsNotSelectable - | JavascriptError - | XPathLookupError - | Timeout - | NoSuchWindow - | InvalidCookieDomain - | UnableToSetCookie - | UnexpectedAlertOpen - | NoAlertOpen - | ScriptTimeout - | InvalidElementCoordinates - | IMENotAvailable - | IMEEngineActivationFailed - | InvalidSelector - | SessionNotCreated - | MoveTargetOutOfBounds - | InvalidXPathSelector - | InvalidXPathSelectorReturnType - deriving (Eq, Ord, Enum, Bounded, Show) - --- |Detailed information about the failed command provided by the server. -data FailedCommandInfo = - FailedCommandInfo { -- |The error message. - errMsg :: String - -- |The session associated with - -- the exception. - , errSess :: Maybe WDSession - -- |A screen shot of the focused window - -- when the exception occured, - -- if provided. - , errScreen :: Maybe ByteString - -- |The "class" in which the exception - -- was raised, if provided. - , errClass :: Maybe String - -- |A stack trace of the exception. - , errStack :: [StackFrame] - } - --- |Provides a readable printout of the error information, useful for --- logging. -instance Show FailedCommandInfo where - show i = showChar '\n' - . showString "Session: " . sess - . showChar '\n' - . showString className . showString ": " . showString (errMsg i) - . showChar '\n' - . foldl (\f s-> f . showString " " . shows s) id (errStack i) - $ "" - where - className = fromMaybe "" . errClass $ i - - sess = case errSess i of - Nothing -> showString "None" - Just WDSession{..} -> - let sessId = maybe "" show wdSessId - in showString sessId . showString " at " - . shows wdSessHost . showChar ':' . shows wdSessPort - - --- |Constructs a FailedCommandInfo from only an error message. -mkFailedCommandInfo :: (WDSessionState s) => String -> CallStack -> s FailedCommandInfo -mkFailedCommandInfo m cs = do - sess <- getSession - return $ FailedCommandInfo { errMsg = m - , errSess = Just sess - , errScreen = Nothing - , errClass = Nothing - , errStack = fmap callStackItemToStackFrame cs } - --- |Use GHC's CallStack capabilities to return a callstack to help debug a FailedCommand. --- Drops all stack frames inside Test.WebDriver modules, so the first frame on the stack --- should be where the user called into Test.WebDriver -externalCallStack :: (HasCallStack) => CallStack -externalCallStack = dropWhile isWebDriverFrame callStack - where isWebDriverFrame :: ([Char], SrcLoc) -> Bool - isWebDriverFrame (_, SrcLoc {srcLocModule}) = "Test.WebDriver" `L.isPrefixOf` srcLocModule - --- |Convenience function to throw a 'FailedCommand' locally with no server-side --- info present. -failedCommand :: (HasCallStack, WDSessionStateIO s) => FailedCommandType -> String -> s a -failedCommand t m = do - throwIO . FailedCommand t =<< mkFailedCommandInfo m externalCallStack - --- |An individual stack frame from the stack trace provided by the server --- during a FailedCommand. -data StackFrame = StackFrame { sfFileName :: String - , sfClassName :: String - , sfMethodName :: String - , sfLineNumber :: Int - } - deriving (Eq) - - -instance Show StackFrame where - show f = showString (sfClassName f) . showChar '.' - . showString (sfMethodName f) . showChar ' ' - . showParen True ( showString (sfFileName f) . showChar ':' - . shows (sfLineNumber f)) - $ "\n" - - -instance FromJSON FailedCommandInfo where - parseJSON (Object o) = - FailedCommandInfo <$> (req "message" >>= maybe (return "") return) - <*> pure Nothing - <*> (fmap TLE.encodeUtf8 <$> opt "screen" Nothing) - <*> opt "class" Nothing - <*> (catMaybes <$> opt "stackTrace" []) - where req :: FromJSON a => Text -> Parser a - req = (o .:) . fromText --required key - opt :: FromJSON a => Text -> a -> Parser a - opt k d = o .:?? k .!= d --optional key - parseJSON v = typeMismatch "FailedCommandInfo" v - -instance FromJSON StackFrame where - parseJSON (Object o) = StackFrame <$> reqStr "fileName" - <*> reqStr "className" - <*> reqStr "methodName" - <*> req "lineNumber" - where req :: FromJSON a => Text -> Parser a - req = (o .:) . fromText -- all keys are required - reqStr :: Text -> Parser String - reqStr k = req k >>= maybe (return "") return - parseJSON v = typeMismatch "StackFrame" v - - -callStackItemToStackFrame :: (String, SrcLoc) -> StackFrame -callStackItemToStackFrame (functionName, SrcLoc {..}) = StackFrame { sfFileName = srcLocFile - , sfClassName = srcLocModule - , sfMethodName = functionName - , sfLineNumber = srcLocStartLine - } diff --git a/src/Test/WebDriver/Firefox/Profile.hs b/src/Test/WebDriver/Firefox/Profile.hs deleted file mode 100644 --- a/src/Test/WebDriver/Firefox/Profile.hs +++ /dev/null @@ -1,243 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- suppress warnings from attoparsec - --- | A module for working with Firefox profiles. Firefox profiles are manipulated --- in pure code and then \"prepared\" for network transmission. - -module Test.WebDriver.Firefox.Profile - ( -- * Profiles - Firefox, Profile(..), PreparedProfile - , defaultProfile - -- * Preferences - , ProfilePref(..), ToPref(..) - , addPref, getPref, deletePref - -- * Extensions - , addExtension, deleteExtension, hasExtension - -- * Other files and directories - , addFile, deleteFile, hasFile - -- * Miscellaneous profile operations - , unionProfiles, onProfileFiles, onProfilePrefs - -- * Loading and preparing profiles - , prepareProfile, prepareTempProfile - -- ** Preparing profiles from disk - , loadProfile, prepareLoadedProfile, prepareLoadedProfile_ - -- ** Preparing zip archives - , prepareZippedProfile, prepareZipArchive, prepareRawZip - -- ** Preferences parsing error - , ProfileParseError(..) - ) where -import Test.WebDriver.Common.Profile -import Data.Aeson (Result(..), encode, fromJSON) -import Data.Aeson.Parser (jstring, value') -import Data.Attoparsec.ByteString.Char8 as AP -import qualified Data.HashMap.Strict as HM -import Data.Text (Text) -import Data.ByteString as BS (readFile) -import qualified Data.ByteString.Lazy.Char8 as LBS - -import System.FilePath hiding (addExtension, hasExtension) -import System.Directory -import System.IO.Temp (createTempDirectory) -import qualified System.Directory.Tree as DS - -import Control.Monad -import Control.Monad.Base -import Control.Monad.Trans.Control -import Control.Exception.Lifted hiding (try) -import Control.Applicative -import Control.Arrow - -#if !MIN_VERSION_base(4,6,0) || defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706 -import Prelude hiding (catch) -#endif - --- |Phantom type used in the parameters of 'Profile' and 'PreparedProfile' -data Firefox - --- |Default Firefox Profile, used when no profile is supplied. -defaultProfile :: Profile Firefox -defaultProfile = - Profile HM.empty - $ HM.fromList [("app.update.auto", PrefBool False) - ,("app.update.enabled", PrefBool False) - ,("browser.startup.page" , PrefInteger 0) - ,("browser.download.manager.showWhenStarting", PrefBool False) - ,("browser.EULA.override", PrefBool True) - ,("browser.EULA.3.accepted", PrefBool True) - ,("browser.link.open_external", PrefInteger 2) - ,("browser.link.open_newwindow", PrefInteger 2) - ,("browser.offline", PrefBool False) - ,("browser.safebrowsing.enabled", PrefBool False) - ,("browser.search.update", PrefBool False) - ,("browser.sessionstore.resume_from_crash", PrefBool False) - ,("browser.shell.checkDefaultBrowser", PrefBool False) - ,("browser.tabs.warnOnClose", PrefBool False) - ,("browser.tabs.warnOnOpen", PrefBool False) - ,("browser.startup.page", PrefInteger 0) - ,("browser.safebrowsing.malware.enabled", PrefBool False) - ,("startup.homepage_welcome_url", PrefString "about:blank") - ,("devtools.errorconsole.enabled", PrefBool True) - ,("focusmanager.testmode", PrefBool True) - ,("dom.disable_open_during_load", PrefBool False) - ,("extensions.autoDisableScopes" , PrefInteger 10) - ,("extensions.logging.enabled", PrefBool True) - ,("extensions.update.enabled", PrefBool False) - ,("extensions.update.notifyUser", PrefBool False) - ,("network.manage-offline-status", PrefBool False) - ,("network.http.max-connections-per-server", PrefInteger 10) - ,("network.http.phishy-userpass-length", PrefInteger 255) - ,("offline-apps.allow_by_default", PrefBool True) - ,("prompts.tab_modal.enabled", PrefBool False) - ,("security.fileuri.origin_policy", PrefInteger 3) - ,("security.fileuri.strict_origin_policy", PrefBool False) - ,("security.warn_entering_secure", PrefBool False) - ,("security.warn_submit_insecure", PrefBool False) - ,("security.warn_entering_secure.show_once", PrefBool False) - ,("security.warn_entering_weak", PrefBool False) - ,("security.warn_entering_weak.show_once", PrefBool False) - ,("security.warn_leaving_secure", PrefBool False) - ,("security.warn_leaving_secure.show_once", PrefBool False) - ,("security.warn_submit_insecure", PrefBool False) - ,("security.warn_viewing_mixed", PrefBool False) - ,("security.warn_viewing_mixed.show_once", PrefBool False) - ,("signon.rememberSignons", PrefBool False) - ,("toolkit.networkmanager.disable", PrefBool True) - ,("toolkit.telemetry.enabled", PrefBool False) - ,("toolkit.telemetry.prompted", PrefInteger 2) - ,("toolkit.telemetry.rejected", PrefBool True) - ,("javascript.options.showInConsole", PrefBool True) - ,("browser.dom.window.dump.enabled", PrefBool True) - ,("webdriver_accept_untrusted_certs", PrefBool True) - ,("webdriver_enable_native_events", native_events) - ,("webdriver_assume_untrusted_issuer", PrefBool True) - ,("dom.max_script_run_time", PrefInteger 30) - ] - where -#ifdef darwin_HOST_OS - native_events = PrefBool False -#else - native_events = PrefBool True -#endif - - --- |Load an existing profile from the file system. Any prepared changes made to --- the 'Profile' will have no effect to the profile on disk. --- --- To make automated browser run smoothly, preferences found in --- 'defaultProfile' are automatically merged into the preferences of the on-disk-- profile. The on-disk profile's preference will override those found in the --- default profile. -loadProfile :: MonadBaseControl IO m => FilePath -> m (Profile Firefox) -loadProfile path = liftBase $ do - unionProfiles defaultProfile <$> (Profile <$> getFiles <*> getPrefs) - where - userPrefFile = path "prefs" <.> "js" - - getFiles = HM.fromList . map (id &&& (path )) . filter isNotIgnored - <$> getDirectoryContents path - where isNotIgnored = (`notElem` - [".", "..", "OfflineCache", "Cache" - ,"parent.lock", ".parentlock", ".lock" - ,userPrefFile]) - - getPrefs = do - prefFileExists <- doesFileExist userPrefFile - if prefFileExists - then HM.fromList <$> (parsePrefs =<< BS.readFile userPrefFile) - else return HM.empty - where parsePrefs s = either (throwIO . ProfileParseError) return - $ parseOnly prefsParser s - --- |Prepare a firefox profile for network transmission. --- Internally, this function constructs a Firefox profile within a temp --- directory, archives it as a zip file, and then base64 encodes the zipped --- data. The temporary directory is deleted afterwards. --- --- NOTE: because this function has to copy the profile files into a --- a temp directory before zip archiving them, this operation is likely to be slow --- for large profiles. In such a case, consider using 'prepareLoadedProfile_' or --- 'prepareZippedProfile' instead. -prepareProfile :: MonadBaseControl IO m => - Profile Firefox -> m (PreparedProfile Firefox) -prepareProfile Profile {profileFiles = files, profilePrefs = prefs} - = liftBase $ do - tmpdir <- mkTemp - mapM_ (installPath tmpdir) . HM.toList $ files - installUserPrefs tmpdir - prepareLoadedProfile_ tmpdir --- <* removeDirectoryRecursive tmpdir - where - installPath destDir (destPath, src) = do - let dest = destDir destPath - isDir <- doesDirectoryExist src - if isDir - then do - createDirectoryIfMissing True dest `catch` ignoreIOException - (_ DS.:/ dir) <- DS.readDirectoryWithL LBS.readFile src - handle ignoreIOException . void - $ DS.writeDirectoryWith LBS.writeFile (dest DS.:/ dir) - else do - let dir = takeDirectory dest - when (not . null $ dir) $ - createDirectoryIfMissing True dir `catch` ignoreIOException - copyFile src dest `catch` ignoreIOException - where - ignoreIOException :: IOException -> IO () - ignoreIOException = print - - installUserPrefs d = LBS.writeFile (d "user" <.> "js") str - where - str = LBS.concat - . map (\(k, v) -> LBS.concat [ "user_pref(", encode k, - ", ", encode v, ");\n"]) - . HM.toList $ prefs - --- |Apply a function on a default profile, and --- prepare the result. The Profile passed to the handler function is --- the default profile used by sessions when Nothing is specified -prepareTempProfile :: MonadBaseControl IO m => - (Profile Firefox -> Profile Firefox) - -> m (PreparedProfile Firefox) -prepareTempProfile f = prepareProfile . f $ defaultProfile - --- |Convenience function to load an existing Firefox profile from disk, apply --- a handler function, and then prepare the result for network transmission. --- --- NOTE: like 'prepareProfile', the same caveat about large profiles applies. -prepareLoadedProfile :: MonadBaseControl IO m => - FilePath - -> (Profile Firefox -> Profile Firefox) - -> m (PreparedProfile Firefox) -prepareLoadedProfile path f = liftM f (loadProfile path) >>= prepareProfile - --- firefox prefs.js parser - -prefsParser :: Parser [(Text, ProfilePref)] -prefsParser = many1 $ do - void . padSpaces $ string "user_pref(" - k <- prefKey "preference key" - void . padSpaces $ char ',' - v <- prefVal "preference value" - void . padSpaces $ string ");" - return (k,v) - where - prefKey = jstring - prefVal = do - v <- value' - case fromJSON v of - Error str -> fail str - Success p -> return p - - padSpaces p = spaces >> p <* spaces - spaces = many (endOfLine <|> void space <|> void comment) - where - comment = inlineComment <|> lineComment - lineComment = char '#' *> manyTill anyChar endOfLine - inlineComment = string "/*" *> manyTill anyChar (string "*/") - - -mkTemp :: IO FilePath -mkTemp = do - d <- getTemporaryDirectory - createTempDirectory d "" diff --git a/src/Test/WebDriver/IO.hs b/src/Test/WebDriver/IO.hs deleted file mode 100644 --- a/src/Test/WebDriver/IO.hs +++ /dev/null @@ -1,17 +0,0 @@ - -module Test.WebDriver.IO where - -import Control.Concurrent (threadDelay) -import Control.Monad.IO.Class (liftIO, MonadIO) -import Test.WebDriver -import Test.WebDriver.Class (WebDriver) - - -sleepIO :: Double -> IO () -sleepIO seconds = Control.Concurrent.threadDelay (round (seconds * 1e6)) - -sleepWD :: (MonadIO wd, WebDriver wd) => Double -> wd () -sleepWD = liftIO . sleepIO - -printWD :: Show s => s -> WD () -printWD = liftIO . print diff --git a/src/Test/WebDriver/Internal.hs b/src/Test/WebDriver/Internal.hs deleted file mode 100644 --- a/src/Test/WebDriver/Internal.hs +++ /dev/null @@ -1,232 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE CPP #-} - --- | The HTTP/JSON plumbing used to implement the 'WD' monad. --- --- These functions can be used to create your own 'WebDriver' instances, providing extra functionality for your application if desired. All exports --- of this module are subject to change at any point. -module Test.WebDriver.Internal - ( mkRequest, sendHTTPRequest - , getJSONResult, handleJSONErr, handleRespSessionId - , WDResponse(..) - ) where -import Test.WebDriver.Class -import Test.WebDriver.JSON -import Test.WebDriver.Session -import Test.WebDriver.Exceptions.Internal - -import Network.HTTP.Client (httpLbs, Request(..), RequestBody(..), Response(..)) -import qualified Network.HTTP.Client as HTTPClient - -import Data.Aeson -import Data.Aeson.Types (typeMismatch) -import Network.HTTP.Types.Header -import Network.HTTP.Types.Status (Status(..)) - -import qualified Data.ByteString.Base64.Lazy as B64 -import qualified Data.ByteString.Char8 as BS -import Data.ByteString.Lazy.Char8 (ByteString) -import Data.ByteString.Lazy.Char8 as LBS (unpack, null) -import qualified Data.ByteString.Lazy.Internal as LBS (ByteString(..)) -import Data.CallStack -import Data.Text as T (Text, splitOn, null) -import qualified Data.Text.Encoding as TE - -import Control.Applicative -import Control.Exception (Exception, SomeException(..), toException, fromException, try) -import Control.Exception.Lifted (throwIO) -import Control.Monad.Base - -import Data.String (fromString) -import Data.Word (Word8) - -#if !MIN_VERSION_http_client(0,4,30) -import Data.Default (def) -#endif - -import Prelude -- hides some "unused import" warnings - ---This is the defintion of fromStrict used by bytestring >= 0.10; we redefine it here to support bytestring < 0.10 -fromStrict :: BS.ByteString -> LBS.ByteString -fromStrict bs | BS.null bs = LBS.Empty - | otherwise = LBS.Chunk bs LBS.Empty - - ---Compatability function to support http-client < 0.4.30 -defaultRequest :: Request -#if MIN_VERSION_http_client(0,4,30) -defaultRequest = HTTPClient.defaultRequest -#else -defaultRequest = def -#endif - --- |Constructs an HTTP 'Request' value when given a list of headers, HTTP request method, and URL fragment -mkRequest :: (WDSessionState s, ToJSON a) => - Method -> Text -> a -> s Request -mkRequest meth wdPath args = do - WDSession {..} <- getSession - let body = case toJSON args of - Null -> "" --passing Null as the argument indicates no request body - other -> encode other - return defaultRequest - { host = wdSessHost - , port = wdSessPort - , path = wdSessBasePath `BS.append` TE.encodeUtf8 wdPath - , requestBody = RequestBodyLBS body - , requestHeaders = wdSessRequestHeaders - ++ [ (hAccept, "application/json;charset=UTF-8") - , (hContentType, "application/json;charset=UTF-8") ] - , method = meth -#if !MIN_VERSION_http_client(0,5,0) - , checkStatus = \_ _ _ -> Nothing -#endif - } - --- |Sends an HTTP request to the remote WebDriver server -sendHTTPRequest :: (WDSessionStateIO s) => Request -> s (Either SomeException (Response ByteString)) -sendHTTPRequest req = do - s@WDSession{..} <- getSession - (nRetries, tryRes) <- liftBase . retryOnTimeout wdSessHTTPRetryCount $ httpLbs req wdSessHTTPManager - let h = SessionHistory { histRequest = req - , histResponse = tryRes - , histRetryCount = nRetries - } - putSession s { wdSessHist = wdSessHistUpdate h wdSessHist } - return tryRes - -retryOnTimeout :: Int -> IO a -> IO (Int, (Either SomeException a)) -retryOnTimeout maxRetry go = retry' 0 - where - retry' nRetries = do - eitherV <- try go - case eitherV of - (Left e) -#if MIN_VERSION_http_client(0,5,0) - | Just (HTTPClient.HttpExceptionRequest _ HTTPClient.ResponseTimeout) <- fromException e -#else - | Just HTTPClient.ResponseTimeout <- fromException e -#endif - , maxRetry > nRetries - -> retry' (succ nRetries) - other -> return (nRetries, other) - --- |Parses a 'WDResponse' object from a given HTTP response. -getJSONResult :: (HasCallStack, WDSessionStateControl s, FromJSON a) => Response ByteString -> s (Either SomeException a) -getJSONResult r - --malformed request errors - | code >= 400 && code < 500 = do - lastReq <- mostRecentHTTPRequest <$> getSession - returnErr . UnknownCommand . maybe reason show $ lastReq - --server-side errors - | code >= 500 && code < 600 = - case lookup hContentType headers of - Just ct - | "application/json" `BS.isInfixOf` ct -> - parseJSON' - (maybe body fromStrict $ lookup "X-Response-Body-Start" headers) - >>= handleJSONErr - >>= maybe returnNull returnErr - | otherwise -> - returnHTTPErr ServerError - Nothing -> - returnHTTPErr (ServerError . ("HTTP response missing content type. Server reason was: "++)) - --redirect case (used as a response to createSession requests) - | code == 302 || code == 303 = - case lookup hLocation headers of - Nothing -> returnErr . HTTPStatusUnknown code $ LBS.unpack body - Just loc -> do - let sessId = last . filter (not . T.null) . splitOn "/" . fromString $ BS.unpack loc - modifySession $ \sess -> sess {wdSessId = Just (SessionId sessId)} - returnNull - -- No Content response - | code == 204 = returnNull - -- HTTP Success - | code >= 200 && code < 300 = - if LBS.null body - then returnNull - else do - rsp@WDResponse {rspVal = val} <- parseJSON' body - handleJSONErr rsp >>= maybe - (handleRespSessionId rsp >> Right <$> fromJSON' val) - returnErr - -- other status codes: return error - | otherwise = returnHTTPErr (HTTPStatusUnknown code) - where - --helper functions - returnErr :: (Exception e, Monad m) => e -> m (Either SomeException a) - returnErr = return . Left . toException - returnHTTPErr errType = returnErr . errType $ reason - returnNull = Right <$> fromJSON' Null - --HTTP response variables - code = statusCode status - reason = BS.unpack $ statusMessage status - status = responseStatus r - body = responseBody r - headers = responseHeaders r - -handleRespSessionId :: (HasCallStack, WDSessionStateIO s) => WDResponse -> s () -handleRespSessionId WDResponse{rspSessId = sessId'} = do - sess@WDSession { wdSessId = sessId} <- getSession - case (sessId, (==) <$> sessId <*> sessId') of - -- if our monad has an uninitialized session ID, initialize it from the response object - (Nothing, _) -> putSession sess { wdSessId = sessId' } - -- if the response ID doesn't match our local ID, throw an error. - (_, Just False) -> throwIO . ServerError $ "Server response session ID (" ++ show sessId' - ++ ") does not match local session ID (" ++ show sessId ++ ")" - _ -> return () - -handleJSONErr :: (HasCallStack, WDSessionStateControl s) => WDResponse -> s (Maybe SomeException) -handleJSONErr WDResponse{rspStatus = 0} = return Nothing -handleJSONErr WDResponse{rspVal = val, rspStatus = status} = do - sess <- getSession - errInfo <- fromJSON' val - let screen = B64.decodeLenient <$> errScreen errInfo - seleniumStack = errStack errInfo - errInfo' = errInfo { errSess = Just sess - -- Append the Haskell stack frames to the ones returned from Selenium - , errScreen = screen - , errStack = seleniumStack ++ (fmap callStackItemToStackFrame externalCallStack) } - e errType = toException $ FailedCommand errType errInfo' - return . Just $ case status of - 7 -> e NoSuchElement - 8 -> e NoSuchFrame - 9 -> toException . UnknownCommand . errMsg $ errInfo - 10 -> e StaleElementReference - 11 -> e ElementNotVisible - 12 -> e InvalidElementState - 13 -> e UnknownError - 15 -> e ElementIsNotSelectable - 17 -> e JavascriptError - 19 -> e XPathLookupError - 21 -> e Timeout - 23 -> e NoSuchWindow - 24 -> e InvalidCookieDomain - 25 -> e UnableToSetCookie - 26 -> e UnexpectedAlertOpen - 27 -> e NoAlertOpen - 28 -> e ScriptTimeout - 29 -> e InvalidElementCoordinates - 30 -> e IMENotAvailable - 31 -> e IMEEngineActivationFailed - 32 -> e InvalidSelector - 33 -> e SessionNotCreated - 34 -> e MoveTargetOutOfBounds - 51 -> e InvalidXPathSelector - 52 -> e InvalidXPathSelectorReturnType - _ -> e UnknownError - - --- |Internal type representing the JSON response object -data WDResponse = WDResponse { - rspSessId :: Maybe SessionId - , rspStatus :: Word8 - , rspVal :: Value - } - deriving (Eq, Show) - -instance FromJSON WDResponse where - parseJSON (Object o) = WDResponse <$> o .:?? "sessionId" .!= Nothing - <*> o .: "status" - <*> o .:?? "value" .!= Null - parseJSON v = typeMismatch "WDResponse" v diff --git a/src/Test/WebDriver/JSON.hs b/src/Test/WebDriver/JSON.hs --- a/src/Test/WebDriver/JSON.hs +++ b/src/Test/WebDriver/JSON.hs @@ -1,55 +1,67 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-deriving-typeable #-} --- |A collection of convenience functions for using and parsing JSON values +-- | A collection of convenience functions for using and parsing JSON values -- within 'WD'. All monadic parse errors are converted to asynchronous -- 'BadJSON' exceptions. -- -- These functions are used internally to implement webdriver commands, and may -- be useful for implementing non-standard commands. -module Test.WebDriver.JSON - ( -- * Access a JSON object key - (!:), (.:??) - -- * Conversion from JSON within WD - -- |Apostrophes are used to disambiguate these functions - -- from their "Data.Aeson" counterparts. - , parseJSON', fromJSON' - -- * Tuple functions - -- |Convenience functions for working with tuples. +module Test.WebDriver.JSON ( + -- * Access a JSON object key + (!:) + , (.:??) - -- ** JSON object constructors - , single, pair, triple - -- ** Extracting JSON objects into tuples - , parsePair, parseTriple - -- * Conversion from parser results to WD - -- |These functions are used to implement the other functions - -- in this module, and could be used to implement other JSON - -- convenience functions - , apResultToWD, aesonResultToWD - -- * Parse exception - , BadJSON(..) - -- * parsing commands with no return value - , NoReturn(..), noReturn, ignoreReturn + -- * Conversion from JSON within WD + -- | Apostrophes are used to disambiguate these functions + -- from their "Data.Aeson" counterparts. + , parseJSON' + , fromJSON' - , fromText - ) where -import Test.WebDriver.Class (WebDriver) + -- * Tuple functions + -- | Convenience functions for working with tuples. + -- ** JSON object constructors + , single + , pair + , triple + -- ** Extracting JSON objects into tuples + , parseTriple + -- * Conversion from parser results to WD + -- | These functions are used to implement the other functions + -- in this module, and could be used to implement other JSON + -- convenience functions + , apResultToWD + , aesonResultToWD + + -- * Parse exception + , BadJSON(..) + + -- * parsing commands with no return value + , noReturn + , ignoreReturn + , aesonKeyFromText + , NoReturn(..) + + -- * JSON helpers + , noObject + ) where + +import Control.Applicative +import Control.Monad (join, void) +import Control.Monad.IO.Class import Data.Aeson as Aeson import Data.Aeson.Types -import Data.Text (Text) -import Data.ByteString.Lazy.Char8 (ByteString) import Data.Attoparsec.ByteString.Lazy (Result(..)) import qualified Data.Attoparsec.ByteString.Lazy as AP - -import Control.Monad (join, void) -import Control.Applicative -import Control.Monad.Trans.Control -import Control.Exception.Lifted +import Data.ByteString.Lazy.Char8 (ByteString) import Data.String -import Data.Typeable - +import Data.Text (Text) import Prelude -- hides some "unused import" warnings +import Test.WebDriver.Types (WebDriver) +import Test.WebDriver.Util.Aeson (aesonKeyFromText) +import UnliftIO.Exception #if MIN_VERSION_aeson(2,2,0) -- This comes from the attoparsec-aeson package @@ -57,24 +69,18 @@ #endif #if MIN_VERSION_aeson(2,0,0) -import qualified Data.Aeson.Key as A import qualified Data.Aeson.KeyMap as HM -fromText :: Text -> A.Key -fromText = A.fromText #else import qualified Data.HashMap.Strict as HM -fromText :: Text -> Text -fromText = id #endif -instance Exception BadJSON --- |An error occured when parsing a JSON value. +-- | An error occured when parsing a JSON value. newtype BadJSON = BadJSON String - deriving (Eq, Show, Typeable) - + deriving (Eq, Show, Typeable) +instance Exception BadJSON --- |A type indicating that we expect no return value from the webdriver request. +-- | A type indicating that we expect no return value from the webdriver request. -- Its FromJSON instance parses successfully for any values that indicate lack of -- a return value (a notion that varies from server to server). data NoReturn = NoReturn @@ -85,68 +91,55 @@ parseJSON (String "") = return NoReturn parseJSON other = typeMismatch "no return value" other --- |Convenience function to handle webdriver commands with no return value. -noReturn :: WebDriver wd => wd NoReturn -> wd () +instance ToJSON NoReturn where + toJSON NoReturn = Aeson.String "" + +-- | Convenience function to handle webdriver commands with no return value. +noReturn :: WebDriver m => m NoReturn -> m () noReturn = void --- |Convenience function to ignore result of a webdriver command. -ignoreReturn :: WebDriver wd => wd Value -> wd () +-- | Convenience function to ignore result of a webdriver command. +ignoreReturn :: WebDriver m => m Value -> m () ignoreReturn = void - --- |Construct a singleton JSON 'object' from a key and value. +-- | Construct a singleton JSON 'object' from a key and value. single :: ToJSON a => Text -> a -> Value -single a x = object [(fromText a) .= x] +single a x = object [aesonKeyFromText a .= x] --- |Construct a 2-element JSON 'object' from a pair of keys and a pair of +-- | Construct a 2-element JSON 'object' from a pair of keys and a pair of -- values. -pair :: (ToJSON a, ToJSON b) => (Text,Text) -> (a,b) -> Value -pair (a,b) (x,y) = object [fromText a .= x, fromText b .= y] +pair :: (ToJSON a, ToJSON b) => (Text, Text) -> (a, b) -> Value +pair (a, b) (x,y) = object [aesonKeyFromText a .= x, aesonKeyFromText b .= y] --- |Construct a 3-element JSON 'object' from a triple of keys and a triple of +-- | Construct a 3-element JSON 'object' from a triple of keys and a triple of -- values. -triple :: (ToJSON a, ToJSON b, ToJSON c) => - (Text,Text,Text) -> (a,b,c) -> Value -triple (a,b,c) (x,y,z) = object [fromText a .= x, fromText b.= y, fromText c .= z] - +triple :: (ToJSON a, ToJSON b, ToJSON c) => (Text, Text, Text) -> (a, b, c) -> Value +triple (a, b, c) (x, y, z) = object [aesonKeyFromText a .= x, aesonKeyFromText b.= y, aesonKeyFromText c .= z] --- |Parse a lazy 'ByteString' as a top-level JSON 'Value', then convert it to an +-- | Parse a lazy 'ByteString' as a top-level JSON 'Value', then convert it to an -- instance of 'FromJSON'.. -parseJSON' :: MonadBaseControl IO wd => FromJSON a => ByteString -> wd a +parseJSON' :: MonadIO m => FromJSON a => ByteString -> m a parseJSON' = apResultToWD . AP.parse json --- |Convert a JSON 'Value' to an instance of 'FromJSON'. -fromJSON' :: MonadBaseControl IO wd => FromJSON a => Value -> wd a +-- | Convert a JSON 'Value' to an instance of 'FromJSON'. +fromJSON' :: MonadIO m => FromJSON a => Value -> m a fromJSON' = aesonResultToWD . fromJSON --- |This operator is a wrapper over Aeson's '.:' operator. -(!:) :: (MonadBaseControl IO wd, FromJSON a) => Object -> Text -> wd a -o !: k = aesonResultToWD $ parse (.: fromText k) o +-- | This operator is a wrapper over Aeson's '.:' operator. +(!:) :: (MonadIO m, FromJSON a) => Object -> Text -> m a +o !: k = aesonResultToWD $ parse (.: aesonKeyFromText k) o --- |Due to a breaking change in the '.:?' operator of aeson 0.10 (see ) that was subsequently reverted, this operator +-- | Due to a breaking change in the '.:?' operator of aeson 0.10 (see ) that was subsequently reverted, this operator -- was added to provide consistent behavior compatible with all aeson versions. If the field is either missing or `Null`, this operator should return a `Nothing` result. (.:??) :: FromJSON a => Object -> Text -> Parser (Maybe a) -o .:?? k = fmap join (o .:? fromText k) - - --- |Parse a JSON 'Object' as a pair. The first two string arguments specify the --- keys to extract from the object. The third string is the name of the --- calling function, for better error reporting. -parsePair :: (MonadBaseControl IO wd, FromJSON a, FromJSON b) => - String -> String -> String -> Value -> wd (a, b) -parsePair a b funcName v = - case v of - Object o -> (,) <$> o !: fromString a <*> o !: fromString b - _ -> throwIO . BadJSON $ funcName ++ - ": cannot parse non-object JSON response as a (" ++ a - ++ ", " ++ b ++ ") pair" ++ ")" - +o .:?? k = fmap join (o .:? aesonKeyFromText k) --- |Parse a JSON Object as a triple. The first three string arguments +-- | Parse a JSON Object as a triple. The first three string arguments -- specify the keys to extract from the object. The fourth string is the name -- of the calling function, for better error reporting. -parseTriple :: (MonadBaseControl IO wd, FromJSON a, FromJSON b, FromJSON c) => - String -> String -> String -> String -> Value -> wd (a, b, c) +parseTriple :: ( + MonadIO m, FromJSON a, FromJSON b, FromJSON c + ) => String -> String -> String -> String -> Value -> m (a, b, c) parseTriple a b c funcName v = case v of Object o -> (,,) <$> o !: fromString a @@ -156,16 +149,18 @@ ": cannot parse non-object JSON response as a (" ++ a ++ ", " ++ b ++ ", " ++ c ++ ") pair" - - --- |Convert an attoparsec parser result to 'WD'. -apResultToWD :: (MonadBaseControl IO wd, FromJSON a) => AP.Result Value -> wd a +-- | Convert an attoparsec parser result to 'WD'. +apResultToWD :: (MonadIO m, FromJSON a) => AP.Result Value -> m a apResultToWD p = case p of Done _ res -> fromJSON' res Fail _ _ err -> throwIO $ BadJSON err --- |Convert an Aeson parser result to 'WD'. -aesonResultToWD :: (MonadBaseControl IO wd) => Aeson.Result a -> wd a +-- | Convert an Aeson parser result to 'WD'. +aesonResultToWD :: (MonadIO m) => Aeson.Result a -> m a aesonResultToWD r = case r of Success val -> return val - Error err -> throwIO $ BadJSON err + Error err -> throwIO $ BadJSON err + +-- Selenium 3.x doesn't seem to like receiving Null for click parameter +noObject :: Value +noObject = Object mempty diff --git a/src/Test/WebDriver/Keys.hs b/src/Test/WebDriver/Keys.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Keys.hs @@ -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" diff --git a/src/Test/WebDriver/LaunchDriver.hs b/src/Test/WebDriver/LaunchDriver.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/LaunchDriver.hs @@ -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 diff --git a/src/Test/WebDriver/Monad.hs b/src/Test/WebDriver/Monad.hs deleted file mode 100644 --- a/src/Test/WebDriver/Monad.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ConstraintKinds #-} - -module Test.WebDriver.Monad ( - WD(..) - , runWD - , runSession - , finallyClose - , closeOnException - , getSessionHistory - , dumpSessionHistory - ) where - -import Test.WebDriver.Class -import Test.WebDriver.Commands -import Test.WebDriver.Config -import Test.WebDriver.Internal -import Test.WebDriver.Session - -import Control.Monad.Base (MonadBase, liftBase) -import Control.Monad.Fix -import Control.Monad.IO.Class -import Control.Monad.Trans.Control (MonadBaseControl(..), StM) -import Control.Monad.Trans.State.Strict (StateT, evalStateT, get, put) -import Control.Exception.Lifted -import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) -import Control.Applicative - -import Prelude -- hides some "unused import" warnings - - -{- | A state monad for WebDriver commands. -} -newtype WD a = WD (StateT WDSession IO a) - deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadFix, MonadMask) - -instance MonadBase IO WD where - liftBase = WD . liftBase - -instance MonadBaseControl IO WD where -#if MIN_VERSION_monad_control(1,0,0) - type StM WD a = StM (StateT WDSession IO) a - - liftBaseWith f = WD $ - liftBaseWith $ \runInBase -> - f (\(WD sT) -> runInBase $ sT) - - restoreM = WD . restoreM -#else - data StM WD a = StWD {unStWD :: StM (StateT WDSession IO) a} - - liftBaseWith f = WD $ - liftBaseWith $ \runInBase -> - f (\(WD sT) -> liftM StWD . runInBase $ sT) - - restoreM = WD . restoreM . unStWD -#endif - -instance WDSessionState WD where - getSession = WD get - putSession = WD . put - -instance WebDriver WD where - doCommand method path args = - mkRequest method path args - >>= sendHTTPRequest - >>= either throwIO return - >>= getJSONResult - >>= either throwIO return - --- |Executes a 'WD' computation within the 'IO' monad, using the given --- 'WDSession' as state for WebDriver requests. -runWD :: WDSession -> WD a -> IO a -runWD sess (WD wd) = evalStateT wd sess - --- |Executes a 'WD' computation within the 'IO' monad, automatically creating a new session beforehand. --- --- NOTE: session is not automatically closed when complete. If you want this behavior, use 'finallyClose'. --- Example: --- --- > runSessionThenClose action = runSession myConfig . finallyClose $ action -runSession :: WebDriverConfig conf => conf -> WD a -> IO a -runSession conf wd = do - sess <- mkSession conf - caps <- mkCaps conf - runWD sess $ createSession caps >> wd - --- |A finalizer ensuring that the session is always closed at the end of --- the given 'WD' action, regardless of any exceptions. -finallyClose:: WebDriver wd => wd a -> wd a -finallyClose wd = closeOnException wd <* closeSession - --- |Exception handler that closes the session when an --- asynchronous exception is thrown, but otherwise leaves the session open --- if the action was successful. -closeOnException :: WebDriver wd => wd a -> wd a -closeOnException wd = wd `onException` closeSession - --- |Gets the command history for the current session. -getSessionHistory :: WDSessionState wd => wd [SessionHistory] -getSessionHistory = fmap wdSessHist getSession - --- |Prints a history of API requests to stdout after computing the given action. -dumpSessionHistory :: WDSessionStateControl wd => wd a -> wd a -dumpSessionHistory = (`finally` (getSession >>= liftBase . print . wdSessHist)) diff --git a/src/Test/WebDriver/Profile.hs b/src/Test/WebDriver/Profile.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Profile.hs @@ -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 "*/") diff --git a/src/Test/WebDriver/Session.hs b/src/Test/WebDriver/Session.hs deleted file mode 100644 --- a/src/Test/WebDriver/Session.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} - -module Test.WebDriver.Session ( - -- * WDSessionState class - WDSessionState(..), WDSessionStateIO, WDSessionStateControl, modifySession, withSession - -- ** WebDriver sessions - , WDSession(..), mostRecentHistory, mostRecentHTTPRequest, SessionId(..), SessionHistory(..) - -- * SessionHistoryConfig options - , SessionHistoryConfig, noHistory, unlimitedHistory, onlyMostRecentHistory - -- * Using custom HTTP request headers - , withRequestHeaders, withAuthHeaders - ) where - -import Test.WebDriver.Session.History - -import Data.Aeson -import Data.ByteString as BS(ByteString) -import Data.Text (Text) -import Data.Maybe (listToMaybe) -import Data.Monoid -import Control.Applicative -import Control.Monad.Base -import Control.Monad.Trans.Class -import Control.Monad.Trans.Control -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Identity -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Except -import Control.Monad.Trans.Writer.Strict as SW -import Control.Monad.Trans.Writer.Lazy as LW -import Control.Monad.Trans.State.Strict as SS -import Control.Monad.Trans.State.Lazy as LS -import Control.Monad.Trans.RWS.Strict as SRWS -import Control.Monad.Trans.RWS.Lazy as LRWS -import Control.Exception.Lifted (SomeException, try, throwIO) -import Network.HTTP.Client (Manager, Request) -import Network.HTTP.Types (RequestHeaders) -import Prelude -- hides some "redundant import" warnings - - -{- |An opaque identifier for a WebDriver session. These handles are produced by -the server on session creation, and act to identify a session in progress. -} -newtype SessionId = SessionId Text - deriving (Eq, Ord, Show, Read, FromJSON, ToJSON) - -{- |The local state of a WebDriver session. This structure is passed -implicitly through all 'WD' computations -} -data WDSession = WDSession { - -- server hostname - wdSessHost :: BS.ByteString - -- server port - , wdSessPort :: Int - -- Base path for API requests - , wdSessBasePath :: BS.ByteString - -- |An opaque reference identifying the session to - -- use with 'WD' commands. - -- A value of Nothing indicates that a session - -- hasn't been created yet. - -- Sessions can be created within 'WD' via - -- 'Test.WebDriver.createSession', or created - -- automatically with 'Test.WebDriver.runSession' - , wdSessId :: Maybe SessionId - -- |The complete history of HTTP requests and - -- responses, most recent first. - , wdSessHist :: [SessionHistory] - -- |Update function used to append new entries to session history - , wdSessHistUpdate :: SessionHistoryConfig - -- |HTTP 'Manager' used for connection pooling by the http-client library. - , wdSessHTTPManager :: Manager - -- |Number of times to retry a HTTP request if it times out - , wdSessHTTPRetryCount :: Int - -- |Custom request headers to add to every HTTP request. - , wdSessRequestHeaders :: RequestHeaders - -- |Custom request headers to add *only* to session creation requests. This is usually done - -- when a WebDriver server requires HTTP auth. - , wdSessAuthHeaders :: RequestHeaders - } - - --- |A function used by 'wdHistoryConfig' to append new entries to session history. -type SessionHistoryConfig = SessionHistory -> [SessionHistory] -> [SessionHistory] - --- |No session history is saved. -noHistory :: SessionHistoryConfig -noHistory _ _ = [] - --- |Keep unlimited history -unlimitedHistory :: SessionHistoryConfig -unlimitedHistory = (:) - --- |Saves only the most recent history -onlyMostRecentHistory :: SessionHistoryConfig -onlyMostRecentHistory h _ = [h] - --- |A class for monads that carry a WebDriver session with them. The --- MonadBaseControl superclass is used for exception handling through --- the lifted-base package. -class (Monad m, Applicative m) => WDSessionState m where - - -- |Retrieves the current session state of the monad - getSession :: m WDSession - - -- |Sets a new session state for the monad - putSession :: WDSession -> m () - --- |Constraint synonym for the common pairing of 'WDSessionState' and 'MonadBase' 'IO'. -type WDSessionStateIO s = (WDSessionState s, MonadBase IO s) - --- |Constraint synonym for another common pairing of 'WDSessionState' and 'MonadBaseControl' 'IO'. This --- is commonly used in library types to indicate use of lifted exception handling. -type WDSessionStateControl s = (WDSessionState s, MonadBaseControl IO s) - -modifySession :: WDSessionState s => (WDSession -> WDSession) -> s () -modifySession f = getSession >>= putSession . f - --- |Locally sets a session state for use within the given action. --- The state of any outside action is unaffected by this function. --- This function is useful if you need to work with multiple sessions simultaneously. -withSession :: WDSessionStateControl m => WDSession -> m a -> m a -withSession s m = do - s' <- getSession - putSession s - (a :: Either SomeException a) <- try m - putSession s' - either throwIO return a - --- |The most recent SessionHistory entry recorded by this session, if any. -mostRecentHistory :: WDSession -> Maybe SessionHistory -mostRecentHistory = listToMaybe . wdSessHist - --- |The most recent HTTP request issued by this session, if any. -mostRecentHTTPRequest :: WDSession -> Maybe Request -mostRecentHTTPRequest = fmap histRequest . mostRecentHistory - --- |Set a temporary list of custom 'RequestHeaders' to use within the given action. --- All previous custom headers are temporarily removed, and then restored at the end. -withRequestHeaders :: WDSessionStateControl m => RequestHeaders -> m a -> m a -withRequestHeaders h m = do - h' <- fmap wdSessRequestHeaders getSession - modifySession $ \s -> s { wdSessRequestHeaders = h } - (a :: Either SomeException a) <- try m - modifySession $ \s -> s { wdSessRequestHeaders = h' } - either throwIO return a - --- |Makes all webdriver HTTP requests in the given action use the session\'s auth headers, typically --- configured by setting the 'wdAuthHeaders' config. This is useful if you want to temporarily use --- the same auth headers you used for session creation with other HTTP requests. -withAuthHeaders :: WDSessionStateControl m => m a -> m a -withAuthHeaders wd = do - authHeaders <- fmap wdSessAuthHeaders getSession - withRequestHeaders authHeaders wd - -instance WDSessionState m => WDSessionState (LS.StateT s m) where - getSession = lift getSession - putSession = lift . putSession - -instance WDSessionState m => WDSessionState (SS.StateT s m) where - getSession = lift getSession - putSession = lift . putSession - -instance WDSessionState m => WDSessionState (MaybeT m) where - getSession = lift getSession - putSession = lift . putSession - -instance WDSessionState m => WDSessionState (IdentityT m) where - getSession = lift getSession - putSession = lift . putSession - -instance (Monoid w, WDSessionState m) => WDSessionState (LW.WriterT w m) where - getSession = lift getSession - putSession = lift . putSession - -instance (Monoid w, WDSessionState m) => WDSessionState (SW.WriterT w m) where - getSession = lift getSession - putSession = lift . putSession - -instance WDSessionState m => WDSessionState (ReaderT r m) where - getSession = lift getSession - putSession = lift . putSession - -instance WDSessionState m => WDSessionState (ExceptT r m) where - getSession = lift getSession - putSession = lift . putSession - -instance (Monoid w, WDSessionState m) => WDSessionState (SRWS.RWST r w s m) where - getSession = lift getSession - putSession = lift . putSession - -instance (Monoid w, WDSessionState wd) => WDSessionState (LRWS.RWST r w s wd) where - getSession = lift getSession - putSession = lift . putSession diff --git a/src/Test/WebDriver/Session/History.hs b/src/Test/WebDriver/Session/History.hs deleted file mode 100644 --- a/src/Test/WebDriver/Session/History.hs +++ /dev/null @@ -1,14 +0,0 @@ - -module Test.WebDriver.Session.History where - -import Control.Exception (SomeException) -import Data.ByteString.Lazy (ByteString) -import Network.HTTP.Client (Request, Response) - - -data SessionHistory = SessionHistory - { histRequest :: Request - , histResponse :: Either SomeException (Response ByteString) - , histRetryCount :: Int - } - deriving (Show) diff --git a/src/Test/WebDriver/Types.hs b/src/Test/WebDriver/Types.hs --- a/src/Test/WebDriver/Types.hs +++ b/src/Test/WebDriver/Types.hs @@ -1,48 +1,225 @@ -{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.WebDriver.Types ( - -- * WebDriver sessions - WD(..), WDSession(..), SessionId(..), SessionHistory + WebDriverContext(..) + -- , HasWebDriverContext + , mkEmptyWebDriverContext - -- * WebDriver configuration - , WDConfig(..), defaultConfig, SessionHistoryConfig + , Driver(..) + , DriverConfig(..) + , SeleniumVersion(..) - -- * Capabilities - , Capabilities(..), defaultCaps, allCaps - , Platform(..), ProxyType(..), UnexpectedAlertBehavior(..) + -- * SessionState class + , SessionState(..) + , SessionStatePut(..) - -- ** Browser-specific capabilities - , Browser(..), + -- ** WebDriver sessions + , SessionId(..) + , Session(..) - -- ** Default settings for browsers - firefox, chrome, ie, opera, iPhone, iPad, android - , LogLevel(..), IELogLevel(..), IEElementScrollBehavior(..) + -- * Exceptions + , SessionException(..) - -- * WebDriver objects and command-specific types - , Element(..) - , WindowHandle(..), currentWindow - , Selector(..) - , JSArg(..) - , FrameSelector(..) - , Cookie(..), mkCookie - , Orientation(..) - , MouseButton(..) - , WebStorageType(..) - , LogType, LogEntry(..) - , ApplicationCacheStatus(..) + -- * Stack frames + , StackFrame(..) + , callStackItemToStackFrame - -- * Exceptions - , InvalidURL(..), NoSessionId(..), BadJSON(..) - , HTTPStatusUnknown(..), HTTPConnError(..) - , UnknownCommand(..), ServerError(..) - , FailedCommand(..), FailedCommandType(..) - , FailedCommandInfo(..), StackFrame(..) - , mkFailedCommandInfo, failedCommand + -- * WebDriver class + , WebDriver + , WebDriverBase(..) + , Method + , methodDelete + , methodGet + , methodPost ) where -import Test.WebDriver.Capabilities -import Test.WebDriver.Commands -import Test.WebDriver.Config -import Test.WebDriver.Exceptions -import Test.WebDriver.Monad -import Test.WebDriver.Session +import Control.Monad.IO.Unlift +import Data.Aeson +import Data.Aeson.Types (Parser, typeMismatch) +import qualified Data.ByteString.Lazy as LBS +import Data.Map as M +import Data.String +import Data.String.Interpolate +import Data.Text as T +import GHC.Stack +import Network.HTTP.Client +import Network.HTTP.Types (RequestHeaders) +import Network.HTTP.Types.Method (methodDelete, methodGet, methodPost, Method) +import Test.WebDriver.Util.Aeson (aesonKeyFromText) +import UnliftIO.Async +import UnliftIO.Concurrent +import UnliftIO.Exception +import UnliftIO.Process +import UnliftIO.STM + + +-- | The 'WebDriverContext' is an opaque type used by this library for +-- bookkeeping purposes. It tracks all the processes we spin up and all the +-- sessions we create. +-- +-- Currently, we will create at most 1 Selenium or Chromedriver process per +-- 'WebDriverContext', and N Geckodriver processes, where N is the number of +-- Firefox sessions you request. +data WebDriverContext = WebDriverContext { + _webDriverSessions :: MVar (Map String Session) + , _webDriverSelenium :: MVar (Maybe Driver) + , _webDriverChromedriver :: MVar (Maybe Driver) + } + +-- | Create a new 'WebDriverContext'. +mkEmptyWebDriverContext :: MonadIO m => m WebDriverContext +mkEmptyWebDriverContext = WebDriverContext + <$> newMVar mempty + <*> newMVar Nothing + <*> newMVar Nothing + +data Driver = Driver { + _driverHostname :: String + , _driverPort :: Int + , _driverBasePath :: String + , _driverRequestHeaders :: RequestHeaders + , _driverManager :: Manager + , _driverProcess :: Maybe ProcessHandle + , _driverLogAsync :: Maybe (Async ()) + , _driverConfig :: DriverConfig + } + +data SeleniumVersion = + Selenium3 + | Selenium4 + deriving (Show, Eq) + +-- | Configuration for how to launch a given driver. +data DriverConfig = + -- | For launching a WebDriver via "java -jar selenium.jar". + -- Selenium can launch other drivers on your behalf. You should pass these as 'driverConfigSubDrivers'. + DriverConfigSeleniumJar { + -- | Path to @java@ binary. + driverConfigJava :: FilePath + -- | Extra flags to pass to @java@. + , driverConfigJavaFlags :: [String] + -- | Extra flags to pass to @java@. + , driverConfigJavaExtraEnv :: Maybe [(String, String)] + -- | Path to @selenium.jar@ file. + , driverConfigSeleniumJar :: FilePath + -- | Specify if this is Selenium 3 or 4. If this is not provided, we'll try to autodetect. + , driverConfigSeleniumVersion :: Maybe SeleniumVersion + -- | Drivers to configure Selenium to use. + , driverConfigSubDrivers :: [DriverConfig] + -- | Directory in which to place driver logs. + , driverConfigLogDir :: Maybe FilePath + } + | DriverConfigGeckodriver { + -- | Path to @geckodriver@ binary. + driverConfigGeckodriver :: FilePath + -- | Extra flags to pass to @geckodriver@. + , driverConfigGeckodriverFlags :: [String] + -- | Extra environment variables to pass to @geckodriver@. + , driverConfigGeckodriverExtraEnv :: Maybe [(String, String)] + -- | Path to @firefox@ binary. + , driverConfigFirefox :: FilePath + -- | Directory in which to place driver logs. + , driverConfigLogDir :: Maybe FilePath + } + | DriverConfigChromedriver { + -- | Path to @chromedriver@ binary. + driverConfigChromedriver :: FilePath + -- | Extra flags to pass to @chromedriver@. + , driverConfigChromedriverFlags :: [String] + -- | Extra environment variables to pass to @chromedriver@. + , driverConfigChromedriverExtraEnv :: Maybe [(String, String)] + -- | Path to @chrome@ binary. + , driverConfigChrome :: FilePath + -- | Directory in which to place driver logs. + , driverConfigLogDir :: Maybe FilePath + } + +-- | An opaque identifier for a WebDriver session. These handles are produced by +-- the server on session creation, and act to identify a session in progress. +newtype SessionId = SessionId T.Text + deriving (Eq, Ord, Show, Read, FromJSON, ToJSON) +instance IsString SessionId where + fromString s = SessionId (T.pack s) + +data Session = Session { + sessionDriver :: Driver + , sessionId :: SessionId + , sessionName :: String + , sessionWebSocketUrl :: Maybe String + -- | Used to generate IDs for BiDi. + , sessionIdCounter :: TVar Int + } +instance Show Session where + show (Session {sessionDriver=(Driver {..}), ..}) = [i|Session<[#{sessionId}] at #{_driverHostname}:#{_driverPort}#{_driverBasePath}>|] + +-- class HasLens ctx a where +-- getLens :: Lens' ctx a + +data SessionException = + SessionNameAlreadyExists + | SessionCreationFailed (Response LBS.ByteString) + | SessionCreationResponseHadNoSessionId (Response LBS.ByteString) + deriving (Show) +instance Exception SessionException + + +class SessionState m where + getSession :: m Session + +class (SessionState m) => SessionStatePut m where + withModifiedSession :: (Session -> Session) -> m a -> m a + +type WebDriver m = (WebDriverBase m, SessionState m) + +-- | A class for monads that can handle wire protocol requests. This is the +-- operation underlying all of the high-level commands exported in +-- "Test.WebDriver.Commands". +class (MonadUnliftIO m) => WebDriverBase m where + doCommandBase :: ( + HasCallStack, ToJSON a + ) + => Driver + -- | HTTP request method + -> Method + -- | URL of request + -> Text + -- | JSON parameters passed in the body of the request. Note that, as a + -- special case, anything that converts to Data.Aeson.Null will result in an + -- empty request body. + -> a + -- | The response of the HTTP request. + -> m (Response LBS.ByteString) + +-- | An individual stack frame from the stack trace provided by the server +-- during a FailedCommand. +data StackFrame = StackFrame { + sfFileName :: String + , sfClassName :: String + , sfMethodName :: String + , sfLineNumber :: Int + } deriving (Eq) +instance Show StackFrame where + show f = showString (sfClassName f) . showChar '.' + . showString (sfMethodName f) . showChar ' ' + . showParen True ( showString (sfFileName f) . showChar ':' + . shows (sfLineNumber f)) + $ "\n" +instance FromJSON StackFrame where + parseJSON (Object o) = StackFrame <$> reqStr "fileName" + <*> reqStr "className" + <*> reqStr "methodName" + <*> req "lineNumber" + where req :: FromJSON a => Text -> Parser a + req = (o .:) . aesonKeyFromText -- all keys are required + reqStr :: Text -> Parser String + reqStr k = req k >>= maybe (return "") return + parseJSON v = typeMismatch "StackFrame" v + +callStackItemToStackFrame :: (String, SrcLoc) -> StackFrame +callStackItemToStackFrame (functionName, SrcLoc {..}) = StackFrame { + sfFileName = srcLocFile + , sfClassName = srcLocModule + , sfMethodName = functionName + , sfLineNumber = srcLocStartLine + } diff --git a/src/Test/WebDriver/Util/Aeson.hs b/src/Test/WebDriver/Util/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Util/Aeson.hs @@ -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 diff --git a/src/Test/WebDriver/Util/Commands.hs b/src/Test/WebDriver/Util/Commands.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Util/Commands.hs @@ -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 +-- +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 diff --git a/src/Test/WebDriver/Util/Ports.hs b/src/Test/WebDriver/Util/Ports.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Util/Ports.hs @@ -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) diff --git a/src/Test/WebDriver/Util/Sockets.hs b/src/Test/WebDriver/Util/Sockets.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Util/Sockets.hs @@ -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) diff --git a/src/Test/WebDriver/Utils.hs b/src/Test/WebDriver/Utils.hs deleted file mode 100644 --- a/src/Test/WebDriver/Utils.hs +++ /dev/null @@ -1,9 +0,0 @@ - -module Test.WebDriver.Utils where - -import Data.Text (Text) -import Data.Text.Encoding as TE -import qualified Network.HTTP.Types.URI as HTTP - -urlEncode :: Text -> Text -urlEncode = TE.decodeUtf8 . HTTP.urlEncode False . TE.encodeUtf8 diff --git a/src/Test/WebDriver/WD.hs b/src/Test/WebDriver/WD.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/WD.hs @@ -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 +. + +-} + +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 _ = "" + +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 diff --git a/src/Test/WebDriver/Waits.hs b/src/Test/WebDriver/Waits.hs new file mode 100644 --- /dev/null +++ b/src/Test/WebDriver/Waits.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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"]) "" diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -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) diff --git a/tests/Spec/Actions.hs b/tests/Spec/Actions.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/Actions.hs @@ -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 diff --git a/tests/Spec/CommandContexts.hs b/tests/Spec/CommandContexts.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/CommandContexts.hs @@ -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) diff --git a/tests/Spec/Cookies.hs b/tests/Spec/Cookies.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/Cookies.hs @@ -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) diff --git a/tests/Spec/DocumentHandling.hs b/tests/Spec/DocumentHandling.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/DocumentHandling.hs @@ -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|Click here|] + + 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))) diff --git a/tests/Spec/ElementInteraction.hs b/tests/Spec/ElementInteraction.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/ElementInteraction.hs @@ -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"))) diff --git a/tests/Spec/ElementRetrieval.hs b/tests/Spec/ElementRetrieval.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/ElementRetrieval.hs @@ -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 diff --git a/tests/Spec/ElementState.hs b/tests/Spec/ElementState.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/ElementState.hs @@ -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) diff --git a/tests/Spec/Logs.hs b/tests/Spec/Logs.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/Logs.hs @@ -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 diff --git a/tests/Spec/LogsBiDi.hs b/tests/Spec/LogsBiDi.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/LogsBiDi.hs @@ -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 () diff --git a/tests/Spec/Navigation.hs b/tests/Spec/Navigation.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/Navigation.hs @@ -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 diff --git a/tests/Spec/ScreenCapture.hs b/tests/Spec/ScreenCapture.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/ScreenCapture.hs @@ -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") diff --git a/tests/Spec/SeleniumSpecific/Mobile.hs b/tests/Spec/SeleniumSpecific/Mobile.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/SeleniumSpecific/Mobile.hs @@ -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 diff --git a/tests/Spec/SeleniumSpecific/Uploads.hs b/tests/Spec/SeleniumSpecific/Uploads.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/SeleniumSpecific/Uploads.hs @@ -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") diff --git a/tests/Spec/Sessions.hs b/tests/Spec/Sessions.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/Sessions.hs @@ -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}|] diff --git a/tests/Spec/UserPrompts.hs b/tests/Spec/UserPrompts.hs new file mode 100644 --- /dev/null +++ b/tests/Spec/UserPrompts.hs @@ -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 diff --git a/tests/TestLib/Contexts/BrowserDependencies.hs b/tests/TestLib/Contexts/BrowserDependencies.hs new file mode 100644 --- /dev/null +++ b/tests/TestLib/Contexts/BrowserDependencies.hs @@ -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 diff --git a/tests/TestLib/Contexts/Selenium4.hs b/tests/TestLib/Contexts/Selenium4.hs new file mode 100644 --- /dev/null +++ b/tests/TestLib/Contexts/Selenium4.hs @@ -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; + }; +} +|] diff --git a/tests/TestLib/Contexts/Session.hs b/tests/TestLib/Contexts/Session.hs new file mode 100644 --- /dev/null +++ b/tests/TestLib/Contexts/Session.hs @@ -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 () diff --git a/tests/TestLib/Contexts/StaticServer.hs b/tests/TestLib/Contexts/StaticServer.hs new file mode 100644 --- /dev/null +++ b/tests/TestLib/Contexts/StaticServer.hs @@ -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" diff --git a/tests/TestLib/Contexts/WebDriver.hs b/tests/TestLib/Contexts/WebDriver.hs new file mode 100644 --- /dev/null +++ b/tests/TestLib/Contexts/WebDriver.hs @@ -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) diff --git a/tests/TestLib/Mouse.hs b/tests/TestLib/Mouse.hs new file mode 100644 --- /dev/null +++ b/tests/TestLib/Mouse.hs @@ -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)) diff --git a/tests/TestLib/Types.hs b/tests/TestLib/Types.hs new file mode 100644 --- /dev/null +++ b/tests/TestLib/Types.hs @@ -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 _ = "" + +-- * 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 () diff --git a/tests/TestLib/Types/Cli.hs b/tests/TestLib/Types/Cli.hs new file mode 100644 --- /dev/null +++ b/tests/TestLib/Types/Cli.hs @@ -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")) diff --git a/tests/TestLib/Waits.hs b/tests/TestLib/Waits.hs new file mode 100644 --- /dev/null +++ b/tests/TestLib/Waits.hs @@ -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) diff --git a/webdriver.cabal b/webdriver.cabal --- a/webdriver.cabal +++ b/webdriver.cabal @@ -1,22 +1,22 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0. +-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack name: webdriver -version: 0.12.0.1 +version: 0.15.0.0 synopsis: a Haskell client for the Selenium WebDriver protocol -description: A Selenium WebDriver client for Haskell. - You can use it to automate browser sessions - for testing, system administration, etc. +description: A WebDriver client for Haskell. + You can use it to automate browser sessions for testing, system administration, etc. + Here are some relevant links: . - For more information about Selenium itself, see - + * + * + * + * . - To find out what's been changed in this version and others, - see the change log at - + See the announcement blog post [here](https://thomasjm.github.io/posts/webdriver-13) to learn about the changes in @0.13.0.0@. category: Web, Browser, Testing, WebDriver, Selenium homepage: https://github.com/haskell-webdriver/haskell-webdriver#readme bug-reports: https://github.com/haskell-webdriver/haskell-webdriver/issues @@ -26,12 +26,13 @@ license-file: LICENSE build-type: Simple tested-with: - GHC == 8.6.5 - , GHC == 8.8.4 - , GHC == 8.10.7 - , GHC == 9.0.2 - , GHC == 9.2.7 - , GHC == 9.4.4 + GHC == 9.0.2 + , GHC == 9.2.8 + , GHC == 9.4.8 + , GHC == 9.6.7 + , GHC == 9.8.4 + , GHC == 9.10.2 + , GHC == 9.12.2 extra-source-files: README.md CHANGELOG.md @@ -44,63 +45,196 @@ exposed-modules: Test.WebDriver Test.WebDriver.Capabilities - Test.WebDriver.Chrome.Extension - Test.WebDriver.Class Test.WebDriver.Commands - Test.WebDriver.Commands.Internal - Test.WebDriver.Commands.Wait - Test.WebDriver.Common.Keys - Test.WebDriver.Common.Profile - Test.WebDriver.Config - Test.WebDriver.Cookies - Test.WebDriver.Exceptions - Test.WebDriver.Exceptions.Internal - Test.WebDriver.Firefox.Profile - Test.WebDriver.Internal - Test.WebDriver.JSON - Test.WebDriver.Monad - Test.WebDriver.Session - Test.WebDriver.Session.History + Test.WebDriver.Keys + Test.WebDriver.Profile Test.WebDriver.Types - Test.WebDriver.Utils + Test.WebDriver.Waits + Test.WebDriver.WD other-modules: - Test.WebDriver.IO + Test.WebDriver.Capabilities.Aeson + Test.WebDriver.Capabilities.ChromeOptions + Test.WebDriver.Capabilities.FirefoxOptions + Test.WebDriver.Capabilities.Platform + Test.WebDriver.Capabilities.Proxy + Test.WebDriver.Capabilities.Timeouts + Test.WebDriver.Capabilities.UserPromptHandler + Test.WebDriver.Commands.Actions + Test.WebDriver.Commands.BiDi.NetworkActivity + Test.WebDriver.Commands.BiDi.Session + Test.WebDriver.Commands.CommandContexts + Test.WebDriver.Commands.Cookies + Test.WebDriver.Commands.DocumentHandling + Test.WebDriver.Commands.ElementInteraction + Test.WebDriver.Commands.ElementRetrieval + Test.WebDriver.Commands.ElementState + Test.WebDriver.Commands.Logs + Test.WebDriver.Commands.Logs.BiDi + Test.WebDriver.Commands.Logs.Chrome + Test.WebDriver.Commands.Logs.Common + Test.WebDriver.Commands.Logs.Firefox + Test.WebDriver.Commands.Logs.Selenium + Test.WebDriver.Commands.Navigation + Test.WebDriver.Commands.ScreenCapture + Test.WebDriver.Commands.SeleniumSpecific.HTML5 + Test.WebDriver.Commands.SeleniumSpecific.Misc + Test.WebDriver.Commands.SeleniumSpecific.Mobile + Test.WebDriver.Commands.SeleniumSpecific.Uploads + Test.WebDriver.Commands.Sessions + Test.WebDriver.Commands.UserPrompts + Test.WebDriver.Exceptions + Test.WebDriver.JSON + Test.WebDriver.LaunchDriver + Test.WebDriver.Util.Aeson + Test.WebDriver.Util.Commands + Test.WebDriver.Util.Ports + Test.WebDriver.Util.Sockets + Paths_webdriver hs-source-dirs: src default-extensions: - ScopedTypeVariables - OverloadedStrings FlexibleContexts FlexibleInstances - RecordWildCards + LambdaCase NamedFieldPuns - ghc-options: -Wall + OverloadedStrings + QuasiQuotes + RecordWildCards + ScopedTypeVariables + ghc-options: -Wall -Wredundant-constraints -Wunused-packages build-depends: - aeson >=0.6.2.0 + aeson >=1.4.1.0 && <2.3 , attoparsec >=0.10 - , attoparsec-aeson >=2 + , attoparsec-aeson >=2.1.0.0 && <2.3 , base ==4.* , base64-bytestring >=1.0 , bytestring >=0.9 - , call-stack - , data-default + , containers , directory >1.0 - , directory-tree >=0.11 , exceptions >=0.4 , filepath >1.0 , http-client >=0.3 , http-types >=0.8 - , lifted-base >=0.1 - , monad-control >=0.3 - , network >=2.6 + , microlens-th >=0.4.0.0 + , monad-logger + , mtl + , network , network-uri >=2.6 + , random + , retry + , safe-exceptions , scientific >=0.2 - , temporary >=1.0 + , stm + , string-interpolate , text >=0.11.3 , time >1.0 - , transformers >=0.4 - , transformers-base >=0.1 + , unliftio + , unliftio-core , unordered-containers >=0.1.3 - , vector >=0.3 + , websockets >=0.13 , zip-archive >=0.1.1.8 + default-language: Haskell2010 + +executable demo + main-is: Main.hs + other-modules: + Paths_webdriver + hs-source-dirs: + app + default-extensions: + FlexibleContexts + FlexibleInstances + LambdaCase + NamedFieldPuns + OverloadedStrings + QuasiQuotes + RecordWildCards + ScopedTypeVariables + ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -W + build-depends: + aeson + , base + , bytestring + , exceptions + , http-client + , http-types + , monad-logger + , mtl + , string-interpolate + , text + , unliftio + , unliftio-core + , webdriver + default-language: Haskell2010 + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Spec + Spec.Actions + Spec.CommandContexts + Spec.Cookies + Spec.DocumentHandling + Spec.ElementInteraction + Spec.ElementRetrieval + Spec.ElementState + Spec.Logs + Spec.LogsBiDi + Spec.Navigation + Spec.ScreenCapture + Spec.SeleniumSpecific.Mobile + Spec.SeleniumSpecific.Uploads + Spec.Sessions + Spec.UserPrompts + TestLib.Contexts.BrowserDependencies + TestLib.Contexts.Selenium4 + TestLib.Contexts.Session + TestLib.Contexts.StaticServer + TestLib.Contexts.WebDriver + TestLib.Mouse + TestLib.Types + TestLib.Types.Cli + TestLib.Waits + Paths_webdriver + hs-source-dirs: + tests + default-extensions: + FlexibleContexts + FlexibleInstances + LambdaCase + NamedFieldPuns + OverloadedStrings + QuasiQuotes + RecordWildCards + ScopedTypeVariables + ghc-options: -threaded -Wall -Wredundant-constraints -Wunused-packages + build-tool-depends: + sandwich:sandwich-discover + build-depends: + aeson + , base + , bytestring + , containers + , exceptions + , filepath + , http-client + , http-types + , microlens + , monad-logger + , mtl + , network + , network-uri + , optparse-applicative + , retry + , safe-exceptions + , sandwich + , sandwich-contexts + , string-interpolate + , text + , unliftio + , unliftio-core + , wai-app-static + , warp + , webdriver default-language: Haskell2010