Skip to content

Commit

Permalink
sandwich-webdriver: --error-videos flag working
Browse files Browse the repository at this point in the history
  • Loading branch information
thomasjm committed Oct 31, 2024
1 parent 174e718 commit 343348e
Show file tree
Hide file tree
Showing 2 changed files with 33 additions and 20 deletions.
40 changes: 26 additions & 14 deletions sandwich-webdriver/src/Test/Sandwich/WebDriver/Video.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TupleSections #-}

-- | Functions for recording videos of browser windows.

Expand All @@ -11,7 +12,7 @@ module Test.Sandwich.WebDriver.Video (
, startVideoRecording
, endVideoRecording

-- * Wrap an ExampleT to conditionally record video
-- * Wrap a test to conditionally record video
, recordVideoIfConfigured

-- * Configuration
Expand All @@ -26,6 +27,7 @@ module Test.Sandwich.WebDriver.Video (
, BaseVideoConstraints
) where

import Control.Monad
import Control.Monad.Catch (MonadMask)
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
Expand Down Expand Up @@ -70,7 +72,7 @@ startFullScreenVideoRecording path videoSettings = do
Nothing -> do
(_x, _y, w, h) <- getScreenResolution sess
return (fromIntegral w, fromIntegral h)
startVideoRecording path (fromIntegral width, fromIntegral height, 0, 0) videoSettings
fst <$> startVideoRecording path (fromIntegral width, fromIntegral height, 0, 0) videoSettings

-- | Wrapper around 'startVideoRecording' which uses WebDriver to find the rectangle corresponding to the browser.
startBrowserVideoRecording :: (
Expand All @@ -79,7 +81,7 @@ startBrowserVideoRecording :: (
-- | Output path
=> FilePath
-> VideoSettings
-> m ProcessHandle
-> m (ProcessHandle, [FilePath])
startBrowserVideoRecording path videoSettings = do
(x, y) <- getWindowPos
(w, h) <- getWindowSize
Expand All @@ -94,26 +96,30 @@ startVideoRecording :: (
-- | Rectangle to record, specified as @(width, height, x, y)@
-> (Word, Word, Int, Int)
-> VideoSettings
-- | Returns handle to video process
-> m ProcessHandle
-- | Returns handle to video process and list of files created
-> m (ProcessHandle, [FilePath])
startVideoRecording path (width, height, x, y) vs = do
sess <- getContext webdriver
let maybeXvfbSession = getXvfbSession sess

cp' <- getVideoArgs path (width, height, x, y) vs maybeXvfbSession
(cp', videoPath) <- getVideoArgs path (width, height, x, y) vs maybeXvfbSession
let cp = cp' { create_group = True }

case cmdspec cp of
ShellCommand s -> debug [i|ffmpeg command: #{s}|]
RawCommand p args -> debug [i|ffmpeg command: #{p} #{unwords args}|]

case logToDisk vs of
False -> createProcessWithLogging cp
False -> do
p <- createProcessWithLogging cp
return (p, [videoPath])
True -> do
liftIO $ bracket (openFile (path <.> "stdout" <.> "log") AppendMode) hClose $ \hout ->
bracket (openFile (path <.> "stderr" <.> "log") AppendMode) hClose $ \herr -> 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 p
return (p, [videoPath, stdoutPath, stderrPath])

-- | Gracefully stop the 'ProcessHandle' returned by 'startVideoRecording'.
endVideoRecording :: (
Expand Down Expand Up @@ -151,16 +157,22 @@ withVideo :: (
) => FilePath -> String -> m a -> m a
withVideo folder browser action = do
path <- getPathInFolder folder browser
bracket (startBrowserVideoRecording path defaultVideoSettings) endVideoRecording (const action)
bracket (startBrowserVideoRecording path defaultVideoSettings) (endVideoRecording . fst) (const action)

withVideoIfException :: (
BaseVideoConstraints context m, W.WebDriver m
) => FilePath -> String -> m a -> m a
withVideoIfException folder browser action = do
path <- getPathInFolder folder browser
tryAny (bracket (startBrowserVideoRecording path defaultVideoSettings) (endVideoRecording) (const action)) >>= \case
Right ret -> removePathForcibly path >> return ret
Left e -> throwIO e
tryAny (bracket (startBrowserVideoRecording path defaultVideoSettings)
(endVideoRecording . fst)
(\(_p, pathsToRemove) -> (pathsToRemove, ) <$> action))
>>= \case
Right (pathsToRemove, ret) -> do
info [i|pathsToRemove: #{pathsToRemove}|]
forM_ pathsToRemove removePathForcibly
return ret
Left e -> throwIO e

getPathInFolder :: (MonadUnliftIO m) => [Char] -> String -> m FilePath
getPathInFolder folder browser = flip fix (0 :: Integer) $ \loop n -> do
Expand Down
13 changes: 7 additions & 6 deletions sandwich-webdriver/src/Test/Sandwich/WebDriver/Video/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,7 @@ import Control.Monad.IO.Unlift
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
Expand All @@ -33,12 +34,12 @@ import UnliftIO.Environment


videoExtension :: String
videoExtension = ".avi"
videoExtension = "avi"

getVideoArgs :: (
MonadUnliftIO m, MonadLoggerIO m, MonadMask m
, MonadReader context m, HasBaseContext context, HasWebDriverContext context
) => FilePath -> (Word, Word, Int, Int) -> VideoSettings -> Maybe XvfbSession -> m CreateProcess
) => FilePath -> (Word, Word, Int, Int) -> VideoSettings -> Maybe XvfbSession -> m (CreateProcess, FilePath)
getVideoArgs path (width, height, x, y) (VideoSettings {..}) maybeXvfbSession = do
WebDriver {wdFfmpeg, wdFfmpegToUse} <- getContext webdriver
ffmpeg <- getOnDemand wdFfmpeg (obtainFfmpeg wdFfmpegToUse)
Expand All @@ -57,7 +58,7 @@ getVideoArgs path (width, height, x, y) (VideoSettings {..}) maybeXvfbSession =
& (("XAUTHORITY", xvfbXauthority) :)
& L.nubBy ((==) `on` fst)

let videoPath = [i|#{path}#{videoExtension}|]
let videoPath = path <.> videoExtension

let cmd = ["-y"
, "-nostdin"
Expand All @@ -66,7 +67,7 @@ getVideoArgs path (width, height, x, y) (VideoSettings {..}) maybeXvfbSession =
, "-i", [i|#{displayNum}.0+#{x},#{y}|]]
++ xcbgrabOptions
++ [videoPath]
return ((proc ffmpeg cmd) { env = Just env })
return ((proc ffmpeg cmd) { env = Just env }, videoPath)
#endif

#ifdef darwin_HOST_OS
Expand All @@ -82,7 +83,7 @@ getVideoArgs path (width, height, x, y) (VideoSettings {..}) maybeXvfbSession =
++ avfoundationOptions
++ [videoPath]
Nothing -> error [i|Not launching ffmpeg since OS X screen number couldn't be determined.|]
return ((proc ffmpeg cmd) { env = Nothing })
return ((proc ffmpeg cmd) { env = Nothing }, videoPath)
#endif

#ifdef mingw32_HOST_OS
Expand All @@ -96,5 +97,5 @@ getVideoArgs path (width, height, x, y) (VideoSettings {..}) maybeXvfbSession =
]
++ gdigrabOptions
++ [videoPath]
return ((proc ffmpeg cmd) { env = Nothing })
return ((proc ffmpeg cmd) { env = Nothing }, videoPath)
#endif

0 comments on commit 343348e

Please sign in to comment.