{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ConstraintKinds #-}

module Test.Sandwich.WebDriver.Video (
  startVideoRecording
  , endVideoRecording

  -- * Helpers
  , startFullScreenVideoRecording
  , startBrowserVideoRecording

  -- * Configuration
  , 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)

-- | Wrapper around 'startVideoRecording' which uses the full screen dimensions.
startFullScreenVideoRecording :: (
  BaseVideoConstraints context m, MonadMask m
  ) => FilePath -> VideoSettings -> m ProcessHandle
startFullScreenVideoRecording :: FilePath -> VideoSettings -> m ProcessHandle
startFullScreenVideoRecording FilePath
path VideoSettings
videoSettings = do
  WebDriver
sess <- Label "webdriver" WebDriver -> m WebDriver
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}) -> (Int, Int) -> m (Int, Int)
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 :: * -> *).
(HasCallStack, MonadIO m, MonadMask m, MonadLogger m) =>
WebDriver -> m (Int, Int, Int, Int)
getScreenResolution WebDriver
sess
      (Int, Int) -> m (Int, Int)
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 ProcessHandle
forall context (m :: * -> *).
BaseVideoConstraints context m =>
FilePath
-> (Word, Word, Int, Int) -> VideoSettings -> m ProcessHandle
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, MonadThrow m, HasWebDriverSessionContext context, W.WebDriver m
  ) => FilePath -> VideoSettings -> m ProcessHandle
startBrowserVideoRecording :: FilePath -> VideoSettings -> m ProcessHandle
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 ProcessHandle
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

-- | Record video to a given path, for a given rectangle specified as (width, height, x, y).
startVideoRecording :: (
  BaseVideoConstraints context m
  ) => FilePath -> (Word, Word, Int, Int) -> VideoSettings -> m ProcessHandle
startVideoRecording :: FilePath
-> (Word, Word, Int, Int) -> VideoSettings -> m ProcessHandle
startVideoRecording FilePath
path (Word
width, Word
height, Int
x, Int
y) VideoSettings
vs = do
  WebDriver
sess <- Label "webdriver" WebDriver -> m WebDriver
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' <- IO CreateProcess -> m CreateProcess
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CreateProcess -> m CreateProcess)
-> IO CreateProcess -> m CreateProcess
forall a b. (a -> b) -> a -> b
$ FilePath
-> (Word, Word, Int, Int)
-> VideoSettings
-> Maybe XvfbSession
-> IO CreateProcess
forall (m :: * -> *) src a b c d.
(MonadIO m, Interpolatable 'False src FilePath,
 Interpolatable 'False a FilePath, Interpolatable 'False b FilePath,
 Interpolatable 'False c FilePath,
 Interpolatable 'False d FilePath) =>
src
-> (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 -> 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 -> CreateProcess -> m ProcessHandle
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadLogger m) =>
CreateProcess -> m ProcessHandle
createProcessWithLogging CreateProcess
cp
    Bool
True -> do
      IO ProcessHandle -> m ProcessHandle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessHandle -> m ProcessHandle)
-> IO ProcessHandle -> m ProcessHandle
forall a b. (a -> b) -> a -> b
$ IO Handle
-> (Handle -> IO ())
-> (Handle -> IO ProcessHandle)
-> IO ProcessHandle
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 ((Handle -> IO ProcessHandle) -> IO ProcessHandle)
-> (Handle -> IO ProcessHandle) -> IO ProcessHandle
forall a b. (a -> b) -> a -> b
$ \Handle
hout ->
        IO Handle
-> (Handle -> IO ())
-> (Handle -> IO ProcessHandle)
-> IO ProcessHandle
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 ((Handle -> IO ProcessHandle) -> IO ProcessHandle)
-> (Handle -> IO ProcessHandle) -> IO ProcessHandle
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 })
          ProcessHandle -> IO ProcessHandle
forall (m :: * -> *) a. Monad m => a -> m a
return ProcessHandle
p

-- | Gracefully stop the 'ProcessHandle' returned by 'startVideoRecording'.
endVideoRecording :: (
  MonadLoggerIO m, MonadCatch m
  ) => ProcessHandle -> m ()
endVideoRecording :: ProcessHandle -> m ()
endVideoRecording ProcessHandle
p = do
  m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
catchAny (IO () -> m ()
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p) m ExitCode -> (ExitCode -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ExitCode
ExitSuccess -> () -> m ()
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 (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}'|]