{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
module Test.Sandwich.WebDriver.Video (
startVideoRecording
, endVideoRecording
, startFullScreenVideoRecording
, startBrowserVideoRecording
, VideoSettings(..)
, defaultVideoSettings
, fastX11VideoOptions
, qualityX11VideoOptions
, defaultAvfoundationOptions
, defaultGdigrabOptions
) where
import Control.Exception.Safe
import Control.Monad.IO.Class
import Control.Monad.Logger hiding (logError)
import Control.Monad.Reader
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.String.Interpolate
import System.Exit
import System.FilePath
import System.IO
import System.Process
import Test.Sandwich
import Test.Sandwich.WebDriver
import Test.Sandwich.WebDriver.Internal.Types
import Test.Sandwich.WebDriver.Internal.Video
import Test.Sandwich.WebDriver.Windows
import Test.WebDriver.Class as W
import Test.WebDriver.Commands
type BaseVideoConstraints context m = (MonadLoggerIO m, MonadReader context m, HasWebDriverContext context, MonadBaseControl IO m)
startFullScreenVideoRecording :: (
BaseVideoConstraints context m, MonadMask m
) => FilePath -> VideoSettings -> m ProcessHandle
startFullScreenVideoRecording :: forall context (m :: * -> *).
(BaseVideoConstraints context m, MonadMask m) =>
FilePath -> VideoSettings -> m ProcessHandle
startFullScreenVideoRecording FilePath
path VideoSettings
videoSettings = do
WebDriver
sess <- forall (m :: * -> *) context (l :: Symbol) a.
(Monad m, HasLabel context l a, HasCallStack,
MonadReader context m) =>
Label l a -> m a
getContext Label "webdriver" WebDriver
webdriver
let maybeXvfbSession :: Maybe XvfbSession
maybeXvfbSession = WebDriver -> Maybe XvfbSession
getXvfbSession WebDriver
sess
(Int
width, Int
height) <- case Maybe XvfbSession
maybeXvfbSession of
Just (XvfbSession {(Int, Int)
xvfbDimensions :: XvfbSession -> (Int, Int)
xvfbDimensions :: (Int, Int)
xvfbDimensions}) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Int, Int)
xvfbDimensions
Maybe XvfbSession
Nothing -> do
(Int
_x, Int
_y, Int
w, Int
h) <- forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadMask m, MonadLogger m) =>
WebDriver -> m (Int, Int, Int, Int)
getScreenResolution WebDriver
sess
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)
forall context (m :: * -> *).
BaseVideoConstraints context m =>
FilePath
-> (Word, Word, Int, Int) -> VideoSettings -> m ProcessHandle
startVideoRecording FilePath
path (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height, Int
0, Int
0) VideoSettings
videoSettings
startBrowserVideoRecording :: (
BaseVideoConstraints context m, MonadThrow m, HasWebDriverSessionContext context, W.WebDriver m
) => FilePath -> VideoSettings -> m ProcessHandle
startBrowserVideoRecording :: forall context (m :: * -> *).
(BaseVideoConstraints context m, MonadThrow m,
HasWebDriverSessionContext context, WebDriver m) =>
FilePath -> VideoSettings -> m ProcessHandle
startBrowserVideoRecording FilePath
path VideoSettings
videoSettings = do
(Int
x, Int
y) <- forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
wd (Int, Int)
getWindowPos
(Word
w, Word
h) <- forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
wd (Word, Word)
getWindowSize
forall context (m :: * -> *).
BaseVideoConstraints context m =>
FilePath
-> (Word, Word, Int, Int) -> VideoSettings -> m ProcessHandle
startVideoRecording FilePath
path (Word
w, Word
h, Int
x, Int
y) VideoSettings
videoSettings
startVideoRecording :: (
BaseVideoConstraints context m
) => FilePath -> (Word, Word, Int, Int) -> VideoSettings -> m ProcessHandle
startVideoRecording :: forall context (m :: * -> *).
BaseVideoConstraints context m =>
FilePath
-> (Word, Word, Int, Int) -> VideoSettings -> m ProcessHandle
startVideoRecording FilePath
path (Word
width, Word
height, Int
x, Int
y) VideoSettings
vs = do
WebDriver
sess <- forall (m :: * -> *) context (l :: Symbol) a.
(Monad m, HasLabel context l a, HasCallStack,
MonadReader context m) =>
Label l a -> m a
getContext Label "webdriver" WebDriver
webdriver
let maybeXvfbSession :: Maybe XvfbSession
maybeXvfbSession = WebDriver -> Maybe XvfbSession
getXvfbSession WebDriver
sess
CreateProcess
cp' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {p} {a} {b} {c} {d}.
(MonadIO m, Interpolatable 'False p FilePath,
Interpolatable 'False a FilePath, Interpolatable 'False b FilePath,
Interpolatable 'False c FilePath,
Interpolatable 'False d FilePath) =>
p
-> (a, b, c, d)
-> VideoSettings
-> Maybe XvfbSession
-> m CreateProcess
getVideoArgs FilePath
path (Word
width, Word
height, Int
x, Int
y) VideoSettings
vs Maybe XvfbSession
maybeXvfbSession
let cp :: CreateProcess
cp = CreateProcess
cp' { create_group :: Bool
create_group = Bool
True }
case CreateProcess -> CmdSpec
cmdspec CreateProcess
cp of
ShellCommand FilePath
s -> forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|ffmpeg command: #{s}|]
RawCommand FilePath
p [FilePath]
args -> forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|ffmpeg command: #{p} #{unwords args}|]
case VideoSettings -> Bool
logToDisk VideoSettings
vs of
Bool
False -> forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) =>
CreateProcess -> m ProcessHandle
createProcessWithLogging CreateProcess
cp
Bool
True -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (FilePath -> IOMode -> IO Handle
openFile (FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
"stdout" FilePath -> FilePath -> FilePath
<.> FilePath
"log") IOMode
AppendMode) Handle -> IO ()
hClose forall a b. (a -> b) -> a -> b
$ \Handle
hout ->
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (FilePath -> IOMode -> IO Handle
openFile (FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
"stderr" FilePath -> FilePath -> FilePath
<.> FilePath
"log") IOMode
AppendMode) Handle -> IO ()
hClose forall a b. (a -> b) -> a -> b
$ \Handle
herr -> do
(Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
p) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (CreateProcess
cp { std_out :: StdStream
std_out = Handle -> StdStream
UseHandle Handle
hout, std_err :: StdStream
std_err = Handle -> StdStream
UseHandle Handle
herr })
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessHandle
p
endVideoRecording :: (
MonadLoggerIO m, MonadCatch m
) => ProcessHandle -> m ()
endVideoRecording :: forall (m :: * -> *).
(MonadLoggerIO m, MonadCatch m) =>
ProcessHandle -> m ()
endVideoRecording ProcessHandle
p = do
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
catchAny (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ()
interruptProcessGroupOf ProcessHandle
p)
(\SomeException
e -> forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logError [i|Exception in interruptProcessGroupOf in endVideoRecording: #{e}|])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ExitCode
ExitSuccess -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
ExitFailure Int
255 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
ExitFailure Int
n -> forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|ffmpeg exited with unexpected exit code #{n}'|]