{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedLists #-}

module Test.Sandwich.WebDriver.Internal.StartWebDriver where

import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Catch (MonadMask)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Retry
import qualified Data.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 Test.Sandwich
import Test.Sandwich.WebDriver.Internal.Binaries
import Test.Sandwich.WebDriver.Internal.Binaries.Util (detectChromeVersion)
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

#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 :: Text -> Key
fromText = Text -> Key
A.fromText
#else
import qualified Data.HashMap.Strict        as HM
fromText :: T.Text -> T.Text
fromText = id
#endif


type Constraints m = (HasCallStack, MonadLogger m, MonadIO m, MonadBaseControl IO m, MonadMask m)

-- | Spin up a Selenium WebDriver and create a WebDriver
startWebDriver :: Constraints m => WdOptions -> FilePath -> m WebDriver
startWebDriver :: forall (m :: * -> *).
Constraints m =>
WdOptions -> FilePath -> m WebDriver
startWebDriver wdOptions :: WdOptions
wdOptions@(WdOptions {Int
FilePath
Maybe FilePath
Maybe Manager
Capabilities
GeckoDriverToUse
ChromeDriverToUse
SeleniumToUse
RunMode
WhenToSave
httpRetryCount :: WdOptions -> Int
httpManager :: WdOptions -> Maybe Manager
runMode :: WdOptions -> RunMode
geckoDriverToUse :: WdOptions -> GeckoDriverToUse
firefoxBinaryPath :: WdOptions -> Maybe FilePath
chromeDriverToUse :: WdOptions -> ChromeDriverToUse
chromeBinaryPath :: WdOptions -> Maybe FilePath
seleniumToUse :: WdOptions -> SeleniumToUse
saveSeleniumMessageHistory :: WdOptions -> WhenToSave
capabilities :: WdOptions -> Capabilities
toolsRoot :: WdOptions -> FilePath
httpRetryCount :: Int
httpManager :: Maybe Manager
runMode :: RunMode
geckoDriverToUse :: GeckoDriverToUse
firefoxBinaryPath :: Maybe FilePath
chromeDriverToUse :: ChromeDriverToUse
chromeBinaryPath :: Maybe FilePath
seleniumToUse :: SeleniumToUse
saveSeleniumMessageHistory :: WhenToSave
capabilities :: Capabilities
toolsRoot :: FilePath
..}) FilePath
runRoot = do
  -- Create a unique name for this webdriver so the folder for its log output doesn't conflict with any others
  Text
webdriverName <- (Text
"webdriver_" forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Text
makeUUID

  -- Directory to log everything for this webdriver
  let webdriverRoot :: FilePath
webdriverRoot = FilePath
runRoot FilePath -> FilePath -> FilePath
</> (Text -> FilePath
T.unpack Text
webdriverName)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
webdriverRoot

  let downloadDir :: FilePath
downloadDir = FilePath
webdriverRoot FilePath -> FilePath -> FilePath
</> FilePath
"Downloads"
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
downloadDir

  -- Get selenium and chromedriver
  forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|Preparing to create the Selenium process|]
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
toolsRoot
  FilePath
seleniumPath <- forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
FilePath -> SeleniumToUse -> m (Either Text FilePath)
obtainSelenium FilePath
toolsRoot SeleniumToUse
seleniumToUse forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left Text
err -> forall a. HasCallStack => FilePath -> a
error [i|Failed to obtain selenium: '#{err}'|]
    Right FilePath
p -> forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
p
  [FilePath]
driverArgs <- case Capabilities -> Browser
W.browser Capabilities
capabilities of
    W.Firefox {} -> do
      forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadBaseControl IO m) =>
FilePath -> GeckoDriverToUse -> m (Either Text FilePath)
obtainGeckoDriver FilePath
toolsRoot GeckoDriverToUse
geckoDriverToUse forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left Text
err -> forall a. HasCallStack => FilePath -> a
error [i|Failed to obtain geckodriver: '#{err}'|]
        Right FilePath
