marionette (empty) → 1.0.0
raw patch · 22 files changed
+2637/−0 lines, 22 filesdep +aesondep +basedep +base64-bytestringsetup-changed
Dependencies added: aeson, base, base64-bytestring, binary, binary-parsers, bytestring, containers, exceptions, hashable, hspec, hspec-expectations-lifted, http-types, lucid2, marionette, mtl, network, network-simple, retry, text, typed-process, unliftio, wai, warp
Files
- CHANGELOG.md +12/−0
- LICENCE +287/−0
- Setup.hs +2/−0
- marionette.cabal +122/−0
- src/Test/Marionette.hs +114/−0
- src/Test/Marionette/AccessibilityProperties.hs +15/−0
- src/Test/Marionette/Class.hs +39/−0
- src/Test/Marionette/Client.hs +223/−0
- src/Test/Marionette/Commands.hs +878/−0
- src/Test/Marionette/Context.hs +19/−0
- src/Test/Marionette/Cookie.hs +21/−0
- src/Test/Marionette/Element.hs +42/−0
- src/Test/Marionette/Frame.hs +27/−0
- src/Test/Marionette/Orientation.hs +18/−0
- src/Test/Marionette/Protocol.hs +130/−0
- src/Test/Marionette/Rect.hs +14/−0
- src/Test/Marionette/Registry.hs +20/−0
- src/Test/Marionette/Selector.hs +55/−0
- src/Test/Marionette/Timeouts.hs +16/−0
- src/Test/Marionette/WebAuthn.hs +53/−0
- src/Test/Marionette/Window.hs +53/−0
- test/Main.hs +477/−0
+ CHANGELOG.md view
@@ -0,0 +1,12 @@+# Changelog++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/),+and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/).++## [1.0.0] - 2026-07-14++### Added++- Initial release.
+ LICENCE view
@@ -0,0 +1,287 @@+ EUROPEAN UNION PUBLIC LICENCE v. 1.2+ EUPL © the European Union 2007, 2016++This European Union Public Licence (the ‘EUPL’) applies to the Work (as defined+below) which is provided under the terms of this Licence. Any use of the Work,+other than as authorised under this Licence is prohibited (to the extent such+use is covered by a right of the copyright holder of the Work).++The Work is provided under the terms of this Licence when the Licensor (as+defined below) has placed the following notice immediately following the+copyright notice for the Work:++ Licensed under the EUPL++or has expressed by any other means his willingness to license under the EUPL.++1. Definitions++In this Licence, the following terms have the following meaning:++- ‘The Licence’: this Licence.++- ‘The Original Work’: the work or software distributed or communicated by the+ Licensor under this Licence, available as Source Code and also as Executable+ Code as the case may be.++- ‘Derivative Works’: the works or software that could be created by the+ Licensee, based upon the Original Work or modifications thereof. This Licence+ does not define the extent of modification or dependence on the Original Work+ required in order to classify a work as a Derivative Work; this extent is+ determined by copyright law applicable in the country mentioned in Article 15.++- ‘The Work’: the Original Work or its Derivative Works.++- ‘The Source Code’: the human-readable form of the Work which is the most+ convenient for people to study and modify.++- ‘The Executable Code’: any code which has generally been compiled and which is+ meant to be interpreted by a computer as a program.++- ‘The Licensor’: the natural or legal person that distributes or communicates+ the Work under the Licence.++- ‘Contributor(s)’: any natural or legal person who modifies the Work under the+ Licence, or otherwise contributes to the creation of a Derivative Work.++- ‘The Licensee’ or ‘You’: any natural or legal person who makes any usage of+ the Work under the terms of the Licence.++- ‘Distribution’ or ‘Communication’: any act of selling, giving, lending,+ renting, distributing, communicating, transmitting, or otherwise making+ available, online or offline, copies of the Work or providing access to its+ essential functionalities at the disposal of any other natural or legal+ person.++2. Scope of the rights granted by the Licence++The Licensor hereby grants You a worldwide, royalty-free, non-exclusive,+sublicensable licence to do the following, for the duration of copyright vested+in the Original Work:++- use the Work in any circumstance and for all usage,+- reproduce the Work,+- modify the Work, and make Derivative Works based upon the Work,+- communicate to the public, including the right to make available or display+ the Work or copies thereof to the public and perform publicly, as the case may+ be, the Work,+- distribute the Work or copies thereof,+- lend and rent the Work or copies thereof,+- sublicense rights in the Work or copies thereof.++Those rights can be exercised on any media, supports and formats, whether now+known or later invented, as far as the applicable law permits so.++In the countries where moral rights apply, the Licensor waives his right to+exercise his moral right to the extent allowed by law in order to make effective+the licence of the economic rights here above listed.++The Licensor grants to the Licensee royalty-free, non-exclusive usage rights to+any patents held by the Licensor, to the extent necessary to make use of the+rights granted on the Work under this Licence.++3. Communication of the Source Code++The Licensor may provide the Work either in its Source Code form, or as+Executable Code. If the Work is provided as Executable Code, the Licensor+provides in addition a machine-readable copy of the Source Code of the Work+along with each copy of the Work that the Licensor distributes or indicates, in+a notice following the copyright notice attached to the Work, a repository where+the Source Code is easily and freely accessible for as long as the Licensor+continues to distribute or communicate the Work.++4. Limitations on copyright++Nothing in this Licence is intended to deprive the Licensee of the benefits from+any exception or limitation to the exclusive rights of the rights owners in the+Work, of the exhaustion of those rights or of other applicable limitations+thereto.++5. Obligations of the Licensee++The grant of the rights mentioned above is subject to some restrictions and+obligations imposed on the Licensee. Those obligations are the following:++Attribution right: The Licensee shall keep intact all copyright, patent or+trademarks notices and all notices that refer to the Licence and to the+disclaimer of warranties. The Licensee must include a copy of such notices and a+copy of the Licence with every copy of the Work he/she distributes or+communicates. The Licensee must cause any Derivative Work to carry prominent+notices stating that the Work has been modified and the date of modification.++Copyleft clause: If the Licensee distributes or communicates copies of the+Original Works or Derivative Works, this Distribution or Communication will be+done under the terms of this Licence or of a later version of this Licence+unless the Original Work is expressly distributed only under this version of the+Licence — for example by communicating ‘EUPL v. 1.2 only’. The Licensee+(becoming Licensor) cannot offer or impose any additional terms or conditions on+the Work or Derivative Work that alter or restrict the terms of the Licence.++Compatibility clause: If the Licensee Distributes or Communicates Derivative+Works or copies thereof based upon both the Work and another work licensed under+a Compatible Licence, this Distribution or Communication can be done under the+terms of this Compatible Licence. For the sake of this clause, ‘Compatible+Licence’ refers to the licences listed in the appendix attached to this Licence.+Should the Licensee's obligations under the Compatible Licence conflict with+his/her obligations under this Licence, the obligations of the Compatible+Licence shall prevail.++Provision of Source Code: When distributing or communicating copies of the Work,+the Licensee will provide a machine-readable copy of the Source Code or indicate+a repository where this Source will be easily and freely available for as long+as the Licensee continues to distribute or communicate the Work.++Legal Protection: This Licence does not grant permission to use the trade names,+trademarks, service marks, or names of the Licensor, except as required for+reasonable and customary use in describing the origin of the Work and+reproducing the content of the copyright notice.++6. Chain of Authorship++The original Licensor warrants that the copyright in the Original Work granted+hereunder is owned by him/her or licensed to him/her and that he/she has the+power and authority to grant the Licence.++Each Contributor warrants that the copyright in the modifications he/she brings+to the Work are owned by him/her or licensed to him/her and that he/she has the+power and authority to grant the Licence.++Each time You accept the Licence, the original Licensor and subsequent+Contributors grant You a licence to their contributions to the Work, under the+terms of this Licence.++7. Disclaimer of Warranty++The Work is a work in progress, which is continuously improved by numerous+Contributors. It is not a finished work and may therefore contain defects or+‘bugs’ inherent to this type of development.++For the above reason, the Work is provided under the Licence on an ‘as is’ basis+and without warranties of any kind concerning the Work, including without+limitation merchantability, fitness for a particular purpose, absence of defects+or errors, accuracy, non-infringement of intellectual property rights other than+copyright as stated in Article 6 of this Licence.++This disclaimer of warranty is an essential part of the Licence and a condition+for the grant of any rights to the Work.++8. Disclaimer of Liability++Except in the cases of wilful misconduct or damages directly caused to natural+persons, the Licensor will in no event be liable for any direct or indirect,+material or moral, damages of any kind, arising out of the Licence or of the use+of the Work, including without limitation, damages for loss of goodwill, work+stoppage, computer failure or malfunction, loss of data or any commercial+damage, even if the Licensor has been advised of the possibility of such damage.+However, the Licensor will be liable under statutory product liability laws as+far such laws apply to the Work.++9. Additional agreements++While distributing the Work, You may choose to conclude an additional agreement,+defining obligations or services consistent with this Licence. However, if+accepting obligations, You may act only on your own behalf and on your sole+responsibility, not on behalf of the original Licensor or any other Contributor,+and only if You agree to indemnify, defend, and hold each Contributor harmless+for any liability incurred by, or claims asserted against such Contributor by+the fact You have accepted any warranty or additional liability.++10. Acceptance of the Licence++The provisions of this Licence can be accepted by clicking on an icon ‘I agree’+placed under the bottom of a window displaying the text of this Licence or by+affirming consent in any other similar way, in accordance with the rules of+applicable law. Clicking on that icon indicates your clear and irrevocable+acceptance of this Licence and all of its terms and conditions.++Similarly, you irrevocably accept this Licence and all of its terms and+conditions by exercising any rights granted to You by Article 2 of this Licence,+such as the use of the Work, the creation by You of a Derivative Work or the+Distribution or Communication by You of the Work or copies thereof.++11. Information to the public++In case of any Distribution or Communication of the Work by means of electronic+communication by You (for example, by offering to download the Work from a+remote location) the distribution channel or media (for example, a website) must+at least provide to the public the information requested by the applicable law+regarding the Licensor, the Licence and the way it may be accessible, concluded,+stored and reproduced by the Licensee.++12. Termination of the Licence++The Licence and the rights granted hereunder will terminate automatically upon+any breach by the Licensee of the terms of the Licence.++Such a termination will not terminate the licences of any person who has+received the Work from the Licensee under the Licence, provided such persons+remain in full compliance with the Licence.++13. Miscellaneous++Without prejudice of Article 9 above, the Licence represents the complete+agreement between the Parties as to the Work.++If any provision of the Licence is invalid or unenforceable under applicable+law, this will not affect the validity or enforceability of the Licence as a+whole. Such provision will be construed or reformed so as necessary to make it+valid and enforceable.++The European Commission may publish other linguistic versions or new versions of+this Licence or updated versions of the Appendix, so far this is required and+reasonable, without reducing the scope of the rights granted by the Licence. New+versions of the Licence will be published with a unique version number.++All linguistic versions of this Licence, approved by the European Commission,+have identical value. Parties can take advantage of the linguistic version of+their choice.++14. Jurisdiction++Without prejudice to specific agreement between parties,++- any litigation resulting from the interpretation of this License, arising+ between the European Union institutions, bodies, offices or agencies, as a+ Licensor, and any Licensee, will be subject to the jurisdiction of the Court+ of Justice of the European Union, as laid down in article 272 of the Treaty on+ the Functioning of the European Union,++- any litigation arising between other parties and resulting from the+ interpretation of this License, will be subject to the exclusive jurisdiction+ of the competent court where the Licensor resides or conducts its primary+ business.++15. Applicable Law++Without prejudice to specific agreement between parties,++- this Licence shall be governed by the law of the European Union Member State+ where the Licensor has his seat, resides or has his registered office,++- this licence shall be governed by Belgian law if the Licensor has no seat,+ residence or registered office inside a European Union Member State.++Appendix++‘Compatible Licences’ according to Article 5 EUPL are:++- GNU General Public License (GPL) v. 2, v. 3+- GNU Affero General Public License (AGPL) v. 3+- Open Software License (OSL) v. 2.1, v. 3.0+- Eclipse Public License (EPL) v. 1.0+- CeCILL v. 2.0, v. 2.1+- Mozilla Public Licence (MPL) v. 2+- GNU Lesser General Public Licence (LGPL) v. 2.1, v. 3+- Creative Commons Attribution-ShareAlike v. 3.0 Unported (CC BY-SA 3.0) for+ works other than software+- European Union Public Licence (EUPL) v. 1.1, v. 1.2+- Québec Free and Open-Source Licence — Reciprocity (LiLiQ-R) or Strong+ Reciprocity (LiLiQ-R+).++The European Commission may update this Appendix to later versions of the above+licences without producing a new version of the EUPL, as long as they provide+the rights granted in Article 2 of this Licence and protect the covered Source+Code from exclusive appropriation.++All other changes or additions to this Appendix require the production of a new+EUPL version.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ marionette.cabal view
@@ -0,0 +1,122 @@+cabal-version: 3.0+name: marionette+version: 1.0.0+category: Web+synopsis: Marionette protocol for Firefox+description:+ Marionette is an automation driver for Mozilla’s Gecko engine. It can remotely control either the UI or the internal JavaScript of a Gecko platform, such as Firefox. It can control both the chrome (i.e. menus and functions) or the content (the webpage loaded inside the browsing context), giving a high level of control and ability to replicate user actions. In addition to performing actions on the browser, Marionette can also read the properties and attributes of the DOM.++ If this sounds similar to <https://dvcs.w3.org/hg/webdriver/raw-file/tip/webdriver-spec.html Selenium/WebDriver> then you’re correct! Marionette shares much of the same ethos and API as Selenium/WebDriver, with additional commands to interact with Gecko’s chrome interface. Its goal is to replicate what Selenium does for web content: to enable the tester to have the ability to send commands to remotely control a user agent.++license: EUPL-1.2+license-file: LICENCE+author: IDA+maintainer: IDA+homepage: https://digital-autonomy.institute+bug-reports: https://issues.digital-autonomy.institute+build-type: Simple+extra-doc-files:+ CHANGELOG.md++common common+ default-language: Haskell2010+ ghc-options:+ -Weverything+ -Wno-unsafe+ -Wno-missing-safe-haskell-mode+ -Wno-missing-export-lists+ -Wno-missing-import-lists+ -Wno-missing-kind-signatures+ -Wno-all-missed-specialisations+ -Wno-missing-role-annotations++ default-extensions:+ ApplicativeDo+ BlockArguments+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ ExplicitNamespaces+ FlexibleContexts+ FlexibleInstances+ GeneralisedNewtypeDeriving+ ImportQualifiedPost+ InstanceSigs+ LambdaCase+ MultiParamTypeClasses+ NamedFieldPuns+ NoImplicitPrelude+ NumericUnderscores+ OverloadedLabels+ OverloadedRecordDot+ OverloadedStrings+ RecordWildCards+ RecursiveDo+ ScopedTypeVariables+ Trustworthy+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ ViewPatterns++ build-depends:+ aeson >=2.2 && <2.3,+ base >=4.16 && <5,+ bytestring >=0.12 && <0.13,+ text >=2.1 && <2.2,++library+ import: common+ hs-source-dirs: src+ build-depends:+ base64-bytestring >=1.2 && <1.3,+ binary >=0.8 && <0.9,+ binary-parsers >=0.2 && <0.3,+ containers >=0.7 && <0.8,+ exceptions >=0.10 && <0.11,+ hashable >=1.5 && <1.6,+ mtl >=2.3 && <2.4,+ network >=3.2 && <3.3,+ network-simple >=0.4.5 && <0.5,+ retry >=0.9 && <0.10,+ unliftio >=0.2 && <0.3,++ exposed-modules:+ Test.Marionette+ Test.Marionette.AccessibilityProperties+ Test.Marionette.Class+ Test.Marionette.Client+ Test.Marionette.Commands+ Test.Marionette.Context+ Test.Marionette.Cookie+ Test.Marionette.Element+ Test.Marionette.Frame+ Test.Marionette.Orientation+ Test.Marionette.Protocol+ Test.Marionette.Rect+ Test.Marionette.Registry+ Test.Marionette.Selector+ Test.Marionette.Timeouts+ Test.Marionette.WebAuthn+ Test.Marionette.Window++test-suite marionette-test+ import: common+ type: exitcode-stdio-1.0+ ghc-options: -threaded+ hs-source-dirs: test+ main-is: Main.hs+ build-depends:+ hspec >=2.11 && <2.12,+ hspec-expectations-lifted >=0.10 && <0.11,+ http-types >=0.12 && <0.13,+ lucid2 >=0.0 && <0.1,+ marionette,+ typed-process >=0.2 && <0.3,+ wai >=3.2 && <3.3,+ warp >=3.4 && <3.5,
+ src/Test/Marionette.hs view
@@ -0,0 +1,114 @@+-- |+-- Module : Test.Marionette+-- Copyright : (c) 2026 Institute for Digital Autonomy+-- License : EUPL-1.2+-- Maintainer : IDA+--+-- <https://firefox-source-docs.mozilla.org/testing/marionette/ Marionette> is+-- Firefox's built-in remote-control protocol. It plays the same role as a+-- <https://www.w3.org/TR/webdriver/ WebDriver> server, letting a test suite+-- drive a real Firefox instance to navigate, find and interact with+-- elements, execute scripts, and so on. In addition to WebDriver functionality,+-- Marionette can also address Firefox's own chrome (its menus and toolbars)+-- rather than just the content of a web page, and speaks its own lightweight+-- length-prefixed JSON protocol directly over a TCP socket instead of+-- HTTP.+--+-- This library provides 'Marionette', a typeclass for sending commands to a+-- running Firefox process, as well as an implementation of every Marionette+-- and WebDriver command.+-- A concrete implementation can be found in 'MarionetteT'/'runMarionetteT'.+--+-- = How to use Marionette+--+-- == Starting Firefox and a session+--+-- Launch Firefox with the @--marionette@ flag so that it listens for+-- connections on port 2828.+--+-- Use 'runMarionetteT' to connect to it and run a client program.+-- Start a new session with 'newSession', and quit the session with 'quit':+--+-- > import System.Process.Typed+-- > import Test.Marionette+-- >+-- > main :: IO ()+-- > main =+-- > withProcessTerm_ (proc "firefox" ["--marionette", "--headless"]) $ \_process ->+-- > runMarionetteT $ do+-- > newSession+-- > -- More Marionette actions go here+-- > quit+--+-- Most Marionette actions need to be performed in a session.+--+-- == Finding and interacting with elements+--+-- Find elements by calling 'findElement' with a 'Selector',+-- then pass the resulting 'Element' to other commands:+--+-- > submitForm :: (HasCallStack, Marionette m) => m ()+-- > submitForm = do+-- > input <- findElement (ById "text-input")+-- > elementSendKeys input "hello, world"+-- > submit <- findElement (ByCSS "button[type=submit]")+-- > elementClick submit+--+-- == Error handling+--+-- Catch command failures via 'MonadError',+-- for example to retry a command against a fallback element:+--+-- > import Control.Monad.Error.Class (catchError)+-- >+-- > clickFirstAvailable :: (HasCallStack, Marionette m) => m ()+-- > clickFirstAvailable =+-- > (elementClick =<< findElement (ById "primary-button"))+-- > `catchError` \_ -> elementClick =<< findElement (ById "fallback-button")+module Test.Marionette+ ( module Test.Marionette.Class+ , module Test.Marionette.Client+ , module Test.Marionette.Commands+ , module Test.Marionette.Cookie+ , module Test.Marionette.Context+ , module Test.Marionette.Frame+ , module Test.Marionette.Element+ , module Test.Marionette.Orientation+ , module Test.Marionette.Protocol+ , module Test.Marionette.Rect+ , module Test.Marionette.Registry+ , module Test.Marionette.Selector+ , module Test.Marionette.Timeouts+ , module Test.Marionette.WebAuthn+ , module Test.Marionette.Window+ )+where++import Test.Marionette.Class (Marionette)+import Test.Marionette.Client (MarionetteT, runMarionetteT)+import Test.Marionette.Commands+import Test.Marionette.Context (Context (..))+import Test.Marionette.Cookie (Cookie (Cookie))+import Test.Marionette.Element (Element, Shadow)+import Test.Marionette.Frame (Frame (..))+import Test.Marionette.Orientation (Orientation (..))+import Test.Marionette.Protocol (Error (Error))+import Test.Marionette.Rect (Rect (Rect))+import Test.Marionette.Registry (RegistryEntry (RegistryEntry))+import Test.Marionette.Selector+ ( Selector (..)+ , SelectorFrom (..)+ , SelectorFromShadowRoot (..)+ )+import Test.Marionette.Timeouts (Timeouts (Timeouts))+import Test.Marionette.WebAuthn+ ( AuthenticatorId+ , Credential (Credential)+ , CredentialId+ , VirtualAuthenticator (VirtualAuthenticator)+ )+import Test.Marionette.Window+ ( NewWindowResult (..)+ , WindowHandle+ , WindowType (..)+ )
+ src/Test/Marionette/AccessibilityProperties.hs view
@@ -0,0 +1,15 @@+module Test.Marionette.AccessibilityProperties where++import Data.Aeson.Types (FromJSON)+import Data.Text (Text)+import GHC.Generics (Generic)+import Prelude++data AccessibilityProperties = AccessibilityProperties+ { role :: Maybe Text+ , name :: Maybe Text+ , value :: Maybe Text+ , description :: Maybe Text+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (FromJSON)
+ src/Test/Marionette/Class.hs view
@@ -0,0 +1,39 @@+module Test.Marionette.Class where++import Control.Monad.Error.Class (MonadError)+import Data.Aeson (FromJSON, Value)+import Data.Functor (void)+import Data.Functor.Identity (Identity (..))+import GHC.Stack (HasCallStack)+import Test.Marionette.Protocol (Command, Error)+import UnliftIO (MonadUnliftIO, mapConcurrently)+import Prelude++-- | Monads with the ability to send commands to a Marionette server and receive their results.+class (Functor m, MonadError Error m) => Marionette m where+ -- | Send a single command, decoding its result.+ sendCommand :: (HasCallStack, FromJSON a) => Command -> m a+ sendCommand = fmap runIdentity . sendCommands . Identity++ -- | Send multiple commands, decoding each result.+ -- The commands may be sent in parallel.+ sendCommands+ :: (HasCallStack, Traversable t, FromJSON a)+ => t Command+ -> m (t a)+ default sendCommands+ :: (HasCallStack, MonadUnliftIO m, Traversable t, FromJSON a)+ => t Command+ -> m (t a)+ sendCommands = mapConcurrently sendCommand++ {-# MINIMAL sendCommand | sendCommands #-}++-- | Send a single command, discarding its result.+sendCommand_ :: (HasCallStack, Marionette m) => Command -> m ()+sendCommand_ = void . sendCommand @_ @Value++-- | Send several commands, discarding their results.+-- The commands may be sent in parallel.+sendCommands_ :: (HasCallStack, Traversable t, Marionette m) => t Command -> m ()+sendCommands_ = void . sendCommands @_ @_ @Value
+ src/Test/Marionette/Client.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Marionette.Client where++import Control.Exception (AssertionFailed (AssertionFailed))+import Control.Monad (void, when)+import Control.Monad.Catch+ ( Exception (..)+ , MonadCatch+ , MonadMask+ , MonadThrow+ , catch+ , catchAll+ , throwM+ )+import Control.Monad.Error.Class (MonadError (..))+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Reader (ReaderT (runReaderT))+import Control.Monad.Reader qualified as Reader+import Control.Monad.Reader.Class (MonadReader)+import Data.Aeson (AesonException (AesonException), FromJSON)+import Data.Aeson qualified as Aeson+import Data.Aeson.Types qualified as Aeson+import Data.Binary (Binary)+import Data.Binary qualified as Binary+import Data.Binary.Get qualified as Binary+import Data.ByteString (ByteString)+import Data.ByteString.Builder.Extra qualified as ByteString+import Data.IntMap.Strict qualified as IntMap+import Data.Maybe (isNothing)+import GHC.Stack (HasCallStack)+import Network.Simple.TCP+ ( HostName+ , ServiceName+ , SockAddr+ , Socket+ , closeSock+ , connectSock+ , sendLazy+ )+import Network.Socket.ByteString (recv)+import System.Timeout (timeout)+import Test.Marionette.Class (Marionette (..))+import Test.Marionette.Protocol+import UnliftIO+ ( MonadUnliftIO+ , TMVar+ , TQueue+ , async+ , bracket+ , isEmptyTMVar+ , link+ , readTMVar+ )+import UnliftIO.Concurrent (forkIO)+import UnliftIO.Retry (constantDelay, limitRetriesByCumulativeDelay, recoverAll)+import UnliftIO.STM+ ( atomically+ , modifyTVar'+ , newEmptyTMVarIO+ , newTQueueIO+ , newTVarIO+ , putTMVar+ , readTQueue+ , stateTVar+ , writeTQueue+ )+import Prelude hiding (log)++data SocketClosed = SocketClosed+ deriving stock (Show)+ deriving anyclass (Exception)++newtype DecodeError = DecodeError String+ deriving stock (Show)+ deriving anyclass (Exception)++incoming+ :: forall m a+ . (MonadUnliftIO m, MonadThrow m, Binary a)+ => Socket+ -> m (TQueue a)+incoming socket = do+ q <- newTQueueIO+ link =<< async (go (atomically . writeTQueue q) (newDecoder ""))+ pure q+ where+ newDecoder :: ByteString -> Binary.Decoder a+ newDecoder bs = Binary.runGetIncremental Binary.get `Binary.pushChunk` bs+ go _ (Binary.Fail _ _ err) = throwM . DecodeError $ err+ go f (Binary.Done rest _ a) = do+ f a+ go f $ newDecoder rest+ go f dec =+ go f . (dec `Binary.pushChunk`)+ =<< liftIO+ (recv socket ByteString.defaultChunkSize `catchAll` \_ -> throwM SocketClosed)++connect+ :: (MonadUnliftIO m)+ => HostName+ -> ServiceName+ -> ((Socket, SockAddr) -> m a)+ -> m a+connect host port =+ bracket+ ( recoverAll (limitRetriesByCumulativeDelay 5_000_000 $ constantDelay 50_000)+ . const+ $ connectSock host port+ )+ (closeSock . fst)++newtype MarionetteTimeout = MarionetteTimeout MarionetteMessage+ deriving stock (Show)+ deriving anyclass (Exception)++newtype UnexpectedResult = UnexpectedResult Result+ deriving stock (Show)+ deriving anyclass (Exception)++data CommandWithCallback = CommandWithCallback Command (TMVar Result)++-- | A monad transformer that speaks the Marionette wire protocol over a TCP+-- socket. Run it with 'runMarionetteT'.+newtype MarionetteT m a = MarionetteT (ReaderT (TQueue CommandWithCallback) m a)+ deriving newtype+ ( Functor+ , Applicative+ , Monad+ , MonadThrow+ , MonadCatch+ , MonadMask+ , MonadIO+ , MonadUnliftIO+ , MonadReader (TQueue CommandWithCallback)+ )++instance (MonadUnliftIO m, MonadThrow m, MonadCatch m) => Marionette (MarionetteT m) where+ sendCommand :: (HasCallStack, FromJSON a) => Command -> MarionetteT m a+ sendCommand command = do+ q <- Reader.ask+ result <- newEmptyTMVarIO+ atomically . writeTQueue q $ CommandWithCallback command result+ either throwM pure =<< parseResult =<< atomically (readTMVar result)+ where+ parseResult :: (FromJSON a) => Result -> MarionetteT m (Either Error a)+ parseResult =+ either (pure . Left) $+ either (throwM . AesonException) (pure . Right)+ . Aeson.parseEither Aeson.parseJSON++instance (MonadThrow m, MonadCatch m) => MonadError Error (MarionetteT m) where+ throwError = throwM+ catchError = catch++-- | Connect to a Marionette server listening on @localhost:2828@ (started+-- by launching Firefox with the @--marionette@ flag), and run the given+-- action against it.+runMarionetteT+ :: forall m a+ . (MonadUnliftIO m, MonadMask m)+ => MarionetteT m a+ -> m a+runMarionetteT action = do+ sendQueue :: TQueue CommandWithCallback <- newTQueueIO+ pendingCommands <- newTVarIO mempty+ done <- newEmptyTMVarIO+ let repeatUntilDone :: forall m'. (MonadIO m') => m' () -> m' ()+ repeatUntilDone a =+ atomically (isEmptyTMVar done) >>= \case+ False -> pure ()+ True -> a >> repeatUntilDone a+ handleIncoming :: MarionetteMessage -> MarionetteT m ()+ handleIncoming message =+ decodeMarionetteM message >>= \Message{..} ->+ atomically+ ( stateTVar pendingCommands $+ IntMap.updateLookupWithKey (\_ _ -> Nothing) messageId+ )+ >>= \case+ Nothing -> throwM . UnexpectedResult $ messageContent+ Just result -> atomically $ putTMVar result messageContent+ handleCommand :: Socket -> Int -> CommandWithCallback -> MarionetteT m ()+ handleCommand socket messageId (CommandWithCallback messageContent callback) = do+ let message = MarionetteMessage . Aeson.encode $ Message{..}+ liftIO . sendLazy socket . Binary.encode $ message+ forkIO do+ result <- liftIO . timeout 5_000_000 . atomically . readTMVar $ callback+ when (isNothing result) . throwM . MarionetteTimeout $ message+ atomically . modifyTVar' pendingCommands $+ IntMap.insert messageId callback+ runSocket :: MarionetteT m ()+ runSocket =+ connect "localhost" "2828" \(socket, _) -> do+ incomingQueue <- incoming socket+ void . decodeMarionetteM @_ @Greeting =<< atomically (readTQueue incomingQueue)+ let send messageId =+ atomically+ ( isEmptyTMVar done >>= \case+ True -> Just <$> readTQueue sendQueue+ False -> pure Nothing+ )+ >>= \case+ Nothing -> pure ()+ Just command -> do+ handleCommand socket messageId command+ send $ messageId + 1+ forkIO $ send 1+ forkIO . repeatUntilDone $ handleIncoming =<< atomically (readTQueue incomingQueue)+ atomically $ readTMVar done+ flip runReaderT sendQueue . (\(MarionetteT r) -> r) $ do+ forkIO runSocket+ a <- action+ atomically $ putTMVar done ()+ pure a+ where+ decodeMarionetteM :: forall m' a'. (MonadThrow m', FromJSON a') => MarionetteMessage -> m' a'+ decodeMarionetteM = either (throwM . AssertionFailed) pure . decodeMarionette++ decodeMarionette :: forall a'. (FromJSON a') => MarionetteMessage -> Either String a'+ decodeMarionette (MarionetteMessage lbs) = Aeson.eitherDecode lbs
+ src/Test/Marionette/Commands.hs view
@@ -0,0 +1,878 @@+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE UndecidableInstances #-}++module Test.Marionette.Commands where++import Data.Aeson+ ( FromJSON+ , KeyValue (..)+ , ToJSON (toJSON)+ , Value (..)+ )+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as Object+import Data.ByteString (ByteString)+import Data.ByteString.Base64 qualified as Base64+import Data.Foldable qualified as Foldable+import Data.Text+import Data.Text.Encoding qualified as Text+import GHC.Generics (Generic)+import GHC.Stack (HasCallStack)+import Test.Marionette.AccessibilityProperties (AccessibilityProperties)+import Test.Marionette.Class+import Test.Marionette.Context (Context)+import Test.Marionette.Cookie (Cookie)+import Test.Marionette.Element (Element (..), Shadow)+import Test.Marionette.Frame (Frame)+import Test.Marionette.Orientation (Orientation)+import Test.Marionette.Protocol+import Test.Marionette.Rect (Rect)+import Test.Marionette.Registry (RegistryEntry)+import Test.Marionette.Selector+ ( Selector+ , SelectorFrom (..)+ , SelectorFromShadowRoot (..)+ )+import Test.Marionette.Timeouts (Timeouts)+import Test.Marionette.WebAuthn+ ( AuthenticatorId (..)+ , Credential+ , CredentialId (..)+ , VirtualAuthenticator+ )+import Test.Marionette.Window+ ( NewWindowResult+ , WindowHandle (..)+ , WindowType (..)+ )+import Prelude hiding (log)++newtype ValueObject a = ValueObject {value :: a}+ deriving stock (Generic)+ deriving anyclass (FromJSON, ToJSON)++type role ValueObject representational++-- | Enable or disable accepting new socket connections.+-- This has no effect on existing connections.+acceptConnections :: (HasCallStack, Marionette m) => Bool -> m ()+acceptConnections value =+ sendCommand_+ Command+ { command = "Marionette:AcceptConnections"+ , parameters = Aeson.object ["value" .= value]+ }++-- | Look up accessibility properties of a node in the platform accessibility tree,+-- rather than by a web element reference.+getAccessibilityPropertiesForAccessibilityNode+ :: (HasCallStack, Marionette m)+ => Text+ -- ^ Node identifier @nodeId@+ -> m AccessibilityProperties+getAccessibilityPropertiesForAccessibilityNode nodeId =+ sendCommand+ Command+ { command = "Marionette:GetAccessibilityPropertiesForAccessibilityNode"+ , parameters = Aeson.object ["nodeId" .= nodeId]+ }++-- | Look up the accessibility properties exposed to assistive technology+-- (such as screen readers) for a given element.+getAccessibilityPropertiesForElement+ :: (HasCallStack, Marionette m)+ => Element+ -> m AccessibilityProperties+getAccessibilityPropertiesForElement Element{..} =+ sendCommand+ Command+ { command = "Marionette:GetAccessibilityPropertiesForElement"+ , parameters = Aeson.object ["id" .= elementId]+ }++-- | Return whether subsequent browsing-context-scoped commands (such as+-- 'navigate' or 'findElement') target privileged browser chrome or ordinary+-- web content.+-- New sessions start in the 'Content' context; use 'setContext' to switch,+-- for example when driving browser UI rather than a web page.+getContext :: (HasCallStack, Marionette m) => m Context+getContext = value <$> sendCommand "Marionette:GetContext"++-- | Return the current orientation of the browser window.+getScreenOrientation :: (HasCallStack, Marionette m) => m Orientation+getScreenOrientation = value <$> sendCommand "Marionette:GetScreenOrientation"++-- | Return the chrome window's @windowtype@ attribute, for example+-- @navigator:browser@ for a normal browser window.+getWindowType :: (HasCallStack, Marionette m) => m Text+getWindowType = value <$> sendCommand "Marionette:GetWindowType"++-- | Shut the browser down: Marionette first stops accepting new+-- connections, then ends the current session, and finally causes the+-- application itself to quit.+quit :: (HasCallStack, Marionette m) => m ()+quit = sendCommand_ "Marionette:Quit"++-- | Register a chrome protocol handler for a directory containing XHTML or+-- XUL files, allowing them to be loaded via the @chrome://@ protocol.+-- Return the identifier for the registered handler which can be unregistered+-- with 'unregisterChromeHandler'.+registerChromeHandler :: (HasCallStack, Marionette m) => Text -> [RegistryEntry] -> m Text+registerChromeHandler manifestPath entries =+ sendCommand+ Command+ { command = "Marionette:RegisterChromeHandler"+ , parameters =+ Aeson.object+ [ "manifestPath" .= manifestPath+ , "entries" .= entries+ ]+ }++-- | Set the context of the subsequent commands. All subsequent requests to+-- commands that in some way involve interaction with a browsing context+-- will target the chosen context.+setContext :: (HasCallStack, Marionette m) => Context -> m ()+setContext value =+ sendCommand_+ Command+ { command = "Marionette:SetContext"+ , parameters = Aeson.object ["value" .= value]+ }++-- | Set the current browser orientation.+setScreenOrientation :: (HasCallStack, Marionette m) => Orientation -> m ()+setScreenOrientation orientation =+ sendCommand_+ Command+ { command = "Marionette:SetScreenOrientation"+ , parameters = Aeson.object ["orientation" .= orientation]+ }++-- | Unregister a previously registered chrome protocol handler, given an+-- identifier returned by 'registerChromeHandler'.+unregisterChromeHandler :: (HasCallStack, Marionette m) => Text -> m ()+unregisterChromeHandler handlerId =+ sendCommand_+ Command+ { command = "Marionette:UnregisterChromeHandler"+ , parameters = Aeson.object ["id" .= handlerId]+ }++-- | Accept a currently displayed dialog modal, or throw if no modal is+-- displayed.+--+-- See <https://w3c.github.io/webdriver/#accept-alert>+acceptAlert :: (HasCallStack, Marionette m) => m ()+acceptAlert = sendCommand_ "WebDriver:AcceptAlert"++-- | Add a single cookie to the cookie store associated with the active+-- document's address.+--+-- See <https://w3c.github.io/webdriver/#add-cookie>+addCookie :: (HasCallStack, Marionette m) => Cookie -> m ()+addCookie cookie =+ sendCommand_+ Command+ { command = "WebDriver:AddCookie"+ , parameters = Aeson.object ["cookie" .= cookie]+ }++-- | Cause the browser to traverse one step backward in the joint history+-- of the current browsing context.+--+-- See <https://w3c.github.io/webdriver/#back>+back :: (HasCallStack, Marionette m) => m ()+back = sendCommand_ "WebDriver:Back"++-- | Close the currently selected chrome window. If it is the last window+-- currently open, the chrome window is not closed, to prevent an+-- application shutdown.+closeChromeWindow :: (HasCallStack, Marionette m) => m ()+closeChromeWindow = sendCommand_ "WebDriver:CloseChromeWindow"++-- | Close the currently selected tab or window. With multiple open tabs,+-- only the selected tab is closed; if it is the last window currently+-- open, the window is not closed, to prevent an application shutdown.+--+-- See <https://w3c.github.io/webdriver/#close-window>+closeWindow :: (HasCallStack, Marionette m) => m ()+closeWindow = sendCommand_ "WebDriver:CloseWindow"++-- | Delete all cookies that are visible to a document.+--+-- See <https://w3c.github.io/webdriver/#delete-all-cookies>+deleteAllCookies :: (HasCallStack, Marionette m) => m ()+deleteAllCookies = sendCommand_ "WebDriver:DeleteAllCookies"++-- | Delete a cookie by name.+--+-- See <https://w3c.github.io/webdriver/#delete-cookie>+deleteCookie :: (HasCallStack, Marionette m) => Text -> m ()+deleteCookie name =+ sendCommand_+ Command+ { command = "WebDriver:DeleteCookie"+ , parameters = Aeson.object ["name" .= name]+ }++-- | Delete the current WebDriver session.+--+-- See <https://w3c.github.io/webdriver/#delete-session>+deleteSession :: (HasCallStack, Marionette m) => m ()+deleteSession = sendCommand_ "WebDriver:DeleteSession"++-- | Dismiss a currently displayed modal dialog, or throw if no modal is+-- displayed.+--+-- See <https://w3c.github.io/webdriver/#dismiss-alert>+dismissAlert :: (HasCallStack, Marionette m) => m ()+dismissAlert = sendCommand_ "WebDriver:DismissAlert"++-- | Clear the text of an element.+--+-- See <https://w3c.github.io/webdriver/#element-clear>+elementClear :: (HasCallStack, Marionette m) => Element -> m ()+elementClear Element{..} =+ sendCommand_+ Command+ { command = "WebDriver:ElementClear"+ , parameters = Aeson.object ["id" .= elementId]+ }++-- | Send a click event to an element.+--+-- See <https://w3c.github.io/webdriver/#element-click>+elementClick :: (HasCallStack, Marionette m) => Element -> m ()+elementClick Element{..} =+ sendCommand_+ Command+ { command = "WebDriver:ElementClick"+ , parameters = Aeson.object ["id" .= elementId]+ }++-- | Send key presses to an element after focusing on it.+--+-- See <https://w3c.github.io/webdriver/#element-send-keys>+elementSendKeys :: (HasCallStack, Marionette m) => Element -> Text -> m ()+elementSendKeys Element{..} text =+ sendCommand_+ Command+ { command = "WebDriver:ElementSendKeys"+ , parameters =+ Aeson.object+ [ "id" .= elementId+ , "text" .= text+ ]+ }++-- | Execute a JavaScript function asynchronously in the context of the+-- current browsing context, and return the value passed to the callback,+-- which is always the last argument exposed to the script.+--+-- See <https://w3c.github.io/webdriver/#execute-async-script>+executeAsyncScript+ :: (HasCallStack, Marionette m, Foldable f, FromJSON a)+ => Text+ -> f Value+ -> m (Maybe a)+executeAsyncScript script args =+ fmap value . sendCommand $+ Command+ { command = "WebDriver:ExecuteAsyncScript"+ , parameters =+ Aeson.object+ [ "script" .= script+ , "args" .= Foldable.toList args+ ]+ }++-- | Execute a JavaScript function synchronously in the context of the+-- current browsing context, and return its return value.+--+-- See <https://w3c.github.io/webdriver/#execute-script>+executeScript :: (HasCallStack, Marionette m, Foldable f, FromJSON a) => Text -> f Value -> m a+executeScript script args =+ fmap value . sendCommand $+ Command+ { command = "WebDriver:ExecuteScript"+ , parameters =+ Aeson.object+ [ "script" .= script+ , "args" .= Foldable.toList args+ ]+ }++-- | Find an element using the given search strategy.+--+-- See <https://w3c.github.io/webdriver/#find-element>+findElement :: (HasCallStack, Marionette m) => Selector -> m Element+findElement selector =+ value+ <$> sendCommand+ Command+ { command = "WebDriver:FindElement"+ , parameters = toJSON selector+ }++-- | Find an element using the given search strategy, relative to the+-- given element.+--+-- See <https://w3c.github.io/webdriver/#find-element>+findElementFrom :: (HasCallStack, Marionette m) => Element -> Selector -> m Element+findElementFrom element selector =+ value+ <$> sendCommand+ Command+ { command = "WebDriver:FindElement"+ , parameters = toJSON $ SelectorFrom element selector+ }++-- | Find an element within a shadow root using the given search strategy.+--+-- See <https://w3c.github.io/webdriver/#find-element-from-shadow-root>+findElementFromShadowRoot :: (HasCallStack, Marionette m) => Shadow -> Selector -> m Element+findElementFromShadowRoot shadowRoot selector =+ value+ <$> sendCommand+ Command+ { command = "WebDriver:FindElementFromShadowRoot"+ , parameters = toJSON $ SelectorFromShadowRoot shadowRoot selector+ }++-- | Find elements using the given search strategy.+--+-- See <https://w3c.github.io/webdriver/#find-elements>+findElements :: (HasCallStack, Marionette m) => Selector -> m [Element]+findElements selector =+ sendCommand+ Command+ { command = "WebDriver:FindElements"+ , parameters = toJSON selector+ }++-- | Find elements using the given search strategy, relative to the given+-- element.+--+-- See <https://w3c.github.io/webdriver/#find-elements>+findElementsFrom :: (HasCallStack, Marionette m) => Element -> Selector -> m [Element]+findElementsFrom element selector =+ sendCommand+ Command+ { command = "WebDriver:FindElements"+ , parameters = toJSON (SelectorFrom element selector)+ }++-- | Find elements within a shadow root using the given search strategy.+--+-- See <https://w3c.github.io/webdriver/#find-elements-from-shadow-root>+findElementsFromShadowRoot :: (HasCallStack, Marionette m) => Shadow -> Selector -> m [Element]+findElementsFromShadowRoot shadowRoot selector =+ sendCommand+ Command+ { command = "WebDriver:FindElementsFromShadowRoot"+ , parameters = toJSON $ SelectorFromShadowRoot shadowRoot selector+ }++-- | Cause the browser to traverse one step forward in the joint history+-- of the current browsing context.+--+-- See <https://w3c.github.io/webdriver/#forward>+forward :: (HasCallStack, Marionette m) => m ()+forward = sendCommand_ "WebDriver:Forward"++-- | Set the window to full screen, as if the user had chosen+-- View -> Enter Full Screen. Not supported on Android.+--+-- See <https://w3c.github.io/webdriver/#fullscreen-window>+fullscreenWindow :: (HasCallStack, Marionette m) => m ()+fullscreenWindow = sendCommand_ "WebDriver:FullscreenWindow"++-- | Return the active element in the document.+--+-- See <https://w3c.github.io/webdriver/#get-active-element>+getActiveElement :: (HasCallStack, Marionette m) => m Element+getActiveElement = value <$> sendCommand "WebDriver:GetActiveElement"++-- | Return the message shown in a currently displayed modal, or throw if+-- no modal is displayed.+--+-- See <https://w3c.github.io/webdriver/#get-alert-text>+getAlertText :: (HasCallStack, Marionette m) => m Text+getAlertText = value <$> sendCommand "WebDriver:GetAlertText"++-- | Determine the accessibility label for an element.+--+-- See <https://w3c.github.io/webdriver/#get-computed-label>+getComputedLabel :: (HasCallStack, Marionette m) => Element -> m Text+getComputedLabel Element{..} =+ value+ <$> sendCommand+ Command+ { command = "WebDriver:GetComputedLabel"+ , parameters = Aeson.object ["id" .= elementId]+ }++-- | Determine the accessibility role for an element.+--+-- See <https://w3c.github.io/webdriver/#get-computed-role>+getComputedRole :: (HasCallStack, Marionette m) => Element -> m Text+getComputedRole Element{..} =+ value+ <$> sendCommand+ Command+ { command = "WebDriver:GetComputedRole"+ , parameters = Aeson.object ["id" .= elementId]+ }++-- | Get all the cookies for the current domain. Equivalent to calling+-- @document.cookie@ and parsing the result.+--+-- See <https://w3c.github.io/webdriver/#get-all-cookies>+getCookies :: (HasCallStack, Marionette m) => m [Cookie]+getCookies = sendCommand "WebDriver:GetCookies"++-- | Get a string representing the current URL, equivalent to+-- @document.location.href@. When in the chrome context, return the+-- canonical URL of the current resource.+--+-- See <https://w3c.github.io/webdriver/#get-current-url>+getCurrentURL :: (HasCallStack, Marionette m) => m Text+getCurrentURL = value <$> sendCommand "WebDriver:GetCurrentURL"++-- | Get the value of the given attribute of an element.+--+-- See <https://w3c.github.io/webdriver/#get-element-attribute>+getElementAttribute :: (HasCallStack, Marionette m) => Text -> Element -> m (Maybe Text)+getElementAttribute attr Element{..} =+ value+ <$> sendCommand+ Command+ { command = "WebDriver:GetElementAttribute"+ , parameters =+ Aeson.object+ [ "id" .= elementId+ , "name" .= attr+ ]+ }++-- | Get the given CSS property of the computed style of an element.+--+-- See <https://w3c.github.io/webdriver/#get-element-css-value>+getElementCSSValue :: (HasCallStack, Marionette m) => Element -> Text -> m (Maybe Text)+getElementCSSValue Element{..} propertyName =+ value+ <$> sendCommand+ Command+ { command = "WebDriver:GetElementCSSValue"+ , parameters =+ Aeson.object+ [ "id" .= elementId+ , "propertyName" .= propertyName+ ]+ }++-- | Get the value of the given property of an element.+--+-- See <https://w3c.github.io/webdriver/#get-element-property>+getElementProperty :: (HasCallStack, Marionette m) => Element -> Text -> m (Maybe Text)+getElementProperty Element{..} name =+ value+ <$> sendCommand+ Command+ { command = "WebDriver:GetElementProperty"+ , parameters =+ Aeson.object+ [ "id" .= elementId+ , "name" .= name+ ]+ }++-- | Get the dimensions and coordinates of an element.+--+-- See <https://w3c.github.io/webdriver/#get-element-rect>+getElementRect :: (HasCallStack, Marionette m) => Element -> m Rect+getElementRect Element{..} =+ sendCommand+ Command+ { command = "WebDriver:GetElementRect"+ , parameters = Aeson.object ["id" .= elementId]+ }++-- | Get the local tag name of an element.+--+-- See <https://w3c.github.io/webdriver/#get-element-tag-name>+getElementTagName :: (HasCallStack, Marionette m) => Element -> m Text+getElementTagName Element{..} =+ value+ <$> sendCommand+ Command+ { command = "WebDriver:GetElementTagName"+ , parameters = Aeson.object ["id" .= elementId]+ }++-- | Get the rendered text of an element, including the text of all its+-- child elements.+--+-- See <https://w3c.github.io/webdriver/#get-element-text>+getElementText :: (HasCallStack, Marionette m) => Element -> m Text+getElementText Element{..} =+ value+ <$> sendCommand+ Command+ { command = "WebDriver:GetElementText"+ , parameters = Aeson.object ["id" .= elementId]+ }++-- | Get the page source of the content document, serialised as a string.+--+-- See <https://w3c.github.io/webdriver/#get-page-source>+getPageSource :: (HasCallStack, Marionette m) => m Text+getPageSource = value <$> sendCommand "WebDriver:GetPageSource"++-- | Get the shadow root of an element.+--+-- See <https://w3c.github.io/webdriver/#get-element-shadow-root>+getShadowRoot :: (HasCallStack, Marionette m) => Element -> m Shadow+getShadowRoot Element{..} =+ value+ <$> sendCommand+ Command+ { command = "WebDriver:GetShadowRoot"+ , parameters = Aeson.object ["id" .= elementId]+ }++-- | Get the timeouts for page loading, searching, and scripts.+--+-- See <https://w3c.github.io/webdriver/#get-timeouts>+getTimeouts :: (HasCallStack, Marionette m) => m Timeouts+getTimeouts = sendCommand "WebDriver:GetTimeouts"++-- | Get the current title of the window.+--+-- See <https://w3c.github.io/webdriver/#get-title>+getTitle :: (HasCallStack, Marionette m) => m Text+getTitle = value <$> sendCommand "WebDriver:GetTitle"++-- | Get the current window's handle: an opaque, server-assigned+-- identifier that can be used to switch back to this window later with+-- 'switchToWindow'.+--+-- See <https://w3c.github.io/webdriver/#get-window-handle>+getWindowHandle :: (HasCallStack, Marionette m) => m WindowHandle+getWindowHandle = value <$> sendCommand "WebDriver:GetWindowHandle"++-- | Get the unordered list of window handles of every open top-level+-- browsing context.+--+-- See <https://w3c.github.io/webdriver/#get-window-handles>+getWindowHandles :: (HasCallStack, Marionette m) => m [WindowHandle]+getWindowHandles = sendCommand "WebDriver:GetWindowHandles"++-- | Get the position and size of the browser window currently in focus.+-- The width and height refer to the window's @outerWidth@ and+-- @outerHeight@, which include scroll bars, title bars, and so on.+--+-- See <https://w3c.github.io/webdriver/#get-window-rect>+getWindowRect :: (HasCallStack, Marionette m) => m Rect+getWindowRect = sendCommand "WebDriver:GetWindowRect"++-- | Check whether an element is displayed.+--+-- See <https://w3c.github.io/webdriver/#element-displayedness>+isElementDisplayed :: (HasCallStack, Marionette m) => Element -> m Bool+isElementDisplayed Element{..} =+ value+ <$> sendCommand+ Command+ { command = "WebDriver:IsElementDisplayed"+ , parameters = Aeson.object ["id" .= elementId]+ }++-- | Check whether an element is enabled.+--+-- See <https://w3c.github.io/webdriver/#is-element-enabled>+isElementEnabled :: (HasCallStack, Marionette m) => Element -> m Bool+isElementEnabled Element{..} =+ value+ <$> sendCommand+ Command+ { command = "WebDriver:IsElementEnabled"+ , parameters = Aeson.object ["id" .= elementId]+ }++-- | Check whether an element is selected.+--+-- See <https://w3c.github.io/webdriver/#is-element-selected>+isElementSelected :: (HasCallStack, Marionette m) => Element -> m Bool+isElementSelected Element{..} =+ value+ <$> sendCommand+ Command+ { command = "WebDriver:IsElementSelected"+ , parameters = Aeson.object ["id" .= elementId]+ }++-- | Maximise the window, as if the user had pressed the maximise button.+-- Not supported on Android.+--+-- See <https://w3c.github.io/webdriver/#maximize-window>+maximizeWindow :: (HasCallStack, Marionette m) => m ()+maximizeWindow = sendCommand_ "WebDriver:MaximizeWindow"++-- | Minimise the window, as if the user had pressed the minimise button.+-- Not supported on Android.+--+-- See <https://w3c.github.io/webdriver/#minimize-window>+minimizeWindow :: (HasCallStack, Marionette m) => m ()+minimizeWindow = sendCommand_ "WebDriver:MinimizeWindow"++-- | Navigate to the given URL, waiting for the document to load or the+-- session's page load timeout to elapse before returning.+--+-- See <https://w3c.github.io/webdriver/#navigate-to>+navigate :: (HasCallStack, Marionette m) => Text -> m ()+navigate url =+ sendCommand_+ Command+ { command = "WebDriver:Navigate"+ , parameters = Aeson.object ["url" .= url]+ }++-- | Create a new WebDriver session. Must be called before performing any+-- other command.+--+-- See <https://w3c.github.io/webdriver/#new-session>+newSession :: (HasCallStack, Marionette m) => m ()+newSession = sendCommand_ "WebDriver:NewSession"++-- | Open a new top-level browsing context of type window.+--+-- See <https://w3c.github.io/webdriver/#new-window>+newWindow :: (HasCallStack, Marionette m) => m NewWindowResult+newWindow =+ sendCommand+ Command+ { command = "WebDriver:NewWindow"+ , parameters = Aeson.object ["type" .= Window]+ }++-- | Open a new top-level browsing context of type tab.+--+-- See <https://w3c.github.io/webdriver/#new-window>+newTab :: (HasCallStack, Marionette m) => m NewWindowResult+newTab =+ sendCommand+ Command+ { command = "WebDriver:NewWindow"+ , parameters = Aeson.object ["type" .= Tab]+ }++-- | Perform a series of grouped input actions at the specified points in+-- time.+--+-- See <https://w3c.github.io/webdriver/#perform-actions>+performActions :: (HasCallStack, Marionette m) => m ()+performActions = sendCommand_ "WebDriver:PerformActions"++-- | Print the current page, returning it as a base64-encoded PDF.+--+-- See <https://w3c.github.io/webdriver/#print-page>+print :: (HasCallStack, Marionette m) => m ()+print = sendCommand_ "WebDriver:Print"++-- | Reload the page in the current top-level browsing context.+--+-- See <https://w3c.github.io/webdriver/#refresh>+refresh :: (HasCallStack, Marionette m) => m ()+refresh = sendCommand_ "WebDriver:Refresh"++-- | Release all the keys and pointer buttons that are currently+-- depressed.+--+-- See <https://w3c.github.io/webdriver/#release-actions>+releaseActions :: (HasCallStack, Marionette m) => m ()+releaseActions = sendCommand_ "WebDriver:ReleaseActions"++-- | Send keys to the input field of a currently displayed modal, or+-- throw if no modal is displayed, or the modal has no means for text+-- input.+--+-- See <https://w3c.github.io/webdriver/#send-alert-text>+sendAlertText :: (HasCallStack, Marionette m) => Text -> m ()+sendAlertText text =+ sendCommand_+ Command+ { command = "WebDriver:SendAlertText"+ , parameters = Aeson.object ["text" .= text]+ }++-- | Simulate user modification of a permission descriptor's permission+-- state.+--+-- See <https://www.w3.org/TR/permissions/#webdriver-command-set-permission>+setPermission :: (HasCallStack, Marionette m) => m ()+setPermission = sendCommand_ "WebDriver:SetPermission"++-- | Set the timeouts for page loading, searching, and scripts.+--+-- See <https://w3c.github.io/webdriver/#set-timeouts>+setTimeouts :: (HasCallStack, Marionette m) => Timeouts -> m ()+setTimeouts timeouts =+ sendCommand_+ Command+ { command = "WebDriver:SetTimeouts"+ , parameters = toJSON timeouts+ }++-- | Set the position and size of the window on the operating system's+-- window manager. The width and height refer to the window's+-- @outerWidth@ and @outerHeight@, which include browser chrome and+-- OS-level window borders.+--+-- See <https://w3c.github.io/webdriver/#set-window-rect>+setWindowRect :: (HasCallStack, Marionette m) => Rect -> m ()+setWindowRect rect =+ sendCommand_+ Command+ { command = "WebDriver:SetWindowRect"+ , parameters = toJSON rect+ }++-- | Switch to the given frame within the current window.+--+-- See <https://w3c.github.io/webdriver/#switch-to-frame>+switchToFrame :: (HasCallStack, Marionette m) => Frame -> m ()+switchToFrame frame =+ sendCommand_+ Command+ { command = "WebDriver:SwitchToFrame"+ , parameters = toJSON frame+ }++-- | Set the current browsing context for future commands to the parent+-- of the current browsing context.+--+-- See <https://w3c.github.io/webdriver/#switch-to-parent-frame>+switchToParentFrame :: (HasCallStack, Marionette m) => m ()+switchToParentFrame = sendCommand_ "WebDriver:SwitchToParentFrame"++-- | Switch to the top-level browsing context identified by the given+-- window handle.+--+-- See <https://w3c.github.io/webdriver/#switch-to-window>+switchToWindow :: (HasCallStack, Marionette m) => WindowHandle -> m ()+switchToWindow window =+ sendCommand_+ Command+ { command = "WebDriver:SwitchToWindow"+ , parameters = toJSON window+ }++-- | Take a screenshot of the current frame, returned as a lossless PNG+-- image.+--+-- See <https://w3c.github.io/webdriver/#take-screenshot>+takeScreenshot :: (HasCallStack, Marionette m) => m ByteString+takeScreenshot =+ Base64.decodeLenient+ . Text.encodeUtf8+ . value+ <$> sendCommand+ Command+ { command = "WebDriver:TakeScreenshot"+ , parameters = Aeson.object []+ }++-- | Add a credential to a virtual authenticator.+--+-- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-add-credential>+addCredential :: (HasCallStack, Marionette m) => AuthenticatorId -> Credential -> m ()+addCredential authenticatorId credential =+ sendCommand_+ Command+ { command = "WebAuthn:AddCredential"+ , parameters =+ Aeson.Object . mconcat $+ [ Object.fromList ["authenticatorId" .= authenticatorId]+ , case toJSON credential of+ Aeson.Object o -> o+ _ -> mempty+ ]+ }++-- | Add a virtual authenticator, returning its identifier.+--+-- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-add-virtual-authenticator>+addVirtualAuthenticator :: (HasCallStack, Marionette m) => VirtualAuthenticator -> m AuthenticatorId+addVirtualAuthenticator authenticator =+ value+ <$> sendCommand+ Command+ { command = "WebAuthn:AddVirtualAuthenticator"+ , parameters = toJSON authenticator+ }++-- | Get the credentials stored in a virtual authenticator.+--+-- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-get-credentials>+getCredentials :: (HasCallStack, Marionette m) => AuthenticatorId -> m [Credential]+getCredentials authenticatorId =+ value+ <$> sendCommand+ Command+ { command = "WebAuthn:GetCredentials"+ , parameters = Aeson.object ["authenticatorId" .= authenticatorId]+ }++-- | Remove all credentials from a virtual authenticator.+--+-- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-remove-all-credentials>+removeAllCredentials :: (HasCallStack, Marionette m) => AuthenticatorId -> m ()+removeAllCredentials authenticatorId =+ sendCommand_+ Command+ { command = "WebAuthn:RemoveAllCredentials"+ , parameters = Aeson.object ["authenticatorId" .= authenticatorId]+ }++-- | Remove a credential from a virtual authenticator.+--+-- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-remove-credential>+removeCredential :: (HasCallStack, Marionette m) => AuthenticatorId -> CredentialId -> m ()+removeCredential authenticatorId credentialId =+ sendCommand_+ Command+ { command = "WebAuthn:RemoveCredential"+ , parameters =+ Aeson.object+ [ "authenticatorId" .= authenticatorId+ , "credentialId" .= credentialId+ ]+ }++-- | Remove a virtual authenticator.+--+-- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-remove-virtual-authenticator>+removeVirtualAuthenticator :: (HasCallStack, Marionette m) => AuthenticatorId -> m ()+removeVirtualAuthenticator authenticatorId =+ sendCommand_+ Command+ { command = "WebAuthn:RemoveVirtualAuthenticator"+ , parameters = Aeson.object ["authenticatorId" .= authenticatorId]+ }++-- | Set the user-verified flag on a virtual authenticator.+--+-- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-set-user-verified>+setUserVerified :: (HasCallStack, Marionette m) => AuthenticatorId -> Bool -> m ()+setUserVerified authenticatorId verified =+ sendCommand_+ Command+ { command = "WebAuthn:SetUserVerified"+ , parameters =+ Aeson.object+ [ "authenticatorId" .= authenticatorId+ , "isUserVerified" .= verified+ ]+ }
+ src/Test/Marionette/Context.hs view
@@ -0,0 +1,19 @@+module Test.Marionette.Context where++import Data.Aeson.Types+import GHC.Generics (Generic)+import Prelude++-- | The browsing context for script execution.+data Context = ContentContext | ChromeContext+ deriving stock (Generic, Eq, Show, Bounded, Enum)++instance FromJSON Context where+ parseJSON = withText "Context" \case+ "content" -> pure ContentContext+ "chrome" -> pure ChromeContext+ other -> fail $ "Unknown context: " <> show other++instance ToJSON Context where+ toJSON ContentContext = String "content"+ toJSON ChromeContext = String "chrome"
+ src/Test/Marionette/Cookie.hs view
@@ -0,0 +1,21 @@+module Test.Marionette.Cookie where++import Data.Aeson.Types+import Data.Text (Text)+import GHC.Generics (Generic)+import Prelude++data Cookie = Cookie+ { name :: Text+ , value :: Text+ , path :: Maybe Text+ , domain :: Maybe Text+ , secure :: Maybe Bool+ , httpOnly :: Maybe Bool+ , expiry :: Maybe Int+ }+ deriving stock (Generic, Show, Eq)+ deriving anyclass (FromJSON)++instance ToJSON Cookie where+ toJSON = genericToJSON defaultOptions{omitNothingFields = True}
+ src/Test/Marionette/Element.hs view
@@ -0,0 +1,42 @@+module Test.Marionette.Element where++import Data.Aeson.Types+import Data.Hashable (Hashable)+import Data.Text (Text)+import Prelude++-- | An opaque identifier for a web page element.+newtype Element = Element {elementId :: Text}+ deriving newtype+ ( Eq+ , Ord+ , Show+ , Read+ , Hashable+ )++instance FromJSON Element where+ parseJSON = withObject "Element" \o -> do+ elementId <- o .: "element-6066-11e4-a52e-4f735466cecf"+ pure Element{..}++instance ToJSON Element where+ toJSON Element{..} = object ["element-6066-11e4-a52e-4f735466cecf" .= elementId]++-- | An opaque identifier for a web page element that identifies a shadow root.+newtype Shadow = Shadow {shadowId :: Text}+ deriving newtype+ ( Eq+ , Ord+ , Show+ , Read+ , Hashable+ )++instance FromJSON Shadow where+ parseJSON = withObject "Element" \o -> do+ shadowId <- o .: "shadow-6066-11e4-a52e-4f735466cecf"+ pure Shadow{..}++instance ToJSON Shadow where+ toJSON Shadow{..} = object ["shadow-6066-11e4-a52e-4f735466cecf" .= shadowId]
+ src/Test/Marionette/Frame.hs view
@@ -0,0 +1,27 @@+module Test.Marionette.Frame where++import Data.Aeson.Types+import Data.Hashable (Hashable)+import GHC.Generics (Generic)+import Test.Marionette.Element (Element (..))+import Prelude++data Frame+ = FrameIndex Int+ | FrameElement Element+ | TopFrame+ deriving stock (Generic, Eq, Show)+ deriving anyclass (Hashable)++instance FromJSON Frame where+ parseJSON = withObject "Frame" \o ->+ liftA2 (,) (o .:? "id") (o .:? "element") >>= \case+ (Just _, Just _) -> fail "conflicting frame identifiers"+ (Just index, Nothing) -> pure . FrameIndex $ index+ (Nothing, Just elementId) -> pure . FrameElement . Element $ elementId+ (Nothing, Nothing) -> pure TopFrame++instance ToJSON Frame where+ toJSON (FrameIndex index) = object ["id" .= index]+ toJSON (FrameElement Element{..}) = object ["element" .= elementId]+ toJSON TopFrame = object ["id" .= Null]
+ src/Test/Marionette/Orientation.hs view
@@ -0,0 +1,18 @@+module Test.Marionette.Orientation where++import Data.Aeson.Types+import GHC.Generics (Generic)+import Prelude++data Orientation = Portrait | Landscape+ deriving stock (Eq, Show, Generic)++instance ToJSON Orientation where+ toJSON Portrait = String "portrait"+ toJSON Landscape = String "landscape"++instance FromJSON Orientation where+ parseJSON = withText "Orientation" \case+ "portrait" -> pure Portrait+ "landscape" -> pure Landscape+ other -> fail $ "Unknown orientation: " <> show other
+ src/Test/Marionette/Protocol.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE UndecidableInstances #-}++module Test.Marionette.Protocol where++import Control.Monad (MonadPlus (mzero))+import Control.Monad.Catch (Exception (..))+import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value (..), withArray)+import Data.Aeson qualified as Aeson+import Data.Aeson.Types qualified as Aeson+import Data.Binary (Binary (..), getWord8)+import Data.Binary qualified as Binary+import Data.Binary.Parser (decimal, getLazyByteString)+import Data.Binary.Put (putLazyByteString)+import Data.ByteString.Lazy (LazyByteString)+import Data.ByteString.Lazy qualified as LazyByteString+import Data.Char (chr)+import Data.Either (fromRight)+import Data.Foldable qualified as Foldable+import Data.String (IsString (fromString))+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import GHC.Generics (Generic)+import Prelude hiding (log)++data Message a = Message {messageId :: Int, messageContent :: a}+ deriving stock (Show)++newtype MarionetteMessage = MarionetteMessage LazyByteString++instance Binary MarionetteMessage where+ put :: MarionetteMessage -> Binary.Put+ put (MarionetteMessage lbs) =+ putLazyByteString $+ (fromString . show . LazyByteString.length $ lbs) <> ":" <> lbs+ get :: Binary.Get MarionetteMessage+ get = do+ len <- decimal+ ':' <- chr . fromIntegral <$> getWord8+ MarionetteMessage <$> getLazyByteString len++instance Show MarionetteMessage where+ show :: MarionetteMessage -> String+ show = Text.unpack . Text.decodeUtf8 . LazyByteString.toStrict . Binary.encode++data Command = Command+ { command :: Text+ , parameters :: Value+ }+ deriving stock (Show)++instance IsString Command where+ fromString str =+ Command+ { command = Text.pack str+ , parameters = Aeson.object []+ }++instance ToJSON (Message Command) where+ toJSON :: Message Command -> Value+ toJSON Message{messageId, messageContent = Command{..}} =+ Array+ [ Number 0+ , toJSON messageId+ , toJSON command+ , parameters+ ]++instance FromJSON (Message Command) where+ parseJSON :: Value -> Aeson.Parser (Message Command)+ parseJSON = withArray "Command" \a -> do+ case Foldable.toList a of+ [Number 0, messageIdVal, String command, parameters] -> do+ messageId <- parseJSON messageIdVal+ pure $ Message messageId $ Command{..}+ _ -> mzero++type Result = Either Error Value++instance ToJSON (Message Result) where+ toJSON :: Message Result -> Value+ toJSON Message{..} =+ Array+ [ Number 1+ , toJSON messageId+ , errVal+ , resVal+ ]+ where+ errVal = either toJSON (const Null) messageContent+ resVal = fromRight Null messageContent++instance FromJSON (Message Result) where+ parseJSON :: Value -> Aeson.Parser (Message Result)+ parseJSON = withArray "Result" \a -> do+ case Foldable.toList a of+ [Number 1, messageIdVal, err, res] -> do+ messageId <- parseJSON messageIdVal+ Message messageId+ <$> if err == Null+ then pure . Right $ res+ else Left <$> parseJSON err+ _ -> mzero++-- | An error reported by a Marionette or WebDriver command, as returned by+-- the server.+--+-- See <https://w3c.github.io/webdriver/#errors>+data Error = Error+ { error :: Text+ -- ^ An error code identifying the kind of failure, e.g. @no such element@.+ , message :: Text+ -- ^ A human-readable description of the failure.+ , stacktrace :: Text+ -- ^ A stack trace taken on the server side when the error occurred.+ }+ deriving stock (Generic)+ deriving anyclass (Exception, FromJSON, ToJSON)++instance Show Error where+ show = Text.unpack . message++data Greeting = Greeting+ { applicationType :: Text+ , marionetteProtocol :: Int+ }+ deriving stock (Generic, Show)+ deriving anyclass (FromJSON)
+ src/Test/Marionette/Rect.hs view
@@ -0,0 +1,14 @@+module Test.Marionette.Rect where++import Data.Aeson.Types (FromJSON, ToJSON)+import GHC.Generics (Generic)+import Prelude++data Rect = Rect+ { x :: Float+ , y :: Float+ , width :: Float+ , height :: Float+ }+ deriving stock (Generic, Show, Eq)+ deriving anyclass (FromJSON, ToJSON)
+ src/Test/Marionette/Registry.hs view
@@ -0,0 +1,20 @@+module Test.Marionette.Registry where++import Data.Aeson.Types+import Data.Maybe (maybeToList)+import Data.Text (Text)+import GHC.Generics (Generic)+import Prelude++-------------------------------------------------------------------++data RegistryEntry = RegistryEntry+ { entryType :: Text+ , namespace :: Text+ , directory :: Text+ , options :: Maybe Text+ }+ deriving stock (Generic, Show, Eq)++instance ToJSON RegistryEntry where+ toJSON RegistryEntry{..} = toJSON $ [entryType, namespace, directory] <> maybeToList options
+ src/Test/Marionette/Selector.hs view
@@ -0,0 +1,55 @@+module Test.Marionette.Selector where++import Data.Aeson.KeyMap qualified as Object+import Data.Aeson.Types+import Data.Hashable (Hashable)+import Data.Text (Text)+import GHC.Generics (Generic)+import Test.Marionette.Element (Element (..), Shadow (..))+import Prelude++-- | Specifies element(s) within a DOM tree using various selection methods.+data Selector+ = ById Text+ | ByName Text+ | -- | (Note: multiple classes are not allowed. For more control, use 'ByCSS')+ ByClass Text+ | ByTag Text+ | ByLinkText Text+ | ByPartialLinkText Text+ | ByCSS Text+ | ByXPath Text+ | Anon Text+ | AnonAttribute Text+ deriving stock (Generic, Eq, Show)+ deriving anyclass (Hashable)++toObject :: Selector -> Object+toObject s =+ case s of+ ById t -> selector "id" t+ ByName t -> selector "name" t+ ByClass t -> selector "class name" t+ ByTag t -> selector "tag name" t+ ByLinkText t -> selector "link text" t+ ByPartialLinkText t -> selector "partial link text" t+ ByCSS t -> selector "css selector" t+ ByXPath t -> selector "xpath" t+ Anon t -> selector "anon" t+ AnonAttribute t -> selector "anon attribute" t+ where+ selector :: Text -> Text -> Object+ selector sn t = Object.fromList ["using" .= sn, "value" .= t]++instance ToJSON Selector where+ toJSON = Object . toObject++data SelectorFrom = SelectorFrom Element Selector++instance ToJSON SelectorFrom where+ toJSON (SelectorFrom Element{..} s) = Object $ Object.fromList ["element" .= elementId] <> toObject s++data SelectorFromShadowRoot = SelectorFromShadowRoot Shadow Selector++instance ToJSON SelectorFromShadowRoot where+ toJSON (SelectorFromShadowRoot Shadow{..} s) = Object $ Object.fromList ["shadowRoot" .= shadowId] <> toObject s
+ src/Test/Marionette/Timeouts.hs view
@@ -0,0 +1,16 @@+module Test.Marionette.Timeouts where++import Data.Aeson.Types+import GHC.Generics (Generic)+import Prelude++data Timeouts = Timeouts+ { script :: Maybe Int+ , pageLoad :: Maybe Int+ , implicit :: Maybe Int+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (FromJSON)++instance ToJSON Timeouts where+ toJSON = genericToJSON defaultOptions{omitNothingFields = True}
+ src/Test/Marionette/WebAuthn.hs view
@@ -0,0 +1,53 @@+module Test.Marionette.WebAuthn where++import Data.Aeson.Types+import Data.Text (Text)+import GHC.Generics (Generic)+import Prelude++-------------------------------------------------------------------++newtype AuthenticatorId = AuthenticatorId Text+ deriving stock (Show, Eq, Generic)+ deriving newtype (FromJSON, ToJSON)++-------------------------------------------------------------------++newtype CredentialId = CredentialId Text+ deriving stock (Show, Eq, Generic)+ deriving newtype (FromJSON, ToJSON)++-------------------------------------------------------------------++data VirtualAuthenticator = VirtualAuthenticator+ { protocol :: Text+ -- ^ "ctap1/u2f" or "ctap2"+ , transport :: Text+ -- ^ "usb", "nfc", "ble", "smart-card", "hybrid", or "internal"+ , hasResidentKey :: Bool+ , hasUserVerification :: Bool+ , isUserConsenting :: Bool+ , isUserVerified :: Bool+ , extensions :: Maybe [Text]+ , uvm :: Maybe Bool+ }+ deriving stock (Show, Eq, Generic)++instance ToJSON VirtualAuthenticator where+ toJSON = genericToJSON defaultOptions{omitNothingFields = True}++-------------------------------------------------------------------++data Credential = Credential+ { credentialId :: CredentialId+ , isResidentCredential :: Bool+ , rpId :: Text+ , privateKey :: Text+ , userHandle :: Maybe Text+ , signCount :: Int+ }+ deriving stock (Show, Eq, Generic)+ deriving anyclass (FromJSON)++instance ToJSON Credential where+ toJSON = genericToJSON defaultOptions{omitNothingFields = True}
+ src/Test/Marionette/Window.hs view
@@ -0,0 +1,53 @@+module Test.Marionette.Window where++import Data.Aeson.Types+import Data.Hashable (Hashable)+import Data.Text (Text)+import GHC.Generics (Generic)+import Prelude++-------------------------------------------------------------------++newtype WindowHandle = WindowHandle Text+ deriving newtype+ ( Eq+ , Ord+ , Show+ , Read+ , Hashable+ )++instance FromJSON WindowHandle where+ parseJSON = withText "WindowHandle" $ pure . WindowHandle++instance ToJSON WindowHandle where+ toJSON (WindowHandle handle) = object ["handle" .= handle]++-------------------------------------------------------------------++data WindowType = Tab | Window+ deriving stock (Eq, Show, Generic)++instance ToJSON WindowType where+ toJSON Tab = String "tab"+ toJSON Window = String "window"++instance FromJSON WindowType where+ parseJSON = withText "WindowType" \case+ "tab" -> pure Tab+ "window" -> pure Window+ other -> fail $ "Unknown window type: " <> show other++-------------------------------------------------------------------++data NewWindowResult = NewWindowResult+ { newWindowHandle :: WindowHandle+ , newWindowType :: WindowType+ }+ deriving stock (Show, Eq, Generic)++instance FromJSON NewWindowResult where+ parseJSON = withObject "NewWindowResult" \o -> do+ newWindowHandle <- o .: "handle"+ newWindowType <- o .: "type"+ pure NewWindowResult{..}
+ test/Main.hs view
@@ -0,0 +1,477 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Main where++import Control.Concurrent (forkIO, killThread)+import Control.Exception (bracket)+import Data.Aeson (toJSON)+import Data.ByteString qualified as ByteString+import Data.Functor (void)+import Data.Text (Text)+import Data.Text qualified as Text+import Lucid+import Network.HTTP.Types (status200)+import Network.Wai (Application, rawPathInfo, responseLBS)+import Network.Wai.Handler.Warp (run)+import System.Process.Typed+ ( checkExitCode+ , nullStream+ , proc+ , setStderr+ , setStdout+ , startProcess+ )+import Test.Hspec (describe, hspec, it)+import Test.Hspec.Expectations.Lifted+import Test.Marionette+import Test.Marionette.Cookie qualified as Cookie+import Test.Marionette.Rect qualified as Rect+import Test.Marionette.Timeouts qualified as Timeouts+import Test.Marionette.WebAuthn qualified as WebAuthn+import Prelude hiding (print)++page :: Text -> Html () -> Html ()+page title body =+ html_ do+ head_ $ title_ (toHtml title)+ body_ body++app :: Application+app req respond =+ respond . responseLBS status200 [("Content-Type", "text/html")] . renderBS $+ case rawPathInfo req of+ "/form" ->+ page "Form Page" do+ form_ do+ input_ [id_ "text-input", type_ "text", name_ "q"]+ input_ [id_ "checkbox", type_ "checkbox", name_ "check"]+ select_ [id_ "select"] do+ option_ [value_ "a"] "Option A"+ option_ [value_ "b"] "Option B"+ button_ [id_ "submit", type_ "submit"] "Submit"+ "/link" ->+ page "Link Page" do+ a_ [id_ "link", href_ "/target"] "Click me"+ a_ [id_ "partial", href_ "/target"] "Click here for more"+ "/target" ->+ page "Target Page" do+ p_ [id_ "result"] "You arrived!"+ "/shadow" ->+ page "Shadow DOM Page" do+ div_ [id_ "host"] mempty+ script_+ "\+ \const host = document.getElementById('host');\+ \const shadow = host.attachShadow({mode: 'open'});\+ \shadow.innerHTML = '<p id=\"shadow-p\">Shadow content</p>';"+ "/alert" ->+ page "Alert Page" do+ button_ [id_ "alert-btn", onclick_ "alert('Hello!')"] "Alert"+ button_ [id_ "confirm-btn", onclick_ "confirm('Sure?')"] "Confirm"+ button_ [id_ "prompt-btn", onclick_ "prompt('Input:')"] "Prompt"+ _ ->+ page "Marionette Test" do+ h1_ [id_ "heading"] "Hello, Marionette!"+ p_ [id_ "para", class_ "content"] "Test paragraph"+ p_ [id_ "para2", class_ "content"] "Second paragraph"+ div_ [id_ "parent"] do+ span_ [id_ "child"] "Child element"++withTestServer :: IO a -> IO a+withTestServer = bracket (forkIO $ run 8080 app) killThread . const++withFirefox :: IO a -> IO a+withFirefox =+ bracket+ ( startProcess+ . setStdout nullStream+ . setStderr nullStream+ . proc "firefox"+ $ [ "--marionette"+ , "--headless"+ , "-remote-allow-system-access"+ ]+ )+ ( \process -> do+ runMarionetteT $ newSession >> quit+ checkExitCode process+ )+ . const++run' :: (HasCallStack) => MarionetteT IO () -> IO ()+run' action = runMarionetteT do+ newSession+ navigate "http://localhost:8080/"+ action+ deleteSession++main :: IO ()+main = withTestServer . withFirefox . hspec $ do+ describe "Session" do+ it "can create and delete a session" . run' $ do+ deleteSession+ newSession++ describe "Navigation" do+ it "navigates to a URL" . run' $ getCurrentURL `shouldReturn` "http://localhost:8080/"++ it "can go back and forward" . run' $ do+ navigate "http://localhost:8080/target"+ back+ getCurrentURL `shouldReturn` "http://localhost:8080/"+ forward+ getCurrentURL `shouldReturn` "http://localhost:8080/target"++ it "can refresh" . run' $ do+ refresh+ getCurrentURL `shouldReturn` "http://localhost:8080/"++ it "getTitle returns page title" . run' $ getTitle `shouldReturn` "Marionette Test"++ it "getPageSource returns HTML" . run' $ do+ source <- getPageSource+ source `shouldSatisfy` Text.isInfixOf "Hello, Marionette!"++ it "getCurrentURL returns current URL" . run' $+ getCurrentURL `shouldReturn` "http://localhost:8080/"++ describe "Timeouts" do+ it "setTimeouts / getTimeouts roundtrip" . run' $ do+ let t =+ Timeouts+ { script = Just 5000+ , pageLoad = Just 10000+ , implicit = Just 0+ }+ setTimeouts t+ getTimeouts `shouldReturn` t++ describe "Window" do+ it "getWindowHandle returns a handle" . run' $ do+ handle <- getWindowHandle+ handle `shouldSatisfy` not . null . show++ it "getWindowHandles returns at least one handle" . run' $ do+ handles <- getWindowHandles+ handles `shouldSatisfy` not . null++ it "getWindowRect returns a rect" . run' $ do+ Rect{..} <- getWindowRect+ width `shouldSatisfy` (> 0)+ height `shouldSatisfy` (> 0)++ it "setWindowRect / getWindowRect roundtrip" . run' $ do+ let r =+ Rect+ { x = 0+ , y = 0+ , width = 800+ , height = 600+ }+ setWindowRect r+ getWindowRect `shouldReturn` r++ it "maximizeWindow does not throw" $ run' maximizeWindow+ it "minimizeWindow does not throw" $ run' minimizeWindow+ it "fullscreenWindow does not throw" $ run' fullscreenWindow++ it "newTab opens a new window handle" . run' $ do+ before <- getWindowHandles+ NewWindowResult{..} <- newTab+ -- newWindowType `shouldBe` Tab+ after <- getWindowHandles+ after `shouldBe` before <> [newWindowHandle]++ it "newWindow opens a new window handle" . run' $ do+ before <- getWindowHandles+ NewWindowResult{..} <- newTab+ -- This does not seem to work+ -- newWindowType `shouldBe` Window+ after <- getWindowHandles+ after `shouldBe` before <> [newWindowHandle]++ it "switchToWindow and closeWindow" . run' $ do+ original <- getWindowHandle+ NewWindowResult{..} <- newTab+ switchToWindow newWindowHandle+ getWindowHandle `shouldReturn` newWindowHandle+ closeWindow+ switchToWindow original+ getWindowHandle `shouldReturn` original++ describe "Element finding" do+ it "findElement by id" . run' $ do+ el <- findElement (ById "heading")+ getElementText el `shouldReturn` "Hello, Marionette!"++ it "findElement by class" . run' $ do+ el <- findElement (ByClass "content")+ getElementText el `shouldReturn` "Test paragraph"++ it "findElement by tag" . run' $ do+ el <- findElement (ByTag "h1")+ getElementText el `shouldReturn` "Hello, Marionette!"++ it "findElement by CSS selector" . run' $ do+ el <- findElement (ByCSS "#heading")+ getElementText el `shouldReturn` "Hello, Marionette!"++ it "findElement by XPath" . run' $ do+ el <- findElement (ByXPath "//h1[@id='heading']")+ getElementText el `shouldReturn` "Hello, Marionette!"++ it "findElements returns multiple elements" . run' $ do+ els <- findElements (ByClass "content")+ length els `shouldBe` 2++ it "findElementFrom finds child within parent" . run' $ do+ parent <- findElement (ById "parent")+ child <- findElementFrom parent (ById "child")+ getElementText child `shouldReturn` "Child element"++ it "findElementsFrom finds children within parent" . run' $ do+ parent <- findElement (ById "parent")+ children :: [Element] <- findElementsFrom parent (ByTag "span")+ length children `shouldBe` 1++ it "findElement by link text" . run' $ do+ navigate "http://localhost:8080/link"+ el <- findElement (ByLinkText "Click me")+ getElementText el `shouldReturn` "Click me"++ it "findElement by partial link text" . run' $ do+ navigate "http://localhost:8080/link"+ el <- findElement (ByPartialLinkText "Click here")+ text <- getElementText el+ text `shouldSatisfy` Text.isInfixOf "Click here"++ describe "Element properties" do+ it "getElementAttribute" . run' $ do+ el <- findElement (ById "para")+ getElementAttribute "class" el `shouldReturn` Just "content"++ it "getElementProperty" . run' $ do+ el <- findElement (ById "para")+ getElementProperty el "id" `shouldReturn` Just "para"++ it "getElementTagName" . run' $ do+ el <- findElement (ById "heading")+ getElementTagName el `shouldReturn` "h1"++ it "getElementRect" . run' $ do+ el <- findElement (ById "heading")+ Rect{..} <- getElementRect el+ width `shouldSatisfy` (> 0)++ it "getElementCSSValue" . run' $ do+ el <- findElement (ById "heading")+ val <- getElementCSSValue el "display"+ val `shouldSatisfy` not . null . show++ it "getComputedRole" . run' $ do+ el <- findElement (ById "heading")+ role <- getComputedRole el+ role `shouldSatisfy` not . Text.null++ it "getComputedLabel" . run' $ do+ navigate "http://localhost:8080/form"+ el <- findElement (ById "submit")+ label <- getComputedLabel el+ label `shouldSatisfy` not . Text.null++ it "isElementDisplayed" . run' $ do+ navigate "http://localhost:8080/"+ el <- findElement (ById "heading")+ isElementDisplayed el `shouldReturn` True++ it "isElementEnabled" . run' $ do+ navigate "http://localhost:8080/form"+ el <- findElement (ById "text-input")+ isElementEnabled el `shouldReturn` True++ it "isElementSelected for unchecked checkbox" . run' $ do+ navigate "http://localhost:8080/form"+ el <- findElement (ById "checkbox")+ isElementSelected el `shouldReturn` False++ it "getActiveElement does not throw" . run' . void $ getActiveElement++ describe "Element interaction" do+ it "elementClick navigates via link" . run' $ do+ navigate "http://localhost:8080/link"+ el <- findElement (ById "link")+ elementClick el+ getCurrentURL `shouldReturn` "http://localhost:8080/target"++ it "elementSendKeys fills input" . run' $ do+ navigate "http://localhost:8080/form"+ el <- findElement (ById "text-input")+ elementSendKeys el "hello"+ getElementProperty el "value" `shouldReturn` Just "hello"++ it "elementClear clears input" . run' $ do+ navigate "http://localhost:8080/form"+ el <- findElement (ById "text-input")+ elementSendKeys el "hello"+ elementClear el+ getElementProperty el "value" `shouldReturn` Just ""++ describe "Script execution" do+ it "executeScript returns a value" . run' $ do+ executeScript "return 1 + 1" [] `shouldReturn` (2 :: Int)++ it "executeScript can access elements" . run' $ do+ navigate "http://localhost:8080/"+ executeScript+ "return document.getElementById(arguments[0]).textContent"+ [toJSON @Text "heading"]+ `shouldReturn` ("Hello, Marionette!" :: Text)++ it "executeAsyncScript returns a value" . run' $ do+ executeAsyncScript @_ @_ @Int+ "const callback = arguments[arguments.length - 1]; setTimeout(() => callback(arguments[0]), 100)"+ [toJSON @Int 42]+ `shouldReturn` Just 42++ describe "Cookies" do+ it "addCookie / getCookies roundtrip" . run' $ do+ deleteAllCookies+ let cookie =+ Cookie+ { name = "test"+ , value = "value"+ , path = Just "/"+ , domain = Nothing+ , secure = Just False+ , httpOnly = Just False+ , expiry = Nothing+ }+ addCookie cookie+ cookies <- getCookies+ cookies `shouldSatisfy` any \c -> Cookie.name c == "test"++ it "deleteCookie removes a cookie" . run' $ do+ deleteAllCookies+ let cookie =+ Cookie+ { name = "todelete"+ , value = "x"+ , path = Just "/"+ , domain = Nothing+ , secure = Just False+ , httpOnly = Just False+ , expiry = Nothing+ }+ addCookie cookie+ deleteCookie "todelete"+ cookies <- getCookies+ cookies `shouldNotSatisfy` any \c -> Cookie.name c == "test"++ it "deleteAllCookies removes all cookies" . run' $ do+ deleteAllCookies+ getCookies `shouldReturn` []++ describe "Alerts" do+ it "acceptAlert dismisses an alert" . run' $ do+ navigate "http://localhost:8080/alert"+ el <- findElement (ById "alert-btn")+ elementClick el+ getAlertText `shouldReturn` "Hello!"+ acceptAlert++ it "dismissAlert dismisses a confirm dialog" . run' $ do+ navigate "http://localhost:8080/alert"+ el <- findElement (ById "confirm-btn")+ elementClick el+ dismissAlert++ it "sendAlertText fills a prompt" . run' $ do+ navigate "http://localhost:8080/alert"+ el <- findElement (ById "prompt-btn")+ elementClick el+ sendAlertText "my input"+ acceptAlert++ describe "Frames" do+ it "switchToParentFrame does not throw" . run' $ switchToParentFrame++ describe "Context" do+ it "getContext returns a context" . run' $ do+ ctx <- getContext+ ctx `shouldSatisfy` (`elem` [minBound .. maxBound])++ it "setContext / getContext roundtrip" . run' $ do+ setContext ContentContext+ getContext `shouldReturn` ContentContext+ setContext ChromeContext+ getContext `shouldReturn` ChromeContext++ describe "Shadow DOM" do+ it "getShadowRoot / findElementFromShadowRoot" . run' $ do+ navigate "http://localhost:8080/shadow"+ host <- findElement (ById "host")+ shadow <- getShadowRoot host+ el <- findElementFromShadowRoot shadow (ByCSS "#shadow-p")+ getElementText el `shouldReturn` "Shadow content"++ it "findElementsFromShadowRoot" . run' $ do+ navigate "http://localhost:8080/shadow"+ host <- findElement (ById "host")+ shadow <- getShadowRoot host+ els <- findElementsFromShadowRoot shadow (ByCSS "p")+ length els `shouldBe` 1++ describe "Screenshots" do+ it "takeScreenshot returns non-empty bytes" . run' $ do+ bytes <- takeScreenshot+ ByteString.length bytes `shouldNotBe` 0++ describe "WebAuthn" do+ it "addVirtualAuthenticator / getCredentials roundtrip" . run' $ do+ let opts =+ VirtualAuthenticator+ { protocol = "ctap2"+ , transport = "internal"+ , hasResidentKey = True+ , hasUserVerification = True+ , isUserConsenting = True+ , isUserVerified = True+ , extensions = Nothing+ , uvm = Nothing+ }+ aid <- addVirtualAuthenticator opts+ getCredentials aid `shouldReturn` []+ removeVirtualAuthenticator aid++ it "setUserVerified does not throw" . run' $ do+ let opts =+ VirtualAuthenticator+ { protocol = "ctap2"+ , transport = "internal"+ , hasResidentKey = True+ , hasUserVerification = True+ , isUserConsenting = True+ , isUserVerified = True+ , extensions = Nothing+ , uvm = Nothing+ }+ aid <- addVirtualAuthenticator opts+ setUserVerified aid False+ setUserVerified aid True+ removeVirtualAuthenticator aid++ it "removeAllCredentials does not throw" . run' $ do+ let opts =+ VirtualAuthenticator+ { protocol = "ctap2"+ , transport = "internal"+ , hasResidentKey = True+ , hasUserVerification = True+ , isUserConsenting = True+ , isUserVerified = True+ , extensions = Nothing+ , uvm = Nothing+ }+ aid <- addVirtualAuthenticator opts+ removeAllCredentials aid+ removeVirtualAuthenticator aid