sandwich-webdriver 0.2.3.1 → 0.3.0.0

raw patch · 45 files changed

+2071/−1460 lines, 45 filesdep +regex-tdfadep +sandwich-contextsdep +unliftio-coredep −lifted-basedep −regex-compatdep −safe-exceptionsdep ~sandwichPVP ok

version bump matches the API change (PVP)

Dependencies added: regex-tdfa, sandwich-contexts, unliftio-core

Dependencies removed: lifted-base, regex-compat, safe-exceptions

Dependency ranges changed: sandwich

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• LICENSE +1/−1
• app/Main.hs +0/−100
• app/Simple.hs +0/−22
• linux-src/Test/Sandwich/WebDriver/Resolution.hs +38/−15
• sandwich-webdriver.cabal +42/−101
• src/Test/Sandwich/WebDriver.hs +167/−78
• src/Test/Sandwich/WebDriver/Binaries.hs +48/−0
• src/Test/Sandwich/WebDriver/Class.hs +0/−15
• src/Test/Sandwich/WebDriver/Config.hs +22/−23
• src/Test/Sandwich/WebDriver/Internal/Action.hs +14/−12
• src/Test/Sandwich/WebDriver/Internal/Binaries.hs +0/−200
• src/Test/Sandwich/WebDriver/Internal/Binaries/Chrome.hs +113/−0
• src/Test/Sandwich/WebDriver/Internal/Binaries/Chrome/Detect.hs +158/−0
• src/Test/Sandwich/WebDriver/Internal/Binaries/Chrome/Types.hs +41/−0
• src/Test/Sandwich/WebDriver/Internal/Binaries/Common.hs +58/−0
• src/Test/Sandwich/WebDriver/Internal/Binaries/DetectChrome.hs +0/−157
• src/Test/Sandwich/WebDriver/Internal/Binaries/DetectFirefox.hs +0/−77
• src/Test/Sandwich/WebDriver/Internal/Binaries/Ffmpeg.hs +44/−0
• src/Test/Sandwich/WebDriver/Internal/Binaries/Ffmpeg/Types.hs +16/−0
• src/Test/Sandwich/WebDriver/Internal/Binaries/Firefox.hs +82/−0
• src/Test/Sandwich/WebDriver/Internal/Binaries/Firefox/Detect.hs +78/−0
• src/Test/Sandwich/WebDriver/Internal/Binaries/Firefox/Types.hs +32/−0
• src/Test/Sandwich/WebDriver/Internal/Binaries/Selenium.hs +77/−0
• src/Test/Sandwich/WebDriver/Internal/Binaries/Selenium/Types.hs +17/−0
• src/Test/Sandwich/WebDriver/Internal/Binaries/Xvfb.hs +37/−0
• src/Test/Sandwich/WebDriver/Internal/Binaries/Xvfb/Types.hs +33/−0
• src/Test/Sandwich/WebDriver/Internal/Capabilities.hs +7/−7
• src/Test/Sandwich/WebDriver/Internal/Capabilities/Extra.hs +130/−0
• src/Test/Sandwich/WebDriver/Internal/Dependencies.hs +176/−0
• src/Test/Sandwich/WebDriver/Internal/OnDemand.hs +45/−0
• src/Test/Sandwich/WebDriver/Internal/Ports.hs +0/−78
• src/Test/Sandwich/WebDriver/Internal/Screenshots.hs +8/−6
• src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs +99/−192
• src/Test/Sandwich/WebDriver/Internal/Types.hs +65/−149
• src/Test/Sandwich/WebDriver/Internal/Util.hs +12/−68
• src/Test/Sandwich/WebDriver/Internal/Video.hs +0/−65
• src/Test/Sandwich/WebDriver/Types.hs +36/−27
• src/Test/Sandwich/WebDriver/Video.hs +121/−23
• src/Test/Sandwich/WebDriver/Video/Internal.hs +101/−0
• src/Test/Sandwich/WebDriver/Video/Types.hs +56/−0
• src/Test/Sandwich/WebDriver/Windows.hs +36/−16
• test/Spec.hs +15/−11
• unix-src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs +32/−16
• windows-src/Test/Sandwich/WebDriver/Resolution.hsc +1/−1

@@ -2,6 +2,19 @@  # Unreleased +# 0.3.0.0++* BREAKING CHANGE: switch most monads away from using `MonadBaseControl IO` and switch to `MonadUnliftIO`. We also remove `MonadThrow` constraints, relying only on `MonadIO` for throwing exceptions.+* Fix window positioning commands to use window.devicePixelRatio.+* Add support for introducing Selenium dependencies using Nix with `sandwich-contexts`.+* Improve Haddocks and simplify module structure.+* Export `getDownloadDirectory` accessor for `WebDriver`.+* Be able to obtain dependencies like `ffmpeg` and `Xvfb` on demand.+* Clean up dependencies and fix some warnings on MacOS and Windows.+* Be able to pass a custom Firefox profile in `Capabilities`.+* Remove `hoistExample` helper which didn't belong in this package.+* Support video recording flags `--error-videos`/`--individual-videos`.+ # 0.2.3.1  * Binary fetching: don't create the toolsRoot directory unless necessary.

@@ -1,4 +1,4 @@-Copyright Tom McLaughlin (c) 2023+Copyright Tom McLaughlin (c) 2024  All rights reserved. 

@@ -1,100 +0,0 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE CPP #-}--module Main where--import Control.Concurrent-import Control.Monad.IO.Class-import Data.Maybe-import Data.String.Interpolate-import Data.Time.Clock-import Test.Sandwich-import Test.Sandwich.Formatters.Print-import Test.Sandwich.WebDriver-import Test.Sandwich.WebDriver.Windows-import Test.WebDriver--#ifndef mingw32_HOST_OS-import Test.Sandwich.Formatters.TerminalUI-#endif---simple :: TopSpec-simple = introduceWebDriver wdOptions $ do-  it "does the thing 1" $ withSession1 $ do-    openPage "http://www.google.com"-    setWindowLeftSide-    search <- findElem (ByCSS [i|*[title="Search"]|])-    click search-    sendKeys "asdf" search-    liftIO $ threadDelay 1000000-    sendKeys "fdsa" search-    liftIO $ threadDelay 1000000-    sendKeys "jkl" search-    liftIO $ threadDelay 1000000-    findElem (ByCSS ".does-not-exist")-    expectationFailure "OH NO"-  -- it "does the thing 2" $ withSession2 $ do-  --   openPage "http://www.cnn.com"-  --   setWindowRightSide-  --   liftIO $ threadDelay 1000000---- concurrent :: TopSpec--- concurrent = introduceWebDriver wdOptions $ parallel $ do---   it "does the thing 1" $ withSession1 $ do---     openPage "http://www.google.com"---     setWindowLeftSide---     liftIO $ threadDelay 10000000---   it "does the thing 2" $ withSession2 $ do---     openPage "http://www.cnn.com"---     setWindowRightSide---     liftIO $ threadDelay 10000000---- pooled :: TopSpec--- pooled = do---   introduce "WebDriver pool" webdriverPool doCreatePool (liftIO . purgePool) $ parallel $ do---     it "works" (2 `shouldBe` 2)----     claimWebDriver $ do---       it "does the thing 1" $ withSession1 $ do---         openPage "http://www.google.com"---         setWindowLeftSide---         liftIO $ threadDelay 1000000----     claimWebDriver $ do---       it "does the thing 2" $ withSession1 $ do---         openPage "http://www.cnn.com"---         setWindowRightSide---         liftIO $ threadDelay 1000000---- doCreatePool = do---   maybeRunRoot <- getRunRoot---   let runRoot = fromMaybe "/tmp" maybeRunRoot---   liftIO $ createPool (allocateWebDriver' runRoot wdOptions) cleanupWebDriver' 1 (5) 4---- claimWebDriver subspec = introduceWith "Claim webdriver" webdriver wrappedAction subspec---   where wrappedAction action = do---           pool <- getContext webdriverPool---           debug "Trying to claim webdriver"---           withResource pool (liftIO . action)---- webdriverPool = Label :: Label "webdriverPool" (Pool WdSession)--wdOptions = (defaultWdOptions "/tmp/tools") {-  -- capabilities = chromeCapabilities-  capabilities = firefoxCapabilities Nothing-  -- capabilities = headlessFirefoxCapabilities-  , saveSeleniumMessageHistory = Always-  -- , runMode = Normal-  , runMode = RunHeadless defaultHeadlessConfig-  }--testOptions = defaultOptions {-  optionsTestArtifactsDirectory = TestArtifactsGeneratedDirectory "test_runs" (show <$> getCurrentTime)-  -- , optionsFormatters = [SomeFormatter defaultTerminalUIFormatter]-  , optionsFormatters = [SomeFormatter defaultPrintFormatter]-  }--main :: IO ()-main = runSandwich testOptions simple

@@ -1,22 +0,0 @@--module Simple where--import Test.Sandwich-import Test.Sandwich.WebDriver-import Test.WebDriver--wdOptions = (defaultWdOptions "/tmp/tools") {-  capabilities = firefoxCapabilities Nothing-  , runMode = RunHeadless defaultHeadlessConfig-  }--spec :: TopSpec-spec = introduceWebDriver wdOptions $ do-  it "opens Google and searches" $ withSession1 $ do-    openPage "http://www.google.com"-    search <- findElem (ByCSS "*[title='Search']")-    click search-    sendKeys "asdf\n" search--main :: IO ()-main = runSandwich defaultOptions spec

