{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TupleSections #-}

-- | Functions for recording videos of browser windows.

module Test.Sandwich.WebDriver.Video (
  startBrowserVideoRecording
  , startFullScreenVideoRecording

  -- * Lower-level
  , startVideoRecording
  , endVideoRecording

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

  -- * Configuration
  , VideoSettings(..)
  , defaultVideoSettings
  , fastX11VideoOptions
  , qualityX11VideoOptions
  , defaultAvfoundationOptions
  , defaultGdigrabOptions

  -- * Types
  , VideoProcess
  , videoProcessProcess
  , BaseVideoConstraints
  ) where

import Control.Monad
import Control.Monad.Catch (MonadMask)
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Control.Monad.Logger hiding (logError)
import Control.Monad.Reader
import Data.Function
import Data.String.Interpolate
import System.Exit
import System.FilePath
import System.IO
import System.Process
import Test.Sandwich
import Test.Sandwich.WebDriver.Internal.Types
import Test.Sandwich.WebDriver.Types
import Test.Sandwich.WebDriver.Video.Internal
import Test.Sandwich.WebDriver.Video.Types
import Test.Sandwich.WebDriver.Windows
import Test.WebDriver.Class as W
import Test.WebDriver.Commands
import UnliftIO.Directory
import UnliftIO.Exception


type BaseVideoConstraints context m = (
  MonadLoggerIO m, MonadUnliftIO m, MonadMask m
  , MonadReader context m, HasBaseContext context, HasWebDriverContext context
  )

-- | A type representing a live video recording process
data VideoProcess = VideoProcess {
  -- | The process handle
  VideoProcess -> ProcessHandle
videoProcessProcess :: ProcessHandle
  , VideoProcess -> [FilePath]
videoProcessCreatedFiles :: [FilePath]
  }
-- defaultVideoProcess :: ProcessHandle -> VideoProcess
-- defaultVideoProcess p = VideoProcess p mempty

-- | Wrapper around 'startVideoRecording' which uses the full screen dimensions.
startFullScreenVideoRecording :: (
  BaseVideoConstraints context m
  )
  -- | Output path
  => FilePath
  -> VideoSettings
  -> m VideoProcess
startFullScreenVideoRecording :: forall context (m :: * -> *).
BaseVideoConstraints context m =>
FilePath -> VideoSettings -> m VideoProcess
startFullScreenVideoRecording FilePath
path VideoSettings
videoSettings = do
  WebDriver
sess <- Label "webdriver" WebDriver -> m WebDriver
forall context (l :: Symbol) a (m :: * -> *).
(HasLabel context l a, 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 :: (Int, Int)
xvfbDimensions :: XvfbSession -> (Int, Int)
xvfbDimensions}) -> (Int, Int) -> m (Int, Int)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int, Int)
xvfbDimensions
    Maybe XvfbSession
Nothing -> do
      (Int
_x, Int
_y, Int
w, Int
h) <- WebDriver -> m (Int, Int, Int, Int)
forall (m :: * -> *).
MonadIO m =>
WebDriver -> m (Int, Int, Int, Int)
getScreenResolution WebDriver
sess
      (Int, Int) -> m (Int, Int)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w, Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h)
  FilePath
-> (Word, Word, Int, Int) -> VideoSettings -> m VideoProcess
forall context (m :: * -> *).
BaseVideoConstraints context m =>
FilePath
-> (Word, Word, Int, Int) -> VideoSettings -> m VideoProcess
startVideoRecording FilePath
path (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width, Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height, Int
0, Int
0) VideoSettings
videoSettings

-- | Wrapper around 'startVideoRecording' which uses WebDriver to find the rectangle corresponding to the browser.
startBrowserVideoRecording :: (
  BaseVideoConstraints context m, W.WebDriver m
  )
  -- | Output path
  => FilePath
  -> VideoSettings
  -> m VideoProcess
startBrowserVideoRecording :: forall context (m :: * -> *).
(BaseVideoConstraints context m, WebDriver m) =>
FilePath -> VideoSettings -> m VideoProcess
startBrowserVideoRecording FilePath
path VideoSettings
videoSettings = do
  (Int
x, Int
y) <- m (Int, Int)
forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
wd (Int, Int)
getWindowPos
  (Word
w, Word
h) <- m (Word, Word)
forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
wd (Word, Word)
getWindowSize
  FilePath
-> (Word, Word, Int, Int) -> VideoSettings -> m VideoProcess
forall context (m :: * -> *).
BaseVideoConstraints context m =>
FilePath
-> (Word, Word, Int, Int) -> VideoSettings -> m VideoProcess
startVideoRecording FilePath
path (Word
w, Word
h, Int
x, Int
y) VideoSettings
videoSettings