p -> forall (m :: * -> *) a. Monad m => a -> m a
return [[i|-Dwebdriver.gecko.driver=#{p}|]
                          -- , [i|-Dwebdriver.gecko.logfile=#{webdriverRoot </> "geckodriver.log"}|]
                          -- , [i|-Dwebdriver.gecko.verboseLogging=true|]
                          ]
    W.Chrome {} -> do
      forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadMask m) =>
FilePath -> ChromeDriverToUse -> m (Either Text FilePath)
obtainChromeDriver FilePath
toolsRoot ChromeDriverToUse
chromeDriverToUse forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left Text
err -> forall a. HasCallStack => FilePath -> a
error [i|Failed to obtain chromedriver: '#{err}'|]
        Right FilePath
p -> forall (m :: * -> *) a. Monad m => a -> m a
return [[i|-Dwebdriver.chrome.driver=#{p}|]
                          , [i|-Dwebdriver.chrome.logfile=#{webdriverRoot </> "chromedriver.log"}|]
                          , [i|-Dwebdriver.chrome.verboseLogging=true|]]
    Browser
x -> forall a. HasCallStack => FilePath -> a
error [i|Browser #{x} is not supported yet|]

  forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|driverArgs: #{driverArgs}|]

  (Maybe XvfbSession
maybeXvfbSession, Maybe [(FilePath, FilePath)]
javaEnv) <- case RunMode
runMode of
#ifndef mingw32_HOST_OS
    RunInXvfb (XvfbConfig {Bool
Maybe (Int, Int)
xvfbStartFluxbox :: XvfbConfig -> Bool
xvfbResolution :: XvfbConfig -> Maybe (Int, Int)
xvfbStartFluxbox :: Bool
xvfbResolution :: Maybe (Int, Int)
..}) -> do
      (XvfbSession
s, [(FilePath, FilePath)]
e) <- forall (m :: * -> *).
Constraints m =>
Maybe (Int, Int)
-> Bool -> FilePath -> m (XvfbSession, [(FilePath, FilePath)])
makeXvfbSession Maybe (Int, Int)
xvfbResolution Bool
xvfbStartFluxbox FilePath
webdriverRoot
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just XvfbSession
s, forall a. a -> Maybe a
Just [(FilePath, FilePath)]
e)
#endif
    RunMode
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)

  -- 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 :: RetryPolicyM m
policy = forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
constantDelay Int
0 forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicy
limitRetries Int
10
  forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m -> (RetryStatus -> m a) -> m a
recoverAll RetryPolicyM m
policy forall a b. (a -> b) -> a -> b
$ \RetryStatus
retryStatus -> do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RetryStatus -> Int
rsIterNumber RetryStatus
retryStatus forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
warn [i|Trying again to start selenium server|]

    -- Create a distinct process name
    Text
webdriverProcessName <- (Text
"webdriver_process_" forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Text
makeUUID)
    let webdriverProcessRoot :: FilePath
webdriverProcessRoot = FilePath
webdriverRoot FilePath -> FilePath -> FilePath
</> Text -> FilePath
T.unpack Text
webdriverProcessName
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
webdriverProcessRoot
    forall {m :: * -> *}.
(MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadMask m) =>
WdOptions
-> Text
-> FilePath
-> FilePath
-> FilePath
-> [FilePath]
-> Maybe XvfbSession
-> Maybe [(FilePath, FilePath)]
-> m WebDriver
startWebDriver' WdOptions
wdOptions Text
webdriverName FilePath
webdriverProcessRoot FilePath
downloadDir FilePath
seleniumPath [FilePath]
driverArgs Maybe XvfbSession
maybeXvfbSession Maybe [(FilePath, FilePath)]
javaEnv

startWebDriver' :: WdOptions
-> Text
-> FilePath
-> FilePath
-> FilePath
-> [FilePath]
-> Maybe XvfbSession
-> Maybe [(FilePath, FilePath)]
-> m WebDriver
startWebDriver' wdOptions :: WdOptions
wdOptions@(WdOptions {capabilities :: WdOptions -> Capabilities
capabilities=Capabilities
capabilities', Int
FilePath
Maybe FilePath
Maybe Manager
GeckoDriverToUse
ChromeDriverToUse
SeleniumToUse
RunMode
WhenToSave
httpRetryCount :: Int
httpManager :: Maybe Manager
runMode :: RunMode
geckoDriverToUse :: GeckoDriverToUse
firefoxBinaryPath :: Maybe FilePath
chromeDriverToUse :: ChromeDriverToUse
chromeBinaryPath :: Maybe FilePath
seleniumToUse :: SeleniumToUse
saveSeleniumMessageHistory :: WhenToSave
toolsRoot :: FilePath
httpRetryCount :: WdOptions -> Int
httpManager :: WdOptions -> Maybe Manager
runMode :: WdOptions -> RunMode
geckoDriverToUse :: WdOptions -> GeckoDriverToUse
firefoxBinaryPath :: WdOptions -> Maybe FilePath
chromeDriverToUse :: WdOptions -> ChromeDriverToUse
chromeBinaryPath :: WdOptions -> Maybe FilePath
seleniumToUse :: WdOptions -> SeleniumToUse
saveSeleniumMessageHistory :: WdOptions -> WhenToSave
toolsRoot :: WdOptions -> FilePath
..}) Text
webdriverName FilePath
webdriverRoot FilePath
downloadDir FilePath
seleniumPath [FilePath]
driverArgs Maybe XvfbSession
maybeXvfbSession Maybe [(FilePath, FilePath)]
javaEnv = do
  PortNumber
port <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO PortNumber
findFreePortOrException
  let wdCreateProcess :: CreateProcess
wdCreateProcess = (FilePath -> [FilePath] -> CreateProcess
proc FilePath
"java" ([FilePath]
driverArgs forall a. Semigroup a => a -> a -> a
<> [FilePath
"-jar", FilePath
seleniumPath
                                                    , FilePath
"-port", forall a. Show a => a -> FilePath
show PortNumber
port])) { env :: Maybe [(FilePath, FilePath)]
env = Maybe [(FilePath, FilePath)]
javaEnv }

  -- Open output handles
  let seleniumOutPath :: FilePath
seleniumOutPath = FilePath
webdriverRoot FilePath -> FilePath -> FilePath
</> FilePath
seleniumOutFileName
  Handle
hout <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IOMode -> IO Handle
openFile FilePath
seleniumOutPath IOMode
AppendMode
  let seleniumErrPath :: FilePath
seleniumErrPath = FilePath
webdriverRoot FilePath -> FilePath -> FilePath
</> FilePath
seleniumErrFileName
  Handle
herr <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IOMode -> IO Handle
openFile FilePath
seleniumErrPath IOMode
AppendMode

  -- Start the process and wait for it to be ready
  forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|Starting the Selenium process|]
  (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
p) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess forall a b. (a -> b) -> a -> b
$ CreateProcess
wdCreateProcess {
    std_in :: StdStream
std_in = StdStream
Inherit
    , std_out :: StdStream
std_out = Handle -> StdStream
UseHandle Handle
hout
    , std_err :: StdStream
std_err = Handle -> StdStream
UseHandle Handle
herr
    , create_group :: Bool
create_group = Bool
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 :: Text
readyMessage = Text
"Selenium Server is up and running"
  -- Retry every 60ms, for up to 60s before admitting defeat
  let policy :: RetryPolicyM m
policy = forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
constantDelay Int
60000 forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicy
limitRetries Int
1000
  Bool
success <- forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying RetryPolicyM m
policy (\RetryStatus
_retryStatus Bool
result -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
result)) forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Text
T.readFile FilePath
seleniumErrPath) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Text
t | Text
readyMessage Text -> Text -> Bool
`T.isInfixOf` Text
t -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      Text
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Text
T.readFile FilePath
seleniumOutPath) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Text
t | Text
readyMessage Text -> Text -> Bool
`T.isInfixOf` Text
t -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Text
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    ProcessHandle -> IO ()
interruptProcessGroupOf ProcessHandle
p forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p
    forall a. HasCallStack => FilePath -> a
