Able to run webdriver demo using Nix

This commit is contained in:
Tom McLaughlin 2024-06-10 03:08:07 -07:00 committed by thomasjm
parent 1828e15538
commit 6d36f4fce6
26 changed files with 210 additions and 142 deletions

View File

@ -11,7 +11,7 @@ import Test.Sandwich.WebDriver
tests :: TopSpec
tests = describe "Selenium tests" $ introduceWebDriver (defaultWdOptions "/tmp/tools") $ do
tests = describe "Selenium tests" $ introduceWebDriver defaultWdOptions $ do
$(getSpecFromFolder defaultGetSpecFromFolderOptions)
main :: IO ()

View File

@ -16,7 +16,7 @@ import Test.WebDriver.Commands
simple :: TopSpecWithOptions
simple = introduceWebDriverOptions @() (defaultWdOptions "/tmp/tools") $ do
simple = introduceWebDriverOptions @() defaultWdOptions $ do
before "Position window" (withSession1 setWindowRightSide) $ do
it "opens Google" $ withSession1 $ do
openPage [i|https://www.google.com|]

View File

@ -63,7 +63,7 @@ claimWebdriver spec = introduceWith' (
tests :: TopSpecWithOptions
tests =
introduceWebDriverPool 4 (defaultWdOptions "/tmp/tools") $
introduceWebDriverPool 4 defaultWdOptions $
parallel $
replicateM_ 20 $
claimWebdriver $ it "opens Google" $ withSession1 $ openPage "http://www.google.com"

View File

@ -13,7 +13,7 @@ import Test.WebDriver.Commands
positioning :: TopSpec
positioning = introduceWebDriver (defaultWdOptions "/tmp/tools") $ do
positioning = introduceWebDriver defaultWdOptions $ do
describe "two windows side by side" $ do
it "opens Google" $ withSession1 $ do
openPage "http://www.google.com"

View File

@ -17,7 +17,7 @@ import UnliftIO.Exception
manualVideo :: TopSpec
manualVideo = introduceWebDriver (defaultWdOptions "/tmp/tools") $ do
manualVideo = introduceWebDriver defaultWdOptions $ do
describe "video recording" $ do
it "opens Google" $ withSession1 $ do
openPage "http://www.google.com"

View File

@ -1,8 +1,11 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Main where
import Control.Concurrent
@ -11,12 +14,13 @@ import qualified Data.ByteString.Lazy as BL
import Data.String.Interpolate
import System.FilePath
import Test.Sandwich
import Test.Sandwich.Contexts.Nix
import Test.Sandwich.WebDriver
import Test.WebDriver.Commands
simple :: TopSpecWithOptions
simple = introduceWebDriverOptions @() (defaultWdOptions "/tmp/tools") $ do
simple = introduceNixContext nixpkgsReleaseDefault $ introduceWebDriverViaNix defaultWdOptions $ do
it "opens Google and searches" $ withSession1 $ do
openPage [i|https://www.google.com|]
search <- findElem (ByCSS [i|*[title="Search"]|])
@ -27,7 +31,7 @@ simple = introduceWebDriverOptions @() (defaultWdOptions "/tmp/tools") $ do
Just dir <- getCurrentFolder
screenshot >>= liftIO . BL.writeFile (dir </> "screenshot.png")
liftIO $ threadDelay 3000000
liftIO $ threadDelay 3_000_000
testOptions = defaultOptions {
optionsTestArtifactsDirectory = defaultTestArtifactsDirectory

View File

@ -31,6 +31,7 @@ executable demo-webdriver
, bytestring
, filepath
, sandwich
, sandwich-contexts
, sandwich-webdriver
, string-interpolate
, webdriver

View File

@ -7,6 +7,7 @@ dependencies:
- bytestring
- filepath
- sandwich
- sandwich-contexts
- sandwich-webdriver
- string-interpolate
- webdriver

View File

@ -42,7 +42,7 @@ tests = do
UnitTests1.tests
UnitTests2.tests
introduceWebDriver (defaultWdOptions "/tmp/tools") $
introduceWebDriver defaultWdOptions $
describe "Selenium tests" $ do
SeleniumTests1.tests
SeleniumTests2.tests
@ -71,7 +71,7 @@ import Test.Sandwich.WebDriver
#insert_test_imports
tests :: TopSpec
tests = describe "Selenium tests" $ introduceWebDriver (defaultWdOptions "/tmp/tools") $ do
tests = describe "Selenium tests" $ introduceWebDriver defaultWdOptions $ do
$(getSpecFromFolder defaultGetSpecFromFolderOptions)
main :: IO ()

View File

@ -13,7 +13,7 @@ import Test.Sandwich.WebDriver
import Test.WebDriver
spec :: TopSpec
spec = introduceWebDriver (defaultWdOptions "/tmp/tools") $ do
spec = introduceWebDriver defaultWdOptions $ do
it "opens Google and searches" $ withSession1 $ do
openPage "http://www.google.com"
search <- findElem (ByCSS "*[title='Search']")
@ -36,7 +36,7 @@ For example, the code below opens two windows with a different site in each.
```haskell
spec :: TopSpec
spec = introduceWebDriver (defaultWdOptions "/tmp/tools") $ do
spec = introduceWebDriver defaultWdOptions $ do
describe "two browser sessions" $ do
it "opens Google" $ withSession1 $ openPage "http://www.google.com"
it "opens Yahoo" $ withSession2 $ openPage "http://www.yahoo.com"
@ -49,7 +49,7 @@ The code below extends the previous example with window positioning. You can fin
```haskell
positioning :: TopSpec
positioning = introduceWebDriver (defaultWdOptions "/tmp/tools") $ do
positioning = introduceWebDriver defaultWdOptions $ do
describe "two windows side by side" $ do
it "opens Google" $ withSession1 $ do
openPage "http://www.google.com"
@ -69,7 +69,7 @@ This package makes it easy to run Selenium tests in the background, using either
Many browsers now have the ability to natively run in headless mode. For example, passing these modified `WdOptions` to `introduceWebDriver` will run using headless Firefox.
```haskell
wdOptions = (defaultWdOptions "/tmp/tools") {
wdOptions = defaultWdOptions {
capabilities = firefoxCapabilities Nothing
, runMode = RunHeadless defaultHeadlessConfig
}
@ -84,7 +84,7 @@ Xvfb can be used to run your browser on a separate, "virtual" X11 display, diffe
Xvfb mode can be configured manually just like headless mode.
```haskell
wdOptions = (defaultWdOptions "/tmp/tools") {
wdOptions = defaultWdOptions {
capabilities = chromeCapabilities
, runMode = RunInXvfb XvfbConfig
}
@ -106,7 +106,7 @@ Using the methods in [Test.Sandwich.WebDriver.Video](http://hackage.haskell.org/
```haskell
manualVideo :: TopSpec
manualVideo = introduceWebDriver (defaultWdOptions "/tmp/tools") $ do
manualVideo = introduceWebDriver defaultWdOptions $ do
describe "video recording" $ do
it "opens Google" $ withSession1 $ do
openPage "http://www.google.com"
@ -204,7 +204,7 @@ Having written these functions, we can finally write our tests. The following wi
```haskell
tests :: TopSpecWithOptions
tests =
introduceWebDriverPool 4 (defaultWdOptions "/tmp/tools") $
introduceWebDriverPool 4 defaultWdOptions $
parallel $
replicateM_ 20 $
claimWebdriver $

View File

@ -80,7 +80,7 @@ simple = introduceWebDriver wdOptions $ do
-- webdriverPool = Label :: Label "webdriverPool" (Pool WdSession)
wdOptions = (defaultWdOptions "/tmp/tools") {
wdOptions = defaultWdOptions {
-- capabilities = chromeCapabilities
capabilities = firefoxCapabilities Nothing
-- capabilities = headlessFirefoxCapabilities

View File

@ -5,7 +5,7 @@ import Test.Sandwich
import Test.Sandwich.WebDriver
import Test.WebDriver
wdOptions = (defaultWdOptions "/tmp/tools") {
wdOptions = defaultWdOptions {
capabilities = firefoxCapabilities Nothing
, runMode = RunHeadless defaultHeadlessConfig
}

View File

@ -34,6 +34,7 @@ library
Test.Sandwich.WebDriver.Internal.Binaries.DetectChrome
Test.Sandwich.WebDriver.Internal.Binaries.DetectFirefox
Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform
Test.Sandwich.WebDriver.Internal.BrowserDependencies
Test.Sandwich.WebDriver.Internal.Capabilities
Test.Sandwich.WebDriver.Internal.Capabilities.Extra
Test.Sandwich.WebDriver.Internal.Screenshots

View File

@ -1,7 +1,8 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Test.Sandwich.WebDriver (
-- * Introducing a WebDriver server
@ -35,7 +36,6 @@ module Test.Sandwich.WebDriver (
, module Test.Sandwich.WebDriver.Types
) where
import Control.Applicative
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
@ -43,6 +43,7 @@ import Data.IORef
import qualified Data.Map as M
import Data.Maybe
import Data.String.Interpolate
import qualified Data.Text as T
import Test.Sandwich
import Test.Sandwich.Contexts.Files
import Test.Sandwich.Contexts.Nix
@ -50,6 +51,7 @@ import Test.Sandwich.Internal
import Test.Sandwich.WebDriver.Class
import Test.Sandwich.WebDriver.Config
import Test.Sandwich.WebDriver.Internal.Action
import Test.Sandwich.WebDriver.Internal.BrowserDependencies
import Test.Sandwich.WebDriver.Internal.StartWebDriver
import Test.Sandwich.WebDriver.Internal.Types
import Test.Sandwich.WebDriver.Types
@ -57,6 +59,7 @@ import qualified Test.WebDriver as W
import qualified Test.WebDriver.Config as W
import qualified Test.WebDriver.Session as W
import UnliftIO.MVar
import UnliftIO.Process
-- | This is the main 'introduce' method for creating a WebDriver.
@ -65,24 +68,39 @@ introduceWebDriver :: (
) => WdOptions -> SpecFree (LabelValue "webdriver" WebDriver :> context) m () -> SpecFree context m ()
introduceWebDriver wdOptions = undefined -- introduce "Introduce WebDriver session" webdriver (allocateWebDriver wdOptions) cleanupWebDriver
introduceWebDriverViaNix :: (
BaseMonadContext m context, HasNixContext context, HasFile context "java"
) => WdOptions -> SpecFree (LabelValue "webdriver" WebDriver :> context) m () -> SpecFree context m ()
type ContextWithWebdriverDeps context =
LabelValue "webdriver" WebDriver
:> LabelValue "browserDependencies" BrowserDependencies
:> LabelValue "file-java" (EnvironmentFile "java")
:> LabelValue "file-selenium.jar" (EnvironmentFile "selenium.jar")
:> context
introduceWebDriverViaNix :: forall m context. (
BaseMonadContext m context, HasSomeCommandLineOptions context, HasNixContext context
) => WdOptions -> SpecFree (ContextWithWebdriverDeps context) m () -> SpecFree context m ()
introduceWebDriverViaNix wdOptions =
introduce "Introduce WebDriver session" webdriver (allocateWebDriver wdOptions) cleanupWebDriver
introduceFileViaNixPackage @"selenium.jar" "selenium-server-standalone" tryFindSeleniumJar
. introduceBinaryViaNixPackage @"java" "jre"
. introduceBrowserDependencies
. introduce "Introduce WebDriver session" webdriver (allocateWebDriver wdOptions) cleanupWebDriver
where
tryFindSeleniumJar :: FilePath -> IO FilePath
tryFindSeleniumJar path = (T.unpack . T.strip . T.pack) <$> readCreateProcess (proc "find" [path, "-name", "*.jar"]) ""
-- | Same as introduceWebDriver, but merges command line options into the 'WdOptions'.
introduceWebDriverOptions :: forall a context m. (
BaseMonadContext m context, HasCommandLineOptions context a, HasFile context "java"
BaseMonadContext m context, HasSomeCommandLineOptions context
)
=> WdOptions -> SpecFree (LabelValue "webdriver" WebDriver :> context) m () -> SpecFree context m ()
introduceWebDriverOptions wdOptions = introduce "Introduce WebDriver session" webdriver alloc cleanupWebDriver
where alloc = do
clo <- getCommandLineOptions
allocateWebDriver (addCommandLineOptionsToWdOptions @a clo wdOptions)
introduceWebDriverOptions wdOptions = undefined -- introduce "Introduce WebDriver session" webdriver alloc cleanupWebDriver
-- where alloc = do
-- clo <- getCommandLineOptions
-- allocateWebDriver (addCommandLineOptionsToWdOptions @a clo wdOptions)
-- | Allocate a WebDriver using the given options.
allocateWebDriver :: (BaseMonad m, HasBaseContext context, HasFile context "java") => WdOptions -> ExampleT context m WebDriver
allocateWebDriver :: (
BaseMonad m, HasBaseContext context, HasFile context "java", HasFile context "selenium.jar", HasBrowserDependencies context
) => WdOptions -> ExampleT context m WebDriver
allocateWebDriver wdOptions = do
debug "Beginning allocateWebDriver"
dir <- fromMaybe "/tmp" <$> getCurrentFolder
@ -91,7 +109,10 @@ allocateWebDriver wdOptions = do
-- | Allocate a WebDriver using the given options and putting logs under the given path.
allocateWebDriver' :: FilePath -> WdOptions -> IO WebDriver
allocateWebDriver' runRoot wdOptions = do
runNoLoggingT $ flip runReaderT (undefined :: LabelValue "file-java" (EnvironmentFile "java")) $ startWebDriver wdOptions runRoot
let ctx = (undefined :: LabelValue "file-java" (EnvironmentFile "java"))
:> (undefined :: LabelValue "file-selenium.jar" (EnvironmentFile "selenium.jar"))
:> (undefined :: LabelValue "browserDependencies" BrowserDependencies)
runNoLoggingT $ flip runReaderT ctx $ startWebDriver wdOptions runRoot
-- | Clean up the given WebDriver.
cleanupWebDriver :: (BaseMonad m) => WebDriver -> ExampleT context m ()
@ -107,7 +128,9 @@ cleanupWebDriver' sess = do
stopWebDriver sess
-- | Run a given example using a given Selenium session.
withSession :: forall m context a. (WebDriverMonad m context) => Session -> ExampleT (ContextWithSession context) m a -> ExampleT context m a
withSession :: forall m context a. (
WebDriverMonad m context
) => Session -> ExampleT (ContextWithSession context) m a -> ExampleT context m a
withSession session (ExampleT readerMonad) = do
WebDriver {..} <- getContext webdriver
-- Create new session if necessary (this can throw an exception)
@ -145,30 +168,9 @@ getSessions = do
-- | Merge the options from the 'CommandLineOptions' into some 'WdOptions'.
addCommandLineOptionsToWdOptions :: CommandLineOptions a -> WdOptions -> WdOptions
addCommandLineOptionsToWdOptions (CommandLineOptions {optWebdriverOptions=(CommandLineWebdriverOptions {..})}) wdOptions@(WdOptions {..}) = wdOptions {
capabilities = case optFirefox of
Just UseFirefox -> firefoxCapabilities fbp
Just UseChrome -> chromeCapabilities cbp
Nothing -> case cbp of
Just p -> chromeCapabilities (Just p)
Nothing -> case fbp of
Just p -> firefoxCapabilities (Just p)
Nothing -> capabilities
, runMode = case optDisplay of
Nothing -> runMode
Just Headless -> RunHeadless defaultHeadlessConfig
Just Xvfb -> RunInXvfb (defaultXvfbConfig { xvfbStartFluxbox = optFluxbox })
Just Current -> Normal
, seleniumToUse = maybe seleniumToUse UseSeleniumAt optSeleniumJar
, chromeBinaryPath = cbp
, chromeDriverToUse = maybe chromeDriverToUse UseChromeDriverAt optChromeDriver
, firefoxBinaryPath = fbp
, geckoDriverToUse = maybe geckoDriverToUse UseGeckoDriverAt optGeckoDriver
runMode = case optDisplay of
Nothing -> runMode
Just Headless -> RunHeadless defaultHeadlessConfig
Just Xvfb -> RunInXvfb (defaultXvfbConfig { xvfbStartFluxbox = optFluxbox })
Just Current -> Normal
}
where
cbp = optChromeBinary <|> chromeBinaryPath
fbp = optFirefoxBinary <|> firefoxBinaryPath

View File

@ -4,16 +4,14 @@ module Test.Sandwich.WebDriver.Config (
WdOptions
, defaultWdOptions
, runMode
, seleniumToUse
, chromeBinaryPath
, chromeDriverToUse
, firefoxBinaryPath
, geckoDriverToUse
, capabilities
, httpManager
, httpRetryCount
, saveSeleniumMessageHistory
-- * Browser options
, BrowserDependencies(..)
-- * Run mode constructors
, RunMode(..)

View File

@ -81,8 +81,8 @@ obtainChromeDriver toolsDir (DownloadChromeDriverVersion chromeDriverVersion) =
let downloadPath = getChromeDriverDownloadUrl chromeDriverVersion detectPlatform
ExceptT $ downloadAndUnzipToPath downloadPath path
return path
obtainChromeDriver toolsDir (DownloadChromeDriverAutodetect maybeChromePath) = runExceptT $ do
version <- ExceptT $ liftIO $ getChromeDriverVersion maybeChromePath
obtainChromeDriver toolsDir (DownloadChromeDriverAutodetect chromePath) = runExceptT $ do
version <- ExceptT $ liftIO $ getChromeDriverVersion chromePath
ExceptT $ obtainChromeDriver toolsDir (DownloadChromeDriverVersion version)
obtainChromeDriver _ (UseChromeDriverAt path) = liftIO (doesFileExist path) >>= \case
False -> return $ Left [i|Path '#{path}' didn't exist|]
@ -135,9 +135,9 @@ downloadChromeDriverIfNecessary' toolsDir chromeDriverVersion = runExceptT $ do
return chromeDriverPath
downloadChromeDriverIfNecessary :: Constraints m => Maybe FilePath -> FilePath -> m (Either T.Text FilePath)
downloadChromeDriverIfNecessary maybeChromePath toolsDir = runExceptT $ do
chromeDriverVersion <- ExceptT $ liftIO $ getChromeDriverVersion maybeChromePath
downloadChromeDriverIfNecessary :: Constraints m => FilePath -> FilePath -> m (Either T.Text FilePath)
downloadChromeDriverIfNecessary chromePath toolsDir = runExceptT $ do
chromeDriverVersion <- ExceptT $ liftIO $ getChromeDriverVersion chromePath
ExceptT $ downloadChromeDriverIfNecessary' toolsDir chromeDriverVersion
getChromeDriverPath :: FilePath -> ChromeDriverVersion -> FilePath

View File

@ -6,6 +6,8 @@ module Test.Sandwich.WebDriver.Internal.Binaries.DetectChrome (
detectChromeVersion
, getChromeDriverVersion
, getChromeDriverDownloadUrl
, findChromeInEnvironment
) where
import Control.Exception
@ -62,10 +64,8 @@ findChromeInEnvironment =
, "google-chrome-stable" -- May be found on NixOS
]
detectChromeVersion :: Maybe FilePath -> IO (Either T.Text ChromeVersion)
detectChromeVersion maybeChromePath = leftOnException $ runExceptT $ do
chromeToUse <- liftIO $ maybe findChromeInEnvironment pure maybeChromePath
detectChromeVersion :: FilePath -> IO (Either T.Text ChromeVersion)
detectChromeVersion chromeToUse = leftOnException $ runExceptT $ do
(exitCode, stdout, stderr) <- liftIO $ readCreateProcessWithExitCode (shell (chromeToUse <> " --version | grep -Eo \"[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\"")) ""
rawString <- case exitCode of
@ -76,9 +76,9 @@ detectChromeVersion maybeChromePath = leftOnException $ runExceptT $ do
[tReadMay -> Just w, tReadMay -> Just x, tReadMay -> Just y, tReadMay -> Just z] -> return $ ChromeVersion (w, x, y, z)
_ -> throwE [i|Failed to parse google-chrome version from string: '#{rawString}'|]
getChromeDriverVersion :: Maybe FilePath -> IO (Either T.Text ChromeDriverVersion)
getChromeDriverVersion maybeChromePath = runExceptT $ do
chromeVersion <- ExceptT $ liftIO $ detectChromeVersion maybeChromePath
getChromeDriverVersion :: FilePath -> IO (Either T.Text ChromeDriverVersion)
getChromeDriverVersion chromePath = runExceptT $ do
chromeVersion <- ExceptT $ liftIO $ detectChromeVersion chromePath
ExceptT $ getChromeDriverVersion' chromeVersion
getChromeDriverVersion' :: ChromeVersion -> IO (Either T.Text ChromeDriverVersion)

View File

@ -0,0 +1,37 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Test.Sandwich.WebDriver.Internal.BrowserDependencies where
import Control.Monad.IO.Unlift
import Data.String.Interpolate
import Test.Sandwich
import Test.Sandwich.Contexts.Files
import Test.Sandwich.Contexts.Nix
import Test.Sandwich.WebDriver.Internal.Types
introduceBrowserDependencies :: forall m context. (
MonadUnliftIO m, HasBaseContext context, HasNixContext context, HasSomeCommandLineOptions context
) => SpecFree (LabelValue "browserDependencies" BrowserDependencies :> context) m () -> SpecFree context m ()
introduceBrowserDependencies = introduce "Introduce browser dependencies" browserDependencies alloc (const $ return ())
where
alloc = do
SomeCommandLineOptions (CommandLineOptions {optWebdriverOptions=(CommandLineWebdriverOptions {..})}) <- getSomeCommandLineOptions
deps <- case optFirefox of
Just UseChrome ->
BrowserDependenciesChrome <$> getBinaryViaNixPackage @"google-chrome-stable" "google-chrome"
<*> getBinaryViaNixPackage @"chromedriver" "chromedriver"
Just UseFirefox ->
BrowserDependenciesFirefox <$> getBinaryViaNixPackage @"firefox" "firefox"
<*> getBinaryViaNixPackage @"geckodriver" "geckodriver"
_ ->
BrowserDependenciesFirefox <$> getBinaryViaNixPackage @"firefox" "firefox"
<*> getBinaryViaNixPackage @"geckodriver" "geckodriver"
debug [i|Got browser dependencies: #{deps}|]
return deps

View File

@ -45,9 +45,13 @@ fromText = id
type Constraints m = (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadBaseControl IO m, MonadMask m)
-- | Add headless configuration to the Chrome browser
configureHeadlessCapabilities :: Constraints m => WdOptions -> RunMode -> W.Capabilities -> m W.Capabilities
configureHeadlessCapabilities :: (Constraints m) => WdOptions -> RunMode -> W.Capabilities -> m W.Capabilities
configureHeadlessCapabilities wdOptions (RunHeadless (HeadlessConfig {..})) caps@(W.Capabilities {W.browser=browser@(W.Chrome {..})}) = do
headlessArg <- liftIO (detectChromeVersion (chromeBinaryPath wdOptions)) >>= \case
chromeBinaryPath <- case chromeBinary of
Nothing -> expectationFailure [i|Chrome capabilities didn't define chromeBinary in configureHeadlessCapabilities|]
Just x -> pure x
headlessArg <- liftIO (detectChromeVersion chromeBinaryPath) >>= \case
Left err -> do
warn [i|Couldn't determine chrome version when configuring headless capabilities (err: #{err}); passing --headless|]
return "--headless"

View File

@ -29,12 +29,13 @@ import Test.Sandwich
import Test.Sandwich.Contexts.Files
import Test.Sandwich.Contexts.Util.Ports (findFreePortOrException)
import Test.Sandwich.Util.Process
import Test.Sandwich.WebDriver.Internal.Binaries
import Test.Sandwich.WebDriver.Internal.Capabilities.Extra
import Test.Sandwich.WebDriver.Internal.Types
import Test.Sandwich.WebDriver.Internal.Util
import qualified Test.WebDriver as W
import UnliftIO.Async
import UnliftIO.Process
import UnliftIO.Timeout
#ifndef mingw32_HOST_OS
import Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb
@ -45,9 +46,10 @@ type Constraints m = (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadBaseCon
-- | Spin up a Selenium WebDriver and create a WebDriver
startWebDriver :: (
Constraints m, MonadReader context m, HasFile context "java"
Constraints m, MonadReader context m
, HasFile context "java", HasFile context "selenium.jar", HasBrowserDependencies context
) => WdOptions -> FilePath -> m WebDriver
startWebDriver wdOptions@(WdOptions {capabilities=capabilities', ..}) runRoot = do
startWebDriver wdOptions@(WdOptions {capabilities=capabilities'', ..}) runRoot = do
-- Create a unique name for this webdriver so the folder for its log output doesn't conflict with any others
webdriverName <- ("webdriver_" <>) <$> liftIO makeUUID
@ -59,26 +61,30 @@ startWebDriver wdOptions@(WdOptions {capabilities=capabilities', ..}) runRoot =
let downloadDir = webdriverRoot </> "Downloads"
liftIO $ createDirectoryIfMissing True downloadDir
-- Get selenium and chromedriver
debug [i|Preparing to create the Selenium process|]
seleniumPath <- obtainSelenium toolsRoot seleniumToUse >>= \case
Left err -> error [i|Failed to obtain selenium: '#{err}'|]
Right p -> return p
driverArgs <- case W.browser capabilities' of
W.Firefox {} -> do
obtainGeckoDriver toolsRoot geckoDriverToUse >>= \case
Left err -> error [i|Failed to obtain geckodriver: '#{err}'|]
Right p -> return [[i|-Dwebdriver.gecko.driver=#{p}|]
-- , [i|-Dwebdriver.gecko.logfile=#{webdriverRoot </> "geckodriver.log"}|]
-- , [i|-Dwebdriver.gecko.verboseLogging=true|]
]
W.Chrome {} -> do
obtainChromeDriver toolsRoot chromeDriverToUse >>= \case
Left err -> error [i|Failed to obtain chromedriver: '#{err}'|]
Right p -> return [[i|-Dwebdriver.chrome.driver=#{p}|]
, [i|-Dwebdriver.chrome.logfile=#{webdriverRoot </> "chromedriver.log"}|]
, [i|-Dwebdriver.chrome.verboseLogging=true|]]
x -> error [i|Browser #{x} is not supported yet|]
-- Get selenium, driver args, and capabilities with browser paths applied
java <- askFile @"java"
seleniumPath <- askFile @"selenium.jar"
(driverArgs, capabilities') <- getContext browserDependencies >>= \case
BrowserDependenciesFirefox {..} -> do
let args = [
[i|-Dwebdriver.gecko.driver=#{browserDependenciesFirefoxGeckodriver}|]
-- , [i|-Dwebdriver.gecko.logfile=#{webdriverRoot </> "geckodriver.log"}|]
-- , [i|-Dwebdriver.gecko.verboseLogging=true|]
]
let capabilities' = capabilities'' {
W.browser = W.firefox { W.ffBinary = Just browserDependenciesFirefoxFirefox }
}
return (args, capabilities')
BrowserDependenciesChrome {..} -> do
let args = [
[i|-Dwebdriver.chrome.driver=#{browserDependenciesChromeChromedriver}|]
, [i|-Dwebdriver.chrome.logfile=#{webdriverRoot </> "chromedriver.log"}|]
, [i|-Dwebdriver.chrome.verboseLogging=true|]
]
let capabilities' = capabilities'' {
W.browser = W.chrome { W.chromeBinary = Just browserDependenciesChromeChrome }
}
return (args, capabilities')
(maybeXvfbSession, javaEnv) <- case runMode of
#ifndef mingw32_HOST_OS
@ -93,9 +99,6 @@ startWebDriver wdOptions@(WdOptions {capabilities=capabilities', ..}) runRoot =
let webdriverProcessRoot = webdriverRoot </> T.unpack webdriverProcessName
liftIO $ createDirectoryIfMissing True webdriverProcessRoot
java <- askFile @"java"
-- seleniumJar <- askFile @"selenium.jar"
-- Retry up to 10 times
-- This is necessary because sometimes we get a race for the port we get from findFreePortOrException.
-- There doesn't seem to be any way to make Selenium choose its own port.
@ -124,17 +127,19 @@ startWebDriver wdOptions@(WdOptions {capabilities=capabilities', ..}) runRoot =
-- Read from the (combined) output stream until we see the up and running message,
-- or the process ends and we get an exception from hGetLine
fix $ \loop -> do
startupResult <- timeout 10_000_000 $ fix $ \loop -> do
line <- fmap T.pack $ liftIO $ hGetLine hRead
debug line
if | "Selenium Server is up and running" `T.isInfixOf` line -> return ()
| otherwise -> loop
return (port, hRead, p)
case startupResult of
Nothing -> expectationFailure [i|Didn't see "up and running" line in Selenium output.|]
Just () -> return (port, hRead, p)
-- TODO: save this in the WebDriver to tear it down later?
logAsync <- forever $ liftIO (hGetLine hRead) >>= (debug . T.pack)
_logAsync <- async $ forever (liftIO (hGetLine hRead) >>= (debug . T.pack))
-- Final extra capabilities configuration
capabilities <-

View File

@ -55,28 +55,12 @@ data RunMode = Normal
-- xvfb-run script must be installed and on the PATH.
data WdOptions = WdOptions {
toolsRoot :: ToolsRoot
-- ^ Folder where any necessary binaries (chromedriver, Selenium, etc.) will be downloaded if needed. Required.
, capabilities :: W.Capabilities
capabilities :: W.Capabilities
-- ^ The WebDriver capabilities to use.
, saveSeleniumMessageHistory :: WhenToSave
-- ^ When to save a record of Selenium requests and responses.
, seleniumToUse :: SeleniumToUse
-- ^ Which Selenium server JAR file to use.
, chromeBinaryPath :: Maybe FilePath
-- ^ Which chrome binary to use.
, chromeDriverToUse :: ChromeDriverToUse
-- ^ Which chromedriver executable to use.
, firefoxBinaryPath :: Maybe FilePath
-- ^ Which firefox binary to use.
, geckoDriverToUse :: GeckoDriverToUse
-- ^ Which geckodriver executable to use.
, runMode :: RunMode
-- ^ How to handle opening the browser (in a popup window, headless, etc.).
@ -103,7 +87,7 @@ data ChromeDriverToUse =
-- ^ Download chromedriver from the given URL to the 'toolsRoot'
| DownloadChromeDriverVersion ChromeDriverVersion
-- ^ Download the given chromedriver version to the 'toolsRoot'
| DownloadChromeDriverAutodetect (Maybe FilePath)
| DownloadChromeDriverAutodetect FilePath
-- ^ Autodetect chromedriver to use based on the Chrome version and download it to the 'toolsRoot'
-- Pass the path to the Chrome binary, or else it will be found by looking for google-chrome on the PATH.
| UseChromeDriverAt FilePath
@ -155,16 +139,10 @@ defaultXvfbConfig = XvfbConfig Nothing False
-- | The default 'WdOptions' object.
-- You should start with this and modify it using the accessors.
defaultWdOptions :: FilePath -> WdOptions
defaultWdOptions toolsRoot = WdOptions {
toolsRoot = toolsRoot
, capabilities = def
defaultWdOptions :: WdOptions
defaultWdOptions = WdOptions {
capabilities = def
, saveSeleniumMessageHistory = OnException
, seleniumToUse = DownloadSeleniumDefault
, chromeBinaryPath = Nothing
, chromeDriverToUse = DownloadChromeDriverAutodetect Nothing
, firefoxBinaryPath = Nothing
, geckoDriverToUse = DownloadGeckoDriverAutodetect Nothing
, runMode = Normal
, httpManager = Nothing
, httpRetryCount = 0
@ -270,3 +248,18 @@ defaultVideoSettings = VideoSettings {
, hideMouseWhenRecording = False
, logToDisk = True
}
data BrowserDependencies = BrowserDependenciesChrome {
browserDependenciesChromeChrome :: FilePath
, browserDependenciesChromeChromedriver :: FilePath
}
| BrowserDependenciesFirefox {
browserDependenciesFirefoxFirefox :: FilePath
, browserDependenciesFirefoxGeckodriver :: FilePath
}
deriving (Show)
browserDependencies :: Label "browserDependencies" BrowserDependencies
browserDependencies = Label
type HasBrowserDependencies context = HasLabel context "browserDependencies" BrowserDependencies

View File

@ -155,16 +155,21 @@ runSandwichWithCommandLineArgs' baseOptions userOptionsParser spec = do
updateGolden (optGoldenDir (optGoldenOptions clo))
| otherwise -> do
-- Awkward, but we need a specific context type to call countItNodes
let totalTests = countItNodes (spec :: SpecFree (LabelValue "commandLineOptions" (CommandLineOptions a) :> BaseContext) IO ())
let totalTests = countItNodes (spec :: SpecFree (LabelValue "someCommandLineOptions" SomeCommandLineOptions :> LabelValue "commandLineOptions" (CommandLineOptions a) :> BaseContext) IO ())
let cliNodeOptions = defaultNodeOptions { nodeOptionsVisibilityThreshold = systemVisibilityThreshold
, nodeOptionsCreateFolder = False }
runWithRepeat repeatCount totalTests $
case optIndividualTestModule clo of
Nothing -> runSandwich' (Just $ clo { optUserOptions = () }) options $
introduce' (defaultNodeOptions { nodeOptionsVisibilityThreshold = systemVisibilityThreshold
, nodeOptionsCreateFolder = False }) "command line options" commandLineOptions (pure clo) (const $ return ()) spec
introduce' cliNodeOptions "some command line options" someCommandLineOptions (pure (SomeCommandLineOptions clo)) (const $ return ())
$ introduce' cliNodeOptions "command line options" commandLineOptions (pure clo) (const $ return ())
$ spec
Just (IndividualTestModuleName x) -> runSandwich' (Just $ clo { optUserOptions = () }) options $ filterTreeToModule x $
introduce' (defaultNodeOptions { nodeOptionsVisibilityThreshold = systemVisibilityThreshold
, nodeOptionsCreateFolder = False }) "command line options" commandLineOptions (pure clo) (const $ return ()) spec
introduce' cliNodeOptions "some command line options" someCommandLineOptions (pure (SomeCommandLineOptions clo)) (const $ return ())
$ introduce' cliNodeOptions "command line options" commandLineOptions (pure clo) (const $ return ())
$ spec
Just (IndividualTestMainFn x) -> do
let individualTestFlagStrings = [[ Just ("--" <> shorthand), const ("--" <> shorthand <> "-main") <$> nodeModuleInfoFn ]
| (NodeModuleInfo {..}, shorthand) <- modulesAndShorthands]

View File

@ -202,7 +202,7 @@ parseCommandLineArgs' :: forall a. Typeable a => Parser a -> TopSpecWithOptions'
, [(NodeModuleInfo, T.Text)]
)
parseCommandLineArgs' userOptionsParser spec = do
let modulesAndShorthands = gatherMainFunctions (spec :: SpecFree (LabelValue "commandLineOptions" (CommandLineOptions a) :> BaseContext) IO ())
let modulesAndShorthands = gatherMainFunctions (spec :: SpecFree (LabelValue "someCommandLineOptions" SomeCommandLineOptions :> LabelValue "commandLineOptions" (CommandLineOptions a) :> BaseContext) IO ())
& L.sortOn nodeModuleInfoModuleName
& gatherShorthands
let individualTestFlags maybeInternal =

View File

@ -38,6 +38,12 @@ getCurrentFolder = asks (baseContextPath . getBaseContext)
getCommandLineOptions :: forall a context m. (HasCommandLineOptions context a, MonadReader context m) => m (CommandLineOptions a)
getCommandLineOptions = getContext commandLineOptions
-- | Get existentially wrapped command line options, if configured.
-- Using the 'runSandwichWithCommandLineArgs' family of main functions will introduce these, or you can
-- introduce them manually
getSomeCommandLineOptions :: forall context m. (HasSomeCommandLineOptions context, MonadReader context m) => m SomeCommandLineOptions
getSomeCommandLineOptions = getContext someCommandLineOptions
-- | Get the user command line options, if configured.
-- This just calls 'getCommandLineOptions' and pulls out the user options.
getUserCommandLineOptions :: (HasCommandLineOptions context a, MonadReader context m) => m a

View File

@ -37,6 +37,8 @@ module Test.Sandwich.Misc (
, HasBaseContext
, HasBaseContextMonad
, HasCommandLineOptions
, SomeCommandLineOptions(..)
, HasSomeCommandLineOptions
-- * Result types
, Result(..)

View File

@ -168,16 +168,25 @@ commandLineOptions = Label :: Label "commandLineOptions" (CommandLineOptions a)
-- | Has-* class for asserting a 'CommandLineOptions a' is available.
type HasCommandLineOptions context a = HasLabel context "commandLineOptions" (CommandLineOptions a)
-- | Existential wrapper for 'CommandLineOptions a'.
someCommandLineOptions :: Label "someCommandLineOptions" SomeCommandLineOptions
someCommandLineOptions = Label :: Label "someCommandLineOptions" SomeCommandLineOptions
data SomeCommandLineOptions where
SomeCommandLineOptions :: CommandLineOptions a -> SomeCommandLineOptions
type HasSomeCommandLineOptions context = HasLabel context "someCommandLineOptions" SomeCommandLineOptions
type TopSpecWithOptions = forall context. (
Typeable context
, HasBaseContext context
, HasCommandLineOptions context ()
, HasSomeCommandLineOptions context
) => SpecFree context IO ()
type TopSpecWithOptions' a = forall context. (
Typeable context
, HasBaseContext context
, HasCommandLineOptions context a
, HasSomeCommandLineOptions context
) => SpecFree context IO ()
-- * Formatter