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 Safe
import System.Directory
import System.Exit
import System.Process
import Text.Regex


-- | 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
-- sandwich-webdriver documentation manually.
-- It also caused problems when trying to make the demos easy to run on a clean machine or a Mac.
-- Instead, we 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: 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 here:
-- https://github.com/rr-/screeninfo/blob/master/screeninfo/enumerators/xinerama.py
-- but again, that would require users to install those libraries. xrandr itself seems like an easier
-- dependency.
getResolution :: IO (Int, Int, Int, Int)
getResolution :: IO (Int, Int, Int, Int)
getResolution = Maybe [(String, String)] -> IO (Int, Int, Int, Int)
getResolution' forall a. Maybe a
Nothing

getResolutionForDisplay :: Int -> IO (Int, Int, Int, Int)
getResolutionForDisplay :: Int -> IO (Int, Int, Int, Int)
getResolutionForDisplay Int
n = Maybe [(String, String)] -> IO (Int, Int, Int, Int)
getResolution' (forall a. a -> Maybe a
Just [(String
"DISPLAY", String
":" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
n)])

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

  (ExitCode
exitCode, String
sout, String
serr) <- CreateProcess -> String -> IO (ExitCode, String, String)
readCreateProcessWithExitCode ((String -> [String] -> CreateProcess
proc String
xrandrPath []) { env :: Maybe [(String, String)]
env = Maybe [(String, String)]
xrandrEnv }) String
""
  case ExitCode
exitCode of
    ExitCode
ExitSuccess -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ExitFailure Int
n -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> IOError
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 :: [Text]
connectedLines = String
sout
                     forall a b. a -> (a -> b) -> b
& Text -> [Text]
T.lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
                     forall a b. a -> (a -> b) -> b
& forall a. (a -> Bool) -> [a] -> [a]
filter (Text
"connected" Text -> Text -> Bool
`T.isInfixOf`)
                     forall a b. a -> (a -> b) -> b
& forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy Text -> Text -> Ordering
preferPrimary

  case forall a. [a] -> Maybe a
headMay [(Int
x, Int
y, Int
w, Int
h) | (Regex -> String -> Maybe [String]
matchRegex Regex
resolutionRegex -> Just [(forall a. Read a => String -> Maybe a
readMay -> Just Int
w), (forall a. Read a => String -> Maybe a
readMay -> Just Int
h), (forall a. Read a => String -> Maybe a
readMay -> Just Int
x), (forall a. Read a => String -> Maybe a
readMay -> Just Int
y)]) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
T.unpack [Text]
connectedLines] of
    Maybe (Int, Int, Int, Int)
Nothing -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"Couldn't parse xrandr output to find screen resolution.\n\n***Stdout***\n\n#{stdout}"
    Just (Int, Int, Int, Int)
x -> forall (m :: * -> *) a. Monad m => a -> m a
return (Int, Int, Int, Int)
x

resolutionRegex :: Regex
resolutionRegex :: Regex
resolutionRegex = String -> Regex
mkRegex String
"([0-9]+)x([0-9]+)\\+([0-9]+)\\+([0-9]+)"

preferPrimary :: T.Text -> T.Text -> Ordering
preferPrimary :: Text -> Text -> Ordering
preferPrimary Text
x Text
y =
  if | Bool
xPrimary Bool -> Bool -> Bool
&& Bool
yPrimary -> Ordering
EQ
     | Bool
xPrimary -> Ordering
LT
     | Bool
yPrimary -> Ordering
GT
     | Bool
otherwise -> Ordering
EQ
  where
    xPrimary :: Bool
xPrimary = Text
"primary" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` (Text -> [Text]
T.words Text
x)
    yPrimary :: Bool
yPrimary = Text
"primary" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` (Text -> [Text]
T.words Text
y)