-- | Record video to a given path, for a given screen rectangle.
startVideoRecording :: (
  BaseVideoConstraints context m
  )
  -- | Output path
  => FilePath
  -- | Rectangle to record, specified as @(width, height, x, y)@
  -> (Word, Word, Int, Int)
  -> VideoSettings
  -- | Returns handle to video process and list of files created
  -> m VideoProcess
startVideoRecording :: forall context (m :: * -> *).
BaseVideoConstraints context m =>
FilePath
-> (Word, Word, Int, Int) -> VideoSettings -> m VideoProcess
startVideoRecording FilePath
path (Word
width, Word
height, Int
x, Int
y) VideoSettings
vs = do
  WebDriver
sess <- Label "webdriver" WebDriver -> m WebDriver
forall context (l :: Symbol) a (m :: * -> *).
(HasLabel context l a, 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', FilePath
videoPath) <- FilePath
-> (Word, Word, Int, Int)
-> VideoSettings
-> Maybe XvfbSession
-> m (CreateProcess, FilePath)
forall (m :: * -> *) context.
(MonadUnliftIO m, MonadLoggerIO m, MonadMask m,
 MonadReader context m, HasBaseContext context,
 HasWebDriverContext context) =>
FilePath
-> (Word, Word, Int, Int)
-> VideoSettings
-> Maybe XvfbSession
-> m (CreateProcess, FilePath)
getVideoArgs FilePath
path (Word
width, Word
height, Int
x, Int
y) VideoSettings
vs Maybe XvfbSession
maybeXvfbSession
  let cp :: CreateProcess
cp = CreateProcess
cp' { create_group = True }

  case CreateProcess -> CmdSpec
cmdspec CreateProcess
cp of
    ShellCommand FilePath
s -> Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|ffmpeg command: #{s}|]
    RawCommand FilePath
p [FilePath]
args -> Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|ffmpeg command: #{p} #{unwords args}|]

  case VideoSettings -> Bool
logToDisk VideoSettings
vs of
    Bool
False -> do
      ProcessHandle
p <- CreateProcess -> m ProcessHandle
forall (m :: * -> *).
(HasCallStack, MonadUnliftIO m, MonadLogger m) =>
CreateProcess -> m ProcessHandle
createProcessWithLogging CreateProcess
cp
      VideoProcess -> m VideoProcess
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (VideoProcess -> m VideoProcess) -> VideoProcess -> m VideoProcess
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> [FilePath] -> VideoProcess
VideoProcess ProcessHandle
p [FilePath
videoPath]
    Bool
True -> do
      let stdoutPath :: FilePath
stdoutPath = FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
"stdout" FilePath -> FilePath -> FilePath
<.> FilePath
"log"
      let stderrPath :: FilePath
stderrPath = FilePath
path FilePath -> FilePath -> FilePath
<.> FilePath
"stderr" FilePath -> FilePath -> FilePath
<.> FilePath
"log"
      IO VideoProcess -> m VideoProcess
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO VideoProcess -> m VideoProcess)
-> IO VideoProcess -> m VideoProcess
forall a b. (a -> b) -> a -> b
$ IO Handle
-> (Handle -> IO ())
-> (Handle -> IO VideoProcess)
-> IO VideoProcess
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (FilePath -> IOMode -> IO Handle
openFile FilePath
stdoutPath IOMode
AppendMode) Handle -> IO ()
hClose ((Handle -> IO VideoProcess) -> IO VideoProcess)
-> (Handle -> IO VideoProcess) -> IO VideoProcess
forall a b. (a -> b) -> a -> b
$ \Handle
hout ->
        IO Handle
-> (Handle -> IO ())
-> (Handle -> IO VideoProcess)
-> IO VideoProcess
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (FilePath -> IOMode -> IO Handle
openFile FilePath
stderrPath IOMode
AppendMode) Handle -> IO ()
hClose ((Handle -> IO VideoProcess) -> IO VideoProcess)
-> (Handle -> IO VideoProcess) -> IO VideoProcess
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 = UseHandle hout, std_err = UseHandle herr })
          VideoProcess -> IO VideoProcess
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (VideoProcess -> IO VideoProcess)
-> VideoProcess -> IO VideoProcess
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> [FilePath] -> VideoProcess
VideoProcess ProcessHandle
p [FilePath
videoPath, FilePath
stdoutPath, FilePath
stderrPath]