error [i|Selenium server failed to start after 60 seconds|]

  Capabilities
capabilities <- forall (m :: * -> *).
Constraints m =>
WdOptions -> RunMode -> Capabilities -> m Capabilities
configureHeadlessCapabilities WdOptions
wdOptions RunMode
runMode Capabilities
capabilities'
                  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *}.
(MonadIO m, MonadBaseControl IO m) =>
FilePath -> Capabilities -> m Capabilities
configureDownloadCapabilities FilePath
downloadDir

  -- Make the WebDriver
  FilePath
-> (Handle, Handle, ProcessHandle, FilePath, FilePath,
    Maybe XvfbSession)
-> WdOptions
-> MVar (Map FilePath WDSession)
-> WDConfig
-> FilePath
-> WebDriver
WebDriver forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> FilePath
T.unpack Text
webdriverName)
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Handle
hout, Handle
herr, ProcessHandle
p, FilePath
seleniumOutPath, FilePath
seleniumErrPath, Maybe XvfbSession
maybeXvfbSession)
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure WdOptions
wdOptions
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. a -> IO (MVar a)
newMVar forall a. Monoid a => a
mempty)
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Default a => a
def { wdPort :: Int
W.wdPort = forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port
                          , wdCapabilities :: Capabilities
W.wdCapabilities = Capabilities
capabilities
                          , wdHTTPManager :: Maybe Manager
W.wdHTTPManager = Maybe Manager
httpManager
                          , wdHTTPRetryCount :: Int
W.wdHTTPRetryCount = Int
httpRetryCount
                          })
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
downloadDir

