marionette-effectful 1.0.0 → 1.0.1

raw patch · 4 files changed

+140/−461 lines, 4 filesdep +directorydep +filepathdep +networkdep −lucid2dep −waidep −warpdep ~marionettePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: directory, filepath, network, retry-effectful, wai-effectful, warp-effectful

Dependencies removed: lucid2, wai, warp

Dependency ranges changed: marionette

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• marionette-effectful.cabal +13/−7
• src/Effectful/Marionette.hs +16/−7
• test/Main.hs +105/−447

@@ -5,6 +5,12 @@ 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.1] - 2026-10-01++### Added++- `runMarionetteWith`, allowing connections to an arbitrary host and port.+ ## [1.0.0] - 2026-07-14  ### Added

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: marionette-effectful-version: 1.0.0+version: 1.0.1 category: Web synopsis: Effectful driver for Marionette description:@@ -43,6 +43,7 @@     MultiParamTypeClasses     NamedFieldPuns     NoImplicitPrelude+    NumericUnderscores     OverloadedLabels     OverloadedRecordDot     OverloadedStrings@@ -57,14 +58,15 @@    build-depends:     base >=4.16 && <5,-    effectful >=2.6 && <2.7,-    marionette >=1.0 && <1.1,+    effectful >=2.6 && <2.8,+    marionette >=1.0 && <1.2,  library   import: common   hs-source-dirs: src   build-depends:     mtl >=2.3 && <2.4,+    network >=3.2 && <3.3,     unliftio >=0.2 && <0.3,    exposed-modules:@@ -79,11 +81,15 @@   build-depends:     aeson >=2.2 && <2.3,     bytestring >=0.12 && <0.13,-    hspec-effectful >=1.0 && <1.1,+    directory >=1.3 && <1.4,+    filepath >=1.5 && <1.6,+    hspec-effectful >=1.0 && <1.2,     http-types >=0.12 && <0.13,-    lucid2 >=0.0 && <0.1,     marionette-effectful,+    mtl >=2.3 && <2.4,+    network >=3.2 && <3.3,+    retry-effectful >=0.1 && <0.2,     text >=2.1 && <2.2,     typed-process-effectful >=1.0 && <1.1,-    wai >=3.2 && <3.3,-    warp >=3.4 && <3.5,+    wai-effectful >=1.0 && <1.1,+    warp-effectful >=1.0 && <1.2,

