marionette 1.0.0 → 1.1.0

raw patch · 12 files changed

+1051/−337 lines, 12 filesdep +directorydep +filepathdep +temporarydep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, filepath, temporary

Dependency ranges changed: containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +34/−0
• marionette.cabal +28/−2
• src/Test/Marionette.hs +9/−2
• src/Test/Marionette/Actions.hs +216/−0
• src/Test/Marionette/Client.hs +89/−56
• src/Test/Marionette/Commands.hs +135/−157
• src/Test/Marionette/Key.hs +129/−0
• src/Test/Marionette/Protocol.hs +2/−3
• src/Test/Marionette/Registry.hs +0/−2
• src/Test/Marionette/Selector.hs +1/−1
• test/ClientSpec.hs +150/−0
• test/Main.hs +258/−114

@@ -5,6 +5,40 @@ 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.1.0] - 2026-10-01++### Added++- `runMarionetteTWith`, allowing connections to an arbitrary host and port.+- `ClientEnv`, the reader environment that `MarionetteT` runs against.+- `Test.Marionette.Actions` and `Test.Marionette.Key` modules to support structured virtual input device actions.++### Removed++- `UnexpectedResult`, unexpected / timed out responses are now discarded rather than ending the session.+- `CommandWithCallback`, replaced by `QueuedCommand`.++### Changed++- `incoming` takes a callback to run if reading or decoding the connection ever fails,+  instead of asynchronously killing the whole session.+- `MarionetteTimeout` carries the `Command` that timed out instead of the raw wire message.++### Fixed++- Command timeouts no longer close the session.+- Raised command timeout from 5s to 15s.+- Closed connection no longer spin the reader.+- Command callback are before sending instead of after.+- Timed-out commands are deregistered.+- `Test.Marionette.Commands.performActions` now accepts action sequences to simulate keyboard, mouse, and touch events, rather than doing nothing.++## [1.0.1] - 2026-08-07++### Fixed++- Rethrow async exceptions in the Client.+ ## [1.0.0] - 2026-07-14  ### Added

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: marionette-version: 1.0.0+version: 1.1.0 category: Web synopsis: Marionette protocol for Firefox description:@@ -77,7 +77,7 @@     base64-bytestring >=1.2 && <1.3,     binary >=0.8 && <0.9,     binary-parsers >=0.2 && <0.3,-    containers >=0.7 && <0.8,+    containers >=0.7 && <0.9,     exceptions >=0.10 && <0.11,     hashable >=1.5 && <1.6,     mtl >=2.3 && <2.4,@@ -89,6 +89,7 @@   exposed-modules:     Test.Marionette     Test.Marionette.AccessibilityProperties+    Test.Marionette.Actions     Test.Marionette.Class     Test.Marionette.Client     Test.Marionette.Commands@@ -96,6 +97,7 @@     Test.Marionette.Cookie     Test.Marionette.Element     Test.Marionette.Frame+    Test.Marionette.Key     Test.Marionette.Orientation     Test.Marionette.Protocol     Test.Marionette.Rect@@ -112,11 +114,35 @@   hs-source-dirs: test   main-is: Main.hs   build-depends:+    directory >=1.3 && <1.4,+    filepath >=1.5 && <1.6,     hspec >=2.11 && <2.12,     hspec-expectations-lifted >=0.10 && <0.11,     http-types >=0.12 && <0.13,     lucid2 >=0.0 && <0.1,     marionette,+    network >=3.2 && <3.3,+    retry >=0.9 && <0.10,+    temporary >=1.3 && <1.4,     typed-process >=0.2 && <0.3,     wai >=3.2 && <3.3,     warp >=3.4 && <3.5,++test-suite marionette-client-test+  import: common+  type: exitcode-stdio-1.0+  ghc-options:+    -threaded+    -with-rtsopts=-N+    -Wno-unused-packages++  hs-source-dirs: test+  main-is: ClientSpec.hs+  build-depends:+    binary >=0.8 && <0.9,+    hspec >=2.11 && <2.12,+    hspec-expectations-lifted >=0.10 && <0.11,+    marionette,+    network >=3.2 && <3.3,+    network-simple >=0.4.5 && <0.5,+    unliftio >=0.2 && <0.3,

