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-effectful.cabal b/marionette-effectful.cabal new file mode 100644 --- /dev/null +++ b/marionette-effectful.cabal @@ -0,0 +1,89 @@ +cabal-version: 3.0 +name: marionette-effectful +version: 1.0.0 +category: Web +synopsis: Effectful driver for Marionette +description: + Adaptation of the @@ library for the @@ ecosystem. + +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 + + default-extensions: + ApplicativeDo + BlockArguments + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DerivingVia + ExplicitNamespaces + FlexibleContexts + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + NoImplicitPrelude + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + RankNTypes + RecordWildCards + RecursiveDo + ScopedTypeVariables + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + + build-depends: + base >=4.16 && <5, + effectful >=2.6 && <2.7, + marionette >=1.0 && <1.1, + +library + import: common + hs-source-dirs: src + build-depends: + mtl >=2.3 && <2.4, + unliftio >=0.2 && <0.3, + + exposed-modules: + Effectful.Marionette + +test-suite marionette-effectful-test + import: common + type: exitcode-stdio-1.0 + ghc-options: -threaded + hs-source-dirs: test + main-is: Main.hs + build-depends: + aeson >=2.2 && <2.3, + bytestring >=0.12 && <0.13, + hspec-effectful >=1.0 && <1.1, + http-types >=0.12 && <0.13, + lucid2 >=0.0 && <0.1, + marionette-effectful, + text >=2.1 && <2.2, + typed-process-effectful >=1.0 && <1.1, + wai >=3.2 && <3.3, + warp >=3.4 && <3.5, diff --git a/src/Effectful/Marionette.hs b/src/Effectful/Marionette.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Marionette.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-role-annotations #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- Module : Effectful.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 module lifts every command from the +-- library into +-- the 'Eff' monad as a 'Marionette' effect. Run 'runMarionette' to open the +-- connection and discharge that effect for the duration of your action. +-- +-- = 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 'runMarionette' to connect to it and run a client program. +-- Start a new session with 'newSession', and quit the session with 'quit': +-- +-- > import Effectful +-- > import Effectful.Marionette +-- > import Effectful.Process.Typed +-- > import System.Process.Typed (proc) +-- > +-- > main :: IO () +-- > main = +-- > runEff . runTypedProcess $ +-- > withProcessTerm_ (proc "firefox" ["--marionette", "--headless"]) \_process -> +-- > runMarionette $ 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 :> es) => Eff es () +-- > submitForm = do +-- > input <- findElement (ById "text-input") +-- > elementSendKeys input "hello, world" +-- > submit <- findElement (ByCSS "button[type=submit]") +-- > elementClick submit +-- +-- == Error handling +-- +-- Catch command failures using @Effectful.Exception@, +-- for example to retry a command against a fallback element: +-- +-- > import Effectful.Exception (catchError) +-- > +-- > clickFirstAvailable :: (HasCallStack, Marionette :> es) => Eff es () +-- > clickFirstAvailable = +-- > (elementClick =<< findElement (ById "primary-button")) +-- > `catchError` \_ -> elementClick =<< findElement (ById "fallback-button") +module Effectful.Marionette + ( -- * Effect + Marionette + , runMarionette + + -- * Re-exports from @Marionette@ + , module Test.Marionette + ) +where + +import Control.Monad.Error.Class (MonadError (..)) +import Effectful + ( Dispatch (Static) + , DispatchOf + , Eff + , Effect + , IOE + , Limit (..) + , Persistence (Ephemeral) + , UnliftStrategy (ConcUnlift) + , withEffToIO + , (:>) + ) +import Effectful.Dispatch.Static + ( SideEffects (WithSideEffects) + , StaticRep + , evalStaticRep + , getStaticRep + , unsafeEff_ + ) +import Effectful.Exception (catch, throwIO) +import Test.Marionette hiding (Marionette) +import Test.Marionette qualified as Marionette +import Test.Marionette.Class qualified as Marionette +import UnliftIO (withRunInIO) +import Prelude + +data Marionette :: Effect + +type instance DispatchOf Marionette = 'Static 'WithSideEffects + +newtype instance StaticRep Marionette = Marionette (forall a. MarionetteT IO a -> IO a) + +instance {-# OVERLAPPING #-} MonadError Marionette.Error (Eff es) where + throwError = throwIO + catchError = catch + +instance (Marionette :> es) => Marionette.Marionette (Eff es) where + sendCommands commands = do + Marionette unlift <- getStaticRep + unsafeEff_ . unlift $ Marionette.sendCommands commands + +-- | Connect to a Marionette server listening on @localhost:2828@ (started +-- by launching Firefox with the @--marionette@ flag), and run the given +-- action against it. +runMarionette + :: (IOE :> es) + => Eff (Marionette ': es) a + -> Eff es a +runMarionette action = + withEffToIO (ConcUnlift Ephemeral Unlimited) \unlift -> runMarionetteT $ + withRunInIO \runInIO -> unlift . evalStaticRep (Marionette runInIO) $ action diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,478 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Main where + +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 Effectful +import Effectful.Concurrent (Concurrent, forkIO, killThread, runConcurrent) +import Effectful.Exception (bracket) +import Effectful.Hspec +import Effectful.Marionette +import Effectful.Process.Typed + ( checkExitCode + , nullStream + , proc + , runTypedProcess + , setStderr + , setStdout + , startProcess + ) +import Lucid +import Network.HTTP.Types (status200) +import Network.Wai (Application, rawPathInfo, responseLBS) +import Network.Wai.Handler.Warp (run) +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" + +runTestServer :: (IOE :> es, Concurrent :> es) => Eff es a -> Eff es a +runTestServer = bracket (forkIO . liftIO $ run 8080 app) killThread . const + +runFirefox :: (IOE :> es) => Eff es a -> Eff es a +runFirefox = + runTypedProcess + . bracket + ( startProcess + . setStdout nullStream + . setStderr nullStream + . proc "firefox" + $ [ "--marionette" + , "--headless" + , "-remote-allow-system-access" + ] + ) + ( \process -> do + runMarionette $ newSession >> quit + checkExitCode process + ) + . const + . inject + +run' :: (IOE :> es) => Eff (Marionette ': es) () -> Eff es () +run' action = runMarionette do + newSession + navigate "http://localhost:8080/" + action + deleteSession + +main :: IO () +main = runEff . runConcurrent . runTestServer . runFirefox . runHspec $ 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