Internal.hs

{-# OPTIONS_GHC -fno-warn-unused-matches #-}
{-# LANGUAGE CPP #-}

module Test.Sandwich.WebDriver.Video.Internal (
  getVideoArgs
  , videoExtension
  ) where

import Control.Monad.IO.Unlift
import Control.Monad.Logger
import Control.Monad.Reader
import Data.String.Interpolate
import System.Process
import Test.Sandwich
import Test.Sandwich.WebDriver.Internal.Binaries.Ffmpeg
import Test.Sandwich.WebDriver.Internal.OnDemand
import Test.Sandwich.WebDriver.Internal.Types
import Test.Sandwich.WebDriver.Types
import Test.Sandwich.WebDriver.Video.Types

#ifdef darwin_HOST_OS
getMacScreenNumber :: IO (Maybe Int)
getMacScreenNumber = return $ Just 0 -- TODO
#endif

#ifdef linux_HOST_OS
import Data.Function ((&), on)
import qualified Data.List as L
import Data.Maybe
import System.FilePath ((<.>))
import UnliftIO.Environment
#endif


videoExtension :: String
videoExtension = "avi"

getVideoArgs :: (
  MonadUnliftIO m, MonadLoggerIO m
  , MonadReader context m, HasBaseContext context, HasTestWebDriverContext context
  ) => FilePath -> (Float, Float, Float, Float) -> VideoSettings -> Maybe XvfbSession -> m (CreateProcess, FilePath)
getVideoArgs path (width, height, x, y) (VideoSettings {..}) maybeXvfbSession = do
  TestWebDriverContext {wdFfmpeg, wdFfmpegToUse} <- getContext webdriver
  ffmpeg <- getOnDemand wdFfmpeg (obtainFfmpeg wdFfmpegToUse)

#ifdef linux_HOST_OS
  displayNum <- case maybeXvfbSession of
    Nothing -> fromMaybe "" <$> (liftIO $ lookupEnv "DISPLAY")
    Just (XvfbSession {xvfbDisplayNum}) -> return $ ":" <> show xvfbDisplayNum

  baseEnv <- getEnvironment

  let env = case maybeXvfbSession of
        Nothing -> baseEnv
        Just (XvfbSession {..}) -> baseEnv
          & (("DISPLAY", displayNum) :)
          & (("XAUTHORITY", xvfbXauthority) :)
          & L.nubBy ((==) `on` fst)

  let videoPath = path <.> videoExtension

  let cmd = ["-y"
            , "-nostdin"
            , "-f", "x11grab"
            , "-s", [i|#{width}x#{height}|]
            , "-i", [i|#{displayNum}.0+#{x},#{y}|]]
            ++ xcbgrabOptions
            ++ [videoPath]
  return ((proc ffmpeg cmd) { env = Just env }, videoPath)
#endif

#ifdef darwin_HOST_OS
  maybeScreenNumber <- liftIO getMacScreenNumber
  let videoPath = [i|#{path}.avi|]
  let cmd = case maybeScreenNumber of
        Just screenNumber -> ["-y"
                             , "-nostdin"
                             , "-f", "avfoundation"
                             , "-video-size", [i|#{width}x#{height}|]
                             , "-vf", [i|crop=#{width}:#{height}:#{x}:#{y}|]
                             , "-i", [i|#{screenNumber}|]]
                             ++ avfoundationOptions
                             ++ [videoPath]
        Nothing -> error [i|Not launching ffmpeg since OS X screen number couldn't be determined.|]
  return ((proc ffmpeg cmd) { env = Nothing }, videoPath)
#endif

#ifdef mingw32_HOST_OS
  let videoPath = [i|#{path}.mkv|]
  let cmd = ["-f", "gdigrab"
            , "-nostdin"
            , "-i", "desktop"
            , "-offset_x", [i|#{x}|]
            , "-offset_y", [i|#{y}|]
            , "-video-size", [i|#{width}x#{height}|]
            ]
            ++ gdigrabOptions
            ++ [videoPath]
  return ((proc ffmpeg cmd) { env = Nothing }, videoPath)
#endif