{-# 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.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) =>
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 forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ 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 :: * -> *}.
(MonadIO m, MonadBaseControl IO m) =>
FilePath -> Capabilities -> m Capabilities
configureDownloadCapabilities FilePath
downloadDir (RunMode -> Capabilities -> Capabilities
configureHeadlessCapabilities RunMode
runMode Capabilities
capabilities')

  -- 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 :: RunMode -> Capabilities -> Capabilities
configureHeadlessCapabilities (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
..})}) = Capabilities
caps { browser :: Browser
W.browser = Browser
browser' }
  where browser' :: Browser
browser' = Browser
browser { chromeOptions :: [FilePath]
W.chromeOptions = FilePath
"--headless"forall a. a -> [a] -> [a]
:FilePath
resolutionforall a. a -> [a] -> [a]
:[FilePath]
chromeOptions }
        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 (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}) = 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 (RunHeadless {}) Capabilities
browser = forall a. HasCallStack => FilePath -> a
error [i|Headless mode not yet supported for browser '#{browser}'|]
configureHeadlessCapabilities RunMode
_ Capabilities
browser = 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