-- | Functions for manipulating browser windows.

module Test.Sandwich.WebDriver.Windows (
  -- * Window positioning
  setWindowLeftSide
  , setWindowRightSide
  , setWindowFullScreen

  -- * Screen resolution
  , getScreenResolution

  -- * Lower-level
  , getResolution
  , getResolutionForDisplay
  ) where

import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Maybe
import Test.Sandwich
import Test.Sandwich.WebDriver.Internal.Types
import Test.Sandwich.WebDriver.Resolution
import Test.Sandwich.WebDriver.Types
import Test.WebDriver
import qualified Test.WebDriver.Class as W


-- | Position the window on the left 50% of the screen.
setWindowLeftSide :: (WebDriverMonad m context, MonadReader context m, W.WebDriver m) => m ()
setWindowLeftSide :: forall (m :: * -> *) context.
(WebDriverMonad m context, MonadReader context m, WebDriver m) =>
m ()
setWindowLeftSide = 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
  (Int
x, Int
y, Int
width, Int
height) <- case WdOptions -> RunMode
runMode (WdOptions -> RunMode) -> WdOptions -> RunMode
forall a b. (a -> b) -> a -> b
$ WebDriver -> WdOptions
wdOptions WebDriver
sess of
    RunHeadless (HeadlessConfig {Maybe (Int, Int)
headlessResolution :: Maybe (Int, Int)
headlessResolution :: HeadlessConfig -> Maybe (Int, Int)
..}) -> (Int, Int, Int, Int) -> m (Int, Int, Int, Int)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0, Int
0, Int
w, Int
h)
      where (Int
w, Int
h) = (Int, Int) -> Maybe (Int, Int) -> (Int, Int)
forall a. a -> Maybe a -> a
fromMaybe (Int
1920, Int
1080) Maybe (Int, Int)
headlessResolution
    RunMode
_ -> WebDriver -> m (Int, Int, Int, Int)
forall (m :: * -> *).
MonadIO m =>
WebDriver -> m (Int, Int, Int, Int)
getScreenResolution WebDriver
sess

  (Double
screenWidth, Double
screenHeight) <- Int -> Int -> m (Double, Double)
forall (m :: * -> *).
(MonadIO m, WebDriver m) =>
Int -> Int -> m (Double, Double)
getScreenPixelDimensions Int
width Int
height

  (Int, Int) -> m ()
forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
(Int, Int) -> wd ()
setWindowPos (Int
x, Int
y)
  (Word, Word) -> m ()
forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
(Word, Word) -> wd ()
setWindowSize (Double -> Word
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
screenWidth Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2.0), Double -> Word
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
screenHeight)

-- | Position the window on the right 50% of the screen.
setWindowRightSide :: (WebDriverMonad m context, MonadReader context m, W.WebDriver m) => m ()
setWindowRightSide :: forall (m :: * -> *) context.
(WebDriverMonad m context, MonadReader context m, WebDriver m) =>
m ()
setWindowRightSide = 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
  (Int
x, Int
y, Int
width, Int
height) <- case WdOptions -> RunMode
runMode (WdOptions -> RunMode) -> WdOptions -> RunMode
forall a b. (a -> b) -> a -> b
$ WebDriver -> WdOptions
wdOptions WebDriver
sess of
    RunHeadless (HeadlessConfig {Maybe (Int, Int)
headlessResolution :: HeadlessConfig -> Maybe (Int, Int)
headlessResolution :: Maybe (Int, Int)
..}) -> (Int, Int, Int, Int) -> m (Int, Int, Int, Int)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0, Int
0, Int
w, Int
h)
      where (Int
w, Int
h) = (Int, Int) -> Maybe (Int, Int) -> (Int, Int)
forall a. a -> Maybe a -> a
fromMaybe (Int
1920, Int
1080) Maybe (Int, Int)
headlessResolution
    RunMode
_ -> WebDriver -> m (Int, Int, Int, Int)
forall (m :: * -> *).
MonadIO m =>
WebDriver -> m (Int, Int, Int, Int)
getScreenResolution WebDriver
sess

  (Double
screenWidth, Double
screenHeight) <- Int -> Int -> m (Double, Double)
forall (m :: * -> *).
(MonadIO m, WebDriver m) =>
Int -> Int -> m (Double, Double)
getScreenPixelDimensions Int
width Int
height

  (Int, Int) -> m ()
forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
(Int, Int) -> wd ()
setWindowPos (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
screenWidth Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2.0), Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0)
  (Word, Word) -> m ()
forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
(Word, Word) -> wd ()
setWindowSize (Double -> Word
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
screenWidth Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2.0), Double -> Word
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
screenHeight)

