Working on better dependency injection

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

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

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

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

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 ()

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Capabilities.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE OverloadedLists #-}
--- |
 
 module Test.Sandwich.WebDriver.Internal.Capabilities (
   -- * Chrome

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

sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Ports.hs

@@ -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}'|]

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.IO (hGetLine)
-import System.Process
 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.Capabilities.Extra
-import Test.Sandwich.WebDriver.Internal.Ports
 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.Process
-import UnliftIO.Exception
 
 #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 :: (
-startWebDriver wdOptions@(WdOptions {..}) runRoot = do
+  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
+    (hRead, hWrite) <- createPipe
-    webdriverProcessName <- ("webdriver_process_" <>) <$> (liftIO makeUUID)
+    port <- findFreePortOrException
-    let webdriverProcessRoot = webdriverRoot </> T.unpack webdriverProcessName
-    liftIO $ createDirectoryIfMissing True webdriverProcessRoot
-    startWebDriver' wdOptions webdriverName webdriverProcessRoot downloadDir seleniumPath driverArgs maybeXvfbSession javaEnv
 
-startWebDriver' :: (
+    let allArgs = driverArgs <> ["-jar", seleniumPath
-  MonadLogger m, MonadUnliftIO m, MonadBaseControl IO m, MonadMask m
+                                , "-port", show port]
-  ) => WdOptions -> T.Text -> [Char] -> [Char] -> [Char] -> [String] -> Maybe XvfbSession -> Maybe [(String, String)] -> m WebDriver
+    let cp = (proc java allArgs) {
-startWebDriver' wdOptions@(WdOptions {capabilities=capabilities', ..}) webdriverName webdriverRoot downloadDir seleniumPath driverArgs maybeXvfbSession javaEnv = do
+               env = javaEnv
-  port <- liftIO findFreePortOrException
+               , std_in = Inherit
-  let wdCreateProcess = (proc "java" (driverArgs <> ["-jar", seleniumPath
+               , std_out = UseHandle hWrite
-                                                    , "-port", show port])) { env = javaEnv }
+               , std_err = UseHandle hWrite
+               , create_group = True
+             }
 
-  -- Open output handles
+    -- Start the process and wait for it to be ready
-  let seleniumOutPath = webdriverRoot </> seleniumOutFileName
+    debug [i|#{java} #{T.unwords $ fmap T.pack allArgs}|]
-  hout <- liftIO $ openFile seleniumOutPath AppendMode
-  let seleniumErrPath = webdriverRoot </> seleniumErrFileName
-  herr <- liftIO $ openFile seleniumErrPath AppendMode
 
-  -- Start the process and wait for it to be ready
+    (_, _, _, p) <- liftIO $ createProcess cp
-  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|]
 
-  capabilities <- configureHeadlessCapabilities wdOptions runMode capabilities'
+    -- Read from the (combined) output stream until we see the up and running message,
-                  >>= configureDownloadCapabilities downloadDir
+    -- 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

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'.

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