diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,10 @@ ## Unreleased changes +# 0.1.0.6 + +* Remove X11 dependency and replace with per-platform code to get screen resolution. + # 0.1.0.5 * Getting documentation sorted out. diff --git a/darwin-src/Test/Sandwich/WebDriver/Resolution.hs b/darwin-src/Test/Sandwich/WebDriver/Resolution.hs new file mode 100644 --- /dev/null +++ b/darwin-src/Test/Sandwich/WebDriver/Resolution.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ViewPatterns #-} + +module Test.Sandwich.WebDriver.Resolution ( + getResolution + , getResolutionForDisplay + ) where + +import Data.Word + + +getResolution :: IO (Int, Int, Int, Int) +getResolution = do + ddid <- cg_main_display_id + getResolutionForDisplay (fromIntegral ddid) + +-- TODO: currently we just use the "main display" ID. +-- When when we return 0 for x and y here, the WebDriver setWindowPos +-- should just position the window on the main display. +-- This probably won't work at all for xvfb displays, but we have more work to do there... +getResolutionForDisplay :: Int -> IO (Int, Int, Int, Int) +getResolutionForDisplay ddid = do + width <- cg_display_pixels_wide (fromIntegral ddid) + height <- cg_display_pixels_high (fromIntegral ddid) + return (0, 0, fromIntegral width, fromIntegral height) + +type CGDirectDisplayID = Word32 + +foreign import ccall unsafe " CGMainDisplayID" + cg_main_display_id :: IO CGDirectDisplayID + +foreign import ccall unsafe " CGDisplayPixelsWide" + cg_display_pixels_wide :: CGDirectDisplayID -> IO CGDirectDisplayID + +foreign import ccall unsafe " CGDisplayPixelsHigh" + cg_display_pixels_high :: CGDirectDisplayID -> IO CGDirectDisplayID diff --git a/linux-src/Test/Sandwich/WebDriver/Resolution.hs b/linux-src/Test/Sandwich/WebDriver/Resolution.hs new file mode 100644 --- /dev/null +++ b/linux-src/Test/Sandwich/WebDriver/Resolution.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ViewPatterns #-} + +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 = getResolution' Nothing + +getResolutionForDisplay :: Int -> 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' :: 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) | (matchRegex resolutionRegex -> Just [(readMay -> Just w), (readMay -> Just h), (readMay -> Just x), (readMay -> Just y)]) <- 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 + +resolutionRegex :: Regex +resolutionRegex = mkRegex "([0-9]+)x([0-9]+)\\+([0-9]+)\\+([0-9]+)" + +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) diff --git a/sandwich-webdriver.cabal b/sandwich-webdriver.cabal --- a/sandwich-webdriver.cabal +++ b/sandwich-webdriver.cabal @@ -3,11 +3,9 @@ -- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: d0f87b2b7cab058dff99c4329afa43f6e20ee3c5c867a9495f09f543f73f2ed6 name: sandwich-webdriver -version: 0.1.0.5 +version: 0.1.0.6 synopsis: Sandwich integration with Selenium WebDriver description: Please see the . category: Testing @@ -46,7 +44,7 @@ Test.Sandwich.WebDriver.Video Test.Sandwich.WebDriver.Windows other-modules: - Paths_sandwich_webdriver + Test.Sandwich.WebDriver.Resolution hs-source-dirs: src default-extensions: @@ -60,11 +58,9 @@ LambdaCase ghc-options: -W build-depends: - X11 - , aeson + aeson , base <5 , containers - , convertible , data-default , directory , exceptions @@ -94,6 +90,19 @@ , unordered-containers , vector , webdriver + if os(darwin) + hs-source-dirs: + darwin-src + frameworks: + CoreGraphics + if os(windows) + hs-source-dirs: + windows-src + if os(linux) + hs-source-dirs: + linux-src + build-depends: + regex-compat default-language: Haskell2010 executable sandwich-webdriver-exe @@ -114,11 +123,9 @@ LambdaCase ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - X11 - , aeson + aeson , base <5 , containers - , convertible , data-default , directory , exceptions @@ -149,6 +156,25 @@ , unordered-containers , vector , webdriver + if os(darwin) + other-modules: + Test.Sandwich.WebDriver.Resolution + hs-source-dirs: + darwin-src + frameworks: + CoreGraphics + if os(windows) + other-modules: + Test.Sandwich.WebDriver.Resolution + hs-source-dirs: + windows-src + if os(linux) + other-modules: + Test.Sandwich.WebDriver.Resolution + hs-source-dirs: + linux-src + build-depends: + regex-compat default-language: Haskell2010 test-suite sandwich-webdriver-test @@ -169,11 +195,9 @@ LambdaCase ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - X11 - , aeson + aeson , base <5 , containers - , convertible , data-default , directory , exceptions @@ -204,4 +228,23 @@ , unordered-containers , vector , webdriver + if os(darwin) + other-modules: + Test.Sandwich.WebDriver.Resolution + hs-source-dirs: + darwin-src + frameworks: + CoreGraphics + if os(windows) + other-modules: + Test.Sandwich.WebDriver.Resolution + hs-source-dirs: + windows-src + if os(linux) + other-modules: + Test.Sandwich.WebDriver.Resolution + hs-source-dirs: + linux-src + build-depends: + regex-compat default-language: Haskell2010 diff --git a/src/Test/Sandwich/WebDriver/Internal/Binaries/Util.hs b/src/Test/Sandwich/WebDriver/Internal/Binaries/Util.hs --- a/src/Test/Sandwich/WebDriver/Internal/Binaries/Util.hs +++ b/src/Test/Sandwich/WebDriver/Internal/Binaries/Util.hs @@ -1,4 +1,9 @@ -{-# LANGUAGE CPP, QuasiQuotes, ScopedTypeVariables, NamedFieldPuns, OverloadedStrings, ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} module Test.Sandwich.WebDriver.Internal.Binaries.Util ( detectPlatform @@ -16,10 +21,11 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Except import qualified Data.Aeson as A -import Data.Convertible import qualified Data.HashMap.Strict as HM import Data.String.Interpolate import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL import Network.HTTP.Client import Network.HTTP.Client.TLS import Network.HTTP.Conduit (simpleHttp) @@ -47,7 +53,7 @@ rawString <- case exitCode of ExitFailure _ -> throwE [i|Couldn't parse google-chrome version. Stdout: '#{stdout}'. Stderr: '#{stderr}'|] - ExitSuccess -> return $ T.strip $ convert stdout + ExitSuccess -> return $ T.strip $ T.pack stdout case T.splitOn "." rawString of [tReadMay -> Just w, tReadMay -> Just x, tReadMay -> Just y, tReadMay -> Just z] -> return $ ChromeVersion (w, x, y, z) @@ -65,7 +71,7 @@ return $ Left [i|Error when requesting '#{url}': '#{e}'|] ) (do - result :: T.Text <- convert <$> simpleHttp url + result :: T.Text <- (TL.toStrict . TL.decodeUtf8) <$> simpleHttp url case T.splitOn "." result of [tReadMay -> Just w, tReadMay -> Just x, tReadMay -> Just y, tReadMay -> Just z] -> return $ Right $ ChromeDriverVersion (w, x, y, z) _ -> return $ Left [i|Failed to parse chromedriver version from string: '#{result}'|] @@ -84,7 +90,7 @@ rawString <- case exitCode of ExitFailure _ -> throwE [i|Couldn't parse firefox version. Stdout: '#{stdout}'. Stderr: '#{stderr}'|] - ExitSuccess -> return $ T.strip $ convert stdout + ExitSuccess -> return $ T.strip $ T.pack stdout case T.splitOn "." rawString of [tReadMay -> Just x, tReadMay -> Just y] -> return $ FirefoxVersion (x, y, 0) @@ -122,4 +128,4 @@ -- * Util -tReadMay = readMay . convert +tReadMay = readMay . T.unpack diff --git a/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs b/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs --- a/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs +++ b/src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs @@ -12,7 +12,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE ViewPatterns #-} --- | module Test.Sandwich.WebDriver.Internal.StartWebDriver where @@ -48,6 +47,7 @@ import Test.Sandwich.WebDriver.Internal.Types import Test.Sandwich.WebDriver.Internal.Util import qualified Test.WebDriver as W + type Constraints m = (HasCallStack, MonadLogger m, MonadIO m, MonadBaseControl IO m, MonadMask m) diff --git a/src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs b/src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs --- a/src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs +++ b/src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs @@ -10,7 +10,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} --- | module Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb ( makeXvfbSession @@ -40,6 +39,12 @@ import System.Posix.Types #endif +#ifdef darwin_HOST_OS +import GHC.IO.FD +import qualified GHC.IO.Handle.FD as HFD +newtype Fd = Fd FD +handleToFd h = Fd <$> HFD.handleToFd h +#endif type Constraints m = (HasCallStack, MonadLogger m, MonadIO m, MonadBaseControl IO m, MonadMask m) diff --git a/src/Test/Sandwich/WebDriver/Internal/Util.hs b/src/Test/Sandwich/WebDriver/Internal/Util.hs --- a/src/Test/Sandwich/WebDriver/Internal/Util.hs +++ b/src/Test/Sandwich/WebDriver/Internal/Util.hs @@ -7,7 +7,6 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Control (MonadBaseControl) -import Data.Convertible import Data.String.Interpolate import qualified Data.Text as T import System.Directory @@ -38,10 +37,10 @@ -- * Exceptions leftOnException :: (MonadIO m, MonadBaseControl IO m) => m (Either T.Text a) -> m (Either T.Text a) -leftOnException = E.handle (\(e :: SomeException) -> return $ Left $ convert $ show e) +leftOnException = E.handle (\(e :: SomeException) -> return $ Left $ T.pack $ show e) leftOnException' :: (MonadIO m, MonadBaseControl IO m) => m a -> m (Either T.Text a) -leftOnException' action = E.catch (Right <$> action) (\(e :: SomeException) -> return $ Left $ convert $ show e) +leftOnException' action = E.catch (Right <$> action) (\(e :: SomeException) -> return $ Left $ T.pack $ show e) -- * Util @@ -58,4 +57,4 @@ whenRight (Right x) action = action x makeUUID :: IO T.Text -makeUUID = (convert . take 10 . R.randomRs ('a','z')) <$> R.newStdGen +makeUUID = (T.pack . take 10 . R.randomRs ('a','z')) <$> R.newStdGen diff --git a/src/Test/Sandwich/WebDriver/Internal/Video.hs b/src/Test/Sandwich/WebDriver/Internal/Video.hs --- a/src/Test/Sandwich/WebDriver/Internal/Video.hs +++ b/src/Test/Sandwich/WebDriver/Internal/Video.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP, QuasiQuotes, ScopedTypeVariables, FlexibleContexts, OverloadedStrings, NamedFieldPuns, ViewPatterns #-} --- | module Test.Sandwich.WebDriver.Internal.Video where @@ -12,6 +11,9 @@ #ifdef darwin_HOST_OS import Safe + +getMacScreenNumber :: IO (Maybe Int) +getMacScreenNumber = undefined #endif @@ -41,14 +43,14 @@ maybeScreenNumber <- liftIO getMacScreenNumber let videoPath = [i|#{path}.avi|] let cmd = case maybeScreenNumber of - Just screenNumber -> ["-y" - , "-nostdin" - , "-f", "avfoundation" - , "-i", [i|#{screenNumber}|]] - ++ avfoundationOptions - ++ [videoPath] - Nothing -> error [i|Not launching ffmpeg since OS X screen number couldn't be determined.|] - return ((proc "ffmpeg" cmds) { env = Nothing }) + Just screenNumber -> ["-y" + , "-nostdin" + , "-f", "avfoundation" + , "-i", [i|#{screenNumber}|]] + ++ avfoundationOptions + ++ [videoPath] + Nothing -> error [i|Not launching ffmpeg since OS X screen number couldn't be determined.|] + return ((proc "ffmpeg" cmd) { env = Nothing }) #endif #ifdef mingw32_HOST_OS diff --git a/src/Test/Sandwich/WebDriver/Windows.hs b/src/Test/Sandwich/WebDriver/Windows.hs --- a/src/Test/Sandwich/WebDriver/Windows.hs +++ b/src/Test/Sandwich/WebDriver/Windows.hs @@ -18,13 +18,10 @@ 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.Sandwich.WebDriver.Resolution import Test.WebDriver import qualified Test.WebDriver.Class as W @@ -36,8 +33,8 @@ (x, y, width, height) <- case runMode $ wdOptions sess of RunHeadless (HeadlessConfig {..}) -> return (0, 0, w, h) where (w, h) = fromMaybe (1920, 1080) headlessResolution - _ -> getScreenResolutionX11 sess - setWindowPos (x + 0, y + 0) + _ -> getScreenResolution sess + setWindowPos (x, y) setWindowSize (fromIntegral $ B.shift width (-1), fromIntegral height) -- | Position the window on the right 50% of the screen. @@ -47,7 +44,7 @@ (x, y, width, height) <- case runMode $ wdOptions sess of RunHeadless (HeadlessConfig {..}) -> return (0, 0, w, h) where (w, h) = fromMaybe (1920, 1080) headlessResolution - _ -> getScreenResolutionX11 sess + _ -> getScreenResolution sess let pos = (x + (fromIntegral $ B.shift width (-1)), y + 0) setWindowPos pos setWindowSize (fromIntegral $ B.shift width (-1), fromIntegral height) @@ -59,31 +56,12 @@ (x, y, width, height) <- case runMode $ wdOptions sess of RunHeadless (HeadlessConfig {..}) -> return (0, 0, w, h) where (w, h) = fromMaybe (1920, 1080) headlessResolution - _ -> getScreenResolutionX11 sess + _ -> getScreenResolution sess setWindowPos (x + 0, y + 0) setWindowSize (fromIntegral width, fromIntegral 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 = getScreenResolutionX11 - --- * Internal - -getScreenResolutionX11 :: (HasCallStack, MonadIO m, MonadMask m, MonadLogger m) => WebDriver -> m (Int, Int, Int, Int) -getScreenResolutionX11 (WebDriver {wdWebDriver=(_, _, _, _, _, maybeXvfbSession)}) = case maybeXvfbSession of - Nothing -> getScreenResolutionX11' ":0" 0 - Just (XvfbSession {..}) -> getScreenResolutionX11' (":" <> show xvfbDisplayNum) 0 - -getScreenResolutionX11' :: (HasCallStack, MonadIO m, MonadMask m, MonadLogger m) => String -> Int -> m (Int, Int, Int, Int) -getScreenResolutionX11' displayString screenNumber = do - bracket (liftIO $ X.openDisplay displayString) (liftIO . X.closeDisplay) $ \display -> do - liftIO (X.xineramaQueryScreens display) >>= \case - Nothing -> do - -- TODO: this happens in CI when running under Xvfb. How to get resolution in that case? - logError [i|Couldn't query X11 for screens for display "#{display}"; using default resolution 1920x1080|] - return (0, 0, 1920, 1080) - Just infos -> do - case headMay [(xsi_x_org, xsi_y_org, xsi_width, xsi_height) | X.XineramaScreenInfo {..} <- infos - , xsi_screen_number == fromIntegral screenNumber] of - Nothing -> throwIO $ userError [i|Failed to get screen resolution (couldn't find screen number #{screenNumber})|] - Just (x, y, w, h) -> return (fromIntegral x, fromIntegral y, fromIntegral w, fromIntegral h) +getScreenResolution (WebDriver {wdWebDriver=(_, _, _, _, _, maybeXvfbSession)}) = case maybeXvfbSession of + Nothing -> liftIO getResolution + Just (XvfbSession {..}) -> liftIO $ getResolutionForDisplay xvfbDisplayNum diff --git a/windows-src/Test/Sandwich/WebDriver/Resolution.hsc b/windows-src/Test/Sandwich/WebDriver/Resolution.hsc new file mode 100644 --- /dev/null +++ b/windows-src/Test/Sandwich/WebDriver/Resolution.hsc @@ -0,0 +1,19 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ViewPatterns #-} + +module Test.Sandwich.WebDriver.Resolution ( + getResolution + , getResolutionForDisplay + ) where + +-- TODO: implement +-- https://blog.bytellect.com/software-development/windows-programming/getting-the-windows-screen-resolution-in-c/ +-- https://hackage.haskell.org/package/Win32-2.12.0.1/docs/Graphics-Win32-Window.html + + +getResolution :: IO (Int, Int, Int, Int) +getResolution = undefined + +getResolutionForDisplay :: Int -> IO (Int, Int, Int, Int) +getResolutionForDisplay n = undefined