diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,11 @@ # Changelog for sandwich-webdriver -# Unreleased +# 0.3.0.1 + +* Add more debugging statements to binary fetching. +* Fix getResolutionForDisplay on macOS. +* Pass --user-data-dir to chrome. +* Be able to pass --chrome-no-sandbox. # 0.3.0.0 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Tom McLaughlin (c) 2024 +Copyright Tom McLaughlin (c) 2025 All rights reserved. diff --git a/darwin-src/Test/Sandwich/WebDriver/Resolution.hs b/darwin-src/Test/Sandwich/WebDriver/Resolution.hs --- a/darwin-src/Test/Sandwich/WebDriver/Resolution.hs +++ b/darwin-src/Test/Sandwich/WebDriver/Resolution.hs @@ -5,6 +5,8 @@ ) where import Data.Word +import Foreign.C.Types +import Foreign.Ptr getResolution :: IO (Int, Int, Int, Int) @@ -13,22 +15,45 @@ getResolutionForDisplay (fromIntegral ddid) -- TODO: currently we just use the "main display" ID. --- When when we return 0 for x and y here, the WebDriver setWindowPos +-- When we return 0 for x and y here, the WebDriver setWindowPos -- should just position the window on the main display. -- This probably won't work at all for xvfb displays, but we have more work to do there... getResolutionForDisplay :: Int -> IO (Int, Int, Int, Int) getResolutionForDisplay ddid = do - width <- cg_display_pixels_wide (fromIntegral ddid) - height <- cg_display_pixels_high (fromIntegral ddid) + mode <- cg_display_copy_display_mode (fromIntegral ddid) + + -- This version gets the dimension in "points" (scaled pixels) + -- width <- cg_display_pixels_wide (fromIntegral ddid) + -- height <- cg_display_pixels_high (fromIntegral ddid) + + -- This version should always get the dimensions in actual non-scaled pixels + width <- cg_display_mode_get_pixel_width mode + height <- cg_display_mode_get_pixel_height mode + + -- We could actually use a combination of cg_display_pixels_wide and cg_display_mode_get_pixel_width to + -- get the scaling + return (0, 0, fromIntegral width, fromIntegral height) type CGDirectDisplayID = Word32 +data CGDisplayMode +type CGDisplayModeRef = Ptr CGDisplayMode + foreign import ccall unsafe " CGMainDisplayID" cg_main_display_id :: IO CGDirectDisplayID -foreign import ccall unsafe " CGDisplayPixelsWide" - cg_display_pixels_wide :: CGDirectDisplayID -> IO CGDirectDisplayID +-- foreign import ccall unsafe " CGDisplayPixelsWide" +-- cg_display_pixels_wide :: CGDirectDisplayID -> IO CGDirectDisplayID -foreign import ccall unsafe " CGDisplayPixelsHigh" - cg_display_pixels_high :: CGDirectDisplayID -> IO CGDirectDisplayID +-- foreign import ccall unsafe " CGDisplayPixelsHigh" +-- cg_display_pixels_high :: CGDirectDisplayID -> IO CGDirectDisplayID + +foreign import ccall unsafe "CGDisplayModeGetPixelWidth" + cg_display_mode_get_pixel_width :: CGDisplayModeRef -> IO CSize + +foreign import ccall unsafe "CGDisplayModeGetPixelHeight" + cg_display_mode_get_pixel_height :: CGDisplayModeRef -> IO CSize + +foreign import ccall unsafe "CGDisplayCopyDisplayMode" + cg_display_copy_display_mode :: CGDirectDisplayID -> IO CGDisplayModeRef diff --git a/sandwich-webdriver.cabal b/sandwich-webdriver.cabal --- a/sandwich-webdriver.cabal +++ b/sandwich-webdriver.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0. +-- This file has been generated from package.yaml by hpack version 0.38.0. -- -- see: https://github.com/sol/hpack name: sandwich-webdriver -version: 0.3.0.0 +version: 0.3.0.1 synopsis: Sandwich integration with Selenium WebDriver description: Please see the . category: Testing @@ -13,7 +13,7 @@ bug-reports: https://github.com/codedownio/sandwich/issues author: Tom McLaughlin maintainer: tom@codedown.io -copyright: 2024 Tom McLaughlin +copyright: 2025 Tom McLaughlin license: BSD3 license-file: LICENSE build-type: Simple @@ -100,6 +100,7 @@ , sandwich >=0.3.0.0 , sandwich-contexts >=0.3.0.0 , string-interpolate + , temporary , text , time , transformers @@ -136,8 +137,6 @@ Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb hs-source-dirs: unix-src - build-depends: - temporary test-suite sandwich-webdriver-test type: exitcode-stdio-1.0 @@ -186,6 +185,7 @@ , sandwich-contexts >=0.3.0.0 , sandwich-webdriver , string-interpolate + , temporary , text , time , transformers diff --git a/src/Test/Sandwich/WebDriver.hs b/src/Test/Sandwich/WebDriver.hs --- a/src/Test/Sandwich/WebDriver.hs +++ b/src/Test/Sandwich/WebDriver.hs @@ -247,4 +247,5 @@ Just Headless -> RunHeadless defaultHeadlessConfig Just Xvfb -> RunInXvfb (defaultXvfbConfig { xvfbStartFluxbox = optFluxbox }) Just Current -> Normal + , chromeNoSandbox = optChromeNoSandbox } diff --git a/src/Test/Sandwich/WebDriver/Internal/Binaries/Chrome.hs b/src/Test/Sandwich/WebDriver/Internal/Binaries/Chrome.hs --- a/src/Test/Sandwich/WebDriver/Internal/Binaries/Chrome.hs +++ b/src/Test/Sandwich/WebDriver/Internal/Binaries/Chrome.hs @@ -45,15 +45,24 @@ ) => ChromeToUse -> m (Either T.Text FilePath) obtainChrome UseChromeFromPath = do findExecutable "google-chrome" >>= \case - Just p -> return $ Right p + Just p -> do + debug [i|Found Chrome at #{p}|] + return $ Right p Nothing -> findExecutable "google-chrome-stable" >>= \case - Just p -> return $ Right p + Just p -> do + debug [i|Found Chrome at #{p}|] + return $ Right p Nothing -> expectationFailure [i|Couldn't find either "google-chrome" or "google-chrome-stable" on the PATH|] obtainChrome (UseChromeAt p) = doesFileExist p >>= \case False -> return $ Left [i|Path '#{p}' didn't exist|] - True -> return $ Right p -obtainChrome (UseChromeFromNixpkgs nixContext) = - Right <$> getBinaryViaNixPackage' @"google-chrome-stable" nixContext "google-chrome" + True -> do + debug [i|Found Chrome at #{p}|] + return $ Right p +obtainChrome (UseChromeFromNixpkgs nixContext) = do + debug [i|Building Chrome with Nix...|] + ret <- getBinaryViaNixPackage' @"google-chrome-stable" nixContext "google-chrome" + debug [i|Built Chrome: #{ret}|] + return $ Right ret -- | Manually obtain a @chromedriver@ binary, according to the 'ChromeDriverToUse' policy. obtainChromeDriver :: ( @@ -65,26 +74,39 @@ -> m (Either T.Text FilePath) obtainChromeDriver (DownloadChromeDriverFrom toolsDir url) = do let path = [i|#{toolsDir}/#{chromeDriverExecutable}|] - unlessM (liftIO $ doesFileExist path) $ - curlDownloadToPath url path + doesFileExist path >>= \case + True -> do + debug [i|chromedriver already existed at #{path}|] + False -> do + debug [i|Downloading chromedriver from #{url}...|] + curlDownloadToPath url path + debug [i|Downloaded chromedriver to #{path}|] return $ Right path obtainChromeDriver (DownloadChromeDriverVersion toolsDir chromeDriverVersion) = runExceptT $ do let path = getChromeDriverPath toolsDir chromeDriverVersion liftIO (doesFileExist path) >>= \case - True -> return path + True -> do + debug [i|Found chromedriver at #{path}|] + return path False -> do - let downloadPath = getChromeDriverDownloadUrl chromeDriverVersion detectPlatform - ExceptT $ downloadAndUnzipToPath downloadPath path + let downloadUrl = getChromeDriverDownloadUrl chromeDriverVersion detectPlatform + debug [i|Downloading chromedriver from #{downloadUrl}...|] + ExceptT $ downloadAndUnzipToPath downloadUrl path + debug [i|Downloaded chromedriver to #{path}|] return path obtainChromeDriver (DownloadChromeDriverAutodetect toolsDir chromePath) = runExceptT $ do version <- ExceptT $ liftIO $ getChromeDriverVersion chromePath ExceptT $ obtainChromeDriver (DownloadChromeDriverVersion toolsDir version) obtainChromeDriver (UseChromeDriverAt path) = doesFileExist path >>= \case False -> return $ Left [i|Path '#{path}' didn't exist|] - True -> return $ Right path -obtainChromeDriver (UseChromeDriverFromNixpkgs nixContext) = - Right <$> getBinaryViaNixPackage' @"chromedriver" nixContext "chromedriver" - + True -> do + debug [i|Found chromedriver at #{path}|] + return $ Right path +obtainChromeDriver (UseChromeDriverFromNixpkgs nixContext) = do + debug [i|Building chromedriver with Nix|] + ret <- getBinaryViaNixPackage' @"chromedriver" nixContext "chromedriver" + debug [i|Built chromedriver: #{ret}|] + return $ Right ret downloadChromeDriverIfNecessary' :: Constraints m => FilePath -> ChromeDriverVersion -> m (Either T.Text FilePath) downloadChromeDriverIfNecessary' toolsDir chromeDriverVersion = runExceptT $ do diff --git a/src/Test/Sandwich/WebDriver/Internal/Binaries/DetectPlatform.hs b/src/Test/Sandwich/WebDriver/Internal/Binaries/DetectPlatform.hs --- a/src/Test/Sandwich/WebDriver/Internal/Binaries/DetectPlatform.hs +++ b/src/Test/Sandwich/WebDriver/Internal/Binaries/DetectPlatform.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} module Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform ( detectPlatform @@ -9,7 +8,8 @@ import qualified System.Info as SI -data Platform = Linux | OSX | Windows deriving (Show, Eq) +data Platform = Linux | OSX | Windows + deriving (Show, Eq) detectPlatform :: Platform detectPlatform = case SI.os of diff --git a/src/Test/Sandwich/WebDriver/Internal/Binaries/Ffmpeg.hs b/src/Test/Sandwich/WebDriver/Internal/Binaries/Ffmpeg.hs --- a/src/Test/Sandwich/WebDriver/Internal/Binaries/Ffmpeg.hs +++ b/src/Test/Sandwich/WebDriver/Internal/Binaries/Ffmpeg.hs @@ -8,7 +8,6 @@ , FfmpegToUse(..) ) where -import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Unlift import Control.Monad.Logger import Control.Monad.Reader @@ -23,17 +22,23 @@ -- | Manually obtain an ffmpeg binary, according to the 'FfmpegToUse' policy. obtainFfmpeg :: ( MonadReader context m, HasBaseContext context - , MonadUnliftIO m, MonadLoggerIO m, MonadMask m + , MonadUnliftIO m, MonadLoggerIO m ) => FfmpegToUse -> m (Either T.Text FilePath) obtainFfmpeg UseFfmpegFromPath = findExecutable "ffmpeg" >>= \case Nothing -> return $ Left [i|Couldn't find "ffmpeg" on the PATH.|] - Just p -> return $ Right p + Just p -> do + debug [i|Found ffmpeg at #{p}|] + return $ Right p obtainFfmpeg (UseFfmpegAt path) = doesFileExist path >>= \case False -> return $ Left [i|Path '#{path}' didn't exist|] - True -> return $ Right path -obtainFfmpeg (UseFfmpegFromNixpkgs nixContext) = - Right <$> getBinaryViaNixDerivation' @"ffmpeg" nixContext ffmpegDerivation - + True -> do + debug [i|Found ffmpeg at #{path}|] + return $ Right path +obtainFfmpeg (UseFfmpegFromNixpkgs nixContext) = do + debug [i|Building ffmpeg with Nix...|] + ret <- getBinaryViaNixDerivation' @"ffmpeg" nixContext ffmpegDerivation + debug [i|Built ffmpeg with Nix: #{ret}|] + return $ Right ret ffmpegDerivation :: T.Text ffmpegDerivation = [i| diff --git a/src/Test/Sandwich/WebDriver/Internal/Binaries/Firefox.hs b/src/Test/Sandwich/WebDriver/Internal/Binaries/Firefox.hs --- a/src/Test/Sandwich/WebDriver/Internal/Binaries/Firefox.hs +++ b/src/Test/Sandwich/WebDriver/Internal/Binaries/Firefox.hs @@ -34,13 +34,26 @@ ) => FirefoxToUse -> m (Either T.Text FilePath) obtainFirefox UseFirefoxFromPath = do findExecutable "firefox" >>= \case - Just p -> return $ Right p + Just p -> do + debug [i|Found firefox: #{p}|] + return $ Right p Nothing -> expectationFailure [i|Couldn't find "firefox" on the PATH|] obtainFirefox (UseFirefoxAt p) = doesFileExist p >>= \case False -> return $ Left [i|Path '#{p}' didn't exist|] - True -> return $ Right p -obtainFirefox (UseFirefoxFromNixpkgs nixContext) = - Right <$> getBinaryViaNixPackage' @"firefox" nixContext "firefox" + True -> do + debug [i|Found firefox: #{p}|] + return $ Right p +obtainFirefox (UseFirefoxFromNixpkgs nixContext) = do + debug [i|Building Firefox with Nix|] + -- ret <- case os of + -- "darwin" -> + -- -- The only Firefox version that currently works on Darwin as of 5/5/2025 is firefox-bin + -- buildNixPackage' nixContext "firefox-bin" >>= (liftIO . defaultFindFile "firefox") + -- _ -> + -- getBinaryViaNixPackage' @"firefox" nixContext "firefox" + ret <- getBinaryViaNixPackage' @"firefox" nixContext "firefox" + debug [i|Built Firefox: #{ret}|] + return $ Right ret -- | Manually obtain a @geckodriver@ binary, according to the 'GeckoDriverToUse' policy, -- storing it under the provided 'FilePath' if necessary and returning the exact path. @@ -53,23 +66,35 @@ -> m (Either T.Text FilePath) obtainGeckoDriver (DownloadGeckoDriverFrom toolsDir url) = do let path = [i|#{toolsDir}/#{geckoDriverExecutable}|] - unlessM (liftIO $ doesFileExist path) $ - curlDownloadToPath url path + doesFileExist path >>= \case + True -> do + debug [i|GeckoDriver already existed at #{path}|] + False -> do + debug [i|Downloading GeckoDriver from #{url}...|] + curlDownloadToPath url path + debug [i|Downloaded GeckoDriver to #{path}|] return $ Right path obtainGeckoDriver (DownloadGeckoDriverVersion toolsDir geckoDriverVersion) = runExceptT $ do let path = getGeckoDriverPath toolsDir geckoDriverVersion - liftIO (doesFileExist path) >>= \case - True -> return path + doesFileExist path >>= \case + True -> do + debug [i|GeckoDriver already existed at #{path}|] + return path False -> do - let downloadPath = getGeckoDriverDownloadUrl geckoDriverVersion detectPlatform - ExceptT $ downloadAndUntarballToPath downloadPath path + let downloadUrl = getGeckoDriverDownloadUrl geckoDriverVersion detectPlatform + debug [i|Downloading GeckoDriver from #{downloadUrl}|] + ExceptT $ downloadAndUntarballToPath downloadUrl path + debug [i|Downloaded GeckoDriver to #{path}|] return path obtainGeckoDriver (DownloadGeckoDriverAutodetect toolsDir) = runExceptT $ do version <- ExceptT $ liftIO $ getGeckoDriverVersion Nothing + debug [i|Trying to obtain GeckoDriver version #{version} (autodetected)|] ExceptT $ obtainGeckoDriver (DownloadGeckoDriverVersion toolsDir version) obtainGeckoDriver (UseGeckoDriverAt path) = liftIO (doesFileExist path) >>= \case False -> return $ Left [i|Path '#{path}' didn't exist|] - True -> return $ Right path + True -> do + debug [i|Found GeckoDriver at #{path}|] + return $ Right path obtainGeckoDriver (UseGeckoDriverFromNixpkgs nixContext) = Right <$> getBinaryViaNixPackage' @"geckodriver" nixContext "geckodriver" diff --git a/src/Test/Sandwich/WebDriver/Internal/Binaries/Selenium.hs b/src/Test/Sandwich/WebDriver/Internal/Binaries/Selenium.hs --- a/src/Test/Sandwich/WebDriver/Internal/Binaries/Selenium.hs +++ b/src/Test/Sandwich/WebDriver/Internal/Binaries/Selenium.hs @@ -15,13 +15,13 @@ import Data.String.Interpolate import qualified Data.Text as T import GHC.Stack -import System.Directory import Test.Sandwich import Test.Sandwich.Contexts.Files import Test.Sandwich.Contexts.Nix import Test.Sandwich.WebDriver.Internal.Binaries.Common import Test.Sandwich.WebDriver.Internal.Binaries.Selenium.Types import Test.Sandwich.WebDriver.Internal.Util +import UnliftIO.Directory type Constraints m = ( @@ -46,24 +46,35 @@ -> m FilePath obtainSelenium (DownloadSeleniumFrom toolsDir url) = do let path = [i|#{toolsDir}/selenium-server-standalone.jar|] - unlessM (liftIO $ doesFileExist path) $ - curlDownloadToPath url path + doesFileExist path >>= \case + True -> do + debug [i|Selenium already existed at #{path}|] + False -> do + debug [i|Downloading Selenium from #{url} to #{path}|] + curlDownloadToPath url path return path obtainSelenium (DownloadSeleniumDefault toolsDir) = do let path = [i|#{toolsDir}/selenium-server-standalone-3.141.59.jar|] - unlessM (liftIO $ doesFileExist path) $ - curlDownloadToPath defaultSeleniumJarUrl path + doesFileExist path >>= \case + True -> do + debug [i|Selenium already existed at #{path}|] + False -> do + debug [i|Downloading Selenium from #{defaultSeleniumJarUrl} to #{path}|] + curlDownloadToPath defaultSeleniumJarUrl path return path obtainSelenium (UseSeleniumAt path) = liftIO (doesFileExist path) >>= \case False -> expectationFailure [i|Path '#{path}' didn't exist|] - True -> return path + True -> do + debug [i|Found Selenium at #{path}|] + return path obtainSelenium (UseSeleniumFromNixpkgs nixContext) = do - buildNixSymlinkJoin' nixContext ["selenium-server-standalone"] >>= + debug [i|Building selenium-server-standalone with Nix...|] + ret <- buildNixSymlinkJoin' nixContext ["selenium-server-standalone"] >>= liftIO . findFirstFile (return . (".jar" `L.isSuffixOf`)) - + debug [i|Got Selenium: #{ret}|] + return ret -- * Lower level helpers - downloadSeleniumIfNecessary :: Constraints m => FilePath -> m (Either T.Text FilePath) downloadSeleniumIfNecessary toolsDir = leftOnException' $ do diff --git a/src/Test/Sandwich/WebDriver/Internal/Binaries/Xvfb.hs b/src/Test/Sandwich/WebDriver/Internal/Binaries/Xvfb.hs --- a/src/Test/Sandwich/WebDriver/Internal/Binaries/Xvfb.hs +++ b/src/Test/Sandwich/WebDriver/Internal/Binaries/Xvfb.hs @@ -28,10 +28,17 @@ ) => XvfbToUse -> m (Either T.Text FilePath) obtainXvfb UseXvfbFromPath = findExecutable "Xvfb" >>= \case Nothing -> return $ Left [i|Couldn't find "Xvfb" on the PATH.|] - Just p -> return $ Right p + Just p -> do + debug [i|Found Xvfb at #{p}|] + return $ Right p obtainXvfb (UseXvfbAt path) = doesFileExist path >>= \case False -> return $ Left [i|Path '#{path}' didn't exist|] - True -> return $ Right path -obtainXvfb (UseXvfbFromNixpkgs nixContext) = + True -> do + debug [i|Found Xvfb at #{path}|] + return $ Right path +obtainXvfb (UseXvfbFromNixpkgs nixContext) = do -- Note: on master *after* release-24.05, there seems to be xorg.xvfb - Right <$> getBinaryViaNixPackage' @"Xvfb" nixContext "xorg.xorgserver" + debug [i|Building Xvfb with Nix|] + ret <- getBinaryViaNixPackage' @"Xvfb" nixContext "xorg.xorgserver" + debug [i|Built Xvfb: #{ret}|] + return $ Right ret diff --git a/src/Test/Sandwich/WebDriver/Internal/Capabilities/Extra.hs b/src/Test/Sandwich/WebDriver/Internal/Capabilities/Extra.hs --- a/src/Test/Sandwich/WebDriver/Internal/Capabilities/Extra.hs +++ b/src/Test/Sandwich/WebDriver/Internal/Capabilities/Extra.hs @@ -5,6 +5,9 @@ module Test.Sandwich.WebDriver.Internal.Capabilities.Extra ( configureHeadlessCapabilities , configureDownloadCapabilities + + , configureChromeUserDataDir + , configureChromeNoSandbox ) where import Control.Monad.Catch (MonadMask) @@ -21,6 +24,7 @@ import GHC.Stack import Lens.Micro import Lens.Micro.Aeson +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(..)) @@ -122,9 +126,37 @@ 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))] + 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 + +-- | chromedriver >= 131 started showing the following error: +-- "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 a regression of some kind, but a fix is to explicitly pass a distinct user data dir. +configureChromeUserDataDir :: (Constraints m, HasBaseContextMonad context m, MonadFail m) => W.Capabilities -> m W.Capabilities +configureChromeUserDataDir caps@(W.Capabilities {W.browser=browser@(W.Chrome {..})}) = do + Just dir <- getCurrentFolder + userDataDir <- liftIO $ createTempDirectory dir "chrome-user-data-dir" + let arg = [i|--user-data-dir=#{userDataDir}|] + let browser' = browser { W.chromeOptions = arg:chromeOptions } + return (caps { W.browser = browser' }) +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, HasBaseContextMonad context m, MonadFail m) => WdOptions -> W.Capabilities -> m W.Capabilities +configureChromeNoSandbox (WdOptions {chromeNoSandbox=True}) caps@(W.Capabilities {W.browser=browser@(W.Chrome {..})}) = do + let browser' = browser { W.chromeOptions = "--no-sandbox":chromeOptions } + return (caps { W.browser = browser' }) +configureChromeNoSandbox _ caps = return caps diff --git a/src/Test/Sandwich/WebDriver/Internal/Dependencies.hs b/src/Test/Sandwich/WebDriver/Internal/Dependencies.hs --- a/src/Test/Sandwich/WebDriver/Internal/Dependencies.hs +++ b/src/Test/Sandwich/WebDriver/Internal/Dependencies.hs @@ -101,16 +101,20 @@ type HasBrowserDependencies context = HasLabel context "browserDependencies" BrowserDependencies getBrowserDependencies :: ( - MonadUnliftIO m, MonadLogger m - , MonadReader context m, HasBaseContext context + MonadReader context m, HasBaseContext context + , MonadUnliftIO m, MonadLogger m ) => BrowserDependenciesSpec -> m BrowserDependencies getBrowserDependencies BrowserDependenciesSpecChrome {..} = do chrome <- exceptionOnLeft $ obtainChrome browserDependenciesSpecChromeChrome chromeDriver <- exceptionOnLeft $ obtainChromeDriver browserDependenciesSpecChromeChromeDriver + info [i|chrome: #{chrome}|] + info [i|chromedriver: #{chromeDriver}|] return $ BrowserDependenciesChrome chrome chromeDriver getBrowserDependencies (BrowserDependenciesSpecFirefox {..}) = do firefox <- exceptionOnLeft $ obtainFirefox browserDependenciesSpecFirefoxFirefox geckoDriver <- exceptionOnLeft $ obtainGeckoDriver browserDependenciesSpecFirefoxGeckodriver + info [i|firefox: #{firefox}|] + info [i|geckodriver: #{geckoDriver}|] return $ BrowserDependenciesFirefox firefox geckoDriver -- | Introduce 'BrowserDependencies' via Nix, using the command line options. @@ -141,15 +145,23 @@ let useChrome = BrowserDependenciesChrome <$> getBinaryViaNixPackage @"google-chrome-stable" "google-chrome" <*> getBinaryViaNixPackage @"chromedriver" "chromedriver" + -- let useFirefox = case os of + -- "darwin" -> do + -- -- The only Firefox version that currently works on Darwin as of 5/5/2025 is firefox-bin + -- firefox <- buildNixPackage "firefox-bin" >>= (liftIO . defaultFindFile "firefox") + -- BrowserDependenciesFirefox firefox <$> getBinaryViaNixPackage @"geckodriver" "geckodriver" + -- _ -> BrowserDependenciesFirefox <$> getBinaryViaNixPackage @"firefox" "firefox" + -- <*> getBinaryViaNixPackage @"geckodriver" "geckodriver" + let useFirefox = BrowserDependenciesFirefox <$> getBinaryViaNixPackage @"firefox" "firefox" <*> getBinaryViaNixPackage @"geckodriver" "geckodriver" - deps <- case optFirefox of + deps <- case optBrowserToUse of Just UseChrome -> useChrome Just UseFirefox -> useFirefox Nothing -> useChrome - debug [i|Got browser dependencies: #{deps}|] + info [i|Got browser dependencies: #{deps}|] return deps diff --git a/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs b/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs --- a/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs +++ b/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs @@ -13,7 +13,7 @@ import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Logger -import Control.Monad.Reader +import Control.Monad.Reader (MonadReader) import Control.Retry import Data.Default import Data.Function (fix) @@ -137,7 +137,10 @@ -- Final extra capabilities configuration capabilities <- - configureHeadlessCapabilities wdOptions runMode capabilities' + pure capabilities' + >>= configureChromeNoSandbox wdOptions + >>= configureChromeUserDataDir + >>= configureHeadlessCapabilities wdOptions runMode >>= configureDownloadCapabilities downloadDir -- Make the WebDriver diff --git a/src/Test/Sandwich/WebDriver/Internal/Types.hs b/src/Test/Sandwich/WebDriver/Internal/Types.hs --- a/src/Test/Sandwich/WebDriver/Internal/Types.hs +++ b/src/Test/Sandwich/WebDriver/Internal/Types.hs @@ -64,6 +64,9 @@ , httpRetryCount :: Int -- ^ Number of times to retry an HTTP request if it times out. + + , chromeNoSandbox :: Bool + -- ^ Pass the --no-sandbox flag to Chrome (useful in GitHub Actions when installing Chrome via Nix). } -- | How to obtain certain binaries "on demand". These may or not be needed based on 'WdOptions', so @@ -111,6 +114,7 @@ , runMode = Normal , httpManager = Nothing , httpRetryCount = 0 + , chromeNoSandbox = False } data OnDemand a = diff --git a/src/Test/Sandwich/WebDriver/Types.hs b/src/Test/Sandwich/WebDriver/Types.hs --- a/src/Test/Sandwich/WebDriver/Types.hs +++ b/src/Test/Sandwich/WebDriver/Types.hs @@ -6,7 +6,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Test.Sandwich.WebDriver.Types ( - -- * Type aliases to make signatures shorter + -- * Type aliases to make signatures shorter. BaseMonad , ContextWithWebdriverDeps , ContextWithBaseDeps diff --git a/src/Test/Sandwich/WebDriver/Video.hs b/src/Test/Sandwich/WebDriver/Video.hs --- a/src/Test/Sandwich/WebDriver/Video.hs +++ b/src/Test/Sandwich/WebDriver/Video.hs @@ -34,8 +34,8 @@ import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Logger hiding (logError) -import Control.Monad.Reader -import Data.Function +import Control.Monad.Reader (MonadReader) +import Data.Function (fix) import Data.String.Interpolate import System.Exit import System.FilePath diff --git a/src/Test/Sandwich/WebDriver/Video/Internal.hs b/src/Test/Sandwich/WebDriver/Video/Internal.hs --- a/src/Test/Sandwich/WebDriver/Video/Internal.hs +++ b/src/Test/Sandwich/WebDriver/Video/Internal.hs @@ -11,7 +11,6 @@ import Control.Monad.Logger import Control.Monad.Reader import Data.String.Interpolate -import System.FilePath import System.Process import Test.Sandwich import Test.Sandwich.WebDriver.Internal.Binaries.Ffmpeg @@ -29,6 +28,7 @@ import Data.Function ((&), on) import qualified Data.List as L import Data.Maybe +import System.FilePath ((<.>)) import UnliftIO.Environment #endif diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -6,28 +6,35 @@ import UnliftIO.Temporary import Data.Time.Clock import Data.String.Interpolate +import Test.Sandwich.Contexts.Nix +import System.FilePath +import Test.WebDriver.Commands +import Test.Sandwich.WebDriver +import Control.Monad.IO.Class +import qualified Data.ByteString.Lazy as BL -spec :: TopSpec -spec = do - it "works" $ do - 2 `shouldBe` 2 +-- We use nixpkgsRelease2405 here, because Chrome/chromedriver > 131 seems to have a bug where we get +-- a message like this in CI: +-- +-- 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 - -- it "successfully runs obtainChromeDriver" $ do - -- withSystemTempDirectory "test-download" $ \dir -> do - -- obtainChromeDriver dir (DownloadChromeDriverAutodetect Nothing) >>= \case - -- Right x -> info [i|Got chromedriver: #{x}|] - -- Left err -> expectationFailure (T.unpack err) +spec :: TopSpecWithOptions +spec = introduceNixContext (nixpkgsRelease2405 { nixpkgsDerivationAllowUnfree = True }) $ + introduceWebDriverViaNix defaultWdOptions $ do + it "opens Google and searches" $ withSession1 $ do + openPage [i|https://www.google.com|] + search <- findElem (ByCSS [i|*[title="Search"]|]) + click search + sendKeys "Haskell Sandwich" search + findElem (ByCSS [i|input[type="submit"]|]) >>= click - -- it "successfully runs obtainGeckoDriver" $ do - -- withSystemTempDirectory "test-download" $ \dir -> do - -- obtainGeckoDriver dir (DownloadGeckoDriverAutodetect Nothing) >>= \case - -- Right x -> info [i|Got geckoDriver: #{x}|] - -- Left err -> expectationFailure (T.unpack err) + Just dir <- getCurrentFolder + screenshot >>= liftIO . BL.writeFile (dir "screenshot.png") main :: IO () -main = runSandwich options spec +main = runSandwichWithCommandLineArgs options spec where options = defaultOptions { optionsTestArtifactsDirectory = defaultTestArtifactsDirectory