-- | 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 Data.String.Interpolate
import GHC.Stack
import qualified Graphics.X11.Xinerama as X
import qualified Graphics.X11.Xlib.Display as X
import Safe
import Test.Sandwich
import Test.Sandwich.WebDriver.Internal.Types
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)
getScreenResolutionX11 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 -> 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)
getScreenResolutionX11 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)
getScreenResolutionX11 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 -> m (Int, Int, Int, Int)
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadMask m, MonadLogger m) =>
WebDriver -> m (Int, Int, Int, Int)
getScreenResolutionX11

-- * Internal

getScreenResolutionX11 :: (HasCallStack, MonadIO m, MonadMask m, MonadLogger m) => WebDriver -> m (Int, Int, Int, Int)
getScreenResolutionX11 :: WebDriver -> m (Int, Int, Int, Int)
getScreenResolutionX11 (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 -> FilePath -> Int -> m (Int, Int, Int, Int)
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadMask m, MonadLogger m) =>
FilePath -> Int -> m (Int, Int, Int, Int)
getScreenResolutionX11' FilePath
":0" Int
0
    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
..}) -> FilePath -> Int -> m (Int, Int, Int, Int)
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadMask m, MonadLogger m) =>
FilePath -> Int -> m (Int, Int, Int, Int)
getScreenResolutionX11' (FilePath
":" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
xvfbDisplayNum) Int
0

getScreenResolutionX11' :: (HasCallStack, MonadIO m, MonadMask m, MonadLogger m) => String -> Int -> m (Int, Int, Int, Int)
getScreenResolutionX11' :: FilePath -> Int -> m (Int, Int, Int, Int)
getScreenResolutionX11' FilePath
displayString Int
screenNumber = do
  m Display
-> (Display -> m ())
-> (Display -> m (Int, Int, Int, Int))
-> m (Int, Int, Int, Int)
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (IO Display -> m Display
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Display -> m Display) -> IO Display -> m Display
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Display
X.openDisplay FilePath
displayString) (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Display -> IO ()) -> Display -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Display -> IO ()
X.closeDisplay) ((Display -> m (Int, Int, Int, Int)) -> m (Int, Int, Int, Int))
-> (Display -> m (Int, Int, Int, Int)) -> m (Int, Int, Int, Int)
forall a b. (a -> b) -> a -> b
$ \Display
display -> do
    IO (Maybe [XineramaScreenInfo]) -> m (Maybe [XineramaScreenInfo])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Display -> IO (Maybe [XineramaScreenInfo])
X.xineramaQueryScreens Display
display) m (Maybe [XineramaScreenInfo])
-> (Maybe [XineramaScreenInfo] -> m (Int, Int, Int, Int))
-> m (Int, Int, Int, Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe [XineramaScreenInfo]
Nothing -> do
        -- TODO: this happens in CI when running under Xvfb. How to get resolution in that case?
        Text -> m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
logError [i|Couldn't query X11 for screens for display "#{display}"; using default resolution 1920x1080|]
        (Int, Int, Int, Int) -> m (Int, Int, Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0, Int
0, Int
1920, Int
1080)
      Just [XineramaScreenInfo]
infos -> do
        case [(CShort, CShort, CShort, CShort)]
-> Maybe (CShort, CShort, CShort, CShort)
forall a. [a] -> Maybe a
headMay [(CShort
xsi_x_org, CShort
xsi_y_org, CShort
xsi_width, CShort
xsi_height) | X.XineramaScreenInfo {CShort
CInt
xsi_screen_number :: XineramaScreenInfo -> CInt
xsi_x_org :: XineramaScreenInfo -> CShort
xsi_y_org :: XineramaScreenInfo -> CShort
xsi_width :: XineramaScreenInfo -> CShort
xsi_height :: XineramaScreenInfo -> CShort
xsi_screen_number :: CInt
xsi_height :: CShort
xsi_width :: CShort
xsi_y_org :: CShort
xsi_x_org :: CShort
..} <- [XineramaScreenInfo]
infos
                                                                    , CInt
xsi_screen_number CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
screenNumber] of
          Maybe (CShort, CShort, CShort, CShort)
Nothing -> IOError -> m (Int, Int, Int, Int)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (IOError -> m (Int, Int, Int, Int))
-> IOError -> m (Int, Int, Int, Int)
forall a b. (a -> b) -> a -> b
$ FilePath -> IOError
userError [i|Failed to get screen resolution (couldn't find screen number #{screenNumber})|]
          Just (CShort
x, CShort
y, CShort
w, CShort
h) -> (Int, Int, Int, Int) -> m (Int, Int, Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (CShort -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CShort
x, CShort -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CShort
y, CShort -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CShort
w, CShort -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CShort
h)