sandwich-webdriver 0.3.0.1 → 0.4.0.0
raw patch · 17 files changed
+402/−488 lines, 17 filesdep +http-typesdep ~webdriver
Dependencies added: http-types
Dependency ranges changed: webdriver
Files
- CHANGELOG.md +9/−0
- sandwich-webdriver.cabal +5/−4
- src/Test/Sandwich/WebDriver.hs +117/−47
- src/Test/Sandwich/WebDriver/Config.hs +4/−4
- src/Test/Sandwich/WebDriver/Internal/Action.hs +8/−10
- src/Test/Sandwich/WebDriver/Internal/Binaries/Selenium.hs +2/−2
- src/Test/Sandwich/WebDriver/Internal/Capabilities.hs +36/−37
- src/Test/Sandwich/WebDriver/Internal/Capabilities/Extra.hs +71/−69
- src/Test/Sandwich/WebDriver/Internal/Dependencies.hs +16/−36
- src/Test/Sandwich/WebDriver/Internal/Screenshots.hs +0/−29
- src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs +10/−152
- src/Test/Sandwich/WebDriver/Internal/Types.hs +35/−38
- src/Test/Sandwich/WebDriver/Types.hs +59/−28
- src/Test/Sandwich/WebDriver/Video.hs +12/−12
- src/Test/Sandwich/WebDriver/Video/Internal.hs +4/−5
- src/Test/Sandwich/WebDriver/Windows.hs +12/−15
- unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs +2/−0
CHANGELOG.md view
@@ -1,5 +1,14 @@ # Changelog for sandwich-webdriver +# 0.4.0.0++* Switch to `webdriver-0.13.0.0`, which is a major change.+* Rename 'WebDriver' -> 'TestWebDriverContext'+* Disabling Xvfb support for now.+* Be able to pass extra flags to chromedriver or geckodriver.+* Now we have debug logging of all WebDriver requests and responses by default, which makes it much easier to see what's going on.+* Some logic for starting and managing WebDriver processes has been moved to the `webdriver` package.+ # 0.3.0.1 * Add more debugging statements to binary fetching.
sandwich-webdriver.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sandwich-webdriver-version: 0.3.0.1+version: 0.4.0.0 synopsis: Sandwich integration with Selenium WebDriver description: Please see the <https://codedownio.github.io/sandwich/docs/extensions/sandwich-webdriver documentation>. category: Testing@@ -51,7 +51,6 @@ Test.Sandwich.WebDriver.Internal.Capabilities.Extra Test.Sandwich.WebDriver.Internal.Dependencies Test.Sandwich.WebDriver.Internal.OnDemand- Test.Sandwich.WebDriver.Internal.Screenshots Test.Sandwich.WebDriver.Internal.StartWebDriver Test.Sandwich.WebDriver.Internal.Types Test.Sandwich.WebDriver.Internal.Util@@ -87,6 +86,7 @@ , http-client , http-client-tls , http-conduit+ , http-types , microlens , microlens-aeson , monad-control@@ -108,7 +108,7 @@ , unliftio-core , unordered-containers , vector- , webdriver+ , webdriver >=0.13.0.0 default-language: Haskell2010 if os(darwin) other-modules:@@ -171,6 +171,7 @@ , http-client , http-client-tls , http-conduit+ , http-types , microlens , microlens-aeson , monad-control@@ -193,7 +194,7 @@ , unliftio-core , unordered-containers , vector- , webdriver+ , webdriver >=0.13.0.0 default-language: Haskell2010 if os(darwin) other-modules:
src/Test/Sandwich/WebDriver.hs view
@@ -30,7 +30,7 @@ , closeSession , closeAllSessions , closeAllSessionsExcept- , Session+ , SessionName -- * Lower-level allocation functions , allocateWebDriver@@ -43,8 +43,8 @@ -- * Context types -- ** WebDriver , webdriver- , WebDriver- , HasWebDriverContext+ , TestWebDriverContext+ , HasTestWebDriverContext -- ** WebDriverSession , webdriverSession , WebDriverSession@@ -66,29 +66,33 @@ , module Test.Sandwich.WebDriver.Config ) where +import Control.Monad import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class import Control.Monad.Reader-import Control.Monad.Trans.Control (MonadBaseControl)-import Data.IORef-import qualified Data.List as L import qualified Data.Map as M import Data.Maybe import Data.String.Interpolate+import qualified Data.Text as T+import Lens.Micro+import System.FilePath+import System.IO.Temp import Test.Sandwich-import Test.Sandwich.Contexts.Files import Test.Sandwich.Contexts.Nix import Test.Sandwich.WebDriver.Binaries import Test.Sandwich.WebDriver.Config import Test.Sandwich.WebDriver.Internal.Action+import Test.Sandwich.WebDriver.Internal.Capabilities.Extra import Test.Sandwich.WebDriver.Internal.Dependencies import Test.Sandwich.WebDriver.Internal.StartWebDriver import Test.Sandwich.WebDriver.Internal.Types+import Test.Sandwich.WebDriver.Internal.Util (makeUUID) import Test.Sandwich.WebDriver.Types import Test.Sandwich.WebDriver.Video (recordVideoIfConfigured) import qualified Test.WebDriver as W-import qualified Test.WebDriver.Config as W-import qualified Test.WebDriver.Session as W+import qualified Test.WebDriver.Capabilities as W+import UnliftIO.Directory+import UnliftIO.Exception (bracket) import UnliftIO.MVar @@ -133,10 +137,11 @@ -> SpecFree (ContextWithWebdriverDeps context) m () -> SpecFree context m () introduceWebDriverViaNix' nodeOptions wdOptions =- introduceFileViaNixPackage'' @"selenium.jar" nodeOptions "selenium-server-standalone" (findFirstFile (return . (".jar" `L.isSuffixOf`)))- . introduceBinaryViaNixPackage' @"java" nodeOptions "jre"- . introduceBrowserDependenciesViaNix' nodeOptions- . introduce "Introduce WebDriver session" webdriver alloc cleanupWebDriver+ introduceBrowserDependenciesViaNix' nodeOptions+ -- We use 'introduceWith' here because the alloc function will start an Async to read the logs from the Selenium+ -- process and log them. If we were to use 'introduce', the test_logs.txt file would be closed after the allocate section+ -- and the write handle would become invalid.+ . introduceWith "Introduce WebDriver session" webdriver (\action -> bracket alloc cleanupWebDriver (void . action)) where alloc = do clo <- getSomeCommandLineOptions@@ -151,71 +156,136 @@ -- | Same as 'introduceWebDriver', but with a controllable allocation callback. introduceWebDriver' :: forall m context. (- BaseMonad m context+ BaseMonad m context, HasSomeCommandLineOptions context ) -- | Dependencies => WebDriverDependencies- -> (WdOptions -> ExampleT (ContextWithBaseDeps context) m WebDriver)+ -> (WdOptions -> ExampleT (ContextWithBaseDeps context) m TestWebDriverContext) -> WdOptions -> SpecFree (ContextWithWebdriverDeps context) m () -> SpecFree context m () introduceWebDriver' (WebDriverDependencies {..}) alloc wdOptions =- introduce "Introduce selenium.jar" (mkFileLabel @"selenium.jar") ((EnvironmentFile <$>) $ obtainSelenium webDriverDependencySelenium) (const $ return ())- . (case webDriverDependencyJava of Nothing -> introduceBinaryViaEnvironment @"java"; Just p -> introduceFile @"java" p)- . introduce "Introduce browser dependencies" browserDependencies (getBrowserDependencies webDriverDependencyBrowser) (const $ return ())- . introduce "Introduce WebDriver session" webdriver (alloc wdOptions) cleanupWebDriver+ introduce "Introduce browser dependencies" browserDependencies (getBrowserDependencies webDriverDependencyBrowser) (const $ return ())+ -- We use 'introduceWith' deliberately here instead of 'introduce'. See comment on above.+ . introduceWith "Introduce WebDriver session" webdriver (\action -> bracket (alloc wdOptions) cleanupWebDriver (void . action)) -- | Allocate a WebDriver using the given options. allocateWebDriver :: (- BaseMonad m context- , HasFile context "java", HasFile context "selenium.jar", HasBrowserDependencies context+ BaseMonad m context, HasBrowserDependencies context ) -- | Options => WdOptions -> OnDemandOptions- -> ExampleT context m WebDriver-allocateWebDriver wdOptions onDemandOptions = do- dir <- fromMaybe "/tmp" <$> getCurrentFolder- startWebDriver wdOptions onDemandOptions dir+ -> ExampleT context m TestWebDriverContext+allocateWebDriver wdOptions (OnDemandOptions {..}) = do+ runRoot <- fromMaybe "/tmp" <$> getCurrentFolder + -- Create a unique name for this webdriver so the folder for its log output doesn't conflict with any others+ webdriverName <- ("webdriver_" <>) <$> liftIO makeUUID++ -- Directory to log everything for this webdriver+ let webdriverRoot = runRoot </> (T.unpack webdriverName)+ liftIO $ createDirectoryIfMissing True webdriverRoot++ -- Directory to hold any downloads+ let downloadDir = webdriverRoot </> "Downloads"+ liftIO $ createDirectoryIfMissing True downloadDir++ (baseCaps, driverConfig) <- getContext browserDependencies >>= \case+ BrowserDependenciesChrome {..} -> do+ let caps = W.defaultCaps {+ W._capabilitiesBrowserName = Just "chrome"+ , W._capabilitiesGoogChromeOptions = Just $+ W.defaultChromeOptions+ & set W.chromeOptionsBinary (Just browserDependenciesChromeChrome)+ }+ let driverConfig = W.DriverConfigChromedriver {+ driverConfigChromedriver = browserDependenciesChromeChromedriver+ , driverConfigChrome = browserDependenciesChromeChrome+ , driverConfigLogDir = runRoot+ , driverConfigChromedriverFlags = chromedriverExtraFlags wdOptions+ }+ return (caps, driverConfig)+ BrowserDependenciesFirefox {..} -> do+ let ffOptions = W.defaultFirefoxOptions+ & set W.firefoxOptionsBinary (Just browserDependenciesFirefoxFirefox)++ let caps = W.defaultCaps {+ W._capabilitiesBrowserName = Just "firefox"+ , W._capabilitiesMozFirefoxOptions = Just ffOptions+ }++ profileRootDir <- liftIO $ createTempDirectory webdriverRoot "geckodriver-profile-root"++ let driverConfig = W.DriverConfigGeckodriver {+ driverConfigGeckodriver = browserDependenciesFirefoxGeckodriver+ , driverConfigFirefox = browserDependenciesFirefoxFirefox+ , driverConfigLogDir = runRoot+ , driverConfigGeckodriverFlags = "--profile-root" : profileRootDir : geckodriverExtraFlags wdOptions+ -- , driverConfigGeckodriverFlags = geckodriverExtraFlags wdOptions+ }+ return (caps, driverConfig)++ -- Final extra capabilities configuration+ finalCaps <- pure baseCaps+ >>= configureChromeNoSandbox wdOptions+ >>= configureHeadlessChromeCapabilities wdOptions (runMode wdOptions)+ >>= configureHeadlessFirefoxCapabilities wdOptions (runMode wdOptions)+ >>= configureChromeDownloadCapabilities downloadDir+ >>= configureFirefoxDownloadCapabilities downloadDir++ wdc <- W.mkEmptyWebDriverContext++ TestWebDriverContext+ <$> pure (T.unpack webdriverName)+ <*> pure wdc+ <*> pure (wdOptions { capabilities = finalCaps })+ <*> liftIO (newMVar mempty)+ <*> pure driverConfig+ <*> pure downloadDir++ <*> pure ffmpegToUse+ <*> newMVar OnDemandNotStarted++ <*> pure xvfbToUse+ <*> newMVar OnDemandNotStarted++ -- | Clean up the given WebDriver.-cleanupWebDriver :: (BaseMonad m context) => WebDriver -> ExampleT context m ()+cleanupWebDriver :: (BaseMonad m context) => TestWebDriverContext -> ExampleT context m () cleanupWebDriver sess = do closeAllSessions sess stopWebDriver sess -- | Run a given example using a given Selenium session. withSession :: forall m context a. (- MonadMask m, MonadBaseControl IO m+ MonadMask m , HasBaseContext context, HasSomeCommandLineOptions context, WebDriverMonad m context ) -- | Session to run- => Session+ => SessionName -> ExampleT (LabelValue "webdriverSession" WebDriverSession :> context) m a -> ExampleT context m a-withSession session action = do- WebDriver {..} <- getContext webdriver+withSession sessionName action = do+ TestWebDriverContext {..} <- getContext webdriver+ -- Create new session if necessary (this can throw an exception)- sess <- modifyMVar wdSessionMap $ \sessionMap -> case M.lookup session sessionMap of+ sess <- modifyMVar wdSessionMap $ \sessionMap -> case M.lookup sessionName sessionMap of Just sess -> return (sessionMap, sess) Nothing -> do- debug [i|Creating session '#{session}'|]- sess'' <- liftIO $ W.mkSession wdConfig- let sess' = sess'' { W.wdSessHistUpdate = W.unlimitedHistory }- sess <- liftIO $ W.runWD sess' $ W.createSession $ W.wdCapabilities wdConfig- return (M.insert session sess sessionMap, sess)-- ref <- liftIO $ newIORef sess+ finalCaps <- pure (capabilities wdOptions)+ >>= configureChromeUserDataDir - -- Not used for now, but previous libraries have use a finally to grab the final session on exception.- -- We could do the same here, but it's not clear that it's needed.- -- let f :: m a -> m a = id+ debug [i|Creating session '#{sessionName}'|]+ sess <- W.startSession wdContext wdDriverConfig finalCaps sessionName+ return (M.insert sessionName sess sessionMap, sess) - pushContext webdriverSession (session, ref) $- recordVideoIfConfigured session action+ pushContext webdriverSession (sessionName, sess) $+ recordVideoIfConfigured sessionName+ action -- | Convenience function. @withSession1 = withSession "session1"@. withSession1 :: (- MonadMask m, MonadBaseControl IO m+ MonadMask m , HasBaseContext context, HasSomeCommandLineOptions context, WebDriverMonad m context ) -- | Wrapped action@@ -225,7 +295,7 @@ -- | Convenience function. @withSession2 = withSession "session2"@. withSession2 :: (- MonadMask m, MonadBaseControl IO m+ MonadMask m , HasBaseContext context, HasSomeCommandLineOptions context, WebDriverMonad m context ) -- | Wrapped action@@ -234,9 +304,9 @@ withSession2 = withSession "session2" -- | Get all existing session names.-getSessions :: (MonadReader context m, WebDriverMonad m context) => m [Session]+getSessions :: (MonadReader context m, WebDriverMonad m context) => m [SessionName] getSessions = do- WebDriver {..} <- getContext webdriver+ TestWebDriverContext {..} <- getContext webdriver M.keys <$> liftIO (readMVar wdSessionMap) -- | Merge the options from the 'CommandLineOptions' into some 'WdOptions'.
src/Test/Sandwich/WebDriver/Config.hs view
@@ -7,16 +7,16 @@ , defaultWdOptions , runMode , capabilities- , httpManager , httpRetryCount- , saveSeleniumMessageHistory+ , geckodriverExtraFlags+ , chromedriverExtraFlags -- * Accessors for the 'WebDriver' context , getWdOptions- , getDisplayNumber+ -- , getDisplayNumber , getDownloadDirectory , getWebDriverName- , getXvfbSession+ -- , getXvfbSession -- * Xvfb mode , XvfbConfig
src/Test/Sandwich/WebDriver/Internal/Action.hs view
@@ -3,8 +3,6 @@ module Test.Sandwich.WebDriver.Internal.Action where import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.IO.Unlift import Control.Monad.Logger import qualified Data.Map as M import Data.String.Interpolate@@ -19,31 +17,31 @@ -- | Close the given session.-closeSession :: (HasCallStack, MonadLogger m, MonadUnliftIO m) => Session -> WebDriver -> m ()-closeSession session (WebDriver {wdSessionMap}) = do+closeSession :: (MonadLogger m, W.WebDriverBase m) => SessionName -> TestWebDriverContext -> m ()+closeSession session (TestWebDriverContext {wdSessionMap, wdContext}) = do toClose <- modifyMVar wdSessionMap $ \sessionMap -> case M.lookup session sessionMap of Nothing -> return (sessionMap, Nothing) Just x -> return (M.delete session sessionMap, Just x) - whenJust toClose $ \sess -> liftIO $ W.runWD sess W.closeSession+ whenJust toClose $ \sess -> W.closeSession wdContext sess -- | Close all sessions except those listed.-closeAllSessionsExcept :: (HasCallStack, MonadLogger m, MonadUnliftIO m) => [Session] -> WebDriver -> m ()-closeAllSessionsExcept toKeep (WebDriver {wdSessionMap}) = do+closeAllSessionsExcept :: (HasCallStack, MonadLogger m, W.WebDriverBase m) => [SessionName] -> TestWebDriverContext -> m ()+closeAllSessionsExcept toKeep (TestWebDriverContext {wdSessionMap, wdContext}) = do toClose <- modifyMVar wdSessionMap $ return . M.partitionWithKey (\name _ -> name `elem` toKeep) forM_ (M.toList toClose) $ \(name, sess) ->- catch (liftIO $ W.runWD sess W.closeSession)+ catch (W.closeSession wdContext sess) (\(e :: SomeException) -> warn [i|Failed to destroy session '#{name}': '#{e}'|]) -- | Close all sessions.-closeAllSessions :: (HasCallStack, MonadLogger m, MonadUnliftIO m) => WebDriver -> m ()+closeAllSessions :: (HasCallStack, MonadLogger m, W.WebDriverBase m) => TestWebDriverContext -> m () closeAllSessions = closeAllSessionsExcept [] -- | Close the current session. closeCurrentSession :: (- MonadLogger m, WebDriverSessionMonad m context+ MonadLogger m, WebDriverSessionMonad m context, W.WebDriverBase m ) => m () closeCurrentSession = do webDriver <- getContext webdriver
src/Test/Sandwich/WebDriver/Internal/Binaries/Selenium.hs view
@@ -67,9 +67,9 @@ True -> do debug [i|Found Selenium at #{path}|] return path-obtainSelenium (UseSeleniumFromNixpkgs nixContext) = do+obtainSelenium (UseSeleniumFromNixpkgs nc) = do debug [i|Building selenium-server-standalone with Nix...|]- ret <- buildNixSymlinkJoin' nixContext ["selenium-server-standalone"] >>=+ ret <- buildNixSymlinkJoin' nc ["selenium-server-standalone"] >>= liftIO . findFirstFile (return . (".jar" `L.isSuffixOf`)) debug [i|Got Selenium: #{ret}|] return ret
src/Test/Sandwich/WebDriver/Internal/Capabilities.hs view
@@ -11,12 +11,12 @@ , getDefaultFirefoxProfile ) where -import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.Aeson as A-import Data.Default-import Data.Function ((&))+import Data.Maybe+import Lens.Micro import Test.WebDriver-import qualified Test.WebDriver.Firefox.Profile as FF+import Test.WebDriver.Capabilities+import Test.WebDriver.Profile loggingPrefs :: A.Value loggingPrefs = A.object [@@ -32,49 +32,48 @@ -- | Default capabilities for regular Chrome. -- Has the "browser" log level to "ALL" so that tests can collect browser logs. chromeCapabilities :: Maybe FilePath -> Capabilities-chromeCapabilities maybeChromePath = def {- browser = Chrome Nothing maybeChromePath ["--verbose"] [] mempty- , additionalCaps=[("loggingPrefs", loggingPrefs)- , ("goog:loggingPrefs", loggingPrefs)]+chromeCapabilities maybeChromePath = defaultCaps {+ _capabilitiesGoogChromeOptions = Just $ defaultChromeOptions {+ _chromeOptionsArgs = Just ["--verbose"]+ , _chromeOptionsBinary = maybeChromePath+ , _chromeOptionsPerfLoggingPrefs = Just prefs+ } }+ where+ prefs = case loggingPrefs of+ A.Object x -> x+ _ -> error "Impossible" -- | Default capabilities for headless Chrome. headlessChromeCapabilities :: Maybe FilePath -> Capabilities-headlessChromeCapabilities maybeChromePath = def {- browser = Chrome Nothing maybeChromePath ["--verbose", "--headless"] [] mempty- , additionalCaps=[("loggingPrefs", loggingPrefs)- , ("goog:loggingPrefs", loggingPrefs)]- }+headlessChromeCapabilities maybeChromePath = chromeCapabilities maybeChromePath+ & over (capabilitiesGoogChromeOptions . _Just . chromeOptionsArgs) (Just . ("--headless" :) . fromMaybe []) -- * Firefox -getDefaultFirefoxProfile :: MonadBaseControl IO m => FilePath -> m (FF.PreparedProfile FF.Firefox)-getDefaultFirefoxProfile downloadDir = do- FF.defaultProfile- & FF.addPref "browser.download.folderList" (2 :: Int)- & FF.addPref "browser.download.manager.showWhenStarting" False- & FF.addPref "browser.download.dir" downloadDir- & FF.addPref "browser.helperApps.neverAsk.saveToDisk" ("*" :: String)- & FF.prepareProfile+getDefaultFirefoxProfile :: FilePath -> Profile Firefox+getDefaultFirefoxProfile downloadDir =+ defaultFirefoxProfile+ & addPref "browser.download.folderList" (2 :: Int)+ & addPref "browser.download.manager.showWhenStarting" False+ & addPref "browser.download.dir" downloadDir+ & addPref "browser.helperApps.neverAsk.saveToDisk" ("*" :: String) -- | Default capabilities for regular Firefox. firefoxCapabilities :: Maybe FilePath -> Capabilities-firefoxCapabilities maybeFirefoxPath = def { browser = ff }- where- ff = Firefox { ffProfile = Nothing- , ffLogPref = LogAll- , ffBinary = maybeFirefoxPath- , ffAcceptInsecureCerts = Nothing- }+firefoxCapabilities maybeFirefoxPath = defaultCaps {+ _capabilitiesMozFirefoxOptions = Just $ defaultFirefoxOptions {+ _firefoxOptionsBinary = maybeFirefoxPath+ , _firefoxOptionsLog = Just (FirefoxLogLevel FirefoxLogLevelTypeInfo)+ }+ } -- | Default capabilities for headless Firefox. headlessFirefoxCapabilities :: Maybe FilePath -> Capabilities-headlessFirefoxCapabilities maybeFirefoxPath = def { browser=ff, additionalCaps=additionalCaps }- where- ff = Firefox { ffProfile = Nothing- , ffLogPref = LogAll- , ffBinary = maybeFirefoxPath- , ffAcceptInsecureCerts = Nothing- }-- additionalCaps = [("moz:firefoxOptions", A.object [("args", A.Array ["-headless"])])]+headlessFirefoxCapabilities maybeFirefoxPath = defaultCaps {+ _capabilitiesMozFirefoxOptions = Just $ defaultFirefoxOptions {+ _firefoxOptionsBinary = maybeFirefoxPath+ , _firefoxOptionsArgs = Just ["-headless"]+ , _firefoxOptionsLog = Just (FirefoxLogLevel FirefoxLogLevelTypeInfo)+ }+ }
src/Test/Sandwich/WebDriver/Internal/Capabilities/Extra.hs view
@@ -3,8 +3,10 @@ {-# LANGUAGE OverloadedLists #-} module Test.Sandwich.WebDriver.Internal.Capabilities.Extra (- configureHeadlessCapabilities- , configureDownloadCapabilities+ configureHeadlessChromeCapabilities+ , configureHeadlessFirefoxCapabilities+ , configureChromeDownloadCapabilities+ , configureFirefoxDownloadCapabilities , configureChromeUserDataDir , configureChromeNoSandbox@@ -16,41 +18,33 @@ import Control.Monad.Logger import qualified Data.Aeson as A import Data.Function-import qualified Data.List as L import Data.Maybe import Data.String.Interpolate import qualified Data.Text as T-import qualified Data.Vector as V import GHC.Stack import Lens.Micro-import Lens.Micro.Aeson import System.IO.Temp import Test.Sandwich import Test.Sandwich.WebDriver.Internal.Binaries.Chrome.Detect (detectChromeVersion) import Test.Sandwich.WebDriver.Internal.Binaries.Chrome.Types (ChromeVersion(..)) import Test.Sandwich.WebDriver.Internal.Types-import qualified Test.WebDriver as W-import qualified Test.WebDriver.Firefox.Profile as FF+import Test.WebDriver.Capabilities as W+import Test.WebDriver.Profile #if MIN_VERSION_aeson(2,0,0)-import qualified Data.Aeson.Key as A import qualified Data.Aeson.KeyMap as HM-fromText :: T.Text -> A.Key-fromText = A.fromText #else import qualified Data.HashMap.Strict as HM-fromText :: T.Text -> T.Text-fromText = id #endif type Constraints m = (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadMask m) -- | Add headless configuration to the Chrome browser-configureHeadlessCapabilities :: (Constraints m) => WdOptions -> RunMode -> W.Capabilities -> m W.Capabilities-configureHeadlessCapabilities _wdOptions (RunHeadless (HeadlessConfig {..})) caps@(W.Capabilities {W.browser=browser@(W.Chrome {..})}) = do- chromeBinaryPath <- case chromeBinary of+configureHeadlessChromeCapabilities :: (Constraints m) => WdOptions -> RunMode -> W.Capabilities -> m W.Capabilities+configureHeadlessChromeCapabilities _wdOptions (RunHeadless (HeadlessConfig {..})) caps@(W.Capabilities {_capabilitiesGoogChromeOptions=(Just chromeOptions)}) = do+ chromeBinaryPath <- case W._chromeOptionsBinary chromeOptions of Nothing -> expectationFailure [i|Chrome capabilities didn't define chromeBinary in configureHeadlessCapabilities|] Just x -> pure x @@ -63,68 +57,46 @@ | major >= 110 -> return "--headless=new" | otherwise -> return "--headless" - let browser' = browser { W.chromeOptions = headlessArg:resolution:chromeOptions }+ let finalChromeOptions = chromeOptions+ & over chromeOptionsArgs (Just . (\x -> headlessArg:resolution:x) . fromMaybe []) - return (caps { W.browser = browser' })+ return (caps { W._capabilitiesGoogChromeOptions = Just finalChromeOptions }) where resolution = [i|--window-size=#{w},#{h}|] (w, h) = fromMaybe (1920, 1080) headlessResolution+configureHeadlessChromeCapabilities _ _ browser = return browser -- | Add headless configuration to the Firefox capabilities-configureHeadlessCapabilities _ (RunHeadless (HeadlessConfig {})) caps@(W.Capabilities {W.browser=(W.Firefox {}), W.additionalCaps=ac}) = return (caps { W.additionalCaps = additionalCaps })+configureHeadlessFirefoxCapabilities :: (Constraints m) => WdOptions -> RunMode -> W.Capabilities -> m W.Capabilities+configureHeadlessFirefoxCapabilities _ (RunHeadless (HeadlessConfig {})) caps@(W.Capabilities {_capabilitiesMozFirefoxOptions=(Just firefoxOptions)}) =+ return (caps { W._capabilitiesMozFirefoxOptions = Just finalFirefoxOptions }) where- additionalCaps = case L.findIndex (\x -> fst x == "moz:firefoxOptions") ac of- Nothing -> ("moz:firefoxOptions", A.object [("args", A.Array ["-headless"])]) : ac- Just i' -> let ffOptions' = snd (ac !! i')- & ensureKeyExists "args" (A.Array [])- & ((key "args" . _Array) %~ addHeadlessArg) in- L.nubBy (\x y -> fst x == fst y) (("moz:firefoxOptions", ffOptions') : ac)-- ensureKeyExists :: T.Text -> A.Value -> A.Value -> A.Value- ensureKeyExists key' _ val@(A.Object (HM.lookup (fromText key') -> Just _)) = val- ensureKeyExists key' defaultVal (A.Object m@(HM.lookup (fromText key') -> Nothing)) = A.Object (HM.insert (fromText key') defaultVal m)- ensureKeyExists _ _ _ = error "Expected Object in ensureKeyExists"-- addHeadlessArg :: V.Vector A.Value -> V.Vector A.Value- addHeadlessArg xs | (A.String "-headless") `V.elem` xs = xs- addHeadlessArg xs = (A.String "-headless") `V.cons` xs+ finalFirefoxOptions = firefoxOptions+ & over firefoxOptionsArgs (Just . (\x -> headlessArg:x) . fromMaybe []) -configureHeadlessCapabilities _ (RunHeadless {}) browser = error [i|Headless mode not yet supported for browser '#{browser}'|]-configureHeadlessCapabilities _ _ browser = return browser+ headlessArg = "-headless"+configureHeadlessFirefoxCapabilities _ _ browser = return browser -- | Configure download capabilities to set the download directory and disable prompts -- (since you can't test download prompts using Selenium)-configureDownloadCapabilities :: (- MonadIO m- ) => [Char] -> W.Capabilities -> m W.Capabilities-configureDownloadCapabilities downloadDir caps@(W.Capabilities {W.browser=browser@(W.Firefox {..})}) = do- profile <- case ffProfile of- Just x -> pure x- Nothing -> liftIO $ FF.defaultProfile- & FF.addPref "browser.download.folderList" (2 :: Int)- & FF.addPref "browser.download.manager.showWhenStarting" False- & FF.addPref "browser.download.dir" downloadDir- & FF.addPref "browser.helperApps.neverAsk.saveToDisk" ("*" :: String)- & FF.prepareProfile-- return (caps { W.browser = browser { W.ffProfile = Just profile } })-configureDownloadCapabilities downloadDir caps@(W.Capabilities {W.browser=browser@(W.Chrome {..})}) = return $ caps { W.browser=browser' }+configureChromeDownloadCapabilities :: Monad m => String -> Capabilities -> m Capabilities+configureChromeDownloadCapabilities downloadDir caps@(W.Capabilities {_capabilitiesGoogChromeOptions=(Just chromeOptions)}) =+ return $ caps { W._capabilitiesGoogChromeOptions=(Just finalChromeOptions) } where- browser' = browser { W.chromeExperimentalOptions = options }-- basePrefs :: A.Object- basePrefs = case HM.lookup "prefs" chromeExperimentalOptions of- Just (A.Object hm) -> hm- Just x -> error [i|Expected chrome prefs to be object, got '#{x}'.|]- Nothing -> mempty+ finalChromeOptions = chromeOptions+ & set chromeOptionsPrefs (Just prefs) prefs :: A.Object prefs = basePrefs & foldl (.) id [HM.insert k v | (k, v) <- downloadPrefs] - options = HM.insert "prefs" (A.Object prefs) chromeExperimentalOptions+ basePrefs :: A.Object+ basePrefs = case HM.lookup "prefs" (fromMaybe mempty (W._chromeOptionsPrefs chromeOptions)) of+ Just (A.Object hm) -> hm+ Just x -> error [i|Expected chrome prefs to be object, got '#{x}'.|]+ Nothing -> mempty downloadPrefs = [ ("profile.default_content_setting_values.automatic_downloads", A.Number 1)@@ -133,19 +105,47 @@ , ("download.directory_upgrade", A.Bool True) , ("download.default_directory", A.String (T.pack downloadDir)) ]-configureDownloadCapabilities _ browser = return browser+configureChromeDownloadCapabilities _ browser = return browser --- | chromedriver >= 131 started showing the following error:--- "session not created: probably user data directory is already in use, please specify a unique value for --user-data-dir argument, or don't use --user-data-dir".+-- | Configure download capabilities to set the download directory and disable prompts+-- (since you can't test download prompts using Selenium)+configureFirefoxDownloadCapabilities :: (+ MonadIO m+ ) => [Char] -> W.Capabilities -> m W.Capabilities+configureFirefoxDownloadCapabilities downloadDir caps@(W.Capabilities {_capabilitiesMozFirefoxOptions=(Just firefoxOptions)}) = do+ profile <- case W._firefoxOptionsProfile firefoxOptions of+ Just x -> pure x+ Nothing -> pure $ defaultFirefoxProfile+ & addPref "browser.download.folderList" (2 :: Int)+ & addPref "browser.download.manager.showWhenStarting" False+ & addPref "browser.download.dir" downloadDir+ & addPref "browser.helperApps.neverAsk.saveToDisk" ("*" :: String)++ let finalFirefoxOptions = firefoxOptions+ & set firefoxOptionsProfile (Just profile)++ return (caps { W._capabilitiesMozFirefoxOptions = Just finalFirefoxOptions })+configureFirefoxDownloadCapabilities _ browser = return browser++-- | Pass the @--user-data-dir@ argument to Chrome, putting the directory inside+-- the test tree. This is usually better than allowing tests to leave stuff in+-- /tmp etc. ----- This is a regression of some kind, but a fix is to explicitly pass a distinct user data dir.+-- Note that chromedriver sometimes reports an error like the following:+-- "session not created: probably user data directory is already in use, please+-- specify a unique value for --user-data-dir argument, or don't use+-- --user-data-dir".+--+-- This is usually a red herring, chromedriver seems to report it whenever the+-- browser fails to start up for whatever reason. configureChromeUserDataDir :: (Constraints m, HasBaseContextMonad context m, MonadFail m) => W.Capabilities -> m W.Capabilities-configureChromeUserDataDir caps@(W.Capabilities {W.browser=browser@(W.Chrome {..})}) = do+configureChromeUserDataDir caps@(W.Capabilities {_capabilitiesGoogChromeOptions=(Just chromeOptions)}) = do Just dir <- getCurrentFolder userDataDir <- liftIO $ createTempDirectory dir "chrome-user-data-dir" let arg = [i|--user-data-dir=#{userDataDir}|]- let browser' = browser { W.chromeOptions = arg:chromeOptions }- return (caps { W.browser = browser' })+ let finalChromeOptions = chromeOptions+ & over chromeOptionsArgs (Just . (arg :) . fromMaybe [])+ return (caps { W._capabilitiesGoogChromeOptions = Just finalChromeOptions }) configureChromeUserDataDir caps = return caps @@ -155,8 +155,10 @@ -- but is not configured correctly. Rather than run without sandboxing I'm aborting now. You need to make sure -- that /nix/store/6sshf2mnzfy72sqr7k9f2mi36ccczr9a-google-chrome-130.0.6723.91/share/google/chrome/chrome-sandbox -- is owned by root and has mode 4755.-configureChromeNoSandbox :: (Constraints m, HasBaseContextMonad context m, MonadFail m) => WdOptions -> W.Capabilities -> m W.Capabilities-configureChromeNoSandbox (WdOptions {chromeNoSandbox=True}) caps@(W.Capabilities {W.browser=browser@(W.Chrome {..})}) = do- let browser' = browser { W.chromeOptions = "--no-sandbox":chromeOptions }- return (caps { W.browser = browser' })+configureChromeNoSandbox :: (Constraints m) => WdOptions -> W.Capabilities -> m W.Capabilities+configureChromeNoSandbox (WdOptions {chromeNoSandbox=True}) caps@(W.Capabilities {_capabilitiesGoogChromeOptions=(Just chromeOptions)}) = do+ let arg = "--no-sandbox"+ let finalChromeOptions = chromeOptions+ & over chromeOptionsArgs (Just . (arg :) . fromMaybe [])+ return (caps { W._capabilitiesGoogChromeOptions = Just finalChromeOptions }) configureChromeNoSandbox _ caps = return caps
src/Test/Sandwich/WebDriver/Internal/Dependencies.hs view
@@ -18,14 +18,12 @@ , getBrowserDependencies , introduceBrowserDependenciesViaNix , introduceBrowserDependenciesViaNix'- , fillInCapabilitiesAndGetDriverArgs ) where import Control.Monad.IO.Unlift import Control.Monad.Logger import Control.Monad.Reader import Data.String.Interpolate-import System.FilePath import Test.Sandwich import Test.Sandwich.Contexts.Files import Test.Sandwich.Contexts.Nix@@ -35,7 +33,6 @@ import Test.Sandwich.WebDriver.Internal.Binaries.Selenium.Types import Test.Sandwich.WebDriver.Internal.Binaries.Xvfb import Test.Sandwich.WebDriver.Internal.Util-import qualified Test.WebDriver as W -- * All dependencies@@ -75,6 +72,7 @@ -- -- But, it's easy to customize this behavior. You can define your own 'WebDriverDependencies' and customize -- how each of these dependencies are found.+defaultWebDriverDependencies :: WebDriverDependencies defaultWebDriverDependencies = WebDriverDependencies { webDriverDependencyJava = Nothing , webDriverDependencySelenium = DownloadSeleniumDefault "/tmp/tools"@@ -101,18 +99,20 @@ type HasBrowserDependencies context = HasLabel context "browserDependencies" BrowserDependencies getBrowserDependencies :: (- MonadReader context m, HasBaseContext context- , MonadUnliftIO m, MonadLogger m+ MonadUnliftIO m, MonadLogger m+ , MonadReader context m, HasBaseContext context, HasSomeCommandLineOptions context ) => BrowserDependenciesSpec -> m BrowserDependencies getBrowserDependencies BrowserDependenciesSpecChrome {..} = do- chrome <- exceptionOnLeft $ obtainChrome browserDependenciesSpecChromeChrome- chromeDriver <- exceptionOnLeft $ obtainChromeDriver browserDependenciesSpecChromeChromeDriver+ SomeCommandLineOptions (CommandLineOptions {optWebdriverOptions=(CommandLineWebdriverOptions{..})}) <- getSomeCommandLineOptions+ chrome <- maybe (exceptionOnLeft (obtainChrome browserDependenciesSpecChromeChrome)) pure optChromeBinary+ chromeDriver <- maybe (exceptionOnLeft (obtainChromeDriver browserDependenciesSpecChromeChromeDriver)) pure optChromeDriverBinary info [i|chrome: #{chrome}|]- info [i|chromedriver: #{chromeDriver}|]+ info [i|chromedriver: ''#{chromeDriver}|] return $ BrowserDependenciesChrome chrome chromeDriver getBrowserDependencies (BrowserDependenciesSpecFirefox {..}) = do- firefox <- exceptionOnLeft $ obtainFirefox browserDependenciesSpecFirefoxFirefox- geckoDriver <- exceptionOnLeft $ obtainGeckoDriver browserDependenciesSpecFirefoxGeckodriver+ SomeCommandLineOptions (CommandLineOptions {optWebdriverOptions=(CommandLineWebdriverOptions{..})}) <- getSomeCommandLineOptions+ firefox <- maybe (exceptionOnLeft $ obtainFirefox browserDependenciesSpecFirefoxFirefox) pure optFirefoxBinary+ geckoDriver <- maybe (exceptionOnLeft $ obtainGeckoDriver browserDependenciesSpecFirefoxGeckodriver) pure optGeckoDriverBinary info [i|firefox: #{firefox}|] info [i|geckodriver: #{geckoDriver}|] return $ BrowserDependenciesFirefox firefox geckoDriver@@ -142,8 +142,9 @@ alloc = do SomeCommandLineOptions (CommandLineOptions {optWebdriverOptions=(CommandLineWebdriverOptions {..})}) <- getSomeCommandLineOptions - let useChrome = BrowserDependenciesChrome <$> getBinaryViaNixPackage @"google-chrome-stable" "google-chrome"- <*> getBinaryViaNixPackage @"chromedriver" "chromedriver"+ let useChrome = BrowserDependenciesChrome+ <$> maybe (getBinaryViaNixPackage @"google-chrome-stable" "google-chrome") pure optChromeBinary+ <*> maybe (getBinaryViaNixPackage @"chromedriver" "chromedriver") pure optChromeDriverBinary -- let useFirefox = case os of -- "darwin" -> do@@ -153,8 +154,9 @@ -- _ -> BrowserDependenciesFirefox <$> getBinaryViaNixPackage @"firefox" "firefox" -- <*> getBinaryViaNixPackage @"geckodriver" "geckodriver" - let useFirefox = BrowserDependenciesFirefox <$> getBinaryViaNixPackage @"firefox" "firefox"- <*> getBinaryViaNixPackage @"geckodriver" "geckodriver"+ let useFirefox = BrowserDependenciesFirefox+ <$> maybe (getBinaryViaNixPackage @"firefox" "firefox") pure optFirefoxBinary+ <*> maybe (getBinaryViaNixPackage @"geckodriver" "geckodriver") pure optGeckoDriverBinary deps <- case optBrowserToUse of Just UseChrome -> useChrome@@ -164,25 +166,3 @@ info [i|Got browser dependencies: #{deps}|] return deps--fillInCapabilitiesAndGetDriverArgs webdriverRoot 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')
− src/Test/Sandwich/WebDriver/Internal/Screenshots.hs
@@ -1,29 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Test.Sandwich.WebDriver.Internal.Screenshots where--import Control.Concurrent-import Control.Monad-import Control.Monad.IO.Class-import qualified Data.Map as M-import Data.String.Interpolate-import qualified Data.Text as T-import GHC.Stack-import Network.HTTP.Client-import System.FilePath-import Test.Sandwich.WebDriver.Internal.Types-import Test.WebDriver-import UnliftIO.Exception--saveScreenshots :: (HasCallStack) => T.Text -> WebDriver -> FilePath -> IO ()-saveScreenshots screenshotName (WebDriver {..}) resultsDir = do- -- For every session, and for every window, try to get a screenshot for the results dir- sessionMap <- readMVar wdSessionMap- forM_ (M.toList sessionMap) $ \(browser, sess) ->- handle (\(e :: HttpException) -> case e of- (HttpExceptionRequest _ content) -> liftIO $ putStrLn [i|HttpException when trying to take a screenshot: '#{content}'|]- e' -> liftIO $ putStrLn [i|HttpException when trying to take a screenshot: '#{e'}'|])- (runWD sess $ saveScreenshot $ resultsDir </> [i|#{browser}_#{screenshotName}.png|])
src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs view
@@ -6,37 +6,16 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module Test.Sandwich.WebDriver.Internal.StartWebDriver where+module Test.Sandwich.WebDriver.Internal.StartWebDriver (+ stopWebDriver+ ) where -import Control.Monad import Control.Monad.Catch (MonadMask)-import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Logger-import Control.Monad.Reader (MonadReader)-import Control.Retry-import Data.Default-import Data.Function (fix)-import Data.String.Interpolate-import qualified Data.Text as T import GHC.Stack-import System.Directory-import System.FilePath-import System.IO (hClose, hGetLine)-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.Capabilities.Extra-import Test.Sandwich.WebDriver.Internal.Dependencies import Test.Sandwich.WebDriver.Internal.Types-import Test.Sandwich.WebDriver.Internal.Util import qualified Test.WebDriver as W-import UnliftIO.Async-import UnliftIO.Concurrent-import UnliftIO.Exception-import UnliftIO.Process-import UnliftIO.Timeout #ifndef mingw32_HOST_OS import Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb@@ -47,133 +26,12 @@ HasCallStack, MonadLoggerIO m, MonadUnliftIO m, MonadMask m, MonadFail m ) --- | Spin up a Selenium WebDriver and create a WebDriver-startWebDriver :: (- Constraints m, MonadReader context m, HasBaseContext context- , HasFile context "java", HasFile context "selenium.jar", HasBrowserDependencies context- ) => WdOptions -> OnDemandOptions -> FilePath -> m WebDriver-startWebDriver wdOptions@(WdOptions {capabilities=capabilities'', ..}) (OnDemandOptions {..}) 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-- -- Directory to log everything for this webdriver- let webdriverRoot = runRoot </> (T.unpack webdriverName)- liftIO $ createDirectoryIfMissing True webdriverRoot-- -- Directory to hold any downloads- let downloadDir = webdriverRoot </> "Downloads"- liftIO $ createDirectoryIfMissing True downloadDir-- -- Get selenium, driver args, and capabilities with browser paths applied- java <- askFile @"java"- seleniumPath <- askFile @"selenium.jar"- (driverArgs, capabilities') <- fillInCapabilitiesAndGetDriverArgs webdriverRoot capabilities''-- -- Set up xvfb if configured- xvfbOnDemand <- newMVar OnDemandNotStarted- (maybeXvfbSession, javaEnv) <- case runMode of-#ifndef mingw32_HOST_OS- RunInXvfb (XvfbConfig {..}) -> do- (s, e) <- makeXvfbSession xvfbResolution xvfbStartFluxbox webdriverRoot xvfbToUse xvfbOnDemand- return (Just s, Just e)-#endif- _ -> return (Nothing, Nothing)-- -- Create a distinct process name- webdriverProcessName <- ("webdriver_process_" <>) <$> (liftIO makeUUID)- let webdriverProcessRoot = webdriverRoot </> T.unpack webdriverProcessName- liftIO $ createDirectoryIfMissing True webdriverProcessRoot-- -- 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.- let policy = constantDelay 0 <> limitRetries 10- (port, hRead, p) <- recoverAll policy $ \retryStatus -> flip withException (\(e :: SomeException) -> warn [i|Exception in startWebDriver retry: #{e}|]) $ do- when (rsIterNumber retryStatus > 0) $- warn [i|Trying again to start selenium server (attempt #{rsIterNumber retryStatus})|]-- (hRead, hWrite) <- createPipe- port <- findFreePortOrException-- let allArgs = driverArgs <> ["-jar", seleniumPath- , "-port", show port]- let cp = (proc java allArgs) {- env = javaEnv- , std_in = Inherit- , std_out = UseHandle hWrite- , std_err = UseHandle hWrite- , create_group = True- }-- -- Start the process and wait for it to be ready- debug [i|#{java} #{T.unwords $ fmap T.pack allArgs}|]-- (_, _, _, p) <- liftIO $ createProcess cp-- let teardown = do- gracefullyStopProcess p 30_000_000- liftIO $ hClose hRead-- -- On exception, make sure the process is gone and the pipe handle is closed- flip withException (\(_ :: SomeException) -> teardown) $ do- -- 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- 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-- case startupResult of- Nothing -> do- let msg = [i|Didn't see "up and running" line in Selenium output after 10s.|]- warn msg- expectationFailure (T.unpack msg)- Just () -> return (port, hRead, p)-- -- TODO: save this in the WebDriver to tear it down later?- _logAsync <- async $ forever (liftIO (hGetLine hRead) >>= (debug . T.pack))-- -- Final extra capabilities configuration- capabilities <-- pure capabilities'- >>= configureChromeNoSandbox wdOptions- >>= configureChromeUserDataDir- >>= configureHeadlessCapabilities wdOptions runMode- >>= configureDownloadCapabilities downloadDir-- -- Make the WebDriver- WebDriver <$> pure (T.unpack webdriverName)- <*> pure (p, maybeXvfbSession)- <*> pure (wdOptions {- capabilities = capabilities- })- <*> liftIO (newMVar mempty)- <*> pure (def { W.wdPort = fromIntegral port- , W.wdCapabilities = capabilities- , W.wdHTTPManager = httpManager- , W.wdHTTPRetryCount = httpRetryCount- })- <*> pure downloadDir-- <*> pure ffmpegToUse- <*> newMVar OnDemandNotStarted-- <*> pure xvfbToUse- <*> pure xvfbOnDemand---stopWebDriver :: Constraints m => WebDriver -> m ()-stopWebDriver (WebDriver {wdWebDriver=(h, maybeXvfbSession)}) = do- -- | TODO: expose this as an option- let gracePeriod :: Int- gracePeriod = 30000000-- gracefullyStopProcess h gracePeriod+stopWebDriver :: (Constraints m, W.WebDriverBase m) => TestWebDriverContext -> m ()+stopWebDriver (TestWebDriverContext {wdContext}) = do+ W.teardownWebDriverContext wdContext - whenJust maybeXvfbSession $ \(XvfbSession {..}) -> do- whenJust xvfbFluxboxProcess $ \p -> do- gracefullyStopProcess p gracePeriod+ -- whenJust maybeXvfbSession $ \(XvfbSession {..}) -> do+ -- whenJust xvfbFluxboxProcess $ \p' -> do+ -- gracefullyStopProcess p' gracePeriod - gracefullyStopProcess xvfbProcess gracePeriod+ -- gracefullyStopProcess xvfbProcess gracePeriod
src/Test/Sandwich/WebDriver/Internal/Types.hs view
@@ -1,33 +1,29 @@-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-} module Test.Sandwich.WebDriver.Internal.Types where import Control.Concurrent.MVar import Control.Exception-import Data.Default-import Data.IORef import qualified Data.Map as M import Data.String.Interpolate import Data.Text (Text)-import Network.HTTP.Client (Manager) import System.Process import Test.Sandwich import Test.Sandwich.WebDriver.Internal.Binaries.Ffmpeg import Test.Sandwich.WebDriver.Internal.Binaries.Xvfb import qualified Test.WebDriver as W-import qualified Test.WebDriver.Session as W import UnliftIO.Async -- | 'Session' is just a 'String' name.-type Session = String+type SessionName = String -- * Labels-webdriver :: Label "webdriver" WebDriver+webdriver :: Label "webdriver" TestWebDriverContext webdriver = Label webdriverSession :: Label "webdriverSession" WebDriverSession@@ -50,23 +46,23 @@ -- The @Xvfb@ binary must be installed and on the PATH. data WdOptions = WdOptions {+ -- | The WebDriver capabilities to use. capabilities :: W.Capabilities- -- ^ The WebDriver capabilities to use. - , saveSeleniumMessageHistory :: WhenToSave- -- ^ When to save a record of Selenium requests and responses.-+ -- | How to handle opening the browser (in a popup window, headless, etc.). , runMode :: RunMode- -- ^ How to handle opening the browser (in a popup window, headless, etc.). - , httpManager :: Maybe Manager- -- ^ HTTP manager for making requests to Selenium. If not provided, one will be created for each session.-+ -- | Number of times to retry an HTTP request if it times out. , httpRetryCount :: Int- -- ^ Number of times to retry an HTTP request if it times out. + -- | Pass the --no-sandbox flag to Chrome (useful in GitHub Actions when installing Chrome via Nix). , chromeNoSandbox :: Bool- -- ^ Pass the --no-sandbox flag to Chrome (useful in GitHub Actions when installing Chrome via Nix).++ -- | Extra flags to pass to chromedriver+ , chromedriverExtraFlags :: [String]++ -- | Extra flags to pass to geckodriver+ , geckodriverExtraFlags :: [String] } -- | How to obtain certain binaries "on demand". These may or not be needed based on 'WdOptions', so@@ -78,6 +74,7 @@ -- | How to obtain Xvfb binary. , xvfbToUse :: XvfbToUse }+defaultOnDemandOptions :: OnDemandOptions defaultOnDemandOptions = OnDemandOptions { ffmpegToUse = UseFfmpegFromPath , xvfbToUse = UseXvfbFromPath@@ -109,12 +106,12 @@ -- You should start with this and modify it using the accessors. defaultWdOptions :: WdOptions defaultWdOptions = WdOptions {- capabilities = def- , saveSeleniumMessageHistory = OnException+ capabilities = W.defaultCaps , runMode = Normal- , httpManager = Nothing , httpRetryCount = 0 , chromeNoSandbox = False+ , chromedriverExtraFlags = []+ , geckodriverExtraFlags = [] } data OnDemand a =@@ -123,12 +120,12 @@ | OnDemandReady a | OnDemandErrored Text -data WebDriver = WebDriver {+data TestWebDriverContext = TestWebDriverContext { wdName :: String- , wdWebDriver :: (ProcessHandle, Maybe XvfbSession)+ , wdContext :: W.WebDriverContext , wdOptions :: WdOptions- , wdSessionMap :: MVar (M.Map Session W.WDSession)- , wdConfig :: W.WDConfig+ , wdSessionMap :: MVar (M.Map String W.Session)+ , wdDriverConfig :: W.DriverConfig , wdDownloadDir :: FilePath , wdFfmpegToUse :: FfmpegToUse@@ -151,31 +148,31 @@ , xvfbFluxboxProcess :: Maybe ProcessHandle } -type WebDriverSession = (Session, IORef W.WDSession)+type WebDriverSession = (SessionName, W.Session) -- | Get the 'WdOptions' associated with the 'WebDriver'.-getWdOptions :: WebDriver -> WdOptions+getWdOptions :: TestWebDriverContext -> WdOptions getWdOptions = wdOptions -- | Get the X11 display number associated with the 'WebDriver'. -- Only present if running in 'RunInXvfb' mode.-getDisplayNumber :: WebDriver -> Maybe Int-getDisplayNumber (WebDriver {wdWebDriver=(_, Just (XvfbSession {xvfbDisplayNum}))}) = Just xvfbDisplayNum-getDisplayNumber _ = Nothing+-- getDisplayNumber :: TestWebDriverContext -> Maybe Int+-- getDisplayNumber (TestWebDriverContext {wdWebDriver=(_, Just (XvfbSession {xvfbDisplayNum}))}) = Just xvfbDisplayNum+-- getDisplayNumber _ = Nothing --- | Get the Xvfb session associated with the 'WebDriver', if present.-getXvfbSession :: WebDriver -> Maybe XvfbSession-getXvfbSession (WebDriver {wdWebDriver=(_, Just sess)}) = Just sess-getXvfbSession _ = Nothing+-- -- | Get the Xvfb session associated with the 'WebDriver', if present.+-- getXvfbSession :: TestWebDriverContext -> Maybe XvfbSession+-- getXvfbSession (TestWebDriverContext {wdWebDriver=(_, Just sess)}) = Just sess+-- getXvfbSession _ = Nothing -- | Get the configured download directory for the 'WebDriver'.-getDownloadDirectory :: WebDriver -> FilePath+getDownloadDirectory :: TestWebDriverContext -> FilePath getDownloadDirectory = wdDownloadDir -- | Get the name of the 'WebDriver'. -- This corresponds to the folder that will be created to hold the log files for the 'WebDriver'.-getWebDriverName :: WebDriver -> String-getWebDriverName (WebDriver {wdName}) = wdName+getWebDriverName :: TestWebDriverContext -> String+getWebDriverName (TestWebDriverContext {wdName}) = wdName instance Show XvfbSession where show (XvfbSession {xvfbDisplayNum}) = [i|<XVFB session with server num #{xvfbDisplayNum}>|]
src/Test/Sandwich/WebDriver/Types.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE TypeOperators #-}@@ -15,64 +16,94 @@ -- * Context aliases , HasBrowserDependencies- , HasWebDriverContext+ , HasTestWebDriverContext , HasWebDriverSessionContext -- * The Xvfb session , XvfbSession(..)- , getXvfbSession+ -- , getXvfbSession ) where import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Reader-import Control.Monad.Trans.Control (MonadBaseControl)-import Data.IORef+import qualified Data.Aeson as A+import Data.ByteString+import qualified Data.ByteString.Lazy as BL+import Data.String.Interpolate+import Data.Text (Text) import GHC.Stack+import qualified Network.HTTP.Client as HC+import Network.HTTP.Types.Status as N import Test.Sandwich-import Test.Sandwich.Contexts.Files import Test.Sandwich.WebDriver.Internal.Dependencies import Test.Sandwich.WebDriver.Internal.Types-import qualified Test.WebDriver.Class as W-import qualified Test.WebDriver.Internal as WI-import qualified Test.WebDriver.Session as W+import qualified Test.WebDriver as W+import qualified Test.WebDriver.Types as W import UnliftIO.Exception as ES +#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as A+import qualified Data.Aeson.KeyMap as HM+#else+import Data.Hashable+import qualified Data.HashMap.Strict as HM+#endif -instance (MonadIO m, HasWebDriverSessionContext context) => W.WDSessionState (ExampleT context m) where++#if MIN_VERSION_aeson(2,0,0)+aesonLookup :: Text -> HM.KeyMap v -> Maybe v+aesonLookup = HM.lookup . A.fromText+#else+aesonLookup :: (Eq k, Hashable k) => k -> HM.HashMap k v -> Maybe v+aesonLookup = HM.lookup+#endif++instance (MonadIO m, HasWebDriverSessionContext context) => W.SessionState (ExampleT context m) where getSession = do- (_, sessVar) <- getContext webdriverSession- liftIO $ readIORef sessVar- putSession sess = do- (_, sessVar) <- getContext webdriverSession- liftIO $ writeIORef sessVar sess+ (_, sess) <- getContext webdriverSession+ return sess --- Implementation copied from that of the WD monad implementation-instance (MonadIO m, MonadBaseControl IO m, HasWebDriverSessionContext context) => W.WebDriver (ExampleT context m) where- doCommand method path args = WI.mkRequest method path args- >>= WI.sendHTTPRequest- >>= either throwIO return- >>= WI.getJSONResult- >>= either throwIO return+-- This implementation of 'W.WebDriverBase' provides logging for the requests/responses.+instance (MonadUnliftIO m) => W.WebDriverBase (ExampleT context m) where+ doCommandBase driver method path args = do+ let req = W.mkDriverRequest driver method path args+ debug [i|--> #{HC.method req} #{HC.path req}#{HC.queryString req} (#{showRequestBody (HC.requestBody req)})|]+ response <- tryAny (liftIO $ HC.httpLbs req (W._driverManager driver)) >>= either throwIO return+ let (N.Status code _) = HC.responseStatus response -type HasWebDriverContext context = HasLabel context "webdriver" WebDriver+ -- TODO: truncate the response body. We're currently logging entire screenshot responses.++ if | code >= 200 && code < 300 -> case A.eitherDecode (HC.responseBody response) of+ -- For successful responses, try to pull out the "value" and show it+ Right (A.Object (aesonLookup "value" -> Just value)) -> debug [i|<-- #{code} #{A.encode value}|]+ _ -> debug [i|<-- #{code} #{HC.responseBody response}|]+ -- For non-successful responses, log the entire response.+ -- Reading the WebDriver spec, it would probably be sufficient to just show the "value" as above,+ -- plus the HTTP status message.+ | otherwise -> debug [i|<-- #{code} #{response}|]+ return response++ where+ showRequestBody :: HC.RequestBody -> ByteString+ showRequestBody (HC.RequestBodyLBS bytes) = BL.toStrict bytes+ showRequestBody (HC.RequestBodyBS bytes) = bytes+ showRequestBody _ = "<request body>"++type HasTestWebDriverContext context = HasLabel context "webdriver" TestWebDriverContext type HasWebDriverSessionContext context = HasLabel context "webdriverSession" WebDriverSession type ContextWithWebdriverDeps context =- LabelValue "webdriver" WebDriver+ LabelValue "webdriver" TestWebDriverContext :> ContextWithBaseDeps context type ContextWithBaseDeps context = -- | Browser dependencies LabelValue "browserDependencies" BrowserDependencies- -- | Java- :> FileValue "java"- -- | Selenium- :> FileValue "selenium.jar" -- | Base context :> context type BaseMonad m context = (HasCallStack, MonadUnliftIO m, MonadMask m, HasBaseContext context)-type WebDriverMonad m context = (HasCallStack, MonadUnliftIO m, HasWebDriverContext context)+type WebDriverMonad m context = (HasCallStack, MonadUnliftIO m, HasTestWebDriverContext context) type WebDriverSessionMonad m context = (WebDriverMonad m context, MonadReader context m, HasWebDriverSessionContext context)
src/Test/Sandwich/WebDriver/Video.hs view
@@ -47,15 +47,14 @@ import Test.Sandwich.WebDriver.Video.Internal import Test.Sandwich.WebDriver.Video.Types import Test.Sandwich.WebDriver.Windows-import Test.WebDriver.Class as W-import Test.WebDriver.Commands+import Test.WebDriver import UnliftIO.Directory import UnliftIO.Exception type BaseVideoConstraints context m = ( MonadLoggerIO m, MonadUnliftIO m, MonadMask m- , MonadReader context m, HasBaseContext context, HasWebDriverContext context+ , MonadReader context m, HasBaseContext context, HasTestWebDriverContext context ) -- | A type representing a live video recording process@@ -77,7 +76,8 @@ -> m VideoProcess startFullScreenVideoRecording path videoSettings = do sess <- getContext webdriver- let maybeXvfbSession = getXvfbSession sess+ -- let maybeXvfbSession = getXvfbSession sess+ let maybeXvfbSession = Nothing (width, height) <- case maybeXvfbSession of Just (XvfbSession {xvfbDimensions}) -> return xvfbDimensions Nothing -> do@@ -87,15 +87,14 @@ -- | Wrapper around 'startVideoRecording' which uses WebDriver to find the rectangle corresponding to the browser. startBrowserVideoRecording :: (- BaseVideoConstraints context m, W.WebDriver m+ BaseVideoConstraints context m, WebDriver m ) -- | Output path => FilePath -> VideoSettings -> m VideoProcess startBrowserVideoRecording path videoSettings = do- (x, y) <- getWindowPos- (w, h) <- getWindowSize+ Rect x y w h <- getWindowRect startVideoRecording path (w, h, x, y) videoSettings -- | Record video to a given path, for a given screen rectangle.@@ -105,13 +104,14 @@ -- | Output path => FilePath -- | Rectangle to record, specified as @(width, height, x, y)@- -> (Word, Word, Int, Int)+ -> (Float, Float, Float, Float) -> VideoSettings -- | Returns handle to video process and list of files created -> m VideoProcess startVideoRecording path (width, height, x, y) vs = do sess <- getContext webdriver- let maybeXvfbSession = getXvfbSession sess+ -- let maybeXvfbSession = getXvfbSession sess+ let maybeXvfbSession = Nothing (cp', videoPath) <- getVideoArgs path (width, height, x, y) vs maybeXvfbSession let cp = cp' { create_group = True }@@ -156,7 +156,7 @@ -- This can be used to record video around individual tests. It can also keep videos only in case of -- exceptions, deleting them on successful runs. recordVideoIfConfigured :: (- BaseVideoConstraints context m, W.WebDriver m, HasSomeCommandLineOptions context+ BaseVideoConstraints context m, WebDriver m, HasSomeCommandLineOptions context ) -- | Session name => String@@ -172,14 +172,14 @@ | otherwise -> action withVideo :: (- BaseVideoConstraints context m, W.WebDriver m+ BaseVideoConstraints context m, WebDriver m ) => FilePath -> String -> m a -> m a withVideo folder browser action = do path <- getPathInFolder folder browser bracket (startBrowserVideoRecording path defaultVideoSettings) endVideoRecording (const action) withVideoIfException :: (- BaseVideoConstraints context m, W.WebDriver m+ BaseVideoConstraints context m, WebDriver m ) => FilePath -> String -> m a -> m a withVideoIfException folder browser action = do path <- getPathInFolder folder browser
src/Test/Sandwich/WebDriver/Video/Internal.hs view
@@ -6,7 +6,6 @@ , videoExtension ) where -import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Unlift import Control.Monad.Logger import Control.Monad.Reader@@ -37,11 +36,11 @@ videoExtension = "avi" getVideoArgs :: (- MonadUnliftIO m, MonadLoggerIO m, MonadMask m- , MonadReader context m, HasBaseContext context, HasWebDriverContext context- ) => FilePath -> (Word, Word, Int, Int) -> VideoSettings -> Maybe XvfbSession -> m (CreateProcess, FilePath)+ MonadUnliftIO m, MonadLoggerIO m+ , MonadReader context m, HasBaseContext context, HasTestWebDriverContext context+ ) => FilePath -> (Float, Float, Float, Float) -> VideoSettings -> Maybe XvfbSession -> m (CreateProcess, FilePath) getVideoArgs path (width, height, x, y) (VideoSettings {..}) maybeXvfbSession = do- WebDriver {wdFfmpeg, wdFfmpegToUse} <- getContext webdriver+ TestWebDriverContext {wdFfmpeg, wdFfmpegToUse} <- getContext webdriver ffmpeg <- getOnDemand wdFfmpeg (obtainFfmpeg wdFfmpegToUse) #ifdef linux_HOST_OS
src/Test/Sandwich/WebDriver/Windows.hs view
@@ -22,11 +22,10 @@ import Test.Sandwich.WebDriver.Resolution import Test.Sandwich.WebDriver.Types import Test.WebDriver-import qualified Test.WebDriver.Class as W -- | Position the window on the left 50% of the screen.-setWindowLeftSide :: (WebDriverMonad m context, MonadReader context m, W.WebDriver m) => m ()+setWindowLeftSide :: (WebDriverMonad m context, MonadReader context m, WebDriver m) => m () setWindowLeftSide = do sess <- getContext webdriver (x, y, width, height) <- case runMode $ wdOptions sess of@@ -36,11 +35,10 @@ (screenWidth, screenHeight) <- getScreenPixelDimensions width height - setWindowPos (x, y)- setWindowSize (round (screenWidth / 2.0), round screenHeight)+ setWindowRect $ Rect (fromIntegral x) (fromIntegral y) (realToFrac (screenWidth / 2.0)) (realToFrac screenHeight) -- | Position the window on the right 50% of the screen.-setWindowRightSide :: (WebDriverMonad m context, MonadReader context m, W.WebDriver m) => m ()+setWindowRightSide :: (WebDriverMonad m context, MonadReader context m, WebDriver m) => m () setWindowRightSide = do sess <- getContext webdriver (x, y, width, height) <- case runMode $ wdOptions sess of@@ -50,11 +48,10 @@ (screenWidth, screenHeight) <- getScreenPixelDimensions width height - setWindowPos (x + round (screenWidth / 2.0), y + 0)- setWindowSize (round (screenWidth / 2.0), round screenHeight)+ setWindowRect $ Rect (fromIntegral (x + round (screenWidth / 2.0))) (fromIntegral (y + 0)) (realToFrac (screenWidth / 2.0)) (realToFrac screenHeight) -- | Fullscreen the browser window.-setWindowFullScreen :: (WebDriverMonad m context, MonadReader context m, W.WebDriver m) => m ()+setWindowFullScreen :: (WebDriverMonad m context, MonadReader context m, WebDriver m) => m () setWindowFullScreen = do sess <- getContext webdriver (x, y, width, height) <- case runMode $ wdOptions sess of@@ -64,17 +61,17 @@ (screenWidth, screenHeight) <- getScreenPixelDimensions width height - setWindowPos (x + 0, y + 0)- setWindowSize (round screenWidth, round screenHeight)+ setWindowRect $ Rect (fromIntegral x) (fromIntegral y) (realToFrac screenWidth) (realToFrac screenHeight) -- | Get the screen resolution as (x, y, width, height). (The x and y coordinates may be nonzero in multi-monitor setups.) -- This function works with both normal 'RunMode' and Xvfb mode.-getScreenResolution :: (MonadIO m) => WebDriver -> m (Int, Int, Int, Int)-getScreenResolution (WebDriver {wdWebDriver=(_, maybeXvfbSession)}) = case maybeXvfbSession of- Nothing -> liftIO getResolution- Just (XvfbSession {..}) -> liftIO $ getResolutionForDisplay xvfbDisplayNum+getScreenResolution :: (MonadIO m) => TestWebDriverContext -> m (Int, Int, Int, Int)+-- getScreenResolution (TestWebDriverContext {wdWebDriver=(_, maybeXvfbSession)}) = case maybeXvfbSession of+-- Nothing -> liftIO getResolution+-- Just (XvfbSession {..}) -> liftIO $ getResolutionForDisplay xvfbDisplayNum+getScreenResolution twdc = liftIO getResolution -getScreenPixelDimensions :: (MonadIO m, W.WebDriver m) => Int -> Int -> m (Double, Double)+getScreenPixelDimensions :: (WebDriver m) => Int -> Int -> m (Double, Double) getScreenPixelDimensions width height = do devicePixelRatio <- executeJS [] "return window.devicePixelRatio" >>= \case Just (ratio :: Double) -> pure ratio
unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs view
@@ -38,8 +38,10 @@ #ifdef darwin_HOST_OS import GHC.IO.FD+import GHC.IO.Handle (Handle) import qualified GHC.IO.Handle.FD as HFD newtype Fd = Fd FD+handleToFd :: Handle -> IO Fd handleToFd h = Fd <$> HFD.handleToFd h #endif