marionette-effectful-1.0.1: test/Main.hs

module Main where

import Control.Exception (Exception)
import Control.Monad.Error.Class (catchError)
import Data.Aeson (object, toJSON, (.=))
import Data.ByteString qualified as ByteString
import Data.Maybe (isNothing)
import Data.Text qualified as Text
import Effectful
import Effectful.Exception (bracket, finally, throwIO)
import Effectful.Hspec hiding (it)
import Effectful.Hspec qualified as Hspec
import Effectful.Marionette
import Effectful.Process.Typed
    ( TypedProcess
    , checkExitCode
    , nullStream
    , proc
    , runTypedProcess
    , setStderr
    , setStdout
    , startProcess
    )
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.Socket (PortNumber)
import System.Directory (doesFileExist)
import System.FilePath ((</>))
import Test.Marionette.Class (sendCommands)
import Prelude

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

newtype MarionetteDidNotStart = MarionetteDidNotStart FilePath
    deriving stock (Show)
    deriving anyclass (Exception)

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, port) -> do
                runMarionetteWith "localhost" port defaultCommandTimeout $ newSession >> quit
                checkExitCode process
            )
            (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 . runTypedProcess . runTemporary $
    testWithApplication (pure app) \httpPort -> withFirefox \marionettePort ->
        runMarionetteWith "localhost" marionettePort defaultCommandTimeout . runHspec $
            spec httpPort

spec :: (Hspec :> es, Marionette :> es) => Port -> Eff es ()
spec httpPort = describe "Marionette" do
    Hspec.it "creates and deletes a session" $ newSession >> deleteSession

    it "navigates and reads the page title" do
        getTitle `shouldReturn` "Marionette Smoke Test"

    it "finds an element and reads its text" do
        el <- findElement (ById "heading")
        getElementText el `shouldReturn` "Hello, Marionette!"

    it "finds multiple elements" do
        els <- findElements (ByClass "item")
        length els `shouldBe` 2

    it "executes a script with arguments" do
        executeScript "return arguments[0] + 1" [toJSON @Int 41] `shouldReturn` (42 :: Int)

    it "surfaces a command failure via MonadError" do
        found <-
            (Just <$> findElement (ById "missing"))
                `catchError` \(_ :: Error) -> pure Nothing
        found `shouldBe` (Nothing :: Maybe Element)

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