-- | Gracefully stop the 'ProcessHandle' returned by 'startVideoRecording'.
endVideoRecording :: (
  MonadLoggerIO m, MonadUnliftIO m
  ) => VideoProcess -> m ()
endVideoRecording :: forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m) =>
VideoProcess -> m ()
endVideoRecording (VideoProcess { videoProcessProcess :: VideoProcess -> ProcessHandle
videoProcessProcess=ProcessHandle
p }) = do
  m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
catchAny (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ()
interruptProcessGroupOf ProcessHandle
p)
           (\SomeException
e -> Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logError [i|Exception in interruptProcessGroupOf in endVideoRecording: #{e}|])

  IO ExitCode -> m ExitCode
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p) m ExitCode -> (ExitCode -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ExitCode
ExitSuccess -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- ffmpeg seems to exit with code 255 when exiting in response to a signal
    -- https://github.com/FFmpeg/FFmpeg/blob/d182d8f10cf69c59ef9c21df4b06e5478df063ef/fftools/ffmpeg.c#L4890
    ExitFailure Int
255 -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    ExitFailure Int
n -> Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|ffmpeg exited with unexpected exit code #{n}'|]

-- * Wrappers

-- | Record video around a given action, if configured to do so in the 'CommandLineWebdriverOptions'.
--
-- This can be used to record video around individual tests. It can also keep videos only in case of
-- exceptions, deleting them on successful runs.
recordVideoIfConfigured :: (
  BaseVideoConstraints context m, W.WebDriver m, HasSomeCommandLineOptions context
  )
  -- | Session name
  => String
  -> m a
  -> m a
recordVideoIfConfigured :: forall context (m :: * -> *) a.
(BaseVideoConstraints context m, WebDriver m,
 HasSomeCommandLineOptions context) =>
FilePath -> m a -> m a
recordVideoIfConfigured FilePath
browser m a
action = do
  m (Maybe FilePath)
forall context (m :: * -> *).
HasBaseContextMonad context m =>
m (Maybe FilePath)
getCurrentFolder m (Maybe FilePath) -> (Maybe FilePath -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe FilePath
Nothing -> m a
action
    Just FilePath
folder -> do
      SomeCommandLineOptions (CommandLineOptions {optWebdriverOptions :: forall a. CommandLineOptions a -> CommandLineWebdriverOptions
optWebdriverOptions=(CommandLineWebdriverOptions {Bool
Maybe FilePath
Maybe BrowserToUse
Maybe DisplayType
optFirefox :: Maybe BrowserToUse
optDisplay :: Maybe DisplayType
optFluxbox :: Bool
optIndividualVideos :: Bool
optErrorVideos :: Bool
optSeleniumJar :: Maybe FilePath
optChromeBinary :: Maybe FilePath
optChromeDriver :: Maybe FilePath
optFirefoxBinary :: Maybe FilePath
optGeckoDriver :: Maybe FilePath
optFirefox :: CommandLineWebdriverOptions -> Maybe BrowserToUse
optDisplay :: CommandLineWebdriverOptions -> Maybe DisplayType
optFluxbox :: CommandLineWebdriverOptions -> Bool
optIndividualVideos :: CommandLineWebdriverOptions -> Bool
optErrorVideos :: CommandLineWebdriverOptions -> Bool
optSeleniumJar :: CommandLineWebdriverOptions -> Maybe FilePath
optChromeBinary :: CommandLineWebdriverOptions -> Maybe FilePath
optChromeDriver :: CommandLineWebdriverOptions -> Maybe FilePath
optFirefoxBinary :: CommandLineWebdriverOptions -> Maybe FilePath
optGeckoDriver :: CommandLineWebdriverOptions -> Maybe FilePath
..})}) <- m SomeCommandLineOptions
forall context (m :: * -> *).
(HasSomeCommandLineOptions context, MonadReader context m) =>
m SomeCommandLineOptions
getSomeCommandLineOptions
      if | Bool
optIndividualVideos -> FilePath -> FilePath -> m a -> m a
forall context (m :: * -> *) a.
(BaseVideoConstraints context m, WebDriver m) =>
FilePath -> FilePath -> m a -> m a
withVideo FilePath
folder FilePath
browser m a
action
         | Bool
optErrorVideos -> FilePath -> FilePath -> m a -> m a
forall context (m :: * -> *) a.
(BaseVideoConstraints context m, WebDriver m) =>
FilePath -> FilePath -> m a -> m a
withVideoIfException FilePath
folder FilePath
browser m a
action
         | Bool
otherwise -> m a
action

withVideo :: (
  BaseVideoConstraints context m, W.WebDriver m
  ) => FilePath -> String -> m a -> m a
withVideo :: forall context (m :: * -> *) a.
(BaseVideoConstraints context m, WebDriver m) =>
FilePath -> FilePath -> m a -> m a
withVideo FilePath
folder FilePath
browser m a
action = do
  FilePath
path <- FilePath -> FilePath -> m FilePath
forall (m :: * -> *).
MonadUnliftIO m =>
FilePath -> FilePath -> m FilePath
getPathInFolder FilePath
folder FilePath
browser
  m VideoProcess
-> (VideoProcess -> m ()) -> (VideoProcess -> m a) -> m a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (FilePath -> VideoSettings -> m VideoProcess
forall context (m :: * -> *).
(BaseVideoConstraints context m, WebDriver m) =>
FilePath -> VideoSettings -> m VideoProcess
startBrowserVideoRecording FilePath
path VideoSettings
defaultVideoSettings) VideoProcess -> m ()
forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m) =>
VideoProcess -> m ()
endVideoRecording (m a -> VideoProcess -> m a
forall a b. a -> b -> a
const m a
action)

withVideoIfException :: (
  BaseVideoConstraints context m, W.WebDriver m
  ) => FilePath -> String -> m a -> m a
withVideoIfException :: forall context (m :: * -> *) a.
(BaseVideoConstraints context m, WebDriver m) =>
FilePath -> FilePath -> m a -> m a
withVideoIfException FilePath
folder FilePath
browser m a
action = do
  FilePath
path <- FilePath -> FilePath -> m FilePath
forall (m :: * -> *).
MonadUnliftIO m =>
FilePath -> FilePath -> m FilePath
getPathInFolder FilePath
folder FilePath
browser
  m ([FilePath], a) -> m (Either SomeException ([FilePath], a))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (m VideoProcess
-> (VideoProcess -> m ())
-> (VideoProcess -> m ([FilePath], a))
-> m ([FilePath], a)
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (FilePath -> VideoSettings -> m VideoProcess
forall context (m :: * -> *).
(BaseVideoConstraints context m, WebDriver m) =>
FilePath -> VideoSettings -> m VideoProcess
startBrowserVideoRecording FilePath
path VideoSettings
defaultVideoSettings)
                  VideoProcess -> m ()
forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m) =>
VideoProcess -> m ()
endVideoRecording
                  (\(VideoProcess {[FilePath]
ProcessHandle
videoProcessProcess :: VideoProcess -> ProcessHandle
videoProcessCreatedFiles :: VideoProcess -> [FilePath]
videoProcessProcess :: ProcessHandle
videoProcessCreatedFiles :: [FilePath]
..}) -> ([FilePath]
videoProcessCreatedFiles, ) (a -> ([FilePath], a)) -> m a -> m ([FilePath], a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
action))
    m (Either SomeException ([FilePath], a))
-> (Either SomeException ([FilePath], a) -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Right ([FilePath]
pathsToRemove, a
ret) -> do
        Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
info [i|pathsToRemove: #{pathsToRemove}|]
        [FilePath] -> (FilePath -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
pathsToRemove FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
removePathForcibly
        a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
ret
      Left SomeException
e -> SomeException -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
e

getPathInFolder :: (MonadUnliftIO m) => [Char] -> String -> m FilePath
getPathInFolder :: forall (m :: * -> *).
MonadUnliftIO m =>
FilePath -> FilePath -> m FilePath
getPathInFolder FilePath
folder FilePath
browser = (((Integer -> m FilePath) -> Integer -> m FilePath)
 -> Integer -> m FilePath)
-> Integer
-> ((Integer -> m FilePath) -> Integer -> m FilePath)
-> m FilePath
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Integer -> m FilePath) -> Integer -> m FilePath)
-> Integer -> m FilePath
forall a. (a -> a) -> a
fix (Integer
0 :: Integer) (((Integer -> m FilePath) -> Integer -> m FilePath) -> m FilePath)
-> ((Integer -> m FilePath) -> Integer -> m FilePath) -> m FilePath
forall a b. (a -> b) -> a -> b
$ \Integer -> m FilePath
loop Integer
n -> do
  let path :: FilePath
path = FilePath
folder FilePath -> FilePath -> FilePath
</> [i|#{browser}_video_#{n}|]
  IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesFileExist (FilePath
path FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
videoExtension)) m Bool -> (Bool -> m FilePath) -> m FilePath
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> FilePath -> m FilePath
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path
    Bool
True -> Integer -> m FilePath
loop (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)