@@ -66,7 +66,8 @@ -- >   (elementClick =<< findElement (ById "primary-button")) -- >     `catchError` \_ -> elementClick =<< findElement (ById "fallback-button") module Test.Marionette-    ( module Test.Marionette.Class+    ( module Test.Marionette.Actions+    , module Test.Marionette.Class     , module Test.Marionette.Client     , module Test.Marionette.Commands     , module Test.Marionette.Cookie@@ -84,8 +85,14 @@     ) where +import Test.Marionette.Actions import Test.Marionette.Class (Marionette)-import Test.Marionette.Client (MarionetteT, runMarionetteT)+import Test.Marionette.Client+    ( MarionetteT+    , defaultCommandTimeout+    , runMarionetteT+    , runMarionetteTWith+    ) import Test.Marionette.Commands import Test.Marionette.Context (Context (..)) import Test.Marionette.Cookie (Cookie (Cookie))

@@ -0,0 +1,216 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# OPTIONS_GHC -Wno-partial-fields #-}++-- | The <W3C https://w3c.github.io/webdriver/#actions Actions> API.+module Test.Marionette.Actions where++import Data.Aeson (ToJSON (toJSON), Value (String), object, (.=))+import Data.Text (Text)+import Data.Text qualified as Text+import Test.Marionette.Element (Element)+import Test.Marionette.Key (Key)+import Prelude++-- | Where a pointer or wheel action is anchored.+data Origin+    = -- | The top-left of the viewport.+      Viewport+    | -- | The input source's current position.+      Pointer+    | -- | The centre of the given element.+      FromElement Element+    deriving stock (Show, Eq)++instance ToJSON Origin where+    toJSON Viewport = String "viewport"+    toJSON Pointer = String "pointer"+    toJSON (FromElement element) = toJSON element++-- | Which mouse button an action addresses.+data Button+    = LeftButton+    | MiddleButton+    | RightButton+    | BackButton+    | ForwardButton+    deriving stock (Show, Eq, Enum, Bounded)++-- | The kind of physical device a pointer input source represents.+data PointerType = Mouse | Pen | Touch+    deriving stock (Show, Eq)++instance ToJSON PointerType where+    toJSON = String . Text.toLower . Text.show++-- | One tick of a pointer input source's action list.+data PointerAction+    = -- | Do nothing for this many milliseconds, or until every other+      -- source's action in this tick has finished, whichever is longer.+      PointerPause {durationMs :: Int}+    | -- | Move to (or by, relative to the 'Origin') the given position over+      -- the given number of milliseconds.+      PointerMove {durationMs :: Int, origin :: Origin, x :: Int, y :: Int}+    | PointerDown Button+    | PointerUp Button+    deriving stock (Show, Eq)++instance ToJSON PointerAction where+    toJSON PointerPause{..} =+        object+            [ "type" .= String "pause"+            , "duration" .= durationMs+            ]+    toJSON PointerMove{..} =+        object+            [ "type" .= String "pointerMove"+            , "duration" .= durationMs+            , "origin" .= origin+            , "x" .= x+            , "y" .= y+            ]+    toJSON (PointerDown button) =+        object+            [ "type" .= String "pointerDown"+            , "button" .= fromEnum button+            ]+    toJSON (PointerUp button) =+        object+            [ "type" .= String "pointerUp"+            , "button" .= fromEnum button+            ]++-- | One tick of a key input source's action list.+data KeyAction+    = KeyPause {durationMs :: Int}+    | KeyDown Key+    | KeyUp Key+    deriving stock (Show, Eq)++instance ToJSON KeyAction where+    toJSON KeyPause{..} =+        object+            [ "type" .= String "pause"+            , "duration" .= durationMs+            ]+    toJSON (KeyDown key) =+        object+            [ "type" .= String "keyDown"+            , "value" .= key+            ]+    toJSON (KeyUp key) =+        object+            [ "type" .= String "keyUp"+            , "value" .= key+            ]++-- | One tick of a wheel input source's action list.+data WheelAction+    = WheelPause {durationMs :: Int}+    | -- | Scroll by the given @(deltaX, deltaY)@ pixels, anchored at the+      -- given @(x, y)@ relative to the 'Origin', over the given number of+      -- milliseconds.+      Scroll+        { durationMs :: Int+        , origin :: Origin+        , x :: Int+        , y :: Int+        , deltaX :: Int+        , deltaY :: Int+        }+    deriving stock (Show, Eq)++instance ToJSON WheelAction where+    toJSON WheelPause{..} =+        object+            [ "type" .= String "pause"+            , "duration" .= durationMs+            ]+    toJSON Scroll{..} =+        object+            [ "type" .= String "scroll"+            , "duration" .= durationMs+            , "origin" .= origin+            , "x" .= x+            , "y" .= y+            , "deltaX" .= deltaX+            , "deltaY" .= deltaY+            ]++-- | One tick of a "none" input source's action list.+newtype NoneAction = NonePause {durationMs :: Int}+    deriving stock (Show, Eq)++instance ToJSON NoneAction where+    toJSON NonePause{..} =+        object+            [ "type" .= String "pause"+            , "duration" .= durationMs+            ]++-- | A virtual input device and the sequence of actions to dispatch on it.+data InputSource+    = PointerInput+        { sourceId :: Text+        , pointerType :: PointerType+        , pointerActions :: [PointerAction]+        }+    | KeyInput+        { sourceId :: Text+        , keyActions :: [KeyAction]+        }+    | WheelInput+        { sourceId :: Text+        , wheelActions :: [WheelAction]+        }+    | NoneInput+        { sourceId :: Text+        , noneActions :: [NoneAction]+        }+    deriving stock (Show, Eq)++instance ToJSON InputSource where+    toJSON PointerInput{..} =+        object+            [ "type" .= String "pointer"+            , "id" .= sourceId+            , "parameters" .= object ["pointerType" .= pointerType]+            , "actions" .= pointerActions+            ]+    toJSON KeyInput{..} =+        object+            [ "type" .= String "key"+            , "id" .= sourceId+            , "actions" .= keyActions+            ]+    toJSON WheelInput{..} =+        object+            [ "type" .= String "wheel"+            , "id" .= sourceId+            , "actions" .= wheelActions+            ]+    toJSON NoneInput{..} =+        object+            [ "type" .= String "none"+            , "id" .= sourceId+            , "actions" .= noneActions+            ]++-- | A single mouse pointer input source named @"mouse"@.+mouse :: [PointerAction] -> InputSource+mouse = PointerInput "mouse" Mouse++-- | A single pen pointer input source named @"pen"@.+pen :: [PointerAction] -> InputSource+pen = PointerInput "pen" Pen++-- | A single touch pointer input source named @"touch"@.+touch :: [PointerAction] -> InputSource+touch = PointerInput "touch" Touch++-- | A single keyboard input source named @"keyboard"@.+keyboard :: [KeyAction] -> InputSource+keyboard = KeyInput "keyboard"++-- | A single wheel input source named @"wheel"@.+wheel :: [WheelAction] -> InputSource+wheel = WheelInput "wheel"

@@ -4,8 +4,9 @@  module Test.Marionette.Client where -import Control.Exception (AssertionFailed (AssertionFailed))-import Control.Monad (void, when)+import Control.Applicative ((<|>))+import Control.Exception (AssertionFailed (AssertionFailed), SomeException)+import Control.Monad (void, (<=<)) import Control.Monad.Catch     ( Exception (..)     , MonadCatch@@ -13,6 +14,7 @@     , MonadThrow     , catch     , catchAll+    , finally     , throwM     ) import Control.Monad.Error.Class (MonadError (..))@@ -27,9 +29,10 @@ import Data.Binary qualified as Binary import Data.Binary.Get qualified as Binary import Data.ByteString (ByteString)+import Data.ByteString qualified as BS import Data.ByteString.Builder.Extra qualified as ByteString+import Data.IntMap (IntMap) import Data.IntMap.Strict qualified as IntMap-import Data.Maybe (isNothing) import GHC.Stack (HasCallStack) import Network.Simple.TCP     ( HostName@@ -40,6 +43,7 @@     , connectSock     , sendLazy     )+import Network.Socket (PortNumber) import Network.Socket.ByteString (recv) import System.Timeout (timeout) import Test.Marionette.Class (Marionette (..))@@ -54,10 +58,10 @@     , link     , readTMVar     )-import UnliftIO.Concurrent (forkIO) import UnliftIO.Retry (constantDelay, limitRetriesByCumulativeDelay, recoverAll) import UnliftIO.STM-    ( atomically+    ( TVar+    , atomically     , modifyTVar'     , newEmptyTMVarIO     , newTQueueIO@@ -65,6 +69,7 @@     , putTMVar     , readTQueue     , stateTVar+    , tryPutTMVar     , writeTQueue     ) import Prelude hiding (log)@@ -79,12 +84,13 @@  incoming     :: forall m a-     . (MonadUnliftIO m, MonadThrow m, Binary a)+     . (MonadUnliftIO m, MonadCatch m, Binary a)     => Socket+    -> (SomeException -> m ())     -> m (TQueue a)-incoming socket = do+incoming socket onFailure = do     q <- newTQueueIO-    link =<< async (go (atomically . writeTQueue q) (newDecoder ""))+    void . async $ go (atomically . writeTQueue q) (newDecoder "") `catch` onFailure     pure q   where     newDecoder :: ByteString -> Binary.Decoder a@@ -93,10 +99,12 @@     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)+    go f dec = do+        chunk <-+            liftIO (recv socket ByteString.defaultChunkSize `catchAll` \_ -> throwM SocketClosed)+        if BS.null chunk+            then throwM SocketClosed+            else go f (dec `Binary.pushChunk` chunk)  connect     :: (MonadUnliftIO m)@@ -112,19 +120,26 @@         )         (closeSock . fst) -newtype MarionetteTimeout = MarionetteTimeout MarionetteMessage+newtype MarionetteTimeout = MarionetteTimeout Command     deriving stock (Show)     deriving anyclass (Exception) -newtype UnexpectedResult = UnexpectedResult Result-    deriving stock (Show)-    deriving anyclass (Exception)+data QueuedCommand = QueuedCommand Int Command -data CommandWithCallback = CommandWithCallback Command (TMVar Result)+data ClientEnv = ClientEnv+    { sendQueue :: TQueue QueuedCommand+    , connectionLost :: TMVar SomeException+    , commandTimeout :: Int+    , nextMessageId :: TVar Int+    , pendingCommands :: TVar (IntMap (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)+defaultCommandTimeout :: Int+defaultCommandTimeout = 15_000_000++-- | A monad transformer that speaks the Marionette wire protocol over a TCP socket.+-- Run it with 'runMarionetteT'.+newtype MarionetteT m a = MarionetteT (ReaderT ClientEnv m a)     deriving newtype         ( Functor         , Applicative@@ -134,16 +149,29 @@         , MonadMask         , MonadIO         , MonadUnliftIO-        , MonadReader (TQueue CommandWithCallback)+        , MonadReader ClientEnv         )  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+        ClientEnv{..} <- Reader.ask         result <- newEmptyTMVarIO-        atomically . writeTQueue q $ CommandWithCallback command result-        either throwM pure =<< parseResult =<< atomically (readTMVar result)+        messageId <- atomically do+            messageId <- stateTVar nextMessageId $ \n -> (n, n + 1)+            modifyTVar' pendingCommands $ IntMap.insert messageId result+            writeTQueue sendQueue $ QueuedCommand messageId command+            pure messageId+        outcome <-+            liftIO . timeout commandTimeout . atomically $+                (Right <$> readTMVar result) <|> (Left <$> readTMVar connectionLost)+        case outcome of+            Nothing -> atomically . modifyTVar' pendingCommands $ IntMap.delete messageId+            Just _ -> pure ()+        maybe+            (throwM . MarionetteTimeout $ command)+            (either throwM (either throwM pure <=< parseResult))+            outcome       where         parseResult :: (FromJSON a) => Result -> MarionetteT m (Either Error a)         parseResult =@@ -155,16 +183,20 @@     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+-- | Run an action against a Marionette server.+runMarionetteTWith     :: forall m a      . (MonadUnliftIO m, MonadMask m)-    => MarionetteT m a+    => HostName+    -> PortNumber+    -> Int+    -- ^ Command timeout, in microseconds.+    -> MarionetteT m a     -> m a-runMarionetteT action = do-    sendQueue :: TQueue CommandWithCallback <- newTQueueIO+runMarionetteTWith host port commandTimeout action = do+    sendQueue :: TQueue QueuedCommand <- newTQueueIO+    connectionLost <- newEmptyTMVarIO+    nextMessageId <- newTVarIO 1     pendingCommands <- newTVarIO mempty     done <- newEmptyTMVarIO     let repeatUntilDone :: forall m'. (MonadIO m') => m' () -> m' ()@@ -180,44 +212,45 @@                         IntMap.updateLookupWithKey (\_ _ -> Nothing) messageId                     )                     >>= \case-                        Nothing -> throwM . UnexpectedResult $ messageContent+                        Nothing -> pure () -- a late or unsolicited reply; not fatal                         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+        failPending :: SomeException -> MarionetteT m ()+        failPending = void . atomically . tryPutTMVar connectionLost+        handleCommand :: Socket -> QueuedCommand -> MarionetteT m ()+        handleCommand socket (QueuedCommand messageId messageContent) =+            liftIO . sendLazy socket . Binary.encode . MarionetteMessage . Aeson.encode $+                Message{..}         runSocket :: MarionetteT m ()         runSocket =-            connect "localhost" "2828" \(socket, _) -> do-                incomingQueue <- incoming socket+            connect host (show port) \(socket, _) -> do+                incomingQueue <- incoming socket failPending                 void . decodeMarionetteM @_ @Greeting =<< atomically (readTQueue incomingQueue)-                let send messageId =+                let send =                         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)+                            >>= maybe (pure ()) ((>> send) . handleCommand socket)+                linkedAsync send+                void . async $+                    repeatUntilDone (handleIncoming =<< atomically (readTQueue incomingQueue))+                        `catch` failPending                 atomically $ readTMVar done-    flip runReaderT sendQueue . (\(MarionetteT r) -> r) $ do-        forkIO runSocket-        a <- action-        atomically $ putTMVar done ()-        pure a+    flip runReaderT ClientEnv{..} . (\(MarionetteT r) -> r) $ do+        linkedAsync runSocket+        action `finally` atomically (void $ tryPutTMVar done ())   where+    linkedAsync :: MarionetteT m () -> MarionetteT m ()+    linkedAsync = link <=< async+     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++-- | Run an action against a Marionette server listening on @localhost:2828@+-- (started by launching Firefox with the @--marionette@ flag).+runMarionetteT :: (MonadUnliftIO m, MonadMask m) => MarionetteT m a -> m a+runMarionetteT = runMarionetteTWith "localhost" 2828 defaultCommandTimeout

@@ -19,6 +19,7 @@ import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import Test.Marionette.AccessibilityProperties (AccessibilityProperties)+import Test.Marionette.Actions (InputSource) import Test.Marionette.Class import Test.Marionette.Context (Context) import Test.Marionette.Cookie (Cookie)@@ -53,8 +54,7 @@  type role ValueObject representational --- | Enable or disable accepting new socket connections.--- This has no effect on existing connections.+-- | Enable or disable accepting new socket connections. Has no effect on existing connections. acceptConnections :: (HasCallStack, Marionette m) => Bool -> m () acceptConnections value =     sendCommand_@@ -63,8 +63,8 @@             , parameters = Aeson.object ["value" .= value]             } --- | Look up accessibility properties of a node in the platform accessibility tree,--- rather than by a web element reference.+-- | Look up accessibility properties of a node in the platform accessibility tree, rather than+-- by a web element reference. getAccessibilityPropertiesForAccessibilityNode     :: (HasCallStack, Marionette m)     => Text@@ -77,8 +77,7 @@             , parameters = Aeson.object ["nodeId" .= nodeId]             } --- | Look up the accessibility properties exposed to assistive technology--- (such as screen readers) for a given element.+-- | Look up the accessibility properties exposed to assistive technology for a given element. getAccessibilityPropertiesForElement     :: (HasCallStack, Marionette m)     => Element@@ -90,11 +89,9 @@             , 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.+-- | Return whether subsequent browsing-context-scoped commands target privileged browser chrome+-- or ordinary web content.+-- New sessions start in the 'Content' context. getContext :: (HasCallStack, Marionette m) => m Context getContext = value <$> sendCommand "Marionette:GetContext" @@ -102,21 +99,20 @@ 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.+-- | 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.+-- | 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'.+-- | 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@@ -129,9 +125,8 @@                     ]             } --- | 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.+-- | 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_@@ -149,8 +144,8 @@             , parameters = Aeson.object ["orientation" .= orientation]             } --- | Unregister a previously registered chrome protocol handler, given an--- identifier returned by 'registerChromeHandler'.+-- | Unregister a previously registered chrome protocol handler, given an identifier returned by+-- 'registerChromeHandler'. unregisterChromeHandler :: (HasCallStack, Marionette m) => Text -> m () unregisterChromeHandler handlerId =     sendCommand_@@ -159,17 +154,15 @@             , parameters = Aeson.object ["id" .= handlerId]             } --- | Accept a currently displayed dialog modal, or throw if no modal is--- displayed.+-- | Accept a currently displayed dialog modal, or throw if no modal is displayed. ----- See <https://w3c.github.io/webdriver/#accept-alert>+-- See <https://w3c.github.io/webdriver/#accept-alert>. acceptAlert :: (HasCallStack, Marionette m) => m () acceptAlert = sendCommand_ "WebDriver:AcceptAlert" --- | Add a single cookie to the cookie store associated with the active--- document's address.+-- | Add a single cookie to the cookie store associated with the active document's address. ----- See <https://w3c.github.io/webdriver/#add-cookie>+-- See <https://w3c.github.io/webdriver/#add-cookie>. addCookie :: (HasCallStack, Marionette m) => Cookie -> m () addCookie cookie =     sendCommand_@@ -178,36 +171,33 @@             , parameters = Aeson.object ["cookie" .= cookie]             } --- | Cause the browser to traverse one step backward in the joint history--- of the current browsing context.+-- | Traverse one step backward in the history of the current browsing context. ----- See <https://w3c.github.io/webdriver/#back>+-- See <https://w3c.github.io/webdriver/#back>. back :: (HasCallStack, Marionette m) => m () back = sendCommand_ "WebDriver:Back" --- | Close the currently selected chrome window. If it is the last window--- currently open, the chrome window is not closed, to prevent an--- application shutdown.+-- | Close the currently selected chrome window.+-- Does not close the last window currently open 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.+-- | Close the currently selected tab or window.+-- Does not close the last window currently open to prevent an application shutdown. ----- See <https://w3c.github.io/webdriver/#close-window>+-- See <https://w3c.github.io/webdriver/#close-window>. closeWindow :: (HasCallStack, Marionette m) => m () closeWindow = sendCommand_ "WebDriver:CloseWindow"  -- | Delete all cookies that are visible to a document. ----- See <https://w3c.github.io/webdriver/#delete-all-cookies>+-- See <https://w3c.github.io/webdriver/#delete-all-cookies>. deleteAllCookies :: (HasCallStack, Marionette m) => m () deleteAllCookies = sendCommand_ "WebDriver:DeleteAllCookies"  -- | Delete a cookie by name. ----- See <https://w3c.github.io/webdriver/#delete-cookie>+-- See <https://w3c.github.io/webdriver/#delete-cookie>. deleteCookie :: (HasCallStack, Marionette m) => Text -> m () deleteCookie name =     sendCommand_@@ -218,20 +208,20 @@  -- | Delete the current WebDriver session. ----- See <https://w3c.github.io/webdriver/#delete-session>+-- See <https://w3c.github.io/webdriver/#delete-session>. deleteSession :: (HasCallStack, Marionette m) => m () deleteSession = sendCommand_ "WebDriver:DeleteSession"  -- | Dismiss a currently displayed modal dialog, or throw if no modal is -- displayed. ----- See <https://w3c.github.io/webdriver/#dismiss-alert>+-- See <https://w3c.github.io/webdriver/#dismiss-alert>. dismissAlert :: (HasCallStack, Marionette m) => m () dismissAlert = sendCommand_ "WebDriver:DismissAlert"  -- | Clear the text of an element. ----- See <https://w3c.github.io/webdriver/#element-clear>+-- See <https://w3c.github.io/webdriver/#element-clear>. elementClear :: (HasCallStack, Marionette m) => Element -> m () elementClear Element{..} =     sendCommand_@@ -242,7 +232,7 @@  -- | Send a click event to an element. ----- See <https://w3c.github.io/webdriver/#element-click>+-- See <https://w3c.github.io/webdriver/#element-click>. elementClick :: (HasCallStack, Marionette m) => Element -> m () elementClick Element{..} =     sendCommand_@@ -253,7 +243,7 @@  -- | Send key presses to an element after focusing on it. ----- See <https://w3c.github.io/webdriver/#element-send-keys>+-- See <https://w3c.github.io/webdriver/#element-send-keys>. elementSendKeys :: (HasCallStack, Marionette m) => Element -> Text -> m () elementSendKeys Element{..} text =     sendCommand_@@ -266,11 +256,10 @@                     ]             } --- | 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.+-- | Execute a JavaScript function asynchronously in the context of the current browsing context,+-- and return the value passed to the callback, which is the last argument exposed to the script. ----- See <https://w3c.github.io/webdriver/#execute-async-script>+-- See <https://w3c.github.io/webdriver/#execute-async-script>. executeAsyncScript     :: (HasCallStack, Marionette m, Foldable f, FromJSON a)     => Text@@ -287,10 +276,10 @@                     ]             } --- | Execute a JavaScript function synchronously in the context of the--- current browsing context, and return its return value.+-- | Execute a JavaScript function synchronously in the context of the current browsing context,+-- and return its return value. ----- See <https://w3c.github.io/webdriver/#execute-script>+-- See <https://w3c.github.io/webdriver/#execute-script>. executeScript :: (HasCallStack, Marionette m, Foldable f, FromJSON a) => Text -> f Value -> m a executeScript script args =     fmap value . sendCommand $@@ -305,7 +294,7 @@  -- | Find an element using the given search strategy. ----- See <https://w3c.github.io/webdriver/#find-element>+-- See <https://w3c.github.io/webdriver/#find-element>. findElement :: (HasCallStack, Marionette m) => Selector -> m Element findElement selector =     value@@ -315,10 +304,9 @@                 , parameters = toJSON selector                 } --- | Find an element using the given search strategy, relative to the--- given element.+-- | Find an element using the given search strategy, relative to the given element. ----- See <https://w3c.github.io/webdriver/#find-element>+-- See <https://w3c.github.io/webdriver/#find-element>. findElementFrom :: (HasCallStack, Marionette m) => Element -> Selector -> m Element findElementFrom element selector =     value@@ -330,7 +318,7 @@  -- | Find an element within a shadow root using the given search strategy. ----- See <https://w3c.github.io/webdriver/#find-element-from-shadow-root>+-- See <https://w3c.github.io/webdriver/#find-element-from-shadow-root>. findElementFromShadowRoot :: (HasCallStack, Marionette m) => Shadow -> Selector -> m Element findElementFromShadowRoot shadowRoot selector =     value@@ -342,7 +330,7 @@  -- | Find elements using the given search strategy. ----- See <https://w3c.github.io/webdriver/#find-elements>+-- See <https://w3c.github.io/webdriver/#find-elements>. findElements :: (HasCallStack, Marionette m) => Selector -> m [Element] findElements selector =     sendCommand@@ -351,10 +339,9 @@             , parameters = toJSON selector             } --- | Find elements using the given search strategy, relative to the given--- element.+-- | Find elements using the given search strategy, relative to the given element. ----- See <https://w3c.github.io/webdriver/#find-elements>+-- See <https://w3c.github.io/webdriver/#find-elements>. findElementsFrom :: (HasCallStack, Marionette m) => Element -> Selector -> m [Element] findElementsFrom element selector =     sendCommand@@ -365,7 +352,7 @@  -- | Find elements within a shadow root using the given search strategy. ----- See <https://w3c.github.io/webdriver/#find-elements-from-shadow-root>+-- See <https://w3c.github.io/webdriver/#find-elements-from-shadow-root>. findElementsFromShadowRoot :: (HasCallStack, Marionette m) => Shadow -> Selector -> m [Element] findElementsFromShadowRoot shadowRoot selector =     sendCommand@@ -374,36 +361,33 @@             , parameters = toJSON $ SelectorFromShadowRoot shadowRoot selector             } --- | Cause the browser to traverse one step forward in the joint history--- of the current browsing context.+-- | Traverse one step forward in the history of the current browsing context. ----- See <https://w3c.github.io/webdriver/#forward>+-- See <https://w3c.github.io/webdriver/#forward>. forward :: (HasCallStack, Marionette m) => m () forward = sendCommand_ "WebDriver:Forward" --- | Set the window to full screen, as if the user had chosen--- View -> Enter Full Screen. Not supported on Android.+-- | Set the window to full screen. Not supported on Android. ----- See <https://w3c.github.io/webdriver/#fullscreen-window>+-- See <https://w3c.github.io/webdriver/#fullscreen-window>. fullscreenWindow :: (HasCallStack, Marionette m) => m () fullscreenWindow = sendCommand_ "WebDriver:FullscreenWindow"  -- | Return the active element in the document. ----- See <https://w3c.github.io/webdriver/#get-active-element>+-- See <https://w3c.github.io/webdriver/#get-active-element>. getActiveElement :: (HasCallStack, Marionette m) => m Element getActiveElement = value <$> sendCommand "WebDriver:GetActiveElement" --- | Return the message shown in a currently displayed modal, or throw if--- no modal is displayed.+-- | Return the message shown in a currently displayed modal, or throw if no modal is displayed. ----- See <https://w3c.github.io/webdriver/#get-alert-text>+-- See <https://w3c.github.io/webdriver/#get-alert-text>. getAlertText :: (HasCallStack, Marionette m) => m Text getAlertText = value <$> sendCommand "WebDriver:GetAlertText"  -- | Determine the accessibility label for an element. ----- See <https://w3c.github.io/webdriver/#get-computed-label>+-- See <https://w3c.github.io/webdriver/#get-computed-label>. getComputedLabel :: (HasCallStack, Marionette m) => Element -> m Text getComputedLabel Element{..} =     value@@ -415,7 +399,7 @@  -- | Determine the accessibility role for an element. ----- See <https://w3c.github.io/webdriver/#get-computed-role>+-- See <https://w3c.github.io/webdriver/#get-computed-role>. getComputedRole :: (HasCallStack, Marionette m) => Element -> m Text getComputedRole Element{..} =     value@@ -425,24 +409,23 @@                 , parameters = Aeson.object ["id" .= elementId]                 } --- | Get all the cookies for the current domain. Equivalent to calling--- @document.cookie@ and parsing the result.+-- | Get all the cookies for the current domain. Equivalent to calling @document.cookie@ and+-- parsing the result. ----- See <https://w3c.github.io/webdriver/#get-all-cookies>+-- See <https://w3c.github.io/webdriver/#get-all-cookies>. getCookies :: (HasCallStack, Marionette m) => m [Cookie] getCookies = sendCommand "WebDriver:GetCookies" --- | Get a string representing the current URL, equivalent to--- @document.location.href@. When in the chrome context, return the--- canonical URL of the current resource.+-- | Get a string representing the current URL, equivalent to @document.location.href@.+-- When in the chrome context, return the canonical URL of the current resource. ----- See <https://w3c.github.io/webdriver/#get-current-url>+-- See <https://w3c.github.io/webdriver/#get-current-url>. getCurrentURL :: (HasCallStack, Marionette m) => m Text getCurrentURL = value <$> sendCommand "WebDriver:GetCurrentURL"  -- | Get the value of the given attribute of an element. ----- See <https://w3c.github.io/webdriver/#get-element-attribute>+-- See <https://w3c.github.io/webdriver/#get-element-attribute>. getElementAttribute :: (HasCallStack, Marionette m) => Text -> Element -> m (Maybe Text) getElementAttribute attr Element{..} =     value@@ -458,7 +441,7 @@  -- | Get the given CSS property of the computed style of an element. ----- See <https://w3c.github.io/webdriver/#get-element-css-value>+-- See <https://w3c.github.io/webdriver/#get-element-css-value>. getElementCSSValue :: (HasCallStack, Marionette m) => Element -> Text -> m (Maybe Text) getElementCSSValue Element{..} propertyName =     value@@ -474,7 +457,7 @@  -- | Get the value of the given property of an element. ----- See <https://w3c.github.io/webdriver/#get-element-property>+-- See <https://w3c.github.io/webdriver/#get-element-property>. getElementProperty :: (HasCallStack, Marionette m) => Element -> Text -> m (Maybe Text) getElementProperty Element{..} name =     value@@ -490,7 +473,7 @@  -- | Get the dimensions and coordinates of an element. ----- See <https://w3c.github.io/webdriver/#get-element-rect>+-- See <https://w3c.github.io/webdriver/#get-element-rect>. getElementRect :: (HasCallStack, Marionette m) => Element -> m Rect getElementRect Element{..} =     sendCommand@@ -501,7 +484,7 @@  -- | Get the local tag name of an element. ----- See <https://w3c.github.io/webdriver/#get-element-tag-name>+-- See <https://w3c.github.io/webdriver/#get-element-tag-name>. getElementTagName :: (HasCallStack, Marionette m) => Element -> m Text getElementTagName Element{..} =     value@@ -511,10 +494,9 @@                 , parameters = Aeson.object ["id" .= elementId]                 } --- | Get the rendered text of an element, including the text of all its--- child elements.+-- | Get the rendered text of an element, including the text of all its child elements. ----- See <https://w3c.github.io/webdriver/#get-element-text>+-- See <https://w3c.github.io/webdriver/#get-element-text>. getElementText :: (HasCallStack, Marionette m) => Element -> m Text getElementText Element{..} =     value@@ -526,13 +508,13 @@  -- | Get the page source of the content document, serialised as a string. ----- See <https://w3c.github.io/webdriver/#get-page-source>+-- See <https://w3c.github.io/webdriver/#get-page-source>. getPageSource :: (HasCallStack, Marionette m) => m Text getPageSource = value <$> sendCommand "WebDriver:GetPageSource"  -- | Get the shadow root of an element. ----- See <https://w3c.github.io/webdriver/#get-element-shadow-root>+-- See <https://w3c.github.io/webdriver/#get-element-shadow-root>. getShadowRoot :: (HasCallStack, Marionette m) => Element -> m Shadow getShadowRoot Element{..} =     value@@ -544,42 +526,40 @@  -- | Get the timeouts for page loading, searching, and scripts. ----- See <https://w3c.github.io/webdriver/#get-timeouts>+-- See <https://w3c.github.io/webdriver/#get-timeouts>. getTimeouts :: (HasCallStack, Marionette m) => m Timeouts getTimeouts = sendCommand "WebDriver:GetTimeouts"  -- | Get the current title of the window. ----- See <https://w3c.github.io/webdriver/#get-title>+-- See <https://w3c.github.io/webdriver/#get-title>. getTitle :: (HasCallStack, Marionette m) => m Text getTitle = value <$> sendCommand "WebDriver:GetTitle" --- | Get the current window's handle: an opaque, server-assigned--- identifier that can be used to switch back to this window later with--- 'switchToWindow'.+-- | Get the current window's handle: an opaque, server-assigned identifier+-- that can be used to switch back to this window later with 'switchToWindow'. ----- See <https://w3c.github.io/webdriver/#get-window-handle>+-- See <https://w3c.github.io/webdriver/#get-window-handle>. getWindowHandle :: (HasCallStack, Marionette m) => m WindowHandle getWindowHandle = value <$> sendCommand "WebDriver:GetWindowHandle" --- | Get the unordered list of window handles of every open top-level--- browsing context.+-- | Get the unordered list of window handles of every open top-level browsing context. ----- See <https://w3c.github.io/webdriver/#get-window-handles>+-- See <https://w3c.github.io/webdriver/#get-window-handles>. getWindowHandles :: (HasCallStack, Marionette m) => m [WindowHandle] getWindowHandles = sendCommand "WebDriver:GetWindowHandles"  -- | Get the position and size of the browser window currently in focus.--- The width and height refer to the window's @outerWidth@ and--- @outerHeight@, which include scroll bars, title bars, and so on.+-- The width and height refer to the window's @outerWidth@ and @outerHeight@,+-- which include scroll bars, title bars, and so on. ----- See <https://w3c.github.io/webdriver/#get-window-rect>+-- See <https://w3c.github.io/webdriver/#get-window-rect>. getWindowRect :: (HasCallStack, Marionette m) => m Rect getWindowRect = sendCommand "WebDriver:GetWindowRect"  -- | Check whether an element is displayed. ----- See <https://w3c.github.io/webdriver/#element-displayedness>+-- See <https://w3c.github.io/webdriver/#element-displayedness>. isElementDisplayed :: (HasCallStack, Marionette m) => Element -> m Bool isElementDisplayed Element{..} =     value@@ -591,7 +571,7 @@  -- | Check whether an element is enabled. ----- See <https://w3c.github.io/webdriver/#is-element-enabled>+-- See <https://w3c.github.io/webdriver/#is-element-enabled>. isElementEnabled :: (HasCallStack, Marionette m) => Element -> m Bool isElementEnabled Element{..} =     value@@ -603,7 +583,7 @@  -- | Check whether an element is selected. ----- See <https://w3c.github.io/webdriver/#is-element-selected>+-- See <https://w3c.github.io/webdriver/#is-element-selected>. isElementSelected :: (HasCallStack, Marionette m) => Element -> m Bool isElementSelected Element{..} =     value@@ -616,21 +596,21 @@ -- | Maximise the window, as if the user had pressed the maximise button. -- Not supported on Android. ----- See <https://w3c.github.io/webdriver/#maximize-window>+-- See <https://w3c.github.io/webdriver/#maximize-window>. maximizeWindow :: (HasCallStack, Marionette m) => m () maximizeWindow = sendCommand_ "WebDriver:MaximizeWindow"  -- | Minimise the window, as if the user had pressed the minimise button. -- Not supported on Android. ----- See <https://w3c.github.io/webdriver/#minimize-window>+-- See <https://w3c.github.io/webdriver/#minimize-window>. minimizeWindow :: (HasCallStack, Marionette m) => m () minimizeWindow = sendCommand_ "WebDriver:MinimizeWindow" --- | Navigate to the given URL, waiting for the document to load or the--- session's page load timeout to elapse before returning.+-- | Navigate to the given URL, waiting for the document to load or the session's page load+-- timeout to elapse before returning. ----- See <https://w3c.github.io/webdriver/#navigate-to>+-- See <https://w3c.github.io/webdriver/#navigate-to>. navigate :: (HasCallStack, Marionette m) => Text -> m () navigate url =     sendCommand_@@ -639,16 +619,15 @@             , parameters = Aeson.object ["url" .= url]             } --- | Create a new WebDriver session. Must be called before performing any--- other command.+-- | Create a new WebDriver session. Must be called before performing any other command. ----- See <https://w3c.github.io/webdriver/#new-session>+-- See <https://w3c.github.io/webdriver/#new-session>. newSession :: (HasCallStack, Marionette m) => m () newSession = sendCommand_ "WebDriver:NewSession"  -- | Open a new top-level browsing context of type window. ----- See <https://w3c.github.io/webdriver/#new-window>+-- See <https://w3c.github.io/webdriver/#new-window>. newWindow :: (HasCallStack, Marionette m) => m NewWindowResult newWindow =     sendCommand@@ -659,7 +638,7 @@  -- | Open a new top-level browsing context of type tab. ----- See <https://w3c.github.io/webdriver/#new-window>+-- See <https://w3c.github.io/webdriver/#new-window>. newTab :: (HasCallStack, Marionette m) => m NewWindowResult newTab =     sendCommand@@ -668,37 +647,39 @@             , parameters = Aeson.object ["type" .= Tab]             } --- | Perform a series of grouped input actions at the specified points in--- time.+-- | Perform a series of grouped input actions at the specified points in time. ----- See <https://w3c.github.io/webdriver/#perform-actions>-performActions :: (HasCallStack, Marionette m) => m ()-performActions = sendCommand_ "WebDriver:PerformActions"+-- See <https://w3c.github.io/webdriver/#perform-actions>.+performActions :: (HasCallStack, Marionette m) => [InputSource] -> m ()+performActions actions =+    sendCommand_+        Command+            { command = "WebDriver:PerformActions"+            , parameters = Aeson.object ["actions" .= actions]+            }  -- | Print the current page, returning it as a base64-encoded PDF. ----- See <https://w3c.github.io/webdriver/#print-page>+-- See <https://w3c.github.io/webdriver/#print-page>. print :: (HasCallStack, Marionette m) => m () print = sendCommand_ "WebDriver:Print"  -- | Reload the page in the current top-level browsing context. ----- See <https://w3c.github.io/webdriver/#refresh>+-- See <https://w3c.github.io/webdriver/#refresh>. refresh :: (HasCallStack, Marionette m) => m () refresh = sendCommand_ "WebDriver:Refresh" --- | Release all the keys and pointer buttons that are currently--- depressed.+-- | Release all the keys and pointer buttons that are currently depressed. ----- See <https://w3c.github.io/webdriver/#release-actions>+-- See <https://w3c.github.io/webdriver/#release-actions>. releaseActions :: (HasCallStack, Marionette m) => m () releaseActions = sendCommand_ "WebDriver:ReleaseActions" --- | Send keys to the input field of a currently displayed modal, or--- throw if no modal is displayed, or the modal has no means for text--- input.+-- | Send keys to the input field of a currently displayed modal, or throw if no modal is+-- displayed, or the modal has no means for text input. ----- See <https://w3c.github.io/webdriver/#send-alert-text>+-- See <https://w3c.github.io/webdriver/#send-alert-text>. sendAlertText :: (HasCallStack, Marionette m) => Text -> m () sendAlertText text =     sendCommand_@@ -707,16 +688,15 @@             , parameters = Aeson.object ["text" .= text]             } --- | Simulate user modification of a permission descriptor's permission--- state.+-- | Simulate user modification of a permission descriptor's permission state. ----- See <https://www.w3.org/TR/permissions/#webdriver-command-set-permission>+-- See <https://www.w3.org/TR/permissions/#webdriver-command-set-permission>. setPermission :: (HasCallStack, Marionette m) => m () setPermission = sendCommand_ "WebDriver:SetPermission"  -- | Set the timeouts for page loading, searching, and scripts. ----- See <https://w3c.github.io/webdriver/#set-timeouts>+-- See <https://w3c.github.io/webdriver/#set-timeouts>. setTimeouts :: (HasCallStack, Marionette m) => Timeouts -> m () setTimeouts timeouts =     sendCommand_@@ -725,12 +705,11 @@             , 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.+-- | Set the position and size of the window on the operating system's window manager.+-- The width and height refer to the window's @outerWidth@ and @outerHeight@, which include+-- browser chrome and OS-level window borders. ----- See <https://w3c.github.io/webdriver/#set-window-rect>+-- See <https://w3c.github.io/webdriver/#set-window-rect>. setWindowRect :: (HasCallStack, Marionette m) => Rect -> m () setWindowRect rect =     sendCommand_@@ -741,7 +720,7 @@  -- | Switch to the given frame within the current window. ----- See <https://w3c.github.io/webdriver/#switch-to-frame>+-- See <https://w3c.github.io/webdriver/#switch-to-frame>. switchToFrame :: (HasCallStack, Marionette m) => Frame -> m () switchToFrame frame =     sendCommand_@@ -750,17 +729,17 @@             , parameters = toJSON frame             } --- | Set the current browsing context for future commands to the parent--- of the current browsing context.+-- | Set the current browsing context for future commands to the parent of the current browsing+-- context. ----- See <https://w3c.github.io/webdriver/#switch-to-parent-frame>+-- See <https://w3c.github.io/webdriver/#switch-to-parent-frame>. switchToParentFrame :: (HasCallStack, Marionette m) => m () switchToParentFrame = sendCommand_ "WebDriver:SwitchToParentFrame"  -- | Switch to the top-level browsing context identified by the given -- window handle. ----- See <https://w3c.github.io/webdriver/#switch-to-window>+-- See <https://w3c.github.io/webdriver/#switch-to-window>. switchToWindow :: (HasCallStack, Marionette m) => WindowHandle -> m () switchToWindow window =     sendCommand_@@ -769,10 +748,9 @@             , parameters = toJSON window             } --- | Take a screenshot of the current frame, returned as a lossless PNG--- image.+-- | Take a screenshot of the current frame as a lossless PNG image. ----- See <https://w3c.github.io/webdriver/#take-screenshot>+-- See <https://w3c.github.io/webdriver/#take-screenshot>. takeScreenshot :: (HasCallStack, Marionette m) => m ByteString takeScreenshot =     Base64.decodeLenient@@ -786,7 +764,7 @@  -- | Add a credential to a virtual authenticator. ----- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-add-credential>+-- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-add-credential>. addCredential :: (HasCallStack, Marionette m) => AuthenticatorId -> Credential -> m () addCredential authenticatorId credential =     sendCommand_@@ -803,7 +781,7 @@  -- | Add a virtual authenticator, returning its identifier. ----- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-add-virtual-authenticator>+-- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-add-virtual-authenticator>. addVirtualAuthenticator :: (HasCallStack, Marionette m) => VirtualAuthenticator -> m AuthenticatorId addVirtualAuthenticator authenticator =     value@@ -815,7 +793,7 @@  -- | Get the credentials stored in a virtual authenticator. ----- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-get-credentials>+-- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-get-credentials>. getCredentials :: (HasCallStack, Marionette m) => AuthenticatorId -> m [Credential] getCredentials authenticatorId =     value@@ -827,7 +805,7 @@  -- | Remove all credentials from a virtual authenticator. ----- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-remove-all-credentials>+-- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-remove-all-credentials>. removeAllCredentials :: (HasCallStack, Marionette m) => AuthenticatorId -> m () removeAllCredentials authenticatorId =     sendCommand_@@ -838,7 +816,7 @@  -- | Remove a credential from a virtual authenticator. ----- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-remove-credential>+-- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-remove-credential>. removeCredential :: (HasCallStack, Marionette m) => AuthenticatorId -> CredentialId -> m () removeCredential authenticatorId credentialId =     sendCommand_@@ -853,7 +831,7 @@  -- | Remove a virtual authenticator. ----- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-remove-virtual-authenticator>+-- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-remove-virtual-authenticator>. removeVirtualAuthenticator :: (HasCallStack, Marionette m) => AuthenticatorId -> m () removeVirtualAuthenticator authenticatorId =     sendCommand_@@ -864,7 +842,7 @@  -- | Set the user-verified flag on a virtual authenticator. ----- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-set-user-verified>+-- See <https://www.w3.org/TR/webauthn-3/#sctn-automation-set-user-verified>. setUserVerified :: (HasCallStack, Marionette m) => AuthenticatorId -> Bool -> m () setUserVerified authenticatorId verified =     sendCommand_

@@ -0,0 +1,129 @@+module Test.Marionette.Key where++import Data.Aeson (ToJSON (..), Value (String))+import Data.Text qualified as Text+import Prelude hiding (Left, Right)++-- | Key values representing special keys and arbitrary characters, as defined in the+-- <https://www.w3.org/TR/webdriver/#keyboard-actions W3C WebDriver specification>.+data Key+    = Null+    | Cancel+    | Help+    | Backspace+    | Tab+    | Clear+    | Return+    | Enter+    | Shift+    | Control+    | Alt+    | Pause+    | Escape+    | Space+    | PageUp+    | PageDown+    | End+    | Home+    | Left+    | UpArrow+    | Right+    | DownArrow+    | Insert+    | Delete+    | Semicolon+    | Equals+    | Numpad0+    | Numpad1+    | Numpad2+    | Numpad3+    | Numpad4+    | Numpad5+    | Numpad6+    | Numpad7+    | Numpad8+    | Numpad9+    | Multiply+    | Add+    | Separator+    | Subtract+    | Decimal+    | Divide+    | F1+    | F2+    | F3+    | F4+    | F5+    | F6+    | F7+    | F8+    | F9+    | F10+    | F11+    | F12+    | Meta+    | ZenkakuHankaku+    | Key Char+    deriving stock (Show, Eq)++char :: Key -> Char+char Null = '\xE000'+char Cancel = '\xE001'+char Help = '\xE002'+char Backspace = '\xE003'+char Tab = '\xE004'+char Clear = '\xE005'+char Return = '\xE006'+char Enter = '\xE007'+char Shift = '\xE008'+char Control = '\xE009'+char Alt = '\xE00A'+char Pause = '\xE00B'+char Escape = '\xE00C'+char Space = '\xE00D'+char PageUp = '\xE00E'+char PageDown = '\xE00F'+char End = '\xE010'+char Home = '\xE011'+char Left = '\xE012'+char UpArrow = '\xE013'+char Right = '\xE014'+char DownArrow = '\xE015'+char Insert = '\xE016'+char Delete = '\xE017'+char Semicolon = '\xE018'+char Equals = '\xE019'+char Numpad0 = '\xE01A'+char Numpad1 = '\xE01B'+char Numpad2 = '\xE01C'+char Numpad3 = '\xE01D'+char Numpad4 = '\xE01E'+char Numpad5 = '\xE01F'+char Numpad6 = '\xE020'+char Numpad7 = '\xE021'+char Numpad8 = '\xE022'+char Numpad9 = '\xE023'+char Multiply = '\xE024'+char Add = '\xE025'+char Separator = '\xE026'+char Subtract = '\xE027'+char Decimal = '\xE028'+char Divide = '\xE029'+char F1 = '\xE031'+char F2 = '\xE032'+char F3 = '\xE033'+char F4 = '\xE034'+char F5 = '\xE035'+char F6 = '\xE036'+char F7 = '\xE037'+char F8 = '\xE038'+char F9 = '\xE039'+char F10 = '\xE03A'+char F11 = '\xE03B'+char F12 = '\xE03C'+char Meta = '\xE03D'+char ZenkakuHankaku = '\xE040'+char (Key c) = c++instance ToJSON Key where+    toJSON = String . Text.singleton . char

@@ -104,8 +104,7 @@                         else Left <$> parseJSON err             _ -> mzero --- | An error reported by a Marionette or WebDriver command, as returned by--- the server.+-- | An error reported by a Marionette or WebDriver command, as returned by the server. -- -- See <https://w3c.github.io/webdriver/#errors> data Error = Error@@ -127,4 +126,4 @@     , marionetteProtocol :: Int     }     deriving stock (Generic, Show)-    deriving anyclass (FromJSON)+    deriving anyclass (FromJSON, ToJSON)

@@ -6,8 +6,6 @@ import GHC.Generics (Generic) import Prelude --------------------------------------------------------------------- data RegistryEntry = RegistryEntry     { entryType :: Text     , namespace :: Text

@@ -21,7 +21,7 @@     | ByXPath Text     | Anon Text     | AnonAttribute Text-    deriving stock (Generic, Eq, Show)+    deriving stock (Generic, Eq, Ord, Show)     deriving anyclass (Hashable)  toObject :: Selector -> Object

@@ -0,0 +1,150 @@+module Main where++import Data.Aeson qualified as Aeson+import Data.Binary qualified as Binary+import Network.Simple.TCP+    ( HostPreference (Host)+    , Socket+    , accept+    , closeSock+    , listen+    , sendLazy+    )+import Network.Socket (PortNumber, socketPort)+import Test.Hspec (describe, hspec, it)+import Test.Hspec.Expectations.Lifted (shouldReturn, shouldSatisfy)+import Test.Marionette.Class (sendCommand)+import Test.Marionette.Client+    ( MarionetteTimeout (..)+    , SocketClosed (..)+    , incoming+    , runMarionetteTWith+    )+import Test.Marionette.Protocol+import UnliftIO (TQueue, async, cancel, finally, timeout, try)+import UnliftIO.STM (atomically, readTQueue)+import Prelude++withServer :: (Socket -> TQueue MarionetteMessage -> IO ()) -> (PortNumber -> IO a) -> IO a+withServer serve body =+    listen (Host "127.0.0.1") "0" \(listening, _) -> do+        port <- socketPort listening+        handling <-+            async $ accept listening \(socket, _) ->+                serve socket =<< incoming socket \_ -> pure ()+        body port `finally` cancel handling++send :: (Aeson.ToJSON a) => Socket -> a -> IO ()+send socket = sendLazy socket . Binary.encode . MarionetteMessage . Aeson.encode++recv :: TQueue MarionetteMessage -> IO (Message Command)+recv frames = do+    MarionetteMessage lbs <- atomically $ readTQueue frames+    either fail pure $ Aeson.eitherDecode lbs++greeting :: Greeting+greeting = Greeting{applicationType = "fake", marionetteProtocol = 3}++reply :: Socket -> Message Command -> Result -> IO ()+reply socket Message{messageId} result =+    send socket Message{messageId, messageContent = result}++testCommandTimeout :: Int+testCommandTimeout = 200_000++main :: IO ()+main = hspec do+    describe "incoming" do+        it "reports SocketClosed when the server hangs up" $+            withServer+                ( \socket _frames -> do+                    send socket greeting+                    closeSock socket+                )+                \port -> do+                    outcome <-+                        timeout 2_000_000 . try $+                            runMarionetteTWith+                                "127.0.0.1"+                                port+                                testCommandTimeout+                                (sendCommand @_ @Aeson.Value "noop")++                    outcome `shouldSatisfy` \case+                        Just (Left SocketClosed) -> True+                        _ -> False++    describe "sendCommand" do+        it "throws MarionetteTimeout without killing the session" $+            withServer+                ( \socket frames -> do+                    send socket greeting+                    _silent <- recv frames+                    echoed <- recv frames+                    reply socket echoed $ Right (Aeson.String "ok")+                )+                \port ->+                    runMarionetteTWith "127.0.0.1" port testCommandTimeout do+                        silent <- try $ sendCommand @_ @Aeson.Value "silent"+                        silent `shouldSatisfy` \case+                            Left MarionetteTimeout{} -> True+                            _ -> False+                        sendCommand "echo" `shouldReturn` Aeson.String "ok"++        it "reports connection loss promptly, waking a command already in flight" $+            withServer+                ( \socket frames -> do+                    send socket greeting+                    _abandoned <- recv frames+                    closeSock socket+                )+                \port -> do+                    outcome <-+                        timeout 2_000_000 . try $+                            runMarionetteTWith+                                "127.0.0.1"+                                port+                                testCommandTimeout+                                (sendCommand @_ @Aeson.Value "abandoned")++                    outcome `shouldSatisfy` \case+                        Just (Left SocketClosed) -> True+                        _ -> False++        it "surfaces a server-reported Error rather than a transport failure" $+            withServer+                ( \socket frames -> do+                    send socket greeting+                    command <- recv frames+                    reply socket command $+                        Left Error{error = "no such element", message = "nope", stacktrace = ""}+                )+                \port -> do+                    outcome <-+                        try $+                            runMarionetteTWith+                                "127.0.0.1"+                                port+                                testCommandTimeout+                                (sendCommand @_ @Aeson.Value "find")++                    outcome `shouldSatisfy` \case+                        Left Error{message = "nope"} -> True+                        _ -> False++        it "discards a reply that arrives after its command already timed out" $+            withServer+                ( \socket frames -> do+                    send socket greeting+                    slow <- recv frames+                    echoed <- recv frames -- only received once the client gives up on "slow"+                    reply socket slow $ Right (Aeson.String "too late")+                    reply socket echoed $ Right (Aeson.String "ok")+                )+                \port ->+                    runMarionetteTWith "127.0.0.1" port testCommandTimeout do+                        slow <- try $ sendCommand @_ @Aeson.Value "slow"+                        slow `shouldSatisfy` \case+                            Left MarionetteTimeout{} -> True+                            _ -> False+                        sendCommand "echo" `shouldReturn` Aeson.String "ok"

@@ -1,18 +1,20 @@-{-# OPTIONS_GHC -Wno-orphans #-}- module Main where -import Control.Concurrent (forkIO, killThread)-import Control.Exception (bracket)+import Control.Exception (Exception, bracket, throwIO) import Data.Aeson (toJSON) import Data.ByteString qualified as ByteString import Data.Functor (void)+import Data.Maybe (isNothing) import Data.Text (Text) import Data.Text qualified as Text import Lucid import Network.HTTP.Types (status200)+import Network.Socket (PortNumber) import Network.Wai (Application, rawPathInfo, responseLBS)-import Network.Wai.Handler.Warp (run)+import Network.Wai.Handler.Warp (Port, testWithApplication)+import System.Directory (doesFileExist)+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory) import System.Process.Typed     ( checkExitCode     , nullStream@@ -21,13 +23,17 @@     , setStdout     , startProcess     )-import Test.Hspec (describe, hspec, it)+import Test.Hspec (Spec, describe, hspec)+import Test.Hspec qualified as Hspec import Test.Hspec.Expectations.Lifted-import Test.Marionette+import Test.Marionette hiding (navigate)+import Test.Marionette qualified as Marionette import Test.Marionette.Cookie qualified as Cookie+import Test.Marionette.Key qualified as Key import Test.Marionette.Rect qualified as Rect import Test.Marionette.Timeouts qualified as Timeouts import Test.Marionette.WebAuthn qualified as WebAuthn+import UnliftIO.Retry (constantDelay, limitRetriesByCumulativeDelay, retrying) import Prelude hiding (print)  page :: Text -> Html () -> Html ()@@ -69,6 +75,48 @@                     button_ [id_ "alert-btn", onclick_ "alert('Hello!')"] "Alert"                     button_ [id_ "confirm-btn", onclick_ "confirm('Sure?')"] "Confirm"                     button_ [id_ "prompt-btn", onclick_ "prompt('Input:')"] "Prompt"+            "/actions" ->+                page "Actions Page" do+                    style_+                        "\+                        \#hover-target { width: 100px; height: 100px; background: red; }\+                        \#hover-target:hover { background: green; }\+                        \#drag-source { position: absolute; top: 0; left: 0; width: 50px; height: 50px; background: blue; }\+                        \#drop-target { position: absolute; top: 200px; left: 200px; width: 100px; height: 100px; background: yellow; }\+                        \#scroll-container { height: 100px; overflow: auto; }\+                        \#scroll-container div { height: 1000px; }"+                    div_+                        [ id_ "hover-target"+                        , onmouseover_ "this.dataset.hovered = 'true'"+                        , onmouseout_ "this.dataset.hovered = 'false'"+                        ]+                        "Hover me"+                    div_ [id_ "drag-source"] "Drag"+                    div_ [id_ "drop-target"] "Drop"+                    button_ [id_ "shift-click-btn", onclick_ "this.dataset.shift = event.shiftKey"] "Click"+                    div_ [id_ "scroll-container"] (div_ mempty "tall content")+                    script_+                        "\+                        \(function () {\+                        \  const source = document.getElementById('drag-source');\+                        \  const target = document.getElementById('drop-target');\+                        \  let dragging = false;\+                        \  source.addEventListener('pointerdown', () => { dragging = true; });\+                        \  document.addEventListener('pointermove', (e) => {\+                        \    if (!dragging) return;\+                        \    source.style.left = (e.clientX - 25) + 'px';\+                        \    source.style.top = (e.clientY - 25) + 'px';\+                        \  });\+                        \  document.addEventListener('pointerup', () => {\+                        \    if (!dragging) return;\+                        \    dragging = false;\+                        \    const sr = source.getBoundingClientRect();\+                        \    const tr = target.getBoundingClientRect();\+                        \    const overlap = sr.left < tr.right && sr.right > tr.left\+                        \      && sr.top < tr.bottom && sr.bottom > tr.top;\+                        \    target.dataset.dropped = overlap ? 'true' : 'false';\+                        \  });\+                        \})();"             _ ->                 page "Marionette Test" do                     h1_ [id_ "heading"] "Hello, Marionette!"@@ -77,66 +125,86 @@                     div_ [id_ "parent"] do                         span_ [id_ "child"] "Child element" -withTestServer :: IO a -> IO a-withTestServer = bracket (forkIO $ run 8080 app) killThread . const+newtype MarionetteDidNotStart = MarionetteDidNotStart FilePath+    deriving stock (Show)+    deriving anyclass (Exception) -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+awaitMarionettePort :: FilePath -> IO PortNumber+awaitMarionettePort profile = do+    port <-+        retrying+            (limitRetriesByCumulativeDelay 5_000_000 $ constantDelay 100_000)+            (const $ pure . isNothing)+            (const poll)+    maybe (throwIO $ MarionetteDidNotStart activePortPath) pure port+  where+    activePortPath = profile </> "MarionetteActivePort"+    poll =+        doesFileExist activePortPath >>= \case+            True -> Just . read <$> readFile activePortPath+            False -> pure Nothing -run' :: (HasCallStack) => MarionetteT IO () -> IO ()-run' action = runMarionetteT do-    newSession-    navigate "http://localhost:8080/"-    action-    deleteSession+withFirefox :: (PortNumber -> IO a) -> IO a+withFirefox action =+    withSystemTempDirectory "marionette-test-profile" \profile -> do+        writeFile (profile </> "user.js") "user_pref(\"marionette.port\", 0);\n"+        bracket+            ( do+                process <-+                    startProcess+                        . setStdout nullStream+                        . setStderr nullStream+                        . proc "firefox"+                        $ [ "--profile"+                          , profile+                          , "--marionette"+                          , "--headless"+                          , "-remote-allow-system-access"+                          ]+                port <- awaitMarionettePort profile+                pure (process, port)+            )+            ( \(process, port) -> do+                runMarionetteTWith "localhost" port defaultCommandTimeout $ newSession >> quit+                checkExitCode process+            )+            (action . snd)  main :: IO ()-main = withTestServer . withFirefox . hspec $ do+main = testWithApplication (pure app) $ (withFirefox . (hspec .)) . spec++spec :: Port -> PortNumber -> Spec+spec httpPort marionettePort = describe "Marionette" do     describe "Session" do-        it "can create and delete a session" . run' $ do+        it "can create and delete a session" do             deleteSession             newSession      describe "Navigation" do-        it "navigates to a URL" . run' $ getCurrentURL `shouldReturn` "http://localhost:8080/"+        it "navigates to a URL" $ getCurrentURL `shouldReturn` url "/" -        it "can go back and forward" . run' $ do-            navigate "http://localhost:8080/target"+        it "can go back and forward" do+            navigate "/target"             back-            getCurrentURL `shouldReturn` "http://localhost:8080/"+            getCurrentURL `shouldReturn` url "/"             forward-            getCurrentURL `shouldReturn` "http://localhost:8080/target"+            getCurrentURL `shouldReturn` url "/target" -        it "can refresh" . run' $ do+        it "can refresh" do             refresh-            getCurrentURL `shouldReturn` "http://localhost:8080/"+            getCurrentURL `shouldReturn` url "/" -        it "getTitle returns page title" . run' $ getTitle `shouldReturn` "Marionette Test"+        it "getTitle returns page title" $ getTitle `shouldReturn` "Marionette Test" -        it "getPageSource returns HTML" . run' $ do+        it "getPageSource returns HTML" do             source <- getPageSource             source `shouldSatisfy` Text.isInfixOf "Hello, Marionette!" -        it "getCurrentURL returns current URL" . run' $-            getCurrentURL `shouldReturn` "http://localhost:8080/"+        it "getCurrentURL returns current URL" $+            getCurrentURL `shouldReturn` url "/"      describe "Timeouts" do-        it "setTimeouts / getTimeouts roundtrip" . run' $ do+        it "setTimeouts / getTimeouts roundtrip" do             let t =                     Timeouts                         { script = Just 5000@@ -147,20 +215,20 @@             getTimeouts `shouldReturn` t      describe "Window" do-        it "getWindowHandle returns a handle" . run' $ do+        it "getWindowHandle returns a handle" do             handle <- getWindowHandle             handle `shouldSatisfy` not . null . show -        it "getWindowHandles returns at least one handle" . run' $ do+        it "getWindowHandles returns at least one handle" do             handles <- getWindowHandles             handles `shouldSatisfy` not . null -        it "getWindowRect returns a rect" . run' $ do+        it "getWindowRect returns a rect" do             Rect{..} <- getWindowRect             width `shouldSatisfy` (> 0)             height `shouldSatisfy` (> 0) -        it "setWindowRect / getWindowRect roundtrip" . run' $ do+        it "setWindowRect / getWindowRect roundtrip" do             let r =                     Rect                         { x = 0@@ -171,18 +239,18 @@             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 "maximizeWindow does not throw" maximizeWindow+        it "minimizeWindow does not throw" minimizeWindow+        it "fullscreenWindow does not throw" fullscreenWindow -        it "newTab opens a new window handle" . run' $ do+        it "newTab opens a new window handle" do             before <- getWindowHandles             NewWindowResult{..} <- newTab             -- newWindowType `shouldBe` Tab             after <- getWindowHandles             after `shouldBe` before <> [newWindowHandle] -        it "newWindow opens a new window handle" . run' $ do+        it "newWindow opens a new window handle" do             before <- getWindowHandles             NewWindowResult{..} <- newTab             -- This does not seem to work@@ -190,7 +258,7 @@             after <- getWindowHandles             after `shouldBe` before <> [newWindowHandle] -        it "switchToWindow and closeWindow" . run' $ do+        it "switchToWindow and closeWindow" do             original <- getWindowHandle             NewWindowResult{..} <- newTab             switchToWindow newWindowHandle@@ -200,141 +268,141 @@             getWindowHandle `shouldReturn` original      describe "Element finding" do-        it "findElement by id" . run' $ do+        it "findElement by id" do             el <- findElement (ById "heading")             getElementText el `shouldReturn` "Hello, Marionette!" -        it "findElement by class" . run' $ do+        it "findElement by class" do             el <- findElement (ByClass "content")             getElementText el `shouldReturn` "Test paragraph" -        it "findElement by tag" . run' $ do+        it "findElement by tag" do             el <- findElement (ByTag "h1")             getElementText el `shouldReturn` "Hello, Marionette!" -        it "findElement by CSS selector" . run' $ do+        it "findElement by CSS selector" do             el <- findElement (ByCSS "#heading")             getElementText el `shouldReturn` "Hello, Marionette!" -        it "findElement by XPath" . run' $ do+        it "findElement by XPath" do             el <- findElement (ByXPath "//h1[@id='heading']")             getElementText el `shouldReturn` "Hello, Marionette!" -        it "findElements returns multiple elements" . run' $ do+        it "findElements returns multiple elements" do             els <- findElements (ByClass "content")             length els `shouldBe` 2 -        it "findElementFrom finds child within parent" . run' $ do+        it "findElementFrom finds child within parent" do             parent <- findElement (ById "parent")             child <- findElementFrom parent (ById "child")             getElementText child `shouldReturn` "Child element" -        it "findElementsFrom finds children within parent" . run' $ do+        it "findElementsFrom finds children within parent" 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"+        it "findElement by link text" do+            navigate "/link"             el <- findElement (ByLinkText "Click me")             getElementText el `shouldReturn` "Click me" -        it "findElement by partial link text" . run' $ do-            navigate "http://localhost:8080/link"+        it "findElement by partial link text" do+            navigate "/link"             el <- findElement (ByPartialLinkText "Click here")             text <- getElementText el             text `shouldSatisfy` Text.isInfixOf "Click here"      describe "Element properties" do-        it "getElementAttribute" . run' $ do+        it "getElementAttribute" do             el <- findElement (ById "para")             getElementAttribute "class" el `shouldReturn` Just "content" -        it "getElementProperty" . run' $ do+        it "getElementProperty" do             el <- findElement (ById "para")             getElementProperty el "id" `shouldReturn` Just "para" -        it "getElementTagName" . run' $ do+        it "getElementTagName" do             el <- findElement (ById "heading")             getElementTagName el `shouldReturn` "h1" -        it "getElementRect" . run' $ do+        it "getElementRect" do             el <- findElement (ById "heading")             Rect{..} <- getElementRect el             width `shouldSatisfy` (> 0) -        it "getElementCSSValue" . run' $ do+        it "getElementCSSValue" do             el <- findElement (ById "heading")             val <- getElementCSSValue el "display"             val `shouldSatisfy` not . null . show -        it "getComputedRole" . run' $ do+        it "getComputedRole" do             el <- findElement (ById "heading")             role <- getComputedRole el             role `shouldSatisfy` not . Text.null -        it "getComputedLabel" . run' $ do-            navigate "http://localhost:8080/form"+        it "getComputedLabel" do+            navigate "/form"             el <- findElement (ById "submit")             label <- getComputedLabel el             label `shouldSatisfy` not . Text.null -        it "isElementDisplayed" . run' $ do-            navigate "http://localhost:8080/"+        it "isElementDisplayed" do+            navigate "/"             el <- findElement (ById "heading")             isElementDisplayed el `shouldReturn` True -        it "isElementEnabled" . run' $ do-            navigate "http://localhost:8080/form"+        it "isElementEnabled" do+            navigate "/form"             el <- findElement (ById "text-input")             isElementEnabled el `shouldReturn` True -        it "isElementSelected for unchecked checkbox" . run' $ do-            navigate "http://localhost:8080/form"+        it "isElementSelected for unchecked checkbox" do+            navigate "/form"             el <- findElement (ById "checkbox")             isElementSelected el `shouldReturn` False -        it "getActiveElement does not throw" . run' . void $ getActiveElement+        it "getActiveElement does not throw" $ void getActiveElement      describe "Element interaction" do-        it "elementClick navigates via link" . run' $ do-            navigate "http://localhost:8080/link"+        it "elementClick navigates via link" do+            navigate "/link"             el <- findElement (ById "link")             elementClick el-            getCurrentURL `shouldReturn` "http://localhost:8080/target"+            getCurrentURL `shouldReturn` url "/target" -        it "elementSendKeys fills input" . run' $ do-            navigate "http://localhost:8080/form"+        it "elementSendKeys fills input" do+            navigate "/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"+        it "elementClear clears input" do+            navigate "/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+        it "executeScript returns a value" $             executeScript "return 1 + 1" [] `shouldReturn` (2 :: Int) -        it "executeScript can access elements" . run' $ do-            navigate "http://localhost:8080/"+        it "executeScript can access elements" do+            navigate "/"             executeScript                 "return document.getElementById(arguments[0]).textContent"                 [toJSON @Text "heading"]                 `shouldReturn` ("Hello, Marionette!" :: Text) -        it "executeAsyncScript returns a value" . run' $ do+        it "executeAsyncScript returns a value" 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+        it "addCookie / getCookies roundtrip" do             deleteAllCookies             let cookie =                     Cookie@@ -350,7 +418,7 @@             cookies <- getCookies             cookies `shouldSatisfy` any \c -> Cookie.name c == "test" -        it "deleteCookie removes a cookie" . run' $ do+        it "deleteCookie removes a cookie" do             deleteAllCookies             let cookie =                     Cookie@@ -367,67 +435,67 @@             cookies <- getCookies             cookies `shouldNotSatisfy` any \c -> Cookie.name c == "test" -        it "deleteAllCookies removes all cookies" . run' $ do+        it "deleteAllCookies removes all cookies" do             deleteAllCookies             getCookies `shouldReturn` []      describe "Alerts" do-        it "acceptAlert dismisses an alert" . run' $ do-            navigate "http://localhost:8080/alert"+        it "acceptAlert dismisses an alert" do+            navigate "/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"+        it "dismissAlert dismisses a confirm dialog" do+            navigate "/alert"             el <- findElement (ById "confirm-btn")             elementClick el             dismissAlert -        it "sendAlertText fills a prompt" . run' $ do-            navigate "http://localhost:8080/alert"+        it "sendAlertText fills a prompt" do+            navigate "/alert"             el <- findElement (ById "prompt-btn")             elementClick el             sendAlertText "my input"             acceptAlert      describe "Frames" do-        it "switchToParentFrame does not throw" . run' $ switchToParentFrame+        it "switchToParentFrame does not throw" switchToParentFrame      describe "Context" do-        it "getContext returns a context" . run' $ do+        it "getContext returns a context" do             ctx <- getContext             ctx `shouldSatisfy` (`elem` [minBound .. maxBound]) -        it "setContext / getContext roundtrip" . run' $ do+        it "setContext / getContext roundtrip" 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"+        it "getShadowRoot / findElementFromShadowRoot" do+            navigate "/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"+        it "findElementsFromShadowRoot" do+            navigate "/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+        it "takeScreenshot returns non-empty bytes" do             bytes <- takeScreenshot             ByteString.length bytes `shouldNotBe` 0      describe "WebAuthn" do-        it "addVirtualAuthenticator / getCredentials roundtrip" . run' $ do+        it "addVirtualAuthenticator / getCredentials roundtrip" do             let opts =                     VirtualAuthenticator                         { protocol = "ctap2"@@ -443,7 +511,7 @@             getCredentials aid `shouldReturn` []             removeVirtualAuthenticator aid -        it "setUserVerified does not throw" . run' $ do+        it "setUserVerified does not throw" do             let opts =                     VirtualAuthenticator                         { protocol = "ctap2"@@ -460,7 +528,7 @@             setUserVerified aid True             removeVirtualAuthenticator aid -        it "removeAllCredentials does not throw" . run' $ do+        it "removeAllCredentials does not throw" do             let opts =                     VirtualAuthenticator                         { protocol = "ctap2"@@ -475,3 +543,79 @@             aid <- addVirtualAuthenticator opts             removeAllCredentials aid             removeVirtualAuthenticator aid++    describe "Actions" do+        it "hovering dispatches mouseover/mouseout and real CSS :hover state" do+            navigate "/actions"+            target <- findElement (ById "hover-target")+            getElementAttribute "data-hovered" target `shouldReturn` Nothing+            getElementCSSValue target "background-color" `shouldReturn` Just "rgb(255, 0, 0)"+            performActions [mouse [PointerMove 0 (FromElement target) 0 0]]+            getElementAttribute "data-hovered" target `shouldReturn` Just "true"+            getElementCSSValue target "background-color" `shouldReturn` Just "rgb(0, 128, 0)"+            performActions [mouse [PointerMove 0 Viewport 0 0]]+            getElementAttribute "data-hovered" target `shouldReturn` Just "false"+            getElementCSSValue target "background-color" `shouldReturn` Just "rgb(255, 0, 0)"+            releaseActions++        it "drags an element onto a drop target" do+            navigate "/actions"+            source <- findElement (ById "drag-source")+            target <- findElement (ById "drop-target")+            getElementAttribute "data-dropped" target `shouldReturn` Nothing+            performActions+                [ mouse+                    [ PointerMove 0 (FromElement source) 0 0+                    , PointerDown LeftButton+                    , PointerMove 200 (FromElement target) 0 0+                    , PointerUp LeftButton+                    ]+                ]+            getElementAttribute "data-dropped" target `shouldReturn` Just "true"+            releaseActions++        it "combines a held key and a pointer click into one gesture" do+            navigate "/actions"+            button <- findElement (ById "shift-click-btn")+            performActions+                [ keyboard [KeyDown Key.Shift]+                , mouse+                    [ PointerMove 0 (FromElement button) 0 0+                    , PointerDown LeftButton+                    , PointerUp LeftButton+                    ]+                ]+            getElementAttribute "data-shift" button `shouldReturn` Just "true"+            releaseActions+            elementClick button+            getElementAttribute "data-shift" button `shouldReturn` Just "false"++        it "releaseActions lets go of a key held with no matching keyUp" do+            navigate "/actions"+            button <- findElement (ById "shift-click-btn")+            performActions [keyboard [KeyDown Key.Shift]]+            releaseActions+            elementClick button+            getElementAttribute "data-shift" button `shouldReturn` Just "false"++        it "scrolls a container via a wheel action" do+            navigate "/actions"+            container <- findElement (ById "scroll-container")+            (before :: Double) <- executeScript "return arguments[0].scrollTop" [toJSON container]+            before `shouldBe` 0+            -- A zero duration reliably does not scroll in headless Firefox,+            -- unlike pointer moves/clicks, which work fine at duration 0.+            performActions [wheel [Scroll 100 (FromElement container) 0 0 0 200]]+            (after :: Double) <- executeScript "return arguments[0].scrollTop" [toJSON container]+            after `shouldSatisfy` (> 0)+  where+    url path = "http://localhost:" <> Text.show httpPort <> path++    navigate = Marionette.navigate . url++    it :: (HasCallStack) => String -> MarionetteT IO () -> Spec+    it label action = Hspec.it label $ runMarionetteTWith "localhost" marionettePort defaultCommandTimeout do+        newSession+        navigate "/"+        action+        deleteSession