{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ViewPatterns #-}
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)
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
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
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
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}|]
]
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)
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|]
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 }
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
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
}
let readyMessage :: Text
readyMessage = Text
"Selenium Server is up and running"
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
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
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
seleniumOutFileName, seleniumErrFileName :: FilePath
seleniumOutFileName :: FilePath
seleniumOutFileName = FilePath
"stdout.txt"
seleniumErrFileName :: FilePath
seleniumErrFileName = FilePath
"stderr.txt"
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
_))
| 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
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