sandwich-webdriver 0.1.0.6 → 0.1.1.0
raw patch · 16 files changed
+369/−217 lines, 16 files
Files
- CHANGELOG.md +6/−0
- LICENSE +1/−1
- app/Main.hs +8/−2
- app/Simple.hs +1/−1
- sandwich-webdriver.cabal +16/−7
- src/Test/Sandwich/WebDriver.hs +4/−5
- src/Test/Sandwich/WebDriver/Config.hs +2/−0
- src/Test/Sandwich/WebDriver/Internal/Binaries.hs +7/−7
- src/Test/Sandwich/WebDriver/Internal/Binaries/Util.hs +22/−13
- src/Test/Sandwich/WebDriver/Internal/Capabilities.hs +25/−23
- src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs +82/−19
- src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs +0/−134
- src/Test/Sandwich/WebDriver/Internal/Types.hs +16/−4
- src/Test/Sandwich/WebDriver/Internal/Util.hs +43/−1
- src/Test/Sandwich/WebDriver/Types.hs +2/−0
- unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs +134/−0
CHANGELOG.md view
@@ -2,6 +2,12 @@ ## Unreleased changes +* Be able to control download directory.++# 0.1.1.0++* Windows support.+ # 0.1.0.6 * Remove X11 dependency and replace with per-platform code to get screen resolution.
LICENSE view
@@ -1,4 +1,4 @@-Copyright Tom McLaughlin (c) 2021+Copyright Tom McLaughlin (c) 2022 All rights reserved.
app/Main.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE CPP #-}+ module Main where import Control.Concurrent@@ -11,11 +13,15 @@ import Data.Time.Clock import Test.Sandwich import Test.Sandwich.Formatters.Print-import Test.Sandwich.Formatters.TerminalUI import Test.Sandwich.WebDriver import Test.Sandwich.WebDriver.Windows import Test.WebDriver +#ifndef mingw32_HOST_OS+import Test.Sandwich.Formatters.TerminalUI+#endif++ simple :: TopSpec simple = introduceWebDriver wdOptions $ do it "does the thing 1" $ withSession1 $ do@@ -79,7 +85,7 @@ wdOptions = (defaultWdOptions "/tmp/tools") { -- capabilities = chromeCapabilities- capabilities = firefoxCapabilities+ capabilities = firefoxCapabilities Nothing -- capabilities = headlessFirefoxCapabilities , saveSeleniumMessageHistory = Always -- , runMode = Normal
app/Simple.hs view
@@ -6,7 +6,7 @@ import Test.WebDriver wdOptions = (defaultWdOptions "/tmp/tools") {- capabilities = firefoxCapabilities+ capabilities = firefoxCapabilities Nothing , runMode = RunHeadless defaultHeadlessConfig }
sandwich-webdriver.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sandwich-webdriver-version: 0.1.0.6+version: 0.1.1.0 synopsis: Sandwich integration with Selenium WebDriver description: Please see the <https://codedownio.github.io/sandwich/docs/extensions/sandwich-webdriver documentation>. category: Testing@@ -13,7 +13,7 @@ bug-reports: https://github.com/codedownio/sandwich/issues author: Tom McLaughlin maintainer: tom@codedown.io-copyright: 2021 Tom McLaughlin+copyright: 2022 Tom McLaughlin license: BSD3 license-file: LICENSE build-type: Simple@@ -36,7 +36,6 @@ Test.Sandwich.WebDriver.Internal.Ports Test.Sandwich.WebDriver.Internal.Screenshots Test.Sandwich.WebDriver.Internal.StartWebDriver- Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb Test.Sandwich.WebDriver.Internal.Types Test.Sandwich.WebDriver.Internal.Util Test.Sandwich.WebDriver.Internal.Video@@ -86,7 +85,6 @@ , text , time , transformers- , unix , unordered-containers , vector , webdriver@@ -103,6 +101,14 @@ linux-src build-depends: regex-compat+ if !os(windows)+ build-depends:+ unix+ if !os(windows)+ other-modules:+ Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb+ hs-source-dirs:+ unix-src default-language: Haskell2010 executable sandwich-webdriver-exe@@ -152,7 +158,6 @@ , text , time , transformers- , unix , unordered-containers , vector , webdriver@@ -175,6 +180,9 @@ linux-src build-depends: regex-compat+ if !os(windows)+ build-depends:+ unix default-language: Haskell2010 test-suite sandwich-webdriver-test@@ -218,13 +226,11 @@ , safe , safe-exceptions , sandwich >=0.1.0.3- , sandwich-webdriver , string-interpolate , temporary , text , time , transformers- , unix , unordered-containers , vector , webdriver@@ -247,4 +253,7 @@ linux-src build-depends: regex-compat+ if !os(windows)+ build-depends:+ unix default-language: Haskell2010
src/Test/Sandwich/WebDriver.hs view
@@ -78,9 +78,8 @@ allocateWebDriver :: (HasBaseContext context, BaseMonad m) => WdOptions -> ExampleT context m WebDriver allocateWebDriver wdOptions = do debug "Beginning allocateWebDriver"- maybeRunRoot <- getRunRoot- let runRoot = fromMaybe "/tmp" maybeRunRoot- startWebDriver wdOptions runRoot+ dir <- fromMaybe "/tmp" <$> getCurrentFolder+ startWebDriver wdOptions dir -- | Allocate a WebDriver using the given options and putting logs under the given path. allocateWebDriver' :: FilePath -> WdOptions -> IO WebDriver@@ -141,8 +140,8 @@ addCommandLineOptionsToWdOptions (CommandLineOptions {optWebdriverOptions=(CommandLineWebdriverOptions {..})}) wdOptions@(WdOptions {..}) = wdOptions { capabilities = case optFirefox of Nothing -> capabilities- Just UseFirefox -> firefoxCapabilities- Just UseChrome -> chromeCapabilities+ Just UseFirefox -> firefoxCapabilities firefoxBinaryPath+ Just UseChrome -> chromeCapabilities chromeBinaryPath , runMode = case optDisplay of Nothing -> runMode Just Headless -> RunHeadless defaultHeadlessConfig
src/Test/Sandwich/WebDriver/Config.hs view
@@ -5,7 +5,9 @@ , defaultWdOptions , runMode , seleniumToUse+ , chromeBinaryPath , chromeDriverToUse+ , firefoxBinaryPath , geckoDriverToUse , capabilities , httpManager
src/Test/Sandwich/WebDriver/Internal/Binaries.hs view
@@ -68,8 +68,8 @@ let downloadPath = getChromeDriverDownloadUrl chromeDriverVersion detectPlatform ExceptT $ downloadAndUnzipToPath downloadPath path return path-obtainChromeDriver toolsDir DownloadChromeDriverAutodetect = runExceptT $ do- version <- ExceptT $ liftIO getChromeDriverVersion+obtainChromeDriver toolsDir (DownloadChromeDriverAutodetect maybeChromePath) = runExceptT $ do+ version <- ExceptT $ liftIO $ getChromeDriverVersion maybeChromePath ExceptT $ obtainChromeDriver toolsDir (DownloadChromeDriverVersion version) obtainChromeDriver _ (UseChromeDriverAt path) = (liftIO $ doesFileExist path) >>= \case@@ -93,8 +93,8 @@ let downloadPath = getGeckoDriverDownloadUrl geckoDriverVersion detectPlatform ExceptT $ downloadAndUntarballToPath downloadPath path return path-obtainGeckoDriver toolsDir DownloadGeckoDriverAutodetect = runExceptT $ do- version <- ExceptT $ liftIO getGeckoDriverVersion+obtainGeckoDriver toolsDir (DownloadGeckoDriverAutodetect maybeFirefoxPath) = runExceptT $ do+ version <- ExceptT $ liftIO $ getGeckoDriverVersion maybeFirefoxPath ExceptT $ obtainGeckoDriver toolsDir (DownloadGeckoDriverVersion version) obtainGeckoDriver _ (UseGeckoDriverAt path) = (liftIO $ doesFileExist path) >>= \case@@ -126,9 +126,9 @@ return chromeDriverPath -downloadChromeDriverIfNecessary :: Constraints m => FilePath -> m (Either T.Text FilePath)-downloadChromeDriverIfNecessary toolsDir = runExceptT $ do- chromeDriverVersion <- ExceptT $ liftIO getChromeDriverVersion+downloadChromeDriverIfNecessary :: Constraints m => Maybe FilePath -> FilePath -> m (Either T.Text FilePath)+downloadChromeDriverIfNecessary maybeChromePath toolsDir = runExceptT $ do+ chromeDriverVersion <- ExceptT $ liftIO $ getChromeDriverVersion maybeChromePath ExceptT $ downloadChromeDriverIfNecessary' toolsDir chromeDriverVersion getChromeDriverPath :: FilePath -> ChromeDriverVersion -> FilePath
src/Test/Sandwich/WebDriver/Internal/Binaries/Util.hs view
@@ -21,7 +21,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Except import qualified Data.Aeson as A-import qualified Data.HashMap.Strict as HM+import Data.Maybe import Data.String.Interpolate import qualified Data.Text as T import qualified Data.Text.Lazy as TL@@ -36,6 +36,13 @@ import Test.Sandwich.WebDriver.Internal.Types import Test.Sandwich.WebDriver.Internal.Util +#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as HM+#else+import qualified Data.HashMap.Strict as HM+#endif++ data Platform = Linux | OSX | Windows deriving (Show, Eq) detectPlatform :: Platform@@ -47,9 +54,10 @@ -- * Chrome -detectChromeVersion :: IO (Either T.Text ChromeVersion)-detectChromeVersion = leftOnException $ runExceptT $ do- (exitCode, stdout, stderr) <- liftIO $ readCreateProcessWithExitCode (shell "google-chrome --version | grep -Eo \"[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\"") ""+detectChromeVersion :: Maybe FilePath -> IO (Either T.Text ChromeVersion)+detectChromeVersion maybeChromePath = leftOnException $ runExceptT $ do+ let chromeToUse = fromMaybe "google-chrome" maybeChromePath+ (exitCode, stdout, stderr) <- liftIO $ readCreateProcessWithExitCode (shell (chromeToUse <> " --version | grep -Eo \"[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\"")) "" rawString <- case exitCode of ExitFailure _ -> throwE [i|Couldn't parse google-chrome version. Stdout: '#{stdout}'. Stderr: '#{stderr}'|]@@ -59,9 +67,9 @@ [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 :: IO (Either T.Text ChromeDriverVersion)-getChromeDriverVersion = runExceptT $ do- chromeVersion <- ExceptT $ liftIO detectChromeVersion+getChromeDriverVersion :: Maybe FilePath -> IO (Either T.Text ChromeDriverVersion)+getChromeDriverVersion maybeChromePath = runExceptT $ do+ chromeVersion <- ExceptT $ liftIO $ detectChromeVersion maybeChromePath ExceptT $ getChromeDriverVersion' chromeVersion getChromeDriverVersion' :: ChromeVersion -> IO (Either T.Text ChromeDriverVersion)@@ -84,9 +92,10 @@ -- * Firefox -detectFirefoxVersion :: IO (Either T.Text FirefoxVersion)-detectFirefoxVersion = leftOnException $ runExceptT $ do- (exitCode, stdout, stderr) <- liftIO $ readCreateProcessWithExitCode (shell "firefox --version | grep -Eo \"[0-9]+\\.[0-9]+(\\.[0-9]+)?\"") ""+detectFirefoxVersion :: Maybe FilePath -> IO (Either T.Text FirefoxVersion)+detectFirefoxVersion maybeFirefoxPath = leftOnException $ runExceptT $ do+ let firefoxToUse = fromMaybe "firefox" maybeFirefoxPath+ (exitCode, stdout, stderr) <- liftIO $ readCreateProcessWithExitCode (shell (firefoxToUse <> " --version | grep -Eo \"[0-9]+\\.[0-9]+(\\.[0-9]+)?\"")) "" rawString <- case exitCode of ExitFailure _ -> throwE [i|Couldn't parse firefox version. Stdout: '#{stdout}'. Stderr: '#{stderr}'|]@@ -98,9 +107,9 @@ _ -> throwE [i|Failed to parse firefox version from string: '#{rawString}'|] -getGeckoDriverVersion :: IO (Either T.Text GeckoDriverVersion)-getGeckoDriverVersion = runExceptT $ do- -- firefoxVersion <- ExceptT $ liftIO detectFirefoxVersion+getGeckoDriverVersion :: Maybe FilePath -> IO (Either T.Text GeckoDriverVersion)+getGeckoDriverVersion _maybeFirefoxPath = runExceptT $ do+ -- firefoxVersion <- ExceptT $ liftIO $ detectFirefoxVersion maybeFirefoxPath -- Just get the latest release on GitHub let url = [i|https://api.github.com/repos/mozilla/geckodriver/releases/latest|]
src/Test/Sandwich/WebDriver/Internal/Capabilities.hs view
@@ -9,13 +9,15 @@ -- * Firefox , firefoxCapabilities , headlessFirefoxCapabilities+ , getDefaultFirefoxProfile ) where +import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.Aeson as A import Data.Default-import qualified Data.HashMap.Strict as HM-import qualified Data.Text as T+import Data.Function ((&)) import Test.WebDriver+import qualified Test.WebDriver.Firefox.Profile as FF loggingPrefs :: A.Value loggingPrefs = A.object [("browser", "ALL")@@ -29,51 +31,51 @@ -- | Default capabilities for regular Chrome. -- Has the "browser" log level to "ALL" so that tests can collect browser logs.-chromeCapabilities :: Capabilities-chromeCapabilities =- def {browser=Chrome Nothing Nothing args [] chromePrefs+chromeCapabilities :: Maybe FilePath -> Capabilities+chromeCapabilities maybeChromePath =+ def {browser=Chrome Nothing maybeChromePath args [] mempty , additionalCaps=[("loggingPrefs", loggingPrefs) , ("goog:loggingPrefs", loggingPrefs)] } where args = ["--verbose"] -- | Default capabilities for headless Chrome.-headlessChromeCapabilities :: Capabilities-headlessChromeCapabilities =- def {browser=Chrome Nothing Nothing args [] chromePrefs+headlessChromeCapabilities :: Maybe FilePath -> Capabilities+headlessChromeCapabilities maybeChromePath =+ def {browser=Chrome Nothing maybeChromePath args [] mempty , additionalCaps=[("loggingPrefs", loggingPrefs) , ("goog:loggingPrefs", loggingPrefs)] } where args = ["--verbose", "--headless"] -chromePrefs :: HM.HashMap T.Text A.Value-chromePrefs = HM.fromList [- ("prefs", A.object [("profile.default_content_setting_values.automatic_downloads", A.Number 1)- , ("profile.content_settings.exceptions.automatic_downloads.*.setting", A.Number 1)- , ("download.prompt_for_download", A.Bool False)- , ("download.directory_upgrade", A.Bool True)- , ("download.default_directory", "/tmp")])- ]- -- * 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+ -- | Default capabilities for regular Firefox.-firefoxCapabilities :: Capabilities-firefoxCapabilities = def { browser=ff }+firefoxCapabilities :: Maybe FilePath -> Capabilities+firefoxCapabilities maybeFirefoxPath = def { browser=ff } where ff = Firefox { ffProfile = Nothing , ffLogPref = LogAll- , ffBinary = Nothing+ , ffBinary = maybeFirefoxPath , ffAcceptInsecureCerts = Nothing } -- | Default capabilities for headless Firefox.-headlessFirefoxCapabilities :: Capabilities-headlessFirefoxCapabilities = def { browser=ff, additionalCaps=additionalCaps }+headlessFirefoxCapabilities :: Maybe FilePath -> Capabilities+headlessFirefoxCapabilities maybeFirefoxPath = def { browser=ff, additionalCaps=additionalCaps } where ff = Firefox { ffProfile = Nothing , ffLogPref = LogAll- , ffBinary = Nothing+ , ffBinary = maybeFirefoxPath , ffAcceptInsecureCerts = Nothing }
src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs view
@@ -17,6 +17,7 @@ import Control.Concurrent+import Control.Exception import Control.Monad import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class@@ -26,7 +27,6 @@ import qualified Data.Aeson as A import Data.Default import Data.Function-import qualified Data.HashMap.Strict as HM import qualified Data.List as L import Data.Maybe import Data.String.Interpolate@@ -43,24 +43,42 @@ import Test.Sandwich import Test.Sandwich.WebDriver.Internal.Binaries import Test.Sandwich.WebDriver.Internal.Ports-import Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb import Test.Sandwich.WebDriver.Internal.Types import Test.Sandwich.WebDriver.Internal.Util import qualified Test.WebDriver as W+import qualified Test.WebDriver.Firefox.Profile as FF +#ifndef mingw32_HOST_OS+import Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb+#endif +#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, MonadIO m, MonadBaseControl IO m, MonadMask m) -- | Spin up a Selenium WebDriver and create a WebDriver startWebDriver :: Constraints m => WdOptions -> FilePath -> m WebDriver startWebDriver wdOptions@(WdOptions {..}) 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)+ webdriverName <- ("webdriver_" <>) <$> liftIO makeUUID -- Directory to log everything for this webdriver let webdriverRoot = runRoot </> (T.unpack webdriverName) liftIO $ createDirectoryIfMissing True webdriverRoot + let downloadDir = webdriverRoot </> "Downloads"+ liftIO $ createDirectoryIfMissing True downloadDir+ -- Get selenium and chromedriver debug [i|Preparing to create the Selenium process|] liftIO $ createDirectoryIfMissing True toolsRoot@@ -86,9 +104,11 @@ debug [i|driverArgs: #{driverArgs}|] (maybeXvfbSession, javaEnv) <- case runMode of+#ifndef mingw32_HOST_OS RunInXvfb (XvfbConfig {..}) -> do (s, e) <- makeXvfbSession xvfbResolution xvfbStartFluxbox webdriverRoot return (Just s, Just e)+#endif _ -> return (Nothing, Nothing) -- Retry up to 10 times@@ -103,9 +123,9 @@ webdriverProcessName <- ("webdriver_process_" <>) <$> (liftIO makeUUID) let webdriverProcessRoot = webdriverRoot </> T.unpack webdriverProcessName liftIO $ createDirectoryIfMissing True webdriverProcessRoot- startWebDriver' wdOptions webdriverName webdriverProcessRoot seleniumPath driverArgs maybeXvfbSession javaEnv+ startWebDriver' wdOptions webdriverName webdriverProcessRoot downloadDir seleniumPath driverArgs maybeXvfbSession javaEnv -startWebDriver' wdOptions@(WdOptions {capabilities=capabilities', ..}) webdriverName webdriverRoot seleniumPath driverArgs maybeXvfbSession javaEnv = do+startWebDriver' wdOptions@(WdOptions {capabilities=capabilities', ..}) webdriverName webdriverRoot downloadDir seleniumPath driverArgs maybeXvfbSession javaEnv = do port <- liftIO findFreePortOrException let wdCreateProcess = (proc "java" (driverArgs <> ["-jar", seleniumPath , "-port", show port])) { env = javaEnv }@@ -141,29 +161,35 @@ interruptProcessGroupOf p >> waitForProcess p error [i|Selenium server failed to start after 60 seconds|] + capabilities <- configureDownloadCapabilities downloadDir (configureHeadlessCapabilities runMode capabilities')+ -- Make the WebDriver WebDriver <$> pure (T.unpack webdriverName) <*> pure (hout, herr, p, seleniumOutPath, seleniumErrPath, maybeXvfbSession) <*> pure wdOptions <*> liftIO (newMVar mempty) <*> pure (def { W.wdPort = fromIntegral port- , W.wdCapabilities = configureCapabilities capabilities' runMode+ , W.wdCapabilities = capabilities , W.wdHTTPManager = httpManager , W.wdHTTPRetryCount = httpRetryCount })+ <*> pure downloadDir +-- | TODO: expose this as an option+gracePeriod :: Int+gracePeriod = 30000000 stopWebDriver :: Constraints m => WebDriver -> m () stopWebDriver (WebDriver {wdWebDriver=(hout, herr, h, _, _, maybeXvfbSession)}) = do- _ <- liftIO (interruptProcessGroupOf h >> waitForProcess h)+ gracefullyStopProcess h gracePeriod liftIO $ hClose hout liftIO $ hClose herr whenJust maybeXvfbSession $ \(XvfbSession {..}) -> do- whenJust xvfbFluxboxProcess $ \p ->- liftIO (interruptProcessGroupOf p >> waitForProcess p)+ whenJust xvfbFluxboxProcess $ \p -> do+ gracefullyStopProcess p gracePeriod - liftIO (interruptProcessGroupOf xvfbProcess >> waitForProcess xvfbProcess)+ gracefullyStopProcess xvfbProcess gracePeriod -- * Util @@ -172,29 +198,66 @@ seleniumErrFileName = "stderr.txt" -- | Add headless configuration to the Chrome browser-configureCapabilities caps@(W.Capabilities {W.browser=browser@(W.Chrome {..})}) (RunHeadless (HeadlessConfig {..})) = caps { W.browser = browser' }+configureHeadlessCapabilities (RunHeadless (HeadlessConfig {..})) caps@(W.Capabilities {W.browser=browser@(W.Chrome {..})}) = caps { W.browser = browser' } where browser' = browser { W.chromeOptions = "--headless":resolution:chromeOptions } resolution = [i|--window-size=#{w},#{h}|] (w, h) = fromMaybe (1920, 1080) headlessResolution -- | Add headless configuration to the Firefox capabilities-configureCapabilities caps@(W.Capabilities {W.browser=(W.Firefox {..}), W.additionalCaps=ac}) (RunHeadless (HeadlessConfig {..})) = caps { W.additionalCaps = additionalCaps }+configureHeadlessCapabilities (RunHeadless (HeadlessConfig {..})) caps@(W.Capabilities {W.browser=(W.Firefox {..}), W.additionalCaps=ac}) = caps { W.additionalCaps = additionalCaps } 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+ 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 key -> Just _)) = val- ensureKeyExists key defaultVal (A.Object m@(HM.lookup key -> Nothing)) = A.Object (HM.insert key defaultVal m)+ 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 -configureCapabilities browser (RunHeadless {}) = error [i|Headless mode not yet supported for browser '#{browser}'|]-configureCapabilities browser _ = browser+configureHeadlessCapabilities (RunHeadless {}) browser = error [i|Headless mode not yet supported for browser '#{browser}'|]+configureHeadlessCapabilities _ browser = browser+++configureDownloadCapabilities downloadDir caps@(W.Capabilities {W.browser=browser@(W.Firefox {..})}) = do+ case ffProfile of+ Nothing -> return ()+ Just _ -> liftIO $ throwIO $ userError [i|Can't support Firefox profile yet.|]++ profile <- 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' }+ 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++ prefs :: A.Object+ prefs = basePrefs+ & foldl (.) id [HM.insert k v | (k, v) <- downloadPrefs]++ options = HM.insert "prefs" (A.Object prefs) chromeExperimentalOptions++ downloadPrefs = [("profile.default_content_setting_values.automatic_downloads", A.Number 1)+ , ("profile.content_settings.exceptions.automatic_downloads.*.setting", A.Number 1)+ , ("download.prompt_for_download", A.Bool False)+ , ("download.directory_upgrade", A.Bool True)+ , ("download.default_directory", A.String (T.pack downloadDir))]+configureDownloadCapabilities _ browser = return browser
− src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs
@@ -1,134 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE OverloadedStrings #-}--module Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb (- makeXvfbSession- ) where--import Control.Exception-import Control.Monad.Catch (MonadMask)-import Control.Monad.IO.Class-import Control.Monad.Logger-import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Retry-import qualified Data.List as L-import Data.Maybe-import Data.String.Interpolate-import GHC.Stack-import Safe-import System.Directory-import System.Environment-import System.IO.Temp-import System.Process-import Test.Sandwich-import Test.Sandwich.WebDriver.Internal.Types---#ifdef linux_HOST_OS-import System.Posix.IO as Posix-import System.Posix.Types-#endif--#ifdef darwin_HOST_OS-import GHC.IO.FD-import qualified GHC.IO.Handle.FD as HFD-newtype Fd = Fd FD-handleToFd h = Fd <$> HFD.handleToFd h-#endif--type Constraints m = (HasCallStack, MonadLogger m, MonadIO m, MonadBaseControl IO m, MonadMask m)---makeXvfbSession :: Constraints m => Maybe (Int, Int) -> Bool -> FilePath -> m (XvfbSession, [(String, String)])-makeXvfbSession xvfbResolution xvfbStartFluxbox webdriverRoot = do- let (w, h) = fromMaybe (1920, 1080) xvfbResolution- liftIO $ createDirectoryIfMissing True webdriverRoot-- let policy = constantDelay 10000 <> limitRetries 1000- (serverNum :: Int, p, authFile, displayNum) <- recoverAll policy $ \_ -> do- withTempFile webdriverRoot "x11_server_num" $ \path tmpHandle -> do- fd <- liftIO $ handleToFd tmpHandle- (serverNum, p, authFile) <- createXvfbSession webdriverRoot w h fd-- debug [i|Trying to determine display number for auth file '#{authFile}', using '#{path}'|]-- displayNum <-- recoverAll policy $ \_ ->- (liftIO $ readFile path) >>= \contents -> case readMay contents of -- hGetContents readHandle- Nothing -> liftIO $ throwIO $ userError [i|Couldn't determine X11 screen to use. Got data: '#{contents}'. Path was '#{path}'|]- Just (x :: Int) -> return x-- return (serverNum, p, authFile, displayNum)-- fluxboxProcess <- if xvfbStartFluxbox then Just <$> (startFluxBoxOnDisplay webdriverRoot displayNum) else return Nothing-- let xvfbSession = XvfbSession {- xvfbDisplayNum = displayNum- , xvfbXauthority = authFile- , xvfbDimensions = (w, h)- , xvfbProcess = p- , xvfbFluxboxProcess = fluxboxProcess- }-- -- TODO: allow verbose logging to be controlled with an option:- env' <- liftIO getEnvironment- let env = L.nubBy (\x y -> fst x == fst y) $ [("DISPLAY", ":" <> show serverNum)- , ("XAUTHORITY", xvfbXauthority xvfbSession)] <> env'- return (xvfbSession, env)---createXvfbSession :: Constraints m => FilePath -> Int -> Int -> Fd -> m (Int, ProcessHandle, FilePath)-createXvfbSession webdriverRoot w h (Fd fd) = do- serverNum <- liftIO findFreeServerNum-- -- Start the Xvfb session- authFile <- liftIO $ writeTempFile webdriverRoot ".Xauthority" ""- p <- createProcessWithLogging $ (proc "Xvfb" [":" <> show serverNum- , "-screen", "0", [i|#{w}x#{h}x24|]- , "-displayfd", [i|#{fd}|]- , "-auth", authFile- ]) { cwd = Just webdriverRoot- , create_group = True }-- return (serverNum, p, authFile)---findFreeServerNum :: IO Int-findFreeServerNum = findFreeServerNum' 99- where- findFreeServerNum' :: Int -> IO Int- findFreeServerNum' candidate = do- doesPathExist [i|/tmp/.X11-unix/X#{candidate}|] >>= \case- True -> findFreeServerNum' (candidate + 1)- False -> return candidate---startFluxBoxOnDisplay :: Constraints m => FilePath -> Int -> m ProcessHandle-startFluxBoxOnDisplay webdriverRoot x = do- logPath <- liftIO $ writeTempFile webdriverRoot "fluxbox.log" ""-- debug [i|Starting fluxbox on logPath '#{logPath}'|]-- let args = ["-display", ":" <> show x- , "-log", logPath]-- (_, _, _, p) <- liftIO $ createProcess $ (proc "fluxbox" args) {- cwd = Just webdriverRoot- , create_group = True- , std_out = CreatePipe- , std_err = CreatePipe- }-- -- TODO: confirm fluxbox started successfully-- return p
src/Test/Sandwich/WebDriver/Internal/Types.hs view
@@ -68,9 +68,13 @@ , 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. @@ -92,6 +96,7 @@ -- ^ Download selenium from a default location to the 'toolsRoot' | UseSeleniumAt FilePath -- ^ Use the JAR file at the given path+ deriving Show -- | How to obtain the chromedriver binary. data ChromeDriverToUse =@@ -99,10 +104,12 @@ -- ^ Download chromedriver from the given URL to the 'toolsRoot' | DownloadChromeDriverVersion ChromeDriverVersion -- ^ Download the given chromedriver version to the 'toolsRoot'- | DownloadChromeDriverAutodetect+ | DownloadChromeDriverAutodetect (Maybe 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 -- ^ Use the chromedriver at the given path+ deriving Show -- | How to obtain the geckodriver binary. data GeckoDriverToUse =@@ -110,10 +117,12 @@ -- ^ Download geckodriver from the given URL to the 'toolsRoot' | DownloadGeckoDriverVersion GeckoDriverVersion -- ^ Download the given geckodriver version to the 'toolsRoot'- | DownloadGeckoDriverAutodetect+ | DownloadGeckoDriverAutodetect (Maybe FilePath) -- ^ Autodetect geckodriver to use based on the Gecko version and download it to the 'toolsRoot'+ -- Pass the path to the Firefox binary, or else it will be found by looking for firefox on the PATH. | UseGeckoDriverAt FilePath -- ^ Use the geckodriver at the given path+ deriving Show newtype ChromeVersion = ChromeVersion (Int, Int, Int, Int) deriving Show newtype ChromeDriverVersion = ChromeDriverVersion (Int, Int, Int, Int) deriving Show@@ -148,8 +157,10 @@ , capabilities = def , saveSeleniumMessageHistory = OnException , seleniumToUse = DownloadSeleniumDefault- , chromeDriverToUse = DownloadChromeDriverAutodetect- , geckoDriverToUse = DownloadGeckoDriverAutodetect+ , chromeBinaryPath = Nothing+ , chromeDriverToUse = DownloadChromeDriverAutodetect Nothing+ , firefoxBinaryPath = Nothing+ , geckoDriverToUse = DownloadGeckoDriverAutodetect Nothing , runMode = Normal , httpManager = Nothing , httpRetryCount = 0@@ -161,6 +172,7 @@ , wdOptions :: WdOptions , wdSessionMap :: MVar (M.Map Session W.WDSession) , wdConfig :: W.WDConfig+ , wdDownloadDir :: FilePath } data InvalidLogsException = InvalidLogsException [W.LogEntry]
src/Test/Sandwich/WebDriver/Internal/Util.hs view
@@ -1,4 +1,9 @@-{-# LANGUAGE CPP, QuasiQuotes, ScopedTypeVariables, NamedFieldPuns, FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NumericUnderscores #-} module Test.Sandwich.WebDriver.Internal.Util where @@ -6,13 +11,22 @@ import qualified Control.Exception.Lifted as E import Control.Monad import Control.Monad.IO.Class+import Control.Monad.Logger import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Retry+import Data.Maybe import Data.String.Interpolate import qualified Data.Text as T import System.Directory import System.Process import qualified System.Random as R+import Test.Sandwich.Logging +#ifdef mingw32_HOST_OS+import System.IO+#endif++ -- * Truncating log files moveAndTruncate :: FilePath -> String -> IO ()@@ -58,3 +72,31 @@ makeUUID :: IO T.Text makeUUID = (T.pack . take 10 . R.randomRs ('a','z')) <$> R.newStdGen++-- * Stopping processes++gracefullyStopProcess :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m ()+gracefullyStopProcess p gracePeriodUs = do+ liftIO $ interruptProcessGroupOf p+ gracefullyWaitForProcess p gracePeriodUs++gracefullyWaitForProcess :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m ()+gracefullyWaitForProcess p gracePeriodUs = do+ let waitForExit = do+ let policy = limitRetriesByCumulativeDelay gracePeriodUs $ capDelay 200_000 $ exponentialBackoff 1_000+ retrying policy (\_ x -> return $ isNothing x) $ \_ -> do+ liftIO $ getProcessExitCode p++ waitForExit >>= \case+ Just _ -> return ()+ Nothing -> do+ pid <- liftIO $ getPid p+ warn [i|(#{pid}) Process didn't stop after #{gracePeriodUs}us; trying to interrupt|]++ liftIO $ interruptProcessGroupOf p+ waitForExit >>= \case+ Just _ -> return ()+ Nothing -> void $ do+ warn [i|(#{pid}) Process didn't stop after a further #{gracePeriodUs}us; going to kill|]+ liftIO $ terminateProcess p+ liftIO $ waitForProcess p
src/Test/Sandwich/WebDriver/Types.hs view
@@ -14,6 +14,8 @@ , webdriver + , wdDownloadDir+ -- * Constraint synonyms , BaseMonad , BaseMonadContext
+ unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb (+ makeXvfbSession+ ) where++import Control.Exception+import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Retry+import qualified Data.List as L+import Data.Maybe+import Data.String.Interpolate+import GHC.Stack+import Safe+import System.Directory+import System.Environment+import System.IO.Temp+import System.Process+import Test.Sandwich+import Test.Sandwich.WebDriver.Internal.Types+++#ifdef linux_HOST_OS+import System.Posix.IO as Posix+import System.Posix.Types+#endif++#ifdef darwin_HOST_OS+import GHC.IO.FD+import qualified GHC.IO.Handle.FD as HFD+newtype Fd = Fd FD+handleToFd h = Fd <$> HFD.handleToFd h+#endif++type Constraints m = (HasCallStack, MonadLogger m, MonadIO m, MonadBaseControl IO m, MonadMask m)+++makeXvfbSession :: Constraints m => Maybe (Int, Int) -> Bool -> FilePath -> m (XvfbSession, [(String, String)])+makeXvfbSession xvfbResolution xvfbStartFluxbox webdriverRoot = do+ let (w, h) = fromMaybe (1920, 1080) xvfbResolution+ liftIO $ createDirectoryIfMissing True webdriverRoot++ let policy = constantDelay 10000 <> limitRetries 1000+ (serverNum :: Int, p, authFile, displayNum) <- recoverAll policy $ \_ -> do+ withTempFile webdriverRoot "x11_server_num" $ \path tmpHandle -> do+ fd <- liftIO $ handleToFd tmpHandle+ (serverNum, p, authFile) <- createXvfbSession webdriverRoot w h fd++ debug [i|Trying to determine display number for auth file '#{authFile}', using '#{path}'|]++ displayNum <-+ recoverAll policy $ \_ ->+ (liftIO $ readFile path) >>= \contents -> case readMay contents of -- hGetContents readHandle+ Nothing -> liftIO $ throwIO $ userError [i|Couldn't determine X11 screen to use. Got data: '#{contents}'. Path was '#{path}'|]+ Just (x :: Int) -> return x++ return (serverNum, p, authFile, displayNum)++ fluxboxProcess <- if xvfbStartFluxbox then Just <$> (startFluxBoxOnDisplay webdriverRoot displayNum) else return Nothing++ let xvfbSession = XvfbSession {+ xvfbDisplayNum = displayNum+ , xvfbXauthority = authFile+ , xvfbDimensions = (w, h)+ , xvfbProcess = p+ , xvfbFluxboxProcess = fluxboxProcess+ }++ -- TODO: allow verbose logging to be controlled with an option:+ env' <- liftIO getEnvironment+ let env = L.nubBy (\x y -> fst x == fst y) $ [("DISPLAY", ":" <> show serverNum)+ , ("XAUTHORITY", xvfbXauthority xvfbSession)] <> env'+ return (xvfbSession, env)+++createXvfbSession :: Constraints m => FilePath -> Int -> Int -> Fd -> m (Int, ProcessHandle, FilePath)+createXvfbSession webdriverRoot w h (Fd fd) = do+ serverNum <- liftIO findFreeServerNum++ -- Start the Xvfb session+ authFile <- liftIO $ writeTempFile webdriverRoot ".Xauthority" ""+ p <- createProcessWithLogging $ (proc "Xvfb" [":" <> show serverNum+ , "-screen", "0", [i|#{w}x#{h}x24|]+ , "-displayfd", [i|#{fd}|]+ , "-auth", authFile+ ]) { cwd = Just webdriverRoot+ , create_group = True }++ return (serverNum, p, authFile)+++findFreeServerNum :: IO Int+findFreeServerNum = findFreeServerNum' 99+ where+ findFreeServerNum' :: Int -> IO Int+ findFreeServerNum' candidate = do+ doesPathExist [i|/tmp/.X11-unix/X#{candidate}|] >>= \case+ True -> findFreeServerNum' (candidate + 1)+ False -> return candidate+++startFluxBoxOnDisplay :: Constraints m => FilePath -> Int -> m ProcessHandle+startFluxBoxOnDisplay webdriverRoot x = do+ logPath <- liftIO $ writeTempFile webdriverRoot "fluxbox.log" ""++ debug [i|Starting fluxbox on logPath '#{logPath}'|]++ let args = ["-display", ":" <> show x+ , "-log", logPath]++ (_, _, _, p) <- liftIO $ createProcess $ (proc "fluxbox" args) {+ cwd = Just webdriverRoot+ , create_group = True+ , std_out = CreatePipe+ , std_err = CreatePipe+ }++ -- TODO: confirm fluxbox started successfully++ return p