-- | TODO: expose this as an option
gracePeriod :: Int
gracePeriod :: Int
gracePeriod = Int
30000000

stopWebDriver :: Constraints m => WebDriver -> m ()
stopWebDriver :: forall (m :: * -> *). Constraints m => WebDriver -> m ()
stopWebDriver (WebDriver {wdWebDriver :: WebDriver
-> (Handle, Handle, ProcessHandle, FilePath, FilePath,
    Maybe XvfbSession)
wdWebDriver=(Handle
hout, Handle
herr, ProcessHandle
h, FilePath
_, FilePath
_, Maybe XvfbSession
maybeXvfbSession)}) = do
  forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
ProcessHandle -> Int -> m ()
gracefullyStopProcess ProcessHandle
h Int
gracePeriod
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
hout
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
herr

  forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe XvfbSession
maybeXvfbSession forall a b. (a -> b) -> a -> b
$ \(XvfbSession {Int
FilePath
Maybe ProcessHandle
(Int, Int)
ProcessHandle
xvfbFluxboxProcess :: XvfbSession -> Maybe ProcessHandle
xvfbProcess :: XvfbSession -> ProcessHandle
xvfbDimensions :: XvfbSession -> (Int, Int)
xvfbXauthority :: XvfbSession -> FilePath
xvfbDisplayNum :: XvfbSession -> Int
xvfbFluxboxProcess :: Maybe ProcessHandle
xvfbProcess :: ProcessHandle
xvfbDimensions :: (Int, Int)
xvfbXauthority :: FilePath
xvfbDisplayNum :: Int
..}) -> do
    forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe ProcessHandle
xvfbFluxboxProcess forall a b. (a -> b) -> a -> b
$ \ProcessHandle
p -> do
      forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
ProcessHandle -> Int -> m ()
gracefullyStopProcess ProcessHandle
p Int
gracePeriod

    forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
ProcessHandle -> Int -> m ()
gracefullyStopProcess ProcessHandle
xvfbProcess Int
gracePeriod

-- * Util

seleniumOutFileName, seleniumErrFileName :: FilePath
seleniumOutFileName :: FilePath
seleniumOutFileName = FilePath
"stdout.txt"
seleniumErrFileName :: FilePath
seleniumErrFileName = FilePath
"stderr.txt"

