sandwich-webdriver (empty) → 0.1.0.0

raw patch · 25 files changed

+2020/−0 lines, 25 filesdep +X11dep +aesondep +basesetup-changed

Dependencies added: X11, aeson, base, containers, convertible, 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, sandwich-webdriver, string-interpolate, temporary, text, time, transformers, unix, unordered-containers, vector, webdriver

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +1/−0
Setup.hs +2/−0
app/Main.hs +96/−0
app/Simple.hs +22/−0
sandwich-webdriver.cabal +182/−0
src/Test/Sandwich/WebDriver.hs +151/−0
src/Test/Sandwich/WebDriver/Class.hs +15/−0
src/Test/Sandwich/WebDriver/Config.hs +52/−0
src/Test/Sandwich/WebDriver/Internal/Action.hs +49/−0
src/Test/Sandwich/WebDriver/Internal/Binaries.hs +165/−0
src/Test/Sandwich/WebDriver/Internal/Binaries/Util.hs +125/−0
src/Test/Sandwich/WebDriver/Internal/Capabilities.hs +80/−0
src/Test/Sandwich/WebDriver/Internal/Ports.hs +78/−0
src/Test/Sandwich/WebDriver/Internal/Screenshots.hs +27/−0
src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs +200/−0
src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs +129/−0
src/Test/Sandwich/WebDriver/Internal/Types.hs +235/−0
src/Test/Sandwich/WebDriver/Internal/Util.hs +61/−0
src/Test/Sandwich/WebDriver/Internal/Video.hs +63/−0
src/Test/Sandwich/WebDriver/Types.hs +67/−0
src/Test/Sandwich/WebDriver/Video.hs +82/−0
src/Test/Sandwich/WebDriver/Windows.hs +84/−0
test/Spec.hs +21/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for sandwich-webdriver++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Tom McLaughlin (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Tom McLaughlin nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,1 @@+# sandwich-webdriver

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ app/Main.hs view

@@ -0,0 +1,96 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+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.Formatters.TerminalUI+import Test.Sandwich.WebDriver+import Test.Sandwich.WebDriver.Windows+import Test.WebDriver++simple :: TopSpec+simple = introduceWebDriver wdOptions $ do+  it "does the thing 1" $ withSession1 $ do+    openPage "http://www.google.com"+    setWindowLeftSide+    search <- findElem (ByCSS [i|input[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+  -- 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

+ app/Simple.hs view

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

+ sandwich-webdriver.cabal view

@@ -0,0 +1,182 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 1445634cb05bff8d8f14f1859f68e0088405fbc2410b4efaa022d2e4d7e004e0++name:           sandwich-webdriver+version:        0.1.0.0+description:    Please see the README on GitHub at <https://github.com/githubuser/sandwich-webdriver#readme>+homepage:       https://github.com/codedownio/sandwich-webdriver#readme+bug-reports:    https://github.com/codedownio/sandwich-webdriver/issues+author:         Tom McLaughlin+maintainer:     tom@codedown.io+copyright:      2021 Tom McLaughlin+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/codedownio/sandwich-webdriver++library+  exposed-modules:+      Test.Sandwich.WebDriver+      Test.Sandwich.WebDriver.Class+      Test.Sandwich.WebDriver.Config+      Test.Sandwich.WebDriver.Internal.Action+      Test.Sandwich.WebDriver.Internal.Binaries+      Test.Sandwich.WebDriver.Internal.Binaries.Util+      Test.Sandwich.WebDriver.Internal.Capabilities+      Test.Sandwich.WebDriver.Internal.Ports+      Test.Sandwich.WebDriver.Internal.Screenshots+      Test.Sandwich.WebDriver.Internal.StartWebDriver+      Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb+      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:+      Paths_sandwich_webdriver+  hs-source-dirs:+      src+  default-extensions: OverloadedStrings QuasiQuotes NamedFieldPuns RecordWildCards ScopedTypeVariables FlexibleContexts FlexibleInstances LambdaCase+  ghc-options: -W+  build-depends:+      X11+    , aeson+    , base <=4.14+    , containers+    , convertible+    , 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+    , string-interpolate+    , temporary+    , text+    , time+    , transformers+    , unix+    , unordered-containers+    , vector+    , webdriver+  default-language: Haskell2010++executable sandwich-webdriver-exe+  main-is: Main.hs+  other-modules:+      Simple+      Paths_sandwich_webdriver+  hs-source-dirs:+      app+  default-extensions: OverloadedStrings QuasiQuotes NamedFieldPuns RecordWildCards ScopedTypeVariables FlexibleContexts FlexibleInstances LambdaCase+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      X11+    , aeson+    , base <=4.14+    , containers+    , convertible+    , 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+    , sandwich-webdriver+    , string-interpolate+    , temporary+    , text+    , time+    , transformers+    , unix+    , unordered-containers+    , vector+    , webdriver+  default-language: Haskell2010++test-suite sandwich-webdriver-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_sandwich_webdriver+  hs-source-dirs:+      test+  default-extensions: OverloadedStrings QuasiQuotes NamedFieldPuns RecordWildCards ScopedTypeVariables FlexibleContexts FlexibleInstances LambdaCase+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      X11+    , aeson+    , base <=4.14+    , containers+    , convertible+    , 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+    , sandwich-webdriver+    , string-interpolate+    , temporary+    , text+    , time+    , transformers+    , unix+    , unordered-containers+    , vector+    , webdriver+  default-language: Haskell2010

+ src/Test/Sandwich/WebDriver.hs view

@@ -0,0 +1,151 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications #-}++module Test.Sandwich.WebDriver (+  -- * Introducing a WebDriver server+  introduceWebDriver+  , introduceWebDriverOptions+  , addCommandLineOptionsToWdOptions++  -- * Running an example in a given session+  , withSession+  , withSession1+  , withSession2++  -- * Managing sessions+  , getSessions+  , closeCurrentSession+  , closeSession+  , closeAllSessions+  , closeAllSessionsExcept+  , Session++  -- * Lower-level allocation functions+  , allocateWebDriver+  , allocateWebDriver'+  , cleanupWebDriver+  , cleanupWebDriver'++  -- * Re-exports+  , module Test.Sandwich.WebDriver.Class+  , module Test.Sandwich.WebDriver.Config+  , module Test.Sandwich.WebDriver.Types+  ) where++import Control.Concurrent.MVar.Lifted+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader+import Data.IORef+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.WebDriver.Config+import Test.Sandwich.WebDriver.Internal.Action+import Test.Sandwich.WebDriver.Internal.StartWebDriver+import Test.Sandwich.WebDriver.Internal.Types+import Test.Sandwich.WebDriver.Types+import qualified Test.WebDriver as W+import qualified Test.WebDriver.Config as W+import qualified Test.WebDriver.Session as W+++-- | 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++-- | 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)++-- | Allocate a WebDriver using the given options.+allocateWebDriver :: (HasBaseContext context, BaseMonad m) => WdOptions -> ExampleT context m WebDriver+allocateWebDriver wdOptions = do+  debug "Beginning allocateWebDriver"+  maybeRunRoot <- getRunRoot+  let runRoot = fromMaybe "/tmp" maybeRunRoot+  startWebDriver wdOptions runRoot++-- | 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++-- | Clean up the given WebDriver.+cleanupWebDriver :: (HasBaseContext context, BaseMonad m) => 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+  WebDriver {..} <- getContext webdriver+  -- Create new session if necessary (this can throw an exception)+  sess <- modifyMVar wdSessionMap $ \sessionMap -> case M.lookup session sessionMap of+    Just sess -> return (sessionMap, sess)+    Nothing -> do+      debug [i|Creating session '#{session}'|]+      sess'' <- liftIO $ W.mkSession wdConfig+      let sess' = sess'' { W.wdSessHistUpdate = W.unlimitedHistory }+      sess <- liftIO $ W.runWD sess' $ W.createSession $ W.wdCapabilities wdConfig+      return (M.insert session sess sessionMap, sess)++  ref <- liftIO $ newIORef sess++  -- 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++  ExampleT (withReaderT (\ctx -> LabelValue (session, ref) :> ctx) $ mapReaderT (mapLoggingT f) readerMonad)++-- | Convenience function. 'withSession1' = 'withSession' "session1"+withSession1 :: WebDriverMonad m context => ExampleT (ContextWithSession 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+withSession2 = withSession "session2"++-- | Get all existing session names+getSessions :: (WebDriverMonad m context, MonadReader context m, HasLabel context "webdriver" WebDriver) => 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+    Nothing -> capabilities+    Just UseFirefox -> firefoxCapabilities+    Just UseChrome -> chromeCapabilities+  , runMode = case optDisplay of+      Nothing -> runMode+      Just Headless -> RunHeadless defaultHeadlessConfig+      Just Xvfb -> RunInXvfb (defaultXvfbConfig { xvfbStartFluxbox = optFluxbox })+      Just Current -> Normal+  }

+ src/Test/Sandwich/WebDriver/Class.hs view

@@ -0,0 +1,15 @@++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

+ src/Test/Sandwich/WebDriver/Config.hs view

@@ -0,0 +1,52 @@++module Test.Sandwich.WebDriver.Config (+  -- * Main options+  WdOptions+  , defaultWdOptions+  , runMode+  , seleniumToUse+  , chromeDriverToUse+  , geckoDriverToUse+  , capabilities+  , httpManager+  , httpRetryCount+  , saveSeleniumMessageHistory++  -- * Run mode constructors+  , RunMode(..)++  -- ** Xvfb mode+  , XvfbConfig+  , defaultXvfbConfig+  , xvfbResolution+  , xvfbStartFluxbox++  -- ** 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++  ) where++import Test.Sandwich.WebDriver.Internal.Binaries+import Test.Sandwich.WebDriver.Internal.Capabilities+import Test.Sandwich.WebDriver.Internal.Types

+ src/Test/Sandwich/WebDriver/Internal/Action.hs view

@@ -0,0 +1,49 @@+{-# LANGUAGE ViewPatterns, LambdaCase, QuasiQuotes, RecordWildCards, NamedFieldPuns, ScopedTypeVariables, DataKinds #-}++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.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 qualified Test.WebDriver as W+++-- | Close the given sessions+closeSession :: (HasCallStack, MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => Session -> WebDriver -> m ()+closeSession session (WebDriver {wdSessionMap}) = do+  toClose <- modifyMVar wdSessionMap $ \sessionMap ->+    case M.lookup session sessionMap of+      Nothing -> return (sessionMap, Nothing)+      Just x -> return (M.delete session sessionMap, Just x)++  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 ()+closeAllSessionsExcept toKeep (WebDriver {wdSessionMap}) = do+  toClose <- modifyMVar wdSessionMap $ return . M.partitionWithKey (\name _ -> name `elem` toKeep)++  forM_ (M.toList toClose) $ \(name, sess) ->+    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 ()+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 ()+closeCurrentSession = do+  webDriver <- getContext webdriver+  (session, _) <- getContext webdriverSession+  closeSession session webDriver

+ src/Test/Sandwich/WebDriver/Internal/Binaries.hs view

@@ -0,0 +1,165 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP, QuasiQuotes, ScopedTypeVariables, NamedFieldPuns, Rank2Types #-}++module Test.Sandwich.WebDriver.Internal.Binaries (+  obtainSelenium+  , obtainChromeDriver+  , obtainGeckoDriver+  , downloadSeleniumIfNecessary+  , downloadChromeDriverIfNecessary+  ) where++import Control.Monad+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.FilePath+import System.Process+import Test.Sandwich.Logging+import Test.Sandwich.WebDriver.Internal.Binaries.Util+import Test.Sandwich.WebDriver.Internal.Types+import Test.Sandwich.WebDriver.Internal.Util++type Constraints m = (HasCallStack, MonadLogger m, MonadIO m, MonadBaseControl IO m)++-- * Obtaining binaries++  -- 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) => FilePath -> SeleniumToUse -> m (Either T.Text FilePath)+obtainSelenium toolsDir (DownloadSeleniumFrom url) = do+  let seleniumPath = [i|#{toolsDir}/selenium-server-standalone.jar|]+  liftIO $ createDirectoryIfMissing True (takeDirectory seleniumPath)+  unlessM (liftIO $ doesFileExist seleniumPath) $+    void $ liftIO $ readCreateProcess (shell [i|curl #{url} -o #{seleniumPath}|]) ""+  return $ Right seleniumPath+obtainSelenium toolsDir DownloadSeleniumDefault = do+  let seleniumPath = [i|#{toolsDir}/selenium-server-standalone-3.141.59.jar|]+  liftIO $ createDirectoryIfMissing True (takeDirectory seleniumPath)+  unlessM (liftIO $ doesFileExist seleniumPath) $+    void $ liftIO $ readCreateProcess (shell [i|curl https://selenium-release.storage.googleapis.com/3.141/selenium-server-standalone-3.141.59.jar -o #{seleniumPath}|]) ""+  return $ Right seleniumPath+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) => FilePath -> ChromeDriverToUse -> m (Either T.Text FilePath)+obtainChromeDriver toolsDir (DownloadChromeDriverFrom url) = do+  let path = [i|#{toolsDir}/#{chromeDriverExecutable}|]+  liftIO $ createDirectoryIfMissing True (takeDirectory path)+  unlessM (liftIO $ doesFileExist path) $+    void $ liftIO $ readCreateProcess (shell [i|curl #{url} -o #{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 = runExceptT $ do+  version <- ExceptT $ liftIO getChromeDriverVersion+  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) => FilePath -> GeckoDriverToUse -> m (Either T.Text FilePath)+obtainGeckoDriver toolsDir (DownloadGeckoDriverFrom url) = do+  let path = [i|#{toolsDir}/#{geckoDriverExecutable}|]+  liftIO $ createDirectoryIfMissing True (takeDirectory path)+  unlessM (liftIO $ doesFileExist path) $+    void $ liftIO $ readCreateProcess (shell [i|curl #{url} -o #{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 = runExceptT $ do+  version <- ExceptT $ liftIO getGeckoDriverVersion+  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++downloadSelenium :: Constraints m => FilePath -> m ()+downloadSelenium seleniumPath = void $ do+  info [i|Downloading selenium-server.jar to #{seleniumPath}|]+  liftIO $ createDirectoryIfMissing True (takeDirectory seleniumPath)+  liftIO $ readCreateProcess (shell [i|curl https://selenium-release.storage.googleapis.com/3.141/selenium-server-standalone-3.141.59.jar -o #{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 => FilePath -> m (Either T.Text FilePath)+downloadChromeDriverIfNecessary toolsDir = runExceptT $ do+  chromeDriverVersion <- ExceptT $ liftIO getChromeDriverVersion+  ExceptT $ downloadChromeDriverIfNecessary' toolsDir chromeDriverVersion++getChromeDriverPath :: FilePath -> ChromeDriverVersion -> FilePath+getChromeDriverPath toolsDir (ChromeDriverVersion (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) => T.Text -> FilePath -> m (Either T.Text ())+downloadAndUnzipToPath downloadPath localPath = leftOnException' $ do+  info [i|Downloading #{downloadPath} to #{localPath}|]+  liftIO $ createDirectoryIfMissing True (takeDirectory localPath)+  liftIO $ void $ readCreateProcess (shell [i|wget -nc -O - #{downloadPath} | gunzip - > #{localPath}|]) ""+  liftIO $ void $ readCreateProcess (shell [i|chmod u+x #{localPath}|]) ""++downloadAndUntarballToPath :: (MonadIO m, MonadBaseControl IO 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)+  liftIO $ void $ readCreateProcess (shell [i|wget -qO- #{downloadPath} | tar xvz  -C #{takeDirectory localPath}|]) ""+  liftIO $ void $ readCreateProcess (shell [i|chmod u+x #{localPath}|]) ""++unlessM :: Monad m => m Bool -> m () -> m ()+unlessM b s = b >>= (\t -> unless t s)

+ src/Test/Sandwich/WebDriver/Internal/Binaries/Util.hs view

@@ -0,0 +1,125 @@+{-# LANGUAGE CPP, QuasiQuotes, ScopedTypeVariables, NamedFieldPuns, OverloadedStrings, ViewPatterns #-}++module Test.Sandwich.WebDriver.Internal.Binaries.Util (+  detectPlatform+  , detectChromeVersion+  , getChromeDriverVersion+  , getChromeDriverDownloadUrl+  , Platform(..)++  , 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.Convertible+import qualified Data.HashMap.Strict as HM+import Data.String.Interpolate+import qualified Data.Text as T+import Network.HTTP.Client+import Network.HTTP.Client.TLS+import Network.HTTP.Conduit (simpleHttp)+import Safe+import System.Exit+import qualified System.Info as SI+import System.Process+import Test.Sandwich.WebDriver.Internal.Types+import Test.Sandwich.WebDriver.Internal.Util++data Platform = Linux | OSX | Windows deriving (Show, Eq)++detectPlatform :: Platform+detectPlatform =  case SI.os of+  "windows" -> Windows+  "linux" -> Linux+  "darwin" -> OSX+  _ -> error [i|Couldn't determine host platform from string: '#{SI.os}'|]++-- * Chrome++detectChromeVersion :: IO (Either T.Text ChromeVersion)+detectChromeVersion = leftOnException $ runExceptT $ do+  (exitCode, stdout, stderr) <- liftIO $ readCreateProcessWithExitCode (shell "google-chrome --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 $ convert 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 :: IO (Either T.Text ChromeDriverVersion)+getChromeDriverVersion = runExceptT $ do+  chromeVersion <- ExceptT $ liftIO detectChromeVersion+  ExceptT $ getChromeDriverVersion' chromeVersion++getChromeDriverVersion' :: ChromeVersion -> IO (Either T.Text ChromeDriverVersion)+getChromeDriverVersion' (ChromeVersion (w, x, y, _)) = 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 <- convert <$> simpleHttp url+             case T.splitOn "." result of+               [tReadMay -> Just w, tReadMay -> Just x, tReadMay -> Just y, tReadMay -> Just z] -> return $ Right $ ChromeDriverVersion (w, x, y, z)+               _ -> return $ Left [i|Failed to parse chromedriver version from string: '#{result}'|]+         )++getChromeDriverDownloadUrl :: ChromeDriverVersion -> Platform -> T.Text+getChromeDriverDownloadUrl (ChromeDriverVersion (w, x, y, z)) Linux = [i|https://chromedriver.storage.googleapis.com/#{w}.#{x}.#{y}.#{z}/chromedriver_linux64.zip|]+getChromeDriverDownloadUrl (ChromeDriverVersion (w, x, y, z)) OSX = [i|https://chromedriver.storage.googleapis.com/#{w}.#{x}.#{y}.#{z}/chromedriver_mac64.zip|]+getChromeDriverDownloadUrl (ChromeDriverVersion (w, x, y, z)) Windows = [i|https://chromedriver.storage.googleapis.com/#{w}.#{x}.#{y}.#{z}/chromedriver_win32.zip|]++-- * Firefox++detectFirefoxVersion :: IO (Either T.Text FirefoxVersion)+detectFirefoxVersion = leftOnException $ runExceptT $ do+  (exitCode, stdout, stderr) <- liftIO $ readCreateProcessWithExitCode (shell "firefox --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 $ convert 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 :: IO (Either T.Text GeckoDriverVersion)+getGeckoDriverVersion = runExceptT $ do+  -- firefoxVersion <- ExceptT $ liftIO detectFirefoxVersion++  -- 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 . convert

+ src/Test/Sandwich/WebDriver/Internal/Capabilities.hs view

@@ -0,0 +1,80 @@+{-# LANGUAGE OverloadedLists #-}+-- |++module Test.Sandwich.WebDriver.Internal.Capabilities (+  -- * Chrome+  chromeCapabilities+  , headlessChromeCapabilities++  -- * Firefox+  , firefoxCapabilities+  , headlessFirefoxCapabilities+  ) where++import qualified Data.Aeson as A+import Data.Default+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import Test.WebDriver++loggingPrefs :: A.Value+loggingPrefs = A.object [("browser", "ALL")+                        , ("client", "WARNING")+                        , ("driver", "WARNING")+                        , ("performance", "ALL")+                        , ("server", "WARNING")+                        ]++-- * Chrome++-- | Default capabilities for regular Chrome.+-- Has the "browser" log level to "ALL" so that tests can collect browser logs.+chromeCapabilities :: Capabilities+chromeCapabilities =+  def {browser=Chrome Nothing Nothing args [] chromePrefs+      , additionalCaps=[("loggingPrefs", loggingPrefs)+                       , ("goog:loggingPrefs", loggingPrefs)]+      }+  where args = ["--verbose"]++-- | Default capabilities for headless Chrome.+headlessChromeCapabilities :: Capabilities+headlessChromeCapabilities =+  def {browser=Chrome Nothing Nothing args [] chromePrefs+      , additionalCaps=[("loggingPrefs", loggingPrefs)+                       , ("goog:loggingPrefs", loggingPrefs)]+      }+  where args = ["--verbose", "--headless"]++chromePrefs :: HM.HashMap T.Text A.Value+chromePrefs = HM.fromList [+  ("prefs", A.object [("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", "/tmp")])+  ]++-- * Firefox++-- | Default capabilities for regular Firefox.+firefoxCapabilities :: Capabilities+firefoxCapabilities = def { browser=ff }+  where+    ff = Firefox { ffProfile = Nothing+                 , ffLogPref = LogAll+                 , ffBinary = Nothing+                 , ffAcceptInsecureCerts = Nothing+                 }++-- | Default capabilities for headless Firefox.+headlessFirefoxCapabilities :: Capabilities+headlessFirefoxCapabilities = def { browser=ff, additionalCaps=additionalCaps }+  where+    ff = Firefox { ffProfile = Nothing+                 , ffLogPref = LogAll+                 , ffBinary = Nothing+                 , ffAcceptInsecureCerts = Nothing+                 }++    additionalCaps = [("moz:firefoxOptions", A.object [("args", A.Array ["-headless"])])]

+ src/Test/Sandwich/WebDriver/Internal/Ports.hs view

@@ -0,0 +1,78 @@+{-# 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}'|]

+ src/Test/Sandwich/WebDriver/Internal/Screenshots.hs view

@@ -0,0 +1,27 @@+{-# LANGUAGE RankNTypes, MultiWayIf, ScopedTypeVariables, CPP, QuasiQuotes, RecordWildCards #-}+-- |++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+import Data.String.Interpolate+import qualified Data.Text as T+import GHC.Stack+import Network.HTTP.Client+import System.FilePath+import Test.Sandwich.WebDriver.Internal.Types+import Test.WebDriver++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 $+    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|])

+ src/Test/Sandwich/WebDriver/Internal/StartWebDriver.hs view

@@ -0,0 +1,200 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE ViewPatterns #-}+-- |++module Test.Sandwich.WebDriver.Internal.StartWebDriver where+++import Control.Concurrent+import Control.Monad+import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Retry+import qualified Data.Aeson as A+import Data.Default+import Data.Function+import qualified Data.HashMap.Strict as HM+import qualified Data.List as L+import Data.Maybe+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 Test.Sandwich+import Test.Sandwich.WebDriver.Internal.Binaries+import Test.Sandwich.WebDriver.Internal.Ports+import Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb+import Test.Sandwich.WebDriver.Internal.Types+import Test.Sandwich.WebDriver.Internal.Util+import qualified Test.WebDriver as W++type Constraints m = (HasCallStack, MonadLogger m, MonadIO m, MonadBaseControl IO m, MonadMask m)++-- | Spin up a Selenium WebDriver and create a WebDriver+startWebDriver :: Constraints m => WdOptions -> FilePath -> m WebDriver+startWebDriver wdOptions@(WdOptions {..}) 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)++  -- Directory to log everything for this webdriver+  let webdriverRoot = runRoot </> (T.unpack webdriverName)+  liftIO $ createDirectoryIfMissing True webdriverRoot++  -- Get selenium and chromedriver+  debug [i|Preparing to create the Selenium process|]+  liftIO $ createDirectoryIfMissing True toolsRoot+  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}|]++  (maybeXvfbSession, javaEnv) <- case runMode of+    RunInXvfb (XvfbConfig {..}) -> do+      (s, e) <- makeXvfbSession xvfbResolution xvfbStartFluxbox webdriverRoot+      return (Just s, Just e)+    _ -> return (Nothing, Nothing)++  -- 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+    when (rsIterNumber retryStatus > 0) $+      warn [i|Trying again to start selenium server|]++    -- Create a distinct process name+    webdriverProcessName <- ("webdriver_process_" <>) <$> (liftIO makeUUID)+    let webdriverProcessRoot = webdriverRoot </> T.unpack webdriverProcessName+    liftIO $ createDirectoryIfMissing True webdriverProcessRoot+    startWebDriver' wdOptions webdriverName webdriverProcessRoot seleniumPath driverArgs maybeXvfbSession javaEnv++startWebDriver' wdOptions@(WdOptions {capabilities=capabilities', ..}) webdriverName webdriverRoot seleniumPath driverArgs maybeXvfbSession javaEnv = do+  port <- liftIO findFreePortOrException+  let wdCreateProcess = (proc "java" (driverArgs <> ["-jar", seleniumPath+                                                    , "-port", show port])) { env = javaEnv }++  -- 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|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|]++  -- Make the WebDriver+  WebDriver <$> pure (T.unpack webdriverName)+            <*> pure (hout, herr, p, seleniumOutPath, seleniumErrPath, maybeXvfbSession)+            <*> pure wdOptions+            <*> liftIO (newMVar mempty)+            <*> pure (def { W.wdPort = fromIntegral port+                          , W.wdCapabilities = configureCapabilities capabilities' runMode+                          , W.wdHTTPManager = httpManager+                          , W.wdHTTPRetryCount = httpRetryCount+                          })+++stopWebDriver :: Constraints m => WebDriver -> m ()+stopWebDriver (WebDriver {wdWebDriver=(hout, herr, h, _, _, maybeXvfbSession)}) = do+  _ <- liftIO (interruptProcessGroupOf h >> waitForProcess h)+  liftIO $ hClose hout+  liftIO $ hClose herr++  whenJust maybeXvfbSession $ \(XvfbSession {..}) -> do+    whenJust xvfbFluxboxProcess $ \p ->+      liftIO (interruptProcessGroupOf p >> waitForProcess p)++    liftIO (interruptProcessGroupOf xvfbProcess >> waitForProcess xvfbProcess)++-- * Util++seleniumOutFileName, seleniumErrFileName :: FilePath+seleniumOutFileName = "stdout.txt"+seleniumErrFileName = "stderr.txt"++-- | Add headless configuration to the Chrome browser+configureCapabilities caps@(W.Capabilities {W.browser=browser@(W.Chrome {..})}) (RunHeadless (HeadlessConfig {..})) = caps { W.browser = browser' }+  where browser' = browser { W.chromeOptions = "--headless":resolution:chromeOptions }+        resolution = [i|--window-size=#{w},#{h}|]+        (w, h) = fromMaybe (1920, 1080) headlessResolution++-- | Add headless configuration to the Firefox capabilities+configureCapabilities caps@(W.Capabilities {W.browser=(W.Firefox {..}), W.additionalCaps=ac}) (RunHeadless (HeadlessConfig {..})) = 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 key -> Just _)) = val+    ensureKeyExists key defaultVal (A.Object m@(HM.lookup key -> Nothing)) = A.Object (HM.insert 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++configureCapabilities browser (RunHeadless {}) = error [i|Headless mode not yet supported for browser '#{browser}'|]+configureCapabilities browser _ = browser

+ src/Test/Sandwich/WebDriver/Internal/StartWebDriver/Xvfb.hs view

@@ -0,0 +1,129 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+-- |++module Test.Sandwich.WebDriver.Internal.StartWebDriver.Xvfb (+  makeXvfbSession+  ) where++import Control.Exception+import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Retry+import qualified Data.List as L+import Data.Maybe+import Data.String.Interpolate+import GHC.Stack+import Safe+import System.Directory+import System.Environment+import System.IO.Temp+import System.Process+import Test.Sandwich+import Test.Sandwich.WebDriver.Internal.Types+++#ifdef linux_HOST_OS+import System.Posix.IO as Posix+import System.Posix.Types+#endif+++type Constraints m = (HasCallStack, MonadLogger m, MonadIO m, MonadBaseControl IO m, MonadMask m)+++makeXvfbSession :: Constraints m => Maybe (Int, Int) -> Bool -> FilePath -> m (XvfbSession, [(String, String)])+makeXvfbSession xvfbResolution xvfbStartFluxbox webdriverRoot = do+  let (w, h) = fromMaybe (1920, 1080) xvfbResolution+  liftIO $ createDirectoryIfMissing True webdriverRoot++  let policy = constantDelay 10000 <> limitRetries 1000+  (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++      debug [i|Trying to determine display number for auth file '#{authFile}', using '#{path}'|]++      displayNum <-+        recoverAll policy $ \_ ->+          (liftIO $ readFile path) >>= \contents -> case readMay contents of -- hGetContents readHandle+            Nothing -> liftIO $ throwIO $ userError [i|Couldn't determine X11 screen to use. Got data: '#{contents}'. Path was '#{path}'|]+            Just (x :: Int) -> return x++      return (serverNum, p, authFile, displayNum)++  fluxboxProcess <- if xvfbStartFluxbox then Just <$> (startFluxBoxOnDisplay webdriverRoot displayNum) else return Nothing++  let xvfbSession = XvfbSession {+        xvfbDisplayNum = displayNum+        , xvfbXauthority = authFile+        , xvfbDimensions = (w, h)+        , xvfbProcess = p+        , xvfbFluxboxProcess = fluxboxProcess+        }++  -- TODO: allow verbose logging to be controlled with an option:+  env' <- liftIO getEnvironment+  let env = L.nubBy (\x y -> fst x == fst y) $ [("DISPLAY", ":" <> show serverNum)+                                               , ("XAUTHORITY", xvfbXauthority xvfbSession)] <> env'+  return (xvfbSession, env)+++createXvfbSession :: Constraints m => FilePath -> Int -> Int -> Fd -> m (Int, ProcessHandle, FilePath)+createXvfbSession webdriverRoot w h (Fd fd) = do+  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 }++  return (serverNum, p, authFile)+++findFreeServerNum :: IO Int+findFreeServerNum = findFreeServerNum' 99+  where+    findFreeServerNum' :: Int -> IO Int+    findFreeServerNum' candidate = do+      doesPathExist [i|/tmp/.X11-unix/X#{candidate}|] >>= \case+        True -> findFreeServerNum' (candidate + 1)+        False -> return candidate+++startFluxBoxOnDisplay :: Constraints m => FilePath -> Int -> m ProcessHandle+startFluxBoxOnDisplay webdriverRoot x = do+  logPath <- liftIO $ writeTempFile webdriverRoot "fluxbox.log" ""++  debug [i|Starting fluxbox on logPath '#{logPath}'|]++  let args = ["-display", ":" <> show x+             , "-log", logPath]++  (_, _, _, p) <- liftIO $ createProcess $ (proc "fluxbox" args) {+    cwd = Just webdriverRoot+    , create_group = True+    , std_out = CreatePipe+    , std_err = CreatePipe+    }++  -- TODO: confirm fluxbox started successfully++  return p

+ src/Test/Sandwich/WebDriver/Internal/Types.hs view

@@ -0,0 +1,235 @@+{-# LANGUAGE TypeFamilies, InstanceSigs, RecordWildCards, ScopedTypeVariables, QuasiQuotes, Rank2Types, NamedFieldPuns, DataKinds, ConstraintKinds #-}++module Test.Sandwich.WebDriver.Internal.Types where++import Control.Concurrent.MVar+import Control.Exception+import Data.Default+import Data.IORef+import qualified Data.Map as M+import Data.String.Interpolate+import qualified Data.Text as T+import Network.HTTP.Client (Manager)+import System.IO+import System.Process+import Test.Sandwich+import qualified Test.WebDriver as W+import qualified Test.WebDriver.Class as W+import qualified Test.WebDriver.Session as W++-- | '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++instance HasWebDriver WebDriver where+  getWebDriver = id++type ToolsRoot = FilePath++data WhenToSave = Always | OnException | Never deriving (Show, Eq)++-- | 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 WdOptions = WdOptions {+  toolsRoot :: ToolsRoot+  -- ^ Folder where any necessary binaries (chromedriver, Selenium, etc.) will be downloaded if needed. Required.++  , capabilities :: W.Capabilities+  -- ^ The WebDriver capabilities to use++  , saveSeleniumMessageHistory :: WhenToSave+  -- ^ When to save a record of Selenium requests and responses++  , saveLogSettings :: SaveLogSettings+  -- ^ When to save a record of Selenium requests and responses++  , seleniumToUse :: SeleniumToUse+  -- ^ Which Selenium server JAR file to use++  , chromeDriverToUse :: ChromeDriverToUse+  -- ^ Which chromedriver executable to use++  , geckoDriverToUse :: GeckoDriverToUse+  -- ^ Which geckodriver executable to use++  , runMode :: RunMode+  -- ^ How to handle opening the browser (in a popup window, headless, etc.)++  , httpManager :: Maybe Manager+  -- ^ HTTP manager for making requests to Selenium. If not provided, one will be created for each session.++  , httpRetryCount :: Int+  -- ^ 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++-- | 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+  -- ^ Autodetect chromedriver to use based on the Chrome version and download it to the 'toolsRoot'+  | UseChromeDriverAt FilePath+  -- ^ Use the chromedriver at the given path++-- | 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+  -- ^ Autodetect geckodriver to use based on the Gecko version and download it to the 'toolsRoot'+  | UseGeckoDriverAt FilePath+  -- ^ Use the geckodriver at the given path++newtype ChromeVersion = ChromeVersion (Int, Int, Int, Int) deriving Show+newtype ChromeDriverVersion = ChromeDriverVersion (Int, Int, Int, Int) deriving Show++newtype FirefoxVersion = FirefoxVersion (Int, Int, Int) deriving Show+newtype GeckoDriverVersion = GeckoDriverVersion (Int, Int, Int) deriving Show++data HeadlessConfig = HeadlessConfig {+  headlessResolution :: Maybe (Int, Int)+  -- ^ Resolution for the headless browser. Defaults to (1920, 1080)+  }++defaultHeadlessConfig = HeadlessConfig Nothing++data XvfbConfig = XvfbConfig {+  xvfbResolution :: Maybe (Int, Int)+  -- ^ 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+  }++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+  , saveSeleniumMessageHistory = OnException+  , saveLogSettings = mempty+  , seleniumToUse = DownloadSeleniumDefault+  , chromeDriverToUse = DownloadChromeDriverAutodetect+  , geckoDriverToUse = DownloadGeckoDriverAutodetect+  , runMode = Normal+  , httpManager = Nothing+  , httpRetryCount = 0+  }++type SaveLogSettings = M.Map W.LogType (W.LogEntry -> Bool, W.LogEntry -> T.Text, W.LogEntry -> Bool)++data WebDriver = WebDriver { wdName :: String+                           , wdWebDriver :: (Handle, Handle, ProcessHandle, FilePath, FilePath, Maybe XvfbSession)+                           , wdOptions :: WdOptions+                           , wdSessionMap :: MVar (M.Map Session W.WDSession)+                           , wdConfig :: W.WDConfig }++data InvalidLogsException = InvalidLogsException [W.LogEntry]+  deriving (Show)++instance Exception InvalidLogsException++data XvfbSession = XvfbSession { xvfbDisplayNum :: Int+                               , xvfbXauthority :: FilePath+                               , xvfbDimensions :: (Int, Int)+                               , xvfbProcess :: ProcessHandle+                               , xvfbFluxboxProcess :: Maybe ProcessHandle }++type WebDriverSession = (Session, IORef W.WDSession)++-- | Get the 'WdOptions' associated with the 'WebDriver'+getWdOptions :: WebDriver -> WdOptions+getWdOptions = wdOptions++-- | 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 _ = Nothing++-- | Get the Xvfb session associated with the 'WebDriver', if present+getXvfbSession :: WebDriver -> Maybe XvfbSession+getXvfbSession (WebDriver {wdWebDriver=(_, _, _, _, _, Just sess)}) = Just sess+getXvfbSession _ = Nothing++-- | Get the name of 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++fastX11VideoOptions = ["-an"+                      , "-r", "30"+                      , "-vcodec"+                      , "libxvid"+                      , "-qscale:v", "1"+                      , "-threads", "0"]++qualityX11VideoOptions = ["-an"+                         , "-r", "30"+                         , "-vcodec", "libx264"+                         , "-preset", "veryslow"+                         , "-crf", "0"+                         , "-threads", "0"]++defaultAvfoundationOptions = ["-r", "30"+                             , "-an"+                             , "-vcodec", "libxvid"+                             , "-qscale:v", "1"+                             , "-threads", "0"]++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.+                                   }++instance Default VideoSettings where+  def = VideoSettings { x11grabOptions = fastX11VideoOptions+                      , avfoundationOptions = defaultAvfoundationOptions+                      , gdigrabOptions = defaultGdigrabOptions+                      , hideMouseWhenRecording = False }

+ src/Test/Sandwich/WebDriver/Internal/Util.hs view

@@ -0,0 +1,61 @@+{-# LANGUAGE CPP, QuasiQuotes, ScopedTypeVariables, NamedFieldPuns, FlexibleContexts #-}++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.Trans.Control (MonadBaseControl)+import Data.Convertible+import Data.String.Interpolate+import qualified Data.Text as T+import System.Directory+import System.Process+import qualified System.Random as R++-- * 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 $ convert $ show e)++leftOnException' :: (MonadIO m, MonadBaseControl IO m) => m a -> m (Either T.Text a)+leftOnException' action = E.catch (Right <$> action) (\(e :: SomeException) -> return $ Left $ convert $ show e)++-- * Util++whenJust :: (Monad m) => Maybe a -> (a -> m b) -> m ()+whenJust Nothing _ = return ()+whenJust (Just x) action = void $ action x++whenLeft :: (Monad m) => Either a b -> (a -> m ()) -> m ()+whenLeft (Left x) action = action x+whenLeft (Right _) _ = return ()++whenRight :: (Monad m) => Either a b -> (b -> m ()) -> m ()+whenRight (Left _) _ = return ()+whenRight (Right x) action = action x++makeUUID :: IO T.Text+makeUUID = (convert . take 10 . R.randomRs ('a','z')) <$> R.newStdGen

+ src/Test/Sandwich/WebDriver/Internal/Video.hs view

@@ -0,0 +1,63 @@+{-# LANGUAGE CPP, QuasiQuotes, ScopedTypeVariables, FlexibleContexts, OverloadedStrings, NamedFieldPuns, ViewPatterns #-}+-- |++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+#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" cmds) { 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

+ src/Test/Sandwich/WebDriver/Types.hs view

@@ -0,0 +1,67 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Test.Sandwich.WebDriver.Types (+  ExampleWithWebDriver+  , HasWebDriverContext+  , HasWebDriverSessionContext+  , ContextWithSession++  , hoistExample++  , webdriver++  -- * Constraint synonyms+  , BaseMonad+  , BaseMonadContext+  , WebDriverMonad+  , WebDriverSessionMonad+  ) where++import Control.Exception.Safe as ES+import Control.Monad.IO.Class+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.WebDriver.Internal.Types+import qualified Test.WebDriver.Class as W+import qualified Test.WebDriver.Internal as WI+import qualified Test.WebDriver.Session as W+++type ContextWithSession context = LabelValue "webdriverSession" WebDriverSession :> context++instance (MonadIO m, HasLabel context "webdriverSession" WebDriverSession) => W.WDSessionState (ExampleT context m) where+  getSession = do+    (_, sessVar) <- getContext webdriverSession+    liftIO $ readIORef sessVar+  putSession sess = do+    (_, sessVar) <- getContext webdriverSession+    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+  doCommand method path args = WI.mkRequest method path args+    >>= WI.sendHTTPRequest+    >>= either throwIO return+    >>= WI.getJSONResult+    >>= either throwIO return++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 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)

+ src/Test/Sandwich/WebDriver/Video.hs view

@@ -0,0 +1,82 @@+{-# LANGUAGE CPP, QuasiQuotes, ScopedTypeVariables, FlexibleContexts, OverloadedStrings, NamedFieldPuns, ViewPatterns #-}++module Test.Sandwich.WebDriver.Video (+  startVideoRecording+  , endVideoRecording++  , startFullScreenVideoRecording+  , startBrowserVideoRecording+  ) where++import Control.Exception.Safe+import Control.Monad.IO.Class+import Control.Monad.Logger hiding (logError)+import Control.Monad.Reader+import Control.Monad.Trans.Control (MonadBaseControl)+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.Windows+import Test.WebDriver.Class as W+import Test.WebDriver.Commands+++startFullScreenVideoRecording :: (MonadIO m, MonadReader context m, MonadLogger m, HasWebDriverContext context, MonadBaseControl IO m, MonadMask m) =>+  FilePath -> VideoSettings -> Bool -> m ProcessHandle+startFullScreenVideoRecording path videoSettings logToDisk = do+  sess <- getContext webdriver+  let maybeXvfbSession = getXvfbSession sess+  (width, height) <- case maybeXvfbSession of+    Just (XvfbSession {xvfbDimensions}) -> return xvfbDimensions+    Nothing -> do+      (_x, _y, w, h) <- getScreenResolution sess+      return (fromIntegral w, fromIntegral h)+  startVideoRecording path (fromIntegral width, fromIntegral height, 0, 0) videoSettings logToDisk++startBrowserVideoRecording :: (MonadIO m, MonadThrow m, MonadReader context m, MonadLogger m, HasWebDriverContext context, HasWebDriverSessionContext context, MonadBaseControl IO m, W.WebDriver m) =>+  FilePath -> VideoSettings -> Bool -> m ProcessHandle+startBrowserVideoRecording path videoSettings logToDisk = do+  (x, y) <- getWindowPos+  (w, h) <- getWindowSize+  startVideoRecording path (w, h, x, y) videoSettings logToDisk++startVideoRecording :: (MonadIO m, MonadReader context m, MonadLogger m, HasWebDriverContext context, MonadBaseControl IO m) =>+  FilePath -> (Word, Word, Int, Int) -> VideoSettings -> Bool -> m ProcessHandle+startVideoRecording path (width, height, x, y) vs logToDisk = do+  sess <- getContext webdriver+  let maybeXvfbSession = getXvfbSession sess++  cp' <- liftIO $ getVideoArgs path (width, height, x, y) vs maybeXvfbSession+  let cp = cp' { create_group = True }++  case cmdspec cp of+    ShellCommand s -> debug [i|ffmpeg command: #{s}|]+    RawCommand p args -> debug [i|ffmpeg command: #{p} #{unwords args}|]++  case logToDisk of+    False -> createProcessWithLogging cp+    True -> do+      liftIO $ bracket (openFile (path <.> "stdout" <.> "log") AppendMode) hClose $ \hout ->+        bracket (openFile (path <.> "stderr" <.> "log") AppendMode) hClose $ \herr -> do+          (_, _, _, p) <- createProcess (cp { std_out = UseHandle hout, std_err = UseHandle herr })+          return p++endVideoRecording :: (MonadIO m, MonadLogger m, MonadCatch m) => ProcessHandle -> m ()+endVideoRecording p = do+  catchAny (liftIO $ interruptProcessGroupOf p)+           (\e -> logError [i|Exception in interruptProcessGroupOf in endVideoRecording: #{e}|])++  liftIO (waitForProcess p) >>= \case+    ExitSuccess -> return ()++    -- ffmpeg seems to exit with code 255 when exiting in response to a signal+    -- https://github.com/FFmpeg/FFmpeg/blob/d182d8f10cf69c59ef9c21df4b06e5478df063ef/fftools/ffmpeg.c#L4890+    ExitFailure 255 -> return ()++    ExitFailure n -> debug [i|ffmpeg exited with unexpected exit code #{n}'|]

+ src/Test/Sandwich/WebDriver/Windows.hs view

@@ -0,0 +1,84 @@+{-# LANGUAGE QuasiQuotes #-}+-- | Functions for manipulating browser windows++module Test.Sandwich.WebDriver.Windows (+  setWindowLeftSide+  , setWindowRightSide+  , setWindowFullScreen++  , getScreenResolution+  ) 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 Data.String.Interpolate+import GHC.Stack+import qualified Graphics.X11.Xinerama as X+import qualified Graphics.X11.Xlib.Display as X+import Safe+import Test.Sandwich+import Test.Sandwich.WebDriver.Internal.Types+import Test.WebDriver+import qualified Test.WebDriver.Class as W+++setWindowLeftSide :: (HasCallStack, MonadIO wd, WebDriverContext context wd, MonadReader context wd, W.WebDriver wd, MonadLogger wd, MonadMask wd) => wd ()+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+    _ -> getScreenResolutionX11 sess+  setWindowPos (x + 0, y + 0)+  setWindowSize (fromIntegral $ B.shift width (-1), fromIntegral height)++setWindowRightSide :: (HasCallStack, MonadIO wd, WebDriverContext context wd, MonadReader context wd, W.WebDriver wd, MonadLogger wd, MonadMask wd) => wd ()+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+    _ -> getScreenResolutionX11 sess+  let pos = (x + (fromIntegral $ B.shift width (-1)), y + 0)+  setWindowPos pos+  setWindowSize (fromIntegral $ B.shift width (-1), fromIntegral height)++setWindowFullScreen :: (HasCallStack, MonadIO wd, WebDriverContext context wd, MonadReader context wd, W.WebDriver wd, MonadLogger wd, MonadMask wd) => wd ()+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+    _ -> getScreenResolutionX11 sess+  setWindowPos (x + 0, y + 0)+  setWindowSize (fromIntegral width, fromIntegral height)++-- * Getting screen dimensions and resolution++getScreenResolution :: (HasCallStack, MonadIO m, MonadMask m, MonadLogger m) => WebDriver -> m (Int, Int, Int, Int)+getScreenResolution = getScreenResolutionX11++-- * Internal++getScreenResolutionX11 :: (HasCallStack, MonadIO m, MonadMask m, MonadLogger m) => WebDriver -> m (Int, Int, Int, Int)+getScreenResolutionX11 (WebDriver {wdWebDriver=(_, _, _, _, _, maybeXvfbSession)}) = case maybeXvfbSession of+    Nothing -> getScreenResolutionX11' ":0" 0+    Just (XvfbSession {..}) -> getScreenResolutionX11' (":" <> show xvfbDisplayNum) 0++getScreenResolutionX11' :: (HasCallStack, MonadIO m, MonadMask m, MonadLogger m) => String -> Int -> m (Int, Int, Int, Int)+getScreenResolutionX11' displayString screenNumber = do+  bracket (liftIO $ X.openDisplay displayString) (liftIO . X.closeDisplay) $ \display -> do+    liftIO (X.xineramaQueryScreens display) >>= \case+      Nothing -> do+        -- TODO: this happens in CI when running under Xvfb. How to get resolution in that case?+        logError [i|Couldn't query X11 for screens for display "#{display}"; using default resolution 1920x1080|]+        return (0, 0, 1920, 1080)+      Just infos -> do+        case headMay [(xsi_x_org, xsi_y_org, xsi_width, xsi_height) | X.XineramaScreenInfo {..} <- infos+                                                                    , xsi_screen_number == fromIntegral screenNumber] of+          Nothing -> throwIO $ userError [i|Failed to get screen resolution (couldn't find screen number #{screenNumber})|]+          Just (x, y, w, h) -> return (fromIntegral x, fromIntegral y, fromIntegral w, fromIntegral h)

+ test/Spec.hs view

@@ -0,0 +1,21 @@++import Test.Sandwich+import Data.Time.Clock+import Test.Sandwich.Formatters.Print++data Foo = Foo { fooInt :: Int, fooString :: String, fooBar :: Bar } deriving (Show, Eq)+data Bar = Bar { barInt :: Int, barString :: String } deriving (Show, Eq)+data Baz = Baz Int String Bar deriving (Show, Eq)+data Simple = Simple { simpleInt :: Int } deriving (Show, Eq)+++verySimple :: TopSpec+verySimple = do+  it "succeeds" (return ())++main :: IO ()+main = runSandwich options verySimple+  where+    options = defaultOptions {+      optionsTestArtifactsDirectory = TestArtifactsGeneratedDirectory "test_runs" (show <$> getCurrentTime)+      }