From 6d36f4fce62a42962eb8304471646ecfccc65178 Mon Sep 17 00:00:00 2001 From: Tom McLaughlin Date: Mon, 10 Jun 2024 03:08:07 -0700 Subject: [PATCH] Able to run webdriver demo using Nix --- demos/demo-discover/app/SeleniumTests.hs | 2 +- demos/demo-webdriver-landing/app/Main.hs | 2 +- demos/demo-webdriver-pool/app/Main.hs | 2 +- demos/demo-webdriver-positioning/app/Main.hs | 2 +- demos/demo-webdriver-video/app/Main.hs | 2 +- demos/demo-webdriver/app/Main.hs | 12 ++- demos/demo-webdriver/demo-webdriver.cabal | 1 + demos/demo-webdriver/package.yaml | 1 + sandwich-site/docs/discovery.md | 4 +- .../docs/extensions/sandwich-webdriver.md | 14 ++-- sandwich-webdriver/app/Main.hs | 2 +- sandwich-webdriver/app/Simple.hs | 2 +- sandwich-webdriver/sandwich-webdriver.cabal | 1 + .../src/Test/Sandwich/WebDriver.hs | 84 ++++++++++--------- .../src/Test/Sandwich/WebDriver/Config.hs | 8 +- .../Sandwich/WebDriver/Internal/Binaries.hs | 10 +-- .../Internal/Binaries/DetectChrome.hs | 14 ++-- .../WebDriver/Internal/BrowserDependencies.hs | 37 ++++++++ .../WebDriver/Internal/Capabilities/Extra.hs | 8 +- .../WebDriver/Internal/StartWebDriver.hs | 63 +++++++------- .../Test/Sandwich/WebDriver/Internal/Types.hs | 47 +++++------ sandwich/src/Test/Sandwich.hs | 15 ++-- sandwich/src/Test/Sandwich/ArgParsing.hs | 2 +- sandwich/src/Test/Sandwich/Contexts.hs | 6 ++ sandwich/src/Test/Sandwich/Misc.hs | 2 + sandwich/src/Test/Sandwich/Types/RunTree.hs | 9 ++ 26 files changed, 210 insertions(+), 142 deletions(-) create mode 100644 sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/BrowserDependencies.hs diff --git a/demos/demo-discover/app/SeleniumTests.hs b/demos/demo-discover/app/SeleniumTests.hs index dbe9346..07c76bf 100644 --- a/demos/demo-discover/app/SeleniumTests.hs +++ b/demos/demo-discover/app/SeleniumTests.hs @@ -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 () diff --git a/demos/demo-webdriver-landing/app/Main.hs b/demos/demo-webdriver-landing/app/Main.hs index 26d327e..d317898 100644 --- a/demos/demo-webdriver-landing/app/Main.hs +++ b/demos/demo-webdriver-landing/app/Main.hs @@ -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|] diff --git a/demos/demo-webdriver-pool/app/Main.hs b/demos/demo-webdriver-pool/app/Main.hs index 608a9b0..1b15c35 100644 --- a/demos/demo-webdriver-pool/app/Main.hs +++ b/demos/demo-webdriver-pool/app/Main.hs @@ -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" diff --git a/demos/demo-webdriver-positioning/app/Main.hs b/demos/demo-webdriver-positioning/app/Main.hs index 7d10504..6c736b6 100644 --- a/demos/demo-webdriver-positioning/app/Main.hs +++ b/demos/demo-webdriver-positioning/app/Main.hs @@ -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" diff --git a/demos/demo-webdriver-video/app/Main.hs b/demos/demo-webdriver-video/app/Main.hs index 4dcda84..6d3e56c 100644 --- a/demos/demo-webdriver-video/app/Main.hs +++ b/demos/demo-webdriver-video/app/Main.hs @@ -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" diff --git a/demos/demo-webdriver/app/Main.hs b/demos/demo-webdriver/app/Main.hs index c32a8fe..e78dbd1 100644 --- a/demos/demo-webdriver/app/Main.hs +++ b/demos/demo-webdriver/app/Main.hs @@ -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 diff --git a/demos/demo-webdriver/demo-webdriver.cabal b/demos/demo-webdriver/demo-webdriver.cabal index 3b1ed94..abfa58e 100644 --- a/demos/demo-webdriver/demo-webdriver.cabal +++ b/demos/demo-webdriver/demo-webdriver.cabal @@ -31,6 +31,7 @@ executable demo-webdriver , bytestring , filepath , sandwich + , sandwich-contexts , sandwich-webdriver , string-interpolate , webdriver diff --git a/demos/demo-webdriver/package.yaml b/demos/demo-webdriver/package.yaml index d308bbf..cb04fb2 100644 --- a/demos/demo-webdriver/package.yaml +++ b/demos/demo-webdriver/package.yaml @@ -7,6 +7,7 @@ dependencies: - bytestring - filepath - sandwich +- sandwich-contexts - sandwich-webdriver - string-interpolate - webdriver diff --git a/sandwich-site/docs/discovery.md b/sandwich-site/docs/discovery.md index ec75803..5327984 100644 --- a/sandwich-site/docs/discovery.md +++ b/sandwich-site/docs/discovery.md @@ -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 () diff --git a/sandwich-site/docs/extensions/sandwich-webdriver.md b/sandwich-site/docs/extensions/sandwich-webdriver.md index 016f002..67c1b74 100644 --- a/sandwich-site/docs/extensions/sandwich-webdriver.md +++ b/sandwich-site/docs/extensions/sandwich-webdriver.md @@ -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 $ diff --git a/sandwich-webdriver/app/Main.hs b/sandwich-webdriver/app/Main.hs index 88daac3..8bcd255 100644 --- a/sandwich-webdriver/app/Main.hs +++ b/sandwich-webdriver/app/Main.hs @@ -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 diff --git a/sandwich-webdriver/app/Simple.hs b/sandwich-webdriver/app/Simple.hs index f529dfc..de99ca5 100644 --- a/sandwich-webdriver/app/Simple.hs +++ b/sandwich-webdriver/app/Simple.hs @@ -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 } diff --git a/sandwich-webdriver/sandwich-webdriver.cabal b/sandwich-webdriver/sandwich-webdriver.cabal index d658185..4bcd81d 100644 --- a/sandwich-webdriver/sandwich-webdriver.cabal +++ b/sandwich-webdriver/sandwich-webdriver.cabal @@ -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 diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs index 353039b..cab7cd9 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs @@ -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 diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Config.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Config.hs index 45c48bc..a40c690 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Config.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Config.hs @@ -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(..) diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries.hs index 4888e7b..8b5afe5 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries.hs @@ -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 diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/DetectChrome.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/DetectChrome.hs index ae8434d..0b7b549 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/DetectChrome.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Binaries/DetectChrome.hs @@ -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) diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/BrowserDependencies.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/BrowserDependencies.hs new file mode 100644 index 0000000..e51013b --- /dev/null +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/BrowserDependencies.hs @@ -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 diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Capabilities/Extra.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Capabilities/Extra.hs index 4d7f12b..aed0aec 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Capabilities/Extra.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Capabilities/Extra.hs @@ -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" diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs index 6bee21a..9d49e48 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs @@ -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 <- diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Types.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Types.hs index de45821..499e6c9 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Types.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Types.hs @@ -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 diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs index a198e39..a475200 100644 --- a/sandwich/src/Test/Sandwich.hs +++ b/sandwich/src/Test/Sandwich.hs @@ -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] diff --git a/sandwich/src/Test/Sandwich/ArgParsing.hs b/sandwich/src/Test/Sandwich/ArgParsing.hs index dd07b0a..be9a483 100644 --- a/sandwich/src/Test/Sandwich/ArgParsing.hs +++ b/sandwich/src/Test/Sandwich/ArgParsing.hs @@ -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 = diff --git a/sandwich/src/Test/Sandwich/Contexts.hs b/sandwich/src/Test/Sandwich/Contexts.hs index 427d6f8..75f94aa 100644 --- a/sandwich/src/Test/Sandwich/Contexts.hs +++ b/sandwich/src/Test/Sandwich/Contexts.hs @@ -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 diff --git a/sandwich/src/Test/Sandwich/Misc.hs b/sandwich/src/Test/Sandwich/Misc.hs index 1495af4..15578f6 100644 --- a/sandwich/src/Test/Sandwich/Misc.hs +++ b/sandwich/src/Test/Sandwich/Misc.hs @@ -37,6 +37,8 @@ module Test.Sandwich.Misc ( , HasBaseContext , HasBaseContextMonad , HasCommandLineOptions + , SomeCommandLineOptions(..) + , HasSomeCommandLineOptions -- * Result types , Result(..) diff --git a/sandwich/src/Test/Sandwich/Types/RunTree.hs b/sandwich/src/Test/Sandwich/Types/RunTree.hs index ddc0a22..6f3ef73 100644 --- a/sandwich/src/Test/Sandwich/Types/RunTree.hs +++ b/sandwich/src/Test/Sandwich/Types/RunTree.hs @@ -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