Working on better dependency injection

2024-07-14 23:20:39 +03:00 · 2024-03-29 18:47:32 -07:00 · 2024-03-29 18:47:32 -07:00 · 1828e15538
commit 1828e15538
parent 7ec3e785da
11 changed files with 223 additions and 259 deletions
--- 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
--- 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
--- 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
--- 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
--- 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 ()
--- 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
--- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Capabilities/Extra.hs
+++ 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
--- a/sandwich-webdriver/src/Test/Sandwich/WebDriver/Internal/Ports.hs
+++ b/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}'|]
--- 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
--- 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'.
--- 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