-- | Fullscreen the browser window.
setWindowFullScreen :: (WebDriverMonad m context, MonadReader context m, W.WebDriver m) => m ()
setWindowFullScreen :: forall (m :: * -> *) context.
(WebDriverMonad m context, MonadReader context m, WebDriver m) =>
m ()
setWindowFullScreen = 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
  (Int
x, Int
y, Int
width, Int
height) <- case WdOptions -> RunMode
runMode (WdOptions -> RunMode) -> WdOptions -> RunMode
forall a b. (a -> b) -> a -> b
$ WebDriver -> WdOptions
wdOptions WebDriver
sess of
    RunHeadless (HeadlessConfig {Maybe (Int, Int)
headlessResolution :: HeadlessConfig -> Maybe (Int, Int)
headlessResolution :: Maybe (Int, Int)
..}) -> (Int, Int, Int, Int) -> m (Int, Int, Int, Int)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0, Int
0, Int
w, Int
h)
      where (Int
w, Int
h) = (Int, Int) -> Maybe (Int, Int) -> (Int, Int)
forall a. a -> Maybe a -> a
fromMaybe (Int
1920, Int
1080) Maybe (Int, Int)
headlessResolution
    RunMode
_ -> WebDriver -> m (Int, Int, Int, Int)
forall (m :: * -> *).
MonadIO m =>
WebDriver -> m (Int, Int, Int, Int)
getScreenResolution WebDriver
sess

  (Double
screenWidth, Double
screenHeight) <- Int -> Int -> m (Double, Double)
forall (m :: * -> *).
(MonadIO m, WebDriver m) =>
Int -> Int -> m (Double, Double)
getScreenPixelDimensions Int
width Int
height

  (Int, Int) -> m ()
forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
(Int, Int) -> wd ()
setWindowPos (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0, Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0)
  (Word, Word) -> m ()
forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
(Word, Word) -> wd ()
setWindowSize (Double -> Word
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
screenWidth, Double -> Word
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
screenHeight)

-- | Get the screen resolution as (x, y, width, height). (The x and y coordinates may be nonzero in multi-monitor setups.)
-- This function works with both normal 'RunMode' and Xvfb mode.
getScreenResolution :: (MonadIO m) => WebDriver -> m (Int, Int, Int, Int)
getScreenResolution :: forall (m :: * -> *).
MonadIO m =>
WebDriver -> m (Int, Int, Int, Int)
getScreenResolution (WebDriver {wdWebDriver :: WebDriver -> (ProcessHandle, Maybe XvfbSession)
wdWebDriver=(ProcessHandle
_, Maybe XvfbSession
maybeXvfbSession)}) = case Maybe XvfbSession
maybeXvfbSession of
  Maybe XvfbSession
Nothing -> IO (Int, Int, Int, Int) -> m (Int, Int, Int, Int)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Int, Int, Int, Int)
HasCallStack => IO (Int, Int, Int, Int)
getResolution
  Just (XvfbSession {Int
FilePath
Maybe ProcessHandle
(Int, Int)
ProcessHandle
xvfbDisplayNum :: Int
xvfbXauthority :: FilePath
xvfbDimensions :: (Int, Int)
xvfbProcess :: ProcessHandle
xvfbFluxboxProcess :: Maybe ProcessHandle
xvfbDisplayNum :: XvfbSession -> Int
xvfbXauthority :: XvfbSession -> FilePath
xvfbDimensions :: XvfbSession -> (Int, Int)
xvfbProcess :: XvfbSession -> ProcessHandle
xvfbFluxboxProcess :: XvfbSession -> Maybe ProcessHandle
..}) -> IO (Int, Int, Int, Int) -> m (Int, Int, Int, Int)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Int, Int, Int, Int) -> m (Int, Int, Int, Int))
-> IO (Int, Int, Int, Int) -> m (Int, Int, Int, Int)
forall a b. (a -> b) -> a -> b
$ HasCallStack => Int -> IO (Int, Int, Int, Int)
Int -> IO (Int, Int, Int, Int)
getResolutionForDisplay Int
xvfbDisplayNum

getScreenPixelDimensions :: (MonadIO m, W.WebDriver m) => Int -> Int -> m (Double, Double)
getScreenPixelDimensions :: forall (m :: * -> *).
(MonadIO m, WebDriver m) =>
Int -> Int -> m (Double, Double)
getScreenPixelDimensions Int
width Int
height = do
  Double
devicePixelRatio <- [JSArg] -> Text -> m (Maybe Double)
forall (f :: * -> *) a (wd :: * -> *).
(Foldable f, FromJSON a, WebDriver wd) =>
f JSArg -> Text -> wd a
executeJS [] Text
"return window.devicePixelRatio" m (Maybe Double) -> (Maybe Double -> m Double) -> m Double
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (Double
ratio :: Double) -> Double -> m Double
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
ratio
    Maybe Double
Nothing -> Double -> m Double
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
1.0

  let screenWidth :: Double
screenWidth = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
devicePixelRatio
  let screenHeight :: Double
screenHeight = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
devicePixelRatio

  (Double, Double) -> m (Double, Double)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
screenWidth, Double
screenHeight)