diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,15 @@ # Changelog for sandwich-webdriver +# 0.5.0.0 + +* Support `webdriver-0.15.0.0`. +* BREAKING CHANGE: remove `capabilities` from `WdOptions`; use `modifyCapabilities` to adjust capabilities before session creation. +* Add `getWdCapabilities` accessor. +* Add debug logging to `setWindow*` functions. +* Remove Chrome user data dirs created in the test artifacts tree. +* Use the latest `sandwich` process file logging and managed asyncs. +* Put geckodriver --profile-root at run root to deal with long path issues. + # 0.4.0.2 * Support `webdriver-0.14.0.0`. diff --git a/sandwich-webdriver.cabal b/sandwich-webdriver.cabal --- a/sandwich-webdriver.cabal +++ b/sandwich-webdriver.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: sandwich-webdriver -version: 0.4.0.2 +version: 0.5.0.0 synopsis: Sandwich integration with Selenium WebDriver description: Please see the . category: Testing @@ -93,7 +93,7 @@ , random , retry , safe - , sandwich >=0.3.0.0 + , sandwich >=0.3.1.0 , sandwich-contexts >=0.3.0.0 , string-interpolate , temporary @@ -173,7 +173,7 @@ , random , retry , safe - , sandwich >=0.3.0.0 + , sandwich >=0.3.1.0 , sandwich-contexts >=0.3.0.0 , sandwich-webdriver , string-interpolate 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 @@ -208,6 +208,9 @@ , driverConfigLogDir = runRoot #endif , driverConfigChromedriverFlags = chromedriverExtraFlags wdOptions +#if MIN_VERSION_webdriver(0,15,0) + , driverConfigChromedriverExtraEnv = mempty +#endif } return (caps, driverConfig) BrowserDependenciesFirefox {..} -> do @@ -219,7 +222,10 @@ , W._capabilitiesMozFirefoxOptions = Just ffOptions } - profileRootDir <- liftIO $ createTempDirectory webdriverRoot "geckodriver-profile-root" + -- Put geckodriver profiles in the run root, since Firefox seems to crash + -- with longer paths. Especially in non-headless mode. + runRoot <- fromMaybe "/tmp" <$> getRunRoot + profileRootDir <- liftIO $ createTempDirectory runRoot "geckodriver-profiles" let driverConfig = W.DriverConfigGeckodriver { driverConfigGeckodriver = browserDependenciesFirefoxGeckodriver @@ -231,6 +237,9 @@ #endif , driverConfigGeckodriverFlags = "--profile-root" : profileRootDir : geckodriverExtraFlags wdOptions -- , driverConfigGeckodriverFlags = geckodriverExtraFlags wdOptions +#if MIN_VERSION_webdriver(0,15,0) + , driverConfigGeckodriverExtraEnv = mempty +#endif } return (caps, driverConfig) @@ -247,7 +256,8 @@ TestWebDriverContext <$> pure (T.unpack webdriverName) <*> pure wdc - <*> pure (wdOptions { capabilities = finalCaps }) + <*> pure wdOptions + <*> pure finalCaps <*> liftIO (newMVar mempty) <*> pure driverConfig <*> pure downloadDir @@ -278,17 +288,25 @@ TestWebDriverContext {..} <- getContext webdriver -- Create new session if necessary (this can throw an exception) - sess <- modifyMVar wdSessionMap $ \sessionMap -> case M.lookup sessionName sessionMap of - Just sess -> return (sessionMap, sess) + SessionMapEntry {..} <- modifyMVar wdSessionMap $ \sessionMap -> case M.lookup sessionName sessionMap of + Just sessionMapEntry -> return (sessionMap, sessionMapEntry) Nothing -> do - finalCaps <- pure (capabilities wdOptions) + (maybeChromeUserDataDir, finalCaps') <- pure wdCapabilities >>= configureChromeUserDataDir + finalCaps <- liftIO $ modifyCapabilities wdOptions finalCaps' + debug [i|Creating session '#{sessionName}'|] sess <- W.startSession wdContext wdDriverConfig finalCaps sessionName - return (M.insert sessionName sess sessionMap, sess) - pushContext webdriverSession (sessionName, sess) $ + let sessionMapEntry = SessionMapEntry { + sessionMapEntrySession = sess + , sessionMapEntryDirsToRemove = maybeToList maybeChromeUserDataDir + } + + return (M.insert sessionName sessionMapEntry sessionMap, sessionMapEntry) + + pushContext webdriverSession (sessionName, sessionMapEntrySession) $ recordVideoIfConfigured sessionName action diff --git a/src/Test/Sandwich/WebDriver/Config.hs b/src/Test/Sandwich/WebDriver/Config.hs --- a/src/Test/Sandwich/WebDriver/Config.hs +++ b/src/Test/Sandwich/WebDriver/Config.hs @@ -6,13 +6,14 @@ WdOptions , defaultWdOptions , runMode - , capabilities , httpRetryCount , geckodriverExtraFlags , chromedriverExtraFlags + , modifyCapabilities -- * Accessors for the 'WebDriver' context , getWdOptions + , getWdCapabilities -- , getDisplayNumber , getDownloadDirectory , getWebDriverName diff --git a/src/Test/Sandwich/WebDriver/Internal/Action.hs b/src/Test/Sandwich/WebDriver/Internal/Action.hs --- a/src/Test/Sandwich/WebDriver/Internal/Action.hs +++ b/src/Test/Sandwich/WebDriver/Internal/Action.hs @@ -13,6 +13,7 @@ import Test.Sandwich.WebDriver.Types import qualified Test.WebDriver as W import UnliftIO.Concurrent +import UnliftIO.Directory import UnliftIO.Exception @@ -24,16 +25,29 @@ Nothing -> return (sessionMap, Nothing) Just x -> return (M.delete session sessionMap, Just x) - whenJust toClose $ \sess -> W.closeSession wdContext sess + whenJust toClose $ \(SessionMapEntry {..}) -> do + W.closeSession wdContext sessionMapEntrySession + info [i|Closing session: #{sessionMapEntrySession}. sessionMapEntryDirsToRemove: #{sessionMapEntryDirsToRemove}|] + + forM_ sessionMapEntryDirsToRemove $ \dirToRemove -> do + debug [i|Removing session-specific directory: #{dirToRemove}|] + catch (removePathForcibly dirToRemove) + (\(e :: SomeException) -> warn [i|Failed to remove session directory '#{dirToRemove}': '#{e}'|]) + -- | Close all sessions except those listed. closeAllSessionsExcept :: (HasCallStack, MonadLogger m, W.WebDriverBase m) => [SessionName] -> TestWebDriverContext -> m () closeAllSessionsExcept toKeep (TestWebDriverContext {wdSessionMap, wdContext}) = do toClose <- modifyMVar wdSessionMap $ return . M.partitionWithKey (\name _ -> name `elem` toKeep) - forM_ (M.toList toClose) $ \(name, sess) -> - catch (W.closeSession wdContext sess) + forM_ (M.toList toClose) $ \(name, SessionMapEntry {..}) -> do + catch (W.closeSession wdContext sessionMapEntrySession) (\(e :: SomeException) -> warn [i|Failed to destroy session '#{name}': '#{e}'|]) + + forM_ sessionMapEntryDirsToRemove $ \dirToRemove -> do + debug [i|Removing session-specific directory: #{dirToRemove}|] + catch (removePathForcibly dirToRemove) + (\(e :: SomeException) -> warn [i|Failed to remove session directory '#{dirToRemove}': '#{e}'|]) -- | Close all sessions. closeAllSessions :: (HasCallStack, MonadLogger m, W.WebDriverBase m) => TestWebDriverContext -> m () 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 @@ -32,10 +32,11 @@ import UnliftIO.Directory -type Constraints m = ( +type Constraints context m = ( HasCallStack , MonadLogger m , MonadUnliftIO m + , HasBaseContextMonad context m ) -- | Manually obtain a chrome binary, according to the 'ChromeToUse' policy, @@ -108,7 +109,7 @@ debug [i|Built chromedriver: #{ret}|] return $ Right ret -downloadChromeDriverIfNecessary' :: Constraints m => FilePath -> ChromeDriverVersion -> m (Either T.Text FilePath) +downloadChromeDriverIfNecessary' :: Constraints context m => FilePath -> ChromeDriverVersion -> m (Either T.Text FilePath) downloadChromeDriverIfNecessary' toolsDir chromeDriverVersion = runExceptT $ do let chromeDriverPath = getChromeDriverPath toolsDir chromeDriverVersion @@ -118,7 +119,7 @@ return chromeDriverPath -downloadChromeDriverIfNecessary :: Constraints m => FilePath -> FilePath -> m (Either T.Text FilePath) +downloadChromeDriverIfNecessary :: Constraints context m => FilePath -> FilePath -> m (Either T.Text FilePath) downloadChromeDriverIfNecessary chromePath toolsDir = runExceptT $ do chromeDriverVersion <- ExceptT $ liftIO $ getChromeDriverVersion chromePath ExceptT $ downloadChromeDriverIfNecessary' toolsDir chromeDriverVersion diff --git a/src/Test/Sandwich/WebDriver/Internal/Binaries/Common.hs b/src/Test/Sandwich/WebDriver/Internal/Binaries/Common.hs --- a/src/Test/Sandwich/WebDriver/Internal/Binaries/Common.hs +++ b/src/Test/Sandwich/WebDriver/Internal/Binaries/Common.hs @@ -1,58 +1,65 @@ module Test.Sandwich.WebDriver.Internal.Binaries.Common where -import Control.Exception import Control.Monad import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Logger import Data.String.Interpolate import qualified Data.Text as T -import System.Directory import System.Exit import System.FilePath -import System.Process import Test.Sandwich.Expectations import Test.Sandwich.Logging +import Test.Sandwich.Misc (HasBaseContextMonad) import Test.Sandwich.WebDriver.Internal.Util +import UnliftIO.Async +import UnliftIO.Directory +import UnliftIO.Exception +import UnliftIO.Process import UnliftIO.Temporary -downloadAndUnzipToPath :: (MonadUnliftIO m, MonadLogger m) => T.Text -> FilePath -> m (Either T.Text ()) +downloadAndUnzipToPath :: (MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => T.Text -> FilePath -> m (Either T.Text ()) downloadAndUnzipToPath downloadPath localPath = leftOnException' $ do info [i|Downloading #{downloadPath} to #{localPath}|] - liftIO $ createDirectoryIfMissing True (takeDirectory localPath) + createDirectoryIfMissing True (takeDirectory localPath) withSystemTempDirectory "sandwich-webdriver-tool-download" $ \dir -> do curlDownloadToPath (T.unpack downloadPath) (dir "temp.zip") createProcessWithLogging ((proc "unzip" ["temp.zip", "-d", "unzipped"]) { cwd = Just dir }) - >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess) + >>= \(ps, asy) -> finally (waitForProcess ps >>= (`shouldBe` ExitSuccess)) + (cancel asy) let unzipped = dir "unzipped" executables <- (filter (/= "") . T.splitOn "\n" . T.pack) <$> readCreateProcessWithLogging (proc "find" [unzipped, "-executable", "-type", "f"]) "" case executables of - [] -> liftIO $ throwIO $ userError [i|No executable found in file downloaded from #{downloadPath}|] + [] -> throwIO $ userError [i|No executable found in file downloaded from #{downloadPath}|] [x] -> do - liftIO $ copyFile (T.unpack x) localPath + copyFile (T.unpack x) localPath createProcessWithLogging (shell [i|chmod u+x #{localPath}|]) - >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess) - xs -> liftIO $ throwIO $ userError [i|Found multiple executable found in file downloaded from #{downloadPath}: #{xs}|] + >>= \(ps, asy) -> finally (waitForProcess ps >>= (`shouldBe` ExitSuccess)) + (cancel asy) + xs -> throwIO $ userError [i|Found multiple executable found in file downloaded from #{downloadPath}: #{xs}|] -downloadAndUntarballToPath :: (MonadUnliftIO m, MonadLogger m) => T.Text -> FilePath -> m (Either T.Text ()) +downloadAndUntarballToPath :: (MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => T.Text -> FilePath -> m (Either T.Text ()) downloadAndUntarballToPath downloadPath localPath = leftOnException' $ do info [i|Downloading #{downloadPath} to #{localPath}|] - liftIO $ createDirectoryIfMissing True (takeDirectory localPath) + createDirectoryIfMissing True (takeDirectory localPath) createProcessWithLogging (shell [i|wget -qO- #{downloadPath} | tar xvz -C #{takeDirectory localPath}|]) - >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess) + >>= \(ps, asy) -> finally (liftIO $ waitForProcess ps >>= (`shouldBe` ExitSuccess)) + (cancel asy) createProcessWithLogging (shell [i|chmod u+x #{localPath}|]) - >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess) + >>= \(ps, asy) -> finally (liftIO $ waitForProcess ps >>= (`shouldBe` ExitSuccess)) + (cancel asy) -curlDownloadToPath :: (MonadUnliftIO m, MonadLogger m) => String -> FilePath -> m () +curlDownloadToPath :: (MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => String -> FilePath -> m () curlDownloadToPath downloadPath localPath = do info [i|Downloading #{downloadPath} to #{localPath}|] - liftIO $ createDirectoryIfMissing True (takeDirectory localPath) - p <- createProcessWithLogging (proc "curl" [downloadPath, "-o", localPath, "-s"]) - liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess) + createDirectoryIfMissing True (takeDirectory localPath) + (p, asy) <- createProcessWithLogging (proc "curl" [downloadPath, "-o", localPath, "-s"]) + finally (liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess)) + (cancel asy) unlessM :: Monad m => m Bool -> m () -> m () unlessM b s = b >>= (\t -> unless t s) 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 @@ -24,10 +24,11 @@ import UnliftIO.Directory -type Constraints m = ( +type Constraints context m = ( HasCallStack , MonadLogger m , MonadUnliftIO m + , HasBaseContextMonad context m ) -- * Obtaining binaries @@ -76,13 +77,13 @@ -- * Lower level helpers -downloadSeleniumIfNecessary :: Constraints m => FilePath -> m (Either T.Text FilePath) +downloadSeleniumIfNecessary :: Constraints context m => FilePath -> m (Either T.Text FilePath) downloadSeleniumIfNecessary toolsDir = leftOnException' $ do let seleniumPath = [i|#{toolsDir}/selenium-server.jar|] liftIO (doesFileExist seleniumPath) >>= flip unless (downloadSelenium seleniumPath) return seleniumPath where - downloadSelenium :: Constraints m => FilePath -> m () + downloadSelenium :: Constraints context m => FilePath -> m () downloadSelenium seleniumPath = void $ do info [i|Downloading selenium-server.jar to #{seleniumPath}|] curlDownloadToPath defaultSeleniumJarUrl seleniumPath 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 @@ -138,15 +138,15 @@ -- -- 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 :: (Constraints m, HasBaseContextMonad context m, MonadFail m) => W.Capabilities -> m (Maybe FilePath, 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 + return (Just userDataDir, caps { W._capabilitiesGoogChromeOptions = Just finalChromeOptions }) +configureChromeUserDataDir caps = return (Nothing, caps) -- | This is to make it possible to use Chrome installed by Nix, avoiding errors like this: diff --git a/src/Test/Sandwich/WebDriver/Internal/OnDemand.hs b/src/Test/Sandwich/WebDriver/Internal/OnDemand.hs --- a/src/Test/Sandwich/WebDriver/Internal/OnDemand.hs +++ b/src/Test/Sandwich/WebDriver/Internal/OnDemand.hs @@ -7,19 +7,19 @@ import Data.Text as T import Test.Sandwich import Test.Sandwich.WebDriver.Internal.Types -import UnliftIO.Async +import UnliftIO.Async (wait) import UnliftIO.Exception import UnliftIO.MVar -getOnDemand :: forall m a. ( - MonadUnliftIO m, MonadLogger m +getOnDemand :: forall context m a. ( + MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m ) => MVar (OnDemand a) -> m (Either Text a) -> m a getOnDemand onDemandVar doObtain = do result <- modifyMVar onDemandVar $ \case OnDemandErrored msg -> expectationFailure (T.unpack msg) OnDemandNotStarted -> do - asy <- async $ do + asy <- managedAsync "webdriver-on-demand" $ do let handler :: SomeException -> m a handler e = do modifyMVar_ onDemandVar (const $ return $ OnDemandErrored [i|Got exception: #{e}|]) 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 @@ -17,9 +17,9 @@ import Test.Sandwich.WebDriver.Internal.Types import qualified Test.WebDriver as W -#ifndef mingw32_HOST_OS -import Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb -#endif +-- #ifndef mingw32_HOST_OS +-- import Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb +-- #endif type Constraints m = ( 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 @@ -46,11 +46,8 @@ -- The @Xvfb@ binary must be installed and on the PATH. data WdOptions = WdOptions { - -- | The WebDriver capabilities to use. - capabilities :: W.Capabilities - -- | How to handle opening the browser (in a popup window, headless, etc.). - , runMode :: RunMode + runMode :: RunMode -- | Number of times to retry an HTTP request if it times out. , httpRetryCount :: Int @@ -58,11 +55,14 @@ -- | Pass the --no-sandbox flag to Chrome (useful in GitHub Actions when installing Chrome via Nix). , chromeNoSandbox :: Bool - -- | Extra flags to pass to chromedriver + -- | Extra flags to pass to chromedriver. , chromedriverExtraFlags :: [String] - -- | Extra flags to pass to geckodriver + -- | Extra flags to pass to geckodriver. , geckodriverExtraFlags :: [String] + + -- | Modify capabilities before session creation. + , modifyCapabilities :: W.Capabilities -> IO W.Capabilities } -- | How to obtain certain binaries "on demand". These may or not be needed based on 'WdOptions', so @@ -106,12 +106,12 @@ -- You should start with this and modify it using the accessors. defaultWdOptions :: WdOptions defaultWdOptions = WdOptions { - capabilities = W.defaultCaps - , runMode = Normal + runMode = Normal , httpRetryCount = 0 , chromeNoSandbox = False , chromedriverExtraFlags = [] , geckodriverExtraFlags = [] + , modifyCapabilities = return } data OnDemand a = @@ -120,11 +120,20 @@ | OnDemandReady a | OnDemandErrored Text +data SessionMapEntry = SessionMapEntry { + sessionMapEntrySession :: W.Session + -- Per-session directories which we should clean up when a session is closed. + -- These are typically browser profile directories, which can take up a lot of + -- space in test artifact directories. + , sessionMapEntryDirsToRemove :: [FilePath] + } + data TestWebDriverContext = TestWebDriverContext { wdName :: String , wdContext :: W.WebDriverContext , wdOptions :: WdOptions - , wdSessionMap :: MVar (M.Map String W.Session) + , wdCapabilities :: W.Capabilities + , wdSessionMap :: MVar (M.Map String SessionMapEntry) , wdDriverConfig :: W.DriverConfig , wdDownloadDir :: FilePath @@ -153,6 +162,10 @@ -- | Get the 'WdOptions' associated with the 'WebDriver'. getWdOptions :: TestWebDriverContext -> WdOptions getWdOptions = wdOptions + +-- | Get the 'W.Capabilities' associated with the 'WebDriver'. +getWdCapabilities :: TestWebDriverContext -> W.Capabilities +getWdCapabilities = wdCapabilities -- | Get the X11 display number associated with the 'WebDriver'. -- Only present if running in 'RunInXvfb' mode. 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 @@ -48,6 +48,7 @@ import Test.Sandwich.WebDriver.Video.Types import Test.Sandwich.WebDriver.Windows import Test.WebDriver +import UnliftIO.Async import UnliftIO.Directory import UnliftIO.Exception @@ -61,6 +62,7 @@ data VideoProcess = VideoProcess { -- | The process handle videoProcessProcess :: ProcessHandle + , videoProcessAsync :: Async () , videoProcessCreatedFiles :: [FilePath] } -- defaultVideoProcess :: ProcessHandle -> VideoProcess @@ -109,7 +111,7 @@ -- | Returns handle to video process and list of files created -> m VideoProcess startVideoRecording path (width, height, x, y) vs = do - sess <- getContext webdriver + -- sess <- getContext webdriver -- let maybeXvfbSession = getXvfbSession sess let maybeXvfbSession = Nothing @@ -122,15 +124,16 @@ case logToDisk vs of False -> do - p <- createProcessWithLogging cp - return $ VideoProcess p [videoPath] + (p, asy) <- createProcessWithLogging cp + return $ VideoProcess p asy [videoPath] True -> do let stdoutPath = path <.> "stdout" <.> "log" let stderrPath = path <.> "stderr" <.> "log" liftIO $ bracket (openFile stdoutPath AppendMode) hClose $ \hout -> bracket (openFile stderrPath AppendMode) hClose $ \herr -> do (_, _, _, p) <- createProcess (cp { std_out = UseHandle hout, std_err = UseHandle herr }) - return $ VideoProcess p [videoPath, stdoutPath, stderrPath] + asy <- async $ return () + return $ VideoProcess p asy [videoPath, stdoutPath, stderrPath] -- | Gracefully stop the 'ProcessHandle' returned by 'startVideoRecording'. endVideoRecording :: ( diff --git a/src/Test/Sandwich/WebDriver/Windows.hs b/src/Test/Sandwich/WebDriver/Windows.hs --- a/src/Test/Sandwich/WebDriver/Windows.hs +++ b/src/Test/Sandwich/WebDriver/Windows.hs @@ -15,8 +15,10 @@ ) where import Control.Monad.IO.Class +import Control.Monad.Logger import Control.Monad.Reader import Data.Maybe +import Data.String.Interpolate import Test.Sandwich import Test.Sandwich.WebDriver.Internal.Types import Test.Sandwich.WebDriver.Resolution @@ -25,7 +27,7 @@ -- | Position the window on the left 50% of the screen. -setWindowLeftSide :: (WebDriverMonad m context, MonadReader context m, WebDriver m) => m () +setWindowLeftSide :: (WebDriverMonad m context, MonadReader context m, MonadLogger m, WebDriver m) => m () setWindowLeftSide = do sess <- getContext webdriver (x, y, width, height) <- case runMode $ wdOptions sess of @@ -35,10 +37,12 @@ (screenWidth, screenHeight) <- getScreenPixelDimensions width height + debug [i|setWindowLeftSide: got screen resolution (x, y, w, h) = #{(x, y, width, height)} and pixel dimensions #{(screenWidth, screenHeight)}|] + setWindowRect $ Rect (fromIntegral x) (fromIntegral y) (realToFrac (screenWidth / 2.0)) (realToFrac screenHeight) -- | Position the window on the right 50% of the screen. -setWindowRightSide :: (WebDriverMonad m context, MonadReader context m, WebDriver m) => m () +setWindowRightSide :: (WebDriverMonad m context, MonadReader context m, MonadLogger m, WebDriver m) => m () setWindowRightSide = do sess <- getContext webdriver (x, y, width, height) <- case runMode $ wdOptions sess of @@ -48,10 +52,12 @@ (screenWidth, screenHeight) <- getScreenPixelDimensions width height + debug [i|setWindowRightSide: got screen resolution (x, y, w, h) = #{(x, y, width, height)} and pixel dimensions #{(screenWidth, screenHeight)}|] + setWindowRect $ Rect (fromIntegral (x + round (screenWidth / 2.0))) (fromIntegral (y + 0)) (realToFrac (screenWidth / 2.0)) (realToFrac screenHeight) -- | Fullscreen the browser window. -setWindowFullScreen :: (WebDriverMonad m context, MonadReader context m, WebDriver m) => m () +setWindowFullScreen :: (WebDriverMonad m context, MonadReader context m, MonadLogger m, WebDriver m) => m () setWindowFullScreen = do sess <- getContext webdriver (x, y, width, height) <- case runMode $ wdOptions sess of @@ -61,6 +67,8 @@ (screenWidth, screenHeight) <- getScreenPixelDimensions width height + debug [i|setWindowFullScreen: got screen resolution (x, y, w, h) = #{(x, y, width, height)} and pixel dimensions #{(screenWidth, screenHeight)}|] + setWindowRect $ Rect (fromIntegral x) (fromIntegral y) (realToFrac screenWidth) (realToFrac screenHeight) -- | Get the screen resolution as (x, y, width, height). (The x and y coordinates may be nonzero in multi-monitor setups.) @@ -69,7 +77,7 @@ -- getScreenResolution (TestWebDriverContext {wdWebDriver=(_, maybeXvfbSession)}) = case maybeXvfbSession of -- Nothing -> liftIO getResolution -- Just (XvfbSession {..}) -> liftIO $ getResolutionForDisplay xvfbDisplayNum -getScreenResolution twdc = liftIO getResolution +getScreenResolution _twdc = liftIO getResolution getScreenPixelDimensions :: (WebDriver m) => Int -> Int -> m (Double, Double) getScreenPixelDimensions width height = do diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -21,7 +21,7 @@ -- 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 spec :: TopSpecWithOptions -spec = introduceNixContext (nixpkgsRelease2405 { nixpkgsDerivationAllowUnfree = True }) $ +spec = introduceNixContext (nixpkgsRelease2505 { nixpkgsDerivationAllowUnfree = True }) $ introduceWebDriverViaNix defaultWdOptions $ do it "opens Xkcd and presses the prev button" $ withSession1 $ do openPage [i|https://www.xkcd.com|] diff --git a/unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs b/unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs --- a/unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs +++ b/unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs @@ -101,7 +101,7 @@ -- Start the Xvfb session authFile <- liftIO $ writeTempFile webdriverRoot ".Xauthority" "" - p <- createProcessWithLogging $ ( + p <- createProcessWithFileLogging' "xvfb" $ ( proc xvfb [":" <> show serverNum , "-screen", "0", [i|#{w}x#{h}x24|] , "-displayfd", [i|#{fd}|]