-- | Functions for manipulating browser windows.

{-# LANGUAGE QuasiQuotes #-}

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

  -- * Querying screen info
  , getScreenResolution
  ) where

import Control.Exception.Safe
import Control.Monad.IO.Class
import Control.Monad.Logger (MonadLogger)
import Control.Monad.Reader
import Data.Bits as B
import Data.Maybe
import GHC.Stack
import Test.Sandwich
import Test.Sandwich.WebDriver.Internal.Types
import Test.Sandwich.WebDriver.Resolution
import Test.WebDriver
import qualified Test.WebDriver.Class as W


-- | Position the window on the left 50% of the screen.
setWindowLeftSide :: (HasCallStack, MonadIO wd, WebDriverContext context wd, MonadReader context wd, W.WebDriver wd, MonadLogger wd, MonadMask wd) => wd ()
setWindowLeftSide :: wd ()
setWindowLeftSide = do
  WebDriver
sess <- Label "webdriver" WebDriver -> wd 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
  (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) -> wd (Int, Int, Int, Int)
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 -> wd (Int, Int, Int, Int)
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadMask m, MonadLogger m) =>
WebDriver -> m (Int, Int, Int, Int)
getScreenResolution WebDriver
sess
  (Int, Int) -> wd ()
forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
(Int, Int) -> wd ()
setWindowPos (Int
x, Int
y)
  (Word, Word) -> wd ()
forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
(Word, Word) -> wd ()
setWindowSize (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Bits a => a -> Int -> a
B.shift Int
width (-Int
1), Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height)

-- | Position the window on the right 50% of the screen.
setWindowRightSide :: (HasCallStack, MonadIO wd, WebDriverContext context wd, MonadReader context wd, W.WebDriver wd, MonadLogger wd, MonadMask wd) => wd ()
setWindowRightSide :: wd ()
setWindowRightSide = do
  WebDriver
sess <- Label "webdriver" WebDriver -> wd 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
  (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) -> wd (Int, Int, Int, Int)
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 -> wd (Int, Int, Int, Int)
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadMask m, MonadLogger m) =>
WebDriver -> m (Int, Int, Int, Int)
getScreenResolution WebDriver
sess
  let pos :: (Int, Int)
pos = (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Bits a => a -> Int -> a
B.shift Int
width (-Int
1)), Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0)
  (Int, Int) -> wd ()
forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
(Int, Int) -> wd ()
setWindowPos (Int, Int)
pos
  (Word, Word) -> wd ()
forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
(Word, Word) -> wd ()
setWindowSize (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Bits a => a -> Int -> a
B.shift Int
width (-Int
1), Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
height)

-- | Fullscreen the browser window.
setWindowFullScreen :: (HasCallStack, MonadIO wd, WebDriverContext context wd, MonadReader context wd, W.WebDriver wd, MonadLogger wd, MonadMask wd) => wd ()
setWindowFullScreen :: wd ()
setWindowFullScreen = do
  WebDriver
sess <- Label "webdriver" WebDriver -> wd 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
  (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) -> wd (Int, Int, Int, Int)
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 -> wd (Int, Int, Int, Int)
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadMask m, MonadLogger m) =>
WebDriver -> m (Int, Int, Int, Int)
getScreenResolution WebDriver
sess
  (Int, Int) -> wd ()
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) -> wd ()
forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
(Word, Word) -> wd ()
setWindowSize (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)

-- | Get the screen resolution as (x, y, width, height). (The x and y coordinates may be nonzero in multi-monitor setups.)
getScreenResolution :: (HasCallStack, MonadIO m, MonadMask m, MonadLogger m) => WebDriver -> m (Int, Int, Int, Int)
getScreenResolution :: WebDriver -> m (Int, Int, Int, Int)
getScreenResolution (WebDriver {wdWebDriver :: WebDriver
-> (Handle, Handle, ProcessHandle, FilePath, FilePath,
    Maybe XvfbSession)
wdWebDriver=(Handle
_, Handle
_, ProcessHandle
_, FilePath
_, FilePath
_, Maybe XvfbSession
maybeXvfbSession)}) = case Maybe XvfbSession
maybeXvfbSession of
  Maybe XvfbSession
Nothing -> IO (Int, Int, Int, Int) -> m (Int, Int, Int, Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Int, Int, Int, Int)
getResolution
  Just (XvfbSession {Int
FilePath
Maybe ProcessHandle
(Int, Int)
ProcessHandle
xvfbFluxboxProcess :: XvfbSession -> Maybe ProcessHandle
xvfbProcess :: XvfbSession -> ProcessHandle
xvfbDimensions :: XvfbSession -> (Int, Int)
xvfbXauthority :: XvfbSession -> FilePath
xvfbDisplayNum :: XvfbSession -> Int
xvfbFluxboxProcess :: Maybe ProcessHandle
xvfbProcess :: ProcessHandle
xvfbDimensions :: (Int, Int)
xvfbXauthority :: FilePath
xvfbDisplayNum :: Int
..}) -> IO (Int, Int, Int, Int) -> m (Int, Int, Int, Int)
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
$ Int -> IO (Int, Int, Int, Int)
getResolutionForDisplay Int
xvfbDisplayNum