module Main where
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 (Port, testWithApplication)
import System.Directory (doesFileExist)
import System.FilePath ((</>))
import System.IO.Temp (withSystemTempDirectory)
import System.Process.Typed
( checkExitCode
, nullStream
, proc
, setStderr
, setStdout
, startProcess
)
import Test.Hspec (Spec, describe, hspec)
import Test.Hspec qualified as Hspec
import Test.Hspec.Expectations.Lifted
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 ()
page title body =
html_ do
head_ $ title_ (toHtml title)
body_ body
app :: Application
app req respond =
respond . responseLBS status200 [("Content-Type", "text/html")] . renderBS $
case rawPathInfo req of
"/form" ->
page "Form Page" do
form_ do
input_ [id_ "text-input", type_ "text", name_ "q"]
input_ [id_ "checkbox", type_ "checkbox", name_ "check"]
select_ [id_ "select"] do
option_ [value_ "a"] "Option A"
option_ [value_ "b"] "Option B"
button_ [id_ "submit", type_ "submit"] "Submit"
"/link" ->
page "Link Page" do
a_ [id_ "link", href_ "/target"] "Click me"
a_ [id_ "partial", href_ "/target"] "Click here for more"
"/target" ->
page "Target Page" do
p_ [id_ "result"] "You arrived!"
"/shadow" ->
page "Shadow DOM Page" do
div_ [id_ "host"] mempty
script_
"\
\const host = document.getElementById('host');\
\const shadow = host.attachShadow({mode: 'open'});\
\shadow.innerHTML = '<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"
"/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!"
p_ [id_ "para", class_ "content"] "Test paragraph"
p_ [id_ "para2", class_ "content"] "Second paragraph"
div_ [id_ "parent"] do
span_ [id_ "child"] "Child element"
newtype MarionetteDidNotStart = MarionetteDidNotStart FilePath
deriving stock (Show)
deriving anyclass (Exception)
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
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 = 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" do
deleteSession
newSession
describe "Navigation" do
it "navigates to a URL" $ getCurrentURL `shouldReturn` url "/"
it "can go back and forward" do
navigate "/target"
back
getCurrentURL `shouldReturn` url "/"
forward
getCurrentURL `shouldReturn` url "/target"
it "can refresh" do
refresh
getCurrentURL `shouldReturn` url "/"
it "getTitle returns page title" $ getTitle `shouldReturn` "Marionette Test"
it "getPageSource returns HTML" do
source <- getPageSource
source `shouldSatisfy` Text.isInfixOf "Hello, Marionette!"
it "getCurrentURL returns current URL" $
getCurrentURL `shouldReturn` url "/"
describe "Timeouts" do
it "setTimeouts / getTimeouts roundtrip" 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" do
handle <- getWindowHandle
handle `shouldSatisfy` not . null . show
it "getWindowHandles returns at least one handle" do
handles <- getWindowHandles
handles `shouldSatisfy` not . null
it "getWindowRect returns a rect" do
Rect{..} <- getWindowRect
width `shouldSatisfy` (> 0)
height `shouldSatisfy` (> 0)
it "setWindowRect / getWindowRect roundtrip" do
let r =
Rect
{ x = 0
, y = 0
, width = 800
, height = 600
}
setWindowRect r
getWindowRect `shouldReturn` r
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" do
before <- getWindowHandles
NewWindowResult{..} <- newTab
-- newWindowType `shouldBe` Tab
after <- getWindowHandles
after `shouldBe` before <> [newWindowHandle]
it "newWindow opens a new window handle" do
before <- getWindowHandles
NewWindowResult{..} <- newTab
-- This does not seem to work
-- newWindowType `shouldBe` Window
after <- getWindowHandles
after `shouldBe` before <> [newWindowHandle]
it "switchToWindow and closeWindow" do
original <- getWindowHandle
NewWindowResult{..} <- newTab
switchToWindow newWindowHandle
getWindowHandle `shouldReturn` newWindowHandle
closeWindow
switchToWindow original
getWindowHandle `shouldReturn` original
describe "Element finding" do
it "findElement by id" do
el <- findElement (ById "heading")
getElementText el `shouldReturn` "Hello, Marionette!"
it "findElement by class" do
el <- findElement (ByClass "content")
getElementText el `shouldReturn` "Test paragraph"
it "findElement by tag" do
el <- findElement (ByTag "h1")
getElementText el `shouldReturn` "Hello, Marionette!"
it "findElement by CSS selector" do
el <- findElement (ByCSS "#heading")
getElementText el `shouldReturn` "Hello, Marionette!"
it "findElement by XPath" do
el <- findElement (ByXPath "//h1[@id='heading']")
getElementText el `shouldReturn` "Hello, Marionette!"
it "findElements returns multiple elements" do
els <- findElements (ByClass "content")
length els `shouldBe` 2
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" do
parent <- findElement (ById "parent")
children :: [Element] <- findElementsFrom parent (ByTag "span")
length children `shouldBe` 1
it "findElement by link text" do
navigate "/link"
el <- findElement (ByLinkText "Click me")
getElementText el `shouldReturn` "Click me"
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" do
el <- findElement (ById "para")
getElementAttribute "class" el `shouldReturn` Just "content"
it "getElementProperty" do
el <- findElement (ById "para")
getElementProperty el "id" `shouldReturn` Just "para"
it "getElementTagName" do
el <- findElement (ById "heading")
getElementTagName el `shouldReturn` "h1"
it "getElementRect" do
el <- findElement (ById "heading")
Rect{..} <- getElementRect el
width `shouldSatisfy` (> 0)
it "getElementCSSValue" do
el <- findElement (ById "heading")
val <- getElementCSSValue el "display"
val `shouldSatisfy` not . null . show
it "getComputedRole" do
el <- findElement (ById "heading")
role <- getComputedRole el
role `shouldSatisfy` not . Text.null
it "getComputedLabel" do
navigate "/form"
el <- findElement (ById "submit")
label <- getComputedLabel el
label `shouldSatisfy` not . Text.null
it "isElementDisplayed" do
navigate "/"
el <- findElement (ById "heading")
isElementDisplayed el `shouldReturn` True
it "isElementEnabled" do
navigate "/form"
el <- findElement (ById "text-input")
isElementEnabled el `shouldReturn` True
it "isElementSelected for unchecked checkbox" do
navigate "/form"
el <- findElement (ById "checkbox")
isElementSelected el `shouldReturn` False
it "getActiveElement does not throw" $ void getActiveElement
describe "Element interaction" do
it "elementClick navigates via link" do
navigate "/link"
el <- findElement (ById "link")
elementClick el
getCurrentURL `shouldReturn` url "/target"
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" 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" $
executeScript "return 1 + 1" [] `shouldReturn` (2 :: Int)
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" 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" 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" 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" do
deleteAllCookies
getCookies `shouldReturn` []
describe "Alerts" do
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" do
navigate "/alert"
el <- findElement (ById "confirm-btn")
elementClick el
dismissAlert
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" switchToParentFrame
describe "Context" do
it "getContext returns a context" do
ctx <- getContext
ctx `shouldSatisfy` (`elem` [minBound .. maxBound])
it "setContext / getContext roundtrip" do
setContext ContentContext
getContext `shouldReturn` ContentContext
setContext ChromeContext
getContext `shouldReturn` ChromeContext
describe "Shadow DOM" do
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" 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" do
bytes <- takeScreenshot
ByteString.length bytes `shouldNotBe` 0
describe "WebAuthn" do
it "addVirtualAuthenticator / getCredentials roundtrip" do
let opts =
VirtualAuthenticator
{ protocol = "ctap2"
, transport = "internal"
, hasResidentKey = True
, hasUserVerification = True
, isUserConsenting = True
, isUserVerified = True
, extensions = Nothing
, uvm = Nothing
}
aid <- addVirtualAuthenticator opts
getCredentials aid `shouldReturn` []
removeVirtualAuthenticator aid
it "setUserVerified does not throw" do
let opts =
VirtualAuthenticator
{ protocol = "ctap2"
, transport = "internal"
, hasResidentKey = True
, hasUserVerification = True
, isUserConsenting = True
, isUserVerified = True
, extensions = Nothing
, uvm = Nothing
}
aid <- addVirtualAuthenticator opts
setUserVerified aid False
setUserVerified aid True
removeVirtualAuthenticator aid
it "removeAllCredentials does not throw" 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
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