Resolution.hs

{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

{-|
Helper module to obtain the current display resolution. This is useful for positioning windows or setting up video recording.
-}


module Test.Sandwich.WebDriver.Resolution (
  getResolution
  , getResolutionForDisplay
  ) where

import Control.Exception
import Data.Function
import qualified Data.List as L
import Data.String.Interpolate
import qualified Data.Text as T
import GHC.Stack
import Safe
import System.Directory
import System.Exit
import System.Process
import Text.Regex.TDFA


-- | Note: previously we got the screen resolution on Linux using the X11 Haskell library.
--
-- This was a troublesome dependency because it wouldn't build on Hackage, forcing us to upload
-- the documentation manually.
--
-- It also caused problems when trying to make the demos easy to run on a clean machine or a Mac.
-- So instead, we now implement platform-specific 'getResolution' functions.
--
-- On Linux, the simplest way seems to be to parse the output of @xrandr@. This is the approach taken by
-- at least one other library called [screenres](https://github.com/davidmarkclements/screenres/blob/master/linux.cc).
-- The other way to do it would be to load the x11 and/or xinerama libraries like is done in
-- [screeninfo](https://github.com/rr-/screeninfo/blob/master/screeninfo/enumerators/xinerama.py),
-- but again, that would require users to install those libraries. Just using @xrandr@ itself seems like an easier
-- dependency.
getResolution :: (
  HasCallStack
  )
  -- | Returns (x, y, width, height)
  => IO (Int, Int, Int, Int)
getResolution = getResolution' Nothing

-- | Get the resolution for a specific display.
getResolutionForDisplay :: (
  HasCallStack
  )
  -- | Display number
  => Int
  -- | Returns (x, y, width, height)
  -> IO (Int, Int, Int, Int)
getResolutionForDisplay n = getResolution' (Just [("DISPLAY", ":" <> show n)])

-- | Note: this doesn't pick up display scaling on Ubuntu 20.04.
getResolution' :: (HasCallStack) => Maybe [(String, String)] -> IO (Int, Int, Int, Int)
getResolution' xrandrEnv = do
  xrandrPath <- findExecutable "xrandr" >>= \case
    Just x -> return x
    Nothing -> throwIO $ userError "Couldn't find xrandr executable. Please make sure it's in the path so that sandwich can get the screen resolution."

  (exitCode, sout, serr) <- readCreateProcessWithExitCode ((proc xrandrPath []) { env = xrandrEnv }) ""
  case exitCode of
    ExitSuccess -> return ()
    ExitFailure n -> throwIO $ userError [i|Couldn't parse xrandr output to find screen resolution (exit code #{n}).\n***Stdout***\n\n#{sout}\n\n***Stderr***\n\n#{serr}|]

  let connectedLines = sout
                     & T.lines . T.pack
                     & filter ("connected" `T.isInfixOf`)
                     & L.sortBy preferPrimary

  case headMay [(x, y, w, h) | (parseRegex -> Just (x, y, w, h)) <- fmap T.unpack connectedLines] of
    Nothing -> throwIO $ userError "Couldn't parse xrandr output to find screen resolution.\n\n***Stdout***\n\n#{stdout}"
    Just x -> return x

parseRegex :: String -> Maybe (Int, Int, Int, Int)
parseRegex context = case (context =~~ ("([0-9]+)x([0-9]+)\\+([0-9]+)\\+([0-9]+)" :: String)) :: Maybe (String, String, String, [String]) of
  Just (_before, _fullMatch, _after, [(readMay -> Just w), (readMay -> Just h), (readMay -> Just x), (readMay -> Just y)]) -> Just (x, y, w, h)
  _ -> Nothing

preferPrimary :: T.Text -> T.Text -> Ordering
preferPrimary x y =
  if | xPrimary && yPrimary -> EQ
     | xPrimary -> LT
     | yPrimary -> GT
     | otherwise -> EQ
  where
    xPrimary = "primary" `L.elem` (T.words x)
    yPrimary = "primary" `L.elem` (T.words y)