Extra.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE OverloadedLists #-}

module Test.Sandwich.WebDriver.Internal.Capabilities.Extra (
  configureHeadlessChromeCapabilities
  , configureHeadlessFirefoxCapabilities
  , configureChromeDownloadCapabilities
  , configureFirefoxDownloadCapabilities

  , configureChromeUserDataDir
  , configureChromeNoSandbox
  ) where

import Control.Monad.Catch (MonadMask)
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Control.Monad.Logger
import qualified Data.Aeson as A
import Data.Function
import Data.Maybe
import Data.String.Interpolate
import qualified Data.Text as T
import GHC.Stack
import Lens.Micro
import System.IO.Temp
import Test.Sandwich
import Test.Sandwich.WebDriver.Internal.Binaries.Chrome.Detect (detectChromeVersion)
import Test.Sandwich.WebDriver.Internal.Binaries.Chrome.Types (ChromeVersion(..))
import Test.Sandwich.WebDriver.Internal.Types
import Test.WebDriver.Capabilities as W
import Test.WebDriver.Profile


#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap          as HM
#else
import qualified Data.HashMap.Strict        as HM
#endif


type Constraints m = (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadMask m)

-- | Add headless configuration to the Chrome browser
configureHeadlessChromeCapabilities :: (Constraints m) => WdOptions -> RunMode -> W.Capabilities -> m W.Capabilities
configureHeadlessChromeCapabilities _wdOptions (RunHeadless (HeadlessConfig {..})) caps@(W.Capabilities {_capabilitiesGoogChromeOptions=(Just chromeOptions)}) = do
  chromeBinaryPath <- case W._chromeOptionsBinary chromeOptions of
    Nothing -> expectationFailure [i|Chrome capabilities didn't define chromeBinary in configureHeadlessCapabilities|]
    Just x -> pure x

  headlessArg <- liftIO (detectChromeVersion chromeBinaryPath) >>= \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 finalChromeOptions = chromeOptions
                         & over chromeOptionsArgs (Just . (\x -> headlessArg:resolution:x) . fromMaybe [])

  return (caps { W._capabilitiesGoogChromeOptions = Just finalChromeOptions })

  where
    resolution = [i|--window-size=#{w},#{h}|]
    (w, h) = fromMaybe (1920, 1080) headlessResolution
configureHeadlessChromeCapabilities _ _ browser = return browser

-- | Add headless configuration to the Firefox capabilities
configureHeadlessFirefoxCapabilities :: (Constraints m) => WdOptions -> RunMode -> W.Capabilities -> m W.Capabilities
configureHeadlessFirefoxCapabilities _ (RunHeadless (HeadlessConfig {})) caps@(W.Capabilities {_capabilitiesMozFirefoxOptions=(Just firefoxOptions)}) =
  return (caps { W._capabilitiesMozFirefoxOptions = Just finalFirefoxOptions })
  where
    finalFirefoxOptions = firefoxOptions
                        & over firefoxOptionsArgs (Just . (\x -> headlessArg:x) . fromMaybe [])

    headlessArg = "-headless"
configureHeadlessFirefoxCapabilities _ _ browser = return browser


-- | Configure download capabilities to set the download directory and disable prompts
-- (since you can't test download prompts using Selenium)
configureChromeDownloadCapabilities :: Monad m => String -> Capabilities -> m Capabilities
configureChromeDownloadCapabilities downloadDir caps@(W.Capabilities {_capabilitiesGoogChromeOptions=(Just chromeOptions)}) =
  return $ caps { W._capabilitiesGoogChromeOptions=(Just finalChromeOptions) }
  where
    finalChromeOptions = chromeOptions
                       & set chromeOptionsPrefs (Just prefs)

    prefs :: A.Object
    prefs = basePrefs
          & foldl (.) id [HM.insert k v | (k, v) <- downloadPrefs]

    basePrefs :: A.Object
    basePrefs = case HM.lookup "prefs" (fromMaybe mempty (W._chromeOptionsPrefs chromeOptions)) of
      Just (A.Object hm) -> hm
      Just x -> error [i|Expected chrome prefs to be object, got '#{x}'.|]
      Nothing -> mempty

    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))
      ]
configureChromeDownloadCapabilities _ browser = return browser

-- | Configure download capabilities to set the download directory and disable prompts
-- (since you can't test download prompts using Selenium)
configureFirefoxDownloadCapabilities :: (
  MonadIO m
  ) => [Char] -> W.Capabilities -> m W.Capabilities
configureFirefoxDownloadCapabilities downloadDir caps@(W.Capabilities {_capabilitiesMozFirefoxOptions=(Just firefoxOptions)}) = do
  profile <- case W._firefoxOptionsProfile firefoxOptions of
    Just x -> pure x
    Nothing -> pure $ defaultFirefoxProfile
      & addPref "browser.download.folderList" (2 :: Int)
      & addPref "browser.download.manager.showWhenStarting" False
      & addPref "browser.download.dir" downloadDir
      & addPref "browser.helperApps.neverAsk.saveToDisk" ("*" :: String)

  let finalFirefoxOptions = firefoxOptions
                          & set firefoxOptionsProfile (Just profile)

  return (caps { W._capabilitiesMozFirefoxOptions = Just finalFirefoxOptions  })
configureFirefoxDownloadCapabilities _ browser = return browser

-- | Pass the @--user-data-dir@ argument to Chrome, putting the directory inside
-- the test tree. This is usually better than allowing tests to leave stuff in
-- /tmp etc.
--
-- Note that chromedriver sometimes reports an error like the following:
-- "session not created: probably user data directory is already in use, please
-- specify a unique value for --user-data-dir argument, or don't use
-- --user-data-dir".
--
-- This is usually a red herring, chromedriver seems to report it whenever the
-- browser fails to start up for whatever reason.
configureChromeUserDataDir :: (Constraints m, HasBaseContextMonad context m, MonadFail m) => W.Capabilities -> m W.Capabilities
configureChromeUserDataDir caps@(W.Capabilities {_capabilitiesGoogChromeOptions=(Just chromeOptions)}) = do
  Just dir <- getCurrentFolder
  userDataDir <- liftIO $ createTempDirectory dir "chrome-user-data-dir"
  let arg = [i|--user-data-dir=#{userDataDir}|]
  let finalChromeOptions = chromeOptions
                         & over chromeOptionsArgs (Just . (arg :) . fromMaybe [])
  return (caps { W._capabilitiesGoogChromeOptions = Just finalChromeOptions })
configureChromeUserDataDir caps = return caps


-- | This is to make it possible to use Chrome installed by Nix, avoiding errors like this:
--
-- [76593:76593:0608/101002.800744:FATAL:setuid_sandbox_host.cc(163)] The SUID sandbox helper binary was found,
-- but is not configured correctly. Rather than run without sandboxing I'm aborting now. You need to make sure
-- that /nix/store/6sshf2mnzfy72sqr7k9f2mi36ccczr9a-google-chrome-130.0.6723.91/share/google/chrome/chrome-sandbox
-- is owned by root and has mode 4755.
configureChromeNoSandbox :: (Constraints m) => WdOptions -> W.Capabilities -> m W.Capabilities
configureChromeNoSandbox (WdOptions {chromeNoSandbox=True}) caps@(W.Capabilities {_capabilitiesGoogChromeOptions=(Just chromeOptions)}) = do
  let arg = "--no-sandbox"
  let finalChromeOptions = chromeOptions
                         & over chromeOptionsArgs (Just . (arg :) . fromMaybe [])
  return (caps { W._capabilitiesGoogChromeOptions = Just finalChromeOptions })
configureChromeNoSandbox _ caps = return caps