{-# OPTIONS_GHC -Wno-orphans #-}
module Main where
import Control.Concurrent (forkIO, killThread)
import Control.Exception (bracket)
import Data.Aeson (toJSON)
import Data.ByteString qualified as ByteString
import Data.Functor (void)
import Data.Text (Text)
import Data.Text qualified as Text
import Lucid
import Network.HTTP.Types (status200)
import Network.Wai (Application, rawPathInfo, responseLBS)
import Network.Wai.Handler.Warp (run)
import System.Process.Typed
( checkExitCode
, nullStream
, proc
, setStderr
, setStdout
, startProcess
)
import Test.Hspec (describe, hspec, it)
import Test.Hspec.Expectations.Lifted
import Test.Marionette
import Test.Marionette.Cookie qualified as Cookie
import Test.Marionette.Rect qualified as Rect
import Test.Marionette.Timeouts qualified as Timeouts
import Test.Marionette.WebAuthn qualified as WebAuthn
import Prelude hiding (print)
page :: Text -> Html () -> Html ()
page title body =
html_ do
head_ $ title_ (toHtml title)
body_ body
app :: Application
app req respond =
respond . responseLBS status200 [("Content-Type", "text/html")] . renderBS $
case rawPathInfo req of
"/form" ->
page "Form Page" do
form_ do
input_ [id_ "text-input", type_ "text", name_ "q"]
input_ [id_ "checkbox", type_ "checkbox", name_ "check"]
select_ [id_ "select"] do
option_ [value_ "a"] "Option A"
option_ [value_ "b"] "Option B"
button_ [id_ "submit", type_ "submit"] "Submit"
"/link" ->
page "Link Page" do
a_ [id_ "link", href_ "/target"] "Click me"
a_ [id_ "partial", href_ "/target"] "Click here for more"
"/target" ->
page "Target Page" do
p_ [id_ "result"] "You arrived!"
"/shadow" ->
page "Shadow DOM Page" do
div_ [id_ "host"] mempty
script_
"\
\const host = document.getElementById('host');\
\const shadow = host.attachShadow({mode: 'open'});\
\shadow.innerHTML = '<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"
withTestServer :: IO a -> IO a
withTestServer = bracket (forkIO $ run 8080 app) killThread . const
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
run' :: (HasCallStack) => MarionetteT IO () -> IO ()
run' action = runMarionetteT do
newSession
navigate "http://localhost:8080/"
action
deleteSession
main :: IO ()
main = withTestServer . withFirefox . hspec $ do
describe "Session" do
it "can create and delete a session" . run' $ do
deleteSession
newSession
describe "Navigation" do
it "navigates to a URL" . run' $ getCurrentURL `shouldReturn` "http://localhost:8080/"
it "can go back and forward" . run' $ do
navigate "http://localhost:8080/target"
back
getCurrentURL `shouldReturn` "http://localhost:8080/"
forward
getCurrentURL `shouldReturn` "http://localhost:8080/target"
it "can refresh" . run' $ do
refresh
getCurrentURL `shouldReturn` "http://localhost:8080/"
it "getTitle returns page title" . run' $ getTitle `shouldReturn` "Marionette Test"
it "getPageSource returns HTML" . run' $ do
source <- getPageSource
source `shouldSatisfy` Text.isInfixOf "Hello, Marionette!"
it "getCurrentURL returns current URL" . run' $
getCurrentURL `shouldReturn` "http://localhost:8080/"
describe "Timeouts" do
it "setTimeouts / getTimeouts roundtrip" . run' $ do
let t =
Timeouts
{ script = Just 5000
, pageLoad = Just 10000
, implicit = Just 0
}
setTimeouts t
getTimeouts `shouldReturn` t
describe "Window" do
it "getWindowHandle returns a handle" . run' $ do
handle <- getWindowHandle
handle `shouldSatisfy` not . null . show
it "getWindowHandles returns at least one handle" . run' $ do
handles <- getWindowHandles
handles `shouldSatisfy` not . null
it "getWindowRect returns a rect" . run' $ do
Rect{..} <- getWindowRect
width `shouldSatisfy` (> 0)
height `shouldSatisfy` (> 0)
it "setWindowRect / getWindowRect roundtrip" . run' $ do
let r =
Rect
{ x = 0
, y = 0
, width = 800
, height = 600
}
setWindowRect r
getWindowRect `shouldReturn` r
it "maximizeWindow does not throw" $ run' maximizeWindow
it "minimizeWindow does not throw" $ run' minimizeWindow
it "fullscreenWindow does not throw" $ run' fullscreenWindow
it "newTab opens a new window handle" . run' $ do
before <- getWindowHandles
NewWindowResult{..} <- newTab
-- newWindowType `shouldBe` Tab
after <- getWindowHandles
after `shouldBe` before <> [newWindowHandle]
it "newWindow opens a new window handle" . run' $ do
before <- getWindowHandles
NewWindowResult{..} <- newTab
-- This does not seem to work
-- newWindowType `shouldBe` Window
after <- getWindowHandles
after `shouldBe` before <> [newWindowHandle]
it "switchToWindow and closeWindow" . run' $ do
original <- getWindowHandle
NewWindowResult{..} <- newTab
switchToWindow newWindowHandle
getWindowHandle `shouldReturn` newWindowHandle
closeWindow
switchToWindow original
getWindowHandle `shouldReturn` original
describe "Element finding" do
it "findElement by id" . run' $ do
el <- findElement (ById "heading")
getElementText el `shouldReturn` "Hello, Marionette!"
it "findElement by class" . run' $ do
el <- findElement (ByClass "content")
getElementText el `shouldReturn` "Test paragraph"
it "findElement by tag" . run' $ do
el <- findElement (ByTag "h1")
getElementText el `shouldReturn` "Hello, Marionette!"
it "findElement by CSS selector" . run' $ do
el <- findElement (ByCSS "#heading")
getElementText el `shouldReturn` "Hello, Marionette!"
it "findElement by XPath" . run' $ do
el <- findElement (ByXPath "//h1[@id='heading']")
getElementText el `shouldReturn` "Hello, Marionette!"
it "findElements returns multiple elements" . run' $ do
els <- findElements (ByClass "content")
length els `shouldBe` 2
it "findElementFrom finds child within parent" . run' $ do
parent <- findElement (ById "parent")
child <- findElementFrom parent (ById "child")
getElementText child `shouldReturn` "Child element"
it "findElementsFrom finds children within parent" . run' $ do
parent <- findElement (ById "parent")
children :: [Element] <- findElementsFrom parent (ByTag "span")
length children `shouldBe` 1
it "findElement by link text" . run' $ do
navigate "http://localhost:8080/link"
el <- findElement (ByLinkText "Click me")
getElementText el `shouldReturn` "Click me"
it "findElement by partial link text" . run' $ do
navigate "http://localhost:8080/link"
el <- findElement (ByPartialLinkText "Click here")
text <- getElementText el
text `shouldSatisfy` Text.isInfixOf "Click here"
describe "Element properties" do
it "getElementAttribute" . run' $ do
el <- findElement (ById "para")
getElementAttribute "class" el `shouldReturn` Just "content"
it "getElementProperty" . run' $ do
el <- findElement (ById "para")
getElementProperty el "id" `shouldReturn` Just "para"
it "getElementTagName" . run' $ do
el <- findElement (ById "heading")
getElementTagName el `shouldReturn` "h1"
it "getElementRect" . run' $ do
el <- findElement (ById "heading")
Rect{..} <- getElementRect el
width `shouldSatisfy` (> 0)
it "getElementCSSValue" . run' $ do
el <- findElement (ById "heading")
val <- getElementCSSValue el "display"
val `shouldSatisfy` not . null . show
it "getComputedRole" . run' $ do
el <- findElement (ById "heading")
role <- getComputedRole el
role `shouldSatisfy` not . Text.null
it "getComputedLabel" . run' $ do
navigate "http://localhost:8080/form"
el <- findElement (ById "submit")
label <- getComputedLabel el
label `shouldSatisfy` not . Text.null
it "isElementDisplayed" . run' $ do
navigate "http://localhost:8080/"
el <- findElement (ById "heading")
isElementDisplayed el `shouldReturn` True
it "isElementEnabled" . run' $ do
navigate "http://localhost:8080/form"
el <- findElement (ById "text-input")
isElementEnabled el `shouldReturn` True
it "isElementSelected for unchecked checkbox" . run' $ do
navigate "http://localhost:8080/form"
el <- findElement (ById "checkbox")
isElementSelected el `shouldReturn` False
it "getActiveElement does not throw" . run' . void $ getActiveElement
describe "Element interaction" do
it "elementClick navigates via link" . run' $ do
navigate "http://localhost:8080/link"
el <- findElement (ById "link")
elementClick el
getCurrentURL `shouldReturn` "http://localhost:8080/target"
it "elementSendKeys fills input" . run' $ do
navigate "http://localhost:8080/form"
el <- findElement (ById "text-input")
elementSendKeys el "hello"
getElementProperty el "value" `shouldReturn` Just "hello"
it "elementClear clears input" . run' $ do
navigate "http://localhost:8080/form"
el <- findElement (ById "text-input")
elementSendKeys el "hello"
elementClear el
getElementProperty el "value" `shouldReturn` Just ""
describe "Script execution" do
it "executeScript returns a value" . run' $ do
executeScript "return 1 + 1" [] `shouldReturn` (2 :: Int)
it "executeScript can access elements" . run' $ do
navigate "http://localhost:8080/"
executeScript
"return document.getElementById(arguments[0]).textContent"
[toJSON @Text "heading"]
`shouldReturn` ("Hello, Marionette!" :: Text)
it "executeAsyncScript returns a value" . run' $ do
executeAsyncScript @_ @_ @Int
"const callback = arguments[arguments.length - 1]; setTimeout(() => callback(arguments[0]), 100)"
[toJSON @Int 42]
`shouldReturn` Just 42
describe "Cookies" do
it "addCookie / getCookies roundtrip" . run' $ do
deleteAllCookies
let cookie =
Cookie
{ name = "test"
, value = "value"
, path = Just "/"
, domain = Nothing
, secure = Just False
, httpOnly = Just False
, expiry = Nothing
}
addCookie cookie
cookies <- getCookies
cookies `shouldSatisfy` any \c -> Cookie.name c == "test"
it "deleteCookie removes a cookie" . run' $ do
deleteAllCookies
let cookie =
Cookie
{ name = "todelete"
, value = "x"
, path = Just "/"
, domain = Nothing
, secure = Just False
, httpOnly = Just False
, expiry = Nothing
}
addCookie cookie
deleteCookie "todelete"
cookies <- getCookies
cookies `shouldNotSatisfy` any \c -> Cookie.name c == "test"
it "deleteAllCookies removes all cookies" . run' $ do
deleteAllCookies
getCookies `shouldReturn` []
describe "Alerts" do
it "acceptAlert dismisses an alert" . run' $ do
navigate "http://localhost:8080/alert"
el <- findElement (ById "alert-btn")
elementClick el
getAlertText `shouldReturn` "Hello!"
acceptAlert
it "dismissAlert dismisses a confirm dialog" . run' $ do
navigate "http://localhost:8080/alert"
el <- findElement (ById "confirm-btn")
elementClick el
dismissAlert
it "sendAlertText fills a prompt" . run' $ do
navigate "http://localhost:8080/alert"
el <- findElement (ById "prompt-btn")
elementClick el
sendAlertText "my input"
acceptAlert
describe "Frames" do
it "switchToParentFrame does not throw" . run' $ switchToParentFrame
describe "Context" do
it "getContext returns a context" . run' $ do
ctx <- getContext
ctx `shouldSatisfy` (`elem` [minBound .. maxBound])
it "setContext / getContext roundtrip" . run' $ do
setContext ContentContext
getContext `shouldReturn` ContentContext
setContext ChromeContext
getContext `shouldReturn` ChromeContext
describe "Shadow DOM" do
it "getShadowRoot / findElementFromShadowRoot" . run' $ do
navigate "http://localhost:8080/shadow"
host <- findElement (ById "host")
shadow <- getShadowRoot host
el <- findElementFromShadowRoot shadow (ByCSS "#shadow-p")
getElementText el `shouldReturn` "Shadow content"
it "findElementsFromShadowRoot" . run' $ do
navigate "http://localhost:8080/shadow"
host <- findElement (ById "host")
shadow <- getShadowRoot host
els <- findElementsFromShadowRoot shadow (ByCSS "p")
length els `shouldBe` 1
describe "Screenshots" do
it "takeScreenshot returns non-empty bytes" . run' $ do
bytes <- takeScreenshot
ByteString.length bytes `shouldNotBe` 0
describe "WebAuthn" do
it "addVirtualAuthenticator / getCredentials roundtrip" . run' $ do
let opts =
VirtualAuthenticator
{ protocol = "ctap2"
, transport = "internal"
, hasResidentKey = True
, hasUserVerification = True
, isUserConsenting = True
, isUserVerified = True
, extensions = Nothing
, uvm = Nothing
}
aid <- addVirtualAuthenticator opts
getCredentials aid `shouldReturn` []
removeVirtualAuthenticator aid
it "setUserVerified does not throw" . run' $ do
let opts =
VirtualAuthenticator
{ protocol = "ctap2"
, transport = "internal"
, hasResidentKey = True
, hasUserVerification = True
, isUserConsenting = True
, isUserVerified = True
, extensions = Nothing
, uvm = Nothing
}
aid <- addVirtualAuthenticator opts
setUserVerified aid False
setUserVerified aid True
removeVirtualAuthenticator aid
it "removeAllCredentials does not throw" . run' $ do
let opts =
VirtualAuthenticator
{ protocol = "ctap2"
, transport = "internal"
, hasResidentKey = True
, hasUserVerification = True
, isUserConsenting = True
, isUserVerified = True
, extensions = Nothing
, uvm = Nothing
}
aid <- addVirtualAuthenticator opts
removeAllCredentials aid
removeVirtualAuthenticator aid