sandwich-webdriver 0.1.0.5 → 0.1.0.6
raw patch · 11 files changed
+228/−64 lines, 11 filesdep +regex-compatdep −X11dep −convertiblePVP ok
version bump matches the API change (PVP)
Dependencies added: regex-compat
Dependencies removed: X11, convertible
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−0
- darwin-src/Test/Sandwich/WebDriver/Resolution.hs +37/−0
- linux-src/Test/Sandwich/WebDriver/Resolution.hs +71/−0
- sandwich-webdriver.cabal +56/−13
- src/Test/Sandwich/WebDriver/Internal/Binaries/Util.hs +12/−6
- src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs +1/−1
- src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs +6/−1
- src/Test/Sandwich/WebDriver/Internal/Util.hs +3/−4
- src/Test/Sandwich/WebDriver/Internal/Video.hs +11/−9
- src/Test/Sandwich/WebDriver/Windows.hs +8/−30
- windows-src/Test/Sandwich/WebDriver/Resolution.hsc +19/−0
CHANGELOG.md view
@@ -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.
+ darwin-src/Test/Sandwich/WebDriver/Resolution.hs view
@@ -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 "<CoreGraphics/CGDisplayConfiguration.h> CGMainDisplayID"+ cg_main_display_id :: IO CGDirectDisplayID++foreign import ccall unsafe "<CoreGraphics/CGDisplayConfiguration.h> CGDisplayPixelsWide"+ cg_display_pixels_wide :: CGDirectDisplayID -> IO CGDirectDisplayID++foreign import ccall unsafe "<CoreGraphics/CGDisplayConfiguration.h> CGDisplayPixelsHigh"+ cg_display_pixels_high :: CGDirectDisplayID -> IO CGDirectDisplayID
+ linux-src/Test/Sandwich/WebDriver/Resolution.hs view
@@ -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)
sandwich-webdriver.cabal view
@@ -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 <https://codedownio.github.io/sandwich/docs/extensions/sandwich-webdriver documentation>. 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
src/Test/Sandwich/WebDriver/Internal/Binaries/Util.hs view
@@ -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
src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs view
@@ -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)
src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs view
@@ -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)
src/Test/Sandwich/WebDriver/Internal/Util.hs view
@@ -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
src/Test/Sandwich/WebDriver/Internal/Video.hs view
@@ -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
src/Test/Sandwich/WebDriver/Windows.hs view
@@ -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
+ windows-src/Test/Sandwich/WebDriver/Resolution.hsc view
@@ -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