@@ -1,4 +1,10 @@+{-# 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@@ -9,32 +15,47 @@ 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+import Text.Regex.TDFA  --- | Previously we got the screen resolution on Linux using the X11 Haskell library.+-- | 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--- sandwich-webdriver documentation manually.+-- the 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+-- 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 :: IO (Int, Int, Int, Int)+getResolution :: (+  HasCallStack+  )+  -- | Returns (x, y, width, height)+  => IO (Int, Int, Int, Int) getResolution = getResolution' Nothing -getResolutionForDisplay :: Int -> IO (Int, Int, Int, Int)+-- | 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' :: Maybe [(String, String)] -> IO (Int, Int, Int, Int)+getResolution' :: (HasCallStack) => Maybe [(String, String)] -> IO (Int, Int, Int, Int) getResolution' xrandrEnv = do   xrandrPath <- findExecutable "xrandr" >>= \case     Just x -> return x@@ -50,12 +71,14 @@                      & 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+  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 -resolutionRegex :: Regex-resolutionRegex = mkRegex "([0-9]+)x([0-9]+)\\+([0-9]+)\\+([0-9]+)"+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 =

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2.+-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack  name:           sandwich-webdriver-version:        0.2.3.1+version:        0.3.0.0 synopsis:       Sandwich integration with Selenium WebDriver description:    Please see the <https://codedownio.github.io/sandwich/docs/extensions/sandwich-webdriver documentation>. category:       Testing@@ -13,7 +13,7 @@ bug-reports:    https://github.com/codedownio/sandwich/issues author:         Tom McLaughlin maintainer:     tom@codedown.io-copyright:      2023 Tom McLaughlin+copyright:      2024 Tom McLaughlin license:        BSD3 license-file:   LICENSE build-type:     Simple@@ -27,25 +27,38 @@ library   exposed-modules:       Test.Sandwich.WebDriver-      Test.Sandwich.WebDriver.Class+      Test.Sandwich.WebDriver.Binaries       Test.Sandwich.WebDriver.Config+      Test.Sandwich.WebDriver.Video+      Test.Sandwich.WebDriver.Windows+  other-modules:       Test.Sandwich.WebDriver.Internal.Action-      Test.Sandwich.WebDriver.Internal.Binaries-      Test.Sandwich.WebDriver.Internal.Binaries.DetectChrome-      Test.Sandwich.WebDriver.Internal.Binaries.DetectFirefox+      Test.Sandwich.WebDriver.Internal.Binaries.Chrome+      Test.Sandwich.WebDriver.Internal.Binaries.Chrome.Detect+      Test.Sandwich.WebDriver.Internal.Binaries.Chrome.Types+      Test.Sandwich.WebDriver.Internal.Binaries.Common       Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform+      Test.Sandwich.WebDriver.Internal.Binaries.Ffmpeg+      Test.Sandwich.WebDriver.Internal.Binaries.Ffmpeg.Types+      Test.Sandwich.WebDriver.Internal.Binaries.Firefox+      Test.Sandwich.WebDriver.Internal.Binaries.Firefox.Detect+      Test.Sandwich.WebDriver.Internal.Binaries.Firefox.Types+      Test.Sandwich.WebDriver.Internal.Binaries.Selenium+      Test.Sandwich.WebDriver.Internal.Binaries.Selenium.Types+      Test.Sandwich.WebDriver.Internal.Binaries.Xvfb+      Test.Sandwich.WebDriver.Internal.Binaries.Xvfb.Types       Test.Sandwich.WebDriver.Internal.Capabilities-      Test.Sandwich.WebDriver.Internal.Ports+      Test.Sandwich.WebDriver.Internal.Capabilities.Extra+      Test.Sandwich.WebDriver.Internal.Dependencies+      Test.Sandwich.WebDriver.Internal.OnDemand       Test.Sandwich.WebDriver.Internal.Screenshots       Test.Sandwich.WebDriver.Internal.StartWebDriver       Test.Sandwich.WebDriver.Internal.Types       Test.Sandwich.WebDriver.Internal.Util-      Test.Sandwich.WebDriver.Internal.Video       Test.Sandwich.WebDriver.Types-      Test.Sandwich.WebDriver.Video-      Test.Sandwich.WebDriver.Windows-  other-modules:-      Test.Sandwich.WebDriver.Resolution+      Test.Sandwich.WebDriver.Video.Internal+      Test.Sandwich.WebDriver.Video.Types+      Paths_sandwich_webdriver   hs-source-dirs:       src   default-extensions:@@ -74,7 +87,6 @@     , http-client     , http-client-tls     , http-conduit-    , lifted-base     , microlens     , microlens-aeson     , monad-control@@ -85,91 +97,14 @@     , random     , retry     , safe-    , safe-exceptions-    , sandwich >=0.1.0.3+    , sandwich >=0.3.0.0+    , sandwich-contexts >=0.3.0.0     , string-interpolate-    , temporary     , text     , time     , transformers-    , unordered-containers-    , vector-    , webdriver-  default-language: Haskell2010-  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-  if !os(windows)-    build-depends:-        unix-  if !os(windows)-    other-modules:-        Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb-    hs-source-dirs:-        unix-src--executable sandwich-webdriver-exe-  main-is: Main.hs-  other-modules:-      Simple-      Paths_sandwich_webdriver-  hs-source-dirs:-      app-  default-extensions:-      FlexibleContexts-      FlexibleInstances-      LambdaCase-      MultiParamTypeClasses-      MultiWayIf-      NamedFieldPuns-      NumericUnderscores-      OverloadedStrings-      QuasiQuotes-      RecordWildCards-      ScopedTypeVariables-      ViewPatterns-  ghc-options: -threaded -rtsopts -with-rtsopts=-N-  build-depends:-      aeson-    , base <5-    , bytestring-    , containers-    , data-default-    , directory-    , exceptions-    , filepath-    , http-client-    , http-client-tls-    , http-conduit-    , lifted-base-    , microlens-    , microlens-aeson-    , monad-control-    , monad-logger-    , mtl-    , network-    , process-    , random-    , retry-    , safe-    , safe-exceptions-    , sandwich >=0.1.0.3-    , sandwich-webdriver-    , string-interpolate-    , temporary-    , text-    , time-    , transformers+    , unliftio+    , unliftio-core     , unordered-containers     , vector     , webdriver@@ -192,10 +127,17 @@     hs-source-dirs:         linux-src     build-depends:-        regex-compat+        regex-tdfa   if !os(windows)     build-depends:         unix+  if !os(windows)+    other-modules:+        Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb+    hs-source-dirs:+        unix-src+    build-depends:+        temporary  test-suite sandwich-webdriver-test   type: exitcode-stdio-1.0@@ -230,7 +172,6 @@     , http-client     , http-client-tls     , http-conduit-    , lifted-base     , microlens     , microlens-aeson     , monad-control@@ -241,15 +182,15 @@     , random     , retry     , safe-    , safe-exceptions-    , sandwich >=0.1.0.3+    , sandwich >=0.3.0.0+    , sandwich-contexts >=0.3.0.0     , sandwich-webdriver     , string-interpolate-    , temporary     , text     , time     , transformers     , unliftio+    , unliftio-core     , unordered-containers     , vector     , webdriver@@ -272,7 +213,7 @@     hs-source-dirs:         linux-src     build-depends:-        regex-compat+        regex-tdfa   if !os(windows)     build-depends:         unix

@@ -1,15 +1,25 @@-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-} +{-|+Introduce [WebDriver](https://www.selenium.dev/documentation/webdriver/) servers and sessions.+-}+ module Test.Sandwich.WebDriver (   -- * Introducing a WebDriver server   introduceWebDriver-  , introduceWebDriverOptions-  , addCommandLineOptionsToWdOptions+  , introduceWebDriverViaNix+  , introduceWebDriverViaNix' +  -- * Non-Nix dependency fetching+  -- | When you aren't using Nix, these types specify how to obtain the necessary dependencies.+  , defaultWebDriverDependencies+  , WebDriverDependencies(..)+   -- * Running an example in a given session+  -- | Once you have a 'WebDriver' in context, you can run one or more sessions.+  -- Each session will open an independent browser instance.   , withSession   , withSession1   , withSession2@@ -24,78 +34,165 @@    -- * Lower-level allocation functions   , allocateWebDriver-  , allocateWebDriver'   , cleanupWebDriver-  , cleanupWebDriver'+  , introduceBrowserDependenciesViaNix+  , introduceBrowserDependenciesViaNix'+  , introduceWebDriver'+  , addCommandLineOptionsToWdOptions +  -- * Context types+  -- ** WebDriver+  , webdriver+  , WebDriver+  , HasWebDriverContext+  -- ** WebDriverSession+  , webdriverSession+  , WebDriverSession+  , HasWebDriverSessionContext++  -- * Shorthands+  -- | These are used to make type signatures shorter.+  , BaseMonad+  , ContextWithBaseDeps+  , ContextWithWebdriverDeps+  , WebDriverMonad+  , WebDriverSessionMonad++  -- * On demand options+  , OnDemandOptions+  , defaultOnDemandOptions+   -- * Re-exports-  , module Test.Sandwich.WebDriver.Class   , module Test.Sandwich.WebDriver.Config-  , module Test.Sandwich.WebDriver.Types   ) where -import Control.Applicative-import Control.Concurrent.MVar.Lifted+import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class-import Control.Monad.Logger import Control.Monad.Reader+import Control.Monad.Trans.Control (MonadBaseControl) import Data.IORef+import qualified Data.List as L import qualified Data.Map as M import Data.Maybe import Data.String.Interpolate import Test.Sandwich-import Test.Sandwich.Internal-import Test.Sandwich.WebDriver.Class+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Nix+import Test.Sandwich.WebDriver.Binaries import Test.Sandwich.WebDriver.Config import Test.Sandwich.WebDriver.Internal.Action+import Test.Sandwich.WebDriver.Internal.Dependencies import Test.Sandwich.WebDriver.Internal.StartWebDriver import Test.Sandwich.WebDriver.Internal.Types import Test.Sandwich.WebDriver.Types+import Test.Sandwich.WebDriver.Video (recordVideoIfConfigured) import qualified Test.WebDriver as W import qualified Test.WebDriver.Config as W import qualified Test.WebDriver.Session as W+import UnliftIO.MVar  --- | This is the main 'introduce' method for creating a WebDriver.-introduceWebDriver :: (BaseMonadContext m context) => WdOptions -> SpecFree (LabelValue "webdriver" WebDriver :> context) m () -> SpecFree context m ()-introduceWebDriver wdOptions = introduce "Introduce WebDriver session" webdriver (allocateWebDriver wdOptions) cleanupWebDriver+-- | Introduce a 'WebDriver', using the given 'WebDriverDependencies'.+-- A good default is 'defaultWebDriverDependencies'.+introduceWebDriver :: forall context m. (+  BaseMonad m context, HasSomeCommandLineOptions context+  )+  -- | How to obtain dependencies+  => WebDriverDependencies+  -> WdOptions+  -> SpecFree (ContextWithWebdriverDeps context) m () -> SpecFree context m ()+introduceWebDriver wdd wdOptions = introduceWebDriver' wdd alloc wdOptions+  where+    alloc wdOptions' = do+      clo <- getSomeCommandLineOptions+      allocateWebDriver (addCommandLineOptionsToWdOptions clo wdOptions') onDemandOptions --- | Same as introduceWebDriver, but merges command line options into the 'WdOptions'.-introduceWebDriverOptions :: forall a context m. (BaseMonadContext m context, HasCommandLineOptions context a)-  => WdOptions -> SpecFree (LabelValue "webdriver" WebDriver :> context) m () -> SpecFree context m ()-introduceWebDriverOptions wdOptions = introduce "Introduce WebDriver session" webdriver alloc cleanupWebDriver-  where alloc = do-          clo <- getCommandLineOptions-          allocateWebDriver (addCommandLineOptionsToWdOptions @a clo wdOptions)+    onDemandOptions = OnDemandOptions {+      ffmpegToUse = webDriverFfmpeg wdd+      , xvfbToUse = xvfbDependenciesSpecXvfb $ webDriverXvfb wdd+      } +-- | Introduce a 'WebDriver' using the current 'NixContext'.+-- This will pull everything required from the configured Nixpkgs snapshot.+introduceWebDriverViaNix :: forall m context. (+  BaseMonad m context, HasSomeCommandLineOptions context, HasNixContext context+  )+  -- | Options+  => WdOptions+  -> SpecFree (ContextWithWebdriverDeps context) m ()+  -> SpecFree context m ()+introduceWebDriverViaNix = introduceWebDriverViaNix' (defaultNodeOptions { nodeOptionsVisibilityThreshold = defaultFileContextVisibilityThreshold })++-- | Same as 'introduceWebDriverViaNix', but allows passing custom 'NodeOptions'.+introduceWebDriverViaNix' :: forall m context. (+  BaseMonad m context, HasSomeCommandLineOptions context, HasNixContext context+  )+  => NodeOptions+  -- | Options+  -> WdOptions+  -> SpecFree (ContextWithWebdriverDeps context) m ()+  -> SpecFree context m ()+introduceWebDriverViaNix' nodeOptions wdOptions =+  introduceFileViaNixPackage'' @"selenium.jar" nodeOptions "selenium-server-standalone" (findFirstFile (return . (".jar" `L.isSuffixOf`)))+  . introduceBinaryViaNixPackage' @"java" nodeOptions "jre"+  . introduceBrowserDependenciesViaNix' nodeOptions+  . introduce "Introduce WebDriver session" webdriver alloc cleanupWebDriver+  where+    alloc = do+      clo <- getSomeCommandLineOptions++      nc <- getContext nixContext+      let onDemandOptions = OnDemandOptions {+            ffmpegToUse = UseFfmpegFromNixpkgs nc+            , xvfbToUse = UseXvfbFromNixpkgs nc+            }++      allocateWebDriver (addCommandLineOptionsToWdOptions clo wdOptions) onDemandOptions++-- | Same as 'introduceWebDriver', but with a controllable allocation callback.+introduceWebDriver' :: forall m context. (+  BaseMonad m context+  )+  -- | Dependencies+  => WebDriverDependencies+  -> (WdOptions -> ExampleT (ContextWithBaseDeps context) m WebDriver)+  -> WdOptions+  -> SpecFree (ContextWithWebdriverDeps context) m () -> SpecFree context m ()+introduceWebDriver' (WebDriverDependencies {..}) alloc wdOptions =+  introduce "Introduce selenium.jar" (mkFileLabel @"selenium.jar") ((EnvironmentFile <$>) $ obtainSelenium webDriverDependencySelenium) (const $ return ())+  . (case webDriverDependencyJava of Nothing -> introduceBinaryViaEnvironment @"java"; Just p -> introduceFile @"java" p)+  . introduce "Introduce browser dependencies" browserDependencies (getBrowserDependencies webDriverDependencyBrowser) (const $ return ())+  . introduce "Introduce WebDriver session" webdriver (alloc wdOptions) cleanupWebDriver+ -- | Allocate a WebDriver using the given options.-allocateWebDriver :: (HasBaseContext context, BaseMonad m) => WdOptions -> ExampleT context m WebDriver-allocateWebDriver wdOptions = do-  debug "Beginning allocateWebDriver"+allocateWebDriver :: (+  BaseMonad m context+  , HasFile context "java", HasFile context "selenium.jar", HasBrowserDependencies context+  )+  -- | Options+  => WdOptions+  -> OnDemandOptions+  -> ExampleT context m WebDriver+allocateWebDriver wdOptions onDemandOptions = do   dir <- fromMaybe "/tmp" <$> getCurrentFolder-  startWebDriver wdOptions dir---- | Allocate a WebDriver using the given options and putting logs under the given path.-allocateWebDriver' :: FilePath -> WdOptions -> IO WebDriver-allocateWebDriver' runRoot wdOptions = do-  runNoLoggingT $ startWebDriver wdOptions runRoot+  startWebDriver wdOptions onDemandOptions dir  -- | Clean up the given WebDriver.-cleanupWebDriver :: (HasBaseContext context, BaseMonad m) => WebDriver -> ExampleT context m ()+cleanupWebDriver :: (BaseMonad m context) => WebDriver -> ExampleT context m () cleanupWebDriver sess = do   closeAllSessions sess   stopWebDriver sess --- | Clean up the given WebDriver without logging.-cleanupWebDriver' :: WebDriver -> IO ()-cleanupWebDriver' sess = do-  runNoLoggingT $ do-    closeAllSessions sess-    stopWebDriver sess- -- | Run a given example using a given Selenium session.-withSession :: forall m context a. WebDriverMonad m context => Session -> ExampleT (ContextWithSession context) m a -> ExampleT context m a-withSession session (ExampleT readerMonad) = do+withSession :: forall m context a. (+  MonadMask m, MonadBaseControl IO m+  , HasBaseContext context, HasSomeCommandLineOptions context, WebDriverMonad m context+  )+  -- | Session to run+  => Session+  -> ExampleT (LabelValue "webdriverSession" WebDriverSession :> context) m a+  -> ExampleT context m a+withSession session action = do   WebDriver {..} <- getContext webdriver   -- Create new session if necessary (this can throw an exception)   sess <- modifyMVar wdSessionMap $ \sessionMap -> case M.lookup session sessionMap of@@ -111,51 +208,43 @@    -- Not used for now, but previous libraries have use a finally to grab the final session on exception.   -- We could do the same here, but it's not clear that it's needed.-  let f :: m a -> m a = id+  -- let f :: m a -> m a = id -  ExampleT (withReaderT (\ctx -> LabelValue (session, ref) :> ctx) $ mapReaderT (mapLoggingT f) readerMonad)+  pushContext webdriverSession (session, ref) $+    recordVideoIfConfigured session action --- | Convenience function. 'withSession1' = 'withSession' "session1"-withSession1 :: WebDriverMonad m context => ExampleT (ContextWithSession context) m a -> ExampleT context m a+-- | Convenience function. @withSession1 = withSession "session1"@.+withSession1 :: (+  MonadMask m, MonadBaseControl IO m+  , HasBaseContext context, HasSomeCommandLineOptions context, WebDriverMonad m context+  )+  -- | Wrapped action+  => ExampleT (LabelValue "webdriverSession" WebDriverSession :> context) m a+  -> ExampleT context m a withSession1 = withSession "session1" --- | Convenience function. 'withSession2' = 'withSession' "session2"-withSession2 :: WebDriverMonad m context => ExampleT (ContextWithSession context) m a -> ExampleT context m a+-- | Convenience function. @withSession2 = withSession "session2"@.+withSession2 :: (+  MonadMask m, MonadBaseControl IO m+  , HasBaseContext context, HasSomeCommandLineOptions context, WebDriverMonad m context+  )+  -- | Wrapped action+  => ExampleT (LabelValue "webdriverSession" WebDriverSession :> context) m a+  -> ExampleT context m a withSession2 = withSession "session2" --- | Get all existing session names-getSessions :: (WebDriverMonad m context, MonadReader context m, HasLabel context "webdriver" WebDriver) => m [Session]+-- | Get all existing session names.+getSessions :: (MonadReader context m, WebDriverMonad m context) => m [Session] getSessions = do   WebDriver {..} <- getContext webdriver   M.keys <$> liftIO (readMVar wdSessionMap)  -- | Merge the options from the 'CommandLineOptions' into some 'WdOptions'.-addCommandLineOptionsToWdOptions :: CommandLineOptions a -> WdOptions -> WdOptions-addCommandLineOptionsToWdOptions (CommandLineOptions {optWebdriverOptions=(CommandLineWebdriverOptions {..})}) wdOptions@(WdOptions {..}) = wdOptions {-  capabilities = case optFirefox of-    Just UseFirefox -> firefoxCapabilities fbp-    Just UseChrome -> chromeCapabilities cbp-    Nothing -> case cbp of-      Just p -> chromeCapabilities (Just p)-      Nothing -> case fbp of-        Just p -> firefoxCapabilities (Just p)-        Nothing -> capabilities--  , runMode = case optDisplay of-      Nothing -> runMode-      Just Headless -> RunHeadless defaultHeadlessConfig-      Just Xvfb -> RunInXvfb (defaultXvfbConfig { xvfbStartFluxbox = optFluxbox })-      Just Current -> Normal--  , seleniumToUse = maybe seleniumToUse UseSeleniumAt optSeleniumJar--  , chromeBinaryPath = cbp-  , chromeDriverToUse = maybe chromeDriverToUse UseChromeDriverAt optChromeDriver--  , firefoxBinaryPath = fbp-  , geckoDriverToUse = maybe geckoDriverToUse UseGeckoDriverAt optGeckoDriver+addCommandLineOptionsToWdOptions :: SomeCommandLineOptions -> WdOptions -> WdOptions+addCommandLineOptionsToWdOptions (SomeCommandLineOptions (CommandLineOptions {optWebdriverOptions=(CommandLineWebdriverOptions {..})})) wdOptions@(WdOptions {..}) = wdOptions {+  runMode = case optDisplay of+    Nothing -> runMode+    Just Headless -> RunHeadless defaultHeadlessConfig+    Just Xvfb -> RunInXvfb (defaultXvfbConfig { xvfbStartFluxbox = optFluxbox })+    Just Current -> Normal   }--  where-    cbp = optChromeBinary <|> chromeBinaryPath-    fbp = optFirefoxBinary <|> firefoxBinaryPath

@@ -0,0 +1,48 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}++{-|+Obtain various binaries you might need for WebDriver testing.+-}++module Test.Sandwich.WebDriver.Binaries (+  -- * Selenium+  obtainSelenium+  , SeleniumToUse(..)++  -- * Chrome+  , obtainChrome+  , ChromeToUse(..)+  , ChromeVersion(..)++  -- * Chrome driver+  , obtainChromeDriver+  , ChromeDriverToUse(..)+  , ChromeDriverVersion(..)++  -- * Firefox+  , obtainFirefox+  , FirefoxToUse(..)++  -- * Geckodriver+  , obtainGeckoDriver+  , GeckoDriverToUse(..)+  , GeckoDriverVersion(..)++  -- * Ffmpeg+  , obtainFfmpeg+  , FfmpegToUse(..)++  -- * Xvfb+  , obtainXvfb+  , XvfbDependenciesSpec(..)+  , XvfbToUse(..)+  , FluxboxToUse(..)+  ) where++import Test.Sandwich.WebDriver.Internal.Binaries.Chrome+import Test.Sandwich.WebDriver.Internal.Binaries.Ffmpeg+import Test.Sandwich.WebDriver.Internal.Binaries.Firefox+import Test.Sandwich.WebDriver.Internal.Binaries.Selenium+import Test.Sandwich.WebDriver.Internal.Binaries.Xvfb

@@ -1,15 +0,0 @@--module Test.Sandwich.WebDriver.Class (-  -- * The main WebDriver type-  WebDriver-  , getWdOptions-  , getDisplayNumber-  , getXvfbSession-  , getWebDriverName--  -- * The Xvfb session-  , XvfbSession(..)-  ) where---import Test.Sandwich.WebDriver.Internal.Types

@@ -1,54 +1,53 @@ +-- | Configuration types for WebDriver servers, Xvfb mode, browser capabilities, etc.+ module Test.Sandwich.WebDriver.Config (   -- * Main options   WdOptions   , defaultWdOptions   , runMode-  , seleniumToUse-  , chromeBinaryPath-  , chromeDriverToUse-  , firefoxBinaryPath-  , geckoDriverToUse   , capabilities   , httpManager   , httpRetryCount   , saveSeleniumMessageHistory -  -- * Run mode constructors-  , RunMode(..)+  -- * Accessors for the 'WebDriver' context+  , getWdOptions+  , getDisplayNumber+  , getDownloadDirectory+  , getWebDriverName+  , getXvfbSession -  -- ** Xvfb mode+  -- * Xvfb mode   , XvfbConfig   , defaultXvfbConfig   , xvfbResolution   , xvfbStartFluxbox -  -- ** Headless mode+  -- * Headless mode   , HeadlessConfig   , defaultHeadlessConfig   , headlessResolution -  -- * Binary fetching options-  , SeleniumToUse(..)-  , ChromeDriverToUse(..)-  , GeckoDriverToUse(..)--  -- * Miscellaneous constructors-  , WhenToSave(..)--  -- * Manually obtaining binaries-  , obtainSelenium-  , obtainChromeDriver-  , obtainGeckoDriver-   -- * Browser capabilities   , chromeCapabilities   , headlessChromeCapabilities   , firefoxCapabilities   , headlessFirefoxCapabilities +  -- * Types+  -- ** BrowserDependencies+  , browserDependencies+  , BrowserDependenciesSpec(..)+  , BrowserDependencies(..)+  , HasBrowserDependencies+  -- ** Xvfb+  , XvfbSession(..)+  -- ** Miscellaneous+  , WhenToSave(..)+  , RunMode(..)   ) where -import Test.Sandwich.WebDriver.Internal.Binaries import Test.Sandwich.WebDriver.Internal.Capabilities+import Test.Sandwich.WebDriver.Internal.Dependencies import Test.Sandwich.WebDriver.Internal.Types

@@ -2,24 +2,24 @@  module Test.Sandwich.WebDriver.Internal.Action where -import Control.Concurrent.MVar.Lifted-import Control.Exception.Safe import Control.Monad import Control.Monad.IO.Class+import Control.Monad.IO.Unlift import Control.Monad.Logger-import Control.Monad.Reader-import Control.Monad.Trans.Control (MonadBaseControl) import qualified Data.Map as M import Data.String.Interpolate import GHC.Stack import Test.Sandwich import Test.Sandwich.WebDriver.Internal.Types import Test.Sandwich.WebDriver.Internal.Util+import Test.Sandwich.WebDriver.Types import qualified Test.WebDriver as W+import UnliftIO.Concurrent+import UnliftIO.Exception  --- | Close the given sessions-closeSession :: (HasCallStack, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => Session -> WebDriver -> m ()+-- | Close the given session.+closeSession :: (HasCallStack, MonadLogger m, MonadUnliftIO m) => Session -> WebDriver -> m () closeSession session (WebDriver {wdSessionMap}) = do   toClose <- modifyMVar wdSessionMap $ \sessionMap ->     case M.lookup session sessionMap of@@ -28,8 +28,8 @@    whenJust toClose $ \sess -> liftIO $ W.runWD sess W.closeSession --- | Close all sessions except those listed-closeAllSessionsExcept :: (HasCallStack, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => [Session] -> WebDriver -> m ()+-- | Close all sessions except those listed.+closeAllSessionsExcept :: (HasCallStack, MonadLogger m, MonadUnliftIO m) => [Session] -> WebDriver -> m () closeAllSessionsExcept toKeep (WebDriver {wdSessionMap}) = do   toClose <- modifyMVar wdSessionMap $ return . M.partitionWithKey (\name _ -> name `elem` toKeep) @@ -37,12 +37,14 @@     catch (liftIO $ W.runWD sess W.closeSession)           (\(e :: SomeException) -> warn [i|Failed to destroy session '#{name}': '#{e}'|]) --- | Close all sessions-closeAllSessions :: (HasCallStack, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => WebDriver -> m ()+-- | Close all sessions.+closeAllSessions :: (HasCallStack, MonadLogger m, MonadUnliftIO m) => WebDriver -> m () closeAllSessions = closeAllSessionsExcept [] --- | Close the current session-closeCurrentSession :: (HasCallStack, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadReader context m, HasLabel context "webdriver" WebDriver, HasLabel context "webdriverSession" WebDriverSession) => m ()+-- | Close the current session.+closeCurrentSession :: (+  MonadLogger m, WebDriverSessionMonad m context+  ) => m () closeCurrentSession = do   webDriver <- getContext webdriver   (session, _) <- getContext webdriverSession

@@ -1,200 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types #-}--module Test.Sandwich.WebDriver.Internal.Binaries (-  obtainSelenium-  , obtainChromeDriver-  , obtainGeckoDriver-  , downloadSeleniumIfNecessary-  , downloadChromeDriverIfNecessary-  ) where--import Control.Exception-import Control.Monad-import Control.Monad.Catch-import Control.Monad.IO.Class-import Control.Monad.Logger-import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Monad.Trans.Except-import Data.String.Interpolate-import qualified Data.Text as T-import GHC.Stack-import System.Directory-import System.Exit-import System.FilePath-import System.IO.Temp-import System.Process-import Test.Sandwich.Expectations-import Test.Sandwich.Logging-import Test.Sandwich.WebDriver.Internal.Binaries.DetectChrome-import Test.Sandwich.WebDriver.Internal.Binaries.DetectFirefox-import Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform-import Test.Sandwich.WebDriver.Internal.Types-import Test.Sandwich.WebDriver.Internal.Util---type Constraints m = (-  HasCallStack-  , MonadLogger m-  , MonadIO m-  , MonadBaseControl IO m-  , MonadMask m-  )---- * Obtaining binaries--defaultSeleniumJarUrl :: String-defaultSeleniumJarUrl = "https://selenium-release.storage.googleapis.com/3.141/selenium-server-standalone-3.141.59.jar"---- TODO: remove curl dependencies here---- | Manually obtain a Selenium server JAR file, according to the 'SeleniumToUse' policy,--- storing it under the provided 'FilePath' if necessary and returning the exact path.-obtainSelenium :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadThrow m) => FilePath -> SeleniumToUse -> m (Either T.Text FilePath)-obtainSelenium toolsDir (DownloadSeleniumFrom url) = do-  let path = [i|#{toolsDir}/selenium-server-standalone.jar|]-  unlessM (liftIO $ doesFileExist path) $-    curlDownloadToPath url path-  return $ Right path-obtainSelenium toolsDir DownloadSeleniumDefault = do-  let path = [i|#{toolsDir}/selenium-server-standalone-3.141.59.jar|]-  unlessM (liftIO $ doesFileExist path) $-    curlDownloadToPath defaultSeleniumJarUrl path-  return $ Right path-obtainSelenium _ (UseSeleniumAt path) = liftIO (doesFileExist path) >>= \case-  False -> return $ Left [i|Path '#{path}' didn't exist|]-  True -> return $ Right path---- | Manually obtain a chromedriver binary, according to the 'ChromeDriverToUse' policy,--- storing it under the provided 'FilePath' if necessary and returning the exact path.-obtainChromeDriver :: (-  MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadMask m-  ) => FilePath -> ChromeDriverToUse -> m (Either T.Text FilePath)-obtainChromeDriver toolsDir (DownloadChromeDriverFrom url) = do-  let path = [i|#{toolsDir}/#{chromeDriverExecutable}|]-  unlessM (liftIO $ doesFileExist path) $-    curlDownloadToPath url path-  return $ Right path-obtainChromeDriver toolsDir (DownloadChromeDriverVersion chromeDriverVersion) = runExceptT $ do-  let path = getChromeDriverPath toolsDir chromeDriverVersion-  liftIO (doesFileExist path) >>= \case-    True -> return path-    False -> do-      let downloadPath = getChromeDriverDownloadUrl chromeDriverVersion detectPlatform-      ExceptT $ downloadAndUnzipToPath downloadPath path-      return path-obtainChromeDriver toolsDir (DownloadChromeDriverAutodetect maybeChromePath) = runExceptT $ do-  version <- ExceptT $ liftIO $ getChromeDriverVersion maybeChromePath-  ExceptT $ obtainChromeDriver toolsDir (DownloadChromeDriverVersion version)-obtainChromeDriver _ (UseChromeDriverAt path) = liftIO (doesFileExist path) >>= \case-  False -> return $ Left [i|Path '#{path}' didn't exist|]-  True -> return $ Right path---- | Manually obtain a geckodriver binary, according to the 'GeckoDriverToUse' policy,--- storing it under the provided 'FilePath' if necessary and returning the exact path.-obtainGeckoDriver :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadThrow m) => FilePath -> GeckoDriverToUse -> m (Either T.Text FilePath)-obtainGeckoDriver toolsDir (DownloadGeckoDriverFrom url) = do-  let path = [i|#{toolsDir}/#{geckoDriverExecutable}|]-  unlessM (liftIO $ doesFileExist path) $-    curlDownloadToPath url path-  return $ Right path-obtainGeckoDriver toolsDir (DownloadGeckoDriverVersion geckoDriverVersion) = runExceptT $ do-  let path = getGeckoDriverPath toolsDir geckoDriverVersion-  liftIO (doesFileExist path) >>= \case-    True -> return path-    False -> do-      let downloadPath = getGeckoDriverDownloadUrl geckoDriverVersion detectPlatform-      ExceptT $ downloadAndUntarballToPath downloadPath path-      return path-obtainGeckoDriver toolsDir (DownloadGeckoDriverAutodetect maybeFirefoxPath) = runExceptT $ do-  version <- ExceptT $ liftIO $ getGeckoDriverVersion maybeFirefoxPath-  ExceptT $ obtainGeckoDriver toolsDir (DownloadGeckoDriverVersion version)-obtainGeckoDriver _ (UseGeckoDriverAt path) = liftIO (doesFileExist path) >>= \case-  False -> return $ Left [i|Path '#{path}' didn't exist|]-  True -> return $ Right path---- * Lower level helpers---downloadSeleniumIfNecessary :: Constraints m => FilePath -> m (Either T.Text FilePath)-downloadSeleniumIfNecessary toolsDir = leftOnException' $ do-  let seleniumPath = [i|#{toolsDir}/selenium-server.jar|]-  liftIO (doesFileExist seleniumPath) >>= flip unless (downloadSelenium seleniumPath)-  return seleniumPath-  where-    downloadSelenium :: Constraints m => FilePath -> m ()-    downloadSelenium seleniumPath = void $ do-      info [i|Downloading selenium-server.jar to #{seleniumPath}|]-      curlDownloadToPath defaultSeleniumJarUrl seleniumPath--downloadChromeDriverIfNecessary' :: Constraints m => FilePath -> ChromeDriverVersion -> m (Either T.Text FilePath)-downloadChromeDriverIfNecessary' toolsDir chromeDriverVersion = runExceptT $ do-  let chromeDriverPath = getChromeDriverPath toolsDir chromeDriverVersion--  unlessM (liftIO $ doesFileExist chromeDriverPath) $ do-    let downloadPath = getChromeDriverDownloadUrl chromeDriverVersion detectPlatform-    ExceptT $ downloadAndUnzipToPath downloadPath chromeDriverPath--  return chromeDriverPath--downloadChromeDriverIfNecessary :: Constraints m => Maybe FilePath -> FilePath -> m (Either T.Text FilePath)-downloadChromeDriverIfNecessary maybeChromePath toolsDir = runExceptT $ do-  chromeDriverVersion <- ExceptT $ liftIO $ getChromeDriverVersion maybeChromePath-  ExceptT $ downloadChromeDriverIfNecessary' toolsDir chromeDriverVersion--getChromeDriverPath :: FilePath -> ChromeDriverVersion -> FilePath-getChromeDriverPath toolsDir (ChromeDriverVersionTuple (w, x, y, z)) = [i|#{toolsDir}/chromedrivers/#{w}.#{x}.#{y}.#{z}/#{chromeDriverExecutable}|]-getChromeDriverPath toolsDir (ChromeDriverVersionExactUrl (w, x, y, z) _) = [i|#{toolsDir}/chromedrivers/#{w}.#{x}.#{y}.#{z}/#{chromeDriverExecutable}|]--getGeckoDriverPath :: FilePath -> GeckoDriverVersion -> FilePath-getGeckoDriverPath toolsDir (GeckoDriverVersion (x, y, z)) = [i|#{toolsDir}/geckodrivers/#{x}.#{y}.#{z}/#{geckoDriverExecutable}|]--chromeDriverExecutable :: T.Text-chromeDriverExecutable = case detectPlatform of-  Windows -> "chromedriver.exe"-  _ -> "chromedriver"--geckoDriverExecutable :: T.Text-geckoDriverExecutable = case detectPlatform of-  Windows -> "geckodriver.exe"-  _ -> "geckodriver"--downloadAndUnzipToPath :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadMask m) => T.Text -> FilePath -> m (Either T.Text ())-downloadAndUnzipToPath downloadPath localPath = leftOnException' $ do-  info [i|Downloading #{downloadPath} to #{localPath}|]-  liftIO $ createDirectoryIfMissing True (takeDirectory localPath)-  withSystemTempDirectory "sandwich-webdriver-tool-download" $ \dir -> do-    curlDownloadToPath (T.unpack downloadPath) (dir </> "temp.zip")--    createProcessWithLogging ((proc "unzip" ["temp.zip", "-d", "unzipped"]) { cwd = Just dir })-      >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)-    let unzipped = dir </> "unzipped"--    executables <- (filter (/= "") . T.splitOn "\n" . T.pack) <$> readCreateProcessWithLogging (proc "find" [unzipped, "-executable", "-type", "f"]) ""-    case executables of-      [] -> liftIO $ throwIO $ userError [i|No executable found in file downloaded from #{downloadPath}|]-      [x] -> do-        liftIO $ copyFile (T.unpack x) localPath-        createProcessWithLogging (shell [i|chmod u+x #{localPath}|])-          >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)-      xs -> liftIO $ throwIO $ userError [i|Found multiple executable found in file downloaded from #{downloadPath}: #{xs}|]--downloadAndUntarballToPath :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadThrow m) => T.Text -> FilePath -> m (Either T.Text ())-downloadAndUntarballToPath downloadPath localPath = leftOnException' $ do-  info [i|Downloading #{downloadPath} to #{localPath}|]-  liftIO $ createDirectoryIfMissing True (takeDirectory localPath)-  createProcessWithLogging (shell [i|wget -qO- #{downloadPath} | tar xvz  -C #{takeDirectory localPath}|])-    >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)-  createProcessWithLogging (shell [i|chmod u+x #{localPath}|])-    >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)--curlDownloadToPath :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadThrow m) => String -> FilePath -> m ()-curlDownloadToPath downloadPath localPath = do-  info [i|Downloading #{downloadPath} to #{localPath}|]-  liftIO $ createDirectoryIfMissing True (takeDirectory localPath)-  p <- createProcessWithLogging (proc "curl" [downloadPath, "-o", localPath, "-s"])-  liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess)--unlessM :: Monad m => m Bool -> m () -> m ()-unlessM b s = b >>= (\t -> unless t s)

@@ -0,0 +1,113 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}++module Test.Sandwich.WebDriver.Internal.Binaries.Chrome (+  obtainChrome+  , obtainChromeDriver++  -- * Lower-level+  , downloadChromeDriverIfNecessary++  -- * Types+  , ChromeToUse(..)+  , ChromeDriverToUse(..)+  , ChromeVersion(..)+  , ChromeDriverVersion(..)+  ) where++import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Monad.Reader+import Control.Monad.Trans.Except+import Data.String.Interpolate+import Data.Text as T+import GHC.Stack+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.WebDriver.Internal.Binaries.Chrome.Detect+import Test.Sandwich.WebDriver.Internal.Binaries.Chrome.Types+import Test.Sandwich.WebDriver.Internal.Binaries.Common+import Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform+import UnliftIO.Directory+++type Constraints m = (+  HasCallStack+  , MonadLogger m+  , MonadUnliftIO m+  )++-- | Manually obtain a chrome binary, according to the 'ChromeToUse' policy,+obtainChrome :: (+  MonadReader context m, HasBaseContext context+  , MonadUnliftIO m, MonadLogger m+  ) => ChromeToUse -> m (Either T.Text FilePath)+obtainChrome UseChromeFromPath = do+  findExecutable "google-chrome" >>= \case+    Just p -> return $ Right p+    Nothing -> findExecutable "google-chrome-stable" >>= \case+      Just p -> return $ Right p+      Nothing -> expectationFailure [i|Couldn't find either "google-chrome" or "google-chrome-stable" on the PATH|]+obtainChrome (UseChromeAt p) = doesFileExist p >>= \case+  False -> return $ Left [i|Path '#{p}' didn't exist|]+  True -> return $ Right p+obtainChrome (UseChromeFromNixpkgs nixContext) =+  Right <$> getBinaryViaNixPackage' @"google-chrome-stable" nixContext "google-chrome"++-- | Manually obtain a @chromedriver@ binary, according to the 'ChromeDriverToUse' policy.+obtainChromeDriver :: (+  MonadReader context m, HasBaseContext context+  , MonadUnliftIO m, MonadLogger m+  )+  -- | How to obtain @chromedriver@+  => ChromeDriverToUse+  -> m (Either T.Text FilePath)+obtainChromeDriver (DownloadChromeDriverFrom toolsDir url) = do+  let path = [i|#{toolsDir}/#{chromeDriverExecutable}|]+  unlessM (liftIO $ doesFileExist path) $+    curlDownloadToPath url path+  return $ Right path+obtainChromeDriver (DownloadChromeDriverVersion toolsDir chromeDriverVersion) = runExceptT $ do+  let path = getChromeDriverPath toolsDir chromeDriverVersion+  liftIO (doesFileExist path) >>= \case+    True -> return path+    False -> do+      let downloadPath = getChromeDriverDownloadUrl chromeDriverVersion detectPlatform+      ExceptT $ downloadAndUnzipToPath downloadPath path+      return path+obtainChromeDriver (DownloadChromeDriverAutodetect toolsDir chromePath) = runExceptT $ do+  version <- ExceptT $ liftIO $ getChromeDriverVersion chromePath+  ExceptT $ obtainChromeDriver (DownloadChromeDriverVersion toolsDir version)+obtainChromeDriver (UseChromeDriverAt path) = doesFileExist path >>= \case+  False -> return $ Left [i|Path '#{path}' didn't exist|]+  True -> return $ Right path+obtainChromeDriver (UseChromeDriverFromNixpkgs nixContext) =+  Right <$> getBinaryViaNixPackage' @"chromedriver" nixContext "chromedriver"+++downloadChromeDriverIfNecessary' :: Constraints m => FilePath -> ChromeDriverVersion -> m (Either T.Text FilePath)+downloadChromeDriverIfNecessary' toolsDir chromeDriverVersion = runExceptT $ do+  let chromeDriverPath = getChromeDriverPath toolsDir chromeDriverVersion++  unlessM (liftIO $ doesFileExist chromeDriverPath) $ do+    let downloadPath = getChromeDriverDownloadUrl chromeDriverVersion detectPlatform+    ExceptT $ downloadAndUnzipToPath downloadPath chromeDriverPath++  return chromeDriverPath++downloadChromeDriverIfNecessary :: Constraints m => FilePath -> FilePath -> m (Either T.Text FilePath)+downloadChromeDriverIfNecessary chromePath toolsDir = runExceptT $ do+  chromeDriverVersion <- ExceptT $ liftIO $ getChromeDriverVersion chromePath+  ExceptT $ downloadChromeDriverIfNecessary' toolsDir chromeDriverVersion++getChromeDriverPath :: FilePath -> ChromeDriverVersion -> FilePath+getChromeDriverPath toolsDir (ChromeDriverVersionTuple (w, x, y, z)) =+  [i|#{toolsDir}/chromedrivers/#{w}.#{x}.#{y}.#{z}/#{chromeDriverExecutable}|]+getChromeDriverPath toolsDir (ChromeDriverVersionExactUrl (w, x, y, z) _) =+  [i|#{toolsDir}/chromedrivers/#{w}.#{x}.#{y}.#{z}/#{chromeDriverExecutable}|]++chromeDriverExecutable :: T.Text+chromeDriverExecutable = case detectPlatform of+  Windows -> "chromedriver.exe"+  _ -> "chromedriver"

@@ -0,0 +1,158 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}++module Test.Sandwich.WebDriver.Internal.Binaries.Chrome.Detect (+  detectChromeVersion+  , getChromeDriverVersion+  , getChromeDriverDownloadUrl++  , findChromeInEnvironment+  ) where++import Control.Exception+import Control.Monad.IO.Class+import Control.Monad.Trans.Except+import Data.Aeson as A+import qualified Data.ByteString.Lazy as LB+import Data.Function+import Data.Map as M hiding (mapMaybe)+import Data.Maybe (mapMaybe)+import Data.String.Interpolate+import Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import GHC.Generics+import Network.HTTP.Client+import Network.HTTP.Conduit (simpleHttp)+import Safe+import System.Directory (findExecutable)+import System.Exit+import qualified System.Info as SI+import System.Process+import Test.Sandwich.WebDriver.Internal.Binaries.Chrome.Types+import Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform+import Test.Sandwich.WebDriver.Internal.Util+++data PlatformAndUrl = PlatformAndUrl {+  platform :: Text+  , url :: Text+  } deriving (Show, Generic, FromJSON, ToJSON)++data Version = Version {+  version :: Text+  , revision :: Text+  , downloads :: Map Text [PlatformAndUrl]+  } deriving (Show, Generic, FromJSON, ToJSON)++data JsonResponse = JsonResponse {+  timestamp :: Text+  , versions :: [Version]+  } deriving (Show, Generic, FromJSON, ToJSON)++findChromeInEnvironment :: IO String+findChromeInEnvironment =+  flip fix candidates $ \loop cs -> case cs of+    [] -> pure "google-chrome" -- Give up+    (candidate:rest) -> findExecutable candidate >>= \case+      Nothing -> loop rest+      Just _ -> pure candidate+  where+    candidates = [+      "google-chrome"+      , "google-chrome-stable" -- May be found on NixOS+      ]++detectChromeVersion :: FilePath -> IO (Either T.Text ChromeVersion)+detectChromeVersion chromeToUse = leftOnException $ runExceptT $ do+  (exitCode, stdout, stderr) <- liftIO $ readCreateProcessWithExitCode (shell (chromeToUse <> " --version | grep -Eo \"[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\"")) ""++  rawString <- case exitCode of+    ExitFailure _ -> throwE [i|Couldn't parse google-chrome version. Stdout: '#{stdout}'. Stderr: '#{stderr}'|]+    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)+    _ -> throwE [i|Failed to parse google-chrome version from string: '#{rawString}'|]++getChromeDriverVersion :: FilePath -> IO (Either T.Text ChromeDriverVersion)+getChromeDriverVersion chromePath = runExceptT $ do+  chromeVersion <- ExceptT $ liftIO $ detectChromeVersion chromePath+  ExceptT $ getChromeDriverVersion' chromeVersion++getChromeDriverVersion' :: ChromeVersion -> IO (Either T.Text ChromeDriverVersion)+getChromeDriverVersion' (ChromeVersion (w, x, y, z))+  | w < 115 = do+      let url = [i|https://chromedriver.storage.googleapis.com/LATEST_RELEASE_#{w}.#{x}.#{y}|]+      handle (\(e :: HttpException) -> do+                return $ Left [i|Error when requesting '#{url}': '#{e}'|]+             )+             (do+                 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 $ ChromeDriverVersionTuple (w', x', y', z')+                   _ -> return $ Left [i|Failed to parse chromedriver version from string: '#{result}'|]+             )+  | otherwise = do+      let url = [i|https://googlechromelabs.github.io/chrome-for-testing/known-good-versions-with-downloads.json|]+      handle (\(e :: HttpException) -> do+                return $ Left [i|Error when requesting '#{url}': '#{e}'|]+             )+             (do+                 result :: LB.ByteString <- simpleHttp url+                 case A.eitherDecode result of+                   Left err -> return $ Left [i|Failed to decode response from '#{url}': #{err}|]+                   Right (response :: JsonResponse) -> do+                     let matchingVersions = [v | v@(Version {..}) <- versions response+                                               , [i|#{w}.#{x}.#{y}.|] `T.isPrefixOf` version]++                     let exactMatch = headMay [v | v@(Version {..}) <- matchingVersions+                                                 , [i|#{w}.#{x}.#{y}.#{z}|] == version]++                     let versionList :: [Version]+                         versionList = (case exactMatch of Nothing -> id; Just v -> (v :)) matchingVersions++                     case headMay (mapMaybe extractSuitableChromeDriver versionList) of+                       Nothing -> return $ Left [i|Couldn't find chromedriver associated with any Chrome release|]+                       Just (tup, url') -> return $ Right $ ChromeDriverVersionExactUrl tup url'+             )++extractSuitableChromeDriver :: Version -> Maybe ((Int, Int, Int, Int), Text)+extractSuitableChromeDriver (Version { version=(parseTuple -> Just tup), downloads=(M.lookup "chromedriver" -> Just platforms) }) =+  case headMay [url | PlatformAndUrl {platform, url} <- platforms+                    , platform == desiredPlatform] of+    Nothing -> Nothing+    Just url -> Just (tup, url)+  where+    desiredPlatform = case (SI.os, SI.arch) of+      ("windows", "x86_64") -> "win64"+      ("windows", "i386") -> "win32"+      ("mingw32", "x86_64") -> "win64"+      ("mingw32", "i386") -> "win32"++      ("darwin", "x86_64") -> "mac-x64"+      ("darwin", "arm") -> "mac-arm64"++      ("linux", _) -> "linux64"+      ("freebsd", _) -> "linux64"+      ("netbsd", _) -> "linux64"+      ("openbsd", _) -> "linux64"++      _ -> "unknown"+extractSuitableChromeDriver _ = Nothing++parseTuple :: Text -> Maybe (Int, Int, Int, Int)+parseTuple (T.splitOn "." -> [tReadMay -> Just w, tReadMay -> Just x, tReadMay -> Just y, tReadMay -> Just z]) = Just (w, x, y, z)+parseTuple _ = Nothing++getChromeDriverDownloadUrl :: ChromeDriverVersion -> Platform -> T.Text+getChromeDriverDownloadUrl (ChromeDriverVersionTuple (w, x, y, z)) Linux = [i|https://chromedriver.storage.googleapis.com/#{w}.#{x}.#{y}.#{z}/chromedriver_linux64.zip|]+getChromeDriverDownloadUrl (ChromeDriverVersionTuple (w, x, y, z)) OSX = [i|https://chromedriver.storage.googleapis.com/#{w}.#{x}.#{y}.#{z}/chromedriver_mac64.zip|]+getChromeDriverDownloadUrl (ChromeDriverVersionTuple (w, x, y, z)) Windows = [i|https://chromedriver.storage.googleapis.com/#{w}.#{x}.#{y}.#{z}/chromedriver_win32.zip|]+getChromeDriverDownloadUrl (ChromeDriverVersionExactUrl _ url) _ = url++-- * Util++tReadMay :: T.Text -> Maybe Int+tReadMay = readMay . T.unpack

@@ -0,0 +1,41 @@++module Test.Sandwich.WebDriver.Internal.Binaries.Chrome.Types (+  ChromeToUse(..)+  , ChromeDriverToUse(..)+  , ChromeVersion(..)+  , ChromeDriverVersion(..)+  ) where++import Data.Text as T+import Test.Sandwich.Contexts.Nix++-- | How to obtain the chrome binary.+data ChromeToUse =+  -- | Search the PATH for the @google-chrome@ or @google-chrome-stable@ binary.+  UseChromeFromPath+  -- | Use the Chrome at the given path.+  | UseChromeAt FilePath+  -- | Get Chrome from Nixpkgs.+  | UseChromeFromNixpkgs NixContext+  deriving Show++-- | How to obtain the chromedriver binary.+data ChromeDriverToUse =+  DownloadChromeDriverFrom FilePath String+  -- ^ Download chromedriver from the given URL to the 'toolsRoot'.+  | DownloadChromeDriverVersion FilePath ChromeDriverVersion+  -- ^ Download the given chromedriver version to the 'toolsRoot'.+  | DownloadChromeDriverAutodetect FilePath FilePath+  -- ^ Autodetect chromedriver to use based on the Chrome version and download it to the 'toolsRoot'+  -- Pass the path to the Chrome binary, or else it will be found by looking for google-chrome on the PATH.+  | UseChromeDriverAt FilePath+  -- ^ Use the chromedriver at the given path.+  | UseChromeDriverFromNixpkgs NixContext+  -- ^ Use the chromedriver in the given Nixpkgs derivation.+  deriving Show++newtype ChromeVersion = ChromeVersion (Int, Int, Int, Int) deriving Show+data ChromeDriverVersion =+  ChromeDriverVersionTuple (Int, Int, Int, Int)+  | ChromeDriverVersionExactUrl (Int, Int, Int, Int) Text+  deriving Show

@@ -0,0 +1,58 @@++module Test.Sandwich.WebDriver.Internal.Binaries.Common where++import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Data.String.Interpolate+import qualified Data.Text as T+import System.Directory+import System.Exit+import System.FilePath+import System.Process+import Test.Sandwich.Expectations+import Test.Sandwich.Logging+import Test.Sandwich.WebDriver.Internal.Util+import UnliftIO.Temporary+++downloadAndUnzipToPath :: (MonadUnliftIO m, MonadLogger m) => T.Text -> FilePath -> m (Either T.Text ())+downloadAndUnzipToPath downloadPath localPath = leftOnException' $ do+  info [i|Downloading #{downloadPath} to #{localPath}|]+  liftIO $ createDirectoryIfMissing True (takeDirectory localPath)+  withSystemTempDirectory "sandwich-webdriver-tool-download" $ \dir -> do+    curlDownloadToPath (T.unpack downloadPath) (dir </> "temp.zip")++    createProcessWithLogging ((proc "unzip" ["temp.zip", "-d", "unzipped"]) { cwd = Just dir })+      >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)+    let unzipped = dir </> "unzipped"++    executables <- (filter (/= "") . T.splitOn "\n" . T.pack) <$> readCreateProcessWithLogging (proc "find" [unzipped, "-executable", "-type", "f"]) ""+    case executables of+      [] -> liftIO $ throwIO $ userError [i|No executable found in file downloaded from #{downloadPath}|]+      [x] -> do+        liftIO $ copyFile (T.unpack x) localPath+        createProcessWithLogging (shell [i|chmod u+x #{localPath}|])+          >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)+      xs -> liftIO $ throwIO $ userError [i|Found multiple executable found in file downloaded from #{downloadPath}: #{xs}|]++downloadAndUntarballToPath :: (MonadUnliftIO m, MonadLogger m) => T.Text -> FilePath -> m (Either T.Text ())+downloadAndUntarballToPath downloadPath localPath = leftOnException' $ do+  info [i|Downloading #{downloadPath} to #{localPath}|]+  liftIO $ createDirectoryIfMissing True (takeDirectory localPath)+  createProcessWithLogging (shell [i|wget -qO- #{downloadPath} | tar xvz  -C #{takeDirectory localPath}|])+    >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)+  createProcessWithLogging (shell [i|chmod u+x #{localPath}|])+    >>= liftIO . waitForProcess >>= (`shouldBe` ExitSuccess)++curlDownloadToPath :: (MonadUnliftIO m, MonadLogger m) => String -> FilePath -> m ()+curlDownloadToPath downloadPath localPath = do+  info [i|Downloading #{downloadPath} to #{localPath}|]+  liftIO $ createDirectoryIfMissing True (takeDirectory localPath)+  p <- createProcessWithLogging (proc "curl" [downloadPath, "-o", localPath, "-s"])+  liftIO (waitForProcess p) >>= (`shouldBe` ExitSuccess)++unlessM :: Monad m => m Bool -> m () -> m ()+unlessM b s = b >>= (\t -> unless t s)

@@ -1,157 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}--module Test.Sandwich.WebDriver.Internal.Binaries.DetectChrome (-  detectChromeVersion-  , getChromeDriverVersion-  , getChromeDriverDownloadUrl-  ) where--import Control.Exception-import Control.Monad.IO.Class-import Control.Monad.Trans.Except-import Data.Aeson as A-import qualified Data.ByteString.Lazy as LB-import Data.Function-import Data.Map as M hiding (mapMaybe)-import Data.Maybe (mapMaybe)-import Data.String.Interpolate-import Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL-import GHC.Generics-import Network.HTTP.Client-import Network.HTTP.Conduit (simpleHttp)-import Safe-import System.Directory (findExecutable)-import System.Exit-import qualified System.Info as SI-import System.Process-import Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform-import Test.Sandwich.WebDriver.Internal.Types-import Test.Sandwich.WebDriver.Internal.Util---data PlatformAndUrl = PlatformAndUrl {-  platform :: Text-  , url :: Text-  } deriving (Show, Generic, FromJSON, ToJSON)--data Version = Version {-  version :: Text-  , revision :: Text-  , downloads :: Map Text [PlatformAndUrl]-  } deriving (Show, Generic, FromJSON, ToJSON)--data JsonResponse = JsonResponse {-  timestamp :: Text-  , versions :: [Version]-  } deriving (Show, Generic, FromJSON, ToJSON)--findChromeInEnvironment :: IO String-findChromeInEnvironment =-  flip fix candidates $ \loop cs -> case cs of-    [] -> pure "google-chrome" -- Give up-    (candidate:rest) -> findExecutable candidate >>= \case-      Nothing -> loop rest-      Just _ -> pure candidate-  where-    candidates = [-      "google-chrome"-      , "google-chrome-stable" -- May be found on NixOS-      ]--detectChromeVersion :: Maybe FilePath -> IO (Either T.Text ChromeVersion)-detectChromeVersion maybeChromePath = leftOnException $ runExceptT $ do-  chromeToUse <- liftIO $ maybe findChromeInEnvironment pure maybeChromePath--  (exitCode, stdout, stderr) <- liftIO $ readCreateProcessWithExitCode (shell (chromeToUse <> " --version | grep -Eo \"[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\"")) ""--  rawString <- case exitCode of-    ExitFailure _ -> throwE [i|Couldn't parse google-chrome version. Stdout: '#{stdout}'. Stderr: '#{stderr}'|]-    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)-    _ -> throwE [i|Failed to parse google-chrome version from string: '#{rawString}'|]--getChromeDriverVersion :: Maybe FilePath -> IO (Either T.Text ChromeDriverVersion)-getChromeDriverVersion maybeChromePath = runExceptT $ do-  chromeVersion <- ExceptT $ liftIO $ detectChromeVersion maybeChromePath-  ExceptT $ getChromeDriverVersion' chromeVersion--getChromeDriverVersion' :: ChromeVersion -> IO (Either T.Text ChromeDriverVersion)-getChromeDriverVersion' (ChromeVersion (w, x, y, z))-  | w < 115 = do-      let url = [i|https://chromedriver.storage.googleapis.com/LATEST_RELEASE_#{w}.#{x}.#{y}|]-      handle (\(e :: HttpException) -> do-                return $ Left [i|Error when requesting '#{url}': '#{e}'|]-             )-             (do-                 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 $ ChromeDriverVersionTuple (w, x, y, z)-                   _ -> return $ Left [i|Failed to parse chromedriver version from string: '#{result}'|]-             )-  | otherwise = do-      let url = [i|https://googlechromelabs.github.io/chrome-for-testing/known-good-versions-with-downloads.json|]-      handle (\(e :: HttpException) -> do-                return $ Left [i|Error when requesting '#{url}': '#{e}'|]-             )-             (do-                 result :: LB.ByteString <- simpleHttp url-                 case A.eitherDecode result of-                   Left err -> return $ Left [i|Failed to decode response from '#{url}': #{err}|]-                   Right (response :: JsonResponse) -> do-                     let matchingVersions = [v | v@(Version {..}) <- versions response-                                               , [i|#{w}.#{x}.#{y}.|] `T.isPrefixOf` version]--                     let exactMatch = headMay [x | x@(Version {..}) <- matchingVersions-                                               , [i|#{w}.#{x}.#{y}.#{z}|] == version]--                     let versionList :: [Version]-                         versionList = (case exactMatch of Nothing -> id; Just x -> (x :)) matchingVersions--                     case headMay (mapMaybe extractSuitableChromeDriver versionList) of-                       Nothing -> return $ Left [i|Couldn't find chromedriver associated with any Chrome release|]-                       Just (tup, url) -> return $ Right $ ChromeDriverVersionExactUrl tup url-             )--extractSuitableChromeDriver :: Version -> Maybe ((Int, Int, Int, Int), Text)-extractSuitableChromeDriver (Version { version=(parseTuple -> Just tup), downloads=(M.lookup "chromedriver" -> Just platforms) }) =-  case headMay [url | PlatformAndUrl {platform, url} <- platforms-                    , platform == desiredPlatform] of-    Nothing -> Nothing-    Just url -> Just (tup, url)-  where-    desiredPlatform = case (SI.os, SI.arch) of-      ("windows", "x86_64") -> "win64"-      ("windows", "i386") -> "win32"-      ("mingw32", "x86_64") -> "win64"-      ("mingw32", "i386") -> "win32"--      ("darwin", "x86_64") -> "mac-x64"-      ("darwin", "arm") -> "mac-arm64"--      ("linux", _) -> "linux64"-      ("freebsd", _) -> "linux64"-      ("netbsd", _) -> "linux64"-      ("openbsd", _) -> "linux64"--      _ -> "unknown"-extractSuitableChromeDriver _ = Nothing--parseTuple :: Text -> Maybe (Int, Int, Int, Int)-parseTuple (T.splitOn "." -> [tReadMay -> Just w, tReadMay -> Just x, tReadMay -> Just y, tReadMay -> Just z]) = Just (w, x, y, z)-parseTuple _ = Nothing--getChromeDriverDownloadUrl :: ChromeDriverVersion -> Platform -> T.Text-getChromeDriverDownloadUrl (ChromeDriverVersionTuple (w, x, y, z)) Linux = [i|https://chromedriver.storage.googleapis.com/#{w}.#{x}.#{y}.#{z}/chromedriver_linux64.zip|]-getChromeDriverDownloadUrl (ChromeDriverVersionTuple (w, x, y, z)) OSX = [i|https://chromedriver.storage.googleapis.com/#{w}.#{x}.#{y}.#{z}/chromedriver_mac64.zip|]-getChromeDriverDownloadUrl (ChromeDriverVersionTuple (w, x, y, z)) Windows = [i|https://chromedriver.storage.googleapis.com/#{w}.#{x}.#{y}.#{z}/chromedriver_win32.zip|]-getChromeDriverDownloadUrl (ChromeDriverVersionExactUrl _ url) _ = url---- * Util--tReadMay = readMay . T.unpack

@@ -1,77 +0,0 @@-{-# LANGUAGE CPP #-}--module Test.Sandwich.WebDriver.Internal.Binaries.DetectFirefox (-  detectFirefoxVersion-  , getGeckoDriverVersion-  , getGeckoDriverDownloadUrl-  ) where--import Control.Exception-import Control.Monad.IO.Class-import Control.Monad.Trans.Except-import qualified Data.Aeson as A-import Data.Maybe-import Data.String.Interpolate-import qualified Data.Text as T-import Network.HTTP.Client-import Network.HTTP.Client.TLS-import Safe-import System.Exit-import System.Process-import Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform-import Test.Sandwich.WebDriver.Internal.Types-import Test.Sandwich.WebDriver.Internal.Util--#if MIN_VERSION_aeson(2,0,0)-import qualified Data.Aeson.KeyMap          as HM-#else-import qualified Data.HashMap.Strict        as HM-#endif---detectFirefoxVersion :: Maybe FilePath -> IO (Either T.Text FirefoxVersion)-detectFirefoxVersion maybeFirefoxPath = leftOnException $ runExceptT $ do-  let firefoxToUse = fromMaybe "firefox" maybeFirefoxPath-  (exitCode, stdout, stderr) <- liftIO $ readCreateProcessWithExitCode (shell (firefoxToUse <> " --version | grep -Eo \"[0-9]+\\.[0-9]+(\\.[0-9]+)?\"")) ""--  rawString <- case exitCode of-                 ExitFailure _ -> throwE [i|Couldn't parse firefox version. Stdout: '#{stdout}'. Stderr: '#{stderr}'|]-                 ExitSuccess -> return $ T.strip $ T.pack stdout--  case T.splitOn "." rawString of-    [tReadMay -> Just x, tReadMay -> Just y] -> return $ FirefoxVersion (x, y, 0)-    [tReadMay -> Just x, tReadMay -> Just y, tReadMay -> Just z] -> return $ FirefoxVersion (x, y, z)-    _ -> throwE [i|Failed to parse firefox version from string: '#{rawString}'|]---getGeckoDriverVersion :: Maybe FilePath -> IO (Either T.Text GeckoDriverVersion)-getGeckoDriverVersion _maybeFirefoxPath = runExceptT $ do-  -- firefoxVersion <- ExceptT $ liftIO $ detectFirefoxVersion maybeFirefoxPath--  -- Just get the latest release on GitHub-  let url = [i|https://api.github.com/repos/mozilla/geckodriver/releases/latest|]-  req <- parseRequest url-  manager <- liftIO newTlsManager-  ExceptT $-    handle (\(e :: HttpException) -> return $ Left [i|Error when requesting '#{url}': '#{e}'|])-           (do-               result <- httpLbs (req { requestHeaders = ("User-Agent", "foo") : (requestHeaders req) }) manager-               case A.eitherDecode $ responseBody result of-                 Right (A.Object (HM.lookup "tag_name" -> Just (A.String tag))) -> do-                   let parts = T.splitOn "." $ T.drop 1 tag-                   case parts of-                     [tReadMay -> Just x, tReadMay -> Just y] -> return $ Right $ GeckoDriverVersion (x, y, 0)-                     [tReadMay -> Just x, tReadMay -> Just y, tReadMay -> Just z] -> return $ Right $ GeckoDriverVersion (x, y, z)-                     _ -> return $ Left [i|Unexpected geckodriver release tag: '#{tag}'|]-                 val -> return $ Left [i|Failed to decode GitHub releases: '#{val}'|]-           )---getGeckoDriverDownloadUrl :: GeckoDriverVersion -> Platform -> T.Text-getGeckoDriverDownloadUrl (GeckoDriverVersion (x, y, z)) Linux = [i|https://github.com/mozilla/geckodriver/releases/download/v#{x}.#{y}.#{z}/geckodriver-v#{x}.#{y}.#{z}-linux64.tar.gz|]-getGeckoDriverDownloadUrl (GeckoDriverVersion (x, y, z)) OSX = [i|https://github.com/mozilla/geckodriver/releases/download/v#{x}.#{y}.#{z}/geckodriver-v#{x}.#{y}.#{z}-macos.tar.gz|]-getGeckoDriverDownloadUrl (GeckoDriverVersion (x, y, z)) Windows = [i|https://github.com/mozilla/geckodriver/releases/download/v#{x}.#{y}.#{z}/geckodriver-v#{x}.#{y}.#{z}-win32.tar.gz|]---- * Util--tReadMay = readMay . T.unpack

@@ -0,0 +1,44 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}++module Test.Sandwich.WebDriver.Internal.Binaries.Ffmpeg (+  obtainFfmpeg++  -- * Types+  , FfmpegToUse(..)+  ) where++import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Monad.Reader+import Data.String.Interpolate+import qualified Data.Text as T+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.WebDriver.Internal.Binaries.Ffmpeg.Types+import UnliftIO.Directory+++-- | Manually obtain an ffmpeg binary, according to the 'FfmpegToUse' policy.+obtainFfmpeg :: (+  MonadReader context m, HasBaseContext context+  , MonadUnliftIO m, MonadLoggerIO m, MonadMask m+  ) => FfmpegToUse -> m (Either T.Text FilePath)+obtainFfmpeg UseFfmpegFromPath = findExecutable "ffmpeg" >>= \case+  Nothing -> return $ Left [i|Couldn't find "ffmpeg" on the PATH.|]+  Just p -> return $ Right p+obtainFfmpeg (UseFfmpegAt path) = doesFileExist path >>= \case+  False -> return $ Left [i|Path '#{path}' didn't exist|]+  True -> return $ Right path+obtainFfmpeg (UseFfmpegFromNixpkgs nixContext) =+  Right <$> getBinaryViaNixDerivation' @"ffmpeg" nixContext ffmpegDerivation+++ffmpegDerivation :: T.Text+ffmpegDerivation = [i|+{ ffmpeg+}:++ffmpeg.override { withXcb = true; }+|]

@@ -0,0 +1,16 @@++module Test.Sandwich.WebDriver.Internal.Binaries.Ffmpeg.Types (+  FfmpegToUse(..)+  ) where++import Test.Sandwich.Contexts.Nix++-- | How to obtain the @ffmpeg@ binary.+data FfmpegToUse =+  -- | Search the PATH for the @ffmpeg@ binary.+  UseFfmpegFromPath+  -- | Use the @ffmpeg@ at the given path.+  | UseFfmpegAt FilePath+  -- | Get @ffmpeg@ from Nixpkgs.+  | UseFfmpegFromNixpkgs NixContext+  deriving Show

@@ -0,0 +1,82 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}++module Test.Sandwich.WebDriver.Internal.Binaries.Firefox (+  obtainFirefox+  , obtainGeckoDriver++  , FirefoxToUse(..)+  , GeckoDriverToUse(..)+  , GeckoDriverVersion(..)+  ) where++import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Monad.Reader+import Control.Monad.Trans.Except+import Data.String.Interpolate+import qualified Data.Text as T+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.WebDriver.Internal.Binaries.Common+import Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform+import Test.Sandwich.WebDriver.Internal.Binaries.Firefox.Detect+import Test.Sandwich.WebDriver.Internal.Binaries.Firefox.Types+import UnliftIO.Directory+++-- | Manually obtain a firefox binary, according to the 'FirefoxToUse' policy,+obtainFirefox :: (+  MonadReader context m, HasBaseContext context+  , MonadUnliftIO m, MonadLogger m+  ) => FirefoxToUse -> m (Either T.Text FilePath)+obtainFirefox UseFirefoxFromPath = do+  findExecutable "firefox" >>= \case+    Just p -> return $ Right p+    Nothing -> expectationFailure [i|Couldn't find "firefox" on the PATH|]+obtainFirefox (UseFirefoxAt p) = doesFileExist p >>= \case+  False -> return $ Left [i|Path '#{p}' didn't exist|]+  True -> return $ Right p+obtainFirefox (UseFirefoxFromNixpkgs nixContext) =+  Right <$> getBinaryViaNixPackage' @"firefox" nixContext "firefox"++-- | Manually obtain a @geckodriver@ binary, according to the 'GeckoDriverToUse' policy,+-- storing it under the provided 'FilePath' if necessary and returning the exact path.+obtainGeckoDriver :: (+  MonadReader context m, HasBaseContext context+  , MonadUnliftIO m, MonadLogger m+  )+  -- | How to obtain @geckodriver@+  => GeckoDriverToUse+  -> m (Either T.Text FilePath)+obtainGeckoDriver (DownloadGeckoDriverFrom toolsDir url) = do+  let path = [i|#{toolsDir}/#{geckoDriverExecutable}|]+  unlessM (liftIO $ doesFileExist path) $+    curlDownloadToPath url path+  return $ Right path+obtainGeckoDriver (DownloadGeckoDriverVersion toolsDir geckoDriverVersion) = runExceptT $ do+  let path = getGeckoDriverPath toolsDir geckoDriverVersion+  liftIO (doesFileExist path) >>= \case+    True -> return path+    False -> do+      let downloadPath = getGeckoDriverDownloadUrl geckoDriverVersion detectPlatform+      ExceptT $ downloadAndUntarballToPath downloadPath path+      return path+obtainGeckoDriver (DownloadGeckoDriverAutodetect toolsDir) = runExceptT $ do+  version <- ExceptT $ liftIO $ getGeckoDriverVersion Nothing+  ExceptT $ obtainGeckoDriver (DownloadGeckoDriverVersion toolsDir version)+obtainGeckoDriver (UseGeckoDriverAt path) = liftIO (doesFileExist path) >>= \case+  False -> return $ Left [i|Path '#{path}' didn't exist|]+  True -> return $ Right path+obtainGeckoDriver (UseGeckoDriverFromNixpkgs nixContext) = Right <$> getBinaryViaNixPackage' @"geckodriver" nixContext "geckodriver"+++getGeckoDriverPath :: FilePath -> GeckoDriverVersion -> FilePath+getGeckoDriverPath toolsDir (GeckoDriverVersion (x, y, z)) = [i|#{toolsDir}/geckodrivers/#{x}.#{y}.#{z}/#{geckoDriverExecutable}|]++geckoDriverExecutable :: T.Text+geckoDriverExecutable = case detectPlatform of+  Windows -> "geckodriver.exe"+  _ -> "geckodriver"

@@ -0,0 +1,78 @@+{-# LANGUAGE CPP #-}++module Test.Sandwich.WebDriver.Internal.Binaries.Firefox.Detect (+  detectFirefoxVersion+  , getGeckoDriverVersion+  , getGeckoDriverDownloadUrl+  ) where++import Control.Exception+import Control.Monad.IO.Class+import Control.Monad.Trans.Except+import qualified Data.Aeson as A+import Data.Maybe+import Data.String.Interpolate+import qualified Data.Text as T+import Network.HTTP.Client+import Network.HTTP.Client.TLS+import Safe+import System.Exit+import System.Process+import Test.Sandwich.WebDriver.Internal.Binaries.DetectPlatform+import Test.Sandwich.WebDriver.Internal.Binaries.Firefox.Types+import Test.Sandwich.WebDriver.Internal.Util++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap          as HM+#else+import qualified Data.HashMap.Strict        as HM+#endif+++detectFirefoxVersion :: Maybe FilePath -> IO (Either T.Text FirefoxVersion)+detectFirefoxVersion maybeFirefoxPath = leftOnException $ runExceptT $ do+  let firefoxToUse = fromMaybe "firefox" maybeFirefoxPath+  (exitCode, stdout, stderr) <- liftIO $ readCreateProcessWithExitCode (shell (firefoxToUse <> " --version | grep -Eo \"[0-9]+\\.[0-9]+(\\.[0-9]+)?\"")) ""++  rawString <- case exitCode of+                 ExitFailure _ -> throwE [i|Couldn't parse firefox version. Stdout: '#{stdout}'. Stderr: '#{stderr}'|]+                 ExitSuccess -> return $ T.strip $ T.pack stdout++  case T.splitOn "." rawString of+    [tReadMay -> Just x, tReadMay -> Just y] -> return $ FirefoxVersion (x, y, 0)+    [tReadMay -> Just x, tReadMay -> Just y, tReadMay -> Just z] -> return $ FirefoxVersion (x, y, z)+    _ -> throwE [i|Failed to parse firefox version from string: '#{rawString}'|]+++getGeckoDriverVersion :: Maybe FilePath -> IO (Either T.Text GeckoDriverVersion)+getGeckoDriverVersion _maybeFirefoxPath = runExceptT $ do+  -- firefoxVersion <- ExceptT $ liftIO $ detectFirefoxVersion maybeFirefoxPath++  -- Just get the latest release on GitHub+  let url = [i|https://api.github.com/repos/mozilla/geckodriver/releases/latest|]+  req <- parseRequest url+  manager <- liftIO newTlsManager+  ExceptT $+    handle (\(e :: HttpException) -> return $ Left [i|Error when requesting '#{url}': '#{e}'|])+           (do+               result <- httpLbs (req { requestHeaders = ("User-Agent", "foo") : (requestHeaders req) }) manager+               case A.eitherDecode $ responseBody result of+                 Right (A.Object (HM.lookup "tag_name" -> Just (A.String tag))) -> do+                   let parts = T.splitOn "." $ T.drop 1 tag+                   case parts of+                     [tReadMay -> Just x, tReadMay -> Just y] -> return $ Right $ GeckoDriverVersion (x, y, 0)+                     [tReadMay -> Just x, tReadMay -> Just y, tReadMay -> Just z] -> return $ Right $ GeckoDriverVersion (x, y, z)+                     _ -> return $ Left [i|Unexpected geckodriver release tag: '#{tag}'|]+                 val -> return $ Left [i|Failed to decode GitHub releases: '#{val}'|]+           )+++getGeckoDriverDownloadUrl :: GeckoDriverVersion -> Platform -> T.Text+getGeckoDriverDownloadUrl (GeckoDriverVersion (x, y, z)) Linux = [i|https://github.com/mozilla/geckodriver/releases/download/v#{x}.#{y}.#{z}/geckodriver-v#{x}.#{y}.#{z}-linux64.tar.gz|]+getGeckoDriverDownloadUrl (GeckoDriverVersion (x, y, z)) OSX = [i|https://github.com/mozilla/geckodriver/releases/download/v#{x}.#{y}.#{z}/geckodriver-v#{x}.#{y}.#{z}-macos.tar.gz|]+getGeckoDriverDownloadUrl (GeckoDriverVersion (x, y, z)) Windows = [i|https://github.com/mozilla/geckodriver/releases/download/v#{x}.#{y}.#{z}/geckodriver-v#{x}.#{y}.#{z}-win32.tar.gz|]++-- * Util++tReadMay :: T.Text -> Maybe Int+tReadMay = readMay . T.unpack

@@ -0,0 +1,32 @@++module Test.Sandwich.WebDriver.Internal.Binaries.Firefox.Types where++import Test.Sandwich.Contexts.Nix+++-- | How to obtain the @firefox@ binary.+data FirefoxToUse =+  -- | Search the PATH for the @firefox@ binary.+  UseFirefoxFromPath+  -- | Use the Firefox at the given path.+  | UseFirefoxAt FilePath+  -- | Get Firefox from Nixpkgs.+  | UseFirefoxFromNixpkgs NixContext+  deriving Show++-- | How to obtain the @geckodriver@ binary.+data GeckoDriverToUse =+  DownloadGeckoDriverFrom FilePath String+  -- ^ Download @geckodriver@ from the given URL to the 'toolsRoot'.+  | DownloadGeckoDriverVersion FilePath GeckoDriverVersion+  -- ^ Download the given @geckodriver@ version to the 'toolsRoot'.+  | DownloadGeckoDriverAutodetect FilePath+  -- ^ Autodetect @geckodriver@ to use based on the Firefox version and download it to the 'toolsRoot'.+  | UseGeckoDriverAt FilePath+  -- ^ Use the @geckodriver@ at the given path.+  | UseGeckoDriverFromNixpkgs NixContext+  -- ^ Use the @geckodriver@ in the given Nixpkgs derivation.+  deriving Show++newtype FirefoxVersion = FirefoxVersion (Int, Int, Int) deriving Show+newtype GeckoDriverVersion = GeckoDriverVersion (Int, Int, Int) deriving Show

@@ -0,0 +1,77 @@+{-# LANGUAGE ConstraintKinds #-}++module Test.Sandwich.WebDriver.Internal.Binaries.Selenium (+  obtainSelenium+  , downloadSeleniumIfNecessary+  , SeleniumToUse(..)+  ) where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Monad.Reader+import qualified Data.List as L+import Data.String.Interpolate+import qualified Data.Text as T+import GHC.Stack+import System.Directory+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Nix+import Test.Sandwich.WebDriver.Internal.Binaries.Common+import Test.Sandwich.WebDriver.Internal.Binaries.Selenium.Types+import Test.Sandwich.WebDriver.Internal.Util+++type Constraints m = (+  HasCallStack+  , MonadLogger m+  , MonadUnliftIO m+  )++-- * Obtaining binaries++defaultSeleniumJarUrl :: String+defaultSeleniumJarUrl = "https://selenium-release.storage.googleapis.com/3.141/selenium-server-standalone-3.141.59.jar"++-- | Manually obtain a Selenium server JAR file, according to the 'SeleniumToUse' policy,+-- storing it under the provided 'FilePath' if necessary and returning the exact path.+obtainSelenium :: (+  MonadReader context m, HasBaseContext context+  , MonadUnliftIO m, MonadLogger m+  )+  -- | How to obtain Selenium+  => SeleniumToUse+  -> m FilePath+obtainSelenium (DownloadSeleniumFrom toolsDir url) = do+  let path = [i|#{toolsDir}/selenium-server-standalone.jar|]+  unlessM (liftIO $ doesFileExist path) $+    curlDownloadToPath url path+  return path+obtainSelenium (DownloadSeleniumDefault toolsDir) = do+  let path = [i|#{toolsDir}/selenium-server-standalone-3.141.59.jar|]+  unlessM (liftIO $ doesFileExist path) $+    curlDownloadToPath defaultSeleniumJarUrl path+  return path+obtainSelenium (UseSeleniumAt path) = liftIO (doesFileExist path) >>= \case+  False -> expectationFailure [i|Path '#{path}' didn't exist|]+  True -> return path+obtainSelenium (UseSeleniumFromNixpkgs nixContext) = do+  buildNixSymlinkJoin' nixContext ["selenium-server-standalone"] >>=+    liftIO . findFirstFile (return . (".jar" `L.isSuffixOf`))+++-- * Lower level helpers+++downloadSeleniumIfNecessary :: Constraints m => FilePath -> m (Either T.Text FilePath)+downloadSeleniumIfNecessary toolsDir = leftOnException' $ do+  let seleniumPath = [i|#{toolsDir}/selenium-server.jar|]+  liftIO (doesFileExist seleniumPath) >>= flip unless (downloadSelenium seleniumPath)+  return seleniumPath+  where+    downloadSelenium :: Constraints m => FilePath -> m ()+    downloadSelenium seleniumPath = void $ do+      info [i|Downloading selenium-server.jar to #{seleniumPath}|]+      curlDownloadToPath defaultSeleniumJarUrl seleniumPath

@@ -0,0 +1,17 @@++module Test.Sandwich.WebDriver.Internal.Binaries.Selenium.Types where++import Test.Sandwich.Contexts.Nix+++-- | How to obtain the Selenium server JAR file.+data SeleniumToUse =+  DownloadSeleniumFrom FilePath String+  -- ^ Download selenium from the given URL to the 'toolsRoot'+  | DownloadSeleniumDefault FilePath+  -- ^ Download selenium from a default location to the 'toolsRoot'+  | UseSeleniumAt FilePath+  -- ^ Use the JAR file at the given path+  | UseSeleniumFromNixpkgs NixContext+  -- ^ Use the Selenium in the given Nixpkgs derivation+  deriving Show

@@ -0,0 +1,37 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}++module Test.Sandwich.WebDriver.Internal.Binaries.Xvfb (+  obtainXvfb++  -- * Types+  , XvfbDependenciesSpec(..)+  , XvfbToUse(..)+  , FluxboxToUse(..)+  ) where++import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Monad.Reader+import Data.String.Interpolate+import qualified Data.Text as T+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.WebDriver.Internal.Binaries.Xvfb.Types+import UnliftIO.Directory+++-- | Manually obtain an Xvfb binary, according to the 'XvfbToUse' policy.+obtainXvfb :: (+  MonadReader context m, HasBaseContext context+  , MonadUnliftIO m, MonadLoggerIO m+  ) => XvfbToUse -> m (Either T.Text FilePath)+obtainXvfb UseXvfbFromPath = findExecutable "Xvfb" >>= \case+  Nothing -> return $ Left [i|Couldn't find "Xvfb" on the PATH.|]+  Just p -> return $ Right p+obtainXvfb (UseXvfbAt path) = doesFileExist path >>= \case+  False -> return $ Left [i|Path '#{path}' didn't exist|]+  True -> return $ Right path+obtainXvfb (UseXvfbFromNixpkgs nixContext) =+  -- Note: on master *after* release-24.05, there seems to be xorg.xvfb+  Right <$> getBinaryViaNixPackage' @"Xvfb" nixContext "xorg.xorgserver"

@@ -0,0 +1,33 @@++module Test.Sandwich.WebDriver.Internal.Binaries.Xvfb.Types (+  XvfbDependenciesSpec(..)+  , XvfbToUse(..)+  , FluxboxToUse(..)+  ) where++import Test.Sandwich.Contexts.Nix++data XvfbDependenciesSpec = XvfbDependenciesSpec {+  xvfbDependenciesSpecXvfb :: XvfbToUse+  , xvfbDependenciesSpecFluxbox :: Maybe FluxboxToUse+  }++-- | How to obtain the @Xvfb@ binary.+data XvfbToUse =+  -- | Search the PATH for the @Xvfb@ binary.+  UseXvfbFromPath+  -- | Use the @Xvfb@ at the given path.+  | UseXvfbAt FilePath+  -- | Get @Xvfb@ from Nixpkgs.+  | UseXvfbFromNixpkgs NixContext+  deriving Show++-- | How to obtain the @fluxbox@ binary.+data FluxboxToUse =+  -- | Search the PATH for the @fluxbox@ binary.+  UseFluxboxFromPath+  -- | Use the @fluxbox@ at the given path.+  | UseFluxboxAt FilePath+  -- | Get @fluxbox@ from Nixpkgs.+  | UseFluxboxFromNixpkgs NixContext+  deriving Show

@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedLists #-}--- |  module Test.Sandwich.WebDriver.Internal.Capabilities (   -- * Chrome@@ -20,12 +19,13 @@ import qualified Test.WebDriver.Firefox.Profile as FF  loggingPrefs :: A.Value-loggingPrefs = A.object [("browser", "ALL")-                        , ("client", "WARNING")-                        , ("driver", "WARNING")-                        , ("performance", "ALL")-                        , ("server", "WARNING")-                        ]+loggingPrefs = A.object [+  ("browser", "ALL")+  , ("client", "WARNING")+  , ("driver", "WARNING")+  , ("performance", "ALL")+  , ("server", "WARNING")+  ]  -- * Chrome 

@@ -0,0 +1,130 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE OverloadedLists #-}++module Test.Sandwich.WebDriver.Internal.Capabilities.Extra (+  configureHeadlessCapabilities+  , configureDownloadCapabilities+  ) where++import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import qualified Data.Aeson as A+import Data.Function+import qualified Data.List as L+import Data.Maybe+import Data.String.Interpolate+import qualified Data.Text as T+import qualified Data.Vector as V+import GHC.Stack+import Lens.Micro+import Lens.Micro.Aeson+import Test.Sandwich+import Test.Sandwich.WebDriver.Internal.Binaries.Chrome.Detect (detectChromeVersion)+import Test.Sandwich.WebDriver.Internal.Binaries.Chrome.Types (ChromeVersion(..))+import Test.Sandwich.WebDriver.Internal.Types+import qualified Test.WebDriver as W+import qualified Test.WebDriver.Firefox.Profile as FF+++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key             as A+import qualified Data.Aeson.KeyMap          as HM+fromText :: T.Text -> A.Key+fromText = A.fromText+#else+import qualified Data.HashMap.Strict        as HM+fromText :: T.Text -> T.Text+fromText = id+#endif+++type Constraints m = (HasCallStack, MonadLogger m, MonadUnliftIO m, MonadMask m)++-- | Add headless configuration to the Chrome browser+configureHeadlessCapabilities :: (Constraints m) => WdOptions -> RunMode -> W.Capabilities -> m W.Capabilities+configureHeadlessCapabilities _wdOptions (RunHeadless (HeadlessConfig {..})) caps@(W.Capabilities {W.browser=browser@(W.Chrome {..})}) = do+  chromeBinaryPath <- case chromeBinary of+    Nothing -> expectationFailure [i|Chrome capabilities didn't define chromeBinary in configureHeadlessCapabilities|]+    Just x -> pure x++  headlessArg <- liftIO (detectChromeVersion chromeBinaryPath) >>= \case+    Left err -> do+      warn [i|Couldn't determine chrome version when configuring headless capabilities (err: #{err}); passing --headless|]+      return "--headless"+    Right (ChromeVersion (major, _, _, _))+      -- See https://www.selenium.dev/blog/2023/headless-is-going-away/+      | major >= 110 -> return "--headless=new"+      | otherwise -> return "--headless"++  let browser' = browser { W.chromeOptions = headlessArg:resolution:chromeOptions }++  return (caps { W.browser = browser' })++  where+    resolution = [i|--window-size=#{w},#{h}|]+    (w, h) = fromMaybe (1920, 1080) headlessResolution++-- | Add headless configuration to the Firefox capabilities+configureHeadlessCapabilities _ (RunHeadless (HeadlessConfig {})) caps@(W.Capabilities {W.browser=(W.Firefox {}), W.additionalCaps=ac}) = return (caps { W.additionalCaps = additionalCaps })+  where+    additionalCaps = case L.findIndex (\x -> fst x == "moz:firefoxOptions") ac of+      Nothing -> ("moz:firefoxOptions", A.object [("args", A.Array ["-headless"])]) : ac+      Just i' -> let ffOptions' = snd (ac !! i')+                                & ensureKeyExists "args" (A.Array [])+                                & ((key "args" . _Array) %~ addHeadlessArg) in+        L.nubBy (\x y -> fst x == fst y) (("moz:firefoxOptions", ffOptions') : ac)++    ensureKeyExists :: T.Text -> A.Value -> A.Value -> A.Value+    ensureKeyExists key' _ val@(A.Object (HM.lookup (fromText key') -> Just _)) = val+    ensureKeyExists key' defaultVal (A.Object m@(HM.lookup (fromText key') -> Nothing)) = A.Object (HM.insert (fromText key') defaultVal m)+    ensureKeyExists _ _ _ = error "Expected Object in ensureKeyExists"++    addHeadlessArg :: V.Vector A.Value -> V.Vector A.Value+    addHeadlessArg xs | (A.String "-headless") `V.elem` xs = xs+    addHeadlessArg xs = (A.String "-headless") `V.cons` xs++configureHeadlessCapabilities _ (RunHeadless {}) browser = error [i|Headless mode not yet supported for browser '#{browser}'|]+configureHeadlessCapabilities _ _ browser = return browser+++-- | Configure download capabilities to set the download directory and disable prompts+-- (since you can't test download prompts using Selenium)+configureDownloadCapabilities :: (+  MonadIO m+  ) => [Char] -> W.Capabilities -> m W.Capabilities+configureDownloadCapabilities downloadDir caps@(W.Capabilities {W.browser=browser@(W.Firefox {..})}) = do+  profile <- case ffProfile of+    Just x -> pure x+    Nothing -> liftIO $ FF.defaultProfile+      & FF.addPref "browser.download.folderList" (2 :: Int)+      & FF.addPref "browser.download.manager.showWhenStarting" False+      & FF.addPref "browser.download.dir" downloadDir+      & FF.addPref "browser.helperApps.neverAsk.saveToDisk" ("*" :: String)+      & FF.prepareProfile++  return (caps { W.browser = browser { W.ffProfile = Just profile } })+configureDownloadCapabilities downloadDir caps@(W.Capabilities {W.browser=browser@(W.Chrome {..})}) = return $ caps { W.browser=browser' }+  where+    browser' = browser { W.chromeExperimentalOptions = options }++    basePrefs :: A.Object+    basePrefs = case HM.lookup "prefs" chromeExperimentalOptions of+      Just (A.Object hm) -> hm+      Just x -> error [i|Expected chrome prefs to be object, got '#{x}'.|]+      Nothing -> mempty++    prefs :: A.Object+    prefs = basePrefs+          & foldl (.) id [HM.insert k v | (k, v) <- downloadPrefs]++    options = HM.insert "prefs" (A.Object prefs) chromeExperimentalOptions++    downloadPrefs = [("profile.default_content_setting_values.automatic_downloads", A.Number 1)+                    , ("profile.content_settings.exceptions.automatic_downloads.*.setting", A.Number 1)+                    , ("download.prompt_for_download", A.Bool False)+                    , ("download.directory_upgrade", A.Bool True)+                    , ("download.default_directory", A.String (T.pack downloadDir))]+configureDownloadCapabilities _ browser = return browser

@@ -0,0 +1,176 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Test.Sandwich.WebDriver.Internal.Dependencies (+  WebDriverDependencies(..)+  , BrowserDependenciesSpec(..)++  , defaultWebDriverDependencies++  , BrowserDependencies(..)+  , browserDependencies+  , HasBrowserDependencies++  , getBrowserDependencies+  , introduceBrowserDependenciesViaNix+  , introduceBrowserDependenciesViaNix'+  , fillInCapabilitiesAndGetDriverArgs+  ) where++import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Monad.Reader+import Data.String.Interpolate+import System.FilePath+import Test.Sandwich+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Nix+import Test.Sandwich.WebDriver.Internal.Binaries.Chrome+import Test.Sandwich.WebDriver.Internal.Binaries.Ffmpeg+import Test.Sandwich.WebDriver.Internal.Binaries.Firefox+import Test.Sandwich.WebDriver.Internal.Binaries.Selenium.Types+import Test.Sandwich.WebDriver.Internal.Binaries.Xvfb+import Test.Sandwich.WebDriver.Internal.Util+import qualified Test.WebDriver as W+++-- * All dependencies++-- | This type describes how we should obtain all the dependencies needed to launch a WebDriver session.+-- You can configure them individually.+data WebDriverDependencies = WebDriverDependencies {+  -- | Path to @java@ binary to use to start Selenium. If not provided, we'll search the PATH.+  webDriverDependencyJava :: Maybe FilePath+  -- | How to obtain a @selenium.jar@ file.+  , webDriverDependencySelenium :: SeleniumToUse+  -- | Browser/driver dependencies.+  , webDriverDependencyBrowser :: BrowserDependenciesSpec+  -- | How to obtain @Xvfb@ (used for the 'RunInXvfb' 'RunMode').+  , webDriverXvfb :: XvfbDependenciesSpec+  -- | How to obtain @ffmpeg@ (used for video recording).+  , webDriverFfmpeg :: FfmpegToUse+  }++-- | This type describes how to obain a browser + browser driver combination.+data BrowserDependenciesSpec = BrowserDependenciesSpecChrome {+  browserDependenciesSpecChromeChrome :: ChromeToUse+  , browserDependenciesSpecChromeChromeDriver :: ChromeDriverToUse+  }+  | BrowserDependenciesSpecFirefox {+      browserDependenciesSpecFirefoxFirefox :: FirefoxToUse+      , browserDependenciesSpecFirefoxGeckodriver :: GeckoDriverToUse+      }++-- | This configuration will+--+-- * Use @java@ from the PATH, failing if it isn't found.+-- * Download Selenium to @\/tmp\/tools@, reusing the one there if found.+-- * Use @firefox@ from the PATH as the browser.+-- * Download a compatible @geckodriver@ to @\/tmp\/tools@, reusing the one there if found.+-- * If applicable, it will also get @Xvfb@, @fluxbox@, and/or @ffmpeg@ from the PATH.+--+-- But, it's easy to customize this behavior. You can define your own 'WebDriverDependencies' and customize+-- how each of these dependencies are found.+defaultWebDriverDependencies = WebDriverDependencies {+  webDriverDependencyJava = Nothing+  , webDriverDependencySelenium = DownloadSeleniumDefault "/tmp/tools"+  , webDriverDependencyBrowser = BrowserDependenciesSpecFirefox UseFirefoxFromPath (DownloadGeckoDriverAutodetect "/tmp/tools")+  , webDriverXvfb = XvfbDependenciesSpec UseXvfbFromPath (Just UseFluxboxFromPath)+  , webDriverFfmpeg = UseFfmpegFromPath+  }++-- * Browser dependencies++data BrowserDependencies = BrowserDependenciesChrome {+  browserDependenciesChromeChrome :: FilePath+  , browserDependenciesChromeChromedriver :: FilePath+  }+  | BrowserDependenciesFirefox {+      browserDependenciesFirefoxFirefox :: FilePath+      , browserDependenciesFirefoxGeckodriver :: FilePath+      }+  deriving (Show)++browserDependencies :: Label "browserDependencies" BrowserDependencies+browserDependencies = Label++type HasBrowserDependencies context = HasLabel context "browserDependencies" BrowserDependencies++getBrowserDependencies :: (+  MonadUnliftIO m, MonadLogger m+  , MonadReader context m, HasBaseContext context+  ) => BrowserDependenciesSpec -> m BrowserDependencies+getBrowserDependencies BrowserDependenciesSpecChrome {..} = do+  chrome <- exceptionOnLeft $ obtainChrome browserDependenciesSpecChromeChrome+  chromeDriver <- exceptionOnLeft $ obtainChromeDriver browserDependenciesSpecChromeChromeDriver+  return $ BrowserDependenciesChrome chrome chromeDriver+getBrowserDependencies (BrowserDependenciesSpecFirefox {..}) = do+  firefox <- exceptionOnLeft $ obtainFirefox browserDependenciesSpecFirefoxFirefox+  geckoDriver <- exceptionOnLeft $ obtainGeckoDriver browserDependenciesSpecFirefoxGeckodriver+  return $ BrowserDependenciesFirefox firefox geckoDriver++-- | Introduce 'BrowserDependencies' via Nix, using the command line options.+-- This is useful to create the context for functions like 'allocateWebDriver'.+introduceBrowserDependenciesViaNix :: forall m context. (+  MonadUnliftIO m, HasBaseContext context, HasNixContext context, HasSomeCommandLineOptions context+  )+  -- | Child spec+  => SpecFree (LabelValue "browserDependencies" BrowserDependencies :> context) m ()+  -- | Parent spec+  -> SpecFree context m ()+introduceBrowserDependenciesViaNix = introduceBrowserDependenciesViaNix' (defaultNodeOptions { nodeOptionsVisibilityThreshold = 100 })++-- | Same as 'introduceBrowserDependenciesViaNix', but allows passing custom 'NodeOptions'.+introduceBrowserDependenciesViaNix' :: forall m context. (+  MonadUnliftIO m, HasBaseContext context, HasNixContext context, HasSomeCommandLineOptions context+  )+  => NodeOptions+  -- | Child spec+  -> SpecFree (LabelValue "browserDependencies" BrowserDependencies :> context) m ()+  -- | Parent spec+  -> SpecFree context m ()+introduceBrowserDependenciesViaNix' nodeOptions = introduce' nodeOptions "Introduce browser dependencies" browserDependencies alloc (const $ return ())+  where+    alloc = do+      SomeCommandLineOptions (CommandLineOptions {optWebdriverOptions=(CommandLineWebdriverOptions {..})}) <- getSomeCommandLineOptions++      let useChrome = BrowserDependenciesChrome <$> getBinaryViaNixPackage @"google-chrome-stable" "google-chrome"+                                                <*> getBinaryViaNixPackage @"chromedriver" "chromedriver"++      let useFirefox = BrowserDependenciesFirefox <$> getBinaryViaNixPackage @"firefox" "firefox"+                                                  <*> getBinaryViaNixPackage @"geckodriver" "geckodriver"++      deps <- case optFirefox of+        Just UseChrome -> useChrome+        Just UseFirefox -> useFirefox+        Nothing -> useChrome++      debug [i|Got browser dependencies: #{deps}|]++      return deps++fillInCapabilitiesAndGetDriverArgs webdriverRoot capabilities'' = getContext browserDependencies >>= \case+  BrowserDependenciesFirefox {..} -> do+    let args = [+          [i|-Dwebdriver.gecko.driver=#{browserDependenciesFirefoxGeckodriver}|]+          -- , [i|-Dwebdriver.gecko.logfile=#{webdriverRoot </> "geckodriver.log"}|]+          -- , [i|-Dwebdriver.gecko.verboseLogging=true|]+          ]+    let capabilities' = capabilities'' {+          W.browser = W.firefox { W.ffBinary = Just browserDependenciesFirefoxFirefox }+          }+    return (args, capabilities')+  BrowserDependenciesChrome {..} -> do+    let args = [+          [i|-Dwebdriver.chrome.driver=#{browserDependenciesChromeChromedriver}|]+          , [i|-Dwebdriver.chrome.logfile=#{webdriverRoot </> "chromedriver.log"}|]+          , [i|-Dwebdriver.chrome.verboseLogging=true|]+          ]+    let capabilities' = capabilities'' {+          W.browser = W.chrome { W.chromeBinary = Just browserDependenciesChromeChrome }+          }+    return (args, capabilities')

@@ -0,0 +1,45 @@++module Test.Sandwich.WebDriver.Internal.OnDemand where++import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Data.String.Interpolate+import Data.Text as T+import Test.Sandwich+import Test.Sandwich.WebDriver.Internal.Types+import UnliftIO.Async+import UnliftIO.Exception+import UnliftIO.MVar+++getOnDemand :: forall m a. (+  MonadUnliftIO m, MonadLogger m+  ) => MVar (OnDemand a) -> m (Either Text a) -> m a+getOnDemand onDemandVar doObtain = do+  result <- modifyMVar onDemandVar $ \case+    OnDemandErrored msg -> expectationFailure (T.unpack msg)+    OnDemandNotStarted -> do+      asy <- async $ do+        let handler :: SomeException -> m a+            handler e = do+              modifyMVar_ onDemandVar (const $ return $ OnDemandErrored [i|Got exception: #{e}|])+              throwIO e++        handle handler $ do+          doObtain >>= \case+            Left err -> do+              modifyMVar_ onDemandVar (const $ return $ OnDemandErrored err)+              expectationFailure [i|Failed to obtain: #{err}|]++            Right x -> do+              modifyMVar_ onDemandVar (const $ return $ OnDemandReady x)+              return x++      return (OnDemandInProgress asy, Left asy)++    od@(OnDemandInProgress asy) -> pure (od, Left asy)+    od@(OnDemandReady x) -> pure (od, Right x)++  case result of+    Right x -> pure x+    Left asy -> wait asy

@@ -1,78 +0,0 @@-{-# LANGUAGE RankNTypes, MultiWayIf, ScopedTypeVariables, LambdaCase #-}--module Test.Sandwich.WebDriver.Internal.Ports (-  findFreePortOrException-  ) where--import Control.Exception-import Control.Retry-import Data.Maybe-import Data.String.Interpolate-import qualified Data.Text as T-import Network.Socket-import System.Random (randomRIO)-import Test.Sandwich.WebDriver.Internal.Util--firstUserPort :: PortNumber-firstUserPort = 1024--highestPort :: PortNumber-highestPort = 65535---- |Find an unused port in a given range-findFreePortInRange' :: RetryPolicy -> IO PortNumber -> IO (Maybe PortNumber)-findFreePortInRange' policy getAcceptableCandidate = retrying policy (\_retryStatus result -> return $ isNothing result) (const findFreePortInRange'')-  where-    findFreePortInRange'' :: IO (Maybe PortNumber)-    findFreePortInRange'' = do-      candidate <- getAcceptableCandidate-      catch (tryOpenAndClosePort candidate >> return (Just candidate)) (\(_ :: SomeException) -> return Nothing)-      where-        tryOpenAndClosePort :: PortNumber -> IO PortNumber-        tryOpenAndClosePort port = do-          sock <- socket AF_INET Stream 0-          setSocketOption sock ReuseAddr 1-          let hostAddress = tupleToHostAddress (127, 0, 0, 1)-          bind sock (SockAddrInet port hostAddress)-          close sock-          return $ fromIntegral port--findFreePortInRange :: IO PortNumber -> IO (Maybe PortNumber)-findFreePortInRange = findFreePortInRange' (limitRetries 50)---- | Find an unused port in the ephemeral port range.--- See https://en.wikipedia.org/wiki/List_of_TCP_and_UDP_port_numbers--- This works without a timeout since there should always be a port in the somewhere;--- it might be advisable to wrap in a timeout anyway.-findFreePort :: IO (Maybe PortNumber)-findFreePort = findFreePortInRange getNonEphemeralCandidate--findFreePortOrException :: IO PortNumber-findFreePortOrException = findFreePort >>= \case-  Just port -> return port-  Nothing -> error "Couldn't find free port"---- * Util--getNonEphemeralCandidate :: IO PortNumber-getNonEphemeralCandidate = do-  (ephemeralStart, ephemeralEnd) <- getEphemeralPortRange >>= \case-    Left _ -> return (49152, 65535)-    Right range -> return range--  let numBelow = ephemeralStart - firstUserPort-  let numAbove = highestPort - ephemeralEnd--  u :: Double <- randomRIO (0, 1)--  let useLowerRange = u < ((fromIntegral numBelow) / (fromIntegral numBelow + fromIntegral numAbove))--  if | useLowerRange -> fromInteger <$> randomRIO (fromIntegral firstUserPort, fromIntegral ephemeralStart)-     | otherwise -> fromInteger <$> randomRIO (fromIntegral ephemeralEnd, fromIntegral highestPort)--getEphemeralPortRange :: IO (Either T.Text (PortNumber, PortNumber))-getEphemeralPortRange = leftOnException' $ do-  contents <- readFile "/proc/sys/net/ipv4/ip_local_port_range"-  case fmap read (words contents) of-    [p1, p2] -> return (p1, p2)-    _ -> error [i|Unexpected contents: '#{contents}'|]

@@ -1,10 +1,11 @@-{-# LANGUAGE RankNTypes, MultiWayIf, ScopedTypeVariables, CPP, QuasiQuotes, RecordWildCards #-}--- |+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Test.Sandwich.WebDriver.Internal.Screenshots where  import Control.Concurrent-import Control.Exception.Lifted import Control.Monad import Control.Monad.IO.Class import qualified Data.Map as M@@ -15,13 +16,14 @@ import System.FilePath import Test.Sandwich.WebDriver.Internal.Types import Test.WebDriver+import UnliftIO.Exception  saveScreenshots :: (HasCallStack) => T.Text -> WebDriver -> FilePath -> IO () saveScreenshots screenshotName (WebDriver {..}) resultsDir = do   -- For every session, and for every window, try to get a screenshot for the results dir   sessionMap <- readMVar wdSessionMap-  forM_ (M.toList sessionMap) $ \(browser, sess) -> runWD sess $+  forM_ (M.toList sessionMap) $ \(browser, sess) ->     handle (\(e :: HttpException) -> case e of                (HttpExceptionRequest _ content) -> liftIO $ putStrLn [i|HttpException when trying to take a screenshot: '#{content}'|]-               e -> liftIO $ putStrLn [i|HttpException when trying to take a screenshot: '#{e}'|])-           (saveScreenshot $ resultsDir </> [i|#{browser}_#{screenshotName}.png|])+               e' -> liftIO $ putStrLn [i|HttpException when trying to take a screenshot: '#{e'}'|])+           (runWD sess $ saveScreenshot $ resultsDir </> [i|#{browser}_#{screenshotName}.png|])

@@ -1,66 +1,58 @@-{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}  module Test.Sandwich.WebDriver.Internal.StartWebDriver where -import Control.Concurrent-import Control.Exception import Control.Monad import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class+import Control.Monad.IO.Unlift import Control.Monad.Logger-import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Reader import Control.Retry-import qualified Data.Aeson as A import Data.Default-import Data.Function-import qualified Data.List as L-import Data.Maybe+import Data.Function (fix) import Data.String.Interpolate import qualified Data.Text as T-import qualified Data.Text.IO as T-import qualified Data.Vector as V import GHC.Stack-import Lens.Micro-import Lens.Micro.Aeson import System.Directory import System.FilePath-import System.IO-import System.Process+import System.IO (hClose, hGetLine) import Test.Sandwich-import Test.Sandwich.WebDriver.Internal.Binaries-import Test.Sandwich.WebDriver.Internal.Binaries.DetectChrome (detectChromeVersion)-import Test.Sandwich.WebDriver.Internal.Ports+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Util.Ports (findFreePortOrException)+import Test.Sandwich.Util.Process+import Test.Sandwich.WebDriver.Internal.Capabilities.Extra+import Test.Sandwich.WebDriver.Internal.Dependencies import Test.Sandwich.WebDriver.Internal.Types import Test.Sandwich.WebDriver.Internal.Util import qualified Test.WebDriver as W-import qualified Test.WebDriver.Firefox.Profile as FF+import UnliftIO.Async+import UnliftIO.Concurrent+import UnliftIO.Exception+import UnliftIO.Process+import UnliftIO.Timeout  #ifndef mingw32_HOST_OS import Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb #endif -#if MIN_VERSION_aeson(2,0,0)-import qualified Data.Aeson.Key             as A-import qualified Data.Aeson.KeyMap          as HM-fromText :: T.Text -> A.Key-fromText = A.fromText-#else-import qualified Data.HashMap.Strict        as HM-fromText :: T.Text -> T.Text-fromText = id-#endif --type Constraints m = (HasCallStack, MonadLogger m, MonadIO m, MonadBaseControl IO m, MonadMask m)+type Constraints m = (+  HasCallStack, MonadLoggerIO m, MonadUnliftIO m, MonadMask m, MonadFail m+  )  -- | Spin up a Selenium WebDriver and create a WebDriver-startWebDriver :: Constraints m => WdOptions -> FilePath -> m WebDriver-startWebDriver wdOptions@(WdOptions {..}) runRoot = do+startWebDriver :: (+  Constraints m, MonadReader context m, HasBaseContext context+  , HasFile context "java", HasFile context "selenium.jar", HasBrowserDependencies context+  ) => WdOptions -> OnDemandOptions -> FilePath -> m WebDriver+startWebDriver wdOptions@(WdOptions {capabilities=capabilities'', ..}) (OnDemandOptions {..}) runRoot = do   -- Create a unique name for this webdriver so the folder for its log output doesn't conflict with any others   webdriverName <- ("webdriver_" <>) <$> liftIO makeUUID @@ -68,97 +60,92 @@   let webdriverRoot = runRoot </> (T.unpack webdriverName)   liftIO $ createDirectoryIfMissing True webdriverRoot +  -- Directory to hold any downloads   let downloadDir = webdriverRoot </> "Downloads"   liftIO $ createDirectoryIfMissing True downloadDir -  -- Get selenium and chromedriver-  debug [i|Preparing to create the Selenium process|]-  seleniumPath <- obtainSelenium toolsRoot seleniumToUse >>= \case-    Left err -> error [i|Failed to obtain selenium: '#{err}'|]-    Right p -> return p-  driverArgs <- case W.browser capabilities of-    W.Firefox {} -> do-      obtainGeckoDriver toolsRoot geckoDriverToUse >>= \case-        Left err -> error [i|Failed to obtain geckodriver: '#{err}'|]-        Right p -> return [[i|-Dwebdriver.gecko.driver=#{p}|]-                          -- , [i|-Dwebdriver.gecko.logfile=#{webdriverRoot </> "geckodriver.log"}|]-                          -- , [i|-Dwebdriver.gecko.verboseLogging=true|]-                          ]-    W.Chrome {} -> do-      obtainChromeDriver toolsRoot chromeDriverToUse >>= \case-        Left err -> error [i|Failed to obtain chromedriver: '#{err}'|]-        Right p -> return [[i|-Dwebdriver.chrome.driver=#{p}|]-                          , [i|-Dwebdriver.chrome.logfile=#{webdriverRoot </> "chromedriver.log"}|]-                          , [i|-Dwebdriver.chrome.verboseLogging=true|]]-    x -> error [i|Browser #{x} is not supported yet|]--  debug [i|driverArgs: #{driverArgs}|]+  -- Get selenium, driver args, and capabilities with browser paths applied+  java <- askFile @"java"+  seleniumPath <- askFile @"selenium.jar"+  (driverArgs, capabilities') <- fillInCapabilitiesAndGetDriverArgs webdriverRoot capabilities'' +  -- Set up xvfb if configured+  xvfbOnDemand <- newMVar OnDemandNotStarted   (maybeXvfbSession, javaEnv) <- case runMode of #ifndef mingw32_HOST_OS     RunInXvfb (XvfbConfig {..}) -> do-      (s, e) <- makeXvfbSession xvfbResolution xvfbStartFluxbox webdriverRoot+      (s, e) <- makeXvfbSession xvfbResolution xvfbStartFluxbox webdriverRoot xvfbToUse xvfbOnDemand       return (Just s, Just e) #endif     _ -> return (Nothing, Nothing) +  -- Create a distinct process name+  webdriverProcessName <- ("webdriver_process_" <>) <$> (liftIO makeUUID)+  let webdriverProcessRoot = webdriverRoot </> T.unpack webdriverProcessName+  liftIO $ createDirectoryIfMissing True webdriverProcessRoot+   -- Retry up to 10 times   -- This is necessary because sometimes we get a race for the port we get from findFreePortOrException.   -- There doesn't seem to be any way to make Selenium choose its own port.   let policy = constantDelay 0 <> limitRetries 10-  recoverAll policy $ \retryStatus -> do+  (port, hRead, p) <- recoverAll policy $ \retryStatus -> flip withException (\(e :: SomeException) -> warn [i|Exception in startWebDriver retry: #{e}|]) $ do     when (rsIterNumber retryStatus > 0) $-      warn [i|Trying again to start selenium server|]+      warn [i|Trying again to start selenium server (attempt #{rsIterNumber retryStatus})|] -    -- Create a distinct process name-    webdriverProcessName <- ("webdriver_process_" <>) <$> (liftIO makeUUID)-    let webdriverProcessRoot = webdriverRoot </> T.unpack webdriverProcessName-    liftIO $ createDirectoryIfMissing True webdriverProcessRoot-    startWebDriver' wdOptions webdriverName webdriverProcessRoot downloadDir seleniumPath driverArgs maybeXvfbSession javaEnv+    (hRead, hWrite) <- createPipe+    port <- findFreePortOrException -startWebDriver' wdOptions@(WdOptions {capabilities=capabilities', ..}) webdriverName webdriverRoot downloadDir seleniumPath driverArgs maybeXvfbSession javaEnv = do-  port <- liftIO findFreePortOrException-  let wdCreateProcess = (proc "java" (driverArgs <> ["-jar", seleniumPath-                                                    , "-port", show port])) { env = javaEnv }+    let allArgs = driverArgs <> ["-jar", seleniumPath+                                , "-port", show port]+    let cp = (proc java allArgs) {+               env = javaEnv+               , std_in = Inherit+               , std_out = UseHandle hWrite+               , std_err = UseHandle hWrite+               , create_group = True+             } -  -- Open output handles-  let seleniumOutPath = webdriverRoot </> seleniumOutFileName-  hout <- liftIO $ openFile seleniumOutPath AppendMode-  let seleniumErrPath = webdriverRoot </> seleniumErrFileName-  herr <- liftIO $ openFile seleniumErrPath AppendMode+    -- Start the process and wait for it to be ready+    debug [i|#{java} #{T.unwords $ fmap T.pack allArgs}|] -  -- Start the process and wait for it to be ready-  debug [i|Starting the Selenium process|]-  (_, _, _, p) <- liftIO $ createProcess $ wdCreateProcess {-    std_in = Inherit-    , std_out = UseHandle hout-    , std_err = UseHandle herr-    , create_group = True-    }-  -- Normally Selenium prints the ready message to stderr. However, when we're running under-  -- XVFB the two streams get combined and sent to stdout; see-  -- https://bugs.launchpad.net/ubuntu/+source/xorg-server/+bug/1059947-  -- As a result, we poll both files-  let readyMessage = "Selenium Server is up and running"-  -- Retry every 60ms, for up to 60s before admitting defeat-  let policy = constantDelay 60000 <> limitRetries 1000-  success <- retrying policy (\_retryStatus result -> return (not result)) $ const $-    liftIO (T.readFile seleniumErrPath) >>= \case-      t | readyMessage `T.isInfixOf` t -> return True-      _ -> liftIO (T.readFile seleniumOutPath) >>= \case-        t | readyMessage `T.isInfixOf` t -> return True-        _ -> return False-  unless success $ liftIO $ do-    interruptProcessGroupOf p >> waitForProcess p-    error [i|Selenium server failed to start after 60 seconds|]+    (_, _, _, p) <- liftIO $ createProcess cp -  capabilities <- configureHeadlessCapabilities wdOptions runMode capabilities'-                  >>= configureDownloadCapabilities downloadDir+    let teardown = do+          gracefullyStopProcess p 30_000_000+          liftIO $ hClose hRead +    -- On exception, make sure the process is gone and the pipe handle is closed+    flip withException (\(_ :: SomeException) -> teardown) $ do+      -- Read from the (combined) output stream until we see the up and running message,+      -- or the process ends and we get an exception from hGetLine+      startupResult <- timeout 10_000_000 $ fix $ \loop -> do+        line <- fmap T.pack $ liftIO $ hGetLine hRead+        debug line++        if | "Selenium Server is up and running" `T.isInfixOf` line -> return ()+           | otherwise -> loop++      case startupResult of+        Nothing -> do+          let msg = [i|Didn't see "up and running" line in Selenium output after 10s.|]+          warn msg+          expectationFailure (T.unpack msg)+        Just () -> return (port, hRead, p)++  -- TODO: save this in the WebDriver to tear it down later?+  _logAsync <- async $ forever (liftIO (hGetLine hRead) >>= (debug . T.pack))++  -- Final extra capabilities configuration+  capabilities <-+    configureHeadlessCapabilities wdOptions runMode capabilities'+    >>= configureDownloadCapabilities downloadDir+   -- Make the WebDriver   WebDriver <$> pure (T.unpack webdriverName)-            <*> pure (hout, herr, p, seleniumOutPath, seleniumErrPath, maybeXvfbSession)-            <*> pure wdOptions+            <*> pure (p, maybeXvfbSession)+            <*> pure (wdOptions {+                       capabilities = capabilities+                     })             <*> liftIO (newMVar mempty)             <*> pure (def { W.wdPort = fromIntegral port                           , W.wdCapabilities = capabilities@@ -167,103 +154,23 @@                           })             <*> pure downloadDir --- | TODO: expose this as an option-gracePeriod :: Int-gracePeriod = 30000000+            <*> pure ffmpegToUse+            <*> newMVar OnDemandNotStarted +            <*> pure xvfbToUse+            <*> pure xvfbOnDemand++ stopWebDriver :: Constraints m => WebDriver -> m ()-stopWebDriver (WebDriver {wdWebDriver=(hout, herr, h, _, _, maybeXvfbSession)}) = do+stopWebDriver (WebDriver {wdWebDriver=(h, maybeXvfbSession)}) = do+  -- | TODO: expose this as an option+  let gracePeriod :: Int+      gracePeriod = 30000000+   gracefullyStopProcess h gracePeriod-  liftIO $ hClose hout-  liftIO $ hClose herr    whenJust maybeXvfbSession $ \(XvfbSession {..}) -> do     whenJust xvfbFluxboxProcess $ \p -> do       gracefullyStopProcess p gracePeriod      gracefullyStopProcess xvfbProcess gracePeriod---- * Util--seleniumOutFileName, seleniumErrFileName :: FilePath-seleniumOutFileName = "stdout.txt"-seleniumErrFileName = "stderr.txt"---- | Add headless configuration to the Chrome browser-configureHeadlessCapabilities :: Constraints m => WdOptions -> RunMode -> W.Capabilities -> m W.Capabilities-configureHeadlessCapabilities wdOptions (RunHeadless (HeadlessConfig {..})) caps@(W.Capabilities {W.browser=browser@(W.Chrome {..})}) = do-  headlessArg <- liftIO (detectChromeVersion (chromeBinaryPath wdOptions)) >>= \case-    Left err -> do-      warn [i|Couldn't determine chrome version when configuring headless capabilities (err: #{err}); passing --headless|]-      return "--headless"-    Right (ChromeVersion (major, _, _, _))-      -- See https://www.selenium.dev/blog/2023/headless-is-going-away/-      | major >= 110 -> return "--headless=new"-      | otherwise -> return "--headless"--  let browser' = browser { W.chromeOptions = headlessArg:resolution:chromeOptions }--  return (caps { W.browser = browser' })--  where-    resolution = [i|--window-size=#{w},#{h}|]-    (w, h) = fromMaybe (1920, 1080) headlessResolution---- | Add headless configuration to the Firefox capabilities-configureHeadlessCapabilities _ (RunHeadless (HeadlessConfig {..})) caps@(W.Capabilities {W.browser=(W.Firefox {..}), W.additionalCaps=ac}) = return (caps { W.additionalCaps = additionalCaps })-  where-    additionalCaps = case L.findIndex (\x -> fst x == "moz:firefoxOptions") ac of-      Nothing -> ("moz:firefoxOptions", A.object [("args", A.Array ["-headless"])]) : ac-      Just i -> let ffOptions' = snd (ac !! i)-                               & ensureKeyExists "args" (A.Array [])-                               & ((key "args" . _Array) %~ addHeadlessArg) in-        L.nubBy (\x y -> fst x == fst y) (("moz:firefoxOptions", ffOptions') : ac)--    ensureKeyExists :: T.Text -> A.Value -> A.Value -> A.Value-    ensureKeyExists key _ val@(A.Object (HM.lookup (fromText key) -> Just _)) = val-    ensureKeyExists key defaultVal (A.Object m@(HM.lookup (fromText key) -> Nothing)) = A.Object (HM.insert (fromText key) defaultVal m)-    ensureKeyExists _ _ _ = error "Expected Object in ensureKeyExists"--    addHeadlessArg :: V.Vector A.Value -> V.Vector A.Value-    addHeadlessArg xs | (A.String "-headless") `V.elem` xs = xs-    addHeadlessArg xs = (A.String "-headless") `V.cons` xs--configureHeadlessCapabilities _ (RunHeadless {}) browser = error [i|Headless mode not yet supported for browser '#{browser}'|]-configureHeadlessCapabilities _ _ browser = return browser---configureDownloadCapabilities downloadDir caps@(W.Capabilities {W.browser=browser@(W.Firefox {..})}) = do-  case ffProfile of-    Nothing -> return ()-    Just _ -> liftIO $ throwIO $ userError [i|Can't support Firefox profile yet.|]--  profile <- FF.defaultProfile-    & FF.addPref "browser.download.folderList" (2 :: Int)-    & FF.addPref "browser.download.manager.showWhenStarting" False-    & FF.addPref "browser.download.dir" downloadDir-    & FF.addPref "browser.helperApps.neverAsk.saveToDisk" ("*" :: String)-    & FF.prepareProfile--  return (caps { W.browser = browser { W.ffProfile = Just profile } })-configureDownloadCapabilities downloadDir caps@(W.Capabilities {W.browser=browser@(W.Chrome {..})}) = return $ caps { W.browser=browser' }-  where-    browser' = browser { W.chromeExperimentalOptions = options }--    basePrefs :: A.Object-    basePrefs = case HM.lookup "prefs" chromeExperimentalOptions of-      Just (A.Object hm) -> hm-      Just x -> error [i|Expected chrome prefs to be object, got '#{x}'.|]-      Nothing -> mempty--    prefs :: A.Object-    prefs = basePrefs-          & foldl (.) id [HM.insert k v | (k, v) <- downloadPrefs]--    options = HM.insert "prefs" (A.Object prefs) chromeExperimentalOptions--    downloadPrefs = [("profile.default_content_setting_values.automatic_downloads", A.Number 1)-                    , ("profile.content_settings.exceptions.automatic_downloads.*.setting", A.Number 1)-                    , ("download.prompt_for_download", A.Bool False)-                    , ("download.directory_upgrade", A.Bool True)-                    , ("download.default_directory", A.String (T.pack downloadDir))]-configureDownloadCapabilities _ browser = return browser

@@ -12,30 +12,26 @@ import Data.IORef import qualified Data.Map as M import Data.String.Interpolate-import Data.Text as T+import Data.Text (Text) import Network.HTTP.Client (Manager)-import System.IO import System.Process import Test.Sandwich+import Test.Sandwich.WebDriver.Internal.Binaries.Ffmpeg+import Test.Sandwich.WebDriver.Internal.Binaries.Xvfb import qualified Test.WebDriver as W-import qualified Test.WebDriver.Class as W import qualified Test.WebDriver.Session as W+import UnliftIO.Async + -- | 'Session' is just a 'String' name. type Session = String  -- * Labels-webdriver = Label :: Label "webdriver" WebDriver-webdriverSession = Label :: Label "webdriverSession" WebDriverSession--type WebDriverContext context wd = (HasLabel context "webdriver" WebDriver, W.WebDriver (ExampleT context wd))---- TODO: remove-class HasWebDriver a where-  getWebDriver :: a -> WebDriver+webdriver :: Label "webdriver" WebDriver+webdriver = Label -instance HasWebDriver WebDriver where-  getWebDriver = id+webdriverSession :: Label "webdriverSession" WebDriverSession+webdriverSession = Label  type ToolsRoot = FilePath @@ -44,37 +40,22 @@ -- | Headless and Xvfb modes are useful because they allow you to run tests in the background, without popping up browser windows. -- This is useful for development or for running on a CI server, and is also more reproducible since the screen resolution can be fixed. -- In addition, Xvfb mode allows videos to be recorded of tests.-data RunMode = Normal-             -- ^ Normal Selenium behavior; will pop up a web browser.-             | RunHeadless HeadlessConfig-             -- ^ Run with a headless browser. Supports screenshots but videos will be black.-             | RunInXvfb XvfbConfig-             -- ^ Run inside <https://en.wikipedia.org/wiki/Xvfb Xvfb> so that tests run in their own X11 display.-             -- xvfb-run script must be installed and on the PATH.+data RunMode =+  Normal+  -- ^ Normal Selenium behavior; will pop up a web browser.+  | RunHeadless HeadlessConfig+  -- ^ Run with a headless browser. Supports screenshots but videos will be black.+  | RunInXvfb XvfbConfig+  -- ^ Run inside <https://en.wikipedia.org/wiki/Xvfb Xvfb> so that tests run in their own X11 display.+  -- The @Xvfb@ binary must be installed and on the PATH.  data WdOptions = WdOptions {-  toolsRoot :: ToolsRoot-  -- ^ Folder where any necessary binaries (chromedriver, Selenium, etc.) will be downloaded if needed. Required.--  , capabilities :: W.Capabilities+  capabilities :: W.Capabilities   -- ^ The WebDriver capabilities to use.    , saveSeleniumMessageHistory :: WhenToSave   -- ^ When to save a record of Selenium requests and responses. -  , seleniumToUse :: SeleniumToUse-  -- ^ Which Selenium server JAR file to use.--  , chromeBinaryPath :: Maybe FilePath-  -- ^ Which chrome binary to use.-  , chromeDriverToUse :: ChromeDriverToUse-  -- ^ Which chromedriver executable to use.--  , firefoxBinaryPath :: Maybe FilePath-  -- ^ Which firefox binary to use.-  , geckoDriverToUse :: GeckoDriverToUse-  -- ^ Which geckodriver executable to use.-   , runMode :: RunMode   -- ^ How to handle opening the browser (in a popup window, headless, etc.). @@ -85,57 +66,28 @@   -- ^ Number of times to retry an HTTP request if it times out.   } --- | How to obtain the Selenium server JAR file.-data SeleniumToUse =-  DownloadSeleniumFrom String-  -- ^ Download selenium from the given URL to the 'toolsRoot'-  | DownloadSeleniumDefault-  -- ^ Download selenium from a default location to the 'toolsRoot'-  | UseSeleniumAt FilePath-  -- ^ Use the JAR file at the given path-  deriving Show---- | How to obtain the chromedriver binary.-data ChromeDriverToUse =-  DownloadChromeDriverFrom String-  -- ^ Download chromedriver from the given URL to the 'toolsRoot'-  | DownloadChromeDriverVersion ChromeDriverVersion-  -- ^ Download the given chromedriver version to the 'toolsRoot'-  | DownloadChromeDriverAutodetect (Maybe FilePath)-  -- ^ Autodetect chromedriver to use based on the Chrome version and download it to the 'toolsRoot'-  -- Pass the path to the Chrome binary, or else it will be found by looking for google-chrome on the PATH.-  | UseChromeDriverAt FilePath-  -- ^ Use the chromedriver at the given path-  deriving Show---- | How to obtain the geckodriver binary.-data GeckoDriverToUse =-  DownloadGeckoDriverFrom String-  -- ^ Download geckodriver from the given URL to the 'toolsRoot'-  | DownloadGeckoDriverVersion GeckoDriverVersion-  -- ^ Download the given geckodriver version to the 'toolsRoot'-  | DownloadGeckoDriverAutodetect (Maybe FilePath)-  -- ^ Autodetect geckodriver to use based on the Gecko version and download it to the 'toolsRoot'-  -- Pass the path to the Firefox binary, or else it will be found by looking for firefox on the PATH.-  | UseGeckoDriverAt FilePath-  -- ^ Use the geckodriver at the given path-  deriving Show--newtype ChromeVersion = ChromeVersion (Int, Int, Int, Int) deriving Show-data ChromeDriverVersion =-  ChromeDriverVersionTuple (Int, Int, Int, Int)-  | ChromeDriverVersionExactUrl (Int, Int, Int, Int) Text-  deriving Show+-- | How to obtain certain binaries "on demand". These may or not be needed based on 'WdOptions', so+-- they will be obtained as needed.+data OnDemandOptions = OnDemandOptions {+  -- | How to obtain ffmpeg binary.+  ffmpegToUse :: FfmpegToUse -newtype FirefoxVersion = FirefoxVersion (Int, Int, Int) deriving Show-newtype GeckoDriverVersion = GeckoDriverVersion (Int, Int, Int) deriving Show+  -- | How to obtain Xvfb binary.+  , xvfbToUse :: XvfbToUse+  }+defaultOnDemandOptions = OnDemandOptions {+  ffmpegToUse = UseFfmpegFromPath+  , xvfbToUse = UseXvfbFromPath+  } +-- | Configuration for a headless browser. data HeadlessConfig = HeadlessConfig {   headlessResolution :: Maybe (Int, Int)-  -- ^ Resolution for the headless browser. Defaults to (1920, 1080)+  -- ^ Resolution for the headless browser, specified as @(width, height)@. Defaults to @(1920, 1080)@.   }  -- | Default headless config.+defaultHeadlessConfig :: HeadlessConfig defaultHeadlessConfig = HeadlessConfig Nothing  data XvfbConfig = XvfbConfig {@@ -143,36 +95,43 @@   -- ^ Resolution for the virtual screen. Defaults to (1920, 1080)    , xvfbStartFluxbox :: Bool-  -- ^ Whether to start fluxbox window manager to go with the Xvfb session. fluxbox must be on the path+  -- ^ Whether to start fluxbox window manager to go with the Xvfb session. @fluxbox@ must be on the path.   }  -- | Default Xvfb settings.+defaultXvfbConfig :: XvfbConfig defaultXvfbConfig = XvfbConfig Nothing False  -- | The default 'WdOptions' object. -- You should start with this and modify it using the accessors.-defaultWdOptions :: FilePath -> WdOptions-defaultWdOptions toolsRoot = WdOptions {-  toolsRoot = toolsRoot-  , capabilities = def+defaultWdOptions :: WdOptions+defaultWdOptions = WdOptions {+  capabilities = def   , saveSeleniumMessageHistory = OnException-  , seleniumToUse = DownloadSeleniumDefault-  , chromeBinaryPath = Nothing-  , chromeDriverToUse = DownloadChromeDriverAutodetect Nothing-  , firefoxBinaryPath = Nothing-  , geckoDriverToUse = DownloadGeckoDriverAutodetect Nothing   , runMode = Normal   , httpManager = Nothing   , httpRetryCount = 0   } +data OnDemand a =+  OnDemandNotStarted+  | OnDemandInProgress (Async a)+  | OnDemandReady a+  | OnDemandErrored Text+ data WebDriver = WebDriver {   wdName :: String-  , wdWebDriver :: (Handle, Handle, ProcessHandle, FilePath, FilePath, Maybe XvfbSession)+  , wdWebDriver :: (ProcessHandle, Maybe XvfbSession)   , wdOptions :: WdOptions   , wdSessionMap :: MVar (M.Map Session W.WDSession)   , wdConfig :: W.WDConfig   , wdDownloadDir :: FilePath++  , wdFfmpegToUse :: FfmpegToUse+  , wdFfmpeg :: MVar (OnDemand FilePath)++  , wdXvfbToUse :: XvfbToUse+  , wdXvfb :: MVar (OnDemand FilePath)   }  data InvalidLogsException = InvalidLogsException [W.LogEntry]@@ -180,11 +139,13 @@  instance Exception InvalidLogsException -data XvfbSession = XvfbSession { xvfbDisplayNum :: Int-                               , xvfbXauthority :: FilePath-                               , xvfbDimensions :: (Int, Int)-                               , xvfbProcess :: ProcessHandle-                               , xvfbFluxboxProcess :: Maybe ProcessHandle }+data XvfbSession = XvfbSession {+  xvfbDisplayNum :: Int+  , xvfbXauthority :: FilePath+  , xvfbDimensions :: (Int, Int)+  , xvfbProcess :: ProcessHandle+  , xvfbFluxboxProcess :: Maybe ProcessHandle+  }  type WebDriverSession = (Session, IORef W.WDSession) @@ -195,67 +156,22 @@ -- | Get the X11 display number associated with the 'WebDriver'. -- Only present if running in 'RunInXvfb' mode. getDisplayNumber :: WebDriver -> Maybe Int-getDisplayNumber (WebDriver {wdWebDriver=(_, _, _, _, _, Just (XvfbSession {xvfbDisplayNum}))}) = Just xvfbDisplayNum+getDisplayNumber (WebDriver {wdWebDriver=(_, Just (XvfbSession {xvfbDisplayNum}))}) = Just xvfbDisplayNum getDisplayNumber _ = Nothing  -- | Get the Xvfb session associated with the 'WebDriver', if present. getXvfbSession :: WebDriver -> Maybe XvfbSession-getXvfbSession (WebDriver {wdWebDriver=(_, _, _, _, _, Just sess)}) = Just sess+getXvfbSession (WebDriver {wdWebDriver=(_, Just sess)}) = Just sess getXvfbSession _ = Nothing +-- | Get the configured download directory for the 'WebDriver'.+getDownloadDirectory :: WebDriver -> FilePath+getDownloadDirectory = wdDownloadDir+ -- | Get the name of the 'WebDriver'.+-- This corresponds to the folder that will be created to hold the log files for the 'WebDriver'. getWebDriverName :: WebDriver -> String getWebDriverName (WebDriver {wdName}) = wdName  instance Show XvfbSession where   show (XvfbSession {xvfbDisplayNum}) = [i|<XVFB session with server num #{xvfbDisplayNum}>|]---- * Video stuff---- | Default options for fast X11 video recording.-fastX11VideoOptions = ["-an"-                      , "-r", "30"-                      , "-vcodec"-                      , "libxvid"-                      , "-qscale:v", "1"-                      , "-threads", "0"]---- | Default options for quality X11 video recording.-qualityX11VideoOptions = ["-an"-                         , "-r", "30"-                         , "-vcodec", "libx264"-                         , "-preset", "veryslow"-                         , "-crf", "0"-                         , "-threads", "0"]---- | Default options for AVFoundation recording (for Darwin).-defaultAvfoundationOptions = ["-r", "30"-                             , "-an"-                             , "-vcodec", "libxvid"-                             , "-qscale:v", "1"-                             , "-threads", "0"]---- | Default options for gdigrab recording (for Windows).-defaultGdigrabOptions = ["-framerate", "30"]--data VideoSettings = VideoSettings {-  x11grabOptions :: [String]-  -- ^ Arguments to x11grab, used with Linux.-  , avfoundationOptions :: [String]-  -- ^ Arguments to avfoundation, used with OS X.-  , gdigrabOptions :: [String]-  -- ^ Arguments to gdigrab, used with Windows.-  , hideMouseWhenRecording :: Bool-  -- ^ Hide the mouse while recording video. Linux and Windows only.-  , logToDisk :: Bool-  -- ^ Log ffmpeg stdout and stderr to disk.-  }---- | Default video settings.-defaultVideoSettings = VideoSettings {-  x11grabOptions = fastX11VideoOptions-  , avfoundationOptions = defaultAvfoundationOptions-  , gdigrabOptions = defaultGdigrabOptions-  , hideMouseWhenRecording = False-  , logToDisk = True-  }

@@ -2,55 +2,27 @@  module Test.Sandwich.WebDriver.Internal.Util where -import Control.Exception-import qualified Control.Exception.Lifted as E import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Logger-import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Retry-import Data.Maybe-import Data.String.Interpolate+import Control.Monad.IO.Unlift import qualified Data.Text as T-import System.Directory-import System.Process import qualified System.Random as R-import Test.Sandwich.Logging--#ifdef mingw32_HOST_OS-import System.IO-#endif+import Test.Sandwich (expectationFailure)+import UnliftIO.Exception  --- * Truncating log files--moveAndTruncate :: FilePath -> String -> IO ()-moveAndTruncate from to = do-  exists <- doesFileExist from-  when exists $ do-    copyFile from to-    tryTruncateFile from--  where-    tryTruncateFile :: FilePath -> IO ()-    tryTruncateFile path = E.catch (truncateFile path)-                                   (\(e :: E.SomeException) -> putStrLn [i|Failed to truncate file #{path}: #{e}|])--    truncateFile :: FilePath -> IO ()-#ifdef mingw32_HOST_OS-    truncateFile path = withFile path WriteMode $ flip hPutStr "\n" -- Not exactly truncation, but close enough?-#else-    truncateFile path = void $ readCreateProcess (shell [i|> #{path}|]) ""-#endif- -- * Exceptions -leftOnException :: (MonadIO m, MonadBaseControl IO m) => m (Either T.Text a) -> m (Either T.Text a)-leftOnException = E.handle (\(e :: SomeException) -> return $ Left $ T.pack $ show e)+leftOnException :: (MonadUnliftIO m) => m (Either T.Text a) -> m (Either T.Text a)+leftOnException = 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 $ T.pack $ show e)+exceptionOnLeft :: (MonadUnliftIO m) => m (Either T.Text a) -> m a+exceptionOnLeft action = action >>= \case+  Left err -> expectationFailure (T.unpack err)+  Right x -> pure x +leftOnException' :: (MonadUnliftIO m) => m a -> m (Either T.Text a)+leftOnException' action = catch (Right <$> action) (\(e :: SomeException) -> return $ Left $ T.pack $ show e)+ -- * Util  whenJust :: (Monad m) => Maybe a -> (a -> m b) -> m ()@@ -67,31 +39,3 @@  makeUUID :: IO T.Text makeUUID = (T.pack . take 10 . R.randomRs ('a','z')) <$> R.newStdGen---- * Stopping processes--gracefullyStopProcess :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m ()-gracefullyStopProcess p gracePeriodUs = do-  liftIO $ interruptProcessGroupOf p-  gracefullyWaitForProcess p gracePeriodUs--gracefullyWaitForProcess :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m ()-gracefullyWaitForProcess p gracePeriodUs = do-  let waitForExit = do-        let policy = limitRetriesByCumulativeDelay gracePeriodUs $ capDelay 200_000 $ exponentialBackoff 1_000-        retrying policy (\_ x -> return $ isNothing x) $ \_ -> do-          liftIO $ getProcessExitCode p--  waitForExit >>= \case-    Just _ -> return ()-    Nothing -> do-      pid <- liftIO $ getPid p-      warn [i|(#{pid}) Process didn't stop after #{gracePeriodUs}us; trying to interrupt|]--      liftIO $ interruptProcessGroupOf p-      waitForExit >>= \case-        Just _ -> return ()-        Nothing -> void $ do-          warn [i|(#{pid}) Process didn't stop after a further #{gracePeriodUs}us; going to kill|]-          liftIO $ terminateProcess p-          liftIO $ waitForProcess p

@@ -1,65 +0,0 @@-{-# LANGUAGE CPP #-}--module Test.Sandwich.WebDriver.Internal.Video where--import Control.Monad.IO.Class-import Data.Maybe-import Data.String.Interpolate-import System.Environment-import System.Process-import Test.Sandwich.WebDriver.Internal.Types--#ifdef darwin_HOST_OS-import Safe--getMacScreenNumber :: IO (Maybe Int)-getMacScreenNumber = undefined-#endif---getVideoArgs path (width, height, x, y) (VideoSettings {..}) maybeXvfbSession = do-#ifdef linux_HOST_OS-  displayNum <- case maybeXvfbSession of-    Nothing -> fromMaybe "" <$> (liftIO $ lookupEnv "DISPLAY")-    Just (XvfbSession {xvfbDisplayNum}) -> return $ ":" <> show xvfbDisplayNum--  let videoPath = [i|#{path}.avi|]-  let env' = [("DISPLAY", displayNum)]-  let env = case maybeXvfbSession of-       Nothing -> Just env'-       Just (XvfbSession {xvfbXauthority}) -> Just (("XAUTHORITY", xvfbXauthority) : env')-  let cmd = ["-draw_mouse", (if hideMouseWhenRecording then "0" else "1")-            , "-y"-            , "-nostdin"-            , "-f", "x11grab"-            , "-s", [i|#{width}x#{height}|]-            , "-i", [i|#{displayNum}.0+#{x},#{y}|]]-            ++ x11grabOptions-            ++ [videoPath]-  return ((proc "ffmpeg" cmd) { env = env })-#endif--#ifdef darwin_HOST_OS-  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" cmd) { env = Nothing })-#endif--#ifdef mingw32_HOST_OS-  let videoPath = [i|#{path}.mkv|]-  let cmd = ["-f", "gdigrab"-            , "-nostdin"-            , "-draw_mouse", (if hideMouseWhenRecording then "0" else "1")-            , "-i", "desktop"]-            ++ gdigrabOptions-            ++ [videoPath]-  return ((proc "ffmpeg.exe" cmd) { env = Nothing })-#endif

@@ -3,43 +3,44 @@ {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Test.Sandwich.WebDriver.Types (-  ExampleWithWebDriver+  -- * Type aliases to make signatures shorter+  BaseMonad+  , ContextWithWebdriverDeps+  , ContextWithBaseDeps+  , WebDriverMonad+  , WebDriverSessionMonad++  -- * Context aliases+  , HasBrowserDependencies   , HasWebDriverContext   , HasWebDriverSessionContext-  , ContextWithSession -  , hoistExample--  , webdriver--  , wdDownloadDir--  -- * Constraint synonyms-  , BaseMonad-  , BaseMonadContext-  , WebDriverMonad-  , WebDriverSessionMonad+  -- * The Xvfb session+  , XvfbSession(..)+  , getXvfbSession   ) where -import Control.Exception.Safe as ES+import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class+import Control.Monad.IO.Unlift import Control.Monad.Reader import Control.Monad.Trans.Control (MonadBaseControl) import Data.IORef import GHC.Stack import Test.Sandwich-import Test.Sandwich.Internal+import Test.Sandwich.Contexts.Files+import Test.Sandwich.WebDriver.Internal.Dependencies import Test.Sandwich.WebDriver.Internal.Types import qualified Test.WebDriver.Class as W import qualified Test.WebDriver.Internal as WI import qualified Test.WebDriver.Session as W+import UnliftIO.Exception as ES  -type ContextWithSession context = LabelValue "webdriverSession" WebDriverSession :> context--instance (MonadIO m, HasLabel context "webdriverSession" WebDriverSession) => W.WDSessionState (ExampleT context m) where+instance (MonadIO m, HasWebDriverSessionContext context) => W.WDSessionState (ExampleT context m) where   getSession = do     (_, sessVar) <- getContext webdriverSession     liftIO $ readIORef sessVar@@ -48,7 +49,7 @@     liftIO $ writeIORef sessVar sess  -- Implementation copied from that of the WD monad implementation-instance (MonadIO m, MonadThrow m, HasLabel context "webdriverSession" WebDriverSession, MonadBaseControl IO m) => W.WebDriver (ExampleT context m) where+instance (MonadIO m, MonadBaseControl IO m, HasWebDriverSessionContext context) => W.WebDriver (ExampleT context m) where   doCommand method path args = WI.mkRequest method path args     >>= WI.sendHTTPRequest     >>= either throwIO return@@ -57,13 +58,21 @@  type HasWebDriverContext context = HasLabel context "webdriver" WebDriver type HasWebDriverSessionContext context = HasLabel context "webdriverSession" WebDriverSession-type ExampleWithWebDriver context wd = (W.WDSessionState (ExampleT context wd), W.WebDriver wd) -hoistExample :: ExampleT context IO a -> ExampleT (ContextWithSession context) IO a-hoistExample (ExampleT r) = ExampleT $ transformContext r-  where transformContext = withReaderT (\(_ :> ctx) -> ctx)+type ContextWithWebdriverDeps context =+  LabelValue "webdriver" WebDriver+  :> ContextWithBaseDeps context -type WebDriverMonad m context = (HasCallStack, HasLabel context "webdriver" WebDriver, MonadIO m, MonadBaseControl IO m)-type WebDriverSessionMonad m context = (WebDriverMonad m context, MonadReader context m, HasLabel context "webdriverSession" WebDriverSession)-type BaseMonad m = (HasCallStack, MonadIO m, MonadCatch m, MonadBaseControl IO m, MonadMask m)-type BaseMonadContext m context = (BaseMonad m, HasBaseContext context)+type ContextWithBaseDeps context =+  -- | Browser dependencies+  LabelValue "browserDependencies" BrowserDependencies+  -- | Java+  :> FileValue "java"+  -- | Selenium+  :> FileValue "selenium.jar"+  -- | Base context+  :> context++type BaseMonad m context = (HasCallStack, MonadUnliftIO m, MonadMask m, HasBaseContext context)+type WebDriverMonad m context = (HasCallStack, MonadUnliftIO m, HasWebDriverContext context)+type WebDriverSessionMonad m context = (WebDriverMonad m context, MonadReader context m, HasWebDriverSessionContext context)

@@ -1,13 +1,19 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TupleSections #-} +-- | Functions for recording videos of browser windows.+ module Test.Sandwich.WebDriver.Video (-  startVideoRecording+  startBrowserVideoRecording+  , startFullScreenVideoRecording++  -- * Lower-level+  , startVideoRecording   , endVideoRecording -  -- * Helpers-  , startFullScreenVideoRecording-  , startBrowserVideoRecording+  -- * Wrap a test to conditionally record video+  , recordVideoIfConfigured    -- * Configuration   , VideoSettings(..)@@ -16,33 +22,59 @@   , qualityX11VideoOptions   , defaultAvfoundationOptions   , defaultGdigrabOptions++  -- * Types+  , VideoProcess+  , videoProcessProcess+  , BaseVideoConstraints   ) where -import Control.Exception.Safe+import Control.Monad+import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class+import Control.Monad.IO.Unlift import Control.Monad.Logger hiding (logError) import Control.Monad.Reader-import Control.Monad.Trans.Control (MonadBaseControl)+import Data.Function import Data.String.Interpolate import System.Exit import System.FilePath import System.IO import System.Process import Test.Sandwich-import Test.Sandwich.WebDriver import Test.Sandwich.WebDriver.Internal.Types-import Test.Sandwich.WebDriver.Internal.Video+import Test.Sandwich.WebDriver.Types+import Test.Sandwich.WebDriver.Video.Internal+import Test.Sandwich.WebDriver.Video.Types import Test.Sandwich.WebDriver.Windows import Test.WebDriver.Class as W import Test.WebDriver.Commands+import UnliftIO.Directory+import UnliftIO.Exception  -type BaseVideoConstraints context m = (MonadLoggerIO m, MonadReader context m, HasWebDriverContext context, MonadBaseControl IO m)+type BaseVideoConstraints context m = (+  MonadLoggerIO m, MonadUnliftIO m, MonadMask m+  , MonadReader context m, HasBaseContext context, HasWebDriverContext context+  ) +-- | A type representing a live video recording process+data VideoProcess = VideoProcess {+  -- | The process handle+  videoProcessProcess :: ProcessHandle+  , videoProcessCreatedFiles :: [FilePath]+  }+-- defaultVideoProcess :: ProcessHandle -> VideoProcess+-- defaultVideoProcess p = VideoProcess p mempty+ -- | Wrapper around 'startVideoRecording' which uses the full screen dimensions. startFullScreenVideoRecording :: (-  BaseVideoConstraints context m, MonadMask m-  ) => FilePath -> VideoSettings -> m ProcessHandle+  BaseVideoConstraints context m+  )+  -- | Output path+  => FilePath+  -> VideoSettings+  -> m VideoProcess startFullScreenVideoRecording path videoSettings = do   sess <- getContext webdriver   let maybeXvfbSession = getXvfbSession sess@@ -55,22 +87,33 @@  -- | Wrapper around 'startVideoRecording' which uses WebDriver to find the rectangle corresponding to the browser. startBrowserVideoRecording :: (-  BaseVideoConstraints context m, MonadThrow m, HasWebDriverSessionContext context, W.WebDriver m-  ) => FilePath -> VideoSettings -> m ProcessHandle+  BaseVideoConstraints context m, W.WebDriver m+  )+  -- | Output path+  => FilePath+  -> VideoSettings+  -> m VideoProcess startBrowserVideoRecording path videoSettings = do   (x, y) <- getWindowPos   (w, h) <- getWindowSize   startVideoRecording path (w, h, x, y) videoSettings --- | Record video to a given path, for a given rectangle specified as (width, height, x, y).+-- | Record video to a given path, for a given screen rectangle. startVideoRecording :: (   BaseVideoConstraints context m-  ) => FilePath -> (Word, Word, Int, Int) -> VideoSettings -> m ProcessHandle+  )+  -- | Output path+  => FilePath+  -- | Rectangle to record, specified as @(width, height, x, y)@+  -> (Word, Word, Int, Int)+  -> VideoSettings+  -- | Returns handle to video process and list of files created+  -> m VideoProcess startVideoRecording path (width, height, x, y) vs = do   sess <- getContext webdriver   let maybeXvfbSession = getXvfbSession sess -  cp' <- liftIO $ getVideoArgs path (width, height, x, y) vs maybeXvfbSession+  (cp', videoPath) <- getVideoArgs path (width, height, x, y) vs maybeXvfbSession   let cp = cp' { create_group = True }    case cmdspec cp of@@ -78,18 +121,22 @@     RawCommand p args -> debug [i|ffmpeg command: #{p} #{unwords args}|]    case logToDisk vs of-    False -> createProcessWithLogging cp+    False -> do+      p <- createProcessWithLogging cp+      return $ VideoProcess p [videoPath]     True -> do-      liftIO $ bracket (openFile (path <.> "stdout" <.> "log") AppendMode) hClose $ \hout ->-        bracket (openFile (path <.> "stderr" <.> "log") AppendMode) hClose $ \herr -> do+      let stdoutPath = path <.> "stdout" <.> "log"+      let stderrPath = path <.> "stderr" <.> "log"+      liftIO $ bracket (openFile stdoutPath AppendMode) hClose $ \hout ->+        bracket (openFile stderrPath AppendMode) hClose $ \herr -> do           (_, _, _, p) <- createProcess (cp { std_out = UseHandle hout, std_err = UseHandle herr })-          return p+          return $ VideoProcess p [videoPath, stdoutPath, stderrPath]  -- | Gracefully stop the 'ProcessHandle' returned by 'startVideoRecording'. endVideoRecording :: (-  MonadLoggerIO m, MonadCatch m-  ) => ProcessHandle -> m ()-endVideoRecording p = do+  MonadLoggerIO m, MonadUnliftIO m+  ) => VideoProcess -> m ()+endVideoRecording (VideoProcess { videoProcessProcess=p }) = do   catchAny (liftIO $ interruptProcessGroupOf p)            (\e -> logError [i|Exception in interruptProcessGroupOf in endVideoRecording: #{e}|]) @@ -101,3 +148,54 @@     ExitFailure 255 -> return ()      ExitFailure n -> debug [i|ffmpeg exited with unexpected exit code #{n}'|]++-- * Wrappers++-- | Record video around a given action, if configured to do so in the 'CommandLineWebdriverOptions'.+--+-- This can be used to record video around individual tests. It can also keep videos only in case of+-- exceptions, deleting them on successful runs.+recordVideoIfConfigured :: (+  BaseVideoConstraints context m, W.WebDriver m, HasSomeCommandLineOptions context+  )+  -- | Session name+  => String+  -> m a+  -> m a+recordVideoIfConfigured browser action = do+  getCurrentFolder >>= \case+    Nothing -> action+    Just folder -> do+      SomeCommandLineOptions (CommandLineOptions {optWebdriverOptions=(CommandLineWebdriverOptions {..})}) <- getSomeCommandLineOptions+      if | optIndividualVideos -> withVideo folder browser action+         | optErrorVideos -> withVideoIfException folder browser action+         | otherwise -> action++withVideo :: (+  BaseVideoConstraints context m, W.WebDriver m+  ) => FilePath -> String -> m a -> m a+withVideo folder browser action = do+  path <- getPathInFolder folder browser+  bracket (startBrowserVideoRecording path defaultVideoSettings) endVideoRecording (const action)++withVideoIfException :: (+  BaseVideoConstraints context m, W.WebDriver m+  ) => FilePath -> String -> m a -> m a+withVideoIfException folder browser action = do+  path <- getPathInFolder folder browser+  tryAny (bracket (startBrowserVideoRecording path defaultVideoSettings)+                  endVideoRecording+                  (\(VideoProcess {..}) -> (videoProcessCreatedFiles, ) <$> action))+    >>= \case+      Right (pathsToRemove, ret) -> do+        info [i|pathsToRemove: #{pathsToRemove}|]+        forM_ pathsToRemove removePathForcibly+        return ret+      Left e -> throwIO e++getPathInFolder :: (MonadUnliftIO m) => [Char] -> String -> m FilePath+getPathInFolder folder browser = flip fix (0 :: Integer) $ \loop n -> do+  let path = folder </> [i|#{browser}_video_#{n}|]+  liftIO (doesFileExist (path <> videoExtension)) >>= \case+    False -> return path+    True -> loop (n + 1)

@@ -0,0 +1,101 @@+{-# OPTIONS_GHC -fno-warn-unused-matches #-}+{-# LANGUAGE CPP #-}++module Test.Sandwich.WebDriver.Video.Internal (+  getVideoArgs+  , videoExtension+  ) where++import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Monad.Reader+import Data.String.Interpolate+import System.FilePath+import System.Process+import Test.Sandwich+import Test.Sandwich.WebDriver.Internal.Binaries.Ffmpeg+import Test.Sandwich.WebDriver.Internal.OnDemand+import Test.Sandwich.WebDriver.Internal.Types+import Test.Sandwich.WebDriver.Types+import Test.Sandwich.WebDriver.Video.Types++#ifdef darwin_HOST_OS+getMacScreenNumber :: IO (Maybe Int)+getMacScreenNumber = return $ Just 0 -- TODO+#endif++#ifdef linux_HOST_OS+import Data.Function ((&), on)+import qualified Data.List as L+import Data.Maybe+import UnliftIO.Environment+#endif+++videoExtension :: String+videoExtension = "avi"++getVideoArgs :: (+  MonadUnliftIO m, MonadLoggerIO m, MonadMask m+  , MonadReader context m, HasBaseContext context, HasWebDriverContext context+  ) => FilePath -> (Word, Word, Int, Int) -> VideoSettings -> Maybe XvfbSession -> m (CreateProcess, FilePath)+getVideoArgs path (width, height, x, y) (VideoSettings {..}) maybeXvfbSession = do+  WebDriver {wdFfmpeg, wdFfmpegToUse} <- getContext webdriver+  ffmpeg <- getOnDemand wdFfmpeg (obtainFfmpeg wdFfmpegToUse)++#ifdef linux_HOST_OS+  displayNum <- case maybeXvfbSession of+    Nothing -> fromMaybe "" <$> (liftIO $ lookupEnv "DISPLAY")+    Just (XvfbSession {xvfbDisplayNum}) -> return $ ":" <> show xvfbDisplayNum++  baseEnv <- getEnvironment++  let env = case maybeXvfbSession of+        Nothing -> baseEnv+        Just (XvfbSession {..}) -> baseEnv+          & (("DISPLAY", displayNum) :)+          & (("XAUTHORITY", xvfbXauthority) :)+          & L.nubBy ((==) `on` fst)++  let videoPath = path <.> videoExtension++  let cmd = ["-y"+            , "-nostdin"+            , "-f", "x11grab"+            , "-s", [i|#{width}x#{height}|]+            , "-i", [i|#{displayNum}.0+#{x},#{y}|]]+            ++ xcbgrabOptions+            ++ [videoPath]+  return ((proc ffmpeg cmd) { env = Just env }, videoPath)+#endif++#ifdef darwin_HOST_OS+  maybeScreenNumber <- liftIO getMacScreenNumber+  let videoPath = [i|#{path}.avi|]+  let cmd = case maybeScreenNumber of+        Just screenNumber -> ["-y"+                             , "-nostdin"+                             , "-f", "avfoundation"+                             , "-video-size", [i|#{width}x#{height}|]+                             , "-vf", [i|crop=#{width}:#{height}:#{x}:#{y}|]+                             , "-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 }, videoPath)+#endif++#ifdef mingw32_HOST_OS+  let videoPath = [i|#{path}.mkv|]+  let cmd = ["-f", "gdigrab"+            , "-nostdin"+            , "-i", "desktop"+            , "-offset_x", [i|#{x}|]+            , "-offset_y", [i|#{y}|]+            , "-video-size", [i|#{width}x#{height}|]+            ]+            ++ gdigrabOptions+            ++ [videoPath]+  return ((proc ffmpeg cmd) { env = Nothing }, videoPath)+#endif

@@ -0,0 +1,56 @@++module Test.Sandwich.WebDriver.Video.Types where+++-- | Default options for fast X11 video recording.+fastX11VideoOptions :: [String]+fastX11VideoOptions = ["-an"+                      , "-r", "30"+                      , "-vcodec"+                      , "libxvid"+                      , "-qscale:v", "1"+                      , "-threads", "0"]++-- | Default options for quality X11 video recording.+qualityX11VideoOptions :: [String]+qualityX11VideoOptions = ["-an"+                         , "-r", "30"+                         , "-vcodec", "libx264"+                         , "-preset", "veryslow"+                         , "-crf", "0"+                         , "-threads", "0"]++-- | Default options for AVFoundation recording (for Darwin).+defaultAvfoundationOptions :: [String]+defaultAvfoundationOptions = ["-r", "30"+                             , "-an"+                             , "-vcodec", "libxvid"+                             , "-qscale:v", "1"+                             , "-threads", "0"]++-- | Default options for gdigrab recording (for Windows).+defaultGdigrabOptions :: [String]+defaultGdigrabOptions = ["-framerate", "30"]++data VideoSettings = VideoSettings {+  xcbgrabOptions :: [String]+  -- ^ Arguments to x11grab, used with Linux.+  , avfoundationOptions :: [String]+  -- ^ Arguments to avfoundation, used with OS X.+  , gdigrabOptions :: [String]+  -- ^ Arguments to gdigrab, used with Windows.+  , hideMouseWhenRecording :: Bool+  -- ^ Hide the mouse while recording video. Linux and Windows only.+  , logToDisk :: Bool+  -- ^ Log ffmpeg stdout and stderr to disk.+  }++-- | Default video settings.+defaultVideoSettings :: VideoSettings+defaultVideoSettings = VideoSettings {+  xcbgrabOptions = fastX11VideoOptions+  , avfoundationOptions = defaultAvfoundationOptions+  , gdigrabOptions = defaultGdigrabOptions+  , hideMouseWhenRecording = False+  , logToDisk = True+  }

@@ -1,66 +1,86 @@ -- | Functions for manipulating browser windows. - module Test.Sandwich.WebDriver.Windows (   -- * Window positioning   setWindowLeftSide   , setWindowRightSide   , setWindowFullScreen -  -- * Querying screen info+  -- * Screen resolution   , getScreenResolution++  -- * Lower-level+  , getResolution+  , getResolutionForDisplay   ) 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 GHC.Stack import Test.Sandwich import Test.Sandwich.WebDriver.Internal.Types import Test.Sandwich.WebDriver.Resolution+import Test.Sandwich.WebDriver.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 :: (WebDriverMonad m context, MonadReader context m, W.WebDriver m) => m () setWindowLeftSide = do   sess <- getContext webdriver   (x, y, width, height) <- case runMode $ wdOptions sess of     RunHeadless (HeadlessConfig {..}) -> return (0, 0, w, h)       where (w, h) = fromMaybe (1920, 1080) headlessResolution     _ -> getScreenResolution sess++  (screenWidth, screenHeight) <- getScreenPixelDimensions width height+   setWindowPos (x, y)-  setWindowSize (fromIntegral $ B.shift width (-1), fromIntegral height)+  setWindowSize (round (screenWidth / 2.0), round screenHeight)  -- | 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 :: (WebDriverMonad m context, MonadReader context m, W.WebDriver m) => m () setWindowRightSide = do   sess <- getContext webdriver   (x, y, width, height) <- case runMode $ wdOptions sess of     RunHeadless (HeadlessConfig {..}) -> return (0, 0, w, h)       where (w, h) = fromMaybe (1920, 1080) headlessResolution     _ -> getScreenResolution sess-  let pos = (x + (fromIntegral $ B.shift width (-1)), y + 0)-  setWindowPos pos-  setWindowSize (fromIntegral $ B.shift width (-1), fromIntegral height) +  (screenWidth, screenHeight) <- getScreenPixelDimensions width height++  setWindowPos (x + round (screenWidth / 2.0), y + 0)+  setWindowSize (round (screenWidth / 2.0), round screenHeight)+ -- | Fullscreen the browser window.-setWindowFullScreen :: (HasCallStack, MonadIO wd, WebDriverContext context wd, MonadReader context wd, W.WebDriver wd, MonadLogger wd, MonadMask wd) => wd ()+setWindowFullScreen :: (WebDriverMonad m context, MonadReader context m, W.WebDriver m) => m () setWindowFullScreen = do   sess <- getContext webdriver   (x, y, width, height) <- case runMode $ wdOptions sess of     RunHeadless (HeadlessConfig {..}) -> return (0, 0, w, h)       where (w, h) = fromMaybe (1920, 1080) headlessResolution     _ -> getScreenResolution sess++  (screenWidth, screenHeight) <- getScreenPixelDimensions width height+   setWindowPos (x + 0, y + 0)-  setWindowSize (fromIntegral width, fromIntegral height)+  setWindowSize (round screenWidth, round screenHeight)  -- | 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 {wdWebDriver=(_, _, _, _, _, maybeXvfbSession)}) = case maybeXvfbSession of+-- This function works with both normal 'RunMode' and Xvfb mode.+getScreenResolution :: (MonadIO m) => WebDriver -> m (Int, Int, Int, Int)+getScreenResolution (WebDriver {wdWebDriver=(_, maybeXvfbSession)}) = case maybeXvfbSession of   Nothing -> liftIO getResolution   Just (XvfbSession {..}) -> liftIO $ getResolutionForDisplay xvfbDisplayNum++getScreenPixelDimensions :: (MonadIO m, W.WebDriver m) => Int -> Int -> m (Double, Double)+getScreenPixelDimensions width height = do+  devicePixelRatio <- executeJS [] "return window.devicePixelRatio" >>= \case+    Just (ratio :: Double) -> pure ratio+    Nothing -> pure 1.0++  let screenWidth = fromIntegral width / devicePixelRatio+  let screenHeight = fromIntegral height / devicePixelRatio++  return (screenWidth, screenHeight)

@@ -1,6 +1,7 @@  import Test.Sandwich import Test.Sandwich.WebDriver.Config+import Test.Sandwich.WebDriver.Binaries import Data.Text as T import UnliftIO.Temporary import Data.Time.Clock@@ -9,22 +10,25 @@  spec :: TopSpec spec = do-  it "successfully runs obtainChromeDriver" $ do-    withSystemTempDirectory "test-download" $ \dir -> do-      obtainChromeDriver dir (DownloadChromeDriverAutodetect Nothing) >>= \case-        Right x -> info [i|Got chromedriver: #{x}|]-        Left err -> expectationFailure (T.unpack err)+  it "works" $ do+    2 `shouldBe` 2 -  it "successfully runs obtainGeckoDriver" $ do-    withSystemTempDirectory "test-download" $ \dir -> do-      obtainGeckoDriver dir (DownloadGeckoDriverAutodetect Nothing) >>= \case-        Right x -> info [i|Got geckoDriver: #{x}|]-        Left err -> expectationFailure (T.unpack err)+  -- it "successfully runs obtainChromeDriver" $ do+  --   withSystemTempDirectory "test-download" $ \dir -> do+  --     obtainChromeDriver dir (DownloadChromeDriverAutodetect Nothing) >>= \case+  --       Right x -> info [i|Got chromedriver: #{x}|]+  --       Left err -> expectationFailure (T.unpack err) +  -- it "successfully runs obtainGeckoDriver" $ do+  --   withSystemTempDirectory "test-download" $ \dir -> do+  --     obtainGeckoDriver dir (DownloadGeckoDriverAutodetect Nothing) >>= \case+  --       Right x -> info [i|Got geckoDriver: #{x}|]+  --       Left err -> expectationFailure (T.unpack err) + main :: IO () main = runSandwich options spec   where     options = defaultOptions {-      optionsTestArtifactsDirectory = TestArtifactsGeneratedDirectory "test_runs" (show <$> getCurrentTime)+      optionsTestArtifactsDirectory = defaultTestArtifactsDirectory       }

@@ -1,7 +1,7 @@-{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}  module Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb (@@ -11,8 +11,9 @@ import Control.Exception import Control.Monad.Catch (MonadMask) import Control.Monad.IO.Class+import Control.Monad.IO.Unlift import Control.Monad.Logger-import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Reader import Control.Retry import qualified Data.List as L import Data.Maybe@@ -24,7 +25,10 @@ import System.IO.Temp import System.Process import Test.Sandwich+import Test.Sandwich.WebDriver.Internal.Binaries.Xvfb+import Test.Sandwich.WebDriver.Internal.OnDemand import Test.Sandwich.WebDriver.Internal.Types+import UnliftIO.MVar   #ifdef linux_HOST_OS@@ -39,11 +43,16 @@ handleToFd h = Fd <$> HFD.handleToFd h #endif -type Constraints m = (HasCallStack, MonadLogger m, MonadIO m, MonadBaseControl IO m, MonadMask m)+type Constraints m context = (+  HasCallStack, MonadLoggerIO m, MonadUnliftIO m, MonadMask m, MonadFail m+  , MonadReader context m, HasBaseContext context+  )  -makeXvfbSession :: Constraints m => Maybe (Int, Int) -> Bool -> FilePath -> m (XvfbSession, [(String, String)])-makeXvfbSession xvfbResolution xvfbStartFluxbox webdriverRoot = do+makeXvfbSession :: (+  Constraints m context+  ) => Maybe (Int, Int) -> Bool -> FilePath -> XvfbToUse -> MVar (OnDemand FilePath) -> m (XvfbSession, [(String, String)])+makeXvfbSession xvfbResolution xvfbStartFluxbox webdriverRoot xvfbOnDemand xvfbToUse = do   let (w, h) = fromMaybe (1920, 1080) xvfbResolution   liftIO $ createDirectoryIfMissing True webdriverRoot @@ -51,7 +60,7 @@   (serverNum :: Int, p, authFile, displayNum) <- recoverAll policy $ \_ -> do     withTempFile webdriverRoot "x11_server_num" $ \path tmpHandle -> do       fd <- liftIO $ handleToFd tmpHandle-      (serverNum, p, authFile) <- createXvfbSession webdriverRoot w h fd+      (serverNum, p, authFile) <- createXvfbSession webdriverRoot w h fd xvfbOnDemand xvfbToUse        debug [i|Trying to determine display number for auth file '#{authFile}', using '#{path}'|] @@ -80,18 +89,25 @@   return (xvfbSession, env)  -createXvfbSession :: Constraints m => FilePath -> Int -> Int -> Fd -> m (Int, ProcessHandle, FilePath)-createXvfbSession webdriverRoot w h (Fd fd) = do+createXvfbSession :: (+  Constraints m context+  ) => FilePath -> Int -> Int -> Fd -> XvfbToUse -> MVar (OnDemand FilePath) -> m (Int, ProcessHandle, FilePath)+createXvfbSession webdriverRoot w h (Fd fd) xvfbToUse xvfbOnDemand = do+  xvfb <- getOnDemand xvfbOnDemand (obtainXvfb xvfbToUse)+   serverNum <- liftIO findFreeServerNum    -- Start the Xvfb session   authFile <- liftIO $ writeTempFile webdriverRoot ".Xauthority" ""-  p <- createProcessWithLogging $ (proc "Xvfb" [":" <> show serverNum-                                               , "-screen", "0", [i|#{w}x#{h}x24|]-                                               , "-displayfd", [i|#{fd}|]-                                               , "-auth", authFile-                                               ]) { cwd = Just webdriverRoot-                                                  , create_group = True }+  p <- createProcessWithLogging $ (+    proc xvfb [":" <> show serverNum+              , "-screen", "0", [i|#{w}x#{h}x24|]+              , "-displayfd", [i|#{fd}|]+              , "-auth", authFile+              ]) {+      cwd = Just webdriverRoot+      , create_group = True+      }    return (serverNum, p, authFile) @@ -106,7 +122,7 @@         False -> return candidate  -startFluxBoxOnDisplay :: Constraints m => FilePath -> Int -> m ProcessHandle+startFluxBoxOnDisplay :: Constraints m context => FilePath -> Int -> m ProcessHandle startFluxBoxOnDisplay webdriverRoot x = do   logPath <- liftIO $ writeTempFile webdriverRoot "fluxbox.log" "" 

@@ -13,4 +13,4 @@ getResolution = undefined  getResolutionForDisplay :: Int -> IO (Int, Int, Int, Int)-getResolutionForDisplay n = undefined+getResolutionForDisplay _n = undefined