diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/marionette.cabal b/marionette.cabal new file mode 100644 --- /dev/null +++ b/marionette.cabal @@ -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 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, diff --git a/src/Test/Marionette.hs b/src/Test/Marionette.hs new file mode 100644 --- /dev/null +++ b/src/Test/Marionette.hs @@ -0,0 +1,114 @@ +-- | +-- Module : Test.Marionette +-- Copyright : (c) 2026 Institute for Digital Autonomy +-- License : EUPL-1.2 +-- Maintainer : IDA +-- +-- is +-- Firefox's built-in remote-control protocol. It plays the same role as a +-- 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 (..) + ) diff --git a/src/Test/Marionette/AccessibilityProperties.hs b/src/Test/Marionette/AccessibilityProperties.hs new file mode 100644 --- /dev/null +++ b/src/Test/Marionette/AccessibilityProperties.hs @@ -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) diff --git a/src/Test/Marionette/Class.hs b/src/Test/Marionette/Class.hs new file mode 100644 --- /dev/null +++ b/src/Test/Marionette/Class.hs @@ -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 diff --git a/src/Test/Marionette/Client.hs b/src/Test/Marionette/Client.hs new file mode 100644 --- /dev/null +++ b/src/Test/Marionette/Client.hs @@ -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 diff --git a/src/Test/Marionette/Commands.hs b/src/Test/Marionette/Commands.hs new file mode 100644 --- /dev/null +++ b/src/Test/Marionette/Commands.hs @@ -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 +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 +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 +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 +closeWindow :: (HasCallStack, Marionette m) => m () +closeWindow = sendCommand_ "WebDriver:CloseWindow" + +-- | Delete all cookies that are visible to a document. +-- +-- See +deleteAllCookies :: (HasCallStack, Marionette m) => m () +deleteAllCookies = sendCommand_ "WebDriver:DeleteAllCookies" + +-- | Delete a cookie by name. +-- +-- See +deleteCookie :: (HasCallStack, Marionette m) => Text -> m () +deleteCookie name = + sendCommand_ + Command + { command = "WebDriver:DeleteCookie" + , parameters = Aeson.object ["name" .= name] + } + +-- | Delete the current WebDriver session. +-- +-- See +deleteSession :: (HasCallStack, Marionette m) => m () +deleteSession = sendCommand_ "WebDriver:DeleteSession" + +-- | Dismiss a currently displayed modal dialog, or throw if no modal is +-- displayed. +-- +-- See +dismissAlert :: (HasCallStack, Marionette m) => m () +dismissAlert = sendCommand_ "WebDriver:DismissAlert" + +-- | Clear the text of an element. +-- +-- See +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 +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 +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 +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 +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 +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 +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 +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 +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 +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 +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 +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 +fullscreenWindow :: (HasCallStack, Marionette m) => m () +fullscreenWindow = sendCommand_ "WebDriver:FullscreenWindow" + +-- | Return the active element in the document. +-- +-- See +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 +getAlertText :: (HasCallStack, Marionette m) => m Text +getAlertText = value <$> sendCommand "WebDriver:GetAlertText" + +-- | Determine the accessibility label for an element. +-- +-- See +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 +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 +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 +getCurrentURL :: (HasCallStack, Marionette m) => m Text +getCurrentURL = value <$> sendCommand "WebDriver:GetCurrentURL" + +-- | Get the value of the given attribute of an element. +-- +-- See +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 +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 +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 +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 +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 +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 +getPageSource :: (HasCallStack, Marionette m) => m Text +getPageSource = value <$> sendCommand "WebDriver:GetPageSource" + +-- | Get the shadow root of an element. +-- +-- See +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 +getTimeouts :: (HasCallStack, Marionette m) => m Timeouts +getTimeouts = sendCommand "WebDriver:GetTimeouts" + +-- | Get the current title of the window. +-- +-- See +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 +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 +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 +getWindowRect :: (HasCallStack, Marionette m) => m Rect +getWindowRect = sendCommand "WebDriver:GetWindowRect" + +-- | Check whether an element is displayed. +-- +-- See +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 +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 +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 +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 +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 +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 +newSession :: (HasCallStack, Marionette m) => m () +newSession = sendCommand_ "WebDriver:NewSession" + +-- | Open a new top-level browsing context of type window. +-- +-- See +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 +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 +performActions :: (HasCallStack, Marionette m) => m () +performActions = sendCommand_ "WebDriver:PerformActions" + +-- | Print the current page, returning it as a base64-encoded PDF. +-- +-- See +print :: (HasCallStack, Marionette m) => m () +print = sendCommand_ "WebDriver:Print" + +-- | Reload the page in the current top-level browsing context. +-- +-- See +refresh :: (HasCallStack, Marionette m) => m () +refresh = sendCommand_ "WebDriver:Refresh" + +-- | Release all the keys and pointer buttons that are currently +-- depressed. +-- +-- See +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 +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 +setPermission :: (HasCallStack, Marionette m) => m () +setPermission = sendCommand_ "WebDriver:SetPermission" + +-- | Set the timeouts for page loading, searching, and scripts. +-- +-- See +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 +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 +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 +switchToParentFrame :: (HasCallStack, Marionette m) => m () +switchToParentFrame = sendCommand_ "WebDriver:SwitchToParentFrame" + +-- | Switch to the top-level browsing context identified by the given +-- window handle. +-- +-- See +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 +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 +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 +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 +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 +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 +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 +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 +setUserVerified :: (HasCallStack, Marionette m) => AuthenticatorId -> Bool -> m () +setUserVerified authenticatorId verified = + sendCommand_ + Command + { command = "WebAuthn:SetUserVerified" + , parameters = + Aeson.object + [ "authenticatorId" .= authenticatorId + , "isUserVerified" .= verified + ] + } diff --git a/src/Test/Marionette/Context.hs b/src/Test/Marionette/Context.hs new file mode 100644 --- /dev/null +++ b/src/Test/Marionette/Context.hs @@ -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" diff --git a/src/Test/Marionette/Cookie.hs b/src/Test/Marionette/Cookie.hs new file mode 100644 --- /dev/null +++ b/src/Test/Marionette/Cookie.hs @@ -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} diff --git a/src/Test/Marionette/Element.hs b/src/Test/Marionette/Element.hs new file mode 100644 --- /dev/null +++ b/src/Test/Marionette/Element.hs @@ -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] diff --git a/src/Test/Marionette/Frame.hs b/src/Test/Marionette/Frame.hs new file mode 100644 --- /dev/null +++ b/src/Test/Marionette/Frame.hs @@ -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] diff --git a/src/Test/Marionette/Orientation.hs b/src/Test/Marionette/Orientation.hs new file mode 100644 --- /dev/null +++ b/src/Test/Marionette/Orientation.hs @@ -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 diff --git a/src/Test/Marionette/Protocol.hs b/src/Test/Marionette/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Test/Marionette/Protocol.hs @@ -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 +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) diff --git a/src/Test/Marionette/Rect.hs b/src/Test/Marionette/Rect.hs new file mode 100644 --- /dev/null +++ b/src/Test/Marionette/Rect.hs @@ -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) diff --git a/src/Test/Marionette/Registry.hs b/src/Test/Marionette/Registry.hs new file mode 100644 --- /dev/null +++ b/src/Test/Marionette/Registry.hs @@ -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 diff --git a/src/Test/Marionette/Selector.hs b/src/Test/Marionette/Selector.hs new file mode 100644 --- /dev/null +++ b/src/Test/Marionette/Selector.hs @@ -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 diff --git a/src/Test/Marionette/Timeouts.hs b/src/Test/Marionette/Timeouts.hs new file mode 100644 --- /dev/null +++ b/src/Test/Marionette/Timeouts.hs @@ -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} diff --git a/src/Test/Marionette/WebAuthn.hs b/src/Test/Marionette/WebAuthn.hs new file mode 100644 --- /dev/null +++ b/src/Test/Marionette/WebAuthn.hs @@ -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} diff --git a/src/Test/Marionette/Window.hs b/src/Test/Marionette/Window.hs new file mode 100644 --- /dev/null +++ b/src/Test/Marionette/Window.hs @@ -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{..} diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 = '

Shadow content

';" + "/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