-- | Add headless configuration to the Chrome browser
configureHeadlessCapabilities :: Constraints m => WdOptions -> RunMode -> W.Capabilities -> m W.Capabilities
configureHeadlessCapabilities :: forall (m :: * -> *).
Constraints m =>
WdOptions -> RunMode -> Capabilities -> m Capabilities
configureHeadlessCapabilities WdOptions
wdOptions (RunHeadless (HeadlessConfig {Maybe (Int, Int)
headlessResolution :: HeadlessConfig -> Maybe (Int, Int)
headlessResolution :: Maybe (Int, Int)
..})) caps :: Capabilities
caps@(W.Capabilities {browser :: Capabilities -> Browser
W.browser=browser :: Browser
browser@(W.Chrome {[FilePath]
[ChromeExtension]
Maybe FilePath
Object
chromeDriverVersion :: Browser -> Maybe FilePath
chromeBinary :: Browser -> Maybe FilePath
chromeOptions :: Browser -> [FilePath]
chromeExtensions :: Browser -> [ChromeExtension]
chromeExperimentalOptions :: Browser -> Object
chromeExperimentalOptions :: Object
chromeExtensions :: [ChromeExtension]
chromeOptions :: [FilePath]
chromeBinary :: Maybe FilePath
chromeDriverVersion :: Maybe FilePath
..})}) = do
  FilePath
headlessArg <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe FilePath -> IO (Either Text ChromeVersion)
detectChromeVersion (WdOptions -> Maybe FilePath
chromeBinaryPath WdOptions
wdOptions)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left Text
err -> do
      forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
