mirror of
https://github.com/codedownio/sandwich.git
synced 2024-08-16 23:30:22 +03:00
Working on better dependency injection
This commit is contained in:
parent
7ec3e785da
commit
1828e15538
@ -39,9 +39,9 @@ library:
|
|||||||
- Test.Sandwich.Contexts.Nix
|
- Test.Sandwich.Contexts.Nix
|
||||||
- Test.Sandwich.Contexts.PostgreSQL
|
- Test.Sandwich.Contexts.PostgreSQL
|
||||||
- Test.Sandwich.Contexts.Waits
|
- Test.Sandwich.Contexts.Waits
|
||||||
|
|
||||||
- Test.Sandwich.Contexts.Types.Network
|
- Test.Sandwich.Contexts.Types.Network
|
||||||
- Test.Sandwich.Contexts.Types.S3
|
- Test.Sandwich.Contexts.Types.S3
|
||||||
|
- Test.Sandwich.Contexts.Util.Ports
|
||||||
dependencies:
|
dependencies:
|
||||||
- aeson
|
- aeson
|
||||||
- conduit
|
- conduit
|
||||||
|
@ -23,12 +23,12 @@ library
|
|||||||
Test.Sandwich.Contexts.Waits
|
Test.Sandwich.Contexts.Waits
|
||||||
Test.Sandwich.Contexts.Types.Network
|
Test.Sandwich.Contexts.Types.Network
|
||||||
Test.Sandwich.Contexts.Types.S3
|
Test.Sandwich.Contexts.Types.S3
|
||||||
|
Test.Sandwich.Contexts.Util.Ports
|
||||||
other-modules:
|
other-modules:
|
||||||
Test.Sandwich.Contexts.FakeSmtpServer.Derivation
|
Test.Sandwich.Contexts.FakeSmtpServer.Derivation
|
||||||
Test.Sandwich.Contexts.ReverseProxy.TCP
|
Test.Sandwich.Contexts.ReverseProxy.TCP
|
||||||
Test.Sandwich.Contexts.Util.Aeson
|
Test.Sandwich.Contexts.Util.Aeson
|
||||||
Test.Sandwich.Contexts.Util.Nix
|
Test.Sandwich.Contexts.Util.Nix
|
||||||
Test.Sandwich.Contexts.Util.Ports
|
|
||||||
Test.Sandwich.Contexts.Util.SocketUtil
|
Test.Sandwich.Contexts.Util.SocketUtil
|
||||||
Test.Sandwich.Contexts.Util.UUID
|
Test.Sandwich.Contexts.Util.UUID
|
||||||
Paths_sandwich_contexts
|
Paths_sandwich_contexts
|
||||||
|
@ -25,6 +25,8 @@ dependencies:
|
|||||||
- http-client
|
- http-client
|
||||||
- http-client-tls
|
- http-client-tls
|
||||||
- http-conduit
|
- http-conduit
|
||||||
|
- lens
|
||||||
|
- lens-regex-pcre
|
||||||
- microlens
|
- microlens
|
||||||
- microlens-aeson
|
- microlens-aeson
|
||||||
- monad-control
|
- monad-control
|
||||||
@ -36,6 +38,7 @@ dependencies:
|
|||||||
- retry
|
- retry
|
||||||
- safe
|
- safe
|
||||||
- sandwich >= 0.1.0.3
|
- sandwich >= 0.1.0.3
|
||||||
|
- sandwich-contexts
|
||||||
- string-interpolate
|
- string-interpolate
|
||||||
- text
|
- text
|
||||||
- time
|
- time
|
||||||
|
@ -35,7 +35,7 @@ library
|
|||||||
Test.Sandwich.WebDriver.Internal.Binaries.DetectFirefox
|
Test.Sandwich.WebDriver.Internal.Binaries.DetectFirefox
|
||||||
Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform
|
Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform
|
||||||
Test.Sandwich.WebDriver.Internal.Capabilities
|
Test.Sandwich.WebDriver.Internal.Capabilities
|
||||||
Test.Sandwich.WebDriver.Internal.Ports
|
Test.Sandwich.WebDriver.Internal.Capabilities.Extra
|
||||||
Test.Sandwich.WebDriver.Internal.Screenshots
|
Test.Sandwich.WebDriver.Internal.Screenshots
|
||||||
Test.Sandwich.WebDriver.Internal.StartWebDriver
|
Test.Sandwich.WebDriver.Internal.StartWebDriver
|
||||||
Test.Sandwich.WebDriver.Internal.Types
|
Test.Sandwich.WebDriver.Internal.Types
|
||||||
@ -74,6 +74,8 @@ library
|
|||||||
, http-client
|
, http-client
|
||||||
, http-client-tls
|
, http-client-tls
|
||||||
, http-conduit
|
, http-conduit
|
||||||
|
, lens
|
||||||
|
, lens-regex-pcre
|
||||||
, microlens
|
, microlens
|
||||||
, microlens-aeson
|
, microlens-aeson
|
||||||
, monad-control
|
, monad-control
|
||||||
@ -85,6 +87,7 @@ library
|
|||||||
, retry
|
, retry
|
||||||
, safe
|
, safe
|
||||||
, sandwich >=0.1.0.3
|
, sandwich >=0.1.0.3
|
||||||
|
, sandwich-contexts
|
||||||
, string-interpolate
|
, string-interpolate
|
||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
@ -152,6 +155,8 @@ executable sandwich-webdriver-exe
|
|||||||
, http-client
|
, http-client
|
||||||
, http-client-tls
|
, http-client-tls
|
||||||
, http-conduit
|
, http-conduit
|
||||||
|
, lens
|
||||||
|
, lens-regex-pcre
|
||||||
, microlens
|
, microlens
|
||||||
, microlens-aeson
|
, microlens-aeson
|
||||||
, monad-control
|
, monad-control
|
||||||
@ -163,6 +168,7 @@ executable sandwich-webdriver-exe
|
|||||||
, retry
|
, retry
|
||||||
, safe
|
, safe
|
||||||
, sandwich >=0.1.0.3
|
, sandwich >=0.1.0.3
|
||||||
|
, sandwich-contexts
|
||||||
, sandwich-webdriver
|
, sandwich-webdriver
|
||||||
, string-interpolate
|
, string-interpolate
|
||||||
, text
|
, text
|
||||||
@ -230,6 +236,8 @@ test-suite sandwich-webdriver-test
|
|||||||
, http-client
|
, http-client
|
||||||
, http-client-tls
|
, http-client-tls
|
||||||
, http-conduit
|
, http-conduit
|
||||||
|
, lens
|
||||||
|
, lens-regex-pcre
|
||||||
, microlens
|
, microlens
|
||||||
, microlens-aeson
|
, microlens-aeson
|
||||||
, monad-control
|
, monad-control
|
||||||
@ -241,6 +249,7 @@ test-suite sandwich-webdriver-test
|
|||||||
, retry
|
, retry
|
||||||
, safe
|
, safe
|
||||||
, sandwich >=0.1.0.3
|
, sandwich >=0.1.0.3
|
||||||
|
, sandwich-contexts
|
||||||
, sandwich-webdriver
|
, sandwich-webdriver
|
||||||
, string-interpolate
|
, string-interpolate
|
||||||
, text
|
, text
|
||||||
|
@ -6,6 +6,7 @@
|
|||||||
module Test.Sandwich.WebDriver (
|
module Test.Sandwich.WebDriver (
|
||||||
-- * Introducing a WebDriver server
|
-- * Introducing a WebDriver server
|
||||||
introduceWebDriver
|
introduceWebDriver
|
||||||
|
, introduceWebDriverViaNix
|
||||||
, introduceWebDriverOptions
|
, introduceWebDriverOptions
|
||||||
, addCommandLineOptionsToWdOptions
|
, addCommandLineOptionsToWdOptions
|
||||||
|
|
||||||
@ -43,6 +44,8 @@ import qualified Data.Map as M
|
|||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.String.Interpolate
|
import Data.String.Interpolate
|
||||||
import Test.Sandwich
|
import Test.Sandwich
|
||||||
|
import Test.Sandwich.Contexts.Files
|
||||||
|
import Test.Sandwich.Contexts.Nix
|
||||||
import Test.Sandwich.Internal
|
import Test.Sandwich.Internal
|
||||||
import Test.Sandwich.WebDriver.Class
|
import Test.Sandwich.WebDriver.Class
|
||||||
import Test.Sandwich.WebDriver.Config
|
import Test.Sandwich.WebDriver.Config
|
||||||
@ -60,10 +63,18 @@ import UnliftIO.MVar
|
|||||||
introduceWebDriver :: (
|
introduceWebDriver :: (
|
||||||
BaseMonadContext m context
|
BaseMonadContext m context
|
||||||
) => WdOptions -> SpecFree (LabelValue "webdriver" WebDriver :> context) m () -> SpecFree context m ()
|
) => WdOptions -> SpecFree (LabelValue "webdriver" WebDriver :> context) m () -> SpecFree context m ()
|
||||||
introduceWebDriver wdOptions = introduce "Introduce WebDriver session" webdriver (allocateWebDriver wdOptions) cleanupWebDriver
|
introduceWebDriver wdOptions = undefined -- introduce "Introduce WebDriver session" webdriver (allocateWebDriver wdOptions) cleanupWebDriver
|
||||||
|
|
||||||
|
introduceWebDriverViaNix :: (
|
||||||
|
BaseMonadContext m context, HasNixContext context, HasFile context "java"
|
||||||
|
) => WdOptions -> SpecFree (LabelValue "webdriver" WebDriver :> context) m () -> SpecFree context m ()
|
||||||
|
introduceWebDriverViaNix wdOptions =
|
||||||
|
introduce "Introduce WebDriver session" webdriver (allocateWebDriver wdOptions) cleanupWebDriver
|
||||||
|
|
||||||
-- | Same as introduceWebDriver, but merges command line options into the 'WdOptions'.
|
-- | Same as introduceWebDriver, but merges command line options into the 'WdOptions'.
|
||||||
introduceWebDriverOptions :: forall a context m. (BaseMonadContext m context, HasCommandLineOptions context a)
|
introduceWebDriverOptions :: forall a context m. (
|
||||||
|
BaseMonadContext m context, HasCommandLineOptions context a, HasFile context "java"
|
||||||
|
)
|
||||||
=> WdOptions -> SpecFree (LabelValue "webdriver" WebDriver :> context) m () -> SpecFree context m ()
|
=> WdOptions -> SpecFree (LabelValue "webdriver" WebDriver :> context) m () -> SpecFree context m ()
|
||||||
introduceWebDriverOptions wdOptions = introduce "Introduce WebDriver session" webdriver alloc cleanupWebDriver
|
introduceWebDriverOptions wdOptions = introduce "Introduce WebDriver session" webdriver alloc cleanupWebDriver
|
||||||
where alloc = do
|
where alloc = do
|
||||||
@ -71,7 +82,7 @@ introduceWebDriverOptions wdOptions = introduce "Introduce WebDriver session" we
|
|||||||
allocateWebDriver (addCommandLineOptionsToWdOptions @a clo wdOptions)
|
allocateWebDriver (addCommandLineOptionsToWdOptions @a clo wdOptions)
|
||||||
|
|
||||||
-- | Allocate a WebDriver using the given options.
|
-- | Allocate a WebDriver using the given options.
|
||||||
allocateWebDriver :: (HasBaseContext context, BaseMonad m) => WdOptions -> ExampleT context m WebDriver
|
allocateWebDriver :: (BaseMonad m, HasBaseContext context, HasFile context "java") => WdOptions -> ExampleT context m WebDriver
|
||||||
allocateWebDriver wdOptions = do
|
allocateWebDriver wdOptions = do
|
||||||
debug "Beginning allocateWebDriver"
|
debug "Beginning allocateWebDriver"
|
||||||
dir <- fromMaybe "/tmp" <$> getCurrentFolder
|
dir <- fromMaybe "/tmp" <$> getCurrentFolder
|
||||||
@ -80,7 +91,7 @@ allocateWebDriver wdOptions = do
|
|||||||
-- | Allocate a WebDriver using the given options and putting logs under the given path.
|
-- | Allocate a WebDriver using the given options and putting logs under the given path.
|
||||||
allocateWebDriver' :: FilePath -> WdOptions -> IO WebDriver
|
allocateWebDriver' :: FilePath -> WdOptions -> IO WebDriver
|
||||||
allocateWebDriver' runRoot wdOptions = do
|
allocateWebDriver' runRoot wdOptions = do
|
||||||
runNoLoggingT $ startWebDriver wdOptions runRoot
|
runNoLoggingT $ flip runReaderT (undefined :: LabelValue "file-java" (EnvironmentFile "java")) $ startWebDriver wdOptions runRoot
|
||||||
|
|
||||||
-- | Clean up the given WebDriver.
|
-- | Clean up the given WebDriver.
|
||||||
cleanupWebDriver :: (BaseMonad m) => WebDriver -> ExampleT context m ()
|
cleanupWebDriver :: (BaseMonad m) => WebDriver -> ExampleT context m ()
|
||||||
|
@ -1,5 +1,4 @@
|
|||||||
{-# LANGUAGE OverloadedLists #-}
|
{-# LANGUAGE OverloadedLists #-}
|
||||||
-- |
|
|
||||||
|
|
||||||
module Test.Sandwich.WebDriver.Internal.Capabilities (
|
module Test.Sandwich.WebDriver.Internal.Capabilities (
|
||||||
-- * Chrome
|
-- * Chrome
|
||||||
|
@ -0,0 +1,129 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
|
{-# LANGUAGE OverloadedLists #-}
|
||||||
|
|
||||||
|
module Test.Sandwich.WebDriver.Internal.Capabilities.Extra (
|
||||||
|
configureHeadlessCapabilities
|
||||||
|
, configureDownloadCapabilities
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Control.Monad.Catch (MonadMask)
|
||||||
|
import Control.Monad.IO.Class
|
||||||
|
import Control.Monad.IO.Unlift
|
||||||
|
import Control.Monad.Logger
|
||||||
|
import Control.Monad.Trans.Control (MonadBaseControl)
|
||||||
|
import qualified Data.Aeson as A
|
||||||
|
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.Vector as V
|
||||||
|
import GHC.Stack
|
||||||
|
import Lens.Micro
|
||||||
|
import Lens.Micro.Aeson
|
||||||
|
import Test.Sandwich
|
||||||
|
import Test.Sandwich.WebDriver.Internal.Binaries.DetectChrome (detectChromeVersion)
|
||||||
|
import Test.Sandwich.WebDriver.Internal.Types
|
||||||
|
import qualified Test.WebDriver as W
|
||||||
|
import qualified Test.WebDriver.Firefox.Profile as FF
|
||||||
|
import UnliftIO.Exception
|
||||||
|
|
||||||
|
|
||||||
|
#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 = A.fromText
|
||||||
|
#else
|
||||||
|
import qualified Data.HashMap.Strict as HM
|
||||||
|
fromText :: T.Text -> T.Text
|
||||||
|
fromText = id
|
||||||
|
#endif
|
||||||
|
|
||||||
|
|
||||||
|
type Constraints m = (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadBaseControl IO m, MonadMask m)
|
||||||
|
|
||||||
|
-- | Add headless configuration to the Chrome browser
|
||||||
|
configureHeadlessCapabilities :: Constraints m => WdOptions -> RunMode -> W.Capabilities -> m W.Capabilities
|
||||||
|
configureHeadlessCapabilities wdOptions (RunHeadless (HeadlessConfig {..})) caps@(W.Capabilities {W.browser=browser@(W.Chrome {..})}) = do
|
||||||
|
headlessArg <- liftIO (detectChromeVersion (chromeBinaryPath wdOptions)) >>= \case
|
||||||
|
Left err -> do
|
||||||
|
warn [i|Couldn't determine chrome version when configuring headless capabilities (err: #{err}); passing --headless|]
|
||||||
|
return "--headless"
|
||||||
|
Right (ChromeVersion (major, _, _, _))
|
||||||
|
-- See https://www.selenium.dev/blog/2023/headless-is-going-away/
|
||||||
|
| major >= 110 -> return "--headless=new"
|
||||||
|
| otherwise -> return "--headless"
|
||||||
|
|
||||||
|
let browser' = browser { W.chromeOptions = headlessArg:resolution:chromeOptions }
|
||||||
|
|
||||||
|
return (caps { W.browser = browser' })
|
||||||
|
|
||||||
|
where
|
||||||
|
resolution = [i|--window-size=#{w},#{h}|]
|
||||||
|
(w, h) = fromMaybe (1920, 1080) headlessResolution
|
||||||
|
|
||||||
|
-- | Add headless configuration to the Firefox capabilities
|
||||||
|
configureHeadlessCapabilities _ (RunHeadless (HeadlessConfig {})) caps@(W.Capabilities {W.browser=(W.Firefox {}), W.additionalCaps=ac}) = return (caps { W.additionalCaps = additionalCaps })
|
||||||
|
where
|
||||||
|
additionalCaps = case L.findIndex (\x -> fst x == "moz:firefoxOptions") ac of
|
||||||
|
Nothing -> ("moz:firefoxOptions", A.object [("args", A.Array ["-headless"])]) : ac
|
||||||
|
Just i' -> let ffOptions' = snd (ac !! i')
|
||||||
|
& ensureKeyExists "args" (A.Array [])
|
||||||
|
& ((key "args" . _Array) %~ addHeadlessArg) in
|
||||||
|
L.nubBy (\x y -> fst x == fst y) (("moz:firefoxOptions", ffOptions') : ac)
|
||||||
|
|
||||||
|
ensureKeyExists :: T.Text -> A.Value -> A.Value -> A.Value
|
||||||
|
ensureKeyExists key' _ val@(A.Object (HM.lookup (fromText key') -> Just _)) = val
|
||||||
|
ensureKeyExists key' defaultVal (A.Object m@(HM.lookup (fromText key') -> Nothing)) = A.Object (HM.insert (fromText key') defaultVal m)
|
||||||
|
ensureKeyExists _ _ _ = error "Expected Object in ensureKeyExists"
|
||||||
|
|
||||||
|
addHeadlessArg :: V.Vector A.Value -> V.Vector A.Value
|
||||||
|
addHeadlessArg xs | (A.String "-headless") `V.elem` xs = xs
|
||||||
|
addHeadlessArg xs = (A.String "-headless") `V.cons` xs
|
||||||
|
|
||||||
|
configureHeadlessCapabilities _ (RunHeadless {}) browser = error [i|Headless mode not yet supported for browser '#{browser}'|]
|
||||||
|
configureHeadlessCapabilities _ _ browser = return browser
|
||||||
|
|
||||||
|
|
||||||
|
-- | Configure download capabilities to set the download directory and disable prompts
|
||||||
|
-- (since you can't test download prompts using Selenium)
|
||||||
|
configureDownloadCapabilities :: (
|
||||||
|
MonadIO m, MonadBaseControl IO m
|
||||||
|
) => [Char] -> W.Capabilities -> m W.Capabilities
|
||||||
|
configureDownloadCapabilities downloadDir caps@(W.Capabilities {W.browser=browser@(W.Firefox {..})}) = do
|
||||||
|
case ffProfile of
|
||||||
|
Nothing -> return ()
|
||||||
|
Just _ -> liftIO $ throwIO $ userError [i|Can't support Firefox profile yet.|]
|
||||||
|
|
||||||
|
profile <- FF.defaultProfile
|
||||||
|
& FF.addPref "browser.download.folderList" (2 :: Int)
|
||||||
|
& FF.addPref "browser.download.manager.showWhenStarting" False
|
||||||
|
& FF.addPref "browser.download.dir" downloadDir
|
||||||
|
& FF.addPref "browser.helperApps.neverAsk.saveToDisk" ("*" :: String)
|
||||||
|
& FF.prepareProfile
|
||||||
|
|
||||||
|
return (caps { W.browser = browser { W.ffProfile = Just profile } })
|
||||||
|
configureDownloadCapabilities downloadDir caps@(W.Capabilities {W.browser=browser@(W.Chrome {..})}) = return $ caps { W.browser=browser' }
|
||||||
|
where
|
||||||
|
browser' = browser { W.chromeExperimentalOptions = options }
|
||||||
|
|
||||||
|
basePrefs :: A.Object
|
||||||
|
basePrefs = case HM.lookup "prefs" chromeExperimentalOptions of
|
||||||
|
Just (A.Object hm) -> hm
|
||||||
|
Just x -> error [i|Expected chrome prefs to be object, got '#{x}'.|]
|
||||||
|
Nothing -> mempty
|
||||||
|
|
||||||
|
prefs :: A.Object
|
||||||
|
prefs = basePrefs
|
||||||
|
& foldl (.) id [HM.insert k v | (k, v) <- downloadPrefs]
|
||||||
|
|
||||||
|
options = HM.insert "prefs" (A.Object prefs) chromeExperimentalOptions
|
||||||
|
|
||||||
|
downloadPrefs = [("profile.default_content_setting_values.automatic_downloads", A.Number 1)
|
||||||
|
, ("profile.content_settings.exceptions.automatic_downloads.*.setting", A.Number 1)
|
||||||
|
, ("download.prompt_for_download", A.Bool False)
|
||||||
|
, ("download.directory_upgrade", A.Bool True)
|
||||||
|
, ("download.default_directory", A.String (T.pack downloadDir))]
|
||||||
|
configureDownloadCapabilities _ browser = return browser
|
@ -1,78 +0,0 @@
|
|||||||
{-# LANGUAGE RankNTypes, MultiWayIf, ScopedTypeVariables, LambdaCase #-}
|
|
||||||
|
|
||||||
module Test.Sandwich.WebDriver.Internal.Ports (
|
|
||||||
findFreePortOrException
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Exception
|
|
||||||
import Control.Retry
|
|
||||||
import Data.Maybe
|
|
||||||
import Data.String.Interpolate
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import Network.Socket
|
|
||||||
import System.Random (randomRIO)
|
|
||||||
import Test.Sandwich.WebDriver.Internal.Util
|
|
||||||
|
|
||||||
firstUserPort :: PortNumber
|
|
||||||
firstUserPort = 1024
|
|
||||||
|
|
||||||
highestPort :: PortNumber
|
|
||||||
highestPort = 65535
|
|
||||||
|
|
||||||
-- |Find an unused port in a given range
|
|
||||||
findFreePortInRange' :: RetryPolicy -> IO PortNumber -> IO (Maybe PortNumber)
|
|
||||||
findFreePortInRange' policy getAcceptableCandidate = retrying policy (\_retryStatus result -> return $ isNothing result) (const findFreePortInRange'')
|
|
||||||
where
|
|
||||||
findFreePortInRange'' :: IO (Maybe PortNumber)
|
|
||||||
findFreePortInRange'' = do
|
|
||||||
candidate <- getAcceptableCandidate
|
|
||||||
catch (tryOpenAndClosePort candidate >> return (Just candidate)) (\(_ :: SomeException) -> return Nothing)
|
|
||||||
where
|
|
||||||
tryOpenAndClosePort :: PortNumber -> IO PortNumber
|
|
||||||
tryOpenAndClosePort port = do
|
|
||||||
sock <- socket AF_INET Stream 0
|
|
||||||
setSocketOption sock ReuseAddr 1
|
|
||||||
let hostAddress = tupleToHostAddress (127, 0, 0, 1)
|
|
||||||
bind sock (SockAddrInet port hostAddress)
|
|
||||||
close sock
|
|
||||||
return $ fromIntegral port
|
|
||||||
|
|
||||||
findFreePortInRange :: IO PortNumber -> IO (Maybe PortNumber)
|
|
||||||
findFreePortInRange = findFreePortInRange' (limitRetries 50)
|
|
||||||
|
|
||||||
-- | Find an unused port in the ephemeral port range.
|
|
||||||
-- See https://en.wikipedia.org/wiki/List_of_TCP_and_UDP_port_numbers
|
|
||||||
-- This works without a timeout since there should always be a port in the somewhere;
|
|
||||||
-- it might be advisable to wrap in a timeout anyway.
|
|
||||||
findFreePort :: IO (Maybe PortNumber)
|
|
||||||
findFreePort = findFreePortInRange getNonEphemeralCandidate
|
|
||||||
|
|
||||||
findFreePortOrException :: IO PortNumber
|
|
||||||
findFreePortOrException = findFreePort >>= \case
|
|
||||||
Just port -> return port
|
|
||||||
Nothing -> error "Couldn't find free port"
|
|
||||||
|
|
||||||
-- * Util
|
|
||||||
|
|
||||||
getNonEphemeralCandidate :: IO PortNumber
|
|
||||||
getNonEphemeralCandidate = do
|
|
||||||
(ephemeralStart, ephemeralEnd) <- getEphemeralPortRange >>= \case
|
|
||||||
Left _ -> return (49152, 65535)
|
|
||||||
Right range -> return range
|
|
||||||
|
|
||||||
let numBelow = ephemeralStart - firstUserPort
|
|
||||||
let numAbove = highestPort - ephemeralEnd
|
|
||||||
|
|
||||||
u :: Double <- randomRIO (0, 1)
|
|
||||||
|
|
||||||
let useLowerRange = u < ((fromIntegral numBelow) / (fromIntegral numBelow + fromIntegral numAbove))
|
|
||||||
|
|
||||||
if | useLowerRange -> fromInteger <$> randomRIO (fromIntegral firstUserPort, fromIntegral ephemeralStart)
|
|
||||||
| otherwise -> fromInteger <$> randomRIO (fromIntegral ephemeralEnd, fromIntegral highestPort)
|
|
||||||
|
|
||||||
getEphemeralPortRange :: IO (Either T.Text (PortNumber, PortNumber))
|
|
||||||
getEphemeralPortRange = leftOnException' $ do
|
|
||||||
contents <- readFile "/proc/sys/net/ipv4/ip_local_port_range"
|
|
||||||
case fmap read (words contents) of
|
|
||||||
[p1, p2] -> return (p1, p2)
|
|
||||||
_ -> error [i|Unexpected contents: '#{contents}'|]
|
|
@ -2,6 +2,7 @@
|
|||||||
{-# LANGUAGE ConstraintKinds #-}
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE OverloadedLists #-}
|
{-# LANGUAGE OverloadedLists #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
|
||||||
@ -13,56 +14,40 @@ import Control.Monad.Catch (MonadMask)
|
|||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.IO.Unlift
|
import Control.Monad.IO.Unlift
|
||||||
import Control.Monad.Logger
|
import Control.Monad.Logger
|
||||||
|
import Control.Monad.Reader
|
||||||
import Control.Monad.Trans.Control (MonadBaseControl)
|
import Control.Monad.Trans.Control (MonadBaseControl)
|
||||||
import Control.Retry
|
import Control.Retry
|
||||||
import qualified Data.Aeson as A
|
|
||||||
import Data.Default
|
import Data.Default
|
||||||
import Data.Function
|
import Data.Function
|
||||||
import qualified Data.List as L
|
|
||||||
import Data.Maybe
|
|
||||||
import Data.String.Interpolate
|
import Data.String.Interpolate
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.Text.IO as T
|
|
||||||
import qualified Data.Vector as V
|
|
||||||
import GHC.Stack
|
import GHC.Stack
|
||||||
import Lens.Micro
|
|
||||||
import Lens.Micro.Aeson
|
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
import System.IO
|
import System.IO (hGetLine)
|
||||||
import System.Process
|
|
||||||
import Test.Sandwich
|
import Test.Sandwich
|
||||||
|
import Test.Sandwich.Contexts.Files
|
||||||
|
import Test.Sandwich.Contexts.Util.Ports (findFreePortOrException)
|
||||||
import Test.Sandwich.Util.Process
|
import Test.Sandwich.Util.Process
|
||||||
import Test.Sandwich.WebDriver.Internal.Binaries
|
import Test.Sandwich.WebDriver.Internal.Binaries
|
||||||
import Test.Sandwich.WebDriver.Internal.Binaries.DetectChrome (detectChromeVersion)
|
import Test.Sandwich.WebDriver.Internal.Capabilities.Extra
|
||||||
import Test.Sandwich.WebDriver.Internal.Ports
|
|
||||||
import Test.Sandwich.WebDriver.Internal.Types
|
import Test.Sandwich.WebDriver.Internal.Types
|
||||||
import Test.Sandwich.WebDriver.Internal.Util
|
import Test.Sandwich.WebDriver.Internal.Util
|
||||||
import qualified Test.WebDriver as W
|
import qualified Test.WebDriver as W
|
||||||
import qualified Test.WebDriver.Firefox.Profile as FF
|
import UnliftIO.Process
|
||||||
import UnliftIO.Exception
|
|
||||||
|
|
||||||
#ifndef mingw32_HOST_OS
|
#ifndef mingw32_HOST_OS
|
||||||
import Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb
|
import Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb
|
||||||
#endif
|
#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 = A.fromText
|
|
||||||
#else
|
|
||||||
import qualified Data.HashMap.Strict as HM
|
|
||||||
fromText :: T.Text -> T.Text
|
|
||||||
fromText = id
|
|
||||||
#endif
|
|
||||||
|
|
||||||
|
|
||||||
type Constraints m = (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadBaseControl IO m, MonadMask m)
|
type Constraints m = (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadBaseControl IO m, MonadMask m)
|
||||||
|
|
||||||
-- | Spin up a Selenium WebDriver and create a WebDriver
|
-- | Spin up a Selenium WebDriver and create a WebDriver
|
||||||
startWebDriver :: Constraints m => WdOptions -> FilePath -> m WebDriver
|
startWebDriver :: (
|
||||||
startWebDriver wdOptions@(WdOptions {..}) runRoot = do
|
Constraints m, MonadReader context m, HasFile context "java"
|
||||||
|
) => WdOptions -> FilePath -> m WebDriver
|
||||||
|
startWebDriver wdOptions@(WdOptions {capabilities=capabilities', ..}) runRoot = do
|
||||||
-- Create a unique name for this webdriver so the folder for its log output doesn't conflict with any others
|
-- Create a unique name for this webdriver so the folder for its log output doesn't conflict with any others
|
||||||
webdriverName <- ("webdriver_" <>) <$> liftIO makeUUID
|
webdriverName <- ("webdriver_" <>) <$> liftIO makeUUID
|
||||||
|
|
||||||
@ -70,6 +55,7 @@ startWebDriver wdOptions@(WdOptions {..}) runRoot = do
|
|||||||
let webdriverRoot = runRoot </> (T.unpack webdriverName)
|
let webdriverRoot = runRoot </> (T.unpack webdriverName)
|
||||||
liftIO $ createDirectoryIfMissing True webdriverRoot
|
liftIO $ createDirectoryIfMissing True webdriverRoot
|
||||||
|
|
||||||
|
-- Directory to hold any downloads
|
||||||
let downloadDir = webdriverRoot </> "Downloads"
|
let downloadDir = webdriverRoot </> "Downloads"
|
||||||
liftIO $ createDirectoryIfMissing True downloadDir
|
liftIO $ createDirectoryIfMissing True downloadDir
|
||||||
|
|
||||||
@ -78,7 +64,7 @@ startWebDriver wdOptions@(WdOptions {..}) runRoot = do
|
|||||||
seleniumPath <- obtainSelenium toolsRoot seleniumToUse >>= \case
|
seleniumPath <- obtainSelenium toolsRoot seleniumToUse >>= \case
|
||||||
Left err -> error [i|Failed to obtain selenium: '#{err}'|]
|
Left err -> error [i|Failed to obtain selenium: '#{err}'|]
|
||||||
Right p -> return p
|
Right p -> return p
|
||||||
driverArgs <- case W.browser capabilities of
|
driverArgs <- case W.browser capabilities' of
|
||||||
W.Firefox {} -> do
|
W.Firefox {} -> do
|
||||||
obtainGeckoDriver toolsRoot geckoDriverToUse >>= \case
|
obtainGeckoDriver toolsRoot geckoDriverToUse >>= \case
|
||||||
Left err -> error [i|Failed to obtain geckodriver: '#{err}'|]
|
Left err -> error [i|Failed to obtain geckodriver: '#{err}'|]
|
||||||
@ -94,8 +80,6 @@ startWebDriver wdOptions@(WdOptions {..}) runRoot = do
|
|||||||
, [i|-Dwebdriver.chrome.verboseLogging=true|]]
|
, [i|-Dwebdriver.chrome.verboseLogging=true|]]
|
||||||
x -> error [i|Browser #{x} is not supported yet|]
|
x -> error [i|Browser #{x} is not supported yet|]
|
||||||
|
|
||||||
debug [i|driverArgs: #{driverArgs}|]
|
|
||||||
|
|
||||||
(maybeXvfbSession, javaEnv) <- case runMode of
|
(maybeXvfbSession, javaEnv) <- case runMode of
|
||||||
#ifndef mingw32_HOST_OS
|
#ifndef mingw32_HOST_OS
|
||||||
RunInXvfb (XvfbConfig {..}) -> do
|
RunInXvfb (XvfbConfig {..}) -> do
|
||||||
@ -104,65 +88,62 @@ startWebDriver wdOptions@(WdOptions {..}) runRoot = do
|
|||||||
#endif
|
#endif
|
||||||
_ -> return (Nothing, Nothing)
|
_ -> return (Nothing, Nothing)
|
||||||
|
|
||||||
|
-- Create a distinct process name
|
||||||
|
webdriverProcessName <- ("webdriver_process_" <>) <$> (liftIO makeUUID)
|
||||||
|
let webdriverProcessRoot = webdriverRoot </> T.unpack webdriverProcessName
|
||||||
|
liftIO $ createDirectoryIfMissing True webdriverProcessRoot
|
||||||
|
|
||||||
|
java <- askFile @"java"
|
||||||
|
-- seleniumJar <- askFile @"selenium.jar"
|
||||||
|
|
||||||
-- Retry up to 10 times
|
-- Retry up to 10 times
|
||||||
-- This is necessary because sometimes we get a race for the port we get from findFreePortOrException.
|
-- 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.
|
-- There doesn't seem to be any way to make Selenium choose its own port.
|
||||||
let policy = constantDelay 0 <> limitRetries 10
|
let policy = constantDelay 0 <> limitRetries 10
|
||||||
recoverAll policy $ \retryStatus -> do
|
(port, hRead, p) <- recoverAll policy $ \retryStatus -> do
|
||||||
when (rsIterNumber retryStatus > 0) $
|
when (rsIterNumber retryStatus > 0) $
|
||||||
warn [i|Trying again to start selenium server|]
|
warn [i|Trying again to start selenium server|]
|
||||||
|
|
||||||
-- Create a distinct process name
|
(hRead, hWrite) <- createPipe
|
||||||
webdriverProcessName <- ("webdriver_process_" <>) <$> (liftIO makeUUID)
|
port <- findFreePortOrException
|
||||||
let webdriverProcessRoot = webdriverRoot </> T.unpack webdriverProcessName
|
|
||||||
liftIO $ createDirectoryIfMissing True webdriverProcessRoot
|
|
||||||
startWebDriver' wdOptions webdriverName webdriverProcessRoot downloadDir seleniumPath driverArgs maybeXvfbSession javaEnv
|
|
||||||
|
|
||||||
startWebDriver' :: (
|
let allArgs = driverArgs <> ["-jar", seleniumPath
|
||||||
MonadLogger m, MonadUnliftIO m, MonadBaseControl IO m, MonadMask m
|
, "-port", show port]
|
||||||
) => WdOptions -> T.Text -> [Char] -> [Char] -> [Char] -> [String] -> Maybe XvfbSession -> Maybe [(String, String)] -> m WebDriver
|
let cp = (proc java allArgs) {
|
||||||
startWebDriver' wdOptions@(WdOptions {capabilities=capabilities', ..}) webdriverName webdriverRoot downloadDir seleniumPath driverArgs maybeXvfbSession javaEnv = do
|
env = javaEnv
|
||||||
port <- liftIO findFreePortOrException
|
, std_in = Inherit
|
||||||
let wdCreateProcess = (proc "java" (driverArgs <> ["-jar", seleniumPath
|
, std_out = UseHandle hWrite
|
||||||
, "-port", show port])) { env = javaEnv }
|
, std_err = UseHandle hWrite
|
||||||
|
, create_group = True
|
||||||
|
}
|
||||||
|
|
||||||
-- Open output handles
|
-- Start the process and wait for it to be ready
|
||||||
let seleniumOutPath = webdriverRoot </> seleniumOutFileName
|
debug [i|#{java} #{T.unwords $ fmap T.pack allArgs}|]
|
||||||
hout <- liftIO $ openFile seleniumOutPath AppendMode
|
|
||||||
let seleniumErrPath = webdriverRoot </> seleniumErrFileName
|
|
||||||
herr <- liftIO $ openFile seleniumErrPath AppendMode
|
|
||||||
|
|
||||||
-- Start the process and wait for it to be ready
|
(_, _, _, p) <- liftIO $ createProcess cp
|
||||||
debug [i|Starting the Selenium process|]
|
|
||||||
(_, _, _, p) <- liftIO $ createProcess $ wdCreateProcess {
|
|
||||||
std_in = Inherit
|
|
||||||
, std_out = UseHandle hout
|
|
||||||
, std_err = UseHandle herr
|
|
||||||
, create_group = 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 = "Selenium Server is up and running"
|
|
||||||
-- Retry every 60ms, for up to 60s before admitting defeat
|
|
||||||
let policy = constantDelay 60000 <> limitRetries 1000
|
|
||||||
success <- retrying policy (\_retryStatus result -> return (not result)) $ const $
|
|
||||||
liftIO (T.readFile seleniumErrPath) >>= \case
|
|
||||||
t | readyMessage `T.isInfixOf` t -> return True
|
|
||||||
_ -> liftIO (T.readFile seleniumOutPath) >>= \case
|
|
||||||
t | readyMessage `T.isInfixOf` t -> return True
|
|
||||||
_ -> return False
|
|
||||||
unless success $ liftIO $ do
|
|
||||||
_ <- interruptProcessGroupOf p >> waitForProcess p
|
|
||||||
error [i|Selenium server failed to start after 60 seconds|]
|
|
||||||
|
|
||||||
capabilities <- configureHeadlessCapabilities wdOptions runMode capabilities'
|
-- Read from the (combined) output stream until we see the up and running message,
|
||||||
>>= configureDownloadCapabilities downloadDir
|
-- or the process ends and we get an exception from hGetLine
|
||||||
|
fix $ \loop -> do
|
||||||
|
line <- fmap T.pack $ liftIO $ hGetLine hRead
|
||||||
|
debug line
|
||||||
|
|
||||||
|
if | "Selenium Server is up and running" `T.isInfixOf` line -> return ()
|
||||||
|
| otherwise -> loop
|
||||||
|
|
||||||
|
return (port, hRead, p)
|
||||||
|
|
||||||
|
-- TODO: save this in the WebDriver to tear it down later?
|
||||||
|
logAsync <- forever $ liftIO (hGetLine hRead) >>= (debug . T.pack)
|
||||||
|
|
||||||
|
-- Final extra capabilities configuration
|
||||||
|
capabilities <-
|
||||||
|
configureHeadlessCapabilities wdOptions runMode capabilities'
|
||||||
|
>>= configureDownloadCapabilities downloadDir
|
||||||
|
|
||||||
-- Make the WebDriver
|
-- Make the WebDriver
|
||||||
WebDriver <$> pure (T.unpack webdriverName)
|
WebDriver <$> pure (T.unpack webdriverName)
|
||||||
<*> pure (hout, herr, p, seleniumOutPath, seleniumErrPath, maybeXvfbSession)
|
<*> pure (p, maybeXvfbSession)
|
||||||
<*> pure wdOptions
|
<*> pure wdOptions
|
||||||
<*> liftIO (newMVar mempty)
|
<*> liftIO (newMVar mempty)
|
||||||
<*> pure (def { W.wdPort = fromIntegral port
|
<*> pure (def { W.wdPort = fromIntegral port
|
||||||
@ -172,106 +153,17 @@ startWebDriver' wdOptions@(WdOptions {capabilities=capabilities', ..}) webdriver
|
|||||||
})
|
})
|
||||||
<*> pure downloadDir
|
<*> pure downloadDir
|
||||||
|
|
||||||
-- | TODO: expose this as an option
|
|
||||||
gracePeriod :: Int
|
|
||||||
gracePeriod = 30000000
|
|
||||||
|
|
||||||
stopWebDriver :: Constraints m => WebDriver -> m ()
|
stopWebDriver :: Constraints m => WebDriver -> m ()
|
||||||
stopWebDriver (WebDriver {wdWebDriver=(hout, herr, h, _, _, maybeXvfbSession)}) = do
|
stopWebDriver (WebDriver {wdWebDriver=(h, maybeXvfbSession)}) = do
|
||||||
|
-- | TODO: expose this as an option
|
||||||
|
let gracePeriod :: Int
|
||||||
|
gracePeriod = 30000000
|
||||||
|
|
||||||
gracefullyStopProcess h gracePeriod
|
gracefullyStopProcess h gracePeriod
|
||||||
liftIO $ hClose hout
|
|
||||||
liftIO $ hClose herr
|
|
||||||
|
|
||||||
whenJust maybeXvfbSession $ \(XvfbSession {..}) -> do
|
whenJust maybeXvfbSession $ \(XvfbSession {..}) -> do
|
||||||
whenJust xvfbFluxboxProcess $ \p -> do
|
whenJust xvfbFluxboxProcess $ \p -> do
|
||||||
gracefullyStopProcess p gracePeriod
|
gracefullyStopProcess p gracePeriod
|
||||||
|
|
||||||
gracefullyStopProcess xvfbProcess gracePeriod
|
gracefullyStopProcess xvfbProcess gracePeriod
|
||||||
|
|
||||||
-- * Util
|
|
||||||
|
|
||||||
seleniumOutFileName, seleniumErrFileName :: FilePath
|
|
||||||
seleniumOutFileName = "stdout.txt"
|
|
||||||
seleniumErrFileName = "stderr.txt"
|
|
||||||
|
|
||||||
-- | Add headless configuration to the Chrome browser
|
|
||||||
configureHeadlessCapabilities :: Constraints m => WdOptions -> RunMode -> W.Capabilities -> m W.Capabilities
|
|
||||||
configureHeadlessCapabilities wdOptions (RunHeadless (HeadlessConfig {..})) caps@(W.Capabilities {W.browser=browser@(W.Chrome {..})}) = do
|
|
||||||
headlessArg <- liftIO (detectChromeVersion (chromeBinaryPath wdOptions)) >>= \case
|
|
||||||
Left err -> do
|
|
||||||
warn [i|Couldn't determine chrome version when configuring headless capabilities (err: #{err}); passing --headless|]
|
|
||||||
return "--headless"
|
|
||||||
Right (ChromeVersion (major, _, _, _))
|
|
||||||
-- See https://www.selenium.dev/blog/2023/headless-is-going-away/
|
|
||||||
| major >= 110 -> return "--headless=new"
|
|
||||||
| otherwise -> return "--headless"
|
|
||||||
|
|
||||||
let browser' = browser { W.chromeOptions = headlessArg:resolution:chromeOptions }
|
|
||||||
|
|
||||||
return (caps { W.browser = browser' })
|
|
||||||
|
|
||||||
where
|
|
||||||
resolution = [i|--window-size=#{w},#{h}|]
|
|
||||||
(w, h) = fromMaybe (1920, 1080) headlessResolution
|
|
||||||
|
|
||||||
-- | Add headless configuration to the Firefox capabilities
|
|
||||||
configureHeadlessCapabilities _ (RunHeadless (HeadlessConfig {})) caps@(W.Capabilities {W.browser=(W.Firefox {}), W.additionalCaps=ac}) = return (caps { W.additionalCaps = additionalCaps })
|
|
||||||
where
|
|
||||||
additionalCaps = case L.findIndex (\x -> fst x == "moz:firefoxOptions") ac of
|
|
||||||
Nothing -> ("moz:firefoxOptions", A.object [("args", A.Array ["-headless"])]) : ac
|
|
||||||
Just i' -> let ffOptions' = snd (ac !! i')
|
|
||||||
& ensureKeyExists "args" (A.Array [])
|
|
||||||
& ((key "args" . _Array) %~ addHeadlessArg) in
|
|
||||||
L.nubBy (\x y -> fst x == fst y) (("moz:firefoxOptions", ffOptions') : ac)
|
|
||||||
|
|
||||||
ensureKeyExists :: T.Text -> A.Value -> A.Value -> A.Value
|
|
||||||
ensureKeyExists key' _ val@(A.Object (HM.lookup (fromText key') -> Just _)) = val
|
|
||||||
ensureKeyExists key' defaultVal (A.Object m@(HM.lookup (fromText key') -> Nothing)) = A.Object (HM.insert (fromText key') defaultVal m)
|
|
||||||
ensureKeyExists _ _ _ = error "Expected Object in ensureKeyExists"
|
|
||||||
|
|
||||||
addHeadlessArg :: V.Vector A.Value -> V.Vector A.Value
|
|
||||||
addHeadlessArg xs | (A.String "-headless") `V.elem` xs = xs
|
|
||||||
addHeadlessArg xs = (A.String "-headless") `V.cons` xs
|
|
||||||
|
|
||||||
configureHeadlessCapabilities _ (RunHeadless {}) browser = error [i|Headless mode not yet supported for browser '#{browser}'|]
|
|
||||||
configureHeadlessCapabilities _ _ browser = return browser
|
|
||||||
|
|
||||||
|
|
||||||
configureDownloadCapabilities :: (
|
|
||||||
MonadIO m, MonadBaseControl IO m
|
|
||||||
) => [Char] -> W.Capabilities -> m W.Capabilities
|
|
||||||
configureDownloadCapabilities downloadDir caps@(W.Capabilities {W.browser=browser@(W.Firefox {..})}) = do
|
|
||||||
case ffProfile of
|
|
||||||
Nothing -> return ()
|
|
||||||
Just _ -> liftIO $ throwIO $ userError [i|Can't support Firefox profile yet.|]
|
|
||||||
|
|
||||||
profile <- FF.defaultProfile
|
|
||||||
& FF.addPref "browser.download.folderList" (2 :: Int)
|
|
||||||
& FF.addPref "browser.download.manager.showWhenStarting" False
|
|
||||||
& FF.addPref "browser.download.dir" downloadDir
|
|
||||||
& FF.addPref "browser.helperApps.neverAsk.saveToDisk" ("*" :: String)
|
|
||||||
& FF.prepareProfile
|
|
||||||
|
|
||||||
return (caps { W.browser = browser { W.ffProfile = Just profile } })
|
|
||||||
configureDownloadCapabilities downloadDir caps@(W.Capabilities {W.browser=browser@(W.Chrome {..})}) = return $ caps { W.browser=browser' }
|
|
||||||
where
|
|
||||||
browser' = browser { W.chromeExperimentalOptions = options }
|
|
||||||
|
|
||||||
basePrefs :: A.Object
|
|
||||||
basePrefs = case HM.lookup "prefs" chromeExperimentalOptions of
|
|
||||||
Just (A.Object hm) -> hm
|
|
||||||
Just x -> error [i|Expected chrome prefs to be object, got '#{x}'.|]
|
|
||||||
Nothing -> mempty
|
|
||||||
|
|
||||||
prefs :: A.Object
|
|
||||||
prefs = basePrefs
|
|
||||||
& foldl (.) id [HM.insert k v | (k, v) <- downloadPrefs]
|
|
||||||
|
|
||||||
options = HM.insert "prefs" (A.Object prefs) chromeExperimentalOptions
|
|
||||||
|
|
||||||
downloadPrefs = [("profile.default_content_setting_values.automatic_downloads", A.Number 1)
|
|
||||||
, ("profile.content_settings.exceptions.automatic_downloads.*.setting", A.Number 1)
|
|
||||||
, ("download.prompt_for_download", A.Bool False)
|
|
||||||
, ("download.directory_upgrade", A.Bool True)
|
|
||||||
, ("download.default_directory", A.String (T.pack downloadDir))]
|
|
||||||
configureDownloadCapabilities _ browser = return browser
|
|
||||||
|
@ -14,7 +14,6 @@ import qualified Data.Map as M
|
|||||||
import Data.String.Interpolate
|
import Data.String.Interpolate
|
||||||
import Data.Text as T
|
import Data.Text as T
|
||||||
import Network.HTTP.Client (Manager)
|
import Network.HTTP.Client (Manager)
|
||||||
import System.IO
|
|
||||||
import System.Process
|
import System.Process
|
||||||
import Test.Sandwich
|
import Test.Sandwich
|
||||||
import qualified Test.WebDriver as W
|
import qualified Test.WebDriver as W
|
||||||
@ -173,7 +172,7 @@ defaultWdOptions toolsRoot = WdOptions {
|
|||||||
|
|
||||||
data WebDriver = WebDriver {
|
data WebDriver = WebDriver {
|
||||||
wdName :: String
|
wdName :: String
|
||||||
, wdWebDriver :: (Handle, Handle, ProcessHandle, FilePath, FilePath, Maybe XvfbSession)
|
, wdWebDriver :: (ProcessHandle, Maybe XvfbSession)
|
||||||
, wdOptions :: WdOptions
|
, wdOptions :: WdOptions
|
||||||
, wdSessionMap :: MVar (M.Map Session W.WDSession)
|
, wdSessionMap :: MVar (M.Map Session W.WDSession)
|
||||||
, wdConfig :: W.WDConfig
|
, wdConfig :: W.WDConfig
|
||||||
@ -202,12 +201,12 @@ getWdOptions = wdOptions
|
|||||||
-- | Get the X11 display number associated with the 'WebDriver'.
|
-- | Get the X11 display number associated with the 'WebDriver'.
|
||||||
-- Only present if running in 'RunInXvfb' mode.
|
-- Only present if running in 'RunInXvfb' mode.
|
||||||
getDisplayNumber :: WebDriver -> Maybe Int
|
getDisplayNumber :: WebDriver -> Maybe Int
|
||||||
getDisplayNumber (WebDriver {wdWebDriver=(_, _, _, _, _, Just (XvfbSession {xvfbDisplayNum}))}) = Just xvfbDisplayNum
|
getDisplayNumber (WebDriver {wdWebDriver=(_, Just (XvfbSession {xvfbDisplayNum}))}) = Just xvfbDisplayNum
|
||||||
getDisplayNumber _ = Nothing
|
getDisplayNumber _ = Nothing
|
||||||
|
|
||||||
-- | Get the Xvfb session associated with the 'WebDriver', if present.
|
-- | Get the Xvfb session associated with the 'WebDriver', if present.
|
||||||
getXvfbSession :: WebDriver -> Maybe XvfbSession
|
getXvfbSession :: WebDriver -> Maybe XvfbSession
|
||||||
getXvfbSession (WebDriver {wdWebDriver=(_, _, _, _, _, Just sess)}) = Just sess
|
getXvfbSession (WebDriver {wdWebDriver=(_, Just sess)}) = Just sess
|
||||||
getXvfbSession _ = Nothing
|
getXvfbSession _ = Nothing
|
||||||
|
|
||||||
-- | Get the name of the 'WebDriver'.
|
-- | Get the name of the 'WebDriver'.
|
||||||
|
@ -65,7 +65,7 @@ setWindowFullScreen = do
|
|||||||
|
|
||||||
-- | Get the screen resolution as (x, y, width, height). (The x and y coordinates may be nonzero in multi-monitor setups.)
|
-- | Get the screen resolution as (x, y, width, height). (The x and y coordinates may be nonzero in multi-monitor setups.)
|
||||||
getScreenResolution :: (MonadIO m) => WebDriver -> m (Int, Int, Int, Int)
|
getScreenResolution :: (MonadIO m) => WebDriver -> m (Int, Int, Int, Int)
|
||||||
getScreenResolution (WebDriver {wdWebDriver=(_, _, _, _, _, maybeXvfbSession)}) = case maybeXvfbSession of
|
getScreenResolution (WebDriver {wdWebDriver=(_, maybeXvfbSession)}) = case maybeXvfbSession of
|
||||||
Nothing -> liftIO getResolution
|
Nothing -> liftIO getResolution
|
||||||
Just (XvfbSession {..}) -> liftIO $ getResolutionForDisplay xvfbDisplayNum
|
Just (XvfbSession {..}) -> liftIO $ getResolutionForDisplay xvfbDisplayNum
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user