diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/marionette-effectful.cabal b/marionette-effectful.cabal --- a/marionette-effectful.cabal +++ b/marionette-effectful.cabal @@ -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, diff --git a/src/Effectful/Marionette.hs b/src/Effectful/Marionette.hs --- a/src/Effectful/Marionette.hs +++ b/src/Effectful/Marionette.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 = '

Shadow content

';" - "/alert" -> - page "Alert Page" do - button_ [id_ "alert-btn", onclick_ "alert('Hello!')"] "Alert" - button_ [id_ "confirm-btn", onclick_ "confirm('Sure?')"] "Confirm" - button_ [id_ "prompt-btn", onclick_ "prompt('Input:')"] "Prompt" - _ -> - page "Marionette Test" do - h1_ [id_ "heading"] "Hello, Marionette!" - p_ [id_ "para", class_ "content"] "Test paragraph" - p_ [id_ "para2", class_ "content"] "Second paragraph" - div_ [id_ "parent"] do - span_ [id_ "child"] "Child element" +app :: Application es +app _req respond = + respond . responseLBS status200 [("Content-Type", "text/html")] $ + "Marionette Smoke Test\ + \

Hello, Marionette!

\ + \

One

Two

" -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