warn [i|Couldn't determine chrome version when configuring headless capabilities (err: #{err}); passing --headless|]
      forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"--headless"
    Right (ChromeVersion (Int
major, Int
_, Int
_, Int
_))
      -- See https://www.selenium.dev/blog/2023/headless-is-going-away/
      | Int
major forall a. Ord a => a -> a -> Bool
>= Int
110 -> forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"--headless=new"
      | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"--headless"

  let browser' :: Browser
browser' = Browser
browser { chromeOptions :: [FilePath]
W.chromeOptions = FilePath
headlessArgforall a. a -> [a] -> [a]
:FilePath
resolutionforall a. a -> [a] -> [a]
:[FilePath]
chromeOptions }

  forall (m :: * -> *) a. Monad m => a -> m a
return (Capabilities
caps { browser :: Browser
W.browser = Browser
browser' })

  where
    resolution :: FilePath
resolution = [i|--window-size=#{w},#{h}|]
    (Int
w, Int
h) = forall a. a -> Maybe a -> a
fromMaybe (Int
1920, Int
1080) Maybe (Int, Int)
headlessResolution

-- | Add headless configuration to the Firefox capabilities
configureHeadlessCapabilities WdOptions
_ (RunHeadless (HeadlessConfig {Maybe (Int, Int)
headlessResolution :: Maybe (Int, Int)
headlessResolution :: HeadlessConfig -> Maybe (Int, Int)
..})) caps :: Capabilities
caps@(W.Capabilities {browser :: Capabilities -> Browser
W.browser=(W.Firefox {Maybe Bool
Maybe FilePath
Maybe (PreparedProfile Firefox)
LogLevel
ffProfile :: Browser -> Maybe (PreparedProfile Firefox)
ffLogPref :: Browser -> LogLevel
ffBinary :: Browser -> Maybe FilePath
ffAcceptInsecureCerts :: Browser -> Maybe Bool
ffAcceptInsecureCerts :: Maybe Bool
ffBinary :: Maybe FilePath
ffLogPref :: LogLevel
ffProfile :: Maybe (PreparedProfile Firefox)
..}), additionalCaps :: Capabilities -> [Pair]
W.additionalCaps=[Pair]
ac}) = forall (m :: * -> *) a. Monad m => a -> m a
return (Capabilities
caps { additionalCaps :: [Pair]
W.additionalCaps = [Pair]
additionalCaps })
  where
    additionalCaps :: [Pair]
additionalCaps = case forall a. (a -> Bool) -> [a] -> Maybe Int
L.findIndex (\Pair
x -> forall a b. (a, b) -> a
fst Pair
x forall a. Eq a => a -> a -> Bool
== Key
"moz:firefoxOptions") [Pair]
ac of
      Maybe Int
Nothing -> (Key
"moz:firefoxOptions", [Pair] -> Value
A.object [(Key
"args", Array -> Value
A.Array [Value
"-headless"])]) forall a. a -> [a] -> [a]
: [Pair]
ac
      Just Int
i -> let ffOptions' :: Value
ffOptions' = forall a b. (a, b) -> b
snd ([Pair]
ac forall a. [a] -> Int -> a
!! Int
i)
                               forall a b. a -> (a -> b) -> b
& Text -> Value -> Value -> Value
ensureKeyExists Text
"args" (Array -> Value
A.Array [])
                               forall a b. a -> (a -> b) -> b
& ((forall t. AsValue t => Key -> Traversal' t Value
key Key
"args" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Traversal' t Array
_Array) forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Array -> Array
addHeadlessArg) in
        forall a. (a -> a -> Bool) -> [a] -> [a]
L.nubBy (\Pair
x Pair
y -> forall a b. (a, b) -> a
fst Pair
x forall a. Eq a => a -> a -> Bool
== forall a b. (a, b) -> a
fst Pair
y) ((Key
"moz:firefoxOptions", Value
ffOptions') forall a. a -> [a] -> [a]
: [Pair]
ac)

    ensureKeyExists :: T.Text -> A.Value -> A.Value -> A.Value
    ensureKeyExists :: Text -> Value -> Value -> Value
ensureKeyExists Text
key Value
_ val :: Value
val@(A.Object (forall v. Key -> KeyMap v -> Maybe v
HM.lookup (Text -> Key
fromText Text
key) -> Just Value
_)) = Value
val
    ensureKeyExists Text
key Value
defaultVal (A.Object m :: Object
m@(forall v. Key -> KeyMap v -> Maybe v
HM.lookup (Text -> Key
fromText Text
key) -> Maybe Value
Nothing)) = Object -> Value
A.Object (forall v. Key -> v -> KeyMap v -> KeyMap v
HM.insert (Text -> Key
fromText Text
key) Value
defaultVal Object
m)
    ensureKeyExists Text
_ Value
_ Value
_ = forall a. HasCallStack => FilePath -> a
error FilePath
"Expected Object in ensureKeyExists"

    addHeadlessArg :: V.Vector A.Value -> V.Vector A.Value
    addHeadlessArg :: Array -> Array
addHeadlessArg Array
xs | (Text -> Value
A.String Text
"-headless") forall a. Eq a => a -> Vector a -> Bool
`V.elem` Array
xs = Array
xs
    addHeadlessArg Array
xs = (Text -> Value
A.String Text
"-headless") forall a. a -> Vector a -> Vector a
`V.cons` Array
xs

configureHeadlessCapabilities WdOptions
_ (RunHeadless {}) Capabilities
browser = forall a. HasCallStack => FilePath -> a
error [i|Headless mode not yet supported for browser '#{browser}'|]
configureHeadlessCapabilities WdOptions
_ RunMode
_ Capabilities
browser = forall (m :: * -> *) a. Monad m => a -> m a
return Capabilities
browser


configureDownloadCapabilities :: FilePath -> Capabilities -> m Capabilities
configureDownloadCapabilities FilePath
downloadDir caps :: Capabilities
caps@(W.Capabilities {browser :: Capabilities -> Browser
W.browser=browser :: Browser
browser@(W.Firefox {Maybe Bool
Maybe FilePath
Maybe (PreparedProfile Firefox)
LogLevel
ffAcceptInsecureCerts :: Maybe Bool
ffBinary :: Maybe FilePath
ffLogPref :: LogLevel
ffProfile :: Maybe (PreparedProfile Firefox)
ffProfile :: Browser -> Maybe (PreparedProfile Firefox)
ffLogPref :: Browser -> LogLevel
ffBinary :: Browser -> Maybe FilePath
ffAcceptInsecureCerts :: Browser -> Maybe Bool
..})}) = do
  case Maybe (PreparedProfile Firefox)
ffProfile of
    Maybe (PreparedProfile Firefox)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just PreparedProfile Firefox
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ FilePath -> IOError
userError [i|Can't support Firefox profile yet.|]

  PreparedProfile Firefox
profile <- Profile Firefox
FF.defaultProfile
    forall a b. a -> (a -> b) -> b
& forall a b. ToPref a => Text -> a -> Profile b -> Profile b
FF.addPref Text
"browser.download.folderList" (Int
2 :: Int)
    forall a b. a -> (a -> b) -> b
& forall a b. ToPref a => Text -> a -> Profile b -> Profile b
FF.addPref Text
"browser.download.manager.showWhenStarting" Bool
False
    forall a b. a -> (a -> b) -> b
& forall a b. ToPref a => Text -> a -> Profile b -> Profile b
FF.addPref Text
"browser.download.dir" FilePath
downloadDir
    forall a b. a -> (a -> b) -> b
& forall a b. ToPref a => Text -> a -> Profile b -> Profile b
FF.addPref Text
"browser.helperApps.neverAsk.saveToDisk" (FilePath
"*" :: String)
    forall a b. a -> (a -> b) -> b
& forall (m :: * -> *).
MonadBaseControl IO m =>
Profile Firefox -> m (PreparedProfile Firefox)
FF.prepareProfile

  forall (m :: * -> *) a. Monad m => a -> m a
return (Capabilities
caps { browser :: Browser
W.browser = Browser
browser { ffProfile :: Maybe (PreparedProfile Firefox)
W.ffProfile = forall a. a -> Maybe a
Just PreparedProfile Firefox
profile } })
configureDownloadCapabilities FilePath
downloadDir caps :: Capabilities
caps@(W.Capabilities {browser :: Capabilities -> Browser
W.browser=browser :: Browser
browser@(W.Chrome {[FilePath]
[ChromeExtension]
Maybe FilePath
Object
chromeExperimentalOptions :: Object
chromeExtensions :: [ChromeExtension]
chromeOptions :: [FilePath]
chromeBinary :: Maybe FilePath
chromeDriverVersion :: Maybe FilePath
chromeDriverVersion :: Browser -> Maybe FilePath
chromeBinary :: Browser -> Maybe FilePath
chromeOptions :: Browser -> [FilePath]
chromeExtensions :: Browser -> [ChromeExtension]
chromeExperimentalOptions :: Browser -> Object
..})}) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Capabilities
caps { browser :: Browser
W.browser=Browser
browser' }
  where
    browser' :: Browser
browser' = Browser
browser { chromeExperimentalOptions :: Object
W.chromeExperimentalOptions = Object
options }

    basePrefs :: A.Object
    basePrefs :: Object
basePrefs = case forall v. Key -> KeyMap v -> Maybe v
HM.lookup Key
"prefs" Object
chromeExperimentalOptions of
      Just (A.Object Object
hm) -> Object
hm
      Just Value
x -> forall a. HasCallStack => FilePath -> a
error [i|Expected chrome prefs to be object, got '#{x}'.|]
      Maybe Value
Nothing -> forall a. Monoid a => a
mempty

    prefs :: A.Object
    prefs :: Object
prefs = Object
basePrefs
          forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id [forall v. Key -> v -> KeyMap v -> KeyMap v
HM.insert Key
k Value
v | (Key
k, Value
v) <- [Pair]
downloadPrefs]

    options :: Object
options = forall v. Key -> v -> KeyMap v -> KeyMap v
HM.insert Key
"prefs" (Object -> Value
A.Object Object
prefs) Object
chromeExperimentalOptions

    downloadPrefs :: [Pair]
downloadPrefs = [(Key
"profile.default_content_setting_values.automatic_downloads", Scientific -> Value
A.Number Scientific
1)
                    , (Key
"profile.content_settings.exceptions.automatic_downloads.*.setting", Scientific -> Value
A.Number Scientific
1)
                    , (Key
"download.prompt_for_download", Bool -> Value
A.Bool Bool
False)
                    , (Key
"download.directory_upgrade", Bool -> Value
A.Bool Bool
True)
                    , (Key
"download.default_directory", Text -> Value
A.String (FilePath -> Text
T.pack FilePath
downloadDir))]
configureDownloadCapabilities FilePath
_ Capabilities
browser = forall (m :: * -> *) a. Monad m => a -> m a
return Capabilities
browser