@@ -77,6 +77,7 @@     ( -- * Effect       Marionette     , runMarionette+    , runMarionetteWith        -- * Re-exports from @Marionette@     , module Test.Marionette@@ -104,6 +105,7 @@     , unsafeEff_     ) import Effectful.Exception (catch, throwIO)+import Network.Socket (HostName, PortNumber) import Test.Marionette hiding (Marionette) import Test.Marionette qualified as Marionette import Test.Marionette.Class qualified as Marionette@@ -125,13 +127,20 @@         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+-- | Run an action against a Marionette server.+runMarionetteWith     :: (IOE :> es)-    => Eff (Marionette ': es) a+    => HostName+    -> PortNumber+    -> Int+    -- ^ Command timeout, in microseconds.+    -> Eff (Marionette ': es) a     -> Eff es a-runMarionette action =-    withEffToIO (ConcUnlift Ephemeral Unlimited) \unlift -> runMarionetteT $+runMarionetteWith host port commandTimeout action =+    withEffToIO (ConcUnlift Ephemeral Unlimited) \unlift -> runMarionetteTWith host port commandTimeout $         withRunInIO \runInIO -> unlift . evalStaticRep (Marionette runInIO) $ action++-- | Run an action against a Marionette server listening on @localhost:2828@+-- (started by launching Firefox with the @--marionette@ flag).+runMarionette :: (IOE :> es) => Eff (Marionette ': es) a -> Eff es a+runMarionette = runMarionetteWith "localhost" 2828 defaultCommandTimeout

@@ -1,19 +1,19 @@-{-# OPTIONS_GHC -Wno-orphans #-}- module Main where -import Data.Aeson (toJSON)+import Control.Exception (Exception)+import Control.Monad.Error.Class (catchError)+import Data.Aeson (object, toJSON, (.=)) import Data.ByteString qualified as ByteString-import Data.Functor (void)-import Data.Text (Text)+import Data.Maybe (isNothing) import Data.Text qualified as Text import Effectful-import Effectful.Concurrent (Concurrent, forkIO, killThread, runConcurrent)-import Effectful.Exception (bracket)-import Effectful.Hspec+import Effectful.Exception (bracket, finally, throwIO)+import Effectful.Hspec hiding (it)+import Effectful.Hspec qualified as Hspec import Effectful.Marionette import Effectful.Process.Typed-    ( checkExitCode+    ( TypedProcess+    , checkExitCode     , nullStream     , proc     , runTypedProcess@@ -21,458 +21,116 @@     , setStdout     , startProcess     )-import Lucid+import Effectful.Retry (constantDelay, limitRetriesByCumulativeDelay, retrying, runRetry)+import Effectful.Temporary (Temporary, runTemporary, withSystemTempDirectory)+import Effectful.Wai (Application, responseLBS)+import Effectful.Wai.Handler.Warp (Port, testWithApplication) 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+import Network.Socket (PortNumber)+import System.Directory (doesFileExist)+import System.FilePath ((</>))+import Test.Marionette.Class (sendCommands)+import Prelude -app :: Application-app req respond =-    respond-        . responseLBS status200 [("Content-Type", "text/html")]-        . renderBS-        $ case rawPathInfo req of-            "/form" ->-                page "Form Page" do-                    form_ do-                        input_ [id_ "text-input", type_ "text", name_ "q"]-                        input_ [id_ "checkbox", type_ "checkbox", name_ "check"]-                        select_ [id_ "select"] do-                            option_ [value_ "a"] "Option A"-                            option_ [value_ "b"] "Option B"-                        button_ [id_ "submit", type_ "submit"] "Submit"-            "/link" ->-                page "Link Page" do-                    a_ [id_ "link", href_ "/target"] "Click me"-                    a_ [id_ "partial", href_ "/target"] "Click here for more"-            "/target" ->-                page "Target Page" do-                    p_ [id_ "result"] "You arrived!"-            "/shadow" ->-                page "Shadow DOM Page" do-                    div_ [id_ "host"] mempty-                    script_-                        "\-                        \const host = document.getElementById('host');\-                        \const shadow = host.attachShadow({mode: 'open'});\-                        \shadow.innerHTML = '<p id=\"shadow-p\">Shadow content</p>';"-            "/alert" ->-                page "Alert Page" do-                    button_ [id_ "alert-btn", onclick_ "alert('Hello!')"] "Alert"-                    button_ [id_ "confirm-btn", onclick_ "confirm('Sure?')"] "Confirm"-                    button_ [id_ "prompt-btn", onclick_ "prompt('Input:')"] "Prompt"-            _ ->-                page "Marionette Test" do-                    h1_ [id_ "heading"] "Hello, Marionette!"-                    p_ [id_ "para", class_ "content"] "Test paragraph"-                    p_ [id_ "para2", class_ "content"] "Second paragraph"-                    div_ [id_ "parent"] do-                        span_ [id_ "child"] "Child element"+app :: Application es+app _req respond =+    respond . responseLBS status200 [("Content-Type", "text/html")] $+        "<!DOCTYPE html><html><head><title>Marionette Smoke Test</title></head>\+        \<body><h1 id=\"heading\">Hello, Marionette!</h1>\+        \<p class=\"item\">One</p><p class=\"item\">Two</p></body></html>" -runTestServer :: (IOE :> es, Concurrent :> es) => Eff es a -> Eff es a-runTestServer = bracket (forkIO . liftIO $ run 8080 app) killThread . const+newtype MarionetteDidNotStart = MarionetteDidNotStart FilePath+    deriving stock (Show)+    deriving anyclass (Exception) -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"-                  ]+withFirefox+    :: (IOE :> es, Temporary :> es, TypedProcess :> es)+    => (PortNumber -> Eff es a)+    -> Eff es a+withFirefox action =+    withSystemTempDirectory "marionette-effectful-test-profile" \profile -> do+        liftIO $ 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 -> do-                runMarionette $ newSession >> quit+            ( \(process, port) -> do+                runMarionetteWith "localhost" port defaultCommandTimeout $ 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+            (action . snd)+  where+    activePortPath :: FilePath -> FilePath+    activePortPath profile = profile </> "MarionetteActivePort"+    awaitMarionettePort :: (IOE :> es) => FilePath -> Eff es PortNumber+    awaitMarionettePort profile = runRetry $ do+        port <-+            retrying+                (limitRetriesByCumulativeDelay 5_000_000 $ constantDelay 100_000)+                (const $ pure . isNothing)+                (const $ poll profile)+        maybe (throwIO $ MarionetteDidNotStart $ activePortPath profile) pure port+    poll :: (IOE :> es) => FilePath -> Eff es (Maybe PortNumber)+    poll profile =+        liftIO (doesFileExist $ activePortPath profile) >>= \case+            True -> Just . read <$> liftIO (readFile $ activePortPath profile)+            False -> pure Nothing  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+main = runEff . runTypedProcess . runTemporary $+    testWithApplication (pure app) \httpPort -> withFirefox \marionettePort ->+        runMarionetteWith "localhost" marionettePort defaultCommandTimeout . runHspec $+            spec httpPort -    describe "Context" do-        it "getContext returns a context" . run' $ do-            ctx <- getContext-            ctx `shouldSatisfy` (`elem` [minBound .. maxBound])+spec :: (Hspec :> es, Marionette :> es) => Port -> Eff es ()+spec httpPort = describe "Marionette" do+    Hspec.it "creates and deletes a session" $ newSession >> deleteSession -        it "setContext / getContext roundtrip" . run' $ do-            setContext ContentContext-            getContext `shouldReturn` ContentContext-            setContext ChromeContext-            getContext `shouldReturn` ChromeContext+    it "navigates and reads the page title" do+        getTitle `shouldReturn` "Marionette Smoke Test" -    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 "finds an element and reads its text" do+        el <- findElement (ById "heading")+        getElementText el `shouldReturn` "Hello, Marionette!" -        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+    it "finds multiple elements" do+        els <- findElements (ByClass "item")+        length els `shouldBe` 2 -    describe "Screenshots" do-        it "takeScreenshot returns non-empty bytes" . run' $ do-            bytes <- takeScreenshot-            ByteString.length bytes `shouldNotBe` 0+    it "executes a script with arguments" do+        executeScript "return arguments[0] + 1" [toJSON @Int 41] `shouldReturn` (42 :: Int) -    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 "surfaces a command failure via MonadError" do+        found <-+            (Just <$> findElement (ById "missing"))+                `catchError` \(_ :: Error) -> pure Nothing+        found `shouldBe` (Nothing :: Maybe Element) -        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 "sendCommands runs multiple commands directly" do+        results <- sendCommands ["WebDriver:GetTitle", "WebDriver:GetCurrentURL"]+        case results of+            [title, currentUrl] -> do+                title `shouldBe` object ["value" .= ("Marionette Smoke Test" :: String)]+                currentUrl `shouldSatisfy` (/= toJSON @String "")+            _ -> expectationFailure "expected two results" -        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+    it "takes a screenshot" do+        bytes <- takeScreenshot+        ByteString.length bytes `shouldNotBe` 0+  where+    url = "http://localhost:" <> Text.show httpPort <> "/"+    it label action = Hspec.it label do+        newSession+        (navigate url >> action) `finally` deleteSession