diff --git a/sandwich-contexts/package.yaml b/sandwich-contexts/package.yaml index 8f4eec9..1ad018f 100644 --- a/sandwich-contexts/package.yaml +++ b/sandwich-contexts/package.yaml @@ -39,9 +39,9 @@ library: - Test.Sandwich.Contexts.Nix - Test.Sandwich.Contexts.PostgreSQL - Test.Sandwich.Contexts.Waits - - Test.Sandwich.Contexts.Types.Network - Test.Sandwich.Contexts.Types.S3 + - Test.Sandwich.Contexts.Util.Ports dependencies: - aeson - conduit diff --git a/sandwich-contexts/sandwich-contexts.cabal b/sandwich-contexts/sandwich-contexts.cabal index 85dacf5..57dec9d 100644 --- a/sandwich-contexts/sandwich-contexts.cabal +++ b/sandwich-contexts/sandwich-contexts.cabal @@ -23,12 +23,12 @@ library Test.Sandwich.Contexts.Waits Test.Sandwich.Contexts.Types.Network Test.Sandwich.Contexts.Types.S3 + Test.Sandwich.Contexts.Util.Ports other-modules: Test.Sandwich.Contexts.FakeSmtpServer.Derivation Test.Sandwich.Contexts.ReverseProxy.TCP Test.Sandwich.Contexts.Util.Aeson Test.Sandwich.Contexts.Util.Nix - Test.Sandwich.Contexts.Util.Ports Test.Sandwich.Contexts.Util.SocketUtil Test.Sandwich.Contexts.Util.UUID Paths_sandwich_contexts diff --git a/sandwich-webdriver/package.yaml b/sandwich-webdriver/package.yaml index 5c45b4c..29790bc 100644 --- a/sandwich-webdriver/package.yaml +++ b/sandwich-webdriver/package.yaml @@ -25,6 +25,8 @@ dependencies: - http-client - http-client-tls - http-conduit +- lens +- lens-regex-pcre - microlens - microlens-aeson - monad-control @@ -36,6 +38,7 @@ dependencies: - retry - safe - sandwich >= 0.1.0.3 +- sandwich-contexts - string-interpolate - text - time diff --git a/sandwich-webdriver/sandwich-webdriver.cabal b/sandwich-webdriver/sandwich-webdriver.cabal index 4061dcb..d658185 100644 --- a/sandwich-webdriver/sandwich-webdriver.cabal +++ b/sandwich-webdriver/sandwich-webdriver.cabal @@ -35,7 +35,7 @@ library Test.Sandwich.WebDriver.Internal.Binaries.DetectFirefox Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform Test.Sandwich.WebDriver.Internal.Capabilities - Test.Sandwich.WebDriver.Internal.Ports + Test.Sandwich.WebDriver.Internal.Capabilities.Extra Test.Sandwich.WebDriver.Internal.Screenshots Test.Sandwich.WebDriver.Internal.StartWebDriver Test.Sandwich.WebDriver.Internal.Types @@ -74,6 +74,8 @@ library , http-client , http-client-tls , http-conduit + , lens + , lens-regex-pcre , microlens , microlens-aeson , monad-control @@ -85,6 +87,7 @@ library , retry , safe , sandwich >=0.1.0.3 + , sandwich-contexts , string-interpolate , text , time @@ -152,6 +155,8 @@ executable sandwich-webdriver-exe , http-client , http-client-tls , http-conduit + , lens + , lens-regex-pcre , microlens , microlens-aeson , monad-control @@ -163,6 +168,7 @@ executable sandwich-webdriver-exe , retry , safe , sandwich >=0.1.0.3 + , sandwich-contexts , sandwich-webdriver , string-interpolate , text @@ -230,6 +236,8 @@ test-suite sandwich-webdriver-test , http-client , http-client-tls , http-conduit + , lens + , lens-regex-pcre , microlens , microlens-aeson , monad-control @@ -241,6 +249,7 @@ test-suite sandwich-webdriver-test , retry , safe , sandwich >=0.1.0.3 + , sandwich-contexts , sandwich-webdriver , string-interpolate , text diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs index 1740ba3..353039b 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver.hs @@ -6,6 +6,7 @@ module Test.Sandwich.WebDriver ( -- * Introducing a WebDriver server introduceWebDriver + , introduceWebDriverViaNix , introduceWebDriverOptions , addCommandLineOptionsToWdOptions @@ -43,6 +44,8 @@ import qualified Data.Map as M import Data.Maybe import Data.String.Interpolate import Test.Sandwich +import Test.Sandwich.Contexts.Files +import Test.Sandwich.Contexts.Nix import Test.Sandwich.Internal import Test.Sandwich.WebDriver.Class import Test.Sandwich.WebDriver.Config @@ -60,10 +63,18 @@ import UnliftIO.MVar introduceWebDriver :: ( BaseMonadContext m context ) => WdOptions -> SpecFree (LabelValue "webdriver" WebDriver :> context) m () -> SpecFree context m () -introduceWebDriver wdOptions = introduce "Introduce WebDriver session" webdriver (allocateWebDriver wdOptions) cleanupWebDriver +introduceWebDriver wdOptions = undefined -- introduce "Introduce WebDriver session" webdriver (allocateWebDriver wdOptions) cleanupWebDriver + +introduceWebDriverViaNix :: ( + BaseMonadContext m context, HasNixContext context, HasFile context "java" + ) => WdOptions -> SpecFree (LabelValue "webdriver" WebDriver :> context) m () -> SpecFree context m () +introduceWebDriverViaNix wdOptions = + introduce "Introduce WebDriver session" webdriver (allocateWebDriver wdOptions) cleanupWebDriver -- | Same as introduceWebDriver, but merges command line options into the 'WdOptions'. -introduceWebDriverOptions :: forall a context m. (BaseMonadContext m context, HasCommandLineOptions context a) +introduceWebDriverOptions :: forall a context m. ( + BaseMonadContext m context, HasCommandLineOptions context a, HasFile context "java" + ) => WdOptions -> SpecFree (LabelValue "webdriver" WebDriver :> context) m () -> SpecFree context m () introduceWebDriverOptions wdOptions = introduce "Introduce WebDriver session" webdriver alloc cleanupWebDriver where alloc = do @@ -71,7 +82,7 @@ introduceWebDriverOptions wdOptions = introduce "Introduce WebDriver session" we allocateWebDriver (addCommandLineOptionsToWdOptions @a clo wdOptions) -- | Allocate a WebDriver using the given options. -allocateWebDriver :: (HasBaseContext context, BaseMonad m) => WdOptions -> ExampleT context m WebDriver +allocateWebDriver :: (BaseMonad m, HasBaseContext context, HasFile context "java") => WdOptions -> ExampleT context m WebDriver allocateWebDriver wdOptions = do debug "Beginning allocateWebDriver" dir <- fromMaybe "/tmp" <$> getCurrentFolder @@ -80,7 +91,7 @@ allocateWebDriver wdOptions = do -- | Allocate a WebDriver using the given options and putting logs under the given path. allocateWebDriver' :: FilePath -> WdOptions -> IO WebDriver allocateWebDriver' runRoot wdOptions = do - runNoLoggingT $ startWebDriver wdOptions runRoot + runNoLoggingT $ flip runReaderT (undefined :: LabelValue "file-java" (EnvironmentFile "java")) $ startWebDriver wdOptions runRoot -- | Clean up the given WebDriver. cleanupWebDriver :: (BaseMonad m) => WebDriver -> ExampleT context m () diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Capabilities.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Capabilities.hs index d95b9ea..ed24cea 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Capabilities.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Capabilities.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedLists #-} --- | module Test.Sandwich.WebDriver.Internal.Capabilities ( -- * Chrome diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Capabilities/Extra.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Capabilities/Extra.hs new file mode 100644 index 0000000..4d7f12b --- /dev/null +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Capabilities/Extra.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE OverloadedLists #-} + +module Test.Sandwich.WebDriver.Internal.Capabilities.Extra ( + configureHeadlessCapabilities + , configureDownloadCapabilities + ) where + +import Control.Monad.Catch (MonadMask) +import Control.Monad.IO.Class +import Control.Monad.IO.Unlift +import Control.Monad.Logger +import Control.Monad.Trans.Control (MonadBaseControl) +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 Test.Sandwich +import Test.Sandwich.WebDriver.Internal.Binaries.DetectChrome (detectChromeVersion) +import Test.Sandwich.WebDriver.Internal.Types +import qualified Test.WebDriver as W +import qualified Test.WebDriver.Firefox.Profile as FF +import UnliftIO.Exception + + +#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, MonadBaseControl IO 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 + headlessArg <- liftIO (detectChromeVersion (chromeBinaryPath wdOptions)) >>= \case + Left err -> do + warn [i|Couldn't determine chrome version when configuring headless capabilities (err: #{err}); passing --headless|] + return "--headless" + Right (ChromeVersion (major, _, _, _)) + -- See https://www.selenium.dev/blog/2023/headless-is-going-away/ + | major >= 110 -> return "--headless=new" + | otherwise -> return "--headless" + + let browser' = browser { W.chromeOptions = headlessArg:resolution:chromeOptions } + + return (caps { W.browser = browser' }) + + where + resolution = [i|--window-size=#{w},#{h}|] + (w, h) = fromMaybe (1920, 1080) headlessResolution + +-- | 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 }) + 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 + +configureHeadlessCapabilities _ (RunHeadless {}) browser = error [i|Headless mode not yet supported for browser '#{browser}'|] +configureHeadlessCapabilities _ _ 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, MonadBaseControl IO m + ) => [Char] -> W.Capabilities -> m W.Capabilities +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 diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Ports.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Ports.hs deleted file mode 100644 index ebdfc6d..0000000 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Ports.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE RankNTypes, MultiWayIf, ScopedTypeVariables, LambdaCase #-} - -module Test.Sandwich.WebDriver.Internal.Ports ( - findFreePortOrException - ) where - -import Control.Exception -import Control.Retry -import Data.Maybe -import Data.String.Interpolate -import qualified Data.Text as T -import Network.Socket -import System.Random (randomRIO) -import Test.Sandwich.WebDriver.Internal.Util - -firstUserPort :: PortNumber -firstUserPort = 1024 - -highestPort :: PortNumber -highestPort = 65535 - --- |Find an unused port in a given range -findFreePortInRange' :: RetryPolicy -> IO PortNumber -> IO (Maybe PortNumber) -findFreePortInRange' policy getAcceptableCandidate = retrying policy (\_retryStatus result -> return $ isNothing result) (const findFreePortInRange'') - where - findFreePortInRange'' :: IO (Maybe PortNumber) - findFreePortInRange'' = do - candidate <- getAcceptableCandidate - catch (tryOpenAndClosePort candidate >> return (Just candidate)) (\(_ :: SomeException) -> return Nothing) - where - tryOpenAndClosePort :: PortNumber -> IO PortNumber - tryOpenAndClosePort port = do - sock <- socket AF_INET Stream 0 - setSocketOption sock ReuseAddr 1 - let hostAddress = tupleToHostAddress (127, 0, 0, 1) - bind sock (SockAddrInet port hostAddress) - close sock - return $ fromIntegral port - -findFreePortInRange :: IO PortNumber -> IO (Maybe PortNumber) -findFreePortInRange = findFreePortInRange' (limitRetries 50) - --- | Find an unused port in the ephemeral port range. --- See https://en.wikipedia.org/wiki/List_of_TCP_and_UDP_port_numbers --- This works without a timeout since there should always be a port in the somewhere; --- it might be advisable to wrap in a timeout anyway. -findFreePort :: IO (Maybe PortNumber) -findFreePort = findFreePortInRange getNonEphemeralCandidate - -findFreePortOrException :: IO PortNumber -findFreePortOrException = findFreePort >>= \case - Just port -> return port - Nothing -> error "Couldn't find free port" - --- * Util - -getNonEphemeralCandidate :: IO PortNumber -getNonEphemeralCandidate = do - (ephemeralStart, ephemeralEnd) <- getEphemeralPortRange >>= \case - Left _ -> return (49152, 65535) - Right range -> return range - - let numBelow = ephemeralStart - firstUserPort - let numAbove = highestPort - ephemeralEnd - - u :: Double <- randomRIO (0, 1) - - let useLowerRange = u < ((fromIntegral numBelow) / (fromIntegral numBelow + fromIntegral numAbove)) - - if | useLowerRange -> fromInteger <$> randomRIO (fromIntegral firstUserPort, fromIntegral ephemeralStart) - | otherwise -> fromInteger <$> randomRIO (fromIntegral ephemeralEnd, fromIntegral highestPort) - -getEphemeralPortRange :: IO (Either T.Text (PortNumber, PortNumber)) -getEphemeralPortRange = leftOnException' $ do - contents <- readFile "/proc/sys/net/ipv4/ip_local_port_range" - case fmap read (words contents) of - [p1, p2] -> return (p1, p2) - _ -> error [i|Unexpected contents: '#{contents}'|] diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs index 6c81edf..6bee21a 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -13,56 +14,40 @@ import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Logger +import Control.Monad.Reader import Control.Monad.Trans.Control (MonadBaseControl) import Control.Retry -import qualified Data.Aeson as A import Data.Default 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.Text.IO as T -import qualified Data.Vector as V import GHC.Stack -import Lens.Micro -import Lens.Micro.Aeson import System.Directory import System.FilePath -import System.IO -import System.Process +import System.IO (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.Binaries -import Test.Sandwich.WebDriver.Internal.Binaries.DetectChrome (detectChromeVersion) -import Test.Sandwich.WebDriver.Internal.Ports +import Test.Sandwich.WebDriver.Internal.Capabilities.Extra import Test.Sandwich.WebDriver.Internal.Types import Test.Sandwich.WebDriver.Internal.Util import qualified Test.WebDriver as W -import qualified Test.WebDriver.Firefox.Profile as FF -import UnliftIO.Exception +import UnliftIO.Process #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, MonadUnliftIO 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 +startWebDriver :: ( + Constraints m, MonadReader context m, HasFile context "java" + ) => WdOptions -> FilePath -> m WebDriver +startWebDriver wdOptions@(WdOptions {capabilities=capabilities', ..}) runRoot = do -- Create a unique name for this webdriver so the folder for its log output doesn't conflict with any others webdriverName <- ("webdriver_" <>) <$> liftIO makeUUID @@ -70,6 +55,7 @@ startWebDriver wdOptions@(WdOptions {..}) runRoot = do let webdriverRoot = runRoot (T.unpack webdriverName) liftIO $ createDirectoryIfMissing True webdriverRoot + -- Directory to hold any downloads let downloadDir = webdriverRoot "Downloads" liftIO $ createDirectoryIfMissing True downloadDir @@ -78,7 +64,7 @@ startWebDriver wdOptions@(WdOptions {..}) runRoot = do seleniumPath <- obtainSelenium toolsRoot seleniumToUse >>= \case Left err -> error [i|Failed to obtain selenium: '#{err}'|] Right p -> return p - driverArgs <- case W.browser capabilities of + driverArgs <- case W.browser capabilities' of W.Firefox {} -> do obtainGeckoDriver toolsRoot geckoDriverToUse >>= \case Left err -> error [i|Failed to obtain geckodriver: '#{err}'|] @@ -94,8 +80,6 @@ startWebDriver wdOptions@(WdOptions {..}) runRoot = do , [i|-Dwebdriver.chrome.verboseLogging=true|]] x -> error [i|Browser #{x} is not supported yet|] - debug [i|driverArgs: #{driverArgs}|] - (maybeXvfbSession, javaEnv) <- case runMode of #ifndef mingw32_HOST_OS RunInXvfb (XvfbConfig {..}) -> do @@ -104,65 +88,62 @@ startWebDriver wdOptions@(WdOptions {..}) runRoot = do #endif _ -> return (Nothing, Nothing) + -- Create a distinct process name + webdriverProcessName <- ("webdriver_process_" <>) <$> (liftIO makeUUID) + let webdriverProcessRoot = webdriverRoot T.unpack webdriverProcessName + liftIO $ createDirectoryIfMissing True webdriverProcessRoot + + java <- askFile @"java" + -- seleniumJar <- askFile @"selenium.jar" + -- Retry up to 10 times -- This is necessary because sometimes we get a race for the port we get from findFreePortOrException. -- There doesn't seem to be any way to make Selenium choose its own port. let policy = constantDelay 0 <> limitRetries 10 - recoverAll policy $ \retryStatus -> do + (port, hRead, p) <- recoverAll policy $ \retryStatus -> do when (rsIterNumber retryStatus > 0) $ warn [i|Trying again to start selenium server|] - -- Create a distinct process name - webdriverProcessName <- ("webdriver_process_" <>) <$> (liftIO makeUUID) - let webdriverProcessRoot = webdriverRoot T.unpack webdriverProcessName - liftIO $ createDirectoryIfMissing True webdriverProcessRoot - startWebDriver' wdOptions webdriverName webdriverProcessRoot downloadDir seleniumPath driverArgs maybeXvfbSession javaEnv + (hRead, hWrite) <- createPipe + port <- findFreePortOrException -startWebDriver' :: ( - MonadLogger m, MonadUnliftIO m, MonadBaseControl IO m, MonadMask m - ) => WdOptions -> T.Text -> [Char] -> [Char] -> [Char] -> [String] -> Maybe XvfbSession -> Maybe [(String, String)] -> m WebDriver -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 } + 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 + } - -- Open output handles - let seleniumOutPath = webdriverRoot seleniumOutFileName - hout <- liftIO $ openFile seleniumOutPath AppendMode - let seleniumErrPath = webdriverRoot seleniumErrFileName - herr <- liftIO $ openFile seleniumErrPath AppendMode + -- Start the process and wait for it to be ready + debug [i|#{java} #{T.unwords $ fmap T.pack allArgs}|] - -- Start the process and wait for it to be ready - debug [i|Starting the Selenium process|] - (_, _, _, p) <- liftIO $ createProcess $ wdCreateProcess { - std_in = Inherit - , std_out = UseHandle hout - , std_err = UseHandle herr - , create_group = True - } - -- Normally Selenium prints the ready message to stderr. However, when we're running under - -- XVFB the two streams get combined and sent to stdout; see - -- https://bugs.launchpad.net/ubuntu/+source/xorg-server/+bug/1059947 - -- As a result, we poll both files - let readyMessage = "Selenium Server is up and running" - -- Retry every 60ms, for up to 60s before admitting defeat - let policy = constantDelay 60000 <> limitRetries 1000 - success <- retrying policy (\_retryStatus result -> return (not result)) $ const $ - liftIO (T.readFile seleniumErrPath) >>= \case - t | readyMessage `T.isInfixOf` t -> return True - _ -> liftIO (T.readFile seleniumOutPath) >>= \case - t | readyMessage `T.isInfixOf` t -> return True - _ -> return False - unless success $ liftIO $ do - _ <- interruptProcessGroupOf p >> waitForProcess p - error [i|Selenium server failed to start after 60 seconds|] + (_, _, _, p) <- liftIO $ createProcess cp - capabilities <- configureHeadlessCapabilities wdOptions runMode capabilities' - >>= configureDownloadCapabilities downloadDir + -- Read from the (combined) output stream until we see the up and running message, + -- or the process ends and we get an exception from hGetLine + fix $ \loop -> do + line <- fmap T.pack $ liftIO $ hGetLine hRead + debug line + + if | "Selenium Server is up and running" `T.isInfixOf` line -> return () + | otherwise -> loop + + return (port, hRead, p) + + -- TODO: save this in the WebDriver to tear it down later? + logAsync <- forever $ liftIO (hGetLine hRead) >>= (debug . T.pack) + + -- Final extra capabilities configuration + capabilities <- + configureHeadlessCapabilities wdOptions runMode capabilities' + >>= configureDownloadCapabilities downloadDir -- Make the WebDriver WebDriver <$> pure (T.unpack webdriverName) - <*> pure (hout, herr, p, seleniumOutPath, seleniumErrPath, maybeXvfbSession) + <*> pure (p, maybeXvfbSession) <*> pure wdOptions <*> liftIO (newMVar mempty) <*> pure (def { W.wdPort = fromIntegral port @@ -172,106 +153,17 @@ startWebDriver' wdOptions@(WdOptions {capabilities=capabilities', ..}) webdriver }) <*> 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 +stopWebDriver (WebDriver {wdWebDriver=(h, maybeXvfbSession)}) = do + -- | TODO: expose this as an option + let gracePeriod :: Int + gracePeriod = 30000000 + gracefullyStopProcess h gracePeriod - liftIO $ hClose hout - liftIO $ hClose herr whenJust maybeXvfbSession $ \(XvfbSession {..}) -> do whenJust xvfbFluxboxProcess $ \p -> do gracefullyStopProcess p gracePeriod gracefullyStopProcess xvfbProcess gracePeriod - --- * Util - -seleniumOutFileName, seleniumErrFileName :: FilePath -seleniumOutFileName = "stdout.txt" -seleniumErrFileName = "stderr.txt" - --- | 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 - headlessArg <- liftIO (detectChromeVersion (chromeBinaryPath wdOptions)) >>= \case - Left err -> do - warn [i|Couldn't determine chrome version when configuring headless capabilities (err: #{err}); passing --headless|] - return "--headless" - Right (ChromeVersion (major, _, _, _)) - -- See https://www.selenium.dev/blog/2023/headless-is-going-away/ - | major >= 110 -> return "--headless=new" - | otherwise -> return "--headless" - - let browser' = browser { W.chromeOptions = headlessArg:resolution:chromeOptions } - - return (caps { W.browser = browser' }) - - where - resolution = [i|--window-size=#{w},#{h}|] - (w, h) = fromMaybe (1920, 1080) headlessResolution - --- | 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 }) - 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 - -configureHeadlessCapabilities _ (RunHeadless {}) browser = error [i|Headless mode not yet supported for browser '#{browser}'|] -configureHeadlessCapabilities _ _ browser = return browser - - -configureDownloadCapabilities :: ( - MonadIO m, MonadBaseControl IO m - ) => [Char] -> W.Capabilities -> m W.Capabilities -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 diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Types.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Types.hs index 194410c..de45821 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Types.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Types.hs @@ -14,7 +14,6 @@ import qualified Data.Map as M import Data.String.Interpolate import Data.Text as T import Network.HTTP.Client (Manager) -import System.IO import System.Process import Test.Sandwich import qualified Test.WebDriver as W @@ -173,7 +172,7 @@ defaultWdOptions toolsRoot = WdOptions { data WebDriver = WebDriver { wdName :: String - , wdWebDriver :: (Handle, Handle, ProcessHandle, FilePath, FilePath, Maybe XvfbSession) + , wdWebDriver :: (ProcessHandle, Maybe XvfbSession) , wdOptions :: WdOptions , wdSessionMap :: MVar (M.Map Session W.WDSession) , wdConfig :: W.WDConfig @@ -202,12 +201,12 @@ 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 (WebDriver {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 (WebDriver {wdWebDriver=(_, Just sess)}) = Just sess getXvfbSession _ = Nothing -- | Get the name of the 'WebDriver'. diff --git a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Windows.hs b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Windows.hs index e1b9798..1c8e440 100644 --- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Windows.hs +++ b/sandwich-webdriver/src/Test/Sandwich/WebDriver/Windows.hs @@ -65,7 +65,7 @@ setWindowFullScreen = do -- | Get the screen resolution as (x, y, width, height). (The x and y coordinates may be nonzero in multi-monitor setups.) getScreenResolution :: (MonadIO m) => WebDriver -> m (Int, Int, Int, Int) -getScreenResolution (WebDriver {wdWebDriver=(_, _, _, _, _, maybeXvfbSession)}) = case maybeXvfbSession of +getScreenResolution (WebDriver {wdWebDriver=(_, maybeXvfbSession)}) = case maybeXvfbSession of Nothing -> liftIO getResolution Just (XvfbSession {..}) -> liftIO $ getResolutionForDisplay xvfbDisplayNum