{-# 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.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.HashMap.Strict as HM
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.Ports
import Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb
import Test.Sandwich.WebDriver.Internal.Types
import Test.Sandwich.WebDriver.Internal.Util
import qualified Test.WebDriver as W
type Constraints m = (HasCallStack, MonadLogger m, MonadIO m, MonadBaseControl IO m, MonadMask m)
startWebDriver :: Constraints m => WdOptions -> FilePath -> m WebDriver
startWebDriver :: WdOptions -> FilePath -> m WebDriver
startWebDriver wdOptions :: WdOptions
wdOptions@(WdOptions {Int
FilePath
Maybe Manager
Capabilities
GeckoDriverToUse
ChromeDriverToUse
SeleniumToUse
RunMode
WhenToSave
httpRetryCount :: WdOptions -> Int
httpManager :: WdOptions -> Maybe Manager
runMode :: WdOptions -> RunMode
geckoDriverToUse :: WdOptions -> GeckoDriverToUse
chromeDriverToUse :: WdOptions -> ChromeDriverToUse
seleniumToUse :: WdOptions -> SeleniumToUse
saveSeleniumMessageHistory :: WdOptions -> WhenToSave
capabilities :: WdOptions -> Capabilities
toolsRoot :: WdOptions -> FilePath
httpRetryCount :: Int
httpManager :: Maybe Manager
runMode :: RunMode
geckoDriverToUse :: GeckoDriverToUse
chromeDriverToUse :: ChromeDriverToUse
seleniumToUse :: SeleniumToUse
saveSeleniumMessageHistory :: WhenToSave
capabilities :: Capabilities
toolsRoot :: FilePath
..}) FilePath
runRoot = do
Text
webdriverName <- (Text
"webdriver_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> m Text -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO Text -> m Text
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)
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
webdriverRoot
Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|Preparing to create the Selenium process|]
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
toolsRoot
FilePath
seleniumPath <- FilePath -> SeleniumToUse -> m (Either Text FilePath)
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
FilePath -> SeleniumToUse -> m (Either Text FilePath)
obtainSelenium FilePath
toolsRoot SeleniumToUse
seleniumToUse m (Either Text FilePath)
-> (Either Text FilePath -> m FilePath) -> m FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left Text
err -> FilePath -> m FilePath
forall a. HasCallStack => FilePath -> a
error [i|Failed to obtain selenium: '#{err}'|]
Right FilePath
p -> FilePath -> m FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
p
[FilePath]
driverArgs <- case Capabilities -> Browser
W.browser Capabilities
capabilities of
W.Firefox {} -> do
FilePath -> GeckoDriverToUse -> m (Either Text FilePath)
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadBaseControl IO m) =>
FilePath -> GeckoDriverToUse -> m (Either Text FilePath)
obtainGeckoDriver FilePath
toolsRoot GeckoDriverToUse
geckoDriverToUse m (Either Text FilePath)
-> (Either Text FilePath -> m [FilePath]) -> m [FilePath]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left Text
err -> FilePath -> m [FilePath]
forall a. HasCallStack => FilePath -> a
error [i|Failed to obtain geckodriver: '#{err}'|]
Right FilePath
p -> [FilePath] -> m [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [[i|-Dwebdriver.gecko.driver=#{p}|]
]
W.Chrome {} -> do
FilePath -> ChromeDriverToUse -> m (Either Text FilePath)
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadBaseControl IO m) =>
FilePath -> ChromeDriverToUse -> m (Either Text FilePath)
obtainChromeDriver FilePath
toolsRoot ChromeDriverToUse
chromeDriverToUse m (Either Text FilePath)
-> (Either Text FilePath -> m [FilePath]) -> m [FilePath]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left Text
err -> FilePath -> m [FilePath]
forall a. HasCallStack => FilePath -> a
error [i|Failed to obtain chromedriver: '#{err}'|]
Right FilePath
p -> [FilePath] -> m [FilePath]
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 -> FilePath -> m [FilePath]
forall a. HasCallStack => FilePath -> a
error [i|Browser #{x} is not supported yet|]
Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|driverArgs: #{driverArgs}|]
(Maybe XvfbSession
maybeXvfbSession, Maybe [(FilePath, FilePath)]
javaEnv) <- case RunMode
runMode of
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) <- Maybe (Int, Int)
-> Bool -> FilePath -> m (XvfbSession, [(FilePath, FilePath)])
forall (m :: * -> *).
Constraints m =>
Maybe (Int, Int)
-> Bool -> FilePath -> m (XvfbSession, [(FilePath, FilePath)])
makeXvfbSession Maybe (Int, Int)
xvfbResolution Bool
xvfbStartFluxbox FilePath
webdriverRoot
(Maybe XvfbSession, Maybe [(FilePath, FilePath)])
-> m (Maybe XvfbSession, Maybe [(FilePath, FilePath)])
forall (m :: * -> *) a. Monad m => a -> m a
return (XvfbSession -> Maybe XvfbSession
forall a. a -> Maybe a
Just XvfbSession
s, [(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)]
forall a. a -> Maybe a
Just [(FilePath, FilePath)]
e)
RunMode
_ -> (Maybe XvfbSession, Maybe [(FilePath, FilePath)])
-> m (Maybe XvfbSession, Maybe [(FilePath, FilePath)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe XvfbSession
forall a. Maybe a
Nothing, Maybe [(FilePath, FilePath)]
forall a. Maybe a
Nothing)
let policy :: RetryPolicyM m
policy = Int -> RetryPolicyM m
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
constantDelay Int
0 RetryPolicyM m -> RetryPolicyM m -> RetryPolicyM m
forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicy
limitRetries Int
10
RetryPolicyM m -> (RetryStatus -> m WebDriver) -> m WebDriver
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m -> (RetryStatus -> m a) -> m a
recoverAll RetryPolicyM m
policy ((RetryStatus -> m WebDriver) -> m WebDriver)
-> (RetryStatus -> m WebDriver) -> m WebDriver
forall a b. (a -> b) -> a -> b
$ \RetryStatus
retryStatus -> do
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RetryStatus -> Int
rsIterNumber RetryStatus
retryStatus Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
warn [i|Trying again to start selenium server|]
Text
webdriverProcessName <- (Text
"webdriver_process_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> m Text -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO Text -> m Text
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
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
webdriverProcessRoot
WdOptions
-> Text
-> FilePath
-> FilePath
-> [FilePath]
-> Maybe XvfbSession
-> Maybe [(FilePath, FilePath)]
-> m WebDriver
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
WdOptions
-> Text
-> FilePath
-> FilePath
-> [FilePath]
-> Maybe XvfbSession
-> Maybe [(FilePath, FilePath)]
-> m WebDriver
startWebDriver' WdOptions
wdOptions Text
webdriverName FilePath
webdriverProcessRoot FilePath
seleniumPath [FilePath]
driverArgs Maybe XvfbSession
maybeXvfbSession Maybe [(FilePath, FilePath)]
javaEnv
startWebDriver' :: WdOptions
-> Text
-> FilePath
-> FilePath
-> [FilePath]
-> Maybe XvfbSession
-> Maybe [(FilePath, FilePath)]
-> m WebDriver
startWebDriver' wdOptions :: WdOptions
wdOptions@(WdOptions {capabilities :: WdOptions -> Capabilities
capabilities=Capabilities
capabilities', Int
FilePath
Maybe Manager
GeckoDriverToUse
ChromeDriverToUse
SeleniumToUse
RunMode
WhenToSave
httpRetryCount :: Int
httpManager :: Maybe Manager
runMode :: RunMode
geckoDriverToUse :: GeckoDriverToUse
chromeDriverToUse :: ChromeDriverToUse
seleniumToUse :: SeleniumToUse
saveSeleniumMessageHistory :: WhenToSave
toolsRoot :: FilePath
httpRetryCount :: WdOptions -> Int
httpManager :: WdOptions -> Maybe Manager
runMode :: WdOptions -> RunMode
geckoDriverToUse :: WdOptions -> GeckoDriverToUse
chromeDriverToUse :: WdOptions -> ChromeDriverToUse
seleniumToUse :: WdOptions -> SeleniumToUse
saveSeleniumMessageHistory :: WdOptions -> WhenToSave
toolsRoot :: WdOptions -> FilePath
..}) Text
webdriverName FilePath
webdriverRoot FilePath
seleniumPath [FilePath]
driverArgs Maybe XvfbSession
maybeXvfbSession Maybe [(FilePath, FilePath)]
javaEnv = do
PortNumber
port <- IO PortNumber -> m PortNumber
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 [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [Item [FilePath]
"-jar", FilePath
Item [FilePath]
seleniumPath
, Item [FilePath]
"-port", PortNumber -> FilePath
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 <- IO Handle -> m Handle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> m Handle) -> IO Handle -> m Handle
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 <- IO Handle -> m Handle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> m Handle) -> IO Handle -> m Handle
forall a b. (a -> b) -> a -> b
$ FilePath -> IOMode -> IO Handle
openFile FilePath
seleniumErrPath IOMode
AppendMode
Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|Starting the Selenium process|]
(Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
p) <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
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 = Int -> RetryPolicyM m
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
constantDelay Int
60000 RetryPolicyM m -> RetryPolicyM m -> RetryPolicyM m
forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicy
limitRetries Int
1000
Bool
success <- RetryPolicyM m
-> (RetryStatus -> Bool -> m Bool)
-> (RetryStatus -> m Bool)
-> m Bool
forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying RetryPolicyM m
policy (\RetryStatus
_retryStatus Bool
result -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
result)) ((RetryStatus -> m Bool) -> m Bool)
-> (RetryStatus -> m Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ m Bool -> RetryStatus -> m Bool
forall a b. a -> b -> a
const (m Bool -> RetryStatus -> m Bool)
-> m Bool -> RetryStatus -> m Bool
forall a b. (a -> b) -> a -> b
$
(IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Text
T.readFile FilePath
seleniumErrPath) m Text -> (Text -> m Bool) -> m Bool
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 -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Text
_ -> (IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Text
T.readFile FilePath
seleniumOutPath) m Text -> (Text -> m Bool) -> m Bool
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 -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Text
_ -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
ProcessHandle -> IO ()
interruptProcessGroupOf ProcessHandle
p IO () -> IO ExitCode -> IO ExitCode
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p
FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error [i|Selenium server failed to start after 60 seconds|]
FilePath
-> (Handle, Handle, ProcessHandle, FilePath, FilePath,
Maybe XvfbSession)
-> WdOptions
-> MVar (Map FilePath WDSession)
-> WDConfig
-> WebDriver
WebDriver (FilePath
-> (Handle, Handle, ProcessHandle, FilePath, FilePath,
Maybe XvfbSession)
-> WdOptions
-> MVar (Map FilePath WDSession)
-> WDConfig
-> WebDriver)
-> m FilePath
-> m ((Handle, Handle, ProcessHandle, FilePath, FilePath,
Maybe XvfbSession)
-> WdOptions
-> MVar (Map FilePath WDSession)
-> WDConfig
-> WebDriver)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> m FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> FilePath
T.unpack Text
webdriverName)
m ((Handle, Handle, ProcessHandle, FilePath, FilePath,
Maybe XvfbSession)
-> WdOptions
-> MVar (Map FilePath WDSession)
-> WDConfig
-> WebDriver)
-> m (Handle, Handle, ProcessHandle, FilePath, FilePath,
Maybe XvfbSession)
-> m (WdOptions
-> MVar (Map FilePath WDSession) -> WDConfig -> WebDriver)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Handle, Handle, ProcessHandle, FilePath, FilePath,
Maybe XvfbSession)
-> m (Handle, Handle, ProcessHandle, FilePath, FilePath,
Maybe XvfbSession)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Handle
hout, Handle
herr, ProcessHandle
p, FilePath
seleniumOutPath, FilePath
seleniumErrPath, Maybe XvfbSession
maybeXvfbSession)
m (WdOptions
-> MVar (Map FilePath WDSession) -> WDConfig -> WebDriver)
-> m WdOptions
-> m (MVar (Map FilePath WDSession) -> WDConfig -> WebDriver)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> WdOptions -> m WdOptions
forall (f :: * -> *) a. Applicative f => a -> f a
pure WdOptions
wdOptions
m (MVar (Map FilePath WDSession) -> WDConfig -> WebDriver)
-> m (MVar (Map FilePath WDSession)) -> m (WDConfig -> WebDriver)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (MVar (Map FilePath WDSession))
-> m (MVar (Map FilePath WDSession))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Map FilePath WDSession -> IO (MVar (Map FilePath WDSession))
forall a. a -> IO (MVar a)
newMVar Map FilePath WDSession
forall a. Monoid a => a
mempty)
m (WDConfig -> WebDriver) -> m WDConfig -> m WebDriver
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> WDConfig -> m WDConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WDConfig
forall a. Default a => a
def { wdPort :: Int
W.wdPort = PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port
, wdCapabilities :: Capabilities
W.wdCapabilities = Capabilities -> RunMode -> Capabilities
configureCapabilities Capabilities
capabilities' RunMode
runMode
, wdHTTPManager :: Maybe Manager
W.wdHTTPManager = Maybe Manager
httpManager
, wdHTTPRetryCount :: Int
W.wdHTTPRetryCount = Int
httpRetryCount
})
stopWebDriver :: Constraints m => WebDriver -> m ()
stopWebDriver :: 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
ExitCode
_ <- IO ExitCode -> m ExitCode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ProcessHandle -> IO ()
interruptProcessGroupOf ProcessHandle
h IO () -> IO ExitCode -> IO ExitCode
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
h)
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
hout
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
herr
Maybe XvfbSession -> (XvfbSession -> m ExitCode) -> m ()
forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe XvfbSession
maybeXvfbSession ((XvfbSession -> m ExitCode) -> m ())
-> (XvfbSession -> m ExitCode) -> m ()
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
Maybe ProcessHandle -> (ProcessHandle -> m ExitCode) -> m ()
forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe ProcessHandle
xvfbFluxboxProcess ((ProcessHandle -> m ExitCode) -> m ())
-> (ProcessHandle -> m ExitCode) -> m ()
forall a b. (a -> b) -> a -> b
$ \ProcessHandle
p ->
IO ExitCode -> m ExitCode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ProcessHandle -> IO ()
interruptProcessGroupOf ProcessHandle
p IO () -> IO ExitCode -> IO ExitCode
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p)
IO ExitCode -> m ExitCode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ProcessHandle -> IO ()
interruptProcessGroupOf ProcessHandle
xvfbProcess IO () -> IO ExitCode -> IO ExitCode
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
xvfbProcess)
seleniumOutFileName, seleniumErrFileName :: FilePath
seleniumOutFileName :: FilePath
seleniumOutFileName = FilePath
"stdout.txt"
seleniumErrFileName :: FilePath
seleniumErrFileName = FilePath
"stderr.txt"
configureCapabilities :: Capabilities -> RunMode -> Capabilities
configureCapabilities 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
..})}) (RunHeadless (HeadlessConfig {Maybe (Int, Int)
headlessResolution :: HeadlessConfig -> Maybe (Int, Int)
headlessResolution :: Maybe (Int, Int)
..})) = Capabilities
caps { browser :: Browser
W.browser = Browser
browser' }
where browser' :: Browser
browser' = Browser
browser { chromeOptions :: [FilePath]
W.chromeOptions = FilePath
"--headless"FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:FilePath
resolutionFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
chromeOptions }
resolution :: FilePath
resolution = [i|--window-size=#{w},#{h}|]
(Int
w, Int
h) = (Int, Int) -> Maybe (Int, Int) -> (Int, Int)
forall a. a -> Maybe a -> a
fromMaybe (Int
1920, Int
1080) Maybe (Int, Int)
headlessResolution
configureCapabilities 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}) (RunHeadless (HeadlessConfig {Maybe (Int, Int)
headlessResolution :: Maybe (Int, Int)
headlessResolution :: HeadlessConfig -> Maybe (Int, Int)
..})) = Capabilities
caps { additionalCaps :: [Pair]
W.additionalCaps = [Pair]
additionalCaps }
where
additionalCaps :: [Pair]
additionalCaps = case (Pair -> Bool) -> [Pair] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
L.findIndex (\Pair
x -> Pair -> Text
forall a b. (a, b) -> a
fst Pair
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"moz:firefoxOptions") [Pair]
ac of
Maybe Int
Nothing -> (Text
"moz:firefoxOptions", [Pair] -> Value
A.object [(Text
"args", Array -> Value
A.Array [Item Array
"-headless"])]) Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: [Pair]
ac
Just Int
i -> let ffOptions' :: Value
ffOptions' = (Pair -> Value
forall a b. (a, b) -> b
snd (Pair -> Value) -> Pair -> Value
forall a b. (a -> b) -> a -> b
$ [Pair]
ac [Pair] -> Int -> Pair
forall a. [a] -> Int -> a
!! Int
i)
Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Text -> Value -> Value -> Value
ensureKeyExists Text
"args" (Array -> Value
A.Array [])
Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& ((Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key Text
"args" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Array -> Identity Array) -> Value -> Identity Value)
-> (Array -> Identity Array)
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Array -> Identity Array) -> Value -> Identity Value
forall t. AsValue t => Traversal' t Array
_Array) ((Array -> Identity Array) -> Value -> Identity Value)
-> (Array -> Array) -> Value -> Value
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Array -> Array
addHeadlessArg) in
(Pair -> Pair -> Bool) -> [Pair] -> [Pair]
forall a. (a -> a -> Bool) -> [a] -> [a]
L.nubBy (\Pair
x Pair
y -> Pair -> Text
forall a b. (a, b) -> a
fst Pair
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Pair -> Text
forall a b. (a, b) -> a
fst Pair
y) ((Text
"moz:firefoxOptions", Value
ffOptions') Pair -> [Pair] -> [Pair]
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 (Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key -> Just Value
_)) = Value
val
ensureKeyExists Text
key Value
defaultVal (A.Object m :: Object
m@(Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
key -> Maybe Value
Nothing)) = Object -> Value
A.Object (Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
key Value
defaultVal Object
m)
ensureKeyExists Text
_ Value
_ Value
_ = FilePath -> 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") Value -> Array -> Bool
forall a. Eq a => a -> Vector a -> Bool
`V.elem` Array
xs = Array
xs
addHeadlessArg Array
xs = (Text -> Value
A.String Text
"-headless") Value -> Array -> Array
forall a. a -> Vector a -> Vector a
`V.cons` Array
xs
configureCapabilities Capabilities
browser (RunHeadless {}) = FilePath -> Capabilities
forall a. HasCallStack => FilePath -> a
error [i|Headless mode not yet supported for browser '#{browser}'|]
configureCapabilities Capabilities
browser RunMode
_ = Capabilities
browser