{-# 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)

-- | Spin up a Selenium WebDriver and create a WebDriver
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
  -- Create a unique name for this webdriver so the folder for its log output doesn't conflict with any others
  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)

  -- Directory to log everything for this webdriver
  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

  -- Get selenium and chromedriver
  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}|]
                          -- , [i|-Dwebdriver.gecko.logfile=#{webdriverRoot </> "geckodriver.log"}|]
                          -- , [i|-Dwebdriver.gecko.verboseLogging=true|]
                          ]
    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)

  -- 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 = 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|]

    -- Create a distinct process name
    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 }

  -- Open output handles
  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

  -- Start the process and wait for it to be ready
  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
    }
  -- 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 = 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|]

  -- Make the WebDriver
  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)

-- * Util

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

-- | Add headless configuration to the Chrome browser
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

-- | Add headless configuration to the Firefox capabilities
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