diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,127 @@ - +# webdriver-precore-0.2.0.0 (2026-01-17) +## Breaking Changes + +### Module Restructure + +The library has been reorganized to support both HTTP and BiDi protocols: + +- `WebDriverPreCore.SpecDefinition` deleted. Use `WebDriverPreCore.HTTP.API` or the deprecated `WebDriverPreCore.HTTP.SpecDefinition` +- `WebDriverPreCore.Capabilities` → `WebDriverPreCore.HTTP.Capabilities` +- `WebDriverPreCore.HttpResponse` → `WebDriverPreCore.HTTP.HttpResponse` + +Main module exports updated to reflect new structure. Import from `WebDriverPreCore.HTTP.*` for HTTP protocol or `WebDriverPreCore.BiDi.*` for BiDi protocol. + +### Type Renames + +- `W3Spec` → `Command` (in `WebDriverPreCore.HTTP.Protocol`) +- `SessionId` → `Session` (constructor: `MkSession`) +- `WebDriverErrorType` → `ErrorType` +- `ScriptTimeoutError` → `ScriptTimeout` +- Error functions renamed: + - `errorCodeToErrorType` → `toErrorType` + - `errorTypeToErrorCode` → `toErrorCode` + - `parseWebDriverError` → `parseWebDriverException` + - `parseWebDriverErrorType` → `parseErrorType` + +### HTTP API Changes + +**Status endpoint**: Return type changed from `DriverStatus` to `Status`. The `Status` type correctly implements the spec: +- `ready` field indicates if server accepts commands +- `message` field provides additional info +- Previous implementation incorrectly returned `ready` as status + +**New session**: Now returns `SessionResponse` containing: +- `sessionId :: Session` (the session ID) +- `webSocketUrl :: Maybe Text` (for BiDi connections) +- `capabilities :: Capabilities` (matched capabilities) +- `extensions :: Maybe (Map Text Value)` (extension-specific data) + +**Response parsing**: The `Command` type in the new API no longer exposes a `parser` field. Extract the response body value and call `parseJSON` on it. For migration examples, see [HTTP test runners](https://github.com/pyrethrum/webdriver/tree/main/webdriver-precore/test/HTTP). + +### Migration Guide + +1. Update imports: + ```haskell + -- Old + import WebDriverPreCore.SpecDefinition + + -- New + import WebDriverPreCore.HTTP.API + ``` + +2. Update types in code: + ```haskell + -- Old + spec :: W3Spec a + sessionId :: SessionId + errType :: WebDriverErrorType + + -- New + cmd :: Command a + session :: Session + errType :: ErrorType + ``` + +3. Handle new session response: + ```haskell + -- Old: newSession returned SessionId + sessionId <- runCommand $ newSession caps + + -- New: newSession returns SessionResponse + sessionResp <- runCommand $ newSession caps + let session = sessionResp.sessionId -- Session type + wsUrl = sessionResp.webSocketUrl -- for BiDi connection + caps = sessionResp.capabilities -- matched capabilities + ``` + +4. Update error handling: + ```haskell + -- Old + errorCodeToErrorType code + + -- New + toErrorType code + ``` + +## Deprecations + +`WebDriverPreCore.HTTP.SpecDefinition` module deprecated (removal ~2027-02-01). This module provides backward compatibility with the old `SpecDefinition` API using the deprecated name `HttpSpec` for the spec type. Migrate to `WebDriverPreCore.HTTP.API` which uses the `Command` type. + +## New Features + +### BiDi Protocol Support + +Complete implementation of W3C WebDriver BiDi protocol, including: + +- **Session management**: Connection setup, capability negotiation +- **Browsing contexts**: Navigation, context management, tree traversal +- **Script evaluation**: JavaScript execution, realm management, channel messaging +- **Network**: Request interception, authentication, response modification +- **Input**: Actions for keyboard, mouse, wheel +- **Storage**: Cookie and storage partition management +- **Events**: Subscriptions for logs, network events, browsing context lifecycle, script realm events +- **Emulation**: User agent, viewport configuration +- **Browser**: Process management, user context handling +- **WebExtensions**: Install and uninstall browser extensions (experimental) + +See `WebDriverPreCore.BiDi.API` for commands and `WebDriverPreCore.BiDi.Protocol` for types. + +### Error Handling Improvements + +- Added 17 BiDi-specific error types +- `ErrorType` now derives `FromJSON` for direct parsing +- Improved error-to-code conversion with proper camelCase handling + +## Bug Fixes + +- Status endpoint implementation corrected to match W3C spec +- Fixed session status data structure (was incorrectly returning `ready` as the status value) + +## Examples + +See [test directory](https://github.com/pyrethrum/webdriver/tree/main/webdriver-precore/test) for HTTP and BiDi usage examples + # webdriver-precore-0.1.0.2 (2025-05-17) Fix Hackage build failure (ghc-9.8.4) @@ -18,7 +140,7 @@ # webdriver-precore-0.0.0.3 (2025-04-21) -A few documentation typos an bump version of Vector dependencies +A few documentation typos and bump version of Vector dependencies # webdriver-precore-0.0.0.2 (2025-04-21) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -12,37 +12,24 @@ [![Stackage Nightly](http://stackage.org/package/path/badge/nightly)](http://stackage.org/nightly/package/path) --> -- [webdriver-precore](#webdriver-precore) - - [What is This Library?](#what-is-this-library) - - [Why This Library?](#why-this-library) - - [Core Principles](#core-principles) - - [Library Non-Goals](#library-non-goals) - - [Acknowledgements](#acknowledgements) -- [Minimal Example](#minimal-example) - - [1. Implementing a runner](#1-implementing-a-runner) - - [Main Types (Used in the Runner)](#main-types-used-in-the-runner) - - [W3Spec](#w3spec) - - [HttpResponse](#httpresponse) - - [The Runner](#the-runner) - - [1.1 Convert W3Spec to params for req](#11-convert-w3spec-to-params-for-req) - - [1.2 Call the WebDriver](#12-call-the-webdriver) - - [1.3 Parse HttpResponse Using the Parser Provided in the W3Spec](#13-parse-httpresponse-using-the-parser-provided-in-the-w3spec) - - [2. Applying the Runner to the W3Spec Functions](#2-applying-the-runner-to-the-w3spec-functions) - - [3. Install a Vendor Provided WebDriver](#3-install-a-vendor-provided-webdriver) - - [4. Launch WebDriver From the Terminal](#4-launch-webdriver-from-the-terminal) - - [5. Drive the Browser Via the IO API](#5-drive-the-browser-via-the-io-api) ## What is This Library? -This library provides a minimal abstraction over the [WebDriver W3C Protocol endpoints](https://www.w3.org/TR/webdriver2/) without providing any implementation. It provides a description of the W3C API as a list of functions that return a [W3Spec type](#w3spec). The intention is that other libraries will provide the actual implementation. +This library provides typed definitions for the W3C WebDriver Protocol, supporting both the [HTTP](https://www.w3.org/TR/2025/WD-webdriver2-20251028/) and the [BiDi](https://www.w3.org/TR/2025/WD-webdriver-bidi-20251212/) protocols. -You can not use this library directly to drive a browser. If you are looking for a fully featured library to drive a browser, you may be interested in an alternative library such as [haskell-webdriver](https://hackage.haskell.org/package/webdriver), a Selenium 2 client that is actively maintained. +This library is intended as a foundation for building WebDriver client implementations. **It is type constructors only**, and does not include any executable client code. +If you are writing a webdriver client, this library will save you the effort of analysing the specs and implementing the protocol types and JSON instances. + +If you are looking for a library to enable you to interact with web pages directly then you need a fully implemented web client library **which this library is not**. + +For a fully implemented webdriver client, consider an alternative such as [haskell-webdriver](https://github.com/haskell-webdriver/haskell-webdriver#readme) + ## Why This Library? Several libraries provide WebDriver bindings for Haskell. However, when development on this library began, the existing options were either unmaintained, dependent on Selenium, or tightly coupled with larger "batteries included" testing frameworks. -We, the authors of this library, are building our own standalone test framework. To support browser based testing within this framework we're first creating a series of independent low-level libraries. This library is the first in that series. Our aim is to make each of our low level libraries broadly useful to others, outside its use within our own framework. +We, the authors of this library, are building our own stand-alone test framework. To support browser based testing within this framework we're first creating a series of independent low-level libraries. This library is the first in that series. Our aim is to make each of our low level libraries broadly useful to others, outside its use within our own framework. ### Core Principles - **Direct W3C WebDriver Implementation** @@ -59,8 +46,10 @@ ### Library Non-Goals - * Any convenience or utility functions, that do not directly correspond to an endpoint on the WC3 spec. Such functions belong in downstream libraries. - * Any transformers, effects or similar abstractions. These too belong downstream. +The following features are not included in this library. They belong in downstream libraries. + * Convenience or utility functions, that do not directly correspond to an endpoint on the W3C spec. + * Transformers, effects or similar abstractions. + * Bespoke variations from the spec to accommodate non-standard driver behaviour. ### Acknowledgements @@ -72,259 +61,10 @@ **Selenium and WebDriver Standards**: -The decade+ efforts of the [Selenium](https://www.selenium.dev/) maintainers, both in forging the way with Selenium and their ongoing work in the development of the [W3C standards](https://www.w3.org/TR/webdriver2/) - - -# Minimal Example - -*TLDR ~ bring your own HTTP client and use it to implement the endpoints as defined in this library.* - -Driving a browser using this library requires the following: -1. Implement a `runner` that takes a [W3Spec](#w3spec) and makes HTTP calls an active WebDriver instance -2. Create an IO API by applying the `runner` to each of the endpoint functions in this library -3. Install the desired browser and browser driver -4. Run the driver -5. Drive the browser via the IO API - -The full source can be found in the [example project repo](https://github.com/pyrethrum/webdriver/blob/main/webdriver-examples/README.md). - - -## 1. Implementing a runner - -The first step in writing a WebDriver implementation is to choose an HTTP library. In this example, the chosen library is [req](https://hackage.haskell.org/package/req). - -Then to implement a run function requires the following: - -1. Transform a [W3Spec](#w3spec) to RequestParams compatible with the chosen HTTP library. -2. Make an HTTP call to WebDriver as per the RequestParams and return a simplified [HttpResponse](#httpresponse). -3. Use the parser provided by the [W3Spec](#w3spec) to parse the [HttpResponse](#httpresponse) and handle any errors. - -#### Main Types (Used in the Runner) - -The two most important types in this library are: - -##### W3Spec - -The `W3Spec` returned by each of this library's endpoint functions. This type represents a driver endpoint. - -```haskell -data W3Spec a - = Get - { description :: Text, - path :: UrlPath, - parser :: HttpResponse -> Result a - } - | Post - { description :: Text, - path :: UrlPath, - body :: Value, - parser :: HttpResponse -> Result a - } - | PostEmpty - { description :: Text, - path :: UrlPath, - parser :: HttpResponse -> Result a - } - | Delete - { description :: Text, - path :: UrlPath, - parser :: HttpResponse -> Result a - } -``` - -##### HttpResponse - -`HttpResponse` is consumed by the `parser` provided by this library and needs to be constructed by the `runner` - -```haskell -data HttpResponse = MkHttpResponse - { -- | HTTP status code. - statusCode :: Int, - -- | HTTP status message. - statusMessage :: Text, - -- | Response body in JSON format. - body :: Value - } -``` - -#### The Runner - -[source](https://github.com/pyrethrum/webdriver/blob/main/webdriver-examples/driver-demo-e2e/IORunner.hs) - - -```haskell -run :: W3Spec a -> IO a -run spec = do - -- 1. Convert W3Spec to params for req - let request = mkRequest spec - -- 2. Call WebDriver server (via req) and return a simplified HttpResponse - response <- callReq request - -- 3. Apply the W3Spec parser to the HttpResponse get result type and handle errors - parseResponse spec response -``` - -### 1.1 Convert W3Spec to params for req - -*W3Spec -> ReqRequestParams* - -```haskell --- A custom data type specific to req -data ReqRequestParams where - MkRequestParams :: - (HttpBodyAllowed (AllowsBody method) (ProvidesBody body), HttpMethod method, HttpBody body) => - { url :: Url 'Http, - method :: method, - body :: body, - port :: Int - } -> - ReqRequestParams - --- W3Spec -> ReqRequestParams --- the url and port would not normally be hard coded -mkRequest :: forall a. W3Spec a -> ReqRequestParams -mkRequest spec = case spec of - Get {} -> MkRequestParams url GET NoReqBody 4444 - Post {body} -> MkRequestParams url POST (ReqBodyJson body) 4444 - PostEmpty {} -> MkRequestParams url POST (ReqBodyJson $ object []) 4444 - Delete {} -> MkRequestParams url DELETE NoReqBody 4444 - where - url = foldl' (/:) (http "127.0.0.1") spec.path.segments -``` - -### 1.2 Call the WebDriver - -*ReqRequestParams -> HttpResponse* - -```haskell -callReq :: ReqRequestParams -> IO HttpResponse -callReq MkRequestParams {url, method, body, port = prt} = - runReq defaultHttpConfig {httpConfigCheckResponse = \_ _ _ -> Nothing} $ do - r <- req method url body jsonResponse $ port prt - pure $ - MkHttpResponse - { statusCode = responseStatusCode r, - statusMessage = responseStatusText r, - body = responseBody r :: Value - } - where - responseStatusText = decodeUtf8Lenient . responseStatusMessage -``` - -### 1.3 Parse HttpResponse Using the Parser Provided in the [W3Spec](#w3spec) - -*HttpResponse -> Return Type* - -```haskell --- in this implementation we are just throwing exceptions on failure -parseResponse :: W3Spec a -> HttpResponse -> IO a -parseResponse spec r = - spec.parser r - & \case - Error msg -> fail $ parseWebDriverError r & \case - e@NotAnError {} -> unpack spec.description <> "\n" <> - "Failed to parse response:\n " <> msg <> "\nin response:" <> show e - e@UnrecognisedError {} -> "UnrecognisedError:\n " <> "\nin response:" <> show e - e@WebDriverError {} -> "WebDriver error thrown:\n " <> show e - Success a -> pure a -``` - -### 2. Applying the Runner to the W3Spec Functions - -*Create an IO API by applying run to each endpoint definition exposed by this library* - -The full source for can be found in the [example project repo](https://github.com/pyrethrum/webdriver/blob/main/webdriver-examples/driver-demo-e2e/IOAPI.hs). -```haskell -module IOAPI where - -import Data.Aeson (Value) -import Data.Text as T (Text) -import WebDriverPreCore (DriverStatus, ElementId, Selector, SessionId) -import WebDriverPreCore qualified as W -import Prelude hiding (log) -import IOUtils (sleepMs, encodeFileToBase64) -import IORunner (run) - -status :: IO DriverStatus -status = run W.status - -newSession :: W.FullCapabilities -> IO SessionId -newSession = run . W.newSession - -getTimeouts :: SessionId -> IO W.Timeouts -getTimeouts = run . W.getTimeouts - -setTimeouts :: SessionId -> W.Timeouts -> IO () -setTimeouts s = run . W.setTimeouts s - -getCurrentUrl :: SessionId -> IO Text -getCurrentUrl = run . W.getCurrentUrl - -getTitle :: SessionId -> IO Text -getTitle = run . W.getTitle - -maximizeWindow :: SessionId -> IO W.WindowRect -maximizeWindow = run . W.maximizeWindow - --- ... and 50+ more API functions -``` - -### 3. Install a Vendor Provided WebDriver - -*Once all the required endpoints are implemented you will be able to interact with browsers via WebDriver* - -Examples: - 1. [Firefox](https://github.com/mozilla/geckodriver/releases) - 2. [Chrome](https://googlechromelabs.github.io/chrome-for-testing/) - 3. [Edge](https://developer.microsoft.com/en-us/microsoft-edge/tools/webdriver?form=MA13LH) - 4. [Opera](https://github.com/operasoftware/operachromiumdriver?tab=readme-ov-file) - 5. [Safari](https://developer.apple.com/documentation/webkit/testing-with-webdriver-in-safari) - -*Ensure the corresponding browser is installed on your system* - -### 4. Launch WebDriver From the Terminal - -e.g. For Firefox and geckodriver on Linux or WSL you could start geckodriver from the terminal as follows: - -*Note: we are setting the port to 4444, which is the hard coded port in our example.* - -```bash -> pkill -f geckodriver || true && geckodriver --port=4444 & -``` -or with logging: - -```bash -> pkill -f geckodriver || true && geckodriver --log trace --port=4444 & -``` - -or similarly for Chrome and chromedriver: - -```bash -> pkill -f chromedriver || true && chromedriver --port=4444 & -``` - -or with logging: - -```bash -> pkill -f chromedriver || true && chromedriver --log-level=ALL --port=4444 & -``` - -### 5. Drive the Browser Via the IO API - -*With the driver running you can now run code that interacts with the browser:* +The decade+ efforts of the [Selenium](https://www.selenium.dev/) maintainers, both in forging the way with Selenium and their ongoing work in the development of the W3C standards, both [HTTP](https://www.w3.org/TR/webdriver2/) and [BiDi](https://www.w3.org/TR/webdriver-bidi/) -Full source file can be found in the [example project repo](https://github.com/pyrethrum/webdriver/blob/main/webdriver-examples/driver-demo-e2e/WebDriverE2EDemoTest.hs). +## Further Details -```haskell -demoForwardBackRefresh :: IO () -demoForwardBackRefresh = do - ses <- newSession $ minFullCapabilities Firefox - navigateTo ses "https://the-internet.herokuapp.com/" - link findElement ses $ CSS "#content ul:nth-child(4) > li:nth-child(6) > a:nth-child(1)" - elementClick ses link - back ses - forward ses - refresh ses - deleteSession ses -``` +For further details on the structure and use of this library see the [Hackage Docs](https://hackage.haskell.org/package/webdriver-precore). -*This is a minimal API. There is plenty of scope to build on this to provide more constrained types, user-friendly functions and capabilities such as retries, and session and driver management.* +For runnable demos and source code for an example client implementation see the [test directory of this repository](./test/README.md). diff --git a/src/WebDriverPreCore.hs b/src/WebDriverPreCore.hs --- a/src/WebDriverPreCore.hs +++ b/src/WebDriverPreCore.hs @@ -1,150 +1,215 @@ -module WebDriverPreCore - ( - -- ** The W3Spec Type - module WC3Spec, +{-# LANGUAGE CPP #-} - -- ** Root Methods - module RootMethods, +{-| +Module : WebDriverPreCore +Description : W3C WebDriver Protocol Typed Definitions +Copyright : (c) 2025 John Walker, Adrian Glouftsis +License : BSD-3-Clause +Maintainer : theghostjw@gmail.com +Stability : experimental - -- ** Session Methods - -- | /See also 'newSession' and 'newSession''/ - module SessionMethods, += Overview - -- ** Window Methods - module WindowMethods, +This library provides typed definitions for the W3C WebDriver Protocol, supporting both the [HTML](HTMLSpecURL) and the [BiDi](BiDiSpecURL) protocols. - -- ** Frame Methods - module FrameMethods, +This library is intended as a foundation for building WebDriver client implementations. __It is type constructors only__, and does not include any executable client code. - -- ** Element(s) Methods - module ElementMethods, +If you are writing a webdriver client, this library will save you the effort of analysing the specs and implementing the protocol types and JSON instances. - -- ** Element Instance Methods - module ElementInstanceMethods, +If you are looking for a library to enable you to interact with web pages directly then you need a fully implemented client library __which this library is not__. - -- ** Shadow DOM Methods - module ShadowDOMMethods, +For a fully implemented (HTTP) WebDriver client, consider an alternative such as [haskell-webdriver](https://github.com/haskell-webdriver/haskell-webdriver#readme) - -- * HTTP Response - module WebDriverPreCore.HttpResponse, += Which Protocol? - -- * Capabilities - module CoreCapabilities, - module WebDriverPreCore.Capabilities, +- [BiDi](BiDiSpecURL) is a newer websocket protocol. It supports a wider range of features including real-time event subscriptions, improved handling of multiple browsing contexts, and enhanced scripting capabilities. +- [HTML](HTMLSpecURL) is the original WebDriver protocol, primarily focused on browser automation using HTTP requests. It is widely supported by existing WebDriver implementations. - -- * Errors - module WebDriverPreCore.Error, - -- * Action Types - module ActionTypes, +Note that the Bidi protocol is [still evolving](https://github.com/w3c/webdriver-bidi/blob/main/roadmap.md), and API coverage [varies between drivers](https://wpt.fyi/results/webdriver/tests/bidi?label=experimental&label=master&aligned). Depending on your use case and the WebDriver server you are targeting, you may choose to implement either or both protocols. - -- * Auxiliary Spec Types - module AuxTypes, - ) -where +For an introduction to WebDriver Bidi and its use cases, see: -import WebDriverPreCore.Capabilities as CoreCapabilities (FullCapabilities(..), Capabilities(..) ) -import WebDriverPreCore.Capabilities -import WebDriverPreCore.Error -import WebDriverPreCore.HttpResponse -import WebDriverPreCore.SpecDefinition as ActionTypes - ( Action (..), - Actions (..), - KeyAction (..), - Pointer (..), - PointerAction (..), - PointerOrigin (..), - WheelAction (..), - ) -import WebDriverPreCore.SpecDefinition as AuxTypes - ( Cookie (..), - DriverStatus (..), - ElementId (..), - FrameReference (..), - HttpResponse (..), - SameSite (..), - Selector (..), - SessionId (..), - Timeouts (..), - UrlPath (..), - WindowHandle (..), - WindowHandleSpec (..), - WindowRect (..), - ) -import WebDriverPreCore.SpecDefinition as ElementInstanceMethods - ( elementClear, - elementClick, - elementSendKeys, - findElementFromElement, - findElementsFromElement, - getElementAttribute, - getElementComputedLabel, - getElementComputedRole, - getElementCssValue, - getElementProperty, - getElementRect, - getElementShadowRoot, - getElementTagName, - getElementText, - isElementEnabled, - isElementSelected, - takeElementScreenshot, - ) -import WebDriverPreCore.SpecDefinition as ElementMethods - ( findElement, - findElements, - getActiveElement, - ) -import WebDriverPreCore.SpecDefinition as FrameMethods (switchToParentFrame) -import WebDriverPreCore.SpecDefinition as RootMethods (newSession, newSession', status) -import WebDriverPreCore.SpecDefinition as SessionMethods - ( acceptAlert, - addCookie, - back, - closeWindow, - deleteAllCookies, - deleteCookie, - deleteSession, - dismissAlert, - executeScript, - executeScriptAsync, - forward, - fullscreenWindow, - getAlertText, - getAllCookies, - getCurrentUrl, - getNamedCookie, - getPageSource, - getTimeouts, - getTitle, - getWindowHandle, - getWindowHandles, - getWindowRect, - maximizeWindow, - minimizeWindow, - navigateTo, - newWindow, - performActions, - printPage, - refresh, - releaseActions, - sendAlertText, - setTimeouts, - setWindowRect, - switchToFrame, - switchToWindow, - takeScreenshot, - ) -import WebDriverPreCore.SpecDefinition as ShadowDOMMethods (findElementFromShadowRoot, findElementsFromShadowRoot) -import WebDriverPreCore.SpecDefinition as WC3Spec (W3Spec (..)) -import WebDriverPreCore.SpecDefinition as WindowMethods - ( closeWindow, - fullscreenWindow, - getWindowHandles, - getWindowRect, - maximizeWindow, - minimizeWindow, - newWindow, - setWindowRect, - switchToWindow, - ) +- [WebDriver BiDi: Future of browser automation](https://www.youtube.com/watch?v=6oXic6dcn9w) +- [Example of WebDriver BiDi implementation in wdio (TypeScript) framework](https://youtu.be/2TBrFgSkqNE?si=6vl1RlPSjcA18YBy) + += Module Organisation + +Both HTTP and BiDi protocols follow a the same module structure. Each has two modules: + +__1. An API module__ + + Contains type constructors that generate a payload corresponding to each endpoint/command in the relevant WebDriver specification. + +__2. A Protocol module__ + Contains: + + 1. types used by the API functions + + 2. fallback functions that allow the user to generate payloads that diverge from API + +== HTTP + +"WebDriverPreCore.HTTP.API" + + Example: + + @ + -- Calling the API (navigateTo) function to generate the navigation command payload + let goExample :: Command () + goExample = navigateTo (Session "session-id-123") $ MkUrl "https://example.com" + + + -- The result of the API function call contains HTTP request details required for the driver 'WebDriverPreCore.HTTP.Protocol.Command' including the path and body (a JSON payload) if applicable. + + Post + { description = "Navigate To" + , path = + [ "session" , "b07baa96-046a-4e11-ad1e-94eda436502b" , "url" ] + , body = + fromList + [ ( "url" + , String + "https://example.com" + ) + ] + } + @ + +"WebDriverPreCore.HTTP.Protocol" + + Protocol types including 'WebDriverPreCore.HTTP.Protocol.Command', request parameters, and response and error types + such as URL, and Session. + +== BiDi + +"WebDriverPreCore.BiDi.API" + + API functions for BiDi commands and event subscriptions. Each command function returns a 'WebDriverPreCore.BiDi.Protocol.Command' value with the WebSocket message specification and response type. + + Example: + + @ + -- Calling the API function to generate the command payload + let navCommand :: Command NavigateResult + navCommand = browsingContextNavigate MkNavigate + { context = "context-id-123" + , url = "https://example.com" + , wait = Just Interactive + } + + -- The result is a 'WebDriverPreCore.BiDi.Protocol.Command' value with the method and params (a JSON payload) to send to the WebSocket + navCommand = MkCommand + { method = KnownCommand BrowsingContextNavigate + , params = fromList [("context", String "context-id-123"), + ("url", String "https://example.com"), + ("wait", String "interactive")] + } + @ + +"WebDriverPreCore.BiDi.Protocol" + + Protocol types including 'Command', 'Event', request parameters, and response and error types + such as 'KnownCommand'. + += Using this Library to Implement a WebDriver Client + +Implementing a WebDriver client involves: + +1. Writing a runner to send HTTP requests or WebSocket messages to WebDriver +2. Creating some kind of abstraction, such as handles, a typeclass, or the use of an effects library to call the runner and hence lift the static type constructors provided by the API into IO actions. +3. Handling errors using the shared error types + +Example implementations for both BiDi and HTTP runners, in this case using [the handle pattern](https://jaspervdj.be/posts/2018-03-08-handle-pattern.html)), can be found in the [test repository](https://github.com/pyrethrum/webdriver/tree/main/webdriver-precore/test#readme). + +== Example Implementation (Single Endpoint) +Using navigation as an example with both protocols, the client implementation is implemented as follows: + +=== HTTP + +__The Runner__ takes commands and sends HTTP requests to the driver and parses responses (implemented in [HTTP.Runner](https://github.com/pyrethrum/webdriver/blob/main/webdriver-precore/test/HTTP/Runner.hs)) + +__An Actions Type__ mirrors the type API functions with the response wrapped in IO (implemented in [HTTP.Actions](https://github.com/pyrethrum/webdriver/blob/main/webdriver-precore/test/HTTP/Actions.hs)) + +__An Actions Implementation__ an instance of the Actions type that uses the runner to send commands (implemented in [HTTP.Actions](https://github.com/pyrethrum/webdriver/blob/main/webdriver-precore/test/HTTP/Actions.hs)) + +@ +import WebDriverPreCore.HTTP.API qualified as API +import WebDriverPreCore.HTTP.Protocol (Session, URL) + +-- The Actions type +data HttpActions = MkHttpActions + { navigateTo :: Session -> URL -> IO () + , ... + -- the rest of the API + } + +-- The Actions implementation +mkActions :: HttpRunner -> HttpActions +mkActions runner = MkHttpActions + { navigateTo = \sessionId url -> + runner.runHttpCommand $ API.navigateTo sessionId url + , ... + -- the rest of the API + } +@ + +With the above in place, a /run/ or /withActions/ function can be created to provide the user a means to perform WebDriver operations. + +==== User's (of the Client Implementation) Module + +A user of the client implementation would import the Actions module for performing operations and the "WebDriverPreCore.HTTP.Protocol" module for the related types and utility functions. + +@ +import WebDriverPreCore.HTTP.Protocol +import HTTP.Actions +import HTTP.Runner (mkRunner) +import HTTP.DemoUtils (HttpDemo, runDemo, sessionDemo) + +-- >>> runDemo navigate +demoNavigate :: HttpDemo +demoNavigate = + sessionDemo "navigate" action + where + action :: Session -> HttpActions -> IO () + action sesId MkHttpActions {..} = do + navigateTo sesId $ MkUrl "https://example.com/index.html" + +@ + +Full example is available in the [test repository](https://github.com/pyrethrum/webdriver/blob/main/webdriver-precore/test/HTTP/HttpDemo.hs) + +=== BiDi + +A BiDi client implementation follows the same pattern as HTTP, with a runner, actions type, and actions implementation. It is, however, more complicated than HTTP due to the asynchronous nature of WebSocket communication and event handling, the need to create correlation IDs for commands and the need to manage subscriptions for events. + +Example implementations can be found in the [test repository](https://github.com/pyrethrum/webdriver/tree/main/webdriver-precore/test#readme) + += Deprecated Modules (Removal planned ~ 2027-02-01) + +⚠️ The following modules are deprecated. Please migrate to their replacements. + +"WebDriverPreCore.Http" + __Deprecated:__ Use "WebDriverPreCore.HTTP.Protocol" instead + + This module re-exported various HTTP protocol components. The functionality + has been reorganized into the Protocol module. + +"WebDriverPreCore.HTTP.SpecDefinition" (formerly @WebDriverPreCore.Http.SpecDefinition@) + __Deprecated:__ Use "WebDriverPreCore.HTTP.API" instead + + This module contained the HTTP API endpoint functions. It has been renamed + to better reflect the distinction between API (functions) and Protocol (types). + +"WebDriverPreCore.HTTP.HttpResponse" (formerly "WebDriverPreCore.Http.HttpResponse") + __Deprecated:__ This type is implementation specific and has been removed. The parser supplied in this type is now implicit, as the return types of all Commands are instances of 'FromJSON'. + + +== Migration for Deprecated Modules + +See the [ChangeLog](https://github.com/pyrethrum/webdriver/blob/main/webdriver-precore/ChangeLog.md) for details +-} + + +module WebDriverPreCore () where + -- This module is intentionally left empty. It serves as a placeholder for the package documentation. diff --git a/src/WebDriverPreCore/BiDi/API.hs b/src/WebDriverPreCore/BiDi/API.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/BiDi/API.hs @@ -0,0 +1,895 @@ +{-# LANGUAGE CPP #-} + +module WebDriverPreCore.BiDi.API + ( + -- | Type definitions for commands and subscriptions to events defined in the [WebDriver BiDi specification](BiDiSpecURL). + -- + -- Not all commands and subscriptions will be supported by all [BiDi drivers yet](https://wpt.fyi/results/webdriver/tests/bidi?label=experimental&label=master&aligned), as the specification is [still evolving](https://www.w3.org/standards/history/webdriver-bidi/) rapidly. + -- + -- See the demos in the [demos](https://github.com/pyrethrum/webdriver/blob/main/webdriver-precore/test/README.md) for how this module can be used to develop a WebDriver client. + -- + + -- * Session Commands + sessionNew, + sessionStatus, + sessionEnd, + sessionSubscribe, + sessionUnsubscribe, + + -- * BrowsingContext Commands + browsingContextActivate, + browsingContextCaptureScreenshot, + browsingContextClose, + browsingContextCreate, + browsingContextGetTree, + browsingContextHandleUserPrompt, + browsingContextLocateNodes, + browsingContextNavigate, + browsingContextPrint, + browsingContextReload, + browsingContextSetViewport, + browsingContextTraverseHistory, + + -- * Browser Commands + browserClose, + browserCreateUserContext, + browserGetClientWindows, + browserGetUserContexts, + browserRemoveUserContext, + browserSetClientWindowState, + browserSetDownloadBehavior, + + -- * Emulation Commands + emulationSetForcedColorsModeThemeOverride, + emulationSetGeolocationOverride, + emulationSetLocaleOverride, + emulationSetNetworkConditions, + emulationSetScreenOrientationOverride, + emulationSetScreenSettingsOverride, + emulationSetScriptingEnabled, + emulationSetTimezoneOverride, + emulationSetTouchOverride, + emulationSetUserAgentOverride, + + -- * Input Commands + inputPerformActions, + inputReleaseActions, + inputSetFiles, + + -- * Network Commands + networkAddDataCollector, + networkAddIntercept, + networkContinueRequest, + networkContinueResponse, + networkContinueWithAuth, + networkDisownData, + networkFailRequest, + networkGetData, + networkProvideResponse, + networkRemoveDataCollector, + networkRemoveIntercept, + networkSetCacheBehavior, + networkSetExtraHeaders, + + -- * Script Commands + scriptAddPreloadScript, + scriptCallFunction, + scriptDisown, + scriptEvaluate, + scriptGetRealms, + scriptRemovePreloadScript, + + -- * Storage Commands + storageDeleteCookies, + storageGetCookies, + storageSetCookie, + + -- * WebExtension Commands + webExtensionInstall, + webExtensionUninstall, + + -- * Subscriptions + subscribeLogEntryAdded, + subscribeBrowsingContextCreated, + subscribeBrowsingContextDestroyed, + subscribeBrowsingContextNavigationStarted, + subscribeBrowsingContextFragmentNavigated, + subscribeBrowsingContextHistoryUpdated, + subscribeBrowsingContextDomContentLoaded, + subscribeBrowsingContextLoad, + subscribeBrowsingContextDownloadWillBegin, + subscribeBrowsingContextDownloadEnd, + subscribeBrowsingContextNavigationAborted, + subscribeBrowsingContextNavigationCommitted, + subscribeBrowsingContextNavigationFailed, + subscribeBrowsingContextUserPromptClosed, + subscribeBrowsingContextUserPromptOpened, + subscribeNetworkAuthRequired, + subscribeNetworkBeforeRequestSent, + subscribeNetworkFetchError, + subscribeNetworkResponseCompleted, + subscribeNetworkResponseStarted, + subscribeScriptMessage, + subscribeScriptRealmCreated, + subscribeScriptRealmDestroyed, + subscribeInputFileDialogOpened, + subscribeMany, + + -- * Fallback Subscriptions + subscribeOffSpecMany, + ) +where + +import Data.Aeson (Value) +import WebDriverPreCore.BiDi.Protocol + ( Activate, + AddDataCollector, + AddDataCollectorResult, + AddIntercept, + AddInterceptResult, + AddPreloadScript, + AddPreloadScriptResult, + AuthRequired, + BeforeRequestSent, + BrowsingContext, + CallFunction, + Capabilities, + CaptureScreenshot, + CaptureScreenshotResult, + ClientWindowInfo, + Close, + Command, + ContinueRequest, + ContinueResponse, + ContinueWithAuth, + Create, + CreateUserContext, + DeleteCookies, + DeleteCookiesResult, + Disown, + DisownData, + DownloadEnd, + DownloadWillBegin, + Evaluate, + EvaluateResult, + Event, + FailRequest, + FetchError, + FileDialogOpened, + GetClientWindowsResult, + GetCookies, + GetCookiesResult, + GetData, + GetDataResult, + GetRealms, + GetRealmsResult, + GetTree, + GetTreeResult, + GetUserContextsResult, + HandleUserPrompt, + HistoryUpdated, + Info, + KnownCommand (..), + KnownSubscriptionType (..), + LocateNodes, + LocateNodesResult, + LogEntry, + Navigate, + NavigateResult, + NavigationInfo, + PerformActions, + Print, + PrintResult, + ProvideResponse, + RealmDestroyed, + ReleaseActions, + Reload, + RemoveDataCollector, + RemoveIntercept, + RemovePreloadScript, + RemoveUserContext, + ResponseCompleted, + ResponseStarted, + SessionNewResult, + SessionStatusResult, + SessionSubscibe (..), + SessionSubscribeResult (..), + SessionUnsubscribe (..), + SetCacheBehavior, + SetClientWindowState, + SetCookie, + SetCookieResult, + SetDownloadBehavior, + SetExtraHeaders, + SetFiles, + SetForcedColorsModeThemeOverride, + SetGeolocationOverride, + SetLocaleOverride, + SetNetworkConditions, + SetScreenOrientationOverride, + SetScreenSettingsOverride, + SetScriptingEnabled, + SetTimezoneOverride, + SetTouchOverride, + SetUserAgentOverride, + SetViewport, + Subscription, + TraverseHistory, + OffSpecSubscriptionType, + UserContext, + UserPromptClosed, + UserPromptOpened, + WebExtensionInstall, + WebExtensionResult, + WebExtensionUninstall, + emptyCommand, + mkCommand, + mkMultiSubscription, + mkSubscription, + mkOffSpecSubscription, + ) +import WebDriverPreCore.BiDi.Script (Message, RealmInfo) + +--- ############## Commands ############## + +---- Session ---- + +-- | Specification Entry: +-- +-- This function is not supported by many Bidi drivers yet. To start a BiDi session you need to create an HTTP session with a web socket port specified. +-- Creating a new BiDi session via this command may result in a driver error. +-- +-- First added to Spec: +sessionNew :: Capabilities -> Command SessionNewResult +sessionNew = mkCommand SessionNew + +-- | Specification Entry: +-- +-- First added to Spec: +sessionStatus :: Command SessionStatusResult +sessionStatus = emptyCommand SessionStatus + +-- | Specification Entry: +-- +-- Only sessions created via 'sessionNew' can be ended via this command. +-- If the BiDi session was created by other means (e.g. during HTTP session creation with a web socket port), it needs to be ended by ending the HTTP session. +-- +-- First added to Spec: +sessionEnd :: Command () +sessionEnd = emptyCommand SessionEnd + +-- | Specification Entry: +-- +-- First added to Spec: +sessionSubscribe :: SessionSubscibe -> Command SessionSubscribeResult +sessionSubscribe = mkCommand SessionSubscribe + +-- | Specification Entry: +-- +-- First added to Spec: +sessionUnsubscribe :: SessionUnsubscribe -> Command () +sessionUnsubscribe = mkCommand SessionUnsubscribe + +---- Browsing Context ---- + +-- | Specification Entry: +-- +-- First added to Spec: +browsingContextActivate :: Activate -> Command () +browsingContextActivate = mkCommand BrowsingContextActivate + +-- | Specification Entry: +-- +-- First added to Spec: +browsingContextCaptureScreenshot :: CaptureScreenshot -> Command CaptureScreenshotResult +browsingContextCaptureScreenshot = mkCommand BrowsingContextCaptureScreenshot + +-- | Specification Entry: +-- +-- First added to Spec: +browsingContextClose :: Close -> Command () +browsingContextClose = mkCommand BrowsingContextClose + +-- | Specification Entry: +-- +-- First added to Spec: +browsingContextCreate :: Create -> Command BrowsingContext +browsingContextCreate = mkCommand BrowsingContextCreate + +-- | Specification Entry: +-- +-- First added to Spec: +browsingContextGetTree :: GetTree -> Command GetTreeResult +browsingContextGetTree = mkCommand BrowsingContextGetTree + +-- | Specification Entry: +-- +-- First added to Spec: +browsingContextHandleUserPrompt :: HandleUserPrompt -> Command () +browsingContextHandleUserPrompt = mkCommand BrowsingContextHandleUserPrompt + +-- | Specification Entry: +-- +-- First added to Spec: +browsingContextLocateNodes :: LocateNodes -> Command LocateNodesResult +browsingContextLocateNodes = mkCommand BrowsingContextLocateNodes + +-- | Specification Entry: +-- +-- First added to Spec: +browsingContextNavigate :: Navigate -> Command NavigateResult +browsingContextNavigate = mkCommand BrowsingContextNavigate + +-- | Specification Entry: +-- +-- First added to Spec: +browsingContextPrint :: Print -> Command PrintResult +browsingContextPrint = mkCommand BrowsingContextPrint + +-- | Specification Entry: +-- +-- First added to Spec: +browsingContextReload :: Reload -> Command () +browsingContextReload = mkCommand BrowsingContextReload + +-- | Specification Entry: +-- +-- First added to Spec: +browsingContextSetViewport :: SetViewport -> Command () +browsingContextSetViewport = mkCommand BrowsingContextSetViewport + +-- | Specification Entry: +-- +-- First added to Spec: +browsingContextTraverseHistory :: TraverseHistory -> Command () +browsingContextTraverseHistory = mkCommand BrowsingContextTraverseHistory + +---- Browser ---- + +-- | Specification Entry: +-- +-- First added to Spec: +browserClose :: Command () +browserClose = emptyCommand BrowserClose + +-- | Specification Entry: +-- +-- First added to Spec: +browserCreateUserContext :: CreateUserContext -> Command UserContext +browserCreateUserContext = mkCommand BrowserCreateUserContext + +-- | Specification Entry: +-- +-- First added to Spec: +browserGetClientWindows :: Command GetClientWindowsResult +browserGetClientWindows = emptyCommand BrowserGetClientWindows + +-- | Specification Entry: +-- +-- First added to Spec: +browserGetUserContexts :: Command GetUserContextsResult +browserGetUserContexts = emptyCommand BrowserGetUserContexts + +-- | Specification Entry: +-- +-- First added to Spec: +browserRemoveUserContext :: RemoveUserContext -> Command () +browserRemoveUserContext = mkCommand BrowserRemoveUserContext + +-- | Specification Entry: +-- +-- First added to Spec: +browserSetClientWindowState :: SetClientWindowState -> Command ClientWindowInfo +browserSetClientWindowState = mkCommand BrowserSetClientWindowState + +-- since 18-09-2025 https://www.w3.org/TR/2025/WD-webdriver-bidi-20250918 +-- | Specification Entry: +-- +-- First added to Spec: +browserSetDownloadBehavior :: SetDownloadBehavior -> Command () +browserSetDownloadBehavior = mkCommand BrowserSetDownloadBehavior + +---- Emulation ---- + +-- | Specification Entry: +-- +-- First added to Spec: +emulationSetForcedColorsModeThemeOverride :: SetForcedColorsModeThemeOverride -> Command () +emulationSetForcedColorsModeThemeOverride = mkCommand EmulationSetForcedColorsModeThemeOverride + +-- | Specification Entry: +-- +-- First added to Spec: +emulationSetGeolocationOverride :: SetGeolocationOverride -> Command () +emulationSetGeolocationOverride = mkCommand EmulationSetGeolocationOverride + +-- | Specification Entry: +-- +-- First added to Spec: +emulationSetLocaleOverride :: SetLocaleOverride -> Command () +emulationSetLocaleOverride = mkCommand EmulationSetLocaleOverride + +-- since 07-10-2025 https://www.w3.org/TR/2025/WD-webdriver-bidi-20251007 +-- | Specification Entry: +-- +-- First added to Spec: +emulationSetNetworkConditions :: SetNetworkConditions -> Command () +emulationSetNetworkConditions = mkCommand EmulationSetNetworkConditions + +-- | Specification Entry: +-- +-- First added to Spec: +emulationSetScreenOrientationOverride :: SetScreenOrientationOverride -> Command () +emulationSetScreenOrientationOverride = mkCommand EmulationSetScreenOrientationOverride + +-- since 20-11-2025 https://www.w3.org/TR/2025/WD-webdriver-bidi-20251120 +-- | Specification Entry: +-- +-- First added to Spec: +emulationSetScreenSettingsOverride :: SetScreenSettingsOverride -> Command () +emulationSetScreenSettingsOverride = mkCommand EmulationSetScreenSettingsOverride + +-- since 11-08-2025 https://www.w3.org/TR/2025/WD-webdriver-bidi-20250811 +-- | Specification Entry: +-- +-- First added to Spec: +emulationSetScriptingEnabled :: SetScriptingEnabled -> Command () +emulationSetScriptingEnabled = mkCommand EmulationSetScriptingEnabled + +-- | Specification Entry: +-- +-- First added to Spec: +emulationSetTimezoneOverride :: SetTimezoneOverride -> Command () +emulationSetTimezoneOverride = mkCommand EmulationSetTimezoneOverride + +-- since 09-01-2026 https://www.w3.org/TR/2026/WD-webdriver-bidi-20260109 +-- | Specification Entry: +-- +-- First added to Spec: +emulationSetTouchOverride :: SetTouchOverride -> Command () +emulationSetTouchOverride = mkCommand EmulationSetTouchOverride + +-- since 10-09-2025 https://www.w3.org/TR/2025/WD-webdriver-bidi-20250910 +-- | Specification Entry: +-- +-- First added to Spec: +emulationSetUserAgentOverride :: SetUserAgentOverride -> Command () +emulationSetUserAgentOverride = mkCommand EmulationSetUserAgentOverride + +---- Input ---- + +-- | Specification Entry: +-- +-- First added to Spec: +inputPerformActions :: PerformActions -> Command () +inputPerformActions = mkCommand InputPerformActions + +-- | Specification Entry: +-- +-- First added to Spec: +inputReleaseActions :: ReleaseActions -> Command () +inputReleaseActions = mkCommand InputReleaseActions + +-- | Specification Entry: +-- +-- First added to Spec: +inputSetFiles :: SetFiles -> Command () +inputSetFiles = mkCommand InputSetFiles + +---- Network ---- + +-- | Specification Entry: +-- +-- First added to Spec: +networkAddDataCollector :: AddDataCollector -> Command AddDataCollectorResult +networkAddDataCollector = mkCommand NetworkAddDataCollector + +-- | Specification Entry: +-- +-- First added to Spec: +networkAddIntercept :: AddIntercept -> Command AddInterceptResult +networkAddIntercept = mkCommand NetworkAddIntercept + +-- | Specification Entry: +-- +-- First added to Spec: +networkContinueRequest :: ContinueRequest -> Command () +networkContinueRequest = mkCommand NetworkContinueRequest + +-- | Specification Entry: +-- +-- First added to Spec: +networkContinueResponse :: ContinueResponse -> Command () +networkContinueResponse = mkCommand NetworkContinueResponse + +-- | Specification Entry: +-- +-- First added to Spec: +networkContinueWithAuth :: ContinueWithAuth -> Command () +networkContinueWithAuth = mkCommand NetworkContinueWithAuth + +-- | Specification Entry: +-- +-- First added to Spec: +networkDisownData :: DisownData -> Command () +networkDisownData = mkCommand NetworkDisownData + +-- | Specification Entry: +-- +-- First added to Spec: +networkFailRequest :: FailRequest -> Command () +networkFailRequest = mkCommand NetworkFailRequest + +-- | Specification Entry: +-- +-- First added to Spec: +networkGetData :: GetData -> Command GetDataResult +networkGetData = mkCommand NetworkGetData + +-- | Specification Entry: +-- +-- First added to Spec: +networkProvideResponse :: ProvideResponse -> Command () +networkProvideResponse = mkCommand NetworkProvideResponse + +-- | Specification Entry: +-- +-- First added to Spec: +networkRemoveDataCollector :: RemoveDataCollector -> Command () +networkRemoveDataCollector = mkCommand NetworkRemoveDataCollector + +-- | Specification Entry: +-- +-- First added to Spec: +networkRemoveIntercept :: RemoveIntercept -> Command () +networkRemoveIntercept = mkCommand NetworkRemoveIntercept + +-- | Specification Entry: +-- +-- First added to Spec: +networkSetCacheBehavior :: SetCacheBehavior -> Command () +networkSetCacheBehavior = mkCommand NetworkSetCacheBehavior + +-- | Specification Entry: +-- +-- First added to Spec: +networkSetExtraHeaders :: SetExtraHeaders -> Command () +networkSetExtraHeaders = mkCommand NetworkSetExtraHeaders + +---- Script ---- + +-- | Specification Entry: +-- +-- First added to Spec: +scriptAddPreloadScript :: AddPreloadScript -> Command AddPreloadScriptResult +scriptAddPreloadScript = mkCommand ScriptAddPreloadScript + +-- | Specification Entry: +-- +-- First added to Spec: +scriptCallFunction :: CallFunction -> Command EvaluateResult +scriptCallFunction = mkCommand ScriptCallFunction + +-- | Specification Entry: +-- +-- First added to Spec: +scriptDisown :: Disown -> Command () +scriptDisown = mkCommand ScriptDisown + +-- | Specification Entry: +-- +-- First added to Spec: +scriptEvaluate :: Evaluate -> Command EvaluateResult +scriptEvaluate = mkCommand ScriptEvaluate + +-- | Specification Entry: +-- +-- First added to Spec: +scriptGetRealms :: GetRealms -> Command GetRealmsResult +scriptGetRealms = mkCommand ScriptGetRealms + +-- | Specification Entry: +-- +-- First added to Spec: +scriptRemovePreloadScript :: RemovePreloadScript -> Command () +scriptRemovePreloadScript = mkCommand ScriptRemovePreloadScript + +---- Storage ---- + +-- | Specification Entry: +-- +-- First added to Spec: +storageDeleteCookies :: DeleteCookies -> Command DeleteCookiesResult +storageDeleteCookies = mkCommand StorageDeleteCookies + +-- | Specification Entry: +-- +-- First added to Spec: +storageGetCookies :: GetCookies -> Command GetCookiesResult +storageGetCookies = mkCommand StorageGetCookies + +-- | Specification Entry: +-- +-- First added to Spec: +storageSetCookie :: SetCookie -> Command SetCookieResult +storageSetCookie = mkCommand StorageSetCookie + +---- WebExtension ---- + +-- | Specification Entry: +-- +-- First added to Spec: +webExtensionInstall :: WebExtensionInstall -> Command WebExtensionResult +webExtensionInstall = mkCommand WebExtensionInstall + +-- | Specification Entry: +-- +-- First added to Spec: +webExtensionUninstall :: WebExtensionUninstall -> Command () +webExtensionUninstall = mkCommand WebExtensionUninstall + +-- ############## Subscriptions (Events) ############## + +subscribeMany :: + [KnownSubscriptionType] -> + [BrowsingContext] -> + [UserContext] -> + (Event -> m ()) -> + Subscription m +subscribeMany = mkMultiSubscription + +-- | Subscribe to off-specification event types. +-- +-- Use this only as a fallback when a driver supports events not covered by +-- this library. Prefer using the standard subscription functions when available. +subscribeOffSpecMany :: + [OffSpecSubscriptionType] -> + [BrowsingContext] -> + [UserContext] -> + (Value -> m ()) -> + Subscription m +subscribeOffSpecMany = mkOffSpecSubscription + +---- BrowsingContext ---- + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeBrowsingContextCreated :: + [BrowsingContext] -> + [UserContext] -> + (Info -> m ()) -> + Subscription m +subscribeBrowsingContextCreated = mkSubscription BrowsingContextContextCreated + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeBrowsingContextDestroyed :: + [BrowsingContext] -> + [UserContext] -> + (Info -> m ()) -> + Subscription m +subscribeBrowsingContextDestroyed = mkSubscription BrowsingContextContextDestroyed + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeBrowsingContextNavigationStarted :: + [BrowsingContext] -> + [UserContext] -> + (NavigationInfo -> m ()) -> + Subscription m +subscribeBrowsingContextNavigationStarted = mkSubscription BrowsingContextNavigationStarted + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeBrowsingContextFragmentNavigated :: + [BrowsingContext] -> + [UserContext] -> + (NavigationInfo -> m ()) -> + Subscription m +subscribeBrowsingContextFragmentNavigated = mkSubscription BrowsingContextFragmentNavigated + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeBrowsingContextHistoryUpdated :: + [BrowsingContext] -> + [UserContext] -> + (HistoryUpdated -> m ()) -> + Subscription m +subscribeBrowsingContextHistoryUpdated = mkSubscription BrowsingContextHistoryUpdated + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeBrowsingContextDomContentLoaded :: + [BrowsingContext] -> + [UserContext] -> + (NavigationInfo -> m ()) -> + Subscription m +subscribeBrowsingContextDomContentLoaded = mkSubscription BrowsingContextDomContentLoaded + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeBrowsingContextLoad :: + [BrowsingContext] -> + [UserContext] -> + (NavigationInfo -> m ()) -> + Subscription m +subscribeBrowsingContextLoad = mkSubscription BrowsingContextLoad + +subscribeBrowsingContextDownloadWillBegin :: + [BrowsingContext] -> + [UserContext] -> + (DownloadWillBegin -> m ()) -> + Subscription m +subscribeBrowsingContextDownloadWillBegin = mkSubscription BrowsingContextDownloadWillBegin + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeBrowsingContextDownloadEnd :: + [BrowsingContext] -> + [UserContext] -> + (DownloadEnd -> m ()) -> + Subscription m +subscribeBrowsingContextDownloadEnd = mkSubscription BrowsingContextDownloadEnd + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeBrowsingContextNavigationAborted :: + [BrowsingContext] -> + [UserContext] -> + (NavigationInfo -> m ()) -> + Subscription m +subscribeBrowsingContextNavigationAborted = mkSubscription BrowsingContextNavigationAborted + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeBrowsingContextNavigationCommitted :: + [BrowsingContext] -> + [UserContext] -> + (NavigationInfo -> m ()) -> + Subscription m +subscribeBrowsingContextNavigationCommitted = mkSubscription BrowsingContextNavigationCommitted + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeBrowsingContextNavigationFailed :: + [BrowsingContext] -> + [UserContext] -> + (NavigationInfo -> m ()) -> + Subscription m +subscribeBrowsingContextNavigationFailed = mkSubscription BrowsingContextNavigationFailed + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeBrowsingContextUserPromptClosed :: + [BrowsingContext] -> + [UserContext] -> + (UserPromptClosed -> m ()) -> + Subscription m +subscribeBrowsingContextUserPromptClosed = mkSubscription BrowsingContextUserPromptClosed + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeBrowsingContextUserPromptOpened :: + [BrowsingContext] -> + [UserContext] -> + (UserPromptOpened -> m ()) -> + Subscription m +subscribeBrowsingContextUserPromptOpened = mkSubscription BrowsingContextUserPromptOpened + +---- Log ---- + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeLogEntryAdded :: + [BrowsingContext] -> + [UserContext] -> + (LogEntry -> m ()) -> + Subscription m +subscribeLogEntryAdded = mkSubscription LogEntryAdded + +---- Network ---- + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeNetworkAuthRequired :: + [BrowsingContext] -> + [UserContext] -> + (AuthRequired -> m ()) -> + Subscription m +subscribeNetworkAuthRequired = mkSubscription NetworkAuthRequired + +subscribeNetworkBeforeRequestSent :: + [BrowsingContext] -> + [UserContext] -> + (BeforeRequestSent -> m ()) -> + Subscription m +subscribeNetworkBeforeRequestSent = mkSubscription NetworkBeforeRequestSent + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeNetworkFetchError :: + [BrowsingContext] -> + [UserContext] -> + (FetchError -> m ()) -> + Subscription m +subscribeNetworkFetchError = mkSubscription NetworkFetchError + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeNetworkResponseCompleted :: + [BrowsingContext] -> + [UserContext] -> + (ResponseCompleted -> m ()) -> + Subscription m +subscribeNetworkResponseCompleted = mkSubscription NetworkResponseCompleted + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeNetworkResponseStarted :: + [BrowsingContext] -> + [UserContext] -> + (ResponseStarted -> m ()) -> + Subscription m +subscribeNetworkResponseStarted = mkSubscription NetworkResponseStarted + +---- Script ---- + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeScriptMessage :: + [BrowsingContext] -> + [UserContext] -> + (Message -> m ()) -> + Subscription m +subscribeScriptMessage = mkSubscription ScriptMessage + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeScriptRealmCreated :: + [BrowsingContext] -> + [UserContext] -> + (RealmInfo -> m ()) -> + Subscription m +subscribeScriptRealmCreated = mkSubscription ScriptRealmCreated + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeScriptRealmDestroyed :: + [BrowsingContext] -> + [UserContext] -> + (RealmDestroyed -> m ()) -> + Subscription m +subscribeScriptRealmDestroyed = mkSubscription ScriptRealmDestroyed + +---- Input ---- + +-- | Specification Entry: +-- +-- First added to Spec: +subscribeInputFileDialogOpened :: + [BrowsingContext] -> + [UserContext] -> + (FileDialogOpened -> m ()) -> + Subscription m +subscribeInputFileDialogOpened = mkSubscription InputFileDialogOpened diff --git a/src/WebDriverPreCore/BiDi/Browser.hs b/src/WebDriverPreCore/BiDi/Browser.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/BiDi/Browser.hs @@ -0,0 +1,209 @@ +module WebDriverPreCore.BiDi.Browser + ( ClientWindowInfo (..), + ClientWindowState (..), + CreateUserContext (..), + DownloadBehaviour (..), + GetClientWindowsResult (..), + GetUserContextsResult (..), + NamedState (..), + RectState (..), + RemoveUserContext (..), + SetClientWindowState (..), + SetDownloadBehavior (..), + WindowState (..), + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, (.=), KeyValue) +import Data.Aeson.KeyMap (fromList) +import Data.Aeson.Types (Parser) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import GHC.Generics (Generic) +import WebDriverPreCore.BiDi.Capabilities (ProxyConfiguration, UserPromptHandler) +import WebDriverPreCore.BiDi.CoreTypes (ClientWindow, UserContext) +import AesonUtils (enumCamelCase, fromJSONCamelCase, opt) + +-- ######### Remote ######### + +data ClientWindowInfo = MkClientWindowInfo + { active :: Bool, + clientWindow :: ClientWindow, + height :: Int, + state :: ClientWindowState, + width :: Int, + x :: Int, + y :: Int + } + deriving (Show, Eq, Generic) + +instance FromJSON ClientWindowInfo + +data ClientWindowState + = Fullscreen + | Maximized + | Minimized + | Normal + deriving (Show, Eq, Generic) + +instance FromJSON ClientWindowState where + parseJSON :: Value -> Parser ClientWindowState + parseJSON = fromJSONCamelCase + +instance ToJSON ClientWindowState where + toJSON :: ClientWindowState -> Value + toJSON = enumCamelCase + +data CreateUserContext = MkCreateUserContext + { -- renamed from acceptInsecureCerts to insecureCerts to avoid name collision with Capabilities + insecureCerts :: Maybe Bool, + proxy :: Maybe ProxyConfiguration, + unhandledPromptBehavior :: Maybe UserPromptHandler + } + deriving (Show, Eq, Generic) + +instance ToJSON CreateUserContext where + toJSON :: CreateUserContext -> Value + toJSON MkCreateUserContext {insecureCerts, proxy, unhandledPromptBehavior} = + object $ + catMaybes + [ opt "acceptInsecureCerts" insecureCerts, + opt "proxy" proxy, + opt "unhandledPromptBehavior" unhandledPromptBehavior + ] + +newtype RemoveUserContext = MkRemoveUserContext + { userContext :: UserContext + } + deriving (Show, Eq, Generic) + +instance ToJSON RemoveUserContext + +data SetClientWindowState = MkSetClientWindowState + { clientWindow :: ClientWindow, + windowState :: WindowState + } + deriving (Show, Eq, Generic) + +instance ToJSON SetClientWindowState where + toJSON :: SetClientWindowState -> Value + toJSON (MkSetClientWindowState cw ws) = + case ws of + ClientWindowNamedState ns -> + object $ cwProp <> ["state" .= ns] + ClientWindowRectState rs -> + object $ cwProp <> ["state" .= "normal"] + <> recStatePairs rs + where + cwProp = ["clientWindow" .= cw] + +data WindowState + = ClientWindowNamedState NamedState + | ClientWindowRectState RectState + deriving (Show, Eq, Generic) + +instance FromJSON WindowState + +instance ToJSON WindowState where + toJSON :: WindowState -> Value + toJSON = enumCamelCase + +data NamedState + = FullscreenState + | MaximizedState + | MinimizedState + deriving (Show, Eq, Generic) + +instance FromJSON NamedState where + parseJSON :: Value -> Parser NamedState + parseJSON = \case + String "fullscreen" -> pure FullscreenState + String "maximized" -> pure MaximizedState + String "minimized" -> pure MinimizedState + _ -> fail "Expected one of: fullscreen, maximized, minimized" + +instance ToJSON NamedState where + toJSON :: NamedState -> Value + toJSON = \case + FullscreenState -> "fullscreen" + MaximizedState -> "maximized" + MinimizedState -> "minimized" + +data RectState = MkRectState + { width :: Maybe Int, + height :: Maybe Int, + x :: Maybe Int, + y :: Maybe Int + } + deriving (Show, Eq, Generic) + +instance FromJSON RectState + +instance ToJSON RectState where + toJSON :: RectState -> Value + toJSON = + Object . fromList . recStatePairs + + +recStatePairs :: KeyValue e a => RectState -> [a] +recStatePairs MkRectState {width, height, x, y} = + catMaybes + [ opt "width" width, + opt "height" height, + opt "x" x, + opt "y" y + ] + +-- SetDownloadBehavior command types + +data SetDownloadBehavior = MkSetDownloadBehavior + { downloadBehavior :: Maybe DownloadBehaviour, + userContexts :: Maybe [UserContext] + } + deriving (Show, Eq, Generic) + +instance ToJSON SetDownloadBehavior where + toJSON :: SetDownloadBehavior -> Value + toJSON MkSetDownloadBehavior {downloadBehavior, userContexts} = + object $ + ["downloadBehavior" .= downloadBehavior] + <> catMaybes + [ opt "userContexts" userContexts + ] + +data DownloadBehaviour + = AllowedDownload + { destinationFolder :: Text + } + | DeniedDownload + deriving (Show, Eq, Generic) + +instance FromJSON DownloadBehaviour + +instance ToJSON DownloadBehaviour where + toJSON :: DownloadBehaviour -> Value + toJSON (AllowedDownload destinationFolder) = + object + [ "type" .= ("allowed" :: Text), + "destinationFolder" .= destinationFolder + ] + toJSON DeniedDownload = + object + [ "type" .= ("denied" :: Text) + ] + +-- ######### Local ######### + +newtype GetClientWindowsResult = MkGetClientWindowsResult + { clientWindows :: [ClientWindowInfo] + } + deriving (Show, Eq, Generic) + +instance FromJSON GetClientWindowsResult + +newtype GetUserContextsResult = MkGetUserContextsResult + { userContexts :: [UserContext] + } + deriving (Show, Eq, Generic) + +instance FromJSON GetUserContextsResult diff --git a/src/WebDriverPreCore/BiDi/BrowsingContext.hs b/src/WebDriverPreCore/BiDi/BrowsingContext.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/BiDi/BrowsingContext.hs @@ -0,0 +1,631 @@ +module WebDriverPreCore.BiDi.BrowsingContext + ( Activate (..), + CaptureScreenshot (..), + ScreenShotOrigin (..), + ClipRectangle (..), + ImageFormat (..), + Close (..), + Create (..), + CreateType (..), + GetTree (..), + HandleUserPrompt (..), + LocateNodes (..), + Navigate (..), + Print (..), + Orientation (..), + PageRange (..), + Reload (..), + SetViewport (..), + TraverseHistory (..), + MatchType (..), + Locator (..), + ReadinessState (..), + UserPromptType (..), + PrintMargin (..), + PrintPage (..), + Viewport (..), + GetTreeResult (..), + LocateNodesResult (..), + CaptureScreenshotResult (..), + PrintResult (..), + Info (..), + NavigateResult (..), + BrowsingContextEvent (..), + NavigationInfo (..), + DownloadEnd (..), + DownloadWillBegin (..), + HistoryUpdated (..), + UserPromptClosed (..), + UserPromptOpened (..), + Navigation (..), + ) +where + +import Data.Aeson (FromJSON (..), GFromJSON, KeyValue (..), Options (..), ToJSON (..), Value (..), Zero, defaultOptions, genericParseJSON, genericToJSON, object, withObject, (.:), (.=)) +import Data.Aeson.Types (Parser) +import Data.Functor ((<&>)) +import Data.Maybe (catMaybes) +import Data.Text (Text, pack, unpack) +import GHC.Generics ( Generic(Rep) ) +import WebDriverPreCore.BiDi.Capabilities (UserPromptHandlerType) +import WebDriverPreCore.BiDi.CoreTypes (BrowsingContext, JSInt, JSUInt, NodeRemoteValue, UserContext, KnownSubscriptionType (..), ClientWindow, URL (..)) +import WebDriverPreCore.BiDi.Script (SharedReference) +import AesonUtils (enumCamelCase, fromJSONCamelCase, opt, parseJSONOmitNothing, toJSONOmitNothing) + +-- ######### REMOTE ######### + +-- | for activate command +newtype Activate = MkActivate + { context :: BrowsingContext + } + deriving (Show, Eq, Generic) + +instance ToJSON Activate + +-- | for captureScreenshot command +data CaptureScreenshot = MkCaptureScreenshot + { context :: BrowsingContext, + origin :: Maybe ScreenShotOrigin, + format :: Maybe ImageFormat, + clip :: Maybe ClipRectangle + } + deriving (Show, Eq, Generic) + +instance ToJSON CaptureScreenshot where + toJSON :: CaptureScreenshot -> Value + toJSON (MkCaptureScreenshot {context, origin, format, clip}) = + object $ + [ "context" .= context + ] + <> catMaybes + [ opt "origin" origin, + opt "format" format, + opt "clip" clip + ] + +data ScreenShotOrigin = Viewport | Document deriving (Show, Eq, Generic) + +instance ToJSON ScreenShotOrigin where + toJSON :: ScreenShotOrigin -> Value + toJSON = enumCamelCase + +-- | Clip rectangle for screenshots +data ClipRectangle + = BoxClipRectangle + { x :: Float, + y :: Float, + width :: Float, + height :: Float + } + | ElementClipRectangle + { element :: Text -- script.SharedReference + } + deriving (Show, Eq, Generic) + +instance ToJSON ClipRectangle where + toJSON :: ClipRectangle -> Value + toJSON = \case + BoxClipRectangle {x, y, width, height} -> + object + [ "type" .= "box", + "x" .= x, + "y" .= y, + "width" .= width, + "height" .= height + ] + ElementClipRectangle {element} -> + object + [ "type" .= "element", + "element" .= element + ] + +-- | Image format specification +data ImageFormat = MkImageFormat + { imageType :: Text, + quality :: Maybe Float + } + deriving (Show, Eq, Generic) + +instance ToJSON ImageFormat where + toJSON :: ImageFormat -> Value + toJSON (MkImageFormat {imageType, quality}) = + object $ + [ "type" .= imageType + ] + <> catMaybes + [ opt "quality" quality + ] + +-- | for close command +data Close = MkClose + { context :: BrowsingContext, + promptUnload :: Maybe Bool + } + deriving (Show, Eq, Generic) + +instance ToJSON Close where + toJSON :: Close -> Value + toJSON (MkClose {context, promptUnload}) = + object $ + [ "context" .= context + ] + <> catMaybes + [ opt "promptUnload" promptUnload + ] + +-- | for create command +data Create = MkCreate + { createType :: CreateType, + background :: Bool, + referenceContext :: Maybe BrowsingContext, + userContext :: Maybe UserContext + } + deriving (Show, Eq, Generic) + +instance ToJSON Create where + toJSON :: Create -> Value + toJSON (MkCreate {createType, referenceContext, background, userContext}) = + object $ + [ "type" .= createType, + "background" .= background + ] + <> catMaybes + [ opt "referenceContext" referenceContext, + opt "userContext" userContext + ] + +-- | for getTree command +data GetTree = MkGetTree + { maxDepth :: Maybe JSUInt, + root :: Maybe BrowsingContext + } + deriving (Show, Eq, Generic) + +instance ToJSON GetTree where + toJSON :: GetTree -> Value + toJSON = toJSONOmitNothing + +-- | for handleUserPrompt command +data HandleUserPrompt = MkHandleUserPrompt + { context :: BrowsingContext, + accept :: Maybe Bool, + userText :: Maybe Text + } + deriving (Show, Eq, Generic) + +instance ToJSON HandleUserPrompt where + toJSON :: HandleUserPrompt -> Value + toJSON = genericToJSON defaultOptions {omitNothingFields = True} + +-- | for locateNodes command +data LocateNodes = MkLocateNodes + { context :: BrowsingContext, + locator :: Locator, + maxNodeCount :: Maybe JSUInt, + serializationOptions :: Maybe Value, -- script.SerializationOptions + startNodes :: Maybe [SharedReference] -- script.SharedReference + } + deriving (Show, Eq, Generic) + +instance ToJSON LocateNodes where + toJSON :: LocateNodes -> Value + toJSON = toJSONOmitNothing + +-- | for navigate command +data Navigate = MkNavigate + { context :: BrowsingContext, + url :: URL, + wait :: Maybe ReadinessState + } + deriving (Show, Eq, Generic) + +instance ToJSON Navigate where + toJSON :: Navigate -> Value + toJSON = toJSONOmitNothing + +-- | for print command +data Print = MkPrint + { context :: BrowsingContext, + background :: Maybe Bool, + margin :: Maybe PrintMargin, + orientation :: Maybe Orientation, + page :: Maybe PrintPage, + pageRanges :: Maybe [PageRange], + scale :: Maybe Float, + shrinkToFit :: Maybe Bool + } + deriving (Show, Eq, Generic) + +instance ToJSON Print where + toJSON :: Print -> Value + toJSON = toJSONOmitNothing + +data Orientation = Portrait | Landscape deriving (Show, Eq, Generic) + +instance ToJSON Orientation where + toJSON :: Orientation -> Value + toJSON = enumCamelCase + +data PageRange + = Page Word + | Range + { fromPage :: Word, + toPage :: Word + } + deriving (Show, Eq) + +instance ToJSON PageRange where + toJSON :: PageRange -> Value + toJSON = \case + Page p -> Number $ fromIntegral p + Range {fromPage, toPage} -> String (pack (show fromPage <> "-" <> show toPage)) + +-- | for reload command +data Reload = MkReload + { context :: BrowsingContext, + ignoreCache :: Maybe Bool, + wait :: Maybe ReadinessState + } + deriving (Show, Eq, Generic) + +instance ToJSON Reload where + toJSON :: Reload -> Value + toJSON = toJSONOmitNothing + +-- | for setViewport command +data SetViewport = MkSetViewport + { context :: Maybe BrowsingContext, + viewport :: Maybe (Maybe Viewport), -- Viewport or null + devicePixelRatio :: Maybe (Maybe Float), -- Float or null + userContexts :: Maybe [Text] -- browser.UserContext + } + deriving (Show, Eq, Generic) + +instance ToJSON SetViewport where + toJSON :: SetViewport -> Value + toJSON = toJSONOmitNothing + +-- | for traverseHistory command +data TraverseHistory = MkTraverseHistory + { context :: BrowsingContext, + delta :: JSInt + } + deriving (Show, Eq, Generic) + +-- | Text matching type for InnerText locator +data MatchType = Full | Partial + deriving (Show, Eq, Generic) + +instance ToJSON MatchType where + toJSON :: MatchType -> Value + toJSON = enumCamelCase + +-- | Different types of locators for elements +data Locator + = Accessibility + { name :: Maybe Text, + role :: Maybe Text + } + | CSS + { value :: Text + } + | Context + { context :: BrowsingContext + } + | InnerText + { value :: Text, + ignoreCase :: Maybe Bool, + matchType :: Maybe MatchType, + maxDepth :: Maybe JSUInt + } + | XPath + { value :: Text + } + deriving (Show, Eq) + +instance ToJSON Locator where + toJSON :: Locator -> Value + toJSON = \case + Accessibility {name, role} -> + object $ + [ "type" .= "accessibility", + "value" + .= ( object $ + catMaybes + [ opt "name" name, + opt "role" role + ] + ) + ] + CSS {value} -> + object + [ "type" .= "css", + "value" .= value + ] + Context {context} -> + object + [ "type" .= "context", + "value" .= object ["context" .= context] + ] + InnerText {value, ignoreCase, matchType, maxDepth} -> + object $ + [ "type" .= "innerText", + "value" .= value + ] + <> catMaybes + [ opt "ignoreCase" ignoreCase, + opt "matchType" matchType, + opt "maxDepth" maxDepth + ] + XPath {value} -> + object + [ "type" .= "xpath", + "value" .= value + ] + +-- | Readiness state of a browsing context +data ReadinessState = None | Interactive | Complete + deriving (Show, Eq, Generic) + +instance ToJSON ReadinessState where + toJSON :: ReadinessState -> Value + toJSON = enumCamelCase + +-- | User prompt types +data UserPromptType = Alert | BeforeUnload | Confirm | Prompt + deriving (Show, Eq, Generic) + +instance ToJSON UserPromptType where + toJSON :: UserPromptType -> Value + toJSON = enumCamelCase + +instance FromJSON UserPromptType where + parseJSON :: Value -> Parser UserPromptType + parseJSON = fromJSONCamelCase + +-- | Type of browsing context to create +data CreateType = Tab | Window + deriving (Show, Eq, Generic) + +instance ToJSON CreateType where + toJSON :: CreateType -> Value + toJSON = enumCamelCase + +-- | Print margin +data PrintMargin = MkPrintMargin + { bottom :: Maybe Float, + left :: Maybe Float, + right :: Maybe Float, + top :: Maybe Float + } + deriving (Show, Eq, Generic) + +-- | Print page +data PrintPage = MkPrintPage + { height :: Maybe Float, + width :: Maybe Float + } + deriving (Show, Eq, Generic) + +-- | Viewport dimensions +data Viewport = MkViewport + { width :: JSUInt, + height :: JSUInt + } + deriving (Show, Eq, Generic) + +-- ######### Local ######### + +instance FromJSON NavigateResult + +newtype GetTreeResult = MkGetTreeResult + { contexts :: [Info] + } + deriving stock (Show, Eq, Generic) + +instance FromJSON GetTreeResult + +newtype LocateNodesResult = MkLocateNodesResult + { nodes :: [NodeRemoteValue] + } + deriving newtype (Show, Eq) + deriving stock (Generic) + +instance FromJSON LocateNodesResult + +newtype CaptureScreenshotResult = MkCaptureScreenshotResult + { base64Text :: Text + } + deriving newtype (Show, Eq) + +parseTextData :: Text -> Value -> Parser Text +parseTextData description = withObject (unpack description) $ flip (.:) "data" + +instance FromJSON CaptureScreenshotResult where + parseJSON :: Value -> Parser CaptureScreenshotResult + parseJSON = fmap MkCaptureScreenshotResult . parseTextData "CaptureScreenshotResult" + +newtype PrintResult = MkPrintResult + { base64Text :: Text + } + deriving newtype (Show, Eq) + +instance FromJSON PrintResult where + parseJSON :: Value -> Parser PrintResult + parseJSON = fmap MkPrintResult . parseTextData "PrintResult" + +data Info = MkInfo + { children :: Maybe [Info], + clientWindow :: ClientWindow, + context :: BrowsingContext, + originalOpener :: Maybe BrowsingContext, + url :: URL, + userContext :: UserContext, + parent :: Maybe BrowsingContext + } + deriving (Show, Eq, Generic) + +instance FromJSON Info where + parseJSON :: Value -> Parser Info + parseJSON = parseJSONOmitNothing + +data NavigateResult = MkNavigateResult + { navigation :: Maybe Text, + url :: URL + } + deriving (Show, Eq, Generic) + +-- | Event from a browsing context +data BrowsingContextEvent + = ContextCreated Info + | ContextDestroyed Info + | DomContentLoaded NavigationInfo + | DownloadEnd + | DownloadWillBegin DownloadWillBegin + | FragmentNavigated NavigationInfo + | HistoryUpdated HistoryUpdated + | Load NavigationInfo + | NavigationAborted NavigationInfo + | NavigationCommitted NavigationInfo + | NavigationFailed NavigationInfo + | NavigationStarted NavigationInfo + | UserPromptClosed UserPromptClosed + | UserPromptOpened UserPromptOpened + deriving (Show, Eq, Generic) + +instance FromJSON BrowsingContextEvent where + parseJSON :: Value -> Parser BrowsingContextEvent + parseJSON = withObject "BrowsingContextEvent" $ \o -> do + typ <- o .: "method" + params <- o .: "params" + let parsedPrms :: forall a b. (FromJSON a) => (a -> b) -> Parser b + parsedPrms = (<&>) (parseJSON params) + case typ of + BrowsingContextContextCreated -> parsedPrms ContextCreated + BrowsingContextContextDestroyed -> parsedPrms ContextDestroyed + BrowsingContextDomContentLoaded -> parsedPrms DomContentLoaded + BrowsingContextDownloadEnd -> pure DownloadEnd + BrowsingContextDownloadWillBegin -> parsedPrms DownloadWillBegin + BrowsingContextFragmentNavigated -> parsedPrms FragmentNavigated + BrowsingContextHistoryUpdated -> parsedPrms HistoryUpdated + BrowsingContextLoad -> parsedPrms Load + BrowsingContextNavigationAborted -> parsedPrms NavigationAborted + BrowsingContextNavigationCommitted -> parsedPrms NavigationCommitted + BrowsingContextNavigationFailed -> parsedPrms NavigationFailed + BrowsingContextNavigationStarted -> parsedPrms NavigationStarted + BrowsingContextUserPromptClosed -> parsedPrms UserPromptClosed + BrowsingContextUserPromptOpened -> parsedPrms UserPromptOpened + _ -> fail $ "Unknown BrowsingContextEvent type: " <> show typ + +data NavigationInfo = MkNavigationInfo + { context :: BrowsingContext, + navigation :: Maybe Navigation, + timestamp :: JSUInt, + url :: URL + } + deriving (Show, Eq, Generic) + +instance FromJSON NavigationInfo where + parseJSON :: Value -> Parser NavigationInfo + parseJSON = parseJSONOmitNothing + +data DownloadEnd + = DownloadCompleted + { filePath :: Maybe Text, + navigationInfo :: NavigationInfo + } + | DownloadCanceled {navigationInfo :: NavigationInfo} + deriving (Show, Eq, Generic) + +instance FromJSON DownloadEnd where + parseJSON :: Value -> Parser DownloadEnd + parseJSON = withObject "DownloadEnd" $ \v -> do + status <- v .: "status" + case status of + "complete" -> do + filePath <- v .: "filepath" + context <- v .: "context" + navigation <- v .: "navigation" + timestamp <- v .: "timestamp" + url <- v .: "url" + let navigationInfo = MkNavigationInfo {context, navigation, timestamp, url} + pure $ DownloadCompleted {filePath, navigationInfo} + "canceled" -> do + context <- v .: "context" + navigation <- v .: "navigation" + timestamp <- v .: "timestamp" + url <- v .: "url" + let navigationInfo = MkNavigationInfo {context, navigation, timestamp, url} + pure $ DownloadCanceled {navigationInfo} + _ -> fail $ "Unknown DownloadEnd status: " <> unpack status + +data DownloadWillBegin = MkDownloadWillBegin + { suggestedFilename :: Text, + context :: BrowsingContext, + navigation :: Maybe Navigation, + timestamp :: JSUInt, + url :: URL + } + deriving (Show, Eq, Generic) + +instance FromJSON DownloadWillBegin where + parseJSON :: Value -> Parser DownloadWillBegin + parseJSON = parseJSONOmitNothing + +data HistoryUpdated = MkHistoryUpdated + { context :: BrowsingContext, + timestamp :: JSUInt, + url :: URL + } + deriving (Show, Eq, Generic) + +instance FromJSON HistoryUpdated + +data UserPromptClosed = MkUserPromptClosed + { context :: BrowsingContext, + accepted :: Bool, + promptType :: UserPromptType, + userText :: Maybe Text + } + deriving (Show, Eq, Generic) + +promptParser :: forall a. (Generic a, GFromJSON Zero (Rep a)) => Value -> Parser a +promptParser = + genericParseJSON + defaultOptions + { fieldLabelModifier = \case + "promptType" -> "type" + other -> other, + omitNothingFields = True + } + +instance FromJSON UserPromptClosed where + parseJSON :: Value -> Parser UserPromptClosed + parseJSON = promptParser + +data UserPromptOpened = MkUserPromptOpened + { context :: BrowsingContext, + handler :: UserPromptHandlerType, + message :: Text, + promptType :: UserPromptType, + defaultValue :: Maybe Text + } + deriving (Show, Eq, Generic) + +instance FromJSON UserPromptOpened where + parseJSON :: Value -> Parser UserPromptOpened + parseJSON = promptParser + +newtype Navigation = MkNavigation + { navigationId :: Text + } + deriving (Show, Eq, Generic) + deriving newtype (FromJSON) + +instance ToJSON TraverseHistory + +instance ToJSON PrintMargin + +instance ToJSON PrintPage + +instance ToJSON Viewport diff --git a/src/WebDriverPreCore/BiDi/Capabilities.hs b/src/WebDriverPreCore/BiDi/Capabilities.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/BiDi/Capabilities.hs @@ -0,0 +1,181 @@ +module WebDriverPreCore.BiDi.Capabilities + ( Capabilities (..), + Capability (..), + ProxyConfiguration (..), + SocksProxyConfiguration (..), + UserPromptHandler (..), + UserPromptHandlerType (..), + CapabilitiesResult (..), + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, (.=)) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Vector (fromList) +import Data.Word (Word8) +import GHC.Generics (Generic) +import AesonUtils (opt, fromJSONCamelCase) +import Data.Aeson.Types (Parser) + + + +-- | Capabilities Request +data Capabilities = MkCapabilities + { alwaysMatch :: Maybe Capability, + firstMatch :: [Capability] + } + deriving (Show, Eq, Generic) + +instance ToJSON Capabilities where + toJSON :: Capabilities -> Value + toJSON MkCapabilities {alwaysMatch, firstMatch} = + object $ + [ "capabilities" .= (object $ catMaybes [opt "alwaysMatch" $ alwaysMatch]), + "firstMatch" .= firstMatch' + ] + where + firstMatch' :: Value + firstMatch' = Array . Data.Vector.fromList $ toJSON <$> firstMatch + +-- | Capability Request +data Capability = MkCapability + { acceptInsecureCerts :: Maybe Bool, + browserName :: Maybe Text, + browserVersion :: Maybe Text, + -- Always true for BiDi + webSocketUrl :: Bool, + platformName :: Maybe Text, + proxy :: Maybe ProxyConfiguration, + unhandledPromptBehavior :: Maybe UserPromptHandler + } + deriving (Show, Eq, Generic) + +instance ToJSON Capability + +-- | Proxy Configuration +data ProxyConfiguration + = AutodetectProxyConfiguration + | DirectProxyConfiguration + | ManualProxyConfiguration + { httpProxy :: Maybe Text, + sslProxy :: Maybe Text, + socksProxyConfig :: Maybe SocksProxyConfiguration, + noProxy :: Maybe [Text] + } + | PacProxyConfiguration + { proxyAutoconfigUrl :: Text + } + | SystemProxyConfiguration + deriving (Show, Eq, Generic) + +instance FromJSON ProxyConfiguration + +instance ToJSON ProxyConfiguration where + toJSON :: ProxyConfiguration -> Value + toJSON = \case + AutodetectProxyConfiguration -> object ["proxyType" .= ("autodetect" :: Text)] + DirectProxyConfiguration -> object ["proxyType" .= ("direct" :: Text)] + ManualProxyConfiguration {httpProxy, sslProxy, socksProxyConfig, noProxy} -> + object + [ "proxyType" .= ("manual" :: Text), + "httpProxy" .= httpProxy, + "sslProxy" .= sslProxy, + "socksProxy" .= socksProxyConfig, + "noProxy" .= noProxy + ] + PacProxyConfiguration proxyAutoconfigUrl -> + object ["proxyType" .= ("pac" :: Text), "proxyAutoconfigUrl" .= proxyAutoconfigUrl] + SystemProxyConfiguration -> object ["proxyType" .= ("system" :: Text)] + +instance FromJSON SocksProxyConfiguration + +instance ToJSON SocksProxyConfiguration where + toJSON :: SocksProxyConfiguration -> Value + toJSON (MkSocksProxyConfiguration socksProxy socksVersion) = + object + [ "socksProxy" .= socksProxy, + "socksVersion" .= socksVersion + ] + +-- | Socks Proxy Configuration +data SocksProxyConfiguration = MkSocksProxyConfiguration + { socksProxy :: Text, + socksVersion :: Word8 + } + deriving (Show, Eq, Generic) + +-- | User Prompt Handler +data UserPromptHandler = MkUserPromptHandler + { alert :: Maybe UserPromptHandlerType, + beforeUnload :: Maybe UserPromptHandlerType, + confirm :: Maybe UserPromptHandlerType, + defaultHandler :: Maybe UserPromptHandlerType, + fileHandler :: Maybe UserPromptHandlerType, + prompt :: Maybe UserPromptHandlerType + } + deriving (Show, Eq, Generic) + +instance FromJSON UserPromptHandler + +instance ToJSON UserPromptHandler where + toJSON :: UserPromptHandler -> Value + toJSON (MkUserPromptHandler alert beforeUnload confirm defaultHandler fileHandler prompt) = + object + [ "alert" .= alert, + "beforeUnload" .= beforeUnload, + "confirm" .= confirm, + "defaultHandler" .= defaultHandler, + "fileHandler" .= fileHandler, + "prompt" .= prompt + ] + +-- | User Prompt Handler Type +data UserPromptHandlerType + = Accept + | Dismiss + | Ignore + deriving (Show, Eq, Generic) + +instance FromJSON UserPromptHandlerType where + parseJSON :: Value -> Parser UserPromptHandlerType + parseJSON = fromJSONCamelCase + +instance ToJSON UserPromptHandlerType where + toJSON :: UserPromptHandlerType -> Value + toJSON = \case + Accept -> "accept" + Dismiss -> "dismiss" + Ignore -> "ignore" + + +-- | Capabilities Result +data CapabilitiesResult = MkCapabilitiesResult + { acceptInsecureCerts :: Bool, + browserName :: Text, + browserVersion :: Text, + platformName :: Text, + setWindowRect :: Bool, + userAgent :: Text, + proxy :: Maybe ProxyConfiguration, + unhandledPromptBehavior :: Maybe UserPromptHandler, + webSocketUrl :: Maybe Text + } + deriving (Show, Eq, Generic) + +instance ToJSON CapabilitiesResult where + toJSON :: CapabilitiesResult -> Value + toJSON (MkCapabilitiesResult acceptInsecureCerts browserName browserVersion platformName setWindowRect userAgent proxy unhandledPromptBehavior webSocketUrl) = + object + [ "acceptInsecureCerts" .= acceptInsecureCerts, + "browserName" .= browserName, + "browserVersion" .= browserVersion, + "platformName" .= platformName, + "setWindowRect" .= setWindowRect, + "userAgent" .= userAgent, + "proxy" .= proxy, + "unhandledPromptBehavior" .= unhandledPromptBehavior, + "webSocketUrl" .= webSocketUrl + ] + +instance FromJSON CapabilitiesResult diff --git a/src/WebDriverPreCore/BiDi/Command.hs b/src/WebDriverPreCore/BiDi/Command.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/BiDi/Command.hs @@ -0,0 +1,365 @@ +module WebDriverPreCore.BiDi.Command + ( Command (..), + CommandMethod (..), + KnownCommand (..), + OffSpecCommand (..), + mkCommand, + emptyCommand, + mkOffSpecCommand, + extendLoosenCommand, + extendCommand, + extendCoerceCommand, + loosenCommand, + coerceCommand, + knownCommandToText, + toCommandText, + ) +where + +import AesonUtils (jsonToText, objectOrThrow) +import Control.Applicative (Alternative (..)) +import Data.Aeson + ( Object, + ToJSON, + Value (..), + ) +import Data.Aeson.KeyMap qualified as KM +import Data.Aeson.Types (FromJSON (parseJSON), Parser, ToJSON (..)) +import Data.Text as T (Text, intercalate, unpack) +import Utils (enumerate) + +-- | A BiDi Command to be sent over the WebSocket connection. +-- +-- All functions in "WebDriverPreCore.BiDi.API" return values of this type. +-- +-- The command contains the method name and parameters to be serialized as JSON and a phantom response type @r@, which is always an instance of 'FromJSON'. +data Command r = MkCommand + { -- | An identifier for the command to be invoked + method :: CommandMethod, + -- | The JSON payload to be sent + params :: Object + } + deriving (Show, Eq) + +-- | The method name of a BiDi command. +-- +-- This library provides known commands as 'KnownCommand' values, but users can also create off-spec commands using 'OffSpecCommand' as a fallback, when the driver supports commands not yet implemented in this library. +data CommandMethod + = KnownCommand KnownCommand + | OffSpecCommand OffSpecCommand + deriving (Show, Eq) + +instance ToJSON CommandMethod where + toJSON :: CommandMethod -> Value + toJSON = String . toCommandText + +-- | This type enumerates the BiDi commands known to this library. +data KnownCommand + = BrowserClose + | BrowserCreateUserContext + | BrowserGetClientWindows + | BrowserGetUserContexts + | BrowserRemoveUserContext + | BrowserSetClientWindowState + | BrowserSetDownloadBehavior + | BrowsingContextActivate + | BrowsingContextCaptureScreenshot + | BrowsingContextClose + | BrowsingContextCreate + | BrowsingContextGetTree + | BrowsingContextHandleUserPrompt + | BrowsingContextLocateNodes + | BrowsingContextNavigate + | BrowsingContextPrint + | BrowsingContextReload + | BrowsingContextSetViewport + | BrowsingContextTraverseHistory + | EmulationSetForcedColorsModeThemeOverride + | EmulationSetGeolocationOverride + | EmulationSetLocaleOverride + | EmulationSetNetworkConditions + | EmulationSetScreenOrientationOverride + | EmulationSetScreenSettingsOverride + | EmulationSetScriptingEnabled + | EmulationSetTimezoneOverride + | EmulationSetTouchOverride + | EmulationSetUserAgentOverride + | InputPerformActions + | InputReleaseActions + | InputSetFiles + | NetworkAddDataCollector + | NetworkAddIntercept + | NetworkContinueRequest + | NetworkContinueResponse + | NetworkContinueWithAuth + | NetworkDisownData + | NetworkFailRequest + | NetworkGetData + | NetworkProvideResponse + | NetworkRemoveDataCollector + | NetworkRemoveIntercept + | NetworkSetCacheBehavior + | NetworkSetExtraHeaders + | ScriptAddPreloadScript + | ScriptCallFunction + | ScriptDisown + | ScriptEvaluate + | ScriptGetRealms + | ScriptRemovePreloadScript + | SessionEnd + | SessionNew + | SessionStatus + | SessionSubscribe + | SessionUnsubscribe + | StorageDeleteCookies + | StorageGetCookies + | StorageSetCookie + | WebExtensionInstall + | WebExtensionUninstall + deriving (Show, Eq, Enum, Bounded) + +-- | The method name of a BiDi command not yet implemented in this library +newtype OffSpecCommand = MkOffSpecCommand {command :: Text} + deriving (Show, Eq) + deriving newtype (FromJSON, ToJSON) + +-- constructors + +-- | Creates a 'Command' with the given 'KnownCommand' method and parameters. +-- +-- Patially applied in "WebDriverPreCore.BiDi.API" to generate specific named command functions which accept only an input type, relevant to that command. +-- The input type must be an instance of 'ToJSON' and encode to a JSON 'Object' type. +-- +-- E.g. the 'WebDriverPreCore.BiDi.API.browsingContextNavigate', which takes a 'Navigate' input and returns a 'Command' with a 'NavigateResult' output, is defined by the partial application of 'mkCommand': +-- +-- @ +-- browsingContextNavigate :: Navigate -> Command NavigateResult +-- browsingContextNavigate = mkCommand BrowsingContextNavigate +-- @ +mkCommand :: + forall c r. + (ToJSON c) => + -- | The identitifier for the command to be invoked + KnownCommand -> + -- | The parameters to be sent with the command + c -> + -- | A 'Command' value with the given method and parameters + Command r +mkCommand method params = MkCommand {method = KnownCommand method, params = objectOrThrow ("mkCommand - " <> toCommandText (KnownCommand method)) params} + +-- | Creates a 'Command' with the given 'KnownCommand' method and no parameters. +-- This is the same as calling 'mkCommand' with an empty object as parameters. +-- +-- E.g. the 'WebDriverPreCore.BiDi.API.browserGetClientWindows', which takes no input and returns a 'Command' with a list of 'WindowInfo' output, is defined by the partial application of 'emptyCommand': +-- +-- @ +-- browserGetClientWindows :: Command [WindowInfo] +-- browserGetClientWindows = emptyCommand BrowserGetClientWindows +-- @ +emptyCommand :: + forall r. + -- | The identitifier for the command to be invoked + KnownCommand -> + -- | A 'Command' value with the given method and no parameters + Command r +emptyCommand method = MkCommand {method = KnownCommand method, params = KM.empty} + +-- fallback modifiers + +-- | Creates a 'Command' with the given method name text, JSON Object parameters, and an expected JSON Object response. +mkOffSpecCommand :: Text -> Object -> Command Object +mkOffSpecCommand method = MkCommand (OffSpecCommand $ MkOffSpecCommand method) + +-- | Extends the parameters of a 'Command' with additional fields from a JSON 'Object', changing the expected response type to a generic JSON 'Value'. +extendLoosenCommand :: forall r. Object -> Command r -> Command Value +extendLoosenCommand = extendCoerceCommand + +-- | Extends the parameters of a 'Command' with additional fields from a JSON 'Object', preserving the expected response type. +extendCommand :: forall r. Object -> Command r -> Command r +extendCommand = extendCoerceCommand + +-- | Extends the parameters of a 'Command' with additional fields from a JSON 'Object', changing the expected response type to a different type. +extendCoerceCommand :: forall r r2. Object -> Command r -> Command r2 +extendCoerceCommand extended MkCommand {method, params} = + MkCommand + { method, + params = params <> extended + } + +-- | Changes the expected response type of a 'Command' to a generic JSON 'Value'. +loosenCommand :: forall r. Command r -> Command Value +loosenCommand = coerceCommand + +-- | Changes the expected response type of a 'Command' to a different type. +coerceCommand :: forall r r'. Command r -> Command r' +coerceCommand MkCommand {method, params} = MkCommand {method, params} + +instance ToJSON KnownCommand where + toJSON :: KnownCommand -> Value + toJSON = String . knownCommandToText + +instance FromJSON KnownCommand where + parseJSON :: Value -> Parser KnownCommand + parseJSON = + \case + String c -> case c of + "browser.close" -> p BrowserClose + "browser.createUserContext" -> p BrowserCreateUserContext + "browser.getClientWindows" -> p BrowserGetClientWindows + "browser.getUserContexts" -> p BrowserGetUserContexts + "browser.removeUserContext" -> p BrowserRemoveUserContext + "browser.setClientWindowState" -> p BrowserSetClientWindowState + "browser.setDownloadBehavior" -> p BrowserSetDownloadBehavior + "browsingContext.activate" -> p BrowsingContextActivate + "browsingContext.captureScreenshot" -> p BrowsingContextCaptureScreenshot + "browsingContext.close" -> p BrowsingContextClose + "browsingContext.create" -> p BrowsingContextCreate + "browsingContext.getTree" -> p BrowsingContextGetTree + "browsingContext.handleUserPrompt" -> p BrowsingContextHandleUserPrompt + "browsingContext.locateNodes" -> p BrowsingContextLocateNodes + "browsingContext.navigate" -> p BrowsingContextNavigate + "browsingContext.print" -> p BrowsingContextPrint + "browsingContext.reload" -> p BrowsingContextReload + "browsingContext.setViewport" -> p BrowsingContextSetViewport + "browsingContext.traverseHistory" -> p BrowsingContextTraverseHistory + "emulation.setForcedColorsModeThemeOverride" -> p EmulationSetForcedColorsModeThemeOverride + "emulation.setGeolocationOverride" -> p EmulationSetGeolocationOverride + "emulation.setLocaleOverride" -> p EmulationSetLocaleOverride + "emulation.setNetworkConditions" -> p EmulationSetNetworkConditions + "emulation.setScreenOrientationOverride" -> p EmulationSetScreenOrientationOverride + "emulation.setScreenSettingsOverride" -> p EmulationSetScreenSettingsOverride + "emulation.setScriptingEnabled" -> p EmulationSetScriptingEnabled + "emulation.setTimezoneOverride" -> p EmulationSetTimezoneOverride + "emulation.setTouchOverride" -> p EmulationSetTouchOverride + "emulation.setUserAgentOverride" -> p EmulationSetUserAgentOverride + "input.performActions" -> p InputPerformActions + "input.releaseActions" -> p InputReleaseActions + "input.setFiles" -> p InputSetFiles + "network.addDataCollector" -> p NetworkAddDataCollector + "network.addIntercept" -> p NetworkAddIntercept + "network.continueRequest" -> p NetworkContinueRequest + "network.continueResponse" -> p NetworkContinueResponse + "network.continueWithAuth" -> p NetworkContinueWithAuth + "network.disownData" -> p NetworkDisownData + "network.failRequest" -> p NetworkFailRequest + "network.getData" -> p NetworkGetData + "network.provideResponse" -> p NetworkProvideResponse + "network.removeDataCollector" -> p NetworkRemoveDataCollector + "network.removeIntercept" -> p NetworkRemoveIntercept + "network.setCacheBehavior" -> p NetworkSetCacheBehavior + "network.setExtraHeaders" -> p NetworkSetExtraHeaders + "script.addPreloadScript" -> p ScriptAddPreloadScript + "script.callFunction" -> p ScriptCallFunction + "script.disown" -> p ScriptDisown + "script.evaluate" -> p ScriptEvaluate + "script.getRealms" -> p ScriptGetRealms + "script.removePreloadScript" -> p ScriptRemovePreloadScript + "session.end" -> p SessionEnd + "session.new" -> p SessionNew + "session.status" -> p SessionStatus + "session.subscribe" -> p SessionSubscribe + "session.unsubscribe" -> p SessionUnsubscribe + "storage.deleteCookies" -> p StorageDeleteCookies + "storage.getCookies" -> p StorageGetCookies + "storage.setCookie" -> p StorageSetCookie + "webExtension.install" -> p WebExtensionInstall + "webExtension.uninstall" -> p WebExtensionUninstall + u -> failConversion u + c -> failConversion $ jsonToText c + where + p = pure + failConversion c = + fail . unpack $ + "Unrecognised CommandMethodType: " + <> c + <> " - " + <> "Expected one of: " + <> " " + <> (T.intercalate ", " $ knownCommandToText <$> enumerate @KnownCommand) + +-- | Converts a 'KnownCommand' to its corresponding method name text. +knownCommandToText :: KnownCommand -> Text +knownCommandToText = \case + BrowserClose -> "browser.close" + BrowserCreateUserContext -> "browser.createUserContext" + BrowserGetClientWindows -> "browser.getClientWindows" + BrowserGetUserContexts -> "browser.getUserContexts" + BrowserRemoveUserContext -> "browser.removeUserContext" + BrowserSetClientWindowState -> "browser.setClientWindowState" + BrowserSetDownloadBehavior -> "browser.setDownloadBehavior" + BrowsingContextActivate -> "browsingContext.activate" + BrowsingContextCaptureScreenshot -> "browsingContext.captureScreenshot" + BrowsingContextClose -> "browsingContext.close" + BrowsingContextCreate -> "browsingContext.create" + BrowsingContextGetTree -> "browsingContext.getTree" + BrowsingContextHandleUserPrompt -> "browsingContext.handleUserPrompt" + BrowsingContextLocateNodes -> "browsingContext.locateNodes" + BrowsingContextNavigate -> "browsingContext.navigate" + BrowsingContextPrint -> "browsingContext.print" + BrowsingContextReload -> "browsingContext.reload" + BrowsingContextSetViewport -> "browsingContext.setViewport" + BrowsingContextTraverseHistory -> "browsingContext.traverseHistory" + EmulationSetForcedColorsModeThemeOverride -> "emulation.setForcedColorsModeThemeOverride" + EmulationSetGeolocationOverride -> "emulation.setGeolocationOverride" + EmulationSetLocaleOverride -> "emulation.setLocaleOverride" + EmulationSetNetworkConditions -> "emulation.setNetworkConditions" + EmulationSetScreenOrientationOverride -> "emulation.setScreenOrientationOverride" + EmulationSetScreenSettingsOverride -> "emulation.setScreenSettingsOverride" + EmulationSetScriptingEnabled -> "emulation.setScriptingEnabled" + EmulationSetTimezoneOverride -> "emulation.setTimezoneOverride" + EmulationSetTouchOverride -> "emulation.setTouchOverride" + EmulationSetUserAgentOverride -> "emulation.setUserAgentOverride" + InputPerformActions -> "input.performActions" + InputReleaseActions -> "input.releaseActions" + InputSetFiles -> "input.setFiles" + NetworkAddDataCollector -> "network.addDataCollector" + NetworkAddIntercept -> "network.addIntercept" + NetworkContinueRequest -> "network.continueRequest" + NetworkContinueResponse -> "network.continueResponse" + NetworkContinueWithAuth -> "network.continueWithAuth" + NetworkDisownData -> "network.disownData" + NetworkFailRequest -> "network.failRequest" + NetworkGetData -> "network.getData" + NetworkProvideResponse -> "network.provideResponse" + NetworkRemoveDataCollector -> "network.removeDataCollector" + NetworkRemoveIntercept -> "network.removeIntercept" + NetworkSetCacheBehavior -> "network.setCacheBehavior" + NetworkSetExtraHeaders -> "network.setExtraHeaders" + ScriptAddPreloadScript -> "script.addPreloadScript" + ScriptCallFunction -> "script.callFunction" + ScriptDisown -> "script.disown" + ScriptEvaluate -> "script.evaluate" + ScriptGetRealms -> "script.getRealms" + ScriptRemovePreloadScript -> "script.removePreloadScript" + SessionEnd -> "session.end" + SessionNew -> "session.new" + SessionStatus -> "session.status" + SessionSubscribe -> "session.subscribe" + SessionUnsubscribe -> "session.unsubscribe" + StorageDeleteCookies -> "storage.deleteCookies" + StorageGetCookies -> "storage.getCookies" + StorageSetCookie -> "storage.setCookie" + WebExtensionInstall -> "webExtension.install" + WebExtensionUninstall -> "webExtension.uninstall" + +-- | Converts a 'CommandMethod' to its corresponding method name text. +toCommandText :: CommandMethod -> Text +toCommandText = \case + KnownCommand k -> knownCommandToText k + OffSpecCommand (MkOffSpecCommand t) -> t + +instance FromJSON CommandMethod where + parseJSON :: Value -> Parser CommandMethod + parseJSON val = + (KnownCommand <$> parseJSON @KnownCommand val) + <|> (OffSpecCommand <$> parseJSON @OffSpecCommand val) + <|> failConversion + where + failConversion = + fail . unpack $ + "Unrecognised CommandMethodType: " + <> jsonToText val + <> " - " + <> "Expected a string, the standard command types of whcih are: " + <> " " + <> (T.intercalate ", " $ knownCommandToText <$> enumerate @KnownCommand) diff --git a/src/WebDriverPreCore/BiDi/CoreTypes.hs b/src/WebDriverPreCore/BiDi/CoreTypes.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/BiDi/CoreTypes.hs @@ -0,0 +1,259 @@ +module WebDriverPreCore.BiDi.CoreTypes + ( BrowsingContext (..), + ClientWindow (..), + EmptyResult (..), + Handle (..), + InternalId (..), + JSInt (..), + JSUInt (..), + KnownSubscriptionType (..), + NodeProperties (..), + NodeRemoteValue (..), + SharedId (..), + StringValue (..), + SubscriptionType (..), + OffSpecSubscriptionType (..), + UserContext (..), + URL (..), + subscriptionTypeToText, + ) +where + +import Control.Applicative (Alternative (..)) +import Control.Monad (unless) +import Data.Aeson (FromJSON (..), Object, ToJSON (..), Value (..), withText, (.:), (.:?)) +import Data.Aeson.Types (Parser, withObject) +import Data.Int (Int64) +import Data.Map qualified as Map +import Data.Text (Text, unpack) +import GHC.Generics (Generic) +import AesonUtils (jsonToText) +import WebDriverPreCore.Internal.HTTPBidiCommon (URL (..), JSUInt (..)) + +newtype ClientWindow = MkClientWindow Text + deriving newtype (Show, Eq, FromJSON, ToJSON) + +-- | Core types for the WebDriver BiDi (Bidirectional) protocol. + +-- Base types -- word 64 18446744073709551615 + +newtype JSInt = MkJSInt Int64 deriving newtype (Show, Eq, FromJSON, ToJSON) -- JSINt :: -9007199254740991..9007199254740991 - Int64 -9223372036854775808 to 9223372036854775807 + +-- Main BrowsingContext types +newtype BrowsingContext = MkBrowsingContext {context :: Text} + deriving (Show, Eq, Generic, ToJSON) + +instance FromJSON BrowsingContext where + parseJSON :: Value -> Parser BrowsingContext + parseJSON = + \case + String s -> pure $ MkBrowsingContext s + Object obj -> MkBrowsingContext <$> obj .: "context" + v -> fail $ "Expected BrowsingContext as String or Object, but got: " ++ show v + +-- Node type used by BrowsingContext and Script + +newtype UserContext = MkUserContext {userContext :: Text} + deriving (Show, Eq, ToJSON) + +instance FromJSON UserContext where + parseJSON :: Value -> Parser UserContext + parseJSON = \case + String t -> pure $ MkUserContext t + Object obj -> + obj .: "userContext" >>= pure . MkUserContext + v -> fail . unpack $ "Unable to parse UserContext as String or Object, but got:\n " <> jsonToText v + +data NodeRemoteValue = MkNodeRemoteValue + { sharedId :: Maybe SharedId, + handle :: Maybe Handle, + internalId :: Maybe InternalId, + value :: Maybe NodeProperties + } + deriving (Show, Eq, Generic) + +instance FromJSON NodeRemoteValue where + parseJSON :: Value -> Parser NodeRemoteValue + parseJSON = withObject "NodeRemoteValue" $ \obj -> do + sharedId <- obj .:? "sharedId" + handle <- obj .:? "handle" + internalId <- obj .:? "internalId" + value <- obj .:? "value" + pure $ MkNodeRemoteValue {..} + +newtype Handle = MkHandle Text deriving newtype (Show, Eq, FromJSON, ToJSON) + +newtype InternalId + = MkInternalId Text + deriving newtype (Show, Eq, FromJSON) + +data NodeProperties = MkNodeProperties + { nodeType :: JSUInt, + childNodeCount :: JSUInt, + attributes :: Maybe (Map.Map Text Text), + children :: Maybe [NodeRemoteValue], + localName :: Maybe Text, + mode :: Maybe Text, -- "open" or "closed" + namespaceURI :: Maybe Text, + nodeValue :: Maybe Text, + shadowRoot :: Maybe NodeRemoteValue -- null allowed + } + deriving (Show, Eq, Generic) + +newtype StringValue = MkStringValue {value :: Text} + deriving (Show, Eq, Generic) + +instance ToJSON StringValue where + toJSON :: StringValue -> Value + toJSON (MkStringValue val) = + String val + +instance FromJSON StringValue where + parseJSON :: Value -> Parser StringValue + parseJSON = withObject "StringValue" $ \obj -> do + typ <- obj .: "type" + unless (typ == "string") $ + fail $ + "Expected type 'string' but got: " <> show typ + MkStringValue <$> obj .: "value" + +instance FromJSON NodeProperties + +newtype SharedId = MkSharedId + { id :: Text + } + deriving (Show, Eq, Generic) + deriving newtype (ToJSON, FromJSON) + +newtype EmptyResult = MkEmptyResult {extensible :: Object} deriving (Show, Eq, Generic) + +instance FromJSON EmptyResult where + parseJSON :: Value -> Parser EmptyResult + parseJSON = withObject "EmptyResult" $ fmap MkEmptyResult . pure + +instance ToJSON EmptyResult where + toJSON :: EmptyResult -> Value + toJSON (MkEmptyResult obj) = Object obj + +data KnownSubscriptionType + = -- BrowsingContext module + BrowsingContextContextCreated + | BrowsingContextContextDestroyed + | BrowsingContextNavigationStarted + | BrowsingContextFragmentNavigated + | BrowsingContextHistoryUpdated + | BrowsingContextDomContentLoaded + | BrowsingContextLoad + | BrowsingContextDownloadWillBegin + | BrowsingContextDownloadEnd + | BrowsingContextNavigationAborted + | BrowsingContextNavigationCommitted + | BrowsingContextNavigationFailed + | BrowsingContextUserPromptClosed + | BrowsingContextUserPromptOpened + | -- Log module + LogEntryAdded + | -- Network module + NetworkAuthRequired + | NetworkBeforeRequestSent + | NetworkFetchError + | NetworkResponseCompleted + | NetworkResponseStarted + | -- Script module + ScriptMessage + | ScriptRealmCreated + | ScriptRealmDestroyed + | -- Input module + InputFileDialogOpened + deriving (Show, Eq, Generic, Enum, Bounded) + +instance FromJSON KnownSubscriptionType where + parseJSON :: Value -> Parser KnownSubscriptionType + parseJSON = withText "KnownSubscriptionType" $ \method -> do + case method of + "browsingContext.contextCreated" -> pure BrowsingContextContextCreated + "browsingContext.contextDestroyed" -> pure BrowsingContextContextDestroyed + "browsingContext.navigationStarted" -> pure BrowsingContextNavigationStarted + "browsingContext.fragmentNavigated" -> pure BrowsingContextFragmentNavigated + "browsingContext.historyUpdated" -> pure BrowsingContextHistoryUpdated + "browsingContext.domContentLoaded" -> pure BrowsingContextDomContentLoaded + "browsingContext.load" -> pure BrowsingContextLoad + "browsingContext.downloadWillBegin" -> pure BrowsingContextDownloadWillBegin + "browsingContext.downloadEnd" -> pure BrowsingContextDownloadEnd + "browsingContext.navigationAborted" -> pure BrowsingContextNavigationAborted + "browsingContext.navigationCommitted" -> pure BrowsingContextNavigationCommitted + "browsingContext.navigationFailed" -> pure BrowsingContextNavigationFailed + "browsingContext.userPromptClosed" -> pure BrowsingContextUserPromptClosed + "browsingContext.userPromptOpened" -> pure BrowsingContextUserPromptOpened + "log.entryAdded" -> pure LogEntryAdded + "network.authRequired" -> pure NetworkAuthRequired + "network.beforeRequestSent" -> pure NetworkBeforeRequestSent + "network.fetchError" -> pure NetworkFetchError + "network.responseCompleted" -> pure NetworkResponseCompleted + "network.responseStarted" -> pure NetworkResponseStarted + "script.message" -> pure ScriptMessage + "script.realmCreated" -> pure ScriptRealmCreated + "script.realmDestroyed" -> pure ScriptRealmDestroyed + "input.fileDialogOpened" -> pure InputFileDialogOpened + _ -> fail $ "Unknown KnownSubscriptionType method: " <> show method + +data SubscriptionType + = KnownSubscriptionType KnownSubscriptionType + | OffSpecSubscriptionType OffSpecSubscriptionType + deriving (Show, Eq, Generic) + +-- | Off-specification subscription type for driver-specific events. +-- +-- This type should only be used as a fallback when a WebDriver implementation +-- supports subscribing to events that are not covered by this library's +-- 'KnownSubscriptionType'. Use the standard subscription types whenever possible. +newtype OffSpecSubscriptionType = MkOffSpecSubscriptionType + { method :: Text + } + deriving (Show, Eq, Generic) + deriving newtype (ToJSON, FromJSON) + +instance ToJSON SubscriptionType where + toJSON :: SubscriptionType -> Value + toJSON = String . subscriptionTypeToText + +subscriptionTypeToText :: SubscriptionType -> Text +subscriptionTypeToText = \case + KnownSubscriptionType known -> case known of + -- Log module + LogEntryAdded -> "log.entryAdded" + -- BrowsingContext module + BrowsingContextContextCreated -> "browsingContext.contextCreated" + BrowsingContextContextDestroyed -> "browsingContext.contextDestroyed" + BrowsingContextNavigationStarted -> "browsingContext.navigationStarted" + BrowsingContextFragmentNavigated -> "browsingContext.fragmentNavigated" + BrowsingContextHistoryUpdated -> "browsingContext.historyUpdated" + BrowsingContextDomContentLoaded -> "browsingContext.domContentLoaded" + BrowsingContextLoad -> "browsingContext.load" + BrowsingContextDownloadWillBegin -> "browsingContext.downloadWillBegin" + BrowsingContextDownloadEnd -> "browsingContext.downloadEnd" + BrowsingContextNavigationAborted -> "browsingContext.navigationAborted" + BrowsingContextNavigationCommitted -> "browsingContext.navigationCommitted" + BrowsingContextNavigationFailed -> "browsingContext.navigationFailed" + BrowsingContextUserPromptClosed -> "browsingContext.userPromptClosed" + BrowsingContextUserPromptOpened -> "browsingContext.userPromptOpened" + -- Network module + NetworkAuthRequired -> "network.authRequired" + NetworkBeforeRequestSent -> "network.beforeRequestSent" + NetworkFetchError -> "network.fetchError" + NetworkResponseCompleted -> "network.responseCompleted" + NetworkResponseStarted -> "network.responseStarted" + -- Script module + ScriptMessage -> "script.message" + ScriptRealmCreated -> "script.realmCreated" + ScriptRealmDestroyed -> "script.realmDestroyed" + -- Input module + InputFileDialogOpened -> "input.fileDialogOpened" + OffSpecSubscriptionType MkOffSpecSubscriptionType {method} -> method + +instance FromJSON SubscriptionType where + parseJSON :: Value -> Parser SubscriptionType + parseJSON v = + (KnownSubscriptionType <$> parseJSON @KnownSubscriptionType v) + <|> (OffSpecSubscriptionType <$> parseJSON @OffSpecSubscriptionType v) + <|> (fail . unpack $ "Invalid SubscriptionType: " <> jsonToText v) diff --git a/src/WebDriverPreCore/BiDi/Emulation.hs b/src/WebDriverPreCore/BiDi/Emulation.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/BiDi/Emulation.hs @@ -0,0 +1,309 @@ +module WebDriverPreCore.BiDi.Emulation + ( SetGeolocationOverride (..), + SetLocaleOverride (..), + SetScreenOrientationOverride (..), + SetScreenSettingsOverride (..), + SetTimezoneOverride (..), + SetTouchOverride (..), + SetForcedColorsModeThemeOverride (..), + SetNetworkConditions (..), + SetUserAgentOverride (..), + SetScriptingEnabled (..), + GeoProperty (..), + GeolocationCoordinates (..), + GeolocationPositionError (..), + ScreenArea (..), + ScreenOrientationOverride (..), + ScreenOrientationNatural (..), + ScreenOrientationType (..), + ForcedColorsModeTheme (..), + NetworkConditions (..), + NetworkConditionsOffline (..), + ) +where + +import AesonUtils (opt) +import Data.Aeson (ToJSON (..), Value (..), object, (.=)) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import GHC.Generics (Generic) +import WebDriverPreCore.BiDi.CoreTypes (BrowsingContext, JSUInt, UserContext) + +-- ######### Remote ######### + +-- Note: emulation module does not have a local end + +data GeoProperty + = Coordinates GeolocationCoordinates + | ClearCoodrdinates + | PositionError GeolocationPositionError + deriving (Show, Eq, Generic) + +data SetGeolocationOverride = MkSetGeolocationOverride + { override :: GeoProperty, + contexts :: Maybe [BrowsingContext], + userContexts :: Maybe [UserContext] + } + deriving (Show, Eq, Generic) + +instance ToJSON SetGeolocationOverride where + toJSON :: SetGeolocationOverride -> Value + toJSON MkSetGeolocationOverride {override, contexts, userContexts} = + object $ geoField <> catMaybes [opt "contexts" contexts, opt "userContexts" userContexts] + where + geoField = case override of + Coordinates coords -> [("coordinates" .= coords)] + ClearCoodrdinates -> [("coordinates" .= Null)] + PositionError err -> [("error" .= err)] + +data SetLocaleOverride = MkSetLocaleOverride + { locale :: Maybe Text, + contexts :: Maybe [BrowsingContext], + userContexts :: Maybe [UserContext] + } + deriving (Show, Eq, Generic) + +instance ToJSON SetLocaleOverride where + toJSON :: SetLocaleOverride -> Value + toJSON MkSetLocaleOverride {locale, contexts, userContexts} = + object $ + ["locale" .= locale] + <> catMaybes + [ opt "contexts" contexts, + opt "userContexts" userContexts + ] + +data SetScreenOrientationOverride = MkSetScreenOrientationOverride + { screenOrientation :: Maybe ScreenOrientationOverride, + contexts :: Maybe [BrowsingContext], + userContexts :: Maybe [UserContext] + } + deriving (Show, Eq, Generic) + +instance ToJSON SetScreenOrientationOverride where + toJSON :: SetScreenOrientationOverride -> Value + toJSON MkSetScreenOrientationOverride {screenOrientation, contexts, userContexts} = + object $ + ["screenOrientation" .= screenOrientation] + <> catMaybes + [ opt "contexts" contexts, + opt "userContexts" userContexts + ] + +data SetScreenSettingsOverride = MkSetScreenSettingsOverride + { screenArea :: Maybe ScreenArea, + contexts :: Maybe [BrowsingContext], + userContexts :: Maybe [UserContext] + } + deriving (Show, Eq, Generic) + +-- Note: screenArea is a required field that can be null, while contexts and userContexts are optional +-- Required nullable fields must be included in the JSON with their value (even if null) +-- Optional fields are omitted when Nothing +instance ToJSON SetScreenSettingsOverride where + toJSON :: SetScreenSettingsOverride -> Value + toJSON MkSetScreenSettingsOverride {screenArea, contexts, userContexts} = + object $ + ["screenArea" .= screenArea] + <> catMaybes + [ opt "contexts" contexts, + opt "userContexts" userContexts + ] + +data SetTimezoneOverride = MkSetTimezoneOverride + { timezone :: Maybe Text, + contexts :: Maybe [BrowsingContext], + userContexts :: Maybe [UserContext] + } + deriving (Show, Eq, Generic) + +instance ToJSON SetTimezoneOverride where + toJSON :: SetTimezoneOverride -> Value + toJSON MkSetTimezoneOverride {timezone, contexts, userContexts} = + object $ + ["timezone" .= timezone] + <> catMaybes + [ opt "contexts" contexts, + opt "userContexts" userContexts + ] + +data SetForcedColorsModeThemeOverride = MkSetForcedColorsModeThemeOverride + { theme :: Maybe ForcedColorsModeTheme, + contexts :: Maybe [BrowsingContext], + userContexts :: Maybe [UserContext] + } + deriving (Show, Eq, Generic) + +instance ToJSON SetForcedColorsModeThemeOverride where + toJSON :: SetForcedColorsModeThemeOverride -> Value + toJSON MkSetForcedColorsModeThemeOverride {theme, contexts, userContexts} = + object $ + ["theme" .= theme] + <> catMaybes + [ opt "contexts" contexts, + opt "userContexts" userContexts + ] + +data SetNetworkConditions = MkSetNetworkConditions + { networkConditions :: Maybe NetworkConditions, + contexts :: Maybe [BrowsingContext], + userContexts :: Maybe [UserContext] + } + deriving (Show, Eq, Generic) + +instance ToJSON SetNetworkConditions where + toJSON :: SetNetworkConditions -> Value + toJSON MkSetNetworkConditions {networkConditions, contexts, userContexts} = + object $ + ["networkConditions" .= networkConditions] + <> catMaybes + [ opt "contexts" contexts, + opt "userContexts" userContexts + ] + +data SetUserAgentOverride = MkSetUserAgentOverride + { userAgent :: Maybe Text, + contexts :: Maybe [BrowsingContext], + userContexts :: Maybe [UserContext] + } + deriving (Show, Eq, Generic) + +instance ToJSON SetUserAgentOverride where + toJSON :: SetUserAgentOverride -> Value + toJSON MkSetUserAgentOverride {userAgent, contexts, userContexts} = + object $ + ["userAgent" .= userAgent] + <> catMaybes + [ opt "contexts" contexts, + opt "userContexts" userContexts + ] + +data SetScriptingEnabled = MkSetScriptingEnabled + { enabled :: Maybe Bool, + contexts :: Maybe [BrowsingContext], + userContexts :: Maybe [UserContext] + } + deriving (Show, Eq, Generic) + +instance ToJSON SetScriptingEnabled where + toJSON :: SetScriptingEnabled -> Value + toJSON MkSetScriptingEnabled {enabled, contexts, userContexts} = + object $ + ["enabled" .= enabled] + <> catMaybes + [ opt "contexts" contexts, + opt "userContexts" userContexts + ] + +-- | Parameters for emulation.setTouchOverride command +-- maxTouchPoints: (js-uint .ge 1) / null - the maximum number of touch points to emulate, or null to clear +data SetTouchOverride = MkSetTouchOverride + { maxTouchPoints :: Maybe JSUInt, + contexts :: Maybe [BrowsingContext], + userContexts :: Maybe [UserContext] + } + deriving (Show, Eq, Generic) + +instance ToJSON SetTouchOverride where + toJSON :: SetTouchOverride -> Value + toJSON MkSetTouchOverride {maxTouchPoints, contexts, userContexts} = + object $ + ["maxTouchPoints" .= maxTouchPoints] + <> catMaybes + [ opt "contexts" contexts, + opt "userContexts" userContexts + ] + +data ScreenArea = MkScreenArea + { width :: JSUInt, + height :: JSUInt + } + deriving (Show, Eq, Generic) + +instance ToJSON ScreenArea + +data GeolocationCoordinates = MkGeolocationCoordinates + { latitude :: Float, -- -90.0 to 90.0 + longitude :: Float, -- -180.0 to 180.0 + accuracy :: Maybe Float, -- >= 0.0, defaults to 1.0 + altitude :: Maybe Float, + altitudeAccuracy :: Maybe Float, -- >= 0.0 + heading :: Maybe Float, -- 0.0 to 360.0 + speed :: Maybe Float -- >= 0.0 + } + deriving (Show, Eq, Generic) + +instance ToJSON GeolocationCoordinates + +newtype GeolocationPositionError = MkGeolocationPositionError + { errorType :: Text -- "positionUnavailable" + } + deriving (Show, Eq, Generic) + +instance ToJSON GeolocationPositionError where + toJSON :: GeolocationPositionError -> Value + toJSON MkGeolocationPositionError {errorType} = + object ["type" .= errorType] + +data ScreenOrientationOverride = MkScreenOrientationOverride + { natural :: ScreenOrientationNatural, + screenOrientationType :: ScreenOrientationType + } + deriving (Show, Eq, Generic) + +instance ToJSON ScreenOrientationOverride where + toJSON :: ScreenOrientationOverride -> Value + toJSON MkScreenOrientationOverride {natural, screenOrientationType} = + object + [ "natural" .= natural, + "type" .= screenOrientationType + ] + +data ScreenOrientationNatural = PortraitNatural | LandscapeNatural + deriving (Show, Eq, Generic) + +instance ToJSON ScreenOrientationNatural where + toJSON :: ScreenOrientationNatural -> Value + toJSON = \case + PortraitNatural -> "portrait" + LandscapeNatural -> "landscape" + +data ScreenOrientationType + = PortraitPrimary + | PortraitSecondary + | LandscapePrimary + | LandscapeSecondary + deriving (Show, Eq, Generic) + +instance ToJSON ScreenOrientationType where + toJSON :: ScreenOrientationType -> Value + toJSON = \case + PortraitPrimary -> "portrait-primary" + PortraitSecondary -> "portrait-secondary" + LandscapePrimary -> "landscape-primary" + LandscapeSecondary -> "landscape-secondary" + +data ForcedColorsModeTheme = ForcedColorsLight | ForcedColorsDark + deriving (Show, Eq, Generic) + +instance ToJSON ForcedColorsModeTheme where + toJSON :: ForcedColorsModeTheme -> Value + toJSON = \case + ForcedColorsLight -> "light" + ForcedColorsDark -> "dark" + +newtype NetworkConditions = MkNetworkConditions NetworkConditionsOffline + deriving (Show, Eq, Generic) + +instance ToJSON NetworkConditions where + toJSON :: NetworkConditions -> Value + toJSON (MkNetworkConditions offline) = toJSON offline + +newtype NetworkConditionsOffline = MkNetworkConditionsOffline + { networkConditionsType :: Text -- "offline" + } + deriving (Show, Eq, Generic) + +instance ToJSON NetworkConditionsOffline where + toJSON :: NetworkConditionsOffline -> Value + toJSON _ = object ["type" .= "offline"] diff --git a/src/WebDriverPreCore/BiDi/Event.hs b/src/WebDriverPreCore/BiDi/Event.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/BiDi/Event.hs @@ -0,0 +1,109 @@ +module WebDriverPreCore.BiDi.Event + ( mkSubscription, + mkMultiSubscription, + mkOffSpecSubscription, + Subscription (..), + Event (..), + ) +where + +import Data.Aeson (FromJSON (..), Value (..), withObject, (.:)) +import Data.Aeson.Types (Parser) +import Data.Text (Text, isPrefixOf, unpack) +import GHC.Generics (Generic) +import WebDriverPreCore.BiDi.BrowsingContext (BrowsingContextEvent (..)) +import WebDriverPreCore.BiDi.CoreTypes (BrowsingContext, KnownSubscriptionType (..), SubscriptionType (..), UserContext, OffSpecSubscriptionType (..)) +import WebDriverPreCore.BiDi.Input (FileDialogOpened) +import WebDriverPreCore.BiDi.Log (LogEvent) +import WebDriverPreCore.BiDi.Network (NetworkEvent (..)) +import WebDriverPreCore.BiDi.Script (ScriptEvent (..)) + +mkSubscription :: + forall m r. + (FromJSON r) => + KnownSubscriptionType -> + [BrowsingContext] -> + [UserContext] -> + (r -> m ()) -> + Subscription m +mkSubscription subType = + SingleSubscription (KnownSubscriptionType subType) + +mkMultiSubscription :: + [KnownSubscriptionType] -> + [BrowsingContext] -> + [UserContext] -> + (Event -> m ()) -> + Subscription m +mkMultiSubscription ks = + MultiSubscription (KnownSubscriptionType <$> ks) + +-- | Create a subscription for off-specification event types. +-- +-- Use this only as a fallback when a driver supports events not covered by +-- this library. Prefer using standard subscription constructors when available. +mkOffSpecSubscription :: + [OffSpecSubscriptionType] -> + [BrowsingContext] -> + [UserContext] -> + (Value -> m ()) -> + Subscription m +mkOffSpecSubscription ks = + OffSpecSubscription (OffSpecSubscriptionType <$> ks) + +data Subscription m where + SingleSubscription :: + forall m r. + (FromJSON r) => + { subscriptionType :: SubscriptionType, + browsingContexts :: [BrowsingContext], + userContexts :: [UserContext], + action :: r -> m () + } -> + Subscription m + MultiSubscription :: + { subscriptionTypes :: [SubscriptionType], + browsingContexts :: [BrowsingContext], + userContexts :: [UserContext], + nAction :: Event -> m () + } -> + Subscription m + OffSpecSubscription :: + { subscriptionTypes :: [SubscriptionType], + browsingContexts :: [BrowsingContext], + userContexts :: [UserContext], + nValueAction :: Value -> m () + } -> + Subscription m + +data Event + = BrowsingContextEvent BrowsingContextEvent + | InputEvent FileDialogOpened + | LogEvent LogEvent + | NetworkEvent NetworkEvent + | ScriptEvent ScriptEvent + deriving + ( Show, + Eq, + Generic + ) + +instance FromJSON Event where + parseJSON :: Value -> Parser Event + parseJSON = withObject "Event" $ \o -> do + m <- o .: "method" + params <- o .: "params" + let methodPrefix :: Text -> Bool + methodPrefix = (`isPrefixOf` m) + parseVal :: forall a. (FromJSON a) => Parser a + parseVal = parseJSON (Object o) + -- For input events, parse from params directly (consistent with SingleSubscription) + parseParams :: forall a. (FromJSON a) => Parser a + parseParams = parseJSON params + if + | methodPrefix "browsingContext" -> BrowsingContextEvent <$> parseVal + | methodPrefix "input" -> InputEvent <$> parseParams + | methodPrefix "log" -> LogEvent <$> parseVal + | methodPrefix "network" -> NetworkEvent <$> parseVal + | methodPrefix "script" -> ScriptEvent <$> parseVal + | otherwise -> fail $ "Unknown event type: " <> unpack m diff --git a/src/WebDriverPreCore/BiDi/Input.hs b/src/WebDriverPreCore/BiDi/Input.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/BiDi/Input.hs @@ -0,0 +1,360 @@ +module WebDriverPreCore.BiDi.Input + ( PerformActions (..), + SourceActions (..), + NoneSourceActions (..), + KeySourceActions (..), + KeySourceAction (..), + PointerSourceActions (..), + PointerSourceAction (..), + WheelSourceActions (..), + WheelSourceAction (..), + PauseAction (..), + WheelScrollAction (..), + PointerCommonProperties (..), + Origin (..), + ReleaseActions (..), + SetFiles (..), + FileDialogOpened (..), + FileDialogInfo (..), + Pointer (..), + PointerType (..), + ) +where + +import Data.Aeson (ToJSON (..), Value (Object), object, (.=), FromJSON (..)) +import Data.Aeson.KeyMap qualified +import Data.Aeson.Types (Parser) +import Data.Maybe (fromMaybe, catMaybes) +import Data.Text (Text) +import GHC.Generics (Generic) +import WebDriverPreCore.BiDi.Script qualified as Script +import AesonUtils (toJSONOmitNothing, parseJSONOmitNothing, opt) +import WebDriverPreCore.BiDi.CoreTypes (BrowsingContext(..)) +import WebDriverPreCore.BiDi.Script (SharedReference) + +-- ######### Local ######### + +data PerformActions = MkPerformActions + { context :: BrowsingContext, + actions :: [SourceActions] + } + deriving (Show, Eq, Generic) + +instance ToJSON PerformActions where + toJSON :: PerformActions -> Value + toJSON (MkPerformActions context actions) = + object + [ "context" .= context, + "actions" .= actions + ] + +data SourceActions + = NoneSourceActions NoneSourceActions + | KeySourceActions KeySourceActions + | PointerSourceActions PointerSourceActions + | WheelSourceActions WheelSourceActions + deriving (Show, Eq, Generic) + +instance ToJSON SourceActions where + toJSON :: SourceActions -> Value + toJSON = \case + NoneSourceActions noneSourceActions -> toJSON noneSourceActions + KeySourceActions keySourceActions -> toJSON keySourceActions + PointerSourceActions pointerSourceActions -> toJSON pointerSourceActions + WheelSourceActions wheelSourceActions -> toJSON wheelSourceActions + +data NoneSourceActions = MkNoneSourceActions + { noneId :: Text, + noneActions :: [PauseAction] + } + deriving (Show, Eq, Generic) + +instance ToJSON NoneSourceActions where + toJSON :: NoneSourceActions -> Value + toJSON (MkNoneSourceActions noneId noneActions) = + object + [ "type" .= "none", + "id" .= noneId, + "actions" .= noneActions + ] + +data KeySourceActions = MkKeySourceActions + { keyId :: Text, + keyActions :: [KeySourceAction] + } + deriving (Show, Eq, Generic) + +instance ToJSON KeySourceActions where + toJSON :: KeySourceActions -> Value + toJSON (MkKeySourceActions keyId keyActions) = + object + [ "type" .= "key", + "id" .= keyId, + "actions" .= keyActions + ] + +data KeySourceAction + = KeyPause + { duration :: Maybe Int + } + | KeyDown + { value :: Text + } + | KeyUp + { value :: Text + } + deriving (Show, Eq, Generic) + +instance ToJSON KeySourceAction where + toJSON :: KeySourceAction -> Value + toJSON = \case + KeyPause {duration} -> + object $ + ["type" .= "pause"] + <> catMaybes [opt "duration" duration] + KeyDown {value} -> + object + [ "type" .= "keyDown", + "value" .= value + ] + KeyUp {value} -> + object + [ "type" .= "keyUp", + "value" .= value + ] + +data PointerSourceActions = MkPointerSourceActions + { pointerId :: Text, + pointer :: Maybe Pointer, + pointerActions :: [PointerSourceAction] + } + deriving (Show, Eq, Generic) + +instance ToJSON PointerSourceActions where + toJSON :: PointerSourceActions -> Value + toJSON (MkPointerSourceActions pointerId pointer pointerActions) = + object + [ "type" .= "pointer", + "id" .= pointerId, + "parameters" .= pointer, + "actions" .= pointerActions + ] + +data PointerType = MousePointer | PenPointer | TouchPointer + deriving (Show, Eq, Generic) + +instance ToJSON PointerType where + toJSON :: PointerType -> Value + toJSON = \case + MousePointer -> "mouse" + PenPointer -> "pen" + TouchPointer -> "touch" + +data Pointer = MkPointer + { pointerType :: Maybe PointerType -- default "mouse" + } + deriving (Show, Eq, Generic) + +instance ToJSON Pointer where + toJSON :: Pointer -> Value + toJSON MkPointer {pointerType} = + object + [ "pointerType" .= fromMaybe MousePointer pointerType + ] + +data PointerSourceAction + = Pause + { duration :: Maybe Int + } + | PointerDown + { button :: Int, + pointerCommonProperties :: PointerCommonProperties + } + | PointerUp + { button :: Int + } + | PointerMove + { x :: Double, + y :: Double, + duration :: Maybe Int, + origin :: Maybe Origin, + pointerCommonProperties :: PointerCommonProperties + } + deriving (Show, Eq, Generic) + +instance ToJSON PointerSourceAction where + toJSON :: PointerSourceAction -> Value + toJSON = \case + Pause {duration} -> + object $ + ["type" .= "pause"] + <> catMaybes [opt "duration" duration] + PointerDown {button, pointerCommonProperties} -> + case toJSON pointerCommonProperties of + Object props -> + object $ + [ "type" .= "pointerDown", + "button" .= button + ] ++ [(k, v) | (k, v) <- Data.Aeson.KeyMap.toList props] + _ -> + object + [ "type" .= "pointerDown", + "button" .= button + ] + PointerUp {button} -> + object + [ "type" .= "pointerUp", + "button" .= button + ] + PointerMove {x, y, duration, origin, pointerCommonProperties} -> + case toJSON pointerCommonProperties of + Object props -> + object $ + [ "type" .= "pointerMove", + "x" .= x, + "y" .= y + ] + <> catMaybes [opt "duration" duration, opt "origin" origin] + ++ [(k, v) | (k, v) <- Data.Aeson.KeyMap.toList props] + _ -> + object $ + [ "type" .= "pointerMove", + "x" .= x, + "y" .= y + ] + <> catMaybes [opt "duration" duration, opt "origin" origin] + +data WheelSourceActions = MkWheelSourceActions + { wheelId :: Text, + wheelActions :: [WheelSourceAction] + } + deriving (Show, Eq, Generic) + +instance ToJSON WheelSourceActions where + toJSON :: WheelSourceActions -> Value + toJSON (MkWheelSourceActions wheelId wheelActions) = + object + [ "type" .= "wheel", + "id" .= wheelId, + "actions" .= wheelActions + ] + +data WheelSourceAction + = WheelPauseAction PauseAction + | WheelScrollAction WheelScrollAction + deriving (Show, Eq, Generic) + +instance ToJSON WheelSourceAction where + toJSON :: WheelSourceAction -> Value + toJSON = \case + WheelPauseAction wheelPauseAction -> toJSON wheelPauseAction + WheelScrollAction wheelScrollAction -> toJSON wheelScrollAction + +newtype PauseAction = MkPauseAction + { duration :: Maybe Int + } + deriving (Show, Eq, Generic) + +instance ToJSON PauseAction where + toJSON :: PauseAction -> Value + toJSON (MkPauseAction duration) = + object $ + ["type" .= "pause"] + <> catMaybes [opt "duration" duration] + +data WheelScrollAction = MkWheelScrollAction + { x :: Int, + y :: Int, + deltaX :: Int, + deltaY :: Int, + duration :: Maybe Int, + origin :: Maybe Origin -- default "viewport" + } + deriving (Show, Eq, Generic) + +instance ToJSON WheelScrollAction where + toJSON :: WheelScrollAction -> Value + toJSON (MkWheelScrollAction x y deltaX deltaY duration origin) = + object $ + [ "type" .= "scroll", + "x" .= x, + "y" .= y, + "deltaX" .= deltaX, + "deltaY" .= deltaY + ] + <> catMaybes [opt "duration" duration, opt "origin" origin] + +data PointerCommonProperties = MkPointerCommonProperties + { width :: Maybe Int, -- default 1 + height :: Maybe Int, -- default 1 + pressure :: Maybe Double, -- default 0.0 + tangentialPressure :: Maybe Double, -- default 0.0 + twist :: Maybe Int, -- default 0, range 0..359 + altitudeAngle :: Maybe Double, -- default 0.0, range 0..π/2 + azimuthAngle :: Maybe Double -- default 0.0, range 0..2π + } + deriving (Show, Eq, Generic) + +instance ToJSON PointerCommonProperties where + toJSON :: PointerCommonProperties -> Value + toJSON = toJSONOmitNothing + +data Origin + = ViewportOriginPointerType + | PointerOrigin + | ElementOrigin Script.SharedReference + deriving (Show, Eq, Generic) + +instance ToJSON Origin where + toJSON :: Origin -> Value + toJSON = \case + ViewportOriginPointerType -> "viewport" + PointerOrigin -> "pointer" + ElementOrigin element -> + object + [ "type" .= "element", + "element" .= element + ] + +-- ReleaseActions +newtype ReleaseActions = MkReleaseActions + { context :: BrowsingContext + } + deriving (Show, Eq, Generic) + +instance ToJSON ReleaseActions + +data SetFiles = MkSetFiles + { context :: BrowsingContext, + element :: Script.SharedReference, + files :: [Text] + } + deriving (Show, Eq, Generic) + +instance ToJSON SetFiles + +-- | Event data for input.fileDialogOpened event +-- Parses the params content directly (params is extracted by Event or SingleSubscription handler) +newtype FileDialogOpened = MkFileDialogOpened + { params :: FileDialogInfo + } + deriving (Show, Eq, Generic) + +instance FromJSON FileDialogOpened where + parseJSON :: Value -> Parser FileDialogOpened + parseJSON v = MkFileDialogOpened <$> parseJSON v + +-- ######### Local ######### + +data FileDialogInfo = MkFileDialogInfo + { context :: BrowsingContext, + element :: Maybe SharedReference, + multiple :: Bool + } + deriving (Show, Eq, Generic) + +instance FromJSON FileDialogInfo where + parseJSON :: Value -> Parser FileDialogInfo + parseJSON = parseJSONOmitNothing + +instance ToJSON FileDialogInfo diff --git a/src/WebDriverPreCore/BiDi/Log.hs b/src/WebDriverPreCore/BiDi/Log.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/BiDi/Log.hs @@ -0,0 +1,127 @@ +module WebDriverPreCore.BiDi.Log + ( -- * Log Level + Level (..), + + -- * Log Entry Types + BaseLogEntry (..), + GenericLogEntry (..), + ConsoleLogEntry (..), + JavascriptLogEntry (..), + LogEntry (..), + LogEvent (..) + ) +where + +import Data.Aeson (FromJSON, Value (..), withObject, (.:)) +import Data.Aeson.Types (FromJSON (..), Parser) +import Data.Functor ((<&>)) +import Data.Text (Text) +import GHC.Generics (Generic) +import WebDriverPreCore.BiDi.CoreTypes (JSUInt) +import WebDriverPreCore.BiDi.Script (RemoteValue, Source, StackTrace) +import AesonUtils (fromJSONCamelCase, parseJSONOmitNothing) + +-- ######### Local ######### +-- Note: log module does not have a remote end + +-- | Represents the log level +data Level = Debug | Info | Warn | Error + deriving (Show, Eq, Generic) + +instance FromJSON Level where + parseJSON :: Value -> Parser Level + parseJSON = fromJSONCamelCase + +-- | Base structure for all log entries +data BaseLogEntry = MkBaseLogEntry + { level :: Level, + source :: Source, + text :: Maybe Text, + timestamp :: JSUInt, + stackTrace :: Maybe StackTrace + } + deriving (Show, Eq, Generic) + +instance FromJSON BaseLogEntry where + parseJSON :: Value -> Parser BaseLogEntry + parseJSON = parseJSONOmitNothing + +-- | Generic log entry type +data GenericLogEntry = MkGenericLogEntry + { level :: Level, + source :: Source, + text :: Maybe Text, + timestamp :: JSUInt, + stackTrace :: Maybe StackTrace, + entryType :: Text + } + deriving (Show, Eq, Generic) + +instance FromJSON GenericLogEntry where + parseJSON :: Value -> Parser GenericLogEntry + parseJSON = parseJSONOmitNothing + +-- | Console log entry type +data ConsoleLogEntry = MkConsoleLogEntry + { level :: Level, + source :: Source, + text :: Maybe Text, + timestamp :: JSUInt, + stackTrace :: Maybe StackTrace, + method :: Text, + args :: [RemoteValue] + } + deriving (Show, Eq, Generic) + +instance FromJSON ConsoleLogEntry where + parseJSON :: Value -> Parser ConsoleLogEntry + parseJSON = parseJSONOmitNothing + +-- | JavaScript log entry type +data JavascriptLogEntry = MkJavascriptLogEntry + { level :: Level, + source :: Source, + text :: Maybe Text, + timestamp :: JSUInt, + stackTrace :: Maybe StackTrace + } + deriving (Show, Eq, Generic) + +instance FromJSON JavascriptLogEntry where + parseJSON :: Value -> Parser JavascriptLogEntry + parseJSON = parseJSONOmitNothing + +-- | Union type for all log entry types +data LogEntry + = GenericEntry GenericLogEntry + | ConsoleEntry ConsoleLogEntry + | JavascriptEntry JavascriptLogEntry + deriving (Show, Eq, Generic) + +-- | Event wrapper for log entries (consistent with other event types) +newtype LogEvent = MkLogEvent LogEntry + deriving (Show, Eq, Generic) + +instance FromJSON LogEvent where + parseJSON :: Value -> Parser LogEvent + parseJSON = withObject "LogEvent" $ \o -> do + params <- o .: "params" + entryType <- params .: "type" + let parsedPrms :: forall a b. (FromJSON a) => (a -> b) -> Parser b + parsedPrms = (<&>) (parseJSON (Object params)) + case entryType of + "generic" -> parsedPrms (MkLogEvent . GenericEntry) + "console" -> parsedPrms (MkLogEvent . ConsoleEntry) + "javascript" -> parsedPrms (MkLogEvent . JavascriptEntry) + _ -> fail $ "Unknown log entry type: " <> entryType + +instance FromJSON LogEntry where + parseJSON :: Value -> Parser LogEntry + parseJSON = withObject "LogEntry" $ \o -> do + entryType <- o .: "type" + let val = Object o + case entryType of + "generic" -> GenericEntry <$> parseJSON val + "console" -> ConsoleEntry <$> parseJSON val + "javascript" -> JavascriptEntry <$> parseJSON val + _ -> fail $ "Unknown log entry type: " <> entryType diff --git a/src/WebDriverPreCore/BiDi/Network.hs b/src/WebDriverPreCore/BiDi/Network.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/BiDi/Network.hs @@ -0,0 +1,800 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} + +module WebDriverPreCore.BiDi.Network + ( -- * NetworkCommand + AddDataCollector (..), + AddIntercept (..), + InterceptPhase (..), + UrlPattern (..), + UrlPatternPattern (..), + UrlPatternString (..), + ContinueRequest (..), + BytesValue (..), + Cookie (..), + SameSite (..), + Header (..), + CookieHeader (..), + SetCookieHeader (..), + ContinueResponse (..), + ContinueWithAuth (..), + Intercept (..), + AuthCredentials (..), + AuthAction (..), + DisownData (..), + FailRequest (..), + GetData (..), + ProvideResponse (..), + RemoveDataCollector (..), + RemoveIntercept (..), + SetCacheBehavior (..), + CacheBehavior (..), + SetExtraHeaders (..), + + -- * Additional Network Types + DataType (..), + CollectorType (..), + Collector (..), + Request (..), + + -- * NetworkResult + AddDataCollectorResult (..), + AddInterceptResult (..), + GetDataResult (..), + + -- * NetworkEvent + NetworkEvent (..), + AuthRequired (..), + RequestData (..), + ResponseData (..), + ResponseContent (..), + AuthChallenge (..), + BeforeRequestSent (..), + Initiator (..), + InitiatorType (..), + FetchError (..), + ResponseCompleted (..), + ResponseStarted (..), + HTTPMethod (..), + FetchTimingInfo (..), + ) +where + +-- This module provides functionality related to BiDi (Bidirectional) network operations +-- for WebDriverPreCore. It is currently a placeholder for future implementation. + +-- Data structures for network protocol + +import Data.Aeson (FromArgs, FromJSON (..), ToJSON (..), Value (..), object, withObject, withText, (.:), (.=), Options (..), defaultOptions, genericParseJSON, (.:?)) +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types (Parser, parse) +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.Text (Text, toLower) +import GHC.Generics (Generic (to)) +import WebDriverPreCore.BiDi.BrowsingContext (Navigation) +import WebDriverPreCore.BiDi.CoreTypes (BrowsingContext, JSUInt, StringValue (..), SubscriptionType (..), UserContext, KnownSubscriptionType (..), URL) +import WebDriverPreCore.BiDi.Script (StackTrace) +import AesonUtils (addProps, enumCamelCase, fromJSONCamelCase, objectOrThrow, parseJSONOmitNothing, toJSONOmitNothing) + +-- ######### REMOTE ######### + +data AddDataCollector = MkAddDataCollector + { dataTypes :: [DataType], + maxEncodedDataSize :: JSUInt, + collectorType :: Maybe CollectorType, + contexts :: Maybe [BrowsingContext], + userContexts :: Maybe [UserContext] + } + deriving (Show, Eq, Generic) + +instance ToJSON AddDataCollector where + toJSON :: AddDataCollector -> Value + toJSON = toJSONOmitNothing + + +data DataType = Request | Response + deriving (Show, Eq, Generic) + +instance ToJSON DataType where + toJSON :: DataType -> Value + toJSON = enumCamelCase + +instance FromJSON DataType where + parseJSON :: Value -> Parser DataType + parseJSON = fromJSONCamelCase + +newtype CollectorType = MkCollectorType {collectorType :: Text} + deriving (Show, Eq, Generic) + deriving newtype (FromJSON, ToJSON) + +data DisownData = MkDisownData + { dataType :: DataType, + collector :: Collector, + request :: Request + } + deriving (Show, Eq, Generic) + +instance ToJSON DisownData + +newtype Collector = MkCollector {collector :: Text} + deriving (Show, Eq, Generic) + deriving newtype (FromJSON, ToJSON) + +newtype Request = MkRequest {request :: Text} + deriving (Show, Eq, Generic) + deriving newtype (FromJSON,ToJSON) + +data GetData = MkGetData + { dataType :: DataType, + collector :: Maybe Collector, + disown :: Maybe Bool, + request :: Request + } + deriving (Show, Eq, Generic) + +instance ToJSON GetData + +data RemoveDataCollector = MkRemoveDataCollector + { collector :: Collector + } + deriving (Show, Eq, Generic) + +instance ToJSON RemoveDataCollector + +-- | AddIntercept parameters +data AddIntercept = MkAddIntercept + { phases :: [InterceptPhase], + contexts :: Maybe [BrowsingContext], + urlPatterns :: Maybe [UrlPattern] + } + deriving (Show, Eq, Generic) + +instance ToJSON AddIntercept where + toJSON :: AddIntercept -> Value + toJSON = toJSONOmitNothing + +-- | Intercept phases for network requests +data InterceptPhase + = BeforeRequestSent + | ResponseStarted + | AuthRequired + deriving (Show, Eq, Generic) + +instance FromJSON InterceptPhase + +instance ToJSON InterceptPhase where + toJSON = enumCamelCase + +data UrlPattern + = UrlPatternPattern UrlPatternPattern + | UrlPatternString UrlPatternString + deriving (Show, Eq, Generic) + +instance ToJSON UrlPattern where + toJSON :: UrlPattern -> Value + toJSON = \case + UrlPatternPattern p -> toJSON p + UrlPatternString s -> toJSON s + +newtype UrlPatternString = MkUrlPatternString {patternString :: Text} + deriving (Show, Eq, Generic) + +instance ToJSON UrlPatternString where + toJSON :: UrlPatternString -> Value + toJSON (MkUrlPatternString p) = + object + [ "type" .= ("string" :: Text), + "pattern" .= p + ] + +-- | URL pattern for interception +data UrlPatternPattern = MkUrlPatternPattern + { protocol :: Maybe Text, + hostname :: Maybe Text, + port :: Maybe Text, + pathname :: Maybe Text, + search :: Maybe Text + } + deriving (Show, Eq, Generic) + +instance ToJSON UrlPatternPattern where + toJSON :: UrlPatternPattern -> Value + toJSON p = addProps "UrlPatternPattern" ["type" .= "pattern"] $ toJSONOmitNothing p + +-- | ContinueRequest parameters +data ContinueRequest = MkContinueRequest + { request :: Request, + body :: Maybe BytesValue, + cookies :: Maybe [CookieHeader], + headers :: Maybe [Header], + method :: Maybe Text, + url :: Maybe URL + } + deriving (Show, Eq, Generic) + +instance ToJSON ContinueRequest where + toJSON :: ContinueRequest -> Value + toJSON = toJSONOmitNothing + +data CookieHeader = MkCookieHeader + { cookieHeaderName :: Text, + cookieHeaderValue :: BytesValue + } + deriving (Show, Eq, Generic) + +instance ToJSON CookieHeader where + toJSON :: CookieHeader -> Value + toJSON h = + object + [ "name" .= h.cookieHeaderName, + "value" .= h.cookieHeaderValue + ] + +instance FromJSON CookieHeader where + parseJSON :: Value -> Parser CookieHeader + parseJSON = withObject "CookieHeader" $ \obj -> do + cookieHeaderName <- obj .: "name" + cookieHeaderValue <- obj .: "value" + pure $ MkCookieHeader {cookieHeaderName, cookieHeaderValue} + +-- | BytesValue can be either string or base64-encoded +data BytesValue + = TextBytesValue StringValue + | Base64Value Text + deriving (Show, Eq, Generic) + +instance FromJSON BytesValue where + parseJSON :: Value -> Parser BytesValue + parseJSON v = do + obj <- withObject "BytesValue" pure v + typ <- obj .: "type" + case typ of + "string" -> TextBytesValue <$> parseJSON v + "base64" -> Base64Value <$> obj .: "value" + _ -> fail $ "Invalid BytesValue type: " <> show typ + +instance ToJSON BytesValue where + toJSON :: BytesValue -> Value + toJSON = \case + TextBytesValue val -> + object + [ "type" .= "string", + "value" .= val + ] + Base64Value val -> + object + [ "type" .= "base64", + "value" .= val + ] + +-- | Cookie information +data Cookie = MkCookie + { name :: Text, + value :: BytesValue, + domain :: Text, + path :: Text, + size :: Word, + httpOnly :: Bool, + secure :: Bool, + sameSite :: SameSite, + expiry :: Maybe Word + } + deriving (Show, Eq, Generic) + +instance FromJSON Cookie + +instance ToJSON Cookie where + toJSON :: Cookie -> Value + toJSON = toJSONOmitNothing + +data SameSite + = Strict + | Lax + | SameSiteNone + | Default + deriving (Show, Eq, Generic) + +instance FromJSON SameSite where + parseJSON :: Value -> Parser SameSite + parseJSON = + withText "SameSite" $ \case + "strict" -> pure Strict + "lax" -> pure Lax + "none" -> pure SameSiteNone + "default" -> pure Default + _ -> fail "Invalid SameSite value" + +instance ToJSON SameSite where + toJSON :: SameSite -> Value + toJSON = \case + Strict -> "strict" + Lax -> "lax" + SameSiteNone -> "none" + Default -> "default" + +-- | Headers for requests and responses +data Header = MkHeader + { headerName :: Text, + headerValue :: BytesValue + } + deriving (Show, Eq, Generic) + +instance FromJSON Header where + parseJSON :: Value -> Parser Header + parseJSON = withObject "Header" $ \obj -> do + headerName <- obj .: "name" + headerValue <- obj .: "value" + pure $ MkHeader {headerName, headerValue} + +instance ToJSON Header where + toJSON :: Header -> Value + toJSON h = + object + [ "name" .= h.headerName, + "value" .= h.headerValue + ] + +-- | ContinueResponse parameters +data ContinueResponse = MkContinueResponse + { request :: Request, + cookies :: Maybe [SetCookieHeader], + credentials :: Maybe AuthCredentials, + headers :: Maybe [Header], + reasonPhrase :: Maybe Text, + statusCode :: Maybe JSUInt + } + deriving (Show, Eq, Generic) + +instance ToJSON ContinueResponse where + toJSON :: ContinueResponse -> Value + toJSON = toJSONOmitNothing + +-- | Partial cookie for setting +data SetCookieHeader = MkSetCookieHeader + { name :: Text, + value :: BytesValue, + domain :: Maybe Text, + httpOnly :: Maybe Bool, + expiry :: Maybe Text, + maxAge :: Maybe JSUInt, + path :: Maybe Text, + secure :: Maybe Bool, + sameSite :: Maybe SameSite + } + deriving (Show, Eq, Generic) + +instance ToJSON SetCookieHeader where + toJSON :: SetCookieHeader -> Value + toJSON = toJSONOmitNothing + +-- | ContinueWithAuth parameters - using union type approach from spec +data ContinueWithAuth = MkContinueWithAuth + { request :: Request, + authAction :: AuthAction + } + deriving (Show, Eq, Generic) + +instance ToJSON ContinueWithAuth where + toJSON :: ContinueWithAuth -> Value + toJSON (MkContinueWithAuth req action) = + addProps "ContinueWithAuth" ["request" .= req] $ toJSON action + +-- | Auth action - matches spec's union type structure +data AuthAction + = ProvideCredentials AuthCredentials + | DefaultAuth + | CancelAuth + deriving (Show, Eq, Generic) + +instance ToJSON AuthAction where + toJSON :: AuthAction -> Value + toJSON (ProvideCredentials creds) = object ["action" .= "provideCredentials", "credentials" .= creds] + toJSON DefaultAuth = object ["action" .= "default"] + toJSON CancelAuth = object ["action" .= "cancel"] + +-- | Network intercept identifier +newtype Intercept = MkIntercept Text + deriving (Show, Eq, Generic, FromJSON, ToJSON) + +-- | Auth credentials for authentication +data AuthCredentials = MkAuthCredentials + { username :: Text, + password :: Text + } + deriving (Show, Eq, Generic) + +instance ToJSON AuthCredentials where + toJSON :: AuthCredentials -> Value + toJSON (MkAuthCredentials user pass) = + object + [ "type" .= "password", + "username" .= user, + "password" .= pass + ] + +-- | FailRequest parameters +data FailRequest = MkFailRequest + { request :: Request + } + deriving (Show, Eq, Generic) + +instance ToJSON FailRequest + +-- | ProvideResponse parameters +data ProvideResponse = MkProvideResponse + { request :: Request, + intercept :: Intercept, + body :: Maybe BytesValue, + cookies :: Maybe [Cookie], + headers :: Maybe [Header], + reasonPhrase :: Text, + statusCode :: Word + } + deriving (Show, Eq, Generic) + +instance ToJSON ProvideResponse where + toJSON :: ProvideResponse -> Value + toJSON = toJSONOmitNothing + +-- | RemoveIntercept parameters +newtype RemoveIntercept = MkRemoveIntercept + { intercept :: Intercept + } + deriving (Show, Eq, Generic) + +instance ToJSON RemoveIntercept + +-- | SetCacheBehavior parameters +data SetCacheBehavior = MkSetCacheBehavior + { cacheBehavior :: CacheBehavior, + contexts :: Maybe [BrowsingContext] + } + deriving (Show, Eq, Generic) + +instance ToJSON SetCacheBehavior where + toJSON :: SetCacheBehavior -> Value + toJSON = toJSONOmitNothing + +-- | Cache behavior options +data CacheBehavior + = DefaultCacheBehavior + | BypassCache + deriving (Show, Eq, Generic) + +instance ToJSON CacheBehavior where + toJSON :: CacheBehavior -> Value + toJSON DefaultCacheBehavior = "default" + toJSON BypassCache = "bypass" + +-- | SetExtraHeaders parameters +data SetExtraHeaders = MkSetExtraHeaders + { headers :: [Header], + contexts :: Maybe [BrowsingContext], + userContexts :: Maybe [UserContext] + } + deriving (Show, Eq, Generic) + +instance ToJSON SetExtraHeaders where + toJSON :: SetExtraHeaders -> Value + toJSON = toJSONOmitNothing + +-- ######### Local ######### + +newtype AddInterceptResult = MkAddInterceptResult + { -- name changed to avoid conflict with field name in AddIntercept + addedIntercept :: Intercept + } + deriving (Show, Eq, Generic) + +instance FromJSON AddInterceptResult where + parseJSON :: Value -> Parser AddInterceptResult + parseJSON = + withObject "AddInterceptResult" $ \obj -> + MkAddInterceptResult <$> obj .: "intercept" + +data NetworkEvent + = AuthRequiredEvent AuthRequired + | BeforeRequestSentEvent BeforeRequestSent + | FetchError FetchError + | ResponseCompleted ResponseCompleted + | ResponseStartedEvent ResponseStarted + deriving (Show, Eq, Generic) + +instance FromJSON NetworkEvent where + parseJSON :: Value -> Parser NetworkEvent + parseJSON val = + val + & ( withObject "NetworkEvent" $ \obj -> do + eventType <- obj .: "method" + params <- obj .: "params" + let parseParams :: forall a b. (FromJSON a) => (a -> b) -> Parser b + parseParams = (<&>) (parseJSON params) + case eventType of + NetworkAuthRequired -> parseParams AuthRequiredEvent + NetworkBeforeRequestSent -> parseParams BeforeRequestSentEvent + NetworkFetchError -> parseParams FetchError + NetworkResponseCompleted -> parseParams ResponseCompleted + NetworkResponseStarted -> parseParams ResponseStartedEvent + _ -> fail $ "Unknown NetworkEvent type: " <> show eventType + ) + + +data HTTPMethod + = GET + | POST + | PUT + | DELETE + | HEAD + | OPTIONS + | PATCH + | TRACE + | CONNECT + deriving (Show, Eq, Generic) + +instance FromJSON HTTPMethod where + parseJSON :: Value -> Parser HTTPMethod + parseJSON = withText "Method" $ \t -> + case toLower t of + "get" -> pure GET + "post" -> pure POST + "put" -> pure PUT + "delete" -> pure DELETE + "head" -> pure HEAD + "options" -> pure OPTIONS + "patch" -> pure PATCH + "trace" -> pure TRACE + "connect" -> pure CONNECT + _ -> fail $ "Unknown HTTP method: " <> show t + +data RequestData = MkRequestData + { request :: Request, + url :: Text, + method :: HTTPMethod, + headers :: [Header], + -- not as per spec but geckodriver appears to be returning cookie headers rather than cookies + cookies :: Maybe [CookieHeader], + -- cookies :: Maybe [Cookie], + headersSize :: JSUInt, + bodySize :: Maybe JSUInt, + destination :: Text, + initiatorType :: Maybe InitiatorType, + timings :: Maybe FetchTimingInfo + } + deriving (Show, Eq, Generic) + +instance FromJSON RequestData where + parseJSON :: Value -> Parser RequestData + parseJSON = parseJSONOmitNothing + +data FetchTimingInfo = MkFetchTimingInfo + { timeOrigin :: Double, + requestTime :: Double, + redirectStart :: Double, + redirectEnd :: Double, + fetchStart :: Double, + dnsStart :: Double, + dnsEnd :: Double, + connectStart :: Double, + connectEnd :: Double, + tlsStart :: Double, + requestStart :: Double, + responseStart :: Double, + responseEnd :: Double + } + deriving (Show, Eq, Generic) + +instance FromJSON FetchTimingInfo + +-- | AuthRequired parameters +data AuthRequired = MkAuthRequired + { context :: BrowsingContext, + isBlocked :: Bool, + navigation :: Maybe Navigation, + redirectCount :: JSUInt, + request :: RequestData, + timestamp :: JSUInt, + intercepts :: Maybe [Intercept], + response :: ResponseData + } + deriving (Show, Eq, Generic) + +instance FromJSON AuthRequired + +-- | Response data +-- Note: responseStatus is Int (not Word/JSUInt) because Chrome sends -1 for authRequired events +-- where the response hasn't been completed yet (deviation from spec which says js-uint) +data ResponseData = MkResponseData + { responseUrl :: Text, + responseProtocol :: Text, + responseStatus :: Int, + responseStatusText :: Text, + responseFromCache :: Bool, + responseHeaders :: [Header], + responseMimeType :: Text, + responseBytesReceived :: Word, + responseHeadersSize :: Maybe Word, + responseBodySize :: Maybe Word, + responseContent :: ResponseContent, + responseAuthChallenges :: Maybe [AuthChallenge] + } + deriving (Show, Eq, Generic) + +instance FromJSON ResponseData where + parseJSON :: Value -> Parser ResponseData + parseJSON = withObject "ResponseData" $ \obj -> do + responseUrl <- obj .: "url" + responseProtocol <- obj .: "protocol" + responseStatus <- obj .: "status" + responseStatusText <- obj .: "statusText" + responseFromCache <- obj .: "fromCache" + responseHeaders <- obj .: "headers" + responseMimeType <- obj .: "mimeType" + responseBytesReceived <- obj .: "bytesReceived" + responseHeadersSize <- obj .:? "headersSize" + responseBodySize <- obj .:? "bodySize" + responseContent <- obj .: "content" + responseAuthChallenges <- obj .:? "authChallenges" + pure MkResponseData {..} + +-- | Response content information +newtype ResponseContent = MkResponseContent + { size :: JSUInt + } + deriving (Show, Eq, Generic) + +instance FromJSON ResponseContent + +data AuthChallenge = MkAuthChallenge + { scheme :: Text, + realm :: Text + } + deriving (Show, Eq, Generic) + +instance FromJSON AuthChallenge + +-- | BeforeRequestSent parameters +data BeforeRequestSent = MkBeforeRequestSent + { context :: BrowsingContext, + isBlocked :: Bool, + navigation :: Maybe Navigation, + redirectCount :: JSUInt, + request :: RequestData, + timestamp :: JSUInt, + intercepts :: Maybe [Intercept], + beforeRequestInitiator :: Maybe Initiator + } + deriving (Show, Eq, Generic) + +instance FromJSON BeforeRequestSent where + parseJSON :: Value -> Parser BeforeRequestSent + parseJSON = parseJSONOmitNothing + +data Initiator = MkInitiator + { initiatorColumnNumber :: Maybe Word, + initiatorLineNumber :: Maybe Word, + initiatorRequest :: Maybe Request, + initiatorStackTrace :: Maybe StackTrace, + initiatorType :: Maybe InitiatorType + } + deriving (Show, Eq, Generic) + +instance FromJSON Initiator where + parseJSON :: Value -> Parser Initiator + parseJSON = parseJSONOmitNothing + +-- | Information about what initiated a request +data InitiatorType + = Audio + | Beacon + | Body + | CSSInitiatorType + | EarlyHints + | Embed + | Fetch + | Font + | Frame + | IFrame + | Image + | Img + | Input + | Link + | ObjectElement + | Ping + | Script + | Track + | Video + | XMLHttpRequest + | Other + deriving (Show, Eq, Generic) + +instance FromJSON InitiatorType where + parseJSON :: Value -> Parser InitiatorType + parseJSON = withText "InitiatorType" $ \t -> + case toLower t of + "audio" -> pure Audio + "beacon" -> pure Beacon + "body" -> pure Body + "css" -> pure CSSInitiatorType + "early-hints" -> pure EarlyHints + "embed" -> pure Embed + "fetch" -> pure Fetch + "font" -> pure Font + "frame" -> pure Frame + "iframe" -> pure IFrame + "image" -> pure Image + "img" -> pure Img + "input" -> pure Input + "link" -> pure Link + "object" -> pure ObjectElement + "ping" -> pure Ping + "script" -> pure Script + "track" -> pure Track + "video" -> pure Video + "xmlhttprequest" -> pure XMLHttpRequest + "other" -> pure Other + _ -> fail $ "Unknown InitiatorType: " <> show t + +-- | FetchError parameters +data FetchError = MkFetchError + { context :: BrowsingContext, + isBlocked :: Bool, + navigation :: Maybe Navigation, + redirectCount :: JSUInt, + request :: RequestData, + timestamp :: JSUInt, + intercepts :: Maybe [Intercept], + errorText :: Text + } + deriving (Show, Eq, Generic) + +instance FromJSON FetchError where + parseJSON :: Value -> Parser FetchError + parseJSON = parseJSONOmitNothing + +-- | ResponseCompleted parameters +data ResponseCompleted = MkResponseCompleted + { context :: BrowsingContext, + isBlocked :: Bool, + navigation :: Maybe Navigation, + redirectCount :: JSUInt, + request :: RequestData, + timestamp :: JSUInt, + intercepts :: Maybe [Intercept], + response :: ResponseData + } + deriving (Show, Eq, Generic) + +instance FromJSON ResponseCompleted where + parseJSON :: Value -> Parser ResponseCompleted + parseJSON = parseJSONOmitNothing + +-- | ResponseStarted parameters +data ResponseStarted = MkResponseStarted + { context :: BrowsingContext, + isBlocked :: Bool, + navigation :: Maybe Navigation, + redirectCount :: JSUInt, + request :: RequestData, + timestamp :: JSUInt, + intercepts :: Maybe [Intercept], + response :: ResponseData + } + deriving (Show, Eq, Generic) + +instance FromJSON ResponseStarted where + parseJSON :: Value -> Parser ResponseStarted + parseJSON = parseJSONOmitNothing + +newtype GetDataResult = MkGetDataResult + { bytes :: BytesValue + } + deriving (Show, Eq, Generic) + +instance FromJSON GetDataResult + +newtype AddDataCollectorResult = MkAddDataCollectorResult + { collector :: Collector + } + deriving (Show, Eq, Generic) + +instance FromJSON AddDataCollectorResult diff --git a/src/WebDriverPreCore/BiDi/Protocol.hs b/src/WebDriverPreCore/BiDi/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/BiDi/Protocol.hs @@ -0,0 +1,81 @@ + +{-| +This module defines the 'Command' type and related types/functions for BiDi commands referenced by the API functions in "WebDriverPreCore.BiDi.API" + +"WebDriverPreCore.BiDi.API" contains functions that generate the payload for each BiDi command and is the main interface for users of this package to interact with BiDi. + +An example of using these modules to implement a basic BiDi client can be found in the [test repository](https://github.com/pyrethrum/webdriver/tree/main/webdriver-precore/test#readme) for this package. +-} + +module WebDriverPreCore.BiDi.Protocol + ( + -- * Command + Command (..), + CommandMethod (..), + KnownCommand (..), + OffSpecCommand (..), + -- ** Constructors + {-| The following constructors are partially applied in "WebDriverPreCore.BiDi.API" to generate specific named command functions. + Although these functions form the basis of every command in the "WebDriverPreCore.BiDi.API", it would be unusual to need to use these directly. + -} + mkCommand, + emptyCommand, + -- ** Fallback Constructors + {-| The following constructors are provided to modify or create new commands that are not directly supported by the "WebDriverPreCore.BiDi.API". + These constructors provide a means by which users can work around defects in this package or defects in driver implementation as well as handling driver specific extensions to the BiDi protocol. + -} + mkOffSpecCommand, + extendCommand, + extendLoosenCommand, + extendCoerceCommand, + loosenCommand, + coerceCommand, + -- ** Command Method Utilities + knownCommandToText, + toCommandText, + -- * Browser + module WebDriverPreCore.BiDi.Browser, + -- * Browsing Context + module WebDriverPreCore.BiDi.BrowsingContext, + -- * Capabilities + module WebDriverPreCore.BiDi.Capabilities, + -- * Event + module WebDriverPreCore.BiDi.Event, + -- * Emulation + module WebDriverPreCore.BiDi.Emulation, + -- * Input + module WebDriverPreCore.BiDi.Input, + -- * Log + module WebDriverPreCore.BiDi.Log, + -- * Script + module WebDriverPreCore.BiDi.Script, + -- * Session + module WebDriverPreCore.BiDi.Session, + -- * Storage + module WebDriverPreCore.BiDi.Storage, + -- * Web Extensions + module WebDriverPreCore.BiDi.WebExtensions, + -- * Network + module WebDriverPreCore.BiDi.Network, + -- * Core Types + module WebDriverPreCore.BiDi.CoreTypes, + -- * Error + module WebDriverPreCore.Error, + ) +where + +import WebDriverPreCore.BiDi.Browser +import WebDriverPreCore.BiDi.BrowsingContext +import WebDriverPreCore.BiDi.Capabilities +import WebDriverPreCore.BiDi.Command +import WebDriverPreCore.BiDi.CoreTypes +import WebDriverPreCore.BiDi.Emulation +import WebDriverPreCore.Error +import WebDriverPreCore.BiDi.Event +import WebDriverPreCore.BiDi.Input +import WebDriverPreCore.BiDi.Log +import WebDriverPreCore.BiDi.Network +import WebDriverPreCore.BiDi.Script +import WebDriverPreCore.BiDi.Session +import WebDriverPreCore.BiDi.Storage +import WebDriverPreCore.BiDi.WebExtensions diff --git a/src/WebDriverPreCore/BiDi/Script.hs b/src/WebDriverPreCore/BiDi/Script.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/BiDi/Script.hs @@ -0,0 +1,883 @@ +module WebDriverPreCore.BiDi.Script + ( -- * ScriptCommand + AddPreloadScript (..), + ContextTarget (..), + RemoteValue (..), + PrimitiveProtocolValue (..), + SpecialNumber (..), + WindowProxyProperties (..), + CallFunction (..), + LocalValue (..), + ListLocalValue (..), + ArrayLocalValue (..), + DateLocalValue (..), + MappingLocalValue (..), + MapLocalValue (..), + ObjectLocalValue (..), + IncludeShadowTree (..), + RegExpValue (..), + RegExpLocalValue (..), + SetLocalValue (..), + ResultOwnership (..), + SerializationOptions (..), + RealmType (..), + Disown (..), + Target (..), + Realm (..), + RealmDestroyed (..), + Sandbox (..), + Evaluate (..), + GetRealms (..), + RemovePreloadScript (..), + + -- * ScriptResult + AddPreloadScriptResult (..), + GetRealmsResult (..), + RealmInfo (..), + BaseRealmInfo (..), + EvaluateResult (..), + ExceptionDetails (..), + StackTrace (..), + StackFrame (..), + ScriptEvent (..), + Message (..), + Channel (..), + Source (..), + ChannelValue (..), + ChannelProperties (..), + + -- * PreloadScript + PreloadScript (..), + RemoteReference (..), + SharedReference (..), + RemoteObjectReference (..), + ) +where + +import Control.Applicative ((<|>)) +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), defaultOptions, genericToJSON, object, withObject, (.:), (.:?), (.=)) +import Data.Aeson.Types (Parser, omitNothingFields) +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes) +import Data.Text (Text, unpack) +import Data.Vector qualified as V +import GHC.Generics +import WebDriverPreCore.BiDi.CoreTypes (BrowsingContext, Handle, InternalId (..), JSUInt, NodeRemoteValue (..), SharedId, StringValue (..), UserContext) +import AesonUtils (jsonToText, opt, parseJSONOmitNothing, toJSONOmitNothing) + + +-- ######### REMOTE ######### + +-- AddPreloadScript command +data AddPreloadScript = MkAddPreloadScript + { functionDeclaration :: Text, + arguments :: Maybe [ChannelValue], + contexts :: Maybe [BrowsingContext], + userContexts :: Maybe [UserContext], + sandbox :: Maybe Text + } + deriving (Show, Eq, Generic) + +-- Remote Value types +data RemoteValue + = PrimitiveValue PrimitiveProtocolValue + | SymbolValue + { -- "symbol" + handle :: Maybe Handle, + internalId :: Maybe InternalId + } + | ArrayValue + { -- "array" + handle :: Maybe Handle, + internalId :: Maybe InternalId, + value :: Maybe [RemoteValue] + } + | ObjectValue + { handle :: Maybe Handle, + internalId :: Maybe InternalId, + -- change to value from / to JSON + values :: Maybe [(Either RemoteValue Text, RemoteValue)] + } + | FunctionValue + { handle :: Maybe Handle, + internalId :: Maybe InternalId + } + | RegExpValue + { handle :: Maybe Handle, + internalId :: Maybe InternalId, + pattern' :: Text, + flags :: Maybe Text + } + | DateValue + { handle :: Maybe Handle, + internalId :: Maybe InternalId, + dateValue :: Text + } + | MapValue + { handle :: Maybe Handle, + internalId :: Maybe InternalId, + values :: Maybe [(Either RemoteValue Text, RemoteValue)] + } + | SetValue + { handle :: Maybe Handle, + internalId :: Maybe InternalId, + value :: Maybe [RemoteValue] + } + | WeakMapValue + { handle :: Maybe Handle, + internalId :: Maybe InternalId + } + | WeakSetValue + { handle :: Maybe Handle, + internalId :: Maybe InternalId + } + | GeneratorValue + { handle :: Maybe Handle, + internalId :: Maybe InternalId + } + | ErrorValue + { handle :: Maybe Handle, + internalId :: Maybe InternalId + } + | ProxyValue + { handle :: Maybe Handle, + internalId :: Maybe InternalId + } + | PromiseValue + { handle :: Maybe Handle, + internalId :: Maybe InternalId + } + | TypedArrayValue + { handle :: Maybe Handle, + internalId :: Maybe InternalId + } + | ArrayBufferValue + { handle :: Maybe Handle, + internalId :: Maybe InternalId + } + | NodeListValue + { handle :: Maybe Handle, + internalId :: Maybe InternalId, + value :: Maybe [RemoteValue] + } + | HTMLCollectionValue + { handle :: Maybe Handle, + internalId :: Maybe InternalId, + value :: Maybe [RemoteValue] + } + | NodeValue NodeRemoteValue + | WindowProxyValue + { -- "window" + winProxyValue :: WindowProxyProperties, + handle :: Maybe Handle, -- Optional handle + internalId :: Maybe InternalId -- Optional internal ID + } + deriving (Show, Eq, Generic) + +instance FromJSON RemoteValue where + parseJSON :: Value -> Parser RemoteValue + parseJSON = withObject "RemoteValue" $ \obj -> do + typ <- obj .: "type" + handle <- obj .:? "handle" + internalId <- obj .:? "internalId" + case typ of + "undefined" -> pure $ PrimitiveValue UndefinedValue + "null" -> pure $ PrimitiveValue NullValue + "string" -> PrimitiveValue . StringValue . MkStringValue <$> obj .: "value" + "number" -> + PrimitiveValue . NumberValue <$> do + v <- obj .: "value" + case v of + Number n -> pure $ Left (realToFrac n) + String s -> case s of + "NaN" -> pure $ Right NaN + "-0" -> pure $ Right NegativeZero + "Infinity" -> pure $ Right Infinity + "-Infinity" -> pure $ Right NegativeInfinity + _ -> fail $ "Unknown SpecialNumber string: " <> unpack s + _ -> fail $ "Expected number or special number string, got: " <> show v + "boolean" -> PrimitiveValue . BooleanValue <$> obj .: "value" + "bigint" -> PrimitiveValue . BigIntValue <$> obj .: "value" + "node" -> NodeValue <$> parseJSON (Object obj) + "array" -> do + value <- obj .:? "value" + pure $ ArrayValue {..} + "object" -> do + values <- obj .:? "values" + pure $ ObjectValue {..} + "regexp" -> do + value <- obj .: "value" + pattern' <- value .: "pattern" + flags <- value .:? "flags" + pure $ RegExpValue {..} + "date" -> do + dateValue <- obj .: "value" + pure $ DateValue {..} + "map" -> do + maybeValues <- obj .:? "value" + values <- traverse (mapM parseMapEntry) maybeValues + pure $ MapValue {..} + where + parseMapEntry :: Value -> Parser (Either RemoteValue Text, RemoteValue) + parseMapEntry val = case val of + Array arr -> case V.toList arr of + [keyVal, valueVal] -> do + -- try parse Text first, then RemoteValue + key <- (Right <$> parseJSON keyVal) <|> (Left <$> parseJSON keyVal) + value <- parseJSON valueVal + pure (key, value) + _ -> fail "Map entry must be an array with exactly 2 elements" + _ -> fail "Map entry must be an array" + "set" -> do + value <- obj .:? "value" + pure $ SetValue {..} + "window" -> do + winProxyValue <- obj .: "value" + pure $ WindowProxyValue {..} + "nodelist" -> do + value <- obj .:? "value" + pure $ NodeListValue {..} + "htmlcollection" -> do + value <- obj .:? "value" + pure $ HTMLCollectionValue {..} + "function" -> pure $ FunctionValue {..} + "symbol" -> pure $ SymbolValue {..} + "weakmap" -> pure $ WeakMapValue {..} + "weakset" -> pure $ WeakSetValue {..} + "generator" -> pure $ GeneratorValue {..} + "error" -> pure $ ErrorValue {..} + "proxy" -> pure $ ProxyValue {..} + "promise" -> pure $ PromiseValue {..} + "typedarray" -> pure $ TypedArrayValue {..} + "arraybuffer" -> pure $ ArrayBufferValue {..} + _ -> fail $ "Unknown RemoteValue type: " <> show typ <> "\n" <> (unpack $ jsonToText $ Object obj) + +-- | WindowProxy remote value representation +data PrimitiveProtocolValue + = UndefinedValue + | NullValue + | StringValue StringValue + | NumberValue (Either Double SpecialNumber) + | BooleanValue Bool + | BigIntValue Text + deriving (Show, Eq, Generic) + +data SpecialNumber + = NaN + | NegativeZero + | Infinity + | NegativeInfinity + deriving (Show, Eq, Generic) + +instance FromJSON SpecialNumber + +instance ToJSON SpecialNumber where + toJSON :: SpecialNumber -> Value + toJSON = \case + NaN -> "NaN" + NegativeZero -> "-0" + Infinity -> "Infinity" + NegativeInfinity -> "-Infinity" + +-- | Properties of a WindowProxy remote value +newtype WindowProxyProperties = MkWindowProxyProperties + { context :: BrowsingContext + } + deriving (Show, Eq, Generic) + +instance FromJSON WindowProxyProperties + +instance ToJSON WindowProxyProperties + +-- CallFunction command +data CallFunction = MkCallFunction + { functionDeclaration :: Text, + awaitPromise :: Bool, + target :: Target, + arguments :: Maybe [LocalValue], + resultOwnership :: Maybe ResultOwnership, + serializationOptions :: Maybe SerializationOptions, + this :: Maybe LocalValue + } + deriving (Show, Eq, Generic) + +-- \| Local value representation +data LocalValue + = RemoteReference RemoteReference + | PrimitiveLocalValue PrimitiveProtocolValue + | ChannelValue ChannelValue + | ArrayLocalValue ArrayLocalValue + | DateLocalValue DateLocalValue + | MapLocalValue MapLocalValue + | ObjectLocalValue ObjectLocalValue + | RegExpLocalValue RegExpLocalValue + | SetLocalValue SetLocalValue + deriving (Show, Eq, Generic) + +data RemoteReference = MkRemoteReference + { sharedreference :: SharedReference, + remoteObjectReference :: RemoteObjectReference + } + deriving (Show, Eq, Generic) + +data SharedReference = MkSharedReference + { sharedId :: SharedId, + handle :: Maybe Handle, + extensions :: Maybe (Map.Map Text Value) -- "extensions" field is optional + } + deriving (Show, Eq, Generic) + +instance FromJSON SharedReference where + parseJSON :: Value -> Parser SharedReference + parseJSON = parseJSONOmitNothing + +data RemoteObjectReference = MkRemoteObjectReference + { handle :: Handle, + shartedId :: Maybe SharedId, + extensions :: Maybe (Map.Map Text Value) -- "extensions" field is optional + } + deriving (Show, Eq, Generic) + +-- | List of local values +newtype ListLocalValue = MkListLocalValue [LocalValue] + deriving (Show, Eq, Generic) + +-- | Array local value +data ArrayLocalValue = MkArrayLocalValue + { typ :: Text, -- "array" + value :: ListLocalValue + } + deriving (Show, Eq, Generic) + +-- | Date local value +newtype DateLocalValue = MkDateLocalValue + { value :: Text + } + deriving (Show, Eq, Generic) + +-- | Mapping of local values +newtype MappingLocalValue = MkMappingLocalValue [(Either LocalValue Text, LocalValue)] + deriving (Show, Eq, Generic) + +-- | Map local value +data MapLocalValue = MkMapLocalValue + { value :: MappingLocalValue + } + deriving (Show, Eq, Generic) + +-- | Object local value +data ObjectLocalValue = MkObjectLocalValue + { value :: MappingLocalValue + } + deriving (Show, Eq, Generic) + +-- | RegExp value +data RegExpValue = MkRegExpValue + { regExpPattern :: Text, + flags :: Maybe Text + } + deriving (Show, Eq, Generic) + +-- | RegExp local value +data RegExpLocalValue = MkRegExpLocalValue + { value :: RegExpValue + } + deriving (Show, Eq, Generic) + +-- | Set local value +data SetLocalValue = MkSetLocalValue + { typ :: Text, -- "set" + value :: ListLocalValue + } + deriving (Show, Eq, Generic) + +-- OwnershipNone ~ None - renamed to avoid clash with BrowsingContext None +data ResultOwnership = Root | OwnershipNone deriving (Show, Eq, Generic) + +instance FromJSON ResultOwnership where + parseJSON :: Value -> Parser ResultOwnership + parseJSON = withObject "ResultOwnership" $ \obj -> do + typ <- obj .: "type" + case typ of + "root" -> pure Root + "none" -> pure OwnershipNone + _ -> fail $ "Unknown ResultOwnership type: " <> unpack typ + +instance ToJSON ResultOwnership where + toJSON :: ResultOwnership -> Value + toJSON = \case + Root -> "root" + OwnershipNone -> "none" + +-- | RealmType represents the different types of Realm +data RealmType + = WindowRealm + | DedicatedWorkerRealm + | SharedWorkerRealm + | ServiceWorkerRealm + | WorkerRealm + | PaintWorkletRealm + | AudioWorkletRealm + | WorkletRealm + deriving (Show, Eq, Generic) + +instance FromJSON RealmType + +instance ToJSON RealmType where + toJSON :: RealmType -> Value + toJSON = \case + WindowRealm -> "window" + DedicatedWorkerRealm -> "dedicated-worker" + SharedWorkerRealm -> "shared-worker" + ServiceWorkerRealm -> "service-worker" + WorkerRealm -> "worker" + PaintWorkletRealm -> "paint-worklet" + AudioWorkletRealm -> "audio-worklet" + WorkletRealm -> "worklet" + +data SerializationOptions = MkSerializationOptions + { maxDomDepth :: Maybe (Maybe JSUInt), -- .default 0 + maxObjectDepth :: Maybe (Maybe JSUInt), -- .default null + includeShadowTree :: Maybe IncludeShadowTree -- "none", "open", "all" .default "none" + } + deriving (Show, Eq, Generic) + +instance ToJSON SerializationOptions where + toJSON :: SerializationOptions -> Value + toJSON = genericToJSON defaultOptions {omitNothingFields = True} + +data IncludeShadowTree = ShadowTreeNone | Open | All deriving (Show, Eq, Generic) + +instance ToJSON IncludeShadowTree where + toJSON :: IncludeShadowTree -> Value + toJSON = \case + ShadowTreeNone -> "none" -- name changed to avoid clash with BrowsingContext None + Open -> "open" + All -> "all" + +-- Disown command +data Disown = MkDisown + { handles :: [Handle], + target :: Target + } + deriving (Show, Eq, Generic) + +data Target + = RealmTarget Realm + | ContextTarget ContextTarget + deriving (Show, Eq, Generic) + +newtype Realm = MkRealm {realm :: Text} deriving (Show, Eq, Generic, FromJSON) + +data ContextTarget = MkContextTarget + { context :: BrowsingContext, + sandbox :: Maybe Sandbox + } + deriving (Show, Eq, Generic) + +instance FromJSON ContextTarget + +instance ToJSON ContextTarget where + toJSON :: ContextTarget -> Value + toJSON = genericToJSON defaultOptions {omitNothingFields = True} + +newtype Sandbox = MkSandbox Text + deriving (Show, Eq) + deriving newtype (ToJSON, FromJSON) + +instance ToJSON Realm + +-- Simple sum types +instance ToJSON Target where + toJSON :: Target -> Value + toJSON = \case + RealmTarget r -> toJSON r + ContextTarget ct -> toJSON ct + +-- Evaluate command +data Evaluate = MkEvaluate + { expression :: Text, + target :: Target, + awaitPromise :: Bool, + resultOwnership :: Maybe ResultOwnership, + serializationOptions :: Maybe SerializationOptions + } + deriving (Show, Eq, Generic) + +instance ToJSON Evaluate where + toJSON :: Evaluate -> Value + toJSON = genericToJSON defaultOptions {omitNothingFields = True} + +-- GetRealms command +data GetRealms = MkGetRealms + { context :: Maybe BrowsingContext, + realmType :: Maybe RealmType + } + deriving (Show, Eq, Generic) + +-- RemovePreloadScript command +newtype RemovePreloadScript = MkRemovePreloadScript + { script :: PreloadScript + } + deriving (Show, Eq, Generic) + +newtype PreloadScript = MkPreloadScript Text deriving (Show, Generic, Eq) + +instance FromJSON PreloadScript + +instance ToJSON PreloadScript + +-- Target specification + +-- ######### Local ######### + +newtype AddPreloadScriptResult = MkAddPreloadScriptResult + { script :: PreloadScript + } + deriving (Show, Eq, Generic) + +newtype GetRealmsResult = MkGetRealmsResult + { realms :: [RealmInfo] + } + deriving (Show, Eq, Generic) + +data RealmInfo + = WindowRealmInfo + { base :: BaseRealmInfo, + context :: BrowsingContext, + sandbox :: Maybe Text + } + | DedicatedWorker {base :: BaseRealmInfo, owners :: [Realm]} + | SharedWorker {base :: BaseRealmInfo} + | ServiceWorker {base :: BaseRealmInfo} + | Worker {base :: BaseRealmInfo} + | PaintWorklet {base :: BaseRealmInfo} + | AudioWorklet {base :: BaseRealmInfo} + | Worklet {base :: BaseRealmInfo} + deriving (Show, Eq, Generic) + +instance FromJSON RealmInfo where + parseJSON :: Value -> Parser RealmInfo + parseJSON = withObject "RealmInfo" $ \o -> do + typ <- o .: "type" + base <- BaseRealmInfo <$> o .: "realm" <*> o .: "origin" + case typ of + "window" -> do + context <- o .: "context" + sandbox <- o .:? "sandbox" + pure $ WindowRealmInfo {base, context, sandbox} + "dedicated-worker" -> do + owners <- o .: "owners" + pure $ DedicatedWorker {base, owners} + "shared-worker" -> pure $ SharedWorker {base} + "service-worker" -> pure $ ServiceWorker {base} + "worker" -> pure $ Worker {base} + "paint-worklet" -> pure $ PaintWorklet {base} + "audio-worklet" -> pure $ AudioWorklet {base} + "worklet" -> pure $ Worklet {base} + _ -> fail $ "Unknown RealmInfo type: " <> unpack typ + +data BaseRealmInfo = BaseRealmInfo + { realm :: Realm, + origin :: Text + } + deriving (Show, Eq, Generic) + +data EvaluateResult + = EvaluateResultSuccess + { result :: RemoteValue, + realm :: Realm + } + | EvaluateResultException + { exceptionDetails :: ExceptionDetails, + realm :: Realm + } + deriving (Show, Eq, Generic) + +instance FromJSON EvaluateResult where + parseJSON :: Value -> Parser EvaluateResult + parseJSON = withObject "EvaluateResult" $ \o -> do + typ <- o .: "type" + case typ of + "success" -> do + result <- o .: "result" + realm <- o .: "realm" + pure $ EvaluateResultSuccess {result, realm} + "exception" -> do + exceptionDetails <- o .: "exceptionDetails" + realm <- o .: "realm" + pure $ EvaluateResultException {exceptionDetails, realm} + _ -> fail $ "Unknown EvaluateResult type: " <> unpack typ + +data ExceptionDetails = MkExceptionDetails + { columnNumber :: JSUInt, + exception :: RemoteValue, + lineNumber :: JSUInt, + stackTrace :: StackTrace, + text :: Text + } + deriving (Show, Eq, Generic) + +data StackTrace = MkStackTrace + { callFrames :: [StackFrame] + } + deriving (Show, Eq, Generic) + +data StackFrame = StackFrame + { columnNumber :: JSUInt, + functionName :: Text, + lineNumber :: JSUInt, + url :: Text + } + deriving (Show, Eq, Generic) + +-- ScriptEvent types + +data ScriptEvent + = MessageEvent Message + | RealmCreatedEvent RealmInfo + | RealmDestroyed RealmDestroyed + deriving (Show, Eq, Generic) + +instance FromJSON ScriptEvent where + parseJSON :: Value -> Parser ScriptEvent + parseJSON = withObject "ScriptEvent" $ \o -> do + typ <- o .: "method" + case typ of + "script.message" -> do + params <- o .: "params" + pure $ MessageEvent params + "script.realmCreated" -> do + params <- o .: "params" + realmInfo <- parseJSON params + pure $ RealmCreatedEvent realmInfo + "script.realmDestroyed" -> do + params <- o .: "params" + realmid <- params .: "realm" + pure . RealmDestroyed $ MkRealmDestroyed realmid + _ -> fail $ "Unknown ScriptEvent method: " <> unpack typ + +data Message = MkMessage + { channel :: Channel, + messageData :: RemoteValue, + source :: Source + } + deriving (Show, Eq, Generic) + +instance FromJSON Message where + parseJSON :: Value -> Parser Message + parseJSON = withObject "Message" $ \o -> do + channel <- o .: "channel" + messageData <- o .: "data" + source <- o .: "source" + pure $ MkMessage {channel, messageData, source} + +newtype Channel = Channel {channelId :: Text} + deriving newtype + ( Show, + Eq, + ToJSON, + FromJSON + ) + +data Source = MkSource + { realm :: Realm, + context :: Maybe BrowsingContext + } + deriving (Show, Eq, Generic) + +instance FromJSON Source where + parseJSON :: Value -> Parser Source + parseJSON = parseJSONOmitNothing + +newtype ChannelValue = MkChannelValue + { value :: ChannelProperties + } + deriving (Show, Eq, Generic) + +data ChannelProperties = MkChannelProperties + { channel :: Channel, + serializationOptions :: Maybe SerializationOptions, + ownership :: Maybe ResultOwnership + } + deriving (Show, Eq, Generic) + +-- ToJSON instances for Script module + +-- Simple newtypes +-- ToJSON instances for missing command types +instance ToJSON AddPreloadScript where + toJSON :: AddPreloadScript -> Value + toJSON = toJSONOmitNothing + +instance ToJSON CallFunction where + toJSON :: CallFunction -> Value + toJSON = toJSONOmitNothing + +-- GetRealms has a typ field that needs special handling +instance ToJSON GetRealms where + toJSON :: GetRealms -> Value + toJSON MkGetRealms {context, realmType} = + object $ + catMaybes + [ opt "context" context, + opt "type" realmType + ] + +-- RealmType uses specific string values as per spec + +-- Command types +instance ToJSON Disown + +instance ToJSON RemovePreloadScript + +instance ToJSON PrimitiveProtocolValue where + toJSON :: PrimitiveProtocolValue -> Value + toJSON = \case + UndefinedValue -> object ["type" .= "undefined"] + NullValue -> object ["type" .= "null"] + StringValue str -> + object + [ "type" .= "string", + "value" .= str + ] + NumberValue (Left num) -> + object + [ "type" .= "number", + "value" .= num + ] + NumberValue (Right special) -> + object + [ "type" .= "number", + "value" .= special + ] + BooleanValue bool -> + object + [ "type" .= "boolean", + "value" .= bool + ] + BigIntValue str -> + object + [ "type" .= "bigint", + "value" .= str + ] + +-- Local Value types +instance ToJSON LocalValue where + toJSON :: LocalValue -> Value + toJSON = \case + RemoteReference ref -> toJSON ref + PrimitiveLocalValue prim -> toJSON prim + ChannelValue channel -> toJSON channel + ArrayLocalValue arr -> toJSON arr + DateLocalValue date -> toJSON date + MapLocalValue mapVal -> toJSON mapVal + ObjectLocalValue obj -> toJSON obj + RegExpLocalValue regex -> toJSON regex + SetLocalValue set -> toJSON set + +instance ToJSON RemoteReference + +instance ToJSON SharedReference where + toJSON :: SharedReference -> Value + toJSON = toJSONOmitNothing + +instance ToJSON RemoteObjectReference + +instance ToJSON ListLocalValue + +-- Types with typ field that need manual handling +instance ToJSON ArrayLocalValue where + toJSON (MkArrayLocalValue _ value) = + object + [ "type" .= "array", + "value" .= value + ] + +instance ToJSON DateLocalValue where + toJSON (MkDateLocalValue value) = + object + [ "type" .= "date", + "value" .= value + ] + +instance ToJSON MappingLocalValue where + toJSON :: MappingLocalValue -> Value + toJSON (MkMappingLocalValue pairs) = + toJSON $ pairToArray <$> pairs + where + pairToArray :: (Either LocalValue Text, LocalValue) -> [Value] + pairToArray (key, value) = [keyToJson key, toJSON value] + + keyToJson :: Either LocalValue Text -> Value + keyToJson (Left localVal) = toJSON localVal + keyToJson (Right text) = toJSON text + +instance ToJSON MapLocalValue where + toJSON :: MapLocalValue -> Value + toJSON (MkMapLocalValue value) = + object + [ "type" .= "map", + "value" .= value + ] + +instance ToJSON ObjectLocalValue where + toJSON :: ObjectLocalValue -> Value + toJSON (MkObjectLocalValue value) = + object + [ "type" .= "object", + "value" .= value + ] + +instance ToJSON RegExpValue + +instance ToJSON RegExpLocalValue where + toJSON (MkRegExpLocalValue value) = + object + [ "type" .= "regexp", + "value" .= value + ] + +instance ToJSON SetLocalValue where + toJSON (MkSetLocalValue _ value) = + object + [ "type" .= "set", + "value" .= value + ] + +-- ChannelValue has typ field that needs manual handling +instance ToJSON ChannelValue where + toJSON :: ChannelValue -> Value + toJSON (MkChannelValue value) = + object + [ "type" .= "channel", + "value" .= value + ] + +instance ToJSON ChannelProperties where + toJSON :: ChannelProperties -> Value + toJSON = toJSONOmitNothing + +-- FromJSON instances for Script module + +-- Basic types + +instance FromJSON PrimitiveProtocolValue + +-- Complex result types + +instance FromJSON AddPreloadScriptResult + +instance FromJSON GetRealmsResult + +instance FromJSON BaseRealmInfo + +instance FromJSON ExceptionDetails + +instance FromJSON StackTrace + +instance FromJSON StackFrame + +newtype RealmDestroyed = MkRealmDestroyed {realm :: Realm} deriving (Show, Eq, Generic) + +instance FromJSON RealmDestroyed diff --git a/src/WebDriverPreCore/BiDi/Session.hs b/src/WebDriverPreCore/BiDi/Session.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/BiDi/Session.hs @@ -0,0 +1,93 @@ +module WebDriverPreCore.BiDi.Session + ( SubscriptionId (..), + SessionSubscibe (..), + SessionUnsubscribe (..), + SessionNewResult (..), + SessionStatusResult (..), + SessionSubscribeResult (..), + ) +where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, (.:), (.=)) +import Data.Aeson.Types (Parser) +import Data.Text (Text) +import GHC.Generics (Generic) +import WebDriverPreCore.BiDi.Capabilities (CapabilitiesResult) +import WebDriverPreCore.BiDi.CoreTypes (BrowsingContext, UserContext, SubscriptionType) +import AesonUtils (toJSONOmitNothing) + +-- ######### Remote ######### + +-- | Subscription +newtype SubscriptionId = MkSubscriptionId {subscriptionId :: Text} + deriving newtype (Show, Eq, FromJSON, ToJSON) + +-- | Subscription Request +data SessionSubscibe = MkSessionSubscribe + { events :: [SubscriptionType], + contexts :: Maybe [BrowsingContext], + userContexts :: Maybe [UserContext] + } + deriving (Show, Eq, Generic) + +instance ToJSON SessionSubscibe where + toJSON :: SessionSubscibe -> Value + toJSON = toJSONOmitNothing + +-- | Unsubscribe Parameters +data SessionUnsubscribe + = UnsubscribeById + {subscriptions :: [SubscriptionId]} + | UnsubscribeByAttributes + { unsubEvents :: [SubscriptionType] + } + deriving (Show, Eq, Generic) + +instance ToJSON SessionUnsubscribe where + toJSON :: SessionUnsubscribe -> Value + toJSON (UnsubscribeById {subscriptions}) = + object ["subscriptions" .= subscriptions] + toJSON (UnsubscribeByAttributes {unsubEvents}) = + object $ + ["events" .= unsubEvents] + +-- ######### Local ######### + +-- | Session New Result +data SessionNewResult = MkSessionNewResult + { sessionId :: Text, + capabilities :: CapabilitiesResult + } + deriving (Show, Eq, Generic) + +instance ToJSON SessionNewResult where + toJSON :: SessionNewResult -> Value + toJSON (MkSessionNewResult sessionId capabilities) = + object + [ "sessionId" .= sessionId, + "capabilities" .= capabilities + ] + +instance FromJSON SessionNewResult where + parseJSON :: Value -> Parser SessionNewResult + parseJSON = withObject "SessionNewResult" $ \v -> + MkSessionNewResult + <$> v .: "sessionId" + <*> v .: "capabilities" + +-- | Session Status Result +data SessionStatusResult = MkSessionStatusResult + { ready :: Bool, + message :: Text + } + deriving (Show, Eq, Generic) + +instance FromJSON SessionStatusResult + +-- | Session Subscribe Result +newtype SessionSubscribeResult = MkSessionSubscribeResult + { subscription :: SubscriptionId + } + deriving (Show, Eq, Generic) + +instance FromJSON SessionSubscribeResult diff --git a/src/WebDriverPreCore/BiDi/Storage.hs b/src/WebDriverPreCore/BiDi/Storage.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/BiDi/Storage.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module WebDriverPreCore.BiDi.Storage + ( PartitionKey (..), + GetCookiesResult (..), + SetCookieResult (..), + DeleteCookiesResult (..), + GetCookies (..), + CookieFilter (..), + PartitionDescriptor (..), + SetCookie (..), + PartialCookie (..), + DeleteCookies (..), + ) +where + +{- +create types to represent the remote and local end for storage: + +1. preface singleton data constructors (ie the constructor for types with only one type constructor) with Mk +2. use newtypes where possible +3. ordering - order types such that types that are used by a type are declared immediately below that type in the order they are used +4. derive Show, Eq and Generic for all types +5. use Text rather than String +5. use the cddl in this file remote first under the -- ######### Remote ######### header + then local under the -- ######### Local ######### header +7. Avoid using Parameters suffix in type and data constructor names +8. leave this comment at the top of the file +-} + +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, (.:), (.=)) +import Data.Aeson.Types (Parser) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import GHC.Generics (Generic) +import WebDriverPreCore.BiDi.CoreTypes (BrowsingContext, UserContext) +import WebDriverPreCore.BiDi.Network qualified as Network +import AesonUtils (fromJSONCamelCase, opt, toJSONOmitNothing) + +-- ######### Remote ######### + +-- | Partition key for storage operations +data PartitionKey = MkPartitionKey + { userContext :: Maybe Text, + sourceOrigin :: Maybe Text + } + deriving (Show, Eq, Generic) + +instance FromJSON PartitionKey + +instance ToJSON PartitionKey + +-- | Result of getting cookies +data GetCookiesResult = MkGetCookiesResult + { cookies :: [Network.Cookie], + partitionKey :: PartitionKey + } + deriving (Show, Eq, Generic) + +instance FromJSON GetCookiesResult + +-- | Result of setting a cookie +newtype SetCookieResult = MkSetCookieResult + { partitionKey :: PartitionKey + } + deriving (Show, Eq, Generic) + +instance FromJSON SetCookieResult + +-- | Result of deleting cookies +newtype DeleteCookiesResult = MkDeleteCookiesResult + { partitionKey :: PartitionKey + } + deriving (Show, Eq, Generic) + +instance FromJSON DeleteCookiesResult + +-- ######### Local ######### + +-- | Parameters for getting cookies +data GetCookies = MkGetCookies + { filter :: Maybe CookieFilter, + partition :: Maybe PartitionDescriptor + } + deriving (Show, Eq, Generic) + +instance ToJSON GetCookies where + toJSON :: GetCookies -> Value + toJSON = toJSONOmitNothing + +-- | Filter for cookie operations +data CookieFilter = MkCookieFilter + { name :: Maybe Text, + value :: Maybe Network.BytesValue, + domain :: Maybe Text, + path :: Maybe Text, + size :: Maybe Int, + httpOnly :: Maybe Bool, + secure :: Maybe Bool, + sameSite :: Maybe Network.SameSite, + expiry :: Maybe Int + } + deriving (Show, Eq, Generic) + +instance FromJSON CookieFilter where + parseJSON :: Value -> Parser CookieFilter + parseJSON = fromJSONCamelCase + +instance ToJSON CookieFilter where + toJSON :: CookieFilter -> Value + toJSON = toJSONOmitNothing + +-- | Descriptor for a partition +data PartitionDescriptor + = BrowsingContextPartition + { context :: BrowsingContext + } + | StorageKeyPartition + { userContext :: Maybe UserContext, + sourceOrigin :: Maybe Text + } + deriving (Show, Eq, Generic) + +instance FromJSON PartitionDescriptor where + parseJSON :: Value -> Parser PartitionDescriptor + parseJSON = withObject "PartitionDescriptor" $ \o -> do + typ <- o .: "type" + case typ of + "context" -> BrowsingContextPartition <$> o .: "context" + "storageKey" -> StorageKeyPartition <$> o .: "userContext" <*> o .: "sourceOrigin" + _ -> fail $ "Unknown partition type: " ++ show typ + +instance ToJSON PartitionDescriptor where + toJSON :: PartitionDescriptor -> Value + toJSON = \case + BrowsingContextPartition ctx -> + object + [ "type" .= "context", + "context" .= ctx + ] + StorageKeyPartition userCtx srcOrigin -> + object $ + [ "type" .= "storageKey" + ] + <> catMaybes + [ opt "userContext" userCtx, + opt "sourceOrigin" srcOrigin + ] + +-- | Parameters for setting a cookie +data SetCookie = MkSetCookie + { cookie :: PartialCookie, + partition :: Maybe PartitionDescriptor + } + deriving (Show, Eq, Generic) + +instance ToJSON SetCookie where + toJSON :: SetCookie -> Value + toJSON = toJSONOmitNothing + +-- | Partial cookie for setting +data PartialCookie = MkPartialCookie + { name :: Text, + value :: Network.BytesValue, + domain :: Text, + path :: Maybe Text, + httpOnly :: Maybe Bool, + secure :: Maybe Bool, + sameSite :: Maybe Network.SameSite, + expiry :: Maybe Text + } + deriving (Show, Eq, Generic) + +instance ToJSON PartialCookie where + toJSON :: PartialCookie -> Value + toJSON = toJSONOmitNothing + +-- | Parameters for deleting cookies +data DeleteCookies = MkDeleteCookies + { filter :: Maybe CookieFilter, + partition :: Maybe PartitionDescriptor + } + deriving (Show, Eq, Generic) + +instance ToJSON DeleteCookies where + toJSON :: DeleteCookies -> Value + toJSON = toJSONOmitNothing diff --git a/src/WebDriverPreCore/BiDi/WebExtensions.hs b/src/WebDriverPreCore/BiDi/WebExtensions.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/BiDi/WebExtensions.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} + +module WebDriverPreCore.BiDi.WebExtensions + ( WebExtensionID (..), + WebExtensionInstall (..), + WebExtensionUninstall (..), + WebExtensionResult (..), + ) +where + +import Data.Aeson (FromJSON, ToJSON (..), Value, object, (.=)) +import Data.Text (Text) +import GHC.Generics (Generic) + +{- prompt +create types to represent the remote end for storage as prer the cddl in this file: + +1. preface singleton data constructors (ie the constructor for types with only one type constructor) with Mk +2. use newtypes where possible +3. ordering - order types such that types that are used by a type are declared immediately below that type in the order they are used +4. derive Show, Eq and Generic for all types +5. use Text rather than String +5. use the cddl in this file remote first under the -- ######### Remote ######### header +7. Avoid using Parameters suffix in type and data constructor names +8. leave this comment at the top of the file +-} + +-- ######### Remote ######### + +-- WebExtension type +newtype WebExtensionID = MkWebExtensionID Text + deriving newtype (Show, Eq, FromJSON, ToJSON) + + + +-- ExtensionData represents different ways to provide extension data +data WebExtensionInstall + = ExtensionPath Text + | ExtensionArchivePath Text + | ExtensionBase64Encoded Text + deriving (Show, Eq, Generic) + +instance ToJSON WebExtensionInstall where + toJSON :: WebExtensionInstall -> Value + toJSON ex = + object + [ "extensionData" .= extensionData + ] + where + extensionData = case ex of + ExtensionPath path -> + object + [ "type" .= "path", + "path" .= path + ] + ExtensionArchivePath path -> + object + [ "type" .= "archivePath", + "path" .= path + ] + ExtensionBase64Encoded value -> + object + [ "type" .= "base64", + "value" .= value + ] + +newtype WebExtensionUninstall = MkWebExtensionUninstall + { extension :: WebExtensionID + } + deriving (Show, Eq, Generic) + +instance ToJSON WebExtensionUninstall where + toJSON :: WebExtensionUninstall -> Value + toJSON (MkWebExtensionUninstall extId) = + object + [ "extension" .= extId + ] + + +-- ######### Local ######### + +-- | Represents a command to install a web extension +data WebExtensionResult = WebExtensionInstallResult + { extension :: WebExtensionID + } + deriving (Show, Eq, Generic, ToJSON) + +instance FromJSON WebExtensionResult diff --git a/src/WebDriverPreCore/Capabilities.hs b/src/WebDriverPreCore/Capabilities.hs deleted file mode 100644 --- a/src/WebDriverPreCore/Capabilities.hs +++ /dev/null @@ -1,726 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} - -module WebDriverPreCore.Capabilities - ( FullCapabilities (..), - Capabilities (..), - UnhandledPromptBehavior (..), - PageLoadStrategy (..), - BrowserName (..), - PlatformName (..), - Proxy (..), - Timeouts (..), - VendorSpecific (..), - SocksProxy (..), - PerfLoggingPrefs (..), - MobileEmulation (..), - LogLevel (..), - LogSettings (..), - DeviceMetrics (..), - alwaysMatchCapabilities, - minCapabilities, - minFullCapabilities, - minFirefoxCapabilities, - minChromeCapabilities, - ) -where - -import Control.Applicative (Applicative (..), asum) -import Control.Monad (Monad ((>>=)), MonadFail (..)) -import Data.Aeson - ( FromJSON (parseJSON), - Key, - KeyValue ((.=)), - Object, - ToJSON (toJSON), - Value, - defaultOptions, - genericParseJSON, - genericToJSON, - object, - withObject, - withText, - (.:), - (.:?), - ) -import Data.Aeson.Key (fromText) -import Data.Aeson.Types - ( Pair, - Parser, - Value (..), - omitNothingFields, - parseField, - parseFieldMaybe, - ) -import Prelude (Enum, Bool (..), Maybe (..), Int, Show (..), Eq (..), maybe) -import Data.Function (($), (.), flip) -import Data.Functor ((<$>)) -import Data.Map.Strict (Map) -import Data.Maybe (catMaybes) -import Data.Semigroup (Semigroup (..)) -import Data.Text (Text) -import Data.Vector (fromList) -import GHC.Enum (Bounded) -import GHC.Float (Double) -import GHC.Generics (Generic) -import GHC.IO (FilePath) -import WebDriverPreCore.Internal.Utils (opt) - -{- references: -- https://https://www.w3.org/TR/2025/WD-webdriver2-20250306/#capabilities - - - https://developer.mozilla.org/en-US/docs/Web/WebDriver/Capabilities - - https://mucsi96.gitbook.io/w3c-webdriver/capabilities - - -} - --- | 'FullCapabilities' is the object that is passed to webdriver to define the properties of the session via the 'Spec.newSession' function. --- It is a combination of 'alwaysMatch' and 'firstMatch' properties. --- --- [spec](https://https://www.w3.org/TR/2025/WD-webdriver2-20250306/#capabilities) --- --- See also: 'Capabilities' and related constructors such as 'minCapabilities', 'minFullCapabilities', 'minFirefoxCapabilities' and 'minChromeCapabilities' -data FullCapabilities = MkFullCapabilities - { -- | capabilities that are always matched - alwaysMatch :: Maybe Capabilities, - -- | a list of capabilities that are matched in order, the first matching capabilities that matches the capabilities of the session is used - firstMatch :: [Capabilities] - } - deriving (Show, Generic) - -instance ToJSON FullCapabilities where - toJSON :: FullCapabilities -> Value - toJSON MkFullCapabilities {alwaysMatch, firstMatch} = - object $ - [ "capabilities" .= (object $ catMaybes [opt "alwaysMatch" $ alwaysMatch]), - "firstMatch" .= firstMatch' - ] - where - firstMatch' :: Value - firstMatch' = Array . fromList $ toJSON <$> firstMatch - -instance FromJSON FullCapabilities where - parseJSON :: Value -> Parser FullCapabilities - parseJSON = - withObject "FullCapabilities" $ \v -> - do - capabilities <- v .: "capabilities" - alwaysMatch <- capabilities .:? "alwaysMatch" - firstMatch <- capabilities .: "firstMatch" - pure MkFullCapabilities {..} - --- | Returns the minimal FullCapabilities object where the 'firstMatch' property is empty. --- --- It is very common for 'alwaysMatch' to be the only field populated and the 'firstMatch' field to be empty. --- --- [spec](https://https://www.w3.org/TR/2025/WD-webdriver2-20250306/#capabilities) -alwaysMatchCapabilities :: Capabilities -> FullCapabilities -alwaysMatchCapabilities = flip MkFullCapabilities [] . Just - --- | Returns the minimal FullCapabilities object for a given browser --- The browserName in the 'alwaysMatch' field is the only field populated --- [spec](https://https://www.w3.org/TR/2025/WD-webdriver2-20250306/#capabilities) -minFullCapabilities :: BrowserName -> FullCapabilities -minFullCapabilities = alwaysMatchCapabilities . minCapabilities - --- | Returns the minimal Capabilities object for a given browser --- The browserName is the only field populated --- [spec](https://https://www.w3.org/TR/2025/WD-webdriver2-20250306/#capabilities) -minCapabilities :: BrowserName -> Capabilities -minCapabilities browserName = - MkCapabilities - { browserName = Just browserName, - browserVersion = Nothing, - platformName = Nothing, - acceptInsecureCerts = Nothing, - pageLoadStrategy = Nothing, - proxy = Nothing, - timeouts = Nothing, - strictFileInteractability = Nothing, - unhandledPromptBehavior = Nothing, - vendorSpecific = Nothing - } - --- | Returns the minimal FullCapabilities object for Firefox -minFirefoxCapabilities :: FullCapabilities -minFirefoxCapabilities = minFullCapabilities Firefox - --- | Returns the minimal FullCapabilities object for Chrome -minChromeCapabilities :: FullCapabilities -minChromeCapabilities = minFullCapabilities Chrome - --- Custom Types for Enums - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#capabilities) -data UnhandledPromptBehavior - = Dismiss - | Accept - | DismissAndNotify - | AcceptAndNotify - | Ignore - deriving (Show, Generic, Enum, Bounded, Eq) - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#capabilities) -data PageLoadStrategy - = None' - | Eager - | Normal - deriving (Show, Generic, Enum, Bounded, Eq) - -instance ToJSON PageLoadStrategy where - toJSON :: PageLoadStrategy -> Value - toJSON = \case - None' -> "none" - Eager -> "eager" - Normal -> "normal" - -instance FromJSON PageLoadStrategy where - parseJSON :: Value -> Parser PageLoadStrategy - parseJSON = withText "PageLoadStrategy" $ \case - "none" -> pure None' - "eager" -> pure Eager - "normal" -> pure Normal - _ -> fail "Invalid PageLoadStrategy" - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#capabilities) -data BrowserName - = Chrome - | Firefox - | Safari - | Edge - | InternetExplorer - deriving (Show, Generic, Enum, Bounded, Eq) - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#capabilities) -data PlatformName - = Windows - | Mac - | Linux - | Android - | IOS - deriving (Show, Generic, Enum, Bounded, Eq) - --- | 'Capabilities' define the properties of the session and are passed to the webdriver --- via fields of the 'FullCapabilities' object. --- --- [spec](https://https://www.w3.org/TR/2025/WD-webdriver2-20250306/#capabilities) --- --- See also: 'FullCapabilities' and related constructors such as: 'minCapabilities', --- 'minFullCapabilities', 'minFirefoxCapabilities' and 'minChromeCapabilities' -data Capabilities = MkCapabilities - { browserName :: Maybe BrowserName, - browserVersion :: Maybe Text, - platformName :: Maybe PlatformName, - acceptInsecureCerts :: Maybe Bool, - pageLoadStrategy :: Maybe PageLoadStrategy, - proxy :: Maybe Proxy, - timeouts :: Maybe Timeouts, - strictFileInteractability :: Maybe Bool, - unhandledPromptBehavior :: Maybe UnhandledPromptBehavior, - vendorSpecific :: Maybe VendorSpecific - } - deriving (Show, Generic, Eq) - -instance ToJSON Capabilities where - toJSON :: Capabilities -> Value - toJSON - MkCapabilities - { browserName, - browserVersion, - platformName, - acceptInsecureCerts, - pageLoadStrategy, - proxy, - timeouts, - strictFileInteractability, - unhandledPromptBehavior, - vendorSpecific - } = - object $ - [ "browserName" .= browserName - ] - <> catMaybes - [ opt "browserVersion" browserVersion, - opt "platformName" platformName, - opt "acceptInsecureCerts" acceptInsecureCerts, - opt "pageLoadStrategy" pageLoadStrategy, - opt "proxy" proxy, - opt "timeouts" timeouts, - opt "strictFileInteractability" strictFileInteractability, - opt "unhandledPromptBehavior" unhandledPromptBehavior - ] - <> vendorSpecificToJSON vendorSpecific - -instance FromJSON Capabilities where - parseJSON :: Value -> Parser Capabilities - parseJSON = withObject "Capabilities" $ \v -> - do - let m :: forall a. (FromJSON a) => Key -> Parser (Maybe a) - m = parseFieldMaybe v - browserName <- v .: "browserName" - browserVersion <- m "browserVersion" - platformName <- m "platformName" - acceptInsecureCerts <- m "acceptInsecureCerts" - pageLoadStrategy <- m "pageLoadStrategy" - proxy <- m "proxy" - timeouts <- m "timeouts" - strictFileInteractability <- m "strictFileInteractability" - unhandledPromptBehavior <- m "unhandledPromptBehavior" - vendorSpecific <- parseVendorSpecific v - pure MkCapabilities {..} - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#proxy) -data SocksProxy = MkSocksProxy - { socksProxy :: Text, - socksVersion :: Int - } - deriving (Eq, Show, Generic) - -instance ToJSON SocksProxy where - toJSON :: SocksProxy -> Value - toJSON MkSocksProxy {..} = - object - [ "socksProxy" .= socksProxy, - "socksVersion" .= socksVersion - ] - -instance FromJSON SocksProxy where - parseJSON :: Value -> Parser SocksProxy - parseJSON = withObject "SocksProxy" $ \v -> - do - socksProxy <- v .: "socksProxy" - socksVersion <- v .: "socksVersion" - pure MkSocksProxy {..} - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#proxy) -data Proxy - = Direct - | Manual - { ftpProxy :: Maybe Text, - httpProxy :: Maybe Text, - sslProxy :: Maybe Text, - socksProxy :: Maybe SocksProxy, - noProxy :: Maybe [Text] - } - | AutoDetect - | System - | Pac - { proxyAutoconfigUrl :: Text - } - deriving (Show, Eq) - -instance ToJSON Proxy where - toJSON :: Proxy -> Value - toJSON p = - object $ - [ "proxyType" .= proxyType - ] - <> details - where - proxyType = case p of - Direct -> "direct" - AutoDetect -> "autodetect" - System -> "system" - Pac {} -> "pac" - Manual {} -> "manual" - details = case p of - Direct -> [] - AutoDetect -> [] - System -> [] - Pac {..} -> ["proxyAutoconfigUrl" .= proxyAutoconfigUrl] - Manual {..} -> - catMaybes - [ opt "ftpProxy" ftpProxy, - opt "httpProxy" httpProxy, - opt "sslProxy" sslProxy, - opt "socksProxy" socksProxy, - opt "noProxy" noProxy - ] - -instance FromJSON Proxy where - parseJSON :: Value -> Parser Proxy - parseJSON = withObject "Proxy" $ - \v -> - v .: "proxyType" >>= \case - String "direct" -> pure Direct - String "autodetect" -> pure AutoDetect - String "system" -> pure System - String "pac" -> Pac <$> v .: "proxyAutoconfigUrl" - String "manual" -> - do - ftpProxy <- v .:? "ftpProxy" - httpProxy <- v .:? "httpProxy" - sslProxy <- v .:? "sslProxy" - socksProxy <- v .:? "socksProxy" - noProxy <- v .:? "noProxy" - pure Manual {..} - _ -> fail "Invalid Proxy" - --- Vendor Capabilities - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#extensions-0) -data VendorSpecific - = -- | Chrome capabilities - [spec](https://developer.chrome.com/docs/chromedriver/capabilities) - -- - -- Use also for Opera - [spec](https://github.com/operasoftware/operachromiumdriver) - ChromeOptions - { chromeArgs :: Maybe [Text], - chromeBinary :: Maybe Text, - chromeExtensions :: Maybe [Text], -- Base64-encoded - chromeLocalState :: Maybe (Map Text Value), -- Local state preferences - chromeMobileEmulation :: Maybe MobileEmulation, - chromePrefs :: Maybe (Map Text Value), -- User preferences - chromeDetach :: Maybe Bool, -- Keep browser running after driver exit - chromeDebuggerAddress :: Maybe Text, -- Remote debugger address - chromeExcludeSwitches :: Maybe [Text], -- Chrome switches to exclude - chromeMinidumpPath :: Maybe FilePath, -- Crash dump directory - chromePerfLoggingPrefs :: Maybe PerfLoggingPrefs, - chromeWindowTypes :: Maybe [Text] -- Window types to create - } - -- | Edge capabilities - [spec](https://learn.microsoft.com/en-us/microsoft-edge/webdriver-chromium/capabilities-edge-options) - | EdgeOptions - { edgeArgs :: Maybe [Text], - edgeBinary :: Maybe Text, - edgeExtensions :: Maybe [Text], -- Base64-encoded - edgeLocalState :: Maybe (Map Text Value), -- Local state preferences - edgeMobileEmulation :: Maybe MobileEmulation, - edgePrefs :: Maybe (Map Text Value), -- User preferences - edgeDetach :: Maybe Bool, -- Keep browser running after driver exit - edgeDebuggerAddress :: Maybe Text, -- Remote debugger address - edgeExcludeSwitches :: Maybe [Text], -- Chrome switches to exclude - edgeMinidumpPath :: Maybe FilePath, -- Crash dump directory - edgePerfLoggingPrefs :: Maybe PerfLoggingPrefs, - edgeWindowTypes :: Maybe [Text] -- Window types to create - } - -- | Firefox capabilities - [spec](https://developer.mozilla.org/en-US/docs/Web/WebDriver/Capabilities) - | FirefoxOptions - { firefoxArgs :: Maybe [Text], - firefoxBinary :: Maybe Text, - firefoxProfile :: Maybe Text, -- Base64-encoded profile - firefoxLog :: Maybe LogSettings - } - -- | Safari capabilities - [spec](https://developer.apple.com/documentation/webkit/testing_with_webdriver_in_safari) - | SafariOptions - { safariAutomaticInspection :: Maybe Bool, - safariAutomaticProfiling :: Maybe Bool - } - deriving (Show, Generic, Eq) - -data PerfLoggingPrefs = MkPerfLoggingPrefs - { enableNetwork :: Maybe Bool, - enablePage :: Maybe Bool, - enableTimeline :: Maybe Bool, - traceCategories :: Maybe Text, - bufferUsageReportingInterval :: Maybe Int - } - deriving (Show, Eq, Generic) - -instance ToJSON PerfLoggingPrefs where - toJSON = genericToJSON defaultOptions {omitNothingFields = True} - -instance FromJSON PerfLoggingPrefs where - parseJSON = genericParseJSON defaultOptions {omitNothingFields = True} - -data MobileEmulation = MkMobileEmulation - { deviceName :: Maybe Text, - deviceMetrics :: Maybe DeviceMetrics, - userAgent :: Maybe Text - } - deriving (Show, Eq, Generic) - -instance FromJSON MobileEmulation where - parseJSON = genericParseJSON defaultOptions {omitNothingFields = True} - -instance ToJSON MobileEmulation where - toJSON = genericToJSON defaultOptions {omitNothingFields = True} - --- | Browser log levels as defined in vendor specs -data LogLevel - = -- | Most verbose logging - Trace - | -- | Debug-level information - Debug - | -- | Configuration details - Config - | -- | General operational logs - Info - | -- | Potential issues - Warning - | -- | Recoverable errors - Error - | -- | Critical failures - Fatal - | -- | No logging - Off - deriving (Show, Eq, Enum, Bounded, Generic) - -instance ToJSON LogLevel where - toJSON :: LogLevel -> Value - toJSON = - String . \case - Trace -> "trace" - Debug -> "debug" - Config -> "config" - Info -> "info" - Warning -> "warn" - Error -> "error" - Fatal -> "fatal" - Off -> "off" - -instance FromJSON LogLevel where - parseJSON = withText "LogLevel" $ \case - "trace" -> pure Trace - "debug" -> pure Debug - "config" -> pure Config - "info" -> pure Info - "warn" -> pure Warning - "error" -> pure Error - "fatal" -> pure Fatal - "off" -> pure Off - other -> fail $ "Invalid log level: " <> show other - --- | Log settings structure for vendor capabilities -data LogSettings = MkLogSettings - { level :: LogLevel - } - deriving (Show, Eq, Generic) - -instance FromJSON LogSettings where - parseJSON = withObject "LogSettings" $ \v -> - do - level <- v .: "level" - pure MkLogSettings {..} - -instance ToJSON LogSettings where - toJSON = genericToJSON defaultOptions {omitNothingFields = True} - -data DeviceMetrics = MkDeviceMetrics - { width :: Int, - height :: Int, - pixelRatio :: Double, - touch :: Bool - } - deriving (Show, Eq, Generic) - -instance FromJSON DeviceMetrics where - parseJSON = withObject "DeviceMetrics" $ \v -> - do - let m :: forall a. (FromJSON a) => Key -> Parser a - m = parseField v - width <- m "width" - height <- m "height" - pixelRatio <- m "pixelRatio" - touch <- m "touch" - pure MkDeviceMetrics {..} - -instance ToJSON DeviceMetrics where - toJSON = genericToJSON defaultOptions {omitNothingFields = True} - --- | ToJSON Instance for VendorSpecific - --- ToJSON Instance for VendorSpecific -instance ToJSON VendorSpecific where - toJSON :: VendorSpecific -> Value - toJSON vs = - object $ catMaybes props - where - props = case vs of - ChromeOptions {..} -> - [ opt "args" chromeArgs, - opt "binary" chromeBinary, - opt "extensions" chromeExtensions, - opt "localState" chromeLocalState, - opt "mobileEmulation" chromeMobileEmulation, - opt "prefs" chromePrefs, - opt "detach" chromeDetach, - opt "debuggerAddress" chromeDebuggerAddress, - opt "excludeSwitches" chromeExcludeSwitches, - opt "minidumpPath" chromeMinidumpPath, - opt "perfLoggingPrefs" chromePerfLoggingPrefs, - opt "windowTypes" chromeWindowTypes - ] - EdgeOptions {..} -> - [ opt "args" edgeArgs, - opt "binary" edgeBinary, - opt "extensions" edgeExtensions, - opt "localState" edgeLocalState, - opt "prefs" edgePrefs, - opt "detach" edgeDetach, - opt "debuggerAddress" edgeDebuggerAddress, - opt "excludeSwitches" edgeExcludeSwitches, - opt "minidumpPath" edgeMinidumpPath, - opt "mobileEmulation" edgeMobileEmulation, - opt "perfLoggingPrefs" edgePerfLoggingPrefs, - opt "windowTypes" edgeWindowTypes - ] - FirefoxOptions {..} -> - [ opt "args" firefoxArgs, - opt "binary" firefoxBinary, - opt "profile" firefoxProfile, - opt "log" firefoxLog - ] - SafariOptions {..} -> - [ opt "automaticInspection" safariAutomaticInspection, - opt "automaticProfiling" safariAutomaticProfiling - ] - -vendorSpecificPropName :: VendorSpecific -> Text -vendorSpecificPropName = \case - ChromeOptions {} -> "goog:chromeOptions" - EdgeOptions {} -> "ms:edgeOptions" - FirefoxOptions {} -> "moz:firefoxOptions" - SafariOptions {} -> "safari:options" - -vendorSpecificToJSON :: Maybe VendorSpecific -> [Pair] -vendorSpecificToJSON = maybe [] vendorSpecificToJSON' - where - vendorSpecificToJSON' :: VendorSpecific -> [Pair] - vendorSpecificToJSON' vs = [(fromText (vendorSpecificPropName vs), toJSON vs)] - --- ToJSON Instances for Custom Types -instance ToJSON UnhandledPromptBehavior where - toJSON :: UnhandledPromptBehavior -> Value - toJSON = \case - Dismiss -> "dismiss" - Accept -> "accept" - DismissAndNotify -> "dismiss and notify" - AcceptAndNotify -> "accept and notify" - Ignore -> "ignore" - -instance ToJSON BrowserName where - toJSON :: BrowserName -> Value - toJSON = \case - Chrome -> "chrome" - Firefox -> "firefox" - Safari -> "safari" - Edge -> "edge" - InternetExplorer -> "internet explorer" - -instance ToJSON PlatformName where - toJSON :: PlatformName -> Value - toJSON = \case - Windows -> "windows" - Mac -> "mac" - Linux -> "linux" - Android -> "android" - IOS -> "ios" - -instance FromJSON UnhandledPromptBehavior where - parseJSON :: Value -> Parser UnhandledPromptBehavior - parseJSON = withText "UnhandledPromptBehavior" $ \case - "dismiss" -> pure Dismiss - "accept" -> pure Accept - "dismiss and notify" -> pure DismissAndNotify - "accept and notify" -> pure AcceptAndNotify - "ignore" -> pure Ignore - other -> fail $ "UnhandledPromptBehavior: " <> show other - -instance FromJSON BrowserName where - parseJSON :: Value -> Parser BrowserName - parseJSON = withText "BrowserName" $ \case - "chrome" -> pure Chrome - "firefox" -> pure Firefox - "safari" -> pure Safari - "edge" -> pure Edge - "internet explorer" -> pure InternetExplorer - _ -> fail "Invalid BrowserName" - -instance FromJSON PlatformName where - parseJSON :: Value -> Parser PlatformName - parseJSON = withText "PlatformName" $ \case - "windows" -> pure Windows - "mac" -> pure Mac - "linux" -> pure Linux - "android" -> pure Android - "ios" -> pure IOS - _ -> fail "Invalid PlatformName" - --- FromJSON Instances for Data Structures -parseVendorSpecific :: Object -> Parser (Maybe VendorSpecific) -parseVendorSpecific v = - asum - [ Just <$> (v .: "goog:chromeOptions" >>= parseChromeOptions), - Just <$> (v .: "ms:edgeOptions" >>= parseEdgeOptions), - Just <$> (v .: "moz:firefoxOptions" >>= parseFirefoxOptions), - Just <$> (v .: "safari:options" >>= parseSafariOptions), - pure Nothing - ] - where - parseChromeOptions o = do - chromeArgs <- m "args" - chromeBinary <- m "binary" - chromeExtensions <- m "extensions" - chromeLocalState <- m "localState" -- Local state preferences - chromeMobileEmulation <- m "mobileEmulation" - chromePrefs <- m "prefs" - chromeDetach <- m "detach" - chromeDebuggerAddress <- m "debuggerAddress" - chromeExcludeSwitches <- m "excludeSwitches" - chromeMinidumpPath <- m "minidumpPath" - chromePerfLoggingPrefs <- m "perfLoggingPrefs" - chromeWindowTypes <- m "windowTypes" - pure $ ChromeOptions {..} - where - m :: forall a. (FromJSON a) => Key -> Parser (Maybe a) - m = parseFieldMaybe o - - parseEdgeOptions o = do - edgeArgs <- m "args" - edgeBinary <- m "binary" - edgeExtensions <- m "extensions" - edgeLocalState <- m "localState" - edgePrefs <- m "prefs" - edgeDetach <- m "detach" - edgeDebuggerAddress <- m "debuggerAddress" - edgeExcludeSwitches <- m "excludeSwitches" - edgeMinidumpPath <- m "minidumpPath" - edgeMobileEmulation <- m "mobileEmulation" - edgePerfLoggingPrefs <- m "perfLoggingPrefs" - edgeWindowTypes <- m "windowTypes" - pure EdgeOptions {..} - where - m :: forall a. (FromJSON a) => Key -> Parser (Maybe a) - m = parseFieldMaybe o - - parseFirefoxOptions o = do - firefoxArgs <- m "args" - firefoxBinary <- m "binary" - firefoxProfile <- m "profile" - firefoxLog <- m "log" - pure FirefoxOptions {..} - where - m :: forall a. (FromJSON a) => Key -> Parser (Maybe a) - m = parseFieldMaybe o - - parseSafariOptions o = do - safariAutomaticInspection <- m "automaticInspection" - safariAutomaticProfiling <- m "automaticProfiling" - pure SafariOptions {..} - where - m = parseFieldMaybe o - --- | Timeouts in milliseconds --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#timeouts) -data Timeouts = MkTimeouts - { implicit :: Maybe Int, -- field order needs to be the same as FromJSON below - pageLoad :: Maybe Int, - script :: Maybe Int - } - deriving (Show, Generic, Eq) - -instance FromJSON Timeouts where - parseJSON :: Value -> Parser Timeouts - parseJSON = withObject "Timeouts" $ \v -> - do - implicit <- v .:? "implicit" - pageLoad <- v .:? "pageLoad" - script <- v .:? "script" - pure MkTimeouts {..} - -instance ToJSON Timeouts where - toJSON :: Timeouts -> Value - toJSON MkTimeouts {..} = - object - [ "implicit" .= implicit, - "pageLoad" .= pageLoad, - "script" .= script - ] diff --git a/src/WebDriverPreCore/Error.hs b/src/WebDriverPreCore/Error.hs --- a/src/WebDriverPreCore/Error.hs +++ b/src/WebDriverPreCore/Error.hs @@ -1,27 +1,29 @@ {-# OPTIONS_HADDOCK hide #-} -module WebDriverPreCore.Error ( - WebDriverErrorType(..), - ErrorClassification(..), - errorDescription, - errorCodeToErrorType, - errorTypeToErrorCode, - parseWebDriverError, - parseWebDriverErrorType -) where +module WebDriverPreCore.Error + ( ErrorType (..), + WebDriverException (..), + JSONEncodeException (..), + errorDescription, + toErrorType, + toErrorCode, + parseWebDriverException, + parseErrorType, + ) +where -import Data.Aeson (Value, withObject) -import Data.Aeson.Types ((.:), parseMaybe) -import Data.Text (Text) -import Data.Eq (Eq) -import GHC.Show (Show) -import Data.Ord (Ord) -import Data.Maybe (Maybe (..)) -import WebDriverPreCore.HttpResponse (HttpResponse (..)) -import GHC.Enum ( Bounded, Enum ) -import Data.Either (Either (..)) -import Control.Monad ((>>=)) -import Data.Function (($)) +import AesonUtils (jsonToText) +import Control.Exception (Exception (..)) +import Data.Aeson (FromJSON (..), Options (..), Value, defaultOptions, genericParseJSON, withObject) +import Data.Aeson.Types (Parser, parseEither, parseMaybe, (.:)) +import Data.Bifunctor (first) +import Data.Char (isUpper, toLower) +import Data.Function ((&)) +import Data.Text as T (Text, concat, pack, toTitle, unpack, words) +import GHC.Generics (Generic) +import Text.Read (readEither) +import WebDriverPreCore.Internal.HTTPBidiCommon (JSUInt (..)) +import Prelude as P hiding (error, words) {- Error Code HTTP Status JSON Error Code Description @@ -52,118 +54,85 @@ unknown command 404 unknown command A command could not be executed because the remote end is not aware of it. unknown error 500 unknown error An unknown error occurred in the remote end while processing the command. unknown method 405 unknown method The requested command matched a known URL but did not match any method for that URL. -unsupported operation 500 unsupported operation Indicates that a command that should have executed properly cannot be supported for some reason. +unsupported operation 500 unsupported operation Indicates that a command that should have executed properly cannot be supported for some reason. -} -- | Known WevDriver Error Types --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#errors) -data WebDriverErrorType = - ElementClickIntercepted | - ElementNotInteractable | - InsecureCertificate | - InvalidArgument | - InvalidCookieDomain | - InvalidElementState | - InvalidSelector | - InvalidSessionId | - JavascriptError | - MoveTargetOutOfBounds | - NoSuchAlert | - NoSuchCookie | - NoSuchElement | - NoSuchFrame | - NoSuchWindow | - NoSuchShadowRoot | - ScriptTimeoutError | - SessionNotCreated | - StaleElementReference | - DetachedShadowRoot | - Timeout | - UnableToSetCookie | - UnableToCaptureScreen | - UnexpectedAlertOpen | - UnknownCommand | - UnknownError | - UnknownMethod | - UnsupportedOperation - deriving (Eq, Show, Ord, Bounded, Enum) - - -getError :: Value -> Maybe Text -getError = - parseMaybe $ withObject "root" $ \o -> - o .: "value" >>= withObject "inner" (.: "error") - +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#errors) +data ErrorType + = ElementClickIntercepted + | ElementNotInteractable + | InsecureCertificate + | InvalidArgument + | InvalidCookieDomain + | InvalidElementState + | InvalidSelector + | InvalidSessionId + | JavascriptError + | MoveTargetOutOfBounds + | NoSuchAlert + | NoSuchCookie + | NoSuchElement + | NoSuchFrame + | NoSuchWindow + | NoSuchShadowRoot + | ScriptTimeout + | SessionNotCreated + | StaleElementReference + | DetachedShadowRoot + | Timeout + | UnableToSetCookie + | UnableToCaptureScreen + | UnexpectedAlertOpen + | UnknownCommand + | UnknownError + | UnknownMethod + | UnsupportedOperation + | --- Bidi + InvalidWebExtension + | NoSuchClientWindow + | NoSuchHandle + | NoSuchHistoryEntry + | NoSuchNetworkCollector + | NoSuchIntercept + | NoSuchNetworkData + | NoSuchNode + | NoSuchRequest + | NoSuchScript + | NoSuchStoragePartition + | NoSuchUserContext + | NoSuchWebExtension + | UnableToCloseBrowser + | UnableToSetFileInput + | UnavailableNetworkData + | UnderspecifiedStoragePartition + deriving (Eq, Read, Show, Ord, Bounded, Enum) +instance FromJSON ErrorType where + parseJSON :: Value -> Parser ErrorType + parseJSON = withObject "ErrorType" $ \o -> do + errCode <- o .: "error" + case toErrorType errCode of + Left e -> fail $ "Unknown ErrorType code: " <> unpack e + Right et -> pure et -errorCodeToErrorType :: Text -> Either Text WebDriverErrorType -errorCodeToErrorType errCode = - case errCode of - "element click intercepted" -> r ElementClickIntercepted - "element not interactable" -> r ElementNotInteractable - "insecure certificate" -> r InsecureCertificate - "invalid argument" -> r InvalidArgument - "invalid cookie domain" -> r InvalidCookieDomain - "invalid element state" -> r InvalidElementState - "invalid selector" -> r InvalidSelector - "invalid session id" -> r InvalidSessionId - "javascript error" -> r JavascriptError - "move target out of bounds" -> r MoveTargetOutOfBounds - "no such alert" -> r NoSuchAlert - "no such cookie" -> r NoSuchCookie - "no such element" -> r NoSuchElement - "no such frame" -> r NoSuchFrame - "no such window" -> r NoSuchWindow - "no such shadow root" -> r NoSuchShadowRoot - "script timeout" -> r ScriptTimeoutError - "session not created" -> r SessionNotCreated - "stale element reference" -> r StaleElementReference - "detached shadow root" -> r DetachedShadowRoot - "timeout" -> r Timeout - "unable to set cookie" -> r UnableToSetCookie - "unable to capture screen" -> r UnableToCaptureScreen - "unexpected alert open" -> r UnexpectedAlertOpen - "unknown command" -> r UnknownCommand - "unknown error" -> r UnknownError - "unknown method" -> r UnknownMethod - "unsupported operation" -> r UnsupportedOperation - er -> Left er - where - r = Right +toErrorType :: Text -> Either Text ErrorType +toErrorType = + first pack . readEither . unpack . T.concat . fmap T.toTitle . T.words -errorTypeToErrorCode :: WebDriverErrorType -> Text -errorTypeToErrorCode = \case - ElementClickIntercepted -> "element click intercepted" - ElementNotInteractable -> "element not interactable" - InsecureCertificate -> "insecure certificate" - InvalidArgument -> "invalid argument" - InvalidCookieDomain -> "invalid cookie domain" - InvalidElementState -> "invalid element state" - InvalidSelector -> "invalid selector" - InvalidSessionId -> "invalid session id" - JavascriptError -> "javascript error" - MoveTargetOutOfBounds -> "move target out of bounds" - NoSuchAlert -> "no such alert" - NoSuchCookie -> "no such cookie" - NoSuchElement -> "no such element" - NoSuchFrame -> "no such frame" - NoSuchWindow -> "no such window" - NoSuchShadowRoot -> "no such shadow root" - ScriptTimeoutError -> "script timeout" - SessionNotCreated -> "session not created" - StaleElementReference -> "stale element reference" - DetachedShadowRoot -> "detached shadow root" - Timeout -> "timeout" - UnableToSetCookie -> "unable to set cookie" - UnableToCaptureScreen -> "unable to capture screen" - UnexpectedAlertOpen -> "unexpected alert open" - UnknownCommand -> "unknown command" - UnknownError -> "unknown error" - UnknownMethod -> "unknown method" - UnsupportedOperation -> "unsupported operation" +toErrorCode :: ErrorType -> Text +toErrorCode = + pack . P.unwords . splitCamel . show + where + splitCamel :: String -> [String] + splitCamel = \case + [] -> [] + (x : xs) -> + let (w, rest) = break isUpper xs + in (toLower x : w) : splitCamel rest -errorDescription :: WebDriverErrorType -> Text +errorDescription :: ErrorType -> Text errorDescription = \case ElementClickIntercepted -> "The Element Click command could not be completed because the element receiving the events is obscuring the element that was requested clicked" ElementNotInteractable -> "A command could not be completed because the element is not pointer- or keyboard interactable" @@ -181,43 +150,197 @@ NoSuchFrame -> "A command to switch to a frame could not be satisfied because the frame could not be found" NoSuchWindow -> "A command to switch to a window could not be satisfied because the window could not be found" NoSuchShadowRoot -> "The element does not have a shadow root" - ScriptTimeoutError -> "A script did not complete before its timeout expired" + ScriptTimeout -> "A script did not complete before its timeout expired" SessionNotCreated -> "A new session could not be created" StaleElementReference -> "A command failed because the referenced element is no longer attached to the DOM" DetachedShadowRoot -> "A command failed because the referenced shadow root is no longer attached to the DOM" Timeout -> "An operation did not complete before its timeout expired" - UnableToSetCookie -> "A command to set a cookie's value could not be satisfied" + -- Description from the BiDi spec differs from WebDriver spec + -- UnableToSetCookie -> "A command to set a cookie's value could not be satisfied." + UnableToSetCookie -> "Tried to create a cookie, but the user agent rejected it" UnableToCaptureScreen -> "A screen capture was made impossible" UnexpectedAlertOpen -> "A modal dialog was open, blocking this operation" UnknownCommand -> "A command could not be executed because the remote end is not aware of it" UnknownError -> "An unknown error occurred in the remote end while processing the command" UnknownMethod -> "The requested command matched a known URL but did not match any method for that URL" UnsupportedOperation -> "Indicates that a command that should have executed properly cannot be supported for some reason" + -- Bidi + InvalidWebExtension -> "Tried to install an invalid web extension" + NoSuchClientWindow -> "Tried to interact with an unknown client window" + NoSuchNetworkCollector -> "Tried to remove an unknown collector" + NoSuchHandle -> "Tried to deserialize an unknown RemoteObjectReference" + NoSuchHistoryEntry -> "Tried to navigate to an unknown session history entry" + NoSuchIntercept -> "Tried to remove an unknown network intercept" + NoSuchNetworkData -> "Tried to reference an unknown network data" + NoSuchNode -> "Tried to deserialize an unknown SharedReference" + NoSuchRequest -> "Tried to continue an unknown request" + NoSuchScript -> "Tried to remove an unknown preload script" + NoSuchStoragePartition -> "Tried to access data in a non-existent storage partition" + NoSuchUserContext -> "Tried to reference an unknown user context" + NoSuchWebExtension -> "Tried to reference an unknown web extension" + UnableToCloseBrowser -> "Tried to close the browser, but failed to do so" + UnableToSetFileInput -> "Tried to set a file input, but failed to do so" + UnavailableNetworkData -> "Tried to get network data which was not collected or already evicted" + UnderspecifiedStoragePartition -> "Tried to interact with data in a storage partition which was not adequately specified" -data ErrorClassification = - NotAnError {httpResponse :: HttpResponse} | - UnrecognisedError {httpResponse :: HttpResponse} | - WebDriverError { - error :: WebDriverErrorType, +data WebDriverException + = ResponseParseException + { message :: Text, + response :: Value + } + | UnrecognisedErrorTypeException {errorType :: Text, response :: Value} + | JSONEncodeException JSONEncodeException + | ProtocolException + { error :: ErrorType, + description :: Text, + message :: Text, + stacktrace :: Maybe Text, + errorData :: Maybe Value, + response :: Value + } + deriving (Eq, Show, Ord, Generic) + +data JSONEncodeException = MkJSONEncodeException + { message :: Text, + responseText :: Text + } + deriving (Show, Eq, Ord, Generic) + +instance FromJSON JSONEncodeException + +instance Exception WebDriverException where + displayException :: WebDriverException -> String + displayException = + unpack . \case + ResponseParseException {message, response} -> + "Error parsing WebDriver response: " + <> message + <> "\nResponse was:\n" + <> jsonToText response + UnrecognisedErrorTypeException {response} -> + "Unrecognised WebDriver error type in response:\n" + <> jsonToText response + JSONEncodeException MkJSONEncodeException {message, responseText} -> + "Error converting WebDriver response to JSON: " + <> message + <> "\nResponse text was:\n" + <> responseText + ProtocolException {error, description, message, stacktrace} -> + "Error executing WebDriver command: " + <> "\nError Type: " + <> toErrorCode error + <> "\nDescription: " + <> description + <> "\nMessage: " + <> message + <> maybe "" (\st -> "\nStacktrace: \n" <> st) stacktrace + + +parseWebDriverException :: Text -> Value -> WebDriverException +parseWebDriverException errInfo response = + parseMaybe getErrorProp response + & maybe + (parserErr (errInfo <> "\n" <> "Could not find 'error' property in response\n" <> jsonToText response)) + ( either + (flip UnrecognisedErrorTypeException response) + mkWebDriverException + . toErrorType + ) + where + parserErr message = ResponseParseException {message, response} + mkWebDriverException :: ErrorType -> WebDriverException {- -} + mkWebDriverException et = + parseEither parseJSON response + & either + (\msg -> parserErr $ "Error object parsing failed:\n" <> pack msg <> "\n" <> jsonToText response) + \MkWebDriverExceptionRaw {..} -> + ProtocolException + { error = et, + description = errorDescription et, + response, + message, + stacktrace, + errorData + } + +getErrorProp :: Value -> Parser Text +getErrorProp = + withObject "error" (.: "error") + +parseErrorType :: Value -> Maybe ErrorType +parseErrorType resp = + case parseWebDriverException "parse error type result" resp of + ProtocolException {error} -> Just error + JSONEncodeException {} -> Nothing + ResponseParseException {} -> Nothing + UnrecognisedErrorTypeException {} -> Nothing + +data WebDriverExceptionRaw = MkWebDriverExceptionRaw + { error :: Text, + message :: Text, + biDiId :: Maybe JSUInt, + stacktrace :: Maybe Text, + errorData :: Maybe Value + } + deriving (Show, Eq, Generic) + +instance FromJSON WebDriverExceptionRaw where + parseJSON :: Value -> Parser WebDriverExceptionRaw + parseJSON = + genericParseJSON + defaultOptions + { omitNothingFields = True, + fieldLabelModifier = \case + "data" -> "errorData" + "id" -> "biDiId" + other -> other + } + +{- FROM BIDI + +- get compiling + check empty result +- try known missign Bidi demos +- review unit tests +- a couple of integration demos + - http - element does not exist + - bidi specific - element does not exist + +data DriverError = MkDriverError + { id :: Maybe JSUInt, + error :: ErrorCode, description :: Text, - httpResponse :: HttpResponse - -- todo find stacktrace - -- stacktrace :: Maybe Text - } deriving (Eq, Show, Ord) + message :: Text, + stacktrace :: Maybe Text, + extensions :: EmptyResult + } + deriving (Show, Generic, Eq) -parseWebDriverError :: HttpResponse -> ErrorClassification -parseWebDriverError resp = - case getError resp.body of - Nothing -> NotAnError resp - Just err -> - case errorCodeToErrorType err of - Right et -> WebDriverError et (errorDescription et) resp - Left _ -> UnrecognisedError resp +instance FromJSON DriverError where + parseJSON :: Value -> Parser DriverError + parseJSON = withObject "Driver Error" $ \o -> do + id' <- o .: "id" + error' <- o .: "error" + message <- o .: "message" + stacktrace <- o .: "stacktrace" + pure $ + MkDriverError + { id = id', + error = error', + description = errorDescription error', + message, + stacktrace, + extensions = + MkEmptyResult $ + subtractProps + [ "id",module ErrorCoverageTest where -parseWebDriverErrorType :: HttpResponse -> Maybe WebDriverErrorType -parseWebDriverErrorType resp = - case parseWebDriverError resp of - WebDriverError {error} -> Just error - NotAnError {} -> Nothing - UnrecognisedError {} -> Nothing - + "type", + "error", + "description", + "message", + "stacktrace" + ] + o + } +-} diff --git a/src/WebDriverPreCore/HTTP/API.hs b/src/WebDriverPreCore/HTTP/API.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/HTTP/API.hs @@ -0,0 +1,784 @@ +{-# LANGUAGE CPP #-} + +{- + + -- | Type definitions for commands for all [WebDriver HTTP endpoints](HTMLSpecURL). + -- + -- See the demos in the [demos](https://github.com/pyrethrum/webdriver/blob/main/webdriver-precore/test/README.md) for how this module can be used to develop a WebDriver client. + -- + + +-} + +module WebDriverPreCore.HTTP.API + ( -- * Root Methods + newSession, + status, + + -- * Session Methods + deleteSession, + getTimeouts, + setTimeouts, + navigateTo, + getCurrentUrl, + back, + forward, + refresh, + getTitle, + getWindowHandle, + newWindow, + closeWindow, + switchToWindow, + switchToFrame, + getPageSource, + executeScript, + executeScriptAsync, + addCookie, + getAllCookies, + getNamedCookie, + deleteCookie, + deleteAllCookies, + performActions, + releaseActions, + dismissAlert, + acceptAlert, + getAlertText, + sendAlertText, + takeScreenshot, + printPage, + + -- * Window Methods + getWindowHandles, + getWindowRect, + setWindowRect, + maximizeWindow, + minimizeWindow, + fullScreenWindow, + + -- * Frame Methods + switchToParentFrame, + + -- * Element(s) Methods + getActiveElement, + findElement, + findElements, + + -- * Element Instance Methods + findElementFromElement, + findElementsFromElement, + isElementSelected, + getElementAttribute, + getElementProperty, + getElementCssValue, + getElementShadowRoot, + getElementText, + getElementTagName, + getElementRect, + isElementEnabled, + getElementComputedRole, + getElementComputedLabel, + elementClick, + elementClear, + elementSendKeys, + takeElementScreenshot, + + -- * Shadow DOM Methods + findElementFromShadowRoot, + findElementsFromShadowRoot, + ) +where + +import Data.Aeson as A + ( KeyValue ((.=)), + Value (..), + ) +import Data.Text (Text) +import WebDriverPreCore.HTTP.Protocol + ( Actions (..), + Cookie (..), + Status (..), + ElementId (..), + FrameReference (..), + FullCapabilities, + Script, + Selector (..), + Session (..), + SessionResponse (..), + Timeouts, + URL, + Handle (..), + WindowHandleSpec (..), + WindowRect (..), + ShadowRootElementId(..), + Command(..), + mkPost, + mkPost' + ) +import Utils (UrlPath (..)) +import Prelude hiding (id, lookup) +import Data.Aeson.KeyMap (fromList) + +-- ###################################################################### +-- ########################### WebDriver API ############################ +-- ###################################################################### + +-- ** Root Methods + +-- | +-- Return a spec to create a new session given 'FullCapabilities' object. +-- +-- 'newSession'' can be used if 'FullCapabilities' doesn't meet your requirements. +-- +-- [spec](HTMLSpecURL#new-session) +-- +-- @POST \/session New Session@ +newSession :: FullCapabilities -> Command SessionResponse +newSession = mkPost "New Session" newSessionUrl + +-- | +-- +-- Return a spec to get the status of the driver. +-- +-- [spec](HTMLSpecURL#status) +-- +-- @GET \/status Status@ +status :: Command Status +status = Get "Status" $ MkUrlPath ["status"] + +-- ############################ Session Methods ########################################## + +-- | +-- +-- Return a spec to delete a session given a 'Session'. +-- +-- [spec](HTMLSpecURL#delete-session) +-- +-- @DELETE \/session\/{session id} Delete Session@ +deleteSession :: Session -> Command () +deleteSession sessionRef = Delete "Delete Session" $ sessionUri sessionRef.id + +-- | +-- +-- Return a spec to get the timeouts of a session given a 'Session'. +-- +-- [spec](HTMLSpecURL#get-timeouts) +-- +-- @GET \/session\/{session id}\/timeouts Get Timeouts@ +getTimeouts :: Session -> Command Timeouts +getTimeouts sessionRef = Get "Get Timeouts" $ sessionUri1 sessionRef "timeouts" + +-- | +-- +-- Return a spec to set the timeouts of a session given a 'Session' and 'Timeouts'. +-- +-- [spec](HTMLSpecURL#set-timeouts) +-- +-- @POST \/session\/{session id}\/timeouts Set Timeouts@ +setTimeouts :: Session -> Timeouts -> Command () +setTimeouts sessionRef = + mkPost "Set Timeouts" (sessionUri1 sessionRef "timeouts") + +-- | +-- +-- Return a spec to navigate to a URL given a 'Session' and a 'Text' URL. +-- +-- [spec](HTMLSpecURL#navigate-to) +-- +-- @POST \/session\/{session id}\/url Navigate To@ +navigateTo :: Session -> URL -> Command () +navigateTo sessionRef = mkPost' "Navigate To" (sessionUri1 sessionRef "url") (\url -> fromList ["url" .= url]) + +-- | +-- +-- Return a spec to get the current URL of a session given a 'Session'. +-- +-- [spec](HTMLSpecURL#get-current-url) +-- +-- @GET \/session\/{session id}\/url Get Current URL@ +getCurrentUrl :: Session -> Command URL +getCurrentUrl sessionRef = Get "Get Current URL" (sessionUri1 sessionRef "url") + +-- | +-- +-- Return a spec to navigate back in the browser history given a 'Session'. +-- +-- [spec](HTMLSpecURL#back) +-- +-- @POST \/session\/{session id}\/back Back@ +back :: Session -> Command () +back sessionRef = PostEmpty "Back" (sessionUri1 sessionRef "back") + +-- | +-- +-- Return a spec to navigate forward in the browser history given a 'Session'. +-- +-- [spec](HTMLSpecURL#forward) +-- +-- @POST \/session\/{session id}\/forward Forward@ +forward :: Session -> Command () +forward sessionRef = PostEmpty "Forward" (sessionUri1 sessionRef "forward") + +-- | +-- +-- Return a spec to refresh the current page given a 'Session'. +-- +-- [spec](HTMLSpecURL#refresh) +-- +-- @POST \/session\/{session id}\/refresh Refresh@ +refresh :: Session -> Command () +refresh sessionRef = PostEmpty "Refresh" (sessionUri1 sessionRef "refresh") + +-- | +-- +-- Return a spec to get the title of the current page given a 'Session'. +-- +-- [spec](HTMLSpecURL#get-title) +-- +-- @GET \/session\/{session id}\/title Get Title@ +getTitle :: Session -> Command Text +getTitle sessionRef = Get "Get Title" (sessionUri1 sessionRef "title") + +-- | +-- +-- Return a spec to get the current window handle given a 'Session'. +-- +-- [spec](HTMLSpecURL#get-window-handle) +-- +-- @GET \/session\/{session id}\/window Get Window Handle@ +getWindowHandle :: Session -> Command Handle +getWindowHandle sessionRef = Get "Get Window Handle" (sessionUri1 sessionRef "window") + +-- | +-- +-- Return a spec to create a new window given a 'Session'. +-- +-- [spec](HTMLSpecURL#new-window) +-- +-- @POST \/session\/{session id}\/window\/new New Window@ +newWindow :: Session -> Command WindowHandleSpec +newWindow sessionRef = PostEmpty "New Window" (sessionUri2 sessionRef "window" "new") + +-- | +-- +-- Return a spec to close the current window given a 'Session'. +-- +-- [spec](HTMLSpecURL#close-window) +-- +-- @DELETE \/session\/{session id}\/window Close Window@ +closeWindow :: Session -> Command [Handle] +closeWindow sessionRef = Delete "Close Window" (sessionUri1 sessionRef "window") + +-- | +-- +-- Return a spec to switch to a different window given a 'Session' and 'WindowHandle'. +-- +-- [spec](HTMLSpecURL#switch-to-window) +-- +-- @POST \/session\/{session id}\/window Switch To Window@ +switchToWindow :: Session -> Handle -> Command () +switchToWindow sessionRef = mkPost "Switch To Window" (sessionUri1 sessionRef "window") + +-- | +-- +-- Return a spec to switch to a different frame given a 'Session' and 'FrameReference'. +-- +-- [spec](HTMLSpecURL#switch-to-frame) +-- +-- @POST \/session\/{session id}\/frame Switch To Frame@ +switchToFrame :: Session -> FrameReference -> Command () +switchToFrame sessionRef = mkPost "Switch To Frame" (sessionUri1 sessionRef "frame") + +-- | +-- +-- Return a spec to get the source of the current page given a 'Session'. +-- +-- [spec](HTMLSpecURL#get-page-source) +-- +-- @GET \/session\/{session id}\/source Get Page Source@ +getPageSource :: Session -> Command Text +getPageSource sessionId = Get "Get Page Source" (sessionUri1 sessionId "source") + +-- | +-- +-- Return a spec to execute a script in the context of the current page given a 'Session', 'Text' script, and a list of 'Value' arguments. +-- +-- [spec](HTMLSpecURL#execute-script) +-- +-- @POST \/session\/{session id}\/execute\/sync Execute Script@ +executeScript :: Session -> Script -> Command Value +executeScript sessionId = mkPost "Execute Script" (sessionUri2 sessionId "execute" "sync") + +-- | +-- +-- Return a spec to execute an asynchronous script in the context of the current page given a 'Session', 'Text' script, and a list of 'Value' arguments. +-- +-- [spec](HTMLSpecURL#execute-async-script) +-- +-- @POST \/session\/{session id}\/execute\/async Execute Async Script@ +executeScriptAsync :: Session -> Script -> Command Value +executeScriptAsync sessionId = mkPost "Execute Async Script" (sessionUri2 sessionId "execute" "async") + +-- | +-- +-- Return a spec to get all cookies of the current page given a 'Session'. +-- +-- [spec](HTMLSpecURL#get-all-cookies) +-- +-- @GET \/session\/{session id}\/cookie Get All Cookies@ +getAllCookies :: Session -> Command [Cookie] +getAllCookies sessionId = Get "Get All Cookies" (sessionUri1 sessionId "cookie") + +-- | +-- +-- Return a spec to get a named cookie of the current page given a 'Session' and cookie name. +-- +-- [spec](HTMLSpecURL#get-named-cookie) +-- +-- @GET \/session\/{session id}\/cookie\/{name} Get Named Cookie@ +getNamedCookie :: Session -> Text -> Command Cookie +getNamedCookie sessionId cookieName = Get "Get Named Cookie" (sessionUri2 sessionId "cookie" cookieName) + +-- | +-- +-- Return a spec to add a cookie to the current page given a 'Session' and 'Cookie'. +-- +-- [spec](HTMLSpecURL#add-cookie) +-- +-- @POST \/session\/{session id}\/cookie Add Cookie@ +addCookie :: Session -> Cookie -> Command () +addCookie sessionId cookie = Post "Add Cookie" (sessionUri1 sessionId "cookie") (fromList ["cookie" .= cookie] ) + +-- | +-- +-- Return a spec to delete a named cookie from the current page given a 'Session' and cookie name. +-- +-- [spec](HTMLSpecURL#delete-cookie) +-- +-- @DELETE \/session\/{session id}\/cookie\/{name} Delete Cookie@ +deleteCookie :: Session -> Text -> Command () +deleteCookie sessionId cookieName = Delete "Delete Cookie" (sessionUri2 sessionId "cookie" cookieName) + +-- | +-- +-- Return a spec to delete all cookies from the current page given a 'Session'. +-- +-- [spec](HTMLSpecURL#delete-all-cookies) +-- +-- @DELETE \/session\/{session id}\/cookie Delete All Cookies@ +deleteAllCookies :: Session -> Command () +deleteAllCookies sessionId = Delete "Delete All Cookies" (sessionUri1 sessionId "cookie") + +-- | +-- +-- Return a spec to perform actions on the current page given a 'Session' and 'Actions'. +-- +-- [spec](HTMLSpecURL#perform-actions) +-- +-- @POST \/session\/{session id}\/actions Perform Actions@ +performActions :: Session -> Actions -> Command () +performActions sessionId = mkPost "Perform Actions" (sessionUri1 sessionId "actions") + +-- | +-- +-- Return a spec to release actions on the current page given a 'Session'. +-- +-- [spec](HTMLSpecURL#release-actions) +-- +-- @DELETE \/session\/{session id}\/actions Release Actions@ +releaseActions :: Session -> Command () +releaseActions sessionId = Delete "Release Actions" (sessionUri1 sessionId "actions") + +-- | +-- +-- Return a spec to dismiss an alert on the current page given a 'Session'. +-- +-- [spec](HTMLSpecURL#dismiss-alert) +-- +-- @POST \/session\/{session id}\/alert\/dismiss Dismiss Alert@ +dismissAlert :: Session -> Command () +dismissAlert sessionId = PostEmpty "Dismiss Alert" (sessionUri2 sessionId "alert" "dismiss") + +-- | +-- +-- Return a spec to accept an alert on the current page given a 'Session'. +-- +-- [spec](HTMLSpecURL#accept-alert) +-- +-- @POST \/session\/{session id}\/alert\/accept Accept Alert@ +acceptAlert :: Session -> Command () +acceptAlert sessionId = PostEmpty "Accept Alert" (sessionUri2 sessionId "alert" "accept") + +-- | +-- +-- Return a spec to get the text of an alert on the current page given a 'Session'. +-- +-- [spec](HTMLSpecURL#get-alert-text) +-- +-- @GET \/session\/{session id}\/alert\/text Get Alert Text@ +getAlertText :: Session -> Command Text +getAlertText sessionId = Get "Get Alert Text" (sessionUri2 sessionId "alert" "text") + +-- | +-- +-- Return a spec to send text to an alert on the current page given a 'Session' and 'Text'. +-- +-- [spec](HTMLSpecURL#send-alert-text) +-- +-- @POST \/session\/{session id}\/alert\/text Send Alert Text@ +sendAlertText :: Session -> Text -> Command () +sendAlertText sessionId text = Post "Send Alert Text" (sessionUri2 sessionId "alert" "text") (fromList ["text" .= text]) + +-- | +-- +-- Return a spec to take a screenshot of the current page given a 'Session'. +-- +-- [spec](HTMLSpecURL#take-screenshot) +-- +-- @GET \/session\/{session id}\/screenshot Take Screenshot@ +takeScreenshot :: Session -> Command Text +takeScreenshot sessionId = Get "Take Screenshot" (sessionUri1 sessionId "screenshot") + +-- | +-- +-- Return a spec to print the current page given a 'Session'. +-- +-- [spec](HTMLSpecURL#print-page) +-- +-- @POST \/session\/{session id}\/print Print Page@ +printPage :: Session -> Command Text +printPage sessionId = PostEmpty "Print Page" (sessionUri1 sessionId "print") + +-- ############################ Window Methods ########################################## + +-- | +-- +-- Return a spec to get all window handles of the current session given a 'Session'. +-- +-- [spec](HTMLSpecURL#get-window-handles) +-- +-- @GET \/session\/{session id}\/window\/handles Get Window Handles@ +getWindowHandles :: Session -> Command [Handle] +getWindowHandles sessionRef = Get "Get Window Handles" (sessionUri2 sessionRef "window" "handles") + +-- | +-- +-- Return a spec to get the window rect of the current window given a 'Session'. +-- +-- [spec](HTMLSpecURL#get-window-rect) +-- +-- @GET \/session\/{session id}\/window\/rect Get Window Rect@ +getWindowRect :: Session -> Command WindowRect +getWindowRect sessionRef = Get "Get Window Rect" (sessionUri2 sessionRef "window" "rect") + +-- | +-- +-- Return a spec to set the window rect of the current window given a 'Session' and 'WindowRect'. +-- +-- [spec](HTMLSpecURL#set-window-rect) +-- +-- @POST \/session\/{session id}\/window\/rect Set Window Rect@ +setWindowRect :: Session -> WindowRect -> Command WindowRect +setWindowRect sessionRef = mkPost "Set Window Rect" (sessionUri2 sessionRef "window" "rect") + +-- | +-- +-- Return a spec to maximize the current window given a 'Session'. +-- +-- [spec](HTMLSpecURL#maximize-window) +-- +-- @POST \/session\/{session id}\/window\/maximize Maximize Window@ +maximizeWindow :: Session -> Command WindowRect +maximizeWindow sessionRef = PostEmpty "Maximize Window" (windowUri1 sessionRef "maximize") + +-- | +-- +-- Return a spec to minimize the current window given a 'Session'. +-- +-- [spec](HTMLSpecURL#minimize-window) +-- +-- @POST \/session\/{session id}\/window\/minimize Minimize Window@ +minimizeWindow :: Session -> Command WindowRect +minimizeWindow sessionRef = PostEmpty "Minimize Window" (windowUri1 sessionRef "minimize") + +-- | +-- +-- Return a spec to fullscreen the current window given a 'Session'. +-- +-- [spec](HTMLSpecURL#fullscreen-window) +-- +-- @POST \/session\/{session id}\/window\/fullscreen Fullscreen Window@ +fullScreenWindow :: Session -> Command WindowRect +fullScreenWindow sessionRef = PostEmpty "Fullscreen Window" (windowUri1 sessionRef "fullscreen") + +-- ############################ Frame Methods ########################################## + +-- | +-- +-- Return a spec to switch to the parent frame given a 'Session'. +-- +-- [spec](HTMLSpecURL#switch-to-parent-frame) +-- +-- @POST \/session\/{session id}\/frame\/parent Switch To Parent Frame@ +switchToParentFrame :: Session -> Command () +switchToParentFrame sessionRef = PostEmpty "Switch To Parent Frame" (sessionUri2 sessionRef "frame" "parent") + +-- ############################ Element(s) Methods ########################################## + +-- | +-- +-- Return a spec to get the active element of the current page given a 'Session'. +-- +-- [spec](HTMLSpecURL#get-active-element) +-- +-- @GET \/session\/{session id}\/element\/active Get Active Element@ +getActiveElement :: Session -> Command ElementId +getActiveElement sessionId = Get "Get Active Element" (sessionUri2 sessionId "element" "active") + +-- | +-- +-- Return a spec to find an element on the current page given a 'Session' and 'Selector'. +-- +-- [spec](HTMLSpecURL#find-element) +-- +-- @POST \/session\/{session id}\/element Find Element@ +findElement :: Session -> Selector -> Command ElementId +findElement sessionRef = mkPost "Find Element" (sessionUri1 sessionRef "element") + +-- | +-- +-- Return a spec to find elements on the current page given a 'Session' and 'Selector'. +-- +-- [spec](HTMLSpecURL#find-elements) +-- +-- @POST \/session\/{session id}\/elements Find Elements@ +findElements :: Session -> Selector -> Command [ElementId] +findElements sessionRef = mkPost "Find Elements" (sessionUri1 sessionRef "elements") + +-- ############################ Element Instance Methods ########################################## + +-- | +-- +-- Return a spec to get the shadow root of an element given a 'Session' and 'ElementId'. +-- +-- [spec](HTMLSpecURL#get-element-shadow-root) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/shadow Get Element Shadow Root@ +getElementShadowRoot :: Session -> ElementId -> Command ShadowRootElementId +getElementShadowRoot sessionId elementId = Get "Get Element Shadow Root" (elementUri1 sessionId elementId "shadow") + +-- | +-- +-- Return a spec to find an element from another element given a 'Session', 'ElementId', and 'Selector'. +-- +-- [spec](HTMLSpecURL#find-element-from-element) +-- +-- @POST \/session\/{session id}\/element\/{element id}\/element Find Element From Element@ +findElementFromElement :: Session -> ElementId -> Selector -> Command ElementId +findElementFromElement sessionId elementId = mkPost "Find Element From Element" (elementUri1 sessionId elementId "element") + +-- | +-- +-- Return a spec to find elements from another element given a 'Session', 'ElementId', and 'Selector'. +-- +-- [spec](HTMLSpecURL#find-elements-from-element) +-- +-- @POST \/session\/{session id}\/element\/{element id}\/elements Find Elements From Element@ +findElementsFromElement :: Session -> ElementId -> Selector -> Command [ElementId] +findElementsFromElement sessionId elementId = mkPost "Find Elements From Element" (elementUri1 sessionId elementId "elements") + +-- | +-- +-- Return a spec to check if an element is selected given a 'Session' and 'ElementId'. +-- +-- [spec](HTMLSpecURL#is-element-selected) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/selected Is Element Selected@ +isElementSelected :: Session -> ElementId -> Command Bool +isElementSelected sessionId elementId = Get "Is Element Selected" (elementUri1 sessionId elementId "selected") + +-- | +-- +-- Return a spec to get an attribute of an element given a 'Session', 'ElementId', and attribute name. +-- +-- [spec](HTMLSpecURL#get-element-attribute) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/attribute\/{name} Get Element Attribute@ +getElementAttribute :: Session -> ElementId -> Text -> Command Text +getElementAttribute sessionId elementId attributeName = Get "Get Element Attribute" (elementUri2 sessionId elementId "attribute" attributeName) + +-- | +-- +-- Return a spec to get a property of an element given a 'Session', 'ElementId', and property name. +-- +-- [spec](HTMLSpecURL#get-element-property) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/property\/{name} Get Element Property@ +getElementProperty :: Session -> ElementId -> Text -> Command Value +getElementProperty sessionId elementId propertyName = Get "Get Element Property" (elementUri2 sessionId elementId "property" propertyName) + +-- | +-- +-- Return a spec to get the CSS value of an element given a 'Session', 'ElementId', and CSS property name. +-- +-- [spec](HTMLSpecURL#get-element-css-value) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/css\/{property name} Get Element CSS Value@ +getElementCssValue :: Session -> ElementId -> Text -> Command Text +getElementCssValue sessionId elementId propertyName = Get "Get Element CSS Value" (elementUri2 sessionId elementId "css" propertyName) + +-- | +-- +-- Return a spec to get the text of an element given a 'Session' and 'ElementId'. +-- +-- [spec](HTMLSpecURL#get-element-text) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/text Get Element Text@ +getElementText :: Session -> ElementId -> Command Text +getElementText sessionId elementId = Get "Get Element Text" (elementUri1 sessionId elementId "text") + +-- | +-- +-- Return a spec to get the tag name of an element given a 'Session' and 'ElementId'. +-- +-- [spec](HTMLSpecURL#get-element-tag-name) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/name Get Element Tag Name@ +getElementTagName :: Session -> ElementId -> Command Text +getElementTagName sessionId elementId = Get "Get Element Tag Name" (elementUri1 sessionId elementId "name") + +-- | +-- +-- Return a spec to get the rect of an element given a 'Session' and 'ElementId'. +-- +-- [spec](HTMLSpecURL#get-element-rect) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/rect Get Element Rect@ +getElementRect :: Session -> ElementId -> Command WindowRect +getElementRect sessionId elementId = Get "Get Element Rect" (elementUri1 sessionId elementId "rect") + +-- | +-- +-- Return a spec to check if an element is enabled given a 'Session' and 'ElementId'. +-- +-- [spec](HTMLSpecURL#is-element-enabled) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/enabled Is Element Enabled@ +isElementEnabled :: Session -> ElementId -> Command Bool +isElementEnabled sessionId elementId = Get "Is Element Enabled" (elementUri1 sessionId elementId "enabled") + +-- | +-- +-- Return a spec to get the computed role of an element given a 'Session' and 'ElementId'. +-- +-- [spec](HTMLSpecURL#get-computed-role) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/computedrole Get Computed Role@ +getElementComputedRole :: Session -> ElementId -> Command Text +getElementComputedRole sessionId elementId = Get "Get Computed Role" (elementUri1 sessionId elementId "computedrole") + +-- | +-- +-- Return a spec to get the computed label of an element given a 'Session' and 'ElementId'. +-- +-- [spec](HTMLSpecURL#get-computed-label) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/computedlabel Get Computed Label@ +getElementComputedLabel :: Session -> ElementId -> Command Text +getElementComputedLabel sessionId elementId = Get "Get Computed Label" (elementUri1 sessionId elementId "computedlabel") + +-- | +-- +-- Return a spec to click an element given a 'Session' and 'ElementId'. +-- +-- [spec](HTMLSpecURL#element-click) +-- +-- @POST \/session\/{session id}\/element\/{element id}\/click Element Click@ +elementClick :: Session -> ElementId -> Command () +elementClick sessionId elementId = PostEmpty "Element Click" (elementUri1 sessionId elementId "click") + +-- | +-- +-- Return a spec to clear an element given a 'Session' and 'ElementId'. +-- +-- [spec](HTMLSpecURL#element-clear) +-- +-- @POST \/session\/{session id}\/element\/{element id}\/clear Element Clear@ +elementClear :: Session -> ElementId -> Command () +elementClear sessionId elementId = PostEmpty "Element Clear" (elementUri1 sessionId elementId "clear") + +-- | +-- +-- Return a spec to send keys to an element given a 'Session', 'ElementId', and keys to send. +-- +-- [spec](HTMLSpecURL#element-send-keys) +-- +-- @POST \/session\/{session id}\/element\/{element id}\/value Element Send Keys@ +elementSendKeys :: Session -> ElementId -> Text -> Command () +elementSendKeys sessionId elementId keysToSend = Post "Element Send Keys" (elementUri1 sessionId elementId "value") (fromList ["text" .= keysToSend]) + +-- | +-- +-- Return a spec to take a screenshot of an element given a 'Session' and 'ElementId'. +-- +-- [spec](HTMLSpecURL#take-element-screenshot) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/screenshot Take Element Screenshot@ +takeElementScreenshot :: Session -> ElementId -> Command Text +takeElementScreenshot sessionId elementId = Get "Take Element Screenshot" (elementUri1 sessionId elementId "screenshot") + +-- ############################ Shadow DOM Methods ########################################## + +-- | +-- +-- Return a spec to find an element from the shadow root given a 'Session', 'ElementId', and 'Selector'. +-- +-- [spec](HTMLSpecURL#find-element-from-shadow-root) +-- +-- @POST \/session\/{session id}\/shadow\/{shadow id}\/element Find Element From Shadow Root@ +findElementFromShadowRoot :: Session -> ShadowRootElementId -> Selector -> Command ElementId +findElementFromShadowRoot sessionId shadowId = mkPost "Find Element From Shadow Root" (sessionUri3 sessionId "shadow" shadowId.id "element") + +-- | +-- +-- Return a spec to find elements from the shadow root given a 'Session', 'ElementId', and 'Selector'. +-- +-- [spec](HTMLSpecURL#find-elements-from-shadow-root) +-- +-- @POST \/session\/{session id}\/shadow\/{shadow id}\/elements Find Elements From Shadow Root@ +findElementsFromShadowRoot :: Session -> ShadowRootElementId -> Selector -> Command [ElementId] +findElementsFromShadowRoot sessionId shadowId = mkPost "Find Elements From Shadow Root" (sessionUri3 sessionId "shadow" shadowId.id "elements") + +-- ############################ Helper Functions ########################################## + +newSessionUrl :: UrlPath +newSessionUrl = MkUrlPath [session] + +session :: Text +session = "session" + +sessionUri :: Text -> UrlPath +sessionUri sp = MkUrlPath [session, sp] + +sessionUri1 :: Session -> Text -> UrlPath +sessionUri1 s sp = MkUrlPath [session, s.id, sp] + +sessionUri2 :: Session -> Text -> Text -> UrlPath +sessionUri2 s sp sp2 = MkUrlPath [session, s.id, sp, sp2] + +sessionUri3 :: Session -> Text -> Text -> Text -> UrlPath +sessionUri3 s sp sp2 sp3 = MkUrlPath [session, s.id, sp, sp2, sp3] + +sessionUri4 :: Session -> Text -> Text -> Text -> Text -> UrlPath +sessionUri4 s sp sp2 sp3 sp4 = MkUrlPath [session, s.id, sp, sp2, sp3, sp4] + +elementUri1 :: Session -> ElementId -> Text -> UrlPath +elementUri1 s er ep = sessionUri3 s "element" er.id ep + +elementUri2 :: Session -> ElementId -> Text -> Text -> UrlPath +elementUri2 s er ep ep2 = sessionUri4 s "element" er.id ep ep2 + +window :: Text +window = "window" + +windowUri1 :: Session -> Text -> UrlPath +windowUri1 sr sp = sessionUri2 sr window sp diff --git a/src/WebDriverPreCore/HTTP/Capabilities.hs b/src/WebDriverPreCore/HTTP/Capabilities.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/HTTP/Capabilities.hs @@ -0,0 +1,726 @@ +{-# OPTIONS_HADDOCK hide #-} + +module WebDriverPreCore.HTTP.Capabilities + ( FullCapabilities (..), + Capabilities (..), + UnhandledPromptBehavior (..), + PageLoadStrategy (..), + BrowserName (..), + PlatformName (..), + Proxy (..), + Timeouts (..), + VendorSpecific (..), + SocksProxy (..), + PerfLoggingPrefs (..), + MobileEmulation (..), + LogLevel (..), + LogSettings (..), + DeviceMetrics (..), + alwaysMatchCapabilities, + minCapabilities, + minFullCapabilities, + minFirefoxCapabilities, + minChromeCapabilities, + ) +where + +import Control.Applicative (asum) +import Data.Aeson + ( FromJSON (parseJSON), + Key, + KeyValue ((.=)), + Object, + ToJSON (toJSON), + Value, + object, + withObject, + withText, + (.:), + (.:?), + ) +import Data.Aeson.Key (fromText) +import Data.Aeson.Types + ( Pair, + Parser, + Value (..), + parseField, + parseFieldMaybe, + ) +import Data.Map.Strict (Map) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Data.Vector (fromList) +import GHC.Generics (Generic) +import AesonUtils (opt, parseOpt, toJSONOmitNothing, parseJSONOmitNothing) + +{- references: +- https://https://www.w3.org/TR/2025/WD-webdriver2-20251028/#capabilities + + - https://developer.mozilla.org/en-US/docs/Web/WebDriver/Capabilities + - https://mucsi96.gitbook.io/w3c-webdriver/capabilities + + -} + +-- | 'FullCapabilities' is the object that is passed to webdriver to define the properties of the session via the 'Spec.newSession' function. +-- It is a combination of 'alwaysMatch' and 'firstMatch' properties. +-- +-- [spec](https://https://www.w3.org/TR/2025/WD-webdriver2-20251028/#capabilities) +-- +-- See also: 'Capabilities' and related constructors such as 'minCapabilities', 'minFullCapabilities', 'minFirefoxCapabilities' and 'minChromeCapabilities' +data FullCapabilities = MkFullCapabilities + { -- | capabilities that are always matched + alwaysMatch :: Maybe Capabilities, + -- | a list of capabilities that are matched in order, the first matching capabilities that matches the capabilities of the session is used + firstMatch :: [Capabilities] + } + deriving (Show, Generic) + +instance ToJSON FullCapabilities where + toJSON :: FullCapabilities -> Value + toJSON MkFullCapabilities {alwaysMatch, firstMatch} = + object $ + [ "capabilities" .= (object $ catMaybes [opt "alwaysMatch" $ alwaysMatch]), + "firstMatch" .= firstMatch' + ] + where + firstMatch' :: Value + firstMatch' = Array . fromList $ toJSON <$> firstMatch + +instance FromJSON FullCapabilities where + parseJSON :: Value -> Parser FullCapabilities + parseJSON = + withObject "FullCapabilities" $ \v -> + do + capabilities <- v .: "capabilities" + alwaysMatch <- capabilities .:? "alwaysMatch" + firstMatch <- capabilities .: "firstMatch" + pure MkFullCapabilities {..} + +-- | Returns the minimal FullCapabilities object where the 'firstMatch' property is empty. +-- +-- It is very common for 'alwaysMatch' to be the only field populated and the 'firstMatch' field to be empty. +-- +-- [spec](https://https://www.w3.org/TR/2025/WD-webdriver2-20251028/#capabilities) +alwaysMatchCapabilities :: Capabilities -> FullCapabilities +alwaysMatchCapabilities = flip MkFullCapabilities [] . Just + +-- | Returns the minimal FullCapabilities object for a given browser +-- The browserName in the 'alwaysMatch' field is the only field populated +-- [spec](https://https://www.w3.org/TR/2025/WD-webdriver2-20251028/#capabilities) +minFullCapabilities :: BrowserName -> FullCapabilities +minFullCapabilities = alwaysMatchCapabilities . minCapabilities + +-- | Returns the minimal Capabilities object for a given browser +-- The browserName is the only field populated +-- [spec](https://https://www.w3.org/TR/2025/WD-webdriver2-20251028/#capabilities) +minCapabilities :: BrowserName -> Capabilities +minCapabilities browserName = + MkCapabilities + { browserName = Just browserName, + browserVersion = Nothing, + platformName = Nothing, + acceptInsecureCerts = Nothing, + pageLoadStrategy = Nothing, + proxy = Nothing, + setWindowRect = Nothing, + timeouts = Nothing, + strictFileInteractability = Nothing, + unhandledPromptBehavior = Nothing, + webSocketUrl = Nothing, + vendorSpecific = Nothing + } + +-- | Returns the minimal FullCapabilities object for Firefox +minFirefoxCapabilities :: FullCapabilities +minFirefoxCapabilities = minFullCapabilities Firefox + +-- | Returns the minimal FullCapabilities object for Chrome +minChromeCapabilities :: FullCapabilities +minChromeCapabilities = minFullCapabilities Chrome + +-- Custom Types for Enums + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#capabilities) +data UnhandledPromptBehavior + = Dismiss + | Accept + | DismissAndNotify + | AcceptAndNotify + | Ignore + deriving (Show, Generic, Enum, Bounded, Eq) + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#capabilities) +data PageLoadStrategy + = None' + | Eager + | Normal + deriving (Show, Generic, Enum, Bounded, Eq) + +instance ToJSON PageLoadStrategy where + toJSON :: PageLoadStrategy -> Value + toJSON = \case + None' -> "none" + Eager -> "eager" + Normal -> "normal" + +instance FromJSON PageLoadStrategy where + parseJSON :: Value -> Parser PageLoadStrategy + parseJSON = withText "PageLoadStrategy" $ \case + "none" -> pure None' + "eager" -> pure Eager + "normal" -> pure Normal + _ -> fail "Invalid PageLoadStrategy" + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#capabilities) +data BrowserName + = Chrome + | Firefox + | Safari + | Edge + | InternetExplorer + deriving (Show, Generic, Enum, Bounded, Eq) + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#capabilities) +data PlatformName + = Windows + | Mac + | Linux + | Android + | IOS + deriving (Show, Generic, Enum, Bounded, Eq) + +-- | 'Capabilities' define the properties of the session and are passed to the webdriver +-- via fields of the 'FullCapabilities' object. +-- +-- [spec](https://https://www.w3.org/TR/2025/WD-webdriver2-20251028/#capabilities) +-- +-- See also: 'FullCapabilities' and related constructors such as: 'minCapabilities', +-- 'minFullCapabilities', 'minFirefoxCapabilities' and 'minChromeCapabilities' +data Capabilities = MkCapabilities + { browserName :: Maybe BrowserName, + browserVersion :: Maybe Text, + platformName :: Maybe PlatformName, + acceptInsecureCerts :: Maybe Bool, + pageLoadStrategy :: Maybe PageLoadStrategy, + proxy :: Maybe Proxy, + setWindowRect :: Maybe Bool, + timeouts :: Maybe Timeouts, + strictFileInteractability :: Maybe Bool, + unhandledPromptBehavior :: Maybe UnhandledPromptBehavior, + webSocketUrl :: Maybe Bool, + vendorSpecific :: Maybe VendorSpecific + } + deriving (Show, Generic, Eq) + +instance ToJSON Capabilities where + toJSON :: Capabilities -> Value + toJSON + MkCapabilities + { browserName, + browserVersion, + platformName, + acceptInsecureCerts, + pageLoadStrategy, + setWindowRect, + proxy, + timeouts, + strictFileInteractability, + unhandledPromptBehavior, + webSocketUrl, + vendorSpecific + } = + object $ + [ "browserName" .= browserName + ] + <> catMaybes + [ opt "browserVersion" browserVersion, + opt "platformName" platformName, + opt "acceptInsecureCerts" acceptInsecureCerts, + opt "pageLoadStrategy" pageLoadStrategy, + opt "setWindowRect" setWindowRect, + opt "proxy" proxy, + opt "timeouts" timeouts, + opt "strictFileInteractability" strictFileInteractability, + opt "unhandledPromptBehavior" unhandledPromptBehavior, + opt "webSocketUrl" webSocketUrl + ] + <> vendorSpecificToJSON vendorSpecific + +instance FromJSON Capabilities where + parseJSON :: Value -> Parser Capabilities + parseJSON = withObject "Capabilities" $ \v -> + do + browserName <- v .: "browserName" + browserVersion <- v .:? "browserVersion" + platformName <- v .:? "platformName" + acceptInsecureCerts <- v .:? "acceptInsecureCerts" + pageLoadStrategy <- v .:? "pageLoadStrategy" + proxy <- v `parseOpt` "proxy" + setWindowRect <- v .:? "setWindowRect" + timeouts <- v .:? "timeouts" + strictFileInteractability <- v .:? "strictFileInteractability" + unhandledPromptBehavior <- v .:? "unhandledPromptBehavior" + webSocketUrl <- v .:? "webSocketUrl" + vendorSpecific <- parseVendorSpecific v + pure MkCapabilities {..} + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#proxy) +data SocksProxy = MkSocksProxy + { socksProxy :: Text, + socksVersion :: Int + } + deriving (Eq, Show, Generic) + +instance ToJSON SocksProxy where + toJSON :: SocksProxy -> Value + toJSON MkSocksProxy {..} = + object + [ "socksProxy" .= socksProxy, + "socksVersion" .= socksVersion + ] + +instance FromJSON SocksProxy where + parseJSON :: Value -> Parser SocksProxy + parseJSON = withObject "SocksProxy" $ \v -> + do + socksProxy <- v .: "socksProxy" + socksVersion <- v .: "socksVersion" + pure MkSocksProxy {..} + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#proxy) +data Proxy + = Direct + | Manual + { + httpProxy :: Maybe Text, + sslProxy :: Maybe Text, + socksProxy :: Maybe SocksProxy, + noProxy :: Maybe [Text] + } + | AutoDetect + | System + | Pac + { proxyAutoconfigUrl :: Text + } + deriving (Show, Eq) + +instance ToJSON Proxy where + toJSON :: Proxy -> Value + toJSON p = + object $ + [ "proxyType" .= proxyType + ] + <> details + where + proxyType = case p of + Direct -> "direct" + AutoDetect -> "autodetect" + System -> "system" + Pac {} -> "pac" + Manual {} -> "manual" + details = case p of + Direct -> [] + AutoDetect -> [] + System -> [] + Pac {..} -> ["proxyAutoconfigUrl" .= proxyAutoconfigUrl] + Manual {..} -> + catMaybes + [ opt "httpProxy" httpProxy, + opt "sslProxy" sslProxy, + opt "socksProxy" socksProxy, + opt "noProxy" noProxy + ] + +instance FromJSON Proxy where + parseJSON :: Value -> Parser Proxy + parseJSON = withObject "Proxy" $ + \v -> + v .: "proxyType" >>= \case + String "direct" -> pure Direct + String "autodetect" -> pure AutoDetect + String "system" -> pure System + String "pac" -> Pac <$> v .: "proxyAutoconfigUrl" + String "manual" -> + do + httpProxy <- v .:? "httpProxy" + sslProxy <- v .:? "sslProxy" + socksProxy <- v .:? "socksProxy" + noProxy <- v .:? "noProxy" + pure Manual {..} + _ -> fail "Invalid Proxy" + +-- Vendor Capabilities + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#extensions-0) +data VendorSpecific + = -- | Chrome capabilities - [spec](https://developer.chrome.com/docs/chromedriver/capabilities) + -- + -- Use also for Opera - [spec](https://github.com/operasoftware/operachromiumdriver) + ChromeOptions + { chromeArgs :: Maybe [Text], + chromeBinary :: Maybe Text, + chromeExtensions :: Maybe [Text], -- Base64-encoded + chromeLocalState :: Maybe (Map Text Value), -- Local state preferences + chromeMobileEmulation :: Maybe MobileEmulation, + chromePrefs :: Maybe (Map Text Value), -- User preferences + chromeDetach :: Maybe Bool, -- Keep browser running after driver exit + chromeDebuggerAddress :: Maybe Text, -- Remote debugger address + chromeExcludeSwitches :: Maybe [Text], -- Chrome switches to exclude + chromeMinidumpPath :: Maybe FilePath, -- Crash dump directory + chromePerfLoggingPrefs :: Maybe PerfLoggingPrefs, + chromeWindowTypes :: Maybe [Text] -- Window types to create + } + | -- | Edge capabilities - [spec](https://learn.microsoft.com/en-us/microsoft-edge/webdriver-chromium/capabilities-edge-options) + EdgeOptions + { edgeArgs :: Maybe [Text], + edgeBinary :: Maybe Text, + edgeExtensions :: Maybe [Text], -- Base64-encoded + edgeLocalState :: Maybe (Map Text Value), -- Local state preferences + edgeMobileEmulation :: Maybe MobileEmulation, + edgePrefs :: Maybe (Map Text Value), -- User preferences + edgeDetach :: Maybe Bool, -- Keep browser running after driver exit + edgeDebuggerAddress :: Maybe Text, -- Remote debugger address + edgeExcludeSwitches :: Maybe [Text], -- Chrome switches to exclude + edgeMinidumpPath :: Maybe FilePath, -- Crash dump directory + edgePerfLoggingPrefs :: Maybe PerfLoggingPrefs, + edgeWindowTypes :: Maybe [Text] -- Window types to create + } + | -- | Firefox capabilities - [spec](https://developer.mozilla.org/en-US/docs/Web/WebDriver/Capabilities) + FirefoxOptions + { firefoxArgs :: Maybe [Text], + firefoxBinary :: Maybe Text, + firefoxProfile :: Maybe Text, -- Base64-encoded profile + firefoxLog :: Maybe LogSettings + } + | -- | Safari capabilities - [spec](https://developer.apple.com/documentation/webkit/testing_with_webdriver_in_safari) + SafariOptions + { safariAutomaticInspection :: Maybe Bool, + safariAutomaticProfiling :: Maybe Bool + } + deriving (Show, Generic, Eq) + +data PerfLoggingPrefs = MkPerfLoggingPrefs + { enableNetwork :: Maybe Bool, + enablePage :: Maybe Bool, + enableTimeline :: Maybe Bool, + traceCategories :: Maybe Text, + bufferUsageReportingInterval :: Maybe Int + } + deriving (Show, Eq, Generic) + +instance ToJSON PerfLoggingPrefs where + toJSON :: PerfLoggingPrefs -> Value + toJSON = toJSONOmitNothing + +instance FromJSON PerfLoggingPrefs where + parseJSON :: Value -> Parser PerfLoggingPrefs + parseJSON = parseJSONOmitNothing + +data MobileEmulation = MkMobileEmulation + { deviceName :: Maybe Text, + deviceMetrics :: Maybe DeviceMetrics, + userAgent :: Maybe Text + } + deriving (Show, Eq, Generic) + +instance FromJSON MobileEmulation where + parseJSON :: Value -> Parser MobileEmulation + parseJSON = parseJSONOmitNothing + +instance ToJSON MobileEmulation where + toJSON :: MobileEmulation -> Value + toJSON = toJSONOmitNothing + +-- | Browser log levels as defined in vendor specs +data LogLevel + = -- | Most verbose logging + Trace + | -- | Debug-level information + Debug + | -- | Configuration details + Config + | -- | General operational logs + Info + | -- | Potential issues + Warning + | -- | Recoverable errors + Error + | -- | Critical failures + Fatal + | -- | No logging + Off + deriving (Show, Eq, Enum, Bounded, Generic) + +instance ToJSON LogLevel where + toJSON :: LogLevel -> Value + toJSON = + String . \case + Trace -> "trace" + Debug -> "debug" + Config -> "config" + Info -> "info" + Warning -> "warn" + Error -> "error" + Fatal -> "fatal" + Off -> "off" + +instance FromJSON LogLevel where + parseJSON = withText "LogLevel" $ \case + "trace" -> pure Trace + "debug" -> pure Debug + "config" -> pure Config + "info" -> pure Info + "warn" -> pure Warning + "error" -> pure Error + "fatal" -> pure Fatal + "off" -> pure Off + other -> fail $ "Invalid log level: " <> show other + +-- | Log settings structure for vendor capabilities +data LogSettings = MkLogSettings + { level :: LogLevel + } + deriving (Show, Eq, Generic) + +instance FromJSON LogSettings where + parseJSON = withObject "LogSettings" $ \v -> + do + level <- v .: "level" + pure MkLogSettings {..} + +instance ToJSON LogSettings where + toJSON :: LogSettings -> Value + toJSON = toJSONOmitNothing + +data DeviceMetrics = MkDeviceMetrics + { width :: Int, + height :: Int, + pixelRatio :: Double, + touch :: Bool + } + deriving (Show, Eq, Generic) + +instance FromJSON DeviceMetrics where + parseJSON = withObject "DeviceMetrics" $ \v -> + do + let m :: forall a. (FromJSON a) => Key -> Parser a + m = parseField v + width <- m "width" + height <- m "height" + pixelRatio <- m "pixelRatio" + touch <- m "touch" + pure MkDeviceMetrics {..} + +instance ToJSON DeviceMetrics where + toJSON :: DeviceMetrics -> Value + toJSON = toJSONOmitNothing + +-- | ToJSON Instance for VendorSpecific + +-- ToJSON Instance for VendorSpecific +instance ToJSON VendorSpecific where + toJSON :: VendorSpecific -> Value + toJSON vs = + object $ catMaybes props + where + props = case vs of + ChromeOptions {..} -> + [ opt "args" chromeArgs, + opt "binary" chromeBinary, + opt "extensions" chromeExtensions, + opt "localState" chromeLocalState, + opt "mobileEmulation" chromeMobileEmulation, + opt "prefs" chromePrefs, + opt "detach" chromeDetach, + opt "debuggerAddress" chromeDebuggerAddress, + opt "excludeSwitches" chromeExcludeSwitches, + opt "minidumpPath" chromeMinidumpPath, + opt "perfLoggingPrefs" chromePerfLoggingPrefs, + opt "windowTypes" chromeWindowTypes + ] + EdgeOptions {..} -> + [ opt "args" edgeArgs, + opt "binary" edgeBinary, + opt "extensions" edgeExtensions, + opt "localState" edgeLocalState, + opt "prefs" edgePrefs, + opt "detach" edgeDetach, + opt "debuggerAddress" edgeDebuggerAddress, + opt "excludeSwitches" edgeExcludeSwitches, + opt "minidumpPath" edgeMinidumpPath, + opt "mobileEmulation" edgeMobileEmulation, + opt "perfLoggingPrefs" edgePerfLoggingPrefs, + opt "windowTypes" edgeWindowTypes + ] + FirefoxOptions {..} -> + [ opt "args" firefoxArgs, + opt "binary" firefoxBinary, + opt "profile" firefoxProfile, + opt "log" firefoxLog + ] + SafariOptions {..} -> + [ opt "automaticInspection" safariAutomaticInspection, + opt "automaticProfiling" safariAutomaticProfiling + ] + +vendorSpecificPropName :: VendorSpecific -> Text +vendorSpecificPropName = \case + ChromeOptions {} -> "goog:chromeOptions" + EdgeOptions {} -> "ms:edgeOptions" + FirefoxOptions {} -> "moz:firefoxOptions" + SafariOptions {} -> "safari:options" + +vendorSpecificToJSON :: Maybe VendorSpecific -> [Pair] +vendorSpecificToJSON = maybe [] vendorSpecificToJSON' + where + vendorSpecificToJSON' :: VendorSpecific -> [Pair] + vendorSpecificToJSON' vs = [(fromText (vendorSpecificPropName vs), toJSON vs)] + +-- ToJSON Instances for Custom Types +instance ToJSON UnhandledPromptBehavior where + toJSON :: UnhandledPromptBehavior -> Value + toJSON = \case + Dismiss -> "dismiss" + Accept -> "accept" + DismissAndNotify -> "dismiss and notify" + AcceptAndNotify -> "accept and notify" + Ignore -> "ignore" + +instance ToJSON BrowserName where + toJSON :: BrowserName -> Value + toJSON = \case + Chrome -> "chrome" + Firefox -> "firefox" + Safari -> "safari" + Edge -> "edge" + InternetExplorer -> "internet explorer" + +instance ToJSON PlatformName where + toJSON :: PlatformName -> Value + toJSON = \case + Windows -> "windows" + Mac -> "mac" + Linux -> "linux" + Android -> "android" + IOS -> "ios" + +instance FromJSON UnhandledPromptBehavior where + parseJSON :: Value -> Parser UnhandledPromptBehavior + parseJSON = withText "UnhandledPromptBehavior" $ \case + "dismiss" -> pure Dismiss + "accept" -> pure Accept + "dismiss and notify" -> pure DismissAndNotify + "accept and notify" -> pure AcceptAndNotify + "ignore" -> pure Ignore + other -> fail $ "UnhandledPromptBehavior: " <> show other + +instance FromJSON BrowserName where + parseJSON :: Value -> Parser BrowserName + parseJSON = withText "BrowserName" $ \case + "chrome" -> pure Chrome + "firefox" -> pure Firefox + "safari" -> pure Safari + "edge" -> pure Edge + "internet explorer" -> pure InternetExplorer + _ -> fail "Invalid BrowserName" + +instance FromJSON PlatformName where + parseJSON :: Value -> Parser PlatformName + parseJSON = withText "PlatformName" $ \case + "windows" -> pure Windows + "mac" -> pure Mac + "linux" -> pure Linux + "android" -> pure Android + "ios" -> pure IOS + _ -> fail "Invalid PlatformName" + +-- FromJSON Instances for Data Structures +parseVendorSpecific :: Object -> Parser (Maybe VendorSpecific) +parseVendorSpecific v = + asum + [ Just <$> (v .: "goog:chromeOptions" >>= parseChromeOptions), + Just <$> (v .: "ms:edgeOptions" >>= parseEdgeOptions), + Just <$> (v .: "moz:firefoxOptions" >>= parseFirefoxOptions), + Just <$> (v .: "safari:options" >>= parseSafariOptions), + pure Nothing + ] + where + parseChromeOptions o = do + chromeArgs <- m "args" + chromeBinary <- m "binary" + chromeExtensions <- m "extensions" + chromeLocalState <- m "localState" -- Local state preferences + chromeMobileEmulation <- m "mobileEmulation" + chromePrefs <- m "prefs" + chromeDetach <- m "detach" + chromeDebuggerAddress <- m "debuggerAddress" + chromeExcludeSwitches <- m "excludeSwitches" + chromeMinidumpPath <- m "minidumpPath" + chromePerfLoggingPrefs <- m "perfLoggingPrefs" + chromeWindowTypes <- m "windowTypes" + pure $ ChromeOptions {..} + where + m :: forall a. (FromJSON a) => Key -> Parser (Maybe a) + m = parseFieldMaybe o + + parseEdgeOptions o = do + edgeArgs <- m "args" + edgeBinary <- m "binary" + edgeExtensions <- m "extensions" + edgeLocalState <- m "localState" + edgePrefs <- m "prefs" + edgeDetach <- m "detach" + edgeDebuggerAddress <- m "debuggerAddress" + edgeExcludeSwitches <- m "excludeSwitches" + edgeMinidumpPath <- m "minidumpPath" + edgeMobileEmulation <- m "mobileEmulation" + edgePerfLoggingPrefs <- m "perfLoggingPrefs" + edgeWindowTypes <- m "windowTypes" + pure EdgeOptions {..} + where + m :: forall a. (FromJSON a) => Key -> Parser (Maybe a) + m = parseFieldMaybe o + + parseFirefoxOptions o = do + firefoxArgs <- m "args" + firefoxBinary <- m "binary" + firefoxProfile <- m "profile" + firefoxLog <- m "log" + pure FirefoxOptions {..} + where + m :: forall a. (FromJSON a) => Key -> Parser (Maybe a) + m = parseFieldMaybe o + + parseSafariOptions o = do + safariAutomaticInspection <- m "automaticInspection" + safariAutomaticProfiling <- m "automaticProfiling" + pure SafariOptions {..} + where + m = parseFieldMaybe o + +-- | Timeouts in milliseconds +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#timeouts) +data Timeouts = MkTimeouts + { implicit :: Maybe Int, -- field order needs to be the same as FromJSON below + pageLoad :: Maybe Int, + script :: Maybe Int + } + deriving (Show, Generic, Eq) + +instance FromJSON Timeouts where + parseJSON :: Value -> Parser Timeouts + parseJSON = withObject "Timeouts" $ \v -> + do + implicit <- v .:? "implicit" + pageLoad <- v .:? "pageLoad" + script <- v .:? "script" + pure MkTimeouts {..} + +instance ToJSON Timeouts where + toJSON :: Timeouts -> Value + toJSON MkTimeouts {..} = + object + [ "implicit" .= implicit, + "pageLoad" .= pageLoad, + "script" .= script + ] diff --git a/src/WebDriverPreCore/HTTP/Command.hs b/src/WebDriverPreCore/HTTP/Command.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/HTTP/Command.hs @@ -0,0 +1,127 @@ +{-# OPTIONS_HADDOCK hide #-} + +module WebDriverPreCore.HTTP.Command + ( Command (..), + mkPost, + mkPost', + voidCommand, + loosenCommand, + coerceCommand, + extendPost, + extendPostLoosen, + ) +where + +import Data.Aeson as A + ( Object, + ToJSON (..), Value, + ) +import Data.Text (Text) +import AesonUtils (objectOrThrow) +import Utils (UrlPath (..)) +import Prelude hiding (id, lookup) + +-- | +-- The 'Command' type is a specification for a WebDriver Http command. +-- Every endpoint function in this module returns a 'Command' object which defines the HTTP method, URL path, and request body (if applicable) for the command. +-- The phantom type parameter 'r' represents the expected response type for the command. In practice, this 'r' type will always have a 'FromJSON' instance which can be used to parse the result from the response body. +data Command r + = Get + { description :: Text, + path :: UrlPath + } + | Post + { description :: Text, + path :: UrlPath, + body :: Object + } + | PostEmpty + { description :: Text, + path :: UrlPath + } + | Delete + { description :: Text, + path :: UrlPath + } + deriving (Show, Eq) + + +-- Constructors + +-- | Creates a 'Post' command with the given description, path, and body. +-- +-- The body parameter must be an instance of 'ToJSON' and encode to a JSON 'Object' type. +-- This function is partially applied in "WebDriverPreCore.HTTP.API" to generate specific named command functions. +-- +-- If the body cannot be converted to a JSON 'Object', an error is thrown with the description included in the error message. +mkPost :: forall a r. (ToJSON a) => Text -> UrlPath -> a -> Command r +mkPost description path = mkPost' description path (objectOrThrow ("mkPost - " <> description)) + +-- | Creates a 'Post' command with the given description, path, and a custom parser function. +-- +-- This is a more flexible version of 'mkPost' that allows you to provide a custom function to convert +-- the input parameter to a JSON 'Object'. This is useful when you need more control over the serialization process. +mkPost' :: forall a r. Text -> UrlPath -> (a -> Object) -> a -> Command r +mkPost' description path parser = Post description path . parser + +-- Fallback Functions + +-- | Changes the expected response type of a 'Command' to a different type. +-- +-- This function preserves the HTTP method, path, and request body while only changing the phantom type parameter. +-- It can be used to adapt a command when you need a different response type than what the command originally specified. +coerceCommand :: forall r r'. Command r -> Command r' +coerceCommand = \case + Get {description, path} -> Get {description, path} + Post {description, path, body} -> Post {description, path, body} + PostEmpty {description, path} -> PostEmpty {description, path} + Delete {description, path} -> Delete {description, path} + +-- | Changes the expected response type of a 'Command' to a generic JSON 'Value'. +-- +-- This is a specialization of 'coerceCommand' that loosens the type constraint, +-- allowing you to handle responses in a more flexible way when the exact response structure is not known or not needed. +loosenCommand :: forall r. Command r -> Command Value +loosenCommand = coerceCommand + +-- | Changes the expected response type of a 'Command' to @()@, indicating that the response should be ignored. +-- +-- This is useful for commands where you only care about the side effects and not the response value. +voidCommand :: Command a -> Command () +voidCommand = coerceCommand + +-- | Extends the request body of a 'Post' or 'PostEmpty' command with additional fields from a JSON 'Object', +-- changing the expected response type to a generic JSON 'Value'. +-- +-- For 'Post' commands, the additional fields are merged with the existing body. +-- For 'PostEmpty' commands, the additional fields become the new body. +-- Attempting to use this with 'Get' or 'Delete' commands will result in a runtime error. +extendPostLoosen :: forall r. Command r -> Object -> Command Value +extendPostLoosen = extendCoercePost + +-- | Extends the request body of a 'Post' or 'PostEmpty' command with additional fields from a JSON 'Object', +-- preserving the expected response type. +-- +-- For 'Post' commands, the additional fields are merged with the existing body. +-- For 'PostEmpty' commands, the additional fields become the new body. +-- Attempting to use this with 'Get' or 'Delete' commands will result in a runtime error. +extendPost :: forall r. Command r -> Object -> Command r +extendPost = extendCoercePost + +-- | Extends the request body of a 'Post' or 'PostEmpty' command with additional fields from a JSON 'Object', +-- changing the expected response type to a different type. +-- +-- This is the underlying implementation used by both 'extendPost' and 'extendPostLoosen'. +-- For 'Post' commands, the additional fields are merged with the existing body. +-- For 'PostEmpty' commands, the additional fields become the new body. +-- Attempting to use this with 'Get' or 'Delete' commands will result in a runtime error. +extendCoercePost :: forall r r2. Command r -> Object -> Command r2 +extendCoercePost cmd extended = + case cmd of + Post {description, path, body} -> Post {description, path, body = body <> extended} + PostEmpty {description, path} -> Post {description = description, path = path, body = extended} + get@Get {} -> + error $ "extendPost called with Get Command (extendPost can only be called with Post or PostEmpty commands): " <> show get + del@Delete {} -> + error $ "extendPost called with Delete Command (extendPost can only be called with Post or PostEmpty commands): " <> show del + diff --git a/src/WebDriverPreCore/HTTP/HttpResponse.hs b/src/WebDriverPreCore/HTTP/HttpResponse.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/HTTP/HttpResponse.hs @@ -0,0 +1,25 @@ +{-| +Description : Deprecated + +-} +module WebDriverPreCore.HTTP.HttpResponse {-# DEPRECATED "HttpResponse - will be removed in a future release ~ 2027-02-01. See ChangeLog.md for upgrade instructions" #-} ( + HttpResponse(..) +) where + +import Data.Aeson (Value) +import Data.Text (Text) + +-- | 'HttpResponse' represents a WebDriver HTTP response. +-- +-- An instance of 'HttpResponse' needs to be constructed in order to run the 'WebDriverPreCore.parser' suppplied in the [W3CSpec](WebDriverPreCore.Get) +data HttpResponse = MkHttpResponse + { -- | HTTP status code. + statusCode :: Int, + -- | HTTP status message. + statusMessage :: Text, + -- | Response body in JSON format. + body :: Value + } + deriving (Show, Eq, Ord) + + diff --git a/src/WebDriverPreCore/HTTP/Protocol.hs b/src/WebDriverPreCore/HTTP/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/HTTP/Protocol.hs @@ -0,0 +1,747 @@ +{-| +This module defines the 'Command' type and related types/functions for HTTP commands referenced by the API functions in "WebDriverPreCore.HTTP.API" + +"WebDriverPreCore.HTTP.API" contains functions that generate the payload for each HTTP command and is the main interface for users of this package to interact with the WebDriver HTTP protocol. + +An example of using these modules to implement a basic HTTP client can be found in the [test repository](https://github.com/pyrethrum/webdriver/tree/main/webdriver-precore/test#readme) for this package. +-} + +module WebDriverPreCore.HTTP.Protocol + ( + + -- * Command + Command (..), + + -- ** Constructors + {-| The following constructors are utility functions that partially applied in "WebDriverPreCore.HTTP.API" to generate specific named command functions for POST requests. + Although these functions form the basis of many commands in the "WebDriverPreCore.HTTP.API", it would be unusual to need to use these directly. + -} + mkPost, + mkPost', + + -- ** Fallback Constructors + {-| The following constructors are provided to modify or create new commands that are not directly supported by the "WebDriverPreCore.HTTP.API". + These constructors provide a means by which users can work around defects in this package or defects in driver implementation as well as handling driver specific extensions to the HTTP protocol. + -} + voidCommand, + loosenCommand, + coerceCommand, + extendPost, + extendPostLoosen, + + -- * Capabilities + FullCapabilities (..), + Capabilities (..), + UnhandledPromptBehavior (..), + PageLoadStrategy (..), + BrowserName (..), + PlatformName (..), + Proxy (..), + VendorSpecific (..), + SocksProxy (..), + Timeouts (..), + PerfLoggingPrefs (..), + MobileEmulation (..), + LogLevel (..), + LogSettings (..), + DeviceMetrics (..), + -- * Capability Utility Functions + alwaysMatchCapabilities, + minCapabilities, + minFullCapabilities, + minFirefoxCapabilities, + minChromeCapabilities, + + -- * Error + module WebDriverPreCore.Error, + + -- * Core Types + Cookie (..), + Status (..), + ElementId (..), + ShadowRootElementId (..), + FrameReference (..), + HandleType (..), + SameSite (..), + Script (..), + Selector (..), + Session (..), + SessionResponse (..), + Handle (..), + WindowHandleSpec (..), + WindowRect (..), + module Url, + + -- * Action Types + Action (..), + Actions (..), + KeyAction (..), + Pointer (..), + PointerAction (..), + PointerOrigin (..), + WheelAction (..), + ) +where + +import AesonUtils (nonEmpty, opt, parseObject) +import Data.Aeson as A + ( FromJSON (..), + Key, + KeyValue ((.=)), + ToJSON (toJSON), + Value (..), + object, + withObject, + withText, + (.:), + (.:?), + ) +import Data.Aeson.KeyMap qualified as KM +import Data.Aeson.Types (Parser) +import Data.Function ((&)) +import Data.Map.Strict qualified as M +import Data.Maybe (catMaybes) +import Data.Set (Set, fromList, notMember) +import Data.Text (Text, pack, unpack) +import Data.Text qualified as T +import Data.Word (Word16) +import GHC.Generics (Generic) +import Utils (txt) +import WebDriverPreCore.Error +import WebDriverPreCore.HTTP.Capabilities +import WebDriverPreCore.HTTP.Command +import WebDriverPreCore.Internal.HTTPBidiCommon as Url (URL (..)) +import Prelude hiding (id) + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#dfn-get-window-handle) +newtype Handle = MkHandle {handle :: Text} + deriving (Show, Eq, Generic) + +instance ToJSON Handle where + toJSON :: Handle -> Value + toJSON (MkHandle handle) = object ["handle" .= handle] + +instance FromJSON Handle where + parseJSON :: Value -> Parser Handle + parseJSON = \case + String t -> pure $ MkHandle t + Object o -> do + h <- o .: "handle" + pure $ MkHandle h + v -> fail $ unpack $ "Expected Handle as String or Object with handle property, got: " <> txt v + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#new-window) +data WindowHandleSpec = HandleSpec + { handle :: Handle, + handletype :: HandleType + } + deriving (Show, Eq) + +instance ToJSON WindowHandleSpec where + toJSON :: WindowHandleSpec -> Value + toJSON HandleSpec {handle, handletype} = + object + [ "handle" .= handle.handle, + "type" .= handletype + ] + +instance FromJSON WindowHandleSpec where + parseJSON :: Value -> Parser WindowHandleSpec + parseJSON = withObject "WindowHandleSpec" $ \v -> do + handle <- MkHandle <$> v .: "handle" + handletype <- v .: "type" + pure $ HandleSpec {..} + +data HandleType + = Window + | Tab + deriving (Show, Eq) + +instance ToJSON HandleType where + toJSON :: HandleType -> Value + toJSON = String . T.toLower . pack . show + +instance FromJSON HandleType where + parseJSON :: Value -> Parser HandleType + parseJSON = withText "HandleType" $ \case + "window" -> pure Window + "tab" -> pure Tab + v -> fail $ unpack $ "Unknown HandleType " <> v + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#dfn-find-element) +newtype ElementId = MkElement {id :: Text} + deriving (Show, Eq, Generic) + +instance ToJSON ElementId where + toJSON :: ElementId -> Value + toJSON (MkElement id) = object [elementFieldName .= id] + +instance FromJSON ElementId where + parseJSON :: Value -> Parser ElementId + parseJSON = + withObject "ElementId" $ + fmap MkElement . (.: elementFieldName) + +newtype ShadowRootElementId = MkShadowRootElementId {id :: Text} + deriving (Show, Eq, Generic) + +instance ToJSON ShadowRootElementId where + toJSON :: ShadowRootElementId -> Value + toJSON (MkShadowRootElementId id) = object [shadowRootFieldName .= id] + +instance FromJSON ShadowRootElementId where + parseJSON :: Value -> Parser ShadowRootElementId + parseJSON = + withObject "ElementId" $ + fmap MkShadowRootElementId . (.: shadowRootFieldName) + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#dfn-new-sessions) +newtype Session = MkSession {id :: Text} + deriving (Show, Eq, Generic) + +data SessionResponse = MkSessionResponse + { sessionId :: Session, + webSocketUrl :: Maybe Text, + capabilities :: Capabilities, + extensions :: Maybe (M.Map Text Value) + } + deriving (Show, Eq, Generic) + +webSocketKey :: Key +webSocketKey = "webSocketUrl" + +data Script = MkScript + { script :: Text, + args :: [Value] + } + deriving (Show, Eq, Generic) + +instance ToJSON Script + +instance ToJSON SessionResponse where + toJSON :: SessionResponse -> Value + toJSON MkSessionResponse {sessionId, webSocketUrl, capabilities, extensions} = + object $ + [ "sessionId" .= sessionId.id, + "capabilities" .= mergedCaps, + webSocketKey .= webSocketUrl + ] + where + capsVal = toJSON capabilities + mergedCaps = extensions & maybe capsVal mergeExtensions + mergeExtensions :: M.Map Text Value -> Value + mergeExtensions mv = + case capsVal of + Object capsObj -> Object . KM.union capsObj . KM.fromMapText $ mv + -- this will never happen - capabilities is always an Object + _ -> error "SessionResponse - toJSON: capabilities must be an Object" + +instance FromJSON SessionResponse where + parseJSON :: Value -> Parser SessionResponse + parseJSON = + withObject + "SessionResponse.value" + ( \valueObj -> do + sessionId <- MkSession <$> valueObj .: "sessionId" + -- + capabilitiesVal' :: Value <- valueObj .: "capabilities" + allCapsObject <- parseObject "capabilities property returned from newSession should be an object" capabilitiesVal' + webSocketUrl <- allCapsObject .:? webSocketKey + -- webSocketUrl will come back as a url but is is a Bool flag in Capabilities + -- so it must be converted or there will be a parse error + let capabilitiesVal = webSocketUrlToBool allCapsObject + capabilities :: Capabilities <- parseJSON $ Object capabilitiesVal + standardCapsProps <- parseObject "JSON frotim Capabilities Object must be a JSON Object" $ toJSON capabilities + let keys = fromList . KM.keys + capsKeys = keys standardCapsProps + nonNullExtensionKey k v = k `notMember` capsKeys && k /= webSocketKey && nonEmpty v + extensionsMap = KM.toMapText $ KM.filterWithKey nonNullExtensionKey $ allCapsObject + extensions = + if null extensionsMap + then Nothing + else Just extensionsMap + + pure $ MkSessionResponse {sessionId, webSocketUrl, capabilities, extensions} + ) + +webSocketUrlToBool :: KM.KeyMap Value -> KM.KeyMap Value +webSocketUrlToBool o = + case KM.lookup webSocketKey o of + Just (String url) -> + if (T.null url) + then + KM.delete webSocketKey o + else + KM.insert webSocketKey (Bool True) o -- change to Bool + _ -> o -- no change if property not present + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#dfn-status) +data Status = MkStatus + { ready :: Bool, + message :: Text + } + deriving (Show, Eq, Generic) + +instance ToJSON Status + +instance FromJSON Status + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#cookies) +data SameSite + = Lax + | Strict + | None + deriving (Show, Eq, Ord, Generic) + +instance FromJSON SameSite + +instance ToJSON SameSite where + toJSON :: SameSite -> Value + toJSON = String . txt + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#dfn-switch-to-frame) +data FrameReference + = TopLevelFrame + | FrameNumber Word16 + | FrameElementId ElementId + deriving (Show, Eq) + +instance ToJSON FrameReference where + toJSON :: FrameReference -> Value + toJSON fr = + object + ["id" .= toJSON (frameVariant fr)] + where + frameVariant = + \case + TopLevelFrame -> Null + FrameNumber n -> Number $ fromIntegral n + FrameElementId elm -> object [elementFieldName .= elm.id] + +-- https://www.w3.org/TR/webdriver2/#elements +elementFieldName :: Key +elementFieldName = "element-6066-11e4-a52e-4f735466cecf" + +-- https://www.w3.org/TR/webdriver2/#shadow-root +shadowRootFieldName :: Key +shadowRootFieldName = "shadow-6066-11e4-a52e-4f735466cecf" + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#cookies) +data Cookie = MkCookie + { name :: Text, + value :: Text, + -- optional + path :: Maybe Text, + domain :: Maybe Text, + secure :: Maybe Bool, + httpOnly :: Maybe Bool, + sameSite :: Maybe SameSite, + -- When the cookie expires, specified in seconds since Unix Epoch. + expiry :: Maybe Int + } + deriving (Show, Eq) + +instance FromJSON Cookie where + parseJSON :: Value -> Parser Cookie + parseJSON = withObject "Cookie" $ \v -> do + name <- v .: "name" + value <- v .: "value" + path <- v .:? "path" + domain <- v .:? "domain" + secure <- v .:? "secure" + httpOnly <- v .:? "httpOnly" + sameSite <- v .:? "sameSite" + expiry <- v .:? "expiry" + pure MkCookie {..} + +instance ToJSON Cookie where + toJSON :: Cookie -> Value + toJSON MkCookie {name, value, path, domain, secure, httpOnly, sameSite, expiry} = + object $ + [ "name" .= name, + "value" .= value + ] + <> catMaybes + [ opt "path" path, + opt "domain" domain, + opt "secure" secure, + opt "httpOnly" httpOnly, + opt "sameSite" sameSite, + opt "expiry" expiry + ] + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#locator-strategies) +data Selector + = CSS Text + | XPath Text + | LinkText Text + | PartialLinkText Text + | TagName Text + deriving (Show, Eq) + +instance ToJSON Selector where + toJSON :: Selector -> Value + toJSON = \case + CSS css -> sJSON "css selector" css + XPath xpath -> sJSON "xpath" xpath + LinkText lt -> sJSON "link text" lt + PartialLinkText plt -> sJSON "partial link text" plt + TagName tn -> sJSON "tag name" tn + where + sJSON using value = object ["using" .= using, "value" .= value] + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#dfn-get-element-rect) +data WindowRect = Rect + { x :: Int, + y :: Int, + width :: Int, + height :: Int + } + deriving (Show, Eq, Generic) + +instance ToJSON WindowRect + +instance FromJSON WindowRect where + parseJSON :: Value -> Parser WindowRect + parseJSON = withObject "WindowRect" $ \v -> do + x <- v .: "x" + y <- v .: "y" + width <- v .: "width" + height <- v .: "height" + pure + Rect + { x = floor x, + y = floor y, + width = floor width, + height = floor height + } + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#actions) +newtype Actions = MkActions {actions :: [Action]} + deriving (Show, Eq, Generic) + +instance ToJSON Actions where + toJSON :: Actions -> Value + toJSON MkActions {actions} = + object + [ "actions" .= actions + ] + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#actions) +data KeyAction + = PauseKey {duration :: Maybe Int} -- ms + | KeyDown + { value :: Text + } + | KeyUp + { value :: Text + } + deriving (Show, Eq) + +instance ToJSON KeyAction where + toJSON :: KeyAction -> Value + toJSON PauseKey {duration} = + object $ + [ "type" .= ("pause" :: Text) + ] + <> catMaybes [opt "duration" duration] + toJSON KeyDown {value} = + object + [ "type" .= ("keyDown" :: Text), + "value" .= String value + ] + toJSON KeyUp {value} = + object + [ "type" .= ("keyUp" :: Text), + "value" .= String value + ] + +-- Pointer subtypes + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#actions) +data Pointer + = Mouse + | Pen + | Touch + deriving (Show, Eq) + +mkLwrTxt :: (Show a) => a -> Value +mkLwrTxt = String . T.toLower . txt + +instance ToJSON Pointer where + toJSON :: Pointer -> Value + toJSON = mkLwrTxt + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#actions) +data PointerOrigin + = Viewport + | OriginPointer + | OriginElement ElementId + deriving (Show, Eq) + +instance ToJSON PointerOrigin where + toJSON :: PointerOrigin -> Value + toJSON = \case + Viewport -> "viewport" + OriginPointer -> "pointer" + OriginElement (MkElement id') -> object ["element" .= id'] + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#actions) +data Action + = NoneAction + { id :: Text, + -- the numeric id of the pointing device. This is a positive integer, with the values 0 and 1 reserved for mouse-type pointers. + noneActions :: [Maybe Int] -- delay + } + | Key + { id :: Text, + keyActions :: [KeyAction] + -- https://github.com/jlipps/simple-wd-spec?tab=readme-ov-file#perform-actions + -- keys codepoint https://www.w3.org/TR/webdriver2/#keyboard-actions + } + | Pointer + { id :: Text, + subType :: Pointer, + -- the numeric id of the pointing device. This is a positive integer, with the values 0 and 1 reserved for mouse-type pointers. + pointerId :: Int, + pressed :: Set Int, -- pressed buttons + x :: Int, -- start x location in viewport coordinates. + y :: Int, -- start y location in viewport coordinates + actions :: [PointerAction] + } + | Wheel + { id :: Text, + wheelActions :: [WheelAction] + } + deriving (Show, Eq) + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#actions) +data WheelAction + = PauseWheel {duration :: Maybe Int} -- ms + | Scroll + { origin :: PointerOrigin, + x :: Int, + y :: Int, + deltaX :: Int, + deltaY :: Int, + duration :: Maybe Int -- ms + } + deriving (Show, Eq) + +instance ToJSON WheelAction where + toJSON :: WheelAction -> Value + toJSON wa = + object $ base <> catMaybes [opt "duration" wa.duration] + where + base = case wa of + PauseWheel _ -> ["type" .= ("pause" :: Text)] + Scroll + { origin, + x, + y, + deltaX, + deltaY + } -> + [ "type" .= ("scroll" :: Text), + "origin" .= origin, + "x" .= x, + "y" .= y, + "deltaX" .= deltaX, + "deltaY" .= deltaY + ] + +-- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#actions) +data PointerAction + = PausePointer {duration :: Maybe Int} -- ms + | Up + { button :: Int, + width :: Maybe Int, + height :: Maybe Int, + pressure :: Maybe Float, -- 0 -> 1 + tangentialPressure :: Maybe Float, -- -1 -> 1 + tiltX :: Maybe Int, -- -90 -> 90 + tiltY :: Maybe Int, -- -90 -> 90 + twist :: Maybe Int, -- 0 -> 359 + altitudeAngle :: Maybe Double, -- 0 -> pi/2 + azimuthAngle :: Maybe Double -- 0 -> 2pi-- button} -- button + } + | Down + { button :: Int, + width :: Maybe Int, + height :: Maybe Int, + pressure :: Maybe Float, -- 0 -> 1 + tangentialPressure :: Maybe Float, -- -1 -> 1 + tiltX :: Maybe Int, -- -90 -> 90 + tiltY :: Maybe Int, -- -90 -> 90 + twist :: Maybe Int, -- 0 -> 359 + altitudeAngle :: Maybe Double, -- 0 -> pi/2 + azimuthAngle :: Maybe Double -- 0 -> 2pi-- button + } + | Move + { origin :: PointerOrigin, + duration :: Maybe Int, -- ms + -- where to move to + -- though the spec seems to indicate width and height are double + -- gecko driver was blowing up with anything other than int + width :: Maybe Int, + height :: Maybe Int, + pressure :: Maybe Float, -- 0 -> 1 + tangentialPressure :: Maybe Float, -- -1 -> 1 + tiltX :: Maybe Int, -- -90 -> 90 + tiltY :: Maybe Int, -- -90 -> 90 + twist :: Maybe Int, -- 0 -> 359 + altitudeAngle :: Maybe Double, -- 0 -> pi/2 + azimuthAngle :: Maybe Double, -- 0 -> 2pi + x :: Int, + y :: Int + } + | -- looks like not supported yet by gecko driver 02-02-2025 + -- https://searchfox.org/mozilla-central/source/remote/shared/webdriver/Actions.sys.mjs#2340 + Cancel + deriving (Show, Eq) + +instance ToJSON PointerAction where + toJSON :: PointerAction -> Value + toJSON = \case + PausePointer d -> + object $ + ["type" .= ("pause" :: Text)] + <> catMaybes [opt "duration" d] + Up + { -- https://www.w3.org/TR/pointerevents/#dom-pointerevent-pointerid + button, + width, -- magnitude on the X axis), in CSS pixels (see [CSS21]) -- default = 1 + height, -- (magnitude on the Y axis), in CSS pixels (see [CSS21]) -- default = 1 + pressure, -- 0 - 1 + tangentialPressure, -- -1 -> 1 + tiltX, -- -90 -> 90 + tiltY, -- -90 -> 90 + twist, -- 0 -> 359 + altitudeAngle, -- 0 -> pi/2 + azimuthAngle -- 0 -> 2pi + } -> + object $ + [ "type" .= ("pointerUp" :: Text), + "button" .= button + ] + <> catMaybes + [ opt "height" height, + opt "width" width, + opt "pressure" pressure, + opt "tangentialPressure" tangentialPressure, + opt "tiltX" tiltX, + opt "tiltY" tiltY, + opt "twist" twist, + opt "altitudeAngle" altitudeAngle, + opt "azimuthAngle" azimuthAngle + ] + Down + { button, + width, + height, + pressure, + tangentialPressure, -- -1 -> 1 + tiltX, -- -90 -> 90 + tiltY, -- -90 -> 90 + twist, -- 0 -> 359 + altitudeAngle, -- 0 -> pi/2 + azimuthAngle -- 0 -> 2pi + } -> + object $ + [ "type" .= ("pointerDown" :: Text), + "button" .= button + ] + <> catMaybes + [ opt "height" height, + opt "width" width, + opt "pressure" pressure, + opt "tangentialPressure" tangentialPressure, + opt "tiltX" tiltX, + opt "tiltY" tiltY, + opt "twist" twist, + opt "altitudeAngle" altitudeAngle, + opt "azimuthAngle" azimuthAngle + ] + Move + { origin, + duration, + width, + height, + pressure, + tangentialPressure, -- -1 -> 1 + tiltX, -- -90 -> 90 + tiltY, -- -90 -> 90 + twist, -- 0 -> 359 + altitudeAngle, -- 0 -> pi/2 + azimuthAngle, -- 0 -> 2pi + x, + y + } -> + object $ + [ "type" .= ("pointerMove" :: Text), + "origin" .= origin, + "x" .= x, + "y" .= y + ] + <> catMaybes + [ opt "duration" duration, + opt "height" height, + opt "width" width, + opt "pressure" pressure, + opt "tangentialPressure" tangentialPressure, + opt "tiltX" tiltX, + opt "tiltY" tiltY, + opt "twist" twist, + opt "altitudeAngle" altitudeAngle, + opt "azimuthAngle" azimuthAngle + ] + -- looks like Cancel not supported yet by gecko driver 02-02-2025 + -- https://searchfox.org/mozilla-central/source/remote/shared/webdriver/Actions.sys.mjs#2340 + Cancel -> object ["type" .= ("pointerCancel" :: Text)] + +mkPause :: Maybe Int -> Value +mkPause d = object $ ["type" .= ("pause" :: Text)] <> catMaybes [opt "duration" d] + +instance ToJSON Action where + toJSON :: Action -> Value + toJSON = \case + NoneAction + { id, + noneActions + } -> + object + [ "type" .= ("none" :: Text), + "id" .= id, + "actions" .= (mkPause <$> noneActions) + ] + Key {id, keyActions} -> + object + [ "id" .= id, + "type" .= ("key" :: Text), + "actions" .= keyActions + ] + Pointer + { subType, + actions, + pointerId, + pressed, + id, + x, + y + } -> + object + [ "id" .= id, + "type" .= ("pointer" :: Text), + "subType" .= subType, + "pointerId" .= pointerId, + "pressed" .= pressed, + "x" .= x, + "y" .= y, + "actions" .= actions + ] + Wheel {id, wheelActions} -> + object + [ "id" .= id, + "type" .= ("wheel" :: Text), + "actions" .= wheelActions + ] diff --git a/src/WebDriverPreCore/HTTP/SpecDefinition.hs b/src/WebDriverPreCore/HTTP/SpecDefinition.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/HTTP/SpecDefinition.hs @@ -0,0 +1,898 @@ +{-| +Module : WebDriverPreCore.HTTP.SpecDefinition +Description : Deprecated in favour of "WebDriverPreCore.HTTP.API" + + +-} + +module WebDriverPreCore.HTTP.SpecDefinition + {-# DEPRECATED "Deprecated in favour of \"WebDriverPreCore.HTTP.API\". SpecDefinition module will be removed in a future release ~ 2027-02-01. See ChangeLog.md for upgrade instructions" #-} + ( -- * The HttpSpec Type + HttpSpec (..), + + -- * The API + + -- ** Root Methods + newSession, + newSession', + status, + + -- ** Session Methods + deleteSession, + getTimeouts, + setTimeouts, + navigateTo, + getCurrentUrl, + back, + forward, + refresh, + getTitle, + getWindowHandle, + newWindow, + closeWindow, + switchToWindow, + switchToFrame, + getPageSource, + executeScript, + executeScriptAsync, + addCookie, + getAllCookies, + getNamedCookie, + deleteCookie, + deleteAllCookies, + performActions, + releaseActions, + dismissAlert, + acceptAlert, + getAlertText, + sendAlertText, + takeScreenshot, + printPage, + + -- ** Window Methods + getWindowHandles, + getWindowRect, + setWindowRect, + maximizeWindow, + minimizeWindow, + fullscreenWindow, + + -- ** Frame Methods + switchToParentFrame, + + -- ** Element(s) Methods + getActiveElement, + findElement, + findElements, + + -- ** Element Instance Methods + findElementFromElement, + findElementsFromElement, + isElementSelected, + getElementAttribute, + getElementProperty, + getElementCssValue, + getElementShadowRoot, + getElementText, + getElementTagName, + getElementRect, + isElementEnabled, + getElementComputedRole, + getElementComputedLabel, + elementClick, + elementClear, + elementSendKeys, + takeElementScreenshot, + + -- ** Shadow DOM Methods + findElementFromShadowRoot, + findElementsFromShadowRoot, + ) +where + +import Data.Aeson as A + ( FromJSON (..), + KeyValue ((.=)), + Result (..), + ToJSON (toJSON), + Value (..), + object, (.:), + ) +import Data.Aeson.Types (parse, Parser) +import Data.Text (Text, unpack) +import WebDriverPreCore.HTTP.HttpResponse (HttpResponse (..)) +import WebDriverPreCore.HTTP.Protocol + ( Actions (..), + Cookie (..), + ElementId (..), + FrameReference (..), + FullCapabilities (..), + Handle (..), + Script (..), + Selector (..), + Session (..), + SessionResponse (..), + ShadowRootElementId (..), + Status (..), + Timeouts (..), + URL (..), + WindowHandleSpec (..), + WindowRect (..) + ) +import AesonUtils (jsonToText) +import Utils (UrlPath (..)) +import Prelude hiding (id, lookup) +import Data.Aeson (withObject) +import Control.Monad (when) +import Data.Function ((&)) + +-- | +-- The 'HttpSpec' type is a specification for a WebDriver Http command. +-- Every endpoint function in this module returns a 'HttpSpec' object. +data HttpSpec a + = Get + { description :: Text, + path :: UrlPath, + parser :: HttpResponse -> Result a + } + | Post + { description :: Text, + path :: UrlPath, + body :: Value, + parser :: HttpResponse -> Result a + } + | PostEmpty + { description :: Text, + path :: UrlPath, + parser :: HttpResponse -> Result a + } + | Delete + { description :: Text, + path :: UrlPath, + parser :: HttpResponse -> Result a + } + +get :: forall a. (FromJSON a) => Text -> UrlPath -> HttpSpec a +get description path = + Get description path (getParser False) + +post :: forall c r. (ToJSON c, FromJSON r) => Text -> UrlPath -> c -> HttpSpec r +post description path body = + Post description path (toJSON body) (getParser False) + +post_ :: forall c. (ToJSON c) => Text -> UrlPath -> c -> HttpSpec () +post_ description path body = + Post description path (toJSON body) (getParser True) + +postEmpty :: forall a. (FromJSON a) => Text -> UrlPath -> HttpSpec a +postEmpty description path = + PostEmpty description path (getParser False) + +postEmpty_ :: Text -> UrlPath -> HttpSpec () +postEmpty_ description path = + PostEmpty description path (getParser True) + +delete :: forall a. (FromJSON a) => Text -> UrlPath -> HttpSpec a +delete description path = + Delete description path (getParser False) + +delete_ :: Text -> UrlPath -> HttpSpec () +delete_ description path = + Delete description path (getParser True) + +-- this is to shim the deprecated API with the new +getParser :: forall a. (FromJSON a) => Bool -> HttpResponse -> Result a +getParser expectNull r = parse (fromBodyValue expectNull) r.body + +fromBodyValue :: forall a. (FromJSON a) => Bool -> Value -> Parser a +fromBodyValue expectNull body = + body & withObject "body value" \b -> do + val <- b .: "value" + when (expectNull && val /= Null) $ + fail $ + unpack $ + "Null value expected but got:\n" <> jsonToText val + parseJSON $ val + +instance (Show a) => Show (HttpSpec a) where + show :: HttpSpec a -> String + show = Prelude.show . mkShowable + +data HttpSpecShowable = Request + { description :: Text, + method :: Text, + path :: UrlPath, + body :: Maybe Text + } + deriving (Show) + +mkShowable :: HttpSpec a -> HttpSpecShowable +mkShowable = \case + Get d p _ -> Request d "GET" p Nothing + Post d p b _ -> Request d "POST" p (Just $ jsonToText b) + PostEmpty d p _ -> Request d "POST" p Nothing + Delete d p _ -> Request d "DELETE" p Nothing + +-- ###################################################################### +-- ########################### WebDriver API ############################ +-- ###################################################################### + +-- https://www.w3.org/TR/2025/WD-webdriver2-20251028/ +-- 61 endpoints +-- Method URI Template Command + +-- ** Root Methods + +-- | +-- Return a spec to create a new session given 'FullCapabilities' object. +-- +-- 'newSession'' can be used if 'FullCapabilities' doesn't meet your requirements. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#new-session) +-- +-- @POST \/session New Session@ +newSession :: FullCapabilities -> HttpSpec SessionResponse +newSession = newSession' + +-- | +-- +-- Return a spec to create a new session given an object of any type that implements `ToJSON`. +-- +-- The 'FullCapabilities' type and associated types should work for the vast majority use cases, but if the required capabilities are not covered by the types provided, 'newSession''. +-- can be used with a custom type instead. 'newSession'' works with any type that implements 'ToJSON', (including an Aeson 'Value'). +-- +-- Obviously, any type used must produce a JSON object compatible with [capabilities as defined W3C spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#capabilities). +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#new-session) +-- +-- @POST \/session New Session@ +newSession' :: (ToJSON a) => a -> HttpSpec SessionResponse +newSession' = post "New Session" newSessionUrl + +-- | +-- +-- Return a spec to get the status of the driver. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#status) +-- +-- @GET \/status Status@ +status :: HttpSpec Status +status = get "Status" (MkUrlPath ["status"]) + +-- ############################ Session Methods ########################################## + +-- | +-- +-- Return a spec to delete a session given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#delete-session) +-- +-- @DELETE \/session\/{session id} Delete Session@ +deleteSession :: Session -> HttpSpec () +deleteSession sessionRef = delete_ "Delete Session" (sessionUri sessionRef.id) + +-- | +-- +-- Return a spec to get the timeouts of a session given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-timeouts) +-- +-- @GET \/session\/{session id}\/timeouts Get Timeouts@ +getTimeouts :: Session -> HttpSpec Timeouts +getTimeouts sessionRef = get "Get Timeouts" (sessionUri1 sessionRef "timeouts") + +-- | +-- +-- Return a spec to set the timeouts of a session given a 'Session' and 'Timeouts'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#set-timeouts) +-- +-- @POST \/session\/{session id}\/timeouts Set Timeouts@ +setTimeouts :: Session -> Timeouts -> HttpSpec () +setTimeouts sessionRef timeouts = + post_ "Set Timeouts" (sessionUri1 sessionRef "timeouts") (toJSON timeouts) + +-- | +-- +-- Return a spec to navigate to a URL given a 'Session' and a 'Text' URL. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#navigate-to) +-- +-- @POST \/session\/{session id}\/url Navigate To@ +navigateTo :: Session -> URL -> HttpSpec () +navigateTo sessionRef url = post_ "Navigate To" (sessionUri1 sessionRef "url") (object ["url" .= url]) + +-- | +-- +-- Return a spec to get the current URL of a session given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-current-url) +-- +-- @GET \/session\/{session id}\/url Get Current URL@ +getCurrentUrl :: Session -> HttpSpec URL +getCurrentUrl sessionRef = get "Get Current URL" (sessionUri1 sessionRef "url") + +-- | +-- +-- Return a spec to navigate back in the browser history given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#back) +-- +-- @POST \/session\/{session id}\/back Back@ +back :: Session -> HttpSpec () +back sessionRef = postEmpty_ "Back" (sessionUri1 sessionRef "back") + +-- | +-- +-- Return a spec to navigate forward in the browser history given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#forward) +-- +-- @POST \/session\/{session id}\/forward Forward@ +forward :: Session -> HttpSpec () +forward sessionRef = postEmpty_ "Forward" (sessionUri1 sessionRef "forward") + +-- | +-- +-- Return a spec to refresh the current page given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#refresh) +-- +-- @POST \/session\/{session id}\/refresh Refresh@ +refresh :: Session -> HttpSpec () +refresh sessionRef = postEmpty_ "Refresh" (sessionUri1 sessionRef "refresh") + +-- | +-- +-- Return a spec to get the title of the current page given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-title) +-- +-- @GET \/session\/{session id}\/title Get Title@ +getTitle :: Session -> HttpSpec Text +getTitle sessionRef = get "Get Title" (sessionUri1 sessionRef "title") + +-- | +-- +-- Return a spec to get the current window handle given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-window-handle) +-- +-- @GET \/session\/{session id}\/window Get Window Handle@ +getWindowHandle :: Session -> HttpSpec Handle +getWindowHandle sessionRef = get "Get Window Handle" (sessionUri1 sessionRef "window") + +-- | +-- +-- Return a spec to create a new window given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#new-window) +-- +-- @POST \/session\/{session id}\/window\/new New Window@ +newWindow :: Session -> HttpSpec WindowHandleSpec +newWindow sessionRef = postEmpty "New Window" (sessionUri2 sessionRef "window" "new") + +-- | +-- +-- Return a spec to close the current window given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#close-window) +-- +-- @DELETE \/session\/{session id}\/window Close Window@ +closeWindow :: Session -> HttpSpec [Handle] +closeWindow sessionRef = delete "Close Window" (sessionUri1 sessionRef "window") + +-- | +-- +-- Return a spec to switch to a different window given a 'Session' and 'WindowHandle'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#switch-to-window) +-- +-- @POST \/session\/{session id}\/window Switch To Window@ +switchToWindow :: Session -> Handle -> HttpSpec () +switchToWindow sessionRef MkHandle {handle} = post_ "Switch To Window" (sessionUri1 sessionRef "window") (object ["handle" .= handle]) + +-- | +-- +-- Return a spec to switch to a different frame given a 'Session' and 'FrameReference'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#switch-to-frame) +-- +-- @POST \/session\/{session id}\/frame Switch To Frame@ +switchToFrame :: Session -> FrameReference -> HttpSpec () +switchToFrame sessionRef frameRef = post_ "Switch To Frame" (sessionUri1 sessionRef "frame") (toJSON frameRef) + +-- | +-- +-- Return a spec to get the source of the current page given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-page-source) +-- +-- @GET \/session\/{session id}\/source Get Page Source@ +getPageSource :: Session -> HttpSpec Text +getPageSource sessionId = get "Get Page Source" (sessionUri1 sessionId "source") + +-- | +-- +-- Return a spec to execute a script in the context of the current page given a 'Session', 'Text' script, and a list of 'Value' arguments. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#execute-script) +-- +-- @POST \/session\/{session id}\/execute\/sync Execute Script@ +executeScript :: Session -> Script -> HttpSpec Value +executeScript sessionId script = post "Execute Script" (sessionUri2 sessionId "execute" "sync") (toJSON script) + +-- | +-- +-- Return a spec to execute an asynchronous script in the context of the current page given a 'Session', 'Text' script, and a list of 'Value' arguments. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#execute-async-script) +-- +-- @POST \/session\/{session id}\/execute\/async Execute Async Script@ +executeScriptAsync :: Session -> Script -> HttpSpec Value +executeScriptAsync sessionId script = post "Execute Async Script" (sessionUri2 sessionId "execute" "async") script + +-- | +-- +-- Return a spec to get all cookies of the current page given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-all-cookies) +-- +-- @GET \/session\/{session id}\/cookie Get All Cookies@ +getAllCookies :: Session -> HttpSpec [Cookie] +getAllCookies sessionId = get "Get All Cookies" (sessionUri1 sessionId "cookie") + +-- | +-- +-- Return a spec to get a named cookie of the current page given a 'Session' and cookie name. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-named-cookie) +-- +-- @GET \/session\/{session id}\/cookie\/{name} Get Named Cookie@ +getNamedCookie :: Session -> Text -> HttpSpec Cookie +getNamedCookie sessionId cookieName = get "Get Named Cookie" (sessionUri2 sessionId "cookie" cookieName) + +-- | +-- +-- Return a spec to add a cookie to the current page given a 'Session' and 'Cookie'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#add-cookie) +-- +-- @POST \/session\/{session id}\/cookie Add Cookie@ +addCookie :: Session -> Cookie -> HttpSpec () +addCookie sessionId cookie = post_ "Add Cookie" (sessionUri1 sessionId "cookie") (object ["cookie" .= cookie]) + +-- | +-- +-- Return a spec to delete a named cookie from the current page given a 'Session' and cookie name. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#delete-cookie) +-- +-- @DELETE \/session\/{session id}\/cookie\/{name} Delete Cookie@ +deleteCookie :: Session -> Text -> HttpSpec () +deleteCookie sessionId cookieName = delete_ "Delete Cookie" (sessionUri2 sessionId "cookie" cookieName) + +-- | +-- +-- Return a spec to delete all cookies from the current page given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#delete-all-cookies) +-- +-- @DELETE \/session\/{session id}\/cookie Delete All Cookies@ +deleteAllCookies :: Session -> HttpSpec () +deleteAllCookies sessionId = delete_ "Delete All Cookies" (sessionUri1 sessionId "cookie") + +-- | +-- +-- Return a spec to perform actions on the current page given a 'Session' and 'Actions'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#perform-actions) +-- +-- @POST \/session\/{session id}\/actions Perform Actions@ +performActions :: Session -> Actions -> HttpSpec () +performActions sessionId actions = post_ "Perform Actions" (sessionUri1 sessionId "actions") (toJSON actions) + +-- | +-- +-- Return a spec to release actions on the current page given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#release-actions) +-- +-- @DELETE \/session\/{session id}\/actions Release Actions@ +releaseActions :: Session -> HttpSpec () +releaseActions sessionId = delete_ "Release Actions" (sessionUri1 sessionId "actions") + +-- | +-- +-- Return a spec to dismiss an alert on the current page given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#dismiss-alert) +-- +-- @POST \/session\/{session id}\/alert\/dismiss Dismiss Alert@ +dismissAlert :: Session -> HttpSpec () +dismissAlert sessionId = postEmpty_ "Dismiss Alert" (sessionUri2 sessionId "alert" "dismiss") + +-- | +-- +-- Return a spec to accept an alert on the current page given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#accept-alert) +-- +-- @POST \/session\/{session id}\/alert\/accept Accept Alert@ +acceptAlert :: Session -> HttpSpec () +acceptAlert sessionId = postEmpty_ "Accept Alert" (sessionUri2 sessionId "alert" "accept") + +-- | +-- +-- Return a spec to get the text of an alert on the current page given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-alert-text) +-- +-- @GET \/session\/{session id}\/alert\/text Get Alert Text@ +getAlertText :: Session -> HttpSpec Text +getAlertText sessionId = get "Get Alert Text" (sessionUri2 sessionId "alert" "text") + +-- | +-- +-- Return a spec to send text to an alert on the current page given a 'Session' and 'Text'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#send-alert-text) +-- +-- @POST \/session\/{session id}\/alert\/text Send Alert Text@ +sendAlertText :: Session -> Text -> HttpSpec () +sendAlertText sessionId text = post_ "Send Alert Text" (sessionUri2 sessionId "alert" "text") (object ["text" .= text]) + +-- | +-- +-- Return a spec to take a screenshot of the current page given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#take-screenshot) +-- +-- @GET \/session\/{session id}\/screenshot Take Screenshot@ +takeScreenshot :: Session -> HttpSpec Text +takeScreenshot sessionId = get "Take Screenshot" (sessionUri1 sessionId "screenshot") + +-- | +-- +-- Return a spec to print the current page given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#print-page) +-- +-- @POST \/session\/{session id}\/print Print Page@ +printPage :: Session -> HttpSpec Text +printPage sessionId = postEmpty "Print Page" (sessionUri1 sessionId "print") + +-- ############################ Window Methods ########################################## + +-- | +-- +-- Return a spec to get all window handles of the current session given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-window-handles) +-- +-- @GET \/session\/{session id}\/window\/handles Get Window Handles@ +getWindowHandles :: Session -> HttpSpec [Handle] +getWindowHandles sessionRef = get "Get Window Handles" (sessionUri2 sessionRef "window" "handles") + +-- | +-- +-- Return a spec to get the window rect of the current window given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-window-rect) +-- +-- @GET \/session\/{session id}\/window\/rect Get Window Rect@ +getWindowRect :: Session -> HttpSpec WindowRect +getWindowRect sessionRef = get "Get Window Rect" (sessionUri2 sessionRef "window" "rect") + +-- | +-- +-- Return a spec to set the window rect of the current window given a 'Session' and 'WindowRect'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#set-window-rect) +-- +-- @POST \/session\/{session id}\/window\/rect Set Window Rect@ +setWindowRect :: Session -> WindowRect -> HttpSpec WindowRect +setWindowRect sessionRef = post "Set Window Rect" (sessionUri2 sessionRef "window" "rect") + +-- | +-- +-- Return a spec to maximize the current window given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#maximize-window) +-- +-- @POST \/session\/{session id}\/window\/maximize Maximize Window@ +maximizeWindow :: Session -> HttpSpec WindowRect +maximizeWindow sessionRef = postEmpty "Maximize Window" (windowUri1 sessionRef "maximize") + +-- | +-- +-- Return a spec to minimize the current window given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#minimize-window) +-- +-- @POST \/session\/{session id}\/window\/minimize Minimize Window@ +minimizeWindow :: Session -> HttpSpec WindowRect +minimizeWindow sessionRef = postEmpty "Minimize Window" (windowUri1 sessionRef "minimize") + +-- | +-- +-- Return a spec to fullscreen the current window given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#fullscreen-window) +-- +-- @POST \/session\/{session id}\/window\/fullscreen Fullscreen Window@ +fullscreenWindow :: Session -> HttpSpec WindowRect +fullscreenWindow sessionRef = postEmpty "Fullscreen Window" (windowUri1 sessionRef "fullscreen") + +-- ############################ Frame Methods ########################################## + +-- | +-- +-- Return a spec to switch to the parent frame given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#switch-to-parent-frame) +-- +-- @POST \/session\/{session id}\/frame\/parent Switch To Parent Frame@ +switchToParentFrame :: Session -> HttpSpec () +switchToParentFrame sessionRef = postEmpty_ "Switch To Parent Frame" (sessionUri2 sessionRef "frame" "parent") + +-- ############################ Element(s) Methods ########################################## + +-- | +-- +-- Return a spec to get the active element of the current page given a 'Session'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-active-element) +-- +-- @GET \/session\/{session id}\/element\/active Get Active Element@ +getActiveElement :: Session -> HttpSpec ElementId +getActiveElement sessionId = get "Get Active Element" (sessionUri2 sessionId "element" "active") + +-- | +-- +-- Return a spec to find an element on the current page given a 'Session' and 'Selector'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#find-element) +-- +-- @POST \/session\/{session id}\/element Find Element@ +findElement :: Session -> Selector -> HttpSpec ElementId +findElement sessionRef = post "Find Element" (sessionUri1 sessionRef "element") + +-- | +-- +-- Return a spec to find elements on the current page given a 'Session' and 'Selector'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#find-elements) +-- +-- @POST \/session\/{session id}\/elements Find Elements@ +findElements :: Session -> Selector -> HttpSpec [ElementId] +findElements sessionRef = post "Find Elements" (sessionUri1 sessionRef "elements") + +-- ############################ Element Instance Methods ########################################## + +-- | +-- +-- Return a spec to get the shadow root of an element given a 'Session' and 'ElementId'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-element-shadow-root) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/shadow Get Element Shadow Root@ +getElementShadowRoot :: Session -> ElementId -> HttpSpec ShadowRootElementId +getElementShadowRoot sessionId elementId = get "Get Element Shadow Root" (elementUri1 sessionId elementId "shadow") + +-- | +-- +-- Return a spec to find an element from another element given a 'Session', 'ElementId', and 'Selector'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#find-element-from-element) +-- +-- @POST \/session\/{session id}\/element\/{element id}\/element Find Element From Element@ +findElementFromElement :: Session -> ElementId -> Selector -> HttpSpec ElementId +findElementFromElement sessionId elementId = post "Find Element From Element" (elementUri1 sessionId elementId "element") + +-- | +-- +-- Return a spec to find elements from another element given a 'Session', 'ElementId', and 'Selector'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#find-elements-from-element) +-- +-- @POST \/session\/{session id}\/element\/{element id}\/elements Find Elements From Element@ +findElementsFromElement :: Session -> ElementId -> Selector -> HttpSpec [ElementId] +findElementsFromElement sessionId elementId = post "Find Elements From Element" (elementUri1 sessionId elementId "elements") + +-- | +-- +-- Return a spec to check if an element is selected given a 'Session' and 'ElementId'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#is-element-selected) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/selected Is Element Selected@ +isElementSelected :: Session -> ElementId -> HttpSpec Bool +isElementSelected sessionId elementId = get "Is Element Selected" (elementUri1 sessionId elementId "selected") + +-- | +-- +-- Return a spec to get an attribute of an element given a 'Session', 'ElementId', and attribute name. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-element-attribute) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/attribute\/{name} Get Element Attribute@ +getElementAttribute :: Session -> ElementId -> Text -> HttpSpec Text +getElementAttribute sessionId elementId attributeName = get "Get Element Attribute" (elementUri2 sessionId elementId "attribute" attributeName) + +-- | +-- +-- Return a spec to get a property of an element given a 'Session', 'ElementId', and property name. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-element-property) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/property\/{name} Get Element Property@ +getElementProperty :: Session -> ElementId -> Text -> HttpSpec Value +getElementProperty sessionId elementId propertyName = get "Get Element Property" (elementUri2 sessionId elementId "property" propertyName) + +-- | +-- +-- Return a spec to get the CSS value of an element given a 'Session', 'ElementId', and CSS property name. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-element-css-value) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/css\/{property name} Get Element CSS Value@ +getElementCssValue :: Session -> ElementId -> Text -> HttpSpec Text +getElementCssValue sessionId elementId propertyName = get "Get Element CSS Value" (elementUri2 sessionId elementId "css" propertyName) + +-- | +-- +-- Return a spec to get the text of an element given a 'Session' and 'ElementId'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-element-text) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/text Get Element Text@ +getElementText :: Session -> ElementId -> HttpSpec Text +getElementText sessionId elementId = get "Get Element Text" (elementUri1 sessionId elementId "text") + +-- | +-- +-- Return a spec to get the tag name of an element given a 'Session' and 'ElementId'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-element-tag-name) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/name Get Element Tag Name@ +getElementTagName :: Session -> ElementId -> HttpSpec Text +getElementTagName sessionId elementId = get "Get Element Tag Name" (elementUri1 sessionId elementId "name") + +-- | +-- +-- Return a spec to get the rect of an element given a 'Session' and 'ElementId'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-element-rect) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/rect Get Element Rect@ +getElementRect :: Session -> ElementId -> HttpSpec WindowRect +getElementRect sessionId elementId = get "Get Element Rect" (elementUri1 sessionId elementId "rect") + +-- | +-- +-- Return a spec to check if an element is enabled given a 'Session' and 'ElementId'. +--SAP will foc +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#is-element-enabled) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/enabled Is Element Enabled@ +isElementEnabled :: Session -> ElementId -> HttpSpec Bool +isElementEnabled sessionId elementId = get "Is Element Enabled" (elementUri1 sessionId elementId "enabled") + +-- | +-- +-- Return a spec to get the computed role of an element given a 'Session' and 'ElementId'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-computed-role) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/computedrole Get Computed Role@ +getElementComputedRole :: Session -> ElementId -> HttpSpec Text +getElementComputedRole sessionId elementId = get "Get Computed Role" (elementUri1 sessionId elementId "computedrole") + +-- | +-- +-- Return a spec to get the computed label of an element given a 'Session' and 'ElementId'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#get-computed-label) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/computedlabel Get Computed Label@ +getElementComputedLabel :: Session -> ElementId -> HttpSpec Text +getElementComputedLabel sessionId elementId = get "Get Computed Label" (elementUri1 sessionId elementId "computedlabel") + +-- | +-- +-- Return a spec to click an element given a 'Session' and 'ElementId'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#element-click) +-- +-- @POST \/session\/{session id}\/element\/{element id}\/click Element Click@ +elementClick :: Session -> ElementId -> HttpSpec () +elementClick sessionId elementId = postEmpty_ "Element Click" (elementUri1 sessionId elementId "click") + +-- | +-- +-- Return a spec to clear an element given a 'Session' and 'ElementId'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#element-clear) +-- +-- @POST \/session\/{session id}\/element\/{element id}\/clear Element Clear@ +elementClear :: Session -> ElementId -> HttpSpec () +elementClear sessionId elementId = postEmpty_ "Element Clear" (elementUri1 sessionId elementId "clear") + +-- | +-- +-- Return a spec to send keys to an element given a 'Session', 'ElementId', and keys to send. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#element-send-keys) +-- +-- @POST \/session\/{session id}\/element\/{element id}\/value Element Send Keys@ +elementSendKeys :: Session -> ElementId -> Text -> HttpSpec () +elementSendKeys sessionId elementId keysToSend = post_ "Element Send Keys" (elementUri1 sessionId elementId "value") (object ["text" .= keysToSend]) + +-- | +-- +-- Return a spec to take a screenshot of an element given a 'Session' and 'ElementId'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#take-element-screenshot) +-- +-- @GET \/session\/{session id}\/element\/{element id}\/screenshot Take Element Screenshot@ +takeElementScreenshot :: Session -> ElementId -> HttpSpec Text +takeElementScreenshot sessionId elementId = get "Take Element Screenshot" (elementUri1 sessionId elementId "screenshot") + +-- ############################ Shadow DOM Methods ########################################## + +-- | +-- +-- Return a spec to find an element from the shadow root given a 'Session', 'ElementId', and 'Selector'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#find-element-from-shadow-root) +-- +-- @POST \/session\/{session id}\/shadow\/{shadow id}\/element Find Element From Shadow Root@ +findElementFromShadowRoot :: Session -> ShadowRootElementId -> Selector -> HttpSpec ElementId +findElementFromShadowRoot sessionId shadowId = post "Find Element From Shadow Root" (sessionUri3 sessionId "shadow" shadowId.id "element") + +-- | +-- +-- Return a spec to find elements from the shadow root given a 'Session', 'ElementId', and 'Selector'. +-- +-- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20251028/#find-elements-from-shadow-root) +-- +-- @POST \/session\/{session id}\/shadow\/{shadow id}\/elements Find Elements From Shadow Root@ +findElementsFromShadowRoot :: Session -> ShadowRootElementId -> Selector -> HttpSpec [ElementId] +findElementsFromShadowRoot sessionId shadowId = post "Find Elements From Shadow Root" (sessionUri3 sessionId "shadow" shadowId.id "elements") + +-- ############################ Utils ########################################## + +sessionUri :: Text -> UrlPath +sessionUri sp = MkUrlPath [session, sp] + +sessionUri1 :: Session -> Text -> UrlPath +sessionUri1 s sp = MkUrlPath [session, s.id, sp] + +sessionUri2 :: Session -> Text -> Text -> UrlPath +sessionUri2 s sp sp2 = MkUrlPath [session, s.id, sp, sp2] + +sessionUri3 :: Session -> Text -> Text -> Text -> UrlPath +sessionUri3 s sp sp2 sp3 = MkUrlPath [session, s.id, sp, sp2, sp3] + +sessionUri4 :: Session -> Text -> Text -> Text -> Text -> UrlPath +sessionUri4 s sp sp2 sp3 sp4 = MkUrlPath [session, s.id, sp, sp2, sp3, sp4] + +window :: Text +window = "window" + +windowUri1 :: Session -> Text -> UrlPath +windowUri1 sr sp = sessionUri2 sr window sp + +elementUri1 :: Session -> ElementId -> Text -> UrlPath +elementUri1 s er ep = sessionUri3 s "element" er.id ep + +elementUri2 :: Session -> ElementId -> Text -> Text -> UrlPath +elementUri2 s er ep ep2 = sessionUri4 s "element" er.id ep ep2 + +newSessionUrl :: UrlPath +newSessionUrl = MkUrlPath [session] + +session :: Text +session = "session" diff --git a/src/WebDriverPreCore/Http.hs b/src/WebDriverPreCore/Http.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/Http.hs @@ -0,0 +1,155 @@ +{-| +Description : Deprecated in favour of "WebDriverPreCore.HTTP.Protocol" + +-} + + +module WebDriverPreCore.Http {-# DEPRECATED "WebDriverPreCore.Http - will be removed in a future release ~ 2027-02-01 (USE WebDriverPreCore.HTTP.Protocol instead). See ChangeLog.md for upgrade instructions" #-} + ( + -- ** The HttpSpec Type + module WC3Spec, + + -- ** Root Methods + module RootMethods, + + -- ** Session Methods + -- | /See also 'newSession' and 'newSession''/ + module SessionMethods, + + -- ** Window Methods + module WindowMethods, + + -- ** Frame Methods + module FrameMethods, + + -- ** Element(s) Methods + module ElementMethods, + + -- ** Element Instance Methods + module ElementInstanceMethods, + + -- ** Shadow DOM Methods + module ShadowDOMMethods, + + -- * HTTP Response + module WebDriverPreCore.HTTP.HttpResponse, + + -- * Capabilities + module CoreCapabilities, + + -- * Errors + module WebDriverPreCore.Error, + + -- * Action Types + -- module ActionTypes, + + -- * Auxiliary Spec Types + -- module AuxTypes, + ) +where +import WebDriverPreCore.HTTP.SpecDefinition as WC3Spec (HttpSpec (..)) +import WebDriverPreCore.HTTP.SpecDefinition as RootMethods (newSession, newSession', status) +import WebDriverPreCore.HTTP.SpecDefinition as SessionMethods + ( acceptAlert, + addCookie, + back, + closeWindow, + deleteAllCookies, + deleteCookie, + deleteSession, + dismissAlert, + executeScript, + executeScriptAsync, + forward, + fullscreenWindow, + getAlertText, + getAllCookies, + getCurrentUrl, + getNamedCookie, + getPageSource, + getTimeouts, + getTitle, + getWindowHandle, + getWindowHandles, + getWindowRect, + maximizeWindow, + minimizeWindow, + navigateTo, + newWindow, + performActions, + printPage, + refresh, + releaseActions, + sendAlertText, + setTimeouts, + setWindowRect, + switchToFrame, + switchToWindow, + takeScreenshot, + ) +import WebDriverPreCore.HTTP.SpecDefinition as WindowMethods + ( closeWindow, + fullscreenWindow, + getWindowHandles, + getWindowRect, + maximizeWindow, + minimizeWindow, + newWindow, + setWindowRect, + switchToWindow, + ) +import WebDriverPreCore.HTTP.SpecDefinition as FrameMethods (switchToParentFrame) +import WebDriverPreCore.HTTP.SpecDefinition as ElementMethods + ( findElement, + findElements, + getActiveElement, + ) +import WebDriverPreCore.HTTP.SpecDefinition as ElementInstanceMethods + ( elementClear, + elementClick, + elementSendKeys, + findElementFromElement, + findElementsFromElement, + getElementAttribute, + getElementComputedLabel, + getElementComputedRole, + getElementCssValue, + getElementProperty, + getElementRect, + getElementShadowRoot, + getElementTagName, + getElementText, + isElementEnabled, + isElementSelected, + takeElementScreenshot, + ) +import WebDriverPreCore.HTTP.SpecDefinition as ShadowDOMMethods (findElementFromShadowRoot, findElementsFromShadowRoot) +import WebDriverPreCore.HTTP.Protocol as CoreCapabilities (FullCapabilities(..), Capabilities(..) ) +import WebDriverPreCore.HTTP.Protocol +import WebDriverPreCore.Error +import WebDriverPreCore.HTTP.HttpResponse +-- import WebDriverPreCore.HTTP.SpecDefinition as ActionTypes +-- ( Action (..), +-- Actions (..), +-- KeyAction (..), +-- Pointer (..), +-- PointerAction (..), +-- PointerOrigin (..), +-- WheelAction (..), +-- ) +-- import WebDriverPreCore.HTTP.SpecDefinition as AuxTypes +-- ( Cookie (..), +-- DriverStatus (..), +-- ElementId (..), +-- FrameReference (..), +-- HttpResponse (..), +-- SameSite (..), +-- Selector (..), +-- Session (..), +-- SessionResponse (..), +-- Timeouts (..), +-- UrlPath (..), +-- Handle (..), +-- WindowHandleSpec (..), +-- WindowRect (..), +-- ) diff --git a/src/WebDriverPreCore/HttpResponse.hs b/src/WebDriverPreCore/HttpResponse.hs deleted file mode 100644 --- a/src/WebDriverPreCore/HttpResponse.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} - -module WebDriverPreCore.HttpResponse ( - HttpResponse(..) -) where - -import Data.Aeson (Value) -import Data.Text (Text) -import Data.Int (Int) -import GHC.Show (Show) -import Data.Eq (Eq) -import Data.Ord (Ord) - --- | 'HttpResponse' represents a WebDriver HTTP response. --- --- An instance of 'HttpResponse' needs to be constructed in order to run the 'WebDriverPreCore.parser' suppplied in the [W3CSpec](WebDriverPreCore.Get) -data HttpResponse = MkHttpResponse - { -- | HTTP status code. - statusCode :: Int, - -- | HTTP status message. - statusMessage :: Text, - -- | Response body in JSON format. - body :: Value - } - deriving (Show, Eq, Ord) diff --git a/src/WebDriverPreCore/Internal/HTTPBidiCommon.hs b/src/WebDriverPreCore/Internal/HTTPBidiCommon.hs new file mode 100644 --- /dev/null +++ b/src/WebDriverPreCore/Internal/HTTPBidiCommon.hs @@ -0,0 +1,30 @@ +module WebDriverPreCore.Internal.HTTPBidiCommon + ( URL (..), + JSUInt (..), + ) +where + +import Data.Aeson as A + ( FromJSON (..), + ToJSON, + Value (..), + (.:), + ) +import Data.Aeson.Types (Parser) +import Data.Text (Text, unpack) +import Data.Word (Word64) +import Utils (txt) + +newtype JSUInt = MkJSUInt Word64 deriving newtype (Show, Eq, Enum, FromJSON, ToJSON) -- JSUnit :: 0..9007199254740991 - Word64 :: 18446744073709551615 + +newtype URL = MkUrl {url :: Text} + deriving newtype (Show, Eq, Ord, ToJSON) + +instance FromJSON URL where + parseJSON :: Value -> Parser URL + parseJSON = \case + String t -> pure $ MkUrl t + Object o -> do + url <- o .: "url" + pure $ MkUrl url + v -> fail $ unpack $ "Expected URL as String or Object with url property, got: " <> txt v diff --git a/src/WebDriverPreCore/Internal/Utils.hs b/src/WebDriverPreCore/Internal/Utils.hs deleted file mode 100644 --- a/src/WebDriverPreCore/Internal/Utils.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} - -module WebDriverPreCore.Internal.Utils - ( opt, - txt, - enumerate, - -- Aeson utils - jsonToText, - lsbToText, - prettyPrintJson, - parseJson - ) -where - -import Data.Aeson - ( Key, - KeyValue ((.=)), - ToJSON (), - Value (..), eitherDecodeStrict, - ) -import Data.Function ((.), ($)) -import Data.Functor (Functor, (<$>)) -import Data.String (String) -import Data.Text ( Text, pack) -import Data.Text.Encoding (encodeUtf8, decodeUtf8) -import GHC.Show (Show (..)) -import Data.Aeson.Encode.Pretty (encodePretty) -import Data.ByteString.Lazy qualified as LBS -import Data.Text.IO qualified as T -import Control.Exception (try, Exception (displayException), SomeException) -import GHC.Base (IO) -import Data.Either (Either, either) -import System.IO (print) -import GHC.Enum (Enum, Bounded (..)) - - -{- - this module is used between the library and testing modules - it will be removed in a later relaease --} - -txt :: (Show a) => a -> Text -txt = pack . show - - -enumerate :: (Enum a, Bounded a) => [a] -enumerate = [minBound ..] - --- Aeson stuff --- TODO move to separte library - -opt :: (Functor f, KeyValue e b, ToJSON a) => Key -> f a -> f b -opt lbl mb = (lbl .=) <$> mb - --- https://blog.ssanj.net/posts/2019-09-24-pretty-printing-json-in-haskell.html -lsbToText :: LBS.ByteString -> Text -lsbToText = decodeUtf8 . LBS.toStrict - -jsonToText :: Value -> Text -jsonToText = lsbToText . encodePretty - -prettyPrintJson :: Value -> IO () -prettyPrintJson v = do - e <- (try @SomeException @_) $ T.putStrLn (jsonToText v) - either (print . displayException) print e - -parseJson :: Text -> Either String Value -parseJson input = - eitherDecodeStrict (encodeUtf8 input) diff --git a/src/WebDriverPreCore/SpecDefinition.hs b/src/WebDriverPreCore/SpecDefinition.hs deleted file mode 100644 --- a/src/WebDriverPreCore/SpecDefinition.hs +++ /dev/null @@ -1,1551 +0,0 @@ -{-# OPTIONS_HADDOCK hide #-} - --- | --- Description : All Webdriver W3C endpoints --- --- --- Here is a longer description of this module, containing some --- commentary with @some markup@. -module WebDriverPreCore.SpecDefinition - ( -- * The W3Spec Type - W3Spec (..), - - -- * The API - - -- ** Root Methods - newSession, - newSession', - status, - - -- ** Session Methods - deleteSession, - getTimeouts, - setTimeouts, - navigateTo, - getCurrentUrl, - back, - forward, - refresh, - getTitle, - getWindowHandle, - newWindow, - closeWindow, - switchToWindow, - switchToFrame, - getPageSource, - executeScript, - executeScriptAsync, - addCookie, - getAllCookies, - getNamedCookie, - deleteCookie, - deleteAllCookies, - performActions, - releaseActions, - dismissAlert, - acceptAlert, - getAlertText, - sendAlertText, - takeScreenshot, - printPage, - - -- ** Window Methods - getWindowHandles, - getWindowRect, - setWindowRect, - maximizeWindow, - minimizeWindow, - fullscreenWindow, - - -- ** Frame Methods - switchToParentFrame, - - -- ** Element(s) Methods - getActiveElement, - findElement, - findElements, - - -- ** Element Instance Methods - findElementFromElement, - findElementsFromElement, - isElementSelected, - getElementAttribute, - getElementProperty, - getElementCssValue, - getElementShadowRoot, - getElementText, - getElementTagName, - getElementRect, - isElementEnabled, - getElementComputedRole, - getElementComputedLabel, - elementClick, - elementClear, - elementSendKeys, - takeElementScreenshot, - - -- ** Shadow DOM Methods - findElementFromShadowRoot, - findElementsFromShadowRoot, - - -- * auxiliary Types - Cookie (..), - DriverStatus (..), - ElementId (..), - FrameReference (..), - HandleType (..), - HttpResponse (..), - SameSite (..), - Selector (..), - SessionId (..), - Timeouts (..), - WindowHandle (..), - WindowHandleSpec (..), - WindowRect (..), - UrlPath (..), - - -- ** Action Types - Action (..), - Actions (..), - KeyAction (..), - Pointer (..), - PointerAction (..), - PointerOrigin (..), - WheelAction (..), - ) -where - -import Data.Aeson as A - ( FromJSON (..), - Key, - KeyValue ((.=)), - Result (..), - ToJSON (toJSON), - Value (..), - fromJSON, - object, - withObject, - withText, - (.:), - ) -import Data.Aeson.KeyMap qualified as AKM -import Data.Aeson.Types (Parser) -import Data.Foldable (toList) -import Data.Function ((&)) -import Data.Maybe (catMaybes) -import Data.Set (Set) -import Data.Text (Text, pack, unpack) -import Data.Text qualified as T -import Data.Word (Word16) -import GHC.Generics (Generic) -import WebDriverPreCore.Internal.Utils (jsonToText, opt, txt) -import WebDriverPreCore.Capabilities as Capabilities -import WebDriverPreCore.HttpResponse (HttpResponse (..)) -import Prelude hiding (id, lookup) - --- | Url as returned by 'W3Spec' --- The 'UrlPath' type is a newtype wrapper around a list of 'Text' segments representing a path. --- --- e.g. the path: @\/session\/session-no-1-2-3\/window@ would be represented as: @MkUrlPath ["session", "session-no-1-2-3", "window"]@ -newtype UrlPath = MkUrlPath {segments :: [Text]} - deriving newtype (Show, Eq, Ord, Semigroup) - -{-| - The 'W3Spec' type is a specification for a WebDriver command. - Every endpoint function in this module returns a 'W3Spec' object. --} -data W3Spec a - = Get - { description :: Text, - path :: UrlPath, - parser :: HttpResponse -> Result a - } - | Post - { description :: Text, - path :: UrlPath, - body :: Value, - parser :: HttpResponse -> Result a - } - | PostEmpty - { description :: Text, - path :: UrlPath, - parser :: HttpResponse -> Result a - } - | Delete - { description :: Text, - path :: UrlPath, - parser :: HttpResponse -> Result a - } - -instance (Show a) => Show (W3Spec a) where - show :: W3Spec a -> String - show = Prelude.show . mkShowable - -data W3SpecShowable = Request - { description :: Text, - method :: Text, - path :: UrlPath, - body :: Maybe Text - } - deriving (Show) - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#dfn-get-window-handle) -newtype WindowHandle = Handle {handle :: Text} - deriving (Show, Eq) - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#new-window) -data WindowHandleSpec = HandleSpec - { handle :: WindowHandle, - handletype :: HandleType - } - deriving (Show, Eq) - -instance ToJSON WindowHandleSpec where - toJSON :: WindowHandleSpec -> Value - toJSON HandleSpec {handle, handletype} = - object - [ "handle" .= handle.handle, - "type" .= handletype - ] - -instance FromJSON WindowHandleSpec where - parseJSON :: Value -> Parser WindowHandleSpec - parseJSON = withObject "WindowHandleSpec" $ \v -> do - handle <- Handle <$> v .: "handle" - handletype <- v .: "type" - pure $ HandleSpec {..} - -data HandleType - = Window - | Tab - deriving (Show, Eq) - -instance ToJSON HandleType where - toJSON :: HandleType -> Value - toJSON = String . T.toLower . pack . show - -instance FromJSON HandleType where - parseJSON :: Value -> Parser HandleType - parseJSON = withText "HandleType" $ \case - "window" -> pure Window - "tab" -> pure Tab - v -> fail $ unpack $ "Unknown HandleType " <> v - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#dfn-find-element) -newtype ElementId = Element {id :: Text} - deriving (Show, Eq, Generic) - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#dfn-new-sessions) -newtype SessionId = Session {id :: Text} - deriving (Show) - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#dfn-status) -data DriverStatus - = Ready - | Running - | ServiceError {statusCode :: Int, statusMessage :: Text} - | Unknown {statusCode :: Int, statusMessage :: Text} - deriving (Show, Eq) - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#cookies) -data SameSite - = Lax - | Strict - | None - deriving (Show, Eq, Ord) - -instance ToJSON SameSite where - toJSON :: SameSite -> Value - toJSON = String . txt - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#dfn-switch-to-frame) -data FrameReference - = TopLevelFrame - | FrameNumber Word16 - | FrameElementId ElementId - deriving (Show, Eq) - -frameJson :: FrameReference -> Value -frameJson fr = - object - ["id" .= toJSON (frameVariant fr)] - where - frameVariant = - \case - TopLevelFrame -> Null - FrameNumber n -> Number $ fromIntegral n - FrameElementId elm -> object [elementFieldName .= elm.id] - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#cookies) -data Cookie = MkCookie - { name :: Text, - value :: Text, - -- optional - path :: Maybe Text, - domain :: Maybe Text, - secure :: Maybe Bool, - httpOnly :: Maybe Bool, - sameSite :: Maybe SameSite, - -- When the cookie expires, specified in seconds since Unix Epoch. - expiry :: Maybe Int - } - deriving (Show, Eq) - -instance ToJSON Cookie where - toJSON :: Cookie -> Value - toJSON MkCookie {name, value, path, domain, secure, httpOnly, sameSite, expiry} = - object $ - [ "name" .= name, - "value" .= value - ] - <> catMaybes - [ opt "path" path, - opt "domain" domain, - opt "secure" secure, - opt "httpOnly" httpOnly, - opt "sameSite" sameSite, - opt "expiry" expiry - ] - -cookieJSON :: Cookie -> Value -cookieJSON c = object ["cookie" .= c] - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#locator-strategies) -data Selector - = CSS Text - | XPath Text - | LinkText Text - | PartialLinkText Text - | TagName Text - deriving (Show, Eq) - --- ###################################################################### --- ########################### WebDriver API ############################ --- ###################################################################### - --- https://www.w3.org/TR/2025/WD-webdriver2-20250306/ --- 61 endpoints --- Method URI Template Command - --- ** Root Methods - --- | --- Return a spec to create a new session given 'FullCapabilities' object. --- --- 'newSession'' can be used if 'FullCapabilities' doesn't meet your requirements. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#new-session) --- --- @POST \/session New Session@ -newSession :: FullCapabilities -> W3Spec SessionId -newSession = newSession' - --- | --- --- Return a spec to create a new session given an object of any type that implements `ToJSON`. --- --- The 'FullCapabilities' type and associated types should work for the vast majority use cases, but if the required capabilities are not covered by the types provided, 'newSession''. --- can be used with a custom type instead. 'newSession'' works with any type that implements 'ToJSON', (including an Aeson 'Value'). --- --- Obviously, any type used must produce a JSON object compatible with [capabilities as defined W3C spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#capabilities). --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#new-session) --- --- @POST \/session New Session@ -newSession' :: (ToJSON a) => a -> W3Spec SessionId -newSession' capabilities = Post "New Session" (MkUrlPath [session]) (toJSON capabilities) parseSessionRef - --- | --- --- Return a spec to get the status of the driver. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#status) --- --- @GET \/status Status@ -status :: W3Spec DriverStatus -status = Get "Status" (MkUrlPath ["status"]) parseDriverStatus - --- ############################ Session Methods ########################################## - --- | --- --- Return a spec to delete a session given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#delete-session) --- --- @DELETE \/session\/{session id} Delete Session@ -deleteSession :: SessionId -> W3Spec () -deleteSession sessionRef = Delete "Delete Session" (sessionUri sessionRef.id) voidParser - --- | --- --- Return a spec to get the timeouts of a session given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-timeouts) --- --- @GET \/session\/{session id}\/timeouts Get Timeouts@ -getTimeouts :: SessionId -> W3Spec Timeouts -getTimeouts sessionRef = Get "Get Timeouts" (sessionUri1 sessionRef "timeouts") parseTimeouts - --- | --- --- Return a spec to set the timeouts of a session given a 'SessionId' and 'Timeouts'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#set-timeouts) --- --- @POST \/session\/{session id}\/timeouts Set Timeouts@ -setTimeouts :: SessionId -> Timeouts -> W3Spec () -setTimeouts sessionRef timeouts = - Post "Set Timeouts" (sessionUri1 sessionRef "timeouts") (toJSON timeouts) voidParser - --- | --- --- Return a spec to navigate to a URL given a 'SessionId' and a 'Text' URL. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#navigate-to) --- --- @POST \/session\/{session id}\/url Navigate To@ -navigateTo :: SessionId -> Text -> W3Spec () -navigateTo sessionRef url = Post "Navigate To" (sessionUri1 sessionRef "url") (object ["url" .= url]) voidParser - --- | --- --- Return a spec to get the current URL of a session given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-current-url) --- --- @GET \/session\/{session id}\/url Get Current URL@ -getCurrentUrl :: SessionId -> W3Spec Text -getCurrentUrl sessionRef = Get "Get Current URL" (sessionUri1 sessionRef "url") parseBodyTxt - --- | --- --- Return a spec to navigate back in the browser history given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#back) --- --- @POST \/session\/{session id}\/back Back@ -back :: SessionId -> W3Spec () -back sessionRef = PostEmpty "Back" (sessionUri1 sessionRef "back") voidParser - --- | --- --- Return a spec to navigate forward in the browser history given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#forward) --- --- @POST \/session\/{session id}\/forward Forward@ -forward :: SessionId -> W3Spec () -forward sessionRef = PostEmpty "Forward" (sessionUri1 sessionRef "forward") voidParser - --- | --- --- Return a spec to refresh the current page given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#refresh) --- --- @POST \/session\/{session id}\/refresh Refresh@ -refresh :: SessionId -> W3Spec () -refresh sessionRef = PostEmpty "Refresh" (sessionUri1 sessionRef "refresh") voidParser - --- | --- --- Return a spec to get the title of the current page given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-title) --- --- @GET \/session\/{session id}\/title Get Title@ -getTitle :: SessionId -> W3Spec Text -getTitle sessionRef = Get "Get Title" (sessionUri1 sessionRef "title") parseBodyTxt - --- | --- --- Return a spec to get the current window handle given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-window-handle) --- --- @GET \/session\/{session id}\/window Get Window Handle@ -getWindowHandle :: SessionId -> W3Spec WindowHandle -getWindowHandle sessionRef = Get "Get Window Handle" (sessionUri1 sessionRef "window") (fmap Handle . parseBodyTxt) - --- | --- --- Return a spec to create a new window given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#new-window) --- --- @POST \/session\/{session id}\/window\/new New Window@ -newWindow :: SessionId -> W3Spec WindowHandleSpec -newWindow sessionRef = PostEmpty "New Window" (sessionUri2 sessionRef "window" "new") windowHandleParser - --- | --- --- Return a spec to close the current window given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#close-window) --- --- @DELETE \/session\/{session id}\/window Close Window@ -closeWindow :: SessionId -> W3Spec () -closeWindow sessionRef = Delete "Close Window" (sessionUri1 sessionRef "window") voidParser - --- | --- --- Return a spec to switch to a different window given a 'SessionId' and 'WindowHandle'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#switch-to-window) --- --- @POST \/session\/{session id}\/window Switch To Window@ -switchToWindow :: SessionId -> WindowHandle -> W3Spec () -switchToWindow sessionRef Handle {handle} = Post "Switch To Window" (sessionUri1 sessionRef "window") (object ["handle" .= handle]) voidParser - --- | --- --- Return a spec to switch to a different frame given a 'SessionId' and 'FrameReference'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#switch-to-frame) --- --- @POST \/session\/{session id}\/frame Switch To Frame@ -switchToFrame :: SessionId -> FrameReference -> W3Spec () -switchToFrame sessionRef frameRef = Post "Switch To Frame" (sessionUri1 sessionRef "frame") (frameJson frameRef) voidParser - --- | --- --- Return a spec to get the source of the current page given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-page-source) --- --- @GET \/session\/{session id}\/source Get Page Source@ -getPageSource :: SessionId -> W3Spec Text -getPageSource sessionId = Get "Get Page Source" (sessionUri1 sessionId "source") parseBodyTxt - --- | --- --- Return a spec to execute a script in the context of the current page given a 'SessionId', 'Text' script, and a list of 'Value' arguments. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#execute-script) --- --- @POST \/session\/{session id}\/execute\/sync Execute Script@ -executeScript :: SessionId -> Text -> [Value] -> W3Spec Value -executeScript sessionId script args = Post "Execute Script" (sessionUri2 sessionId "execute" "sync") (mkScript script args) bodyValue - --- | --- --- Return a spec to execute an asynchronous script in the context of the current page given a 'SessionId', 'Text' script, and a list of 'Value' arguments. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#execute-async-script) --- --- @POST \/session\/{session id}\/execute\/async Execute Async Script@ -executeScriptAsync :: SessionId -> Text -> [Value] -> W3Spec Value -executeScriptAsync sessionId script args = Post "Execute Async Script" (sessionUri2 sessionId "execute" "async") (mkScript script args) bodyValue - --- | --- --- Return a spec to get all cookies of the current page given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-all-cookies) --- --- @GET \/session\/{session id}\/cookie Get All Cookies@ -getAllCookies :: SessionId -> W3Spec [Cookie] -getAllCookies sessionId = Get "Get All Cookies" (sessionUri1 sessionId "cookie") parseCookies - --- | --- --- Return a spec to get a named cookie of the current page given a 'SessionId' and cookie name. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-named-cookie) --- --- @GET \/session\/{session id}\/cookie\/{name} Get Named Cookie@ -getNamedCookie :: SessionId -> Text -> W3Spec Cookie -getNamedCookie sessionId cookieName = Get "Get Named Cookie" (sessionUri2 sessionId "cookie" cookieName) parseCookie - --- | --- --- Return a spec to add a cookie to the current page given a 'SessionId' and 'Cookie'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#add-cookie) --- --- @POST \/session\/{session id}\/cookie Add Cookie@ -addCookie :: SessionId -> Cookie -> W3Spec () -addCookie sessionId cookie = Post "Add Cookie" (sessionUri1 sessionId "cookie") (cookieJSON cookie) voidParser - --- | --- --- Return a spec to delete a named cookie from the current page given a 'SessionId' and cookie name. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#delete-cookie) --- --- @DELETE \/session\/{session id}\/cookie\/{name} Delete Cookie@ -deleteCookie :: SessionId -> Text -> W3Spec () -deleteCookie sessionId cookieName = Delete "Delete Cookie" (sessionUri2 sessionId "cookie" cookieName) voidParser - --- | --- --- Return a spec to delete all cookies from the current page given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#delete-all-cookies) --- --- @DELETE \/session\/{session id}\/cookie Delete All Cookies@ -deleteAllCookies :: SessionId -> W3Spec () -deleteAllCookies sessionId = Delete "Delete All Cookies" (sessionUri1 sessionId "cookie") voidParser - --- | --- --- Return a spec to perform actions on the current page given a 'SessionId' and 'Actions'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#perform-actions) --- --- @POST \/session\/{session id}\/actions Perform Actions@ -performActions :: SessionId -> Actions -> W3Spec () -performActions sessionId actions = Post "Perform Actions" (sessionUri1 sessionId "actions") (actionsToJson actions) voidParser - --- | --- --- Return a spec to release actions on the current page given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#release-actions) --- --- @DELETE \/session\/{session id}\/actions Release Actions@ -releaseActions :: SessionId -> W3Spec () -releaseActions sessionId = Delete "Release Actions" (sessionUri1 sessionId "actions") voidParser - --- | --- --- Return a spec to dismiss an alert on the current page given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#dismiss-alert) --- --- @POST \/session\/{session id}\/alert\/dismiss Dismiss Alert@ -dismissAlert :: SessionId -> W3Spec () -dismissAlert sessionId = PostEmpty "Dismiss Alert" (sessionUri2 sessionId "alert" "dismiss") voidParser - --- | --- --- Return a spec to accept an alert on the current page given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#accept-alert) --- --- @POST \/session\/{session id}\/alert\/accept Accept Alert@ -acceptAlert :: SessionId -> W3Spec () -acceptAlert sessionId = PostEmpty "Accept Alert" (sessionUri2 sessionId "alert" "accept") voidParser - --- | --- --- Return a spec to get the text of an alert on the current page given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-alert-text) --- --- @GET \/session\/{session id}\/alert\/text Get Alert Text@ -getAlertText :: SessionId -> W3Spec Text -getAlertText sessionId = Get "Get Alert Text" (sessionUri2 sessionId "alert" "text") parseBodyTxt - --- | --- --- Return a spec to send text to an alert on the current page given a 'SessionId' and 'Text'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#send-alert-text) --- --- @POST \/session\/{session id}\/alert\/text Send Alert Text@ -sendAlertText :: SessionId -> Text -> W3Spec () -sendAlertText sessionId text = Post "Send Alert Text" (sessionUri2 sessionId "alert" "text") (object ["text" .= text]) voidParser - --- | --- --- Return a spec to take a screenshot of the current page given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#take-screenshot) --- --- @GET \/session\/{session id}\/screenshot Take Screenshot@ -takeScreenshot :: SessionId -> W3Spec Text -takeScreenshot sessionId = Get "Take Screenshot" (sessionUri1 sessionId "screenshot") parseBodyTxt - --- | --- --- Return a spec to print the current page given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#print-page) --- --- @POST \/session\/{session id}\/print Print Page@ -printPage :: SessionId -> W3Spec Text -printPage sessionId = PostEmpty "Print Page" (sessionUri1 sessionId "print") parseBodyTxt - --- ############################ Window Methods ########################################## - --- | --- --- Return a spec to get all window handles of the current session given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-window-handles) --- --- @GET \/session\/{session id}\/window\/handles Get Window Handles@ -getWindowHandles :: SessionId -> W3Spec [WindowHandle] -getWindowHandles sessionRef = Get "Get Window Handles" (sessionUri2 sessionRef "window" "handles") windowHandlesParser - --- | --- --- Return a spec to get the window rect of the current window given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-window-rect) --- --- @GET \/session\/{session id}\/window\/rect Get Window Rect@ -getWindowRect :: SessionId -> W3Spec WindowRect -getWindowRect sessionRef = Get "Get Window Rect" (sessionUri2 sessionRef "window" "rect") parseWindowRect - --- | --- --- Return a spec to set the window rect of the current window given a 'SessionId' and 'WindowRect'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#set-window-rect) --- --- @POST \/session\/{session id}\/window\/rect Set Window Rect@ -setWindowRect :: SessionId -> WindowRect -> W3Spec WindowRect -setWindowRect sessionRef rect = Post "Set Window Rect" (sessionUri2 sessionRef "window" "rect") (toJSON rect) parseWindowRect - --- | --- --- Return a spec to maximize the current window given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#maximize-window) --- --- @POST \/session\/{session id}\/window\/maximize Maximize Window@ -maximizeWindow :: SessionId -> W3Spec WindowRect -maximizeWindow sessionRef = PostEmpty "Maximize Window" (windowUri1 sessionRef "maximize") parseWindowRect - --- | --- --- Return a spec to minimize the current window given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#minimize-window) --- --- @POST \/session\/{session id}\/window\/minimize Minimize Window@ -minimizeWindow :: SessionId -> W3Spec WindowRect -minimizeWindow sessionRef = PostEmpty "Minimize Window" (windowUri1 sessionRef "minimize") parseWindowRect - --- | --- --- Return a spec to fullscreen the current window given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#fullscreen-window) --- --- @POST \/session\/{session id}\/window\/fullscreen Fullscreen Window@ -fullscreenWindow :: SessionId -> W3Spec WindowRect -fullscreenWindow sessionRef = PostEmpty "Fullscreen Window" (windowUri1 sessionRef "fullscreen") parseWindowRect - --- ############################ Frame Methods ########################################## - --- | --- --- Return a spec to switch to the parent frame given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#switch-to-parent-frame) --- --- @POST \/session\/{session id}\/frame\/parent Switch To Parent Frame@ -switchToParentFrame :: SessionId -> W3Spec () -switchToParentFrame sessionRef = PostEmpty "Switch To Parent Frame" (sessionUri2 sessionRef "frame" "parent") voidParser - --- ############################ Element(s) Methods ########################################## - --- | --- --- Return a spec to get the active element of the current page given a 'SessionId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-active-element) --- --- @GET \/session\/{session id}\/element\/active Get Active Element@ -getActiveElement :: SessionId -> W3Spec ElementId -getActiveElement sessionId = Get "Get Active Element" (sessionUri2 sessionId "element" "active") parseElementRef - --- | --- --- Return a spec to find an element on the current page given a 'SessionId' and 'Selector'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#find-element) --- --- @POST \/session\/{session id}\/element Find Element@ -findElement :: SessionId -> Selector -> W3Spec ElementId -findElement sessionRef = findElement' sessionRef . selectorJson - --- | --- --- Return a spec to find elements on the current page given a 'SessionId' and 'Selector'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#find-elements) --- --- @POST \/session\/{session id}\/elements Find Elements@ -findElements :: SessionId -> Selector -> W3Spec [ElementId] -findElements sessionRef selector = Post "Find Elements" (sessionUri1 sessionRef "elements") (selectorJson selector) parseElementsRef - --- ############################ Element Instance Methods ########################################## - --- | --- --- Return a spec to get the shadow root of an element given a 'SessionId' and 'ElementId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-element-shadow-root) --- --- @GET \/session\/{session id}\/element\/{element id}\/shadow Get Element Shadow Root@ -getElementShadowRoot :: SessionId -> ElementId -> W3Spec ElementId -getElementShadowRoot sessionId elementId = Get "Get Element Shadow Root" (elementUri1 sessionId elementId "shadow") parseShadowElementRef - --- | --- --- Return a spec to find an element from another element given a 'SessionId', 'ElementId', and 'Selector'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#find-element-from-element) --- --- @POST \/session\/{session id}\/element\/{element id}\/element Find Element From Element@ -findElementFromElement :: SessionId -> ElementId -> Selector -> W3Spec ElementId -findElementFromElement sessionId elementId selector = Post "Find Element From Element" (elementUri1 sessionId elementId "element") (selectorJson selector) parseElementRef - --- | --- --- Return a spec to find elements from another element given a 'SessionId', 'ElementId', and 'Selector'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#find-elements-from-element) --- --- @POST \/session\/{session id}\/element\/{element id}\/elements Find Elements From Element@ -findElementsFromElement :: SessionId -> ElementId -> Selector -> W3Spec [ElementId] -findElementsFromElement sessionId elementId selector = Post "Find Elements From Element" (elementUri1 sessionId elementId "elements") (selectorJson selector) parseElementsRef - --- | --- --- Return a spec to check if an element is selected given a 'SessionId' and 'ElementId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#is-element-selected) --- --- @GET \/session\/{session id}\/element\/{element id}\/selected Is Element Selected@ -isElementSelected :: SessionId -> ElementId -> W3Spec Bool -isElementSelected sessionId elementId = Get "Is Element Selected" (elementUri1 sessionId elementId "selected") parseBodyBool - --- | --- --- Return a spec to get an attribute of an element given a 'SessionId', 'ElementId', and attribute name. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-element-attribute) --- --- @GET \/session\/{session id}\/element\/{element id}\/attribute\/{name} Get Element Attribute@ -getElementAttribute :: SessionId -> ElementId -> Text -> W3Spec Text -getElementAttribute sessionId elementId attributeName = Get "Get Element Attribute" (elementUri2 sessionId elementId "attribute" attributeName) parseBodyTxt - --- | --- --- Return a spec to get a property of an element given a 'SessionId', 'ElementId', and property name. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-element-property) --- --- @GET \/session\/{session id}\/element\/{element id}\/property\/{name} Get Element Property@ -getElementProperty :: SessionId -> ElementId -> Text -> W3Spec Value -getElementProperty sessionId elementId propertyName = Get "Get Element Property" (elementUri2 sessionId elementId "property" propertyName) bodyValue - --- | --- --- Return a spec to get the CSS value of an element given a 'SessionId', 'ElementId', and CSS property name. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-element-css-value) --- --- @GET \/session\/{session id}\/element\/{element id}\/css\/{property name} Get Element CSS Value@ -getElementCssValue :: SessionId -> ElementId -> Text -> W3Spec Text -getElementCssValue sessionId elementId propertyName = Get "Get Element CSS Value" (elementUri2 sessionId elementId "css" propertyName) parseBodyTxt - --- | --- --- Return a spec to get the text of an element given a 'SessionId' and 'ElementId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-element-text) --- --- @GET \/session\/{session id}\/element\/{element id}\/text Get Element Text@ -getElementText :: SessionId -> ElementId -> W3Spec Text -getElementText sessionId elementId = Get "Get Element Text" (elementUri1 sessionId elementId "text") parseBodyTxt - --- | --- --- Return a spec to get the tag name of an element given a 'SessionId' and 'ElementId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-element-tag-name) --- --- @GET \/session\/{session id}\/element\/{element id}\/name Get Element Tag Name@ -getElementTagName :: SessionId -> ElementId -> W3Spec Text -getElementTagName sessionId elementId = Get "Get Element Tag Name" (elementUri1 sessionId elementId "name") parseBodyTxt - --- | --- --- Return a spec to get the rect of an element given a 'SessionId' and 'ElementId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-element-rect) --- --- @GET \/session\/{session id}\/element\/{element id}\/rect Get Element Rect@ -getElementRect :: SessionId -> ElementId -> W3Spec WindowRect -getElementRect sessionId elementId = Get "Get Element Rect" (elementUri1 sessionId elementId "rect") parseWindowRect - --- | --- --- Return a spec to check if an element is enabled given a 'SessionId' and 'ElementId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#is-element-enabled) --- --- @GET \/session\/{session id}\/element\/{element id}\/enabled Is Element Enabled@ -isElementEnabled :: SessionId -> ElementId -> W3Spec Bool -isElementEnabled sessionId elementId = Get "Is Element Enabled" (elementUri1 sessionId elementId "enabled") parseBodyBool - --- | --- --- Return a spec to get the computed role of an element given a 'SessionId' and 'ElementId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-computed-role) --- --- @GET \/session\/{session id}\/element\/{element id}\/computedrole Get Computed Role@ -getElementComputedRole :: SessionId -> ElementId -> W3Spec Text -getElementComputedRole sessionId elementId = Get "Get Computed Role" (elementUri1 sessionId elementId "computedrole") parseBodyTxt - --- | --- --- Return a spec to get the computed label of an element given a 'SessionId' and 'ElementId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#get-computed-label) --- --- @GET \/session\/{session id}\/element\/{element id}\/computedlabel Get Computed Label@ -getElementComputedLabel :: SessionId -> ElementId -> W3Spec Text -getElementComputedLabel sessionId elementId = Get "Get Computed Label" (elementUri1 sessionId elementId "computedlabel") parseBodyTxt - --- | --- --- Return a spec to click an element given a 'SessionId' and 'ElementId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#element-click) --- --- @POST \/session\/{session id}\/element\/{element id}\/click Element Click@ -elementClick :: SessionId -> ElementId -> W3Spec () -elementClick sessionId elementId = PostEmpty "Element Click" (elementUri1 sessionId elementId "click") voidParser - --- | --- --- Return a spec to clear an element given a 'SessionId' and 'ElementId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#element-clear) --- --- @POST \/session\/{session id}\/element\/{element id}\/clear Element Clear@ -elementClear :: SessionId -> ElementId -> W3Spec () -elementClear sessionId elementId = PostEmpty "Element Clear" (elementUri1 sessionId elementId "clear") voidParser - --- | --- --- Return a spec to send keys to an element given a 'SessionId', 'ElementId', and keys to send. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#element-send-keys) --- --- @POST \/session\/{session id}\/element\/{element id}\/value Element Send Keys@ -elementSendKeys :: SessionId -> ElementId -> Text -> W3Spec () -elementSendKeys sessionId elementId keysToSend = Post "Element Send Keys" (elementUri1 sessionId elementId "value") (keysJson keysToSend) voidParser - --- | --- --- Return a spec to take a screenshot of an element given a 'SessionId' and 'ElementId'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#take-element-screenshot) --- --- @GET \/session\/{session id}\/element\/{element id}\/screenshot Take Element Screenshot@ -takeElementScreenshot :: SessionId -> ElementId -> W3Spec Text -takeElementScreenshot sessionId elementId = Get "Take Element Screenshot" (elementUri1 sessionId elementId "screenshot") parseBodyTxt - --- ############################ Shadow DOM Methods ########################################## - --- | --- --- Return a spec to find an element from the shadow root given a 'SessionId', 'ElementId', and 'Selector'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#find-element-from-shadow-root) --- --- @POST \/session\/{session id}\/shadow\/{shadow id}\/element Find Element From Shadow Root@ -findElementFromShadowRoot :: SessionId -> ElementId -> Selector -> W3Spec ElementId -findElementFromShadowRoot sessionId shadowId selector = Post "Find Element From Shadow Root" (sessionUri3 sessionId "shadow" shadowId.id "element") (selectorJson selector) parseElementRef - --- | --- --- Return a spec to find elements from the shadow root given a 'SessionId', 'ElementId', and 'Selector'. --- --- [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#find-elements-from-shadow-root) --- --- @POST \/session\/{session id}\/shadow\/{shadow id}\/elements Find Elements From Shadow Root@ -findElementsFromShadowRoot :: SessionId -> ElementId -> Selector -> W3Spec [ElementId] -findElementsFromShadowRoot sessionId shadowId selector = Post "Find Elements From Shadow Root" (sessionUri3 sessionId "shadow" shadowId.id "elements") (selectorJson selector) parseElementsRef - --- ############################ Utils ########################################## - -findElement' :: SessionId -> Value -> W3Spec ElementId -findElement' sessionRef selector = Post "Find Element" (sessionUri1 sessionRef "element") selector parseElementRef - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#dfn-get-element-rect) -data WindowRect = Rect - { x :: Int, - y :: Int, - width :: Int, - height :: Int - } - deriving (Show, Eq) - -instance ToJSON WindowRect where - toJSON :: WindowRect -> Value - toJSON Rect {x, y, width, height} = - object - [ "x" .= x, - "y" .= y, - "width" .= width, - "height" .= height - ] - -parseTimeouts :: HttpResponse -> Result Timeouts -parseTimeouts r = do - r' <- bodyValue r - fromJSON r' - -parseWindowRect :: HttpResponse -> Result WindowRect -parseWindowRect r = - do - x <- bdyInt "x" - y <- bdyInt "y" - width <- bdyInt "width" - height <- bdyInt "height" - pure $ Rect {..} - where - bdyInt = bodyInt r - -mkScript :: Text -> [Value] -> Value -mkScript script args = object ["script" .= script, "args" .= args] - -windowHandleParser :: HttpResponse -> Result WindowHandleSpec -windowHandleParser r = - bodyValue r - >>= fromJSON - -windowHandlesParser :: HttpResponse -> Result [WindowHandle] -windowHandlesParser r = do - bodyValue r - >>= \case - Array a -> (Handle <$>) <$> (sequence . toList $ asText <$> a) - v -> aesonTypeError "Array" v - --- windowHandleFromValue :: Value -> Maybe WindowHandleSpec --- windowHandleFromValue v = --- liftA2 HandleSpec (Handle <$> lookupTxt "handle" v) ( <$> lookupTxt "type" v) - -parseCookies :: HttpResponse -> Result [Cookie] -parseCookies r = - bodyValue r - >>= \case - Array a -> mapM cookieFromBody (toList a) - v -> aesonTypeError "Array" v - -parseCookie :: HttpResponse -> Result Cookie -parseCookie r = - bodyValue r - >>= cookieFromBody - -cookieFromBody :: Value -> Result Cookie -cookieFromBody b = case b of - Object kv -> do - name <- lookupTxt "name" b - value <- lookupTxt "value" b - path <- opt' "path" - domain <- opt' "domain" - secure <- optBool "secure" - httpOnly <- optBool "httpOnly" - sameSite <- optBase toSameSite "sameSite" - expiry <- optInt "expiry" - pure $ MkCookie {..} - where - optBase :: (Value -> Result a) -> Key -> Result (Maybe a) - optBase typeCaster k = AKM.lookup k kv & maybe (Success Nothing) (fmap Just . typeCaster) - opt' = optBase asText - optInt = optBase asInt - optBool = optBase asBool - v -> aesonTypeError "Object" v - -selectorJson :: Selector -> Value -selectorJson = \case - CSS css -> sJSON "css selector" css - XPath xpath -> sJSON "xpath" xpath - LinkText lt -> sJSON "link text" lt - PartialLinkText plt -> sJSON "partial link text" plt - TagName tn -> sJSON "tag name" tn - where - sJSON using value = object ["using" .= using, "value" .= value] - -voidParser :: HttpResponse -> Result () -voidParser _ = pure () - -bodyText' :: Result Value -> Key -> Result Text -bodyText' v k = v >>= lookupTxt k - -bodyText :: HttpResponse -> Key -> Result Text -bodyText r = bodyText' (bodyValue r) - -bodyInt' :: Result Value -> Key -> Result Int -bodyInt' v k = v >>= lookupInt k - -bodyInt :: HttpResponse -> Key -> Result Int -bodyInt r = bodyInt' (bodyValue r) - -parseBodyTxt :: HttpResponse -> Result Text -parseBodyTxt r = bodyValue r >>= asText - -parseBodyBool :: HttpResponse -> Result Bool -parseBodyBool r = - bodyValue r >>= asBool - -asBool :: Value -> Result Bool -asBool = \case - Bool b -> Success b - v -> aesonTypeError "Bool" v - -parseElementsRef :: HttpResponse -> Result [ElementId] -parseElementsRef r = - bodyValue r - >>= \case - Array a -> mapM elemtRefFromBody $ toList a - v -> aesonTypeError "Array" v - --- TODO Aeson helpers separate module -lookup :: Key -> Value -> Result Value -lookup k v = - v & \case - Object o -> AKM.lookup k o & maybe (A.Error ("the key: " <> show k <> "does not exist in the object:\n" <> jsonPrettyString v)) pure - _ -> aesonTypeError "Object" v - -lookupTxt :: Key -> Value -> Result Text -lookupTxt k v = lookup k v >>= asText - -toSameSite :: Value -> Result SameSite -toSameSite = \case - String "Lax" -> Success Lax - String "Strict" -> Success Strict - String "None" -> Success None - v -> aesonTypeError' "SameSite" "Expected one of: Lax, Strict, None" v - -lookupInt :: Key -> Value -> Result Int -lookupInt k v = lookup k v >>= asInt - -aesonTypeErrorMessage :: Text -> Value -> Text -aesonTypeErrorMessage t v = "Expected Json Value to be of type: " <> t <> "\nbut got:\n" <> jsonToText v - -aesonTypeError :: Text -> Value -> Result a -aesonTypeError t v = A.Error . unpack $ aesonTypeErrorMessage t v - -aesonTypeError' :: Text -> Text -> Value -> Result a -aesonTypeError' typ info v = A.Error . unpack $ aesonTypeErrorMessage typ v <> "\n" <> info - -asText :: Value -> Result Text -asText = \case - String t -> Success t - v -> aesonTypeError "Text" v - -asInt :: Value -> Result Int -asInt = \case - Number t -> Success $ floor t - v -> aesonTypeError "Int" v - -parseSessionRef :: HttpResponse -> Result SessionId -parseSessionRef r = - Session - <$> bodyText r "sessionId" - -bodyValue :: HttpResponse -> Result Value -bodyValue r = lookup "value" r.body - --- https://www.w3.org/TR/webdriver2/#elements -elementFieldName :: Key -elementFieldName = "element-6066-11e4-a52e-4f735466cecf" - --- https://www.w3.org/TR/webdriver2/#shadow-root -shadowRootFieldName :: Key -shadowRootFieldName = "shadow-6066-11e4-a52e-4f735466cecf" - -parseElementRef :: HttpResponse -> Result ElementId -parseElementRef r = - Element <$> bodyText r elementFieldName - -parseShadowElementRef :: HttpResponse -> Result ElementId -parseShadowElementRef r = - Element <$> bodyText r shadowRootFieldName - -elemtRefFromBody :: Value -> Result ElementId -elemtRefFromBody b = Element <$> lookupTxt elementFieldName b - -session :: Text -session = "session" - -sessionUri :: Text -> UrlPath -sessionUri sp = MkUrlPath [session, sp] - -sessionUri1 :: SessionId -> Text -> UrlPath -sessionUri1 s sp = MkUrlPath [session, s.id, sp] - -sessionUri2 :: SessionId -> Text -> Text -> UrlPath -sessionUri2 s sp sp2 = MkUrlPath [session, s.id, sp, sp2] - -sessionUri3 :: SessionId -> Text -> Text -> Text -> UrlPath -sessionUri3 s sp sp2 sp3 = MkUrlPath [session, s.id, sp, sp2, sp3] - -sessionUri4 :: SessionId -> Text -> Text -> Text -> Text -> UrlPath -sessionUri4 s sp sp2 sp3 sp4 = MkUrlPath [session, s.id, sp, sp2, sp3, sp4] - -window :: Text -window = "window" - -windowUri1 :: SessionId -> Text -> UrlPath -windowUri1 sr sp = sessionUri2 sr window sp - -elementUri1 :: SessionId -> ElementId -> Text -> UrlPath -elementUri1 s er ep = sessionUri3 s "element" er.id ep - -elementUri2 :: SessionId -> ElementId -> Text -> Text -> UrlPath -elementUri2 s er ep ep2 = sessionUri4 s "element" er.id ep ep2 - -jsonPrettyString :: Value -> String -jsonPrettyString = unpack . jsonToText - -mkShowable :: W3Spec a -> W3SpecShowable -mkShowable = \case - Get d p _ -> Request d "GET" p Nothing - Post d p b _ -> Request d "POST" p (Just $ jsonToText b) - PostEmpty d p _ -> Request d "POST" p Nothing - Delete d p _ -> Request d "DELETE" p Nothing - -parseDriverStatus :: HttpResponse -> Result DriverStatus -parseDriverStatus MkHttpResponse {statusCode, statusMessage} = - Success $ - statusCode & \case - 200 -> Ready - 500 -> ServiceError {statusCode, statusMessage} - 501 -> Running - _ -> Unknown {statusCode, statusMessage} - -keysJson :: Text -> Value -keysJson keysToSend = object ["text" .= keysToSend] - --- actions --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#actions) -newtype Actions = MkActions {actions :: [Action]} - -actionsToJson :: Actions -> Value -actionsToJson MkActions {actions} = - object - [ "actions" .= actions - ] - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#actions) -data KeyAction - = PauseKey {duration :: Maybe Int} -- ms - | KeyDown - { value :: Text - } - | KeyUp - { value :: Text - } - deriving (Show, Eq) - -instance ToJSON KeyAction where - toJSON :: KeyAction -> Value - toJSON PauseKey {duration} = - object $ - [ "type" .= ("pause" :: Text) - ] - <> catMaybes [opt "duration" duration] - toJSON KeyDown {value} = - object - [ "type" .= ("keyDown" :: Text), - "value" .= String value - ] - toJSON KeyUp {value} = - object - [ "type" .= ("keyUp" :: Text), - "value" .= String value - ] - --- Pointer subtypes --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#actions) -data Pointer - = Mouse - | Pen - | Touch - deriving (Show, Eq) - -mkLwrTxt :: (Show a) => a -> Value -mkLwrTxt = String . T.toLower . txt - -instance ToJSON Pointer where - toJSON :: Pointer -> Value - toJSON = mkLwrTxt - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#actions) -data PointerOrigin - = Viewport - | OriginPointer - | OriginElement ElementId - deriving (Show, Eq) - -instance ToJSON PointerOrigin where - toJSON :: PointerOrigin -> Value - toJSON = \case - Viewport -> "viewport" - OriginPointer -> "pointer" - OriginElement (Element id') -> object ["element" .= id'] - - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#actions) -data Action - = NoneAction - { id :: Text, - -- the numeric id of the pointing device. This is a positive integer, with the values 0 and 1 reserved for mouse-type pointers. - noneActions :: [Maybe Int] -- delay - } - | Key - { id :: Text, - keyActions :: [KeyAction] - -- https://github.com/jlipps/simple-wd-spec?tab=readme-ov-file#perform-actions - -- keys codepoint https://www.w3.org/TR/webdriver2/#keyboard-actions - } - | Pointer - { id :: Text, - subType :: Pointer, - -- the numeric id of the pointing device. This is a positive integer, with the values 0 and 1 reserved for mouse-type pointers. - pointerId :: Int, - pressed :: Set Int, -- pressed buttons - x :: Int, -- start x location in viewport coordinates. - y :: Int, -- start y location in viewport coordinates - actions :: [PointerAction] - } - | Wheel - { id :: Text, - wheelActions :: [WheelAction] - } - deriving (Show, Eq) - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#actions) -data WheelAction - = PauseWheel {duration :: Maybe Int} -- ms - | Scroll - { origin :: PointerOrigin, - x :: Int, - y :: Int, - deltaX :: Int, - deltaY :: Int, - duration :: Maybe Int -- ms - } - deriving (Show, Eq) - -instance ToJSON WheelAction where - toJSON :: WheelAction -> Value - toJSON wa = - object $ base <> catMaybes [opt "duration" wa.duration] - where - base = case wa of - PauseWheel _ -> ["type" .= ("pause" :: Text)] - Scroll - { origin, - x, - y, - deltaX, - deltaY - } -> - [ "type" .= ("scroll" :: Text), - "origin" .= origin, - "x" .= x, - "y" .= y, - "deltaX" .= deltaX, - "deltaY" .= deltaY - ] - --- | [spec](https://www.w3.org/TR/2025/WD-webdriver2-20250306/#actions) -data PointerAction - = PausePointer {duration :: Maybe Int} -- ms - | Up - { button :: Int, - width :: Maybe Int, - height :: Maybe Int, - pressure :: Maybe Float, -- 0 -> 1 - tangentialPressure :: Maybe Float, -- -1 -> 1 - tiltX :: Maybe Int, -- -90 -> 90 - tiltY :: Maybe Int, -- -90 -> 90 - twist :: Maybe Int, -- 0 -> 359 - altitudeAngle :: Maybe Double, -- 0 -> pi/2 - azimuthAngle :: Maybe Double -- 0 -> 2pi-- button} -- button - } - | Down - { button :: Int, - width :: Maybe Int, - height :: Maybe Int, - pressure :: Maybe Float, -- 0 -> 1 - tangentialPressure :: Maybe Float, -- -1 -> 1 - tiltX :: Maybe Int, -- -90 -> 90 - tiltY :: Maybe Int, -- -90 -> 90 - twist :: Maybe Int, -- 0 -> 359 - altitudeAngle :: Maybe Double, -- 0 -> pi/2 - azimuthAngle :: Maybe Double -- 0 -> 2pi-- button - } - | Move - { origin :: PointerOrigin, - duration :: Maybe Int, -- ms - -- where to move to - -- though the spec seems to indicate width and height are double - -- gecko driver was blowing up with anything other than int - width :: Maybe Int, - height :: Maybe Int, - pressure :: Maybe Float, -- 0 -> 1 - tangentialPressure :: Maybe Float, -- -1 -> 1 - tiltX :: Maybe Int, -- -90 -> 90 - tiltY :: Maybe Int, -- -90 -> 90 - twist :: Maybe Int, -- 0 -> 359 - altitudeAngle :: Maybe Double, -- 0 -> pi/2 - azimuthAngle :: Maybe Double, -- 0 -> 2pi - x :: Int, - y :: Int - } - | -- looks like not supported yet by gecko driver 02-02-2025 - -- https://searchfox.org/mozilla-central/source/remote/shared/webdriver/Actions.sys.mjs#2340 - Cancel - deriving (Show, Eq) - -instance ToJSON PointerAction where - toJSON :: PointerAction -> Value - toJSON = \case - PausePointer d -> - object $ - ["type" .= ("pause" :: Text)] - <> catMaybes [opt "duration" d] - Up - { -- https://www.w3.org/TR/pointerevents/#dom-pointerevent-pointerid - button, - width, -- magnitude on the X axis), in CSS pixels (see [CSS21]) -- default = 1 - height, -- (magnitude on the Y axis), in CSS pixels (see [CSS21]) -- default = 1 - pressure, -- 0 - 1 - tangentialPressure, -- -1 -> 1 - tiltX, -- -90 -> 90 - tiltY, -- -90 -> 90 - twist, -- 0 -> 359 - altitudeAngle, -- 0 -> pi/2 - azimuthAngle -- 0 -> 2pi - } -> - object $ - [ "type" .= ("pointerUp" :: Text), - "button" .= button - ] - <> catMaybes - [ opt "height" height, - opt "width" width, - opt "pressure" pressure, - opt "tangentialPressure" tangentialPressure, - opt "tiltX" tiltX, - opt "tiltY" tiltY, - opt "twist" twist, - opt "altitudeAngle" altitudeAngle, - opt "azimuthAngle" azimuthAngle - ] - Down - { button, - width, - height, - pressure, - tangentialPressure, -- -1 -> 1 - tiltX, -- -90 -> 90 - tiltY, -- -90 -> 90 - twist, -- 0 -> 359 - altitudeAngle, -- 0 -> pi/2 - azimuthAngle -- 0 -> 2pi - } -> - object $ - [ "type" .= ("pointerDown" :: Text), - "button" .= button - ] - <> catMaybes - [ opt "height" height, - opt "width" width, - opt "pressure" pressure, - opt "tangentialPressure" tangentialPressure, - opt "tiltX" tiltX, - opt "tiltY" tiltY, - opt "twist" twist, - opt "altitudeAngle" altitudeAngle, - opt "azimuthAngle" azimuthAngle - ] - Move - { origin, - duration, - width, - height, - pressure, - tangentialPressure, -- -1 -> 1 - tiltX, -- -90 -> 90 - tiltY, -- -90 -> 90 - twist, -- 0 -> 359 - altitudeAngle, -- 0 -> pi/2 - azimuthAngle, -- 0 -> 2pi - x, - y - } -> - object $ - [ "type" .= ("pointerMove" :: Text), - "origin" .= origin, - "x" .= x, - "y" .= y - ] - <> catMaybes - [ opt "duration" duration, - opt "height" height, - opt "width" width, - opt "pressure" pressure, - opt "tangentialPressure" tangentialPressure, - opt "tiltX" tiltX, - opt "tiltY" tiltY, - opt "twist" twist, - opt "altitudeAngle" altitudeAngle, - opt "azimuthAngle" azimuthAngle - ] - -- looks like Cancel not supported yet by gecko driver 02-02-2025 - -- https://searchfox.org/mozilla-central/source/remote/shared/webdriver/Actions.sys.mjs#2340 - Cancel -> object ["type" .= ("pointerCancel" :: Text)] - -mkPause :: Maybe Int -> Value -mkPause d = object $ ["type" .= ("pause" :: Text)] <> catMaybes [opt "duration" d] - -instance ToJSON Action where - toJSON :: Action -> Value - toJSON = \case - NoneAction - { id, - noneActions - } -> - object - [ "type" .= ("none" :: Text), - "id" .= id, - "actions" .= (mkPause <$> noneActions) - ] - Key {id, keyActions} -> - object - [ "id" .= id, - "type" .= ("key" :: Text), - "actions" .= keyActions - ] - Pointer - { subType, - actions, - pointerId, - pressed, - id, - x, - y - } -> - object - [ "id" .= id, - "type" .= ("pointer" :: Text), - "subType" .= subType, - "pointerId" .= pointerId, - "pressed" .= pressed, - "x" .= x, - "y" .= y, - "actions" .= actions - ] - Wheel {id, wheelActions} -> - object - [ "id" .= id, - "type" .= ("wheel" :: Text), - "actions" .= wheelActions - ] diff --git a/test/ApiCoverageTest.hs b/test/ApiCoverageTest.hs --- a/test/ApiCoverageTest.hs +++ b/test/ApiCoverageTest.hs @@ -1,109 +1,36 @@ module ApiCoverageTest where import Data.Set as S (Set, difference, fromList, null) -import Data.Text as T (Text, lines, null, pack, replace, strip, unwords, words, intercalate) +import Data.Text as T (Text, intercalate, lines, null, pack, replace, strip, unwords, words) import GHC.Utils.Misc (filterOut) -import Test.Tasty.HUnit as HUnit ( assertBool, Assertion ) +import Test.Tasty.HUnit as HUnit (Assertion, assertBool) import Text.RawString.QQ (r) -import WebDriverPreCore - ( SessionId(Session), - ElementId(Element), - Selector(CSS), - WindowHandle(Handle), - WindowRect(Rect), - FrameReference(TopLevelFrame), - Cookie(MkCookie), - Actions(MkActions), - Timeouts(..), - W3Spec(description, Get, Post, PostEmpty, Delete, path), - minFirefoxCapabilities, - acceptAlert, - addCookie, - back, - closeWindow, - deleteAllCookies, - deleteCookie, - deleteSession, - dismissAlert, - elementClear, - elementClick, - elementSendKeys, - executeScript, - executeScriptAsync, - findElement, - findElementFromElement, - findElementFromShadowRoot, - findElements, - findElementsFromElement, - findElementsFromShadowRoot, - forward, - fullscreenWindow, - getActiveElement, - getAlertText, - getAllCookies, - getCurrentUrl, - getElementAttribute, - getElementComputedLabel, - getElementComputedRole, - getElementCssValue, - getElementProperty, - getElementRect, - getElementShadowRoot, - getElementTagName, - getElementText, - getNamedCookie, - getPageSource, - getTimeouts, - getTitle, - getWindowHandle, - getWindowHandles, - getWindowRect, - isElementEnabled, - isElementSelected, - maximizeWindow, - minimizeWindow, - navigateTo, - newSession, - newWindow, - performActions, - printPage, - refresh, - releaseActions, - sendAlertText, - setTimeouts, - setWindowRect, - status, - switchToFrame, - switchToParentFrame, - switchToWindow, - takeElementScreenshot, - takeScreenshot ) -import GHC.Show (Show (..)) -import Data.Eq (Eq) -import Data.Ord (Ord) -import Data.Function (($), (.)) -import Data.Semigroup ((<>)) -import Data.List ((!!), drop) -import Data.Functor ((<$>)) -import Data.Maybe (Maybe(..)) -import WebDriverPreCore (UrlPath(..)) - - -{-- TODO use Haddock variable - Covers Spec Version https://www.w3.org/TR/2025/WD-webdriver2-20250306 - --} - +import Utils (UrlPath(..)) +import WebDriverPreCore.Http +import WebDriverPreCore.HTTP.Protocol + ( Actions (..), + Cookie (..), + ElementId (..), + FrameReference (..), + Handle (..), + Script (..), + Selector (..), + Session (..), + ShadowRootElementId (..), + Timeouts (..), + URL (..), + WindowRect (..), + minFirefoxCapabilities + ) {- !! Replace this the endepoints from the spec with every release -https://www.w3.org/TR/2025/WD-webdriver2-20250306 - W3C Editor's Draft 10 February 2025 -61 endpoints -Method URI Template Command -POST /session New Session +https://www.w3.org/TR/2025/WD-webdriver2-20251028/#endpoints- W3C Working Draft 28 October 2025 -} endPointsCopiedFromSpc :: Text -endPointsCopiedFromSpc = pack - [r|POST /session New Session +endPointsCopiedFromSpc = + pack + [r|POST /session New Session DELETE /session/{session id} Delete Session GET /status Status GET /session/{session id}/timeouts Get Timeouts @@ -163,7 +90,7 @@ POST /session/{session id}/alert/text Send Alert Text GET /session/{session id}/screenshot Take Screenshot GET /session/{session id}/element/{element id}/screenshot Take Element Screenshot -POST /session/{session id}/print Print Page +POST /session/{session id}/print Print Page |] parseLine :: Text -> SpecLine @@ -182,18 +109,21 @@ sessionId :: Text sessionId = "session_id" -session :: SessionId -session = Session sessionId +session :: Session +session = MkSession sessionId elementId :: Text elementId = "element_id" element :: ElementId -element = Element elementId +element = MkElement elementId -windowHandle :: WindowHandle -windowHandle = Handle "window-handle" +shadowDOMElement :: ShadowRootElementId +shadowDOMElement = MkShadowRootElementId elementId +windowHandle :: Handle +windowHandle = MkHandle "window-handle" + selector :: Selector selector = CSS "Blahh" @@ -215,7 +145,7 @@ . replace "{element id}" elementId . replace "{shadow id}" elementId -toSpecLine :: W3Spec a -> SpecLine +toSpecLine :: HttpSpec a -> SpecLine toSpecLine w3 = case w3 of Get {} -> MkSpecLine "GET" path command Post {} -> MkSpecLine "POST" path command @@ -227,7 +157,7 @@ allSpecsSample :: Set SpecLine allSpecsSample = - fromList + fromList $ [ toSpecLine $ newSession minFirefoxCapabilities, toSpecLine status, toSpecLine $ maximizeWindow session, @@ -253,7 +183,7 @@ toSpecLine $ getWindowHandles session, toSpecLine $ newWindow session, toSpecLine $ switchToWindow session windowHandle, - toSpecLine $ navigateTo session "url", + toSpecLine $ navigateTo session $ MkUrl "url", toSpecLine $ findElement session selector, toSpecLine $ getWindowRect session, toSpecLine $ elementClick session element, @@ -263,9 +193,9 @@ toSpecLine $ getElementAttribute session element name, toSpecLine $ getElementCssValue session element name, toSpecLine $ setWindowRect session (Rect 0 0 1280 720), - toSpecLine $ findElementsFromShadowRoot session element selector, + toSpecLine $ findElementsFromShadowRoot session shadowDOMElement selector, toSpecLine $ getElementShadowRoot session element, - toSpecLine $ findElementFromShadowRoot session element selector, + toSpecLine $ findElementFromShadowRoot session shadowDOMElement selector, toSpecLine $ getElementTagName session element, toSpecLine $ getElementRect session element, toSpecLine $ isElementEnabled session element, @@ -277,8 +207,8 @@ toSpecLine $ takeScreenshot session, toSpecLine $ takeElementScreenshot session element, toSpecLine $ printPage session, - toSpecLine $ executeScript session "console.log('test');" [], - toSpecLine $ executeScriptAsync session "console.log('test');" [], + toSpecLine $ executeScript session $ MkScript "console.log('test');" [], + toSpecLine $ executeScriptAsync session $ MkScript "console.log('test');" [], toSpecLine $ getAllCookies session, toSpecLine $ getNamedCookie session name, toSpecLine $ addCookie session $ MkCookie "testCookie" "testValue" Nothing Nothing Nothing Nothing Nothing Nothing, diff --git a/test/BiDi/Actions.hs b/test/BiDi/Actions.hs new file mode 100644 --- /dev/null +++ b/test/BiDi/Actions.hs @@ -0,0 +1,509 @@ +module BiDi.Actions + ( BiDiActions (..), + mkActions, + ) +where + +import BiDi.Socket qualified as Socket +import BiDi.Runner qualified as Runner +import Data.Aeson (FromJSON, Object, Value (..)) +import Data.Text (Text) +import WebDriverPreCore.BiDi.API qualified as API +import WebDriverPreCore.BiDi.Protocol + ( Capabilities, + Command (..), + DownloadEnd, + DownloadWillBegin, + HistoryUpdated, + JSUInt (..), + NavigationInfo, + Subscription (..), + UserPromptClosed, + UserPromptOpened, + toCommandText, + ) +import WebDriverPreCore.BiDi.Protocol as P + ( Activate, + AddDataCollector, + AddDataCollectorResult, + AddIntercept, + AddInterceptResult, + AddPreloadScript, + AddPreloadScriptResult, + AuthRequired, + BeforeRequestSent, + BrowsingContext, + CallFunction, + CaptureScreenshot, + CaptureScreenshotResult, + ClientWindowInfo, + Close, + ContinueRequest, + ContinueResponse, + ContinueWithAuth, + Create, + CreateUserContext, + DeleteCookies, + DeleteCookiesResult, + Disown, + DisownData, + Evaluate, + EvaluateResult, + Event, + FailRequest, + FetchError, + FileDialogOpened, + GetClientWindowsResult, + GetCookies, + GetCookiesResult, + GetData, + GetDataResult, + GetRealms, + GetRealmsResult, + GetTree, + GetTreeResult, + GetUserContextsResult, + HandleUserPrompt, + Info, + KnownSubscriptionType (..), + LocateNodes, + LocateNodesResult, + LogEntry, + Message, + Navigate, + NavigateResult, + PerformActions, + Print, + PrintResult, + ProvideResponse, + RealmDestroyed, + RealmInfo, + ReleaseActions, + Reload, + RemoveDataCollector, + RemoveIntercept, + RemovePreloadScript, + RemoveUserContext, + ResponseCompleted, + ResponseStarted, + SessionNewResult, + SessionStatusResult, + SessionSubscibe (..), + SessionSubscribeResult (..), + SessionUnsubscribe (..), + SetCacheBehavior, + SetClientWindowState, + SetCookie, + SetCookieResult, + SetDownloadBehavior, + SetExtraHeaders, + SetFiles, + SetForcedColorsModeThemeOverride, + SetGeolocationOverride, + SetLocaleOverride, + SetNetworkConditions, + SetScreenOrientationOverride, + SetScreenSettingsOverride, + SetScriptingEnabled, + SetTimezoneOverride, + SetTouchOverride, + SetUserAgentOverride, + SetViewport, + SubscriptionId (..), + TraverseHistory, + OffSpecSubscriptionType, + UserContext, + WebExtensionInstall, + WebExtensionResult, + WebExtensionUninstall, + ) + +_for_implementation_see_mkActions :: Socket.SocketActions -> BiDiActions +_for_implementation_see_mkActions = mkActions + +data BiDiActions = MkBiDiActions + { -- Session commands + sessionNew :: Capabilities -> IO SessionNewResult, + sessionStatus :: IO SessionStatusResult, + sessionEnd :: IO (), + -- sessionSubscribe and sessionUnsubscribe are exposed for demo commands but they would not be used normally + -- in client code. They would be called via the subscribe/unsubscribe methods below so the runner can + -- locally track subscriptions + sessionSubscribe :: SessionSubscibe -> IO SubscriptionId, + sessionUnsubscribe :: SessionUnsubscribe -> IO (), + -- BrowsingContext commands + browsingContextActivate :: Activate -> IO (), + browsingContextCaptureScreenshot :: CaptureScreenshot -> IO CaptureScreenshotResult, + browsingContextClose :: Close -> IO (), + -- | Create a browsing context + browsingContextCreate :: Create -> IO BrowsingContext, + browsingContextGetTree :: GetTree -> IO GetTreeResult, + browsingContextHandleUserPrompt :: HandleUserPrompt -> IO (), + browsingContextLocateNodes :: LocateNodes -> IO LocateNodesResult, + browsingContextNavigate :: Navigate -> IO NavigateResult, + browsingContextPrint :: Print -> IO PrintResult, + browsingContextReload :: Reload -> IO (), + browsingContextSetViewport :: SetViewport -> IO (), + browsingContextTraverseHistory :: TraverseHistory -> IO (), + -- Browser commandssendCommandNoWait socket + browserClose :: IO (), + browserCreateUserContext :: CreateUserContext -> IO UserContext, + browserGetClientWindows :: IO GetClientWindowsResult, + browserGetUserContexts :: IO GetUserContextsResult, + browserRemoveUserContext :: RemoveUserContext -> IO (), + browserSetClientWindowState :: SetClientWindowState -> IO ClientWindowInfo, + browserSetDownloadBehavior :: SetDownloadBehavior -> IO (), + -- Emulation commands + emulationSetForcedColorsModeThemeOverride :: SetForcedColorsModeThemeOverride -> IO (), + emulationSetGeolocationOverride :: SetGeolocationOverride -> IO (), + emulationSetLocaleOverride :: SetLocaleOverride -> IO (), + emulationSetNetworkConditions :: SetNetworkConditions -> IO (), + emulationSetScreenOrientationOverride :: SetScreenOrientationOverride -> IO (), + emulationSetScreenSettingsOverride :: SetScreenSettingsOverride -> IO (), + emulationSetScriptingEnabled :: SetScriptingEnabled -> IO (), + emulationSetTimezoneOverride :: SetTimezoneOverride -> IO (), + emulationSetTouchOverride :: SetTouchOverride -> IO (), + emulationSetUserAgentOverride :: SetUserAgentOverride -> IO (), + -- Input commands + inputPerformActions :: PerformActions -> IO (), + inputReleaseActions :: ReleaseActions -> IO (), + inputSetFiles :: SetFiles -> IO (), + -- Network commands + networkAddDataCollector :: AddDataCollector -> IO AddDataCollectorResult, + networkAddIntercept :: AddIntercept -> IO AddInterceptResult, + networkContinueRequest :: ContinueRequest -> IO (), + networkContinueResponse :: ContinueResponse -> IO (), + networkContinueWithAuth :: ContinueWithAuth -> IO (), + networkDisownData :: DisownData -> IO (), + networkFailRequest :: FailRequest -> IO (), + networkGetData :: GetData -> IO GetDataResult, + networkProvideResponse :: ProvideResponse -> IO (), + networkRemoveDataCollector :: RemoveDataCollector -> IO (), + networkRemoveIntercept :: RemoveIntercept -> IO (), + networkSetCacheBehavior :: SetCacheBehavior -> IO (), + networkSetExtraHeaders :: SetExtraHeaders -> IO (), + -- Script commands + scriptAddPreloadScript :: AddPreloadScript -> IO AddPreloadScriptResult, + scriptCallFunction :: CallFunction -> IO EvaluateResult, + scriptDisown :: Disown -> IO (), + scriptEvaluate :: Evaluate -> IO EvaluateResult, + scriptEvaluateNoWait :: Evaluate -> IO Socket.Request, + scriptGetRealms :: GetRealms -> IO GetRealmsResult, + scriptRemovePreloadScript :: RemovePreloadScript -> IO (), + -- Storage commands + storageDeleteCookies :: DeleteCookies -> IO DeleteCookiesResult, + storageGetCookies :: GetCookies -> IO GetCookiesResult, + storageSetCookie :: SetCookie -> IO SetCookieResult, + -- WebExtension commands + webExtensionInstall :: WebExtensionInstall -> IO WebExtensionResult, + webExtensionUninstall :: WebExtensionUninstall -> IO (), + -- ########## EVENTS ########## + + subscribeMany :: [KnownSubscriptionType] -> (Event -> IO ()) -> IO SubscriptionId, + subscribeMany' :: [BrowsingContext] -> [UserContext] -> [KnownSubscriptionType] -> (Event -> IO ()) -> IO SubscriptionId, + -- Log + subscribeLogEntryAdded :: (LogEntry -> IO ()) -> IO SubscriptionId, + subscribeLogEntryAdded' :: [BrowsingContext] -> [UserContext] -> (LogEntry -> IO ()) -> IO SubscriptionId, + -- BrowsingContext + subscribeBrowsingContextCreated :: (Info -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextCreated' :: [BrowsingContext] -> [UserContext] -> (Info -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextDestroyed :: (Info -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextDestroyed' :: [BrowsingContext] -> [UserContext] -> (Info -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextNavigationStarted :: (NavigationInfo -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextNavigationStarted' :: [BrowsingContext] -> [UserContext] -> (NavigationInfo -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextFragmentNavigated :: (NavigationInfo -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextFragmentNavigated' :: [BrowsingContext] -> [UserContext] -> (NavigationInfo -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextHistoryUpdated :: (HistoryUpdated -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextHistoryUpdated' :: [BrowsingContext] -> [UserContext] -> (HistoryUpdated -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextDomContentLoaded :: (NavigationInfo -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextDomContentLoaded' :: [BrowsingContext] -> [UserContext] -> (NavigationInfo -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextLoad :: (NavigationInfo -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextLoad' :: [BrowsingContext] -> [UserContext] -> (NavigationInfo -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextDownloadWillBegin :: (DownloadWillBegin -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextDownloadWillBegin' :: [BrowsingContext] -> [UserContext] -> (DownloadWillBegin -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextDownloadEnd :: (DownloadEnd -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextDownloadEnd' :: [BrowsingContext] -> [UserContext] -> (DownloadEnd -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextNavigationAborted :: (NavigationInfo -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextNavigationAborted' :: [BrowsingContext] -> [UserContext] -> (NavigationInfo -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextNavigationCommitted :: (NavigationInfo -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextNavigationCommitted' :: [BrowsingContext] -> [UserContext] -> (NavigationInfo -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextNavigationFailed :: (NavigationInfo -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextNavigationFailed' :: [BrowsingContext] -> [UserContext] -> (NavigationInfo -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextUserPromptClosed :: (UserPromptClosed -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextUserPromptClosed' :: [BrowsingContext] -> [UserContext] -> (UserPromptClosed -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextUserPromptOpened :: (UserPromptOpened -> IO ()) -> IO SubscriptionId, + subscribeBrowsingContextUserPromptOpened' :: [BrowsingContext] -> [UserContext] -> (UserPromptOpened -> IO ()) -> IO SubscriptionId, + -- Network + subscribeNetworkAuthRequired :: (AuthRequired -> IO ()) -> IO SubscriptionId, + subscribeNetworkAuthRequired' :: [BrowsingContext] -> [UserContext] -> (AuthRequired -> IO ()) -> IO SubscriptionId, + subscribeNetworkBeforeRequestSent :: (BeforeRequestSent -> IO ()) -> IO SubscriptionId, + subscribeNetworkBeforeRequestSent' :: [BrowsingContext] -> [UserContext] -> (BeforeRequestSent -> IO ()) -> IO SubscriptionId, + subscribeNetworkFetchError :: (FetchError -> IO ()) -> IO SubscriptionId, + subscribeNetworkFetchError' :: [BrowsingContext] -> [UserContext] -> (FetchError -> IO ()) -> IO SubscriptionId, + subscribeNetworkResponseCompleted :: (ResponseCompleted -> IO ()) -> IO SubscriptionId, + subscribeNetworkResponseCompleted' :: [BrowsingContext] -> [UserContext] -> (ResponseCompleted -> IO ()) -> IO SubscriptionId, + subscribeNetworkResponseStarted :: (ResponseStarted -> IO ()) -> IO SubscriptionId, + subscribeNetworkResponseStarted' :: [BrowsingContext] -> [UserContext] -> (ResponseStarted -> IO ()) -> IO SubscriptionId, + -- Script + subscribeScriptMessage :: (Message -> IO ()) -> IO SubscriptionId, + subscribeScriptMessage' :: [BrowsingContext] -> [UserContext] -> (Message -> IO ()) -> IO SubscriptionId, + -- + subscribeScriptRealmCreated :: (RealmInfo -> IO ()) -> IO SubscriptionId, + subscribeScriptRealmCreated' :: [BrowsingContext] -> [UserContext] -> (RealmInfo -> IO ()) -> IO SubscriptionId, + subscribeScriptRealmDestroyed :: (RealmDestroyed -> IO ()) -> IO SubscriptionId, + subscribeScriptRealmDestroyed' :: [BrowsingContext] -> [UserContext] -> (RealmDestroyed -> IO ()) -> IO SubscriptionId, + -- Input + subscribeInputFileDialogOpened :: (FileDialogOpened -> IO ()) -> IO SubscriptionId, + subscribeInputFileDialogOpened' :: [BrowsingContext] -> [UserContext] -> (FileDialogOpened -> IO ()) -> IO SubscriptionId, + -- + unsubscribe :: SubscriptionId -> IO (), + -- + sendCommand :: forall r. (FromJSON r) => Command r -> IO r, + sendCommand' :: forall r. (FromJSON r) => JSUInt -> Command r -> IO r, + sendCommandNoWait :: forall r. Command r -> IO Socket.Request, + sendOffSpecCommand' :: JSUInt -> Text -> Object -> IO Object, + sendOffSpecCommandNoWait :: Text -> Object -> IO Socket.Request, + -- fallback subscriptions + subscribeUnknownMany :: + [OffSpecSubscriptionType] -> + (Value -> IO ()) -> + IO SubscriptionId, + subscribeUnknownMany' :: + [BrowsingContext] -> + [UserContext] -> + [OffSpecSubscriptionType] -> + (Value -> IO ()) -> + IO SubscriptionId + } + +mkActions :: Socket.SocketActions -> BiDiActions +mkActions socket = + MkBiDiActions + { -- ########## COMMANDS ########## + -- Session commands + sessionNew = send . API.sessionNew, + sessionStatus = send API.sessionStatus, + sessionEnd = send API.sessionEnd, + sessionSubscribe = fmap (.subscription) . sessionSubscribe, + sessionUnsubscribe = send . API.sessionUnsubscribe, + -- BrowsingContext commands + browsingContextActivate = send . API.browsingContextActivate, + browsingContextCaptureScreenshot = send . API.browsingContextCaptureScreenshot, + browsingContextClose = send . API.browsingContextClose, + browsingContextCreate = send . API.browsingContextCreate, + browsingContextGetTree = send . API.browsingContextGetTree, + browsingContextHandleUserPrompt = send . API.browsingContextHandleUserPrompt, + browsingContextLocateNodes = send . API.browsingContextLocateNodes, + browsingContextNavigate = send . API.browsingContextNavigate, + browsingContextPrint = send . API.browsingContextPrint, + browsingContextReload = send . API.browsingContextReload, + browsingContextSetViewport = send . API.browsingContextSetViewport, + browsingContextTraverseHistory = send . API.browsingContextTraverseHistory, + -- Browser commands + browserClose = send API.browserClose, + browserCreateUserContext = send . API.browserCreateUserContext, + browserGetClientWindows = send API.browserGetClientWindows, + browserGetUserContexts = send API.browserGetUserContexts, + browserRemoveUserContext = send . API.browserRemoveUserContext, + browserSetClientWindowState = send . API.browserSetClientWindowState, + browserSetDownloadBehavior = send . API.browserSetDownloadBehavior, + -- Emulation commands + emulationSetForcedColorsModeThemeOverride = send . API.emulationSetForcedColorsModeThemeOverride, + emulationSetGeolocationOverride = send . API.emulationSetGeolocationOverride, + emulationSetLocaleOverride = send . API.emulationSetLocaleOverride, + emulationSetNetworkConditions = send . API.emulationSetNetworkConditions, + emulationSetScreenOrientationOverride = send . API.emulationSetScreenOrientationOverride, + emulationSetScreenSettingsOverride = send . API.emulationSetScreenSettingsOverride, + emulationSetScriptingEnabled = send . API.emulationSetScriptingEnabled, + emulationSetTimezoneOverride = send . API.emulationSetTimezoneOverride, + emulationSetTouchOverride = send . API.emulationSetTouchOverride, + emulationSetUserAgentOverride = send . API.emulationSetUserAgentOverride, + -- Input commands + inputPerformActions = send . API.inputPerformActions, + inputReleaseActions = send . API.inputReleaseActions, + inputSetFiles = send . API.inputSetFiles, + -- Network commands + networkAddDataCollector = send . API.networkAddDataCollector, + networkAddIntercept = send . API.networkAddIntercept, + networkContinueRequest = send . API.networkContinueRequest, + networkContinueResponse = send . API.networkContinueResponse, + networkContinueWithAuth = send . API.networkContinueWithAuth, + networkDisownData = send . API.networkDisownData, + networkFailRequest = send . API.networkFailRequest, + networkGetData = send . API.networkGetData, + networkProvideResponse = send . API.networkProvideResponse, + networkRemoveDataCollector = send . API.networkRemoveDataCollector, + networkRemoveIntercept = send . API.networkRemoveIntercept, + networkSetCacheBehavior = send . API.networkSetCacheBehavior, + networkSetExtraHeaders = send . API.networkSetExtraHeaders, + -- Script commands + scriptAddPreloadScript = send . API.scriptAddPreloadScript, + scriptCallFunction = send . API.scriptCallFunction, + scriptDisown = send . API.scriptDisown, + scriptEvaluate = send . API.scriptEvaluate, + scriptEvaluateNoWait = sendCommandNoWait . API.scriptEvaluate, + scriptGetRealms = send . API.scriptGetRealms, + scriptRemovePreloadScript = send . API.scriptRemovePreloadScript, + -- Storage commands + storageDeleteCookies = send . API.storageDeleteCookies, + storageGetCookies = send . API.storageGetCookies, + storageSetCookie = send . API.storageSetCookie, + -- WebExtension commands + webExtensionInstall = send . API.webExtensionInstall, + webExtensionUninstall = send . API.webExtensionUninstall, + -- + -- ############## Subscriptions (Events) ############## + + subscribeMany = \sts -> subscribeMany' [] [] sts, + subscribeMany', + -- Log + subscribeLogEntryAdded = sendSub API.subscribeLogEntryAdded, + subscribeLogEntryAdded' = sendSub' API.subscribeLogEntryAdded, + -- BrowsingContext + subscribeBrowsingContextCreated = sendSub API.subscribeBrowsingContextCreated, + subscribeBrowsingContextCreated' = sendSub' API.subscribeBrowsingContextCreated, + subscribeBrowsingContextDestroyed = sendSub API.subscribeBrowsingContextDestroyed, + subscribeBrowsingContextDestroyed' = sendSub' API.subscribeBrowsingContextDestroyed, + subscribeBrowsingContextNavigationStarted = sendSub API.subscribeBrowsingContextNavigationStarted, + subscribeBrowsingContextNavigationStarted' = sendSub' API.subscribeBrowsingContextNavigationStarted, + subscribeBrowsingContextFragmentNavigated = sendSub API.subscribeBrowsingContextFragmentNavigated, + subscribeBrowsingContextFragmentNavigated' = sendSub' API.subscribeBrowsingContextFragmentNavigated, + subscribeBrowsingContextHistoryUpdated = sendSub API.subscribeBrowsingContextHistoryUpdated, + subscribeBrowsingContextHistoryUpdated' = sendSub' API.subscribeBrowsingContextHistoryUpdated, + subscribeBrowsingContextDomContentLoaded = sendSub API.subscribeBrowsingContextDomContentLoaded, + subscribeBrowsingContextDomContentLoaded' = sendSub' API.subscribeBrowsingContextDomContentLoaded, + subscribeBrowsingContextLoad = sendSub API.subscribeBrowsingContextLoad, + subscribeBrowsingContextLoad' = sendSub' API.subscribeBrowsingContextLoad, + subscribeBrowsingContextDownloadWillBegin = sendSub API.subscribeBrowsingContextDownloadWillBegin, + subscribeBrowsingContextDownloadWillBegin' = sendSub' API.subscribeBrowsingContextDownloadWillBegin, + subscribeBrowsingContextDownloadEnd = sendSub API.subscribeBrowsingContextDownloadEnd, + subscribeBrowsingContextDownloadEnd' = sendSub' API.subscribeBrowsingContextDownloadEnd, + subscribeBrowsingContextNavigationAborted = sendSub API.subscribeBrowsingContextNavigationAborted, + subscribeBrowsingContextNavigationAborted' = sendSub' API.subscribeBrowsingContextNavigationAborted, + subscribeBrowsingContextNavigationCommitted = sendSub API.subscribeBrowsingContextNavigationCommitted, + subscribeBrowsingContextNavigationCommitted' = sendSub' API.subscribeBrowsingContextNavigationCommitted, + subscribeBrowsingContextNavigationFailed = sendSub API.subscribeBrowsingContextNavigationFailed, + subscribeBrowsingContextNavigationFailed' = sendSub' API.subscribeBrowsingContextNavigationFailed, + subscribeBrowsingContextUserPromptClosed = sendSub API.subscribeBrowsingContextUserPromptClosed, + subscribeBrowsingContextUserPromptClosed' = sendSub' API.subscribeBrowsingContextUserPromptClosed, + subscribeBrowsingContextUserPromptOpened = sendSub API.subscribeBrowsingContextUserPromptOpened, + subscribeBrowsingContextUserPromptOpened' = sendSub' API.subscribeBrowsingContextUserPromptOpened, + -- Network + subscribeNetworkAuthRequired = sendSub API.subscribeNetworkAuthRequired, + subscribeNetworkAuthRequired' = sendSub' API.subscribeNetworkAuthRequired, + subscribeNetworkBeforeRequestSent = sendSub API.subscribeNetworkBeforeRequestSent, + subscribeNetworkBeforeRequestSent' = sendSub' API.subscribeNetworkBeforeRequestSent, + subscribeNetworkFetchError = sendSub API.subscribeNetworkFetchError, + subscribeNetworkFetchError' = sendSub' API.subscribeNetworkFetchError, + subscribeNetworkResponseCompleted = sendSub API.subscribeNetworkResponseCompleted, + subscribeNetworkResponseCompleted' = sendSub' API.subscribeNetworkResponseCompleted, + subscribeNetworkResponseStarted = sendSub API.subscribeNetworkResponseStarted, + subscribeNetworkResponseStarted' = sendSub' API.subscribeNetworkResponseStarted, + -- Script + subscribeScriptMessage = sendSub API.subscribeScriptMessage, + subscribeScriptMessage' = sendSub' API.subscribeScriptMessage, + subscribeScriptRealmCreated = sendSub API.subscribeScriptRealmCreated, + subscribeScriptRealmCreated' = sendSub' API.subscribeScriptRealmCreated, + subscribeScriptRealmDestroyed = sendSub API.subscribeScriptRealmDestroyed, + subscribeScriptRealmDestroyed' = sendSub' API.subscribeScriptRealmDestroyed, + -- Input + subscribeInputFileDialogOpened = sendSub API.subscribeInputFileDialogOpened, + subscribeInputFileDialogOpened' = sendSub' API.subscribeInputFileDialogOpened, + -- + unsubscribe, + -- fallback command methods + sendCommandNoWait, + sendCommand', + -- + sendCommand = send, + sendOffSpecCommand', + sendOffSpecCommandNoWait, + -- fallback subscriptions + subscribeUnknownMany, + subscribeUnknownMany' + } + where + runnerUnsubscribe :: SessionUnsubscribe -> IO () + runnerUnsubscribe = Runner.unsubscribe socket sessionUnsubscribe + + unsubscribe :: SubscriptionId -> IO () + unsubscribe subId = unsubscribeMany [subId] + + unsubscribeMany :: [SubscriptionId] -> IO () + unsubscribeMany subIds = runnerUnsubscribe (UnsubscribeById subIds) + + toBiDi :: Command r -> Socket.SocketCommand Text r + toBiDi MkCommand {method, params} = + Socket.MkSocketCommand + { method = toCommandText method, + params = Object params + } + + send :: forall r. (FromJSON r) => Command r -> IO r + send = Socket.sendCommand socket . toBiDi + + sendCommand' :: forall r. (FromJSON r) => JSUInt -> Command r -> IO r + sendCommand' id' = Socket.sendCommand' socket id' . toBiDi + + sendCommandNoWait :: forall r. Command r -> IO Socket.Request + sendCommandNoWait = Socket.sendCommandNoWait socket . toBiDi + + sendOffSpecCommand' :: JSUInt -> Text -> Object -> IO Object + sendOffSpecCommand' id' method = + Socket.sendCommand' socket id' . Socket.MkSocketCommand method . Object + + sendOffSpecCommandNoWait :: Text -> Object -> IO Socket.Request + sendOffSpecCommandNoWait method = + Socket.sendCommandNoWait socket . Socket.MkSocketCommand method . Object + + sessionSubscribe :: SessionSubscibe -> IO SessionSubscribeResult + sessionSubscribe = send . API.sessionSubscribe + + sessionUnsubscribe :: SessionUnsubscribe -> IO () + sessionUnsubscribe = send . API.sessionUnsubscribe + + subscribeMany' :: + [BrowsingContext] -> + [UserContext] -> + [KnownSubscriptionType] -> + (Event -> IO ()) -> + IO SubscriptionId + subscribeMany' bcs ucs sts = Runner.subscribe socket sessionSubscribe . API.subscribeMany sts bcs ucs + + subscribeUnknownMany :: + [OffSpecSubscriptionType] -> + (Value -> IO ()) -> + IO SubscriptionId + subscribeUnknownMany sts = Runner.subscribe socket sessionSubscribe . API.subscribeOffSpecMany sts [] [] + + subscribeUnknownMany' :: + [BrowsingContext] -> + [UserContext] -> + [OffSpecSubscriptionType] -> + (Value -> IO ()) -> + IO SubscriptionId + subscribeUnknownMany' bcs ucs sts = Runner.subscribe socket sessionSubscribe . API.subscribeOffSpecMany sts bcs ucs + + sendSub :: + ( [BrowsingContext] -> + [UserContext] -> + (a -> IO ()) -> + Subscription IO + ) -> + (a -> IO ()) -> + IO SubscriptionId + sendSub mkSubscription = + Runner.subscribe socket sessionSubscribe . mkSubscription [] [] + + sendSub' :: + ( [BrowsingContext] -> + [UserContext] -> + (a -> IO ()) -> + Subscription IO + ) -> + [BrowsingContext] -> + [UserContext] -> + (a -> IO ()) -> + IO SubscriptionId + sendSub' mkSubscription bcs ucs = + Runner.subscribe socket sessionSubscribe . mkSubscription bcs ucs diff --git a/test/BiDi/BiDiUrl.hs b/test/BiDi/BiDiUrl.hs new file mode 100644 --- /dev/null +++ b/test/BiDi/BiDiUrl.hs @@ -0,0 +1,68 @@ +module BiDi.BiDiUrl where + +import Data.Function ((&)) +import Data.Text (Text, breakOn, pack, splitOn, unpack) +import Text.Read (readEither) +import WebDriverPreCore.HTTP.Protocol (SessionResponse(..)) +import Utils (txt) + +getBiDiUrl :: SessionResponse -> Either Text BiDiUrl +getBiDiUrl r = + r.webSocketUrl + & maybe + (Left $ "WebSocket URL not provided in session response:\n" <> txt r) + parseUrl + +parseUrl :: Text -> Either Text BiDiUrl +parseUrl url = do + (_scheme, hostPortPath) <- splitScheme + (host, portPath) <- splitHost hostPortPath + (port, path) <- portAndPath portPath + Right $ + MkBiDiUrl + { host, + port, + path + } + where + -- "ws://127.0.0.1:9222/session/e43698d9-b02a-4284-a936-12041deb3552" + -- -> [ws, //127.0.0.1, 9222/session/e43698d9-b02a-4284-a936-12041deb3552] + splitScheme = + splitOn "://" url + & \case + [scheme, hostPortPath] -> Right (scheme, hostPortPath) + _ -> failParser "Expected format: ws://host:port/path" + + splitHost hostPortPath = + splitOn ":" hostPortPath + & \case + [host, portPath] -> Right (host, portPath) + _ -> failParser "Expected format: host:port/path" + + -- 9222/session/e43698d9-b02a-4284-a936-12041deb3552 + -- -> (9222, session/e43698d9-b02a-4284-a936-12041deb3552) + portAndPath :: Text -> Either Text (Int, Text) + portAndPath pp = + (,path) <$> portEth + where + (portTxt, path) = breakOn "/" pp + portEth = case readEither $ unpack portTxt of + Left msg -> + failParser $ + "Could not extract port (an Int) from pBiDi.BiDiRunnerrefix of: " + <> portTxt + <> "\n" + <> "Error on read Int: " + <> pack msg + Right p -> Right p + + failParser :: forall a. Text -> Either Text a + failParser msg = Left $ "Failed to parse URL: " <> url <> "\n" <> msg + +-- | WebDriver BiDi client configuration +data BiDiUrl = MkBiDiUrl + { host :: Text, + port :: Int, + path :: Text + } + deriving (Show) diff --git a/test/BiDi/DemoUtils.hs b/test/BiDi/DemoUtils.hs new file mode 100644 --- /dev/null +++ b/test/BiDi/DemoUtils.hs @@ -0,0 +1,253 @@ +module BiDi.DemoUtils where + +import BiDi.Actions (BiDiActions (..), mkActions) +import BiDi.BiDiUrl (BiDiUrl, getBiDiUrl) +import BiDi.Runner (withBiDi, withBidiFailTest) +import BiDi.Socket (SocketActions) +import Config (Config (..)) +import ConfigLoader (loadConfig) +import Const (Timeout (..), milliseconds, seconds) +import Control.Exception (Exception, SomeException, catch, throwIO, try) +import Data.Function ((&)) +import Data.Text (Text, isInfixOf, unpack) +import Data.Text qualified as T +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) +import Data.Word (Word64) +import HTTP.Actions qualified as HTTPA +import HTTP.DemoUtils (withSession) +import HTTP.Runner (mkRunner) +import IOUtils (DemoActions (..), Logger, logNothingLogger, mkDemoActions) +import Logger (withChannelFileLogger) +import Network.HTTP.Req (http) +import RuntimeConst (httpCapabilities, httpFullCapabilities) +import Utils (txt) +import WebDriverPreCore.BiDi.Protocol + ( BrowsingContext (..), + Close (..), + ContextTarget (..), + Create (..), + CreateType (..), + Evaluate (..), + EvaluateResult (..), + GetTree (..), + GetTreeResult (..), + Info (..), + PrimitiveProtocolValue (..), + RemoteValue (..), + StringValue (..), + Target (..), + ) +import WebDriverPreCore.HTTP.Protocol (FullCapabilities (..)) +import WebDriverPreCore.HTTP.Protocol qualified as Caps (Capabilities (..)) +import Prelude hiding (log, putStrLn) + +data BiDiDemo = MkBiDiDemo + { name :: Text, + action :: DemoActions -> BiDiActions -> IO () + } + +demo :: Text -> (DemoActions -> BiDiActions -> IO ()) -> BiDiDemo +demo name action = MkBiDiDemo {name, action} + +-- -- Bidi capabilities request is the same as regular HTTP capabilities, +-- -- but with the `webSocketUrl` field set to `True` +httpBidiCapabilities :: Config -> FullCapabilities +httpBidiCapabilities cfg = + (httpFullCapabilities cfg) + { alwaysMatch = + Just $ (httpCapabilities cfg) {Caps.webSocketUrl = Just True} + } + +type Runner = DemoActions -> BiDiUrl -> (DemoActions -> SocketActions -> IO ()) -> IO () + +runDemo' :: Config -> BiDiDemo -> IO () +runDemo' = runDemo'' withBiDi + +runDemo'' :: Runner -> Config -> BiDiDemo -> IO () +runDemo'' + bidiRunner + cfg@MkConfig + { httpUrl, + httpPort, + logging, + pauseMS + } + demo' = do + if logging + then + withChannelFileLogger runWithLogger + else + runWithLogger logNothingLogger + where + httpCaps = httpBidiCapabilities cfg + runWithLogger :: Logger -> IO () + runWithLogger logger = + let demoActions = mkDemoActions logger $ fromIntegral pauseMS * milliseconds + httpRunner = mkRunner (http httpUrl) (fromIntegral httpPort) demoActions + httpActions = HTTPA.mkActions httpRunner + in withSession httpCaps httpActions $ \ses -> do + bidiUrl <- getBiDiUrl ses & either (fail . unpack) pure + bidiRunner demoActions bidiUrl $ \_ socketActions -> do + let bidiActions = mkActions socketActions + demoActions.logTxt $ "Executing: " <> demo'.name + demo'.action demoActions bidiActions + +runDemo :: BiDiDemo -> IO () +runDemo dmo = loadConfig >>= flip runDemo' dmo + +runDemoFail :: Word64 -> Word64 -> Word64 -> BiDiDemo -> IO () +runDemoFail failSendCount failGetCount failEventCount dmo = loadConfig >>= \c -> runDemoFail' c failSendCount failGetCount failEventCount dmo + +runDemoFail' :: Config -> Word64 -> Word64 -> Word64 -> BiDiDemo -> IO () +runDemoFail' config failSendCount failGetCount failEventCount dmo = runDemo'' (withBidiFailTest failSendCount failGetCount failEventCount) config dmo + +newWindowContext :: DemoActions -> BiDiActions -> IO BrowsingContext +newWindowContext MkDemoActions {..} MkBiDiActions {..} = do + logTxt "New browsing context - Window" + bcWin <- browsingContextCreate bcParams {createType = Window} + logShow "Browsing context - Window" bcWin + pause + pure bcWin + where + bcParams = + MkCreate + { createType = Tab, + background = False, + referenceContext = Nothing, + userContext = Nothing + } + +closeContext :: DemoActions -> BiDiActions -> BrowsingContext -> IO () +closeContext MkDemoActions {pause, logTxt, logShow} MkBiDiActions {..} bc = do + logTxt "Close browsing context" + co <- browsingContextClose $ MkClose {context = bc, promptUnload = Nothing} + logShow "Close result" co + pause + +rootContext :: DemoActions -> BiDiActions -> IO BrowsingContext +rootContext MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Get root browsing context" + tree <- browsingContextGetTree $ MkGetTree Nothing Nothing + logShow "Browsing context tree" tree + case tree of + MkGetTreeResult (info : _) -> pure $ info.context + _ -> error "No browsing contexts found" + +-- | Custom exception for text validation failures +data TextValidationError = MkTextValidationError + { message :: Text, + expectedText :: Text, + actualText :: Text + } + deriving (Show) + +instance Exception TextValidationError + +-- | Check if expected text is present in DOM with timeout and retry, throw error if not found +chkDomContains' :: Timeout -> Timeout -> DemoActions -> BiDiActions -> BrowsingContext -> Text -> IO () +chkDomContains' timeout pause' MkDemoActions {..} MkBiDiActions {..} bc expectedText = do + startTime <- getPOSIXTime + logTxt $ "Checking DOM contains: " <> expectedText <> " (timeout: " <> txt timeout <> "ms, pause: " <> txt pause' <> "ms)" + checkLoop $ startTime + (fromIntegral timeout.microseconds / 1000000) + where + checkLoop :: POSIXTime -> IO () + checkLoop endTime = do + currentTime <- getPOSIXTime + if currentTime > endTime + then do + throwIO $ + MkTextValidationError + { message = "✗ Timeout reached! Expected text not found after " <> txt timeout <> "ms", + expectedText, + actualText = "" + } + else do + result <- + (validateDomText >> pure ()) `catch` \(_ :: TextValidationError) -> do + pauseAtLeast pause' + checkLoop endTime + pure result + + validateDomText :: IO () + validateDomText = do + -- Get the full DOM text content + domResult <- + scriptEvaluate $ + MkEvaluate + { expression = "document.body ? document.body.innerText || document.body.textContent || '' : ''", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + + case domResult of + EvaluateResultSuccess {result = PrimitiveValue (StringValue (MkStringValue actualText))} -> do + if expectedText `isInfixOf` actualText + then logTxt $ "✓ Found expected text: " <> expectedText + else do + throwIO $ + MkTextValidationError + { message = "✗ Expected text not in DOM", + expectedText, + actualText + } + EvaluateResultSuccess {result = otherResult} -> do + throwIO $ + MkTextValidationError + { message = "Unexpected result type: " <> txt otherResult, + expectedText, + actualText = "Non-string result" + } + EvaluateResultException {exceptionDetails} -> do + throwIO $ + MkTextValidationError + { message = "✗ Script evaluation failed", + expectedText, + actualText = txt exceptionDetails + } + +-- | Check if expected text is present in DOM with default timeout and retry settings +chkDomContains :: DemoActions -> BiDiActions -> BrowsingContext -> Text -> IO () +chkDomContains = chkDomContains' (10 * seconds) (MkTimeout 100) + +data FailTest + = Predicate (Text -> Bool) + | Fragment Text + +toLambda :: FailTest -> (Text -> Bool) +toLambda = \case + Predicate f -> f + Fragment t -> \errText -> t `T.isInfixOf` errText + +expectErrorText :: Text -> Text -> IO () -> IO () +expectErrorText testName expectedFragment = + expectError testName (Fragment expectedFragment) + +toText :: FailTest -> Text +toText (Fragment t) = t +toText (Predicate _) = "" + +-- | General function to test that an IO action throws an exception containing expected text +expectError :: Text -> FailTest -> IO () -> IO () +expectError testName failTest action = do + result <- try action + case result of + Left (e :: SomeException) -> do + let errText = txt $ show e + if toLambda failTest errText + then pure () + else + fail . unpack $ + testName + <> ": Error did not contain expected fragment." + <> "\n" + <> " Expected Fragment was: " + <> "\n" + <> toText failTest + <> "\n" + <> "Actual Error was:" + <> "\n" + <> errText + Right _ -> + fail $ unpack $ testName <> ": Expected error, but action completed successfully." diff --git a/test/BiDi/Demos/BrowserDemos.hs b/test/BiDi/Demos/BrowserDemos.hs new file mode 100644 --- /dev/null +++ b/test/BiDi/Demos/BrowserDemos.hs @@ -0,0 +1,327 @@ +module BiDi.Demos.BrowserDemos where + +import BiDi.Actions (BiDiActions (..)) +import BiDi.DemoUtils +import IOUtils (DemoActions (..)) +import WebDriverPreCore.BiDi.Protocol + ( Close (..), + Create (..), + CreateType (..), + CreateUserContext (..), + DownloadBehaviour (..), + NamedState (..), + RemoveUserContext (..), + SetClientWindowState (..), + SetDownloadBehavior (..), + GetClientWindowsResult (..), + ClientWindowInfo (..), + WindowState (..), + RectState (..) + ) +import Prelude hiding (log, putStrLn) + +-- >>> runDemo browserGetClientWindowsDemo +browserGetClientWindowsDemo :: BiDiDemo +browserGetClientWindowsDemo = + demo "Browser - Get Client Windows" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Getting current client windows" + clientWindows <- browserGetClientWindows + logShow "Client windows" clientWindows + pause + +-- >>> runDemo browserCreateUserContextDemo +browserCreateUserContextDemo :: BiDiDemo +browserCreateUserContextDemo = + demo "Browser - Create User Context" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Creating basic user context" + let basicUserContext = + MkCreateUserContext + { insecureCerts = Nothing, + proxy = Nothing, + unhandledPromptBehavior = Nothing + } + uc1 <- browserCreateUserContext basicUserContext + logShow "Basic user context created" uc1 + pause + + logTxt "Creating user context with insecure certs" + let secureUserContext = basicUserContext {insecureCerts = Just True} + uc2 <- browserCreateUserContext secureUserContext + logShow "User context with insecure certs" uc2 + pause + +-- >>> runDemo browserGetUserContextsDemo +browserGetUserContextsDemo :: BiDiDemo +browserGetUserContextsDemo = + demo "Browser - Get User Contexts" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Getting all user contexts" + userContexts <- browserGetUserContexts + logShow "User contexts" userContexts + pause + +-- >>> runDemo browserSetClientWindowStateDemo +-- *** Exception: BiDIError (ProtocolException {error = UnknownCommand, description = "A command could not be executed because the remote end is not aware of it", message = "browser.setClientWindowState", stacktrace = Just "RemoteError@chrome://remote/content/shared/RemoteError.sys.mjs:8:8\nWebDriverError@chrome://remote/content/shared/webdriver/Errors.sys.mjs:202:5\nUnknownCommandError@chrome://remote/content/shared/webdriver/Errors.sys.mjs:944:5\nexecute@chrome://remote/content/shared/webdriver/Session.sys.mjs:420:13\nonPacket@chrome://remote/content/webdriver-bidi/WebDriverBiDiConnection.sys.mjs:236:37\nonMessage@chrome://remote/content/server/WebSocketTransport.sys.mjs:127:18\nhandleEvent@chrome://remote/content/server/WebSocketTransport.sys.mjs:109:14\n", errorData = Nothing, response = Object (fromList [("error",String "unknown command"),("id",Number 2.0),("message",String "browser.setClientWindowState"),("stacktrace",String "RemoteError@chrome://remote/content/shared/RemoteError.sys.mjs:8:8\nWebDriverError@chrome://remote/content/shared/webdriver/Errors.sys.mjs:202:5\nUnknownCommandError@chrome://remote/content/shared/webdriver/Errors.sys.mjs:944:5\nexecute@chrome://remote/content/shared/webdriver/Session.sys.mjs:420:13\nonPacket@chrome://remote/content/webdriver-bidi/WebDriverBiDiConnection.sys.mjs:236:37\nonMessage@chrome://remote/content/server/WebSocketTransport.sys.mjs:127:18\nhandleEvent@chrome://remote/content/server/WebSocketTransport.sys.mjs:109:14\n"),("type",String "error")])}) +browserSetClientWindowStateDemo :: BiDiDemo +browserSetClientWindowStateDemo = + demo "Browser - Set Client Window State" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Getting current client windows to find one to modify" + clientWindows <- browserGetClientWindows + logShow "Available client windows" clientWindows + + -- TODO: not supported expectation + let window = case clientWindows.clientWindows of + [] -> error "No client windows found" + x : _ -> x + + clientWindow = window.clientWindow + pause + + logTxt "Maximizing window" + let maximizeState = + MkSetClientWindowState + { clientWindow = clientWindow, + windowState = ClientWindowNamedState MaximizedState + } + maxResult <- browserSetClientWindowState maximizeState + logShow "Maximized window result" maxResult + pause + + logTxt "Restoring window to normal" + let normalState = + MkSetClientWindowState + { clientWindow = clientWindow, + windowState = + ClientWindowRectState $ + MkRectState + { + width = Just 800, + height = Just 600, + x = Just 100, + y = Just 100 + } + } + normalResult <- browserSetClientWindowState normalState + logShow "Normal window result" normalResult + pause + +-- >>> runDemo browserRemoveUserContextDemo +browserRemoveUserContextDemo :: BiDiDemo +browserRemoveUserContextDemo = + demo "Browser - Remove User Context" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Creating a user context to remove" + let userContextParams = + MkCreateUserContext + { insecureCerts = Nothing, + proxy = Nothing, + unhandledPromptBehavior = Nothing + } + uc <- browserCreateUserContext userContextParams + logShow "Created user context" uc + pause + + logTxt "Removing the user context" + let removeParams = MkRemoveUserContext {userContext = uc} + removeResult <- browserRemoveUserContext removeParams + logShow "Remove user context result" removeResult + pause + +-- >>> runDemo browserCompleteWorkflowDemo +browserCompleteWorkflowDemo :: BiDiDemo +browserCompleteWorkflowDemo = + demo "Browser - Complete Workflow" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Step 1: Get initial state" + initialWindows <- browserGetClientWindows + initialContexts <- browserGetUserContexts + logShow "Initial client windows" initialWindows + logShow "Initial user contexts" initialContexts + pause + + logTxt "Step 2: Create multiple user contexts" + let userContext1 = + MkCreateUserContext + { insecureCerts = Nothing, + proxy = Nothing, + unhandledPromptBehavior = Nothing + } + uc1 <- browserCreateUserContext userContext1 + logShow "User context 1 created" uc1 + + let userContext2 = userContext1 {insecureCerts = Just True} + uc2 <- browserCreateUserContext userContext2 + logShow "User context 2 created (with insecure certs)" uc2 + pause + + logTxt "Step 3: Create browsing contexts in different user contexts" + let bcParams = + MkCreate + { createType = Window, + background = False, + referenceContext = Nothing, + userContext = Just uc1 + } + bc1 <- browsingContextCreate bcParams + logShow "Browsing context in user context 1" bc1 + + let bcParams2 = + MkCreate + { createType = Window, + background = False, + referenceContext = Nothing, + userContext = Just uc2 + } + bc2 <- browsingContextCreate bcParams2 + logShow "Browsing context in user context 2" bc2 + pause + + logTxt "Step 4: Check updated state" + updatedWindows <- browserGetClientWindows + updatedContexts <- browserGetUserContexts + logShow "Updated client windows" updatedWindows + logShow "Updated user contexts" updatedContexts + pause + + -- todo After errors unknown command expectation + {- Not supported in geckodriver yet + logTxt "Step 5: Demonstrate window state management" + + case updatedWindows.clientWindows of + [] -> logTxt "No windows to manage" + (window:_) -> do + let clientWindow = window.clientWindowJ + + logTxt "Maximizing first window" + let maximizeState = MkSetClientWindowState + { clientWindow = clientWindow, + windowState = ClientWindowNamedState NamedMaximized + } + wm <- browserSetClientWindowState maximizeState + logShow "Window maximized" wm + pause + -} + logTxt "Step 6: Cleanup - Close browsing contexts" + bcc <- + browsingContextClose $ + MkClose + { context = bc1, + promptUnload = Nothing + } + logShow "Browsing context 1 closed" bcc + + bcc2 <- + browsingContextClose $ + MkClose + { context = bc2, + promptUnload = Nothing + } + logShow "Browsing context 2 closed" bcc2 + pause + + logTxt "Step 7: Cleanup - Remove user contexts" + ruc <- browserRemoveUserContext $ MkRemoveUserContext {userContext = uc1} + logShow "User context 1 removed" ruc + + ruc2 <- browserRemoveUserContext $ MkRemoveUserContext {userContext = uc2} + logShow "User context 2 removed" ruc2 + pause + + logTxt "Step 8: Final state check" + finalWindows <- browserGetClientWindows + finalContexts <- browserGetUserContexts + logShow "Final client windows" finalWindows + logShow "Final user contexts" finalContexts + +-- >>> runDemo browserSetDownloadBehaviorDemo +browserSetDownloadBehaviorDemo :: BiDiDemo +browserSetDownloadBehaviorDemo = + demo "Browser - Set Download Behavior (since https://www.w3.org/TR/2025/WD-webdriver-bidi-20250918)" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Setting download behavior to allow downloads to /tmp/downloads" + let allowedDownload = + MkSetDownloadBehavior + { downloadBehavior = Just $ AllowedDownload {destinationFolder = "/tmp/downloads"}, + userContexts = Nothing + } + result <- browserSetDownloadBehavior allowedDownload + logShow "Allow download result" result + pause + + logTxt "Setting download behavior to deny downloads" + let deniedDownload = + MkSetDownloadBehavior + { downloadBehavior = Just DeniedDownload, + userContexts = Nothing + } + result2 <- browserSetDownloadBehavior deniedDownload + logShow "Deny download result" result2 + pause + + logTxt "Clearing download behavior (reset to default)" + let clearDownload = + MkSetDownloadBehavior + { downloadBehavior = Nothing, + userContexts = Nothing + } + result3 <- browserSetDownloadBehavior clearDownload + logShow "Clear download behavior result" result3 + pause + +-- >>> runDemo browserCloseDemo +-- *** Exception: Error executing BiDi command: With JSON: +-- { +-- "id": 3, +-- "method": "browser.close", +-- "params": {} +-- } +-- BiDi driver error: +-- MkDriverError +-- { id = Just 3 +-- , error = UnsupportedOperation +-- , description = "The operation requested is not supported" +-- , message = +-- "Closing the browser in a session started with WebDriver classic is not supported. Use the WebDriver classic \"Delete Session\" command instead which will also close the browser." +-- , stacktrace = +-- Just +-- "RemoteError@chrome://remote/content/shared/RemoteError.sys.mjs:8:8\nWebDriverError@chrome://remote/content/shared/webdriver/Errors.sys.mjs:202:5\nUnsupportedOperationError@chrome://remote/content/shared/webdriver/Errors.sys.mjs:978:5\nclose@chrome://remote/content/webdriver-bidi/modules/root/browser.sys.mjs:120:13\nhandleCommand@chrome://remote/content/shared/messagehandler/MessageHandler.sys.mjs:282:33\nexecute@chrome://remote/content/shared/webdriver/Session.sys.mjs:410:32\nonPacket@chrome://remote/content/webdriver-bidi/WebDriverBiDiConnection.sys.mjs:236:37\nonMessage@chrome://remote/content/server/WebSocketTransport.sys.mjs:127:18\nhandleEvent@chrome://remote/content/server/WebSocketTransport.sys.mjs:109:14\n" +-- , extensions = MkEmptyResult { extensible = fromList [] } +-- } +browserCloseDemo :: BiDiDemo +browserCloseDemo = + demo "Browser - Close (CAUTION: Terminates Session)" action + where + -- will fail with: "Closing the browser in a session started with WebDriver classic is not supported." + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Getting final browser state before closing..." + finalWindows <- browserGetClientWindows + finalContexts <- browserGetUserContexts + logShow "Final client windows before close" finalWindows + logShow "Final user contexts before close" finalContexts + pause + + logTxt "Executing browser.close - this will end the session" + logTxt "This will fail because the session was created with webdriver http not BiDi" + closeResult <- browserClose + logShow "Browser close result" closeResult + + + diff --git a/test/BiDi/Demos/BrowsingContextDemos.hs b/test/BiDi/Demos/BrowsingContextDemos.hs new file mode 100644 --- /dev/null +++ b/test/BiDi/Demos/BrowsingContextDemos.hs @@ -0,0 +1,1019 @@ +module BiDi.Demos.BrowsingContextDemos where + +import BiDi.Actions (BiDiActions (..)) +import BiDi.DemoUtils +import Const (milliseconds) +import Data.Aeson (Value (Null), object, (.=)) +import Data.Text (Text) +import IOUtils (DemoActions (..)) +import TestData (contentPageUrl, framesUrl, loginUrl, navigation1Url, navigation2Url, navigation3Url, navigation4Url, navigation5Url, navigation6Url, nestedFramesUrl, scriptRealmUrl) +import WebDriverPreCore.BiDi.Protocol + ( Activate (..), + CaptureScreenshot (..), + ClipRectangle (..), + Close (..), + ContextTarget (..), + Create (..), + CreateType (..), + CreateUserContext (..), + Evaluate (..), + GetTree (..), + GetTreeResult (..), + HandleUserPrompt (..), + ImageFormat (..), + Info (..), + JSInt (..), + JSUInt (..), + LocateNodes (..), + LocateNodesResult (..), + Locator (..), + Navigate (..), + NodeRemoteValue (..), + Orientation (..), + PageRange (..), + Print (..), + PrintMargin (..), + PrintPage (..), + PrintResult (..), + ReadinessState (..), + Reload (..), + ScreenShotOrigin (..), + SetViewport (..), + SharedId (..), + SharedReference (..), + Target (..), + TraverseHistory (..), + Viewport (..), + ) +import Prelude hiding (log, putStrLn) + +-- >>> runDemo browsingContextCreateActivateCloseDemo +browsingContextCreateActivateCloseDemo :: BiDiDemo +browsingContextCreateActivateCloseDemo = + demo "Browsing Context - Create, Activate, Close" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "New browsing context - Tab" + let bcParams = + MkCreate + { createType = Tab, + background = False, + referenceContext = Nothing, + userContext = Nothing + } + bc <- browsingContextCreate bcParams + logShow "Browsing context - Tab" bc + pause + + logTxt "New browsing context - Window" + bcWin <- browsingContextCreate bcParams {createType = Window} + logShow "Browsing context - Window" bcWin + pause + + logTxt "New browsing context - Tab with reference context" + bcWithContext <- browsingContextCreate bcParams {referenceContext = Just bc} + logShow "Browsing context - Tab with reference context" bcWithContext + pause + + logTxt "New browsing context - Background" + bg <- + browsingContextCreate + bcParams + { background = True, + referenceContext = Just bcWin + } + logShow "Background browsing context created on front window" bg + pause + + logTxt "New user context" + uc <- + browserCreateUserContext + MkCreateUserContext + { insecureCerts = Nothing, + proxy = Nothing, + unhandledPromptBehavior = Nothing + } + logShow "User context created" uc + pause + + logTxt "New browsing context - Window with user context" + bcWinWithUC <- + browsingContextCreate + bcParams + { createType = Window, + userContext = Just uc + } + logShow "Browsing context - Window with user context" bcWinWithUC + pause + + logTxt "Activate initial browsing context" + o <- browsingContextActivate $ MkActivate bc + logShow "Activate result" o + pause + + logTxt "Close initial browsing context" + co <- + browsingContextClose $ + MkClose + { context = bc, + promptUnload = Nothing + } + logShow "Close result" co + pause + +-- >>> runDemo browsingContextCaptureScreenshotCloseDemo +browsingContextCaptureScreenshotCloseDemo :: BiDiDemo +browsingContextCaptureScreenshotCloseDemo = + demo "Browsing Context - Capture Screenshot, Close" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + logTxt "Capture screenshot - default" + screenshot <- browsingContextCaptureScreenshot $ MkCaptureScreenshot bc Nothing Nothing Nothing + logShow "Screenshot captured" screenshot + pause + + logTxt "Capture screenshot - document, format png" + screenshotDoc <- + browsingContextCaptureScreenshot $ + MkCaptureScreenshot + { context = bc, + origin = (Just Document), + format = + Just $ + MkImageFormat + { imageType = "image/png", + quality = Just 0.75 + }, + clip = Nothing + } + logShow "Screenshot captured" screenshotDoc + pause + + logTxt "Capture screenshot - viewport, clip" + screenshotViewport <- + browsingContextCaptureScreenshot $ + MkCaptureScreenshot + { context = bc, + origin = (Just Viewport), + format = Nothing, + clip = Just $ BoxClipRectangle {x = 0, y = 0, width = 300, height = 300} + } + logShow "Screenshot captured" screenshotViewport + pause + + logTxt "Close browsing context - unload prompt False" + co <- browsingContextClose $ MkClose {context = bc, promptUnload = Just False} + logShow "Close result" co + pause + +-- >>> runDemo browsingContextClosePromptUnloadDemo +browsingContextClosePromptUnloadDemo :: BiDiDemo +browsingContextClosePromptUnloadDemo = + demo "Browsing Context - Close with Unload Prompt" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + -- TODO :: promptUnload doesn't seem to do anything ?? + logTxt "Close browsing context - unload prompt True" + co <- browsingContextClose $ MkClose {context = bc, promptUnload = Just True} + logShow "Close result" co + pause + +-- >>> runDemo browsingContextGetTreeDemo +browsingContextGetTreeDemo :: BiDiDemo +browsingContextGetTreeDemo = + demo "Browsing Context - Get Tree" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + logTxt "Get browsing context tree - all" + tree <- browsingContextGetTree $ MkGetTree Nothing Nothing + logShow "Browsing context tree" tree + pause + + logTxt "Create opener browsing context (Window)" + openerContext <- newWindowContext utils bidi + + logTxt "Create opened browsing context (Tab with opener reference)" + openedContext <- + browsingContextCreate $ + MkCreate + { createType = Tab, + background = False, + referenceContext = Just openerContext, + userContext = Nothing + } + logShow "Opened browsing context" openedContext + pause + + logTxt "Get browsing context tree - WebDriver created contexts (originalOpener likely null)" + treeWithOpener <- + browsingContextGetTree + MkGetTree + { maxDepth = Nothing, + root = Nothing -- Get all contexts to see the relationship + } + logShow "Browsing context tree - WebDriver created (originalOpener should be null)" treeWithOpener + pause + + -- TODO: when using Scripts - get browsingContextGetTree with originalOpener + logTxt "NOTE: originalOpener is null because WebDriver.create doesn't set opener relationships" + logTxt "originalOpener is only set when web content opens windows via window.open(), not WebDriver commands" + pause + + logTxt "IMPORTANT: referenceContext does NOT create parent-child relationships!" + logTxt "Parent-child relationships only exist between main documents and their iframes" + logTxt "All WebDriver-created tabs/windows are top-level contexts with no parent" + pause + + logTxt "Demonstrating: All created contexts are top-level (no parent, no children)" + logTxt "Get tree from 'opener' context - will show NO children (not a parent)" + treeFromOpener <- + browsingContextGetTree + MkGetTree + { maxDepth = Nothing, + root = Just openerContext + } + logShow "Tree from opener context (no children expected)" treeFromOpener + pause + + logTxt "Get tree from 'opened' context - will show NO parent (top-level)" + treeFromOpened <- + browsingContextGetTree + MkGetTree + { maxDepth = Nothing, + root = Just openedContext + } + logShow "Tree from opened context (no parent expected)" treeFromOpened + pause + + logTxt "Get full tree - shows all top-level contexts as siblings" + fullTree <- + browsingContextGetTree + MkGetTree + { maxDepth = Nothing, + root = Nothing + } + logShow "Full tree (all contexts are top-level siblings)" fullTree + pause + + -- TODO: when using IFrames - get parent-child relationships + logTxt "To see parent-child relationships, you need:" + logTxt "1. Navigate to a page with iframes" + logTxt "2. The main document = parent, iframes = children" + logTxt "3. referenceContext is only for tab positioning, not hierarchy" + pause + +-- >>> runDemo browsingContextHandleUserPromptDemo +browsingContextHandleUserPromptDemo :: BiDiDemo +browsingContextHandleUserPromptDemo = + demo "Browsing Context - Handle User Prompt" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + logTxt "Test 1: Create and handle an alert dialog" + + scriptEvaluateNoWait $ + MkEvaluate + { expression = "alert('Hello from Pyrethrum BiDi!')", + target = + ContextTarget $ + MkContextTarget + { context = bc, + sandbox = Nothing + }, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + -- Wait for the alert to be displayed + -- in a production automation more sophisticated polling or event subscription would be used + pauseAtLeast $ 500 * milliseconds + + logTxt "Accept the alert dialog" + acceptResult <- + browsingContextHandleUserPrompt $ + MkHandleUserPrompt + { context = bc, + accept = Just True, + userText = Nothing + } + logShow "Alert accept result" acceptResult + pause + + logTxt "Test 2: Create and handle a confirm dialog" + scriptEvaluateNoWait $ + MkEvaluate + { expression = "confirm('Hello from Pyrethrum BiDi. Do you want to continue?')", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + -- Wait for the alert to be displayed (in a production automation more sophisticated polling must be used) + pauseAtLeast $ 500 * milliseconds + + logTxt "Dismiss the confirm dialog" + dismissResult <- + browsingContextHandleUserPrompt $ + MkHandleUserPrompt + { context = bc, + accept = Just False, + userText = Nothing + } + logShow "Confirm dismiss result" dismissResult + pause + + logTxt "Test 3: Create and handle a prompt dialog with user input" + scriptEvaluateNoWait $ + MkEvaluate + { expression = "prompt('What is your name?', 'Default Name')", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + -- Wait for the alert to be displayed (in a productions system, more sophisticated polling would be needed) + pauseAtLeast $ 500 * milliseconds + + logTxt "Accept prompt with custom text" + promptResult <- + browsingContextHandleUserPrompt $ + MkHandleUserPrompt + { context = bc, + accept = Just True, + userText = Just "John Doe from BiDi" + } + logShow "Prompt accept with text result" promptResult + pause + + logTxt "Test 4: Create and dismiss a prompt dialog" + scriptEvaluateNoWait $ + MkEvaluate + { expression = "prompt('Enter your age:')", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + -- Wait for the alert to be displayed (in a productions system, more sophisticated polling would be needed) + pauseAtLeast $ 500 * milliseconds + + logTxt "Dismiss the prompt dialog" + dismissPromptResult <- + browsingContextHandleUserPrompt $ + MkHandleUserPrompt + { context = bc, + accept = Just False, + userText = Nothing + } + logShow "Prompt dismiss result" dismissPromptResult + pause + +-- >>> runDemo browsingNavigateReloadTraverseHistoryDemo +browsingNavigateReloadTraverseHistoryDemo :: BiDiDemo +browsingNavigateReloadTraverseHistoryDemo = + demo "Browsing Context - Navigate, Reload, Traverse History" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + nav1 <- navigation1Url + logTxt "Navigate to Navigation 1" + navResult1 <- browsingContextNavigate $ MkNavigate {context = bc, url = nav1, wait = Just Complete} + logShow "Navigation result - Navigation 1" navResult1 + pause + + nav2 <- navigation2Url + logTxt "Navigate to Navigation 2" + navResult2 <- browsingContextNavigate $ MkNavigate {context = bc, url = nav2, wait = Just Interactive} + logShow "Navigation result - Navigation 2" navResult2 + pause + + nav3 <- navigation3Url + logTxt "Navigate to Navigation 3" + navResult3 <- browsingContextNavigate $ MkNavigate {context = bc, url = nav3, wait = Just Complete} + logShow "Navigation result - Navigation 3" navResult3 + pause + + nav4 <- navigation4Url + logTxt "Navigate to Navigation 4" + navResult4 <- browsingContextNavigate $ MkNavigate {context = bc, url = nav4, wait = Just Complete} + logShow "Navigation result - Navigation 4" navResult4 + pause + + logTxt "Reload current page (Navigation 4) - default options" + reloadResult1 <- browsingContextReload $ MkReload {context = bc, ignoreCache = Nothing, wait = Just Complete} + logShow "Reload result - default" reloadResult1 + pause + + nav5 <- navigation5Url + logTxt "Navigate to Navigation 5" + navResult5 <- browsingContextNavigate $ MkNavigate {context = bc, url = nav5, wait = Just Complete} + logShow "Navigation result - Navigation 5" navResult5 + pause + + -- ignore cache not supported yet in geckodriver + -- logTxt "Reload current page (Navigation 5) - ignore cache" + -- reloadResult2 <- browsingContextReload $ MkReload {context = bc, ignoreCache = Just True, wait = Nothing} + -- logShow "Reload result - ignore cache" reloadResult2 + -- pause + + nav6 <- navigation6Url + logTxt "Navigate to Navigation 6" + navResult6 <- browsingContextNavigate $ MkNavigate {context = bc, url = nav6, wait = Just Complete} + logShow "Navigation result - Navigation 6" navResult6 + pause + + logTxt "Reload current page (Navigation 6) - wait for complete" + reloadResult3 <- browsingContextReload $ MkReload {context = bc, ignoreCache = Nothing, wait = Just Complete} + logShow "Reload result - wait complete" reloadResult3 + pause + + logTxt "Test history traversal - Go back 1 step (to Navigation 5)" + historyResult1 <- browsingContextTraverseHistory $ MkTraverseHistory {context = bc, delta = MkJSInt (-1)} + logShow "History traversal result - back 1" historyResult1 + -- there is an issue in chromedriver where navigating back too quickly causes a failure + -- would need a better solution in production code (retries, waits, event listening, etc ) + pauseAtLeast (100 * milliseconds) + + logTxt "Go back 2 more steps (to Navigation 3)" + historyResult2 <- browsingContextTraverseHistory $ MkTraverseHistory {context = bc, delta = MkJSInt (-2)} + logShow "History traversal result - back 2" historyResult2 + pauseAtLeast (100 * milliseconds) + + logTxt "Go back 1 more step (to Navigation 2)" + historyResult3 <- browsingContextTraverseHistory $ MkTraverseHistory {context = bc, delta = MkJSInt (-1)} + logShow "History traversal result - back 1" historyResult3 + pauseAtLeast (100 * milliseconds) + + logTxt "Go forward 1 step (to Navigation 3)" + historyResult4 <- browsingContextTraverseHistory $ MkTraverseHistory {context = bc, delta = MkJSInt 1} + logShow "History traversal result - forward 1" historyResult4 + pauseAtLeast (100 * milliseconds) + + logTxt "Go forward 2 steps (to Navigation 5)" + historyResult5 <- browsingContextTraverseHistory $ MkTraverseHistory {context = bc, delta = MkJSInt 2} + logShow "History traversal result - forward 2" historyResult5 + pauseAtLeast (100 * milliseconds) + + logTxt "Go forward 1 step (to Navigation 6)" + historyResult6 <- browsingContextTraverseHistory $ MkTraverseHistory {context = bc, delta = MkJSInt 1} + logShow "History traversal result - forward 1" historyResult6 + pauseAtLeast (100 * milliseconds) + + logTxt "Final navigation - back to Navigation 1" + navResultFinal <- browsingContextNavigate $ MkNavigate {context = bc, url = nav1, wait = Just Complete} + logShow "Navigation result - back to Navigation 1" navResultFinal + pause + +-- >>> runDemo browsingContextLocateNodesDemo +browsingContextLocateNodesDemo :: BiDiDemo +browsingContextLocateNodesDemo = + demo "Browsing Context - Locate Nodes with All Selectors and Options" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + loginPage <- loginUrl + logTxt "Navigate to Login Page for comprehensive selector testing" + navResult1 <- browsingContextNavigate $ MkNavigate {context = bc, url = loginPage, wait = Just Complete} + logShow "Navigation result - Login page" navResult1 + pause + + -- Test CSS Selector + logTxt "Test 1: CSS Selector - Find username input field" + cssResult <- + browsingContextLocateNodes $ + MkLocateNodes + { context = bc, + locator = CSS {value = "#username"}, + maxNodeCount = Nothing, + serializationOptions = Nothing, + startNodes = Nothing + } + logShow "CSS Selector result - #username" cssResult + pause + + logTxt "Test 2: CSS Selector - Find all input elements" + cssAllInputs <- + browsingContextLocateNodes $ + MkLocateNodes + { context = bc, + locator = CSS {value = "input"}, + maxNodeCount = Just (MkJSUInt 5), + serializationOptions = Nothing, + startNodes = Nothing + } + logShow "CSS Selector result - all inputs (max 5)" cssAllInputs + pause + + -- Test XPath Selector + logTxt "Test 3: XPath Selector - Find password field by attribute" + xpathResult <- + browsingContextLocateNodes $ + MkLocateNodes + { context = bc, + locator = XPath {value = "//input[@name='password']"}, + maxNodeCount = Nothing, + serializationOptions = Nothing, + startNodes = Nothing + } + logShow "XPath Selector result - password field" xpathResult + pause + + logTxt "Test 4: XPath Selector - Find login button by text content" + xpathButtonResult <- + browsingContextLocateNodes $ + MkLocateNodes + { context = bc, + locator = XPath {value = "//button[contains(text(), 'Login')]"}, + maxNodeCount = Nothing, + serializationOptions = Nothing, + startNodes = Nothing + } + logShow "XPath Selector result - login button" xpathButtonResult + pause + + -- Test SerializationOptions with different depths + logTxt "Test 7: CSS Selector with SerializationOptions - Deep DOM traversal" + cssWithSerializationResult <- + browsingContextLocateNodes $ + MkLocateNodes + { context = bc, + locator = CSS {value = "form"}, + maxNodeCount = Nothing, + serializationOptions = + Just $ + object + [ "maxDomDepth" .= (3 :: Int), + "maxObjectDepth" .= Null, + "includeShadowTree" .= ("none" :: Text) + ], + startNodes = Nothing + } + logShow "CSS Selector with SerializationOptions - form with depth 3" cssWithSerializationResult + pause + + logTxt "Test 8: CSS Selector with different SerializationOptions - Shallow traversal" + cssShallowResult <- + browsingContextLocateNodes $ + MkLocateNodes + { context = bc, + locator = CSS {value = "body"}, + maxNodeCount = Nothing, + serializationOptions = + Just $ + object + [ "maxDomDepth" .= (1 :: Int), + "maxObjectDepth" .= (1 :: Int), + "includeShadowTree" .= ("open" :: Text) + ], + startNodes = Nothing + } + logShow "CSS Selector with SerializationOptions - body with depth 1" cssShallowResult + pause + + -- Navigate to a page with more accessibility content for better testing + framesPage <- framesUrl + logTxt "Navigate to Frames page for accessibility and context testing" + navResult2 <- browsingContextNavigate $ MkNavigate {context = bc, url = framesPage, wait = Just Complete} + logShow "Navigation result - Frames page" navResult2 + pause + + -- Test Accessibility Selector + logTxt "Test 9: Accessibility Selector - Find elements by role" + accessibilityRoleResult <- + browsingContextLocateNodes $ + MkLocateNodes + { context = bc, + locator = + Accessibility + { name = Nothing, + role = Just "link" + }, + maxNodeCount = Nothing, + serializationOptions = Nothing, + startNodes = Nothing + } + logShow "Accessibility Selector result - role 'link'" accessibilityRoleResult + pause + + logTxt "Test 10: Accessibility Selector - Find elements by accessible name" + accessibilityNameResult <- + browsingContextLocateNodes $ + MkLocateNodes + { context = bc, + locator = + Accessibility + { name = Just "iFrame", + role = Nothing + }, + maxNodeCount = Nothing, + serializationOptions = Nothing, + startNodes = Nothing + } + logShow "Accessibility Selector result - name 'iFrame'" accessibilityNameResult + pause + + logTxt "Test 11: Accessibility Selector - Find elements by both name and role" + accessibilityBothResult <- + browsingContextLocateNodes $ + MkLocateNodes + { context = bc, + locator = + Accessibility + { name = Just "Nested Frames", + role = Just "link" + }, + maxNodeCount = Nothing, + serializationOptions = Nothing, + startNodes = Nothing + } + logShow "Accessibility Selector result - name 'Nested Frames' and role 'link'" accessibilityBothResult + pause + + -- Test startNodes functionality + logTxt "Test 12: Demonstrating startNodes - First find a parent element, then search within it" + parentResult <- + browsingContextLocateNodes $ + MkLocateNodes + { context = bc, + locator = CSS {value = "div.example"}, + maxNodeCount = Nothing, + serializationOptions = Nothing, + startNodes = Nothing + } + logShow "Parent element search - div.example" parentResult + pause + + -- Extract sharedId from first result to use as startNode + case parentResult of + MkLocateNodesResult nodes -> case nodes of + (MkNodeRemoteValue {sharedId = Just (MkSharedId nodeId)} : _) -> do + logTxt "Test 13: Using startNodes - Search for links within the parent element" + startNodesResult <- + browsingContextLocateNodes $ + MkLocateNodes + { context = bc, + locator = CSS {value = "a"}, + maxNodeCount = Nothing, + serializationOptions = Nothing, + startNodes = Just [MkSharedReference {sharedId = MkSharedId {id = nodeId}, handle = Nothing, extensions = Nothing}] + } + logShow "StartNodes result - links within div.example" startNodesResult + pause + + logTxt "Test 14: Using startNodes with different selector - Find all text content" + startNodesTextResult <- + browsingContextLocateNodes $ + MkLocateNodes + { context = bc, + locator = XPath {value = ".//text()[normalize-space()]"}, + maxNodeCount = Just (MkJSUInt 5), + serializationOptions = + Just $ + object + [ "maxDomDepth" .= (2 :: Int), + "maxObjectDepth" .= Null, + "includeShadowTree" .= ("none" :: Text) + ], + startNodes = Just [MkSharedReference {sharedId = MkSharedId {id = nodeId}, handle = Nothing, extensions = Nothing}] + } + logShow "StartNodes with XPath - text nodes within parent (max 5)" startNodesTextResult + pause + _ -> do + logTxt "No sharedId found in first result, skipping startNodes test" + pause + + -- Navigate to a simpler page for Context selector test + nestedFrames <- nestedFramesUrl + logTxt "Navigate to Nested Frames for Context selector testing" + navResult3 <- browsingContextNavigate $ MkNavigate {context = bc, url = nestedFrames, wait = Just Complete} + logShow "Navigation result - Nested Frames page" navResult3 + pause + + -- Get child browsing contexts (frames) for Context selector + logTxt "Get browsing context tree to find child frames" + treeResult <- browsingContextGetTree $ MkGetTree Nothing Nothing + logShow "Browsing context tree" treeResult + pause + +-- >>> runDemo browsingContextContextLocatorDemo +browsingContextContextLocatorDemo :: BiDiDemo +browsingContextContextLocatorDemo = + demo "Browsing Context - Context Locator" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + scriptRealmPage <- scriptRealmUrl + logTxt "Navigate to Script Realm page with iframe" + _ <- browsingContextNavigate $ MkNavigate {context = bc, url = scriptRealmPage, wait = Just Complete} + pause + + -- Click the button to create an iframe using script.evaluate + logTxt "Click button to create iframe" + _ <- scriptEvaluate $ + MkEvaluate + { expression = "document.getElementById('createIframe').click()", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + pauseAtLeast (500 * milliseconds) + + -- Get the tree to find the iframe's browsing context + logTxt "Get tree to find iframe browsing context" + MkGetTreeResult {contexts} <- browsingContextGetTree $ MkGetTree {maxDepth = Nothing, root = Just bc} + logShow "Tree result" contexts + + case contexts of + (MkInfo {children = Just (iframeInfo : _)} : _) -> do + let iframeContext = iframeInfo.context + logShow "Found iframe context" iframeContext + + -- Use Context locator to locate nodes within the iframe + logTxt "Using Context locator to find elements in iframe" + contextResult <- + browsingContextLocateNodes $ + MkLocateNodes + { context = bc, + locator = Context {context = iframeContext}, + maxNodeCount = Nothing, + serializationOptions = Nothing, + startNodes = Nothing + } + logShow "Context locator result" contextResult + pause + _ -> logTxt "No iframe child context found" + +-- >>> runDemo browsingContextPrintDemo +browsingContextPrintDemo :: BiDiDemo +browsingContextPrintDemo = + demo "Browsing Context - Print" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + contentPage <- contentPageUrl + logTxt "Navigate to Content Page for print testing" + navResult <- browsingContextNavigate $ MkNavigate {context = bc, url = contentPage, wait = Just Complete} + logShow "Navigation result" navResult + pause + + logTxt "Test 1: Print - Default settings" + printDefault <- browsingContextPrint $ MkPrint {context = bc, background = Nothing, margin = Nothing, orientation = Nothing, page = Nothing, pageRanges = Nothing, scale = Nothing, shrinkToFit = Nothing} + logTxt $ "Print result - default settings: " <> printDefault.base64Text + pause + + logTxt "Test 2: Print - Portrait orientation with custom margins" + printPortraitMargins <- + browsingContextPrint $ + MkPrint + { context = bc, + background = Just False, + margin = + Just $ + MkPrintMargin + { bottom = Just 2.0, + left = Just 1.5, + right = Just 1.5, + top = Just 2.0 + }, + orientation = Just Portrait, + page = Nothing, + pageRanges = Nothing, + scale = Nothing, + shrinkToFit = Nothing + } + logTxt $ "Print result - portrait with margins: " <> printPortraitMargins.base64Text + pause + + logTxt "Test 3: Print - Landscape orientation with custom page size" + printLandscapePage <- + browsingContextPrint $ + MkPrint + { context = bc, + background = Just True, + margin = Nothing, + orientation = Just Landscape, + page = + Just $ + MkPrintPage + { height = Just 29.7, -- A4 height in cm + width = Just 21.0 -- A4 width in cm + }, + pageRanges = Nothing, + scale = Nothing, + shrinkToFit = Nothing + } + logTxt $ "Print result - landscape with page size: " <> printLandscapePage.base64Text + pause + + logTxt "Test 4: Print - Custom scale and shrink to fit" + printScaled <- + browsingContextPrint $ + MkPrint + { context = bc, + background = Nothing, + margin = Nothing, + orientation = Nothing, + page = Nothing, + pageRanges = Nothing, + scale = Just 0.8, + shrinkToFit = Just True + } + logTxt $ "Print result - scaled 80%: " <> printScaled.base64Text + pause + + logTxt "Test 5: Print with pageRanges - Only first page" + printFirstPage <- + browsingContextPrint $ + MkPrint + { context = bc, + background = Nothing, + margin = Nothing, + orientation = Nothing, + page = Nothing, + pageRanges = Just [Page 1], + scale = Nothing, + shrinkToFit = Nothing + } + logTxt $ "Print result - first page only: " <> printFirstPage.base64Text + pause + + logTxt "Test 6: Print with pageRanges - Pages 1-2" + printPageRange <- + browsingContextPrint $ + MkPrint + { context = bc, + background = Nothing, + margin = Nothing, + orientation = Nothing, + page = Nothing, + pageRanges = Just $ [Range {fromPage = 1, toPage = 2}], + scale = Nothing, + shrinkToFit = Nothing + } + logTxt $ "Print result - pages 1-2: " <> printPageRange.base64Text + pause + + logTxt "Test 7: Print with pageRanges - Specific pages (1,3)" + printSpecificPages <- + browsingContextPrint $ + MkPrint + { context = bc, + background = Nothing, + margin = Nothing, + orientation = Nothing, + page = Nothing, + pageRanges = Just [Range 1 2, Page 3], + scale = Nothing, + shrinkToFit = Nothing + } + logTxt $ "Print result - pages 1 and 3: " <> printSpecificPages.base64Text + pause + +-- >>> runDemo browsingContextSetViewportDemo +browsingContextSetViewportDemo :: BiDiDemo +browsingContextSetViewportDemo = + demo "Browsing Context - Set Viewport" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + contentPage <- contentPageUrl + logTxt "Navigate to Content Page for viewport testing" + navResult <- browsingContextNavigate $ MkNavigate {context = bc, url = contentPage, wait = Just Complete} + logShow "Navigation result" navResult + pause + + logTxt "Test 1: Set Viewport - Standard desktop size" + setViewportDesktop <- + browsingContextSetViewport $ + MkSetViewport + { context = Just bc, + viewport = + Just $ + Just $ + MkViewport + { width = MkJSUInt 1920, + height = MkJSUInt 1080 + }, + devicePixelRatio = Nothing, + userContexts = Nothing + } + logShow "Set viewport result - desktop" setViewportDesktop + pause + + logTxt "Test 2: Set Viewport - Mobile size with device pixel ratio" + setViewportMobile <- + browsingContextSetViewport $ + MkSetViewport + { context = Just bc, + viewport = + Just $ + Just $ + MkViewport + { width = MkJSUInt 375, + height = MkJSUInt 812 + }, + devicePixelRatio = Just (Just 2.0), + userContexts = Nothing + } + logShow "Set viewport result - mobile" setViewportMobile + pause + + logTxt "Test 3: Set Viewport - Tablet size" + setViewportTablet <- + browsingContextSetViewport $ + MkSetViewport + { context = Just bc, + viewport = + Just $ + Just $ + MkViewport + { width = MkJSUInt 768, + height = MkJSUInt 1024 + }, + devicePixelRatio = Nothing, + userContexts = Nothing + } + logShow "Set viewport result - tablet" setViewportTablet + pause + + logTxt "Test 4: Print after viewport changes - Should reflect new dimensions" + printAfterViewport <- + browsingContextPrint $ + MkPrint + { context = bc, + background = Nothing, + margin = Nothing, + orientation = Just Portrait, + page = Nothing, + pageRanges = Nothing, + scale = Just 1.0, + shrinkToFit = Just False + } + logTxt $ "Print result - after viewport changes: " <> printAfterViewport.base64Text + pause + +-- >>> runDemo browsingContextSetViewportResetDemo +browsingContextSetViewportResetDemo :: BiDiDemo +browsingContextSetViewportResetDemo = + demo "Browsing Context - Set Viewport Reset to Null" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + contentPage <- contentPageUrl + logTxt "Navigate to Content Page for viewport reset testing" + navResult <- browsingContextNavigate $ MkNavigate {context = bc, url = contentPage, wait = Just Complete} + logShow "Navigation result" navResult + pause + + logTxt "Test 1: Set Viewport - Custom size first" + setViewportCustom <- + browsingContextSetViewport $ + MkSetViewport + { context = Just bc, + viewport = + Just $ + Just $ + MkViewport + { width = MkJSUInt 800, + height = MkJSUInt 600 + }, + devicePixelRatio = Just (Just 1.5), + userContexts = Nothing + } + logShow "Set viewport result - custom size" setViewportCustom + pause + + logTxt "Test 1: Set Viewport - Reset to null (default)" + setViewportNull <- + browsingContextSetViewport $ + MkSetViewport + { context = Just bc, + viewport = Just Nothing, -- Explicitly set to null + devicePixelRatio = Just Nothing, -- Reset device pixel ratio too + userContexts = Nothing + } + logShow "Set viewport result - reset to null" setViewportNull + pause diff --git a/test/BiDi/Demos/BrowsingContextEventDemos.hs b/test/BiDi/Demos/BrowsingContextEventDemos.hs new file mode 100644 --- /dev/null +++ b/test/BiDi/Demos/BrowsingContextEventDemos.hs @@ -0,0 +1,749 @@ +module BiDi.Demos.BrowsingContextEventDemos where + +import BiDi.Actions (BiDiActions (..)) +import BiDi.DemoUtils +import Const (Timeout (..), milliseconds, second) +import Data.Text (unpack) +import IOUtils (DemoActions (..)) +import TestData (checkboxesUrl, downloadLinkUrl, fragmentUrl, promptUrl, slowLoadUrl, textAreaUrl) +import Utils (txt) +import WebDriverPreCore.BiDi.Protocol + ( BrowsingContext (..), + Close (..), + ContextTarget (..), + Create (..), + CreateType (..), + CreateUserContext (..), + Evaluate (..), + HandleUserPrompt (..), + KnownSubscriptionType (..), + Navigate (..), + Target (..), + URL (..), + UserContext (..), + ) +import Prelude hiding (log, putStrLn) + +-- >>> runDemo browsingContextEventDemo +browsingContextEventDemo :: BiDiDemo +browsingContextEventDemo = + demo "Browsing Context Create - Subscribe Unsubscribe" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + subId <- subscribeBrowsingContextCreated (logShow "Event Subscription Fired: browsingContext.contextCreated") + logShow "Subscription id" subId + + logTxt "New browsing context - Tab" + let bcParams = + MkCreate + { createType = Tab, + background = False, + referenceContext = Nothing, + userContext = Nothing + } + bc <- browsingContextCreate bcParams + logShow "Browsing context - Tab II" bc + + logShow "Unsubscribing from browsingContext.contextCreated event" subId + unsubscribe subId + + bc2 <- browsingContextCreate bcParams + logShow "Browsing context - Tab III (No Event Triggered)" bc2 + pause + +-- >>> runDemo browsingContextEventDemoMulti +browsingContextEventDemoMulti :: BiDiDemo +browsingContextEventDemoMulti = + demo "Browsing Context Events - Subscribe Unsubscribe Using subscribeMany" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + subId <- + subscribeMany + [BrowsingContextContextCreated, BrowsingContextContextDestroyed] + (logShow "Event Subscription Fired: browsingContext.contextCreated or contextDestroyed") + + logShow "Subscription id" subId + + logTxt "New browsing context - Tab" + let bcParams = + MkCreate + { createType = Tab, + background = False, + referenceContext = Nothing, + userContext = Nothing + } + bc <- browsingContextCreate bcParams + logShow "Browsing context - Tab II" bc + + logShow "Closing browsing context - Tab II" bc + browsingContextClose + MkClose + { context = bc, + promptUnload = Nothing + } + + logShow "Unsubscribing from events" subId + unsubscribe subId + + bc2 <- browsingContextCreate bcParams + logShow "Browsing context created - Tab III (No Event Triggered)" bc2 + + browsingContextClose $ MkClose bc2 Nothing + logShow "Browsing context destroyed - Tab III (No Event Triggered)" bc2 + +-- >>> runDemo browsingContextEventDemoFilteredSubscriptions +browsingContextEventDemoFilteredSubscriptions :: BiDiDemo +browsingContextEventDemoFilteredSubscriptions = + demo "Browsing Context Events - Filtered Navigation Subscriptions" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Creating two browsing contexts" + + let createParams = + MkCreate + { createType = Tab, + background = False, + referenceContext = Nothing, + userContext = Nothing + } + + -- Create first browsing context + bc1 <- browsingContextCreate createParams + logShow "Created browsing context 1" bc1 + + -- Create second browsing context + bc2 <- browsingContextCreate createParams + logShow "Created browsing context 2" bc2 + + logTxt "Subscribing to navigationStarted events only for browsing context 1" + + -- Subscribe to navigationStarted events only for parentContext1 + subId <- + subscribeBrowsingContextNavigationStarted' [bc1] [] $ + logShow $ + "Navigation Started Event Fired (should only fire for browsing context 1: " <> bc1.context <> ")" + logShow "Subscribed to navigationStarted for browsing context 1" subId + pause + + logTxt "Navigating both contexts to different URLs" + + -- Navigate browsing context 1 (should trigger event) + chkBxsUrl <- checkboxesUrl + logTxt "Navigating browsing context 1 to checkboxes.html (SHOULD trigger event)" + browsingContextNavigate $ MkNavigate bc1 chkBxsUrl Nothing + pause + + logTxt "Resubscribe singleton and many filtered by bc1 (should not fire)" + + subIdre <- + subscribeBrowsingContextNavigationStarted' [bc1] [] $ + \_n -> error $ "Navigation Started Event Fired (should only fire for browsing context 1 this should not happen filtering on bc1: " <> unpack bc1.context <> ")" + logShow "Subscribed to navigationStarted for browsing context 1" subIdre + pause + + subIdm <- + subscribeMany' + [bc1] + [] + [BrowsingContextContextCreated, BrowsingContextContextDestroyed] + (logShow "Event Subscription Fired: browsingContext.contextCreated or contextDestroyed") + + logShow "Subscribed to multi navigation started for browsing context 1" subIdm + + -- Navigate browsing context 2 (should NOT trigger event) + txturl <- textAreaUrl + logTxt "Navigating browsing context 2 to textArea.html (should NOT trigger event)" + browsingContextNavigate $ + MkNavigate + { context = bc2, + url = txturl, + wait = Nothing + } + + -- make sure negative tests have time to fail + pauseAtLeast $ 500 * milliseconds + +-- >>> runDemo browsingContextEventDemoUserContextFiltered +browsingContextEventDemoUserContextFiltered :: BiDiDemo +browsingContextEventDemoUserContextFiltered = + demo "Browsing Context Events - Filtered User Context Subscriptions" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Creating two user contexts" + uc1 <- + browserCreateUserContext + MkCreateUserContext + { insecureCerts = Nothing, + proxy = Nothing, + unhandledPromptBehavior = Nothing + } + logShow "Created user context 1" uc1 + + uc2 <- + browserCreateUserContext + MkCreateUserContext + { insecureCerts = Nothing, + proxy = Nothing, + unhandledPromptBehavior = Nothing + } + logShow "Created user context 2" uc2 + + logTxt "Subscribing to contextCreated events only for user context 1" + subId <- + subscribeBrowsingContextCreated' [] [uc1] $ + logShow $ + "Context Created Event Fired - should only fire for user context: " <> txt uc1.userContext + logShow "Subscribed to contextCreated for user context 1" subId + pause + + logTxt "Creating browsing contexts in both user contexts" + + logTxt "Creating browsing context in user context 1 (SHOULD trigger event)" + let createParams1 = + MkCreate + { createType = Tab, + background = False, + referenceContext = Nothing, + userContext = Just uc1 + } + bc1 <- browsingContextCreate createParams1 + logShow "Created browsing context 1" bc1 + pause + + logTxt "Creating browsing context in user context 2 (should NOT trigger event)" + let createParams2 = + MkCreate + { createType = Tab, + background = False, + referenceContext = Nothing, + userContext = Just uc2 + } + bc2 <- browsingContextCreate createParams2 + logShow "Created browsing context 2" bc2 + pause + + logShow "Unsubscribing from events" subId + unsubscribe subId + + logTxt "Creating browsing context after unsubscribe (should NOT trigger event)" + bc4 <- browsingContextCreate createParams1 + logShow "Created browsing context 4 (no event)" bc4 + + -- Navigate browsing context 1 (should trigger event) + chkBxsUrl <- checkboxesUrl + logTxt "Navigating browsing context 1 to checkboxes.html (SHOULD trigger event)" + browsingContextNavigate $ MkNavigate bc1 chkBxsUrl Nothing + pause + +-- >>> runDemo browsingContextEventCreateDestroy +browsingContextEventCreateDestroy :: BiDiDemo +browsingContextEventCreateDestroy = + demo "Browsing Context Events - Created and Destroyed" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Subscribe to ContextCreated event" + (createdEventFired, waitCreateEventFired) <- timeLimitLog BrowsingContextContextCreated + subscribeBrowsingContextCreated createdEventFired + + (manyCreatedEventFired, waitManyCreatedEventFired) <- timeLimitLogMany BrowsingContextContextCreated + subscribeMany [BrowsingContextContextCreated] manyCreatedEventFired + + logTxt "Creating a browsing context" + let createParams = + MkCreate + { createType = Tab, + background = False, + referenceContext = Nothing, + userContext = Nothing + } + bc <- browsingContextCreate createParams + logShow "Created browsing context" bc + + sequence_ + [ waitCreateEventFired, + waitManyCreatedEventFired + ] + + logTxt "Subscribe to ContextDestroyed event" + + (destroyedEventFired, waitDestroyedEventFired) <- timeLimitLog BrowsingContextContextDestroyed + subscribeBrowsingContextDestroyed destroyedEventFired + + (manyDestroyedEventFired, waitManyDestroyedEventFired) <- timeLimitLogMany BrowsingContextContextDestroyed + subscribeMany [BrowsingContextContextDestroyed] manyDestroyedEventFired + + logTxt "Closing the browsing context" + browsingContextClose $ MkClose bc Nothing + logShow "Closed browsing context" bc + + sequence_ + [ waitDestroyedEventFired, + waitManyDestroyedEventFired + ] + +-- >>> runDemo browsingContextEventNavigationLifecycle +browsingContextEventNavigationLifecycle :: BiDiDemo +browsingContextEventNavigationLifecycle = + demo "Browsing Context Events - Navigation Lifecycle (Started, Committed, DomContentLoaded, Load)" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + logTxt "Subscribe to navigation lifecycle events" + + (startedEventFired, waitStartedEventFired) <- timeLimitLog BrowsingContextNavigationStarted + subscribeBrowsingContextNavigationStarted startedEventFired + + (manyStartedEventFired, waitManyStartedEventFired) <- timeLimitLogMany BrowsingContextNavigationStarted + subscribeMany [BrowsingContextNavigationStarted] manyStartedEventFired + + (committedEventFired, waitCommittedEventFired) <- timeLimitLog BrowsingContextNavigationCommitted + subscribeBrowsingContextNavigationCommitted committedEventFired + + (manyCommittedEventFired, waitManyCommittedEventFired) <- timeLimitLogMany BrowsingContextNavigationCommitted + subscribeMany [BrowsingContextNavigationCommitted] manyCommittedEventFired + + (domContentLoadedEventFired, waitDomContentLoadedEventFired) <- timeLimitLog BrowsingContextDomContentLoaded + subscribeBrowsingContextDomContentLoaded domContentLoadedEventFired + + (manyDomContentLoadedEventFired, waitManyDomContentLoadedEventFired) <- timeLimitLogMany BrowsingContextDomContentLoaded + subscribeMany [BrowsingContextDomContentLoaded] manyDomContentLoadedEventFired + + (loadEventFired, waitLoadEventFired) <- timeLimitLog BrowsingContextLoad + subscribeBrowsingContextLoad loadEventFired + + (manyLoadEventFired, waitManyLoadEventFired) <- timeLimitLogMany BrowsingContextLoad + subscribeMany [BrowsingContextLoad] manyLoadEventFired + + logTxt "Navigating to checkboxes page" + url <- checkboxesUrl + bc <- rootContext utils bidi + browsingContextNavigate $ MkNavigate bc url Nothing + + sequence_ + [ waitStartedEventFired, + waitManyStartedEventFired, + waitCommittedEventFired, + waitManyCommittedEventFired, + waitDomContentLoadedEventFired, + waitManyDomContentLoadedEventFired, + waitLoadEventFired, + waitManyLoadEventFired + ] + +-- >>> runDemo browsingContextEventFragmentNavigation +browsingContextEventFragmentNavigation :: BiDiDemo +browsingContextEventFragmentNavigation = + demo "Browsing Context Events - Fragment Navigation" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + logTxt "Navigate to fragment page" + url <- fragmentUrl + bc <- rootContext utils bidi + browsingContextNavigate $ MkNavigate bc url Nothing + pause + + logTxt "Subscribe to FragmentNavigated event" + + (fragmentEventFired, waitFragmentEventFired) <- timeLimitLog BrowsingContextFragmentNavigated + subscribeBrowsingContextFragmentNavigated fragmentEventFired + + (manyFragmentEventFired, waitManyFragmentEventFired) <- timeLimitLogMany BrowsingContextFragmentNavigated + subscribeMany [BrowsingContextFragmentNavigated] manyFragmentEventFired + + logTxt "Navigate to fragment #section2" + browsingContextNavigate $ MkNavigate {context = bc, url = MkUrl (url.url <> "#section2"), wait = Nothing} + + sequence_ + [ waitFragmentEventFired, + waitManyFragmentEventFired + ] + +-- >>> runDemo browsingContextEventUserPrompts +browsingContextEventUserPrompts :: BiDiDemo +browsingContextEventUserPrompts = + demo "Browsing Context Events - User Prompt Opened and Closed" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + logTxt "Navigate to prompt page" + url <- promptUrl + bc <- rootContext utils bidi + browsingContextNavigate $ MkNavigate bc url Nothing + pause + + logTxt "Subscribe to UserPromptOpened event" + + (openedEventFired, waitOpenedEventFired) <- timeLimitLog BrowsingContextUserPromptOpened + subscribeBrowsingContextUserPromptOpened openedEventFired + + (manyOpenedEventFired, waitManyOpenedEventFired) <- timeLimitLogMany BrowsingContextUserPromptOpened + subscribeMany [BrowsingContextUserPromptOpened] manyOpenedEventFired + + logTxt "Click alert button to trigger prompt" + scriptEvaluateNoWait $ + MkEvaluate + { expression = "document.getElementById('alertBtn').click()", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + + sequence_ + [ waitOpenedEventFired, + waitManyOpenedEventFired + ] + + logTxt "Subscribe to UserPromptClosed event" + + (closedEventFired, waitClosedEventFired) <- timeLimitLog BrowsingContextUserPromptClosed + subscribeBrowsingContextUserPromptClosed closedEventFired + + (manyClosedEventFired, waitManyClosedEventFired) <- timeLimitLogMany BrowsingContextUserPromptClosed + subscribeMany [BrowsingContextUserPromptClosed] manyClosedEventFired + + pauseAtLeast $ 500 * milliseconds + logTxt "Accept the alert prompt" + browsingContextHandleUserPrompt $ + MkHandleUserPrompt + { context = bc, + accept = Just True, + userText = Nothing + } + + sequence_ + [ waitClosedEventFired, + waitManyClosedEventFired + ] + +-- >>> runDemo browsingContextEventUserPromptsVariants +browsingContextEventUserPromptsVariants :: BiDiDemo +browsingContextEventUserPromptsVariants = + demo "Browsing Context Events - User Prompt Types (Alert, Confirm, Prompt)" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + logTxt "Navigate to prompt page" + url <- promptUrl + bc <- rootContext utils bidi + browsingContextNavigate $ MkNavigate bc url Nothing + pause + + logTxt "Subscribe to UserPromptOpened and UserPromptClosed events" + subscribeBrowsingContextUserPromptOpened $ logShow "UserPromptOpened" + subscribeBrowsingContextUserPromptClosed $ logShow "UserPromptClosed" + + -- Test Alert + logTxt "Testing Alert prompt" + scriptEvaluateNoWait $ + MkEvaluate + { expression = "alert('Alert message')", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + pauseAtLeast $ 500 * milliseconds + browsingContextHandleUserPrompt $ MkHandleUserPrompt bc (Just True) Nothing + pause + + -- Test Confirm - Accept + logTxt "Testing Confirm prompt - Accept" + scriptEvaluateNoWait $ + MkEvaluate + { expression = "confirm('Confirm message')", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + pauseAtLeast $ 500 * milliseconds + browsingContextHandleUserPrompt $ MkHandleUserPrompt bc (Just True) Nothing + pause + + -- Test Confirm - Dismiss + logTxt "Testing Confirm prompt - Dismiss" + scriptEvaluateNoWait $ + MkEvaluate + { expression = "confirm('Confirm dismiss message')", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + pauseAtLeast $ 500 * milliseconds + browsingContextHandleUserPrompt $ MkHandleUserPrompt bc (Just False) Nothing + pause + + -- Test Prompt - with user text + logTxt "Testing Prompt with user text" + scriptEvaluateNoWait $ + MkEvaluate + { expression = "prompt('Enter your name:', 'default')", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + -- TODO: get rid of pauseAtleast in tests + pauseAtLeast $ 500 * milliseconds + browsingContextHandleUserPrompt $ MkHandleUserPrompt bc (Just True) (Just "John Doe") + pause + + -- Test Prompt - dismissed + logTxt "Testing Prompt dismissed" + scriptEvaluateNoWait $ + MkEvaluate + { expression = "prompt('This will be dismissed')", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + pauseAtLeast $ 500 * milliseconds + browsingContextHandleUserPrompt $ MkHandleUserPrompt bc (Just False) Nothing + pause + +-- >>> runDemo browsingContextEventHistoryUpdated + +-- *** Exception: user error (Timeout - Expected event did not fire: BrowsingContextHistoryUpdated after 10000 milliseconds) + +browsingContextEventHistoryUpdated :: BiDiDemo +browsingContextEventHistoryUpdated = + demo "Browsing Context Events - History Updated" action + where + -- NOTE: browsingContext.historyUpdated event is not yet implemented in geckodriver + -- See: https://bugzilla.mozilla.org/show_bug.cgi?id=1906050 + -- Status: NEW (as of 2025-06-03) + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + logTxt "Subscribe to HistoryUpdated event" + + (historyEventFired, waitHistoryEventFired) <- timeLimitLog BrowsingContextHistoryUpdated + subscribeBrowsingContextHistoryUpdated historyEventFired + + (manyHistoryEventFired, waitManyHistoryEventFired) <- timeLimitLogMany BrowsingContextHistoryUpdated + subscribeMany [BrowsingContextHistoryUpdated] manyHistoryEventFired + + logTxt "Navigate to checkboxes page" + url1 <- checkboxesUrl + bc <- rootContext utils bidi + browsingContextNavigate $ MkNavigate bc url1 Nothing + pause + + -- not implemnted in geckodriver yet this will fail + logTxt "Navigate to textArea page" + url2 <- textAreaUrl + browsingContextNavigate $ MkNavigate bc url2 Nothing + pause + + -- back button + logTxt "Click back button" + scriptEvaluate $ + MkEvaluate + { expression = "window.history.back()", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + pause + + -- this would work in geckodriver but it is a fudge + -- logTxt "Use pushState to modify browser history" + -- scriptEvaluate $ + -- MkEvaluate + -- { expression = "window.history.pushState({page: 2}, 'Page 2', '?page=2')", + -- target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + -- awaitPromise = False, + -- resultOwnership = Nothing, + -- serializationOptions = Nothing + -- } + -- logTxt "History modified with pushState" + sequence_ + [ waitHistoryEventFired, + waitManyHistoryEventFired + ] + +-- >>> runDemo browsingContextEventNavigationAborted + +-- *** Exception: user error (Timeout - Expected event did not fire: BrowsingContextNavigationAborted after 10000 milliseconds) + +browsingContextEventNavigationAborted :: BiDiDemo +browsingContextEventNavigationAborted = + demo "Browsing Context Events - Navigation Aborted" action + where + -- NOTE: browsingContext.navigationAborted event support varies by driver: + -- + -- geckodriver: Not implemented. The subscription fails with InvalidArgument error: + -- "browsingContext.navigationAborted is not a valid event name" + -- See: https://bugzilla.mozilla.org/show_bug.cgi?id=1874362 + -- Status: NEW (as of 2025-09-17) + -- + -- chromedriver: Partially implemented. Accepts subscriptions but does not emit the event. + -- The test times out waiting for the event that never fires. + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + logTxt "Subscribe to NavigationAborted event" + + (abortedEventFired, waitAbortedEventFired) <- timeLimitLog BrowsingContextNavigationAborted + subscribeBrowsingContextNavigationAborted abortedEventFired + + (manyAbortedEventFired, waitManyAbortedEventFired) <- timeLimitLogMany BrowsingContextNavigationAborted + subscribeMany [BrowsingContextNavigationAborted] manyAbortedEventFired + + logTxt "Start navigation to slow loading page" + url <- slowLoadUrl + bc <- rootContext utils bidi + + -- Start navigation in background (non-blocking) + scriptEvaluate $ + MkEvaluate + { expression = "setTimeout(() => { window.location.href = '" <> url.url <> "'; }, 100)", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + + -- Give the navigation a moment to start + pauseAtLeast (MkTimeout 200) + + logTxt "Abort navigation by navigating to different page" + url2 <- checkboxesUrl + browsingContextNavigate $ MkNavigate bc url2 Nothing + + sequence_ + [ waitAbortedEventFired, + waitManyAbortedEventFired + ] + +-- >>> runDemo browsingContextEventNavigationFailed + +-- *** Exception: BiDIError (ProtocolException {error = UnknownError, description = "An unknown error occurred in the remote end while processing the command", message = "net::ERR_NAME_NOT_RESOLVED", stacktrace = Just "Error\n at new UnknownErrorException (:65:5630)\n at BrowsingContextImpl.navigate (:679:14660)\n at async #processCommand (:485:5805)\n at async CommandProcessor.processCommand (:485:12768)", errorData = Nothing, response = Object (fromList [("error",String "unknown error"),("id",Number 4.0),("message",String "net::ERR_NAME_NOT_RESOLVED"),("stacktrace",String "Error\n at new UnknownErrorException (:65:5630)\n at BrowsingContextImpl.navigate (:679:14660)\n at async #processCommand (:485:5805)\n at async CommandProcessor.processCommand (:485:12768)"),("type",String "error")])}) + +browsingContextEventNavigationFailed :: BiDiDemo +browsingContextEventNavigationFailed = + demo "Browsing Context Events - Navigation Failed (NOT WORKING - driver issue)" action + where + -- NOTE: browsingContext.navigationFailed event is implemented in the library, + -- but both geckodriver and chromedriver throw an error on the navigate command + -- itself for DNS failures rather than starting the navigation and then firing + -- a navigationFailed event. + -- + -- geckodriver throws: NS_ERROR_UNKNOWN_HOST + -- chromedriver throws: ERR_NAME_NOT_RESOLVED + -- + -- This appears to be a driver behavior issue. The navigate command returns + -- an error before the navigation lifecycle begins, so no navigationFailed event + -- is emitted. + -- + -- Possible alternatives to test this event: + -- 1. Use a URL that resolves but returns a server error (may trigger different event) + -- 2. Use network interception to force a failure during navigation + -- 3. Wait for geckodriver fix to properly emit navigationFailed events + -- + -- The library implementation is correct and will handle the event when it fires. + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + logTxt "Subscribe to NavigationFailed event" + + (failedEventFired, waitFailedEventFired) <- timeLimitLog BrowsingContextNavigationFailed + subscribeBrowsingContextNavigationFailed failedEventFired + + (manyFailedEventFired, waitManyFailedEventFired) <- timeLimitLogMany BrowsingContextNavigationFailed + subscribeMany [BrowsingContextNavigationFailed] manyFailedEventFired + + logTxt "Attempting to navigate to invalid URL" + logTxt "NOTE: This will throw an error instead of firing navigationFailed event" + bc <- rootContext utils bidi + + -- This will throw NS_ERROR_UNKNOWN_HOST error from geckodriver + -- instead of firing a navigationFailed event + browsingContextNavigate $ MkNavigate {context = bc, url = MkUrl "https://invalid-domain-that-does-not-exist-12345", wait = Nothing} + + sequence_ + [ waitFailedEventFired, + waitManyFailedEventFired + ] + +-- >>> runDemo browsingContextEventDownloadWillBegin +browsingContextEventDownloadWillBegin :: BiDiDemo +browsingContextEventDownloadWillBegin = + demo "Browsing Context Events - Download Will Begin (NOT IMPLEMENTED)" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + logTxt "Navigate to download link page" + url <- downloadLinkUrl + bc <- rootContext utils bidi + browsingContextNavigate $ MkNavigate bc url Nothing + pause + + logTxt "Subscribe to DownloadWillBegin event" + + (downloadEventFired, waitDownloadEventFired) <- timeLimitLog BrowsingContextDownloadWillBegin + subscribeBrowsingContextDownloadWillBegin downloadEventFired + + (manyDownloadEventFired, waitManyDownloadEventFired) <- timeLimitLogMany BrowsingContextDownloadWillBegin + subscribeMany [BrowsingContextDownloadWillBegin] manyDownloadEventFired + + logTxt "Click download link via script" + scriptEvaluate $ + MkEvaluate + { expression = "document.getElementById('downloadLink').click()", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + + sequence_ + [ waitDownloadEventFired, + waitManyDownloadEventFired + ] + +-- >>> runDemo browsingContextEventDownloadEnd +browsingContextEventDownloadEnd :: BiDiDemo +browsingContextEventDownloadEnd = + demo "Browsing Context Events - Download End (Complete and Canceled)" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + logTxt "Navigate to download link page" + url <- downloadLinkUrl + bc <- rootContext utils bidi + browsingContextNavigate $ MkNavigate bc url Nothing + pause + + (downloadEndEventFired, waitDownloadEndEventFired) <- timeLimitLog BrowsingContextDownloadEnd + subscribeBrowsingContextDownloadEnd downloadEndEventFired + + (manyDownloadEndEventFired, waitManyDownloadEndEventFired) <- timeLimitLogMany BrowsingContextDownloadEnd + subscribeMany [BrowsingContextDownloadEnd] manyDownloadEndEventFired + + -- Wait for page scripts to be fully loaded (Chrome timing issue) + -- prod code would need something better than this + -- Race condition: Chrome's browsingContext.navigate returns before the page's inline ", + wait = Just Complete + } + logShow "Navigation result" navResult + pause + + logTxt "Test 7: Remove intercepts" + let MkAddInterceptResult interceptId1 = intercept1 + removeResult1 <- networkRemoveIntercept $ MkRemoveIntercept interceptId1 + logShow "Removed BeforeRequestSent intercept" removeResult1 + pause + + let MkAddInterceptResult interceptId2 = intercept2 + removeResult2 <- networkRemoveIntercept $ MkRemoveIntercept interceptId2 + logShow "Removed ResponseStarted intercept" removeResult2 + pause + + let MkAddInterceptResult interceptId3 = intercept3 + removeResult3 <- networkRemoveIntercept $ MkRemoveIntercept interceptId3 + logShow "Removed AuthRequired intercept" removeResult3 + pause + + let MkAddInterceptResult interceptId4 = intercept4 + removeResult4 <- networkRemoveIntercept $ MkRemoveIntercept interceptId4 + logShow "Removed multi-phase intercept" removeResult4 + pause + + let MkAddInterceptResult interceptId5 = intercept5 + removeResult5 <- networkRemoveIntercept $ MkRemoveIntercept interceptId5 + logShow "Removed comprehensive pattern intercept" removeResult5 + pause + + let MkAddInterceptResult interceptId6 = intercept6 + removeResult6 <- networkRemoveIntercept $ MkRemoveIntercept interceptId6 + logShow "Removed multi-pattern intercept" removeResult6 + pause + + let MkAddInterceptResult interceptId7 = intercept7 + removeResult7 <- networkRemoveIntercept $ MkRemoveIntercept interceptId7 + logShow "Removed global intercept" removeResult7 + pause + +-- >>> runDemo networkRequestModificationDemo +networkRequestModificationDemo :: BiDiDemo +networkRequestModificationDemo = + demo "Network III - Request Modification" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + withTestServer $ do + logTxt "Subscribe first, then intercept and modify request headers and method" + + (beforeReqFired2, waitBeforeReq2) <- timeLimitLog NetworkBeforeRequestSent + + reqIdMVar <- newEmptyTMVarIO + subscribeNetworkBeforeRequestSent + ( \event -> do + let MkBeforeRequestSent {request = MkRequestData {request = reqId}} = event + atomically $ putTMVar reqIdMVar reqId + beforeReqFired2 event + ) + + -- Add intercept AFTER subscription + intercept2 <- + networkAddIntercept $ + MkAddIntercept + { phases = [BeforeRequestSent], + contexts = Just [bc], + urlPatterns = Nothing + } + let MkAddInterceptResult interceptId2 = intercept2 + logShow "BeforeRequestSent intercept added" interceptId2 + pause + + sendCommandNoWait . mkCommand BrowsingContextNavigate $ + MkNavigate + { context = bc, + url = boringHelloUrl, + wait = Just Complete + } + + reqId <- atomically $ readTMVar reqIdMVar + + logShow ("Switching urls to " <> boringHelloUrl2.url) reqId + + networkContinueRequest $ + MkContinueRequest + { request = reqId, + body = Nothing, + cookies = Nothing, + headers = Nothing, + method = Just "GET", + url = Just boringHelloUrl2 + } + + waitBeforeReq2 + pause + + removeIntercept2 <- networkRemoveIntercept $ MkRemoveIntercept interceptId2 + logShow "Removed intercept" removeIntercept2 + pause + +-- >>> runDemo networkResponseModificationDemo +networkResponseModificationDemo :: BiDiDemo +networkResponseModificationDemo = + demo "Network IV - Response Modification (Headers & Status Only) - modified in subscription" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + withTestServer $ do + logTxt "Disable cache to ensure we see network requests" + networkSetCacheBehavior $ + MkSetCacheBehavior + { cacheBehavior = BypassCache, + contexts = Just [bc] + } + pause + + (respStartedFired, waitRespStarted) <- timeLimitLog NetworkResponseStarted + + subscribeNetworkResponseStarted + ( \event -> do + let MkResponseStarted {request = MkRequestData {request = req}} = event + + logShow "Modifying response: status 404, custom headers" req + + networkContinueResponse $ + MkContinueResponse + { request = req, + cookies = + Just + [ MkSetCookieHeader + { name = "bidi-inserted-cookie", + value = TextBytesValue $ MkStringValue "HELLLLO FROMM BIDI", + domain = Nothing, + path = Nothing, + expiry = Nothing, + httpOnly = Just True, + secure = Just True, + maxAge = Nothing, + sameSite = Nothing + } + ], + credentials = Nothing, + headers = + Just + [ MkHeader "X-Modified-By" (TextBytesValue $ MkStringValue "WebDriver-BiDi-Demo"), + MkHeader "X-Custom-Status" (TextBytesValue $ MkStringValue "Mocked-404"), + MkHeader "X-Intercept-Time" (TextBytesValue $ MkStringValue "2025-10-22") + ], + reasonPhrase = Just "Not Found", + statusCode = Just (MkJSUInt 404) + } + + respStartedFired event + ) + + logTxt "Subscribe to Response Completed - to see the effect of modification" + (responseEndFired, waitRespCompleted) <- timeLimitLog NetworkResponseCompleted + subscribeNetworkResponseCompleted responseEndFired + + intercept <- + networkAddIntercept $ + MkAddIntercept + { phases = [ResponseStarted], + contexts = Just [bc], + urlPatterns = Nothing + } + let MkAddInterceptResult interceptId = intercept + logShow "ResponseStarted intercept added" interceptId + pause + + sendCommandNoWait . mkCommand BrowsingContextNavigate $ + MkNavigate + { context = bc, + url = boringHelloUrl, + wait = Just Complete + } + + sequence_ [waitRespStarted, waitRespCompleted] + + removeIntercept <- networkRemoveIntercept $ MkRemoveIntercept interceptId + logShow "Removed intercept" removeIntercept + pause + +-- >>> runDemo networkResponseModificationDemo +networkResponseModificationDemo2 :: BiDiDemo +networkResponseModificationDemo2 = + demo "Network IV - Response Modification - with pre-generated id" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + withTestServer $ do + logTxt "Disable cache to ensure we see network requests" + networkSetCacheBehavior $ + MkSetCacheBehavior + { cacheBehavior = BypassCache, + contexts = Just [bc] + } + pause + + (responseEndFired, waitRespCompleted) <- timeLimitLog NetworkResponseCompleted + subscribeNetworkResponseCompleted responseEndFired + + intercept <- + networkAddIntercept $ + MkAddIntercept + { phases = [ResponseStarted], + contexts = Just [bc], + urlPatterns = Nothing + } + let MkAddInterceptResult interceptId = intercept + logShow "ResponseStarted intercept added" interceptId + pause + + let requestId = MkJSUInt 9999 + + logTxt "Modifying response: status 404, custom headers" + logShow "Modifying response: status 404, custom headers" 999 + + networkContinueResponse $ + MkContinueResponse + { request = MkRequest $ txt requestId, + cookies = + Just + [ MkSetCookieHeader + { name = "bidi-inserted-cookie", + value = TextBytesValue $ MkStringValue "HELLLLO FROMM BIDI", + domain = Nothing, + path = Nothing, + expiry = Nothing, + httpOnly = Just True, + secure = Just True, + maxAge = Nothing, + sameSite = Nothing + } + ], + credentials = Nothing, + headers = + Just + [ MkHeader "X-Modified-By" (TextBytesValue $ MkStringValue "WebDriver-BiDi-Demo"), + MkHeader "X-Custom-Status" (TextBytesValue $ MkStringValue "Mocked-404"), + MkHeader "X-Intercept-Time" (TextBytesValue $ MkStringValue "2025-10-22") + ], + reasonPhrase = Just "Not Found", + statusCode = Just (MkJSUInt 404) + } + + let navigateCmd :: Command NavigateResult + navigateCmd = + mkCommand BrowsingContextNavigate $ + MkNavigate + { context = bc, + url = boringHelloUrl, + wait = Just Complete + } + sendCommand' requestId navigateCmd + + waitRespCompleted + + removeIntercept <- networkRemoveIntercept $ MkRemoveIntercept interceptId + logShow "Removed intercept" removeIntercept + pause + +-- >>> runDemo networkAuthCancelDemo +networkAuthCancelDemo :: BiDiDemo +networkAuthCancelDemo = + demo "Network V-A - Authentication: Cancel" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + withTestServer $ do + authIntercept <- + networkAddIntercept $ + MkAddIntercept + { phases = [AuthRequired], + contexts = Just [bc], + urlPatterns = Nothing + } + let MkAddInterceptResult authInterceptId = authIntercept + logShow "AuthRequired intercept added" authInterceptId + pause + + (authReqFired, waitAuthReq) <- timeLimitLog NetworkAuthRequired + + sub <- subscribeNetworkAuthRequired $ \event -> do + let MkAuthRequired {request = MkRequestData {request = reqId}} = event + logShow "AuthRequired event captured (will cancel)" reqId + + networkContinueWithAuth $ + MkContinueWithAuth + { request = reqId, + authAction = CancelAuth + } + logTxt "Auth request cancelled" + authReqFired event + pause + + sendCommandNoWait . mkCommand BrowsingContextNavigate $ + MkNavigate + { context = bc, + url = authTestUrl, + wait = Nothing + } + waitAuthReq + unsubscribe sub + pause + + networkRemoveIntercept $ MkRemoveIntercept authInterceptId + pause + +-- >>> runDemo networkAuthWithCredentialsDemo +networkAuthWithCredentialsDemo :: BiDiDemo +networkAuthWithCredentialsDemo = + demo "Network V-B - Authentication: Credentials" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + withTestServer $ do + authIntercept <- + networkAddIntercept $ + MkAddIntercept + { phases = [AuthRequired], + contexts = Just [bc], + urlPatterns = Nothing + } + let MkAddInterceptResult authInterceptId = authIntercept + logShow "AuthRequired intercept added" authInterceptId + pause + + (authReqFired, waitAuthReq) <- timeLimitLog NetworkAuthRequired + + sub <- subscribeNetworkAuthRequired $ \event -> do + let MkAuthRequired {request = MkRequestData {request = reqId}} = event + logShow "AuthRequired event captured (will provide credentials)" reqId + + networkContinueWithAuth $ + MkContinueWithAuth + { request = reqId, + authAction = + ProvideCredentials $ + MkAuthCredentials + { username = "test_user", + password = "test_password_123" + } + } + logTxt "Provided credentials: test_user / test_password_123" + authReqFired event + pause + + sendCommandNoWait . mkCommand BrowsingContextNavigate $ + MkNavigate + { context = bc, + url = authTestUrl, + wait = Nothing + } + waitAuthReq + unsubscribe sub + pause + + networkRemoveIntercept $ MkRemoveIntercept authInterceptId + pause + +-- >>> runDemo networkFailRequestDemo +networkFailRequestDemo :: BiDiDemo +networkFailRequestDemo = + demo "Network VI - Request Failure Handling" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + withTestServer $ do + logTxt "Test 1: Add intercept for BeforeRequestSent phase" + failIntercept <- + networkAddIntercept $ + MkAddIntercept + { phases = [BeforeRequestSent], + contexts = Just [bc], + urlPatterns = Nothing + } + let MkAddInterceptResult failInterceptId = failIntercept + logShow "BeforeRequestSent intercept added for failure demo" failInterceptId + pause + + logTxt "Test 2: Subscribe to BeforeRequestSent and fail the request" + (beforeReqFired1, waitBeforeReq1) <- timeLimitLog NetworkBeforeRequestSent + failReqIdVar1 <- newEmptyTMVarIO + subscribeNetworkBeforeRequestSent $ \event -> do + let MkBeforeRequestSent {request = MkRequestData {request = reqId}} = event + logShow "BeforeRequestSent captured (will fail request)" reqId + atomically $ putTMVar failReqIdVar1 reqId + + networkFailRequest $ MkFailRequest {request = reqId} + logTxt "Request failed intentionally" + beforeReqFired1 event + pause + + logTxt "Test 3: Navigate to trigger request failure" + sendCommandNoWait . mkCommand BrowsingContextNavigate $ + MkNavigate + { context = bc, + url = boringHelloUrl, + wait = Nothing + } + waitBeforeReq1 + pause + + logTxt "Test 4: Fail another request (second demonstration)" + (beforeReqFired2, waitBeforeReq2) <- timeLimitLog NetworkBeforeRequestSent + failReqIdVar2 <- newEmptyTMVarIO + subscribeNetworkBeforeRequestSent $ \event -> do + let MkBeforeRequestSent {request = MkRequestData {request = reqId}} = event + logShow "BeforeRequestSent captured (will fail second request)" reqId + atomically $ putTMVar failReqIdVar2 reqId + + networkFailRequest $ MkFailRequest {request = reqId} + logTxt "Second request failed intentionally" + beforeReqFired2 event + pause + + logTxt "Test 5: Navigate to trigger second request failure" + sendCommandNoWait . mkCommand BrowsingContextNavigate $ + MkNavigate + { context = bc, + url = boringHelloUrl2, + wait = Nothing + } + waitBeforeReq2 + pause + + logTxt "Cleanup: Remove failure intercept" + removeFailIntercept <- networkRemoveIntercept $ MkRemoveIntercept failInterceptId + logShow "Removed BeforeRequestSent intercept" removeFailIntercept + pause + +-- >>> runDemo networkProvideResponseJSONDemo +networkProvideResponseJSONDemo :: BiDiDemo +networkProvideResponseJSONDemo = + demo "Network VII-A - Provide JSON Response" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + withTestServer $ do + logTxt "Disable cache to ensure we see network requests" + networkSetCacheBehavior $ + MkSetCacheBehavior + { cacheBehavior = BypassCache, + contexts = Just [bc] + } + pause + + logTxt "Provide custom JSON response - status 200" + + (beforeReqFired, waitBeforeReq) <- timeLimitLog NetworkBeforeRequestSent + + subscribeNetworkBeforeRequestSent $ \event -> do + let MkBeforeRequestSent {request = MkRequestData {request = reqId}, intercepts = maybeIntercepts} = event + case maybeIntercepts of + Just (interceptId : _) -> do + logShow "Captured request for JSON response" reqId + + let jsonBody = "{\"message\": \"Hello from BiDi!\", \"status\": \"success\", \"data\": [1, 2, 3]}" + networkProvideResponse $ + MkProvideResponse + { request = reqId, + intercept = interceptId, + body = Just $ TextBytesValue $ MkStringValue jsonBody, + cookies = Nothing, + headers = Just [MkHeader "Content-Type" (TextBytesValue $ MkStringValue "application/json")], + reasonPhrase = "OK", + statusCode = 200 + } + logTxt "Provided custom JSON response" + _ -> pure () + beforeReqFired event + + intercept <- + networkAddIntercept $ + MkAddIntercept + { phases = [BeforeRequestSent], + contexts = Just [bc], + urlPatterns = Nothing + } + let MkAddInterceptResult interceptId = intercept + logShow "BeforeRequestSent intercept added" interceptId + pause + + sendCommandNoWait . mkCommand BrowsingContextNavigate $ + MkNavigate + { context = bc, + url = boringHelloUrl, + wait = Just Complete + } + + waitBeforeReq + pause + + networkRemoveIntercept $ MkRemoveIntercept interceptId + logTxt "Removed intercept" + pause + +-- >>> runDemo networkProvideResponseHTMLDemo +networkProvideResponseHTMLDemo :: BiDiDemo +networkProvideResponseHTMLDemo = + demo "Network VII-B - Provide HTML Response" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + withTestServer $ do + logTxt "Disable cache to ensure we see network requests" + networkSetCacheBehavior $ + MkSetCacheBehavior + { cacheBehavior = BypassCache, + contexts = Just [bc] + } + pause + + logTxt "Provide HTML response with custom status" + + (beforeReqFired, waitBeforeReq) <- timeLimitLog NetworkBeforeRequestSent + + subscribeNetworkBeforeRequestSent $ \event -> do + let MkBeforeRequestSent {request = MkRequestData {request = reqId}, intercepts = maybeIntercepts} = event + case maybeIntercepts of + Just (interceptId : _) -> do + logShow "Captured request for HTML response" reqId + + let htmlBody = "Custom Response

This is a custom HTML response from BiDi!

Status: 201 Created

" + networkProvideResponse $ + MkProvideResponse + { request = reqId, + intercept = interceptId, + body = Just $ TextBytesValue $ MkStringValue htmlBody, + cookies = Nothing, + headers = + Just + [ MkHeader "Content-Type" (TextBytesValue $ MkStringValue "text/html; charset=utf-8"), + MkHeader "X-Custom-Header" (TextBytesValue $ MkStringValue "BiDi-Generated") + ], + reasonPhrase = "Created", + statusCode = 201 + } + logTxt "Provided custom HTML response with status 201" + _ -> pure () + beforeReqFired event + + intercept <- + networkAddIntercept $ + MkAddIntercept + { phases = [BeforeRequestSent], + contexts = Just [bc], + urlPatterns = Nothing + } + let MkAddInterceptResult interceptId = intercept + logShow "BeforeRequestSent intercept added" interceptId + pause + + sendCommandNoWait . mkCommand BrowsingContextNavigate $ + MkNavigate + { context = bc, + url = boringHelloUrl2, + wait = Just Complete + } + + waitBeforeReq + pause + + networkRemoveIntercept $ MkRemoveIntercept interceptId + logTxt "Removed intercept" + pause + +-- >>> runDemo networkProvideResponseWithCookiesDemo +networkProvideResponseWithCookiesDemo :: BiDiDemo +networkProvideResponseWithCookiesDemo = + demo "Network VII-C - Provide Response with Cookies" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + withTestServer $ do + logTxt "Disable cache to ensure we see network requests" + networkSetCacheBehavior $ + MkSetCacheBehavior + { cacheBehavior = BypassCache, + contexts = Just [bc] + } + pause + + logTxt "Provide error response with cookies" + + (beforeReqFired, waitBeforeReq) <- timeLimitLog NetworkBeforeRequestSent + + subscribeNetworkBeforeRequestSent $ \event -> do + let MkBeforeRequestSent {request = MkRequestData {request = reqId}, intercepts = maybeIntercepts} = event + case maybeIntercepts of + Just (interceptId : _) -> do + logShow "Captured request for error response with cookies" reqId + + let errorBody = "{\"error\": \"Unauthorized\", \"message\": \"Please provide valid credentials\"}" + networkProvideResponse $ + MkProvideResponse + { request = reqId, + intercept = interceptId, + body = Just $ TextBytesValue $ MkStringValue errorBody, + cookies = + Just + [ MkCookie + { name = "session_expired", + value = TextBytesValue $ MkStringValue "true", + domain = "localhost", + path = "/", + size = 4, + httpOnly = True, + secure = False, + sameSite = Strict, + expiry = Nothing + } + ], + headers = + Just + [ MkHeader "Content-Type" (TextBytesValue $ MkStringValue "application/json"), + MkHeader "WWW-Authenticate" (TextBytesValue $ MkStringValue "Bearer") + ], + reasonPhrase = "Unauthorized", + statusCode = 401 + } + logTxt "Provided 401 error response with cookies" + _ -> pure () + beforeReqFired event + + intercept <- + networkAddIntercept $ + MkAddIntercept + { phases = [BeforeRequestSent], + contexts = Just [bc], + urlPatterns = Nothing + } + let MkAddInterceptResult interceptId = intercept + logShow "BeforeRequestSent intercept added" interceptId + pause + + sendCommandNoWait . mkCommand BrowsingContextNavigate $ + MkNavigate + { context = bc, + url = testServerHomeUrl, + wait = Just Complete + } + + waitBeforeReq + pause + + networkRemoveIntercept $ MkRemoveIntercept interceptId + logTxt "Removed intercept" + pause + +-- >>> runDemo networkProvideResponseBase64Demo +networkProvideResponseBase64Demo :: BiDiDemo +networkProvideResponseBase64Demo = + demo "Network VII-D - Provide Base64 Response" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + withTestServer $ do + logTxt "Disable cache to ensure we see network requests" + networkSetCacheBehavior $ + MkSetCacheBehavior + { cacheBehavior = BypassCache, + contexts = Just [bc] + } + pause + + logTxt "Provide base64 encoded response (simulated image)" + + (beforeReqFired, waitBeforeReq) <- timeLimitLog NetworkBeforeRequestSent + + subscribeNetworkBeforeRequestSent $ \event -> do + let MkBeforeRequestSent {request = MkRequestData {request = reqId}, intercepts = maybeIntercepts} = event + case maybeIntercepts of + Just (interceptId : _) -> do + logShow "Captured request for base64 response" reqId + + -- Tiny 1x1 red PNG in base64 + let pngBase64 = "iVBORw0KGgoAAAANSUhEUgAAAAEAAAABCAYAAAAfFcSJAAAADUlEQVR42mP8z8DwHwAFBQIAX8jx0gAAAABJRU5ErkJggg==" + networkProvideResponse $ + MkProvideResponse + { request = reqId, + intercept = interceptId, + body = Just $ Base64Value pngBase64, + cookies = Nothing, + headers = + Just + [ MkHeader "Content-Type" (TextBytesValue $ MkStringValue "image/png"), + MkHeader "Cache-Control" (TextBytesValue $ MkStringValue "no-cache") + ], + reasonPhrase = "OK", + statusCode = 200 + } + logTxt "Provided base64 encoded PNG response" + _ -> pure () + beforeReqFired event + + intercept <- + networkAddIntercept $ + MkAddIntercept + { phases = [BeforeRequestSent], + contexts = Just [bc], + urlPatterns = Nothing + } + let MkAddInterceptResult interceptId = intercept + logShow "BeforeRequestSent intercept added" interceptId + pause + + sendCommandNoWait . mkCommand BrowsingContextNavigate $ + MkNavigate + { context = bc, + url = boringHelloUrl, + wait = Just Complete + } + + waitBeforeReq + pause + + networkRemoveIntercept $ MkRemoveIntercept interceptId + logTxt "Removed intercept" + pause + +-- >>> runDemo networkProvideResponseErrorDemo +networkProvideResponseErrorDemo :: BiDiDemo +networkProvideResponseErrorDemo = + demo "Network VII-E - Provide Error Response" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + withTestServer $ do + logTxt "Disable cache to ensure we see network requests" + networkSetCacheBehavior $ + MkSetCacheBehavior + { cacheBehavior = BypassCache, + contexts = Just [bc] + } + pause + + logTxt "Provide server error response" + + (beforeReqFired, waitBeforeReq) <- timeLimitLog NetworkBeforeRequestSent + + subscribeNetworkBeforeRequestSent $ \event -> do + let MkBeforeRequestSent {request = MkRequestData {request = reqId}, intercepts = maybeIntercepts} = event + case maybeIntercepts of + Just (interceptId : _) -> do + logShow "Captured request for server error response" reqId + + let errorBody = "

500 Internal Server Error

Something went wrong on our end.

" + networkProvideResponse $ + MkProvideResponse + { request = reqId, + intercept = interceptId, + body = Just $ TextBytesValue $ MkStringValue errorBody, + cookies = Nothing, + headers = + Just + [ MkHeader "Content-Type" (TextBytesValue $ MkStringValue "text/html"), + MkHeader "Retry-After" (TextBytesValue $ MkStringValue "3600") + ], + reasonPhrase = "Internal Server Error", + statusCode = 500 + } + logTxt "Provided 500 server error response" + _ -> pure () + beforeReqFired event + + intercept <- + networkAddIntercept $ + MkAddIntercept + { phases = [BeforeRequestSent], + contexts = Just [bc], + urlPatterns = Nothing + } + let MkAddInterceptResult interceptId = intercept + logShow "BeforeRequestSent intercept added" interceptId + pause + + sendCommandNoWait . mkCommand BrowsingContextNavigate $ + MkNavigate + { context = bc, + url = boringHelloUrl2, + wait = Just Complete + } + + waitBeforeReq + pause + + networkRemoveIntercept $ MkRemoveIntercept interceptId + logTxt "Removed intercept" + pause + +-- >>> runDemo networkDataRetrievalDemo +networkDataRetrievalDemo :: BiDiDemo +networkDataRetrievalDemo = + demo "Network VIII - Data Retrieval and Ownership" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + logTxt "Test 1: Add data collector to capture network data" + MkAddDataCollectorResult collectorId <- + networkAddDataCollector $ + MkAddDataCollector + { dataTypes = [Response], + maxEncodedDataSize = MkJSUInt 2048, + collectorType = Nothing, + contexts = Just [bc], + userContexts = Nothing + } + logShow "Data collector created" collectorId + pause + + logTxt "Test 2: Subscribe to network.responseCompleted event to capture request ID" + requestIdVar <- newTVarIO Nothing + (responseCompletedFired, waitResponseCompleted) <- timeLimitLog NetworkResponseCompleted + subscribeNetworkResponseCompleted $ \event -> do + let MkResponseCompleted {request = MkRequestData {request = requestId}} = event + logShow "Captured request ID from event" requestId + atomically $ writeTVar requestIdVar (Just requestId) + responseCompletedFired event + pause + + logTxt "Test 3: Navigate to trigger a real network request" + withTestServer $ do + navResult <- + browsingContextNavigate $ + MkNavigate + { context = bc, + url = testServerHomeUrl, + wait = Just Complete + } + logShow "Navigation result" navResult + + logTxt "Waiting for response completed event..." + waitResponseCompleted + + logTxt "Test 4: Retrieve the captured request ID" + maybeRequestId <- atomically $ readTVar requestIdVar + case maybeRequestId of + Nothing -> logTxt "ERROR: No request ID was captured from events" + Just (MkRequest requestIdText) -> do + let capturedRequest = MkRequest requestIdText + logShow "Using captured request ID" capturedRequest + pause + + logTxt "Test 6: networkGetData with disown=True" + getData2 <- + networkGetData $ + MkGetData + { dataType = Response, + collector = Just collectorId, + disown = Just True, + request = capturedRequest + } + logShow "Get data with disowning result" getData2 + pause + +-- >>> runDemo networkDisownDataDemo +networkDisownDataDemo :: BiDiDemo +networkDisownDataDemo = + demo "Network IX - Data Retrieval and Disown" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + logTxt "Test 1: Add data collector to capture network data" + MkAddDataCollectorResult collectorId <- + networkAddDataCollector $ + MkAddDataCollector + { dataTypes = [Response], + maxEncodedDataSize = MkJSUInt 2048, + collectorType = Nothing, + contexts = Just [bc], + userContexts = Nothing + } + logShow "Data collector created" collectorId + pause + + logTxt "Test 2: Subscribe to network.responseCompleted event to capture request ID" + requestIdVar <- newTVarIO Nothing + (responseCompletedFired, waitResponseCompleted) <- timeLimitLog NetworkResponseCompleted + subscribeNetworkResponseCompleted $ \event -> do + let MkResponseCompleted {request = MkRequestData {request = requestId}} = event + logShow "Captured request ID from event" requestId + atomically $ writeTVar requestIdVar (Just requestId) + responseCompletedFired event + pause + + logTxt "Test 3: Navigate to trigger a real network request" + withTestServer $ do + navResult <- + browsingContextNavigate $ + MkNavigate + { context = bc, + url = testServerHomeUrl, + wait = Just Complete + } + logShow "Navigation result" navResult + + logTxt "Waiting for response completed event..." + waitResponseCompleted + + logTxt "Test 4: Retrieve the captured request ID" + maybeRequestId <- atomically $ readTVar requestIdVar + case maybeRequestId of + Nothing -> logTxt "ERROR: No request ID was captured from events" + Just (MkRequest requestIdText) -> do + let capturedRequest = MkRequest requestIdText + logShow "Using captured request ID" capturedRequest + pause + + logTxt "Test 5: networkGetData with disown=False" + getData1 <- + networkGetData $ + MkGetData + { dataType = Response, + collector = Just collectorId, + disown = Just False, + request = capturedRequest + } + logShow "Get data without disowning result" getData1 + pause + + logTxt "Test 6: networkDisownData - explicitly disown specific data" + disownResult <- + networkDisownData $ + MkDisownData + { dataType = Response, + collector = collectorId, + request = capturedRequest + } + logShow "Disown data result" disownResult + pause + +-- >>> runDemo networkCacheBehaviorDemo +networkCacheBehaviorDemo :: BiDiDemo +networkCacheBehaviorDemo = + demo "Network X - Cache Behavior Management" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + logTxt "Test 1: Set cache behavior to default (global)" + cacheResult1 <- + networkSetCacheBehavior $ + MkSetCacheBehavior + { cacheBehavior = DefaultCacheBehavior, + contexts = Nothing + } + logShow "Set default cache behavior (global) result" cacheResult1 + pause + + logTxt "Test 2: Set cache behavior to bypass cache (global)" + cacheResult2 <- + networkSetCacheBehavior $ + MkSetCacheBehavior + { cacheBehavior = BypassCache, + contexts = Nothing + } + logShow "Set bypass cache behavior (global) result" cacheResult2 + pause + + logTxt "Test 3: Set cache behavior to default for specific context" + cacheResult3 <- + networkSetCacheBehavior $ + MkSetCacheBehavior + { cacheBehavior = DefaultCacheBehavior, + contexts = Just [bc] + } + logShow "Set default cache behavior (context-specific) result" cacheResult3 + pause + + logTxt "Test 4: Set cache behavior to bypass cache for specific context" + cacheResult4 <- + networkSetCacheBehavior $ + MkSetCacheBehavior + { cacheBehavior = BypassCache, + contexts = Just [bc] + } + logShow "Set bypass cache behavior (context-specific) result" cacheResult4 + pause + + logTxt "Test 5: Create new context to test cache behavior isolation" + newContext <- newWindowContext utils bidi + + logTxt "Test 6: Set different cache behavior for new context" + cacheResult5 <- + networkSetCacheBehavior $ + MkSetCacheBehavior + { cacheBehavior = BypassCache, + contexts = Just [newContext] + } + logShow "Set bypass cache behavior for new context result" cacheResult5 + pause + + logTxt "Test 7: Set cache behavior for multiple contexts" + cacheResult6 <- + networkSetCacheBehavior $ + MkSetCacheBehavior + { cacheBehavior = DefaultCacheBehavior, + contexts = Just [bc, newContext] + } + logShow "Set default cache behavior for multiple contexts result" cacheResult6 + pause + + logTxt "Test 8: Navigate both contexts to test cache behavior" + navResult1 <- + browsingContextNavigate $ + MkNavigate + { context = bc, + url = MkUrl "data:text/html,Cache Test 1

Testing Cache Behavior - Context 1

", + wait = Just Complete + } + logShow "Navigation result - original context" navResult1 + pause + + navResult2 <- + browsingContextNavigate $ + MkNavigate + { context = newContext, + url = MkUrl "data:text/html,Cache Test 2

Testing Cache Behavior - Context 2

", + wait = Just Complete + } + logShow "Navigation result - new context" navResult2 + pause + + logTxt "Test 9: Reset cache behavior to default for all contexts" + cacheResult7 <- + networkSetCacheBehavior $ + MkSetCacheBehavior + { cacheBehavior = DefaultCacheBehavior, + contexts = Nothing + } + logShow "Reset to default cache behavior (global) result" cacheResult7 + pause + + logTxt "Cleanup - close new context" + closeContext utils bidi newContext + + +-- >>> runDemo networkSetExtraHeadersDemo +-- *** Exception: BiDIError (ProtocolException {error = UnsupportedOperation, description = "Indicates that a command that should have executed properly cannot be supported for some reason", message = "Only string headers values are supported", stacktrace = Nothing, errorData = Nothing, response = Object (fromList [("error",String "unsupported operation"),("id",Number 6.0),("message",String "Only string headers values are supported"),("type",String "error")])}) +networkSetExtraHeadersDemo :: BiDiDemo +networkSetExtraHeadersDemo = + demo "Network XI - Set Extra Headers -- since https://www.w3.org/TR/2025/WD-webdriver-bidi-20251106" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + withTestServer $ do + logTxt "Test 1: Set extra headers globally" + setExtraHeaders1 <- + networkSetExtraHeaders $ + MkSetExtraHeaders + { headers = + [ MkHeader "X-Custom-Header-1" (TextBytesValue $ MkStringValue "global-value"), + MkHeader "X-Test-Token" (TextBytesValue $ MkStringValue "abc123") + ], + contexts = Nothing, + userContexts = Nothing + } + logShow "Set extra headers globally result" setExtraHeaders1 + pause + + logTxt "Test 2: Set extra headers for specific browsing context" + setExtraHeaders2 <- + networkSetExtraHeaders $ + MkSetExtraHeaders + { headers = + [ MkHeader "X-Context-Specific" (TextBytesValue $ MkStringValue "context-value"), + MkHeader "Authorization" (TextBytesValue $ MkStringValue "Bearer token123") + ], + contexts = Just [bc], + userContexts = Nothing + } + logShow "Set extra headers for context result" setExtraHeaders2 + pause + + logTxt "Test 3: Create user context for targeted header setting" + userContext <- + browserCreateUserContext + MkCreateUserContext + { insecureCerts = Nothing, + proxy = Nothing, + unhandledPromptBehavior = Nothing + } + logShow "User context created" userContext + pause + + logTxt "Test 4: Set extra headers for specific user context" + setExtraHeaders3 <- + networkSetExtraHeaders $ + MkSetExtraHeaders + { headers = + [ MkHeader "X-User-Context-Header" (TextBytesValue $ MkStringValue "user-context-value") + ], + contexts = Nothing, + userContexts = Just [userContext] + } + logShow "Set extra headers for user context result" setExtraHeaders3 + pause + + logTxt "Test 5: Set extra headers with base64 values" + setExtraHeaders4 <- + networkSetExtraHeaders $ + MkSetExtraHeaders + { headers = + [ MkHeader "X-Base64-Header" (Base64Value "SGVsbG8gV29ybGQ=") + ], + contexts = Just [bc], + userContexts = Nothing + } + logShow "Set extra headers with base64 result" setExtraHeaders4 + pause + + logTxt "Test 6: Subscribe to network events to verify headers" + (beforeReqFired, waitBeforeReq) <- timeLimitLog NetworkBeforeRequestSent + subscribeNetworkBeforeRequestSent $ \event -> do + let MkBeforeRequestSent {request = MkRequestData {headers = requestHeaders}} = event + logShow "Request headers" requestHeaders + beforeReqFired event + pause + + logTxt "Test 7: Navigate to trigger request with extra headers" + sendCommandNoWait . mkCommand BrowsingContextNavigate $ + MkNavigate + { context = bc, + url = boringHelloUrl, + wait = Just Complete + } + waitBeforeReq + pause + + logTxt "Test 8: Clear extra headers by setting empty list" + setExtraHeaders5 <- + networkSetExtraHeaders $ + MkSetExtraHeaders + { headers = [], + contexts = Nothing, + userContexts = Nothing + } + logShow "Cleared extra headers result" setExtraHeaders5 + pause + + logTxt "Cleanup - remove user context" + removeUC <- browserRemoveUserContext $ MkRemoveUserContext userContext + logShow "Removed user context" removeUC + pause diff --git a/test/BiDi/Demos/NetworkEventDemos.hs b/test/BiDi/Demos/NetworkEventDemos.hs new file mode 100644 --- /dev/null +++ b/test/BiDi/Demos/NetworkEventDemos.hs @@ -0,0 +1,120 @@ +module BiDi.Demos.NetworkEventDemos where + +import BiDi.Actions (BiDiActions (..)) +import BiDi.DemoUtils +import IOUtils (DemoActions (..)) +import TestServerAPI (authTestUrl, malformedResponseUrl, testServerHomeUrl, withTestServer) +import WebDriverPreCore.BiDi.Protocol + ( ContextTarget (..), + Evaluate (..), + KnownCommand (..), + KnownSubscriptionType (..), + Navigate (..), + Target (..), + URL (..), + mkCommand, + ) +import Prelude hiding (log, putStrLn) + +-- >>> runDemo networkEventRequestResponseLifecycle +-- *** Exception: user error (Timeout - Expected event did not fire: NetworkResponseStarted after 10000 milliseconds) +networkEventRequestResponseLifecycle :: BiDiDemo +networkEventRequestResponseLifecycle = + demo "Network Events - Complete Request/Response Lifecycle" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + logTxt "Subscribe to all network lifecycle events" + + (beforeReqEventFired, waitBeforeReqEventFired) <- timeLimitLog NetworkBeforeRequestSent + subscribeNetworkBeforeRequestSent beforeReqEventFired + + (respStartedEventFired, waitRespStartedEventFired) <- timeLimitLog NetworkResponseStarted + subscribeNetworkResponseStarted respStartedEventFired + + (respCompletedEventFired, waitNetworkResponseCompletedEventFired) <- timeLimitLog NetworkResponseCompleted + subscribeNetworkResponseCompleted respCompletedEventFired + + bc <- rootContext utils bidi + + withTestServer $ do + logTxt "Trigger network request to demonstrate complete network lifecycle" + scriptEvaluate $ + MkEvaluate + { expression = "fetch('" <> testServerHomeUrl <> "')", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + logTxt "Waiting for all network lifecycle events..." + + sequence_ + [ waitBeforeReqEventFired, + waitRespStartedEventFired, + waitNetworkResponseCompletedEventFired + ] + +-- >>> runDemo networkEventFetchError +networkEventFetchError :: BiDiDemo +networkEventFetchError = + demo "Network Events - Fetch Error" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + withTestServer $ do + logTxt "Subscribe to FetchError event" + (fetchErrorEventFired, waitFetchErrorEventFired) <- timeLimitLog NetworkFetchError + subscribeNetworkFetchError fetchErrorEventFired + + (manyFetchErrorEventFired, waitManyFetchErrorEventFired) <- timeLimitLogMany NetworkFetchError + subscribeMany [NetworkFetchError] manyFetchErrorEventFired + + bc <- rootContext utils bidi + + logTxt "Trigger fetch error using invalid URL" + scriptEvaluate $ + MkEvaluate + { expression = "fetch('" <> malformedResponseUrl <> "')", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + logTxt "Waiting for fetch error events..." + + sequence_ + [ waitFetchErrorEventFired, + waitManyFetchErrorEventFired + ] + +-- >>> runDemo networkEventAuthRequired +-- *** Exception: user error (Timeout - Expected event did not fire: NetworkAuthRequired after 10000 milliseconds) +networkEventAuthRequired :: BiDiDemo +networkEventAuthRequired = + demo "Network Events - Auth Required (requires auth-protected URL)" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + logTxt "Subscribe to AuthRequired event" + (authReqEventFired, waitAuthReqEventFired) <- timeLimitLog NetworkAuthRequired + subscribeNetworkAuthRequired authReqEventFired + + (manyAuthReqEventFired, waitManyAuthReqEventFired) <- timeLimitLogMany NetworkAuthRequired + subscribeMany [NetworkAuthRequired] manyAuthReqEventFired + + bc <- rootContext utils bidi + + logTxt "Navigate to auth-protected URL to trigger AuthRequired event" + + withTestServer $ do + logTxt "Waiting for auth required events..." + + sendCommandNoWait . mkCommand BrowsingContextNavigate $ MkNavigate {context = bc, url = MkUrl authTestUrl, wait = Nothing} + + pause + + sequence_ + [ waitAuthReqEventFired, + waitManyAuthReqEventFired + ] diff --git a/test/BiDi/Demos/NetworkSupportTest.hs b/test/BiDi/Demos/NetworkSupportTest.hs new file mode 100644 --- /dev/null +++ b/test/BiDi/Demos/NetworkSupportTest.hs @@ -0,0 +1,109 @@ +module BiDi.Demos.NetworkSupportTest where + +import BiDi.Actions (BiDiActions (..)) +import BiDi.DemoUtils +import Control.Exception (SomeException, throwIO, try) +import IOUtils (DemoActions (..), exceptionTextIncludes) +import WebDriverPreCore.BiDi.Protocol + ( AddDataCollector (..), + AddIntercept (..), + CacheBehavior (..), + ContinueRequest (..), + DataType (..), + InterceptPhase (..), + JSUInt (..), + Request (..), + SetCacheBehavior (..) + ) +import Prelude hiding (log) + +-- Test which network commands are actually supported by the current driver + +-- >>> runDemo networkSupportTest +networkSupportTest :: BiDiDemo +networkSupportTest = + demo "Network Support Test - Check which commands are implemented" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + logTxt "Testing network command support in current WebDriver implementation..." + logTxt "Commands that fail with 'unknown command' are not yet implemented." + pause + + -- Test 1: addDataCollector + logTxt "Test 1: network.addDataCollector" + result1 <- + try $ + networkAddDataCollector $ + MkAddDataCollector + { dataTypes = [Response], + maxEncodedDataSize = MkJSUInt 1024, + collectorType = Nothing, + contexts = Nothing, + userContexts = Nothing + } + handleCommandResult result1 + pause + + -- Test 2: addIntercept + logTxt "Test 2: network.addIntercept" + result2 <- + try $ + networkAddIntercept $ + MkAddIntercept + { phases = [BeforeRequestSent], + contexts = Just [bc], + urlPatterns = Nothing + } + handleCommandResult result2 + pause + + -- Test 3: setCacheBehavior + logTxt "Test 3: network.setCacheBehavior" + result3 <- + try $ + networkSetCacheBehavior $ + MkSetCacheBehavior + { cacheBehavior = DefaultCacheBehavior, + contexts = Nothing + } + handleCommandResult result3 + pause + + -- Test 4: continueRequest (requires active intercept, so will fail with "no such request") + logTxt "Test 4: network.continueRequest" + result4 <- + try $ + networkContinueRequest $ + MkContinueRequest + { request = MkRequest "test-request-id", + body = Nothing, + cookies = Nothing, + headers = Nothing, + method = Nothing, + url = Nothing + } + handleCommandResult result4 + pause + + logTxt "Support test completed." + logTxt "❌ = Command not implemented in driver" + logTxt "✅ = Command supported and works (or exists but needs active request)" + logTxt "⚠️ = Command supported but failed for unexpected reason" + where + handleCommandResult :: Either SomeException a -> IO () + handleCommandResult = either handleError (const $ logTxt "✅ SUPPORTED") + where + handleError (e :: SomeException) = + let errIncludes = any (flip exceptionTextIncludes e) + in if + | errIncludes ["unknown command", "not supported"] -> + logShow "❌ NOT SUPPORTED (unknown command)" e + | errIncludes ["no such request", "not found"] -> + logTxt "✅ SUPPORTED (command exists but no active request - expected)" + | otherwise -> + do + logShow "⚠️ SUPPORTED but failed" e + throwIO e diff --git a/test/BiDi/Demos/OtherDemos.hs b/test/BiDi/Demos/OtherDemos.hs new file mode 100644 --- /dev/null +++ b/test/BiDi/Demos/OtherDemos.hs @@ -0,0 +1,70 @@ +module BiDi.Demos.OtherDemos where + +import BiDi.Actions (BiDiActions (..)) +import BiDi.DemoUtils +import Config (Config) +import ConfigLoader (loadConfig) +import Data.Text (Text) +import IOUtils (DemoActions (..)) +import TestData (navigation1Url, navigation2Url) +import BiDi.BiDiUrl (parseUrl) +import WebDriverPreCore.BiDi.Protocol + ( KnownSubscriptionType (..), + Navigate (..), + ReadinessState (..), + ) +import Utils (txt) +import Prelude hiding (log, putStrLn) + +-- low level demos - TODO turn into tests --- + +-- >>> parseUrlDemo +-- "Right\n MkBiDiUrl\n { host = \"127.0.0.1\"\n , port = 9222\n , path = \"/session/e43698d9-b02a-4284-a936-12041deb3552\"\n }" +parseUrlDemo :: Text +parseUrlDemo = txt $ parseUrl "ws://127.0.0.1:9222/session/e43698d9-b02a-4284-a936-12041deb3552" + + +-- Check expected errors when rigged to fail + +-- >>> evalFail getFailDemo +getFailDemo :: Config -> IO () +getFailDemo c = expectErrorText "getfail" "Forced failure for testing: get" $ runDemoFail' c 0 2 0 failDemo + +-- >>> evalFail sendFailDemo +sendFailDemo :: Config -> IO () +sendFailDemo c = expectErrorText "sendfail" "Forced failure for testing: send" $ runDemoFail' c 2 0 0 failDemo + +-- >>> evalFail eventFailDemo +eventFailDemo :: Config -> IO () +eventFailDemo c = expectErrorText "eventfail" "Forced failure for testing: eventhandler (call #2)" $ runDemoFail' c 0 0 2 failDemo +evalFail :: (Config -> IO ()) -> IO () +evalFail failAction = do + c <- loadConfig + failAction c + +-- >>> runDemo dummyDemo +failDemo :: BiDiDemo +failDemo = + demo "Fail demo" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {pause, logTxt, logShow, timeLimitLog} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + logTxt "Subscribe to navigation started events" + (startedEventFired, waitStartedEventFired) <- timeLimitLog BrowsingContextNavigationStarted + subscribeBrowsingContextNavigationStarted startedEventFired + + logTxt "Navigate to navigation1.html" + nav1 <- navigation1Url + navResult1 <- browsingContextNavigate $ MkNavigate {context = bc, url = nav1, wait = Just Complete} + logShow "Navigation result 1" navResult1 + pause + + logTxt "Navigate to navigation2.html" + nav2 <- navigation2Url + navResult2 <- browsingContextNavigate $ MkNavigate {context = bc, url = nav2, wait = Just Complete} + logShow "Navigation result 2" navResult2 + pause + + waitStartedEventFired diff --git a/test/BiDi/Demos/ScriptDemos.hs b/test/BiDi/Demos/ScriptDemos.hs new file mode 100644 --- /dev/null +++ b/test/BiDi/Demos/ScriptDemos.hs @@ -0,0 +1,1645 @@ +module BiDi.Demos.ScriptDemos where + +import BiDi.Actions (BiDiActions (..)) +import BiDi.DemoUtils + ( chkDomContains, + closeContext, + demo, + newWindowContext, + rootContext, + BiDiDemo ) +import Data.Aeson (ToJSON (..)) +import Data.Maybe (catMaybes) +import Data.Text (isInfixOf, pack) +import IOUtils (DemoActions (..)) + +import WebDriverPreCore.BiDi.Protocol + ( JSUInt(..), + CreateUserContext(..), + RemoveUserContext(..), + Activate(..), + Create(..), + CreateType(..), + Navigate(..), + ReadinessState(..), + StringValue(..), + AddPreloadScript(..), + AddPreloadScriptResult(..), + BaseRealmInfo(..), + CallFunction(..), + Channel(..), + ChannelProperties(..), + ChannelValue(..), + ContextTarget(..), + Disown(..), + Evaluate(..), + EvaluateResult(..), + GetRealms(..), + GetRealmsResult(..), + IncludeShadowTree(..), + LocalValue(..), + MappingLocalValue(..), + ObjectLocalValue(..), + PrimitiveProtocolValue(..), + RealmInfo(..), + RealmType(..), + RemoteValue(..), + RemovePreloadScript(..), + ResultOwnership(..), + Sandbox(..), + SerializationOptions(..), + Target(..), + URL(..) ) + +import Prelude hiding (log, putStrLn) +import Const (milliseconds) + + +-- >>> runDemo scriptEvaluateAllPrimitiveTypesDemo +scriptEvaluateAllPrimitiveTypesDemo :: BiDiDemo +scriptEvaluateAllPrimitiveTypesDemo = + demo "Script - Evaluate All PrimitiveProtocolValue Types" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + let baseEval = + MkEvaluate + { expression = "alert('Hello from Pyrethrum BiDi!')", + target = + ContextTarget $ + MkContextTarget + { context = bc, + sandbox = Nothing + }, + awaitPromise = True, + resultOwnership = Nothing, + serializationOptions = Nothing + } + + logTxt "Test 1: Undefined evaluation - returns UndefinedValue" + r1 <- scriptEvaluate $ baseEval {expression = "undefined"} + logShow "Script evaluation result - undefined" r1 + pause + + logTxt "Test 2: Null evaluation - returns NullValue" + r2 <- scriptEvaluate $ baseEval {expression = "null"} + logShow "Script evaluation result - null" r2 + pause + + logTxt "Test 3: String evaluation - returns StringValue" + r3 <- scriptEvaluate $ baseEval {expression = "'Hello from BiDi Script!'"} + logShow "Script evaluation result - string" r3 + pause + + logTxt "Test 4: String evaluation with escape characters" + r4 <- scriptEvaluate $ baseEval {expression = "'Line 1\\nLine 2\\tTabbed'"} + logShow "Script evaluation result - string with escapes" r4 + pause + + logTxt "Test 5: Number evaluation - integer" + r5 <- scriptEvaluate $ baseEval {expression = "42"} + logShow "Script evaluation result - number (integer)" r5 + pause + + logTxt "Test 6: Number evaluation - float" + r6 <- scriptEvaluate $ baseEval {expression = "3.14159"} + logShow "Script evaluation result - number (float)" r6 + pause + + logTxt "Test 7: Number evaluation - negative" + r7 <- scriptEvaluate $ baseEval {expression = "-123.456"} + logShow "Script evaluation result - number (negative)" r7 + pause + + logTxt "Test 8: Number evaluation - zero" + r8 <- scriptEvaluate $ baseEval {expression = "0"} + logShow "Script evaluation result - number (zero)" r8 + pause + + logTxt "Test 9: Special Number - NaN" + r9 <- scriptEvaluate $ baseEval {expression = "NaN"} + logShow "Script evaluation result - NaN" r9 + pause + + logTxt "Test 10: Special Number - Negative Zero" + r10 <- scriptEvaluate $ baseEval {expression = "-0"} + logShow "Script evaluation result - negative zero" r10 + pause + + logTxt "Test 11: Special Number - Infinity" + r11 <- scriptEvaluate $ baseEval {expression = "Infinity"} + logShow "Script evaluation result - Infinity" r11 + pause + + logTxt "Test 12: Special Number - Negative Infinity" + r12 <- scriptEvaluate $ baseEval {expression = "-Infinity"} + logShow "Script evaluation result - Negative Infinity" r12 + pause + + logTxt "Test 13: Special Number - Division by zero (Infinity)" + r13 <- scriptEvaluate $ baseEval {expression = "1 / 0"} + logShow "Script evaluation result - 1/0 = Infinity" r13 + pause + + logTxt "Test 14: Special Number - Invalid operation (NaN)" + r14 <- scriptEvaluate $ baseEval {expression = "Math.sqrt(-1)"} + logShow "Script evaluation result - sqrt(-1) = NaN" r14 + pause + + logTxt "Test 15: Boolean evaluation - true" + r15 <- scriptEvaluate $ baseEval {expression = "true"} + logShow "Script evaluation result - boolean true" r15 + pause + + logTxt "Test 16: Boolean evaluation - false" + r16 <- scriptEvaluate $ baseEval {expression = "false"} + logShow "Script evaluation result - boolean false" r16 + pause + + logTxt "Test 17: Boolean evaluation - truthy expression" + r17 <- scriptEvaluate $ baseEval {expression = "!!'hello'"} + logShow "Script evaluation result - !!string = true" r17 + pause + + logTxt "Test 18: Boolean evaluation - falsy expression" + r18 <- scriptEvaluate $ baseEval {expression = "!!0"} + logShow "Script evaluation result - !!0 = false" r18 + pause + + logTxt "Test 19: BigInt evaluation - small BigInt" + r19 <- scriptEvaluate $ baseEval {expression = "42n"} + logShow "Script evaluation result - BigInt 42n" r19 + pause + + logTxt "Test 20: BigInt evaluation - large BigInt" + r20 <- scriptEvaluate $ baseEval {expression = "9007199254740991n"} + logShow "Script evaluation result - BigInt (Number.MAX_SAFE_INTEGER)" r20 + pause + + logTxt "Test 21: BigInt evaluation - very large BigInt" + r21 <- scriptEvaluate $ baseEval {expression = "12345678901234567890123456789012345678901234567890n"} + logShow "Script evaluation result - very large BigInt" r21 + pause + + logTxt "Test 22: BigInt evaluation - negative BigInt" + r22 <- scriptEvaluate $ baseEval {expression = "-9007199254740991n"} + logShow "Script evaluation result - negative BigInt" r22 + pause + + logTxt "Test 23: BigInt evaluation - zero BigInt" + r23 <- scriptEvaluate $ baseEval {expression = "0n"} + logShow "Script evaluation result - BigInt zero" r23 + pause + + logTxt "Test 24: BigInt evaluation - BigInt arithmetic" + r24 <- scriptEvaluate $ baseEval {expression = "BigInt(123) * BigInt(456)"} + logShow "Script evaluation result - BigInt arithmetic" r24 + pause + + logTxt "Test 25: Complex expression evaluation - mixed types in comparison" + r25 <- scriptEvaluate $ baseEval {expression = "typeof 'string' === 'string'"} + logShow "Script evaluation result - typeof comparison" r25 + pause + + logTxt "Test 26: Complex expression evaluation - Number.isNaN" + r26 <- scriptEvaluate $ baseEval {expression = "Number.isNaN(NaN)"} + logShow "Script evaluation result - Number.isNaN(NaN)" r26 + pause + + logTxt "Test 27: Complex expression evaluation - Number.isFinite" + r27 <- scriptEvaluate $ baseEval {expression = "Number.isFinite(42)"} + logShow "Script evaluation result - Number.isFinite(42)" r27 + pause + + logTxt "Test 28: Empty string evaluation" + r28 <- scriptEvaluate $ baseEval {expression = "''"} + logShow "Script evaluation result - empty string" r28 + pause + + logTxt "Test 29: Unicode string evaluation" + r29 <- scriptEvaluate $ baseEval {expression = "'Hello 🌍 World! αβγ 中文'"} + logShow "Script evaluation result - unicode string" r29 + pause + + logTxt "Test 30: Mathematical constants" + r30 <- scriptEvaluate $ baseEval {expression = "Math.PI"} + logShow "Script evaluation result - Math.PI" r30 + pause + +-- >>> runDemo scriptEvaluateAdvancedDemo +scriptEvaluateAdvancedDemo :: BiDiDemo +scriptEvaluateAdvancedDemo = + demo "Script - Evaluate Advanced Types and Edge Cases" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + let baseEval = + MkEvaluate + { expression = "", + target = + ContextTarget $ + MkContextTarget + { context = bc, + sandbox = Nothing + }, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + + logTxt "Advanced Test 1: Array evaluation (non-primitive)" + a1 <- scriptEvaluate $ baseEval {expression = "[1, 2, 3, 'hello', true, null]"} + logShow "Script evaluation result - array" a1 + pause + + logTxt "Advanced Test 2: Object evaluation (non-primitive)" + a2 <- scriptEvaluate $ baseEval {expression = "{ name: 'BiDi', version: 1.0, active: true }"} + logShow "Script evaluation result - object" a2 + pause + + logTxt "Advanced Test 3: Function evaluation (non-primitive)" + a3 <- scriptEvaluate $ baseEval {expression = "function greet(name) { return 'Hello, ' + name; }"} + logShow "Script evaluation result - function" a3 + pause + + logTxt "Advanced Test 4: Date evaluation (non-primitive)" + a4 <- scriptEvaluate $ baseEval {expression = "new Date('2024-01-15T10:30:00Z')"} + logShow "Script evaluation result - date" a4 + pause + + logTxt "Advanced Test 5: RegExp evaluation (non-primitive)" + a5 <- scriptEvaluate $ baseEval {expression = "/^[a-z]+$/gi"} + logShow "Script evaluation result - regexp" a5 + pause + + logTxt "Advanced Test 6: Promise evaluation - resolved (awaitPromise=False)" + a6 <- scriptEvaluate $ baseEval {expression = "Promise.resolve('resolved value')"} + logShow "Script evaluation result - promise (not awaited)" a6 + pause + + logTxt "Advanced Test 7: Promise evaluation - resolved (awaitPromise=True)" + a7 <- scriptEvaluate $ baseEval {expression = "Promise.resolve('resolved value')", awaitPromise = True} + logShow "Script evaluation result - promise (awaited)" a7 + pause + + logTxt "Advanced Test 8: Symbol evaluation (non-primitive)" + a8 <- scriptEvaluate $ baseEval {expression = "Symbol('test-symbol')"} + logShow "Script evaluation result - symbol" a8 + pause + + logTxt "Advanced Test 9: Error evaluation" + a9 <- scriptEvaluate $ baseEval {expression = "new Error('Test error message')"} + logShow "Script evaluation result - error object" a9 + pause + + logTxt "Advanced Test 10: Throw error evaluation (should produce exception result)" + a10 <- scriptEvaluate $ baseEval {expression = "throw new Error('Intentional test error')"} + logShow "Script evaluation result - thrown error" a10 + pause + + logTxt "Advanced Test 11: DOM element evaluation (if available)" + a11 <- scriptEvaluate $ baseEval {expression = "document.body || 'no document.body'"} + logShow "Script evaluation result - DOM element or fallback" a11 + pause + + logTxt "Advanced Test 12: Window proxy evaluation" + a12 <- scriptEvaluate $ baseEval {expression = "window"} + logShow "Script evaluation result - window proxy" a12 + pause + + logTxt "Advanced Test 13: Map evaluation (ES6 collection)" + a13 <- scriptEvaluate $ baseEval {expression = "new Map([['key1', 'value1'], ['key2', 42]])"} + logShow "Script evaluation result - Map" a13 + pause + + logTxt "Advanced Test 14: Set evaluation (ES6 collection)" + a14 <- scriptEvaluate $ baseEval {expression = "new Set([1, 2, 3, 1, 2])"} + logShow "Script evaluation result - Set" a14 + pause + + logTxt "Advanced Test 15: WeakMap evaluation (ES6 collection)" + a15 <- scriptEvaluate $ baseEval {expression = "new WeakMap()"} + logShow "Script evaluation result - WeakMap" a15 + pause + + logTxt "Advanced Test 16: WeakSet evaluation (ES6 collection)" + a16 <- scriptEvaluate $ baseEval {expression = "new WeakSet()"} + logShow "Script evaluation result - WeakSet" a16 + pause + + logTxt "Advanced Test 17: Generator function evaluation" + a17 <- scriptEvaluate $ baseEval {expression = "function* gen() { yield 1; yield 2; }"} + logShow "Script evaluation result - generator function" a17 + pause + + logTxt "Advanced Test 18: Generator evaluation" + a18 <- scriptEvaluate $ baseEval {expression = "(function* gen() { yield 1; yield 2; })()"} + logShow "Script evaluation result - generator" a18 + pause + + logTxt "Advanced Test 19: Proxy evaluation" + a19 <- scriptEvaluate $ baseEval {expression = "new Proxy({}, { get: (target, prop) => 'proxied: ' + prop })"} + logShow "Script evaluation result - proxy" a19 + pause + + logTxt "Advanced Test 20: ArrayBuffer evaluation (typed arrays)" + a20 <- scriptEvaluate $ baseEval {expression = "new ArrayBuffer(16)"} + logShow "Script evaluation result - ArrayBuffer" a20 + pause + + logTxt "Advanced Test 21: Typed array evaluation (Uint8Array)" + a21 <- scriptEvaluate $ baseEval {expression = "new Uint8Array([1, 2, 3, 4, 5])"} + logShow "Script evaluation result - Uint8Array" a21 + pause + + logTxt "Advanced Test 22: Complex expression with mixed primitive types" + a22 <- scriptEvaluate $ baseEval {expression = "({ str: 'text', num: 42, bool: true, nul: null, undef: undefined, big: 123n })"} + logShow "Script evaluation result - object with all primitive types" a22 + pause + + logTxt "Advanced Test 23: Serialization options test - limited depth" + a23 <- + scriptEvaluate $ + baseEval + { expression = "({ level1: { level2: { level3: { deep: 'value' } } } })", + serializationOptions = + Just $ + MkSerializationOptions + { maxDomDepth = Just (Just (MkJSUInt 2)), + maxObjectDepth = Just (Just (MkJSUInt 1)), + includeShadowTree = Just ShadowTreeNone + } + } + logShow "Script evaluation result - limited serialization depth" a23 + pause + + logTxt "Advanced Test 24: Result ownership test" + a24 <- + scriptEvaluate $ + baseEval + { expression = "({ data: 'for ownership test' })", + resultOwnership = Just Root + } + logShow "Script evaluation result - with ownership" a24 + pause + + logTxt "Advanced Test 25: Sandbox evaluation" + a25 <- + scriptEvaluate $ + baseEval + { expression = "typeof sandbox_test_var", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Just $ MkSandbox "test-sandbox"} + } + logShow "Script evaluation result - in sandbox" a25 + pause + + +-- >>> runDemo serializationOptionsDemo +serializationOptionsDemo :: BiDiDemo +serializationOptionsDemo = + demo "Serialization Options - Various Configurations" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} _bidi = do + let logOps msg = logJSON msg . toJSON + + logOps "JSON for Nothing serializationOptions" $ + MkSerializationOptions + { maxDomDepth = Nothing, + maxObjectDepth = Nothing, + includeShadowTree = Nothing + } + pause + + logOps "JSON for maxDomDepth serializationOptions" $ + MkSerializationOptions + { maxDomDepth = Just (Just (MkJSUInt 3)), + maxObjectDepth = Nothing, + includeShadowTree = Nothing + } + pause + + logOps "JSON for maxDomDepth Nothing serializationOptions" $ + MkSerializationOptions + { maxDomDepth = Just Nothing, + maxObjectDepth = Nothing, + includeShadowTree = Nothing + } + pause + + logOps "JSON for maxObjectDepth serializationOptions" $ + MkSerializationOptions + { maxDomDepth = Nothing, + maxObjectDepth = Just (Just (MkJSUInt 2)), + includeShadowTree = Nothing + } + pause + + logOps "JSON for maxObjectDepth Nothing serializationOptions" $ + MkSerializationOptions + { maxDomDepth = Nothing, + maxObjectDepth = Just Nothing, + includeShadowTree = Nothing + } + pause + + logOps "JSON for includeShadowTree None serializationOptions" $ + MkSerializationOptions + { maxDomDepth = Nothing, + maxObjectDepth = Nothing, + includeShadowTree = Just ShadowTreeNone + } + pause + + logOps "JSON for includeShadowTree Open serializationOptions" $ + MkSerializationOptions + { maxDomDepth = Nothing, + maxObjectDepth = Nothing, + includeShadowTree = Just Open + } + pause + + logOps "JSON for includeShadowTree All serializationOptions" $ + MkSerializationOptions + { maxDomDepth = Nothing, + maxObjectDepth = Nothing, + includeShadowTree = Just All + } + pause + + logOps "JSON for all options set serializationOptions" $ + MkSerializationOptions + { maxDomDepth = Just (Just (MkJSUInt 5)), + maxObjectDepth = Just (Just (MkJSUInt 3)), + includeShadowTree = Just Open + } + pause + + logOps "JSON for all options Nothing serializationOptions" $ + MkSerializationOptions + { maxDomDepth = Just Nothing, + maxObjectDepth = Just Nothing, + includeShadowTree = Just ShadowTreeNone + } + pause + +-- >>> runDemo scriptPreloadScriptDemo +scriptPreloadScriptDemo :: BiDiDemo +scriptPreloadScriptDemo = + -- • functionDeclaration property - basic JavaScript function execution + -- • contexts property - targeting specific browsing contexts vs all contexts + -- • sandbox property - script isolation and sandboxing + demo "Script I - Basic Preload Script Properties" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + let chkDOM = chkDomContains utils bidi bc + + logTxt "Navigate to a simple test page" + navResult <- browsingContextNavigate $ MkNavigate {context = bc, url = MkUrl "data:text/html,Preload Script Test

Test Page

Original content

", wait = Just Complete} + logShow "Navigation result" navResult + pause + + logTxt "Test 1: Basic preload script with functionDeclaration and contexts" + preloadScript1 <- + scriptAddPreloadScript $ + MkAddPreloadScript + { functionDeclaration = + "function() {\ + \ document.addEventListener('DOMContentLoaded', function() {\ + \ var indicator = document.getElementById('preload-indicator');\ + \ if (indicator) {\ + \ indicator.innerHTML = '

✓ Basic Preload Script executed!

';\ + \ }\ + \ var content = document.getElementById('content');\ + \ if (content) {\ + \ content.style.backgroundColor = 'lightblue';\ + \ content.innerHTML = 'Content modified by basic preload script!';\ + \ }\ + \ });\ + \}", + arguments = Nothing, + userContexts = Nothing, + contexts = Just [bc], + sandbox = Nothing + } + logShow "Basic preload script added" preloadScript1 + pause + + logTxt "Test 2: Preload script with sandbox isolation" + preloadScriptSandbox <- + scriptAddPreloadScript $ + MkAddPreloadScript + { functionDeclaration = + "function() { \ + \ window.sandboxedVariable = 'This should be isolated in sandbox'; \ + \ document.addEventListener('DOMContentLoaded', function() { \ + \ var notice = document.createElement('div'); \ + \ notice.id = 'sandbox-notice'; \ + \ notice.style.cssText = 'background: yellow; padding: 10px; margin: 5px; border: 2px solid orange;'; \ + \ notice.innerHTML = 'Sandboxed Script: Executed in isolated environment'; \ + \ document.body.appendChild(notice); \ + \ }); \ + \}", + arguments = Nothing, + userContexts = Nothing, + contexts = Just [bc], + sandbox = Just "isolated-sandbox" + } + logShow "Sandboxed preload script added" preloadScriptSandbox + pause + + logTxt "Test 3: Preload script with all contexts (global scope)" + preloadScript2 <- + scriptAddPreloadScript $ + MkAddPreloadScript + { functionDeclaration = + "function() { \ + \ window.PRELOADED_DATA = { \ + \ message: 'Hello from global preload script!', \ + \ timestamp: new Date().toISOString() \ + \ }; \ + \ console.log('Global Preload Script: Added global data', window.PRELOADED_DATA); \ + \}", + arguments = Nothing, + userContexts = Nothing, + contexts = Nothing, -- Apply to all contexts + sandbox = Nothing + } + logShow "Global preload script added" preloadScript2 + pause + + logTxt "Test 4: Navigate to a new page to see all preload scripts in action" + navResult2 <- + browsingContextNavigate $ + MkNavigate + { context = bc, + url = MkUrl "data:text/html,New Page

New Test Page

Fresh content

", + wait = Just Complete + } + logShow "Navigation result to new page" navResult2 + pause + + -- Wait a bit for the preload scripts to execute + + logTxt "Test 5: Check if basic preload script executed (DOM modifications)" + chkDOM "✓ Basic Preload Script executed!" + chkDOM "Content modified by basic preload script!" + pause + + logTxt "Test 6: Check if sandboxed script executed (isolated execution)" + chkDOM "Sandboxed Script:" + chkDOM "Executed in isolated environment" + pause + + logTxt "Test 7: Check if global preload script executed (all contexts)" + -- Check if global data was added by evaluating a script that outputs to DOM + scriptEvaluateNoWait $ + MkEvaluate + { expression = + "if (window.PRELOADED_DATA) { \ + \ document.body.innerHTML += '
Global data present: ' + JSON.stringify(window.PRELOADED_DATA) + '
'; \ + \} else { \ + \ document.body.innerHTML += '
No global data found
'; \ + \}", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + chkDOM "Global data present:" + chkDOM "Hello from global preload script!" + pause + + logTxt "Test 8: Verify sandbox isolation by checking if sandboxed variables are isolated" + scriptEvaluateNoWait $ + MkEvaluate + { expression = + "var isolationTest = 'main context variable'; \ + \if (typeof window.sandboxedVariable !== 'undefined') { \ + \ document.body.innerHTML += '
WARNING: Sandbox leak detected - sandboxedVariable accessible
'; \ + \} else { \ + \ document.body.innerHTML += '
✓ Sandbox isolation confirmed - sandboxedVariable not accessible
'; \ + \}", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + chkDOM "✓ Sandbox isolation confirmed" + pause + +-- >>> runDemo scriptPreloadScriptMultiContextDemo +scriptPreloadScriptMultiContextDemo :: BiDiDemo +scriptPreloadScriptMultiContextDemo = + -- • contexts property - multiple browsing context management and targeting + -- • scriptRemovePreloadScript - selective script removal and cleanup + -- • Cross-context script behavior and isolation verification + demo "Script II - Multi-Context and Cleanup" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + let chkDOM = chkDomContains utils bidi bc + + logTxt "Create a new browsing context to test multiple contexts behavior" + newContext <- newWindowContext utils bidi + + logTxt "Add a preload script specific to the new context only" + preloadScriptNewContext <- + scriptAddPreloadScript $ + MkAddPreloadScript + { functionDeclaration = + "function() { \ + \ window.addEventListener('load', function() { \ + \ var body = document.body; \ + \ if (body) { \ + \ var notice = document.createElement('div'); \ + \ notice.style.cssText = 'position: fixed; top: 10px; right: 10px; background: pink; padding: 10px; border: 2px solid red; z-index: 9999;'; \ + \ notice.innerHTML = 'New Context Script!
Only in new window'; \ + \ body.appendChild(notice); \ + \ } \ + \ }); \ + \}", + arguments = Nothing, + userContexts = Nothing, + contexts = Just [newContext], -- Only apply to new context + sandbox = Nothing + } + logShow "Context-specific preload script added" preloadScriptNewContext + pause + + logTxt "Add a global preload script for comparison" + globalScript <- + scriptAddPreloadScript $ + MkAddPreloadScript + { functionDeclaration = + "function() { \ + \ window.GLOBAL_PRELOAD_DATA = { \ + \ message: 'Global script active', \ + \ timestamp: new Date().toISOString() \ + \ }; \ + \}", + arguments = Nothing, + userContexts = Nothing, + contexts = Nothing, -- Apply to all contexts + sandbox = Nothing + } + logShow "Global preload script added" globalScript + pause + + logTxt "Navigate both contexts to see context-specific script behavior" + navResult3 <- browsingContextNavigate $ MkNavigate {context = bc, url = MkUrl "data:text/html,Original Context

Original Context Page

Original context content

", wait = Just Complete} + logShow "Navigation result - original context" navResult3 + pause + + navResultNew <- browsingContextNavigate $ MkNavigate {context = newContext, url = MkUrl "data:text/html,New Context

New Context Page

New context content

", wait = Just Complete} + logShow "Navigation result - new context" navResultNew + pause + + -- Wait for all preload scripts to execute + pauseAtLeast $ 1500 * milliseconds + + logTxt "Verify original context has only global script (no context-specific script)" + scriptEvaluateNoWait $ + MkEvaluate + { expression = + "if (window.GLOBAL_PRELOAD_DATA) { \ + \ document.body.innerHTML += '
Original context global data confirmed
'; \ + \}", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + chkDOM "Original context global data confirmed" + pause + + logTxt "Check new context has both global and context-specific scripts" + -- Switch to new context for validation + browsingContextActivate $ MkActivate newContext + pauseAtLeast $ 500 * milliseconds + + -- Check new context content using scripts that add to DOM + scriptEvaluateNoWait $ + MkEvaluate + { expression = + "if (window.GLOBAL_PRELOAD_DATA) { \ + \ document.body.innerHTML += '
New context has global data
'; \ + \} else { \ + \ document.body.innerHTML += '
New context missing global data
'; \ + \} \ + \if (document.querySelector('div[style*=\"position: fixed\"]')) { \ + \ document.body.innerHTML += '
New context has fixed position element
'; \ + \}", + target = ContextTarget $ MkContextTarget {context = newContext, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + pauseAtLeast $ 500 * milliseconds + + -- For new context validation, we need to get DOM content from the new context + domContentNew <- + scriptEvaluate $ + MkEvaluate + { expression = "document.body ? document.body.innerText || document.body.textContent || '' : ''", + target = ContextTarget $ MkContextTarget {context = newContext, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + + case domContentNew of + EvaluateResultSuccess {result = PrimitiveValue (StringValue (MkStringValue newContextText))} -> do + logTxt $ "New context DOM content: " <> newContextText + if "New context has global data" `isInfixOf` newContextText + then logTxt "✓ New context has global script effects" + else logTxt "✗ New context missing global script effects" + if "New Context Script!" `isInfixOf` newContextText + then logTxt "✓ New context has context-specific script effects" + else logTxt "✗ New context missing context-specific script effects" + _ -> logTxt "Could not read new context DOM content" + pause + + logTxt "Test selective script removal - Remove context-specific script" + let MkAddPreloadScriptResult scriptNewContextId = preloadScriptNewContext + removeResultNewContext <- scriptRemovePreloadScript $ MkRemovePreloadScript scriptNewContextId + logShow "Removed new context preload script" removeResultNewContext + pause + + logTxt "Navigate original context to verify global script still works" + browsingContextActivate $ MkActivate bc + pauseAtLeast $ 500 * milliseconds + + navResult4 <- browsingContextNavigate $ MkNavigate {context = bc, url = MkUrl "data:text/html,After Context Removal

After Context Script Removal

Content after context removal

", wait = Just Complete} + logShow "Navigation after context script removal" navResult4 + pause + + -- Wait for remaining preload scripts + pauseAtLeast $ 1500 * milliseconds + + logTxt "Verify global script still works after context-specific removal" + scriptEvaluateNoWait $ + MkEvaluate + { expression = + "if (window.GLOBAL_PRELOAD_DATA) { \ + \ document.body.innerHTML += '
Global script still active after context removal
'; \ + \}", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + chkDOM "Global script still active after context removal" + pause + + logTxt "Remove global preload script for complete cleanup" + let MkAddPreloadScriptResult globalScriptId = globalScript + removeResultGlobal <- scriptRemovePreloadScript $ MkRemovePreloadScript globalScriptId + logShow "Removed global preload script" removeResultGlobal + pause + + logTxt "Final navigation to verify complete cleanup" + navResult5 <- browsingContextNavigate $ MkNavigate {context = bc, url = MkUrl "data:text/html,Clean Page

Clean Page - No Preload Scripts

Clean content

", wait = Just Complete} + logShow "Final navigation - clean page" navResult5 + pause + + -- Wait to ensure no preload scripts run + pauseAtLeast $ 1000 * milliseconds + + logTxt "Final verification - no preload script effects should be present" + scriptEvaluateNoWait $ + MkEvaluate + { expression = + "if (!window.GLOBAL_PRELOAD_DATA && !document.querySelector('div[style*=\"position: fixed\"]') && !document.querySelector('#sandbox-notice')) { \ + \ document.body.innerHTML += '
✓ Complete cleanup confirmed: No preload effects
'; \ + \} else { \ + \ document.body.innerHTML += '
⚠ Warning: Some preload effects still detected
'; \ + \}", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + chkDOM "✓ Complete cleanup confirmed: No preload effects" + pause + + logTxt "Cleanup - close the new context" + closeContext utils bidi newContext + +-- >>> runDemo scriptChannelArgumentDemo +scriptChannelArgumentDemo :: BiDiDemo +scriptChannelArgumentDemo = + demo "Script III - Channel Argument Test" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + let chkDOM = chkDomContains utils bidi bc + + logTxt "Navigate to a simple test page for channel test" + navResult <- browsingContextNavigate $ MkNavigate {context = bc, url = MkUrl "data:text/html,Channel Test

Channel Test Page

", wait = Just Complete} + logShow "Navigation result" navResult + pause + + logTxt "Create channel value for preload script arguments" + let channelValue = + MkChannelValue + { value = + MkChannelProperties + { channel = Channel "test-channel", + serializationOptions = Nothing, + ownership = Nothing + } + } + + logTxt "Add preload script with channel argument" + preloadScriptWithChannel <- + scriptAddPreloadScript $ + MkAddPreloadScript + { functionDeclaration = + "function(channelArg) { \ + \ console.log('Channel arg received:', channelArg); \ + \ window.addEventListener('DOMContentLoaded', function() { \ + \ var output = document.getElementById('output'); \ + \ if (output) { \ + \ var div = document.createElement('div'); \ + \ div.id = 'channel-result'; \ + \ div.style.cssText = 'background: lightgreen; padding: 10px; border: 2px solid green; margin: 5px;'; \ + \ if (channelArg) { \ + \ div.innerHTML = '✓ Channel Argument Success: Received channel object'; \ + \ } else { \ + \ div.innerHTML = '✗ Channel Argument Failed: No channel received'; \ + \ } \ + \ output.appendChild(div); \ + \ } \ + \ }); \ + \}", + arguments = Just [channelValue], + contexts = Just [bc], + userContexts = Nothing, + sandbox = Nothing + } + logShow "Preload script with channel added" preloadScriptWithChannel + pause + + logTxt "Navigate to trigger preload script execution" + navResult2 <- browsingContextNavigate $ MkNavigate {context = bc, url = MkUrl "data:text/html,Channel Test Execution

Testing Channel Arguments

", wait = Just Complete} + logShow "Navigation result for execution" navResult2 + pause + + logTxt "Check if channel argument was received successfully" + chkDOM "✓ Channel Argument Success" + chkDOM "Received channel object" + pause + + logTxt "Clean up - remove the channel preload script" + let MkAddPreloadScriptResult scriptId = preloadScriptWithChannel + removeResult <- scriptRemovePreloadScript $ MkRemovePreloadScript scriptId + logShow "Removed channel preload script" removeResult + pause + + logTxt "Final verification - navigate to clean page" + navResultFinal <- browsingContextNavigate $ MkNavigate {context = bc, url = MkUrl "data:text/html,Clean Final

Clean Page

", wait = Just Complete} + logShow "Final clean navigation" navResultFinal + pause + + -- Check DOM is clean (no channel script effects + domContent <- + scriptEvaluate $ + MkEvaluate + { expression = "document.body ? document.body.innerText || document.body.textContent || '' : ''", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + + case domContent of + EvaluateResultSuccess {result = PrimitiveValue (StringValue (MkStringValue cleanText))} -> do + if "Channel Argument Success" `isInfixOf` cleanText + then logTxt "⚠ Warning: Channel script effects still present after removal" + else logTxt "✓ Confirmed: Clean state - no channel script effects" + _ -> logTxt "Could not verify clean state" + pause + +-- >>> runDemo scriptUserContextsDemo +scriptUserContextsDemo :: BiDiDemo +scriptUserContextsDemo = + demo "Script IV - UserContexts Property Exclusive Demo" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + logTxt "Creating multiple user contexts to demonstrate userContexts property" + + logTxt "Create User Context 1 - isolated environment" + userContext1 <- + browserCreateUserContext + MkCreateUserContext + { insecureCerts = Just True, + proxy = Nothing, + unhandledPromptBehavior = Nothing + } + logShow "User Context 1 created" userContext1 + pause + + logTxt "Create User Context 2 - different configuration" + userContext2 <- + browserCreateUserContext + MkCreateUserContext + { insecureCerts = Just False, + proxy = Nothing, + unhandledPromptBehavior = Nothing + } + logShow "User Context 2 created" userContext2 + pause + + logTxt "Create User Context 3 - additional isolation" + userContext3 <- + browserCreateUserContext + MkCreateUserContext + { insecureCerts = Nothing, + proxy = Nothing, + unhandledPromptBehavior = Nothing + } + logShow "User Context 3 created" userContext3 + pause + + logTxt "Get all existing user contexts to verify creation" + allUserContexts <- browserGetUserContexts + logShow "All user contexts available" allUserContexts + pause + + logTxt "Test 1: Add preload script targeting specific user contexts only" + preloadScriptSpecificUsers <- + scriptAddPreloadScript $ + MkAddPreloadScript + { functionDeclaration = + "function() { \ + \ window.USER_CONTEXT_SPECIFIC_DATA = { \ + \ message: 'This script targets specific user contexts only!', \ + \ timestamp: new Date().toISOString(), \ + \ source: 'userContexts-specific-script' \ + \ }; \ + \ document.addEventListener('DOMContentLoaded', function() { \ + \ var indicator = document.createElement('div'); \ + \ indicator.id = 'user-context-indicator'; \ + \ indicator.style.cssText = 'background: purple; color: white; padding: 15px; margin: 10px; border: 3px solid indigo; border-radius: 5px;'; \ + \ indicator.innerHTML = '✓ UserContexts Script Active!
Targeting specific user contexts: [UC1, UC2]'; \ + \ document.body.appendChild(indicator); \ + \ }); \ + \}", + arguments = Nothing, + contexts = Nothing, -- Apply to all browsing contexts + userContexts = Just [userContext1, userContext2], -- Only these user contexts + sandbox = Nothing + } + logShow "UserContexts-specific preload script added" preloadScriptSpecificUsers + pause + + logTxt "Test 2: Add preload script with no userContexts restriction (global)" + preloadScriptGlobal <- + scriptAddPreloadScript $ + MkAddPreloadScript + { functionDeclaration = + "function() { \ + \ window.GLOBAL_USER_CONTEXT_DATA = { \ + \ message: 'Global script - all user contexts', \ + \ timestamp: new Date().toISOString() \ + \ }; \ + \ document.addEventListener('DOMContentLoaded', function() { \ + \ var indicator = document.createElement('div'); \ + \ indicator.id = 'global-indicator'; \ + \ indicator.style.cssText = 'background: gray; color: white; padding: 10px; margin: 5px; border: 2px solid black;'; \ + \ indicator.innerHTML = 'Global Script Active
No userContexts restriction'; \ + \ document.body.appendChild(indicator); \ + \ }); \ + \}", + arguments = Nothing, + contexts = Nothing, + userContexts = Nothing, -- Apply to all user contexts + sandbox = Nothing + } + logShow "Global (no userContexts restriction) preload script added" preloadScriptGlobal + pause + + logTxt "Test 3: Add preload script targeting only UserContext3" + preloadScriptSingleUser <- + scriptAddPreloadScript $ + MkAddPreloadScript + { functionDeclaration = + "function() { \ + \ window.SINGLE_USER_CONTEXT_DATA = { \ + \ message: 'Single user context script - UC3 only!', \ + \ userContext: 'UC3', \ + \ timestamp: new Date().toISOString() \ + \ }; \ + \ document.addEventListener('DOMContentLoaded', function() { \ + \ var indicator = document.createElement('div'); \ + \ indicator.id = 'single-user-indicator'; \ + \ indicator.style.cssText = 'background: orange; color: black; padding: 12px; margin: 8px; border: 2px solid darkorange; font-weight: bold;'; \ + \ indicator.innerHTML = '✓ Single UserContext Script!
Only UserContext3 targeted'; \ + \ document.body.appendChild(indicator); \ + \ }); \ + \}", + arguments = Nothing, + contexts = Nothing, + userContexts = Just [userContext3], -- Only userContext3 + sandbox = Nothing + } + logShow "Single UserContext (UC3) preload script added" preloadScriptSingleUser + pause + + logTxt "Create browsing contexts in different user contexts to test script targeting" + + logTxt "Create browsing context in UserContext1" + bcUserContext1 <- + browsingContextCreate $ + MkCreate + { createType = Tab, + background = False, + referenceContext = Nothing, + userContext = Just userContext1 + } + logShow "Browsing context in UserContext1" bcUserContext1 + pause + + logTxt "Create browsing context in UserContext2" + bcUserContext2 <- + browsingContextCreate $ + MkCreate + { createType = Tab, + background = False, + referenceContext = Nothing, + userContext = Just userContext2 + } + logShow "Browsing context in UserContext2" bcUserContext2 + pause + + logTxt "Create browsing context in UserContext3" + bcUserContext3 <- + browsingContextCreate $ + MkCreate + { createType = Tab, + background = False, + referenceContext = Nothing, + userContext = Just userContext3 + } + logShow "Browsing context in UserContext3" bcUserContext3 + pause + + logTxt "Test script execution in UserContext1 - should have specific AND global scripts" + browsingContextActivate $ MkActivate bcUserContext1 + pauseAtLeast $ 500 * milliseconds + + navResultUC1 <- browsingContextNavigate $ MkNavigate {context = bcUserContext1, url = MkUrl "data:text/html,UserContext1 Test

UserContext1 Page

Testing UserContext1
", wait = Just Complete} + logShow "Navigation in UserContext1" navResultUC1 + pauseAtLeast $ 1500 * milliseconds -- Wait for preload scripts + logTxt "Verify UserContext1 has both global and specific scripts" + scriptEvaluateNoWait $ + MkEvaluate + { expression = + "var results = []; \ + \if (window.GLOBAL_USER_CONTEXT_DATA) results.push('Global script active'); \ + \if (window.USER_CONTEXT_SPECIFIC_DATA) results.push('Specific script active'); \ + \if (window.SINGLE_USER_CONTEXT_DATA) results.push('Single script active'); \ + \document.body.innerHTML += '
UC1 Results: ' + results.join(', ') + '
';", + target = ContextTarget $ MkContextTarget {context = bcUserContext1, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + + -- Check UserContext1 content + domContentUC1 <- + scriptEvaluate $ + MkEvaluate + { expression = "document.body ? document.body.innerText || document.body.textContent || '' : ''", + target = ContextTarget $ MkContextTarget {context = bcUserContext1, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + + case domContentUC1 of + EvaluateResultSuccess {result = PrimitiveValue (StringValue (MkStringValue uc1Text))} -> do + logTxt $ "UserContext1 content: " <> uc1Text + if "Specific script active" `isInfixOf` uc1Text + then logTxt "✓ UserContext1: Specific userContexts script executed" + else logTxt "✗ UserContext1: Missing specific userContexts script" + if "Global script active" `isInfixOf` uc1Text + then logTxt "✓ UserContext1: Global script executed" + else logTxt "✗ UserContext1: Missing global script" + if "Single script active" `isInfixOf` uc1Text + then logTxt "✗ UserContext1: Unexpected single UC3 script execution" + else logTxt "✓ UserContext1: Correctly excluded single UC3 script" + _ -> logTxt "Could not read UserContext1 content" + pause + + logTxt "Test script execution in UserContext2 - should have specific AND global scripts" + browsingContextActivate $ MkActivate bcUserContext2 + pauseAtLeast $ 500 * milliseconds + + navResultUC2 <- browsingContextNavigate $ MkNavigate {context = bcUserContext2, url = MkUrl "data:text/html,UserContext2 Test

UserContext2 Page

Testing UserContext2
", wait = Just Complete} + logShow "Navigation in UserContext2" navResultUC2 + pauseAtLeast $ 1500 * milliseconds -- Wait for preload scripts + logTxt "Verify UserContext2 has both global and specific scripts" + scriptEvaluateNoWait $ + MkEvaluate + { expression = + "var results = []; \ + \if (window.GLOBAL_USER_CONTEXT_DATA) results.push('Global script active'); \ + \if (window.USER_CONTEXT_SPECIFIC_DATA) results.push('Specific script active'); \ + \if (window.SINGLE_USER_CONTEXT_DATA) results.push('Single script active'); \ + \document.body.innerHTML += '
UC2 Results: ' + results.join(', ') + '
';", + target = ContextTarget $ MkContextTarget {context = bcUserContext2, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + + -- Check UserContext2 content + domContentUC2 <- + scriptEvaluate $ + MkEvaluate + { expression = "document.body ? document.body.innerText || document.body.textContent || '' : ''", + target = ContextTarget $ MkContextTarget {context = bcUserContext2, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + + case domContentUC2 of + EvaluateResultSuccess {result = PrimitiveValue (StringValue (MkStringValue uc2Text))} -> do + logTxt $ "UserContext2 content: " <> uc2Text + if "Specific script active" `isInfixOf` uc2Text + then logTxt "✓ UserContext2: Specific userContexts script executed" + else logTxt "✗ UserContext2: Missing specific userContexts script" + if "Global script active" `isInfixOf` uc2Text + then logTxt "✓ UserContext2: Global script executed" + else logTxt "✗ UserContext2: Missing global script" + if "Single script active" `isInfixOf` uc2Text + then logTxt "✗ UserContext2: Unexpected single UC3 script execution" + else logTxt "✓ UserContext2: Correctly excluded single UC3 script" + _ -> logTxt "Could not read UserContext2 content" + pause + + logTxt "Test script execution in UserContext3 - should have global AND single scripts, NOT specific" + browsingContextActivate $ MkActivate bcUserContext3 + pauseAtLeast $ 500 * milliseconds + + navResultUC3 <- browsingContextNavigate $ MkNavigate {context = bcUserContext3, url = MkUrl "data:text/html,UserContext3 Test

UserContext3 Page

Testing UserContext3
", wait = Just Complete} + logShow "Navigation in UserContext3" navResultUC3 + pauseAtLeast $ 1500 * milliseconds -- Wait for preload scripts + logTxt "Verify UserContext3 has global and single scripts, but NOT specific" + scriptEvaluateNoWait $ + MkEvaluate + { expression = + "var results = []; \ + \if (window.GLOBAL_USER_CONTEXT_DATA) results.push('Global script active'); \ + \if (window.USER_CONTEXT_SPECIFIC_DATA) results.push('Specific script active'); \ + \if (window.SINGLE_USER_CONTEXT_DATA) results.push('Single script active'); \ + \document.body.innerHTML += '
UC3 Results: ' + results.join(', ') + '
';", + target = ContextTarget $ MkContextTarget {context = bcUserContext3, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + + -- Check UserContext3 content + domContentUC3 <- + scriptEvaluate $ + MkEvaluate + { expression = "document.body ? document.body.innerText || document.body.textContent || '' : ''", + target = ContextTarget $ MkContextTarget {context = bcUserContext3, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + + case domContentUC3 of + EvaluateResultSuccess {result = PrimitiveValue (StringValue (MkStringValue uc3Text))} -> do + logTxt $ "UserContext3 content: " <> uc3Text + if "Specific script active" `isInfixOf` uc3Text + then logTxt "✗ UserContext3: Unexpected specific userContexts script execution" + else logTxt "✓ UserContext3: Correctly excluded specific userContexts script (UC1,UC2 only)" + if "Global script active" `isInfixOf` uc3Text + then logTxt "✓ UserContext3: Global script executed" + else logTxt "✗ UserContext3: Missing global script" + if "Single script active" `isInfixOf` uc3Text + then logTxt "✓ UserContext3: Single UC3 script executed correctly" + else logTxt "✗ UserContext3: Missing single UC3 script" + _ -> logTxt "Could not read UserContext3 content" + pause + + logTxt "Test original browsing context (default user context) - should only have global script" + browsingContextActivate $ MkActivate bc + pauseAtLeast $ 500 * milliseconds + + navResultOriginal <- browsingContextNavigate $ MkNavigate {context = bc, url = MkUrl "data:text/html,Original Context Test

Original Context Page

Testing Original Default Context
", wait = Just Complete} + logShow "Navigation in original context" navResultOriginal + pauseAtLeast $ 1500 * milliseconds -- Wait for preload scripts + logTxt "Verify original context has only global script (no user context restrictions)" + scriptEvaluateNoWait $ + MkEvaluate + { expression = + "var results = []; \ + \if (window.GLOBAL_USER_CONTEXT_DATA) results.push('Global script active'); \ + \if (window.USER_CONTEXT_SPECIFIC_DATA) results.push('Specific script active'); \ + \if (window.SINGLE_USER_CONTEXT_DATA) results.push('Single script active'); \ + \document.body.innerHTML += '
Original Results: ' + results.join(', ') + '
';", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + + -- Check original context content + domContentOriginal <- + scriptEvaluate $ + MkEvaluate + { expression = "document.body ? document.body.innerText || document.body.textContent || '' : ''", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + + case domContentOriginal of + EvaluateResultSuccess {result = PrimitiveValue (StringValue (MkStringValue originalText))} -> do + logTxt $ "Original context content: " <> originalText + if "Specific script active" `isInfixOf` originalText + then logTxt "✗ Original context: Unexpected specific userContexts script execution" + else logTxt "✓ Original context: Correctly excluded specific userContexts script" + if "Global script active" `isInfixOf` originalText + then logTxt "✓ Original context: Global script executed" + else logTxt "✗ Original context: Missing global script" + if "Single script active" `isInfixOf` originalText + then logTxt "✗ Original context: Unexpected single UC3 script execution" + else logTxt "✓ Original context: Correctly excluded single UC3 script" + _ -> logTxt "Could not read original context content" + pause + + logTxt "Summary of userContexts property demonstration:" + logTxt "• userContexts = Just [UC1, UC2]: Script executes only in those user contexts" + logTxt "• userContexts = Just [UC3]: Script executes only in UC3" + logTxt "• userContexts = Nothing: Script executes in all user contexts (global)" + logTxt "• Default context behavior: Only receives scripts with userContexts = Nothing" + pause + + logTxt "Cleanup - Remove all preload scripts" + let MkAddPreloadScriptResult scriptSpecificId = preloadScriptSpecificUsers + let MkAddPreloadScriptResult scriptGlobalId = preloadScriptGlobal + let MkAddPreloadScriptResult scriptSingleId = preloadScriptSingleUser + + removeSpecific <- scriptRemovePreloadScript $ MkRemovePreloadScript scriptSpecificId + logShow "Removed specific userContexts script" removeSpecific + removeGlobal <- scriptRemovePreloadScript $ MkRemovePreloadScript scriptGlobalId + logShow "Removed global script" removeGlobal + removeSingle <- scriptRemovePreloadScript $ MkRemovePreloadScript scriptSingleId + logShow "Removed single userContext script" removeSingle + pause + + logTxt "Cleanup - Close user context browsing contexts" + closeContext utils bidi bcUserContext1 + closeContext utils bidi bcUserContext2 + closeContext utils bidi bcUserContext3 + pause + + logTxt "Cleanup - Remove user contexts" + removeUC1 <- browserRemoveUserContext $ MkRemoveUserContext userContext1 + logShow "Removed UserContext1" removeUC1 + removeUC2 <- browserRemoveUserContext $ MkRemoveUserContext userContext2 + logShow "Removed UserContext2" removeUC2 + removeUC3 <- browserRemoveUserContext $ MkRemoveUserContext userContext3 + logShow "Removed UserContext3" removeUC3 + pause + + logTxt "Final verification - check remaining user contexts" + finalUserContexts <- browserGetUserContexts + logShow "Remaining user contexts after cleanup" finalUserContexts + pause + +-- >>> runDemo scriptCallFunctionDemo +scriptCallFunctionDemo :: BiDiDemo +scriptCallFunctionDemo = + demo "Script V - script.callFunction Core Scenarios" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + logTxt "Navigate to a simple page for function call tests" + navResult <- + browsingContextNavigate $ + MkNavigate + { context = bc, + url = MkUrl "data:text/html,CallFunction Demo

CallFunction Demo

", + wait = Just Complete + } + logShow "Navigation result" navResult + pause + + let baseTarget = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing} + + -- Test 1: Basic synchronous function returning a string + logTxt "Test 1: Basic synchronous function (string result)" + r1 <- + scriptCallFunction $ + MkCallFunction + { functionDeclaration = "function() { return 'Hello from callFunction!'; }", + awaitPromise = False, + target = baseTarget, + arguments = Nothing, + resultOwnership = Nothing, + serializationOptions = Nothing, + this = Nothing + } + logShow "callFunction result - basic string" r1 + pause + + -- Test 2: Function with arguments (numbers) and arithmetic + logTxt "Test 2: Function with numeric arguments" + let numArg n = PrimitiveLocalValue (NumberValue (Left n)) + r2 <- + scriptCallFunction $ + MkCallFunction + { functionDeclaration = "function(a, b) { return a + b + 0.5; }", + awaitPromise = False, + target = baseTarget, + arguments = Just [numArg 41, numArg 1], + resultOwnership = Nothing, + serializationOptions = Nothing, + this = Nothing + } + logShow "callFunction result - arithmetic" r2 + pause + + -- Test 3: Promise-returning function with awaitPromise=True + logTxt "Test 3: Promise-returning function (awaitPromise=True)" + r3 <- + scriptCallFunction $ + MkCallFunction + { functionDeclaration = "async function(name) { return new Promise(r => setTimeout(()=> r('Hi ' + name), 50)); }", + awaitPromise = True, + target = baseTarget, + arguments = Just [PrimitiveLocalValue (StringValue (MkStringValue "BiDi"))], + resultOwnership = Nothing, + serializationOptions = Nothing, + this = Nothing + } + logShow "callFunction result - awaited promise" r3 + pause + + -- Test 4: Function throwing an error (exception path) + logTxt "Test 4: Function throwing an exception" + r4 <- + scriptCallFunction $ + MkCallFunction + { functionDeclaration = "function() { throw new Error('Boom from callFunction'); }", + awaitPromise = False, + target = baseTarget, + arguments = Nothing, + resultOwnership = Nothing, + serializationOptions = Nothing, + this = Nothing + } + logShow "callFunction result - exception" r4 + pause + + -- Test 5: Function with resultOwnership = Root to obtain a handle (if remote value) + logTxt "Test 5: Object result with ownership=Root" + r5 <- + scriptCallFunction $ + MkCallFunction + { functionDeclaration = "function() { return { message: 'Owned object', time: Date.now() }; }", + awaitPromise = False, + target = baseTarget, + arguments = Nothing, + resultOwnership = Just Root, + serializationOptions = Nothing, + this = Nothing + } + logShow "callFunction result - owned object" r5 + pause + + -- Test 6: Function with serializationOptions limiting object depth + logTxt "Test 6: serializationOptions (maxObjectDepth=1)" + r6 <- + scriptCallFunction $ + MkCallFunction + { functionDeclaration = "function() { return { level1: { level2: { value: 42 } }, keep: 'yes' }; }", + awaitPromise = False, + target = baseTarget, + arguments = Nothing, + resultOwnership = Nothing, + serializationOptions = + Just + MkSerializationOptions + { maxDomDepth = Nothing, + maxObjectDepth = Just (Just (MkJSUInt 1)), + includeShadowTree = Just ShadowTreeNone + }, + this = Nothing + } + logShow "callFunction result - limited serialization" r6 + pause + + -- Test 7: Using 'this' binding (object as this) and argument to access property + logTxt "Test 7: Using 'this' binding to access property" + let objLocal = + ObjectLocalValue + MkObjectLocalValue + { value = + MkMappingLocalValue + [ (Right "greeting", PrimitiveLocalValue (StringValue (MkStringValue "Hello"))), + (Right "name", PrimitiveLocalValue (StringValue (MkStringValue "World"))) + ] + } + r7 <- + scriptCallFunction $ + MkCallFunction + { functionDeclaration = "function(extra) { return this.greeting + ', ' + this.name + extra; }", + awaitPromise = False, + target = baseTarget, + arguments = Just [PrimitiveLocalValue (StringValue (MkStringValue "!!!"))], + resultOwnership = Nothing, + serializationOptions = Nothing, + this = Just objLocal + } + logShow "callFunction result - this binding" r7 + pause + + logTxt "script.callFunction demo complete" + pause + +-- >>> runDemo scriptGetRealmsAndDisownDemo +scriptGetRealmsAndDisownDemo :: BiDiDemo +scriptGetRealmsAndDisownDemo = + demo "Script VI - getRealms and disown Integration" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + logTxt "Navigate to a test page for realms and ownership demo" + navResult <- + browsingContextNavigate $ + MkNavigate + { context = bc, + url = MkUrl "data:text/html,Realms and Ownership Demo

Realms and Ownership Demo

", + wait = Just Complete + } + logShow "Navigation result" navResult + pause + + logTxt "Test 1: Get all realms without filtering" + allRealms <- + scriptGetRealms $ + MkGetRealms + { context = Nothing, -- All contexts + realmType = Nothing -- All realm types + } + logShow "All available realms" allRealms + pause + + logTxt "Test 2: Get realms for specific browsing context" + contextRealms <- + scriptGetRealms $ + MkGetRealms + { context = Just bc, + realmType = Nothing + } + logShow "Realms for current browsing context" contextRealms + pause + + logTxt "Test 3: Get only window realms" + windowRealms <- + scriptGetRealms $ + MkGetRealms + { context = Nothing, + realmType = Just WindowRealm + } + logShow "Window realms only" windowRealms + pause + + -- Extract the first available realm for subsequent tests + let MkGetRealmsResult realms = allRealms + case realms of + [] -> logTxt "No realms available for ownership testing" + (firstRealmInfo : _) -> do + let targetRealm = case firstRealmInfo of + WindowRealmInfo {base = BaseRealmInfo {realm = r}} -> r + DedicatedWorker {base = BaseRealmInfo {realm = r}} -> r + SharedWorker {base = BaseRealmInfo {realm = r}} -> r + ServiceWorker {base = BaseRealmInfo {realm = r}} -> r + Worker {base = BaseRealmInfo {realm = r}} -> r + PaintWorklet {base = BaseRealmInfo {realm = r}} -> r + AudioWorklet {base = BaseRealmInfo {realm = r}} -> r + Worklet {base = BaseRealmInfo {realm = r}} -> r + + logTxt $ "Test 4: Create owned objects in realm: " <> pack (show targetRealm) + + logTxt "Create first owned object (array)" + ownedArray <- + scriptEvaluate $ + MkEvaluate + { expression = "[1, 2, 3, 'owned', { nested: 'data' }]", + target = RealmTarget targetRealm, + awaitPromise = False, + resultOwnership = Just Root, + serializationOptions = Nothing + } + logShow "Owned array result" ownedArray + pause + + logTxt "Create second owned object (function)" + ownedFunction <- + scriptEvaluate $ + MkEvaluate + { expression = "function ownedFunc() { return 'I am owned!'; }", + target = RealmTarget targetRealm, + awaitPromise = False, + resultOwnership = Just Root, + serializationOptions = Nothing + } + logShow "Owned function result" ownedFunction + pause + + logTxt "Create third owned object (complex object)" + ownedObject <- + scriptEvaluate $ + MkEvaluate + { expression = "({ id: Math.random(), message: 'Complex owned object', timestamp: Date.now(), data: [1,2,3] })", + target = RealmTarget targetRealm, + awaitPromise = False, + resultOwnership = Just Root, + serializationOptions = Nothing + } + logShow "Owned object result" ownedObject + pause + + -- Extract handles from the evaluation results + let extractHandle = \case + EvaluateResultSuccess {result = rv} -> case rv of + ArrayValue {handle = Just h} -> Just h + ObjectValue {handle = Just h} -> Just h + FunctionValue {handle = Just h} -> Just h + SymbolValue {handle = Just h} -> Just h + RegExpValue {handle = Just h} -> Just h + DateValue {handle = Just h} -> Just h + MapValue {handle = Just h} -> Just h + SetValue {handle = Just h} -> Just h + WeakMapValue {handle = Just h} -> Just h + WeakSetValue {handle = Just h} -> Just h + GeneratorValue {handle = Just h} -> Just h + ErrorValue {handle = Just h} -> Just h + ProxyValue {handle = Just h} -> Just h + PromiseValue {handle = Just h} -> Just h + TypedArrayValue {handle = Just h} -> Just h + ArrayBufferValue {handle = Just h} -> Just h + NodeListValue {handle = Just h} -> Just h + HTMLCollectionValue {handle = Just h} -> Just h + WindowProxyValue {handle = Just h} -> Just h + _ -> Nothing + _ -> Nothing + + let handles = catMaybes [extractHandle ownedArray, extractHandle ownedFunction, extractHandle ownedObject] + + if null handles + then logTxt "No handles available for disown testing" + else do + logTxt $ "Test 5: Disown " <> pack (show (length handles)) <> " handles using scriptDisown" + logShow "Handles to disown" handles + + disownResult <- + scriptDisown $ + MkDisown + { handles = handles, + target = RealmTarget targetRealm + } + logShow "Disown operation result" disownResult + pause + + logTxt "Test 6: Verification of disown operation complete" + logTxt "Note: Disowned handles should no longer be accessible from the script context" + pause + + logTxt "Test 7: Get realms again to ensure realm is still active" + finalRealms <- + scriptGetRealms $ + MkGetRealms + { context = Just bc, + realmType = Just WindowRealm + } + logShow "Final realms check" finalRealms + pause + + logTxt "Demonstration complete: getRealms discovered realms, objects were created with ownership, and scriptDisown released the handles" + pause diff --git a/test/BiDi/Demos/ScriptEventDemos.hs b/test/BiDi/Demos/ScriptEventDemos.hs new file mode 100644 --- /dev/null +++ b/test/BiDi/Demos/ScriptEventDemos.hs @@ -0,0 +1,200 @@ +module BiDi.Demos.ScriptEventDemos where + +import BiDi.Actions (BiDiActions (..)) +import BiDi.DemoUtils +import IOUtils (DemoActions (..)) +import TestData (checkboxesUrl, scriptRealmUrl) +import WebDriverPreCore.BiDi.Protocol + ( AddPreloadScript (..), + Channel (..), + ChannelProperties (..), + ChannelValue (..), + ContextTarget (..), + Evaluate (..), + KnownSubscriptionType (..), + Navigate (..), + ResultOwnership (..), + Target (..) + ) +import Prelude hiding (log, putStrLn) + +-- >>> runDemo scriptEventRealmLifecycle +scriptEventRealmLifecycle :: BiDiDemo +scriptEventRealmLifecycle = + demo "Script Events - Realm Created and Destroyed" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + logTxt "Subscribe to RealmCreated and RealmDestroyed events" + + (realmCreatedEventFired, waitRealmCreatedEventFired) <- timeLimitLog ScriptRealmCreated + subscribeScriptRealmCreated realmCreatedEventFired + + (manyRealmCreatedEventFired, waitManyRealmCreatedEventFired) <- timeLimitLogMany ScriptRealmCreated + subscribeMany [ScriptRealmCreated] manyRealmCreatedEventFired + + (realmDestroyedEventFired, waitRealmDestroyedEventFired) <- timeLimitLog ScriptRealmDestroyed + subscribeScriptRealmDestroyed realmDestroyedEventFired + + (manyRealmDestroyedEventFired, waitManyRealmDestroyedEventFired) <- timeLimitLogMany ScriptRealmDestroyed + subscribeMany [ScriptRealmDestroyed] manyRealmDestroyedEventFired + + logTxt "Navigate to script realm test page" + url <- scriptRealmUrl + bc <- rootContext utils bidi + browsingContextNavigate $ MkNavigate bc url Nothing + pause + + logTxt "Create iframe to trigger realmCreated event" + scriptEvaluate $ + MkEvaluate + { expression = "createIframe()", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + + logTxt "Waiting for realmCreated events..." + sequence_ + [ + waitRealmCreatedEventFired, + waitManyRealmCreatedEventFired + ] + + logTxt "Remove iframe to trigger realmDestroyed event" + scriptEvaluate $ + MkEvaluate + { expression = "removeIframe()", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + + logTxt "Waiting for realmDestroyed events..." + sequence_ + [ + waitRealmDestroyedEventFired, + waitManyRealmDestroyedEventFired + ] + +-- >>> runDemo scriptEventMessage +scriptEventMessage :: BiDiDemo +scriptEventMessage = + demo "Script Events - Message via Channel" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + logTxt "Subscribe to Message event" + + (messageEventFired, waitMessageEventFired) <- timeLimitLog ScriptMessage + subscribeScriptMessage messageEventFired + + (manyMessageEventFired, waitManyMessageEventFired) <- timeLimitLogMany ScriptMessage + subscribeMany [ScriptMessage] manyMessageEventFired + + logTxt "Navigate to checkboxes page" + url <- checkboxesUrl + bc <- rootContext utils bidi + browsingContextNavigate $ MkNavigate bc url Nothing + pause + + let channelName = "testChannel" + channel = Channel {channelId = channelName} + channelValue = + MkChannelValue + { value = + MkChannelProperties + { channel = channel, + serializationOptions = Nothing, + ownership = Just Root + } + } + + logTxt "Add preload script with channel to send messages" + scriptAddPreloadScript $ + MkAddPreloadScript + { functionDeclaration = + "function(channel) { channel('Message from preload script via channel'); }", + arguments = Just [channelValue], + contexts = Just [bc], + userContexts = Nothing, + sandbox = Nothing + } + + logTxt "Navigate again to trigger preload script and message event" + browsingContextNavigate $ MkNavigate bc url Nothing + + logTxt "Waiting for message events..." + sequence_ + [ waitMessageEventFired, + waitManyMessageEventFired + ] + +-- >>> runDemo scriptEventMessageRuntime +scriptEventMessageRuntime :: BiDiDemo +scriptEventMessageRuntime = + demo "Script Events - Runtime Message via sendBidiMessage" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + logTxt "Subscribe to Message event" + subscribeScriptMessage $ logShow "Script Message Event" + + logTxt "Navigate to checkboxes page" + url <- checkboxesUrl + bc <- rootContext utils bidi + browsingContextNavigate $ MkNavigate bc url Nothing + pause + + let channelName = "runtimeChannel" + channel = Channel {channelId = channelName} + channelValue = + MkChannelValue + { value = + MkChannelProperties + { channel = channel, + serializationOptions = Nothing, + ownership = Just Root + } + } + + logTxt "Add preload script to set up sendBidiMessage function" + scriptAddPreloadScript $ + MkAddPreloadScript + { functionDeclaration = + "function(channel) {\ + \ window.sendBidiMessage = function(msg) { channel(msg); };\ + \}", + arguments = Just [channelValue], + contexts = Just [bc], + userContexts = Nothing, + sandbox = Nothing + } + + logTxt "Navigate to trigger preload script setup" + browsingContextNavigate $ MkNavigate bc url Nothing + pause + + logTxt "Send message from JavaScript via channel" + scriptEvaluate $ + MkEvaluate + { expression = "window.sendBidiMessage('Hello from JavaScript runtime!')", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + pause + + logTxt "Send another message with different content" + scriptEvaluate $ + MkEvaluate + { expression = "window.sendBidiMessage('Second message: ' + new Date().toISOString())", + target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing}, + awaitPromise = False, + resultOwnership = Nothing, + serializationOptions = Nothing + } + pause diff --git a/test/BiDi/Demos/SessionDemos.hs b/test/BiDi/Demos/SessionDemos.hs new file mode 100644 --- /dev/null +++ b/test/BiDi/Demos/SessionDemos.hs @@ -0,0 +1,368 @@ +module BiDi.Demos.SessionDemos where + +import BiDi.Actions (BiDiActions (..)) +import BiDi.DemoUtils +import IOUtils (DemoActions (..)) +import WebDriverPreCore.BiDi.Protocol + ( Capabilities (..), + Capability (..), + CreateUserContext (..), + KnownSubscriptionType (..), + ProxyConfiguration (..), + SessionNewResult (..), + SessionStatusResult (..), + SessionSubscibe (..), + SessionUnsubscribe (..), + SubscriptionType (..), + UserPromptHandler (..), + UserPromptHandlerType (..), + ) +import Prelude hiding (log, putStrLn) + +-- TODO: change from text to typed events + +-- >>> runDemo sessionStatusDemo +sessionStatusDemo :: BiDiDemo +sessionStatusDemo = + demo "Session - Status Check" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Checking session status" + status <- sessionStatus + logShow "Session status" status + pause + + logTxt "Interpreting status result" + case status of + MkSessionStatusResult True msg -> logTxt $ "✓ Session is ready: " <> msg + MkSessionStatusResult False msg -> logTxt $ "✗ Session not ready: " <> msg + pause + +-- >>> runDemo sessionNewDemo + +-- *** Exception: Error executing BiDi command: MkCommand + +-- { method = "session.new" +-- , params = +-- MkCapabilities { alwaysMatch = Nothing , firstMatch = [] } +-- , extended = Nothing +-- } +-- With JSON: +-- { +-- "id": 1, +-- "method": "session.new", +-- "params": { +-- "capabilities": {}, +-- "firstMatch": [] +-- } +-- } +-- BiDi driver error: +-- MkDriverError +-- { id = Just 1 +-- , error = SessionNotCreated +-- , description = "Failed to create a new session" +-- , message = "Maximum number of active sessions" +-- , stacktrace = +-- Just +-- "RemoteError@chrome://remote/content/shared/RemoteError.sys.mjs:8:8\nWebDriverError@chrome://remote/content/shared/webdriver/Errors.sys.mjs:202:5\nSessionNotCreatedError@chrome://remote/content/shared/webdriver/Errors.sys.mjs:814:5\ncreateSession@chrome://remote/content/webdriver-bidi/WebDriverBiDi.sys.mjs:127:13\nonPacket@chrome://remote/content/webdriver-bidi/WebDriverBiDiConnection.sys.mjs:206:55\nonMessage@chrome://remote/content/server/WebSocketTransport.sys.mjs:127:18\nhandleEvent@chrome://remote/content/server/WebSocketTransport.sys.mjs:109:14\n" +-- , extensions = MkEmptyResult { extensible = fromList [] } +-- } +sessionNewDemo :: BiDiDemo +sessionNewDemo = + demo "Session - New Session Creation" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Creating new BiDi session with basic capabilities" + let basicCapabilities = + MkCapabilities + { alwaysMatch = Nothing, + firstMatch = [] + } + newSession <- sessionNew basicCapabilities + logShow "New session created" newSession + pause + + logTxt "Session information:" + logTxt $ "Session ID: " <> newSession.sessionId + logShow "Capabilities result" newSession.capabilities + pause + +-- TODO: Add orchestration between receive loop and session.end to suppress ConnectionClosed when connection closes gracefully + +-- >>> runDemo sessionEndDemo +sessionEndDemo :: BiDiDemo +sessionEndDemo = + demo "Session - End Session" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "⚠️ WARNING: This will end the current session!" + logTxt "Ending current session gracefully" + result <- sessionEnd + logShow "Session end result" result + pause + +-- >>> runDemo sessionSubscribeDemo +sessionSubscribeDemo :: BiDiDemo +sessionSubscribeDemo = + demo "Session - Event Subscription" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + logTxt "Test 1: Subscribe to browsing context events globally" + let globalSubscription = + MkSessionSubscribe + { events = KnownSubscriptionType <$> [BrowsingContextContextCreated, BrowsingContextContextDestroyed], + contexts = Nothing, + userContexts = Nothing + } + sub1 <- sessionSubscribe globalSubscription + logShow "Global subscription" sub1 + pause + + logTxt "Test 2: Subscribe to network events for specific context" + let contextSubscription = + MkSessionSubscribe + { events = KnownSubscriptionType <$> [NetworkFetchError, NetworkResponseCompleted], + contexts = Just [bc], + userContexts = Nothing + } + sub2 <- sessionSubscribe contextSubscription + logShow "Context-specific subscription" sub2 + pause + + logTxt "Test 3: Subscribe to script events for user context" + -- Get current user contexts or create a new one if needed + userContextsResult <- browserGetUserContexts + logShow "Current user contexts" userContextsResult + + -- Create a new user context for demonstration + currentUserContext <- + browserCreateUserContext + MkCreateUserContext + { insecureCerts = Nothing, + proxy = Nothing, + unhandledPromptBehavior = Nothing + } + logShow "Created user context" currentUserContext + + let userContextSubscription = + MkSessionSubscribe + { events = [KnownSubscriptionType ScriptRealmCreated], + contexts = Nothing, + userContexts = Just [currentUserContext] + } + sub3 <- sessionSubscribe userContextSubscription + logShow "User context subscription" sub3 + pause + +-- >>> runDemo sessionUnsubscribeDemo +sessionUnsubscribeDemo :: BiDiDemo +sessionUnsubscribeDemo = + demo "Session - Event Unsubscription" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "First, create a subscription to demonstrate unsubscription" + let subscription = + MkSessionSubscribe + { events = [KnownSubscriptionType BrowsingContextContextCreated], + contexts = Nothing, + userContexts = Nothing + } + subResult <- sessionSubscribe subscription + logShow "Created subscription" subResult + pause + + logTxt "Test 1: Unsubscribe by subscription ID" + let unsubByID = + UnsubscribeById + { subscriptions = [subResult] + } + result1 <- sessionUnsubscribe unsubByID + logShow "Unsubscribed by ID" result1 + pause + + logTxt "Now, Subscribe to network events for specific context" + let contextSubscription = + MkSessionSubscribe + { events = [KnownSubscriptionType NetworkResponseCompleted], + contexts = Nothing, + userContexts = Nothing + } + sub2 <- sessionSubscribe contextSubscription + logShow "Context-specific subscription" sub2 + pause + + logTxt "Test 2: Unsubscribe by attributes (alternative method)" + let unsubByAttrs = + UnsubscribeByAttributes + { unsubEvents = [KnownSubscriptionType NetworkResponseCompleted] + } + result2 <- sessionUnsubscribe unsubByAttrs + logShow "Unsubscribed by attributes" result2 + pause + +-- >>> runDemo sessionCapabilityNegotiationDemo + +-- *** Exception: Error executing BiDi command: MkCommand + +-- { method = "session.new" +-- , params = +-- MkCapabilities +-- { alwaysMatch = +-- Just +-- MkCapability +-- { acceptInsecureCerts = Just True +-- , browserName = Just "firefox" +-- , browserVersion = Nothing +-- , webSocketUrl = True +-- , platformName = Just "linux" +-- , proxy = Nothing +-- , unhandledPromptBehavior = Nothing +-- } +-- , firstMatch = [] +-- } +-- , extended = Nothing +-- } +-- With JSON: +-- { +-- "id": 1, +-- "method": "session.new", +-- "params": { +-- "capabilities": { +-- "alwaysMatch": { +-- "acceptInsecureCerts": true, +-- "browserName": "firefox", +-- "browserVersion": null, +-- "platformName": "linux", +-- "proxy": null, +-- "unhandledPromptBehavior": null, +-- "webSocketUrl": true +-- } +-- }, +-- "firstMatch": [] +-- } +-- } +-- Failed to decode the 'result' property of JSON returned by driver to response type: +-- { +-- "error": "session not created", +-- "id": 1, +-- "message": "Maximum number of active sessions", +-- "stacktrace": "RemoteError@chrome://remote/content/shared/RemoteError.sys.mjs:8:8\nWebDriverError@chrome://remote/content/shared/webdriver/Errors.sys.mjs:202:5\nSessionNotCreatedError@chrome://remote/content/shared/webdriver/Errors.sys.mjs:814:5\ncreateSession@chrome://remote/content/webdriver-bidi/WebDriverBiDi.sys.mjs:127:13\nonPacket@chrome://remote/content/webdriver-bidi/WebDriverBiDiConnection.sys.mjs:206:55\nonMessage@chrome://remote/content/server/WebSocketTransport.sys.mjs:127:18\nhandleEvent@chrome://remote/content/server/WebSocketTransport.sys.mjs:109:14\n", +-- "type": "error" +-- } +-- Error message: +-- key "result" not found +sessionCapabilityNegotiationDemo :: BiDiDemo +sessionCapabilityNegotiationDemo = + demo "Session - Capability Negotiation" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Test 1: Session with alwaysMatch capabilities" + let alwaysMatchCap = + MkCapability + { acceptInsecureCerts = Just True, + browserName = Just "firefox", + browserVersion = Nothing, + webSocketUrl = True, + platformName = Just "linux", + proxy = Nothing, + unhandledPromptBehavior = Nothing + } + let alwaysMatchCapabilities = + MkCapabilities + { alwaysMatch = Just alwaysMatchCap, + firstMatch = [] + } + session1 <- sessionNew alwaysMatchCapabilities + logShow "Session with alwaysMatch" session1 + pause + + logTxt "Test 2: Session with firstMatch capabilities" + let firstMatchCap1 = + MkCapability + { acceptInsecureCerts = Just False, + browserName = Just "firefox", + browserVersion = Just "130.0", + webSocketUrl = True, + platformName = Just "linux", + proxy = Just DirectProxyConfiguration, + unhandledPromptBehavior = Nothing + } + let firstMatchCap2 = + MkCapability + { acceptInsecureCerts = Just True, + browserName = Nothing, + browserVersion = Nothing, + webSocketUrl = True, + platformName = Nothing, + proxy = Nothing, + unhandledPromptBehavior = + Just $ + MkUserPromptHandler + { alert = Just Accept, + beforeUnload = Just Dismiss, + confirm = Just Accept, + defaultHandler = Just Ignore, + fileHandler = Nothing, + prompt = Just Accept + } + } + let firstMatchCapabilities = + MkCapabilities + { alwaysMatch = Nothing, + firstMatch = [firstMatchCap1, firstMatchCap2] + } + session2 <- sessionNew firstMatchCapabilities + logShow "Session with firstMatch" session2 + pause + +-- >>> runDemo sessionCompleteLifecycleDemo +sessionCompleteLifecycleDemo :: BiDiDemo +sessionCompleteLifecycleDemo = + demo "Session - Complete Lifecycle Management" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Step 1: Check initial session status" + initialStatus <- sessionStatus + logShow "Initial status" initialStatus + pause + + logTxt "Step 2: Subscribe to key events" + let subscription = + MkSessionSubscribe + { events = KnownSubscriptionType <$> [BrowsingContextContextCreated, BrowsingContextNavigationStarted], + contexts = Nothing, + userContexts = Nothing + } + subResult <- sessionSubscribe subscription + logShow "Event subscription" subResult + pause + + logTxt "Step 3: Perform some operations (context creation)" + -- This would normally create contexts and generate events + logTxt "Events would be generated during normal operations..." + pause + + logTxt "Step 4: Check status after operations" + operationStatus <- sessionStatus + logShow "Status after operations" operationStatus + pause + + logTxt "Step 5: Clean up subscriptions" + let cleanup = + UnsubscribeById + { subscriptions = [subResult] + } + cleanupResult <- sessionUnsubscribe cleanup + logShow "Cleanup result" cleanupResult + pause + + logTxt "Session lifecycle demo complete" diff --git a/test/BiDi/Demos/StorageDemos.hs b/test/BiDi/Demos/StorageDemos.hs new file mode 100644 --- /dev/null +++ b/test/BiDi/Demos/StorageDemos.hs @@ -0,0 +1,393 @@ +module BiDi.Demos.StorageDemos where + +import BiDi.Actions (BiDiActions (..)) +import BiDi.DemoUtils +import IOUtils (DemoActions (..)) +import WebDriverPreCore.BiDi.Protocol + ( CookieFilter (..), + CreateUserContext (..), + DeleteCookies (..), + GetCookies (..), + PartialCookie (..), + PartitionDescriptor (..), + SameSite (..), + SetCookie (..), + PartitionDescriptor(..), + StringValue (..), + UserContext (..), + BytesValue (..) + ) +import Prelude hiding (log, putStrLn) + +-- >>> runDemo storageGetCookiesDemo +storageGetCookiesDemo :: BiDiDemo +storageGetCookiesDemo = + demo "Storage - Get Cookies" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + logTxt "Test 1: Get all cookies (no filter)" + let getAllCookies = + MkGetCookies + { filter = Nothing, + partition = Just $ BrowsingContextPartition bc + } + result1 <- storageGetCookies getAllCookies + logShow "All cookies" result1 + pause + + logTxt "Test 2: Get cookies with name filter" + let nameFilter = + MkCookieFilter + { name = Just "test-cookie", + value = Nothing, + domain = Nothing, + path = Nothing, + size = Nothing, + httpOnly = Nothing, + secure = Nothing, + sameSite = Nothing, + expiry = Nothing + } + let filteredCookies = + MkGetCookies + { filter = Just nameFilter, + partition = Just $ BrowsingContextPartition bc + } + result2 <- storageGetCookies filteredCookies + logShow "Filtered cookies by name" result2 + pause + + logTxt "Test 3: Get secure cookies only" + let secureFilter = + MkCookieFilter + { name = Nothing, + value = Nothing, + domain = Nothing, + path = Nothing, + size = Nothing, + httpOnly = Nothing, + secure = Just True, + sameSite = Nothing, + expiry = Nothing + } + let secureCookies = + MkGetCookies + { filter = Just secureFilter, + partition = Just $ BrowsingContextPartition bc + } + result3 <- storageGetCookies secureCookies + logShow "Secure cookies only" result3 + pause + +-- >>> runDemo storageSetCookieDemo +-- *** Exception: BiDIError (ProtocolException {error = UnableToSetCookie, description = "Tried to create a cookie, but the user agent rejected it", message = "[object Object]", stacktrace = Nothing, errorData = Nothing, response = Object (fromList [("error",String "unable to set cookie"),("id",Number 4.0),("message",String "[object Object]"),("type",String "error")])}) +storageSetCookieDemo :: BiDiDemo +storageSetCookieDemo = + demo "Storage - Set Cookie" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + logTxt "Test 1: Set basic cookie" + let basicCookie = + MkPartialCookie + { name = "demo-cookie", + value = TextBytesValue $ MkStringValue "demo-value", + domain = "example.com", + path = Nothing, + httpOnly = Nothing, + secure = Nothing, + sameSite = Nothing, + expiry = Nothing + } + let setCookieBasic = + MkSetCookie + { cookie = basicCookie, + partition = Just $ BrowsingContextPartition bc + } + result1 <- storageSetCookie setCookieBasic + logShow "Basic cookie set" result1 + pause + + logTxt "Test 2: Set secure HTTP-only cookie" + let secureCookie = + MkPartialCookie + { name = "secure-cookie", + value = TextBytesValue $ MkStringValue "secure-value", + domain = "example.com", + path = Just "/", + httpOnly = Just True, + secure = Just True, + sameSite = Just Strict, + expiry = Nothing + } + let setCookieSecure = + MkSetCookie + { cookie = secureCookie, + partition = Just $ BrowsingContextPartition bc + } + result2 <- storageSetCookie setCookieSecure + logShow "Secure cookie set" result2 + pause + + logTxt "Test 3: Set cookie with storage key partition" + let partitionCookie = + MkPartialCookie + { name = "partition-cookie", + value = TextBytesValue $ MkStringValue "partition-value", + domain = "example.com", + path = Nothing, + httpOnly = Nothing, + secure = Nothing, + sameSite = Nothing, + expiry = Nothing + } + let storageKeyPartition = StorageKeyPartition (Just $ MkUserContext "default") (Just "https://example.com") + let setCookiePartition = + MkSetCookie + { cookie = partitionCookie, + partition = Just storageKeyPartition + } + result3 <- storageSetCookie setCookiePartition + logShow "Partition cookie set" result3 + pause + +-- >>> runDemo storageDeleteCookiesDemo +storageDeleteCookiesDemo :: BiDiDemo +storageDeleteCookiesDemo = + demo "Storage - Delete Cookies" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + logTxt "Test 1: Delete cookies by name" + let nameFilter = + MkCookieFilter + { name = Just "demo-cookie", + value = Nothing, + domain = Nothing, + path = Nothing, + size = Nothing, + httpOnly = Nothing, + secure = Nothing, + sameSite = Nothing, + expiry = Nothing + } + let deleteCookiesByName = + MkDeleteCookies + { filter = Just nameFilter, + partition = Just $ BrowsingContextPartition bc + } + result1 <- storageDeleteCookies deleteCookiesByName + logShow "Cookies deleted by name" result1 + pause + + logTxt "Test 2: Delete all cookies in partition" + let deleteAllCookies = + MkDeleteCookies + { filter = Nothing, + partition = Just $ BrowsingContextPartition bc + } + result2 <- storageDeleteCookies deleteAllCookies + logShow "All cookies deleted" result2 + pause + + logTxt "Test 3: Delete secure cookies only" + let secureFilter = + MkCookieFilter + { name = Nothing, + value = Nothing, + domain = Nothing, + path = Nothing, + size = Nothing, + httpOnly = Nothing, + secure = Just True, + sameSite = Nothing, + expiry = Nothing + } + let deleteSecureCookies = + MkDeleteCookies + { filter = Just secureFilter, + partition = Just $ BrowsingContextPartition bc + } + result3 <- storageDeleteCookies deleteSecureCookies + logShow "Secure cookies deleted" result3 + pause + +-- >>> runDemo storagePartitionKeyDemo +storagePartitionKeyDemo :: BiDiDemo +storagePartitionKeyDemo = + demo "Storage - Partition Key Management" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + logTxt "Test 1: Context-based partition" + let contextPartition = BrowsingContextPartition bc + let getCookiesContext = + MkGetCookies + { filter = Nothing, + partition = Just contextPartition + } + result1 <- storageGetCookies getCookiesContext + logShow "Context partition cookies" result1 + pause + + logTxt "Test 2: Storage key partition (default user context)" + let storageKeyPartition1 = + StorageKeyPartition + { userContext = Just $ MkUserContext "default", + sourceOrigin = Nothing + } + let getCookiesStorageKey1 = + MkGetCookies + { filter = Nothing, + partition = Just storageKeyPartition1 + } + result2 <- storageGetCookies getCookiesStorageKey1 + logShow "Storage key partition (default)" result2 + pause + + logTxt "Test 3: Storage key partition with custom user context" + -- First create a custom user context + customUserContext <- + browserCreateUserContext + MkCreateUserContext + { insecureCerts = Nothing, + proxy = Nothing, + unhandledPromptBehavior = Nothing + } + logShow "Custom user context created" customUserContext + + let storageKeyPartition2 = + StorageKeyPartition + { userContext = Just customUserContext, + sourceOrigin = Just "https://example.com" + } + let getCookiesStorageKey2 = + MkGetCookies + { filter = Nothing, + partition = Just storageKeyPartition2 + } + result3 <- storageGetCookies getCookiesStorageKey2 + logShow "Storage key partition with custom user context" result3 + pause + +-- >>> runDemo storageCompleteWorkflowDemo +storageCompleteWorkflowDemo :: BiDiDemo +storageCompleteWorkflowDemo = + demo "Storage - Complete Cookie Workflow" action + where + action :: DemoActions -> BiDiActions -> IO () + action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do + bc <- rootContext utils bidi + + logTxt "Step 1: Check initial cookies" + let getAllCookies = + MkGetCookies + { filter = Nothing, + partition = Just $ BrowsingContextPartition bc + } + initial <- storageGetCookies getAllCookies + logShow "Initial cookies" initial + pause + + logTxt "Step 2: Set test cookies" + let testCookie1 = + MkPartialCookie + { name = "workflow-cookie-1", + value = TextBytesValue $ MkStringValue "value1", + domain = "example.com", + path = Just "/", + httpOnly = Just False, + secure = Just False, + sameSite = Just Lax, + expiry = Nothing + } + let setCookie1 = + MkSetCookie + { cookie = testCookie1, + partition = Just $ BrowsingContextPartition bc + } + set1 <- storageSetCookie setCookie1 + logShow "First cookie set" set1 + + let testCookie2 = + MkPartialCookie + { name = "workflow-cookie-2", + value = TextBytesValue $ MkStringValue "value2", + domain = "example.com", + path = Just "/test", + httpOnly = Just True, + secure = Just False, + sameSite = Just Strict, + expiry = Nothing + } + let setCookie2 = + MkSetCookie + { cookie = testCookie2, + partition = Just $ BrowsingContextPartition bc + } + set2 <- storageSetCookie setCookie2 + logShow "Second cookie set" set2 + pause + + logTxt "Step 3: Verify cookies were set" + afterSet <- storageGetCookies getAllCookies + logShow "Cookies after setting" afterSet + pause + + logTxt "Step 4: Filter cookies by path" + let pathFilter = + MkCookieFilter + { name = Nothing, + value = Nothing, + domain = Nothing, + path = Just "/test", + size = Nothing, + httpOnly = Nothing, + secure = Nothing, + sameSite = Nothing, + expiry = Nothing + } + let getFilteredCookies = + MkGetCookies + { filter = Just pathFilter, + partition = Just $ BrowsingContextPartition bc + } + filtered <- storageGetCookies getFilteredCookies + logShow "Cookies filtered by path" filtered + pause + + logTxt "Step 5: Delete specific cookie" + let deleteFilter = + MkCookieFilter + { name = Just "workflow-cookie-1", + value = Nothing, + domain = Nothing, + path = Nothing, + size = Nothing, + httpOnly = Nothing, + secure = Nothing, + sameSite = Nothing, + expiry = Nothing + } + let deleteCookie = + MkDeleteCookies + { filter = Just deleteFilter, + partition = Just $ BrowsingContextPartition bc + } + deleted <- storageDeleteCookies deleteCookie + logShow "Cookie deleted" deleted + pause + + logTxt "Step 6: Verify deletion" + final <- storageGetCookies getAllCookies + logShow "Final cookies" final + pause diff --git a/test/BiDi/Demos/WebExtensionDemos.hs b/test/BiDi/Demos/WebExtensionDemos.hs new file mode 100644 --- /dev/null +++ b/test/BiDi/Demos/WebExtensionDemos.hs @@ -0,0 +1,95 @@ +module BiDi.Demos.WebExtensionDemos where + +import BiDi.Actions (BiDiActions (..)) +import BiDi.DemoUtils ( demo, BiDiDemo, runDemo ) +import Control.Exception (SomeException, catch) +import IOUtils (DemoActions (..)) +import TestData (demoExtensionAsBase64, demoExtensionDirPath, demoExtensionZipPath) +import WebDriverPreCore.BiDi.Protocol + ( WebExtensionID(..), + WebExtensionInstall(..), + WebExtensionResult(..), + WebExtensionUninstall(..) ) +import Utils (txt) +import Prelude hiding (log, putStrLn) + +-- this is just to silence "defined but not used" warnings for runDemo +_stopDemoUnusedWarning :: BiDiDemo -> IO () +_stopDemoUnusedWarning = runDemo + +-- >>> runDemo webExtensionInstallPathDemo +-- *** Exception: BiDIError (ProtocolException {error = UnknownError, description = "An unknown error occurred in the remote end while processing the command", message = "Method not available.", stacktrace = Just "Error\n at new UnknownErrorException (:65:5630)\n at CommandProcessor.processCommand (:485:13324)", errorData = Nothing, response = Object (fromList [("error",String "unknown error"),("id",Number 1.0),("message",String "Method not available."),("stacktrace",String "Error\n at new UnknownErrorException (:65:5630)\n at CommandProcessor.processCommand (:485:13324)"),("type",String "error")])}) +webExtensionInstallPathDemo :: BiDiDemo +webExtensionInstallPathDemo = + demo "WebExtension - Install from Path" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Test 1: Install extension from filesystem path" + exPath <- demoExtensionDirPath + result <- webExtensionInstall $ ExtensionPath exPath + logShow "Extension installed from path" result + pause + + logTxt "Test 2: Uninstall the extension" + uninstallResult <- webExtensionUninstall $ MkWebExtensionUninstall result.extension + logShow "Extension uninstalled" uninstallResult + pause + + logTxt "Test 3: Attempt to uninstall non-existent extension" + webExtensionUninstall (MkWebExtensionUninstall $ MkWebExtensionID "non-existent-extension-id") + `catch` \(e :: SomeException) -> do + logShow "Expected error for non-existent extension: " e + pause + +-- >>> runDemo webExtensionInstallArchiveDemo +webExtensionInstallArchiveDemo :: BiDiDemo +webExtensionInstallArchiveDemo = + demo "WebExtension - Install from Archive" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Test 1: Install extension from zip archive" + zipPath <- demoExtensionZipPath + result1 <- webExtensionInstall $ ExtensionArchivePath zipPath + logShow "Extension installed from archive" result1 + pause + +-- >>> runDemo webExtensionInstallBase64Demo +webExtensionInstallBase64Demo :: BiDiDemo +webExtensionInstallBase64Demo = + demo "WebExtension - Install from Base64" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Test 1: Install extension from base64 encoded data" + + base64Data <- demoExtensionAsBase64 + result1 <- webExtensionInstall $ ExtensionBase64Encoded base64Data + logShow "Extension installed from base64" result1 + pause + +-- >>> runDemo webExtensionValidationDemo +webExtensionValidationDemo :: BiDiDemo +webExtensionValidationDemo = + demo "WebExtension - Extension Validation" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + logTxt "Test 1: Invalid extension path" + let invalidExtension = ExtensionPath "/non/existent/path" + invalidResult <- + webExtensionInstall invalidExtension `catch` \(e :: SomeException) -> do + logTxt $ "Installation failed as expected: " <> txt e + pure $ WebExtensionInstallResult {extension = MkWebExtensionID "failed-extension"} + logShow "Invalid extension handling" invalidResult + pause + + logTxt "Test 2: Malformed base64 data" + let malformedBase64 = ExtensionBase64Encoded "invalid-base64-data!!!" + malformedResult <- + webExtensionInstall malformedBase64 `catch` \(e :: SomeException) -> do + logTxt $ "Base64 error (expected): " <> txt e + pure $ WebExtensionInstallResult {extension = MkWebExtensionID "malformed-extension"} + logShow "Malformed base64 handling" malformedResult + pause diff --git a/test/BiDi/ErrorDemo.hs b/test/BiDi/ErrorDemo.hs new file mode 100644 --- /dev/null +++ b/test/BiDi/ErrorDemo.hs @@ -0,0 +1,125 @@ +module BiDi.ErrorDemo where + +import BiDi.Actions (BiDiActions (..)) +import BiDi.DemoUtils (BiDiDemo, demo, runDemo) +import IOUtils (DemoActions (..), (===)) +import TestData (inputsUrl) +import WebDriverPreCore.BiDi.Protocol + ( Create (..), + CreateType (..), + Navigate (..), + Origin (..), + PerformActions (..), + Pointer (..), + PointerCommonProperties (..), + PointerSourceAction (..), + PointerSourceActions (..), + PointerType (..), + ReadinessState (..), + SharedId (..), + SharedReference (..), + SourceActions (..), + ErrorType (..), + WebDriverException(..) + ) +import Prelude hiding (log) +import GHC.Utils.Misc (HasCallStack) +import BiDi.Response (ResponseException (..)) +import qualified Test.Tasty.HUnit as HUnit +import UnliftIO.Exception (try) + +-- stop warning for unused demo (its used in eval) +_rundemo :: BiDiDemo -> IO () +_rundemo = runDemo + +-- >>> runDemo errorDemo +errorDemo :: BiDiDemo +errorDemo = + demo "BiDi Error Demo" action + where + action :: DemoActions -> BiDiActions -> IO () + action MkDemoActions {..} MkBiDiActions {..} = do + url <- inputsUrl + + -- Create browsing context and navigate + ctx <- browsingContextCreate MkCreate {createType = Tab, background = False, userContext = Nothing, referenceContext = Nothing} + browsingContextNavigate $ MkNavigate {context = ctx, url, wait = Just Interactive} + pause + + -- Try to click using an invalid SharedId and expect NoSuchNode error + let invalidSharedId = MkSharedId "invalid-shared-id-that-does-not-exist" + + exc <- expectProtocolException NoSuchNode $ do + r <- inputPerformActions $ + MkPerformActions + { context = ctx, + actions = + [ PointerSourceActions $ + MkPointerSourceActions + { pointerId = "mouse1", + pointer = Just $ MkPointer {pointerType = Just MousePointer}, + pointerActions = + [ PointerMove + { x = 0, + y = 0, + duration = Just 100, + origin = + Just $ + ElementOrigin $ + MkSharedReference + { sharedId = invalidSharedId, + handle = Nothing, + extensions = Nothing + }, + pointerCommonProperties = + MkPointerCommonProperties + { width = Nothing, + height = Nothing, + pressure = Nothing, + tangentialPressure = Nothing, + twist = Nothing, + altitudeAngle = Nothing, + azimuthAngle = Nothing + } + }, + PointerDown + { button = 0, + pointerCommonProperties = + MkPointerCommonProperties + { width = Nothing, + height = Nothing, + pressure = Nothing, + tangentialPressure = Nothing, + twist = Nothing, + altitudeAngle = Nothing, + azimuthAngle = Nothing + } + }, + PointerUp + { button = 0 + } + ] + } + ] + } + pure r + + logShow "Caught expected exception" exc + pause + + +expectProtocolException :: + (HasCallStack) => + ErrorType -> + IO a -> + IO ResponseException +expectProtocolException expectedError action = + try action + >>= \case + Left exc@(BiDIError ProtocolException {error = err}) -> + expectedError === err + >> pure exc + Left exc -> do + HUnit.assertFailure $ "Expected ProtocolException but got: " <> show exc + Right _ -> do + HUnit.assertFailure $ "Expected ProtocolException with error " <> show expectedError <> " but action succeeded" diff --git a/test/BiDi/Response.hs b/test/BiDi/Response.hs new file mode 100644 --- /dev/null +++ b/test/BiDi/Response.hs @@ -0,0 +1,92 @@ +module BiDi.Response + ( parseResponse, + matchResponseId, + decodeResponse, + MatchedResponse (..), + ResponseObject (..), + ResponseException (..), + Success (..), + ) +where + +import AesonUtils (parseObjectEither, subtractProps) +import Control.Exception (Exception (..)) +import Data.Aeson (FromJSON (parseJSON), Object, Value (..), eitherDecode, withObject, (.:), (.:?)) +import Data.Aeson.Types (Parser, parseEither) +import Data.Bifunctor (Bifunctor (..)) +import Data.ByteString.Lazy (ByteString) +import Data.Text (Text, pack, unpack) +import GHC.Generics (Generic) +import Utils (txt) +import WebDriverPreCore.BiDi.Protocol (EmptyResult (..), JSONEncodeException (..), JSUInt, WebDriverException (..), parseWebDriverException) + +parseResponse :: forall r. (FromJSON r) => JSUInt -> Either JSONEncodeException ResponseObject -> Maybe (Either ResponseException (MatchedResponse r)) +parseResponse id' = + either + (Just . Left . BiDIError . JSONEncodeException) + (matchResponseId id') + +matchResponseId :: forall a. (FromJSON a) => JSUInt -> ResponseObject -> Maybe (Either ResponseException (MatchedResponse a)) +matchResponseId msgId = \case + NoID {} -> Nothing + WithID id' obj -> + if id' == msgId + then + Just $ + bimap + (\e -> BiDIError . parseWebDriverException e $ Object obj) + (\s -> MkMatchedResponse {response = s.result, object = obj}) + (parseObjectEither obj :: Either Text (Success a)) + else + Nothing + +decodeResponse :: ByteString -> Either JSONEncodeException ResponseObject +decodeResponse = + (=<<) parseResponseObj . packLeft . eitherDecode + where + packLeft = first (MkJSONEncodeException "Failed to parse response" . pack) + + parseResponseObj :: Object -> Either JSONEncodeException ResponseObject + parseResponseObj = + packLeft . parseEither (\o' -> maybe NoID WithID <$> o' .:? "id" <*> pure o') + +data MatchedResponse a = MkMatchedResponse + { response :: a, + object :: Object + } + deriving (Show, Generic) + +data ResponseObject + = NoID {object :: Object} + | WithID {id :: JSUInt, object :: Object} + deriving (Show, Generic) + +data ResponseException + = BiDIError WebDriverException + | BiDiTimeoutError {ms :: Int} + deriving (Show, Eq, Generic) + +instance Exception ResponseException where + displayException :: ResponseException -> String + displayException = \case + BiDIError e -> displayException e + BiDiTimeoutError {ms} -> unpack $ "Timed out waiting for matching command response from driver (" <> txt ms <> "milliseconds)" + +data Success a = MkSuccess + { id :: JSUInt, + result :: a, + extensions :: EmptyResult + } + deriving (Show, Generic) + +instance (FromJSON a) => FromJSON (Success a) where + parseJSON :: Value -> Parser (Success a) + parseJSON = withObject "Success" $ \o -> do + id' <- o .: "id" + result <- o .: "result" + pure $ + MkSuccess + { id = id', + result, + extensions = MkEmptyResult $ subtractProps ["id", "result"] o + } diff --git a/test/BiDi/Runner.hs b/test/BiDi/Runner.hs new file mode 100644 --- /dev/null +++ b/test/BiDi/Runner.hs @@ -0,0 +1,413 @@ +module BiDi.Runner + ( ChannelActions (..), + MessageLoops (..), + mkChannelActions, + mkFaiChannelActions, + withBiDi, + withBidiFailTest, + unsubscribe, + subscribe, + ) +where + +import BiDi.Socket as S + ( Channels (..), + RegisteredSubscription (..), + SocketActions (..), + SocketSubscription (..), + SocketSubscriptionId (..), + SocketSubscriptionType (..), + SocketUnregister (..), + counterVar, + initChannels, + mkAtomicCounter, + mkSocketActions, + ) +import Control.Exception (Exception (displayException), throw) +import Control.Monad (when, (>=>)) +import Data.Aeson (FromJSON, Object, Value (..), encode, toJSON, withObject, (.:)) +import Data.Aeson.Types (FromJSON (..), Parser) +import Data.ByteString.Lazy qualified as BL +import Data.Coerce (coerce) +import Data.Foldable (traverse_) +import Data.Function ((&)) +import Data.Set qualified as Set +import Data.Text as T (Text, pack, take, unpack) +import Data.Word (Word64) +import GHC.Generics (Generic) +import IOUtils (DemoActions (..), Logger (..), catchLog, loopForever) +import Network.WebSockets (Connection, receiveData, runClient, sendTextData) +import UnliftIO (catchAny, throwIO, waitAnyCatch) +import UnliftIO.Async (Async, async, cancel) +import UnliftIO.STM +import BiDi.BiDiUrl (BiDiUrl (..)) +import WebDriverPreCore.BiDi.Protocol as P + ( JSUInt (..), + SessionSubscribeResult (..), + SessionSubscibe (..), + SessionUnsubscribe (..), + Subscription (..), + SubscriptionId (..), + SubscriptionType (..), + subscriptionTypeToText + ) +import AesonUtils (jsonToText, objToText, parseThrow) +import Utils (txt) +import Prelude hiding (getLine, log, null, print, putStrLn) +import BiDi.Response + ( ResponseObject (..), + decodeResponse, + ) + +-- | Run WebDriver BiDi client and return a client interface +withBiDi :: DemoActions -> BiDiUrl -> (DemoActions -> SocketActions -> IO ()) -> IO () +withBiDi = withBidi' mkChannelActions + +-- | Run WebDriver BiDi client and return a client interface +withBidi' :: (Logger -> IO ChannelActions) -> DemoActions -> BiDiUrl -> (DemoActions -> SocketActions -> IO ()) -> IO () +withBidi' + mkChActions + demoActions@MkDemoActions {logTxt} + bidiUrl + action = do + ca <- mkChActions logger + withSocket bidiUrl logger ca.messageLoops $ + action demoActions ca.socketActions + where + logger = MkLogger logTxt + +mkChannelActions :: Logger -> IO ChannelActions +mkChannelActions logger = do + c <- initChannels + pure $ + MkChannelActions + { socketActions = mkSocketActions c, + messageLoops = demoMessageLoops logger c + } + +data ChannelActions = MkChannelActions + { messageLoops :: MessageLoops, + socketActions :: SocketActions + } + +data MessageActions = MkMessageActions + { send :: Connection -> IO (), + get :: Connection -> IO (), + eventHandler :: IO () + } + +demoMessageActions :: Logger -> Channels -> MessageActions +demoMessageActions logger MkChannels {sendChan, receiveChan, eventChan, subscriptions} = + MkMessageActions + { send = \conn -> do + msgToSend <- atomically $ readTChan sendChan + log $ "Sending Message: " <> jsonToText msgToSend + catchLog + "Message Send Failed" + log + (sendTextData conn (BL.toStrict $ encode msgToSend)), + -- + get = \conn -> do + msg <- receiveData conn + log $ "Received raw data: " <> T.take 100 (txt msg) <> "..." + log $ "Received raw data: " <> txt msg + let writeReceiveChan = atomically . writeTChan receiveChan + writeEventChan = atomically . writeTChan eventChan + r = decodeResponse msg + case r of + Left {} -> writeReceiveChan r + Right r' -> case r' of + NoID obj -> writeEventChan obj + WithID {} -> writeReceiveChan r, + -- + eventHandler = do + obj <- atomically $ readTChan eventChan + log $ "Event received: " <> jsonToText (toJSON obj) + applySubscriptions log obj subscriptions + } + where + log :: Text -> IO () + log = logger.log + +-- +data EventProps = MkEventProps + { msgType :: Text, + method :: Text, + params :: Value, + fullObj :: Value + } + deriving (Show, Generic) + +instance FromJSON EventProps where + parseJSON :: Value -> Parser EventProps + parseJSON v = + withObject + "EventProps" + ( \o -> + MkEventProps + <$> o .: "type" + <*> o .: "method" + <*> o .: "params" + <*> pure v + ) + v + +unsubscribe :: SocketActions -> (SessionUnsubscribe -> IO ()) -> SessionUnsubscribe -> IO () +unsubscribe sa callUnsubscribe unsub = do + callUnsubscribe unsub + atomically . sa.unregisterSubscription $ toSocketUnregister unsub + where + toSocketUnregister :: SessionUnsubscribe -> SocketUnregister + toSocketUnregister = \case + UnsubscribeById {subscriptions} -> + UnregisterById . Set.fromList $ MkSocketSubscriptionId . coerce <$> subscriptions + UnsubscribeByAttributes {unsubEvents} -> + UnregisterByAttributes . Set.fromList $ MkSocketSubscriptionType . subscriptionTypeToText <$> unsubEvents + +subscribe :: + SocketActions -> + (SessionSubscibe -> IO SessionSubscribeResult) -> + Subscription IO -> + IO SubscriptionId +subscribe sa callSubscribe subscription = do + -- subscribe with a dummy id first so we don't miss any messages + atomically $ subscribeWithId dummySubId + catchAny + ( do + subId <- callSubscribe $ mkRequest subscription + -- swap in the real id + atomically $ do + removeDummySub + subscribeWithId $ coerce subId.subscription + pure subId.subscription + ) + ( \e -> do + -- on error, remove the dummy subscription + atomically removeDummySub + throwIO e + ) + where + mkRequest :: Subscription IO -> SessionSubscibe + mkRequest s = case s of + P.SingleSubscription + { subscriptionType + } -> + MkSessionSubscribe + { events = [coerce subscriptionType], + contexts, + userContexts + } + P.MultiSubscription + { subscriptionTypes + } -> + MkSessionSubscribe + { events = coerce <$> subscriptionTypes, + contexts, + userContexts + } + P.OffSpecSubscription + { subscriptionTypes + } -> + MkSessionSubscribe + { events = coerce <$> subscriptionTypes, + contexts, + userContexts + } + where + contexts = maybeList s.browsingContexts + userContexts = maybeList s.userContexts + maybeList :: [a] -> Maybe [a] + maybeList = \case + [] -> Nothing + xs -> Just xs + + mkRegistration :: Subscription IO -> SocketSubscription + mkRegistration = \case + P.SingleSubscription + { subscriptionType, + action + } -> + S.SingleSubscription + { subscriptionType = toSocketSubType subscriptionType, + action + } + s' -> case s' of + P.MultiSubscription + { nAction + } -> + S.MultiSubscription + { subscriptionTypes = socketSubtypes, + nAction = parseThrow ("Could not parse Event when executing MultiSubscription action for: " <> socketSubtypesTxt) >=> nAction + } + P.OffSpecSubscription + { nValueAction + } -> + S.MultiSubscription + { subscriptionTypes = socketSubtypes, + nAction = parseThrow ("Could not parse Value when executing OffSpecSubscription action for: " <> socketSubtypesTxt) >=> nValueAction + } + where + socketSubtypes = Set.fromList $ toSocketSubType <$> s'.subscriptionTypes + socketSubtypesTxt = txt (Set.toList socketSubtypes) + + dummySubId = MkSocketSubscriptionId "dummy" + + subscribeWithId :: SocketSubscriptionId -> STM () + subscribeWithId = + sa.registerSubscription (mkRegistration subscription) + + removeDummySub :: STM () + removeDummySub = sa.unregisterSubscription . UnregisterById $ Set.singleton dummySubId + +applySubscriptions :: (Text -> IO ()) -> Object -> TVar [RegisteredSubscription IO] -> IO () +applySubscriptions _log obj subscriptions = do + MkEventProps {msgType, method, fullObj, params} <- + parseThrow "Could not parse event properties" (Object obj) + when (msgType /= "event") $ + fail . unpack $ + "Event message expected. This is not an event message: " + <> msgType + <> "\n" + <> objToText obj + + -- log $ "Parsed event: " <> txt eventProps + subs <- readTVarIO subscriptions + traverse_ (applySubscription (coerce method) params fullObj) ((.subscription) <$> subs) + +applySubscription :: SocketSubscriptionType -> Value -> Value -> SocketSubscription -> IO () +applySubscription subType params fullObj = + \case + S.SingleSubscription {subscriptionType, action} -> + when (subType == subscriptionType) $ + parseThrow ("could not parse Event for: " <> txt subType) params + >>= action + S.MultiSubscription {subscriptionTypes, nAction} -> + when (subType `Set.member` subscriptionTypes) $ + nAction fullObj + +toSocketSubType :: SubscriptionType -> SocketSubscriptionType +toSocketSubType = MkSocketSubscriptionType . subscriptionTypeToText + +loopActions :: Logger -> MessageActions -> MessageLoops +loopActions logger MkMessageActions {..} = + MkMessageLoops + { sendLoop = asyncLoop "Sender" . send, + getLoop = asyncLoop "Receiver" . get, + eventLoop = asyncLoop "EventHandler" eventHandler + } + where + asyncLoop = loopForever logger.log + +data MessageLoops = MkMessageLoops + { sendLoop :: Connection -> IO (Async ()), + getLoop :: Connection -> IO (Async ()), + eventLoop :: IO (Async ()) + } + +demoMessageLoops :: Logger -> Channels -> MessageLoops +demoMessageLoops logger channels = + loopActions logger $ demoMessageActions logger channels + +withSocket :: BiDiUrl -> Logger -> MessageLoops -> IO () -> IO () +withSocket + pth@MkBiDiUrl {host, port, path} + logger + messageLoops + action = + do + log $ "Connecting to WebDriver at " <> txt pth + runClient (unpack host) port (unpack path) $ \conn -> do + eventLoop <- messageLoops.eventLoop + getLoop <- messageLoops.getLoop conn + sendLoop <- messageLoops.sendLoop conn + + log "WebSocket connection established" + + result <- async action + + (_asy, ethresult) <- waitAnyCatch [getLoop, sendLoop, result, eventLoop] + + -- cancelMany not reexported by UnliftIO + traverse_ cancel [getLoop, sendLoop, result, eventLoop] + + ethresult + & either + ( \e -> do + log $ "One of the BiDi client threads failed: \n" <> pack (displayException e) + throw e + ) + pure + where + log :: Text -> IO () + log = coerce logger + +-- #################################################################################### +-- ######################## Fail Actions - for testing errors ######################## +-- #################################################################################### + +-- | Run WebDriver BiDi client and return a client interface +withBidiFailTest :: + Word64 -> + Word64 -> + Word64 -> + DemoActions -> + BiDiUrl -> + (DemoActions -> SocketActions -> IO ()) -> + IO () +withBidiFailTest failSendCount failGetCount failEventCount = + withBidi' (mkFaiChannelActions failSendCount failGetCount failEventCount) + +mkFaiChannelActions :: + Word64 -> + Word64 -> + Word64 -> + Logger -> + IO ChannelActions +mkFaiChannelActions failSendCount failGetCount failEventCount logger = do + c <- initChannels + messageLoops <- failMessageLoops logger c failSendCount failGetCount failEventCount + pure $ + MkChannelActions + { socketActions = mkSocketActions c, + messageLoops + } + +failMessageLoops :: + Logger -> + Channels -> + Word64 -> + Word64 -> + Word64 -> + IO MessageLoops +failMessageLoops logger channels failSendCount failGetCount failEventCount = + loopActions logger + <$> failMessageActions + (demoMessageActions logger channels) + failSendCount + failGetCount + failEventCount + +failMessageActions :: MessageActions -> Word64 -> Word64 -> Word64 -> IO MessageActions +failMessageActions a failSendCount failGetCount failEventCount = + do + send <- failAction "send" failSendCount a.send + get <- failAction "get" failGetCount a.get + eventHandler' <- failAction "eventhandler" failEventCount $ const a.eventHandler + pure $ + MkMessageActions + { send, + get, + eventHandler = eventHandler' 1 + } + +failAction :: Text -> Word64 -> (a -> IO ()) -> IO ((a -> IO ())) +failAction lbl failCallCount action = do + counterVar' <- counterVar + let counter = mkAtomicCounter counterVar' + pure $ \a -> do + n <- atomically $ counter + if (coerce n :: Word64) == failCallCount + then do + fail $ "Forced failure for testing: " <> unpack lbl <> " (call #" <> show n <> ")" + else do + action a diff --git a/test/BiDi/Socket.hs b/test/BiDi/Socket.hs new file mode 100644 --- /dev/null +++ b/test/BiDi/Socket.hs @@ -0,0 +1,230 @@ +module BiDi.Socket + ( SocketSubscription (..), + SocketSubscriptionId (..), + SocketCommand (..), + SocketActions (..), + SocketUnregister (..), + SocketSubscriptionType (..), + Channels (..), + RegisteredSubscription (..), + Request (..), + initChannels, + mkSocketActions, + sendCommand, + sendCommand', + sendCommandNoWait, + sendCommandNoWait', + matchedRequest, + counterVar, + mkAtomicCounter, + ) +where + +import BiDi.Response + ( MatchedResponse (..), + ResponseObject (..), + parseResponse, + ) +--- + +import Control.Exception (throw) +import Data.Aeson (FromJSON, Object, ToJSON, Value (..), object, toJSON, (.=)) +import Data.Function ((&)) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text, unpack) +import GHC.Generics (Generic) +import UnliftIO.Exception (Exception (..), SomeException, catch) +import UnliftIO.STM + ( STM, + TChan, + TVar, + atomically, + modifyTVar', + newTChanIO, + newTVarIO, + readTChan, + readTVar, + writeTChan, + ) +import Utils (txt) +import WebDriverPreCore.BiDi.Protocol (JSUInt (..), JSONEncodeException (..)) +import Prelude hiding (id, log) + +-- TODO: ON LIBRARY SPLIT - test / fix / handle - timeouts / exceptions thrown from channel threads +-- eg test ux when serialisation error in get set handle subscription + +data SocketCommand a r = MkSocketCommand + { method :: a, + params :: Value + } + deriving (Show, Eq) + +data SocketSubscription where + SingleSubscription :: + forall r. + (FromJSON r) => + { subscriptionType :: SocketSubscriptionType, + action :: r -> IO () + } -> + SocketSubscription + MultiSubscription :: + { subscriptionTypes :: Set SocketSubscriptionType, + nAction :: Value -> IO () + } -> + SocketSubscription + +data SocketUnregister + = UnregisterById + {subscriptionIds :: Set SocketSubscriptionId} + | UnregisterByAttributes + {subscriptionTypes :: Set SocketSubscriptionType} + deriving (Show, Eq, Generic) + +newtype SocketSubscriptionId = MkSocketSubscriptionId {subscriptionId :: Text} + deriving (Show, Eq, Generic, Ord, FromJSON, ToJSON) + +newtype SocketSubscriptionType = MkSocketSubscriptionType {subscriptionType :: Text} + deriving (Generic) + deriving newtype (Show, Eq, Ord) + +-- | WebDriver BiDi client with communication channels +data SocketActions = MkBiDiSocket + { nextId :: STM JSUInt, + send :: forall a. (ToJSON a, Show a) => a -> STM (), + getNext :: STM (Either JSONEncodeException ResponseObject), + registerSubscription :: SocketSubscription -> SocketSubscriptionId -> STM (), + unregisterSubscription :: SocketUnregister -> STM () + } + +data Channels = MkChannels + { sendChan :: TChan Value, + receiveChan :: TChan (Either JSONEncodeException ResponseObject), + eventChan :: TChan Object, + counterVar :: TVar JSUInt, + subscriptions :: TVar [RegisteredSubscription IO] + } + +data RegisteredSubscription m = MkRegisteredSubscription + { subscriptionId :: SocketSubscriptionId, + subscription :: SocketSubscription + } + +data Request = MkRequest + { id :: JSUInt, + payload :: Value + } + deriving (Show, Generic) + +initChannels :: IO Channels +initChannels = + MkChannels + <$> newTChanIO + <*> newTChanIO + <*> newTChanIO + <*> counterVar + <*> newTVarIO [] + +counterVar :: IO (TVar JSUInt) +counterVar = newTVarIO $ MkJSUInt 0 + +mkAtomicCounter :: TVar JSUInt -> STM JSUInt +mkAtomicCounter var = do + modifyTVar' var succ + readTVar var + +mkSocketActions :: Channels -> SocketActions +mkSocketActions c = + MkBiDiSocket + { nextId = mkAtomicCounter c.counterVar, + send, + getNext = readTChan c.receiveChan, + registerSubscription = \sub subid -> registerSubscription c.subscriptions sub subid, + unregisterSubscription = unregisterSubscription c.subscriptions + } + where + send :: forall a. (ToJSON a) => a -> STM () + send a = do + -- make strict so serialisation errors come from here and not in the logger + let !json = toJSON a + writeTChan c.sendChan json + +sendCommandNoWait' :: forall a r. (Show a, ToJSON a) => SocketActions -> SocketCommand a r -> JSUInt -> IO Request +sendCommandNoWait' MkBiDiSocket {send} command id = do + (atomically $ send payload) + `catch` \(e :: SomeException) -> do + fail $ + "Send command failed: \n" + <> unpack (txt command) + <> "\n ---- Exception -----\n" + <> displayException e + pure $ MkRequest {id = id, payload} + where + payload = + object + [ "id" .= id, + "method" .= command.method, + "params" .= command.params + ] + +sendCommandNoWait :: forall a r. (Show a, ToJSON a) => SocketActions -> SocketCommand a r -> IO Request +sendCommandNoWait sa command = + atomically sa.nextId >>= sendCommandNoWait' sa command + +sendCommand' :: forall a r. (FromJSON r, Show a, ToJSON a) => SocketActions -> JSUInt -> SocketCommand a r -> IO r +sendCommand' sa id' command = do + MkRequest {payload} <- sendCommandNoWait' sa command id' + matchedRequest sa.getNext payload id' + +sendCommand :: forall a r. (FromJSON r, Show a, ToJSON a) => SocketActions -> SocketCommand a r -> IO r +sendCommand m@MkBiDiSocket {getNext} command = do + MkRequest {id = id', payload} <- sendCommandNoWait m command + matchedRequest getNext payload id' + +matchedRequest :: forall r. (FromJSON r) => STM (Either JSONEncodeException ResponseObject) -> Value -> JSUInt -> IO r +matchedRequest getNext request id' = do + response <- atomically getNext + parseResponse id' response + & maybe + (matchedRequest getNext request id') + (either throw (pure . (.response))) + +registerSubscription :: + TVar [RegisteredSubscription IO] -> + SocketSubscription -> + SocketSubscriptionId -> + STM () +registerSubscription allSubs subscription subId = do + modifyTVar' allSubs (MkRegisteredSubscription subId subscription :) + +unregisterSubscription :: TVar [RegisteredSubscription IO] -> SocketUnregister -> STM () +unregisterSubscription allSubs unsub = + case unsub of + UnregisterById {subscriptionIds = subs} -> + modifyTVar' allSubs $ filter (\s -> not (s.subscriptionId `elem` subs)) + UnregisterByAttributes {subscriptionTypes = unregTypes} -> + modifyTVar' allSubs $ + -- remove multi-subscriptions with empty types and single subscriptions matching unsubscribed events + filter (not . subscriptionIsEmpty . (.subscription)) + -- remove subscriptions matching any of the unsubscribed events in multi subscriptions + . fmap removeSubFromMultiSocketRegistration + where + removeSubFromMultiSocketRegistration :: RegisteredSubscription IO -> RegisteredSubscription IO + removeSubFromMultiSocketRegistration regSub@MkRegisteredSubscription {subscription} = + regSub + { subscription = removeSubscriptionFromMulti subscription + } + + removeSubscriptionFromMulti :: SocketSubscription -> SocketSubscription + removeSubscriptionFromMulti = \case + MultiSubscription {subscriptionTypes = subTypes, nAction} -> + MultiSubscription + { subscriptionTypes = subTypes `Set.difference` unregTypes, + nAction + } + s@SingleSubscription {} -> s + + subscriptionIsEmpty :: SocketSubscription -> Bool + subscriptionIsEmpty = \case + MultiSubscription {subscriptionTypes} -> Set.null subscriptionTypes + SingleSubscription {subscriptionType} -> subscriptionType `Set.member` unregTypes diff --git a/test/Config.hs b/test/Config.hs new file mode 100644 --- /dev/null +++ b/test/Config.hs @@ -0,0 +1,34 @@ +module Config + ( Config (..), + DemoBrowser (..), + isFirefox + ) +where + +import Data.Text as T (Text) +import Dhall (FromDhall, Generic, ToDhall) + +isFirefox :: DemoBrowser -> Bool +isFirefox = \case + Firefox {} -> True + Chrome {} -> False + +data DemoBrowser = Chrome {headless :: Bool} | Firefox {headless :: Bool, profilePath :: Maybe Text} + deriving (Eq, Show, Generic) + +instance FromDhall DemoBrowser + +instance ToDhall DemoBrowser + +data Config = MkConfig + { browser :: DemoBrowser, + httpUrl :: Text, + httpPort :: Word, + logging :: Bool, + pauseMS :: Word + } + deriving (Eq, Generic, Show) + +instance FromDhall Config + +instance ToDhall Config diff --git a/test/ConfigLoader.hs b/test/ConfigLoader.hs new file mode 100644 --- /dev/null +++ b/test/ConfigLoader.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE CPP #-} + +module ConfigLoader + ( Config (..), + DemoBrowser (..), + isFirefox, + loadConfig, + ) +where + +import Config ( Config (..), + DemoBrowser (..), + isFirefox + ) + +import Data.Text.IO qualified as T + +#ifdef DEBUG_LOCAL_CONFIG +import DebugConfig (debugConfig) +#else +import Control.Monad (unless) +import Data.Text as T (Text, pack, unlines) +import Dhall (auto, input) +import IOUtils (findWebDriverRoot) +import System.Directory (doesFileExist, getCurrentDirectory) +import System.FilePath (combine, ()) +#endif + +#ifndef DEBUG_LOCAL_CONFIG +configDir :: IO FilePath +configDir = do + currentDir <- getCurrentDirectory + case findWebDriverRoot currentDir of + Just root -> pure $ root testSubDir ".config" + Nothing -> + error $ + "Could not find 'webdriver' root directory from: " + <> currentDir + <> "\n tests are expected to be run from the 'webdriver' directory or " + <> testSubDir + where + testSubDir = "webdriver-precore" "test" + +initialiseTestConfig :: IO () +initialiseTestConfig = do + userPath' <- userPath + exists <- doesFileExist userPath' + unless exists $ do + putStrLn $ "Saving default config to: " <> userPath' + T.writeFile userPath' configText + +{- +Generating in code is more principled but produces a less readable file. + +import Dhall.Pretty qualified as P +let expr = embed (inject @Config) defaultConfig + doc = pack (show (P.prettyCharacterSet P.ASCII expr)) + -} +configText :: Text +configText = + T.unlines + [ "-- Config types", + "let Browser = ", + " < Chrome : { headless : Bool }", + " | Firefox : ", + " { headless : Bool", + " , profilePath : Optional Text ", + " }", + " >", + "", + "let Config = ", + " { browser : Browser", + " , logging : Bool", + " , httpUrl : Text", + " , httpPort : Natural", + " , pauseMS : Natural", + " }", + "", + "-- Config value", + "let browser : Browser = ", + " Browser.Firefox ", + " { headless = False", + " , profilePath = None Text", + " }", + "", + "let config : Config = ", + " { browser = browser", + " , logging = True", + " , httpUrl = \"127.0.0.1\"", + " , httpPort = 4444", + " , pauseMS = 2000", + " }", + "", + "in config" + ] + +readConfig :: IO Config +readConfig = + userPath >>= input auto . pack + +userPath :: IO FilePath +userPath = + configDir >>= pure . (flip combine) "config.dhall" +#endif + +loadConfig :: IO Config +loadConfig = do +#ifdef DEBUG_LOCAL_CONFIG + T.putStrLn "Using debug local config" + pure debugConfig +#else + userPath' <- userPath + T.putStrLn $ "Loading config from file: " <> pack userPath' + initialiseTestConfig + readConfig +#endif diff --git a/test/Const.hs b/test/Const.hs new file mode 100644 --- /dev/null +++ b/test/Const.hs @@ -0,0 +1,78 @@ +module Const + ( ReqRequestParams (..), + Timeout (..), + second, + seconds, + minute, + minutes, + hour, + hours, + defaultRequest, + millisecond, + milliseconds, + ) +where + +import Network.HTTP.Req as R + ( GET (GET), + HttpBody, + HttpBodyAllowed, + HttpMethod (AllowsBody), + NoReqBody (NoReqBody), + ProvidesBody, + Scheme (..), + Url, + http, + ) + + +-- ################### time ################## + +newtype Timeout = MkTimeout {microseconds :: Int} + deriving (Show, Eq) + deriving newtype (Num) + +millisecond :: Timeout +millisecond = MkTimeout 1_000 + +milliseconds :: Timeout +milliseconds = millisecond + +second :: Timeout +second = 1_000 * milliseconds + +seconds :: Timeout +seconds = second + +minute :: Timeout +minute = 60 * seconds + +minutes :: Timeout +minutes = minute + +hour :: Timeout +hour = 60 * minutes + +hours :: Timeout +hours = hour + +-- ################### request ################## + +data ReqRequestParams where + MkRequestParams :: + (HttpBodyAllowed (AllowsBody method) (ProvidesBody body), HttpMethod method, HttpBody body) => + { url :: Url 'Http, + method :: method, + body :: body, + port :: Int + } -> + ReqRequestParams + +defaultRequest :: ReqRequestParams +defaultRequest = + MkRequestParams + { url = http "127.0.0.1", + method = GET, + body = NoReqBody, + port = 4444 + } diff --git a/test/DebugConfig.hs b/test/DebugConfig.hs new file mode 100644 --- /dev/null +++ b/test/DebugConfig.hs @@ -0,0 +1,84 @@ +module DebugConfig + ( debugConfig, + ) +where + +import Config + ( Config (..), + DemoBrowser (..), + ) +import Data.Text (Text) + +debugConfig :: Config +debugConfig = + -- + -- _firefoxSilent + -- _chromeSilent + -- _firefoxHeadlessLogging + -- _chromeHeadlessLogging + _firefoxDebug + -- _chromeDebug + +_firefoxSilent :: Config +_firefoxSilent = + MkConfig + { browser = Firefox {headless = True, profilePath}, + logging = False, + httpUrl = "127.0.0.1", + httpPort = 4444, + pauseMS = 0 + } + +_firefoxHeadlessLogging :: Config +_firefoxHeadlessLogging = + MkConfig + { browser = Firefox {headless = True, profilePath}, + logging = True, + httpUrl = "127.0.0.1", + httpPort = 4444, + pauseMS = 0 + } + +_firefoxDebug :: Config +_firefoxDebug = + MkConfig + { browser = Firefox {headless = False, profilePath}, + logging = True, + httpUrl = "127.0.0.1", + httpPort = 4444, + pauseMS = 0 + } + +_chromeSilent :: Config +_chromeSilent = + MkConfig + { browser = Chrome {headless = True}, + logging = False, + httpUrl = "127.0.0.1", + httpPort = 4444, + pauseMS = 0 + } + +_chromeHeadlessLogging :: Config +_chromeHeadlessLogging = + MkConfig + { browser = Chrome {headless = True}, + logging = True, + httpUrl = "127.0.0.1", + httpPort = 4444, + pauseMS = 0 + } + +_chromeDebug :: Config +_chromeDebug = + MkConfig + { browser = Chrome {headless = False}, + logging = True, + httpUrl = "127.0.0.1", + httpPort = 4444, + pauseMS = 0 + } + +profilePath :: Maybe Text +profilePath = Just "/home/john-walker/test-firefox-profile" + diff --git a/test/Driver.hs b/test/Driver.hs deleted file mode 100644 --- a/test/Driver.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF tasty-discover #-} - --- add tasty discover to dev container / image -- cabal install tasty-discover diff --git a/test/ErrorCoverageTest.hs b/test/ErrorCoverageTest.hs --- a/test/ErrorCoverageTest.hs +++ b/test/ErrorCoverageTest.hs @@ -1,34 +1,30 @@ module ErrorCoverageTest where -import Data.Set as S (Set, difference, fromList, null) +import Data.Set as S (Set, difference, fromList, null, union) import Data.Text as T (Text, lines, null, pack, strip, split) import GHC.Utils.Misc (filterOut) import Test.Tasty.HUnit as HUnit ( assertBool, Assertion, (@=?) ) import Text.RawString.QQ (r) -import WebDriverPreCore - ( errorTypeToErrorCode, +import WebDriverPreCore.BiDi.Protocol + ( toErrorCode, errorDescription, - errorCodeToErrorType ) -import GHC.Show (Show (..)) -import Data.Eq (Eq ((==))) -import Data.Ord (Ord) -import Data.Function (($), (.), (&)) -import Data.Semigroup ((<>)) -import Data.Functor ((<$>)) -import GHC.Base (error) -import WebDriverPreCore.Internal.Utils (enumerate) + toErrorType ) +import Data.Function ((&)) +import Utils(enumerate) import Data.Foldable (traverse_) -import Data.Either (either) +import WebDriverPreCore.HTTP.Protocol (ErrorType) {- !! Replace this the endepoints from the spec with every release !! remove full stops and replace tabs with " | " -https://www.w3.org/TR/2025/WD-webdriver2-20250306 - W3C Editor's Draft 10 February 2025 +https://www.w3.org/TR/2025/WD-webdriver2-20251028 - W3C Editor's Draft 10 February 2025 61 endpoints Error Code HTTP Status JSON Error Code Description +NOTE: This entry is moved out because it is duplicated, with a slightly different description in the BiDi spec +unable to set cookie | 500 | unable to set cookie | A command to set a cookie's value could not be satisfied -} -errorsFromSpec :: Text -errorsFromSpec = pack +httpErrorsFromSpec :: Text +httpErrorsFromSpec = pack [r|element click intercepted | 400 | element click intercepted | The Element Click command could not be completed because the element receiving the events is obscuring the element that was requested clicked element not interactable | 400 | element not interactable | A command could not be completed because the element is not pointer- or keyboard interactable insecure certificate | 400 | insecure certificate | Navigation caused the user agent to hit a certificate warning, which is usually the result of an expired or invalid TLS certificate @@ -50,7 +46,6 @@ stale element reference | 404 | stale element reference | A command failed because the referenced element is no longer attached to the DOM detached shadow root | 404 | detached shadow root | A command failed because the referenced shadow root is no longer attached to the DOM timeout | 500 | timeout | An operation did not complete before its timeout expired -unable to set cookie | 500 | unable to set cookie | A command to set a cookie's value could not be satisfied unable to capture screen | 500 | unable to capture screen | A screen capture was made impossible unexpected alert open | 500 | unexpected alert open | A modal dialog was open, blocking this operation unknown command | 404 | unknown command | A command could not be executed because the remote end is not aware of it @@ -59,6 +54,32 @@ unsupported operation | 500 | unsupported operation | Indicates that a command that should have executed properly cannot be supported for some reason |] +{- +!! Replace this with the error codes from the BiDi spec with every release +WebDriver BiDi Spec +-} +bidiErrorsFromSpec :: Text +bidiErrorsFromSpec = pack + [r|invalid web extension | Tried to install an invalid web extension +no such client window | Tried to interact with an unknown client window +no such handle | Tried to deserialize an unknown RemoteObjectReference +no such history entry | Tried to navigate to an unknown session history entry +no such network collector | Tried to remove an unknown collector +no such intercept | Tried to remove an unknown network intercept +no such network data | Tried to reference an unknown network data +no such node | Tried to deserialize an unknown SharedReference +no such request | Tried to continue an unknown request +no such script | Tried to remove an unknown preload script +no such storage partition | Tried to access data in a non-existent storage partition +no such user context | Tried to reference an unknown user context +no such web extension | Tried to reference an unknown web extension +unable to close browser | Tried to close the browser, but failed to do so +unable to set cookie | Tried to create a cookie, but the user agent rejected it +underspecified storage partition | Tried to interact with data in a storage partition which was not adequately specified +unable to set file input | Tried to set a file input, but failed to do so +unavailable network data | Tried to get network data which was not collected or already evicted|] + + data ErrorLine = MkErrorLine { jsonErrorCode :: Text, @@ -66,10 +87,10 @@ } deriving (Show, Eq, Ord) --- >>> allErrorsFromSpec +-- >>> allHttpErrorsFromSpec -- fromList [MkErrorLine {jsonErrorCode = "detached shadow root", description = "A command failed because the referenced shadow root is no longer attached to the DOM"},MkErrorLine {jsonErrorCode = "element click intercepted", description = "The Element Click command could not be completed because the element receiving the events is obscuring the element that was requested clicked"},MkErrorLine {jsonErrorCode = "element not interactable", description = "A command could not be completed because the element is not pointer- or keyboard interactable"},MkErrorLine {jsonErrorCode = "insecure certificate", description = "Navigation caused the user agent to hit a certificate warning, which is usually the result of an expired or invalid TLS certificate"},MkErrorLine {jsonErrorCode = "invalid argument", description = "The arguments passed to a command are either invalid or malformed"},MkErrorLine {jsonErrorCode = "invalid cookie domain", description = "An illegal attempt was made to set a cookie under a different domain than the current page"},MkErrorLine {jsonErrorCode = "invalid element state", description = "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"},MkErrorLine {jsonErrorCode = "invalid selector", description = "Argument was an invalid selector"},MkErrorLine {jsonErrorCode = "invalid session id", description = "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"},MkErrorLine {jsonErrorCode = "javascript error", description = "An error occurred while executing JavaScript supplied by the user"},MkErrorLine {jsonErrorCode = "move target out of bounds", description = "The target for mouse interaction is not in the browser's viewport and cannot be brought into that viewport"},MkErrorLine {jsonErrorCode = "no such alert", description = "An attempt was made to operate on a modal dialog when one was not open"},MkErrorLine {jsonErrorCode = "no such cookie", description = "No cookie matching the given path name was found amongst the associated cookies of session's current browsing context's active document"},MkErrorLine {jsonErrorCode = "no such element", description = "An element could not be located on the page using the given search parameters"},MkErrorLine {jsonErrorCode = "no such frame", description = "A command to switch to a frame could not be satisfied because the frame could not be found"},MkErrorLine {jsonErrorCode = "no such shadow root", description = "The element does not have a shadow root"},MkErrorLine {jsonErrorCode = "no such window", description = "A command to switch to a window could not be satisfied because the window could not be found"},MkErrorLine {jsonErrorCode = "script timeout", description = "A script did not complete before its timeout expired"},MkErrorLine {jsonErrorCode = "session not created", description = "A new session could not be created"},MkErrorLine {jsonErrorCode = "stale element reference", description = "A command failed because the referenced element is no longer attached to the DOM"},MkErrorLine {jsonErrorCode = "timeout", description = "An operation did not complete before its timeout expired"},MkErrorLine {jsonErrorCode = "unable to capture screen", description = "A screen capture was made impossible"},MkErrorLine {jsonErrorCode = "unable to set cookie", description = "A command to set a cookie's value could not be satisfied"},MkErrorLine {jsonErrorCode = "unexpected alert open", description = "A modal dialog was open, blocking this operation"},MkErrorLine {jsonErrorCode = "unknown command", description = "A command could not be executed because the remote end is not aware of it"},MkErrorLine {jsonErrorCode = "unknown error", description = "An unknown error occurred in the remote end while processing the command"},MkErrorLine {jsonErrorCode = "unknown method", description = "The requested command matched a known URL but did not match any method for that URL"},MkErrorLine {jsonErrorCode = "unsupported operation", description = "Indicates that a command that should have executed properly cannot be supported for some reason"}] -allErrorsFromSpec :: Set ErrorLine -allErrorsFromSpec = fromList $ parseErrorLine <$> filterOut T.null (T.lines errorsFromSpec) +allHttpErrorsFromSpec :: Set ErrorLine +allHttpErrorsFromSpec = fromList $ parseErrorLine <$> filterOut T.null (T.lines httpErrorsFromSpec) where parseErrorLine :: Text -> ErrorLine parseErrorLine line = @@ -77,25 +98,40 @@ [_errrorCode, _httpStatus , jsonErrorCode, description] -> MkErrorLine (strip jsonErrorCode) $ strip description _ -> error $ "Error parsing line: " <> show line +-- >>> allBiDiErrorsFromSpec +-- fromList [MkErrorLine {jsonErrorCode = "invalid web extension", description = "Tried to install an invalid web extension"},MkErrorLine {jsonErrorCode = "no such client window", description = "Tried to interact with an unknown client window"},MkErrorLine {jsonErrorCode = "no such handle", description = "Tried to deserialize an unknown RemoteObjectReference"},MkErrorLine {jsonErrorCode = "no such history entry", description = "Tried to havigate to an unknown session history entry"},MkErrorLine {jsonErrorCode = "no such intercept", description = "Tried to remove an unknown network intercept"},MkErrorLine {jsonErrorCode = "no such network collector", description = "Tried to remove an unknown collector"},MkErrorLine {jsonErrorCode = "no such network data", description = "Tried to reference an unknown network data"},MkErrorLine {jsonErrorCode = "no such node", description = "Tried to deserialize an unknown SharedReference"},MkErrorLine {jsonErrorCode = "no such request", description = "Tried to continue an unknown request"},MkErrorLine {jsonErrorCode = "no such script", description = "Tried to remove an unknown preload script"},MkErrorLine {jsonErrorCode = "no such storage partition", description = "Tried to access data in a non-existent storage partition"},MkErrorLine {jsonErrorCode = "no such user context", description = "Tried to reference an unknown user context"},MkErrorLine {jsonErrorCode = "no such web extension", description = "Tried to reference an unknown web extension"},MkErrorLine {jsonErrorCode = "unable to close browser", description = "Tried to close the browser, but failed to do so"},MkErrorLine {jsonErrorCode = "unable to set cookie", description = "Tried to create a cookie, but the user agent rejected it"},MkErrorLine {jsonErrorCode = "unable to set file input", description = "Tried to set a file input, but failed to do so"},MkErrorLine {jsonErrorCode = "unavailable network data", description = "Tried to get network data which was not collected or already evicted"},MkErrorLine {jsonErrorCode = "underspecified storage partition", description = "Tried to interact with data in a storage partition which was not adequately specified"}] +allBiDiErrorsFromSpec :: Set ErrorLine +allBiDiErrorsFromSpec = fromList $ parseErrorLine <$> filterOut T.null (T.lines bidiErrorsFromSpec) + where + parseErrorLine :: Text -> ErrorLine + parseErrorLine line = + T.split (== '|') line & \case + [jsonErrorCode, description] -> MkErrorLine (strip jsonErrorCode) $ strip description + _ -> error $ "Error parsing line: " <> show line + + +allErrorsFromSpec :: Set ErrorLine +allErrorsFromSpec = allHttpErrorsFromSpec `union` allBiDiErrorsFromSpec + -- >>> allErrors -- fromList [MkErrorLine {jsonErrorCode = "detached shadow root", description = "A command failed because the referenced shadow root is no longer attached to the DOM"},MkErrorLine {jsonErrorCode = "element click intercepted", description = "The Element Click command could not be completed because the element receiving the events is obscuring the element that was requested clicked"},MkErrorLine {jsonErrorCode = "element not interactable", description = "A command could not be completed because the element is not pointer- or keyboard interactable"},MkErrorLine {jsonErrorCode = "insecure certificate", description = "Navigation caused the user agent to hit a certificate warning, which is usually the result of an expired or invalid TLS certificate"},MkErrorLine {jsonErrorCode = "invalid argument", description = "The arguments passed to a command are either invalid or malformed"},MkErrorLine {jsonErrorCode = "invalid cookie domain", description = "An illegal attempt was made to set a cookie under a different domain than the current page"},MkErrorLine {jsonErrorCode = "invalid element state", description = "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"},MkErrorLine {jsonErrorCode = "invalid selector", description = "Argument was an invalid selector"},MkErrorLine {jsonErrorCode = "invalid session id", description = "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"},MkErrorLine {jsonErrorCode = "javascript error", description = "An error occurred while executing JavaScript supplied by the user"},MkErrorLine {jsonErrorCode = "move target out of bounds", description = "The target for mouse interaction is not in the browser's viewport and cannot be brought into that viewport"},MkErrorLine {jsonErrorCode = "no such alert", description = "An attempt was made to operate on a modal dialog when one was not open"},MkErrorLine {jsonErrorCode = "no such cookie", description = "No cookie matching the given path name was found amongst the associated cookies of session's current browsing context's active document"},MkErrorLine {jsonErrorCode = "no such element", description = "An element could not be located on the page using the given search parameters"},MkErrorLine {jsonErrorCode = "no such frame", description = "A command to switch to a frame could not be satisfied because the frame could not be found"},MkErrorLine {jsonErrorCode = "no such shadow root", description = "The element does not have a shadow root"},MkErrorLine {jsonErrorCode = "no such window", description = "A command to switch to a window could not be satisfied because the window could not be found"},MkErrorLine {jsonErrorCode = "script timeout", description = "A script did not complete before its timeout expired"},MkErrorLine {jsonErrorCode = "session not created", description = "A new session could not be created"},MkErrorLine {jsonErrorCode = "stale element reference", description = "A command failed because the referenced element is no longer attached to the DOM"},MkErrorLine {jsonErrorCode = "timeout", description = "An operation did not complete before its timeout expired"},MkErrorLine {jsonErrorCode = "unable to capture screen", description = "A screen capture was made impossible"},MkErrorLine {jsonErrorCode = "unable to set cookie", description = "A command to set a cookie's value could not be satisfied"},MkErrorLine {jsonErrorCode = "unexpected alert open", description = "A modal dialog was open, blocking this operation"},MkErrorLine {jsonErrorCode = "unknown command", description = "A command could not be executed because the remote end is not aware of it"},MkErrorLine {jsonErrorCode = "unknown error", description = "An unknown error occurred in the remote end while processing the command"},MkErrorLine {jsonErrorCode = "unknown method", description = "The requested command matched a known URL but did not match any method for that URL"},MkErrorLine {jsonErrorCode = "unsupported operation", description = "Indicates that a command that should have executed properly cannot be supported for some reason"}] -allErrors :: Set ErrorLine -allErrors = fromList $ +allErrorsFromType :: Set ErrorLine +allErrorsFromType = fromList $ (\et -> MkErrorLine { - jsonErrorCode = errorTypeToErrorCode et, + jsonErrorCode = toErrorCode et, description = errorDescription et - }) <$> enumerate + }) <$> enumerate @ErrorType -- >>> unit_test_all_errors_covered unit_test_all_errors_covered :: Assertion unit_test_all_errors_covered = do -- print allErrors -- putStrLn "" - assertBool ("Missing errors (in spec not captured by WebDriverErrorType):\n " <> show missing) (S.null missing) - assertBool ("Extra errors (in WebDriverErrorType but not in spec):\n " <> show extra) (S.null extra) + assertBool ("!!!! Missing ErrorTypes ~ in spec but not in WebDriverErrorType) !!!!:\n " <> show missing) (S.null missing) + assertBool ("!!!! Extra errors ~ in WebDriverErrorType but not in spec !!!!:\n " <> show extra) (S.null extra) where - missing = allErrors `difference` allErrorsFromSpec - extra = allErrorsFromSpec `difference` allErrors + missing = allErrorsFromSpec `difference` allErrorsFromType + extra = allErrorsFromType `difference` allErrorsFromSpec -- >>> unit_round_trip_error_codes @@ -104,6 +140,10 @@ traverse_ checkRoundTripErrorCodes enumerate where checkRoundTripErrorCodes errorType = do - let errorCode = errorTypeToErrorCode errorType - errorType' = errorCodeToErrorType errorCode - errorType' & either (error . show) (errorType @=?) + let errorCode = toErrorCode errorType + errorType' = toErrorType errorCode + errorType' & either (\e -> error $ "Failed to parse error code: " <> show e <> " for error code: " <> show errorCode) (errorType @=?) + + + + diff --git a/test/HTTP/Actions.hs b/test/HTTP/Actions.hs new file mode 100644 --- /dev/null +++ b/test/HTTP/Actions.hs @@ -0,0 +1,195 @@ +module HTTP.Actions + ( HttpActions (..), + mkActions, + ) +where + +import Data.Aeson (FromJSON, Value) +import Data.Text (Text) +import HTTP.Runner (HttpRunner (..)) +import WebDriverPreCore.HTTP.API qualified as API +import WebDriverPreCore.HTTP.Protocol + ( Actions (..), + Cookie (..), + ElementId (..), + FrameReference (..), + FullCapabilities (..), + Handle (..), + Script (..), + Selector (..), + Session (..), + SessionResponse (..), + ShadowRootElementId, + Status (..), + Timeouts (..), + URL, + WindowHandleSpec (..), + WindowRect (..), + Command + ) + +_for_implementation_see_mkActions :: HttpRunner -> HttpActions +_for_implementation_see_mkActions = mkActions + +data HttpActions = MkHttpActions + { -- Root methods + status :: IO Status, + newSession :: FullCapabilities -> IO SessionResponse, + -- Session methods + deleteSession :: Session -> IO (), + getTimeouts :: Session -> IO Timeouts, + setTimeouts :: Session -> Timeouts -> IO (), + navigateTo :: Session -> URL -> IO (), + getCurrentUrl :: Session -> IO URL, + back :: Session -> IO (), + forward :: Session -> IO (), + refresh :: Session -> IO (), + getTitle :: Session -> IO Text, + getWindowHandle :: Session -> IO Handle, + newWindow :: Session -> IO WindowHandleSpec, + closeWindow :: Session -> IO [Handle], + switchToWindow :: Session -> Handle -> IO (), + switchToFrame :: Session -> FrameReference -> IO (), + getPageSource :: Session -> IO Text, + executeScript :: Session -> Script -> IO Value, + executeScriptAsync :: Session -> Script -> IO Value, + addCookie :: Session -> Cookie -> IO (), + getAllCookies :: Session -> IO [Cookie], + getNamedCookie :: Session -> Text -> IO Cookie, + deleteCookie :: Session -> Text -> IO (), + deleteAllCookies :: Session -> IO (), + performActions :: Session -> Actions -> IO (), + releaseActions :: Session -> IO (), + dismissAlert :: Session -> IO (), + acceptAlert :: Session -> IO (), + getAlertText :: Session -> IO Text, + sendAlertText :: Session -> Text -> IO (), + takeScreenshot :: Session -> IO Text, + printPage :: Session -> IO Text, + -- Window methods + getWindowHandles :: Session -> IO [Handle], + getWindowRect :: Session -> IO WindowRect, + setWindowRect :: Session -> WindowRect -> IO WindowRect, + maximizeWindow :: Session -> IO WindowRect, + minimizeWindow :: Session -> IO WindowRect, + fullScreenWindow :: Session -> IO WindowRect, + -- Frame methods + switchToParentFrame :: Session -> IO (), + -- Element(s) methods + getActiveElement :: Session -> IO ElementId, + findElement :: Session -> Selector -> IO ElementId, + findElements :: Session -> Selector -> IO [ElementId], + -- Element instance methods + findElementFromElement :: Session -> ElementId -> Selector -> IO ElementId, + findElementsFromElement :: Session -> ElementId -> Selector -> IO [ElementId], + isElementSelected :: Session -> ElementId -> IO Bool, + getElementAttribute :: Session -> ElementId -> Text -> IO Text, + getElementProperty :: Session -> ElementId -> Text -> IO Value, + getElementCssValue :: Session -> ElementId -> Text -> IO Text, + getElementShadowRoot :: Session -> ElementId -> IO ShadowRootElementId, + getElementText :: Session -> ElementId -> IO Text, + getElementTagName :: Session -> ElementId -> IO Text, + getElementRect :: Session -> ElementId -> IO WindowRect, + isElementEnabled :: Session -> ElementId -> IO Bool, + getElementComputedRole :: Session -> ElementId -> IO Text, + getElementComputedLabel :: Session -> ElementId -> IO Text, + elementClick :: Session -> ElementId -> IO (), + elementClear :: Session -> ElementId -> IO (), + elementSendKeys :: Session -> ElementId -> Text -> IO (), + takeElementScreenshot :: Session -> ElementId -> IO Text, + -- Shadow DOM methods + findElementFromShadowRoot :: Session -> ShadowRootElementId -> Selector -> IO ElementId, + findElementsFromShadowRoot :: Session -> ShadowRootElementId -> Selector -> IO [ElementId], + -- Fallback methods + runCommand :: forall a. (FromJSON a) => Command a -> IO a, + runCommand' ::forall a. (FromJSON a) => Command a -> IO Value + } + +mkActions :: HttpRunner -> HttpActions +mkActions MkHttpRunner {run, fullResponse} = + MkHttpActions + { -- Root methods + status = run API.status, + newSession = run . API.newSession, + + -- Session methods + deleteSession = run . API.deleteSession, + getTimeouts = run . API.getTimeouts, + setTimeouts = sessRun_ API.setTimeouts, + navigateTo = sessRun_ API.navigateTo, + getCurrentUrl = run . API.getCurrentUrl, + back = run . API.back, + forward = run . API.forward, + refresh = run . API.refresh, + getTitle = run . API.getTitle, + getWindowHandle = run . API.getWindowHandle, + newWindow = run . API.newWindow, + closeWindow = run . API.closeWindow, + switchToWindow = sessRun_ API.switchToWindow, + switchToFrame = sessRun_ API.switchToFrame, + getPageSource = run . API.getPageSource, + executeScript = sessRun API.executeScript, + executeScriptAsync = sessRun API.executeScriptAsync, + addCookie = sessRun_ API.addCookie, + getAllCookies = run . API.getAllCookies, + getNamedCookie = sessRun API.getNamedCookie, + deleteCookie = sessRun_ API.deleteCookie, + deleteAllCookies = run . API.deleteAllCookies, + performActions = sessRun_ API.performActions, + releaseActions = run . API.releaseActions, + dismissAlert = run . API.dismissAlert, + acceptAlert = run . API.acceptAlert, + getAlertText = run . API.getAlertText, + sendAlertText = sessRun_ API.sendAlertText, + takeScreenshot = run . API.takeScreenshot, + printPage = run . API.printPage, + -- Window methods + getWindowHandles = run . API.getWindowHandles, + getWindowRect = run . API.getWindowRect, + setWindowRect = sessRun API.setWindowRect, + maximizeWindow = run . API.maximizeWindow, + minimizeWindow = run . API.minimizeWindow, + fullScreenWindow = run . API.fullScreenWindow, + -- Frame methods + switchToParentFrame = run . API.switchToParentFrame, + -- Element(s) methods + getActiveElement = run . API.getActiveElement, + findElement = sessRun API.findElement, + findElements = sessRun API.findElements, + -- Element instance methods + findElementFromElement = sessRun2 API.findElementFromElement, + findElementsFromElement = sessRun2 API.findElementsFromElement, + isElementSelected = sessRun API.isElementSelected, + getElementAttribute = sessRun2 API.getElementAttribute, + getElementProperty = sessRun2 API.getElementProperty, + getElementCssValue = sessRun2 API.getElementCssValue, + getElementShadowRoot = sessRun API.getElementShadowRoot, + getElementText = sessRun API.getElementText, + getElementTagName = sessRun API.getElementTagName, + getElementRect = sessRun API.getElementRect, + isElementEnabled = sessRun API.isElementEnabled, + getElementComputedRole = sessRun API.getElementComputedRole, + getElementComputedLabel = sessRun API.getElementComputedLabel, + elementClick = sessRun_ API.elementClick, + elementClear = sessRun_ API.elementClear, + elementSendKeys = sessRun2_ API.elementSendKeys, + takeElementScreenshot = sessRun API.takeElementScreenshot, + -- Shadow DOM methods + findElementFromShadowRoot = sessRun2 API.findElementFromShadowRoot, + findElementsFromShadowRoot = sessRun2 API.findElementsFromShadowRoot, + -- + runCommand = run, + runCommand' = fullResponse + } + where + sessRun :: forall a r. (FromJSON r) => (Session -> a -> Command r) -> Session -> a -> IO r + sessRun f s = run . f s + + sessRun_ :: forall a. (Session -> a -> Command ()) -> Session -> a -> IO () + sessRun_ f s = run . f s + + sessRun2 :: forall a b r. (FromJSON r) => (Session -> a -> b -> Command r) -> Session -> a -> b -> IO r + sessRun2 f s a = run . f s a + + sessRun2_ :: forall a b. (Session -> a -> b -> Command ()) -> Session -> a -> b -> IO () + sessRun2_ f s a = run . f s a diff --git a/test/HTTP/DemoUtils.hs b/test/HTTP/DemoUtils.hs new file mode 100644 --- /dev/null +++ b/test/HTTP/DemoUtils.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE CPP #-} + +module HTTP.DemoUtils where + +import Config (Config (..)) +import ConfigLoader (loadConfig) +import Const (milliseconds) +import Control.Exception (bracket) +import Data.Text (Text) +import HTTP.Actions (HttpActions (..)) +import IOUtils (DemoActions (..), Logger, logNothingLogger, mkDemoActions) +import Logger (withChannelFileLogger) +import Network.HTTP.Req (http) +import RuntimeConst (httpFullCapabilities) +import WebDriverPreCore.HTTP.Protocol (FullCapabilities, Session, SessionResponse (..)) + +#ifdef LEGACY_TEST +import HTTP.HttpActionsDeprecated qualified as Legacy +import HTTP.HttpRunnerDeprecated qualified as Legacy +#else +import HTTP.Runner (mkRunner) +import HTTP.Actions (mkActions) +#endif + +data HttpDemo + = Demo + { name :: Text, + action :: DemoActions -> HttpActions -> IO () + } + | SessionDemo + { name :: Text, + sessionAction :: + Session -> + DemoActions -> + HttpActions -> + IO () + } + +demo :: Text -> (DemoActions -> HttpActions -> IO ()) -> HttpDemo +demo = Demo + +sessionDemo :: Text -> (Session -> DemoActions -> HttpActions -> IO ()) -> HttpDemo +sessionDemo = SessionDemo + +runDemo :: HttpDemo -> IO () +runDemo demo' = do + cfg <- loadConfig + runDemoWithConfig cfg demo' + +runDemoWithConfig :: Config -> HttpDemo -> IO () +runDemoWithConfig cfg demo' = do + let run lgr = runDemo' cfg lgr demo' + if cfg.logging + then + withChannelFileLogger run + else + run logNothingLogger + +runDemo' :: Config -> Logger -> HttpDemo -> IO () +runDemo' cfg@MkConfig {httpUrl, httpPort, pauseMS} lgr demo' = do + demoActions.logTxt demo'.name + case demo' of + Demo _ action -> action demoActions httpActions + SessionDemo _ action -> withSession capabilities httpActions $ \ses -> + action ses.sessionId demoActions httpActions + where + capabilities = httpFullCapabilities cfg + demoActions = mkDemoActions lgr $ fromIntegral pauseMS * milliseconds +#ifdef LEGACY_TEST + runner = Legacy.mkRunner (http httpUrl) (fromIntegral httpPort) demoActions + httpActions = Legacy.mkDeprecatedActions runner +#else + runner = mkRunner (http httpUrl) (fromIntegral httpPort) demoActions + httpActions = mkActions runner +#endif + +withSession :: FullCapabilities -> HttpActions -> (SessionResponse -> IO ()) -> IO () +withSession capabilities http' action = do + bracket + (http'.newSession capabilities) + (http'.deleteSession . (.sessionId)) + action diff --git a/test/HTTP/ErrorDemo.hs b/test/HTTP/ErrorDemo.hs new file mode 100644 --- /dev/null +++ b/test/HTTP/ErrorDemo.hs @@ -0,0 +1,63 @@ +module HTTP.ErrorDemo where + +import GHC.Utils.Misc (HasCallStack) +import HTTP.DemoUtils (HttpDemo, runDemo, sessionDemo) +import HTTP.Actions (HttpActions (..)) +import IOUtils (DemoActions (..), (===)) +import Test.Tasty.HUnit (assertFailure) +import TestData (inputsUrl) +import UnliftIO (try) +import WebDriverPreCore.HTTP.Protocol + ( ErrorType (..), + Selector (..), + Session, + Timeouts (..), + WebDriverException (..), + ) +import Prelude hiding (log) + +-- stop warning for unused demo (its used in eval) +_rundemo :: HttpDemo -> IO () +_rundemo = runDemo + +-- >>> runDemo errorDemo +errorDemo :: HttpDemo +errorDemo = + sessionDemo "Http Error Demo" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + -- Set short timeouts + setTimeouts sesId $ + MkTimeouts + { pageLoad = Just 1_000, + script = Just 0, + implicit = Just 0 + } + + url <- inputsUrl + navigateTo sesId url + + -- Try to find non-existent element and expect NoSuchElement error + exc <- + expectProtocolException NoSuchElement + . findElement sesId + $ CSS "#id-that-does-not-exist" + + logShow "Caught expected exception" exc + +expectProtocolException :: + (HasCallStack) => + ErrorType -> + IO a -> + IO WebDriverException +expectProtocolException expectedError action = + try action + >>= \case + Left exc@(ProtocolException {error = err}) -> + expectedError === err + >> pure exc + Left exc -> do + assertFailure $ "Expected ProtocolException but got: " <> show exc + Right _ -> do + assertFailure $ "Expected ProtocolException with error " <> show expectedError <> " but action succeeded" diff --git a/test/HTTP/FallbackDemo.hs b/test/HTTP/FallbackDemo.hs new file mode 100644 --- /dev/null +++ b/test/HTTP/FallbackDemo.hs @@ -0,0 +1,159 @@ +module HTTP.FallbackDemo where + +import Data.Aeson as A (Value (..)) +import Data.Aeson qualified as A +import Data.Aeson.KeyMap qualified as A +import Data.Function ((&)) +import Data.Text (Text) +import HTTP.DemoUtils (HttpDemo, runDemo, sessionDemo) +import HTTP.Actions (HttpActions (..)) +import IOUtils (DemoActions (..)) +import TestData (checkboxesUrl, textAreaUrl) +import WebDriverPreCore.HTTP.API qualified as A +import WebDriverPreCore.HTTP.Protocol + ( Command (..), + ElementId (..), + Session (..), + Timeouts (..), + coerceCommand, + extendPost, + extendPostLoosen, + loosenCommand, + voidCommand, + ) +import Utils (UrlPath (..)) +import Prelude hiding (log) + +-- >>> runDemo demoFallbackActions +demoFallbackActions :: HttpDemo +demoFallbackActions = + sessionDemo "fallback actions demo - manually construct commands" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {runCommand} = do + -- Navigate to checkboxes page using runCommand and log the response + url <- checkboxesUrl + let navigateCmd = + Post + { description = "Navigate To (using fallback)", + path = sessionUri1 sesId "url", + body = A.fromList ["url" A..= url] + } + + logTxt "Navigate using runCommand" + -- as we haven't put a type signature on navigateCmd, we need to use @() to indicate we expect no return value + navigateResult <- runCommand @() navigateCmd + logShow "Navigate response" navigateResult + pause + + -- Find the checkbox using Value command with runCommand + let findElementCmd = + Post + { description = "Find Element (using fallback Value)", + path = sessionUri1 sesId "element", + body = A.fromList ["using" A..= ("css selector" :: String), "value" A..= ("#checkbox1" :: String)] + } + + logTxt "Find checkbox element using Value command and runCommand" + -- as we haven't put a type signature on findElementCmd, we need to use @Value to indicate we expect a Value return type + val <- runCommand @Value findElementCmd + logShow "Element search Result" val + logShow "Full response" val + pause + + -- Extract element ID from the Value result + let checkboxId = case val of + A.Object obj -> + A.lookup "element-6066-11e4-a52e-4f735466cecf" obj + & maybe + (error "Failed to extract element ID from response") + ( \case + A.String eid -> MkElement eid + _ -> error "Expected string for element ID" + ) + _ -> error "Expected object in response" + + logShow "Extracted element ID" checkboxId + pause + +newtype MyURL = MkMyURL {getMyURL :: Text} + deriving (Show, Eq) + deriving newtype (A.FromJSON) + +-- >>> runDemo demoFallbackCoercions +demoFallbackCoercions :: HttpDemo +demoFallbackCoercions = + sessionDemo "fallback coerce commands" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {runCommand} = do + -- Navigate to another page using typed Navigate command and getResponse + logTxt "Navigate to another page using typed command and getResponse (navigateTo returns Command ())" + url2 <- textAreaUrl + runCommand $ A.navigateTo sesId url2 + pause + + logTxt "Return a different type with compatible JSON (runCommand will return MyURL )" + myUrl <- runCommand . coerceCommand @_ @MyURL $ A.getCurrentUrl sesId + logShow "Current url - coerced" myUrl + pause + + logTxt "Return Value rather than url" + url' <- runCommand . loosenCommand $ A.getCurrentUrl sesId + logShow "Current url - as Value" url' + pause + + logTxt "Return void rather than url" + urlVoid <- runCommand . voidCommand $ A.getCurrentUrl sesId + logShow "Current url - voided" urlVoid + pause + +-- >>> runDemo demoExtendPost +demoExtendPost :: HttpDemo +demoExtendPost = + sessionDemo "fallback extend Post commands demo" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {runCommand'} = do + cbxsUrl <- checkboxesUrl + runCommand' $ A.navigateTo sesId cbxsUrl + + -- Step 1: extendPost with a Post command + let timeoutsCmd = A.setTimeouts sesId (MkTimeouts (Just 1000) Nothing Nothing) + extended1 = A.fromList ["script" A..= (2000 :: Int)] + extendedCmd1 = extendPost timeoutsCmd extended1 + logTxt "Extended Post Command" + logShowM "Extended Post Result" $ runCommand' extendedCmd1 + + -- Step 2: extendPostLoosen with a Post command + let extended2 = A.fromList ["pageLoad" A..= (3000 :: Int)] + extendedCmd2 = extendPostLoosen timeoutsCmd extended2 + logTxt "Extended Post (loosened) Command" + logShowM "Extended Post (loosened) Result" $ runCommand' extendedCmd2 + + -- Step 3: extendPost with a PostEmpty command + let backCmd = A.back sesId + extended3 = A.fromList ["ignored" A..= String "test"] + extendedCmd3 = extendPost backCmd extended3 + logTxt "Extended PostEmpty Command" + logShowM "Extended PostEmpty Result" $ runCommand' extendedCmd3 + + -- Step 4: extendPostLoosen with a PostEmpty command + let refreshCmd = A.refresh sesId + extended4 = A.fromList ["alsoIgnored" A..= String "demo"] + extendedCmd4 = extendPostLoosen refreshCmd extended4 + logTxt "Extended PostEmpty (loosened) Command" + logShowM "Extended PostEmpty (loosened) Result" $ runCommand' extendedCmd4 + + pause + +-- Helper functions (copied from API.hs since they're not exported) + +sessionUri1 :: Session -> Text -> UrlPath +sessionUri1 s sp = MkUrlPath ["session", s.id, sp] + +elementUri1 :: Session -> ElementId -> Text -> UrlPath +elementUri1 s er ep = MkUrlPath ["session", s.id, "element", er.id, ep] + +_stopDemoUnusedWarning :: HttpDemo -> IO () +_stopDemoUnusedWarning = runDemo diff --git a/test/HTTP/HttpActionsDeprecated.hs b/test/HTTP/HttpActionsDeprecated.hs new file mode 100644 --- /dev/null +++ b/test/HTTP/HttpActionsDeprecated.hs @@ -0,0 +1,94 @@ +module HTTP.HttpActionsDeprecated + ( + mkDeprecatedActions, + ) +where + +import HTTP.HttpRunnerDeprecated (HttpRunnerDeprecated (..)) + +import WebDriverPreCore.HTTP.Protocol qualified as P +import WebDriverPreCore.HTTP.SpecDefinition qualified as W +import HTTP.Actions (HttpActions (..)) +import WebDriverPreCore.Http qualified as Legacy + +mkDeprecatedActions :: HttpRunnerDeprecated -> HttpActions +mkDeprecatedActions MkHttpRunnerDeprecated {run} = + MkHttpActions + { -- Root methods + status = run W.status, + newSession = run . W.newSession, + -- Session methods + deleteSession = run . W.deleteSession, + getTimeouts = run . W.getTimeouts, + setTimeouts = sessRun W.setTimeouts, + navigateTo = sessRun W.navigateTo, + getCurrentUrl = run . W.getCurrentUrl, + back = run . W.back, + forward = run . W.forward, + refresh = run . W.refresh, + getTitle = run . W.getTitle, + getWindowHandle = run . W.getWindowHandle, + newWindow = run . W.newWindow, + closeWindow = run . W.closeWindow, + switchToWindow = sessRun W.switchToWindow, + switchToFrame = sessRun W.switchToFrame, + getPageSource = run . W.getPageSource, + executeScript = sessRun W.executeScript, + executeScriptAsync = sessRun W.executeScriptAsync, + addCookie = sessRun W.addCookie, + getAllCookies = run . W.getAllCookies, + getNamedCookie = sessRun W.getNamedCookie, + deleteCookie = sessRun W.deleteCookie, + deleteAllCookies = run . W.deleteAllCookies, + performActions = sessRun W.performActions, + releaseActions = run . W.releaseActions, + dismissAlert = run . W.dismissAlert, + acceptAlert = run . W.acceptAlert, + getAlertText = run . W.getAlertText, + sendAlertText = sessRun W.sendAlertText, + takeScreenshot = run . W.takeScreenshot, + printPage = run . W.printPage, + -- Window methods + getWindowHandles = run . W.getWindowHandles, + getWindowRect = run . W.getWindowRect, + setWindowRect = sessRun W.setWindowRect, + maximizeWindow = run . W.maximizeWindow, + minimizeWindow = run . W.minimizeWindow, + fullScreenWindow = run . W.fullscreenWindow, + -- Frame methods + switchToParentFrame = run . W.switchToParentFrame, + -- Element(s) methods + getActiveElement = run . W.getActiveElement, + findElement = sessRun W.findElement, + findElements = sessRun W.findElements, + -- Element instance methods + findElementFromElement = sessRun2 W.findElementFromElement, + findElementsFromElement = sessRun2 W.findElementsFromElement, + isElementSelected = sessRun W.isElementSelected, + getElementAttribute = sessRun2 W.getElementAttribute, + getElementProperty = sessRun2 W.getElementProperty, + getElementCssValue = sessRun2 W.getElementCssValue, + getElementShadowRoot = sessRun W.getElementShadowRoot, + getElementText = sessRun W.getElementText, + getElementTagName = sessRun W.getElementTagName, + getElementRect = sessRun W.getElementRect, + isElementEnabled = sessRun W.isElementEnabled, + getElementComputedRole = sessRun W.getElementComputedRole, + getElementComputedLabel = sessRun W.getElementComputedLabel, + elementClick = sessRun W.elementClick, + elementClear = sessRun W.elementClear, + elementSendKeys = sessRun2 W.elementSendKeys, + takeElementScreenshot = sessRun W.takeElementScreenshot, + -- Shadow DOM methods + findElementFromShadowRoot = sessRun2 W.findElementFromShadowRoot, + findElementsFromShadowRoot = sessRun2 W.findElementsFromShadowRoot, + -- stubs for new methods that will not be implemented withthsi API + runCommand = \_ -> error "runCommand not implemented in legacy actions", + runCommand' = \_ -> error "runCommand not implemented in legacy actions" + } + where + sessRun :: forall a r. (Show r) => (P.Session -> a -> Legacy.HttpSpec r) -> P.Session -> a -> IO r + sessRun f s = run . f s + + sessRun2 :: forall a b r. (Show r) => (P.Session -> a -> b -> Legacy.HttpSpec r) -> P.Session -> a -> b -> IO r + sessRun2 f s a = run . f s a diff --git a/test/HTTP/HttpClient.hs b/test/HTTP/HttpClient.hs new file mode 100644 --- /dev/null +++ b/test/HTTP/HttpClient.hs @@ -0,0 +1,108 @@ +module HTTP.HttpClient + ( callWebDriver, + mkRequest, + -- share with deprecated runner + fullCommandPath, + responseStatusText, + callWebDriver' + ) +where + +import Const (ReqRequestParams (..)) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (Value, object) +import Data.Foldable qualified as F +import Data.Text as T (Text) +import Data.Text.Encoding (decodeUtf8Lenient) +import IOUtils (DemoActions (..)) +import Network.HTTP.Req + ( DELETE (DELETE), + GET (GET), + HttpConfig (httpConfigCheckResponse), + JsonResponse, + NoReqBody (NoReqBody), + POST (POST), + Req, + ReqBodyJson (ReqBodyJson), + Scheme (..), + Url, + defaultHttpConfig, + jsonResponse, + req, + responseBody, + responseStatusCode, + responseStatusMessage, + runReq, + (/:), + ) +import Network.HTTP.Req qualified as R +import WebDriverPreCore.HTTP.Protocol (Command (..)) +import Utils (UrlPath (..)) +import Prelude hiding (log) +import WebDriverPreCore.HTTP.HttpResponse (HttpResponse (..)) + + +-- ############# Http Interaction ############# + +mkRequest :: forall r. Url 'Http -> Int -> Command r -> ReqRequestParams +mkRequest driverUrl port cmd = + case cmd of + Get {} -> MkRequestParams url GET NoReqBody port + Post {body} -> MkRequestParams url POST (ReqBodyJson body) port + PostEmpty {} -> MkRequestParams url POST (ReqBodyJson $ object []) port + Delete {} -> MkRequestParams url DELETE NoReqBody port + where + url = fullCommandPath driverUrl cmd.path.segments + +fullCommandPath :: Url 'Http -> [Text] -> Url 'Http +fullCommandPath basePath = F.foldl' (/:) basePath + +-- call webdriver returning the body of the response as a JSON Value +callWebDriver' :: DemoActions -> ReqRequestParams -> IO Value +callWebDriver' MkDemoActions {logShow = logShow', logJSON = logJSON'} MkRequestParams {url, method, body, port = prt} = + runReq defaultHttpConfig {httpConfigCheckResponse = \_ _ _ -> Nothing} $ do + logShow "URL" url + r <- req method url body jsonResponse $ R.port prt + + let body' = responseBody r :: Value + + logShow "Status Code" $ responseStatusCode r + logShow "Status Message" $ responseStatusText r + logJSON "Response Body" body' + + pure body' + where + logShow :: (Show a) => Text -> a -> Req () + logShow msg = liftIO . logShow' msg + logJSON msg = liftIO . logJSON' msg + +-- call webdriver returning the full HttpResponse (kept for now to support deprecated runner) +callWebDriver :: DemoActions -> ReqRequestParams -> IO HttpResponse +callWebDriver MkDemoActions {logShow = logShow', logJSON = logJSON'} MkRequestParams {url, method, body, port = prt} = + runReq defaultHttpConfig {httpConfigCheckResponse = \_ _ _ -> Nothing} $ do + logShow "URL" url + r <- req method url body jsonResponse $ R.port prt + + let body' = responseBody r :: Value + fr = + MkHttpResponse + { statusCode = responseStatusCode r, + statusMessage = responseStatusText r, + body = body' + } + + logShow "Status Code" fr.statusCode + logShow "Status Message" fr.statusMessage + logJSON "Response Body" fr.body + logShow "Framework Response Object" fr + + pure fr + where + logShow :: (Show a) => Text -> a -> Req () + logShow msg = liftIO . logShow' msg + logJSON msg = liftIO . logJSON' msg + +-- ############# Utils ############# + +responseStatusText :: JsonResponse Value -> Text +responseStatusText = decodeUtf8Lenient . responseStatusMessage diff --git a/test/HTTP/HttpDemo.hs b/test/HTTP/HttpDemo.hs new file mode 100644 --- /dev/null +++ b/test/HTTP/HttpDemo.hs @@ -0,0 +1,940 @@ +module HTTP.HttpDemo where + +-- minFirefoxSession, + +import ConfigLoader (loadConfig) +import Control.Exception (bracket) +import Control.Monad (forM_) +import Data.Aeson (Value (..)) +import Data.Set qualified as Set +import Data.Text (isInfixOf) +import Data.Time.Clock.POSIX (getPOSIXTime) +import GHC.IO (catchAny) +import HTTP.DemoUtils (HttpDemo, demo, runDemo, sessionDemo) +import HTTP.Actions (HttpActions (..)) +import IOUtils + ( DemoActions (..), + (===), + ) +import RuntimeConst (httpFullCapabilities) +import Test.Tasty.HUnit (Assertion, assertBool) +import TestData + ( checkboxesUrl, + indexUrl, + infiniteScrollUrl, + inputsUrl, + loginUrl, + nestedFramesUrl, + promptUrl, + shadowDomUrl, + ) +import TestServerAPI (testServerHomeUrl, withTestServer) +import Utils (txt) +import WebDriverPreCore.HTTP.Protocol + ( Action (..), + Actions (..), + Cookie (..), + FrameReference (..), + KeyAction (..), + Pointer (..), + PointerAction (..), + PointerOrigin (..), + SameSite (..), + Script (..), + Selector (..), + Session (..), + SessionResponse (..), + Status (..), + Timeouts (..), + URL (..), + WheelAction (..), + WindowHandleSpec (..), + WindowRect (..), + ) +import Prelude hiding (log) + +_stopDemoUnusedWarning :: HttpDemo -> IO () +_stopDemoUnusedWarning = runDemo + +-- #################### The Tests ###################### + +-- >>> runDemo newSessionDemo +newSessionDemo :: HttpDemo +newSessionDemo = + demo "new Session" action + where + action :: DemoActions -> HttpActions -> IO () + action MkDemoActions {..} MkHttpActions {..} = do + cfg <- loadConfig + let caps = httpFullCapabilities cfg + logShow "capabilities" caps + bracket + (newSession caps) + (\(MkSessionResponse {sessionId = sid}) -> deleteSession sid) + (logShow "new session response:\n") + +-- >>> runDemo driverStatusDemo +driverStatusDemo :: HttpDemo +driverStatusDemo = + sessionDemo "driver status" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + log "new session:" $ txt sesId + s <- status + {- Per W3C WebDriver spec section 8.4, status.ready must be false when active HTTP sessions exist. + Geckodriver (Firefox) correctly implements this - returns ready: false when serving a session. + Chromedriver diverges from spec - returns ready: true even with active sessions because it + supports multiple concurrent sessions. This test will fail on Chrome. -} + False === s.ready + logShowM "driver status" status + +-- >>> runDemo demoSendKeysClear +demoSendKeysClear :: HttpDemo +demoSendKeysClear = + sessionDemo "send keys clear" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + url <- loginUrl + navigateTo sesId $ url + usr <- findElement sesId $ CSS "#username" + + logTxt "fill in user name" + elementSendKeys sesId usr "user name" + pause + + logTxt "clear user name" + elementClear sesId usr + pause + +-- >>> runDemo demoForwardBackRefresh +demoForwardBackRefresh :: HttpDemo +demoForwardBackRefresh = + sessionDemo "forward back refresh" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + url <- indexUrl + logTxt "navigating to index page" + navigateTo sesId $ url + logShowM "current url" $ getCurrentUrl sesId + logM "title" $ getTitle sesId + + pause + + link <- findElement sesId $ CSS "a[href='checkboxes.html']" + logTxt "navigating to check boxes page" + elementClick sesId link + + pause + logShowM "current url" $ getCurrentUrl sesId + logM "title" $ getTitle sesId + logTxt "navigating back" + back sesId + pause + + logShowM "current url" $ getCurrentUrl sesId + logM "title" $ getTitle sesId + logTxt "navigating forward" + + forward sesId + pause + + logShowM "current url" $ getCurrentUrl sesId + logM "title" $ getTitle sesId + logTxt "refreshing" + refresh sesId + pause + + logShowM "current url" $ getCurrentUrl sesId + logM "title" $ getTitle sesId + +-- >>> runDemo documentationDemo +documentationDemo :: HttpDemo +documentationDemo = + sessionDemo "forward back refresh - external doc demo" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + navigateTo sesId $ MkUrl "https://the-internet.herokuapp.com/" + + link <- findElement sesId $ CSS "#content > ul:nth-child(4) > li:nth-child(6) > a:nth-child(1)" + elementClick sesId link + + logShowM "current url" $ getCurrentUrl sesId + logM "title" $ getTitle sesId + + logTxt "navigating back" + back sesId + + logShowM "current url" $ getCurrentUrl sesId + logM "title" $ getTitle sesId + + logTxt "navigating forward" + forward sesId + + logShowM "current url" $ getCurrentUrl sesId + logM "title" $ getTitle sesId + + logTxt "refreshing" + refresh sesId + pause + +-- >>> runDemo demoWindowHandles +demoWindowHandles :: HttpDemo +demoWindowHandles = + sessionDemo "window handles" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + url <- indexUrl + navigateTo sesId $ url + + logShowM "window Handle" $ getWindowHandle sesId + + w <- newWindow sesId + log "new window Handle" $ txt w + pause + + switchToWindow sesId w.handle + + logShowM "all windows handles" $ getWindowHandles sesId + + closeWindow sesId + log "windows closed" $ txt sesId + + logShowM "all windows handles" $ getWindowHandles sesId + +-- >>> runDemo demoWindowSizes +demoWindowSizes :: HttpDemo +demoWindowSizes = + sessionDemo "window sizes" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + maximizeWindow sesId + url <- indexUrl + navigateTo sesId $ url + pause + + {- ChromeDriver limitation: Transitioning from fullscreen => maximized fails intermittently with + "failed to change window state to 'normal', current state is 'fullscreen'" on some systems. + This is a known ChromeDriver bug on Linux/Wayland/X11 where the window manager state doesn't + sync properly with ChromeDriver's internal state machine. Even with delays and state sync + calls (getWindowRect), the transition remains unreliable. + + Workaround: minimizeWindow => maximizeWindow => fullscreen -} + + logShowM "minimizeWindow" $ minimizeWindow sesId + pause + + logShowM "maximizeWindow" $ maximizeWindow sesId + pause + + logShowM "fullscreen" $ fullScreenWindow sesId + pause + +-- >>> runDemo demoElementPageProps +demoElementPageProps :: HttpDemo +demoElementPageProps = + sessionDemo "element page props" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + url <- indexUrl + navigateTo sesId $ url + logShowM "current url" $ getCurrentUrl sesId + logM "title" $ getTitle sesId + + link <- findElement sesId $ CSS "a[href='checkboxes.html']" + logM "check box link text" $ getElementText sesId link + elementClick sesId link + + cbs <- findElements sesId $ CSS "input[type='checkbox']" + forM_ cbs $ \cb -> do + logShowM "checkBox checked property" $ getElementProperty sesId cb "checked" + logShowM "getElementAttribute type" $ getElementAttribute sesId cb "type" + logShowM "getElementCssValue display" $ getElementCssValue sesId cb "display" + logShowM "getElementTagName" $ getElementTagName sesId cb + logShowM "getElementRect" $ getElementRect sesId cb + logShowM "isElementEnabled" $ isElementEnabled sesId cb + logShowM "getElementComputedRole" $ getElementComputedRole sesId cb + logShowM "getElementComputedLabel" $ getElementComputedLabel sesId cb + + header <- findElement sesId $ CSS "h3" + logShowM "header computed role" $ getElementComputedRole sesId header + logShowM "header computed label" $ getElementComputedLabel sesId header + + divs <- findElements sesId $ CSS "div" + forM_ divs $ \d -> + logShowM "div overflow value" $ getElementCssValue sesId d "overflow" + +-- >>> runDemo demoTimeouts +demoTimeouts :: HttpDemo +demoTimeouts = + sessionDemo "timeouts" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + log "new session" $ txt sesId + logShowM "timeouts" $ getTimeouts sesId + let timeouts = + MkTimeouts + { pageLoad = Just $ 50_000, + script = Just $ 11_000, + implicit = Just $ 12_000 + } + setTimeouts sesId timeouts + timeouts' <- getTimeouts sesId + + logShow "updated timeouts" timeouts' + timeouts === timeouts' + +-- >>> runDemo demoWindowRecs +demoWindowRecs :: HttpDemo +demoWindowRecs = + sessionDemo "window recs" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + {- Note: + There is a known issue with geckodriver and Wayland that prevents setting withe x y window position + see the links below for more details: + - https://github.com/mozilla/geckodriver/issues/2224 + - https://github.com/SeleniumHQ/selenium/issues/15584 + - https://bugzilla.mozilla.org/show_bug.cgi?id=1959040 + This test passes because x and y are set to 0,0. + -} + let wr = + Rect + { x = 0, + y = 0, + width = 600, + height = 400 + } + logShowM "set window rect" $ setWindowRect sesId wr + r <- getWindowRect sesId + logShow "window rect" r + + wr === r + + url <- inputsUrl + navigateTo sesId $ url + div' <- findElement sesId $ CSS "#content" + input <- findElementFromElement sesId div' $ CSS "input" + logShow "input tag" input + + els <- findElementsFromElement sesId div' $ CSS "*" + logShow "elements in div" els + +-- >>> runDemo demoWindowFindElement +demoWindowFindElement :: HttpDemo +demoWindowFindElement = + sessionDemo "window find element" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + url <- inputsUrl + navigateTo sesId $ url + allElms <- findElements sesId $ CSS "*" + + chkHasElms allElms + + logShow "all elements" allElms + div' <- findElement sesId $ CSS "#content" + input <- findElementFromElement sesId div' $ CSS "input" + logShow "input tag" input + + els <- findElementsFromElement sesId div' $ CSS "*" + + chkHasElms els + logShow "elements in div" els + +-- >>> runDemo demoFrames +demoFrames :: HttpDemo +demoFrames = + sessionDemo "frames" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action + sesId + MkDemoActions {logTxt, log, logShow, logShowM} + MkHttpActions + { navigateTo, + switchToFrame, + switchToParentFrame, + getActiveElement, + findElement, + findElements, + getElementText + } = do + let bottomFameExists = not . null <$> findElements sesId (CSS "frame[name='frame-bottom']") + url <- nestedFramesUrl + navigateTo sesId $ url + + logTxt "At top level frame" + hasBottomFrame <- bottomFameExists + + logShow "bottom frame exists" hasBottomFrame + assertBool "bottom frame should exist" hasBottomFrame + + -- switch frames using element id + tf <- findElement sesId $ CSS "frame[name='frame-top']" + logShow "switch to top frame" tf + switchToFrame sesId (FrameElementId tf) + + hasBottomFrame' <- bottomFameExists + logShow "bottom frame exists after switching to top frame" hasBottomFrame' + assertBool "bottom frame should not exist after switching to top frame" $ not hasBottomFrame' + + mf <- findElement sesId $ CSS "frame[name='frame-middle']" + switchToFrame sesId (FrameElementId mf) + + fTitle <- findElement sesId $ CSS "h1" + titleTxt <- getElementText sesId fTitle + log "middle frame title" titleTxt + "Test Page" === titleTxt + + logTxt "switch to top level frame" + switchToFrame sesId TopLevelFrame + logShowM "bottom frame exists" $ bottomFameExists + + -- drill back down to middle frame (repeat the above steps) + tf' <- findElement sesId $ CSS "frame[name='frame-top']" + logShow "switch back to top frame" tf' + switchToFrame sesId (FrameElementId tf') + logShowM "active element" $ getActiveElement sesId + + mf' <- findElement sesId $ CSS "frame[name='frame-middle']" + logShow "drill back down to middle frame" mf' + switchToFrame sesId (FrameElementId mf') + logShowM "active element" $ getActiveElement sesId + + logTxt "switch to parent frame" + switchToParentFrame sesId + logShowM "active element" $ getActiveElement sesId + + logTxt "switch to parent frame again" + switchToParentFrame sesId + logShowM "active element" $ getActiveElement sesId + + hasBottomFrame'' <- bottomFameExists + logShow "bottom frame exists" hasBottomFrame'' + assertBool "bottom frame should exist" hasBottomFrame'' + + logTxt "Switch to frame 1" + switchToFrame sesId $ FrameNumber 1 + + logShowM "active element" $ getActiveElement sesId + +-- >>> runDemo demoShadowDom +demoShadowDom :: HttpDemo +demoShadowDom = + sessionDemo "shadow dom" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + url <- shadowDomUrl + navigateTo sesId $ url + + -- Find the custom element: + myParagraphId <- findElement sesId (CSS "my-paragraph") + logShow "my-paragraph" myParagraphId + + -- Get its shadow root: + shadowRootId <- getElementShadowRoot sesId myParagraphId + logShow "shadowRootId" shadowRootId + + -- From the shadow root, find all elements + allInsideShadow <- findElementsFromShadowRoot sesId shadowRootId $ CSS "*" + logShow "shadow root elements" allInsideShadow + + chkHasElms allInsideShadow + logTxt "got root elements" + + srootElm <- findElementFromShadowRoot sesId shadowRootId $ CSS "*" + logShow "shadow root element" srootElm + + -- Retrieve text from the shadow element: + logShowM "shadow text" $ getElementText sesId srootElm + +-- >>> runDemo demoIsElementSelected +demoIsElementSelected :: HttpDemo +demoIsElementSelected = + sessionDemo "is element selected" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + logShowM "driver status" status + url <- checkboxesUrl + navigateTo sesId $ url + allCbs <- findElements sesId $ CSS "input[type='checkbox']" + forM_ allCbs $ \cb -> do + before <- isElementSelected sesId cb + logShow "checkBox isElementSelected before" before + + elementClick sesId cb + logTxt "clicked" + + after <- isElementSelected sesId cb + logShow "checkBox isElementSelected after click" after + + assertBool "checkBox state should change after click" $ not before == after + logTxt "------------------" + +-- >>> runDemo demoGetPageSourceScreenShot +demoGetPageSourceScreenShot :: HttpDemo +demoGetPageSourceScreenShot = + sessionDemo "get page source screenshot" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + url <- indexUrl + navigateTo sesId $ url + logTxt "!!!!! Page Source !!!!!" + logShowM "page source" $ getPageSource sesId + + logTxt "!!!!! Screenshot!!!!!" + logShowM "take screenshot" $ takeScreenshot sesId + + logTxt "!!!!! Screenshot Element !!!!!" + chkBoxLink <- findElement sesId $ CSS "a[href='checkboxes.html']" + logShowM "take element screenshot" $ takeElementScreenshot sesId chkBoxLink + +-- >>> runDemo demoPrintPage +demoPrintPage :: HttpDemo +demoPrintPage = + sessionDemo "print page" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + url <- indexUrl + navigateTo sesId $ url + -- pdf (encoded string) + logM "print page" $ printPage sesId + +chkHasElms :: (Foldable t) => t a -> Assertion +chkHasElms els = assertBool "elements should be found" $ not (null els) + +-- >>> runDemo demoExecuteScript +demoExecuteScript :: HttpDemo +demoExecuteScript = + sessionDemo "execute script" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + url <- indexUrl + navigateTo sesId $ url + logShowM "executeScript" . executeScript sesId $ + MkScript + { script = "return arguments[0];", + args = [String "Hello from Pyrethrum!", Number 2000] + } + pause + logTxt "executing asynch alert" + executeScriptAsync sesId $ + MkScript + { script = "setTimeout(() => alert('Hello from Pyrethrum!'), 2000); return 5;", + args = [] + } + logTxt "after asynch alert" + pause + +epochSeconds :: IO Int +epochSeconds = round <$> getPOSIXTime + +-- >>> runDemo demoCookies +demoCookies :: HttpDemo +demoCookies = + sessionDemo "cookies" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + withTestServer $ do + navigateTo sesId $ MkUrl testServerHomeUrl + logShowM "cookies before add" $ getAllCookies sesId + + epocSecs <- epochSeconds + let cookieName = "myCookieWithDomain" <> txt epocSecs + let myCookie = + MkCookie + { name = cookieName, + value = "myCookieValue", + path = Just "/", + -- can't set the domain on the test server but have been + -- able to on a remote server + domain = Nothing, + secure = Just True, + sameSite = Just Strict, + httpOnly = Just False, + -- expire in 10 mins (Chrome has a 400 day limit) + expiry = Just $ epocSecs + 600 + } + + logShow "cookie to add (with domain)" myCookie + logShowM "addCookie" $ addCookie sesId myCookie + logShowM "cookies after add" $ getAllCookies sesId + + actualCookie <- getNamedCookie sesId cookieName + logShow "retrieved cookie" actualCookie + -- server fills in domain + myCookie {domain = Just "localhost"} === actualCookie + + logShowM "deleteCookie (myCookie)" $ deleteCookie sesId cookieName + afterRemove <- getAllCookies sesId + logShow "cookies after delete" afterRemove + + assertBool "cookie should be removed" $ not (any ((== cookieName) . (.name)) afterRemove) + assertBool "there still should be cookies in the list" $ not (null afterRemove) + + logShowM "deleteAllCookies" $ deleteAllCookies sesId + afterDeleteAll <- getAllCookies sesId + logShow "cookies after delete all" afterDeleteAll + assertBool "all cookies should be removed" $ null afterDeleteAll + +-- >>> runDemo demoCookiesWithDomain +demoCookiesWithDomain :: HttpDemo +demoCookiesWithDomain = + sessionDemo "cookies with domain" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + navigateTo sesId $ MkUrl "https://example.com" + logShowM "cookies before add" $ getAllCookies sesId + + epocSecs <- epochSeconds + let cookieName = "myExampleCookie" <> txt epocSecs + let myCookie = + MkCookie + { name = cookieName, + value = "exampleValue", + path = Just "/", + domain = Just ".example.com", + secure = Just True, + sameSite = Just Lax, + httpOnly = Just False, + -- expire in 10 mins (Chrome has a 400 day limit) + expiry = Just $ epocSecs + 600 + } + + logShow "cookie to add (with domain set)" myCookie + logShowM "addCookie" $ addCookie sesId myCookie + logShowM "cookies after add" $ getAllCookies sesId + + actualCookie <- getNamedCookie sesId cookieName + logShow "retrieved cookie" actualCookie + myCookie === actualCookie + +-- >>> runDemo demoAlerts +demoAlerts :: HttpDemo +demoAlerts = + sessionDemo "alerts" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + url <- promptUrl + navigateTo sesId $ url + + alert <- findElement sesId $ XPath "//button[@id='alertBtn']" + elementClick sesId alert + + pause + at <- getAlertText sesId + logShow "get alert text" at + "This is an alert!" === at + pause + + logShowM "acceptAlert" $ acceptAlert sesId + pause + + prompt <- findElement sesId $ XPath "//button[@id='promptBtn']" + elementClick sesId prompt + pause + + logShowM "sendAlertText: I am Dave" $ sendAlertText sesId "I am Dave" + pause + + dismissAlert sesId + pause + +-- >>> runDemo demoPointerNoneActions +demoPointerNoneActions :: HttpDemo +demoPointerNoneActions = + sessionDemo "pointer none actions" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + url <- indexUrl + navigateTo sesId $ url + + let pointer = + MkActions + [ Pointer + { id = "mouse1", + subType = Mouse, + pointerId = 0, + pressed = Set.empty, + x = 0, + y = 0, + actions = + [ PausePointer Nothing, + Down + { button = 0, + width = Nothing, + height = Nothing, + pressure = Nothing, + tangentialPressure = Nothing, + tiltX = Nothing, + tiltY = Nothing, + twist = Nothing, + altitudeAngle = Nothing, + azimuthAngle = Nothing + }, + Move + { origin = Viewport, + duration = Just $ 2_000, + x = 150, + y = 150, + width = Just 2, + height = Just 2, + pressure = Just 0.5, + tangentialPressure = Just $ -0.4, + tiltX = Just $ -50, + tiltY = Just $ -50, + twist = Just 5, + altitudeAngle = Just 1.5, + azimuthAngle = Just 6.2 + }, + PausePointer $ Just 1000, + Up + { button = 0, + width = Nothing, + height = Nothing, + pressure = Nothing, + tangentialPressure = Nothing, + tiltX = Nothing, + tiltY = Nothing, + twist = Nothing, + altitudeAngle = Nothing, + azimuthAngle = Nothing + } + -- looks like Cancel not supported yet by gecko driver 02-02-2025 + -- https://searchfox.org/mozilla-central/source/remote/shared/webdriver/Actions.sys.mjs#2340 + -- , Cancel + ] + }, + NoneAction + { id = "NullAction", + noneActions = + [ Nothing, + Just $ 1_000, + Just $ 2_000, + Nothing, + Nothing + ] + } + -- + ] + logTxt "move and None actions" + performActions sesId pointer + +{- + +-- >>> unit_demoPointerNoneActions +unit_demoPointerNoneActions :: IO () +unit_demoPointerNoneActions = + withSession \ses -> do + url <- indexUrl + navigateTo ses url + + let pointer = + MkActions + [ Pointer + { id = "mouse1", + subType = Mouse, + pointerId = 0, + pressed = Set.empty, + x = 0, + y = 0, + actions = + [ PausePointer Nothing, + Down + { button = 0, + width = Nothing, + height = Nothing, + pressure = Nothing, + tangentialPressure = Nothing, + tiltX = Nothing, + tiltY = Nothing, + twist = Nothing, + altitudeAngle = Nothing, + azimuthAngle = Nothing + }, + Move + { origin = Viewport, + duration = Just $ 4 * seconds, + x = 150, + y = 150, + width = Just 2, + height = Just 2, + pressure = Just 0.5, + tangentialPressure = Just $ -0.4, + tiltX = Just $ -50, + tiltY = Just $ -50, + twist = Just 5, + altitudeAngle = Just 1.5, + azimuthAngle = Just 6.2 + }, + PausePointer $ Just 1000, + Up + { button = 0, + width = Nothing, + height = Nothing, + pressure = Nothing, + tangentialPressure = Nothing, + tiltX = Nothing, + tiltY = Nothing, + twist = Nothing, + altitudeAngle = Nothing, + azimuthAngle = Nothing + } + -- looks like Cancel not supported yet by gecko driver 02-02-2025 + -- https://searchfox.org/mozilla-central/source/remote/shared/webdriver/Actions.sys.mjs#2340 + -- , Cancel + ] + }, + NoneAction + { id = "NullAction", + noneActions = + [ Nothing, + Just $ 1 * seconds, + Just $ 4 * seconds, + Nothing, + Nothing + ] + } + -- + ] + + logTxt "move and None actions" + performActions ses pointer + +-} + +-- >>> runDemo demoKeyAndReleaseActions +demoKeyAndReleaseActions :: HttpDemo +demoKeyAndReleaseActions = + sessionDemo "key and release actions" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + url <- loginUrl + navigateTo sesId $ url + usr <- findElement sesId $ CSS "#username" + elementClick sesId usr + + let keys = + MkActions + [ Key + { id = "keyboard1", + keyActions = + [ PauseKey Nothing, + KeyDown "a", + -- a random pause to test the API + PauseKey . Just $ 2_000, + KeyUp "a", + -- select the a + -- send special control key not a raw control character + -- Use \xE009 to represent the Unicode code point U+E009 + KeyDown "\xE009", + KeyDown "a", + -- this will do nothing - just used for correlating frames + -- just testing tha API + PauseKey Nothing + ] + } + ] + + pause + logTxt "key actions" + performActions sesId keys + + pause + releaseActions sesId + pause + +-- >>> runDemo demoWheelActions +demoWheelActions :: HttpDemo +demoWheelActions = + sessionDemo "wheel actions" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + url <- infiniteScrollUrl + navigateTo sesId $ url + + let wheel = + MkActions + [ Wheel + { id = "wheel1", + wheelActions = + [ Scroll + { origin = Viewport, + x = 10, + y = 10, + deltaX = 400, + deltaY = 4000, + duration = Just $ 4_000 + }, + PauseWheel $ Just 1000, + Scroll + { origin = Viewport, + x = 10, + y = 10, + deltaX = -400, + deltaY = -4000, + duration = Just $ 4_000 + } + ] + } + ] + + logTxt "wheel actions" + performActions sesId wheel + pause + +-- >>> runDemo demoError +demoError :: HttpDemo +demoError = + sessionDemo "error" action + where + action :: Session -> DemoActions -> HttpActions -> IO () + action sesId MkDemoActions {..} MkHttpActions {..} = do + -- this tests error mapping of one error type by checking the text of the error + -- thrown by the runner with a deliberately incorrect selector + + -- reset timeouts so we don't wait too long for our failure + setTimeouts sesId $ + MkTimeouts + { pageLoad = Just $ 30_000, + script = Just $ 11_000, + implicit = Just $ 1_000 + } + url <- inputsUrl + navigateTo sesId $ url + + -- if the runner has mapped the error as expected (using parseWebDriverError) we expect it to rethrow the text of the mapped webdriver error + -- including the text: + -- "WebDriverError {error = NoSuchElement, description = "An element could not be located on the page using the given search parameters" + -- other libraries will use the error mapping function in more sophisticated ways + catchAny + ( do + findElement sesId $ CSS "#id-that-does-not-exist-on-this-page" + error "should not get here - no such element" + ) + $ \e -> do + logShow "caught error" e + let errTxt = txt e + expectedText = "An element could not be located on the page using the given search parameters" + assertBool "NoSuchElement error should be mapped" $ expectedText `isInfixOf` errTxt diff --git a/test/HTTP/HttpRunnerDeprecated.hs b/test/HTTP/HttpRunnerDeprecated.hs new file mode 100644 --- /dev/null +++ b/test/HTTP/HttpRunnerDeprecated.hs @@ -0,0 +1,78 @@ +module HTTP.HttpRunnerDeprecated + ( run, + mkRunner, + HttpRunnerDeprecated (..), + ) +where + +import Const (ReqRequestParams (..)) +import Control.Exception (throw) +import Data.Aeson (Result (..), Value, object, withObject, (.:)) +import Data.Aeson.Types (Parser, parseMaybe) +import Data.Function ((&)) +import HTTP.HttpClient (callWebDriver, fullCommandPath) +import IOUtils (DemoActions (..)) +import Network.HTTP.Req (Scheme (Http), Url) +import Network.HTTP.Req as R + ( DELETE (DELETE), + GET (GET), + NoReqBody (NoReqBody), + POST (POST), + ReqBodyJson (ReqBodyJson), + ) +import Utils (UrlPath (..)) +import WebDriverPreCore.Http + ( HttpSpec (..), + ) +import WebDriverPreCore.Http qualified as W +import WebDriverPreCore.HTTP.Protocol (parseWebDriverException, WebDriverException(..)) +import Prelude hiding (log) + +-- ############# Runner ############# + +newtype HttpRunnerDeprecated = MkHttpRunnerDeprecated {run :: forall r. (Show r) => HttpSpec r -> IO r} + +mkRunner :: Url 'Http -> Int -> DemoActions -> HttpRunnerDeprecated +mkRunner driverUrl port da = MkHttpRunnerDeprecated $ run driverUrl port da + +run :: forall r. (Show r) => Url 'Http -> Int -> DemoActions -> HttpSpec r -> IO r +run url port da spec = do + logSpec da spec + callWebDriver da (mkRequest url port spec) >>= parseIO spec + +logSpec :: (Show a) => DemoActions -> HttpSpec a -> IO () +logSpec MkDemoActions {logTxt, logShow, logJSON} spec = do + logTxt "Request" + logShow "HttpSpec" spec + case spec of + Get {} -> pure () + Post {body} -> do + logJSON "body PP" body + PostEmpty {} -> pure () + Delete {} -> pure () + +mkRequest :: forall r. Url 'Http -> Int -> HttpSpec r -> ReqRequestParams +mkRequest driverUrl port spec = case spec of + Get {} -> MkRequestParams url GET NoReqBody port + Post {body} -> MkRequestParams url POST (ReqBodyJson body) port + PostEmpty {} -> MkRequestParams url POST (ReqBodyJson $ object []) port + Delete {} -> MkRequestParams url DELETE NoReqBody port + where + url = fullCommandPath driverUrl spec.path.segments + +parseIO :: HttpSpec a -> W.HttpResponse -> IO a +parseIO spec r = + spec.parser r + & \case + Error _ -> throwFailure r.body + Success a -> pure a + +throwFailure :: Value -> IO a +throwFailure body = + parseMaybe valueParser body + & maybe + (throw $ ResponseParseException "No value property found in WebDriver response" body) + (throw . parseWebDriverException "Could not find body property") + +valueParser :: Value -> Parser Value +valueParser body = body & withObject "body value" (.: "value") diff --git a/test/HTTP/Runner.hs b/test/HTTP/Runner.hs new file mode 100644 --- /dev/null +++ b/test/HTTP/Runner.hs @@ -0,0 +1,80 @@ +module HTTP.Runner + ( mkRunner, + HttpRunner (..) + ) +where + +import Data.Aeson (FromJSON (..), Value, withObject, (.:)) +import Data.Aeson.Types (Parser, Value (..), parseEither, parseMaybe) +import Data.Function ((&)) +import GHC.Exception (throw) +import IOUtils (DemoActions (..)) +import Network.HTTP.Req + ( Scheme (..), + Url, + ) +import UnliftIO (catchAny) +import WebDriverPreCore.HTTP.Protocol ( Command(..), WebDriverException(..), parseWebDriverException) +import Prelude hiding (log) + +import HTTP.HttpClient ( callWebDriver', mkRequest) +import Data.Text (pack) + + +-- ############# Runner ############# + +data HttpRunner = MkHttpRunner + { run :: forall r. (FromJSON r) => Command r -> IO r, + fullResponse :: forall r. (FromJSON r) => Command r -> IO Value + } + +mkRunner :: Url 'Http -> Int -> DemoActions -> HttpRunner +mkRunner driverUrl port da = + MkHttpRunner + { run = run driverUrl port da, + fullResponse = logCall driverUrl port da + } + +logCall :: forall r. Url 'Http -> Int -> DemoActions -> Command r -> IO Value +logCall driverUrl port da cmd = do + logCommand da cmd + callWebDriver' da $ mkRequest driverUrl port cmd + +run :: forall r. (FromJSON r) => Url 'Http -> Int -> DemoActions -> Command r -> IO r +run driverUrl port da@MkDemoActions {logShow} cmd = do + rsp <- logCall driverUrl port da cmd + r <- + catchAny + (parseResultIO rsp) + ( \e -> + logShow "Command Execution Failed" e + >> throw e + ) + pure r + +logCommand :: DemoActions -> Command r -> IO () +logCommand da@MkDemoActions {logShow} cmd = do + logShow (">>>>> Command: " <> cmd.description <> " >>>>>\n") cmd + case cmd of + Get {} -> pure () + Post {body} -> do + da.logJSON "body" $ Object body + PostEmpty {} -> pure () + Delete {} -> pure () + + +parseResultIO :: forall r. (FromJSON r) => Value -> IO r +parseResultIO body = + parseMaybe valueParser body + & maybe + ( throw $ ResponseParseException "No value property found in WebDriver response" body + ) + ( \val -> + parseEither @_ @r parseJSON val & either + (\e -> throw $ parseWebDriverException (pack e) val) + pure + ) + + +valueParser :: Value -> Parser Value +valueParser body = body & withObject "body value" (.: "value") diff --git a/test/IOUtils.hs b/test/IOUtils.hs new file mode 100644 --- /dev/null +++ b/test/IOUtils.hs @@ -0,0 +1,193 @@ +module IOUtils + ( sleep, + encodeFileToBase64, + exceptionTextIncludes, + logNothingLogger, + lwrTxtIncludes, + DemoActions (..), + noOpUtils, + mkDemoActions, + (===), + findWebDriverRoot, + Logger (..), + loopForever, + catchLog, + defToLogNothing + ) +where + +import AesonUtils (prettyJSON) +import Const (Timeout (..), seconds) +import Control.Concurrent (threadDelay) +import Control.Exception (Exception (..), Handler (..), SomeException, catches) +import Control.Monad (void, when) +import Data.Aeson (Value) +import Data.Base64.Types qualified as B64T +import Data.ByteString qualified as BS +import Data.ByteString.Base64 qualified as B64 +import Data.Maybe (fromMaybe) +import Data.Text (Text, isInfixOf, pack, toLower, unpack) +import GHC.Base (coerce) +import System.FilePath (joinPath, splitDirectories, ()) +import Test.Tasty.HUnit as HUnit (Assertion, HasCallStack, (@=?)) +import UnliftIO (AsyncCancelled, async, atomically, race_, readTMVar, throwIO, tryPutTMVar) +import UnliftIO.Async (Async) +import UnliftIO.STM (newEmptyTMVarIO) +import Utils (txt) +import Prelude hiding (log) + +findWebDriverRoot :: FilePath -> Maybe FilePath +findWebDriverRoot path = + if rootDir `elem` dirs + then Just webDriverPath + else Nothing + where + rootDir = "webdriver" + dirs = splitDirectories path + webDriverPath = (joinPath $ takeWhile (/= rootDir) dirs) rootDir + +newtype Logger = MkLogger + { log :: Text -> IO () + } + +logNothingLogger :: Logger +logNothingLogger = MkLogger . const $ pure () + +-- default Nothing to Logger that does nothing +defToLogNothing :: Maybe Logger -> Logger +defToLogNothing = fromMaybe logNothingLogger + +mkDemoActions :: Logger -> Timeout -> DemoActions +mkDemoActions qLog pause = + MkDemoActions + { sleep, + log = log', + logShow = logShow', + logJSON, + logM = \l mt -> mt >>= log' l, + logShowM = \l t -> t >>= logShow' l, + logTxt = logTxt', + pause = sleep pause, + pauseAtLeast = pauseAtLeast pause, + timeLimitLog = timeLimitLog hasEventFired, + timeLimitLogMany = timeLimitLogMany hasEventFired, + timeLimitLog' = \msg tmo -> timeLimitLog' msg hasEventFired tmo + } + where + logTxt' :: Text -> IO () + logTxt' = qLog.log + log' l t = logTxt' $ l <> ": " <> t + logJSON msg val = prettyJSON msg val >>= logTxt' + logShow' :: forall a. (Show a) => Text -> a -> IO () + logShow' l = log' l . txt + hasEventFired :: forall a b. (Show a, Show b) => b -> a -> IO Bool + hasEventFired b a = logShow' ("!!!!! " <> txt b <> " Event Fired !!!!!\n") a >> pure True + +exceptionTextIncludes :: Text -> SomeException -> Bool +exceptionTextIncludes expected = lwrTxtIncludes expected . pack . displayException + +lwrTxtIncludes :: Text -> Text -> Bool +lwrTxtIncludes expected = (toLower expected `isInfixOf`) . toLower + +data DemoActions = MkDemoActions + { sleep :: Timeout -> IO (), + pause :: IO (), + pauseAtLeast :: Timeout -> IO (), + logTxt :: Text -> IO (), + log :: Text -> Text -> IO (), + logShow :: forall a. (Show a) => Text -> a -> IO (), + logJSON :: Text -> Value -> IO (), + logM :: Text -> IO Text -> IO (), + logShowM :: forall a. (Show a) => Text -> IO a -> IO (), + -- timeout functions for testing events TODO: rename + timeLimitLog :: forall a b. (Show a, Show b) => b -> IO (a -> IO (), IO ()), + timeLimitLogMany :: forall a b. (Show a, Show b) => b -> IO (a -> IO (), IO ()), + timeLimitLog' :: forall a b. (Show a, Show b) => Text -> Timeout -> b -> IO (a -> IO (), IO ()) + } + +noOpUtils :: DemoActions +noOpUtils = + MkDemoActions + { sleep = noOp1, + logTxt = noOp1, + log = noOp2, + logShow = noOp2, + logJSON = noOp2, + logM = noOp2, + logShowM = noOp2, + pause = pure (), + -- even for no-op, ensure sleep for passed in ms + pauseAtLeast = sleep, + timeLimitLog = timeLimitLog hasEventFired, + timeLimitLogMany = timeLimitLogMany hasEventFired, + timeLimitLog' = \msg tmo -> timeLimitLog' msg hasEventFired tmo + } + where + noOp1 = const $ pure () + noOp2 = const . const $ pure () + + hasEventFired :: b -> a -> IO Bool + hasEventFired _b _a = pure True + +sleep :: Timeout -> IO () +sleep = threadDelay . coerce + +pauseAtLeast :: Timeout -> Timeout -> IO () +pauseAtLeast defaultSleep = sleep . MkTimeout . max (coerce defaultSleep) . coerce + +timeLimit :: forall a b. (Show b) => Text -> Timeout -> b -> (a -> IO Bool) -> IO (a -> IO (), IO ()) +timeLimit timeoutMsg (MkTimeout mu) eventDesc action = do + triggered <- newEmptyTMVarIO + let waitTriggered = atomically $ readTMVar triggered + waitLimit = threadDelay mu >> (fail . unpack $ "Timeout - " <> timeoutMsg <> ": " <> txt eventDesc <> " after " <> txt (mu `div` 1000) <> " milliseconds") + interceptedAction = \a -> do + result <- action a + when result $ + void $ + atomically $ + tryPutTMVar triggered () + pure () + pure $ (interceptedAction, race_ waitLimit waitTriggered) + +timeLimitLog' :: forall a b. (Show b) => Text -> (b -> a -> IO Bool) -> Timeout -> b -> IO (a -> IO (), IO ()) +timeLimitLog' timeoutMsg prd timeout b = + timeLimit timeoutMsg timeout b (\a -> prd b a >> pure True) + +timeLimitLog :: forall a b. (Show b) => (b -> a -> IO Bool) -> b -> IO (a -> IO (), IO ()) +timeLimitLog prd = timeLimitLog' "Expected event did not fire" prd (10 * seconds) + +timeLimitLogMany :: forall a b. (Show b) => (b -> a -> IO Bool) -> b -> IO (a -> IO (), IO ()) +timeLimitLogMany prd = timeLimitLog' "Expected event(s) did not fire (Many Subscription)" prd (10 * seconds) + +encodeFileToBase64 :: FilePath -> IO Text +encodeFileToBase64 filePath = + B64T.extractBase64 . B64.encodeBase64 <$> BS.readFile filePath + +(===) :: + (Eq a, Show a, HasCallStack) => + -- | The actual value + a -> + -- | The expected value + a -> + Assertion +(===) = (@=?) + +catchLog :: Text -> (Text -> IO ()) -> IO () -> IO () +catchLog name logAction action = + action + `catches` [ Handler $ \(e :: AsyncCancelled) -> do + logAction $ name <> " thread cancelled" + throwIO e, + Handler $ \(e :: SomeException) -> do + logAction $ "Exception thrown in " <> name <> " thread" <> ": " <> (pack $ displayException e) + throwIO e + ] + +-- | like forever but, unlike forever, it fails if an exception is thrown +loopForever :: (Text -> IO ()) -> Text -> IO () -> IO (Async ()) +loopForever logger name action = async $ do + logger $ "Starting " <> name <> " thread" + loop + where + loop = catchLog name logger action >> loop + diff --git a/test/JSONParsingTest.hs b/test/JSONParsingTest.hs --- a/test/JSONParsingTest.hs +++ b/test/JSONParsingTest.hs @@ -1,22 +1,13 @@ module JSONParsingTest where -import Data.Aeson (ToJSON (toJSON), Value (..), decode, encode) +import Data.Aeson (Result (Success), ToJSON (toJSON), Value (..), decode, encode, fromJSON) import Data.Aeson.KeyMap qualified as KM - -import Data.Bool (Bool, (&&), (||)) -import Prelude (Bounded (minBound), Enum, maxBound) -import Data.Foldable (all, null) -import Data.Function (($), (.), id) -import Data.Functor ((<$>)) +import Data.Bits (FiniteBits) import Data.Map.Strict qualified as M -import Data.Maybe (Maybe (..), isNothing) -import Data.String (String) +import Data.Maybe (isNothing) import Data.Text (Text, unpack) import Data.Text qualified as T -import GHC.Base (Applicative (..), Bool (..), Eq (..), Int, const, Functor (..)) -import GHC.Data.Maybe (maybe) -import GHC.Float (Double) -import GHC.IO (FilePath) +import GHC.Plugins (HasCallStack) import Test.Falsify.Generator as G ( Gen, bool, @@ -37,23 +28,35 @@ info, testPropertyWith, ) +import Test.Tasty.HUnit (Assertion, (@=?)) import Text.Show.Pretty (ppShow) -import WebDriverPreCore +import WebDriverPreCore.HTTP.Protocol ( Capabilities (..), DeviceMetrics (..), LogLevel (..), + LogSettings (..), MobileEmulation (..), PerfLoggingPrefs (..), Proxy (..), + SessionResponse (..), SocksProxy (..), Timeouts (..), - VendorSpecific (..), LogSettings (MkLogSettings) + VendorSpecific (..) ) -import WebDriverPreCore.Internal.Utils (jsonToText) -import GHC.Real (Integral, Fractional (..), fromIntegral) -import Data.Bits (FiniteBits) -import GHC.Num (Num(..)) +import AesonUtils (jsonToText) +import Prelude hiding (log) +-- todo: ON SPLIT - moove to extras library + +(===) :: + (Eq a, Show a, HasCallStack) => + -- | The actual value + a -> + -- | The expected value + a -> + Assertion +(===) = (@=?) + genMaybe :: G.Gen a -> G.Gen (Maybe a) genMaybe gen' = G.frequency @@ -77,19 +80,22 @@ genValue :: G.Gen Value genValue = G.frequency - [ (1, pure $ toJSON False), - (1, pure $ toJSON ""), - (1, pure $ toJSON 0), - (1, pure $ toJSON 1), - (1, pure $ toJSON 2), - (1, pure $ toJSON 3), - (1, pure $ toJSON 4), - (1, pure $ toJSON 5), - (1, pure $ toJSON 6), - (1, pure $ toJSON 7), - (1, pure $ toJSON 8), - (1, pure $ toJSON 9) + [ (1, jv False), + (1, jv ""), + (1, jv 0), + (1, jv 1), + (1, jv 2), + (1, jv 3), + (1, jv 4), + (1, jv 5), + (1, jv 6), + (1, jv 7), + (1, jv 8), + (1, jv 9) ] + where + jv :: ToJSON a => a -> G.Gen Value + jv = pure . toJSON genDeviseMetrics :: Gen DeviceMetrics genDeviseMetrics = do @@ -226,12 +232,10 @@ Manual <$> genMaybeText <*> genMaybeText - <*> genMaybeText <*> genMaybe genSocksProxy <*> (genMaybe genTextList) - -genFromRange :: (Integral a, FiniteBits a) => a -> a -> Gen a +genFromRange :: (Integral a, FiniteBits a) => a -> a -> Gen a genFromRange lb ub = G.inRange $ R.between (lb, ub) genInt :: Int -> Int -> G.Gen Int @@ -267,6 +271,8 @@ strictFileInteractability <- genMaybe genBool unhandledPromptBehavior <- genMEnum acceptInsecureCerts <- genMaybe genBool + setWindowRect <- genMaybe genBool + webSocketUrl <- genMaybe genBool pageLoadStrategy <- genMEnum proxy <- genMaybe genProxy timeouts <- genMaybe genTimeouts @@ -283,7 +289,6 @@ overrideMaxRatio = Nothing } - subEmt :: forall a. (a -> Bool) -> Maybe a -> Maybe a subEmt f = maybe Nothing (\x -> if f x then Nothing else Just x) @@ -291,12 +296,11 @@ subEmptyTxt = subEmt T.null subEmptyList :: Maybe String -> Maybe String -subEmptyList = subEmt null +subEmptyList = subEmt null subEmptyTxtLst :: Maybe [Text] -> Maybe [Text] subEmptyTxtLst = subEmt emptyTextList - emptyVal :: Value -> Bool emptyVal = \case Bool _ -> False @@ -308,83 +312,81 @@ subEmtyValueMap :: Maybe (M.Map Text Value) -> Maybe (M.Map Text Value) subEmtyValueMap = fmap M.fromList . subEmt emptyValList . fmap M.toList - where - emptyValList :: [(Text, Value)] -> Bool - emptyValList ml = null ml || all (\(t, v) -> T.null t || emptyVal v) ml + where + emptyValList :: [(Text, Value)] -> Bool + emptyValList ml = null ml || all (\(t, v) -> T.null t || emptyVal v) ml -- | Substitutes empty fields with Nothing subEmptyVendor :: Maybe VendorSpecific -> Maybe VendorSpecific subEmptyVendor = subEmt allPropsNothing . fmap subEmptFields - where - allPropsNothing :: VendorSpecific -> Bool - allPropsNothing = \case - ChromeOptions p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 -> allTrue [n p1, n p2, n p3, n p4, n p5, n p6, n p7, n p8, n p9, n p10, n p11, n p12] - EdgeOptions p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 -> allTrue [n p1, n p2, n p3, n p4, n p5, n p6, n p7, n p8, n p9, n p10, n p11, n p12] - FirefoxOptions p1 p2 p3 p4 -> allTrue [n p1, n p2, n p3, n p4] - SafariOptions p1 p2-> allTrue [n p1, n p2] - - where - n = isNothing - allTrue :: [Bool] -> Bool - allTrue = all id - - subEmptFields :: VendorSpecific -> VendorSpecific - subEmptFields = \case - ChromeOptions {..} -> - ChromeOptions - { chromeArgs = subEmptyTxtLst chromeArgs, - chromeBinary = subEmptyTxt chromeBinary, - chromeExtensions = subEmptyTxtLst chromeExtensions, - chromeLocalState = subEmtyValueMap chromeLocalState, - chromePrefs = subEmtyValueMap chromePrefs, - chromeDetach, - chromeDebuggerAddress = subEmptyTxt chromeDebuggerAddress, - chromeExcludeSwitches = subEmptyTxtLst chromeExcludeSwitches, - chromeMobileEmulation = subEmptyMobileEmulation chromeMobileEmulation, - chromeMinidumpPath = subEmptyList chromeMinidumpPath, - chromePerfLoggingPrefs = subEmptyPerfLoggingPrefs chromePerfLoggingPrefs, - chromeWindowTypes = subEmptyTxtLst chromeWindowTypes - } - EdgeOptions {..} -> - EdgeOptions - { edgeArgs = subEmptyTxtLst edgeArgs, - edgeBinary = subEmptyTxt edgeBinary, - edgeExtensions = subEmptyTxtLst edgeExtensions, - edgeLocalState = subEmtyValueMap edgeLocalState, - edgePrefs = subEmtyValueMap edgePrefs, - edgeDetach, - edgeDebuggerAddress = subEmptyTxt edgeDebuggerAddress, - edgeExcludeSwitches = subEmptyTxtLst edgeExcludeSwitches, - edgeMobileEmulation = subEmptyMobileEmulation edgeMobileEmulation, - edgeMinidumpPath = subEmptyList edgeMinidumpPath, - edgePerfLoggingPrefs = subEmptyPerfLoggingPrefs edgePerfLoggingPrefs, - edgeWindowTypes = subEmptyTxtLst edgeWindowTypes - } - FirefoxOptions {..} -> - FirefoxOptions - { firefoxArgs = subEmptyTxtLst firefoxArgs, - firefoxBinary = subEmptyTxt firefoxBinary, - firefoxProfile = subEmptyTxt firefoxProfile, - firefoxLog - } - s@SafariOptions {} -> s - where - subEmptyMobileEmulation :: Maybe MobileEmulation -> Maybe MobileEmulation - subEmptyMobileEmulation = subEmt emptyMobileEmulation + where + allPropsNothing :: VendorSpecific -> Bool + allPropsNothing = \case + ChromeOptions p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 -> allTrue [n p1, n p2, n p3, n p4, n p5, n p6, n p7, n p8, n p9, n p10, n p11, n p12] + EdgeOptions p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 -> allTrue [n p1, n p2, n p3, n p4, n p5, n p6, n p7, n p8, n p9, n p10, n p11, n p12] + FirefoxOptions p1 p2 p3 p4 -> allTrue [n p1, n p2, n p3, n p4] + SafariOptions p1 p2 -> allTrue [n p1, n p2] + where + n = isNothing + allTrue :: [Bool] -> Bool + allTrue = all id - emptyMobileEmulation :: MobileEmulation -> Bool - emptyMobileEmulation = \case - MkMobileEmulation {deviceName, deviceMetrics, userAgent} -> - emptyTxt deviceName && isNothing deviceMetrics && emptyTxt userAgent + subEmptFields :: VendorSpecific -> VendorSpecific + subEmptFields = \case + ChromeOptions {..} -> + ChromeOptions + { chromeArgs = subEmptyTxtLst chromeArgs, + chromeBinary = subEmptyTxt chromeBinary, + chromeExtensions = subEmptyTxtLst chromeExtensions, + chromeLocalState = subEmtyValueMap chromeLocalState, + chromePrefs = subEmtyValueMap chromePrefs, + chromeDetach, + chromeDebuggerAddress = subEmptyTxt chromeDebuggerAddress, + chromeExcludeSwitches = subEmptyTxtLst chromeExcludeSwitches, + chromeMobileEmulation = subEmptyMobileEmulation chromeMobileEmulation, + chromeMinidumpPath = subEmptyList chromeMinidumpPath, + chromePerfLoggingPrefs = subEmptyPerfLoggingPrefs chromePerfLoggingPrefs, + chromeWindowTypes = subEmptyTxtLst chromeWindowTypes + } + EdgeOptions {..} -> + EdgeOptions + { edgeArgs = subEmptyTxtLst edgeArgs, + edgeBinary = subEmptyTxt edgeBinary, + edgeExtensions = subEmptyTxtLst edgeExtensions, + edgeLocalState = subEmtyValueMap edgeLocalState, + edgePrefs = subEmtyValueMap edgePrefs, + edgeDetach, + edgeDebuggerAddress = subEmptyTxt edgeDebuggerAddress, + edgeExcludeSwitches = subEmptyTxtLst edgeExcludeSwitches, + edgeMobileEmulation = subEmptyMobileEmulation edgeMobileEmulation, + edgeMinidumpPath = subEmptyList edgeMinidumpPath, + edgePerfLoggingPrefs = subEmptyPerfLoggingPrefs edgePerfLoggingPrefs, + edgeWindowTypes = subEmptyTxtLst edgeWindowTypes + } + FirefoxOptions {..} -> + FirefoxOptions + { firefoxArgs = subEmptyTxtLst firefoxArgs, + firefoxBinary = subEmptyTxt firefoxBinary, + firefoxProfile = subEmptyTxt firefoxProfile, + firefoxLog + } + s@SafariOptions {} -> s + where + subEmptyMobileEmulation :: Maybe MobileEmulation -> Maybe MobileEmulation + subEmptyMobileEmulation = subEmt emptyMobileEmulation - subEmptyPerfLoggingPrefs :: Maybe PerfLoggingPrefs -> Maybe PerfLoggingPrefs - subEmptyPerfLoggingPrefs = subEmt emptyPerfLoggingPrefs + emptyMobileEmulation :: MobileEmulation -> Bool + emptyMobileEmulation = \case + MkMobileEmulation {deviceName, deviceMetrics, userAgent} -> + emptyTxt deviceName && isNothing deviceMetrics && emptyTxt userAgent - emptyPerfLoggingPrefs :: PerfLoggingPrefs -> Bool - emptyPerfLoggingPrefs = \case - MkPerfLoggingPrefs {enableNetwork, enablePage, enableTimeline, traceCategories, bufferUsageReportingInterval} -> - emptyTxt traceCategories && isNothing bufferUsageReportingInterval && isNothing enableNetwork && isNothing enablePage && isNothing enableTimeline + subEmptyPerfLoggingPrefs :: Maybe PerfLoggingPrefs -> Maybe PerfLoggingPrefs + subEmptyPerfLoggingPrefs = subEmt emptyPerfLoggingPrefs + emptyPerfLoggingPrefs :: PerfLoggingPrefs -> Bool + emptyPerfLoggingPrefs = \case + MkPerfLoggingPrefs {enableNetwork, enablePage, enableTimeline, traceCategories, bufferUsageReportingInterval} -> + emptyTxt traceCategories && isNothing bufferUsageReportingInterval && isNothing enableNetwork && isNothing enablePage && isNothing enableTimeline emptyTxt :: Maybe Text -> Bool emptyTxt = maybe True T.null @@ -395,12 +397,11 @@ emptyTextList :: [Text] -> Bool emptyTextList ml = null ml || (all T.null) ml - isNothingProxy :: Proxy -> Bool isNothingProxy = \case Direct -> False - Manual ftpProxy httpProxy sslProxy noProxy socksProxy-> - all isNothing [ftpProxy, httpProxy, sslProxy] && isNothing noProxy && isNothing socksProxy + Manual httpProxy sslProxy noProxy socksProxy -> + all isNothing [httpProxy, sslProxy] && isNothing noProxy && isNothing socksProxy AutoDetect -> False Pac url -> T.null url System -> False @@ -412,8 +413,7 @@ subEmptProps p' = case p' of Manual {..} -> Manual - { ftpProxy = subEmptyTxt ftpProxy, - httpProxy = subEmptyTxt httpProxy, + { httpProxy = subEmptyTxt httpProxy, sslProxy = subEmptyTxt sslProxy, noProxy = subEmptyTxtLst noProxy, socksProxy @@ -423,9 +423,8 @@ Pac {} -> p' System -> p' - subEmptyTimeouts :: Maybe Timeouts -> Maybe Timeouts -subEmptyTimeouts = subEmt isNothingTimeouts +subEmptyTimeouts = subEmt isNothingTimeouts where isNothingTimeouts :: Timeouts -> Bool isNothingTimeouts = \case @@ -433,28 +432,29 @@ all isNothing [implicit, pageLoad, script] emptyFieldsToNothing :: Capabilities -> Capabilities -emptyFieldsToNothing caps@MkCapabilities {..} = caps { - browserVersion = subEmptyTxt browserVersion, - vendorSpecific = subEmptyVendor vendorSpecific, - platformName, - acceptInsecureCerts, - pageLoadStrategy, - proxy = subEmptyProxy proxy, - timeouts = subEmptyTimeouts timeouts, - strictFileInteractability, - unhandledPromptBehavior - } +emptyFieldsToNothing caps@MkCapabilities {..} = + caps + { browserVersion = subEmptyTxt browserVersion, + vendorSpecific = subEmptyVendor vendorSpecific, + platformName, + acceptInsecureCerts, + pageLoadStrategy, + proxy = subEmptyProxy proxy, + timeouts = subEmptyTimeouts timeouts, + strictFileInteractability, + unhandledPromptBehavior + } subEmptyCapabilities :: Capabilities -> Capabilities -subEmptyCapabilities caps@MkCapabilities {..} = caps { - browserVersion = subEmptyTxt browserVersion, - strictFileInteractability = strictFileInteractability, - acceptInsecureCerts = acceptInsecureCerts, - proxy = subEmptyProxy proxy, - timeouts = subEmptyTimeouts timeouts, - vendorSpecific = subEmptyVendor vendorSpecific - } - +subEmptyCapabilities caps@MkCapabilities {..} = + caps + { browserVersion = subEmptyTxt browserVersion, + strictFileInteractability = strictFileInteractability, + acceptInsecureCerts = acceptInsecureCerts, + proxy = subEmptyProxy proxy, + timeouts = subEmptyTimeouts timeouts, + vendorSpecific = subEmptyVendor vendorSpecific + } jsonEq :: Capabilities -> Maybe Capabilities -> Bool jsonEq expected = @@ -486,3 +486,59 @@ log "Decoded Capabilities:" log $ maybe "Nothing" ppShow decoded assert $ expect True `dot` fn ("matches encoded", asExpected) .$ ("decoded", decoded) + +-- >>> unit_websocketUrlFromJSon +unit_websocketUrlFromJSon :: IO () +unit_websocketUrlFromJSon = + (Success $ Just "ws://127.0.0.1:9222/session/b82f5798-2d37-4555-ac1d-7c70153ad372") === decoded + where + json = + Object + ( KM.fromList + [ ( "capabilities", + Object + ( KM.fromList + [ ("acceptInsecureCerts", Bool False), + ("browserName", String "firefox"), + ("browserVersion", String "137.0.2"), + ("moz:accessibilityChecks", Bool False), + ("moz:buildID", String "20250414091429"), + ("moz:geckodriverVersion", String "0.36.0"), + ("moz:headless", Bool True), + ("moz:platformVersion", String "6.11.0-26-generic"), + ("moz:processID", Number 14181.0), + ("moz:profile", String "/tmp/rust_mozprofileNltPR1"), + ("moz:shutdownTimeout", Number 60000.0), + ("moz:webdriverClick", Bool True), + ("moz:windowless", Bool False), + ("pageLoadStrategy", String "normal"), + ("platformName", String "linux"), + ("proxy", Object (KM.fromList [])), + ("setWindowRect", Bool True), + ("strictFileInteractability", Bool False), + ( "timeouts", + Object + ( KM.fromList + [ ("implicit", Number 0.0), + ("pageLoad", Number 300000.0), + ("script", Number 30000.0) + ] + ) + ), + ("unhandledPromptBehavior", String "dismiss and notify"), + ( "userAgent", + String + "Mozilla/5.0 (X11; Linux x86_64; rv:137.0) Gecko/20100101 Firefox/137.0" + ), + ( "webSocketUrl", + String + "ws://127.0.0.1:9222/session/b82f5798-2d37-4555-ac1d-7c70153ad372" + ) + ] + ) + ), + ("sessionId", String "b82f5798-2d37-4555-ac1d-7c70153ad372") + ] + ) + + decoded = (.webSocketUrl) <$> fromJSON @SessionResponse json diff --git a/test/Logger.hs b/test/Logger.hs new file mode 100644 --- /dev/null +++ b/test/Logger.hs @@ -0,0 +1,88 @@ +module Logger + ( Printer (..), + withLogger, + withLogFileLogger, + withChannelFileLogger, + printToFileAndLog, + ) +where + +import Control.Monad (unless) +import Data.Text (Text) +import Data.Text.IO qualified as TIO +import IOUtils (Logger (..), findWebDriverRoot, loopForever) +import System.FilePath (()) +import UnliftIO + ( IOMode (..), + atomically, + bracket, + cancel, + isEmptyTChan, + newTChanIO, + readTChan, + withFile, + writeTChan, + atomically + ) +import UnliftIO.Concurrent (threadDelay) +import UnliftIO.Directory (getCurrentDirectory) +import UnliftIO.IO (hSetBuffering) +import UnliftIO.IO (BufferMode(..)) + + +-- | Printer abstraction for logging output +newtype Printer = MkPrinter + { print :: Text -> IO () + } + +-- | Creates a logger with a channel and async loop that processes messages using the provided Printer +withLogger :: Printer -> (Logger -> IO ()) -> IO () +withLogger p loggingAction = do + logChan <- newTChanIO + let waitEmpty :: Int -> IO () + waitEmpty attempt = do + empty <- atomically $ isEmptyTChan logChan + unless (empty || attempt > 500) $ do + threadDelay 10_000 + waitEmpty $ succ attempt + + writeToChan = atomically . writeTChan @Text logChan + readAndPrint = atomically (readTChan logChan) >>= p.print + + bracket + -- initialise printloop + (loopForever writeToChan "Logger" readAndPrint) + -- empty and cancel print loop + ( \printLoop -> do + waitEmpty 0 + cancel printLoop + ) + -- run the loggingAction with a logger that writes messages to the print channel + (const . loggingAction $ MkLogger writeToChan) + +-- | Opens a log file and provides a function to write to it +withLogFileLogger :: ((Text -> IO ()) -> IO ()) -> IO () +withLogFileLogger action = do + lgPath <- getLogPath <$> getCurrentDirectory + withFile lgPath WriteMode $ \h -> do + hSetBuffering h LineBuffering + action $ TIO.hPutStrLn h + where + lgName = "eval.log" + getLogPath = maybe lgName ( lgName) . findWebDriverRoot + +-- | Combines withLogger and withLogFileLogger to provide channel-based file logging +withChannelFileLogger :: (Logger -> IO ()) -> IO () +withChannelFileLogger loggingAction = + withLogFileLogger $ \printToFile -> + withLogger (printToFileAndLog printToFile) loggingAction + +-- | Creates a Printer that writes to both a file and stdout +printToFileAndLog :: (Text -> IO ()) -> Printer +printToFileAndLog printToFile = + MkPrinter + { print = \msg -> do + let logMsg = "[LOG] " <> msg + TIO.putStrLn logMsg + printToFile logMsg + } diff --git a/test/RuntimeConst.hs b/test/RuntimeConst.hs new file mode 100644 --- /dev/null +++ b/test/RuntimeConst.hs @@ -0,0 +1,80 @@ +module RuntimeConst + ( + httpCapabilities, + httpFullCapabilities + ) +where + +import Config as CFG +import WebDriverPreCore.HTTP.Protocol as WPC + ( BrowserName (..), + Capabilities (..), + FullCapabilities (..), + UnhandledPromptBehavior (..), + VendorSpecific (..), + ) +import Prelude as P + ( Maybe (..), + ($), + (<>), + null + ) + +-- "Constants" that depend Config so can't be resolved until runtime + +-- ################### capabilities ################## + +httpCapabilities :: Config -> Capabilities +httpCapabilities MkConfig {browser} = + MkCapabilities + { browserName = Just $ if (isFirefox browser) then WPC.Firefox else WPC.Chrome, + browserVersion = Nothing, + platformName = Nothing, + acceptInsecureCerts = Nothing, + pageLoadStrategy = Nothing, + proxy = Nothing, + setWindowRect = Nothing, + timeouts = Nothing, + strictFileInteractability = Nothing, + unhandledPromptBehavior = Just Ignore, + webSocketUrl = Nothing, + vendorSpecific = + case browser of + CFG.Firefox {headless, profilePath} -> Just $ FirefoxOptions + { firefoxArgs = if null allArgs then Nothing else Just allArgs, + firefoxBinary = Nothing, + firefoxProfile = Nothing, + firefoxLog = Nothing + } + where + headlessArgs = if headless then ["--headless"] else [] + profileArgs = case profilePath of + Just path -> ["--profile", path] + Nothing -> [] + allArgs = headlessArgs <> profileArgs + + CFG.Chrome {headless} -> Just $ ChromeOptions + { chromeArgs = if headless then Just ["--headless=new"] else Nothing, + chromeBinary = Nothing, + chromeExtensions = Nothing, + chromeLocalState = Nothing, + chromeMobileEmulation = Nothing, + chromePrefs = Nothing, + chromeDetach = Nothing, + chromeDebuggerAddress = Nothing, + chromeExcludeSwitches = Nothing, + chromeMinidumpPath = Nothing, + chromePerfLoggingPrefs = Nothing, + chromeWindowTypes = Nothing + } + } + + + +httpFullCapabilities :: Config -> FullCapabilities +httpFullCapabilities cfg = + MkFullCapabilities + { alwaysMatch = + Just $ httpCapabilities cfg, + firstMatch = [] + } diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,499 @@ +{-# LANGUAGE CPP #-} + +module Main where + +import ApiCoverageTest qualified as API +import BiDi.DemoUtils (BiDiDemo (..), expectError, runDemo', FailTest (..), toText) +import BiDi.Demos.BrowserDemos qualified as Browser +import BiDi.Demos.BrowsingContextDemos qualified as BrowsingContext +import BiDi.Demos.BrowsingContextEventDemos qualified as BrowsingContextEvent +import BiDi.Demos.EmulationDemos qualified as Emulation +import BiDi.Demos.FallbackDemos qualified as Fallback +import BiDi.Demos.InputDemos qualified as Input +import BiDi.Demos.InputEventDemos qualified as InputEvent +import BiDi.Demos.LogEventDemos qualified as LogEvent +import BiDi.Demos.NetworkDemos qualified as Network +import BiDi.Demos.NetworkEventDemos qualified as NetworkEvent +import BiDi.Demos.OtherDemos qualified as Other +import BiDi.Demos.ScriptDemos qualified as Script +import BiDi.Demos.ScriptEventDemos qualified as ScriptEvent +import BiDi.Demos.SessionDemos qualified as Session +import BiDi.Demos.StorageDemos qualified as Storage +import BiDi.Demos.WebExtensionDemos qualified as WebExtension +import BiDi.ErrorDemo qualified as BiDiError +import Config (Config (..), DemoBrowser (..)) +import ConfigLoader (loadConfig) +import Control.Exception (SomeException, catch) +import Data.Text (Text, unpack) +import ErrorCoverageTest qualified as Error +import HTTP.DemoUtils (HttpDemo (..), runDemoWithConfig) +import HTTP.ErrorDemo qualified as HttpError +import HTTP.HttpDemo qualified as Http +#ifndef LEGACY_TEST +import HTTP.FallbackDemo qualified as HttpFallback +#endif +import JSONParsingTest qualified as JSON +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (testCase) +import qualified Data.Text as T + +main :: IO () +main = do + testCfg <- loadConfig + -- defaultMain $ httpDemoSingleIsolated testCfg + -- defaultMain $ bidiSingleForDebug testCfg + defaultMain $ tests testCfg + +tests :: Config -> TestTree +tests cfg = + testGroup + "Tests" +#ifdef LEGACY_TEST + [ + httpDemos cfg + ] +#else + [ unitTests, + httpDemos cfg, + propertyTests, + bidiDemos cfg + ] +#endif + +unitTests :: TestTree +unitTests = + testGroup + "Unit Tests" + [ testGroup + "API Coverage" + [ testCase "All endpoints covered" API.unit_test_all_endpoints_covered + ], + testGroup + "Error Coverage" + [ testCase "All errors covered" Error.unit_test_all_errors_covered, + testCase "Round trip error codes" Error.unit_round_trip_error_codes, + testCase "All BiDi errors covered" Error.unit_test_all_errors_covered, + testCase "Round trip BiDi error codes" Error.unit_round_trip_error_codes + ], + testGroup + "JSON Parsing" + [ testCase "WebSocket URL from JSON" JSON.unit_websocketUrlFromJSon + ] + ] + +propertyTests :: TestTree +propertyTests = + testGroup + "Property Tests" + [ testGroup + "JSON Parsing" + [ JSON.test_round_trip + ] + ] + + +-- Single isolated HTTP demo for CI debugging +httpDemoSingleIsolated :: Config -> TestTree +httpDemoSingleIsolated cfg = + testGroup + "HTTP Demos" + $ fromHttpDemo cfg + <$> [ + Http.demoForwardBackRefresh + ] + +-- Single isolated Bidi demo for CI debugging +bidiSingleForDebug :: Config -> TestTree +bidiSingleForDebug cfg = + let + run = bidiTest cfg + thisBrowser = cfg.browser + expectFail bts txt = biDiError thisBrowser bts (Fragment txt) + in testGroup + "BiDi Single Demo" + [ + run + "Emulation" + [ + expectFail [Firefox'] + "Expected \\\\\\\"coordinates\\\\\\\" to be an object" + Emulation.emulationSetGeolocationOverridePositionErrorDemo + ] + ] + +httpDemos :: Config -> TestTree +httpDemos cfg = + let thisBrowser = cfg.browser + expectHttpFail = httpError thisBrowser + in testGroup + "HTTP Demos" + $ fromHttpDemo cfg + <$> [ Http.newSessionDemo, + -- W3C spec requires status.ready=false when sessions exist. Chrome diverges from spec. + expectHttpFail [Chrome'] "status.ready expected to be False" + Http.driverStatusDemo, + Http.demoSendKeysClear, + Http.demoForwardBackRefresh, + -- this test is redundant but used in docs so run anyway + Http.documentationDemo, + Http.demoWindowHandles, + Http.demoWindowSizes, + Http.demoElementPageProps, + Http.demoTimeouts, + Http.demoWindowRecs, + Http.demoWindowFindElement, + Http.demoFrames, + Http.demoShadowDom, + Http.demoIsElementSelected, + Http.demoGetPageSourceScreenShot, + Http.demoPrintPage, + Http.demoExecuteScript, + Http.demoCookies, + Http.demoCookiesWithDomain, + Http.demoAlerts, + Http.demoPointerNoneActions, + Http.demoKeyAndReleaseActions, + Http.demoWheelActions, + Http.demoError, + HttpError.errorDemo +-- fallback commands not implemented for legacy +#ifndef LEGACY_TEST + , HttpFallback.demoFallbackActions + , HttpFallback.demoFallbackCoercions + , HttpFallback.demoExtendPost +#endif + ] + +httpTest :: Config -> Text -> [HttpDemo] -> TestTree +httpTest cfg title = testGroup (unpack title) . fmap (fromHttpDemo cfg) + +fromHttpDemo :: Config -> HttpDemo -> TestTree +fromHttpDemo cfg demo = testCase (unpack demo.name) $ runDemoWithConfig cfg demo + +-- testCase (unpack demo.name) $ runDemo' logNothingLogger MkTimeout {microseconds = 0} demo + +bidiTest :: Config -> Text -> [BiDiDemo] -> TestTree +bidiTest cfg title = + testGroup (unpack title) . fmap fromBidiDemo + where + fromBidiDemo demo = testCase (unpack demo.name) $ runDemo' cfg demo + + + +bidiDemos :: Config -> TestTree +bidiDemos cfg = + let run = bidiTest cfg + thisBrowser = cfg.browser + browserType = fromBrowser thisBrowser + unknownCommand = unknownCommandError thisBrowser + expectFail bts txt = biDiError thisBrowser bts (Fragment txt) + in testGroup + "BiDi Demos" + [ testGroup + "BiDi Commands" + [ testGroup + "BiDi Exception tests - threads rigged to explode" + [ testCase "send exception" $ Other.sendFailDemo cfg, + testCase "get exception" $ Other.getFailDemo cfg, + testCase "event fail exception" $ Other.eventFailDemo cfg + ], + run + "Browser" + [ Browser.browserGetClientWindowsDemo, + Browser.browserCreateUserContextDemo, + Browser.browserGetUserContextsDemo, + unknownCommand [Firefox', Chrome'] + Browser.browserSetClientWindowStateDemo, + Browser.browserRemoveUserContextDemo, + Browser.browserCompleteWorkflowDemo, + expectFail [Firefox'] + "Closing the browser in a session started with WebDriver classic is not supported" + Browser.browserCloseDemo, + unknownCommand [Firefox'] + -- since https://www.w3.org/TR/2025/WD-webdriver-bidi-20250918/#command-browser-seProtocolExceptiontDownloadBehavior + Browser.browserSetDownloadBehaviorDemo + ], + run + "Browsing Context" + [ BrowsingContext.browsingContextCreateActivateCloseDemo, + BrowsingContext.browsingContextCaptureScreenshotCloseDemo, + BrowsingContext.browsingContextClosePromptUnloadDemo, + BrowsingContext.browsingContextGetTreeDemo, + BrowsingContext.browsingContextHandleUserPromptDemo, + BrowsingContext.browsingNavigateReloadTraverseHistoryDemo, + BrowsingContext.browsingContextLocateNodesDemo, + BrowsingContext.browsingContextContextLocatorDemo, + BrowsingContext.browsingContextPrintDemo, + BrowsingContext.browsingContextSetViewportDemo, + BiDiError.errorDemo + -- TODO: WHEN NEW DRIVERS ADDED make conditional - hangs in firefox + -- , BrowsingContext.browsingContextSetViewportResetDemo + ], + run + "Emulation" + [ unknownCommand [Firefox', Chrome'] + -- since https:\/\/www.w3.org\/TR\/2025\/WD-webdriver-bidi-20250729 + Emulation.emulationSetForcedColorsModeThemeOverrideDemo, + Emulation.emulationSetGeolocationOverrideDemo, + -- Geckodriver bug: incorrectly requires 'coordinates' when 'error' is provided + -- Spec section 7.4.2.2 states that 'error' and 'coordinates' are mutually exclusive + expectFail [Firefox'] + "Expected \\\\\\\"coordinates\\\\\\\" to be an object" + Emulation.emulationSetGeolocationOverridePositionErrorDemo, + Emulation.emulationSetLocaleOverrideDemo, + unknownCommand [Firefox'] + -- since https://www.w3.org/TR/2025/WD-webdriver-bidi-20251007 + Emulation.emulationSetNetworkConditionsDemo, + Emulation.emulationSetScreenOrientationOverrideDemo, + unknownCommand [Chrome'] + -- since https://www.w3.org/TR/2025/WD-webdriver-bidi-20251120 + Emulation.emulationSetScreenSettingsOverrideDemo, + unknownCommand [Firefox'] + -- since https://www.w3.org/TR/2025/WD-webdriver-bidi-20250811 + Emulation.emulationSetScriptingEnabledDemo, + Emulation.emulationSetTimezoneOverrideDemo, + unknownCommand [Firefox', Chrome'] + -- since https://www.w3.org/TR/2026/WD-webdriver-bidi-20260109 + Emulation.emulationSetTouchOverrideDemo, + Emulation.emulationSetUserAgentOverrideDemo, + Emulation.emulationCompleteWorkflowDemo + ], + run + "Fallback" + [ Fallback.fallbackExtendCommandDemo, + Fallback.fallbackOffSpecCommandDemo, + Fallback.fallbackCommandCoercionsDemo, + Fallback.fallbackSubscribeUnknownEventDemo, + Fallback.fallbackSubscribeUnknownEventFilteredDemo + ], + run + "Input" + [ Input.inputKeyboardDemo, + Input.inputPointerDemo, + Input.inputWheelDemo, + Input.inputCombinedActionsDemo, + Input.inputReleaseActionsDemo, + Input.inputSetFilesDemo + ], + run + "Network" + [ + Network.networkDataCollectorDemo, + Network.networkInterceptDemo, + Network.networkRequestModificationDemo, + Network.networkResponseModificationDemo, + Network.networkAuthCancelDemo, + Network.networkAuthWithCredentialsDemo, + Network.networkFailRequestDemo, + Network.networkProvideResponseJSONDemo, + Network.networkProvideResponseHTMLDemo, + Network.networkProvideResponseWithCookiesDemo, + Network.networkProvideResponseBase64Demo, + Network.networkProvideResponseErrorDemo, + Network.networkDataRetrievalDemo, + Network.networkDisownDataDemo, + Network.networkCacheBehaviorDemo, + -- since https://www.w3.org/TR/2025/WD-webdriver-bidi-20251106 + -- Chromedriver does not support setting non-string header values + expectFail [Chrome'] + "Only string headers values are supported" + Network.networkSetExtraHeadersDemo + ], + run + "Script" + [ Script.scriptEvaluateAllPrimitiveTypesDemo, + Script.scriptEvaluateAdvancedDemo, + Script.serializationOptionsDemo, + Script.scriptPreloadScriptDemo, + Script.scriptPreloadScriptMultiContextDemo, + Script.scriptChannelArgumentDemo, + Script.scriptUserContextsDemo, + Script.scriptCallFunctionDemo, + Script.scriptGetRealmsAndDisownDemo + ], + run + "Session" + [ Session.sessionStatusDemo, + expectFail [Firefox', Chrome'] + (case thisBrowser of + Firefox{} -> "Maximum number of active sessions" + Chrome{} -> "session already exists" + ) + Session.sessionNewDemo, + + Session.sessionSubscribeDemo, + Session.sessionUnsubscribeDemo, + expectFail [Firefox', Chrome'] + (case thisBrowser of + Firefox{} -> "Maximum number of active sessions" + Chrome{} -> "session already exists" + ) + Session.sessionCapabilityNegotiationDemo, + Session.sessionCompleteLifecycleDemo + ], + run + "Session - firefox only" ( + if browserType == Firefox' then + [ + -- todo: - calling `session.end` on the test BiDi runner throws `ConnectionClosed` when + -- the server closes the WebSocket after session termination - needs orchestration + -- fix in bidi runner when sesssion is closed + expectFail [Firefox'] + "Ending a session started with WebDriver classic is not supported" + Session.sessionEndDemo + ] else []), + run + "Storage" + [ Storage.storageGetCookiesDemo, + -- ChromeDriver does not support storageKey partition type in storage.setCookie + expectFail [Chrome'] + "unable to set cookie" + Storage.storageSetCookieDemo, + Storage.storageDeleteCookiesDemo, + Storage.storagePartitionKeyDemo, + Storage.storageCompleteWorkflowDemo + ], + run + "WebExtension" + [ -- ChromeDriver doesn't support BiDi WebExtension methods + expectFail [Chrome'] + "Method not available" + WebExtension.webExtensionInstallPathDemo, + expectFail [Chrome'] + "Archived and Base64 extensions are not supported" + WebExtension.webExtensionInstallArchiveDemo, + expectFail [Chrome'] + "Archived and Base64 extensions are not supported" + WebExtension.webExtensionInstallBase64Demo, + WebExtension.webExtensionValidationDemo + ] + ], + testGroup + "BiDi Events" + [ run + "Browsing Context Events" + [ BrowsingContextEvent.browsingContextEventDemo, + BrowsingContextEvent.browsingContextEventDemoMulti, + BrowsingContextEvent.browsingContextEventDemoFilteredSubscriptions, + BrowsingContextEvent.browsingContextEventDemoUserContextFiltered, + BrowsingContextEvent.browsingContextEventCreateDestroy, + BrowsingContextEvent.browsingContextEventNavigationLifecycle, + BrowsingContextEvent.browsingContextEventFragmentNavigation, + BrowsingContextEvent.browsingContextEventUserPrompts, + BrowsingContextEvent.browsingContextEventUserPromptsVariants, + expectFail [Firefox', Chrome'] + (case thisBrowser of + Firefox{} -> "Expected event did not fire: BrowsingContextHistoryUpdated" + Chrome{} -> "Timeout" + ) + BrowsingContextEvent.browsingContextEventHistoryUpdated, + -- not supporrted in geckodriver yet + expectFail [Firefox', Chrome'] + (case thisBrowser of + Firefox{} -> "browsingContext.navigationAborted is not a valid event name" + Chrome{} -> "Expected event did not fire: BrowsingContextNavigationAborted" + ) + BrowsingContextEvent.browsingContextEventNavigationAborted, + expectFail [Firefox', Chrome'] + (case thisBrowser of + Firefox{} -> "NS_ERROR_UNKNOWN_HOST" + Chrome{} -> "ERR_NAME_NOT_RESOLVED" + ) + BrowsingContextEvent.browsingContextEventNavigationFailed, + BrowsingContextEvent.browsingContextEventDownloadWillBegin, + BrowsingContextEvent.browsingContextEventDownloadEnd + ], + run + "Input Events" + [], + run + "Input Events - File Dialog Opened" ( + case thisBrowser of + Chrome {} -> [InputEvent.inputEventFileDialogOpened] + Firefox {headless = False} -> [InputEvent.inputEventFileDialogOpened] + -- firfox throws error on file dialog open in headless mode + -- ConnectionClosed is not coming from main thread so not being caught TODO: reinstate this when runner fixed + Firefox {headless = True} -> [] -- [expectFail [Firefox'] "ConnectionClosed" InputEvent.inputEventFileDialogOpened] + ), + run + "Log Events" + [ LogEvent.logEventConsoleEntries, + LogEvent.logEventConsoleLevelDebug, + LogEvent.logEventConsoleLevelInfo, + LogEvent.logEventConsoleLevelWarn, + LogEvent.logEventConsoleLevelError, + LogEvent.logEventJavascriptErrorFromButton + ], + run + "Network Events" + [ expectFail [Chrome'] + "Timeout - Expected event did not fire: NetworkResponseStarted" + NetworkEvent.networkEventRequestResponseLifecycle, + NetworkEvent.networkEventFetchError, + expectFail [Chrome'] + "Timeout - Expected event did not fire: NetworkAuthRequired" + NetworkEvent.networkEventAuthRequired + ], + run + "Script Events" + [ ScriptEvent.scriptEventRealmLifecycle, + ScriptEvent.scriptEventMessage, + ScriptEvent.scriptEventMessageRuntime + ] + ] + ] + +expectFailure :: DemoBrowser -> [BrowserType] -> Bool +expectFailure actualBrowser failBrowsers = + fromBrowser actualBrowser `elem` failBrowsers + +biDiError :: DemoBrowser -> [BrowserType] -> FailTest -> BiDiDemo -> BiDiDemo +biDiError actualBrowser failBrowsers failTest demo@MkBiDiDemo {name, action} = + if expectFailure actualBrowser failBrowsers then + MkBiDiDemo + { name = name <> " - EXPECTED ERROR: " <> toText failTest, + action = \utils bidi -> expectError name failTest (action utils bidi) + } + else demo + +data BrowserType = Firefox' | Chrome' deriving (Eq, Show) + +fromBrowser :: DemoBrowser -> BrowserType +fromBrowser = \case + Firefox {} -> Firefox' + Chrome {} -> Chrome' + +unknownCommandError :: DemoBrowser -> [BrowserType] -> BiDiDemo -> BiDiDemo +unknownCommandError actualBrowser failBrowsers demo = + biDiError actualBrowser failBrowsers failTest demo + where + failTest = Predicate \txt -> "not implemented" `T.isInfixOf` txt || "unknown command" `T.isInfixOf` txt + +httpError :: DemoBrowser -> [BrowserType] -> Text -> HttpDemo -> HttpDemo +httpError actualBrowser failBrowsers errorFragment demo = + if expectFailure actualBrowser failBrowsers then + case demo of + Demo {name, action} -> + Demo + { name = name <> " - EXPECTED ERROR: " <> errorFragment, + action = \demoActions httpActions -> + catch + ( do + action demoActions httpActions + error $ "Expected test to fail with error containing: " <> unpack errorFragment + ) + (\(_ :: SomeException) -> pure ()) + } + SessionDemo {name, sessionAction} -> + SessionDemo + { name = name <> " - EXPECTED ERROR: " <> errorFragment, + sessionAction = \session demoActions httpActions -> + catch + ( do + sessionAction session demoActions httpActions + error $ "Expected test to fail with error containing: " <> unpack errorFragment + ) + (\(_ :: SomeException) -> pure ()) + } + else demo + diff --git a/test/TestData.hs b/test/TestData.hs new file mode 100644 --- /dev/null +++ b/test/TestData.hs @@ -0,0 +1,124 @@ +module TestData where + +import Data.Base64.Types qualified as B64T +import Data.ByteString qualified as BS +import Data.ByteString.Base64 qualified as B64 +import Data.Text (Text, pack, unpack) +import IOUtils (findWebDriverRoot) +import System.Directory (getCurrentDirectory) +import System.FilePath (()) +import WebDriverPreCore.HTTP.Protocol (URL (..)) + +testFilesDir :: IO FilePath +testFilesDir = do + currentDir <- getCurrentDirectory + case findWebDriverRoot currentDir of + Just root -> pure $ root testFilesSubDir + Nothing -> + error $ + "Could not find 'webdriver' root directory from: " + <> currentDir + <> "\n tests are expected to be run from the 'webdriver' directory or " + <> testFilesSubDir + where + testFilesSubDir = "webdriver-precore" "test" "testFiles" + +testPath :: FilePath -> IO Text +testPath filename = + pack . ( filename) <$> testFilesDir + +fileUrl :: FilePath -> IO URL +fileUrl fp = MkUrl <$> ((<>) "file://") <$> testPath fp + +-- | Get absolute file path for upload test files +uploadFilePath :: FilePath -> IO Text +uploadFilePath filename = do + testDir <- testFilesDir + pure . pack $ testDir "uploadFiles" filename + +demoExtensionDirPath :: IO Text +demoExtensionDirPath = testPath "demoExtension" + +demoExtensionZipPath :: IO Text +demoExtensionZipPath = testPath "demoExtension.zip" + +demoExtensionAsBase64 :: IO Text +demoExtensionAsBase64 = do + zipPath <- demoExtensionZipPath + zipContent <- BS.readFile (unpack zipPath) + pure $ B64T.extractBase64 $ B64.encodeBase64 zipContent + +textAreaUrl :: IO URL +textAreaUrl = fileUrl "textArea.html" + +checkboxesUrl :: IO URL +checkboxesUrl = fileUrl "checkboxes.html" + +infiniteScrollUrl :: IO URL +infiniteScrollUrl = fileUrl "infiniteScroll.html" + +promptUrl :: IO URL +promptUrl = fileUrl "prompt.html" + +fragmentUrl :: IO URL +fragmentUrl = fileUrl "fragment.html" + +downloadUrl :: IO URL +downloadUrl = fileUrl "download.html" + +slowLoadUrl :: IO URL +slowLoadUrl = fileUrl "slowLoad.html" + +downloadLinkUrl :: IO URL +downloadLinkUrl = fileUrl "downloadLink.html" + +consoleLogUrl :: IO URL +consoleLogUrl = fileUrl "consoleLog.html" + +scriptRealmUrl :: IO URL +scriptRealmUrl = fileUrl "scriptRealm.html" + +badJavaScriptUrl :: IO URL +badJavaScriptUrl = fileUrl "badJavaScript.html" + +uploadUrl :: IO URL +uploadUrl = fileUrl "upload.html" + +navigation1Url :: IO URL +navigation1Url = fileUrl "navigation1.html" + +navigation2Url :: IO URL +navigation2Url = fileUrl "navigation2.html" + +navigation3Url :: IO URL +navigation3Url = fileUrl "navigation3.html" + +navigation4Url :: IO URL +navigation4Url = fileUrl "navigation4.html" + +navigation5Url :: IO URL +navigation5Url = fileUrl "navigation5.html" + +navigation6Url :: IO URL +navigation6Url = fileUrl "navigation6.html" + +loginUrl :: IO URL +loginUrl = fileUrl "login.html" + +framesUrl :: IO URL +framesUrl = fileUrl "frames.html" + +nestedFramesUrl :: IO URL +nestedFramesUrl = fileUrl "nestedFrames.html" + +contentPageUrl :: IO URL +contentPageUrl = fileUrl "contentPage.html" + +indexUrl :: IO URL +indexUrl = fileUrl "index.html" + +shadowDomUrl :: IO URL +shadowDomUrl = fileUrl "shadowDom.html" + +inputsUrl :: IO URL +inputsUrl = fileUrl "inputs.html" diff --git a/test/TestServerAPI.hs b/test/TestServerAPI.hs new file mode 100644 --- /dev/null +++ b/test/TestServerAPI.hs @@ -0,0 +1,85 @@ +module TestServerAPI + ( withTestServer, + authTestUrl, + invalidUrl, + testServerHomeUrl, + malformedResponseUrl, + boringHelloUrl, + boringHelloUrl2, + ) +where + +import Control.Concurrent (threadDelay) +import Control.Exception (SomeException, catch, throwIO) +import Control.Monad (void, when) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Time (addUTCTime, getCurrentTime) +import IOUtils (findWebDriverRoot) +import Network.HTTP.Req (GET (..), NoReqBody (..), defaultHttpConfig, http, ignoreResponse, port, req, runReq) +import System.Directory (getCurrentDirectory) +import UnliftIO (finally) +import UnliftIO.Process (createProcess, cwd, proc, terminateProcess) + +testServerHomeUrl :: Text +testServerHomeUrl = "http://localhost:8000/" + +subPage :: Text -> Text +subPage subPath = testServerHomeUrl <> "/" <> subPath + +authTestUrl :: Text +authTestUrl = subPage "authtest" + +invalidUrl :: Text +invalidUrl = subPage "invalid-page" + +boringHelloUrl :: Text +boringHelloUrl = subPage "boringHello" + +boringHelloUrl2 :: Text +boringHelloUrl2 = subPage "boringHello2" + +malformedResponseUrl :: Text +malformedResponseUrl = subPage "malformed-response" + +-- | Ping the test server until it responds with 200 OK +-- Throws an exception if the server doesn't respond within 10 seconds +pingUntilReady :: Text -> IO () +pingUntilReady url = do + startTime <- getCurrentTime + let plusTenSecs = addUTCTime 10 startTime + tryPing plusTenSecs + where + tryPing expiryTime = do + currentTime <- getCurrentTime + when (currentTime > expiryTime) $ + throwIO $ + userError $ + "Test server at " <> T.unpack url <> " did not become ready within 10 seconds" + + catch + ( runReq defaultHttpConfig $ + void $ + req GET (http "localhost") NoReqBody ignoreResponse (port 8000) + ) + \(_ :: SomeException) -> + threadDelay 100_000 -- 100ms + >> tryPing expiryTime + +-- | Run an IO action with the test server running +withTestServer :: forall a. IO a -> IO a +withTestServer action = do + currentDir <- getCurrentDirectory + case findWebDriverRoot currentDir of + Nothing -> + fail $ + "Could not find 'webdriver' root directory from: " + <> currentDir + <> "\n withTestServer expects to be run from the 'webdriver' directory" + Just webdriverRoot -> do + let serverStart = (proc "cabal" ["run", "test-server"]) {cwd = Just webdriverRoot} + (_, _, _, handle) <- createProcess serverStart + pingUntilReady testServerHomeUrl + finally + action + $ terminateProcess handle diff --git a/utils/AesonUtils.hs b/utils/AesonUtils.hs new file mode 100644 --- /dev/null +++ b/utils/AesonUtils.hs @@ -0,0 +1,246 @@ +{-# OPTIONS_HADDOCK hide #-} + +module AesonUtils + ( aesonTypeError, + aesonTypeErrorMessage, + asObject, + asText, + bodyText', + emptyObj, + fromJSONCamelCase, + enumCamelCase, + lookup, + lookupTxt, + nonEmpty, + opt, + empty, + subtractProps, + jsonPrettyString, + jsonToText, + objectOrThrow, + objToText, + parseObject, + parseObjectMaybe, + parseOpt, + prettyJSON, + parseJson, + parseObjectEither, + toJSONOmitNothing, + parseJSONOmitNothing, + addProps, + objToString, + parseThrow, + ) +where + +-- \| Utility functions for working with Aeson (JSON) values. +import Control.Exception (Exception (displayException), SomeException, try) +import Data.Aeson + ( FromJSON (..), + Key, + KeyValue ((.=)), + Object, + Options (..), + Result (..), + ToJSON (), + Value (..), + defaultOptions, + eitherDecodeStrict, + object, + (.:?), + ) +import Data.Aeson qualified as A +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.Aeson.Key (fromString) +import Data.Aeson.KeyMap qualified as AKM +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types (Pair, Parser, parse, parseEither, parseMaybe) +import Data.Bifunctor (first) +import Data.ByteString.Lazy qualified as LBS +import Data.Char (toLower) +import Data.Function ((&)) +import Data.Set qualified as S +import Data.Text (Text, pack, unpack) +import Data.Text qualified as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import GHC.Generics (Generic, Rep) +import Prelude hiding (lookup) + + + + +toJSONOmitNothing :: (Generic a, A.GToJSON' Value A.Zero (Rep a)) => a -> Value +toJSONOmitNothing = A.genericToJSON defaultOptions {omitNothingFields = True} + +parseJSONOmitNothing :: (Generic a, A.GFromJSON A.Zero (Rep a)) => Value -> Parser a +parseJSONOmitNothing = A.genericParseJSON defaultOptions {omitNothingFields = True} + + +asText :: Value -> Result Text +asText = \case + String t -> Success t + v -> aesonTypeError "Text" v + +opt :: (Functor f, KeyValue e b, ToJSON a) => Key -> f a -> f b +opt lbl mb = (lbl .=) <$> mb + +parseObject :: Text -> Value -> Parser A.Object +parseObject errMsg val = case val of + Object obj -> pure obj + _ -> fail $ unpack errMsg + +parseThrow :: (FromJSON a, MonadFail m) => Text -> Value -> m a +parseThrow errMsg val = + parseEither parseJSON val + & either + ( \err -> + fail . unpack $ + errMsg + <> "\n" + <> "Parser error was: " + <> "\n" + <> pack err + <> "\n" + <> "The actual JSON value was: " + <> jsonToText val + ) + pure + +parseObjectEither :: (FromJSON a) => Object -> Either Text a +parseObjectEither = first pack . parseEither parseJSON . Object + +parseObjectMaybe :: (FromJSON a) => Object -> Maybe a +parseObjectMaybe = parseMaybe parseJSON . Object + +aesonConstructorName :: Value -> Text +aesonConstructorName = \case + Object _ -> "Object" + Array _ -> "Array" + String _ -> "String" + Number _ -> "Number" + Bool _ -> "Bool" + Null -> "Null" + +asObject :: (ToJSON a) => Text -> a -> Parser A.Object +asObject errMsg val = + let val' = A.toJSON val + in case val' of + Object obj -> pure obj + _ -> + fail . unpack $ + errMsg + <> "\n" + <> "JSON Value must be of JSON type: Object" + <> "\n" + <> "The actual JSON type was: " + <> aesonConstructorName val' + <> "\n" + <> "The actual JSON value was: " + <> jsonToText val' + +objectOrThrow :: (ToJSON a) => Text -> a -> A.Object +objectOrThrow errMsg val = + case result of + Error e -> error . unpack $ errMsg <> "\n" <> "Error was: " <> pack e + Success o -> o + where + result = parse (asObject errMsg) $ A.toJSON val + +lowerFirst :: String -> String +lowerFirst = \case + c : cs -> toLower c : cs + [] -> [] + +lwrFirstOptions :: Options +lwrFirstOptions = + defaultOptions + { constructorTagModifier = lowerFirst + } + +enumCamelCase :: (Generic a, A.GToJSON' Value A.Zero (Rep a)) => a -> Value +enumCamelCase = A.genericToJSON lwrFirstOptions + +fromJSONCamelCase :: (Generic a, A.GFromJSON A.Zero (Rep a)) => Value -> Parser a +fromJSONCamelCase = A.genericParseJSON lwrFirstOptions + +-- https://blog.ssanj.net/posts/2019-09-24-pretty-printing-json-in-haskell.html +lsbToText :: LBS.ByteString -> Text +lsbToText = decodeUtf8 . LBS.toStrict + +objToString :: Object -> String +objToString = unpack . objToText + +objToText :: Object -> Text +objToText = jsonToText . Object + +jsonToText :: Value -> Text +jsonToText = lsbToText . encodePretty + +prettyJSON :: Text -> Value -> IO Text +prettyJSON msg v = do + r <- try @SomeException @_ (pure (jsonToText v)) + let jTxt = either (pack . displayException) id r + pure $ msg <> "\n" <> jTxt + + +parseJson :: Text -> Either String Value +parseJson input = + eitherDecodeStrict (encodeUtf8 input) + +bodyText' :: Result Value -> Key -> Result Text +bodyText' v k = v >>= lookupTxt k + +aesonTypeErrorMessage :: Text -> Value -> Text +aesonTypeErrorMessage t v = "Expected JSON Value to be of type: " <> t <> "\nbut got:\n" <> jsonToText v + +aesonTypeError :: Text -> Value -> Result a +aesonTypeError t v = Error . unpack $ aesonTypeErrorMessage t v + +jsonPrettyString :: Value -> String +jsonPrettyString = unpack . jsonToText + +lookupTxt :: Key -> Value -> Result Text +lookupTxt k v = lookup k v >>= asText + +lookup :: Key -> Value -> Result Value +lookup k v = + v & \case + Object o -> AKM.lookup k o & maybe (Error ("the key: " <> show k <> "does not exist in the object:\n" <> jsonPrettyString v)) pure + _ -> aesonTypeError "Object" v + +nonEmpty :: Value -> Bool +nonEmpty = not . empty + +emptyObj :: Value +emptyObj = Object AKM.empty + +empty :: Value -> Bool +empty = \case + Object o -> AKM.null o + Array a -> null a + String t -> T.null t + Null -> True + Bool _ -> False + Number _ -> False + +forceNonEmpty :: Value -> Maybe Value +forceNonEmpty v = + if empty v + then Nothing + else Just v + +parseOpt :: forall a. (FromJSON a) => A.Object -> Key -> Parser (Maybe a) +parseOpt o k = do + mv <- o .:? k + case mv >>= forceNonEmpty of + Nothing -> pure Nothing + Just v -> Just <$> A.parseJSON v + +subtractProps :: [Text] -> Object -> Object +subtractProps keys obj = AKM.filterWithKey (\k _ -> k `S.notMember` excludeSet) obj + where + excludeSet = S.fromList $ fromString . unpack <$> keys + +addProps :: Text -> [Pair] -> Value -> Value +addProps errMsg ps v = + object $ ps <> KeyMap.toList (objectOrThrow errMsg v) diff --git a/utils/Utils.hs b/utils/Utils.hs new file mode 100644 --- /dev/null +++ b/utils/Utils.hs @@ -0,0 +1,38 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Utils + ( txt, + enumerate, + -- shared path elements + UrlPath (..), + db + ) +where + +-- debugging only remove brefore release + +import Data.Text (Text, pack, unpack) +import Debug.Trace (trace) +import Text.Show.Pretty qualified as P + +{- + this module is used between the library and testing modules + it will be removed in a later release +-} + +-- general utils + +txt :: (Show a) => a -> Text +txt = pack . P.ppShow + +enumerate :: (Enum a, Bounded a) => [a] +enumerate = [minBound ..] + +-- shared path elements +newtype UrlPath = MkUrlPath {segments :: [Text]} + deriving newtype (Show, Eq, Ord, Semigroup) + +-- debugging + +db :: (Show a) => Text -> a -> a +db label value = trace (unpack $ label <> ":\n" <> txt value) value diff --git a/webdriver-precore.cabal b/webdriver-precore.cabal --- a/webdriver-precore.cabal +++ b/webdriver-precore.cabal @@ -1,7 +1,7 @@ -cabal-version: 3.8 +cabal-version: 3.12 name: webdriver-precore -version: 0.1.0.2 +version: 0.2.0.0 homepage: https://github.com/pyrethrum/webdriver-precore#readme bug-reports: https://github.com/pyrethrum/webdriver-precore/issues author: John Walker, Adrian Glouftsis @@ -11,32 +11,26 @@ license: BSD-3-Clause license-file: LICENSE build-type: Simple --- after 3.10 --- extra-doc-files: --- README.md --- ChangeLog.md -extra-source-files: + +extra-doc-files: README.md ChangeLog.md + tested-with: GHC == { 9.8.2, 9.8.4, 9.10.1 } - -synopsis: A typed wrapper for W3C WebDriver protocol. A base for other libraries. +synopsis: A typed wrapper for W3C WebDriver (HTTP and BiDi) protocols. description: - This library provides typed definitions for the endpoints of the @@. + This library provides typed definitions for the WebDriver W3C spec, both @@ and @@. - It is intended to be used as a base for other libraries that provide a WebDriver client implementation and higher level functions. - - A WebDriver client implementation can be built by pattern matching on the 'W3Spec' type returned by the functions in this library, - sending the corresponding HTTP requests to a vendor provided WebDriver, then parsing the response using the parser provided as part - of the 'W3Spec' type. + It is designed as a foundation for building WebDriver client libraries providing type-safe endpoint definitions and response parsers without any client implementation. - See "WebDriverPreCore" for further details and [the project repo](https://github.com/pyrethrum/webdriver) for [examples](https://github.com/pyrethrum/webdriver/blob/main/webdriver-examples/README.md) . - If you are looking for a fully implemented web client library, you should check out an alternative such as [haskell-webdriver](https://github.com/haskell-webdriver/haskell-webdriver#readme). - + __For complete documentation, module organisation, and migration guides, see "WebDriverPreCore".__ + + See also the @@ and the test directory for @@. + common commonExtensions default-extensions: AllowAmbiguousTypes @@ -71,7 +65,6 @@ MultiWayIf NamedFieldPuns NoFieldSelectors - NoImplicitPrelude NumericUnderscores OverloadedStrings OverloadedRecordDot @@ -106,25 +99,71 @@ -fno-warn-type-defaults -fno-warn-unused-do-bind -Wno-overlapping-patterns - -fprefer-byte-code - -fbyte-code-and-object-code - -haddock + -Wno-deprecations + -fbyte-code-and-object-code -- -fdefer-type-errors + cpp-options: + -DHTMLSpecURL=https://www.w3.org/TR/2025/WD-webdriver2-20251028/ + -DBiDiSpecURL=https://www.w3.org/TR/2026/WD-webdriver-bidi-20260109/ +library utils-internal + import: commonExtensions, commonGhcOptions + exposed-modules: + AesonUtils + Utils + hs-source-dirs: utils + build-depends: + base >=4.16 && <5, + aeson >=1.4 && <2.3, + aeson-pretty >=0.8 && <0.9, + bytestring >=0.10 && <0.12.3, + text >=2.1 && <2.2, + containers >=0.6 && <0.9, + pretty-show ^>=1.10 + default-language: Haskell2010 + library import: commonExtensions, commonGhcOptions exposed-modules: + -- Main documentation module WebDriverPreCore - WebDriverPreCore.Internal.Utils + -- BiDi + WebDriverPreCore.BiDi.API + WebDriverPreCore.BiDi.Protocol + -- HTTP + WebDriverPreCore.HTTP.API + WebDriverPreCore.HTTP.Protocol + -- Deprecated (to be removed ~ 2027-02-01) + WebDriverPreCore.Http + WebDriverPreCore.HTTP.SpecDefinition + WebDriverPreCore.HTTP.HttpResponse other-modules: - WebDriverPreCore.SpecDefinition - WebDriverPreCore.Capabilities + -- Shared + WebDriverPreCore.Internal.HTTPBidiCommon + -- HTTP + WebDriverPreCore.HTTP.Capabilities + WebDriverPreCore.HTTP.Command + -- BiDI + WebDriverPreCore.BiDi.Browser + WebDriverPreCore.BiDi.BrowsingContext + WebDriverPreCore.BiDi.Capabilities + WebDriverPreCore.BiDi.Command + WebDriverPreCore.BiDi.CoreTypes + WebDriverPreCore.BiDi.Emulation + WebDriverPreCore.BiDi.Event + WebDriverPreCore.BiDi.Log + WebDriverPreCore.BiDi.Input + WebDriverPreCore.BiDi.Network + WebDriverPreCore.BiDi.Script + WebDriverPreCore.BiDi.Session + WebDriverPreCore.BiDi.Storage + WebDriverPreCore.BiDi.WebExtensions + -- Shared WebDriverPreCore.Error - WebDriverPreCore.HttpResponse hs-source-dirs: src build-depends: + webdriver-precore:utils-internal, aeson >=1.4 && <2.3, - aeson-pretty >=0.8 && <0.9, base >=4.16 && <5, bytestring >=0.10 && <0.12.3, text >=2.1 && <2.2, @@ -132,29 +171,96 @@ vector >=0.12 && <0.14 default-language: Haskell2010 +flag legacy-test + description: Use legacy deprecated HTTP test implementations + default: False + manual: True + +flag debug-local-config + description: Use local debug configuration (ignore Dhall file in test/.config) + default: False + manual: True + test-suite test import: commonExtensions, commonGhcOptions + if flag(legacy-test) + cpp-options: -DLEGACY_TEST + if flag(debug-local-config) + cpp-options: -DDEBUG_LOCAL_CONFIG type: exitcode-stdio-1.0 - main-is: Driver.hs + main-is: Test.hs hs-source-dirs: test build-depends: - , aeson + aeson + , webdriver-precore:utils-internal , base + , base64 + , bytestring , containers + , dhall + , directory >=1.3 && <1.4 + , falsify + , filepath , ghc - , pretty-show - , text + , network + , pretty-show ^>=1.10 + , raw-strings-qq + , req , tasty , tasty-hunit - , tasty-quickcheck - , tasty-discover - , falsify + , time + , text + , unliftio , webdriver-precore - , raw-strings-qq + , websockets other-modules: - ApiCoverageTest, - ErrorCoverageTest, - JSONParsingTest, - build-tool-depends: - tasty-discover:tasty-discover + -- true unit/property tests + ApiCoverageTest + , ErrorCoverageTest + , JSONParsingTest + -- demos + , Config + , ConfigLoader + , Const + , IOUtils + , Logger + , TestData + , TestServerAPI + , HTTP.Runner + , HTTP.HttpClient + , HTTP.Actions + , HTTP.HttpActionsDeprecated + , HTTP.DemoUtils + , HTTP.HttpDemo + , HTTP.ErrorDemo + , HTTP.FallbackDemo + , BiDi.Runner + , BiDi.Response + , BiDi.Socket + , BiDi.Actions + , BiDi.DemoUtils + , BiDi.BiDiUrl + , BiDi.ErrorDemo + , BiDi.Demos.BrowserDemos + , BiDi.Demos.BrowsingContextDemos + , BiDi.Demos.BrowsingContextEventDemos + , BiDi.Demos.EmulationDemos + , BiDi.Demos.FallbackDemos + , BiDi.Demos.InputDemos + , BiDi.Demos.InputEventDemos + , BiDi.Demos.LogEventDemos + , BiDi.Demos.NetworkDemos + , BiDi.Demos.NetworkEventDemos + , BiDi.Demos.NetworkSupportTest + , BiDi.Demos.OtherDemos + , BiDi.Demos.ScriptDemos + , BiDi.Demos.ScriptEventDemos + , BiDi.Demos.SessionDemos + , BiDi.Demos.StorageDemos + , BiDi.Demos.WebExtensionDemos + , RuntimeConst + , HTTP.HttpRunnerDeprecated + if flag(debug-local-config) + other-modules: + DebugConfig default-language: Haskell2010