packages feed

webdriver 0.12.0.1 → 0.13.0.0

raw patch · 88 files changed

+5920/−3815 lines, 88 filesdep +containersdep +microlensdep +microlens-thdep −call-stackdep −data-defaultdep −directory-treedep ~aesondep ~attoparsec-aesondep ~base

Dependencies added: containers, microlens, microlens-th, monad-logger, mtl, optparse-applicative, random, retry, safe-exceptions, sandwich, sandwich-contexts, stm, string-interpolate, unliftio, unliftio-core, wai-app-static, warp, webdriver, websockets

Dependencies removed: call-stack, data-default, directory-tree, lifted-base, monad-control, temporary, transformers, transformers-base, vector

Dependency ranges changed: aeson, attoparsec-aeson, base, bytestring, exceptions, filepath, http-client, http-types, network, network-uri, text

Files

CHANGELOG.md view
@@ -1,5 +1,9 @@ # Change Log +## 0.13.0.0+* Deprecated function `elemInfo` removed+* `deleteVisibleCookies` renamed to `deleteCookies`.+ ## 0.12.0.1 * Switch from `data-default-class` to `data-default` to address https://github.com/commercialhaskell/stackage/issues/7545. This is weirdly complicated: it looks like versions of `data-default` from `0.5.2` to `0.8.0.0` may pull in unnecessary (to us) `data-default-instances-*` dependencies. However, what we've done here should build with all versions, so we won't worry about it. At the next breaking change I'd like to remove `data-default` entirely.
LICENSE view
@@ -1,5 +1,5 @@ Copyright (c) 2012-2015, Adam Curtis-Copyright (c) 2022-2023, Tom McLaughlin+Copyright (c) 2022-2024, Tom McLaughlin All rights reserved.  Redistribution and use in source and binary forms, with or without
README.md view
@@ -3,92 +3,8 @@  [![Hackage](https://img.shields.io/hackage/v/webdriver.svg)](https://hackage.haskell.org/package/webdriver) ![webdriver](https://github.com/haskell-webdriver/haskell-webdriver/workflows/ci/badge.svg) -haskell-webdriver is a Selenium WebDriver client for the Haskell programming language. You can use it to automate browser sessions for testing, system administration, etc.--For more information about Selenium itself, see http://seleniumhq.org/--# Contents-* [Installation](#installation)-    * [Installation from Hackage](#installation-from-hackage)-    * [Installation from This Repository](#installation-from-this-repository)-* [Getting Started](#getting-started)-    * [Using the Selenium Server](#using-the-selenium-server)-    * [Hello, World!](#hello-world)-* [Integration with Haskell Testing Frameworks](#integration-with-haskell-testing-frameworks)-* [Documentation](#documentation)--# Installation-haskell-webdriver uses the Cabal build system to configure, build, install, and generate documentation on multiple platforms.--For more information on using Cabal and its various installation options, see the Cabal User's Guide at http://www.haskell.org/cabal/users-guide/index.html--## Installation from Hackage-haskell-webdriver is hosted on Hackage under the name webdriver. Thus, the simplest way to download and install the most recent version of haskell-webdriver is to run:--```sh-cabal install webdriver-```-There are also options to do system-wide installation, version selection, and other build options; see cabal-install documentation.--## Installation from this repository--To build and install a git revision for a single user on your system, run these commands from within the repository directory---### Using cabal-install--```sh-cabal install-```--### Using Cabal--For systems without cabal-install available, you can also run the Setup.hs-script, as such:--```sh-runhaskell Setup.hs configure --user-runhaskell Setup.hs build-runhaskell Setup.hs install-```--For more build options, please refer to the Cabal documentation.---# Getting Started--WebDriver is a client-server protocol. Since haskell-webdriver only implements a WebDriver client, you must have a WebDriver server to which you can connect in order to make use of this library.--## Using the Selenium Server-While you can use any WebDriver server out there, probably the simplest server to use with haskell-webdriver is [Selenium Server](http://docs.seleniumhq.org/download/). You'll need an installation of the Java runtime to use this server. Once you've downloaded Selenium Server to your current working directory, you can start the server with this shell command:--    java -jar selenium-server-standalone-*.jar--The server should now be listening at localhost on port 4444.--Currently, `haskell-webdriver` only supports selenium version 2.-The [beginner example](/examples/readme-example-beginner.md) was-tested with `selenium-server-standalone-2.53.1`.--## Hello, World!-With the Selenium server running locally, you're ready to write browser automation scripts in Haskell.--A [simple example can be found here](/examples/readme-example-beginner.md), written in literate Haskell so that you can compile it with GHC yourself. It is very beginner friendly and assumes no prior knowledge of Haskell. For other examples see the [examples](examples/) and [test/etc](test/etc/) directory.---# Integration with Haskell Testing Frameworks--This package does not provide utilities to integrate with popular Haskell testing frameworks. However, other packages exist for this purpose:--* [hspec-webdriver](https://hackage.haskell.org/package/hspec-webdriver)-* [quickcheck-webdriver](https://hackage.haskell.org/package/quickcheck-webdriver)+haskell-webdriver is a WebDriver client for the Haskell programming language. You can use it to automate browser sessions for testing, system administration, etc.  # Documentation -Documentation for haskell-webdriver is available on Hackage at <http://hackage.haskell.org/package/webdriver>. You can also generate local HTML documentation from this source revision with the following shell command:--```sh-runhaskell Setup.hs haddock-```--Haddock will generate documentation and save it in `dist/doc/html/webdriver`+Documentation for haskell-webdriver is available on Hackage at <http://hackage.haskell.org/package/webdriver>.
src/Test/WebDriver.hs view
@@ -1,42 +1,242 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ViewPatterns #-}+ {-|-This module serves as the top-level interface to the Haskell WebDriver bindings,-providing most of the functionality you're likely to want.++Once upon a time, the main browser automation tool was Selenium. Users of+this package had to start a Selenium session themselves, making sure to+configure it with a browser-specific driver program like @chromedriver@ or+@geckodriver@, and provide a hostname\/port. Then, this package would connect to+Selenium and use its wire protocol to control browsers.++Nowadays, there is an official W3C spec (<https://www.w3.org/TR/webdriver1>)+specifying the protocol, and a number of implementations. Selenium still exists,+but Chromedriver and Geckodriver can both serve as standalone WebDriver servers.+This library now helps you start up a driver in one of these supported+configurations:++1. Selenium.jar with one or more supported sub-drivers (@chromedriver@,+@geckodriver@). This is similar to the traditional picture.+2. Chromedriver standalone.+3. Geckodriver standalone.++You can pick the configuration you want by passing a 'DriverConfig' to the+'startSession' function. The WebDriver implementations have a few differences+between them, which this library tries to smooth over. For example, a single+Geckodriver instance can't start multiple Firefox sessions (see+<https://github.com/mozilla/geckodriver/issues/1946>). So, this library will spin+up a separate @geckodriver@ process for every session.+ -}  module Test.WebDriver (-  -- * WebDriver monad-  WD(..)-  -- * Running WebDriver commands-  , runSession, withSession, runWD-  -- * WebDriver configuration-  , WDConfig(..), defaultConfig-  -- ** Configuration helper functions-  -- | Instead of working with the 'Capabilities' record directly, you can use-  --   these config modifier functions to specify common options.-  , useBrowser, useProxy, useVersion, usePlatform-  -- ** Session history configuration-  , SessionHistoryConfig, noHistory, unlimitedHistory, onlyMostRecentHistory-  -- ** HTTP request header utilities-  , withRequestHeaders, withAuthHeaders-  -- * WebDriver commands+  -- * WebDriverContext+  WebDriverContext+  , mkEmptyWebDriverContext+  , teardownWebDriverContext++  -- * Managed sessions+  , startSession+  , closeSession+  , DriverConfig(..)++  -- * Lower-level session management+  , startSession'+  , closeSession'+  , mkManualDriver++  -- * Capabilities+  , defaultCaps+  , defaultChromeOptions+  , defaultFirefoxOptions+  , Capabilities(..)+  , Platform(..)+  , ProxyType(..)++  -- * Commands   , module Test.WebDriver.Commands-  -- * Capabilities (advanced configuration)-  , Capabilities(..), defaultCaps, allCaps, modifyCaps-  , Platform(..), ProxyType(..)-  -- ** Browser-specific capabilities-  , Browser(..), LogLevel(..)-  -- *** Browser defaults-  , firefox, chrome, ie, opera, iPhone, iPad, android-  -- * Exception handling-  , finallyClose, closeOnException++  , mkDriverRequest+  , _driverManager++  -- * WebDriver monad+  , WebDriver+  , WebDriverBase++  , Session++  -- * Exceptions   , module Test.WebDriver.Exceptions-  -- * Accessing session history-  , SessionHistory(..), getSessionHistory, dumpSessionHistory   ) where +import Data.Aeson as A+import Test.WebDriver.Capabilities+import Test.WebDriver.Capabilities.Proxy import Test.WebDriver.Commands-import Test.WebDriver.Config import Test.WebDriver.Exceptions-import Test.WebDriver.Monad-import Test.WebDriver.Session+import Test.WebDriver.JSON+import Test.WebDriver.LaunchDriver import Test.WebDriver.Types++import Data.Map as M+import Control.Monad.Catch (MonadMask)+import Control.Monad+import Control.Monad.IO.Class+import Data.String.Interpolate+import qualified Data.Text as T+import Test.WebDriver.Util.Aeson (aesonLookup)+import Control.Monad.Logger+import Network.HTTP.Client+import Network.HTTP.Types (RequestHeaders, statusCode)+import UnliftIO.Concurrent+import UnliftIO.Exception+++-- | Start a WebDriver session, with a given 'WebDriverContext' and+-- 'DriverConfig'.+--+-- You need to provide the WebDriver 'Capabilities' for the session. You should+-- make sure the browser-specific fields of your 'Capabilities' are filled in+-- correctly to match the given 'DriverConfig'. For example, if you're using+-- 'DriverConfigChromedriver', you should make sure to fill in+-- '_capabilitiesGoogChromeOptions' and in particular the '_chromeOptionsBinary'+-- field.++startSession :: (WebDriverBase m, MonadMask m, MonadLogger m) => WebDriverContext -> DriverConfig -> Capabilities -> String -> m Session+startSession wdc dc@(DriverConfigSeleniumJar {}) caps sessionName = do+  driver <- modifyMVar (_webDriverSelenium wdc) $ \maybeSelenium -> do+    driver <- maybe (launchDriver dc) return maybeSelenium+    return (Just driver, driver)++  launchSessionInDriver wdc driver caps sessionName+startSession wdc dc@(DriverConfigChromedriver {}) caps sessionName = do+  driver <- modifyMVar (_webDriverChromedriver wdc) $ \maybeChromedriver -> do+    driver <- maybe (launchDriver dc) return maybeChromedriver+    return (Just driver, driver)++  launchSessionInDriver wdc driver caps sessionName+startSession wdc dc@(DriverConfigGeckodriver {}) caps sessionName = do+  driver <- launchDriver dc+  onException (launchSessionInDriver wdc driver caps sessionName)+              (teardownDriver driver)++launchSessionInDriver :: (WebDriverBase m, MonadLogger m) => WebDriverContext -> Driver -> Capabilities -> String -> m Session+launchSessionInDriver wdc driver caps sessionName = do+  sess <- startSession' driver caps sessionName++  modifyMVar (_webDriverSessions wdc) $ \sessionMap ->+    case M.lookup sessionName sessionMap of+      Just _ -> throwIO SessionNameAlreadyExists+      Nothing -> return (M.insert sessionName sess sessionMap, sess)++-- | Lower-level version of 'startSession'. This one allows you to construct a+-- driver instance manually and pass it in. Does not manage process lifecycles.+startSession' :: (WebDriverBase m, MonadLogger m) => Driver -> Capabilities -> String -> m Session+startSession' driver caps sessionName = do+  response <- doCommandBase driver methodPost "/session" $ single "capabilities" $ single "alwaysMatch" caps++  if | statusCode (responseStatus response) == 200 -> do+         case A.eitherDecode (responseBody response) of+           Right x@(A.Object (aesonLookup "value" -> Just value@(A.Object (aesonLookup "sessionId" -> Just (A.String sessId))))) -> do+             logInfoN [i|Got capabilities from driver: #{A.encode x}|]++             let maybeWebSocketUrl = case value of+                   A.Object (aesonLookup "capabilities" -> Just (A.Object (aesonLookup "webSocketUrl" -> Just (A.String url)))) -> Just url+                   _ -> Nothing++             return $ Session {+               sessionDriver = driver+               , sessionId = SessionId sessId+               , sessionName = sessionName+               , sessionWebSocketUrl = T.unpack <$> maybeWebSocketUrl+               }+           _ -> throwIO $ SessionCreationResponseHadNoSessionId response+     | otherwise -> throwIO SessionNameAlreadyExists++-- | Close the given WebDriver session. This sends the @DELETE+-- \/session\/:sessionId@ command to the WebDriver API, and then shuts down the+-- process if necessary.+closeSession :: (WebDriverBase m, MonadLogger m) => WebDriverContext -> Session -> m ()+closeSession wdc sess@(Session {..}) = do+  closeSession' sess++  modifyMVar_ (_webDriverSessions wdc) (return . M.delete sessionName)++  case _driverConfig sessionDriver of+    DriverConfigGeckodriver {} -> teardownDriver sessionDriver+    _ -> return ()++-- | Close the given WebDriver session. This is a lower-level version of+-- 'closeSession', which manages the driver lifecycle for you. This version will+-- only issue the @DELETE \/session\/:sessionId@ command to the driver, but will+-- not shut driver processes.+closeSession' :: (WebDriverBase m, MonadLogger m) => Session -> m ()+closeSession' (Session { sessionId=(SessionId sessId), .. }) = do+  response <- doCommandBase sessionDriver methodDelete ("/session/" <> sessId) Null+  logInfoN [i|Close result: #{response}|]++-- | Create a manual 'Driver' to use with 'startSession''/'closeSession''.+mkManualDriver :: MonadIO m =>+  -- | Host name+  String+  -- | Port+  -> Int+  -- | Base HTTP path (use "\/wd\/hub" for Selenium)+  -> String+  -- | Headers to send with every request+  -> RequestHeaders+  -> m Driver+mkManualDriver hostname port basePath requestHeaders = do+  manager <- liftIO $ newManager defaultManagerSettings++  return $ Driver {+    _driverHostname = hostname+    , _driverPort = port+    , _driverBasePath = basePath+    , _driverRequestHeaders = requestHeaders+    , _driverManager = manager+    , _driverProcess = Nothing+    , _driverLogAsync = Nothing+    , _driverConfig = DriverConfigChromedriver "" [] "" "" -- Not used+    }++-- | Tear down all sessions and processes associated with a 'WebDriverContext'.+teardownWebDriverContext :: (WebDriverBase m, MonadLogger m) => WebDriverContext -> m ()+teardownWebDriverContext wdc@(WebDriverContext {..}) = do+  modifyMVar_ _webDriverSessions $ \sessions -> do+    forM_ [sess | (_, sess) <- M.toList sessions] $ \sess ->+      closeSession wdc sess+    return mempty++  modifyMVar_ _webDriverSelenium $ \case+    Nothing -> return Nothing+    Just driver -> teardownDriver driver >> return Nothing++  modifyMVar_ _webDriverChromedriver $ \case+    Nothing -> return Nothing+    Just driver -> teardownDriver driver >> return Nothing++-- -- | Set a temporary list of custom 'RequestHeaders' to use within the given action.+-- -- All previous custom headers are temporarily removed, and then restored at the end.+-- withRequestHeaders :: (SessionStatePut m) => RequestHeaders -> m a -> m a+-- withRequestHeaders _h _action = undefined -- do+--   -- withModifiedSession (\s -> s { wdSessRequestHeaders = h }) action++-- -- | Makes all webdriver HTTP requests in the given action use the session\'s auth headers, typically+-- -- configured by setting the 'wdAuthHeaders' config. This is useful if you want to temporarily use+-- -- the same auth headers you used for session creation with other HTTP requests.+-- withAuthHeaders :: (Monad m, SessionStatePut m) => m a -> m a+-- withAuthHeaders _wd = undefined -- do+--   -- authHeaders <- fmap wdSessAuthHeaders getSession+--   -- withRequestHeaders authHeaders wd++-- -- | A finalizer ensuring that the session is always closed at the end of+-- -- the given 'WD' action, regardless of any exceptions.+-- finallyClose :: (HasCallStack, WebDriver wd, MonadMask wd) => wd a -> wd a+-- finallyClose wd = closeOnException wd <* closeSession++-- -- | Exception handler that closes the session when an+-- -- asynchronous exception is thrown, but otherwise leaves the session open+-- -- if the action was successful.+-- closeOnException :: (HasCallStack, MonadMask wd) => WebDriver wd => wd a -> wd a+-- closeOnException wd = wd `onException` closeSession
src/Test/WebDriver/Capabilities.hs view
@@ -1,777 +1,192 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-}--module Test.WebDriver.Capabilities where--import Test.WebDriver.Chrome.Extension-import Test.WebDriver.Firefox.Profile-import Test.WebDriver.JSON--import Data.Aeson-import Data.Aeson.Types (Parser, typeMismatch, Pair)--import Data.Text (Text, toLower, toUpper)-import Data.Default (Default, def)-import Data.Word (Word16)-import Data.Maybe (fromMaybe, catMaybes)-import Data.String (fromString)--import Control.Applicative-import Control.Exception.Lifted (throw)--import Prelude -- hides some "unused import" warnings--#if MIN_VERSION_aeson(2,0,0)-import qualified Data.Aeson.KeyMap          as HM (delete, toList, empty)-#else-import qualified Data.HashMap.Strict        as HM (delete, toList, empty)-#endif----- |A typeclass for readable 'Capabilities'-class GetCapabilities t where-  getCaps :: t -> Capabilities--instance GetCapabilities Capabilities where-  getCaps = id---- |A typeclass for writable 'Capabilities'-class SetCapabilities t where-  setCaps :: Capabilities -> t -> t---- |Read/write 'Capabilities'-type HasCapabilities t = (GetCapabilities t, SetCapabilities t)---- |Modifies the 'wdCapabilities' field of a 'WDConfig' by applying the given function. Overloaded to work with any 'HasCapabilities' instance.-modifyCaps :: HasCapabilities t => (Capabilities -> Capabilities) -> t -> t-modifyCaps f c = setCaps (f (getCaps c)) c---- |A helper function for setting the 'browser' capability of a 'HasCapabilities' instance-useBrowser :: HasCapabilities t => Browser -> t -> t-useBrowser b = modifyCaps $ \c -> c { browser = b }---- |A helper function for setting the 'version' capability of a 'HasCapabilities' instance-useVersion :: HasCapabilities t => String -> t -> t-useVersion v = modifyCaps $ \c -> c { version = Just v }---- |A helper function for setting the 'platform' capability of a 'HasCapabilities' instance-usePlatform :: HasCapabilities t => Platform -> t -> t-usePlatform p = modifyCaps $ \c -> c { platform = p }+{-# LANGUAGE TemplateHaskell #-} --- |A helper function for setting the 'useProxy' capability of a 'HasCapabilities' instance-useProxy :: HasCapabilities t => ProxyType -> t -> t-useProxy p = modifyCaps $ \c -> c { proxy = p }+{-| +This module contains the types for working with WebDriver Capabilities.+Capabilities are used to configure and communicate the features supported by a+session. -{- |A structure describing the capabilities of a session. This record-serves dual roles.+Some settings, like '_capabilitiesTimeouts', are browser-agnostic. But the+'Capabilities' object is also where browser-specific settings can be added,+under '_capabilitiesGoogChromeOptions', '_capabilitiesMozFirefoxOptions', etc. -* It's used to specify the desired capabilities for a session before-it's created. In this usage, fields that are set to Nothing indicate-that we have no preference for that capability.+This module provides lenses for all of the fields it defines, to make it easier+to manipulate nested values. -* When received from the server , it's used to-describe the actual capabilities given to us by the WebDriver-server. Here a value of Nothing indicates that the server doesn't-support the capability. Thus, for Maybe Bool fields, both Nothing and-Just False indicate a lack of support for the desired capability. -}-data Capabilities =-  Capabilities { -- |Browser choice and browser specific settings.-                 browser                  :: Browser-                 -- |Browser version to use.-               , version                  :: Maybe String-                 -- |Platform on which the browser should run.-               , platform                 :: Platform-                 -- |Proxy configuration settings.-               , proxy                    :: ProxyType-                 -- |Whether the session supports executing JavaScript via-                 -- 'executeJS' and 'asyncJS'.-               , javascriptEnabled        :: Maybe Bool-                 -- |Whether the session supports taking screenshots of the-                 -- current page with the 'screenshot' command-               , takesScreenshot          :: Maybe Bool-                 -- |Whether the session can interact with modal popups,-                 -- such as window.alert and window.confirm via-                 -- 'acceptAlerts', 'dismissAlerts', etc.-               , handlesAlerts            :: Maybe Bool-                 -- |Whether the session can interact with database storage.-               , databaseEnabled          :: Maybe Bool-                 -- |Whether the session can set and query the browser's-                 -- location context with 'setLocation' and 'getLocation'.-               , locationContextEnabled   :: Maybe Bool-                 -- |Whether the session can interact with the application cache-                 -- .-               , applicationCacheEnabled  :: Maybe Bool-                 -- |Whether the session can query for the browser's-                 -- connectivity and disable it if desired-               , browserConnectionEnabled :: Maybe Bool-                 -- |Whether the session supports CSS selectors when searching-                 -- for elements.-               , cssSelectorsEnabled      :: Maybe Bool-                 -- |Whether Web Storage ('getKey', 'setKey', etc) support is-                 -- enabled-               , webStorageEnabled        :: Maybe Bool-                 -- |Whether the session can rotate the current page's current-                 -- layout between 'Portrait' and 'Landscape' orientations.-               , rotatable                :: Maybe Bool-                 -- |Whether the session should accept all SSL certs by default-               , acceptSSLCerts           :: Maybe Bool-                 -- |Whether the session is capable of generating native OS-                 -- events when simulating user input.-               , nativeEvents             :: Maybe Bool-                 -- |How the session should handle unexpected alerts.-               , unexpectedAlertBehavior :: Maybe UnexpectedAlertBehavior-                 -- |A list of ('Text', 'Value') pairs specifying additional non-standard capabilities.-               , additionalCaps           :: [Pair]-               } deriving (Eq, Show) -instance Default Capabilities where-  def = Capabilities { browser = firefox-                     , version = Nothing-                     , platform = Any-                     , javascriptEnabled = Nothing-                     , takesScreenshot = Nothing-                     , handlesAlerts = Nothing-                     , databaseEnabled = Nothing-                     , locationContextEnabled = Nothing-                     , applicationCacheEnabled = Nothing-                     , browserConnectionEnabled = Nothing-                     , cssSelectorsEnabled = Nothing-                     , webStorageEnabled = Nothing-                     , rotatable = Nothing-                     , acceptSSLCerts = Nothing-                     , nativeEvents = Nothing-                     , proxy = UseSystemSettings-                     , unexpectedAlertBehavior = Nothing-                     , additionalCaps = []-                     }+module Test.WebDriver.Capabilities (+  -- * Capabilities+  Capabilities(..)+  , defaultCaps --- |Default capabilities. This is the same as the 'Default' instance, but with--- less polymorphism. By default, we use 'firefox' of an unspecified 'version'--- with default system-wide 'proxy' settings on whatever 'platform' is available--- . All 'Maybe' capabilities are set to 'Nothing' (no preference).-defaultCaps :: Capabilities-defaultCaps = def+  -- ** Lenses+  , capabilitiesBrowserName+  , capabilitiesBrowserVersion+  , capabilitiesPlatformName+  , capabilitiesAcceptInsecureCerts+  , capabilitiesPageLoadStrategy+  , capabilitiesProxy+  , capabilitiesSetWindowRect+  , capabilitiesTimeouts+  , capabilitiesUnhandledPromptBehavior+  , capabilitiesGoogChromeOptions+  , capabilitiesMozFirefoxOptions+  , capabilitiesWebSocketUrl --- |Same as 'defaultCaps', but with all 'Maybe' 'Bool' capabilities set to--- 'Just' 'True'.-allCaps :: Capabilities-allCaps = defaultCaps { javascriptEnabled = Just True-                      , takesScreenshot = Just True-                      , handlesAlerts = Just True-                      , databaseEnabled = Just True-                      , locationContextEnabled = Just True-                      , applicationCacheEnabled = Just True-                      , browserConnectionEnabled = Just True-                      , cssSelectorsEnabled = Just True-                      , webStorageEnabled = Just True-                      , rotatable = Just True-                      , acceptSSLCerts = Just True-                      , nativeEvents = Just True-                      }+  -- ** Types+  , Timeouts(..)+  , UserPromptHandler(..)+  , Platform(..) -instance ToJSON Capabilities where-  toJSON Capabilities{..} =-    object $ filter (\p -> snd p /= Null)-           $ [ "browserName" .= browser-             , "version" .= version-             , "platform" .= platform-             , "proxy" .= proxy-             , "javascriptEnabled" .= javascriptEnabled-             , "takesScreenshot" .= takesScreenshot-             , "handlesAlerts" .= handlesAlerts-             , "databaseEnabled" .= databaseEnabled-             , "locationContextEnabled" .= locationContextEnabled-             , "applicationCacheEnabled" .= applicationCacheEnabled-             , "browserConnectionEnabled" .= browserConnectionEnabled-             , "cssSelectorsEnabled" .= cssSelectorsEnabled-             , "webStorageEnabled" .= webStorageEnabled-             , "rotatable" .= rotatable-             , "acceptSslCerts" .= acceptSSLCerts-             , "nativeEvents" .= nativeEvents-             , "unexpectedAlertBehavior" .= unexpectedAlertBehavior-             ]-    ++ browserInfo-    ++ additionalCaps-    where-      browserInfo = case browser of-        Firefox {..}-          -> ["firefox_profile" .= ffProfile-             ,"loggingPrefs" .= object ["driver" .= ffLogPref]-             ,"firefox_binary" .= ffBinary-             ,"acceptInsecureCerts" .= fromMaybe False ffAcceptInsecureCerts-             ]-        Chrome {..}-          -> catMaybes [ opt "chrome.chromedriverVersion" chromeDriverVersion ]-             ++ [ "chromeOptions" .= object (catMaybes-                  [ opt "binary" chromeBinary-                  ] ++-                  [ "args"       .= chromeOptions-                  , "extensions" .= chromeExtensions-                  ] ++ HM.toList chromeExperimentalOptions-                )]-        IE {..}-          -> ["ignoreProtectedModeSettings" .= ieIgnoreProtectedModeSettings-             ,"ignoreZoomSetting" .= ieIgnoreZoomSetting-             ,"initialBrowserUrl" .= ieInitialBrowserUrl-             ,"elementScrollBehavior" .= ieElementScrollBehavior-             ,"enablePersistentHover" .= ieEnablePersistentHover-             ,"enableElementCacheCleanup" .= ieEnableElementCacheCleanup-             ,"requireWindowFocus" .= ieRequireWindowFocus-             ,"browserAttachTimeout" .= ieBrowserAttachTimeout-             ,"logFile" .= ieLogFile-             ,"logLevel" .= ieLogLevel-             ,"host" .= ieHost-             ,"extractPath" .= ieExtractPath-             ,"silent" .= ieSilent-             ,"forceCreateProcess" .= ieForceCreateProcess-             ,"internetExplorerSwitches" .= ieSwitches-             ]-        Opera{..}-          -> catMaybes [ opt "opera.binary" operaBinary-                       , opt "opera.display" operaDisplay-                       , opt "opera.product" operaProduct-                       , opt "opera.launcher" operaLauncher-                       , opt "opera.host" operaHost-                       , opt "opera.logging.file" operaLogFile-                       ]-             ++ ["opera.detatch" .= operaDetach-                ,"opera.no_quit" .= operaDetach --backwards compatability-                ,"opera.autostart" .= operaAutoStart-                , "opera.idle" .= operaIdle-                -- ,"opera.profile" .= operaProfile-                ,"opera.port" .= fromMaybe maxBound {- (-1) -} operaPort-                 --note: consider replacing operaOptions with a list of options-                ,"opera.arguments" .= operaOptions-                ,"opera.logging.level" .= operaLogPref-                ]+  -- * Chrome+  , ChromeOptions(..)+  , defaultChromeOptions+  -- *** Lenses+  , chromeOptionsWindowTypes+  , chromeOptionsPrefs+  , chromeOptionsPerfLoggingPrefs+  , chromeOptionsMobileEmulation+  , chromeOptionsMinidumpPath+  , chromeOptionsLocalState+  , chromeOptionsExtensions+  , chromeOptionsExcludeSwitches+  , chromeOptionsDetach+  , chromeOptionsDebuggerAddress+  , chromeOptionsBinary+  , chromeOptionsArgs -        Phantomjs {..}-          -> catMaybes [ opt "phantomjs.binary.path" phantomjsBinary-                       ] ++-                       [ "phantomjs.cli.args" .= phantomjsOptions-                       ]+  -- ** Client hints+  , ChromeClientHints(..)+  , mkChromeClientHints+  , chromeClientHintsWow64+  , chromeClientHintsPlatformVersion+  , chromeClientHintsPlatform+  , chromeClientHintsModel+  , chromeClientHintsMobile+  , chromeClientHintsFullVersionList+  , chromeClientHintsBrands+  , chromeClientHintsBitness+  , chromeClientHintsArchitecture+  , BrandAndVersion(..) -        _ -> []+  -- ** Device metrics+  , ChromeDeviceMetrics(..)+  , chromeDeviceMetricsWidth+  , chromeDeviceMetricsTouch+  , chromeDeviceMetricsPixelRatio+  , chromeDeviceMetricsMobile+  , chromeDeviceMetricsHeight -        where-          opt k = fmap (k .=)+  -- ** Extensions+  , ChromeExtension+  , loadExtension+  , loadRawExtension +  -- ** Mobile emulation+  , ChromeMobileEmulation(..)+  , chromeMobileEmulationUserAgent+  , chromeMobileEmulationDeviceName+  , chromeMobileEmulationDeviceMetrics+  , chromeMobileEmulationClientHints -instance FromJSON Capabilities where-  parseJSON (Object o) = do-    browser <- req "browserName"-    Capabilities <$> getBrowserCaps browser-                 <*> opt "version" Nothing-                 <*> req "platform"-                 <*> opt "proxy" NoProxy-                 <*> b "javascriptEnabled"-                 <*> b "takesScreenshot"-                 <*> b "handlesAlerts"-                 <*> b "databaseEnabled"-                 <*> b "locationContextEnabled"-                 <*> b "applicationCacheEnabled"-                 <*> b "browserConnectionEnabled"-                 <*> b "cssSelectorEnabled"-                 <*> b "webStorageEnabled"-                 <*> b "rotatable"-                 <*> b "acceptSslCerts"-                 <*> b "nativeEvents"-                 <*> opt "unexpectedAlertBehaviour" Nothing-                 <*> pure (additionalCapabilities browser)+  -- * Firefox+  , FirefoxOptions(..)+  , emptyFirefoxOptions+  , defaultFirefoxOptions -    where --some helpful JSON accessor shorthands-          req :: FromJSON a => Text -> Parser a-          req = (o .:) . fromText  -- required field-          opt :: FromJSON a => Text -> a -> Parser a-          opt k d = o .:?? k .!= d -- optional field-          b :: Text -> Parser (Maybe Bool)-          b k = opt k Nothing     -- Maybe Bool field+  -- ** Lenses+  , firefoxOptionsProfile+  , firefoxOptionsPrefs+  , firefoxOptionsLog+  , firefoxOptionsBinary+  , firefoxOptionsArgs -          -- produce additionalCaps by removing known capabilities from the JSON object-          additionalCapabilities = HM.toList . foldr HM.delete o . knownCapabilities+  -- ** Log level+  , FirefoxLogLevel(..)+  , FirefoxLogLevelType(..)+  ) where -          knownCapabilities browser =-            [ "browserName", "version", "platform", "proxy"-            , "javascriptEnabled", "takesScreenshot", "handlesAlerts"-            , "databaseEnabled", "locationContextEnabled"-            , "applicationCacheEnabled", "browserConnectionEnabled"-            , "cssSelectorEnabled","webStorageEnabled", "rotatable"-            , "acceptSslCerts", "nativeEvents", "unexpectedBrowserBehaviour"]-            ++ case browser of-              Firefox {} -> ["firefox_profile", "loggingPrefs", "firefox_binary", "acceptInsecureCerts"]-              Chrome {} -> ["chrome.chromedriverVersion", "chrome.extensions", "chrome.switches", "chrome.extensions"]-              IE {} -> ["ignoreProtectedModeSettings", "ignoreZoomSettings", "initialBrowserUrl", "elementScrollBehavior"-                       ,"enablePersistentHover", "enableElementCacheCleanup", "requireWindowFocus", "browserAttachTimeout"-                       ,"logFile", "logLevel", "host", "extractPath", "silent", "forceCreateProcess", "internetExplorerSwitches"]-              Opera {} -> ["opera.binary", "opera.product", "opera.no_quit", "opera.autostart", "opera.idle", "opera.display"-                          ,"opera.launcher", "opera.port", "opera.host", "opera.arguments", "opera.logging.file", "opera.logging.level"]-              _ -> []-          getBrowserCaps browser =-            case browser of-              Firefox {} -> Firefox <$> opt "firefox_profile" Nothing-                                    <*> opt "loggingPrefs" def-                                    <*> opt "firefox_binary" Nothing-                                    <*> opt "acceptInsecureCerts" Nothing-              Chrome {} -> Chrome <$> opt "chrome.chromedriverVersion" Nothing-                                  <*> opt "chrome.binary" Nothing-                                  <*> opt "chrome.switches" []-                                  <*> opt "chrome.extensions" []-                                  <*> pure HM.empty-              IE {} -> IE <$> opt "ignoreProtectedModeSettings" True-                          <*> opt "ignoreZoomSettings" False-                          <*> opt "initialBrowserUrl" Nothing-                          <*> opt "elementScrollBehavior" def-                          <*> opt "enablePersistentHover" True-                          <*> opt "enableElementCacheCleanup" True-                          <*> opt "requireWindowFocus" False-                          <*> opt "browserAttachTimeout" 0-                          <*> opt "logFile" Nothing-                          <*> opt "logLevel" def-                          <*> opt "host" Nothing-                          <*> opt "extractPath" Nothing-                          <*> opt "silent" False-                          <*> opt "forceCreateProcess" False-                          <*> opt "internetExplorerSwitches" Nothing-              Opera {} -> Opera <$> opt "opera.binary" Nothing-                                <*> opt "opera.product" Nothing-                                <*> opt "opera.no_quit" False-                                <*> opt "opera.autostart" True-                                <*> opt "opera.idle" False-                                <*> opt "opera.display" Nothing-                                <*> opt "opera.launcher" Nothing-                                <*> opt "opera.port" (Just 0)-                                <*> opt "opera.host" Nothing-                                <*> opt "opera.arguments" Nothing-                                <*> opt "opera.logging.file" Nothing-                                <*> opt "opera.logging.level" def-              _ -> return browser+import Data.Aeson.TH+import Lens.Micro.TH+import Test.WebDriver.Capabilities.Aeson+import Test.WebDriver.Capabilities.ChromeOptions+import Test.WebDriver.Capabilities.FirefoxOptions+import Test.WebDriver.Capabilities.Platform+import Test.WebDriver.Capabilities.Proxy+import Test.WebDriver.Capabilities.Timeouts+import Test.WebDriver.Capabilities.UserPromptHandler -  parseJSON v = typeMismatch "Capabilities" v --- |This constructor simultaneously specifies which browser the session will--- use, while also providing browser-specific configuration. Default--- configuration is provided for each browser by 'firefox', 'chrome', 'opera',--- 'ie', etc.+-- | A structure describing the capabilities of a session. This record+-- serves dual roles. ----- This library uses 'firefox' as its 'Default' browser configuration, when no--- browser choice is specified.-data Browser = Firefox { -- |The firefox profile to use. If Nothing,-                         -- a default temporary profile is automatically created-                         -- and used.-                         ffProfile :: Maybe (PreparedProfile Firefox)-                         -- |Firefox logging preference-                       , ffLogPref :: LogLevel-                         -- |Server-side path to Firefox binary. If Nothing,-                         -- use a sensible system-based default.-                       , ffBinary :: Maybe FilePath-                         -- |Available after Firefox 52, and required only for Firefox-                         -- geckodriver. Indicates whether untrusted and self-signed TLS-                         -- certificates are implicitly trusted on navigation for the-                         -- duration of the session.-                       , ffAcceptInsecureCerts :: Maybe Bool-                       }-             | Chrome { -- |Version of the Chrome Webdriver server server to use-                        ---                        -- for more information on chromedriver see-                        -- <https://github.com/SeleniumHQ/selenium/wiki/ChromeDriver>-                        chromeDriverVersion :: Maybe String-                        -- |Server-side path to Chrome binary. If Nothing,-                        -- use a sensible system-based default.-                      , chromeBinary :: Maybe FilePath-                        -- |A list of command-line options to pass to the-                        -- Chrome binary.-                      , chromeOptions :: [String]-                        -- |A list of extensions to use.-                      , chromeExtensions :: [ChromeExtension]-                        -- | Experimental options not yet exposed through a standard API.-                      , chromeExperimentalOptions :: Object-                      }-             | IE { -- |Whether to skip the protected mode check. If set, tests-                    -- may become flaky, unresponsive, or browsers may hang. If-                    -- not set, and protected mode settings are not the same for-                    -- all zones, an exception will be thrown on driver-                    -- construction.-                    ieIgnoreProtectedModeSettings :: Bool-                    -- |Indicates whether to skip the check that the browser's zoom-                    -- level is set to 100%. Value is set to false by default.-                  , ieIgnoreZoomSetting :: Bool-                    -- |Allows the user to specify the initial URL loaded when IE-                    -- starts. Intended to be used with ignoreProtectedModeSettings-                    -- to allow the user to initialize IE in the proper Protected Mode-                    -- zone. Using this capability may cause browser instability or-                    -- flaky and unresponsive code. Only \"best effort\" support is-                    -- provided when using this capability.-                  , ieInitialBrowserUrl :: Maybe Text-                    -- |Allows the user to specify whether elements are scrolled into-                    -- the viewport for interaction to align with the top or bottom-                    -- of the viewport. The default value is to align with the top of-                    -- the viewport.-                  , ieElementScrollBehavior :: IEElementScrollBehavior-                    -- |Determines whether persistent hovering is enabled (true by-                    -- default). Persistent hovering is achieved by continuously firing-                    -- mouse over events at the last location the mouse cursor has been-                    -- moved to.-                  , ieEnablePersistentHover :: Bool-                    -- |Determines whether the driver should attempt to remove obsolete-                    -- elements from the element cache on page navigation (true by-                    -- default). This is to help manage the IE driver's memory footprint-                    -- , removing references to invalid elements.-                  , ieEnableElementCacheCleanup :: Bool-                    -- |Determines whether to require that the IE window have focus-                    -- before performing any user interaction operations (mouse or-                    -- keyboard events). This capability is false by default, but-                    -- delivers much more accurate native events interactions.-                  , ieRequireWindowFocus :: Bool-                    -- |The timeout, in milliseconds, that the driver will attempt to-                    -- locate and attach to a newly opened instance of Internet Explorer-                    -- . The default is zero, which indicates waiting indefinitely.-                  , ieBrowserAttachTimeout :: Integer-                    -- |The path to file where server should write log messages to.-                    -- By default it writes to stdout.-                  , ieLogFile :: Maybe FilePath-                    -- |The log level used by the server. Defaults to 'IELogFatal'-                  , ieLogLevel :: IELogLevel-                    -- |The address of the host adapter on which the server will listen-                    -- for commands.-                  , ieHost :: Maybe Text-                    -- |The path to the directory used to extract supporting files used-                    -- by the server. Defaults to the TEMP directory if not specified.-                  , ieExtractPath :: Maybe Text-                    -- |Suppresses diagnostic output when the server is started.-                  , ieSilent :: Bool-                    -- |Forces launching Internet Explorer using the CreateProcess API.-                    -- If this option is not specified, IE is launched using the-                    -- IELaunchURL, if it is available. For IE 8 and above, this option-                    -- requires the TabProcGrowth registry value to be set to 0.-                  , ieForceCreateProcess :: Bool-                    -- |Specifies command-line switches with which to launch Internet-                    -- Explorer. This is only valid when used with the-                    -- forceCreateProcess.-                  , ieSwitches :: Maybe Text-                  }-             | Opera { -- |Server-side path to the Opera binary-                       operaBinary    :: Maybe FilePath-                     --, operaNoRestart :: Maybe Bool-                       -- |Which Opera product we're using, e.g. \"desktop\",-                       -- \"core\"-                     , operaProduct   :: Maybe String-                       -- |Whether the Opera instance should stay open after-                       -- we close the session. If false, closing the session-                       -- closes the browser.-                     , operaDetach    :: Bool-                       -- |Whether to auto-start the Opera binary. If false,-                       -- OperaDriver will wait for a connection from the-                       -- browser. By default this is True.-                     , operaAutoStart :: Bool-                       -- |Whether to use Opera's alternative implicit wait-                       -- implementation. It will use an in-browser heuristic-                       -- to guess when a page has finished loading. This-                       -- feature is experimental, and disabled by default.-                     , operaIdle      :: Bool-                       -- |(*nix only) which X display to use.-                     , operaDisplay   :: Maybe Int-                     --, operaProfile   :: Maybe (PreparedProfile Opera)-                       -- |Path to the launcher binary to use. The launcher-                       -- is a gateway between OperaDriver and the Opera-                       -- browser. If Nothing, OperaDriver will use the-                       -- launcher supplied with the package.-                     , operaLauncher  :: Maybe FilePath-                       -- |The port we should use to connect to Opera. If Just 0-                       -- , use a random port. If Nothing, use the default-                       -- Opera port. The default 'opera' constructor uses-                       -- Just 0, since Nothing is likely to cause "address-                       -- already in use" errors.-                     , operaPort      :: Maybe Word16-                       -- |The host Opera should connect to. Unless you're-                       -- starting Opera manually you won't need this.-                     , operaHost      :: Maybe String-                       -- |Command-line arguments to pass to Opera.-                     , operaOptions   :: Maybe String-                       -- |Where to send the log output. If Nothing, logging is-                       -- disabled.-                     , operaLogFile   :: Maybe FilePath-                       -- |Log level preference. Defaults to 'LogInfo'-                     , operaLogPref   :: LogLevel-                     }--             | Phantomjs { phantomjsBinary  :: Maybe FilePath-                         , phantomjsOptions :: [String]-                         }--             | HTMLUnit-             | IPhone-             | IPad-             | Android-             -- |some other browser, specified by a string name-             | Browser Text-             deriving (Eq, Show)--instance Default Browser where-  def = firefox---instance ToJSON Browser where-  toJSON Firefox {}   = String "firefox"-  toJSON Chrome {}    = String "chrome"-  toJSON Opera {}     = String "opera"-  toJSON IE {}        = String "internet explorer"-  toJSON Phantomjs {} = String "phantomjs"-  toJSON (Browser b)  = String b-  toJSON b            = String . toLower . fromString . show $ b--instance FromJSON Browser where-  parseJSON (String jStr) = case toLower jStr of-    "firefox"           -> return firefox-    "chrome"            -> return chrome-    "internet explorer" -> return ie-    "opera"             -> return opera-    "phantomjs"         -> return phantomjs-    -- "safari"            -> return safari-    "iphone"            -> return iPhone-    "ipad"              -> return iPad-    "android"           -> return android-    "htmlunit"          -> return htmlUnit-    other               -> return (Browser other)-  parseJSON v = typeMismatch "Browser" v----- |Default Firefox settings. All Maybe fields are set to Nothing. ffLogPref--- is set to 'LogInfo'.-firefox :: Browser-firefox = Firefox Nothing def Nothing Nothing---- |Default Chrome settings. All Maybe fields are set to Nothing, no options are--- specified, and no extensions are used.-chrome :: Browser-chrome = Chrome Nothing Nothing [] [] HM.empty---- |Default IE settings. See the 'IE' constructor for more details on--- individual defaults-ie :: Browser-ie = IE { ieIgnoreProtectedModeSettings = True-        , ieIgnoreZoomSetting = False-        , ieInitialBrowserUrl = Nothing-        , ieElementScrollBehavior = def-        , ieEnablePersistentHover = True-        , ieEnableElementCacheCleanup = True-        , ieRequireWindowFocus = False-        , ieBrowserAttachTimeout = 0-        , ieLogFile = Nothing-        , ieLogLevel = def-        , ieHost = Nothing-        , ieExtractPath = Nothing-        , ieSilent = False-        , ieForceCreateProcess = False-        , ieSwitches = Nothing-        }---- |Default Opera settings. See the 'Opera' constructor for more details on--- individual defaults.-opera :: Browser-opera = Opera { operaBinary = Nothing-              --, operaNoRestart = Nothing-              , operaProduct = Nothing-              , operaDetach = False-              , operaAutoStart = True-              , operaDisplay = Nothing-              , operaIdle = False---              , operaProfile = Nothing-              , operaLauncher = Nothing-              , operaHost = Nothing-              , operaPort = Just 0-              , operaOptions = Nothing-              , operaLogFile = Nothing-              , operaLogPref = def-              }--phantomjs :: Browser-phantomjs = Phantomjs Nothing []----safari :: Browser---safari = Safari--htmlUnit :: Browser-htmlUnit = HTMLUnit--iPhone :: Browser-iPhone = IPhone--iPad :: Browser-iPad = IPad--android :: Browser-android = Android---- |Represents platform options supported by WebDriver. The value Any represents--- no preference.-data Platform = Windows | XP | Vista | Mac | Linux | Unix | Any-              deriving (Eq, Show, Ord, Bounded, Enum)--instance ToJSON Platform where-  toJSON = String . toUpper . fromString . show--instance FromJSON Platform where-  parseJSON (String jStr) = case toLower jStr of-    "windows" -> return Windows-    "xp"      -> return XP-    "vista"   -> return Vista-    "mac"     -> return Mac-    "linux"   -> return Linux-    "unix"    -> return Unix-    "any"     -> return Any-    err -> fail $ "Invalid Platform string " ++ show err-  parseJSON v = typeMismatch "Platform" v---- |Available settings for the proxy 'Capabilities' field-data ProxyType = NoProxy-               | UseSystemSettings-               | AutoDetect-                 -- |Use a proxy auto-config file specified by URL-               | PAC { autoConfigUrl :: String }-                 -- |Manually specify proxy hosts as hostname:port strings.-                 -- Note that behavior is undefined for empty strings.-               | Manual { ftpProxy  :: String-                        , sslProxy  :: String-                        , httpProxy :: String-                        }-               deriving (Eq, Show)--instance FromJSON ProxyType where-  parseJSON (Object obj) = do-    pTyp <- f "proxyType"-    case toLower pTyp of-      "direct" -> return NoProxy-      "system" -> return UseSystemSettings-      "pac"    -> PAC <$> f "autoConfigUrl"-      "manual" -> Manual <$> f "ftpProxy"-                         <*> f "sslProxy"-                         <*> f "httpProxy"-      _ -> fail $ "Invalid ProxyType " ++ show pTyp-    where-      f :: FromJSON a => Text -> Parser a-      f = (obj .:) . fromText-  parseJSON v = typeMismatch "ProxyType" v--instance ToJSON ProxyType where-  toJSON pt = object $ case pt of-    NoProxy ->-      ["proxyType" .= ("DIRECT" :: String)]-    UseSystemSettings ->-      ["proxyType" .= ("SYSTEM" :: String)]-    AutoDetect ->-      ["proxyType" .= ("AUTODETECT" :: String)]-    PAC{autoConfigUrl = url} ->-      ["proxyType" .= ("PAC" :: String)-      ,"proxyAutoconfigUrl" .= url-      ]-    Manual{ftpProxy = ftp, sslProxy = ssl, httpProxy = http} ->-      ["proxyType" .= ("MANUAL" :: String)-      ,"ftpProxy"  .= ftp-      ,"sslProxy"  .= ssl-      ,"httpProxy" .= http-      ]--data UnexpectedAlertBehavior = AcceptAlert | DismissAlert | IgnoreAlert-                              deriving (Bounded, Enum, Eq, Ord, Read, Show)--instance ToJSON UnexpectedAlertBehavior where-  toJSON AcceptAlert  = String "accept"-  toJSON DismissAlert = String "dismiss"-  toJSON IgnoreAlert  = String "ignore"--instance FromJSON UnexpectedAlertBehavior where-  parseJSON (String s) =-    return $ case s of-      "accept"  -> AcceptAlert-      "dismiss" -> DismissAlert-      "ignore"  -> IgnoreAlert-      err       -> throw . BadJSON-                   $ "Invalid string value for UnexpectedAlertBehavior: " ++ show err-  parseJSON v = typeMismatch "UnexpectedAlertBehavior" v---- |Indicates a log verbosity level. Used in 'Firefox' and 'Opera' configuration.-data LogLevel = LogOff | LogSevere | LogWarning | LogInfo | LogConfig-              | LogFine | LogFiner | LogFinest | LogDebug | LogAll-             deriving (Eq, Show, Read, Ord, Bounded, Enum)+-- It's used to specify the desired capabilities for a session before+-- it's created. In this usage, fields that are set to Nothing indicate+-- that we have no preference for that capability.+--+-- When received from the server , it's used to describe the actual+-- capabilities given to us by the WebDriver server. Here a value of+-- Nothing indicates that the server doesn't support the capability.+-- Thus, for Maybe Bool fields, both Nothing and Just False indicate+-- a lack of support for the desired capability.+data Capabilities = Capabilities {+  -- | Identifies the user agent.+  _capabilitiesBrowserName :: Maybe String+  -- | Identifies the version of the user agent.+  , _capabilitiesBrowserVersion :: Maybe String+  -- | Identifies the operating system of the endpoint node.+  , _capabilitiesPlatformName :: Maybe Platform+  -- | Indicates whether untrusted and self-signed TLS certificates are implicitly trusted on navigation for the+  -- duration of the session.+  , _capabilitiesAcceptInsecureCerts :: Maybe Bool+  -- | Defines the current session’s page load strategy.+  , _capabilitiesPageLoadStrategy :: Maybe String+  -- | Defines the current session’s proxy configuration.+  , _capabilitiesProxy :: Maybe Proxy+  -- | Indicates whether the remote end supports all of the commands in Resizing and Positioning Windows.+  , _capabilitiesSetWindowRect :: Maybe Bool+  -- | Describes the timeouts imposed on certain session operations.+  , _capabilitiesTimeouts :: Maybe Timeouts+  -- | Describes the current session’s user prompt handler.+  , _capabilitiesUnhandledPromptBehavior :: Maybe UserPromptHandler -instance Default LogLevel where-  def = LogInfo+  -- * Vendor-specific stuff+  -- | Chrome options+  , _capabilitiesGoogChromeOptions :: Maybe ChromeOptions+  -- | Firefox options+  , _capabilitiesMozFirefoxOptions :: Maybe FirefoxOptions -instance ToJSON LogLevel where-  toJSON p= String $ case p of-    LogOff -> "OFF"-    LogSevere -> "SEVERE"-    LogWarning -> "WARNING"-    LogInfo -> "INFO"-    LogConfig -> "CONFIG"-    LogFine -> "FINE"-    LogFiner -> "FINER"-    LogFinest -> "FINEST"-    LogDebug -> "DEBUG"-    LogAll -> "ALL"+  , _capabilitiesWebSocketUrl :: Maybe Bool -instance FromJSON LogLevel where-  parseJSON (String s) = return $ case s of-    "OFF" -> LogOff-    "SEVERE" -> LogSevere-    "WARNING" -> LogWarning-    "INFO" -> LogInfo-    "CONFIG" -> LogConfig-    "FINE" -> LogFine-    "FINER" -> LogFiner-    "FINEST" -> LogFinest-    "DEBUG" -> LogDebug-    "ALL" -> LogAll-    _ -> throw . BadJSON $ "Invalid logging preference: " ++ show s-  parseJSON other = typeMismatch "LogLevel" other+  } deriving (Eq, Show)+deriveJSON capabilitiesOptions ''Capabilities+makeLenses ''Capabilities +-- | Default capabilities.+defaultCaps :: Capabilities+defaultCaps = Capabilities {+  _capabilitiesBrowserName = Nothing+  , _capabilitiesBrowserVersion = Nothing --- |Logging levels for Internet Explorer-data IELogLevel = IELogTrace | IELogDebug | IELogInfo | IELogWarn | IELogError-                | IELogFatal-                deriving (Eq, Show, Read, Ord, Bounded, Enum)+  , _capabilitiesPlatformName = Nothing -instance Default IELogLevel where-  def = IELogFatal+  , _capabilitiesAcceptInsecureCerts = Nothing +  , _capabilitiesPageLoadStrategy = Nothing -instance ToJSON IELogLevel where-  toJSON p= String $ case p of-    IELogTrace -> "TRACE"-    IELogDebug -> "DEBUG"-    IELogInfo -> "INFO"-    IELogWarn -> "WARN"-    IELogError -> "ERROR"-    IELogFatal -> "FATAL"+  , _capabilitiesProxy = Nothing -instance FromJSON IELogLevel where-  parseJSON (String s) = return $ case s of-    "TRACE" -> IELogTrace-    "DEBIG" -> IELogDebug-    "INFO"  -> IELogInfo-    "WARN"  -> IELogWarn-    "ERROR" -> IELogError-    "FATAL" -> IELogFatal-    _ -> throw . BadJSON $ "Invalid logging preference: " ++ show s-  parseJSON other = typeMismatch "IELogLevel" other+  , _capabilitiesSetWindowRect = Nothing --- |Specifies how elements scroll into the viewport. (see 'ieElementScrollBehavior')-data IEElementScrollBehavior = AlignTop | AlignBottom-                             deriving (Eq, Ord, Show, Read, Enum, Bounded)+  , _capabilitiesTimeouts = Nothing -instance Default IEElementScrollBehavior where-  def = AlignTop+  , _capabilitiesUnhandledPromptBehavior = Nothing -instance ToJSON IEElementScrollBehavior where-  toJSON AlignTop    = toJSON (0 :: Int)-  toJSON AlignBottom = toJSON (1 :: Int)+  , _capabilitiesGoogChromeOptions = Nothing+  , _capabilitiesMozFirefoxOptions = Nothing -instance FromJSON IEElementScrollBehavior where-  parseJSON v = do-    n <- parseJSON v-    case n :: Integer of-      0 -> return AlignTop-      1 -> return AlignBottom-      _ -> fail $ "Invalid integer for IEElementScrollBehavior: " ++ show n+  , _capabilitiesWebSocketUrl = Nothing+  }
+ src/Test/WebDriver/Capabilities/Aeson.hs view
@@ -0,0 +1,93 @@++module Test.WebDriver.Capabilities.Aeson where++import Data.Aeson as A+import Data.Char+import Data.Function+import qualified Data.List as L+++baseOptions :: A.Options+baseOptions = A.defaultOptions { omitNothingFields = True }++toCamel1, toCamel2, toCamel3 :: A.Options+toCamel1 = baseOptions { A.fieldLabelModifier = snakeToCamelCase . toSnakeAndDropN 1 . dropLeadingUnderscore }+toCamel2 = baseOptions { A.fieldLabelModifier = snakeToCamelCase . toSnakeAndDropN 2 . dropLeadingUnderscore }+toCamel3 = baseOptions { A.fieldLabelModifier = snakeToCamelCase . toSnakeAndDropN 3 . dropLeadingUnderscore }++toCamelC1, toCamelC2, toCamelC3, toCamelC4 :: A.Options+toCamelC1 = baseOptions { A.constructorTagModifier = snakeToCamelCase . toSnakeAndDropN 1 }+toCamelC2 = baseOptions { A.constructorTagModifier = snakeToCamelCase . toSnakeAndDropN 2 }+toCamelC3 = baseOptions { A.constructorTagModifier = snakeToCamelCase . toSnakeAndDropN 3 }+toCamelC4 = baseOptions { A.constructorTagModifier = snakeToCamelCase . toSnakeAndDropN 4 }++-- | For 'UserPromptHandler', which maps things like+-- UserPromptHandlerAcceptAndNotify -> "accept and notify"+toSpacedC3 :: A.Options+toSpacedC3 = baseOptions { A.constructorTagModifier = snakeToSpaced . toSnakeAndDropN 3 }++-- | For FailedCommandError+toSpacedC0 :: A.Options+toSpacedC0 = baseOptions {+  A.constructorTagModifier = snakeToSpaced . toSnakeAndDropN 0+  , A.sumEncoding = A.UntaggedValue+  }++capabilitiesOptions :: A.Options+capabilitiesOptions = baseOptions {+  A.fieldLabelModifier = specialCases . snakeToCamelCase . toSnakeAndDropN 1 . dropLeadingUnderscore+  }+  where+    specialCases "googChromeOptions" = "goog:chromeOptions"+    specialCases "mozFirefoxOptions" = "moz:firefoxOptions"+    specialCases x = x+++-- * Util++toSnakeAndDropN :: Int -> String -> String+toSnakeAndDropN n s = L.intercalate "_" snakeParts+  where+    snakeParts :: [String]+    snakeParts = s+                 & dropLeadingUnderscore+                 & splitR isUpper+                 & L.drop n+                 & fmap (fmap toLower)++splitR :: (Char -> Bool) -> String -> [String]+splitR _ [] = []+splitR p s =+  let+    go :: Char -> String -> [String]+    go m s' = case L.break p s' of+      (b', [])     -> [ m:b' ]+      (b', x:xs) -> ( m:b' ) : go x xs+  in case L.break p s of+    (b,  [])    -> [ b ]+    ([], h:t) -> go h t+    (b,  h:t) -> b : go h t++snakeToCamelCase :: String -> String+snakeToCamelCase s = case parts of+  (x:xs) -> x <> concatMap capitalize xs+  [] -> ""+  where+    parts = case splitR (== '_') s of+      (x:xs) -> x : (fmap (L.drop 1) xs)+      [] -> []++snakeToSpaced :: String -> String+snakeToSpaced s = L.intercalate " " parts+  where+    parts = case splitR (== '_') s of+      (x:xs) -> x : (fmap (L.drop 1) xs)+      [] -> []++dropLeadingUnderscore :: [Char] -> [Char]+dropLeadingUnderscore ('_':xs) = xs+dropLeadingUnderscore xs = xs++capitalize :: String -> String+capitalize (x:xs) = toUpper x : (fmap toLower xs)+capitalize x = x
+ src/Test/WebDriver/Capabilities/ChromeOptions.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}++module Test.WebDriver.Capabilities.ChromeOptions where++import Control.Monad.IO.Class+import Data.Aeson+import Data.Aeson as A+import Data.Aeson.TH+import Data.ByteString.Base64.Lazy as B64+import Data.ByteString.Lazy as LBS+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy.Encoding (decodeLatin1)+import Lens.Micro.TH+import Test.WebDriver.Capabilities.Aeson+++-- | See https://developer.chrome.com/docs/chromedriver/mobile-emulation+data ChromeDeviceMetrics = ChromeDeviceMetrics {+  -- | The width in pixels of the device's screen.+  _chromeDeviceMetricsWidth :: Maybe Int+  -- | The height in pixels of the device's screen.+  , _chromeDeviceMetricsHeight :: Maybe Int+  -- | The device's pixel ratio.+  , _chromeDeviceMetricsPixelRatio :: Maybe Double+  -- | Whether to emulate touch events. The value defaults to true and usually+  -- can be omitted.+  , _chromeDeviceMetricsTouch :: Maybe Bool+  -- | Whether the browser must behave as a mobile user agent (overlay+  -- scrollbars, emit orientation events, shrink the content to fit the+  -- viewport, etc.). The value defaults to true and usually can be omitted.+  , _chromeDeviceMetricsMobile :: Maybe Bool+  } deriving (Show, Eq)+deriveJSON toCamel3 ''ChromeDeviceMetrics+makeLenses ''ChromeDeviceMetrics++data BrandAndVersion = BrandAndVersion {+  brandAndVersionBrand :: String+  , brandAndVersionVersion :: String+  } deriving (Show, Eq)+deriveJSON toCamel3 ''BrandAndVersion+makeLenses ''BrandAndVersion++-- | See https://developer.chrome.com/docs/chromedriver/mobile-emulation+data ChromeClientHints = ChromeClientHints {+  -- | The operating system. It can be either a known value ("Android", "Chrome+  -- OS", "Chromium OS", "Fuchsia", "Linux", "macOS", "Windows"), that exactly+  -- matches the value returned by Chrome running on the given platform, or it+  -- can be a user defined value. This value is mandatory.+  _chromeClientHintsPlatform :: String+  -- | Whether the browser should request a mobile or desktop resource version.+  -- Usually Chrome running on a mobile phone with Android sets this value to+  -- true. Chrome on a tablet Android device sets this value to false. Chrome on+  -- a desktop device also sets this value to false. You can use this+  -- information to specify a realistic emulation. This value is mandatory.+  , _chromeClientHintsMobile :: Bool+  -- | List of brand / major version pairs. If omitted the browser uses its own+  -- values.+  , _chromeClientHintsBrands :: Maybe [BrandAndVersion]+  -- | List of brand / version pairs. It omitted the browser uses its own+  -- values.+  , _chromeClientHintsFullVersionList :: Maybe [BrandAndVersion]+  -- | OS version. Defaults to empty string.+  , _chromeClientHintsPlatformVersion :: Maybe String+  -- | Device model. Defaults to empty string.+  , _chromeClientHintsModel :: Maybe String+  -- | CPU architecture. Known values are "x86" and "arm". The user is free to+  -- provide any string value. Defaults to empty string.+  , _chromeClientHintsArchitecture :: Maybe String+  -- | Platform bitness. Known values are "32" and "64". The user is free to+  -- provide any string value. Defaults to empty string.+  , _chromeClientHintsBitness :: Maybe String+  -- | Emulation of windows 32 on windows 64. A boolean value that defaults to+  -- false.+  , _chromeClientHintsWow64 :: Maybe Bool+  } deriving (Show, Eq)+deriveJSON toCamel3 ''ChromeClientHints+makeLenses ''ChromeClientHints+mkChromeClientHints :: String -> Bool -> ChromeClientHints+mkChromeClientHints platform mobile = ChromeClientHints {+  _chromeClientHintsPlatform = platform+  , _chromeClientHintsMobile = mobile+  , _chromeClientHintsBrands = Nothing+  , _chromeClientHintsFullVersionList = Nothing+  , _chromeClientHintsPlatformVersion = Nothing+  , _chromeClientHintsModel = Nothing+  , _chromeClientHintsArchitecture = Nothing+  , _chromeClientHintsBitness = Nothing+  , _chromeClientHintsWow64 = Nothing+  }++-- | See https://developer.chrome.com/docs/chromedriver/mobile-emulation+data ChromeMobileEmulation =+  -- | Specify a known device. To enable device emulation with a specific+  -- device, the "mobileEmulation" dictionary must contain a "deviceName." Use a+  -- valid device name from the DevTools Emulated Devices settings as the value+  -- for "deviceName."+  ChromeMobileEmulationSpecificDevice {+    _chromeMobileEmulationDeviceName :: String+  }+  -- | Specify individual device attributes.+  | ChromeMobileEmulationIndividualAttributes {+      _chromeMobileEmulationDeviceMetrics :: Maybe ChromeDeviceMetrics+      , _chromeMobileEmulationClientHints :: Maybe ChromeClientHints+      -- | ChromeDriver is capable to infer "userAgent" value from "clientHints" on+      -- the following platforms: "Android", "Chrome OS", "Chromium OS", "Fuchsia",+      -- "Linux", "macOS", "Windows". Therefore this value can be omitted.+      --+      -- If "clientHints" dictionary is omitted (legacy mode) ChromeDriver does its+      -- best to infer the "clientHints" from "userAgent". This feature is not+      -- reliable, due to internal ambiguities of "userAgent" value format.+      , _chromeMobileEmulationUserAgent :: Maybe String+      }+  deriving (Show, Eq)+deriveJSON (toCamel3 { sumEncoding = UntaggedValue }) ''ChromeMobileEmulation+makeLenses ''ChromeMobileEmulation++-- | A packed Google Chrome extension (.crx), as base64-encoded 'Text'.+newtype ChromeExtension = ChromeExtension TL.Text+  deriving (Eq, Show, Read, ToJSON, FromJSON)++-- | Load a .crx file as a 'ChromeExtension'.+loadExtension :: MonadIO m => FilePath -> m ChromeExtension+loadExtension path = liftIO $ loadRawExtension <$> LBS.readFile path++-- | Load raw .crx data as a 'ChromeExtension'.+loadRawExtension :: ByteString -> ChromeExtension+loadRawExtension = ChromeExtension . decodeLatin1 . B64.encode++-- | See https://developer.chrome.com/docs/chromedriver/capabilities#chromeoptions_object+data ChromeOptions = ChromeOptions {+  -- | List of command-line arguments to use when starting Chrome. Arguments with an associated value should be separated+  -- by a '=' sign (such as, ['start-maximized', 'user-data-dir=/tmp/temp_profile']). See a list of Chrome arguments:+  -- https://peter.sh/experiments/chromium-command-line-switches/+  _chromeOptionsArgs :: Maybe [String]+  -- | Path to the Chrome executable to use. On macOS X, this should be the actual binary, not just the app, such as,+  -- /Applications/Google Chrome.app/Contents/MacOS/Google Chrome.+  , _chromeOptionsBinary :: Maybe FilePath+  -- | A list of Chrome extensions to install on startup. Each item in the list should be a base-64 encoded packed Chrome+  -- extension (.crx)+  , _chromeOptionsExtensions :: Maybe [ChromeExtension]+  -- | A dictionary with each entry consisting of the name of the preference and its value. These preferences are applied+  -- to the Local State file in the user data folder.+  , _chromeOptionsLocalState :: Maybe A.Object+  -- | A dictionary with each entry consisting of the name of the preference and its value. These preferences are only+  -- applied to the user profile in use. See the 'Preferences' file in Chrome's user data directory for examples.+  , _chromeOptionsPrefs :: Maybe A.Object+  -- | If false, Chrome is quit when ChromeDriver is killed, regardless of whether the session is quit.+  -- If true, Chrome only quits if the session is quit or closed. If true and the session isn't quit, ChromeDriver+  -- cannot clean up the temporary user data directory that the running Chrome instance is using.+  , _chromeOptionsDetach :: Maybe Bool+  -- | An address of a Chrome debugger server to connect to, in the form of @<hostname/ip:port>@, such as '127.0.0.1:38947'+  , _chromeOptionsDebuggerAddress :: Maybe String+  -- | List of Chrome command line switches to exclude that ChromeDriver by default passes when starting Chrome. Don't+  -- prefix switches with --.+  , _chromeOptionsExcludeSwitches :: Maybe [String]+  -- | Directory to store Chrome minidumps. (Supported only on Linux.)+  , _chromeOptionsMinidumpPath :: Maybe FilePath+  -- | A dictionary with either a value for "deviceName," or values for "deviceMetrics", and "userAgent." Refer to Mobile+  -- Emulation for more information.+  , _chromeOptionsMobileEmulation :: Maybe ChromeMobileEmulation+  -- | An optional dictionary that specifies performance logging preferences.+  , _chromeOptionsPerfLoggingPrefs :: Maybe A.Object+  -- | A list of window types that appear in the list of window handles. For access to webview elements, include "webview"+  -- in this list.+  , _chromeOptionsWindowTypes :: Maybe [String]+  }+  deriving (Show, Eq)+deriveJSON toCamel2 ''ChromeOptions+makeLenses ''ChromeOptions++-- | Empty 'ChromeOptions'.+defaultChromeOptions :: ChromeOptions+defaultChromeOptions = ChromeOptions {+  _chromeOptionsArgs = Nothing+  , _chromeOptionsBinary = Nothing+  , _chromeOptionsExtensions = Nothing+  , _chromeOptionsLocalState = Nothing+  , _chromeOptionsPrefs = Nothing+  , _chromeOptionsDetach = Nothing+  , _chromeOptionsDebuggerAddress = Nothing+  , _chromeOptionsExcludeSwitches = Nothing+  , _chromeOptionsMinidumpPath = Nothing+  , _chromeOptionsMobileEmulation = Nothing+  , _chromeOptionsPerfLoggingPrefs = Nothing+  , _chromeOptionsWindowTypes = Nothing+  }
+ src/Test/WebDriver/Capabilities/FirefoxOptions.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.WebDriver.Capabilities.FirefoxOptions where++import Data.Aeson as A+import Data.Aeson.TH+import Lens.Micro.TH+import Test.WebDriver.Capabilities.Aeson+import Test.WebDriver.Profile+++data FirefoxLogLevelType =+  FirefoxLogLevelTypeTrace+  | FirefoxLogLevelTypeDebug+  | FirefoxLogLevelTypeConfig+  | FirefoxLogLevelTypeInfo+  | FirefoxLogLevelTypeWarn+  | FirefoxLogLevelTypeError+  | FirefoxLogLevelTypeFatal+  deriving (Show, Eq)+deriveJSON toCamelC4 ''FirefoxLogLevelType+makeLenses ''FirefoxLogLevelType++data FirefoxLogLevel = FirefoxLogLevel {+  _firefoxLogLevelLevel :: FirefoxLogLevelType+  }+  deriving (Show, Eq)+deriveJSON toCamel3 ''FirefoxLogLevel+makeLenses ''FirefoxLogLevel++-- | See https://developer.mozilla.org/en-US/docs/Web/WebDriver/Capabilities/firefoxOptions+data FirefoxOptions = FirefoxOptions {+  -- | Absolute path to the custom Firefox binary to use.+  -- On macOS you may either give the path to the application bundle, i.e. @\/Applications\/Firefox.app@, or the absolute+  -- path to the executable binary inside this bundle, for example+  -- @\/Applications\/Firefox.app\/Contents\/MacOS\/firefox-bin@. geckodriver will attempt to deduce the default location of+  -- Firefox on the current system if left undefined.+  _firefoxOptionsBinary :: Maybe String+  -- | Command line arguments to pass to the Firefox binary.+  -- These must include the leading dash (-) where required, e.g. ["-headless"].+  -- To have geckodriver pick up an existing profile on the local filesystem, you may pass @["-profile", -- "\/path\/to\/profile"]@.+  -- But if a profile has to be transferred to a target machine it is recommended to use the profile entry.+  , _firefoxOptionsArgs :: Maybe [String]+  -- | Base64-encoded ZIP of a profile directory to use for the Firefox instance. This may be used to e.g. install+  -- extensions or custom certificates, but for setting custom preferences we recommend using the prefs entry instead.+  , _firefoxOptionsProfile :: Maybe (Profile Firefox)+  -- | To increase the logging verbosity of geckodriver and Firefox, you may pass a log object that may look like+  -- {"log": {"level": "trace"}} to include all trace-level logs and above.+  , _firefoxOptionsLog :: Maybe FirefoxLogLevel+  -- | Map of preference name to preference value, which can be a string, a boolean or an integer.+  , _firefoxOptionsPrefs :: Maybe A.Object++  -- TODO: Android options+  }+  deriving (Show, Eq)+deriveJSON toCamel2 ''FirefoxOptions+makeLenses ''FirefoxOptions++emptyFirefoxOptions :: FirefoxOptions+emptyFirefoxOptions = FirefoxOptions {+  _firefoxOptionsBinary = Nothing+  , _firefoxOptionsArgs = Nothing+  , _firefoxOptionsProfile = Nothing+  , _firefoxOptionsLog = Nothing+  , _firefoxOptionsPrefs = Nothing+  }++-- | Empty 'FirefoxOptions'.+defaultFirefoxOptions :: FirefoxOptions+defaultFirefoxOptions = emptyFirefoxOptions
+ src/Test/WebDriver/Capabilities/Platform.hs view
@@ -0,0 +1,35 @@++module Test.WebDriver.Capabilities.Platform where++import Data.Aeson+import Data.Aeson.Types (typeMismatch)+import Data.String (fromString)+import Data.Text (Text, toLower, toUpper)++-- | Represents the platformName option of the primary capabilities+data Platform =+  Windows+  | XP+  | Vista+  | Mac+  | Linux+  | Unix+  | Any+  | Other Text+  deriving (Eq, Show, Ord)++instance ToJSON Platform where+  toJSON (Other t) = String t+  toJSON x = String $ toUpper $ fromString $ show x++instance FromJSON Platform where+  parseJSON (String jStr) = case toLower jStr of+    "windows" -> return Windows+    "xp" -> return XP+    "vista" -> return Vista+    "mac" -> return Mac+    "linux" -> return Linux+    "unix" -> return Unix+    "any" -> return Any+    t -> return $ Other t+  parseJSON v = typeMismatch "Platform" v
+ src/Test/WebDriver/Capabilities/Proxy.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.WebDriver.Capabilities.Proxy where++import Data.Aeson.TH+import Test.WebDriver.Capabilities.Aeson+++data ProxyType =+  ProxyTypePac+  | ProxyTypeDirect+  | ProxyTypeAutodetect+  | ProxyTypeSystem+  | ProxyTypeManual+  deriving (Show, Eq)+deriveJSON toCamelC2 ''ProxyType++data Proxy = Proxy {+  proxyType :: ProxyType+  }+  deriving (Show, Eq)+deriveJSON baseOptions ''Proxy
+ src/Test/WebDriver/Capabilities/Timeouts.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.WebDriver.Capabilities.Timeouts where++import Data.Aeson.TH+import Test.WebDriver.Capabilities.Aeson+++data Timeouts = Timeouts {+  timeoutsScriptMs :: Maybe Int+  , timeoutsPageLoadMs :: Maybe Int+  , timeoutsImplicitMs :: Maybe Int+  }+  deriving (Show, Eq)+deriveJSON toCamelC2 ''Timeouts
+ src/Test/WebDriver/Capabilities/UserPromptHandler.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.WebDriver.Capabilities.UserPromptHandler where++import Data.Aeson.TH+import Test.WebDriver.Capabilities.Aeson+++data UserPromptHandler =+  UserPromptHandlerDismiss+  | UserPromptHandlerAccept+  | UserPromptHandlerDismissAndNotify+  | UserPromptHandlerAcceptAndNotify+  | UserPromptHandlerIgnore+  deriving (Show, Eq)+deriveJSON toSpacedC3 ''UserPromptHandler
− src/Test/WebDriver/Chrome/Extension.hs 
@@ -1,30 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}---- | Functions and types for working with Google Chrome extensions.-module Test.WebDriver.Chrome.Extension-       ( ChromeExtension-       , loadExtension-       , loadRawExtension-       ) where-import Data.ByteString.Lazy as LBS-import Data.ByteString.Base64.Lazy as B64-import Data.Text.Lazy-import Data.Text.Lazy.Encoding (decodeLatin1)-import Data.Aeson-import Control.Applicative-import Control.Monad.Base--import Prelude -- hides some "unused import" warnings---- |An opaque type representing a Google Chrome extension. Values of this type--- are passed to the 'Test.Webdriver.chromeExtensions' field.-newtype ChromeExtension = ChromeExtension Text-                        deriving (Eq, Show, Read, ToJSON, FromJSON)---- |Load a .crx file as a 'ChromeExtension'.-loadExtension :: MonadBase IO m => FilePath -> m ChromeExtension-loadExtension path = liftBase $ loadRawExtension <$> LBS.readFile path---- |Load raw .crx data as a 'ChromeExtension'.-loadRawExtension :: ByteString -> ChromeExtension-loadRawExtension = ChromeExtension . decodeLatin1 . B64.encode
− src/Test/WebDriver/Class.hs 
@@ -1,73 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}--module Test.WebDriver.Class (-  -- * WebDriver class-  WebDriver(..), Method, methodDelete, methodGet, methodPost,-  ) where-import Test.WebDriver.Session--import Data.Aeson-import Data.Text (Text)-import Network.HTTP.Types.Method (methodDelete, methodGet, methodPost, Method)-import Control.Monad.Trans.Class-import Control.Monad.Trans.Except-import Control.Monad.Trans.Identity-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.RWS.Lazy as LRWS-import Control.Monad.Trans.RWS.Strict as SRWS-import Control.Monad.Trans.Reader-import Control.Monad.Trans.State.Lazy as LS-import Control.Monad.Trans.State.Strict as SS-import Control.Monad.Trans.Writer.Lazy as LW-import Control.Monad.Trans.Writer.Strict as SW-import Data.CallStack--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid) -- for some reason "import Prelude" trick doesn't work with "import Data.Monoid"-#endif----- |A class for monads that can handle wire protocol requests. This is the--- operation underlying all of the high-level commands exported in--- "Test.WebDriver.Commands". For more information on the wire protocol see--- <https://github.com/SeleniumHQ/selenium/wiki/JsonWireProtocol>-class (WDSessionStateControl wd) => WebDriver wd where-  doCommand :: (HasCallStack, ToJSON a, FromJSON b) =>-                   Method      -- ^HTTP request method-                -> Text        -- ^URL of request-                -> a           -- ^JSON parameters passed in the body-                               -- of the request. Note that, as a special case,-                               -- anything that converts to Data.Aeson.Null will-                               -- result in an empty request body.-                -> wd b        -- ^The JSON result of the HTTP request.--instance WebDriver wd => WebDriver (SS.StateT s wd) where-  doCommand rm t a = lift (doCommand rm t a)--instance WebDriver wd => WebDriver (LS.StateT s wd) where-  doCommand rm t a = lift (doCommand rm t a)--instance WebDriver wd => WebDriver (MaybeT wd) where-  doCommand rm t a = lift (doCommand rm t a)--instance WebDriver wd => WebDriver (IdentityT wd) where-  doCommand rm t a = lift (doCommand rm t a)--instance (Monoid w, WebDriver wd) => WebDriver (LW.WriterT w wd) where-  doCommand rm t a = lift (doCommand rm t a)--instance (Monoid w, WebDriver wd) => WebDriver (SW.WriterT w wd) where-  doCommand rm t a = lift (doCommand rm t a)--instance WebDriver wd => WebDriver (ReaderT r wd) where-  doCommand rm t a = lift (doCommand rm t a)--instance WebDriver wd => WebDriver (ExceptT e wd) where-  doCommand rm t a = lift (doCommand rm t a)--instance (Monoid w, WebDriver wd) => WebDriver (SRWS.RWST r w s wd) where-  doCommand rm t a = lift (doCommand rm t a)--instance (Monoid w, WebDriver wd) => WebDriver (LRWS.RWST r w s wd) where-  doCommand rm t a = lift (doCommand rm t a)
src/Test/WebDriver/Commands.hs view
@@ -1,777 +1,117 @@-{-# LANGUAGE ExistentialQuantification #-} --- | This module exports basic WD actions that can be used to interact with a+-- | This module exports all the actions that can be used to interact with a -- browser session.-module Test.WebDriver.Commands-       ( -- * Sessions-         createSession, closeSession, sessions, getActualCaps-         -- * Browser interaction-         -- ** Web navigation-       , openPage, forward, back, refresh-         -- ** Page info-       , getCurrentURL, getSource, getTitle, saveScreenshot, screenshot, screenshotBase64-         -- * Timeouts-       , setImplicitWait, setScriptTimeout, setPageLoadTimeout-         -- * Web elements-       , Element(..), Selector(..)-         -- ** Searching for elements-       , findElem, findElems, findElemFrom, findElemsFrom-         -- ** Interacting with elements-       , click, submit, getText-         -- *** Sending key inputs to elements-       , sendKeys, sendRawKeys, clearInput-         -- ** Element information-       , attr, cssProp, elemPos, elemSize-       , isSelected, isEnabled, isDisplayed-       , tagName, activeElem, elemInfo-         -- ** Element equality-       , (<==>), (</=>)-         -- * Javascript-       , executeJS, asyncJS-       , JSArg(..)-         -- * Windows-       , WindowHandle(..), currentWindow-       , getCurrentWindow, closeWindow, windows, focusWindow,  maximize-       , getWindowSize, setWindowSize, getWindowPos, setWindowPos-         -- * Focusing on frames-       , focusFrame, FrameSelector(..)-         -- * Cookies-       , Cookie(..), mkCookie-       , cookies, setCookie, deleteCookie, deleteVisibleCookies, deleteCookieByName-         -- * Alerts-       , getAlertText, replyToAlert, acceptAlert, dismissAlert-         -- * Mouse gestures-       , moveTo, moveToCenter, moveToFrom-       , clickWith, MouseButton(..)-       , mouseDown, mouseUp, withMouseDown, doubleClick-         -- * HTML 5 Web Storage-       , WebStorageType(..), storageSize, getAllKeys, deleteAllKeys-       , getKey, setKey, deleteKey-         -- * HTML 5 Application Cache-       , ApplicationCacheStatus(..)-       , getApplicationCacheStatus-         -- * Mobile device support-         -- ** Screen orientation-       , Orientation(..)-       , getOrientation, setOrientation-         -- ** Geo-location-       , getLocation, setLocation-         -- ** Touch gestures-       , touchClick, touchDown, touchUp, touchMove-       , touchScroll, touchScrollFrom, touchDoubleClick-       , touchLongClick, touchFlick, touchFlickFrom-         -- * IME support-       , availableIMEEngines, activeIMEEngine, checkIMEActive-       , activateIME, deactivateIME-         -- * Uploading files to remote server-         -- |These functions allow you to upload a file to a remote server.-         -- Note that this operation isn't supported by all WebDriver servers,-         -- and the location where the file is stored is not standardized.-       , uploadFile, uploadRawFile, uploadZipEntry-         -- * Server information and logs-       , serverStatus-       , getLogs, getLogTypes, LogType, LogEntry(..), LogLevel(..)-       ) where--import Codec.Archive.Zip-import Control.Applicative-import Control.Exception (SomeException)-import Control.Exception.Lifted (throwIO, handle)-import qualified Control.Exception.Lifted as L-import Control.Monad-import Control.Monad.Base-import Data.Aeson-import Data.Aeson.Types-import Data.ByteString.Base64.Lazy as B64-import Data.ByteString.Lazy as LBS (ByteString, writeFile)-import Data.CallStack-import qualified Data.Foldable as F-import Data.Maybe-import Data.String (fromString)-import Data.Text (Text, append, toUpper, toLower)-import qualified Data.Text as T-import qualified Data.Text.Lazy.Encoding as TL-import Data.Word-import Network.URI hiding (path)  -- suppresses warnings-import Test.WebDriver.Capabilities-import Test.WebDriver.Class-import Test.WebDriver.Commands.Internal-import Test.WebDriver.Cookies-import Test.WebDriver.Exceptions.Internal-import Test.WebDriver.JSON-import Test.WebDriver.Session-import Test.WebDriver.Utils (urlEncode)--import Prelude -- hides some "unused import" warnings---- |Create a new session with the given 'Capabilities'. The returned session becomes the \"current session\" for this action.------ Note: if you're using 'runSession' to run your WebDriver commands, you don't need to call this explicitly.-createSession :: (HasCallStack, WebDriver wd) => Capabilities -> wd WDSession-createSession caps = do-  ignoreReturn . withAuthHeaders . doCommand methodPost "/session" . single "desiredCapabilities" $ caps-  getSession---- |Retrieve a list of active sessions and their 'Capabilities'.-sessions :: (HasCallStack, WebDriver wd) => wd [(SessionId, Capabilities)]-sessions = do-  objs <- doCommand methodGet "/sessions" Null-  mapM (parsePair "id" "capabilities" "sessions") objs---- |Get the actual server-side 'Capabilities' of the current session.-getActualCaps :: (HasCallStack, WebDriver wd) => wd Capabilities-getActualCaps = doSessCommand methodGet "" Null---- |Close the current session and the browser associated with it.-closeSession :: (HasCallStack, WebDriver wd) => wd ()-closeSession = do s@WDSession {} <- getSession-                  noReturn $ doSessCommand methodDelete "" Null-                  putSession s { wdSessId = Nothing }----- |Sets the amount of time (ms) we implicitly wait when searching for elements.-setImplicitWait :: (HasCallStack, WebDriver wd) => Integer -> wd ()-setImplicitWait ms =-  noReturn $ doSessCommand methodPost "/timeouts/implicit_wait" (object msField)-    `L.catch` \(_ :: SomeException) ->-      doSessCommand methodPost "/timeouts" (object allFields)-  where msField   = ["ms" .= ms]-        allFields = ["type" .= ("implicit" :: String)] ++ msField---- |Sets the amount of time (ms) we wait for an asynchronous script to return a--- result.-setScriptTimeout :: (HasCallStack, WebDriver wd) => Integer -> wd ()-setScriptTimeout ms =-  noReturn $ doSessCommand methodPost "/timeouts/async_script" (object msField)-    `L.catch` \( _ :: SomeException) ->-      doSessCommand methodPost "/timeouts" (object allFields)-  where msField   = ["ms" .= ms]-        allFields = ["type" .= ("script" :: String)] ++ msField---- |Sets the amount of time (ms) to wait for a page to finish loading before throwing a 'Timeout' exception.-setPageLoadTimeout :: (HasCallStack, WebDriver wd) => Integer -> wd ()-setPageLoadTimeout ms = noReturn $ doSessCommand methodPost "/timeouts" params-  where params = object ["type" .= ("page load" :: String)-                        ,"ms"   .= ms ]---- |Gets the URL of the current page.-getCurrentURL :: (HasCallStack, WebDriver wd) => wd String-getCurrentURL = doSessCommand methodGet "/url" Null---- |Opens a new page by the given URL.-openPage :: (HasCallStack, WebDriver wd) => String -> wd ()-openPage url-  | isURI url = noReturn . doSessCommand methodPost "/url" . single "url" $ url-  | otherwise = throwIO . InvalidURL $ url---- |Navigate forward in the browser history.-forward :: (HasCallStack, WebDriver wd) => wd ()-forward = noReturn $ doSessCommand methodPost "/forward" Null---- |Navigate backward in the browser history.-back :: (HasCallStack, WebDriver wd) => wd ()-back = noReturn $ doSessCommand methodPost "/back" Null---- |Refresh the current page-refresh :: (HasCallStack, WebDriver wd) => wd ()-refresh = noReturn $ doSessCommand methodPost "/refresh" Null---- |An existential wrapper for any 'ToJSON' instance. This allows us to pass--- parameters of many different types to Javascript code.-data JSArg = forall a. ToJSON a => JSArg a--instance ToJSON JSArg where-  toJSON (JSArg a) = toJSON a--{- |Inject a snippet of Javascript into the page for execution in the-context of the currently selected frame. The executed script is-assumed to be synchronous and the result of evaluating the script is-returned and converted to an instance of FromJSON.--The first parameter defines a sequence of arguments to pass to the javascript-function. Arguments of type Element will be converted to the-corresponding DOM element. Likewise, any elements in the script result-will be returned to the client as Elements.--The second parameter defines the script itself in the form of a-function body. The value returned by that function will be returned to-the client. The function will be invoked with the provided argument-list and the values may be accessed via the arguments object in the-order specified.--When using 'executeJS', GHC might complain about an ambiguous type in-situations where the result of the executeJS call is ignored/discard.-Consider the following example:--@-	jsExample = do-		e <- findElem (ById "foo")-		executeJS [] "someAction()"-		return e-@--Because the result of the 'executeJS' is discarded, GHC cannot resolve-which instance of the 'fromJSON' class to use when parsing the-Selenium server response. In such cases, we can use the 'ignoreReturn'-helper function located in "Test.WebDriver.JSON". 'ignoreReturn' has-no runtime effect; it simply helps the type system by expicitly providing-a `fromJSON` instance to use.--@-	import Test.WebDriver.JSON (ignoreReturn)-	jsExample = do-		e <- findElem (ById "foo")-		ignoreReturn $ executeJS [] "someAction()"-		return e-@--}-executeJS :: (F.Foldable f, FromJSON a, WebDriver wd) => f JSArg -> Text -> wd a-executeJS a s = fromJSON' =<< getResult-  where-    getResult = doSessCommand methodPost "/execute" . pair ("args", "script") $ (F.toList a,s)--{- |Executes a snippet of Javascript code asynchronously. This function works-similarly to 'executeJS', except that the Javascript is passed a callback-function as its final argument. The script should call this function-to signal that it has finished executing, passing to it a value that will be-returned as the result of asyncJS. A result of Nothing indicates that the-Javascript function timed out (see 'setScriptTimeout')--}-asyncJS :: (HasCallStack, F.Foldable f, FromJSON a, WebDriver wd) => f JSArg -> Text -> wd (Maybe a)-asyncJS a s = handle timeout $ Just <$> (fromJSON' =<< getResult)-  where-    getResult = doSessCommand methodPost "/execute_async" . pair ("args", "script")-                $ (F.toList a,s)-    timeout (FailedCommand Timeout _)       = return Nothing-    timeout (FailedCommand ScriptTimeout _) = return Nothing-    timeout err = throwIO err---- |Save a screenshot to a particular location-saveScreenshot :: (HasCallStack, WebDriver wd) => FilePath -> wd ()-saveScreenshot path = screenshot >>= liftBase . LBS.writeFile path---- |Grab a screenshot of the current page as a PNG image-screenshot :: (HasCallStack, WebDriver wd) => wd LBS.ByteString-screenshot = B64.decodeLenient <$> screenshotBase64---- |Grab a screenshot as a base-64 encoded PNG image. This is the protocol-defined format.-screenshotBase64 :: (HasCallStack, WebDriver wd) => wd LBS.ByteString-screenshotBase64 = TL.encodeUtf8 <$> doSessCommand methodGet "/screenshot" Null--availableIMEEngines :: (HasCallStack, WebDriver wd) => wd [Text]-availableIMEEngines = doSessCommand methodGet "/ime/available_engines" Null--activeIMEEngine :: (HasCallStack, WebDriver wd) => wd Text-activeIMEEngine = doSessCommand methodGet "/ime/active_engine" Null--checkIMEActive :: (HasCallStack, WebDriver wd) => wd Bool-checkIMEActive = doSessCommand methodGet "/ime/activated" Null--activateIME :: (HasCallStack, WebDriver wd) => Text -> wd ()-activateIME = noReturn . doSessCommand methodPost "/ime/activate" . single "engine"--deactivateIME :: (HasCallStack, WebDriver wd) => wd ()-deactivateIME = noReturn $ doSessCommand methodPost "/ime/deactivate" Null----- |Specifies the frame used by 'Test.WebDriver.Commands.focusFrame'-data FrameSelector = WithIndex Integer-                     -- |focus on a frame by name or ID-                   | WithName Text-                     -- |focus on a frame 'Element'-                   | WithElement Element-                     -- |focus on the first frame, or the main document-                     -- if iframes are used.-                   | DefaultFrame-                   deriving (Eq, Show, Read)--instance ToJSON FrameSelector where-  toJSON s = case s of-    WithIndex i -> toJSON i-    WithName n -> toJSON n-    WithElement e -> toJSON e-    DefaultFrame -> Null---- |Switch focus to the frame specified by the FrameSelector.-focusFrame :: (HasCallStack, WebDriver wd) => FrameSelector -> wd ()-focusFrame s = noReturn $ doSessCommand methodPost "/frame" . single "id" $ s---- |Returns a handle to the currently focused window-getCurrentWindow :: (HasCallStack, WebDriver wd) => wd WindowHandle-getCurrentWindow = doSessCommand methodGet "/window_handle" Null---- |Returns a list of all windows available to the session-windows :: (HasCallStack, WebDriver wd) => wd [WindowHandle]-windows = doSessCommand methodGet "/window_handles" Null--focusWindow :: (HasCallStack, WebDriver wd) => WindowHandle -> wd ()-focusWindow w = noReturn $ doSessCommand methodPost "/window" . single "handle" $ w---- |Closes the given window-closeWindow :: (HasCallStack, WebDriver wd) => WindowHandle -> wd ()-closeWindow w = do-  cw <- getCurrentWindow-  focusWindow w-  ignoreReturn $ doSessCommand methodDelete "/window" Null-  unless (w == cw) $ focusWindow cw---- |Maximizes the current  window if not already maximized-maximize :: (HasCallStack, WebDriver wd) => wd ()-maximize = ignoreReturn $ doWinCommand methodPost currentWindow "/maximize" Null---- |Get the dimensions of the current window.-getWindowSize :: (HasCallStack, WebDriver wd) => wd (Word, Word)-getWindowSize = doWinCommand methodGet currentWindow "/size" Null-                >>= parsePair "width" "height" "getWindowSize"---- |Set the dimensions of the current window.-setWindowSize :: (HasCallStack, WebDriver wd) => (Word, Word) -> wd ()-setWindowSize = ignoreReturn . doWinCommand methodPost currentWindow "/size"-                . pair ("width", "height")---- |Get the coordinates of the current window.-getWindowPos :: (HasCallStack, WebDriver wd) => wd (Int, Int)-getWindowPos = doWinCommand methodGet currentWindow "/position" Null-               >>= parsePair "x" "y" "getWindowPos"---- |Set the coordinates of the current window.-setWindowPos :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()-setWindowPos = ignoreReturn . doWinCommand methodPost currentWindow "/position" . pair ("x","y")---- |Retrieve all cookies visible to the current page.-cookies :: (HasCallStack, WebDriver wd) => wd [Cookie]-cookies = doSessCommand methodGet "/cookie" Null---- |Set a cookie. If the cookie path is not specified, it will default to \"/\".--- Likewise, if the domain is omitted, it will default to the current page's--- domain-setCookie :: (HasCallStack, WebDriver wd) => Cookie -> wd ()-setCookie = noReturn . doSessCommand methodPost "/cookie" . single "cookie"---- |Delete a cookie. This will do nothing is the cookie isn't visible to the--- current page.-deleteCookie :: (HasCallStack, WebDriver wd) => Cookie -> wd ()-deleteCookie c = noReturn $ doSessCommand methodDelete ("/cookie/" `append` urlEncode (cookName c)) Null--deleteCookieByName :: (HasCallStack, WebDriver wd) => Text -> wd ()-deleteCookieByName n = noReturn $ doSessCommand methodDelete ("/cookie/" `append` n) Null---- |Delete all visible cookies on the current page.-deleteVisibleCookies :: (HasCallStack, WebDriver wd) => wd ()-deleteVisibleCookies = noReturn $ doSessCommand methodDelete "/cookie" Null---- |Get the current page source-getSource :: (HasCallStack, WebDriver wd) => wd Text-getSource = doSessCommand methodGet "/source" Null---- |Get the title of the current page.-getTitle :: (HasCallStack, WebDriver wd) => wd Text-getTitle = doSessCommand methodGet "/title" Null---- |Specifies element(s) within a DOM tree using various selection methods.-data Selector = ById Text-              | ByName Text-              | ByClass Text -- ^ (Note: multiple classes are not-                             -- allowed. For more control, use 'ByCSS')-              | ByTag Text-              | ByLinkText Text-              | ByPartialLinkText Text-              | ByCSS Text-              | ByXPath Text-              deriving (Eq, Show, Ord)--instance ToJSON Selector where-  toJSON s = case s of-    ById t              -> selector "id" t-    ByName t            -> selector "name" t-    ByClass t           -> selector "class name" t-    ByTag t             -> selector "tag name" t-    ByLinkText t        -> selector "link text" t-    ByPartialLinkText t -> selector "partial link text" t-    ByCSS t             -> selector "css selector" t-    ByXPath t           -> selector "xpath" t-    where-      selector :: Text -> Text -> Value-      selector sn t = object ["using" .= sn, "value" .= t]---- |Find an element on the page using the given element selector.-findElem :: (HasCallStack, WebDriver wd) => Selector -> wd Element-findElem = doSessCommand methodPost "/element"---- |Find all elements on the page matching the given selector.-findElems :: (HasCallStack, WebDriver wd) => Selector -> wd [Element]-findElems = doSessCommand methodPost "/elements"---- |Return the element that currently has focus.-activeElem :: (HasCallStack, WebDriver wd) => wd Element-activeElem = doSessCommand methodPost "/element/active" Null---- |Search for an element using the given element as root.-findElemFrom :: (HasCallStack, WebDriver wd) => Element -> Selector -> wd Element-findElemFrom e = doElemCommand methodPost e "/element"---- |Find all elements matching a selector, using the given element as root.-findElemsFrom :: (HasCallStack, WebDriver wd) => Element -> Selector -> wd [Element]-findElemsFrom e = doElemCommand methodPost e "/elements"---- |Describe the element. Returns a JSON object whose meaning is currently--- undefined by the WebDriver protocol.-elemInfo :: (HasCallStack, WebDriver wd) => Element -> wd Value-elemInfo e = doElemCommand methodGet e "" Null-{-# DEPRECATED elemInfo "This command does not work with Marionette (Firefox) driver, and is likely to be completely removed in Selenium 4" #-}---- |Click on an element.-click :: (HasCallStack, WebDriver wd) => Element -> wd ()-click e = noReturn $ doElemCommand methodPost e "/click" Null---- |Submit a form element. This may be applied to descendents of a form element--- as well.-submit :: (HasCallStack, WebDriver wd) => Element -> wd ()-submit e = noReturn $ doElemCommand methodPost e "/submit" Null---- |Get all visible text within this element.-getText :: (HasCallStack, WebDriver wd) => Element -> wd Text-getText e = doElemCommand methodGet e "/text" Null---- |Send a sequence of keystrokes to an element. All modifier keys are released--- at the end of the function. Named constants for special modifier keys can be found--- in "Test.WebDriver.Common.Keys"-sendKeys :: (HasCallStack, WebDriver wd) => Text -> Element -> wd ()-sendKeys t e = noReturn . doElemCommand methodPost e "/value" . single "value" $ [t]---- |Similar to sendKeys, but doesn't implicitly release modifier keys--- afterwards. This allows you to combine modifiers with mouse clicks.-sendRawKeys :: (HasCallStack, WebDriver wd) => Text -> wd ()-sendRawKeys t = noReturn . doSessCommand methodPost "/keys" . single "value" $ [t]---- |Return the tag name of the given element.-tagName :: (HasCallStack, WebDriver wd) => Element -> wd Text-tagName e = doElemCommand methodGet e "/name" Null---- |Clear a textarea or text input element's value.-clearInput :: (HasCallStack, WebDriver wd) => Element -> wd ()-clearInput e = noReturn $ doElemCommand methodPost e "/clear" Null---- |Determine if the element is selected.-isSelected :: (HasCallStack, WebDriver wd) => Element -> wd Bool-isSelected e = doElemCommand methodGet e "/selected" Null---- |Determine if the element is enabled.-isEnabled :: (HasCallStack, WebDriver wd) => Element -> wd Bool-isEnabled e = doElemCommand methodGet e "/enabled" Null---- |Determine if the element is displayed.-isDisplayed :: (HasCallStack, WebDriver wd) => Element -> wd Bool-isDisplayed e = doElemCommand methodGet e "/displayed" Null---- |Retrieve the value of an element's attribute-attr :: (HasCallStack, WebDriver wd) => Element -> Text -> wd (Maybe Text)-attr e t = doElemCommand methodGet e ("/attribute/" `append` urlEncode t) Null---- |Retrieve the value of an element's computed CSS property-cssProp :: (HasCallStack, WebDriver wd) => Element -> Text -> wd (Maybe Text)-cssProp e t = doElemCommand methodGet e ("/css/" `append` urlEncode t) Null---- |Retrieve an element's current position.-elemPos :: (HasCallStack, WebDriver wd) => Element -> wd (Float, Float)-elemPos e = doElemCommand methodGet e "/location" Null >>= parsePair "x" "y" "elemPos"---- |Retrieve an element's current size.-elemSize :: (HasCallStack, WebDriver wd) => Element -> wd (Float, Float)-elemSize e = doElemCommand methodGet e "/size" Null-             >>= parsePair "width" "height" "elemSize"--infix 4 <==>--- |Determines if two element identifiers refer to the same element.-(<==>) :: (HasCallStack, WebDriver wd) => Element -> Element -> wd Bool-e1 <==> (Element e2) = doElemCommand methodGet e1 ("/equals/" `append` urlEncode e2) Null---- |Determines if two element identifiers refer to different elements.-infix 4 </=>-(</=>) :: (HasCallStack, WebDriver wd) => Element -> Element -> wd Bool-e1 </=> e2 = not <$> (e1 <==> e2)---- |A screen orientation-data Orientation = Landscape | Portrait-                 deriving (Eq, Show, Ord, Bounded, Enum)--instance ToJSON Orientation where-  toJSON = String . toUpper . fromString . show--instance FromJSON Orientation where-  parseJSON (String jStr) = case toLower jStr of-    "landscape" -> return Landscape-    "portrait"  -> return Portrait-    err         -> fail $ "Invalid Orientation string " ++ show err-  parseJSON v = typeMismatch "Orientation" v---- |Get the current screen orientation for rotatable display devices.-getOrientation :: (HasCallStack, WebDriver wd) => wd Orientation-getOrientation = doSessCommand methodGet "/orientation" Null---- |Set the current screen orientation for rotatable display devices.-setOrientation :: (HasCallStack, WebDriver wd) => Orientation -> wd ()-setOrientation = noReturn . doSessCommand methodPost "/orientation" . single "orientation"---- |Get the text of an alert dialog.-getAlertText :: (HasCallStack, WebDriver wd) => wd Text-getAlertText = doSessCommand methodGet "/alert_text" Null---- |Sends keystrokes to Javascript prompt() dialog.-replyToAlert :: (HasCallStack, WebDriver wd) => Text -> wd ()-replyToAlert = noReturn . doSessCommand methodPost "/alert_text" . single "text"---- |Accepts the currently displayed alert dialog.-acceptAlert :: (HasCallStack, WebDriver wd) => wd ()-acceptAlert = noReturn $ doSessCommand methodPost "/accept_alert" Null---- |Dismisses the currently displayed alert dialog.-dismissAlert :: (HasCallStack, WebDriver wd) => wd ()-dismissAlert = noReturn $ doSessCommand methodPost "/dismiss_alert" Null---- |Moves the mouse to the given position relative to the active element.-moveTo :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()-moveTo = noReturn . doSessCommand methodPost "/moveto" . pair ("xoffset","yoffset")---- |Moves the mouse to the center of a given element.-moveToCenter :: (HasCallStack, WebDriver wd) => Element -> wd ()-moveToCenter (Element e) =-  noReturn . doSessCommand methodPost "/moveto" . single "element" $ e---- |Moves the mouse to the given position relative to the given element.-moveToFrom :: (HasCallStack, WebDriver wd) => (Int, Int) -> Element -> wd ()-moveToFrom (x,y) (Element e) =-  noReturn . doSessCommand methodPost "/moveto"-  . triple ("element","xoffset","yoffset") $ (e,x,y)---- |A mouse button-data MouseButton = LeftButton | MiddleButton | RightButton-                 deriving (Eq, Show, Ord, Bounded, Enum)--instance ToJSON MouseButton where-  toJSON = toJSON . fromEnum--instance FromJSON MouseButton where-  parseJSON v = do-    n <- parseJSON v-    case n :: Integer of-      0 -> return LeftButton-      1 -> return MiddleButton-      2 -> return RightButton-      err -> fail $ "Invalid JSON for MouseButton: " ++ show err---- |Click at the current mouse position with the given mouse button.-clickWith :: (HasCallStack, WebDriver wd) => MouseButton -> wd ()-clickWith = noReturn . doSessCommand methodPost "/click" . single "button"---- |Perform the given action with the left mouse button held down. The mouse--- is automatically released afterwards.-withMouseDown :: (HasCallStack, WebDriver wd) => wd a -> wd a-withMouseDown wd = mouseDown >> wd <* mouseUp---- |Press and hold the left mouse button down. Note that undefined behavior--- occurs if the next mouse command is not mouseUp.-mouseDown :: (HasCallStack, WebDriver wd) => wd ()-mouseDown = noReturn $ doSessCommand methodPost "/buttondown" Null---- |Release the left mouse button.-mouseUp :: (HasCallStack, WebDriver wd) => wd ()-mouseUp = noReturn $ doSessCommand methodPost "/buttonup" Null---- |Double click at the current mouse location.-doubleClick :: (HasCallStack, WebDriver wd) => wd ()-doubleClick = noReturn $ doSessCommand methodPost "/doubleclick" Null---- |Single tap on the touch screen at the given element's location.-touchClick :: (HasCallStack, WebDriver wd) => Element -> wd ()-touchClick (Element e) =-  noReturn . doSessCommand methodPost "/touch/click" . single "element" $ e---- |Emulates pressing a finger down on the screen at the given location.-touchDown :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()-touchDown = noReturn . doSessCommand methodPost "/touch/down" . pair ("x","y")---- |Emulates removing a finger from the screen at the given location.-touchUp :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()-touchUp = noReturn . doSessCommand methodPost "/touch/up" . pair ("x","y")---- |Emulates moving a finger on the screen to the given location.-touchMove :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()-touchMove = noReturn . doSessCommand methodPost "/touch/move" . pair ("x","y")---- |Emulate finger-based touch scroll. Use this function if you don't care where--- the scroll begins-touchScroll :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()-touchScroll = noReturn . doSessCommand methodPost "/touch/scroll" . pair ("xoffset","yoffset")---- |Emulate finger-based touch scroll, starting from the given location relative--- to the given element.-touchScrollFrom :: (HasCallStack, WebDriver wd) => (Int, Int) -> Element -> wd ()-touchScrollFrom (x, y) (Element e) =-  noReturn-  . doSessCommand methodPost "/touch/scroll"-  . triple ("xoffset", "yoffset", "element")-  $ (x, y, e)---- |Emulate a double click on a touch device.-touchDoubleClick :: (HasCallStack, WebDriver wd) => Element -> wd ()-touchDoubleClick (Element e) =-  noReturn-  . doSessCommand methodPost "/touch/doubleclick"-  . single "element" $ e---- |Emulate a long click on a touch device.-touchLongClick :: (HasCallStack, WebDriver wd) => Element -> wd ()-touchLongClick (Element e) =-  noReturn-  . doSessCommand methodPost "/touch/longclick"-  . single "element" $ e--- |Emulate a flick on the touch screen. The coordinates indicate x and y--- velocity, respectively. Use this function if you don't care where the--- flick starts.-touchFlick :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()-touchFlick =-  noReturn-  . doSessCommand methodPost "/touch/flick"-  . pair ("xSpeed", "ySpeed")---- |Emulate a flick on the touch screen.-touchFlickFrom :: (HasCallStack, WebDriver wd) =>-                  Int           -- ^ flick velocity-                  -> (Int, Int) -- ^ a location relative to the given element-                  -> Element    -- ^ the given element-                  -> wd ()-touchFlickFrom s (x,y) (Element e) =-  noReturn-  . doSessCommand methodPost "/touch/flick" . object $-  ["xoffset" .= x-  ,"yoffset" .= y-  ,"speed"   .= s-  ,"element" .= e-  ]---- |Get the current geographical location of the device.-getLocation :: (HasCallStack, WebDriver wd) => wd (Int, Int, Int)-getLocation = doSessCommand methodGet "/location" Null-              >>= parseTriple "latitude" "longitude" "altitude" "getLocation"---- |Set the current geographical location of the device.-setLocation :: (HasCallStack, WebDriver wd) => (Int, Int, Int) -> wd ()-setLocation = noReturn . doSessCommand methodPost "/location"-              . triple ("latitude",-                        "longitude",-                        "altitude")---- |Uploads a file from the local filesystem by its file path.-uploadFile :: (HasCallStack, WebDriver wd) => FilePath -> wd ()-uploadFile path = uploadZipEntry =<< liftBase (readEntry [] path)---- |Uploads a raw bytestring with associated file info.-uploadRawFile :: (HasCallStack, WebDriver wd) =>-                 FilePath          -- ^File path to use with this bytestring.-                 -> Integer        -- ^Modification time-                                   -- (in seconds since Unix epoch).-                 -> LBS.ByteString -- ^ The file contents as a lazy ByteString-                 -> wd ()-uploadRawFile path t str = uploadZipEntry (toEntry path t str)----- |Lowest level interface to the file uploading mechanism.--- This allows you to specify the exact details of--- the zip entry sent across network.-uploadZipEntry :: (HasCallStack, WebDriver wd) => Entry -> wd ()-uploadZipEntry = noReturn . doSessCommand methodPost "/file" . single "file"-                 . TL.decodeUtf8 . B64.encode . fromArchive . (`addEntryToArchive` emptyArchive)----- |Get the current number of keys in a web storage area.-storageSize :: (HasCallStack, WebDriver wd) => WebStorageType -> wd Integer-storageSize s = doStorageCommand methodGet s "/size" Null---- |Get a list of all keys from a web storage area.-getAllKeys :: (HasCallStack, WebDriver wd) => WebStorageType -> wd [Text]-getAllKeys s = doStorageCommand methodGet s "" Null---- |Delete all keys within a given web storage area.-deleteAllKeys :: (HasCallStack, WebDriver wd) => WebStorageType -> wd ()-deleteAllKeys s = noReturn $ doStorageCommand methodDelete s "" Null+module Test.WebDriver.Commands (+  -- * Sessions+  -- | A session is equivalent to a single instantiation of a+  -- particular user agent, including all its child browsers. WebDriver gives+  -- each session a unique session ID that can be used to differentiate one+  -- session from another, allowing multiple user agents to be controlled from a+  -- single HTTP server, and allowing sessions to be routed via a multiplexer+  -- (known as an intermediary node).+  --+  -- See https://www.w3.org/TR/webdriver1/#sessions.+  module Test.WebDriver.Commands.Sessions --- |An HTML 5 storage type-data WebStorageType = LocalStorage | SessionStorage-                    deriving (Eq, Show, Ord, Bounded, Enum)+  -- * Navigation+  -- | The commands in this section allow navigation of the current top-level+  -- browsing context to new URLs and introspection of the document currently+  -- loaded in this browsing context.+  --+  -- See https://www.w3.org/TR/webdriver1/#navigation.+  , module Test.WebDriver.Commands.Navigation --- |Get the value associated with a key in the given web storage area.--- Unset keys result in empty strings, since the Web Storage spec--- makes no distinction between the empty string and an undefined value.-getKey :: (HasCallStack, WebDriver wd) => WebStorageType -> Text ->  wd Text-getKey s k = doStorageCommand methodGet s ("/key/" `T.append` urlEncode k) Null+  -- * Command contexts+  -- | Many WebDriver commands happen in the context of either the current+  -- browsing context or current top-level browsing context. The current+  -- top-level browsing context is represented in the protocol by its associated+  -- window handle. When a top-level browsing context is selected using the+  -- Switch To Window command, a specific browsing context can be selected using+  -- the Switch to Frame command.+  --+  -- See https://www.w3.org/TR/webdriver1/#command-contexts.+  , module Test.WebDriver.Commands.CommandContexts --- |Set a key in the given web storage area.-setKey :: (HasCallStack, WebDriver wd) => WebStorageType -> Text -> Text -> wd Text-setKey s k v = doStorageCommand methodPost s "" . object $ ["key"   .= k,-                                                      "value" .= v ]--- |Delete a key in the given web storage area.-deleteKey :: (HasCallStack, WebDriver wd) => WebStorageType -> Text -> wd ()-deleteKey s k = noReturn $ doStorageCommand methodPost s ("/key/" `T.append` urlEncode k) Null+  -- * Element Retrieval+  -- | The Find Element, Find Elements, Find Element From Element, and Find+  -- Elements From Element commands allow lookup of individual elements and+  -- collections of elements. Element retrieval searches are performed using+  -- pre-order traversal of the document’s nodes that match the provided+  -- selector’s expression. Elements are serialized and returned as web+  -- elements.+  --+  -- See https://www.w3.org/TR/webdriver1/#element-retrieval.+  , module Test.WebDriver.Commands.ElementRetrieval --- |A wrapper around 'doSessCommand' to create web storage requests.-doStorageCommand :: (WebDriver wd, ToJSON a, FromJSON b) =>-                     Method -> WebStorageType -> Text -> a -> wd b-doStorageCommand m s path a = doSessCommand m (T.concat ["/", s', path]) a-  where s' = case s of-          LocalStorage -> "local_storage"-          SessionStorage -> "session_storage"+  -- * Element State+  --+  -- See https://www.w3.org/TR/webdriver1/#element-state.+  , module Test.WebDriver.Commands.ElementState --- |Get information from the server as a JSON 'Object'. For more information--- about this object see--- <https://github.com/SeleniumHQ/selenium/wiki/JsonWireProtocol#status>-serverStatus :: (WebDriver wd) => wd Value   -- todo: make this a record type-serverStatus = doCommand methodGet "/status" Null+  -- * Element Interaction+  --+  -- See https://www.w3.org/TR/webdriver1/#element-interaction.+  , module Test.WebDriver.Commands.ElementInteraction --- |A record that represents a single log entry.-data LogEntry =-  LogEntry { logTime  :: Integer  -- ^ timestamp for the log entry. The standard-                                  -- does not specify the epoch or the unit of-                                  -- time.-           , logLevel :: LogLevel -- ^ log verbosity level-           , logMsg   :: Text-           }-  deriving (Eq, Ord, Show, Read)+  -- * Document handling+  --+  -- See https://www.w3.org/TR/webdriver1/#document-handling.+  , module Test.WebDriver.Commands.DocumentHandling+  , ignoreReturn +  -- * Cookies+  --+  -- See https://www.w3.org/TR/webdriver1/#cookies.+  , module Test.WebDriver.Commands.Cookies -instance FromJSON LogEntry where-  parseJSON (Object o) =-    LogEntry <$> o .: "timestamp"-             <*> o .: "level"-             <*> (fromMaybe "" <$> o .: "message")-  parseJSON v = typeMismatch "LogEntry" v+  -- * Actions+  --+  -- See https://www.w3.org/TR/webdriver1/#actions.+  , module Test.WebDriver.Commands.Actions -type LogType = String+  -- * User Prompts+  --+  -- See https://www.w3.org/TR/webdriver1/#user-prompts.+  , module Test.WebDriver.Commands.UserPrompts --- |Retrieve the log buffer for a given log type. The server-side log buffer is reset after each request.------ Which log types are available is server defined, but the wire protocol lists these as common log types:--- client, driver, browser, server-getLogs :: (HasCallStack, WebDriver wd) => LogType -> wd [LogEntry]-getLogs t = doSessCommand methodPost "/log" . object $ ["type" .= t]+  -- * Screen capture+  --+  -- See https://www.w3.org/TR/webdriver1/#screen-capture.+  , module Test.WebDriver.Commands.ScreenCapture --- |Get a list of available log types.-getLogTypes :: (HasCallStack, WebDriver wd) => wd [LogType]-getLogTypes = doSessCommand methodGet "/log/types" Null+  -- * Browser logs+  -- | Retrieve browser console logs and other log types.+  , module Test.WebDriver.Commands.Logs -data ApplicationCacheStatus = Uncached | Idle | Checking | Downloading | UpdateReady | Obsolete deriving (Eq, Enum, Bounded, Ord, Show, Read)+  -- * Selenium-specific+  -- ** Mobile device support+  , module Test.WebDriver.Commands.SeleniumSpecific.Mobile+  -- ** Uploading files to remote server+  -- | These functions allow you to upload a file to a remote server.+  -- Note that this operation isn't supported by all WebDriver servers,+  -- and the location where the file is stored is not standardized.+  , module Test.WebDriver.Commands.SeleniumSpecific.Uploads+  -- ** HTML5+  , module Test.WebDriver.Commands.SeleniumSpecific.HTML5+  -- ** Misc+  , module Test.WebDriver.Commands.SeleniumSpecific.Misc+  ) where -instance FromJSON ApplicationCacheStatus where-    parseJSON val = do-        n <- parseJSON val-        case n :: Integer of-            0 -> return Uncached-            1 -> return Idle-            2 -> return Checking-            3 -> return Downloading-            4 -> return UpdateReady-            5 -> return Obsolete-            err -> fail $ "Invalid JSON for ApplicationCacheStatus: " ++ show err+import Test.WebDriver.Commands.Actions+import Test.WebDriver.Commands.CommandContexts+import Test.WebDriver.Commands.Cookies+import Test.WebDriver.Commands.DocumentHandling+import Test.WebDriver.Commands.ElementInteraction+import Test.WebDriver.Commands.ElementRetrieval+import Test.WebDriver.Commands.ElementState+import Test.WebDriver.Commands.Logs+import Test.WebDriver.Commands.Navigation+import Test.WebDriver.Commands.ScreenCapture+import Test.WebDriver.Commands.SeleniumSpecific.HTML5+import Test.WebDriver.Commands.SeleniumSpecific.Misc+import Test.WebDriver.Commands.SeleniumSpecific.Mobile+import Test.WebDriver.Commands.SeleniumSpecific.Uploads+import Test.WebDriver.Commands.Sessions+import Test.WebDriver.Commands.UserPrompts -getApplicationCacheStatus :: (WebDriver wd) => wd ApplicationCacheStatus-getApplicationCacheStatus = doSessCommand methodGet "/application_cache/status" Null+import Test.WebDriver.JSON (ignoreReturn)
+ src/Test/WebDriver/Commands/Actions.hs view
@@ -0,0 +1,182 @@+module Test.WebDriver.Commands.Actions (+  moveTo+  , moveToCenter+  , moveToFrom+  , clickCenter+  , doubleClickCenter++  -- * Lower-level actions API+  , performActions+  , releaseActions+  , Action(..)+  , ActionSource(..)+  , PointerAction(..)+  , KeyAction(..)+  , PointerOrigin(..)++  -- * Types+  , MouseButton(..)+  ) where++import Data.Aeson as A+import GHC.Stack+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands++-- | A mouse button+data MouseButton = LeftButton | MiddleButton | RightButton+  deriving (Eq, Show, Ord, Bounded, Enum)++instance ToJSON MouseButton where+  toJSON = toJSON . fromEnum++instance FromJSON MouseButton where+  parseJSON v = parseJSON v >>= \case+    (0 :: Int) -> return LeftButton+    1 -> return MiddleButton+    2 -> return RightButton+    err -> fail $ "Invalid JSON for MouseButton: " ++ show err++-- -----------------------------------------------------------------------------+-- Legacy API (Wire Protocol)+-- -----------------------------------------------------------------------------++movementTimeMs :: Int+movementTimeMs = 50++-- | Moves the mouse to the given position relative to the current pointer position.+moveTo :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()+moveTo (x, y) = performActions [PointerSource "mouse1" [ActionPointer $ PointerMove PointerCurrent x y movementTimeMs]]++-- | Moves the mouse to the center of a given element.+moveToCenter :: (HasCallStack, WebDriver wd) => Element -> wd ()+moveToCenter el = performActions [PointerSource "mouse1" [ActionPointer $ PointerMove (PointerElement el) 0 0 movementTimeMs]]++-- | Moves the mouse to the given position relative to the given element.+moveToFrom :: (HasCallStack, WebDriver wd) => (Int, Int) -> Element -> wd ()+moveToFrom (x, y) el = performActions [PointerSource "mouse1" [ActionPointer $ PointerMove (PointerElement el) x y movementTimeMs]]++-- | Helper to click the center of an element.+clickCenter :: (HasCallStack, WebDriver wd) => Element -> wd ()+clickCenter el = performActions [PointerSource "mouse1" [+  ActionPointer $ PointerMove (PointerElement el) 0 0 movementTimeMs+  , ActionPointer $ PointerDown LeftButton+  , ActionPointer $ PointerUp LeftButton+  ]]++-- | Helper to double click the center of an element.+doubleClickCenter :: (HasCallStack, WebDriver wd) => Element -> wd ()+doubleClickCenter el = performActions [PointerSource "mouse1" [+  ActionPointer $ PointerMove (PointerElement el) 0 0 movementTimeMs+  , ActionPointer $ PointerDown LeftButton+  , ActionPointer $ PointerUp LeftButton+  , ActionPause 100+  , ActionPointer $ PointerDown LeftButton+  , ActionPointer $ PointerUp LeftButton+  ]]++-- -----------------------------------------------------------------------------+-- Modern Actions API+-- -----------------------------------------------------------------------------++-- | Origin for pointer actions+data PointerOrigin+  = PointerViewport+  | PointerCurrent+  | PointerElement Element+  deriving (Eq, Show)++-- | Individual pointer actions+data PointerAction+  = PointerMove { moveOrigin :: PointerOrigin, moveX :: Int, moveY :: Int, moveDuration :: Int }+  | PointerDown { downButton :: MouseButton }+  | PointerUp { upButton :: MouseButton }+  | PointerCancel+  deriving (Eq, Show)++-- | Individual key actions+data KeyAction+  = KeyDown { keyValue :: String }+  | KeyUp { keyValue :: String }+  deriving (Eq, Show)++-- | Generic action that can be pause, pointer, or key+data Action+  = ActionPause { pauseDuration :: Int }+  | ActionPointer { pointerAction :: PointerAction }+  | ActionKey { keyAction :: KeyAction }+  deriving (Eq, Show)++-- | Action source (input device)+data ActionSource+  = PointerSource { sourceId :: String, actions :: [Action] }+  | KeySource { sourceId :: String, actions :: [Action] }+  deriving (Eq, Show)++-- | Perform a sequence of actions from multiple input sources+performActions :: (HasCallStack, WebDriver wd) => [ActionSource] -> wd ()+performActions sources = noReturn $ doSessCommand methodPost "/actions"+  (A.object ["actions" A..= map sourceToJSON sources])++-- | Release all currently pressed keys and buttons+releaseActions :: (HasCallStack, WebDriver wd) => wd ()+releaseActions = noReturn $ doSessCommand methodDelete "/actions" noObject++-- -----------------------------------------------------------------------------+-- Internal helpers+-- -----------------------------------------------------------------------------++sourceToJSON :: ActionSource -> A.Value+sourceToJSON (PointerSource sid acts) = A.object [+  "type" A..= ("pointer" :: String)+  , "id" A..= sid+  , "actions" A..= map actionToJSON acts+  ]+sourceToJSON (KeySource sid acts) = A.object [+  "type" A..= ("key" :: String)+  , "id" A..= sid+  , "actions" A..= map actionToJSON acts+  ]++actionToJSON :: Action -> A.Value+actionToJSON (ActionPause dur) = A.object [+  "type" A..= ("pause" :: String)+  , "duration" A..= dur+  ]+actionToJSON (ActionPointer pact) = pointerActionToJSON pact+actionToJSON (ActionKey kact) = keyActionToJSON kact++pointerActionToJSON :: PointerAction -> A.Value+pointerActionToJSON (PointerMove orig x y dur) = A.object ([+  "type" A..= ("pointerMove" :: String)+  , "duration" A..= dur+  , "x" A..= x+  , "y" A..= y+  ] <> originToJSON orig)+  where+    originToJSON :: PointerOrigin -> [(Key, A.Value)]+    originToJSON PointerViewport = [("origin", A.String "viewport")]+    originToJSON PointerCurrent = [("origin", A.String "pointer")]+    originToJSON (PointerElement (Element e)) = [("origin", A.object ["element-6066-11e4-a52e-4f735466cecf" A..= e])]+pointerActionToJSON (PointerDown btn) = A.object [+  "type" A..= ("pointerDown" :: String)+  , "button" A..= btn+  ]+pointerActionToJSON (PointerUp btn) = A.object [+  "type" A..= ("pointerUp" :: String)+  , "button" A..= btn+  ]+pointerActionToJSON PointerCancel = A.object [+  "type" A..= ("pointerCancel" :: String)+  ]++keyActionToJSON :: KeyAction -> A.Value+keyActionToJSON (KeyDown val) = A.object [+  "type" A..= ("keyDown" :: String)+  , "value" A..= val+  ]+keyActionToJSON (KeyUp val) = A.object [+  "type" A..= ("keyUp" :: String)+  , "value" A..= val+  ]
+ src/Test/WebDriver/Commands/CommandContexts.hs view
@@ -0,0 +1,120 @@++module Test.WebDriver.Commands.CommandContexts (+  getCurrentWindow+  , closeWindow+  , focusWindow+  , windows+  , focusFrame+  , focusParentFrame++  -- * Resizing and positioning windows+  , getWindowRect+  , setWindowRect+  , maximize+  , minimize+  , fullscreen++  -- * Types+  , FrameSelector(..)+  , Rect(..)+  , WindowHandle(..)+  ) where++import Control.Monad+import Data.Aeson as A+import Data.Aeson.Types+import Data.Text (Text)+import GHC.Stack+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Returns a handle to the currently focused window+getCurrentWindow :: (HasCallStack, WebDriver wd) => wd WindowHandle+getCurrentWindow = doSessCommand methodGet "/window" Null++-- | Closes the given window+closeWindow :: (HasCallStack, WebDriver wd) => WindowHandle -> wd ()+closeWindow w = do+  cw <- getCurrentWindow+  focusWindow w+  ignoreReturn $ doSessCommand methodDelete "/window" Null+  unless (w == cw) $ focusWindow cw++-- | Switch to a given window+focusWindow :: (HasCallStack, WebDriver wd) => WindowHandle -> wd ()+focusWindow w = noReturn $ doSessCommand methodPost "/window" . single "handle" $ w++-- | Returns a list of all windows available to the session+windows :: (HasCallStack, WebDriver wd) => wd [WindowHandle]+windows = doSessCommand methodGet "/window/handles" Null++-- | Switch focus to the frame specified by the FrameSelector.+focusFrame :: (HasCallStack, WebDriver wd) => FrameSelector -> wd ()+focusFrame s = noReturn $ doSessCommand methodPost "/frame" . single "id" $ s++-- | Switch focus to the frame specified by the FrameSelector.+focusParentFrame :: (HasCallStack, WebDriver wd) => wd ()+focusParentFrame = ignoreReturn $ doSessCommand methodPost "/frame/parent" (A.object [])++-- | Get the dimensions of the current window.+getWindowRect :: (HasCallStack, WebDriver wd) => wd Rect+getWindowRect = doSessCommand methodGet "/window/rect" Null++-- | Set the dimensions of the current window.+setWindowRect :: (HasCallStack, WebDriver wd) => Rect -> wd ()+setWindowRect = ignoreReturn . doSessCommand methodPost "/window/rect"++-- | Maximizes the current window+maximize :: (HasCallStack, WebDriver wd) => wd ()+maximize = ignoreReturn $ doSessCommand methodPost "/window/maximize" (A.object [])++-- | Minimizes the current window+minimize :: (HasCallStack, WebDriver wd) => wd ()+minimize = ignoreReturn $ doSessCommand methodPost "/window/minimize" (A.object [])++-- | Fullscreens the current window+fullscreen :: (HasCallStack, WebDriver wd) => wd ()+fullscreen = ignoreReturn $ doSessCommand methodPost "/window/fullscreen" (A.object [])+++-- | Specifies the frame used by 'Test.WebDriver.Commands.focusFrame'+data FrameSelector =+  WithIndex Integer+  -- | Focus on a frame by name or ID+  | WithName Text+  -- | Focus on a frame 'Element'+  | WithElement Element+  -- | Focus on the first frame, or the main document if iframes are used.+  | DefaultFrame+  deriving (Eq, Show, Read)++instance ToJSON FrameSelector where+  toJSON s = case s of+    WithIndex i -> toJSON i+    WithName n -> toJSON n+    WithElement e -> toJSON e+    DefaultFrame -> Null++data Rect = Rect {+  rectX :: Float+  , rectY :: Float+  , rectWidth :: Float+  , rectHeight :: Float+  } deriving (Eq, Ord, Show)++instance FromJSON Rect where+  parseJSON (Object o) = Rect <$> o .: "x"+                              <*> o .: "y"+                              <*> o .: "width"+                              <*> o .: "height"+  parseJSON j = typeMismatch "Rect" j++instance ToJSON Rect where+  toJSON (Rect x y width height)+    = object [ "x" .= x+             , "y" .= y+             , "width" .= width+             , "height" .= height+             ]
+ src/Test/WebDriver/Commands/Cookies.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE DeriveGeneric #-}++module Test.WebDriver.Commands.Cookies (+  cookies+  , cookie+  , setCookie+  , deleteCookie+  , deleteCookies++  -- * Types+  , mkCookie+  , Cookie(..)+  ) where++import Data.Aeson as A+import Data.Aeson.Types+import qualified Data.Char as C+import Data.Text (Text)+import GHC.Generics+import GHC.Stack+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Retrieve all cookies.+cookies :: (HasCallStack, WebDriver wd) => wd [Cookie]+cookies = doSessCommand methodGet "/cookie" Null++-- | Retrieve a specific cookie by name.+cookie :: (HasCallStack, WebDriver wd) => Text -> wd Cookie+cookie n = doSessCommand methodGet ("/cookie/" <> n) Null++-- | Set a cookie. If the cookie path is not specified, it will default to \"/\".+-- Likewise, if the domain is omitted, it will default to the current page's domain.+setCookie :: (HasCallStack, WebDriver wd) => Cookie -> wd ()+setCookie = noReturn . doSessCommand methodPost "/cookie" . single "cookie"++-- | Delete a cookie by name.+deleteCookie :: (HasCallStack, WebDriver wd) => Text -> wd ()+deleteCookie n = noReturn $ doSessCommand methodDelete ("/cookie/" <> urlEncode n) Null++-- | Delete all visible cookies on the current page.+deleteCookies :: (HasCallStack, WebDriver wd) => wd ()+deleteCookies = noReturn $ doSessCommand methodDelete "/cookie" Null++-- * Types++-- | Cookies are delicious delicacies. When sending cookies to the server, a value+-- of Nothing indicates that the server should use a default value. When receiving+-- cookies from the server, a value of Nothing indicates that the server is unable+-- to specify the value.+data Cookie = Cookie {+  cookName   :: Text+  , cookValue  :: Text+  -- | Path of this cookie. If Nothing, defaults to /+  , cookPath   :: Maybe Text+  -- | Domain of this cookie. If Nothing, the current page's domain is used.+  , cookDomain :: Maybe Text+  -- | Is this cookie secure?+  , cookSecure :: Maybe Bool+  -- | Expiry date expressed as seconds since the Unix epoch.+  -- 'Nothing' indicates that the cookie never expires.+  , cookExpiry :: Maybe Double+  } deriving (Eq, Show, Generic)++aesonOptionsCookie :: Options+aesonOptionsCookie = defaultOptions {+  omitNothingFields = True+  , fieldLabelModifier = map C.toLower . drop 4+  }++-- | Creates a Cookie with only a name and value specified. All other+-- fields are set to Nothing, which tells the server to use default values.+mkCookie :: Text -> Text -> Cookie+mkCookie name value = Cookie {+  cookName = name+  , cookValue = value+  , cookPath = Nothing+  , cookDomain = Nothing+  , cookSecure = Nothing+  , cookExpiry = Nothing+  }++instance ToJSON Cookie where+  toJSON = genericToJSON aesonOptionsCookie+  toEncoding = genericToEncoding aesonOptionsCookie+instance FromJSON Cookie where+  parseJSON (Object o) = Cookie <$> req "name"+                                <*> req "value"+                                <*> opt "path" Nothing+                                <*> opt "domain" Nothing+                                <*> opt "secure" Nothing+                                <*> opt "expiry" Nothing+    where+      req :: FromJSON a => Text -> Parser a+      req = (o .:) . aesonKeyFromText+      opt :: FromJSON a => Text -> a -> Parser a+      opt k d = o .:?? k .!= d+  parseJSON v = typeMismatch "Cookie" v
+ src/Test/WebDriver/Commands/DocumentHandling.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE ExistentialQuantification #-}++module Test.WebDriver.Commands.DocumentHandling (+  getSource+  , executeJS+  , asyncJS+  , JSArg(..)+  ) where++import Data.Aeson as A+import qualified Data.Foldable as F+import qualified Data.List as L+import Data.Text (Text)+import GHC.Stack+import Test.WebDriver.Exceptions+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+import UnliftIO.Exception (handle, throwIO)+++-- | Get the current page source+getSource :: (HasCallStack, WebDriver wd) => wd Text+getSource = doSessCommand methodGet "/source" Null++{- | Inject a snippet of Javascript into the page for execution in the+context of the currently selected frame. The executed script is+assumed to be synchronous and the result of evaluating the script is+returned and converted to an instance of FromJSON.++The first parameter defines a sequence of arguments to pass to the javascript+function. Arguments of type Element will be converted to the+corresponding DOM element. Likewise, any elements in the script result+will be returned to the client as Elements.++The second parameter defines the script itself in the form of a+function body. The value returned by that function will be returned to+the client. The function will be invoked with the provided argument+list and the values may be accessed via the arguments object in the+order specified.++When using 'executeJS', GHC might complain about an ambiguous type in+situations where the result of the executeJS call is ignored/discard.+Consider the following example:++@+	jsExample = do+		e <- findElem (ByCSS "#foo")+		executeJS [] "someAction()"+		return e+@++Because the result of the 'executeJS' is discarded, GHC cannot resolve+which instance of the 'fromJSON' class to use when parsing the+Selenium server response. In such cases, we can use the 'ignoreReturn'+helper function located in "Test.WebDriver.JSON". 'ignoreReturn' has+no runtime effect; it simply helps the type system by expicitly providing+a `fromJSON` instance to use.++@+	import Test.WebDriver.JSON (ignoreReturn)+	jsExample = do+		e <- findElem (ByCSS "#foo")+		ignoreReturn $ executeJS [] "someAction()"+		return e+@+-}+executeJS :: (HasCallStack, F.Foldable f, FromJSON a, WebDriver wd) => f JSArg -> Text -> wd a+executeJS a s = do+  (doSessCommand methodPost "/execute/sync" . pair ("args", "script") $ (F.toList a,s))+    >>= fromJSON'++-- | Executes a snippet of Javascript code asynchronously. This function works+-- similarly to 'executeJS', except that the Javascript is passed a callback+-- function as its final argument. The script should call this function+-- to signal that it has finished executing, passing to it a value that will be+-- returned as the result of asyncJS. A result of Nothing indicates that the+-- Javascript function timed out (see 'setScriptTimeout')+asyncJS :: (HasCallStack, F.Foldable f, FromJSON a, WebDriver wd) => f JSArg -> Text -> wd (Maybe a)+asyncJS a s = handle timeout $ do+  Just <$> (fromJSON' =<< getResult "/execute/async")++  where+    getResult endpoint = doSessCommand methodPost endpoint . pair ("args", "script") $ (F.toList a,s)++    timeout (FailedCommand {rspError})+      | rspError `L.elem` [Timeout, ScriptTimeout] = return Nothing+    timeout err = throwIO err++-- | An existential wrapper for any 'ToJSON' instance. This allows us to pass+-- parameters of many different types to Javascript code.+data JSArg = forall a. ToJSON a => JSArg a++instance ToJSON JSArg where+  toJSON (JSArg a) = toJSON a
+ src/Test/WebDriver/Commands/ElementInteraction.hs view
@@ -0,0 +1,33 @@++module Test.WebDriver.Commands.ElementInteraction (+  click+  , clearInput+  , sendKeys+  -- , sendRawKeys+  ) where++import Data.Text (Text)+import GHC.Stack+import Test.WebDriver.JSON (noObject, noReturn, single)+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Click on an element.+click :: (HasCallStack, WebDriver wd) => Element -> wd ()+click e = noReturn $ doElemCommand methodPost e "/click" noObject++-- | Clear a textarea or text input element's value.+clearInput :: (HasCallStack, WebDriver wd) => Element -> wd ()+clearInput e = noReturn $ doElemCommand methodPost e "/clear" noObject++-- | Send a sequence of keystrokes to an element. All modifier keys are released+-- at the end of the function. Named constants for special modifier keys can be found+-- in "Test.WebDriver.Keys"+sendKeys :: (HasCallStack, WebDriver wd) => Text -> Element -> wd ()+sendKeys t e = noReturn . doElemCommand methodPost e "/value" . single "text" $ t++-- -- | Similar to sendKeys, but doesn't implicitly release modifier keys+-- -- afterwards. This allows you to combine modifiers with mouse clicks.+-- sendRawKeys :: (HasCallStack, WebDriver wd) => Text -> wd ()+-- sendRawKeys t = noReturn . doSessCommand methodPost "/keys" . single "text" $ t
+ src/Test/WebDriver/Commands/ElementRetrieval.hs view
@@ -0,0 +1,58 @@++module Test.WebDriver.Commands.ElementRetrieval (+  findElem+  , findElems+  , findElemFrom+  , findElemsFrom+  , activeElem++  , Selector(..)+  , Element(..)+  ) where++import Data.Aeson as A+import Data.Text (Text)+import GHC.Stack+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Find an element on the page using the given element selector.+findElem :: (HasCallStack, WebDriver wd) => Selector -> wd Element+findElem = doSessCommand methodPost "/element"++-- | Find all elements on the page matching the given selector.+findElems :: (HasCallStack, WebDriver wd) => Selector -> wd [Element]+findElems = doSessCommand methodPost "/elements"++-- | Search for an element using the given element as root.+findElemFrom :: (HasCallStack, WebDriver wd) => Element -> Selector -> wd Element+findElemFrom e = doElemCommand methodPost e "/element"++-- | Find all elements matching a selector, using the given element as root.+findElemsFrom :: (HasCallStack, WebDriver wd) => Element -> Selector -> wd [Element]+findElemsFrom e = doElemCommand methodPost e "/elements"++-- | Return the element that currently has focus.+activeElem :: (HasCallStack, WebDriver wd) => wd Element+activeElem = doSessCommand methodGet "/element/active" Null++-- | Specifies element(s) within a DOM tree using various selection methods.+data Selector =+  ByCSS Text+  | ByLinkText Text+  | ByPartialLinkText Text+  | ByTag Text+  | ByXPath Text+  deriving (Eq, Show, Ord)++instance ToJSON Selector where+  toJSON s = case s of+    ByTag t             -> selector "tag name" t+    ByLinkText t        -> selector "link text" t+    ByPartialLinkText t -> selector "partial link text" t+    ByCSS t             -> selector "css selector" t+    ByXPath t           -> selector "xpath" t+    where+      selector :: Text -> Text -> Value+      selector sn t = object ["using" .= sn, "value" .= t]
+ src/Test/WebDriver/Commands/ElementState.hs view
@@ -0,0 +1,51 @@++module Test.WebDriver.Commands.ElementState (+  isSelected+  , attr+  , prop+  , cssProp+  , getText+  , tagName+  , elemRect+  , isEnabled+  ) where++import Data.Aeson as A+import Data.Text (Text, append)+import GHC.Stack+import Test.WebDriver.Commands.CommandContexts+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Determine if the element is selected.+isSelected :: (HasCallStack, WebDriver wd) => Element -> wd Bool+isSelected e = doElemCommand methodGet e "/selected" Null++-- | Retrieve the value of an element's attribute+attr :: (HasCallStack, WebDriver wd) => Element -> Text -> wd (Maybe Text)+attr e t = doElemCommand methodGet e ("/attribute/" `append` urlEncode t) Null++-- | Retrieve the value of an element's property+prop :: (HasCallStack, WebDriver wd) => Element -> Text -> wd (Maybe Value)+prop e t = doElemCommand methodGet e ("/property/" `append` urlEncode t) Null++-- | Retrieve the value of an element's computed CSS property+cssProp :: (HasCallStack, WebDriver wd) => Element -> Text -> wd (Maybe Text)+cssProp e t = doElemCommand methodGet e ("/css/" `append` urlEncode t) Null++-- | Get all visible text within this element.+getText :: (HasCallStack, WebDriver wd) => Element -> wd Text+getText e = doElemCommand methodGet e "/text" Null++-- | Return the tag name of the given element.+tagName :: (HasCallStack, WebDriver wd) => Element -> wd Text+tagName e = doElemCommand methodGet e "/name" Null++-- | Retrieve an element's current position.+elemRect :: (HasCallStack, WebDriver wd) => Element -> wd Rect+elemRect e = doElemCommand methodGet e "/rect" Null++-- | Determine if the element is enabled.+isEnabled :: (HasCallStack, WebDriver wd) => Element -> wd Bool+isEnabled e = doElemCommand methodGet e "/enabled" Null
− src/Test/WebDriver/Commands/Internal.hs 
@@ -1,108 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--{-# OPTIONS_HADDOCK not-home #-}--- | Internal functions used to implement the functions exported by--- "Test.WebDriver.Commands". These may be useful for implementing non-standard--- webdriver commands.-module Test.WebDriver.Commands.Internal-       (-- * Low-level webdriver functions-         doCommand-        -- ** Commands with :sessionId URL parameter-       , doSessCommand, SessionId(..)-        -- ** Commands with element :id URL parameters-       , doElemCommand, Element(..)-        -- ** Commands with :windowHandle URL parameters-       , doWinCommand, WindowHandle(..), currentWindow-        -- * Exceptions-       , NoSessionId(..)-       ) where--import Test.WebDriver.Class-import Test.WebDriver.JSON-import Test.WebDriver.Session-import Test.WebDriver.Utils (urlEncode)--import Control.Applicative-import Control.Exception.Lifted-import Data.Aeson-import Data.Aeson.Types-import Data.CallStack-import Data.Default (Default, def)-import Data.Text (Text)-import qualified Data.Text as T-import Data.Typeable--import Prelude -- hides some "unused import" warnings--{- |An opaque identifier for a web page element. -}-newtype Element = Element Text-                  deriving (Eq, Ord, Show, Read)--instance FromJSON Element where-  parseJSON (Object o) = Element <$> (o .: "ELEMENT" <|> o .: "element-6066-11e4-a52e-4f735466cecf")-  parseJSON v = typeMismatch "Element" v--instance ToJSON Element where-  toJSON (Element e) = object ["ELEMENT" .= e]---{- |An opaque identifier for a browser window -}-newtype WindowHandle = WindowHandle Text-                     deriving (Eq, Ord, Show, Read,-                               FromJSON, ToJSON)-instance Default WindowHandle where-  def = currentWindow---- |A special 'WindowHandle' that always refers to the currently focused window.--- This is also used by the 'Default' instance.-currentWindow :: WindowHandle-currentWindow = WindowHandle "current"--instance Exception NoSessionId--- |A command requiring a session ID was attempted when no session ID was--- available.-newtype NoSessionId = NoSessionId String-                 deriving (Eq, Show, Typeable)---- |This a convenient wrapper around 'doCommand' that automatically prepends--- the session URL parameter to the wire command URL. For example, passing--- a URL of \"/refresh\" will expand to \"/session/:sessionId/refresh\", where--- :sessionId is a URL parameter as described in--- <https://github.com/SeleniumHQ/selenium/wiki/JsonWireProtocol>-doSessCommand :: (HasCallStack, WebDriver wd, ToJSON a, FromJSON b) =>-                  Method -> Text -> a -> wd b-doSessCommand method path args = do-  WDSession { wdSessId = mSessId } <- getSession-  case mSessId of-      Nothing -> throwIO . NoSessionId $ msg-        where-          msg = "doSessCommand: No session ID found for relative URL "-                ++ show path-      Just (SessionId sId) ->-        -- Catch BadJSON exceptions here, since most commands go through this function.-        -- Then, re-throw them with "error", which automatically appends a callstack-        -- to the message in modern GHCs.-        -- This callstack makes it easy to see which command caused the BadJSON exception,-        -- without exposing too many internals.-        catch-          (doCommand method (T.concat ["/session/", urlEncode sId, path]) args)-          (\(e :: BadJSON) -> error $ show e)---- |A wrapper around 'doSessCommand' to create element URLs.--- For example, passing a URL of "/active" will expand to--- \"/session/:sessionId/element/:id/active\", where :sessionId and :id are URL--- parameters as described in the wire protocol.-doElemCommand :: (HasCallStack, WebDriver wd, ToJSON a, FromJSON b) =>-                  Method -> Element -> Text -> a -> wd b-doElemCommand m (Element e) path a =-  doSessCommand m (T.concat ["/element/", urlEncode e, path]) a---- |A wrapper around 'doSessCommand' to create window handle URLS.--- For example, passing a URL of \"/size\" will expand to--- \"/session/:sessionId/window/:windowHandle/\", where :sessionId and--- :windowHandle are URL parameters as described in the wire protocol-doWinCommand :: (HasCallStack, WebDriver wd, ToJSON a, FromJSON b) =>-                 Method -> WindowHandle -> Text -> a -> wd b-doWinCommand m (WindowHandle w) path a =-  doSessCommand m (T.concat ["/window/", urlEncode w, path]) a
+ src/Test/WebDriver/Commands/Logs.hs view
@@ -0,0 +1,48 @@+module Test.WebDriver.Commands.Logs (+  -- * Main log retrieval functions+  withRecordLogsViaBiDi+  , withRecordLogsViaBiDi'++  , getLogs++  -- * Driver-specific implementations+  -- , getChromeLogs+  -- , getFirefoxLogs+  -- , getSeleniumLogs+  -- , getSeleniumLogTypes++  -- * Types+  , LogType+  , LogEntry(..)+  , LogLevel(..)+  ) where++import GHC.Stack+import Test.WebDriver.Commands.Logs.BiDi+import Test.WebDriver.Commands.Logs.Chrome+import Test.WebDriver.Commands.Logs.Common+import Test.WebDriver.Commands.Logs.Firefox+import Test.WebDriver.Commands.Logs.Selenium+import Test.WebDriver.Types+++-- | Retrieve logs of a specific type from the browser. The W3C spec doesn't+-- define how to do this natively, so we automatically detect the browser and+-- try to use an appropriate method:+--+-- * Chrome/Chromium: Chrome DevTools Protocol (CDP)+-- * Firefox: legacy log endpoint (/log)+-- * Selenium: legacy log endpoint (/log)+-- * Other browsers: returns empty list+--+-- Common log types: @browser@, @driver@, @performance@, @server@.+--+-- However, the modern way to do this is via 'withRecordLogsViaBiDi'.+getLogs :: (HasCallStack, WebDriver wd) => LogType -> wd [LogEntry]+getLogs logType = do+  Session { sessionDriver = Driver { _driverConfig = driverConfig } } <- getSession+  case detectBrowserFromDriver driverConfig of+    Just BrowserChrome -> getChromeLogs logType+    Just BrowserFirefox -> getFirefoxLogs logType+    Just BrowserSelenium -> getSeleniumLogs logType+    Nothing -> return [] -- Return empty for unsupported browsers
+ src/Test/WebDriver/Commands/Logs/BiDi.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}++module Test.WebDriver.Commands.Logs.BiDi (+  withRecordLogsViaBiDi+  , withRecordLogsViaBiDi'+  ) where++import Control.Concurrent.STM (retry)+import Control.Monad (forever)+import Control.Monad.Fix (fix)+import Control.Monad.IO.Unlift+import Control.Monad.Logger (MonadLogger, logDebugN, logErrorN, logInfoN, logWarnN)+import Data.Aeson+import Data.Aeson.TH+import Data.Aeson.Types (parseEither)+import qualified Data.List as L+import Data.String.Interpolate+import Data.Text (Text)+import qualified Network.URI as URI+import qualified Network.WebSockets as WS+import Test.WebDriver.Capabilities.Aeson+import Test.WebDriver.Commands.Logs.Common+import Test.WebDriver.Types+import Text.Read (readMaybe)+import UnliftIO.Async (withAsync)+import UnliftIO.Exception+import UnliftIO.STM (atomically, newTVarIO, readTVar, writeTVar)+import UnliftIO.Timeout (timeout)+++data BiDiLogEvent = BiDiLogEvent {+  biDiType :: Text+  , biDiMethod :: Text+  , biDiParams :: Value+  } deriving Show+deriveFromJSON toCamel2 ''BiDiLogEvent++data BiDiResponse = BiDiResponse {+  biDiResponseType :: Text+  , biDiResponseId :: Int+  , biDiResponseResult :: Maybe Value+  , biDiResponseError :: Maybe Value+  } deriving Show+deriveFromJSON toCamel3 ''BiDiResponse++-- | Wrapper around 'withRecordLogsViaBiDi'' which uses the WebSocket URL from+-- the current 'Session'. You must make sure to pass '_capabilitiesWebSocketUrl'+-- = @Just True@ to enable this. This will not work with Selenium 3.+withRecordLogsViaBiDi :: (WebDriver m, MonadLogger m) => (LogEntry -> m ()) -> m a -> m a+withRecordLogsViaBiDi cb action = do+  Session {..} <- getSession+  webSocketUrl <- case sessionWebSocketUrl of+    Nothing -> throwIO $ userError [i|Session wasn't configured with a BiDi WebSocket URL when trying to record logs. Make sure to enable _capabilitiesWebSocketUrl.|]+    Just x -> pure x++  uri <- case URI.parseURI webSocketUrl of+    Just x -> pure x+    Nothing -> throwIO $ userError [i|Couldn't parse WebSocket URL: #{webSocketUrl}|]++  withRecordLogsViaBiDi' uri cb action++-- | Connect to WebSocket URL and subscribe to log events using the W3C BiDi protocol; see+-- <https://w3c.github.io/webdriver-bidi/>.+withRecordLogsViaBiDi' :: (MonadUnliftIO m, MonadLogger m) => URI.URI -> (LogEntry -> m ()) -> m a -> m a+withRecordLogsViaBiDi' uri@(URI.URI { uriAuthority=(Just (URI.URIAuth {uriPort=(readMaybe . L.drop 1 -> Just (port :: Int)), ..})), .. }) cb action = do+  subscriptionStatus <- newTVarIO Nothing++  withAsync (backgroundAction subscriptionStatus) $ \_ -> do+    -- Wait for subscription to be confirmed or errored before proceeding+    result <- atomically $ do+      status <- readTVar subscriptionStatus+      case status of+        Nothing -> retry+        Just (Left err) -> pure (Left err)+        Just (Right ()) -> pure (Right ())++    case result of+      Left err -> throwIO err+      Right () -> action++  where+    backgroundAction subscriptionStatus = withRunInIO $ \runInIO -> do+      result <- tryAny $ do+        runInIO $ logDebugN [i|BiDi: Connecting to #{uriRegName}:#{port}#{uriPath}|]++        liftIO $ WS.runClient uriRegName port uriPath $ \conn -> do+          runInIO $ logInfoN "BiDi: Connected successfully"++          -- Send subscription request for console logs+          runInIO $ logDebugN "BiDi: Sending subscription request"+          WS.sendTextData conn $ encode $ object [+            "id" .= (1 :: Int)+            , "method" .= ("session.subscribe" :: Text)+            , "params" .= object [+                "events" .= (["log.entryAdded"] :: [Text])+              ]+            ]+          runInIO $ logDebugN "BiDi: Sent subscription request, waiting for response..."++          subscriptionResult <- timeout 15_000_000 $ fix $ \loop -> do+            msg <- WS.receiveData conn+            runInIO $ logDebugN [i|BiDi: Waiting for subscription response: #{msg}|]+            case decode msg of+              Just response@(BiDiResponse responseType responseId _ _)+                | responseType == "success" && responseId == 1 -> do+                    runInIO $ logInfoN "BiDi: Subscription successful!"+                    atomically $ writeTVar subscriptionStatus (Just (Right ()))+                | responseType == "error" && responseId == 1 -> do+                    let errMsg = "BiDi subscription failed: " ++ show response+                    runInIO $ logErrorN [i|BiDi: #{errMsg}|]+                    atomically $ writeTVar subscriptionStatus (Just (Left (toException (userError errMsg))))+                | otherwise -> do+                    runInIO $ logDebugN [i|BiDi: Ignoring response with type #{responseType}, ID #{responseId}|]+                    loop+              Nothing -> do+                runInIO $ logDebugN [i|BiDi: Not a BiDiResponse, continuing to wait for subscription response (#{msg})|]+                loop++          case subscriptionResult of+            Nothing -> do+              runInIO $ logErrorN "BiDi: Subscription response timed out"+              atomically $ writeTVar subscriptionStatus (Just (Left (toException (userError "BiDi subscription response timed out"))))+            Just () -> do+              runInIO $ logDebugN "BiDi: Starting log event listener"+              forever $ do+                msg <- WS.receiveData conn+                runInIO $ logDebugN [i|BiDi: Received log event: #{msg}|]+                case decode msg of+                  Just (BiDiLogEvent "event" "log.entryAdded" params) ->+                    case parseBiDiLogEntry params of+                      Just logEntry -> runInIO (cb logEntry)+                      Nothing -> runInIO $ logWarnN "BiDi: Failed to parse log entry"+                  _ -> runInIO $ logDebugN [i|BiDi: Ignoring non-log event message: #{msg}|]++      case result of+        Left ex -> do+          runInIO $ logErrorN [i|BiDi: got exception (URI #{uri}): #{ex}|]+          atomically $ writeTVar subscriptionStatus (Just (Left ex))+        Right () -> pure ()+withRecordLogsViaBiDi' uri _cb _action =+  throwIO $ userError [i|WebSocket URL didn't contain an authority: #{uri}|]++-- | Convert BiDi log parameters to LogEntry+parseBiDiLogEntry :: Value -> Maybe LogEntry+parseBiDiLogEntry = \case+  Object o -> case parseEither parseLogEntry o of+    Right entry -> Just entry+    Left _ -> Nothing+  _ -> Nothing+  where+    parseLogEntry o = do+      timestamp <- o .: "timestamp"+      levelText <- o .: "level"+      message <- o .: "text"+      level <- case parseLogLevel levelText of+        Just l -> pure l+        Nothing -> fail "Invalid log level"+      pure $ LogEntry (round (timestamp :: Double)) level message++    parseLogLevel :: Text -> Maybe LogLevel+    parseLogLevel = \case+      "debug" -> Just LogDebug+      "info" -> Just LogInfo+      "warn" -> Just LogWarning+      "error" -> Just LogSevere+      _ -> Nothing
+ src/Test/WebDriver/Commands/Logs/Chrome.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module Test.WebDriver.Commands.Logs.Chrome (+  getChromeLogs+  ) where++import Data.Aeson+import qualified Data.Foldable as F+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Stack+import Test.WebDriver.Commands.Logs.Common+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Aeson+import Test.WebDriver.Util.Commands+import UnliftIO.Exception+++getChromeLogs :: (HasCallStack, WebDriver wd) => LogType -> wd [LogEntry]+getChromeLogs logType =+  tryAny (getChromeLogsViaCDP logType) >>= \case+    Right entries -> return entries+    Left (_ :: SomeException) -> getLegacyChromeLogs logType++getChromeLogsViaCDP :: (HasCallStack, WebDriver wd) => LogType -> wd [LogEntry]+getChromeLogsViaCDP _logType = do+  result <- doSessCommand methodPost "/goog/cdp/execute" $ object [+    "cmd" .= ("Runtime.getConsoleEntries" :: Text)+    , "params" .= object []+    ]+  case result of+    (Object (aesonLookup "value" -> Just (Object (aesonLookup "result" -> Just (Object (aesonLookup "entries" -> Just (Array entries))))))) ->+      mapM parseChromeLogEntry (F.toList entries)+    _ -> return []++  where+    parseChromeLogEntry :: (WebDriver wd) => Value -> wd LogEntry+    parseChromeLogEntry (Object obj) = do+      timestamp :: Double <- obj !: "timestamp"+      level :: Text <- obj !: "level"+      message :: Text <- obj !: "text"+      return $ LogEntry {+        logTime = round timestamp+        , logLevel = parseChromeLogLevel level+        , logMsg = message+        }+    parseChromeLogEntry v = return $ LogEntry {+      logTime = 0+      , logLevel = LogInfo+      , logMsg = "Failed to parse log entry: " <> T.pack (show v)+      }++    parseChromeLogLevel :: Text -> LogLevel+    parseChromeLogLevel level = case level of+      "verbose" -> LogDebug+      "debug"   -> LogDebug+      "log"     -> LogInfo+      "info"    -> LogInfo+      "warning" -> LogWarning+      "error"   -> LogSevere+      _         -> LogInfo++getLegacyChromeLogs :: (HasCallStack, WebDriver wd) => LogType -> wd [LogEntry]+getLegacyChromeLogs logType = do+  tryAny (doSessCommand methodPost "/log" $ object ["type" .= logType]) >>= \case+    Right (Array logs) -> mapM fromJSON' (F.toList logs)+    Right _ -> return []+    Left (_ :: SomeException) -> return []
+ src/Test/WebDriver/Commands/Logs/Common.hs view
@@ -0,0 +1,102 @@+module Test.WebDriver.Commands.Logs.Common (+  Browser(..)+  , detectBrowserFromDriver++  -- * Re-exports+  , LogType+  , LogEntry(..)+  , LogLevel(..)+  ) where++import Data.Aeson as A+import Data.Aeson.Types (typeMismatch)+import Data.Maybe+import Data.Text (Text)+import Test.WebDriver.Types++-- | Supported browsers for log retrieval+data Browser =+  BrowserChrome+  | BrowserFirefox+  | BrowserSelenium+  deriving (Eq, Show)++detectBrowserFromDriver :: DriverConfig -> Maybe Browser+detectBrowserFromDriver driverConfig = case driverConfig of+  DriverConfigSeleniumJar { driverConfigSubDrivers = subDrivers } ->+    case subDrivers of+      (subDriver:_) -> detectBrowserFromDriver subDriver+      [] -> Just BrowserSelenium+  DriverConfigGeckodriver {} -> Just BrowserFirefox+  DriverConfigChromedriver {} -> Just BrowserChrome+++-- | A record that represents a single log entry.+data LogEntry = LogEntry {+  -- | Timestamp for the log entry. The standard does not specify the epoch or+  -- the unit of time.+  logTime  :: Integer+  -- | Log verbosity level.+  , logLevel :: LogLevel+  , logMsg   :: Text+  }+  deriving (Eq, Ord, Show, Read)++instance FromJSON LogEntry where+  parseJSON (Object o) =+    LogEntry <$> o .: "timestamp"+             <*> o .: "level"+             <*> (fromMaybe "" <$> o .: "message")+  parseJSON v = typeMismatch "LogEntry" v++instance ToJSON LogEntry where+  toJSON (LogEntry {..}) = A.object [+    ("timestamp", A.Number (fromIntegral logTime))+    , ("level", toJSON logLevel)+    , ("message", A.String logMsg)+    ]++type LogType = String++-- | Indicates a log verbosity level.+data LogLevel =+  LogOff+  | LogSevere+  | LogWarning+  | LogInfo+  | LogConfig+  | LogFine+  | LogFiner+  | LogFinest+  | LogDebug+  | LogAll+  deriving (Eq, Show, Read, Ord, Bounded, Enum)++instance ToJSON LogLevel where+  toJSON p= String $ case p of+    LogOff -> "OFF"+    LogSevere -> "SEVERE"+    LogWarning -> "WARNING"+    LogInfo -> "INFO"+    LogConfig -> "CONFIG"+    LogFine -> "FINE"+    LogFiner -> "FINER"+    LogFinest -> "FINEST"+    LogDebug -> "DEBUG"+    LogAll -> "ALL"++instance FromJSON LogLevel where+  parseJSON (String s) = case s of+    "OFF" -> return LogOff+    "SEVERE" -> return LogSevere+    "WARNING" -> return LogWarning+    "INFO" -> return LogInfo+    "CONFIG" -> return LogConfig+    "FINE" -> return LogFine+    "FINER" -> return LogFiner+    "FINEST" -> return LogFinest+    "DEBUG" -> return LogDebug+    "ALL" -> return LogAll+    _ -> fail ("Invalid logging preference: " ++ show s)++  parseJSON other = typeMismatch "LogLevel" other
+ src/Test/WebDriver/Commands/Logs/Firefox.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.WebDriver.Commands.Logs.Firefox (+  getFirefoxLogs+  ) where++import Data.Aeson+import qualified Data.Foldable as F+import GHC.Stack+import Test.WebDriver.Commands.Logs.Common+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+import UnliftIO.Exception+++getFirefoxLogs :: (HasCallStack, WebDriver wd) => LogType -> wd [LogEntry]+getFirefoxLogs logType = getLegacyFirefoxLogs logType++-- | Try legacy Firefox log endpoints (typically not supported)+getLegacyFirefoxLogs :: (HasCallStack, WebDriver wd) => LogType -> wd [LogEntry]+getLegacyFirefoxLogs logType = do+  tryAny (doSessCommand methodPost "/log" $ object ["type" .= logType]) >>= \case+    Right (Array logs) -> mapM fromJSON' (F.toList logs)+    _ -> return []
+ src/Test/WebDriver/Commands/Logs/Selenium.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.WebDriver.Commands.Logs.Selenium (+  getSeleniumLogs+  , getSeleniumLogTypes+  ) where++import Data.Aeson+import GHC.Stack+import Test.WebDriver.Commands.Logs.Common+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Get logs from Selenium using the legacy /log endpoint+getSeleniumLogs :: (HasCallStack, WebDriver wd) => LogType -> wd [LogEntry]+getSeleniumLogs logType = doSessCommand methodPost "/log" $ object ["type" .= logType]++-- | Get a list of available log types.+getSeleniumLogTypes :: (HasCallStack, WebDriver wd) => wd [LogType]+getSeleniumLogTypes = doSessCommand methodGet "/log/types" Null
+ src/Test/WebDriver/Commands/Navigation.hs view
@@ -0,0 +1,47 @@++module Test.WebDriver.Commands.Navigation (+  openPage+  , getCurrentURL+  , back+  , forward+  , refresh+  , getTitle+  ) where++import Data.Aeson as A+import Data.Text (Text)+import GHC.Stack+import Network.URI hiding (path)  -- suppresses warnings+import Prelude -- hides some "unused import" warnings+import Test.WebDriver.Exceptions+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+import UnliftIO.Exception (throwIO)+++-- | Opens a new page by the given URL.+openPage :: (HasCallStack, WebDriver wd) => String -> wd ()+openPage url+  | isURI url = noReturn . doSessCommand methodPost "/url" . single "url" $ url+  | otherwise = throwIO . InvalidURL $ url++-- | Gets the URL of the current page.+getCurrentURL :: (HasCallStack, WebDriver wd) => wd String+getCurrentURL = doSessCommand methodGet "/url" Null++-- | Navigate backward in the browser history.+back :: (HasCallStack, WebDriver wd) => wd ()+back = noReturn $ doSessCommand methodPost "/back" noObject++-- | Navigate forward in the browser history.+forward :: (HasCallStack, WebDriver wd) => wd ()+forward = noReturn $ doSessCommand methodPost "/forward" noObject++-- | Refresh the current page+refresh :: (HasCallStack, WebDriver wd) => wd ()+refresh = noReturn $ doSessCommand methodPost "/refresh" noObject++-- | Get the title of the current page.+getTitle :: (HasCallStack, WebDriver wd) => wd Text+getTitle = doSessCommand methodGet "/title" Null
+ src/Test/WebDriver/Commands/ScreenCapture.hs view
@@ -0,0 +1,30 @@++module Test.WebDriver.Commands.ScreenCapture (+  screenshot+  , screenshotElement++  -- * Convenience functions+  , saveScreenshot+  ) where++import Control.Monad.IO.Class+import Data.Aeson as A+import Data.ByteString.Base64.Lazy as B64+import Data.ByteString.Lazy as LBS (ByteString, writeFile)+import qualified Data.Text.Lazy.Encoding as TL+import GHC.Stack+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Grab a screenshot of the current page as a PNG image.+screenshot :: (HasCallStack, WebDriver wd) => wd LBS.ByteString+screenshot = (B64.decodeLenient . TL.encodeUtf8) <$> doSessCommand methodGet "/screenshot" Null++-- | Grab a screenshot of the current page as a PNG image.+screenshotElement :: (HasCallStack, WebDriver wd) => Element -> wd LBS.ByteString+screenshotElement e = (B64.decodeLenient . TL.encodeUtf8) <$> doElemCommand methodGet e "/screenshot" Null++-- | Save a screenshot to a particular location.+saveScreenshot :: (HasCallStack, WebDriver wd) => FilePath -> wd ()+saveScreenshot path = screenshot >>= liftIO . LBS.writeFile path
+ src/Test/WebDriver/Commands/SeleniumSpecific/HTML5.hs view
@@ -0,0 +1,95 @@++module Test.WebDriver.Commands.SeleniumSpecific.HTML5 (+  -- * HTML 5 Web Storage+  storageSize+  , getAllKeys+  , deleteAllKeys+  , getKey+  , setKey+  , deleteKey+  , WebStorageType(..)++  -- * HTML 5 Application Cache+  , ApplicationCacheStatus(..)+  , getApplicationCacheStatus+  ) where++import Data.Aeson as A+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Stack+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Get the current number of keys in a web storage area.+storageSize :: (HasCallStack, WebDriver wd) => WebStorageType -> wd Integer+storageSize s = doStorageCommand methodGet s "/size" Null++-- | Get a list of all keys from a web storage area.+getAllKeys :: (HasCallStack, WebDriver wd) => WebStorageType -> wd [Text]+getAllKeys s = doStorageCommand methodGet s "" Null++-- | Delete all keys within a given web storage area.+deleteAllKeys :: (HasCallStack, WebDriver wd) => WebStorageType -> wd ()+deleteAllKeys s = noReturn $ doStorageCommand methodDelete s "" Null++-- | An HTML 5 storage type+data WebStorageType = LocalStorage | SessionStorage+  deriving (Eq, Show, Ord, Bounded, Enum)++-- | Get the value associated with a key in the given web storage area.+-- Unset keys result in empty strings, since the Web Storage spec+-- makes no distinction between the empty string and an undefined value.+getKey :: (HasCallStack, WebDriver wd) => WebStorageType -> Text ->  wd Text+getKey s k = doStorageCommand methodGet s ("/key/" `T.append` urlEncode k) Null++-- | Set a key in the given web storage area.+setKey :: (HasCallStack, WebDriver wd) => WebStorageType -> Text -> Text -> wd Text+setKey s k v = doStorageCommand methodPost s "" . object $ ["key"   .= k,+                                                      "value" .= v ]+-- | Delete a key in the given web storage area.+deleteKey :: (HasCallStack, WebDriver wd) => WebStorageType -> Text -> wd ()+deleteKey s k = noReturn $ doStorageCommand methodPost s ("/key/" `T.append` urlEncode k) Null++-- | A wrapper around 'doSessCommand' to create web storage requests.+doStorageCommand :: (+  HasCallStack, WebDriver wd, ToJSON a, FromJSON b+  ) => Method -> WebStorageType -> Text -> a -> wd b+doStorageCommand m s path a = doSessCommand m (T.concat ["/", s', path]) a+  where s' = case s of+          LocalStorage -> "local_storage"+          SessionStorage -> "session_storage"++data ApplicationCacheStatus =+  Uncached+  | Idle+  | Checking+  | Downloading+  | UpdateReady+  | Obsolete+  deriving (Eq, Enum, Bounded, Ord, Show, Read)++instance FromJSON ApplicationCacheStatus where+  parseJSON val = do+    n <- parseJSON val+    case n :: Integer of+      0 -> return Uncached+      1 -> return Idle+      2 -> return Checking+      3 -> return Downloading+      4 -> return UpdateReady+      5 -> return Obsolete+      err -> fail $ "Invalid JSON for ApplicationCacheStatus: " ++ show err++instance ToJSON ApplicationCacheStatus where+  toJSON Uncached = A.Number 0+  toJSON Idle = A.Number 1+  toJSON Checking = A.Number 2+  toJSON Downloading = A.Number 3+  toJSON UpdateReady = A.Number 4+  toJSON Obsolete = A.Number 5++getApplicationCacheStatus :: (HasCallStack, WebDriver wd) => wd ApplicationCacheStatus+getApplicationCacheStatus = doSessCommand methodGet "/application_cache/status" Null
+ src/Test/WebDriver/Commands/SeleniumSpecific/Misc.hs view
@@ -0,0 +1,39 @@++module Test.WebDriver.Commands.SeleniumSpecific.Misc (+  -- * Interacting with elements+  submit+  , isDisplayed++  -- * Element equality+  , (<==>)+  , (</=>)+  ) where++import Data.Aeson as A+import GHC.Stack+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Submit a form element. This may be applied to descendents of a form element+-- as well.+submit :: (HasCallStack, WebDriver wd) => Element -> wd ()+submit e = noReturn $ doElemCommand methodPost e "/submit" Null++-- | Determine if the element is displayed.+-- This function isn't guaranteed to be implemented by the WebDriver spec,+-- but it is found in Selenium.+-- See https://www.w3.org/TR/webdriver1/#element-displayedness.+isDisplayed :: (HasCallStack, WebDriver wd) => Element -> wd Bool+isDisplayed e = doElemCommand methodGet e "/displayed" Null++infix 4 <==>+-- | Determines if two element identifiers refer to the same element.+(<==>) :: (HasCallStack, WebDriver wd) => Element -> Element -> wd Bool+e1 <==> (Element e2) = doElemCommand methodGet e1 ("/equals/" <> urlEncode e2) Null++-- | Determines if two element identifiers refer to different elements.+infix 4 </=>+(</=>) :: (HasCallStack, WebDriver wd) => Element -> Element -> wd Bool+e1 </=> e2 = not <$> (e1 <==> e2)
+ src/Test/WebDriver/Commands/SeleniumSpecific/Mobile.hs view
@@ -0,0 +1,133 @@++module Test.WebDriver.Commands.SeleniumSpecific.Mobile (+  -- ** Screen orientation+  getOrientation+  , setOrientation+  , Orientation(..)+  -- ** Geo-location+  , getLocation+  , setLocation+  -- ** Touch gestures+  , touchClick+  , touchDown+  , touchUp+  , touchMove+  , touchScroll+  , touchScrollFrom+  , touchDoubleClick+  , touchLongClick+  , touchFlick+  , touchFlickFrom+  ) where++import Data.Aeson as A+import Data.Aeson.Types+import Data.String (fromString)+import Data.Text (toUpper, toLower)+import GHC.Stack+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | A screen orientation+data Orientation = Landscape | Portrait+                 deriving (Eq, Show, Ord, Bounded, Enum)++instance ToJSON Orientation where+  toJSON = String . toUpper . fromString . show++instance FromJSON Orientation where+  parseJSON (String jStr) = case toLower jStr of+    "landscape" -> return Landscape+    "portrait"  -> return Portrait+    err         -> fail $ "Invalid Orientation string " ++ show err+  parseJSON v = typeMismatch "Orientation" v++-- | Get the current screen orientation for rotatable display devices.+getOrientation :: (HasCallStack, WebDriver wd) => wd Orientation+getOrientation = doSessCommand methodGet "/orientation" Null++-- | Set the current screen orientation for rotatable display devices.+setOrientation :: (HasCallStack, WebDriver wd) => Orientation -> wd ()+setOrientation = noReturn . doSessCommand methodPost "/orientation" . single "orientation"++-- | Single tap on the touch screen at the given element's location.+touchClick :: (HasCallStack, WebDriver wd) => Element -> wd ()+touchClick (Element e) =+  noReturn . doSessCommand methodPost "/touch/click" . single "element" $ e++-- | Emulates pressing a finger down on the screen at the given location.+touchDown :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()+touchDown = noReturn . doSessCommand methodPost "/touch/down" . pair ("x","y")++-- | Emulates removing a finger from the screen at the given location.+touchUp :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()+touchUp = noReturn . doSessCommand methodPost "/touch/up" . pair ("x","y")++-- | Emulates moving a finger on the screen to the given location.+touchMove :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()+touchMove = noReturn . doSessCommand methodPost "/touch/move" . pair ("x","y")++-- | Emulate finger-based touch scroll. Use this function if you don't care where+-- the scroll begins+touchScroll :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()+touchScroll = noReturn . doSessCommand methodPost "/touch/scroll" . pair ("xoffset","yoffset")++-- | Emulate finger-based touch scroll, starting from the given location relative+-- to the given element.+touchScrollFrom :: (HasCallStack, WebDriver wd) => (Int, Int) -> Element -> wd ()+touchScrollFrom (x, y) (Element e) =+  noReturn+  . doSessCommand methodPost "/touch/scroll"+  . triple ("xoffset", "yoffset", "element")+  $ (x, y, e)++-- | Emulate a double click on a touch device.+touchDoubleClick :: (HasCallStack, WebDriver wd) => Element -> wd ()+touchDoubleClick (Element e) =+  noReturn+  . doSessCommand methodPost "/touch/doubleclick"+  . single "element" $ e++-- | Emulate a long click on a touch device.+touchLongClick :: (HasCallStack, WebDriver wd) => Element -> wd ()+touchLongClick (Element e) =+  noReturn+  . doSessCommand methodPost "/touch/longclick"+  . single "element" $ e+-- | Emulate a flick on the touch screen. The coordinates indicate x and y+-- velocity, respectively. Use this function if you don't care where the+-- flick starts.+touchFlick :: (HasCallStack, WebDriver wd) => (Int, Int) -> wd ()+touchFlick =+  noReturn+  . doSessCommand methodPost "/touch/flick"+  . pair ("xSpeed", "ySpeed")++-- | Emulate a flick on the touch screen.+touchFlickFrom :: (HasCallStack, WebDriver wd) =>+                  Int           -- ^ flick velocity+                  -> (Int, Int) -- ^ a location relative to the given element+                  -> Element    -- ^ the given element+                  -> wd ()+touchFlickFrom s (x,y) (Element e) =+  noReturn+  . doSessCommand methodPost "/touch/flick" . object $+  ["xoffset" .= x+  ,"yoffset" .= y+  ,"speed"   .= s+  ,"element" .= e+  ]++-- | Get the current geographical location of the device.+getLocation :: (HasCallStack, WebDriver wd) => wd (Int, Int, Int)+getLocation = doSessCommand methodGet "/location" Null+  >>= parseTriple "latitude" "longitude" "altitude" "getLocation"++-- | Set the current geographical location of the device.+setLocation :: (HasCallStack, WebDriver wd) => (Int, Int, Int) -> wd ()+setLocation = noReturn . doSessCommand methodPost "/location"+              . triple ("latitude",+                        "longitude",+                        "altitude")
+ src/Test/WebDriver/Commands/SeleniumSpecific/Uploads.hs view
@@ -0,0 +1,50 @@++module Test.WebDriver.Commands.SeleniumSpecific.Uploads (+  seleniumUploadFile+  , seleniumUploadRawFile+  , seleniumUploadZipEntry+  ) where++import Codec.Archive.Zip+import Control.Monad.IO.Class+import Data.ByteString.Base64.Lazy as B64+import Data.ByteString.Lazy as LBS (ByteString)+import Data.Function ((&))+import Data.Text (Text)+import qualified Data.Text.Lazy.Encoding as TL+import GHC.Stack+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Uploads a file from the local filesystem by its file path. Returns the+-- remote filepath of the file.+seleniumUploadFile :: (HasCallStack, WebDriver wd) => FilePath -> wd Text+seleniumUploadFile path = seleniumUploadZipEntry =<< liftIO (readEntry [] path)++-- | Uploads a raw 'LBS.ByteString' with associated file info. Returns the+-- remote filepath of the file.+seleniumUploadRawFile :: (+  HasCallStack, WebDriver wd+  )+  -- | File path to use with this bytestring.+  => FilePath+  -- | Modification time (in seconds since Unix epoch).+  -> Integer+  -- | The file contents as a lazy ByteString.+  -> LBS.ByteString+  -> wd Text+seleniumUploadRawFile path t str = seleniumUploadZipEntry (toEntry path t str)++-- | Lowest level interface to the file uploading mechanism. This allows you to+-- specify the exact details of the zip entry sent across network. Returns the+-- remote filepath of the extracted file+seleniumUploadZipEntry :: (HasCallStack, WebDriver wd) => Entry -> wd Text+seleniumUploadZipEntry entry = doSessCommand methodPost "/se/file" $ single "file" file+  where+    file = entry+         & (`addEntryToArchive` emptyArchive)+         & fromArchive+         & B64.encode+         & TL.decodeUtf8
+ src/Test/WebDriver/Commands/Sessions.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.WebDriver.Commands.Sessions (+  -- * Server information+  serverStatus++  -- * Timeouts+  , getTimeouts+  , setTimeouts++  -- ** Set individual timeouts+  , setScriptTimeout+  , setPageLoadTimeout+  , setImplicitWait++  -- * Types+  , Timeouts(..)+  , emptyTimeouts++  -- , sessions+  -- , getActualCaps+  ) where++import Data.Aeson as A+import Data.Aeson.TH as A+import GHC.Stack+import Test.WebDriver.Capabilities.Aeson+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Get information from the server as a JSON 'Object'. For more information+-- about this object see+-- <https://github.com/SeleniumHQ/selenium/wiki/JsonWireProtocol#status>+serverStatus :: (HasCallStack, WebDriver wd) => wd Value   -- todo: make this a record type+serverStatus = doCommand methodGet "/status" Null++-- -- | Get the actual server-side 'Capabilities' of the current session.+-- -- TODO: remove, seems not to exist in the W3C spec+-- getActualCaps :: (HasCallStack, WebDriver wd) => wd Capabilities+-- getActualCaps = doSessCommand methodGet "" Null++data Timeouts = Timeouts {+  -- | Determines when to interrupt a script that is being evaluated.+  timeoutsScript :: Maybe Integer+  -- | Provides the timeout limit used to interrupt navigation of the browsing context.+  , timeoutsPageLoad :: Maybe Integer+  -- | Gives the timeout of when to abort locating an element.+  , timeoutsImplicit :: Maybe Integer+  } deriving (Show, Eq)+deriveJSON toCamel1 ''Timeouts+emptyTimeouts :: Timeouts+emptyTimeouts = Timeouts Nothing Nothing Nothing++-- | Get all the 'Timeouts' simultaneously.+getTimeouts :: (HasCallStack, WebDriver wd) => wd Timeouts+getTimeouts = doSessCommand methodGet "/timeouts" Null++-- | Set all the 'Timeouts' simultaneously.+setTimeouts :: (HasCallStack, WebDriver wd) => Timeouts -> wd ()+setTimeouts timeouts = doSessCommand methodPost "/timeouts" (A.toJSON timeouts)++-- | Set the "script" value of the 'Timeouts'.+-- Selenium 3 and 4 accept @null@ for this value, which unsets it. The spec doesn't mention this.+setScriptTimeout :: (HasCallStack, WebDriver wd) => Maybe Integer -> wd ()+setScriptTimeout x = doSessCommand methodPost "/timeouts" (A.object [("script", maybe A.Null (A.Number . fromIntegral) x)])++-- | Set the "pageLoad" value of the 'Timeouts'.+setPageLoadTimeout :: (HasCallStack, WebDriver wd) => Integer -> wd ()+setPageLoadTimeout x = doSessCommand methodPost "/timeouts" (A.object [("pageLoad", A.Number $ fromIntegral x)])++-- | Set the "implicit" value of the 'Timeouts'.+setImplicitWait :: (HasCallStack, WebDriver wd) => Integer -> wd ()+setImplicitWait x = doSessCommand methodPost "/timeouts" (A.object [("implicit", A.Number $ fromIntegral x)])
+ src/Test/WebDriver/Commands/UserPrompts.hs view
@@ -0,0 +1,31 @@++module Test.WebDriver.Commands.UserPrompts (+  dismissAlert+  , acceptAlert+  , getAlertText+  , replyToAlert+  ) where++import Data.Aeson as A+import Data.Text (Text)+import GHC.Stack+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Commands+++-- | Dismisses the currently displayed alert dialog.+dismissAlert :: (HasCallStack, WebDriver wd) => wd ()+dismissAlert = noReturn $ doSessCommand methodPost "/alert/dismiss" noObject++-- | Accepts the currently displayed alert dialog.+acceptAlert :: (HasCallStack, WebDriver wd) => wd ()+acceptAlert = noReturn $ doSessCommand methodPost "/alert/accept" noObject++-- | Get the text of an alert dialog.+getAlertText :: (HasCallStack, WebDriver wd) => wd Text+getAlertText = doSessCommand methodGet "/alert/text" Null++-- | Sends keystrokes to Javascript prompt() dialog.+replyToAlert :: (HasCallStack, WebDriver wd) => Text -> wd ()+replyToAlert = noReturn . doSessCommand methodPost "/alert/text" . single "text"
− src/Test/WebDriver/Commands/Wait.hs 
@@ -1,154 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ConstraintKinds #-}--module Test.WebDriver.Commands.Wait-       ( -- * Wait on expected conditions-         waitUntil, waitUntil'-       , waitWhile, waitWhile'-         -- * Expected conditions-       , ExpectFailed (..), expect, unexpected-       , expectAny, expectAll-       , expectNotStale, expectAlertOpen-       , catchFailedCommand-         -- ** Convenience functions-       , onTimeout-       ) where-import Test.WebDriver.Commands-import Test.WebDriver.Class-import Test.WebDriver.Exceptions-import Test.WebDriver.Session--import Control.Concurrent-import Control.Exception.Lifted-import Control.Monad.Base-import Control.Monad.Trans.Control--import Data.CallStack-import qualified Data.Foldable as F-import Data.Text (Text)-import Data.Time.Clock-import Data.Typeable--#if !MIN_VERSION_base(4,6,0) || defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706-import Prelude hiding (catch)-#endif--instance Exception ExpectFailed--- |An exception representing the failure of an expected condition.-data ExpectFailed = ExpectFailed String deriving (Show, Eq, Typeable)---- |throws 'ExpectFailed'. This is nice for writing your own abstractions.-unexpected :: (MonadBaseControl IO m, HasCallStack) =>-              String -- ^ Reason why the expected condition failed.-           -> m a-unexpected = throwIO . ExpectFailed---- |An expected condition. This function allows you to express assertions in--- your explicit wait. This function raises 'ExpectFailed' if the given--- boolean is False, and otherwise does nothing.-expect :: (MonadBaseControl IO m, HasCallStack) => Bool -> m ()-expect b-  | b         = return ()-  | otherwise = unexpected "Test.WebDriver.Commands.Wait.expect"---- |Apply a monadic predicate to every element in a list, and 'expect' that--- at least one succeeds.-expectAny :: (F.Foldable f, MonadBaseControl IO m, HasCallStack) => (a -> m Bool) -> f a -> m ()-expectAny p xs = expect . F.or =<< mapM p (F.toList xs)---- |Apply a monadic predicate to every element in a list, and 'expect' that all--- succeed.-expectAll :: (F.Foldable f, MonadBaseControl IO m, HasCallStack) => (a -> m Bool) -> f a -> m ()-expectAll p xs = expect . F.and =<< mapM p (F.toList xs)---- | 'expect' the given 'Element' to not be stale and returns it-expectNotStale :: (WebDriver wd, HasCallStack) => Element -> wd Element-expectNotStale e = catchFailedCommand StaleElementReference $ do-    _ <- isEnabled e -- Any command will force a staleness check-    return e---- | 'expect' an alert to be present on the page, and returns its text.-expectAlertOpen :: (WebDriver wd, HasCallStack) => wd Text-expectAlertOpen = catchFailedCommand NoAlertOpen getAlertText---- |Catches any `FailedCommand` exceptions with the given `FailedCommandType` and rethrows as 'ExpectFailed'-catchFailedCommand :: (MonadBaseControl IO m, HasCallStack) => FailedCommandType -> m a -> m a-catchFailedCommand t1 m = m `catch` handler-    where-        handler e@(FailedCommand t2 _)-            | t1 == t2 = unexpected . show $ e-        handler e = throwIO e---- |Wait until either the given action succeeds or the timeout is reached.--- The action will be retried every .5 seconds until no 'ExpectFailed' or--- 'FailedCommand' 'NoSuchElement' exceptions occur. If the timeout is reached,--- then a 'Timeout' exception will be raised. The timeout value--- is expressed in seconds.-waitUntil :: (WDSessionStateControl m, HasCallStack) => Double -> m a -> m a-waitUntil = waitUntil' 500000---- |Similar to 'waitUntil' but allows you to also specify the poll frequency--- of the 'WD' action. The frequency is expressed as an integer in microseconds.-waitUntil' :: (WDSessionStateControl m, HasCallStack) => Int -> Double -> m a -> m a-waitUntil' = waitEither id (\_ -> return)---- |Like 'waitUntil', but retries the action until it fails or until the timeout--- is exceeded.-waitWhile :: (WDSessionStateControl m, HasCallStack)  => Double -> m a -> m ()-waitWhile = waitWhile' 500000---- |Like 'waitUntil'', but retries the action until it either fails or--- until the timeout is exceeded.-waitWhile' :: (WDSessionStateControl m, HasCallStack)  => Int -> Double -> m a -> m ()-waitWhile' =-  waitEither  (\_ _ -> return ())-              (\retry _ -> retry "waitWhile: action did not fail")----- |Internal function used to implement explicit wait commands using success and failure continuations-waitEither :: (WDSessionStateControl m, HasCallStack) =>-               ((String -> m b) -> String -> m b)-            -> ((String -> m b) -> a -> m b)-            -> Int -> Double -> m a -> m b-waitEither failure success = wait' handler- where-  handler retry wd = do-    e <- fmap Right wd  `catches` [Handler handleFailedCommand-                                  ,Handler handleExpectFailed-                                  ]-    either (failure retry) (success retry) e-   where-    handleFailedCommand e@(FailedCommand NoSuchElement _) = return . Left . show $ e-    handleFailedCommand err = throwIO err--    handleExpectFailed (e :: ExpectFailed) = return . Left . show $ e--wait' :: (WDSessionStateIO m, HasCallStack) =>-         ((String -> m b) -> m a -> m b) -> Int -> Double -> m a -> m b-wait' handler waitAmnt t wd = waitLoop =<< liftBase getCurrentTime-  where-    timeout = realToFrac t-    waitLoop startTime = handler retry wd-      where-        retry why = do-          now <- liftBase getCurrentTime-          if diffUTCTime now startTime >= timeout-            then-              failedCommand Timeout $ "wait': explicit wait timed out (" ++ why ++ ")."-            else do-              liftBase . threadDelay $ waitAmnt-              waitLoop startTime---- |Convenience function to catch 'FailedCommand' 'Timeout' exceptions--- and perform some action.------ Example:------ > waitUntil 5 (getText <=< findElem $ ByCSS ".class")--- >    `onTimeout` return ""-onTimeout :: (MonadBaseControl IO m, HasCallStack) => m a -> m a -> m a-onTimeout m r = m `catch` handler-  where-    handler (FailedCommand Timeout _) = r-    handler other = throwIO other
− src/Test/WebDriver/Common/Keys.hs 
@@ -1,199 +0,0 @@---- | This module contains named constants corresponding to the special characters recognized by 'sendKeys'.--- For more details on these special characters, consult the Selenium documentation at--- <https://github.com/SeleniumHQ/selenium/wiki/JsonWireProtocol#sessionsessionidelementidvalue>-module Test.WebDriver.Common.Keys where--import Data.Text (Text)--add :: Text-add = "\xe025"--alt :: Text-alt = "\xe00a"--arrowDown :: Text-arrowDown = "\xe015"--arrowLeft :: Text-arrowLeft = "\xe012"--arrowRight :: Text-arrowRight = "\xe014"--arrowUp :: Text-arrowUp = "\xe013"--backspace :: Text-backspace = "\xe003"--backSpace :: Text-backSpace = "\xe003"--cancel :: Text-cancel = "\xe001"--clear :: Text-clear = "\xe005"--command :: Text-command = "\xe03d"--control :: Text-control = "\xe009"--decimal :: Text-decimal = "\xe028"--delete :: Text-delete = "\xe017"--divide :: Text-divide = "\xe029"--down :: Text-down = "\xe015"--end :: Text-end = "\xe010"--enter :: Text-enter = "\xe007"--equals :: Text-equals = "\xe019"--escape :: Text-escape = "\xe00c"--f1 :: Text-f1 = "\xe031"--f2 :: Text-f2 = "\xe032"--f3 :: Text-f3 = "\xe033"--f4 :: Text-f4 = "\xe034"--f5 :: Text-f5 = "\xe035"--f6 :: Text-f6 = "\xe036"--f7 :: Text-f7 = "\xe037"--f8 :: Text-f8 = "\xe038"--f9 :: Text-f9 = "\xe039"--f10 :: Text-f10 = "\xe03a"--f11 :: Text-f11 = "\xe03b"--f12 :: Text-f12 = "\xe03c"--help :: Text-help = "\xe002"--home :: Text-home = "\xe011"--insert :: Text-insert = "\xe016"--left :: Text-left = "\xe012"--leftAlt :: Text-leftAlt = "\xe00a"--leftControl :: Text-leftControl = "\xe009"--leftShift :: Text-leftShift = "\xe008"--meta :: Text-meta = "\xe03d"--multiply :: Text-multiply = "\xe024"--null :: Text-null = "\xe000"--numpad0 :: Text-numpad0 = "\xe01a"--numpad1 :: Text-numpad1 = "\xe01b"--numpad2 :: Text-numpad2 = "\xe01c"--numpad3 :: Text-numpad3 = "\xe01d"--numpad4 :: Text-numpad4 = "\xe01e"--numpad5 :: Text-numpad5 = "\xe01f"--numpad6 :: Text-numpad6 = "\xe020"--numpad7 :: Text-numpad7 = "\xe021"--numpad8 :: Text-numpad8 = "\xe022"--numpad9 :: Text-numpad9 = "\xe023"--pageDown :: Text-pageDown = "\xe00f"--pageUp :: Text-pageUp = "\xe00e"--pause :: Text-pause = "\xe00b"--return :: Text-return = "\xe006"--right :: Text-right = "\xe014"--semicolon :: Text-semicolon = "\xe018"--separator :: Text-separator = "\xe026"--shift :: Text-shift = "\xe008"--space :: Text-space = "\xe00d"--subtract :: Text-subtract = "\xe027"--tab :: Text-tab = "\xe004"--up :: Text-up = "\xe013"
− src/Test/WebDriver/Common/Profile.hs 
@@ -1,265 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS_HADDOCK not-home #-}---- | A type for profile preferences. These preference values are used by both--- Firefox and Opera profiles.-module Test.WebDriver.Common.Profile-       ( -- *Profiles and profile preferences-         Profile(..), PreparedProfile(..), ProfilePref(..), ToPref(..)-         -- * Preferences-       , getPref, addPref, deletePref-         -- * Extensions-       , addExtension, deleteExtension, hasExtension-         -- * Other files and directories-       , addFile, deleteFile, hasFile-         -- * Miscellaneous profile operations-       , unionProfiles, onProfileFiles, onProfilePrefs-         -- *Preparing profiles from disk-       , prepareLoadedProfile_-         -- *Preparing zipped profiles-       , prepareZippedProfile, prepareZipArchive,-         prepareRawZip-         -- *Profile errors-       , ProfileParseError(..)-       ) where--import Codec.Archive.Zip-import Data.Aeson-import Data.Aeson.Types-import System.Directory-import System.FilePath hiding (addExtension, hasExtension)--#if MIN_VERSION_aeson(0,7,0)-import Data.Scientific-#else-import Data.Attoparsec.Number (Number(..))-#endif--import qualified Data.HashMap.Strict as HM-import Data.Text (Text, pack)-import Data.ByteString.Lazy (ByteString)---import qualified Data.ByteString as SBS-import qualified Data.ByteString.Lazy as LBS-import qualified Data.ByteString.Base64.Lazy as B64-import qualified Data.Text.Lazy.Encoding as TL---import Data.Fixed-import Data.Ratio-import Data.Int-import Data.Word-import Data.Typeable--import Control.Exception-import Control.Applicative-import Control.Monad.Base--import Prelude -- hides some "unused import" warnings---- |This structure allows you to construct and manipulate profiles in pure code,--- deferring execution of IO operations until the profile is \"prepared\". This--- type is shared by both Firefox and Opera profiles; when a distinction--- must be made, the phantom type parameter is used to differentiate.-data Profile b = Profile-                 { -- |A mapping from relative destination filepaths to source-                   -- filepaths found on the filesystem. When the profile is-                   -- prepared, these source filepaths will be moved to their-                   -- destinations within the profile directory.-                   ---                   -- Using the destination path as the key ensures that-                   -- there is one unique source path going to each-                   -- destination path.-                   profileFiles   :: HM.HashMap FilePath FilePath-                   -- |A map of profile preferences. These are the settings-                   -- found in the profile's prefs.js, and entries found in-                   -- about:config-                 , profilePrefs  :: HM.HashMap Text ProfilePref-                 }-               deriving (Eq, Show)---- |Represents a profile that has been prepared for--- network transmission. The profile cannot be modified in this form.-newtype PreparedProfile b = PreparedProfile ByteString-  deriving (Eq, Show)--instance FromJSON (PreparedProfile s) where-  parseJSON v = PreparedProfile . TL.encodeUtf8 <$> parseJSON v--instance ToJSON (PreparedProfile s) where-  toJSON (PreparedProfile s) = toJSON $ TL.decodeUtf8 s---- |A profile preference value. This is the subset of JSON values that excludes--- arrays, objects, and null.-data ProfilePref = PrefInteger !Integer-                 | PrefDouble  !Double-                 | PrefString  !Text-                 | PrefBool    !Bool-                 deriving (Eq, Show)--instance ToJSON ProfilePref where-  toJSON v = case v of-    PrefInteger i -> toJSON i-    PrefDouble d  -> toJSON d-    PrefString s  -> toJSON s-    PrefBool  b   -> toJSON b--instance FromJSON ProfilePref where-  parseJSON (String s) = return $ PrefString s-  parseJSON (Bool b) = return $ PrefBool b-#if MIN_VERSION_aeson(0,7,0)-  parseJSON (Number s) | base10Exponent s >= 0 = return $ PrefInteger (coefficient s * 10^(base10Exponent s))-                       | otherwise = return $ PrefDouble $ realToFrac s-#else-  parseJSON (Number (I i)) = return $ PrefInteger i-  parseJSON (Number (D d)) = return $ PrefDouble d-#endif-  parseJSON other = typeMismatch "ProfilePref" other--instance Exception ProfileParseError--- |An error occured while attempting to parse a profile's preference file.-newtype ProfileParseError = ProfileParseError String-                          deriving  (Eq, Show, Read, Typeable)---- |A typeclass to convert types to profile preference values-class ToPref a where-  toPref :: a -> ProfilePref--instance ToPref Text where-  toPref = PrefString--instance ToPref String where-  toPref = toPref . pack--instance ToPref Bool where-  toPref = PrefBool--instance ToPref Integer where-  toPref = PrefInteger--#define I(t) instance ToPref t where toPref = PrefInteger . toInteger--I(Int)-I(Int8)-I(Int16)-I(Int32)-I(Int64)-I(Word)-I(Word8)-I(Word16)-I(Word32)-I(Word64)--instance ToPref Double where-  toPref = PrefDouble--instance ToPref Float where-  toPref = PrefDouble . realToFrac--instance (Integral a) => ToPref (Ratio a) where-  toPref = PrefDouble . realToFrac--instance (HasResolution r) => ToPref (Fixed r) where-  toPref = PrefDouble . realToFrac--instance ToPref ProfilePref where-  toPref = id---- |Retrieve a preference from a profile by key name.-getPref :: Text -> Profile b -> Maybe ProfilePref-getPref k (Profile _ m) = HM.lookup k m---- |Add a new preference entry to a profile, overwriting any existing entry--- with the same key.-addPref :: ToPref a => Text -> a -> Profile b -> Profile b-addPref k v p = onProfilePrefs p $ HM.insert k (toPref v)---- |Delete an existing preference entry from a profile. This operation is--- silent if the preference wasn't found.-deletePref :: Text -> Profile b -> Profile b-deletePref k p = onProfilePrefs p $ HM.delete k---- |Add a file to the profile directory. The first argument is the source--- of the file on the local filesystem. The second argument is the destination--- as a path relative to a profile directory. Overwrites any file that--- previously pointed to the same destination-addFile :: FilePath -> FilePath -> Profile b -> Profile b-addFile src dest p = onProfileFiles p $ HM.insert dest src---- |Delete a file from the profile directory. The first argument is the name of--- file within the profile directory.-deleteFile :: FilePath -> Profile b -> Profile b-deleteFile path prof = onProfileFiles prof $ HM.delete path---- |Determines if a profile contains the given file, specified as a path--- relative to the profile directory.-hasFile :: String -> Profile b -> Bool-hasFile path (Profile files _) = path `HM.member` files---- |Add a new extension to the profile. The file path should refer to--- a .xpi file or an extension directory on the filesystem.-addExtension :: FilePath -> Profile b -> Profile b-addExtension path = addFile path ("extensions" </> name)-  where (_, name) = splitFileName path---- |Delete an existing extension from the profile. The string parameter--- should refer to an .xpi file or directory located within the extensions--- directory of the profile. This operation has no effect if the extension was--- never added to the profile.-deleteExtension :: String -> Profile b -> Profile b-deleteExtension name = deleteFile ("extensions" </> name)---- |Determines if a profile contains the given extension. specified as an--- .xpi file or directory name-hasExtension :: String -> Profile b -> Bool-hasExtension name prof = hasFile ("extensions" </> name) prof----- |Takes the union of two profiles. This is the union of their 'HashMap'--- fields.-unionProfiles :: Profile b -> Profile b -> Profile b-unionProfiles (Profile f1 p1) (Profile f2 p2)-  = Profile (f1 `HM.union` f2) (p1 `HM.union` p2)---- |Modifies the 'profilePrefs' field of a profile.-onProfilePrefs :: Profile b-                  -> (HM.HashMap Text ProfilePref-                      -> HM.HashMap Text ProfilePref)-                  -> Profile b-onProfilePrefs (Profile hs hm) f = Profile hs (f hm)---- |Modifies the 'profileFiles' field of a profile-onProfileFiles :: Profile b-                  -> (HM.HashMap FilePath FilePath-                      -> HM.HashMap FilePath FilePath)-                  -> Profile b-onProfileFiles (Profile ls hm) f = Profile (f ls) hm----- |Efficiently load an existing profile from disk and prepare it for network--- transmission.-prepareLoadedProfile_ :: MonadBase IO m =>-                        FilePath -> m (PreparedProfile a)-prepareLoadedProfile_ path = liftBase $ do-  oldWd <- getCurrentDirectory-  setCurrentDirectory path-  prepareZipArchive <$>-    liftBase (addFilesToArchive [OptRecursive]-              emptyArchive ["."])-    <* setCurrentDirectory oldWd---- |Prepare a zip file of a profile on disk for network transmission.--- This function is very efficient at loading large profiles from disk.-prepareZippedProfile :: MonadBase IO m =>-                        FilePath -> m (PreparedProfile a)-prepareZippedProfile path = prepareRawZip <$> liftBase (LBS.readFile path)---- |Prepare a zip archive of a profile for network transmission.-prepareZipArchive :: Archive -> PreparedProfile a-prepareZipArchive = prepareRawZip . fromArchive---- |Prepare a ByteString of raw zip data for network transmission-prepareRawZip :: ByteString -> PreparedProfile a-prepareRawZip = PreparedProfile . B64.encode
− src/Test/WebDriver/Config.hs 
@@ -1,96 +0,0 @@--module Test.WebDriver.Config(-    -- * WebDriver configuration-      WDConfig(..), defaultConfig-    -- * Capabilities helpers-    , modifyCaps, useBrowser, useVersion, usePlatform, useProxy-    -- * SessionHistoryConfig options-    , SessionHistoryConfig, noHistory, unlimitedHistory, onlyMostRecentHistory-    -- * Overloadable configuration-    , WebDriverConfig(..)-    ) where-import Test.WebDriver.Capabilities-import Test.WebDriver.Session--import Data.Default (Default, def)-import Data.String (fromString)--import Control.Monad.Base--import Network.HTTP.Client (Manager, newManager, defaultManagerSettings)-import Network.HTTP.Types (RequestHeaders)---- |WebDriver session configuration-data WDConfig = WDConfig {-     -- |Host name of the WebDriver server for this-     -- session (default 127.0.0.1)-      wdHost :: String-     -- |Port number of the server (default 4444)-    , wdPort :: Int-     -- |Capabilities to use for this session-    , wdCapabilities :: Capabilities-     -- |Base path for all API requests (default "\/wd\/hub")-    , wdBasePath :: String-    -- |Custom request headers to add to every HTTP request.-    , wdRequestHeaders :: RequestHeaders-    -- |Custom request headers to add *only* to session creation requests. This is usually done-    --  when a WebDriver server requires HTTP auth.-    , wdAuthHeaders :: RequestHeaders-     -- |Specifies behavior of HTTP request/response history. By default we use 'unlimitedHistory'.-    , wdHistoryConfig :: SessionHistoryConfig-     -- |Use the given http-client 'Manager' instead of automatically creating one.-    , wdHTTPManager :: Maybe Manager-     -- |Number of times to retry a HTTP request if it times out (default 0)-    , wdHTTPRetryCount :: Int-}--instance GetCapabilities WDConfig where-  getCaps = wdCapabilities--instance SetCapabilities WDConfig where-  setCaps caps conf = conf { wdCapabilities = caps }--instance Default WDConfig where-    def = WDConfig {-      wdHost              = "127.0.0.1"-    , wdPort              = 4444-    , wdRequestHeaders    = []-    , wdAuthHeaders       = []-    , wdCapabilities      = def-    , wdHistoryConfig     = unlimitedHistory-    , wdBasePath          = "/wd/hub"-    , wdHTTPManager       = Nothing-    , wdHTTPRetryCount    = 0-    }--{- |A default session config connects to localhost on port 4444, and hasn't been-initialized server-side. This value is the same as 'def' but with a less-polymorphic type. -}-defaultConfig :: WDConfig-defaultConfig = def---- |Class of types that can configure a WebDriver session.-class WebDriverConfig c where-    -- |Produces a 'Capabilities' from the given configuration.-    mkCaps :: MonadBase IO m => c -> m Capabilities--    -- |Produces a 'WDSession' from the given configuration.-    mkSession :: MonadBase IO m => c -> m WDSession--instance WebDriverConfig WDConfig where-    mkCaps = return . getCaps--    mkSession WDConfig{..} = do-      manager <- maybe createManager return wdHTTPManager-      return WDSession { wdSessHost = fromString $ wdHost-                       , wdSessPort = wdPort-                       , wdSessRequestHeaders = wdRequestHeaders-                       , wdSessAuthHeaders = wdAuthHeaders-                       , wdSessBasePath = fromString $ wdBasePath-                       , wdSessId = Nothing-                       , wdSessHist = []-                       , wdSessHistUpdate = wdHistoryConfig-                       , wdSessHTTPManager = manager-                       , wdSessHTTPRetryCount = wdHTTPRetryCount }-      where-        createManager = liftBase $ newManager defaultManagerSettings
− src/Test/WebDriver/Cookies.hs 
@@ -1,60 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--module Test.WebDriver.Cookies where--import Data.Aeson-import Data.Aeson.Types-import qualified Data.Char as C-import Data.Text (Text)-import GHC.Generics-import Test.WebDriver.JSON---- | Cookies are delicious delicacies. When sending cookies to the server, a value--- of Nothing indicates that the server should use a default value. When receiving--- cookies from the server, a value of Nothing indicates that the server is unable--- to specify the value.-data Cookie = Cookie {-  cookName   :: Text-  , cookValue  :: Text          -- ^-  , cookPath   :: Maybe Text    -- ^path of this cookie.-                                -- if Nothing, defaults to /-  , cookDomain :: Maybe Text    -- ^domain of this cookie.-                                -- if Nothing, the current pages-                                -- domain is used-  , cookSecure :: Maybe Bool    -- ^Is this cookie secure?-  , cookExpiry :: Maybe Double  -- ^Expiry date expressed as-                                -- seconds since the Unix epoch-                                -- Nothing indicates that the-                                -- cookie never expires-  } deriving (Eq, Show, Generic)--aesonOptionsCookie :: Options-aesonOptionsCookie = defaultOptions {-  omitNothingFields = True-  , fieldLabelModifier = map C.toLower . drop 4-  }---- |Creates a Cookie with only a name and value specified. All other--- fields are set to Nothing, which tells the server to use default values.-mkCookie :: Text -> Text -> Cookie-mkCookie name value = Cookie { cookName = name, cookValue = value,-                               cookPath = Nothing, cookDomain = Nothing,-                               cookSecure = Nothing, cookExpiry = Nothing-                             }--instance ToJSON Cookie where-  toJSON = genericToJSON aesonOptionsCookie-  toEncoding = genericToEncoding aesonOptionsCookie-instance FromJSON Cookie where-  parseJSON (Object o) = Cookie <$> req "name"-                                <*> req "value"-                                <*> opt "path" Nothing-                                <*> opt "domain" Nothing-                                <*> opt "secure" Nothing-                                <*> opt "expiry" Nothing-    where-      req :: FromJSON a => Text -> Parser a-      req = (o .:) . fromText-      opt :: FromJSON a => Text -> a -> Parser a-      opt k d = o .:?? k .!= d-  parseJSON v = typeMismatch "Cookie" v
src/Test/WebDriver/Exceptions.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-deriving-typeable #-}  module Test.WebDriver.Exceptions (   InvalidURL(..)@@ -5,21 +7,113 @@   , BadJSON(..)    , HTTPStatusUnknown(..)-  , HTTPConnError(..) -  , UnknownCommand(..)   , ServerError(..)    , FailedCommand(..)-  , FailedCommandType(..)+  , FailedCommandError(..) -  , FailedCommandInfo(..)   , StackFrame(..)--  , mkFailedCommandInfo-  , failedCommand   ) where -import Test.WebDriver.Commands.Internal-import Test.WebDriver.Exceptions.Internal+import Control.Exception (Exception)+import Data.Aeson+import Data.Aeson.TH+import Data.Text (Text)+import Data.Typeable (Typeable)+import GHC.Stack+import Prelude -- hides some "unused import" warnings+import Test.WebDriver.Capabilities.Aeson import Test.WebDriver.JSON+import Test.WebDriver.Types+++-- | An invalid URL was given+newtype InvalidURL = InvalidURL String+  deriving (Eq, Show, Typeable)+instance Exception InvalidURL++-- | An unexpected HTTP status was sent by the server.+data HTTPStatusUnknown = HTTPStatusUnknown Int String+  deriving (Eq, Show, Typeable)+instance Exception HTTPStatusUnknown++-- | An unidentified server-side exception occured+newtype ServerError = ServerError String+  deriving (Eq, Show, Typeable)+instance Exception ServerError++data FailedCommandError =+  -- | The Element Click command could not be completed because the element receiving the events is obscuring the element that was requested clicked.+  ElementClickIntercepted+  -- | A command could not be completed because the element is not pointer- or keyboard interactable.+  | ElementNotInteractable+  -- | Navigation caused the user agent to hit a certificate warning, which is usually the result of an expired or invalid TLS certificate.+  | InsecureCertificate+  -- | The arguments passed to a command are either invalid or malformed.+  | InvalidArgument+  -- | An illegal attempt was made to set a cookie under a different domain than the current page.+  | InvalidCookieDomain+  -- | A command could not be completed because the element is in an invalid state, e.g. attempting to clear an element that isn't both editable and resettable.+  | InvalidElementState+  -- | Argument was an invalid selector.+  | InvalidSelector+  -- | Occurs if the given session id is not in the list of active sessions, meaning the session either does not exist or that it’s not active.+  | InvalidSessionId+  -- | An error occurred while executing JavaScript supplied by the user.+  | JavascriptError+  -- | The target for mouse interaction is not in the browser’s viewport and cannot be brought into that viewport.+  | MoveTargetOutOfBounds+  -- | An attempt was made to operate on a modal dialog when one was not open.+  | NoSuchAlert+  -- | No cookie matching the given path name was found amongst the associated cookies of the current browsing context’s active document.+  | NoSuchCookie+  -- | An element could not be located on the page using the given search parameters.+  | NoSuchElement+  -- | A command to switch to a frame could not be satisfied because the frame could not be found.+  | NoSuchFrame+  -- | A command to switch to a window could not be satisfied because the window could not be found.+  | NoSuchWindow+  -- | A script did not complete before its timeout expired.+  | ScriptTimeout+  -- | A new session could not be created.+  | SessionNotCreated+  -- | A command failed because the referenced element is no longer attached to the DOM.+  | StaleElementReference+  -- | An operation did not complete before its timeout expired.+  | Timeout+  -- | A command to set a cookie’s value could not be satisfied.+  | UnableToSetCookie+  -- | A screen capture was made impossible.+  | UnableToCaptureScreen+  -- | A modal dialog was open, blocking this operation.+  | UnexpectedAlertOpen+  -- | A command could not be executed because the remote end is not aware of it.+  | UnknownCommand+  -- | An unknown error occurred in the remote end while processing the command.+  | UnknownError+  -- | The requested command matched a known URL but did not match an method for that URL.+  | UnknownMethod+  -- | Indicates that a command that should have executed properly cannot be supported for some reason.+  | UnsupportedOperation+  -- | Some error string we weren't able to parse.+  | UnparsedError Text+  deriving (Show, Eq)+deriveFromJSON toSpacedC0 ''FailedCommandError+deriveToJSON toSpacedC0 ''FailedCommandError++-- | Internal type representing the JSON response object.+data FailedCommand = FailedCommand {+  rspError :: FailedCommandError+  , rspMessage :: Text+  , rspStacktrace :: Text+  , rspData :: Maybe Value+  } deriving (Eq, Show)+instance Exception FailedCommand+deriveFromJSON toCamel1 ''FailedCommand++-- | A command requiring a session ID was attempted when no session ID was+-- available.+data NoSessionId = NoSessionId String CallStack+  deriving (Show, Typeable)+instance Exception NoSessionId
− src/Test/WebDriver/Exceptions/Internal.hs 
@@ -1,202 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ConstraintKinds #-}--module Test.WebDriver.Exceptions.Internal-       ( InvalidURL(..), HTTPStatusUnknown(..), HTTPConnError(..)-       , UnknownCommand(..), ServerError(..)--       , FailedCommand(..), failedCommand, mkFailedCommandInfo-       , FailedCommandType(..), FailedCommandInfo(..), StackFrame(..)-       , externalCallStack, callStackItemToStackFrame-       ) where-import Test.WebDriver.Session-import Test.WebDriver.JSON--import Data.Aeson-import Data.Aeson.Types (Parser, typeMismatch)-import Data.ByteString.Lazy.Char8 (ByteString)-import Data.CallStack-import qualified Data.List as L-import Data.Text (Text)-import qualified Data.Text.Lazy.Encoding as TLE--import Control.Applicative-import Control.Exception (Exception)-import Control.Exception.Lifted (throwIO)--import Data.Maybe (fromMaybe, catMaybes)-import Data.Typeable (Typeable)--import Prelude -- hides some "unused import" warnings--instance Exception InvalidURL--- |An invalid URL was given-newtype InvalidURL = InvalidURL String-                deriving (Eq, Show, Typeable)--instance Exception HTTPStatusUnknown--- |An unexpected HTTP status was sent by the server.-data HTTPStatusUnknown = HTTPStatusUnknown Int String-                       deriving (Eq, Show, Typeable)--instance Exception HTTPConnError--- |HTTP connection errors.-data HTTPConnError = HTTPConnError String Int-                   deriving (Eq, Show, Typeable)--instance Exception UnknownCommand--- |A command was sent to the WebDriver server that it didn't recognize.-newtype UnknownCommand = UnknownCommand String-                    deriving (Eq, Show, Typeable)--instance Exception ServerError--- |A server-side exception occured-newtype ServerError = ServerError String-                      deriving (Eq, Show, Typeable)--instance Exception FailedCommand--- |This exception encapsulates a broad variety of exceptions that can--- occur when a command fails.-data FailedCommand = FailedCommand FailedCommandType FailedCommandInfo-                   deriving (Show, Typeable)---- |The type of failed command exception that occured.-data FailedCommandType = NoSuchElement-                       | NoSuchFrame-                       | UnknownFrame-                       | StaleElementReference-                       | ElementNotVisible-                       | InvalidElementState-                       | UnknownError-                       | ElementIsNotSelectable-                       | JavascriptError-                       | XPathLookupError-                       | Timeout-                       | NoSuchWindow-                       | InvalidCookieDomain-                       | UnableToSetCookie-                       | UnexpectedAlertOpen-                       | NoAlertOpen-                       | ScriptTimeout-                       | InvalidElementCoordinates-                       | IMENotAvailable-                       | IMEEngineActivationFailed-                       | InvalidSelector-                       | SessionNotCreated-                       | MoveTargetOutOfBounds-                       | InvalidXPathSelector-                       | InvalidXPathSelectorReturnType-                       deriving (Eq, Ord, Enum, Bounded, Show)---- |Detailed information about the failed command provided by the server.-data FailedCommandInfo =-  FailedCommandInfo { -- |The error message.-                      errMsg    :: String-                      -- |The session associated with-                      -- the exception.-                    , errSess :: Maybe WDSession-                      -- |A screen shot of the focused window-                      -- when the exception occured,-                      -- if provided.-                    , errScreen :: Maybe ByteString-                      -- |The "class" in which the exception-                      -- was raised, if provided.-                    , errClass  :: Maybe String-                      -- |A stack trace of the exception.-                    , errStack  :: [StackFrame]-                    }---- |Provides a readable printout of the error information, useful for--- logging.-instance Show FailedCommandInfo where-  show i = showChar '\n'-           . showString "Session: " . sess-           . showChar '\n'-           . showString className . showString ": " . showString (errMsg i)-           . showChar '\n'-           . foldl (\f s-> f . showString "  " . shows s) id (errStack i)-           $ ""-    where-      className = fromMaybe "<unknown exception>" . errClass $ i--      sess = case errSess i of-        Nothing -> showString "None"-        Just WDSession{..} ->-            let sessId = maybe "<no session id>" show wdSessId-            in showString sessId . showString " at "-                . shows wdSessHost . showChar ':' . shows wdSessPort----- |Constructs a FailedCommandInfo from only an error message.-mkFailedCommandInfo :: (WDSessionState s) => String -> CallStack -> s FailedCommandInfo-mkFailedCommandInfo m cs = do-  sess <- getSession-  return $ FailedCommandInfo { errMsg = m-                             , errSess = Just sess-                             , errScreen = Nothing-                             , errClass = Nothing-                             , errStack = fmap callStackItemToStackFrame cs }---- |Use GHC's CallStack capabilities to return a callstack to help debug a FailedCommand.--- Drops all stack frames inside Test.WebDriver modules, so the first frame on the stack--- should be where the user called into Test.WebDriver-externalCallStack :: (HasCallStack) => CallStack-externalCallStack = dropWhile isWebDriverFrame callStack-  where isWebDriverFrame :: ([Char], SrcLoc) -> Bool-        isWebDriverFrame (_, SrcLoc {srcLocModule}) = "Test.WebDriver" `L.isPrefixOf` srcLocModule---- |Convenience function to throw a 'FailedCommand' locally with no server-side--- info present.-failedCommand :: (HasCallStack, WDSessionStateIO s) => FailedCommandType -> String -> s a-failedCommand t m = do-  throwIO . FailedCommand t =<< mkFailedCommandInfo m externalCallStack---- |An individual stack frame from the stack trace provided by the server--- during a FailedCommand.-data StackFrame = StackFrame { sfFileName   :: String-                             , sfClassName  :: String-                             , sfMethodName :: String-                             , sfLineNumber :: Int-                             }-                deriving (Eq)---instance Show StackFrame where-  show f = showString (sfClassName f) . showChar '.'-           . showString (sfMethodName f) . showChar ' '-           . showParen True ( showString (sfFileName f) . showChar ':'-                              . shows (sfLineNumber f))-           $ "\n"---instance FromJSON FailedCommandInfo where-  parseJSON (Object o) =-    FailedCommandInfo <$> (req "message" >>= maybe (return "") return)-                      <*> pure Nothing-                      <*> (fmap TLE.encodeUtf8 <$> opt "screen" Nothing)-                      <*> opt "class"      Nothing-                      <*> (catMaybes <$> opt "stackTrace" [])-    where req :: FromJSON a => Text -> Parser a-          req = (o .:) . fromText  --required key-          opt :: FromJSON a => Text -> a -> Parser a-          opt k d = o .:?? k .!= d --optional key-  parseJSON v = typeMismatch "FailedCommandInfo" v--instance FromJSON StackFrame where-  parseJSON (Object o) = StackFrame <$> reqStr "fileName"-                                    <*> reqStr "className"-                                    <*> reqStr "methodName"-                                    <*> req    "lineNumber"-    where req :: FromJSON a => Text -> Parser a-          req = (o .:) . fromText -- all keys are required-          reqStr :: Text -> Parser String-          reqStr k = req k >>= maybe (return "") return-  parseJSON v = typeMismatch "StackFrame" v---callStackItemToStackFrame :: (String, SrcLoc) -> StackFrame-callStackItemToStackFrame (functionName, SrcLoc {..}) = StackFrame { sfFileName = srcLocFile-                                                                   , sfClassName = srcLocModule-                                                                   , sfMethodName = functionName-                                                                   , sfLineNumber = srcLocStartLine-                                                                   }
− src/Test/WebDriver/Firefox/Profile.hs 
@@ -1,243 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- suppress warnings from attoparsec---- | A module for working with Firefox profiles. Firefox profiles are manipulated--- in pure code and then \"prepared\" for network transmission.--module Test.WebDriver.Firefox.Profile-       ( -- * Profiles-         Firefox, Profile(..), PreparedProfile-       , defaultProfile-         -- * Preferences-       , ProfilePref(..), ToPref(..)-       , addPref, getPref, deletePref-         -- * Extensions-       , addExtension, deleteExtension, hasExtension-         -- * Other files and directories-       , addFile, deleteFile, hasFile-         -- * Miscellaneous profile operations-       , unionProfiles, onProfileFiles, onProfilePrefs-         -- * Loading and preparing profiles-       , prepareProfile, prepareTempProfile-         -- ** Preparing profiles from disk-       , loadProfile, prepareLoadedProfile, prepareLoadedProfile_-         -- ** Preparing zip archives-       , prepareZippedProfile, prepareZipArchive, prepareRawZip-         -- ** Preferences parsing error-       , ProfileParseError(..)-       ) where-import Test.WebDriver.Common.Profile-import Data.Aeson (Result(..), encode, fromJSON)-import Data.Aeson.Parser (jstring, value')-import Data.Attoparsec.ByteString.Char8 as AP-import qualified Data.HashMap.Strict as HM-import Data.Text (Text)-import Data.ByteString as BS (readFile)-import qualified Data.ByteString.Lazy.Char8 as LBS--import System.FilePath hiding (addExtension, hasExtension)-import System.Directory-import System.IO.Temp (createTempDirectory)-import qualified System.Directory.Tree as DS--import Control.Monad-import Control.Monad.Base-import Control.Monad.Trans.Control-import Control.Exception.Lifted hiding (try)-import Control.Applicative-import Control.Arrow--#if !MIN_VERSION_base(4,6,0) || defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706-import Prelude hiding (catch)-#endif---- |Phantom type used in the parameters of 'Profile' and 'PreparedProfile'-data Firefox---- |Default Firefox Profile, used when no profile is supplied.-defaultProfile :: Profile Firefox-defaultProfile =-  Profile HM.empty-  $ HM.fromList [("app.update.auto", PrefBool False)-                ,("app.update.enabled", PrefBool False)-                ,("browser.startup.page" , PrefInteger 0)-                ,("browser.download.manager.showWhenStarting", PrefBool False)-                ,("browser.EULA.override", PrefBool True)-                ,("browser.EULA.3.accepted", PrefBool True)-                ,("browser.link.open_external", PrefInteger 2)-                ,("browser.link.open_newwindow", PrefInteger 2)-                ,("browser.offline", PrefBool False)-                ,("browser.safebrowsing.enabled", PrefBool False)-                ,("browser.search.update", PrefBool False)-                ,("browser.sessionstore.resume_from_crash", PrefBool False)-                ,("browser.shell.checkDefaultBrowser", PrefBool False)-                ,("browser.tabs.warnOnClose", PrefBool False)-                ,("browser.tabs.warnOnOpen", PrefBool False)-                ,("browser.startup.page", PrefInteger 0)-                ,("browser.safebrowsing.malware.enabled", PrefBool False)-                ,("startup.homepage_welcome_url", PrefString "about:blank")-                ,("devtools.errorconsole.enabled", PrefBool True)-                ,("focusmanager.testmode", PrefBool True)-                ,("dom.disable_open_during_load", PrefBool False)-                ,("extensions.autoDisableScopes" , PrefInteger 10)-                ,("extensions.logging.enabled", PrefBool True)-                ,("extensions.update.enabled", PrefBool False)-                ,("extensions.update.notifyUser", PrefBool False)-                ,("network.manage-offline-status", PrefBool False)-                ,("network.http.max-connections-per-server", PrefInteger 10)-                ,("network.http.phishy-userpass-length", PrefInteger 255)-                ,("offline-apps.allow_by_default", PrefBool True)-                ,("prompts.tab_modal.enabled", PrefBool False)-                ,("security.fileuri.origin_policy", PrefInteger 3)-                ,("security.fileuri.strict_origin_policy", PrefBool False)-                ,("security.warn_entering_secure", PrefBool False)-                ,("security.warn_submit_insecure", PrefBool False)-                ,("security.warn_entering_secure.show_once", PrefBool False)-                ,("security.warn_entering_weak", PrefBool False)-                ,("security.warn_entering_weak.show_once", PrefBool False)-                ,("security.warn_leaving_secure", PrefBool False)-                ,("security.warn_leaving_secure.show_once", PrefBool False)-                ,("security.warn_submit_insecure", PrefBool False)-                ,("security.warn_viewing_mixed", PrefBool False)-                ,("security.warn_viewing_mixed.show_once", PrefBool False)-                ,("signon.rememberSignons", PrefBool False)-                ,("toolkit.networkmanager.disable", PrefBool True)-                ,("toolkit.telemetry.enabled", PrefBool False)-                ,("toolkit.telemetry.prompted", PrefInteger 2)-                ,("toolkit.telemetry.rejected", PrefBool True)-                ,("javascript.options.showInConsole", PrefBool True)-                ,("browser.dom.window.dump.enabled", PrefBool True)-                ,("webdriver_accept_untrusted_certs", PrefBool True)-                ,("webdriver_enable_native_events", native_events)-                ,("webdriver_assume_untrusted_issuer", PrefBool True)-                ,("dom.max_script_run_time", PrefInteger 30)-                ]-    where-#ifdef darwin_HOST_OS-      native_events = PrefBool False-#else-      native_events = PrefBool True-#endif----- |Load an existing profile from the file system. Any prepared changes made to--- the 'Profile' will have no effect to the profile on disk.------ To make automated browser run smoothly, preferences found in--- 'defaultProfile' are automatically merged into the preferences of the on-disk-- profile. The on-disk profile's preference will override those found in the--- default profile.-loadProfile :: MonadBaseControl IO m => FilePath -> m (Profile Firefox)-loadProfile path = liftBase $ do-  unionProfiles defaultProfile <$> (Profile <$> getFiles <*> getPrefs)-  where-    userPrefFile = path </> "prefs" <.> "js"--    getFiles = HM.fromList . map (id &&& (path </>)) . filter isNotIgnored-               <$> getDirectoryContents path-      where isNotIgnored = (`notElem`-                         [".", "..", "OfflineCache", "Cache"-                         ,"parent.lock", ".parentlock", ".lock"-                         ,userPrefFile])--    getPrefs = do-       prefFileExists <- doesFileExist userPrefFile-       if prefFileExists-        then HM.fromList <$> (parsePrefs =<< BS.readFile userPrefFile)-        else return HM.empty-      where parsePrefs s = either (throwIO . ProfileParseError) return-                           $ parseOnly prefsParser s---- |Prepare a firefox profile for network transmission.--- Internally, this function constructs a Firefox profile within a temp--- directory, archives it as a zip file, and then base64 encodes the zipped--- data. The temporary directory is deleted afterwards.------ NOTE: because this function has to copy the profile files into a--- a temp directory before zip archiving them, this operation is likely to be slow--- for large profiles. In such a case, consider using 'prepareLoadedProfile_' or--- 'prepareZippedProfile' instead.-prepareProfile :: MonadBaseControl IO m =>-                  Profile Firefox -> m (PreparedProfile Firefox)-prepareProfile Profile {profileFiles = files, profilePrefs = prefs}-  = liftBase $ do-      tmpdir <- mkTemp-      mapM_ (installPath tmpdir) . HM.toList $ files-      installUserPrefs tmpdir-      prepareLoadedProfile_ tmpdir---        <* removeDirectoryRecursive tmpdir-  where-    installPath destDir (destPath, src) = do-      let dest = destDir </> destPath-      isDir <- doesDirectoryExist src-      if isDir-        then do-          createDirectoryIfMissing True dest `catch` ignoreIOException-          (_ DS.:/ dir) <- DS.readDirectoryWithL LBS.readFile src-          handle ignoreIOException . void-              $ DS.writeDirectoryWith LBS.writeFile (dest DS.:/ dir)-        else do-          let dir = takeDirectory dest-          when (not . null $ dir) $-            createDirectoryIfMissing True dir `catch` ignoreIOException-          copyFile src dest `catch` ignoreIOException-      where-        ignoreIOException :: IOException -> IO ()-        ignoreIOException = print--    installUserPrefs d = LBS.writeFile (d </> "user" <.> "js") str-      where-        str = LBS.concat-            . map (\(k, v) -> LBS.concat [ "user_pref(", encode k,-                                           ", ", encode v, ");\n"])-            . HM.toList $ prefs---- |Apply a function on a default profile, and--- prepare the result. The Profile passed to the handler function is--- the default profile used by sessions when Nothing is specified-prepareTempProfile :: MonadBaseControl IO m =>-                     (Profile Firefox -> Profile Firefox)-                     -> m (PreparedProfile Firefox)-prepareTempProfile f = prepareProfile . f $ defaultProfile---- |Convenience function to load an existing Firefox profile from disk, apply--- a handler function, and then prepare the result for network transmission.------ NOTE: like 'prepareProfile', the same caveat about large profiles applies.-prepareLoadedProfile :: MonadBaseControl IO m =>-                        FilePath-                        -> (Profile Firefox -> Profile Firefox)-                        -> m (PreparedProfile Firefox)-prepareLoadedProfile path f = liftM f (loadProfile path) >>= prepareProfile---- firefox prefs.js parser--prefsParser :: Parser [(Text, ProfilePref)]-prefsParser = many1 $ do-  void . padSpaces $ string "user_pref("-  k <- prefKey <?> "preference key"-  void . padSpaces $ char ','-  v <- prefVal <?> "preference value"-  void . padSpaces $ string ");"-  return (k,v)-  where-    prefKey = jstring-    prefVal = do-      v <- value'-      case fromJSON v of-        Error str -> fail str-        Success p -> return p--    padSpaces p = spaces >> p <* spaces-    spaces = many (endOfLine <|> void space <|> void comment)-      where-        comment = inlineComment <|> lineComment-        lineComment = char '#' *> manyTill anyChar endOfLine-        inlineComment = string "/*" *> manyTill anyChar (string "*/")---mkTemp :: IO FilePath-mkTemp = do-  d <- getTemporaryDirectory-  createTempDirectory d ""
− src/Test/WebDriver/IO.hs 
@@ -1,17 +0,0 @@--module Test.WebDriver.IO where--import Control.Concurrent (threadDelay)-import Control.Monad.IO.Class (liftIO, MonadIO)-import Test.WebDriver-import Test.WebDriver.Class (WebDriver)---sleepIO :: Double -> IO ()-sleepIO seconds = Control.Concurrent.threadDelay (round (seconds * 1e6))--sleepWD :: (MonadIO wd, WebDriver wd) => Double -> wd ()-sleepWD = liftIO . sleepIO--printWD :: Show s => s -> WD ()-printWD = liftIO . print
− src/Test/WebDriver/Internal.hs 
@@ -1,232 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE CPP #-}---- | The HTTP/JSON plumbing used to implement the 'WD' monad.------ These functions can be used to create your own 'WebDriver' instances, providing extra functionality for your application if desired. All exports--- of this module are subject to change at any point.-module Test.WebDriver.Internal-       ( mkRequest, sendHTTPRequest-       , getJSONResult, handleJSONErr, handleRespSessionId-       , WDResponse(..)-       ) where-import Test.WebDriver.Class-import Test.WebDriver.JSON-import Test.WebDriver.Session-import Test.WebDriver.Exceptions.Internal--import Network.HTTP.Client (httpLbs, Request(..), RequestBody(..), Response(..))-import qualified Network.HTTP.Client as HTTPClient--import Data.Aeson-import Data.Aeson.Types (typeMismatch)-import Network.HTTP.Types.Header-import Network.HTTP.Types.Status (Status(..))--import qualified Data.ByteString.Base64.Lazy as B64-import qualified Data.ByteString.Char8 as BS-import Data.ByteString.Lazy.Char8 (ByteString)-import Data.ByteString.Lazy.Char8 as LBS (unpack, null)-import qualified Data.ByteString.Lazy.Internal as LBS (ByteString(..))-import Data.CallStack-import Data.Text as T (Text, splitOn, null)-import qualified Data.Text.Encoding as TE--import Control.Applicative-import Control.Exception (Exception, SomeException(..), toException, fromException, try)-import Control.Exception.Lifted (throwIO)-import Control.Monad.Base--import Data.String (fromString)-import Data.Word (Word8)--#if !MIN_VERSION_http_client(0,4,30)-import Data.Default (def)-#endif--import Prelude -- hides some "unused import" warnings----This is the defintion of fromStrict used by bytestring >= 0.10; we redefine it here to support bytestring < 0.10-fromStrict :: BS.ByteString -> LBS.ByteString-fromStrict bs | BS.null bs = LBS.Empty-              | otherwise = LBS.Chunk bs LBS.Empty-----Compatability function to support http-client < 0.4.30-defaultRequest :: Request-#if MIN_VERSION_http_client(0,4,30)-defaultRequest = HTTPClient.defaultRequest-#else-defaultRequest = def-#endif---- |Constructs an HTTP 'Request' value when given a list of headers, HTTP request method, and URL fragment-mkRequest :: (WDSessionState s, ToJSON a) =>-             Method -> Text -> a -> s Request-mkRequest meth wdPath args = do-  WDSession {..} <- getSession-  let body = case toJSON args of-        Null  -> ""   --passing Null as the argument indicates no request body-        other -> encode other-  return defaultRequest-    { host = wdSessHost-    , port = wdSessPort-    , path = wdSessBasePath `BS.append`  TE.encodeUtf8 wdPath-    , requestBody = RequestBodyLBS body-    , requestHeaders = wdSessRequestHeaders-                       ++ [ (hAccept, "application/json;charset=UTF-8")-                          , (hContentType, "application/json;charset=UTF-8") ]-    , method = meth-#if !MIN_VERSION_http_client(0,5,0)-    , checkStatus = \_ _ _ -> Nothing-#endif-    }---- |Sends an HTTP request to the remote WebDriver server-sendHTTPRequest :: (WDSessionStateIO s) => Request -> s (Either SomeException (Response ByteString))-sendHTTPRequest req = do-  s@WDSession{..} <- getSession-  (nRetries, tryRes) <- liftBase . retryOnTimeout wdSessHTTPRetryCount $ httpLbs req wdSessHTTPManager-  let h = SessionHistory { histRequest = req-                         , histResponse = tryRes-                         , histRetryCount = nRetries-                         }-  putSession s { wdSessHist = wdSessHistUpdate h wdSessHist }-  return tryRes--retryOnTimeout :: Int -> IO a -> IO (Int, (Either SomeException a))-retryOnTimeout maxRetry go = retry' 0-  where-    retry' nRetries = do-      eitherV <- try go-      case eitherV of-        (Left e)-#if MIN_VERSION_http_client(0,5,0)-          | Just (HTTPClient.HttpExceptionRequest _ HTTPClient.ResponseTimeout) <- fromException e-#else-          | Just HTTPClient.ResponseTimeout <- fromException e-#endif-          , maxRetry > nRetries-          -> retry' (succ nRetries)-        other -> return (nRetries, other)---- |Parses a 'WDResponse' object from a given HTTP response.-getJSONResult :: (HasCallStack, WDSessionStateControl s, FromJSON a) => Response ByteString -> s (Either SomeException a)-getJSONResult r-  --malformed request errors-  | code >= 400 && code < 500 = do-    lastReq <- mostRecentHTTPRequest <$> getSession-    returnErr . UnknownCommand . maybe reason show $ lastReq-  --server-side errors-  | code >= 500 && code < 600 =-    case lookup hContentType headers of-      Just ct-        | "application/json" `BS.isInfixOf` ct ->-          parseJSON'-            (maybe body fromStrict $ lookup "X-Response-Body-Start" headers)-          >>= handleJSONErr-          >>= maybe returnNull returnErr-        | otherwise ->-          returnHTTPErr ServerError-      Nothing ->-        returnHTTPErr (ServerError . ("HTTP response missing content type. Server reason was: "++))-  --redirect case (used as a response to createSession requests)-  | code == 302 || code == 303 =-    case lookup hLocation headers of-      Nothing ->  returnErr . HTTPStatusUnknown code $ LBS.unpack body-      Just loc -> do-        let sessId = last . filter (not . T.null) . splitOn "/" . fromString $ BS.unpack loc-        modifySession $ \sess -> sess {wdSessId = Just (SessionId sessId)}-        returnNull-  -- No Content response-  | code == 204 = returnNull-  -- HTTP Success-  | code >= 200 && code < 300 =-    if LBS.null body-      then returnNull-      else do-        rsp@WDResponse {rspVal = val} <- parseJSON' body-        handleJSONErr rsp >>= maybe-          (handleRespSessionId rsp >> Right <$> fromJSON' val)-          returnErr-  -- other status codes: return error-  | otherwise = returnHTTPErr (HTTPStatusUnknown code)-  where-    --helper functions-    returnErr :: (Exception e, Monad m) => e -> m (Either SomeException a)-    returnErr = return . Left . toException-    returnHTTPErr errType = returnErr . errType $ reason-    returnNull = Right <$> fromJSON' Null-    --HTTP response variables-    code = statusCode status-    reason = BS.unpack $ statusMessage status-    status = responseStatus r-    body = responseBody r-    headers = responseHeaders r--handleRespSessionId :: (HasCallStack, WDSessionStateIO s) => WDResponse -> s ()-handleRespSessionId WDResponse{rspSessId = sessId'} = do-    sess@WDSession { wdSessId = sessId} <- getSession-    case (sessId, (==) <$> sessId <*> sessId') of-       -- if our monad has an uninitialized session ID, initialize it from the response object-       (Nothing, _)    -> putSession sess { wdSessId = sessId' }-       -- if the response ID doesn't match our local ID, throw an error.-       (_, Just False) -> throwIO . ServerError $ "Server response session ID (" ++ show sessId'-                                 ++ ") does not match local session ID (" ++ show sessId ++ ")"-       _ ->  return ()--handleJSONErr :: (HasCallStack, WDSessionStateControl s) => WDResponse -> s (Maybe SomeException)-handleJSONErr WDResponse{rspStatus = 0} = return Nothing-handleJSONErr WDResponse{rspVal = val, rspStatus = status} = do-  sess <- getSession-  errInfo <- fromJSON' val-  let screen = B64.decodeLenient <$> errScreen errInfo-      seleniumStack = errStack errInfo-      errInfo' = errInfo { errSess = Just sess-                         -- Append the Haskell stack frames to the ones returned from Selenium-                         , errScreen = screen-                         , errStack = seleniumStack ++ (fmap callStackItemToStackFrame externalCallStack) }-      e errType = toException $ FailedCommand errType errInfo'-  return . Just $ case status of-    7   -> e NoSuchElement-    8   -> e NoSuchFrame-    9   -> toException . UnknownCommand . errMsg $ errInfo-    10  -> e StaleElementReference-    11  -> e ElementNotVisible-    12  -> e InvalidElementState-    13  -> e UnknownError-    15  -> e ElementIsNotSelectable-    17  -> e JavascriptError-    19  -> e XPathLookupError-    21  -> e Timeout-    23  -> e NoSuchWindow-    24  -> e InvalidCookieDomain-    25  -> e UnableToSetCookie-    26  -> e UnexpectedAlertOpen-    27  -> e NoAlertOpen-    28  -> e ScriptTimeout-    29  -> e InvalidElementCoordinates-    30  -> e IMENotAvailable-    31  -> e IMEEngineActivationFailed-    32  -> e InvalidSelector-    33  -> e SessionNotCreated-    34  -> e MoveTargetOutOfBounds-    51  -> e InvalidXPathSelector-    52  -> e InvalidXPathSelectorReturnType-    _   -> e UnknownError----- |Internal type representing the JSON response object-data WDResponse = WDResponse {-                               rspSessId :: Maybe SessionId-                             , rspStatus :: Word8-                             , rspVal    :: Value-                             }-                  deriving (Eq, Show)--instance FromJSON WDResponse where-  parseJSON (Object o) = WDResponse <$> o .:?? "sessionId" .!= Nothing-                                    <*> o .: "status"-                                    <*> o .:?? "value" .!= Null-  parseJSON v = typeMismatch "WDResponse" v
src/Test/WebDriver/JSON.hs view
@@ -1,55 +1,67 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-deriving-typeable #-} --- |A collection of convenience functions for using and parsing JSON values+-- | A collection of convenience functions for using and parsing JSON values -- within 'WD'. All monadic parse errors are converted to asynchronous -- 'BadJSON' exceptions. -- -- These functions are used internally to implement webdriver commands, and may -- be useful for implementing non-standard commands.-module Test.WebDriver.JSON-       ( -- * Access a JSON object key-         (!:), (.:??)-         -- * Conversion from JSON within WD-         -- |Apostrophes are used to disambiguate these functions-         -- from their "Data.Aeson" counterparts.-       , parseJSON', fromJSON'-         -- * Tuple functions-         -- |Convenience functions for working with tuples.+module Test.WebDriver.JSON (+  -- * Access a JSON object key+  (!:)+  , (.:??) -         -- ** JSON object constructors-       , single, pair, triple-         -- ** Extracting JSON objects into tuples-       , parsePair, parseTriple-         -- * Conversion from parser results to WD-         -- |These functions are used to implement the other functions-         -- in this module, and could be used to implement other JSON-         -- convenience functions-       , apResultToWD, aesonResultToWD-         -- * Parse exception-       , BadJSON(..)-         -- * parsing commands with no return value-       , NoReturn(..), noReturn, ignoreReturn+  -- * Conversion from JSON within WD+  -- | Apostrophes are used to disambiguate these functions+  -- from their "Data.Aeson" counterparts.+  , parseJSON'+  , fromJSON' -       , fromText-       ) where-import Test.WebDriver.Class (WebDriver)+  -- * Tuple functions+  -- | Convenience functions for working with tuples.+   -- ** JSON object constructors+  , single+  , pair+  , triple+  -- ** Extracting JSON objects into tuples+  , parseTriple +  -- * Conversion from parser results to WD+  -- | These functions are used to implement the other functions+  -- in this module, and could be used to implement other JSON+  -- convenience functions+  , apResultToWD+  , aesonResultToWD++  -- * Parse exception+  , BadJSON(..)++  -- * parsing commands with no return value+  , noReturn+  , ignoreReturn+  , aesonKeyFromText+  , NoReturn(..)++  -- * JSON helpers+  , noObject+  ) where++import Control.Applicative+import Control.Monad (join, void)+import Control.Monad.IO.Class import Data.Aeson as Aeson import Data.Aeson.Types-import Data.Text (Text)-import Data.ByteString.Lazy.Char8 (ByteString) import Data.Attoparsec.ByteString.Lazy (Result(..)) import qualified Data.Attoparsec.ByteString.Lazy as AP--import Control.Monad (join, void)-import Control.Applicative-import Control.Monad.Trans.Control-import Control.Exception.Lifted+import Data.ByteString.Lazy.Char8 (ByteString) import Data.String-import Data.Typeable-+import Data.Text (Text) import Prelude -- hides some "unused import" warnings+import Test.WebDriver.Types (WebDriver)+import Test.WebDriver.Util.Aeson (aesonKeyFromText)+import UnliftIO.Exception  #if MIN_VERSION_aeson(2,2,0) -- This comes from the attoparsec-aeson package@@ -57,24 +69,18 @@ #endif  #if MIN_VERSION_aeson(2,0,0)-import qualified Data.Aeson.Key             as A import qualified Data.Aeson.KeyMap          as HM-fromText :: Text -> A.Key-fromText = A.fromText #else import qualified Data.HashMap.Strict        as HM-fromText :: Text -> Text-fromText = id #endif  -instance Exception BadJSON--- |An error occured when parsing a JSON value.+-- | An error occured when parsing a JSON value. newtype BadJSON = BadJSON String-             deriving (Eq, Show, Typeable)-+  deriving (Eq, Show, Typeable)+instance Exception BadJSON --- |A type indicating that we expect no return value from the webdriver request.+-- | A type indicating that we expect no return value from the webdriver request. -- Its FromJSON instance parses successfully for any values that indicate lack of -- a return value (a notion that varies from server to server). data NoReturn = NoReturn@@ -85,68 +91,55 @@   parseJSON (String "")             = return NoReturn   parseJSON other                   = typeMismatch "no return value" other --- |Convenience function to handle webdriver commands with no return value.-noReturn :: WebDriver wd => wd NoReturn -> wd ()+instance ToJSON NoReturn where+  toJSON NoReturn = Aeson.String "<no return>"++-- | Convenience function to handle webdriver commands with no return value.+noReturn :: WebDriver m => m NoReturn -> m () noReturn = void --- |Convenience function to ignore result of a webdriver command.-ignoreReturn :: WebDriver wd => wd Value -> wd ()+-- | Convenience function to ignore result of a webdriver command.+ignoreReturn :: WebDriver m => m Value -> m () ignoreReturn = void ---- |Construct a singleton JSON 'object' from a key and value.+-- | Construct a singleton JSON 'object' from a key and value. single :: ToJSON a => Text -> a -> Value-single a x = object [(fromText a) .= x]+single a x = object [aesonKeyFromText a .= x] --- |Construct a 2-element JSON 'object' from a pair of keys and a pair of+-- | Construct a 2-element JSON 'object' from a pair of keys and a pair of -- values.-pair :: (ToJSON a, ToJSON b) => (Text,Text) -> (a,b) -> Value-pair (a,b) (x,y) = object [fromText a .= x, fromText b .= y]+pair :: (ToJSON a, ToJSON b) => (Text, Text) -> (a, b) -> Value+pair (a, b) (x,y) = object [aesonKeyFromText a .= x, aesonKeyFromText b .= y] --- |Construct a 3-element JSON 'object' from a triple of keys and a triple of+-- | Construct a 3-element JSON 'object' from a triple of keys and a triple of -- values.-triple :: (ToJSON a, ToJSON b, ToJSON c) =>-          (Text,Text,Text) -> (a,b,c) -> Value-triple (a,b,c) (x,y,z) = object [fromText a .= x, fromText b.= y, fromText c .= z]-+triple :: (ToJSON a, ToJSON b, ToJSON c) => (Text, Text, Text) -> (a, b, c) -> Value+triple (a, b, c) (x, y, z) = object [aesonKeyFromText a .= x, aesonKeyFromText b.= y, aesonKeyFromText c .= z] --- |Parse a lazy 'ByteString' as a top-level JSON 'Value', then convert it to an+-- | Parse a lazy 'ByteString' as a top-level JSON 'Value', then convert it to an -- instance of 'FromJSON'..-parseJSON' :: MonadBaseControl IO wd => FromJSON a => ByteString -> wd a+parseJSON' :: MonadIO m => FromJSON a => ByteString -> m a parseJSON' = apResultToWD . AP.parse json --- |Convert a JSON 'Value' to an instance of 'FromJSON'.-fromJSON' :: MonadBaseControl IO wd => FromJSON a => Value -> wd a+-- | Convert a JSON 'Value' to an instance of 'FromJSON'.+fromJSON' :: MonadIO m => FromJSON a => Value -> m a fromJSON' = aesonResultToWD . fromJSON --- |This operator is a wrapper over Aeson's '.:' operator.-(!:) :: (MonadBaseControl IO wd, FromJSON a) => Object -> Text -> wd a-o !: k = aesonResultToWD $ parse (.: fromText k) o+-- | This operator is a wrapper over Aeson's '.:' operator.+(!:) :: (MonadIO m, FromJSON a) => Object -> Text -> m a+o !: k = aesonResultToWD $ parse (.: aesonKeyFromText k) o --- |Due to a breaking change in the '.:?' operator of aeson 0.10 (see <https://github.com/bos/aeson/issues/287>) that was subsequently reverted, this operator+-- | Due to a breaking change in the '.:?' operator of aeson 0.10 (see <https://github.com/bos/aeson/issues/287>) that was subsequently reverted, this operator -- was added to provide consistent behavior compatible with all aeson versions. If the field is either missing or `Null`, this operator should return a `Nothing` result. (.:??) :: FromJSON a => Object -> Text -> Parser (Maybe a)-o .:?? k = fmap join (o .:? fromText k)----- |Parse a JSON 'Object' as a pair. The first two string arguments specify the--- keys to extract from the object. The third string is the name of the--- calling function, for better error reporting.-parsePair :: (MonadBaseControl IO wd, FromJSON a, FromJSON b) =>-             String -> String -> String -> Value -> wd (a, b)-parsePair a b funcName v =-  case v of-    Object o -> (,) <$> o !: fromString a <*> o !: fromString b-    _        -> throwIO . BadJSON $ funcName ++-                ": cannot parse non-object JSON response as a (" ++ a-                ++ ", " ++ b ++ ") pair" ++ ")"-+o .:?? k = fmap join (o .:? aesonKeyFromText k) --- |Parse a JSON Object as a triple. The first three string arguments+-- | Parse a JSON Object as a triple. The first three string arguments -- specify the keys to extract from the object. The fourth string is the name -- of the calling function, for better error reporting.-parseTriple :: (MonadBaseControl IO wd, FromJSON a, FromJSON b, FromJSON c) =>-               String -> String -> String ->  String -> Value -> wd (a, b, c)+parseTriple :: (+  MonadIO m, FromJSON a, FromJSON b, FromJSON c+  ) => String -> String -> String ->  String -> Value -> m (a, b, c) parseTriple a b c funcName v =   case v of     Object o -> (,,) <$> o !: fromString a@@ -156,16 +149,18 @@                 ": cannot parse non-object JSON response as a (" ++ a                 ++ ", " ++ b ++ ", " ++ c ++ ") pair" ----- |Convert an attoparsec parser result to 'WD'.-apResultToWD :: (MonadBaseControl IO wd, FromJSON a) => AP.Result Value -> wd a+-- | Convert an attoparsec parser result to 'WD'.+apResultToWD :: (MonadIO m, FromJSON a) => AP.Result Value -> m a apResultToWD p = case p of   Done _ res -> fromJSON' res   Fail _ _ err -> throwIO $ BadJSON err --- |Convert an Aeson parser result to 'WD'.-aesonResultToWD :: (MonadBaseControl IO wd) => Aeson.Result a -> wd a+-- |  Convert an Aeson parser result to 'WD'.+aesonResultToWD :: (MonadIO m) => Aeson.Result a -> m a aesonResultToWD r = case r of   Success val -> return val-  Error err   -> throwIO $ BadJSON err+  Error err -> throwIO $ BadJSON err++-- Selenium 3.x doesn't seem to like receiving Null for click parameter+noObject :: Value+noObject = Object mempty
+ src/Test/WebDriver/Keys.hs view
@@ -0,0 +1,201 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++-- | This module contains named constants corresponding to the special characters recognized by 'sendKeys'.+-- See https://www.w3.org/TR/webdriver2/#keyboard-actions.+module Test.WebDriver.Keys where++import Data.Text (Text)+import Test.WebDriver.Commands (sendKeys)+++add :: Text+add = "\xe025"++alt :: Text+alt = "\xe00a"++arrowDown :: Text+arrowDown = "\xe015"++arrowLeft :: Text+arrowLeft = "\xe012"++arrowRight :: Text+arrowRight = "\xe014"++arrowUp :: Text+arrowUp = "\xe013"++backspace :: Text+backspace = "\xe003"++backSpace :: Text+backSpace = "\xe003"++cancel :: Text+cancel = "\xe001"++clear :: Text+clear = "\xe005"++command :: Text+command = "\xe03d"++control :: Text+control = "\xe009"++decimal :: Text+decimal = "\xe028"++delete :: Text+delete = "\xe017"++divide :: Text+divide = "\xe029"++down :: Text+down = "\xe015"++end :: Text+end = "\xe010"++enter :: Text+enter = "\xe007"++equals :: Text+equals = "\xe019"++escape :: Text+escape = "\xe00c"++f1 :: Text+f1 = "\xe031"++f2 :: Text+f2 = "\xe032"++f3 :: Text+f3 = "\xe033"++f4 :: Text+f4 = "\xe034"++f5 :: Text+f5 = "\xe035"++f6 :: Text+f6 = "\xe036"++f7 :: Text+f7 = "\xe037"++f8 :: Text+f8 = "\xe038"++f9 :: Text+f9 = "\xe039"++f10 :: Text+f10 = "\xe03a"++f11 :: Text+f11 = "\xe03b"++f12 :: Text+f12 = "\xe03c"++help :: Text+help = "\xe002"++home :: Text+home = "\xe011"++insert :: Text+insert = "\xe016"++left :: Text+left = "\xe012"++leftAlt :: Text+leftAlt = "\xe00a"++leftControl :: Text+leftControl = "\xe009"++leftShift :: Text+leftShift = "\xe008"++meta :: Text+meta = "\xe03d"++multiply :: Text+multiply = "\xe024"++null :: Text+null = "\xe000"++numpad0 :: Text+numpad0 = "\xe01a"++numpad1 :: Text+numpad1 = "\xe01b"++numpad2 :: Text+numpad2 = "\xe01c"++numpad3 :: Text+numpad3 = "\xe01d"++numpad4 :: Text+numpad4 = "\xe01e"++numpad5 :: Text+numpad5 = "\xe01f"++numpad6 :: Text+numpad6 = "\xe020"++numpad7 :: Text+numpad7 = "\xe021"++numpad8 :: Text+numpad8 = "\xe022"++numpad9 :: Text+numpad9 = "\xe023"++pageDown :: Text+pageDown = "\xe00f"++pageUp :: Text+pageUp = "\xe00e"++pause :: Text+pause = "\xe00b"++returnKey :: Text+returnKey = "\xe006"++right :: Text+right = "\xe014"++semicolon :: Text+semicolon = "\xe018"++separator :: Text+separator = "\xe026"++shift :: Text+shift = "\xe008"++space :: Text+space = "\xe00d"++subtract :: Text+subtract = "\xe027"++tab :: Text+tab = "\xe004"++up :: Text+up = "\xe013"
+ src/Test/WebDriver/LaunchDriver.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ViewPatterns #-}++module Test.WebDriver.LaunchDriver (+  launchDriver+  , teardownDriver+  , mkDriverRequest+  ) where++import Control.Monad+import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Retry+import Data.Aeson+import qualified Data.ByteString.Char8 as BS+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.Text.Encoding as TE+import qualified Data.Text.IO as T+import Data.Time+import Network.HTTP.Client+import Network.HTTP.Types (hAccept, hContentType, statusCode)+import Network.Socket+import System.FilePath+import System.IO+import Test.WebDriver.Types+import Test.WebDriver.Util.Ports+import Test.WebDriver.Util.Sockets+import Text.Read (readMaybe)+import UnliftIO.Async+import UnliftIO.Exception+import UnliftIO.Process+import UnliftIO.Timeout+++launchDriver :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => DriverConfig -> m Driver+launchDriver driverConfig = do+  manager <- liftIO $ newManager defaultManagerSettings+  let requestHeaders = mempty++  port <- findFreePortOrException++  (programName, args) <- getArguments port driverConfig+  logDebugN [i|#{programName} #{T.unwords $ fmap T.pack args}|]++  (hRead, hWrite) <- createPipe++  let cp = (proc programName args) {+        create_group = True+        , std_out = UseHandle hWrite+        , std_err = UseHandle hWrite+        }++  (_, _, _, p) <- createProcess cp++  let hostname = "localhost"++  (logFilePath, logFileHandle) <- liftIO $ openTempFile (driverConfigLogDir driverConfig) ((driverBaseName driverConfig) <> ".log")+  logDebugN [i|Logging driver output to #{logFilePath}|]++  let handler (e :: SomeException) = do+        terminateProcess p+        now <- liftIO getCurrentTime+        liftIO (T.hPutStrLn logFileHandle [i|(#{now}) haskell-webdriver: process ending with exception: #{e}|])+        liftIO (hClose logFileHandle)++  flip withException handler $ do+    -- Read from the (combined) output stream until we see the up and running message+    maybeReady <- timeout 30_000_000 $ fix $ \loop -> do+      line <- fmap T.pack $ liftIO $ hGetLine hRead+      liftIO $ T.hPutStrLn logFileHandle line+      unless (Prelude.any (`T.isInfixOf` line) (needles driverConfig)) loop+    when (isNothing maybeReady) $+      throwIO DriverNoReadyMessage++    logAsync <- async $ flip finally (liftIO $ hClose logFileHandle) $ forever $ do+      line <- liftIO (T.hGetLine hRead)+      liftIO $ T.hPutStrLn logFileHandle line++    flip onException (cancel logAsync) $ do+      -- Wait for a successful connection to the server socket+      addr <- liftIO (getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just (show port))) >>= \case+        addr:_ -> return addr+        _ -> throwIO DriverGetAddrInfoFailed+      let policy = limitRetriesByCumulativeDelay (120 * 1_000_000) $ capDelay 1_000_000 $ exponentialBackoff 1000++      waitForSocket policy addr++      logDebugN [i|Finished wait for driver socket|]++      let basePath = case driverConfig of+            DriverConfigSeleniumJar {} -> "/wd/hub"+            _ -> ""++      let driver = Driver {+            _driverHostname = hostname+            , _driverPort = fromIntegral port+            , _driverBasePath = basePath+            , _driverRequestHeaders = requestHeaders+            , _driverManager = manager+            , _driverProcess = Just p+            , _driverLogAsync = Just logAsync+            , _driverConfig = driverConfig+            }++      -- Wait for a successful call to /status+      recoverAll policy $ \retryStatus -> do+        let req = mkDriverRequest driver methodGet "/status" Null+        resp <- liftIO $ httpLbs req manager+        let code = statusCode (responseStatus resp)+        if | code >= 200 && code < 300 -> return ()+           | otherwise -> do+               logWarnN [i|(#{retryStatus}) Invalid response from /status: #{resp}|]+               throwIO DriverStatusEndpointNotReady++      logInfoN [i|Finished wait for driver /status endpoint. Driver is running on #{hostname}:#{port}|]++      return driver++getArguments :: (MonadIO m, MonadLogger m) => PortNumber -> DriverConfig -> m (FilePath, [String])+getArguments port (DriverConfigSeleniumJar {..}) = do+  javaArgs :: [String] <- mconcat <$> mapM getSubDriverArgs driverConfigSubDrivers++  let maybeSeleniumVersion = case driverConfigSeleniumVersion of+        Just x -> Just x+        Nothing -> autodetectSeleniumVersionByFileName driverConfigSeleniumJar+  logInfoN [i|Detected Selenium version: #{maybeSeleniumVersion}|]+  let extraArgs = case maybeSeleniumVersion of+        Just Selenium3 -> ["-port", show port]+        Just Selenium4 -> ["standalone", "--port", show port, "--host", "localhost"]+        Nothing -> ["-port", show port]++  let fullArgs = javaArgs+               <> ["-jar", driverConfigSeleniumJar]+               <> extraArgs+  return (driverConfigJava, fullArgs <> driverConfigJavaFlags)+getArguments port (DriverConfigChromedriver {..}) = do+  return (driverConfigChromedriver, ["--port=" <> show port] <> driverConfigChromedriverFlags)+getArguments port (DriverConfigGeckodriver {..}) = do+  return (driverConfigGeckodriver, ["--port", show port] <> driverConfigGeckodriverFlags)++autodetectSeleniumVersionByFileName :: FilePath -> Maybe SeleniumVersion+autodetectSeleniumVersionByFileName (takeFileName -> seleniumJar) = case autodetectSeleniumMajorVersionByFileName of+  Just 3 -> Just Selenium3+  Just 4 -> Just Selenium4+  _ -> Nothing+  where+    autodetectSeleniumMajorVersionByFileName :: Maybe Int+    autodetectSeleniumMajorVersionByFileName+      | not ("selenium-server-" `L.isPrefixOf` seleniumJar) = Nothing+      | not (".jar" `L.isSuffixOf` seleniumJar) = Nothing+      | otherwise = do+          let parts = seleniumJar+                    & drop (length ("selenium-server-" :: String))+                    & T.dropEnd (length (".jar" :: String)) . T.pack+                    & T.splitOn "."+                    & fmap T.unpack+                    & fmap readMaybe++          case any isNothing parts of+            True -> Nothing+            False -> case catMaybes parts of+              [x, _, _, _] -> Just x+              [x, _, _] -> Just x+              [x, _] -> Just x+              [x] -> Just x+              _ -> Nothing++getSubDriverArgs :: Monad m => DriverConfig -> m [FilePath]+getSubDriverArgs (DriverConfigChromedriver {..}) = do+  let chromedriverLog = driverConfigLogDir </> "chromedriver.log"+  return [+    "-Dwebdriver.chrome.logfile=" <> chromedriverLog+    , "-Dwebdriver.chrome.verboseLogging=true"+    , "-Dwebdriver.chrome.driver=" <> driverConfigChromedriver+    ]+getSubDriverArgs (DriverConfigGeckodriver {..}) = do+  return [+    "-Dwebdriver.gecko.driver=" <> driverConfigGeckodriver+    ]+getSubDriverArgs _ = return []++needles :: DriverConfig -> [T.Text]+needles (DriverConfigSeleniumJar {}) = ["Selenium Server is up and running", "Started Selenium Standalone"]+needles (DriverConfigChromedriver {}) = ["ChromeDriver was started successfully"]+needles (DriverConfigGeckodriver {}) = ["Listening on"]++driverBaseName :: DriverConfig -> String+driverBaseName (DriverConfigSeleniumJar {}) = "selenium"+driverBaseName (DriverConfigChromedriver {}) = "chromedriver"+driverBaseName (DriverConfigGeckodriver {}) = "geckodriver"++data DriverException =+  DriverGetAddrInfoFailed+  | DriverNoReadyMessage+  | DriverStatusEndpointNotReady+  deriving (Show, Eq)++instance Exception DriverException++mkDriverRequest :: (ToJSON a) => Driver -> Method -> T.Text -> a -> Request+mkDriverRequest (Driver {..}) meth wdPath args =+  defaultRequest {+    host = BS.pack _driverHostname+    , port = _driverPort+    , path = BS.pack _driverBasePath `BS.append`  TE.encodeUtf8 wdPath+    , requestBody = RequestBodyLBS body+    , requestHeaders = _driverRequestHeaders ++ extraHeaders+    , method = meth+#if !MIN_VERSION_http_client(0,5,0)+    , checkStatus = \_ _ _ -> Nothing+#endif+    }+  where+    body = case toJSON args of+      Null -> "" -- Passing Null as the argument indicates no request body+      other -> encode other++    extraHeaders = [+      (hAccept, "application/json;charset=UTF-8")+      , (hContentType, "application/json;charset=UTF-8")+      ]+++teardownDriver :: (MonadUnliftIO m, MonadLogger m) => Driver -> m ()+teardownDriver (Driver {..}) = do+  case _driverProcess of+    Just p -> terminateProcess p+    Nothing -> return ()+  case _driverLogAsync of+    Just x -> cancel x+    Nothing -> return ()
− src/Test/WebDriver/Monad.hs 
@@ -1,108 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ConstraintKinds #-}--module Test.WebDriver.Monad (-  WD(..)-  , runWD-  , runSession-  , finallyClose-  , closeOnException-  , getSessionHistory-  , dumpSessionHistory-  ) where--import Test.WebDriver.Class-import Test.WebDriver.Commands-import Test.WebDriver.Config-import Test.WebDriver.Internal-import Test.WebDriver.Session--import Control.Monad.Base (MonadBase, liftBase)-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Control (MonadBaseControl(..), StM)-import Control.Monad.Trans.State.Strict (StateT, evalStateT, get, put)-import Control.Exception.Lifted-import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)-import Control.Applicative--import Prelude -- hides some "unused import" warnings---{- | A state monad for WebDriver commands. -}-newtype WD a = WD (StateT WDSession IO a)-  deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadFix, MonadMask)--instance MonadBase IO WD where-  liftBase = WD . liftBase--instance MonadBaseControl IO WD where-#if MIN_VERSION_monad_control(1,0,0)-  type StM WD a = StM (StateT WDSession IO) a--  liftBaseWith f = WD $-    liftBaseWith $ \runInBase ->-    f (\(WD sT) -> runInBase $ sT)--  restoreM = WD . restoreM-#else-  data StM WD a = StWD {unStWD :: StM (StateT WDSession IO) a}--  liftBaseWith f = WD $-    liftBaseWith $ \runInBase ->-    f (\(WD sT) -> liftM StWD . runInBase $ sT)--  restoreM = WD . restoreM . unStWD-#endif--instance WDSessionState WD where-  getSession = WD get-  putSession = WD . put--instance WebDriver WD where-  doCommand method path args =-    mkRequest method path args-    >>= sendHTTPRequest-    >>= either throwIO return-    >>= getJSONResult-    >>= either throwIO return---- |Executes a 'WD' computation within the 'IO' monad, using the given--- 'WDSession' as state for WebDriver requests.-runWD :: WDSession -> WD a -> IO a-runWD sess (WD wd) = evalStateT wd sess---- |Executes a 'WD' computation within the 'IO' monad, automatically creating a new session beforehand.------ NOTE: session is not automatically closed when complete. If you want this behavior, use 'finallyClose'.--- Example:------ >    runSessionThenClose action = runSession myConfig . finallyClose $ action-runSession :: WebDriverConfig conf => conf -> WD a -> IO a-runSession conf wd = do-  sess <- mkSession conf-  caps <- mkCaps conf-  runWD sess $ createSession caps >> wd---- |A finalizer ensuring that the session is always closed at the end of--- the given 'WD' action, regardless of any exceptions.-finallyClose:: WebDriver wd => wd a -> wd a-finallyClose wd = closeOnException wd <* closeSession---- |Exception handler that closes the session when an--- asynchronous exception is thrown, but otherwise leaves the session open--- if the action was successful.-closeOnException :: WebDriver wd => wd a -> wd a-closeOnException wd = wd `onException` closeSession---- |Gets the command history for the current session.-getSessionHistory :: WDSessionState wd => wd [SessionHistory]-getSessionHistory = fmap wdSessHist getSession---- |Prints a history of API requests to stdout after computing the given action.-dumpSessionHistory :: WDSessionStateControl wd => wd a -> wd a-dumpSessionHistory = (`finally` (getSession >>= liftBase . print . wdSessHist))
+ src/Test/WebDriver/Profile.hs view
@@ -0,0 +1,411 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-deriving-typeable #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | A type for profile preferences. These preference values are used by both+-- Firefox and Opera profiles.+module Test.WebDriver.Profile (+  -- * Profiles and profile preferences+  Profile(..)+  , ProfilePref(..)+  , ToPref(..)++  -- * Preferences+  , getPref+  , addPref+  , deletePref++  -- * Extensions+  -- , addExtension+  -- , deleteExtension+  , hasExtension++  -- * Miscellaneous profile operations+  , unionProfiles+  , onProfileFiles+  , onProfilePrefs++  -- * Profile errors+  , ProfileParseError(..)++  -- * Firefox+  , Firefox+  , defaultFirefoxProfile+  , loadFirefoxProfile+  , saveFirefoxProfile+  , firefoxProfileToArchive+  ) where++import Codec.Archive.Zip+import Control.Applicative+import Control.Exception.Safe hiding (try)+import Control.Monad+import Control.Monad.IO.Class+import Data.Aeson (Result(..), encode, fromJSON)+import qualified Data.Aeson as A+import Data.Aeson.Parser (jstring, value')+import Data.Aeson.Types (FromJSON, ToJSON, Value(..), parseJSON, toJSON, typeMismatch)+import Data.Attoparsec.ByteString.Char8 as AP+import Data.ByteString as BS (readFile)+import qualified Data.ByteString.Base64.Lazy as B64L+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.Fixed+import Data.Function ((&))+import qualified Data.HashMap.Strict as HM+import Data.Int+import qualified Data.List as L+import Data.Maybe+import Data.Ratio+import Data.Text (Text, pack)+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import Data.Word+import Prelude -- hides some "unused import" warnings+import System.Directory+import System.FilePath ((</>), (<.>), takeFileName)++#if MIN_VERSION_aeson(0,7,0)+import Data.Scientific+#else+import Data.Attoparsec.Number (Number(..))+#endif+++-- | This structure allows you to construct and manipulate profiles. This type+-- is shared by both Firefox and Opera profiles; when a distinction must be+-- made, the phantom type parameter is used to differentiate.+data Profile b = Profile {+  -- | A mapping from relative destination filepaths to source contents.+  profileFiles   :: HM.HashMap FilePath ByteString+  -- | A map of profile preferences. These are the settings found in the+  -- profile's prefs.js, and entries found in about:config+  , profilePrefs  :: HM.HashMap Text ProfilePref+  }+  deriving (Eq, Show)++-- | A profile preference value. This is the subset of JSON values that excludes+-- arrays, objects, and null.+data ProfilePref = PrefInteger !Integer+                 | PrefDouble  !Double+                 | PrefString  !Text+                 | PrefBool    !Bool+                 deriving (Eq, Show)++instance ToJSON ProfilePref where+  toJSON v = case v of+    PrefInteger i -> toJSON i+    PrefDouble d  -> toJSON d+    PrefString s  -> toJSON s+    PrefBool  b   -> toJSON b++instance FromJSON ProfilePref where+  parseJSON (String s) = return $ PrefString s+  parseJSON (Bool b) = return $ PrefBool b+#if MIN_VERSION_aeson(0,7,0)+  parseJSON (Number s)+    | base10Exponent s >= 0 = return $ PrefInteger (coefficient s * 10^(base10Exponent s))+    | otherwise = return $ PrefDouble $ realToFrac s+#else+  parseJSON (Number (I i)) = return $ PrefInteger i+  parseJSON (Number (D d)) = return $ PrefDouble d+#endif+  parseJSON other = typeMismatch "ProfilePref" other++instance Exception ProfileParseError+-- | An error occured while attempting to parse a profile's preference file.+newtype ProfileParseError = ProfileParseError String+  deriving  (Eq, Show, Read, Typeable)++-- | A typeclass to convert types to profile preference values+class ToPref a where+  toPref :: a -> ProfilePref++instance ToPref Text where+  toPref = PrefString++instance ToPref String where+  toPref = toPref . pack++instance ToPref Bool where+  toPref = PrefBool++instance ToPref Integer where+  toPref = PrefInteger++#define I(t) instance ToPref t where toPref = PrefInteger . toInteger++I(Int)+I(Int8)+I(Int16)+I(Int32)+I(Int64)+I(Word)+I(Word8)+I(Word16)+I(Word32)+I(Word64)++instance ToPref Double where+  toPref = PrefDouble++instance ToPref Float where+  toPref = PrefDouble . realToFrac++instance (Integral a) => ToPref (Ratio a) where+  toPref = PrefDouble . realToFrac++instance (HasResolution r) => ToPref (Fixed r) where+  toPref = PrefDouble . realToFrac++instance ToPref ProfilePref where+  toPref = id++-- | Retrieve a preference from a profile by key name.+getPref :: Text -> Profile b -> Maybe ProfilePref+getPref k (Profile _ m) = HM.lookup k m++-- | Add a new preference entry to a profile, overwriting any existing entry+-- with the same key.+addPref :: ToPref a => Text -> a -> Profile b -> Profile b+addPref k v p = onProfilePrefs p $ HM.insert k (toPref v)++-- | Delete an existing preference entry from a profile. This operation is+-- silent if the preference wasn't found.+deletePref :: Text -> Profile b -> Profile b+deletePref k p = onProfilePrefs p $ HM.delete k++-- | Determines if a profile contains the given file, specified as a path+-- relative to the profile directory.+hasFile :: String -> Profile b -> Bool+hasFile path (Profile files _) = path `HM.member` files++-- | Determines if a profile contains the given extension. specified as an+-- .xpi file or directory name+hasExtension :: String -> Profile b -> Bool+hasExtension name = hasFile ("extensions" </> name)++-- | Takes the union of two profiles. This is the union of their 'HashMap'+-- fields.+unionProfiles :: Profile b -> Profile b -> Profile b+unionProfiles (Profile f1 p1) (Profile f2 p2)+  = Profile (f1 `HM.union` f2) (p1 `HM.union` p2)++-- | Modifies the 'profilePrefs' field of a profile.+onProfilePrefs ::+  Profile b+  -> (HM.HashMap Text ProfilePref -> HM.HashMap Text ProfilePref)+  -> Profile b+onProfilePrefs (Profile hs hm) f = Profile hs (f hm)++-- | Modifies the 'profileFiles' field of a profile+onProfileFiles ::+  Profile b+  -> (HM.HashMap FilePath ByteString -> HM.HashMap FilePath ByteString)+  -> Profile b+onProfileFiles (Profile ls hm) f = Profile (f ls) hm++-- -- | Prepare a zip file of a profile on disk for network transmission.+-- -- This function is very efficient at loading large profiles from disk.+-- prepareZippedProfile :: MonadIO m => FilePath -> m (PreparedProfile a)+-- prepareZippedProfile path = prepareRawZip <$> liftIO (LBS.readFile path)++-- -- | Prepare a zip archive of a profile for network transmission.+-- prepareZipArchive :: Archive -> PreparedProfile a+-- prepareZipArchive = prepareRawZip . fromArchive++-- -- | Prepare a 'ByteString' of raw zip data for network transmission.+-- prepareRawZip :: ByteString -> PreparedProfile a+-- prepareRawZip = PreparedProfile . B64.encode++-- * Firefox+++-- | Phantom type used in the parameters of 'Profile' and 'PreparedProfile'+data Firefox++-- | Default Firefox Profile, used when no profile is supplied.+defaultFirefoxProfile :: Profile Firefox+defaultFirefoxProfile = Profile HM.empty $ HM.fromList [+  ("app.update.auto", PrefBool False)+  ,("app.update.enabled", PrefBool False)+  ,("browser.startup.page" , PrefInteger 0)+  ,("browser.download.manager.showWhenStarting", PrefBool False)+  ,("browser.EULA.override", PrefBool True)+  ,("browser.EULA.3.accepted", PrefBool True)+  ,("browser.link.open_external", PrefInteger 2)+  ,("browser.link.open_newwindow", PrefInteger 2)+  ,("browser.offline", PrefBool False)+  ,("browser.safebrowsing.enabled", PrefBool False)+  ,("browser.search.update", PrefBool False)+  ,("browser.sessionstore.resume_from_crash", PrefBool False)+  ,("browser.shell.checkDefaultBrowser", PrefBool False)+  ,("browser.tabs.warnOnClose", PrefBool False)+  ,("browser.tabs.warnOnOpen", PrefBool False)+  ,("browser.startup.page", PrefInteger 0)+  ,("browser.safebrowsing.malware.enabled", PrefBool False)+  ,("startup.homepage_welcome_url", PrefString "about:blank")+  ,("devtools.errorconsole.enabled", PrefBool True)+  ,("focusmanager.testmode", PrefBool True)+  ,("dom.disable_open_during_load", PrefBool False)+  ,("extensions.autoDisableScopes" , PrefInteger 10)+  ,("extensions.logging.enabled", PrefBool True)+  ,("extensions.update.enabled", PrefBool False)+  ,("extensions.update.notifyUser", PrefBool False)+  ,("network.manage-offline-status", PrefBool False)+  ,("network.http.max-connections-per-server", PrefInteger 10)+  ,("network.http.phishy-userpass-length", PrefInteger 255)+  ,("offline-apps.allow_by_default", PrefBool True)+  ,("prompts.tab_modal.enabled", PrefBool False)+  ,("security.fileuri.origin_policy", PrefInteger 3)+  ,("security.fileuri.strict_origin_policy", PrefBool False)+  ,("security.warn_entering_secure", PrefBool False)+  ,("security.warn_submit_insecure", PrefBool False)+  ,("security.warn_entering_secure.show_once", PrefBool False)+  ,("security.warn_entering_weak", PrefBool False)+  ,("security.warn_entering_weak.show_once", PrefBool False)+  ,("security.warn_leaving_secure", PrefBool False)+  ,("security.warn_leaving_secure.show_once", PrefBool False)+  ,("security.warn_submit_insecure", PrefBool False)+  ,("security.warn_viewing_mixed", PrefBool False)+  ,("security.warn_viewing_mixed.show_once", PrefBool False)+  ,("signon.rememberSignons", PrefBool False)+  ,("toolkit.networkmanager.disable", PrefBool True)+  ,("toolkit.telemetry.enabled", PrefBool False)+  ,("toolkit.telemetry.prompted", PrefInteger 2)+  ,("toolkit.telemetry.rejected", PrefBool True)+  ,("javascript.options.showInConsole", PrefBool True)+  ,("browser.dom.window.dump.enabled", PrefBool True)+  ,("webdriver_accept_untrusted_certs", PrefBool True)+  ,("webdriver_enable_native_events", native_events)+  ,("webdriver_assume_untrusted_issuer", PrefBool True)+  ,("dom.max_script_run_time", PrefInteger 30)+  ]+    where+#ifdef darwin_HOST_OS+      native_events = PrefBool False+#else+      native_events = PrefBool True+#endif+++-- | Load an existing profile from the file system. Any prepared changes made to+-- the 'Profile' will have no effect to the profile on disk.+--+-- To make automated browser run smoothly, preferences found in+-- 'defaultFirefoxProfile' are automatically merged into the preferences of the on-disk+-- profile. The on-disk profile's preference will override those found in the+-- default profile.+loadFirefoxProfile :: forall m. MonadIO m => FilePath -> m (Profile Firefox)+loadFirefoxProfile path = unionProfiles defaultFirefoxProfile <$> (Profile <$> getFiles path <*> getPrefs)+  where+    userPrefFile = path </> "prefs" <.> "js"++    getFiles :: FilePath -> m (HM.HashMap FilePath ByteString)+    getFiles dir = liftIO $ do+      allFiles <- getAllFiles dir+      foldM (\acc p -> HM.insert p <$> LBS.readFile p <*> pure acc) HM.empty $+        filter ((`notElem` filesToIgnore) . takeFileName) allFiles++    getAllFiles :: FilePath -> IO [FilePath]+    getAllFiles dir = do+      exists <- doesDirectoryExist dir+      if not exists then return [] else do+        contents <- map (dir </>) <$> listDirectory dir+        files <- filterM doesFileExist contents+        dirs <- filterM doesDirectoryExist contents+        subFiles <- concat <$> mapM getAllFiles dirs+        return (files ++ subFiles)++    filesToIgnore = [".", "..", "OfflineCache", "Cache", "parent.lock", ".parentlock", ".lock", userPrefFile]++    getPrefs = liftIO $ do+       doesFileExist userPrefFile >>= \case+         True -> HM.fromList <$> (parsePrefs =<< BS.readFile userPrefFile)+         False -> return HM.empty+      where+        parsePrefs s = either (throwIO . ProfileParseError) return+                     $ AP.parseOnly prefsParser s++-- | Save a Firefox profile to a destination directory. This directory should+-- already exist.+saveFirefoxProfile :: MonadIO m => Profile Firefox -> FilePath -> m ()+saveFirefoxProfile (firefoxProfileToArchive -> archive) dest = liftIO $ flip extractFilesFromArchive archive [+  OptRecursive+  , OptDestination dest+  ]++-- | Prepare a Firefox profile for network transmission.+firefoxProfileToArchive :: Profile Firefox -> Archive+firefoxProfileToArchive (Profile {profileFiles = files, profilePrefs = prefs}) =+  foldl addProfileFile baseArchive (HM.toList files)++  where+    baseArchive = emptyArchive+                & addEntryToArchive (toEntry ("user" <.> "js") 0 userJsContents)++    userJsContents = prefs+                   & HM.toList+                   & map (\(k, v) -> LBS.concat [ "user_pref(", encode k, ", ", encode v, ");\n"])+                   & LBS.concat++    addProfileFile :: Archive -> (FilePath, ByteString) -> Archive+    addProfileFile archive (dest, bytes) = addEntryToArchive (toEntry dest 0 bytes) archive++instance ToJSON (Profile Firefox) where+  toJSON prof = firefoxProfileToArchive prof+              & fromArchive+              & B64L.encode+              & LBS.toStrict+              & T.decodeUtf8+              & A.String++instance FromJSON (Profile Firefox) where+  parseJSON (String t) = case B64L.decode (TL.encodeUtf8 (TL.fromStrict t)) of+    Left err -> fail ("Couldn't decode Firefox profile archive: " <> err)+    Right bytes -> case toArchiveOrFail bytes of+      Left err -> fail ("Couldn't unzip Firefox profile archive: " <> err)+      Right archive -> return $ Profile {+        profileFiles = HM.fromList [(eRelativePath, fromEntry e) | e@(Entry {..}) <- otherFiles]+        , profilePrefs = prefs+        }+        where+          prefs = case L.find (\(Entry {..}) -> eRelativePath == "prefs.js") (zEntries archive) of+            Nothing -> mempty+            Just entry -> case AP.parseOnly prefsParser (BL.toStrict $ fromEntry entry) of+              Left _err -> mempty+              Right p -> HM.fromList p++          otherFiles = [e | e@(Entry {..}) <- zEntries archive, eRelativePath /= "prefs.js"]+  parseJSON other = typeMismatch "Profile Firefox" other++-- Firefox prefs.js parser++prefsParser :: AP.Parser [(Text, ProfilePref)]+prefsParser = AP.many1 $ do+  void . padSpaces $ AP.string "user_pref("+  k <- prefKey <?> "preference key"+  void . padSpaces $ AP.char ','+  v <- prefVal <?> "preference value"+  void . padSpaces $ AP.string ");"+  return (k,v)+  where+    prefKey = jstring+    prefVal = do+      v <- value'+      case fromJSON v of+        Error str -> fail str+        Success p -> return p++    padSpaces p = spaces >> p <* spaces+    spaces = many (AP.endOfLine <|> void AP.space <|> void comment)+      where+        comment = inlineComment <|> lineComment+        lineComment = AP.char '#' *> AP.manyTill AP.anyChar AP.endOfLine+        inlineComment = AP.string "/*" *> AP.manyTill AP.anyChar (AP.string "*/")
− src/Test/WebDriver/Session.hs 
@@ -1,193 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-}--module Test.WebDriver.Session (-  -- * WDSessionState class-  WDSessionState(..), WDSessionStateIO, WDSessionStateControl, modifySession, withSession-  -- ** WebDriver sessions-  , WDSession(..), mostRecentHistory, mostRecentHTTPRequest, SessionId(..), SessionHistory(..)-  -- * SessionHistoryConfig options-  , SessionHistoryConfig, noHistory, unlimitedHistory, onlyMostRecentHistory-  -- * Using custom HTTP request headers-  , withRequestHeaders, withAuthHeaders-  ) where--import Test.WebDriver.Session.History--import Data.Aeson-import Data.ByteString as BS(ByteString)-import Data.Text (Text)-import Data.Maybe (listToMaybe)-import Data.Monoid-import Control.Applicative-import Control.Monad.Base-import Control.Monad.Trans.Class-import Control.Monad.Trans.Control-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Identity-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Except-import Control.Monad.Trans.Writer.Strict as SW-import Control.Monad.Trans.Writer.Lazy as LW-import Control.Monad.Trans.State.Strict as SS-import Control.Monad.Trans.State.Lazy as LS-import Control.Monad.Trans.RWS.Strict as SRWS-import Control.Monad.Trans.RWS.Lazy as LRWS-import Control.Exception.Lifted (SomeException, try, throwIO)-import Network.HTTP.Client (Manager, Request)-import Network.HTTP.Types (RequestHeaders)-import Prelude -- hides some "redundant import" warnings---{- |An opaque identifier for a WebDriver session. These handles are produced by-the server on session creation, and act to identify a session in progress. -}-newtype SessionId = SessionId Text-                  deriving (Eq, Ord, Show, Read, FromJSON, ToJSON)--{- |The local state of a WebDriver session. This structure is passed-implicitly through all 'WD' computations -}-data WDSession = WDSession {-    -- server hostname-    wdSessHost :: BS.ByteString-    -- server port-  , wdSessPort :: Int-    -- Base path for API requests-  , wdSessBasePath :: BS.ByteString-    -- |An opaque reference identifying the session to-    -- use with 'WD' commands.-    -- A value of Nothing indicates that a session-    -- hasn't been created yet.-    -- Sessions can be created within 'WD' via-    -- 'Test.WebDriver.createSession', or created-    -- automatically with 'Test.WebDriver.runSession'-  , wdSessId   :: Maybe SessionId-    -- |The complete history of HTTP requests and-    -- responses, most recent first.-  , wdSessHist :: [SessionHistory]-    -- |Update function used to append new entries to session history-  , wdSessHistUpdate :: SessionHistoryConfig-    -- |HTTP 'Manager' used for connection pooling by the http-client library.-  , wdSessHTTPManager :: Manager-    -- |Number of times to retry a HTTP request if it times out-  , wdSessHTTPRetryCount :: Int-    -- |Custom request headers to add to every HTTP request.-  , wdSessRequestHeaders :: RequestHeaders-    -- |Custom request headers to add *only* to session creation requests. This is usually done-    --  when a WebDriver server requires HTTP auth.-  , wdSessAuthHeaders :: RequestHeaders-  }----- |A function used by 'wdHistoryConfig' to append new entries to session history.-type SessionHistoryConfig = SessionHistory -> [SessionHistory] -> [SessionHistory]---- |No session history is saved.-noHistory :: SessionHistoryConfig-noHistory _ _ = []---- |Keep unlimited history-unlimitedHistory :: SessionHistoryConfig-unlimitedHistory = (:)---- |Saves only the most recent history-onlyMostRecentHistory :: SessionHistoryConfig-onlyMostRecentHistory h _ = [h]---- |A class for monads that carry a WebDriver session with them. The--- MonadBaseControl superclass is used for exception handling through--- the lifted-base package.-class (Monad m, Applicative m) => WDSessionState m where--  -- |Retrieves the current session state of the monad-  getSession :: m WDSession--  -- |Sets a new session state for the monad-  putSession :: WDSession -> m ()---- |Constraint synonym for the common pairing of 'WDSessionState' and 'MonadBase' 'IO'.-type WDSessionStateIO s = (WDSessionState s, MonadBase IO s)---- |Constraint synonym for another common pairing of 'WDSessionState' and 'MonadBaseControl' 'IO'. This--- is commonly used in library types to indicate use of lifted exception handling.-type WDSessionStateControl s = (WDSessionState s, MonadBaseControl IO s)--modifySession :: WDSessionState s => (WDSession -> WDSession) -> s ()-modifySession f = getSession >>= putSession . f---- |Locally sets a session state for use within the given action.--- The state of any outside action is unaffected by this function.--- This function is useful if you need to work with multiple sessions simultaneously.-withSession :: WDSessionStateControl m => WDSession -> m a -> m a-withSession s m = do-  s' <- getSession-  putSession s-  (a :: Either SomeException a) <- try m-  putSession s'-  either throwIO return a---- |The most recent SessionHistory entry recorded by this session, if any.-mostRecentHistory :: WDSession -> Maybe SessionHistory-mostRecentHistory = listToMaybe . wdSessHist---- |The most recent HTTP request issued by this session, if any.-mostRecentHTTPRequest :: WDSession -> Maybe Request-mostRecentHTTPRequest = fmap histRequest . mostRecentHistory---- |Set a temporary list of custom 'RequestHeaders' to use within the given action.--- All previous custom headers are temporarily removed, and then restored at the end.-withRequestHeaders :: WDSessionStateControl m => RequestHeaders -> m a -> m a-withRequestHeaders h m = do-  h' <- fmap wdSessRequestHeaders getSession-  modifySession $ \s -> s { wdSessRequestHeaders = h }-  (a :: Either SomeException a) <- try m-  modifySession $ \s -> s { wdSessRequestHeaders = h' }-  either throwIO return a---- |Makes all webdriver HTTP requests in the given action use the session\'s auth headers, typically--- configured by setting the 'wdAuthHeaders' config. This is useful if you want to temporarily use--- the same auth headers you used for session creation with other HTTP requests.-withAuthHeaders :: WDSessionStateControl m => m a -> m a-withAuthHeaders wd = do-  authHeaders <- fmap wdSessAuthHeaders getSession-  withRequestHeaders authHeaders wd--instance WDSessionState m => WDSessionState (LS.StateT s m) where-  getSession = lift getSession-  putSession = lift . putSession--instance WDSessionState m => WDSessionState (SS.StateT s m) where-  getSession = lift getSession-  putSession = lift . putSession--instance WDSessionState m => WDSessionState (MaybeT m) where-  getSession = lift getSession-  putSession = lift . putSession--instance WDSessionState m => WDSessionState (IdentityT m) where-  getSession = lift getSession-  putSession = lift . putSession--instance (Monoid w, WDSessionState m) => WDSessionState (LW.WriterT w m) where-  getSession = lift getSession-  putSession = lift . putSession--instance (Monoid w, WDSessionState m) => WDSessionState (SW.WriterT w m) where-  getSession = lift getSession-  putSession = lift . putSession--instance WDSessionState m => WDSessionState (ReaderT r m) where-  getSession = lift getSession-  putSession = lift . putSession--instance WDSessionState m => WDSessionState (ExceptT r m) where-  getSession = lift getSession-  putSession = lift . putSession--instance (Monoid w, WDSessionState m) => WDSessionState (SRWS.RWST r w s m) where-  getSession = lift getSession-  putSession = lift . putSession--instance (Monoid w, WDSessionState wd) => WDSessionState (LRWS.RWST r w s wd) where-  getSession = lift getSession-  putSession = lift . putSession
− src/Test/WebDriver/Session/History.hs 
@@ -1,14 +0,0 @@--module Test.WebDriver.Session.History where--import Control.Exception (SomeException)-import Data.ByteString.Lazy (ByteString)-import Network.HTTP.Client (Request, Response)---data SessionHistory = SessionHistory-    { histRequest :: Request-    , histResponse :: Either SomeException (Response ByteString)-    , histRetryCount :: Int-    }-    deriving (Show)
src/Test/WebDriver/Types.hs view
@@ -1,48 +1,216 @@-{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Test.WebDriver.Types (-  -- * WebDriver sessions-  WD(..), WDSession(..), SessionId(..), SessionHistory+  WebDriverContext(..)+  -- , HasWebDriverContext+  , mkEmptyWebDriverContext -    -- * WebDriver configuration-  , WDConfig(..), defaultConfig, SessionHistoryConfig+  , Driver(..)+  , DriverConfig(..)+  , SeleniumVersion(..) -    -- * Capabilities-  , Capabilities(..), defaultCaps, allCaps-  , Platform(..), ProxyType(..), UnexpectedAlertBehavior(..)+  -- * SessionState class+  , SessionState(..)+  , SessionStatePut(..) -    -- ** Browser-specific capabilities-  , Browser(..),+  -- ** WebDriver sessions+  , SessionId(..)+  , Session(..) -    -- ** Default settings for browsers-    firefox, chrome, ie, opera, iPhone, iPad, android-  , LogLevel(..), IELogLevel(..), IEElementScrollBehavior(..)+  -- * Exceptions+  , SessionException(..) -    -- * WebDriver objects and command-specific types-  , Element(..)-  , WindowHandle(..), currentWindow-  , Selector(..)-  , JSArg(..)-  , FrameSelector(..)-  , Cookie(..), mkCookie-  , Orientation(..)-  , MouseButton(..)-  , WebStorageType(..)-  , LogType, LogEntry(..)-  , ApplicationCacheStatus(..)+  -- * Stack frames+  , StackFrame(..)+  , callStackItemToStackFrame -    -- * Exceptions-  , InvalidURL(..), NoSessionId(..), BadJSON(..)-  , HTTPStatusUnknown(..), HTTPConnError(..)-  , UnknownCommand(..), ServerError(..)-  , FailedCommand(..), FailedCommandType(..)-  , FailedCommandInfo(..), StackFrame(..)-  , mkFailedCommandInfo, failedCommand+  -- * WebDriver class+  , WebDriver+  , WebDriverBase(..)+  , Method+  , methodDelete+  , methodGet+  , methodPost   ) where -import Test.WebDriver.Capabilities-import Test.WebDriver.Commands-import Test.WebDriver.Config-import Test.WebDriver.Exceptions-import Test.WebDriver.Monad-import Test.WebDriver.Session+import Control.Monad.IO.Unlift+import Data.Aeson+import Data.Aeson.Types (Parser, typeMismatch)+import qualified Data.ByteString.Lazy as LBS+import Data.Map as M+import Data.String+import Data.String.Interpolate+import Data.Text as T+import GHC.Stack+import Network.HTTP.Client+import Network.HTTP.Types (RequestHeaders)+import Network.HTTP.Types.Method (methodDelete, methodGet, methodPost, Method)+import Test.WebDriver.Util.Aeson (aesonKeyFromText)+import UnliftIO.Async+import UnliftIO.Concurrent+import UnliftIO.Exception+import UnliftIO.Process+++-- | The 'WebDriverContext' is an opaque type used by this library for+-- bookkeeping purposes. It tracks all the processes we spin up and all the+-- sessions we create.+--+-- Currently, we will create at most 1 Selenium or Chromedriver process per+-- 'WebDriverContext', and N Geckodriver processes, where N is the number of+-- Firefox sessions you request.+data WebDriverContext = WebDriverContext {+  _webDriverSessions :: MVar (Map String Session)+  , _webDriverSelenium :: MVar (Maybe Driver)+  , _webDriverChromedriver :: MVar (Maybe Driver)+  }++-- | Create a new 'WebDriverContext'.+mkEmptyWebDriverContext :: MonadIO m => m WebDriverContext+mkEmptyWebDriverContext = WebDriverContext+  <$> newMVar mempty+  <*> newMVar Nothing+  <*> newMVar Nothing++data Driver = Driver {+  _driverHostname :: String+  , _driverPort :: Int+  , _driverBasePath :: String+  , _driverRequestHeaders :: RequestHeaders+  , _driverManager :: Manager+  , _driverProcess :: Maybe ProcessHandle+  , _driverLogAsync :: Maybe (Async ())+  , _driverConfig :: DriverConfig+  }++data SeleniumVersion =+  Selenium3+  | Selenium4+  deriving (Show, Eq)++-- | Configuration for how to launch a given driver.+data DriverConfig =+  -- | For launching a WebDriver via "java -jar selenium.jar".+  -- Selenium can launch other drivers on your behalf. You should pass these as 'driverConfigSubDrivers'.+  DriverConfigSeleniumJar {+    -- | Path to @java@ binary.+    driverConfigJava :: FilePath+    -- | Extra flags to pass to @java@.+    , driverConfigJavaFlags :: [String]+    -- | Path to @selenium.jar@ file.+    , driverConfigSeleniumJar :: FilePath+    -- | Specify if this is Selenium 3 or 4. If this is not provided, we'll try to autodetect.+    , driverConfigSeleniumVersion :: Maybe SeleniumVersion+    -- | Drivers to configure Selenium to use.+    , driverConfigSubDrivers :: [DriverConfig]+    -- | Directory in which to place driver logs.+    , driverConfigLogDir :: FilePath+    }+  | DriverConfigGeckodriver {+      -- | Path to @geckodriver@ binary.+      driverConfigGeckodriver :: FilePath+      -- | Extra flags to pass to @geckodriver@.+      , driverConfigGeckodriverFlags :: [String]+      -- | Path to @firefox@ binary.+      , driverConfigFirefox :: FilePath+      -- | Directory in which to place driver logs.+      , driverConfigLogDir :: FilePath+      }+  | DriverConfigChromedriver {+      -- | Path to @chromedriver@ binary.+      driverConfigChromedriver :: FilePath+      -- | Extra flags to pass to @chromedriver@.+      , driverConfigChromedriverFlags :: [String]+      -- | Path to @chrome@ binary.+      , driverConfigChrome :: FilePath+      -- | Directory in which to place driver logs.+      , driverConfigLogDir :: FilePath+      }++-- | An opaque identifier for a WebDriver session. These handles are produced by+-- the server on session creation, and act to identify a session in progress.+newtype SessionId = SessionId T.Text+  deriving (Eq, Ord, Show, Read, FromJSON, ToJSON)+instance IsString SessionId where+  fromString s = SessionId (T.pack s)++data Session = Session {+  sessionDriver :: Driver+  , sessionId :: SessionId+  , sessionName :: String+  , sessionWebSocketUrl :: Maybe String+  }+instance Show Session where+  show (Session {sessionDriver=(Driver {..}), ..}) = [i|Session<[#{sessionId}] at #{_driverHostname}:#{_driverPort}#{_driverBasePath}>|]++-- class HasLens ctx a where+--   getLens :: Lens' ctx a++data SessionException =+  SessionNameAlreadyExists+  | SessionCreationFailed (Response LBS.ByteString)+  | SessionCreationResponseHadNoSessionId (Response LBS.ByteString)+  deriving (Show)+instance Exception SessionException+++class SessionState m where+  getSession :: m Session++class (SessionState m) => SessionStatePut m where+  withModifiedSession :: (Session -> Session) -> m a -> m a++type WebDriver m = (WebDriverBase m, SessionState m)++-- | A class for monads that can handle wire protocol requests. This is the+-- operation underlying all of the high-level commands exported in+-- "Test.WebDriver.Commands".+class (MonadUnliftIO m) => WebDriverBase m where+  doCommandBase :: (+    HasCallStack, ToJSON a+    )+    => Driver+    -- | HTTP request method+    -> Method+    -- | URL of request+    -> Text+    -- | JSON parameters passed in the body of the request. Note that, as a+    -- special case, anything that converts to Data.Aeson.Null will result in an+    -- empty request body.+    -> a+    -- | The response of the HTTP request.+    -> m (Response LBS.ByteString)++-- | An individual stack frame from the stack trace provided by the server+-- during a FailedCommand.+data StackFrame = StackFrame {+  sfFileName :: String+  , sfClassName  :: String+  , sfMethodName :: String+  , sfLineNumber :: Int+  } deriving (Eq)+instance Show StackFrame where+  show f = showString (sfClassName f) . showChar '.'+           . showString (sfMethodName f) . showChar ' '+           . showParen True ( showString (sfFileName f) . showChar ':'+                              . shows (sfLineNumber f))+           $ "\n"+instance FromJSON StackFrame where+  parseJSON (Object o) = StackFrame <$> reqStr "fileName"+                                    <*> reqStr "className"+                                    <*> reqStr "methodName"+                                    <*> req    "lineNumber"+    where req :: FromJSON a => Text -> Parser a+          req = (o .:) . aesonKeyFromText -- all keys are required+          reqStr :: Text -> Parser String+          reqStr k = req k >>= maybe (return "") return+  parseJSON v = typeMismatch "StackFrame" v++callStackItemToStackFrame :: (String, SrcLoc) -> StackFrame+callStackItemToStackFrame (functionName, SrcLoc {..}) = StackFrame {+  sfFileName = srcLocFile+  , sfClassName = srcLocModule+  , sfMethodName = functionName+  , sfLineNumber = srcLocStartLine+  }
+ src/Test/WebDriver/Util/Aeson.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE CPP #-}++module Test.WebDriver.Util.Aeson (+  aesonToList+  , aesonLookup+  , aesonKeyFromText+  ) where++import Data.Text (Text)+++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as A+import qualified Data.Aeson.KeyMap as KM++aesonToList :: KM.KeyMap v -> [(A.Key, v)]+aesonToList = KM.toList++aesonLookup :: Text -> KM.KeyMap v -> Maybe v+aesonLookup = KM.lookup . A.fromText++aesonKeyFromText :: Text -> A.Key+aesonKeyFromText = A.fromText+#else+import qualified Data.HashMap.Strict        as HM++aesonToList :: HM.KeyMap v -> [(A.Key, v)]+aesonToList = HM.toList++aesonLookup :: (Eq k, Hashable k) => k -> HM.HashMap k v -> Maybe v+aesonLookup = HM.lookup++aesonKeyFromText :: Text -> Text+aesonKeyFromText = id+#endif
+ src/Test/WebDriver/Util/Commands.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-deriving-typeable #-}++{-# OPTIONS_HADDOCK not-home #-}+-- | Internal functions used to implement the functions exported by+-- "Test.WebDriver.Commands". These may be useful for implementing non-standard+-- webdriver commands.+module Test.WebDriver.Util.Commands (+  -- * Low-level webdriver functions+  doCommand+  -- ** Commands with :sessionId URL parameter+  , doSessCommand+  , SessionId(..)+  -- ** Commands with element :id URL parameters+  , doElemCommand+  , Element(..)+  -- ** Commands with :windowHandle URL parameters+  , WindowHandle(..)++  -- * Helpers+  , urlEncode+  ) where++import Control.Applicative+import Control.Monad.IO.Class+import Data.Aeson+import Data.Aeson.TH+import Data.Aeson.Types+import qualified Data.ByteString.Char8 as BS+import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding as TE+import GHC.Stack+import Network.HTTP.Client (Response(..))+import Network.HTTP.Types.Header+import Network.HTTP.Types.Status (Status(..))+import qualified Network.HTTP.Types.URI as HTTP+import Prelude -- hides some "unused import" warnings+import Test.WebDriver.Capabilities.Aeson+import Test.WebDriver.Exceptions+import Test.WebDriver.JSON+import Test.WebDriver.Types+import Test.WebDriver.Util.Aeson+import UnliftIO.Exception+++data SuccessResponse a = SuccessResponse {+  successValue :: a+  }+deriveFromJSON toCamel1 ''SuccessResponse++-- | An opaque identifier for a web page element+newtype Element = Element Text+  deriving (Eq, Ord, Show, Read)++instance FromJSON Element where+  parseJSON (Object o) = case fmap snd (aesonToList o) of+    (String id' : _) -> pure $ Element id'+    _ -> fail "No elements returned"+  parseJSON v = typeMismatch "Element" v++instance ToJSON Element where+  toJSON (Element e) = object ["element-6066-11e4-a52e-4f735466cecf" .= e]+++-- | An opaque identifier for a browser window+newtype WindowHandle = WindowHandle Text+  deriving (Eq, Ord, Show, Read, FromJSON, ToJSON)++-- | This a convenient wrapper around 'doCommand' that automatically prepends+-- the session URL parameter to the wire command URL. For example, passing+-- a URL of \"/refresh\" will expand to \"/session/:sessionId/refresh\", where+-- :sessionId is a URL parameter as described in+-- <https://github.com/SeleniumHQ/selenium/wiki/JsonWireProtocol>+doSessCommand :: (+  HasCallStack, WebDriver wd, ToJSON a, FromJSON b+  ) => Method -> Text -> a -> wd b+doSessCommand method path args = do+  Session { sessionId = SessionId sId } <- getSession+  -- Catch BadJSON exceptions here, since most commands go through this function.+  -- Then, re-throw them with "error", which automatically appends a callstack+  -- to the message in modern GHCs.+  -- This callstack makes it easy to see which command caused the BadJSON exception,+  -- without exposing too many internals.+  catch+    (doCommand method (T.concat ["/session/", urlEncode sId, path]) args)+    (\(e :: BadJSON) -> error $ show e)++-- | A wrapper around 'doSessCommand' to create element URLs.+-- For example, passing a URL of "/active" will expand to+-- \"/session/:sessionId/element/:id/active\", where :sessionId and :id are URL+-- parameters as described in the wire protocol.+doElemCommand :: (+  HasCallStack, WebDriver wd, ToJSON a, FromJSON b+  ) => Method -> Element -> Text -> a -> wd b+doElemCommand m (Element e) path a =+  doSessCommand m (T.concat ["/element/", urlEncode e, path]) a++urlEncode :: Text -> Text+urlEncode = TE.decodeUtf8 . HTTP.urlEncode False . TE.encodeUtf8++-- | Parse a 'FailedCommand' object from a given HTTP response.+getJSONResult :: (MonadIO m, FromJSON a) => Response ByteString -> m (Either SomeException a)+getJSONResult r+  | code >= 400 && code < 600 =+      case lookup hContentType headers of+        Just ct+          | "application/json" `BS.isInfixOf` ct -> do+              SuccessResponse {..} :: SuccessResponse FailedCommand <- parseJSON' body+              throwIO successValue+          | otherwise ->+              return $ Left $ toException $ ServerError reason+        Nothing ->+          return $ Left $ toException $ ServerError ("HTTP response missing content type. Server reason was: " <> reason)+  | code >= 200 && code < 300 = do+      SuccessResponse {successValue} <- parseJSON' body+      return $ Right successValue+  | otherwise = return $ Left $ toException $ (HTTPStatusUnknown code) reason+  where+    code = statusCode status+    reason = BS.unpack $ statusMessage status+    status = responseStatus r+    body = responseBody r+    headers = responseHeaders r+++doCommand :: (+  HasCallStack, WebDriver m, ToJSON a, FromJSON b+  )+  -- | HTTP request method+  => Method+  -- | URL of request+  -> Text+  -- | JSON parameters passed in the body of the request. Note that, as a+  -- special case, anything that converts to Data.Aeson.Null will result in an+  -- empty request body.+  -> a+  -- | The JSON result of the HTTP request.+  -> m b+doCommand method url params = do+  Session {sessionDriver} <- getSession+  doCommandBase sessionDriver method url params+    >>= getJSONResult+    >>= either throwIO return
+ src/Test/WebDriver/Util/Ports.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++{-|+Helper module for finding free ports, with various options for port ranges, retries, and excluded ports.+-}++module Test.WebDriver.Util.Ports (+  findFreePort++  -- * Exception-throwing versions+  , findFreePortOrException+  , findFreePortOrException'++  -- * Lower-level+  , findFreePortInRange+  , findFreePortInRange'++  -- * Lower-level+  , isPortFree+  , tryOpenAndClosePort+  , ephemeralPortRange+  ) where++import Control.Monad.Catch (MonadCatch, catch)+import Control.Monad.IO.Class+import Control.Retry+import Data.Maybe+import Network.Socket+import System.Random (randomRIO)+import UnliftIO.Exception (SomeException)+++-- | Find an unused port in the ephemeral port range.+-- See https://en.wikipedia.org/wiki/List_of_TCP_and_UDP_port_numbers.+findFreePort :: (MonadIO m, MonadCatch m) => m (Maybe PortNumber)+findFreePort = findFreePortInRange ephemeralPortRange []++-- | Find a free port in the ephemeral range, throwing an exception if one isn't found.+findFreePortOrException :: (MonadIO m, MonadCatch m) => m PortNumber+findFreePortOrException = findFreePortOrException' (const True)++-- | Same as 'findFreePortOrException', but with a callback to test if the port is acceptable or not.+findFreePortOrException' :: (MonadIO m, MonadCatch m) => (PortNumber -> Bool) -> m PortNumber+findFreePortOrException' isAcceptable = findFreePort >>= \case+  Just port+    | isAcceptable port -> return port+    | otherwise -> findFreePortOrException' isAcceptable+  Nothing -> error "Couldn't find free port"++-- | Find an unused port in a given range, excluding certain ports.+-- If the retries time out, returns 'Nothing'.+findFreePortInRange :: (+  MonadIO m, MonadCatch m+  )+  -- | Candidate port range+  => (PortNumber, PortNumber)+  -- | Ports to exclude+  -> [PortNumber]+  -> m (Maybe PortNumber)+findFreePortInRange = findFreePortInRange' (limitRetries 50)++-- | Same as 'findFreePortInRange', but with a configurable retry policy.+findFreePortInRange' :: forall m. (+  MonadIO m, MonadCatch m+  )+  -- | Retry policy+  => RetryPolicy+  -- | Candidate port range+  -> (PortNumber, PortNumber)+  -- | Ports to exclude+  -> [PortNumber]+  -> m (Maybe PortNumber)+findFreePortInRange' retryPolicy (start, end) blacklist = retrying retryPolicy callback (const findFreePortInRange')+  where+    callback _retryStatus result = return $ isNothing result++    getAcceptableCandidate :: m PortNumber+    getAcceptableCandidate = do+      candidate <- liftIO (fromInteger <$> randomRIO (fromIntegral start, fromIntegral end))+      if | candidate `elem` blacklist -> getAcceptableCandidate+         | otherwise -> return candidate++    findFreePortInRange' :: m (Maybe PortNumber)+    findFreePortInRange' = do+      candidate <- getAcceptableCandidate+      isPortFree candidate >>= \case+        False -> return Nothing+        True -> return $ Just candidate++-- | Test if a given 'PortNumber' is currently available.+isPortFree :: (MonadIO m, MonadCatch m) => PortNumber -> m Bool+isPortFree candidate = catch (tryOpenAndClosePort candidate >> return True)+                             (\(_ :: SomeException) -> return False)++-- | Test a given 'PortNumber' availability by trying to open and close a socket on it.+-- Throws an exception on failure.+tryOpenAndClosePort :: MonadIO m => PortNumber -> m PortNumber+tryOpenAndClosePort port = liftIO $ do+  sock <- socket AF_INET Stream 0+  setSocketOption sock ReuseAddr 1+  let hints = defaultHints { addrSocketType = Stream, addrFamily = AF_INET }+  getAddrInfo (Just hints) (Just "127.0.0.1") (Just $ show port) >>= \case+    ((AddrInfo {addrAddress=addr}):_) -> do+      bind sock addr+      close sock+      return $ fromIntegral port+    [] -> error "Couldn't resolve address 127.0.0.1"++-- | The ephemeral port range.+-- See https://en.wikipedia.org/wiki/List_of_TCP_and_UDP_port_numbers.+ephemeralPortRange :: (PortNumber, PortNumber)+ephemeralPortRange = (49152, 65535)
+ src/Test/WebDriver/Util/Sockets.hs view
@@ -0,0 +1,62 @@++module Test.WebDriver.Util.Sockets (+  waitForSocket+  , connectRetryPolicy+  ) where++import Control.Exception.Safe+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Retry+import Data.String.Interpolate+import Network.Socket+import UnliftIO.Timeout++++-- * Socket waits++-- | Each individual connect attempt needs a timeout to prevent it from hanging+-- indefinitely. This policy allows us to make that timeout length adaptive,+-- based on the 'RetryStatus' of the outer retry policy.+--+-- Thus, the first attempt to connect will have a short timeout (currently 100ms),+-- and then successive attempts will get longer timeouts via "FullJitter" backoff.+-- The goals of this are twofold:+--+-- 1) If a connect call hangs during the first few attempts, it is timed out quickly+-- and re-attempted, so on a healthy network you aren't penalized too much by the hang.+-- The outer retry policy can control the time between attempts, so the user can set+-- it high enough to make this be the case.+--+-- 2) If the network is slow, we will eventually reach the maximum timeout of 3 seconds,+-- which should be long enough. Note that the popular wait-for script uses 1 second+-- timeouts, so this is extra conservative:+-- https://github.com/eficode/wait-for/blob/7586b3622f010808bb2027c19aaf367221b4ad54/wait-for#L72+connectRetryPolicy :: MonadIO m => RetryPolicyM m+connectRetryPolicy = capDelay (3000000) (fullJitterBackoff 100000)++waitForSocket :: (+  MonadUnliftIO m, MonadLogger m, MonadMask m+  )+  => RetryPolicyM m+  -> AddrInfo+  -> m ()+waitForSocket policy addr = recoverAll policy $ \retryStatus@(RetryStatus {..}) -> do+  flip withException (\(e :: SomeException) -> logErrorN [i|waitForSocket: failed to connect to #{addr}: #{e}|]) $ do+    when (rsIterNumber > 0) $+      logDebugN [i|waitForSocket: attempt \##{rsIterNumber} to connect to #{addr}|]++    bracket (liftIO initSocket) (liftIO . close) $ \sock -> do+      connectTimeoutUs <- (getRetryPolicyM connectRetryPolicy) retryStatus >>= \case+        Nothing -> throwIO $ userError "Timeout due to connect retry policy"+        Just us -> pure us++      timeout connectTimeoutUs (liftIO $ connect sock (addrAddress addr)) >>= \case+        Nothing -> throwIO $ userError "Timeout in connect attempt"+        Just () -> pure ()++  where+    initSocket = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
− src/Test/WebDriver/Utils.hs 
@@ -1,9 +0,0 @@--module Test.WebDriver.Utils where--import Data.Text (Text)-import Data.Text.Encoding as TE-import qualified Network.HTTP.Types.URI as HTTP--urlEncode :: Text -> Text-urlEncode = TE.decodeUtf8 . HTTP.urlEncode False . TE.encodeUtf8
+ src/Test/WebDriver/Waits.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-deriving-typeable #-}++module Test.WebDriver.Waits (+  -- * Wait on expected conditions+  waitUntil+  , waitUntil'+  , waitWhile+  , waitWhile'++  -- * Expected conditions+  , ExpectFailed (..)+  , expect+  , unexpected+  , expectAny+  , expectAll+  , expectNotStale+  , expectAlertOpen+  , catchFailedCommand++  -- ** Convenience functions+  , onTimeout+  ) where++import Control.Concurrent+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import qualified Data.Foldable as F+import qualified Data.List as L+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time.Clock+import GHC.Stack+import Test.WebDriver.Commands+import Test.WebDriver.Exceptions+import Test.WebDriver.Types+import UnliftIO.Exception+++instance Exception ExpectFailed+-- | An exception representing the failure of an expected condition.+data ExpectFailed = ExpectFailed String deriving (Show, Eq, Typeable)++-- | Throws 'ExpectFailed'. This is nice for writing your own abstractions.+unexpected :: (+  MonadIO m+  )+  => String -- ^ Reason why the expected condition failed.+  -> m a+unexpected = throwIO . ExpectFailed++-- |An expected condition. This function allows you to express assertions in+-- your explicit wait. This function raises 'ExpectFailed' if the given+-- boolean is False, and otherwise does nothing.+expect :: (MonadIO m) => Bool -> m ()+expect b+  | b = return ()+  | otherwise = unexpected "Test.WebDriver.Commands.Wait.expect"++-- |Apply a monadic predicate to every element in a list, and 'expect' that+-- at least one succeeds.+expectAny :: (F.Foldable f, MonadIO m) => (a -> m Bool) -> f a -> m ()+expectAny p xs = expect . F.or =<< mapM p (F.toList xs)++-- |Apply a monadic predicate to every element in a list, and 'expect' that all+-- succeed.+expectAll :: (F.Foldable f, MonadIO m) => (a -> m Bool) -> f a -> m ()+expectAll p xs = expect . F.and =<< mapM p (F.toList xs)++-- | 'expect' the given 'Element' to not be stale and return it.+expectNotStale :: (HasCallStack, WebDriver wd) => Element -> wd Element+expectNotStale e = catchFailedCommand StaleElementReference $ do+    _ <- isEnabled e -- Any command will force a staleness check+    return e++-- | 'expect' an alert to be present on the page, and returns its text.+expectAlertOpen :: (HasCallStack, WebDriver wd) => wd Text+expectAlertOpen = catchFailedCommand NoSuchAlert getAlertText++-- | Catches any `FailedCommand` exceptions with the given `FailedCommandType` and rethrows as 'ExpectFailed'.+catchFailedCommand :: (MonadUnliftIO m) => FailedCommandError -> m a -> m a+catchFailedCommand needle m = m `catch` handler+  where+    handler e@(FailedCommand {rspError})+      | rspError == needle = unexpected . show $ e+    handler e = throwIO e++-- | Wait until either the given action succeeds or the timeout is reached.+-- The action will be retried every .5 seconds until no 'ExpectFailed' or+-- 'FailedCommand' 'NoSuchElement' exceptions occur. If the timeout is reached,+-- then a 'Timeout' exception will be raised. The timeout value+-- is expressed in seconds.+waitUntil :: (MonadUnliftIO m, HasCallStack) => Double -> m a -> m a+waitUntil = waitUntil' 500000++-- |Similar to 'waitUntil' but allows you to also specify the poll frequency+-- of the 'WD' action. The frequency is expressed as an integer in microseconds.+waitUntil' :: (MonadUnliftIO m, HasCallStack) => Int -> Double -> m a -> m a+waitUntil' = waitEither id (\_ -> return)++-- |Like 'waitUntil', but retries the action until it fails or until the timeout+-- is exceeded.+waitWhile :: (MonadUnliftIO m, HasCallStack)  => Double -> m a -> m ()+waitWhile = waitWhile' 500000++-- |Like 'waitUntil'', but retries the action until it either fails or+-- until the timeout is exceeded.+waitWhile' :: (MonadUnliftIO m, HasCallStack)  => Int -> Double -> m a -> m ()+waitWhile' =+  waitEither  (\_ _ -> return ())+              (\retry _ -> retry "waitWhile: action did not fail")+++-- | Internal function used to implement explicit wait commands using success and failure continuations+waitEither :: (+  HasCallStack, MonadUnliftIO m+  )+  => ((String -> m b) -> String -> m b) -> ((String -> m b) -> a -> m b)+  -> Int+  -> Double+  -> m a+  -> m b+waitEither failure success = wait' handler+ where+  handler retry wd = do+    e <- fmap Right wd  `catches` [Handler handleFailedCommand+                                  , Handler handleExpectFailed+                                  ]+    either (failure retry) (success retry) e+   where+    handleFailedCommand e@(FailedCommand {rspError})+      | rspError == NoSuchElement = return . Left . show $ e+    handleFailedCommand err = throwIO err++    handleExpectFailed (e :: ExpectFailed) = return . Left . show $ e++wait' :: (+  HasCallStack, MonadIO m+  ) => ((String -> m b) -> m a -> m b) -> Int -> Double -> m a -> m b+wait' handler waitAmnt t wd = waitLoop =<< liftIO getCurrentTime+  where+    timeout = realToFrac t+    waitLoop startTime = handler retry wd+      where+        retry why = do+          now <- liftIO getCurrentTime+          if diffUTCTime now startTime >= timeout+            then+              throwIO $ FailedCommand {+                rspError = Timeout+                , rspMessage = "wait': explicit wait timed out (" <> T.pack why <> ")."+                , rspStacktrace = T.pack $ show (popCallStack callStack)+                , rspData = Nothing+                }+            else do+              liftIO . threadDelay $ waitAmnt+              waitLoop startTime++-- | Convenience function to catch 'FailedCommand' 'Timeout' exceptions+-- and perform some action.+--+-- Example:+--+-- > waitUntil 5 (getText <=< findElem $ ByCSS ".class")+-- >    `onTimeout` return ""+onTimeout :: (MonadUnliftIO m) => m a -> m a -> m a+onTimeout m r = m `catch` handler+  where+    handler (FailedCommand {rspError})+      | rspError `L.elem` [Timeout, ScriptTimeout] = r+    handler other = throwIO other
+ tests/Main.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Main where++import Control.Monad+import Control.Monad.Reader+import Data.String.Interpolate+import qualified Data.Text as T+import qualified Spec as Spec+import System.Environment+import Test.Sandwich hiding (BrowserToUse(..))+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Nix+import Test.WebDriver+import TestLib.Contexts.BrowserDependencies+import TestLib.Contexts.Selenium4+import TestLib.Contexts.StaticServer+import TestLib.Contexts.WebDriver+import TestLib.Types+import TestLib.Types.Cli+import UnliftIO.Process+++main :: IO ()+main = do+  args <- getArgs+  putStrLn [i|args: #{args}|]++  clo <- parseCommandLineArgs userOptions (return ())++  let introduceSelenium3 :: forall ctx. (HasBaseContext ctx, HasNixContext ctx, HasBrowserDependencies ctx) => SpecFree (LabelValue "driverConfig" DriverConfig :> ctx) IO () -> SpecFree ctx IO ()+      introduceSelenium3 = introduce "Introduce Selenium 3" driverConfig alloc (const $ return ())+        where+          alloc = do+            Just dir <- getCurrentFolder+            java <- getBinaryViaNixPackage @"java" "jre"+            seleniumJar <- getFileViaNixPackage "selenium-server-standalone" tryFindSeleniumJar+            subDrivers <- getSubDrivers dir+            return $ DriverConfigSeleniumJar {+              driverConfigJava = java+              , driverConfigSeleniumJar = seleniumJar+              , driverConfigSubDrivers = subDrivers+              , driverConfigLogDir = dir+              , driverConfigJavaFlags = []+              , driverConfigSeleniumVersion = Just Selenium3+              }++  let introduceSelenium4 :: forall ctx. (HasBaseContext ctx, HasNixContext ctx, HasBrowserDependencies ctx) => SpecFree (LabelValue "driverConfig" DriverConfig :> ctx) IO () -> SpecFree ctx IO ()+      introduceSelenium4 = introduce "Introduce Selenium 4" driverConfig alloc (const $ return ())+        where+          alloc = do+            Just dir <- getCurrentFolder+            java <- getBinaryViaNixPackage @"java" "jre"+            seleniumJar <- getFileViaNixDerivation selenium4Derivation tryFindSeleniumJar+            subDrivers <- getSubDrivers dir+            return $ DriverConfigSeleniumJar {+              driverConfigJava = java+              , driverConfigSeleniumJar = seleniumJar+              , driverConfigSubDrivers = subDrivers+              , driverConfigLogDir = dir+              , driverConfigJavaFlags = []+              , driverConfigSeleniumVersion = Just Selenium4+              }++  let introduceChromedriver :: forall ctx. (HasBaseContext ctx, HasNixContext ctx) => SpecFree (LabelValue "driverConfig" DriverConfig :> ctx) IO () -> SpecFree ctx IO ()+      introduceChromedriver = introduce "Introduce chromedriver" driverConfig alloc (const $ return ())+        where+          alloc = do+            Just dir <- getCurrentFolder+            chrome <- getBinaryViaNixPackage @"google-chrome-stable" "google-chrome"+            chromedriver <- getBinaryViaNixPackage @"chromedriver" "chromedriver"+            return $ DriverConfigChromedriver {+              driverConfigChromedriver = chromedriver+              , driverConfigChrome = chrome+              , driverConfigLogDir = dir+              , driverConfigChromedriverFlags = []+              }++  let introduceGeckodriver :: forall ctx. (HasBaseContext ctx, HasNixContext ctx) => SpecFree (LabelValue "driverConfig" DriverConfig :> ctx) IO () -> SpecFree ctx IO ()+      introduceGeckodriver = introduce "Introduce geckodriver" driverConfig alloc (const $ return ())+        where+          alloc = do+            Just dir <- getCurrentFolder+            firefox <- getBinaryViaNixPackage @"firefox" "firefox"+            geckodriver <- getBinaryViaNixPackage @"geckodriver" "geckodriver"+            return $ DriverConfigGeckodriver {+              driverConfigGeckodriver = geckodriver+              , driverConfigFirefox = firefox+              , driverConfigLogDir = dir+              , driverConfigGeckodriverFlags = []+              }++  let UserOptions {optBrowserToUse} = optUserOptions clo++  runSandwichWithCommandLineArgs' defaultOptions userOptions $+    introduceNixContext nixpkgsRelease $+    introduceStaticServer $+    introduceBrowserDependencies $ do+      describe "Selenium 3" $ introduceSelenium3 $ introduceWebDriverContext $ Spec.spec++      describe "Selenium 4" $ introduceSelenium4 $ introduceWebDriverContext $ Spec.spec++      when (optBrowserToUse == UseChrome) $+        describe "chromedriver direct" $ introduceChromedriver $ introduceWebDriverContext Spec.spec++      when (optBrowserToUse == UseFirefox) $+        describe "geckodriver direct" $ introduceGeckodriver $ introduceWebDriverContext Spec.spec+++-- | Nixpkgs release 24.05, accessed 6\/30\/2025.+-- You can compute updated values for this release (or others) by running+-- nix-prefetch-github NixOS nixpkgs --rev release-25.05+-- We pin this here rather than using 'nixpkgsReleaseDefault' from sandwich-contexts+-- so that sandwich updates can't break this (especially on aarch64-darwin, where+-- google-chrome isn't available on older versions of release-24.05). Also, firefox+-- isn't available for macOS on older Nixpkgs releases.+nixpkgsRelease :: NixpkgsDerivation+nixpkgsRelease = NixpkgsDerivationFetchFromGitHub {+  nixpkgsDerivationOwner = "NixOS"+  , nixpkgsDerivationRepo = "nixpkgs"+  , nixpkgsDerivationRev = "32bd9b9bf9dd95eafff1e83da314c96719908657"+  , nixpkgsDerivationSha256 = "sha256-HXDDEjEBMycmwkOiU045bL3yuhOK1+nZZd3zsBh6zsA="+  , nixpkgsDerivationAllowUnfree = True+  }++getSubDrivers :: (MonadReader ctx m, HasBrowserDependencies ctx) => FilePath -> m [DriverConfig]+getSubDrivers dir = getContext browserDependencies >>= \case+  BrowserDependenciesChrome {..} -> return [+    DriverConfigChromedriver {+        driverConfigChromedriver = browserDependenciesChromeChromedriver+        , driverConfigChrome = browserDependenciesChromeChrome+        , driverConfigLogDir = dir+        , driverConfigChromedriverFlags = []+        }]+  BrowserDependenciesFirefox {..} -> return [+    DriverConfigGeckodriver {+        driverConfigGeckodriver = browserDependenciesFirefoxGeckodriver+        , driverConfigFirefox = browserDependenciesFirefoxFirefox+        , driverConfigLogDir = dir+        , driverConfigGeckodriverFlags = []+    }]+++tryFindSeleniumJar :: FilePath -> IO FilePath+tryFindSeleniumJar path = (T.unpack . T.strip . T.pack) <$> readCreateProcess (proc "find" [path, "-name", "*.jar"]) ""
+ tests/Spec.hs view
@@ -0,0 +1,16 @@+{-# OPTIONS_GHC -F -pgmF sandwich-discover #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++module Spec where++import Test.Sandwich hiding (BrowserToUse(..))+import TestLib.Types++#insert_test_imports+++spec :: SpecWithWebDriver+spec = describe "Selenium tests" $ do+  $(getSpecFromFolder defaultGetSpecFromFolderOptions)
+ tests/Spec/Actions.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE NumericUnderscores #-}++module Spec.Actions where++import Data.Aeson as A+import Data.String.Interpolate+import qualified Data.Text.Lazy.Encoding as TLE+import System.FilePath+import Test.Sandwich+import Test.WebDriver+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Mouse+import TestLib.Types++-- import Control.Monad.IO.Unlift+-- import Control.Concurrent+++setUp :: (+  HasStaticServerContext context, HasSession context+  ) => SpecFree context IO () -> SpecFree context IO ()+setUp x = before "Open test page" openSimpleTestPage $ before "scroll to clickable box" scrollToClickableBox x++tests :: SessionSpec+tests = introduceSession $ describe "Actions" $ setUp $ do+  it "moveToCenter" $ do+    Just dir <- getCurrentFolder+    saveScreenshot (dir </> "before.png")++    -- TODO: how to test this? Might need to detect mouseover events+    pending++    -- box <- findElem (ByCSS "#clickable-box")+    -- clickCenter box+    -- getBoundingClientRect "#clickable-box" >>= \bcr -> info [i|bcr: #{bcr}|]+    -- getLastMouseEvent >>= \lme -> info [i|lme: #{lme}|]++  it "clickCenter" $ do+    findElem (ByCSS "#clickable-box") >>= clickCenter+    center <- getElementCenter "#clickable-box"+    Just MouseEvent { eventType=MouseEventTypeClick, .. } <- getLastMouseEvent++    -- liftIO $ threadDelay 2_000_000+    -- Just dir <- getCurrentFolder+    -- saveScreenshot (dir </> "click.png")+    -- ignoreReturn $ executeJS [] [i|document.querySelectorAll('div.magic').forEach(div => div.remove());|]+    -- liftIO $ threadDelay 2_000_000++    assertWithinPixels center (fromIntegral clientX, fromIntegral clientY) 25++  it "doubleClick" $ do+    findElem (ByCSS "#clickable-box") >>= doubleClickCenter++    -- liftIO $ threadDelay 2_000_000+    -- Just dir <- getCurrentFolder+    -- saveScreenshot (dir </> "doubleclick.png")+    -- ignoreReturn $ executeJS [] [i|document.querySelectorAll('div.magic').forEach(div => div.remove());|]+    -- liftIO $ threadDelay 2_000_000++    center <- getElementCenter "#clickable-box"+    Just MouseEvent { eventType=MouseEventTypeDoubleClick, .. } <- getLastMouseEvent+    assertWithinPixels center (fromIntegral clientX, fromIntegral clientY) 25+++scrollToClickableBox :: (HasSession ctx) => ExampleT ctx IO ()+scrollToClickableBox = do+  -- { behavior: 'smooth', block: 'nearest', inline: 'nearest' }+  executeJS [] [i|document.querySelector("\#clickable-box").scrollIntoView()|]++getLastMouseEvent :: (HasSession ctx) => ExampleT ctx IO (Maybe MouseEvent)+getLastMouseEvent = do+  executeJS [] [i|return document.querySelector("\#last-mouse-event").innerText|] >>= \case+    "{}" -> return Nothing+    json -> case A.eitherDecode (TLE.encodeUtf8 json) of+      Left err -> expectationFailure [i|Failed to decode last mouse event: #{err}|]+      Right x -> pure x
+ tests/Spec/CommandContexts.hs view
@@ -0,0 +1,63 @@++module Spec.CommandContexts where++import Data.String.Interpolate+import Test.Sandwich+import Test.Sandwich.Waits+import Test.WebDriver.Commands+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Command contexts" $ before "Open test page" openSimpleTestPage $ do+  it "getCurrentWindow / focusWindow" $ do+    h <- getCurrentWindow+    info [i|Got current window: #{h}|]++  it "focusWindow" $ do+    getCurrentWindow >>= focusWindow++  it "windows" $ do+    ws <- windows+    info [i|windows: #{ws}|]++  it "focusFrame" $ do+    (length <$> findElems (ByCSS ".input-box")) >>= (`shouldBe` 3)++    findElem (ByCSS "#frame1") >>= focusFrame . WithElement+    (length <$> findElems (ByCSS ".input-box")) >>= (`shouldBe` 1)++  it "focusParentFrame" $ do+    focusParentFrame+    (length <$> findElems (ByCSS ".input-box")) >>= (`shouldBe` 3)++  it "maximize" $ do+    maximize++  it "minimize" $ do+    minimize++  it "fullscreen" $ do+    fullscreen++  describe "rect" $ do+    it "getWindowRect" $ do+      rect <- getWindowRect+      info [i|Got rect: #{rect}|]++    it "setWindowRect" $ do+      -- TODO: modify the rect+      getWindowRect >>= setWindowRect++  it "windows / closeWindow" $ do+    findElem (ByCSS "#openWindowButton") >>= click++    waitUntil 30 $ do+      (length <$> windows) >>= (`shouldBe` 2)++    getCurrentWindow >>= closeWindow++    waitUntil 30 $ do+      (length <$> windows) >>= (`shouldBe` 1)
+ tests/Spec/Cookies.hs view
@@ -0,0 +1,49 @@++module Spec.Cookies where++import qualified Data.List as L+import Data.Ord (comparing)+import Data.Text+import Test.Sandwich+import Test.WebDriver.Commands+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Cookies" $ before "Open test page" openSimpleTestPage $ do+  it "cookies" $ do+    cookies >>= (`shouldBe` [])++    setCookie (mkCookie "cookie1" "value1")+    (getCookieBasics <$> cookies) >>= (`shouldBe` [("cookie1", "value1")])++  it "cookie" $ do+    c <- cookie "cookie1"+    getCookieBasics [c] `shouldBe` [("cookie1", "value1")]++  it "setCookie" $ do+    setCookie (mkCookie "cookie1" "value1")+    (getCookieBasics <$> cookies) >>= (`shouldBe` [("cookie1", "value1")])++  it "deleteCookie" $ do+    deleteCookie "cookie1"+    cookies >>= (`shouldBe` [])++  it "deleteCookies" $ do+    setCookie (mkCookie "cookie1" "value1")+    setCookie (mkCookie "cookie2" "value2")+    (getCookieBasics <$> cookies) >>= (`shouldBe` [+                                          ("cookie1", "value1")+                                          , ("cookie2", "value2")+                                          ])++    deleteCookies+    cookies >>= (`shouldBe` [])+++getCookieBasics :: [Cookie] -> [(Text, Text)]+getCookieBasics = L.sortBy (comparing fst) . fmap go+  where+    go (Cookie {..}) = (cookName, cookValue)
+ tests/Spec/DocumentHandling.hs view
@@ -0,0 +1,37 @@++module Spec.DocumentHandling where++import Data.Aeson as A+import Data.String.Interpolate+import Data.Text+import Test.Sandwich+import Test.Sandwich.Waits+import Test.WebDriver.Commands+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Document handling" $ before "Open test page" openSimpleTestPage $ do+  it "getSource" $ do+    src <- getSource+    src `textShouldContain` "Test page"+    src `textShouldContain` [i|<a id="click-here-link" href="\#foo">Click here</a>|]++  it "executeJS" $ do+    () <- executeJS [] [i|document.querySelector("\#input1").value = "asdf";|]++    waitUntil 5 $ do+      findElem (ByCSS "#input1") >>= (`prop` "value") >>= (`shouldBe` (Just (A.String "asdf")))++      executeJS [] [i|return document.querySelector("\#input1").value;|]+        >>= (`shouldBe` ("asdf" :: Text))++    executeJS [] [i|return document.title;|] >>= (`shouldBe` ("Test page" :: String))++  it "asyncJS" $ do+    asyncJS [] [i|setTimeout(() => arguments[0](42), 5);|]+      >>= (`shouldBe` (Just (42 :: Int)))++    asyncJS [] [i|arguments[0](document.title);|] >>= (`shouldBe` (Just ("Test page" :: String)))
+ tests/Spec/ElementInteraction.hs view
@@ -0,0 +1,37 @@++module Spec.ElementInteraction where++import Data.Aeson as A+import Data.String.Interpolate+import Test.Sandwich+import Test.Sandwich.Waits+import Test.WebDriver.Commands+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Element interaction" $ before "Open test page" openSimpleTestPage $ do+  it "click" $ do+    findElem (ByCSS "#numberLabel") >>= getText >>= (`shouldBe` "0")++    findElem (ByCSS "#incrementButton") >>= click+    findElem (ByCSS "#numberLabel") >>= getText >>= (`shouldBe` "1")++    findElem (ByCSS "#incrementButton") >>= click+    findElem (ByCSS "#numberLabel") >>= getText >>= (`shouldBe` "2")++  it "clearInput" $ do+    () <- executeJS [] [i|document.querySelector("\#input1").value = "asdf";|]+    waitUntil 5 $ do+      findElem (ByCSS "#input1") >>= (`prop` "value") >>= (`shouldBe` (Just (A.String "asdf")))++    findElem (ByCSS "#input1") >>= clearInput+    waitUntil 5 $ do+      findElem (ByCSS "#input1") >>= (`prop` "value") >>= (`shouldBe` (Just (A.String "")))++  it "sendKeys" $ do+    findElem (ByCSS "#input1") >>= sendKeys "fdsa"+    waitUntil 5 $ do+      findElem (ByCSS "#input1") >>= (`prop` "value") >>= (`shouldBe` (Just (A.String "fdsa")))
+ tests/Spec/ElementRetrieval.hs view
@@ -0,0 +1,50 @@++module Spec.ElementRetrieval where++import Test.Sandwich+import Test.WebDriver+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+import UnliftIO.Exception+++tests :: SessionSpec+tests = introduceSession $ describe "Element retrieval" $ before "Open test page" openSimpleTestPage $ do+  describe "findElem" $ do+    it "ByCSS" $ do+      findElem (ByCSS "#incrementButton") >>= getText >>= (`shouldBe` "Increment")++    it "ByLinkText" $ do+      findElem (ByLinkText "Click here") >>= (`attr` "id") >>= (`shouldBe` (Just "click-here-link"))++    it "ByPartialLinkText" $ do+      findElem (ByPartialLinkText "here") >>= (`attr` "id") >>= (`shouldBe` (Just "click-here-link"))++    it "ByTag" $ do+      findElem (ByTag "label") >>= (`attr` "id") >>= (`shouldBe` (Just "numberLabel"))++    it "ByXPath" $ do+      findElem (ByXPath "//a[@id='click-here-link']") >>= getText >>= (`shouldBe` "Click here")++    it "Nonexistent" $ do+      Left (FailedCommand {..}) <- try $ findElem (ByCSS ".nonexistent-element")+      rspError `shouldBe` NoSuchElement++  it "findElems" $ do+    (length <$> findElems (ByCSS ".input-box")) >>= (`shouldBe` 3)++  it "findElemFrom" $ do+    container <- findElem (ByCSS ".input-boxes")+    findElemFrom container (ByCSS "#input1") >>= (`attr` "class") >>= (`shouldBe` (Just "input-box"))++  it "findElemsFrom" $ do+    container <- findElem (ByCSS ".input-boxes")+    (length <$> findElemsFrom container (ByCSS ".input-box")) >>= (`shouldBe` 2)++  it "activeElem" $ do+    container <- findElem (ByCSS "#input1")+    click container++    el <- activeElem+    el `shouldBe` container
+ tests/Spec/ElementState.hs view
@@ -0,0 +1,60 @@++module Spec.ElementState where++import Data.Aeson as A+import Data.String.Interpolate+import Data.Text as T+import Test.Sandwich+import Test.WebDriver.Commands+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Element state" $ before "Open test page" openSimpleTestPage $ do+  it "isSelected" $ do+    findElem (ByCSS "#checkbox") >>= isSelected >>= (`shouldBe` False)++    findElem (ByCSS "#checkbox") >>= click+    findElem (ByCSS "#checkbox") >>= isSelected >>= (`shouldBe` True)++    findElem (ByCSS "#checkbox") >>= click+    findElem (ByCSS "#checkbox") >>= isSelected >>= (`shouldBe` False)++  it "attr" $ do+    findElem (ByTag "label") >>= (`attr` "id") >>= (`shouldBe` (Just "numberLabel"))++  it "prop" $ do+    findElem (ByCSS "#checkbox") >>= isSelected >>= (`shouldBe` False)+    findElem (ByCSS "#checkbox") >>= (`prop` "checked") >>= (`shouldBe` (Just (A.Bool False)))++    findElem (ByCSS "#checkbox") >>= click+    findElem (ByCSS "#checkbox") >>= isSelected >>= (`shouldBe` True)+    findElem (ByCSS "#checkbox") >>= (`prop` "checked") >>= (`shouldBe` (Just (A.Bool True)))++  it "cssProp" $ do+    Just color <- findElem (ByCSS "#input-red") >>= (`cssProp` "color")+    -- Depending on browser, this can produce a couple different values+    ["rgb(255,0,0)", "rgba(255,0,0,1)"] `shouldContain` [T.filter (/= ' ') color]++  it "getText" $ do+    findElem (ByCSS "#click-here-link") >>= getText >>= (`shouldBe` "Click here")++  it "tagName" $ do+    findElem (ByCSS "#incrementButton") >>= tagName >>= (`shouldBe` "button")+    findElem (ByCSS "#numberLabel") >>= tagName >>= (`shouldBe` "label")+    findElem (ByCSS "a") >>= tagName >>= (`shouldBe` "a")++  it "elemRect" $ do+    rect1 <- findElem (ByCSS "#input1") >>= elemRect+    info [i|rect1: #{rect1}|]+    rect2 <- findElem (ByCSS "#input2") >>= elemRect+    info [i|rect2: #{rect2}|]++    rectX rect1 `shouldBe` rectX rect2+    (rectY rect1 < rectY rect2) `shouldBe` True++  it "isEnabled" $ do+    findElem (ByCSS "#input1") >>= isEnabled >>= (`shouldBe` True)+    findElem (ByCSS "#input-disabled") >>= isEnabled >>= (`shouldBe` False)
+ tests/Spec/Logs.hs view
@@ -0,0 +1,35 @@+module Spec.Logs where++import Data.String.Interpolate+import qualified Data.Text as T+import Test.Sandwich+import Test.Sandwich.Waits+import Test.WebDriver.Commands+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Browser logs" $ before "Open test page" openSimpleTestPage $ do+  it "captures different log levels" $ do+    pendingOnFirefox++    ignoreReturn $ executeJS [] [i|+      console.log('info message');+      console.warn('warning message');+      console.error('error message');+    |]+    waitUntil 15 $ do+      logs <- getLogs "server"+      info [i|logs: #{logs}|]++      consoleLogs <- getLogs "browser"+      info [i|consoleLogs: #{consoleLogs}|]++      let logMessages = map logMsg consoleLogs+      let hasInfo = any (T.isInfixOf "info message") logMessages+      let hasWarning = any (T.isInfixOf "warning message") logMessages+      let hasError = any (T.isInfixOf "error message") logMessages++      (hasInfo || hasWarning || hasError) `shouldBe` True
+ tests/Spec/LogsBiDi.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE NumericUnderscores #-}++module Spec.LogsBiDi where++import Control.Monad.IO.Class+import Data.Foldable (toList)+import Data.Sequence+import Data.String.Interpolate+import Data.Text (Text)+import qualified Data.Text as T+import Test.Sandwich+import Test.Sandwich.Waits+import Test.WebDriver.Commands+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+import UnliftIO.IORef+++tests :: SessionSpec+tests = introduceSession $ describe "Browser logs via BiDi" $ before "Open test page" openSimpleTestPage $ do+  it "captures console.log messages" $ do+    -- This test should pass on Selenium 4, but we get an error connecting to the BiDi socket.+    pendingOnSelenium++    allLogEntries <- newIORef (mempty :: Seq LogEntry)++    let cb logEntry = atomicModifyIORef' allLogEntries (\x -> (x |> logEntry, ()))+    withRecordLogsViaBiDi cb $ do+      ignoreReturn $ executeJS [] [i|console.log('log message from haskell-webdriver');|]+      ignoreReturn $ executeJS [] [i|console.warn('warn message from haskell-webdriver');|]+      ignoreReturn $ executeJS [] [i|console.error('error message from haskell-webdriver');|]++      waitUntil 15 $ do+        entries <- toList <$> readIORef allLogEntries+        someMessageShouldContain entries "log message"+        someMessageShouldContain entries "warn message"+        someMessageShouldContain entries "error message"+++someMessageShouldContain :: MonadIO m => [LogEntry] -> Text -> m ()+someMessageShouldContain entries needle = case [x | x@(LogEntry {..}) <- entries, needle `T.isInfixOf` logMsg] of+  [] -> expectationFailure [i|Couldn't find a log message containing needle '#{needle}'|]+  _ -> return ()
+ tests/Spec/Navigation.hs view
@@ -0,0 +1,48 @@++module Spec.Navigation where++import Data.String.Interpolate+import Data.Text (Text)+import qualified Data.Text as T+import Network.URI+import Test.Sandwich+import Test.WebDriver.Commands+import Test.WebDriver.Types+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Navigation" $ before "Open test page" openSimpleTestPage $ do+  it "getCurrentURL / getTitle" $ do+    urlShouldEndWith "test.html"+    getTitle >>= (`shouldBe` "Test page")++  it "openPage / getCurrentURL / getTitle" $ do+    url <- parseAbsoluteURI <$> getCurrentURL >>= \case+      Nothing -> expectationFailure [i|Couldn't parse URI|]+      Just u -> pure u+    openPage $ show (url { uriPath = "/test2.html" })+    urlShouldEndWith "test2.html"+    getTitle >>= (`shouldBe` "Test page 2")++  it "back" $ do+    back+    urlShouldEndWith "test.html"++  it "forward" $ do+    forward+    urlShouldEndWith "test2.html"++  it "refresh" $ do+    refresh++  it "getTitle" $ do+    getTitle >>= (`shouldBe` "Test page 2")+++urlShouldEndWith :: (WebDriver m) => Text -> m ()+urlShouldEndWith suffix = do+  url <- getCurrentURL+  (suffix `T.isSuffixOf` (T.pack url)) `shouldBe` True
+ tests/Spec/ScreenCapture.hs view
@@ -0,0 +1,27 @@++module Spec.ScreenCapture where++import Control.Monad.IO.Class+import qualified Data.ByteString.Lazy as BL+import System.FilePath+import Test.Sandwich+import Test.WebDriver.Commands+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Screen capture" $ before "Open test page" openSimpleTestPage $ do+  it "screenshot" $ do+    Just dir <- getCurrentFolder+    screenshot >>= liftIO . BL.writeFile (dir </> "screenshot.png")++  it "screenshotElement" $ do+    Just dir <- getCurrentFolder+    e <- findElem (ByCSS ".frame-container")+    screenshotElement e >>= liftIO . BL.writeFile (dir </> "screenshotElement.png")++  it "saveScreenshot" $ do+    Just dir <- getCurrentFolder+    saveScreenshot (dir </> "saveScreenshot.png")
+ tests/Spec/SeleniumSpecific/Mobile.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++module Spec.SeleniumSpecific.Mobile where++import Test.Sandwich+-- import Test.WebDriver+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+-- import UnliftIO.Concurrent+++tests :: SessionSpec+tests = introduceMobileSession $ describe "Mobile" $ before "Open test page" openSimpleTestPage $ do+  it "Pauses" $ do+    -- threadDelay 999_999_000_000+    pending
+ tests/Spec/SeleniumSpecific/Uploads.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}++module Spec.SeleniumSpecific.Uploads where++import Control.Monad.IO.Class+import qualified Data.Text as T+import System.FilePath+import Test.Sandwich+import Test.WebDriver+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Uploads" $ before "Open test page" (openStaticServerUrl "/test_file_upload.html") $ do+  it "Upload file with sendKeys" $ do+    Just dir <- getCurrentFolder+    let fp = dir </> "test-file.txt"+    liftIO $ writeFile fp "file contents"+    findElem (ByCSS "input") >>= sendKeys (T.pack fp)+    findElem (ByCSS "#contents") >>= getText >>= (`shouldBe` "test-file.txt 13")++  describe "Selenium specific" $ do+    it "upload file to grid and use sendKeys to upload to browser" $ do+      pendingOnNonSelenium+      filePath <- seleniumUploadRawFile "/shopping.txt" 0 "Eggs, Ham, Cheese"+      findElem (ByCSS "input") >>= sendKeys filePath+      findElem (ByCSS "#contents") >>= getText >>= (`shouldBe` "shopping.txt 17")
+ tests/Spec/Sessions.hs view
@@ -0,0 +1,62 @@++module Spec.Sessions where++import Data.String.Interpolate+import Test.Sandwich+import Test.WebDriver.Commands+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "Sessions" $ before "Open test page" openSimpleTestPage $ do+  -- createSession is already tested in introduceSession++  it "status" $ do+    status <- serverStatus+    info [i|Got status: #{status}|]++  -- TODO: test closeSession without breaking the context+  it "closeSession" $ do+    pending++  describe "Timeouts" $ do+    describe "Bulk timeout functions" $ do+      it "getTimeouts" $ do+        timeouts <- getTimeouts+        info [i|Got timeouts: #{timeouts}|]++      it "setTimeouts" $ do+        let timeouts = Timeouts {+              timeoutsScript = Just 1+              , timeoutsPageLoad = Just 2+              , timeoutsImplicit = Just 3+              }+        setTimeouts timeouts++        getTimeouts >>= (`shouldBe` timeouts)++    describe "Individual timeout functions" $ do+      it "setScriptTimeout" $ do+        setScriptTimeout (Just 11)+        getTimeouts >>= (`shouldBe` (Timeouts (Just 11) (Just 2) (Just 3)))++        setScriptTimeout Nothing+        getTimeouts >>= (`shouldBe` (Timeouts Nothing (Just 2) (Just 3)))++      it "setPageLoadTimeout" $ do+        setPageLoadTimeout 12+        getTimeouts >>= (`shouldBe` (Timeouts Nothing (Just 12) (Just 3)))++      it "setImplicitWait" $ do+        setImplicitWait 13+        getTimeouts >>= (`shouldBe` (Timeouts Nothing (Just 12) (Just 13)))++  -- it "sessions" $ do+  --   xs <- sessions+  --   info [i|Got sessions: #{xs}|]++  -- it "getActualCaps" $ do+  --   caps <- getActualCaps+  --   info [i|Got actual caps: #{caps}|]
+ tests/Spec/UserPrompts.hs view
@@ -0,0 +1,15 @@++module Spec.UserPrompts where++import Test.Sandwich+import TestLib.Contexts.Session+import TestLib.Contexts.StaticServer+import TestLib.Types+++tests :: SessionSpec+tests = introduceSession $ describe "User prompts" $ before "Open test page" openSimpleTestPage $ do+  it "dismissAlert" $ pending+  it "acceptAlert" $ pending+  it "getAlertText" $ pending+  it "replyToAlert" $ pending
+ tests/TestLib/Contexts/BrowserDependencies.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module TestLib.Contexts.BrowserDependencies where++import Control.Monad.IO.Unlift+import Data.String.Interpolate+import Test.Sandwich hiding (BrowserToUse(..))+import Test.Sandwich.Contexts.Files+import Test.Sandwich.Contexts.Nix+import TestLib.Types+import TestLib.Types.Cli+++introduceBrowserDependencies :: forall m context. (+  MonadUnliftIO m, HasBaseContext context, HasNixContext context, HasCommandLineOptions context UserOptions+  ) => SpecFree (LabelValue "browserDependencies" BrowserDependencies :> context) m () -> SpecFree context m ()+introduceBrowserDependencies = introduce "Introduce browser dependencies" browserDependencies alloc (const $ return ())+  where+    alloc = do+      UserOptions {..} <- getUserCommandLineOptions++      deps <- case optBrowserToUse of+        UseChrome ->+          BrowserDependenciesChrome <$> getBinaryViaNixPackage @"google-chrome-stable" "google-chrome"+                                    <*> getBinaryViaNixPackage @"chromedriver" "chromedriver"+                                    <*> pure optChromeNoSandbox+        UseFirefox ->+          BrowserDependenciesFirefox <$> getBinaryViaNixPackage @"firefox" "firefox"+                                     <*> getBinaryViaNixPackage @"geckodriver" "geckodriver"+      debug [i|Got browser dependencies: #{deps}|]+      return deps
+ tests/TestLib/Contexts/Selenium4.hs view
@@ -0,0 +1,55 @@++module TestLib.Contexts.Selenium4 where++import Data.String.Interpolate+import Data.Text+++selenium4Derivation :: Text+selenium4Derivation = [i|+{+  lib,+  stdenv,+  fetchurl,+  makeWrapper,+  jre,+}:++let+  minorVersion = "4.29";+  patchVersion = "0";++in+stdenv.mkDerivation rec {+  pname = "selenium-server";+  version = "${minorVersion}.${patchVersion}";++  src = fetchurl {+    url = "https://github.com/SeleniumHQ/selenium/releases/download/selenium-${version}/selenium-server-${version}.jar";+    hash = "sha256-og3RlPbRU7Mj5F+QJ1cU3klbXSLxWH4ZcNjgphHBkMU=";+  };++  dontUnpack = true;++  nativeBuildInputs = [ makeWrapper ];+  buildInputs = [ jre ];++  installPhase = ''+    mkdir -p $out/share/lib/${pname}-${version}+    cp $src $out/share/lib/${pname}-${version}/${pname}-${version}.jar+    makeWrapper ${jre}/bin/java $out/bin/selenium-server+  '';++  meta = with lib; {+    homepage = "http://www.seleniumhq.org/";+    description = "Selenium Server for remote WebDriver";+    sourceProvenance = with sourceTypes; [ binaryBytecode ];+    license = licenses.asl20;+    maintainers = with maintainers; [+      thomasjm+    ];+    mainProgram = "selenium-server";+    platforms = platforms.all;+  };+}+|]
+ tests/TestLib/Contexts/Session.hs view
@@ -0,0 +1,120 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}++module TestLib.Contexts.Session (+  introduceSession+  , introduceSession'++  , introduceMobileSession++  , pendingOnSelenium+  , pendingOnNonSelenium+  , pendingOnSelenium3+  , pendingOnFirefox+  ) where++import Control.Exception.Safe+import Control.Monad.IO.Unlift+import Control.Monad.Reader+import Data.Function+import Data.Maybe+import Lens.Micro+import Test.Sandwich+import Test.WebDriver+import Test.WebDriver.Capabilities+import TestLib.Types+import TestLib.Types.Cli++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap          as KM+#else+import qualified Data.HashMap.Strict        as KM+#endif+++introduceSession :: forall m context. (+  MonadUnliftIO m, MonadMask m+  , HasBrowserDependencies context, HasWebDriverContext context, HasDriverConfig context, HasCommandLineOptions context UserOptions+  ) => SpecFree (LabelValue "session" Session :> context) m () -> SpecFree context m ()+introduceSession = introduceSession' enableBiDi+  where+    enableBiDi :: Capabilities -> ExampleT context m Capabilities+    enableBiDi x = do+      getContext driverConfig >>= \case+        DriverConfigSeleniumJar { driverConfigSeleniumVersion=(Just Selenium3) } -> return x+        _ -> x+             & set capabilitiesWebSocketUrl (Just True)+             & return++introduceSession' :: forall m context. (+  MonadUnliftIO m, MonadMask m+  , HasBrowserDependencies context, HasWebDriverContext context, HasDriverConfig context, HasCommandLineOptions context UserOptions+  ) => (Capabilities -> ExampleT context m Capabilities) -> SpecFree (LabelValue "session" Session :> context) m () -> SpecFree context m ()+introduceSession' modifyCaps = introduce "Introduce session" session alloc cleanup+  where+    alloc = do+      browserDeps <- getContext browserDependencies+      wdc <- getContext webdriverContext++      UserOptions {..} <- getUserCommandLineOptions+      caps <- getCapabilities (fromMaybe False optHeadlessTests) browserDeps >>= modifyCaps++      dc <- getContext driverConfig++      startSession wdc dc caps "session1"++    cleanup sess = do+      wdc <- getContext webdriverContext+      closeSession wdc sess+++introduceMobileSession :: forall m context. (+  MonadUnliftIO m, MonadMask m+  , HasBrowserDependencies context, HasWebDriverContext context, HasDriverConfig context, HasCommandLineOptions context UserOptions+  ) => SpecFree (LabelValue "session" Session :> context) m () -> SpecFree context m ()+introduceMobileSession = introduceSession' modifyCaps+  where+    modifyCaps :: Capabilities -> ExampleT context m Capabilities+    modifyCaps x = x+                   & over (capabilitiesGoogChromeOptions . _Just) modifyChromeOptions+                   & over (capabilitiesMozFirefoxOptions . _Just) modifyFirefoxOptions+                   & return++    modifyChromeOptions :: ChromeOptions -> ChromeOptions+    modifyChromeOptions x = x+                          & set chromeOptionsMobileEmulation (Just (ChromeMobileEmulationSpecificDevice "Pixel 7"))++    modifyFirefoxOptions :: FirefoxOptions -> FirefoxOptions+    modifyFirefoxOptions x = x+                           & over firefoxOptionsPrefs (Just . fromMaybe mempty)+                           & over (firefoxOptionsPrefs . _Just) (KM.insert "general.useragent.override" "Mozilla/5.0 (iPhone; CPU iPhone OS 14_0 like Mac OS X)")++                           & over firefoxOptionsArgs (Just . fromMaybe [])+                           & over (firefoxOptionsArgs . _Just) (\xs -> "--width=375" : "--height=667" : xs)++pendingOnNonSelenium :: (MonadReader ctx m, HasDriverConfig ctx, MonadIO m) => m ()+pendingOnNonSelenium = do+  getContext driverConfig >>= \case+    DriverConfigSeleniumJar {} -> return ()+    _ -> pending++pendingOnSelenium :: (MonadReader ctx m, HasDriverConfig ctx, MonadIO m) => m ()+pendingOnSelenium = do+  getContext driverConfig >>= \case+    DriverConfigSeleniumJar {} -> pending+    _ -> return ()++pendingOnSelenium3 :: (MonadReader ctx m, HasDriverConfig ctx, MonadIO m) => m ()+pendingOnSelenium3 = do+  getContext driverConfig >>= \case+    DriverConfigSeleniumJar {driverConfigSeleniumVersion=(Just Selenium3)} -> pending+    _ -> return ()++pendingOnFirefox :: (MonadReader ctx m, HasDriverConfig ctx, MonadIO m) => m ()+pendingOnFirefox = do+  getContext driverConfig >>= \case+    DriverConfigGeckodriver {} -> pending+    DriverConfigSeleniumJar {driverConfigSubDrivers=[DriverConfigGeckodriver {}]} -> pending+    _ -> return ()
+ tests/TestLib/Contexts/StaticServer.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++module TestLib.Contexts.StaticServer (+  introduceStaticServer++  , staticServer+  , HasStaticServerContext+  , StaticServerContext(..)++  , openStaticServerUrl+  , openSimpleTestPage+  ) where++import Control.Monad+import Control.Monad.Catch (MonadCatch)+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Reader+import Data.Function+import Data.String.Interpolate+import GHC.Stack+import Network.Wai.Application.Static+import Network.Wai.Handler.Warp+import System.FilePath+import Test.Sandwich hiding (BrowserToUse(..))+import Test.Sandwich.Contexts.Util.Ports+import Test.WebDriver.Commands+import Test.WebDriver.Types+import TestLib.Types+import UnliftIO.Async+import UnliftIO.Directory+import UnliftIO.Exception+import UnliftIO.MVar+++introduceStaticServer :: forall context m. (+  HasCallStack, MonadUnliftIO m, MonadCatch m+  )+  => SpecFree (LabelValue "staticServer" StaticServerContext :> context) m ()+  -> SpecFree context m ()+introduceStaticServer = introduceWith "Introduce static server" staticServer withAlloc+  where+    withAlloc action = do+      staticDir <- getCurrentDirectory >>= findGitRoot >>= \case+        Just dir -> pure (dir </> "test-static")+        Nothing -> expectationFailure [i|Couldn't find test-static directory|]+      info [i|Got static dir: #{staticDir}|]+      let serverStaticConf = defaultFileServerSettings staticDir++      port <- findFreePortOrException++      baton <- newEmptyMVar++      let serverConf = defaultSettings+                     & setPort (fromIntegral port)+                     & setBeforeMainLoop (putMVar baton ())++      bracket+        (do+            asy <- async $ liftIO $ runSettings serverConf (staticApp serverStaticConf)+            takeMVar baton+            info [i|Started static server on http://localhost:#{port}|]+            return asy+        )+        cancel+        (\_ -> void $ action (StaticServerContext "localhost" port))++findGitRoot :: MonadIO m => FilePath -> m (Maybe FilePath)+findGitRoot dir = do+  let gitDir = dir </> ".git"+  doesDirectoryExist gitDir >>= \case+    True -> return (Just dir)+    False -> do+      let parent = takeDirectory dir+      if parent == dir+        then return Nothing+        else findGitRoot parent++openStaticServerUrl :: (+  MonadReader context m, HasStaticServerContext context, WebDriver m+  ) => FilePath -> m ()+openStaticServerUrl url = do+  StaticServerContext {..} <- getContext staticServer+  openPage [i|http://#{staticServerHostname}:#{staticServerPort}#{url}|]++openSimpleTestPage :: (+  MonadReader context m, HasStaticServerContext context, WebDriver m+  ) => m ()+openSimpleTestPage = openStaticServerUrl "/test.html"
+ tests/TestLib/Contexts/WebDriver.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}++module TestLib.Contexts.WebDriver (+  introduceWebDriverContext+  ) where++import Control.Monad+import Control.Monad.Catch (MonadCatch)+import Control.Monad.IO.Unlift+import GHC.Stack+import Test.Sandwich hiding (BrowserToUse(..))+import Test.WebDriver+import TestLib.Types+import UnliftIO.Exception+++introduceWebDriverContext :: forall context m. (+  HasCallStack, MonadUnliftIO m, MonadCatch m+  )+  => SpecFree (LabelValue "webdriver" WebDriverContext :> context) m ()+  -> SpecFree context m ()+introduceWebDriverContext = introduceWith "Introduce WebDriver" webdriverContext withAlloc+  where+    withAlloc action = bracket mkEmptyWebDriverContext teardownWebDriverContext (void . action)
+ tests/TestLib/Mouse.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiWayIf #-}++module TestLib.Mouse (+  assertWithinPixels+  , getBoundingClientRect+  , getElementCenter++  , MouseEventType(..)+  , MouseEvent(..)+  , ClientRect(..)+  ) where++import Control.Monad.IO.Class+import Data.Aeson as A+import Data.String.Interpolate+import qualified Data.Text as T+import GHC.Generics+import Test.Sandwich+import Test.WebDriver+import TestLib.Types+++data MouseEventType =+  MouseEventTypeClick+  | MouseEventTypeDoubleClick+  | MouseEventTypeContextMenu+  deriving (Show, Eq)+instance FromJSON MouseEventType where+  parseJSON (String "click") = pure MouseEventTypeClick+  parseJSON (String "dblclick") = pure MouseEventTypeDoubleClick+  parseJSON (String "contextmenu") = pure MouseEventTypeContextMenu+  parseJSON x = fail [i|Unexpected mouse event type: #{x}|]++data MouseEvent = MouseEvent {+  eventType :: MouseEventType+  , screenX :: Int+  , screenY :: Int+  , clientX :: Int+  , clientY :: Int+  , pageX :: Int+  , pageY :: Int+  , button :: Int+  } deriving (Show, Eq, Generic, FromJSON)++data ClientRect = ClientRect {+  bottom :: Double+  , height :: Double+  , left :: Double+  , right :: Double+  , top :: Double+  , width :: Double+  , x :: Double+  , y :: Double+  } deriving (Show, Eq, Generic, FromJSON)++assertWithinPixels :: (MonadIO m) => (Double, Double) -> (Double, Double) -> Double -> m ()+assertWithinPixels (x1, y1) (x2, y2) tolerance =+  if | d <= tolerance -> return ()+     | otherwise -> expectationFailure [i|Points were supposed to be within #{tolerance}, but distance was #{d}|]+  where+    d = sqrt ((x2 - x1)**2 + (y2 - y1)**2)++getBoundingClientRect :: (HasSession ctx) => T.Text -> ExampleT ctx IO ClientRect+getBoundingClientRect cssSelector =+  executeJS [JSArg cssSelector] [i|return document.querySelector(arguments[0]).getBoundingClientRect()|]++getElementCenter :: (HasSession ctx) => T.Text -> ExampleT ctx IO (Double, Double)+getElementCenter cssSelector = do+  ClientRect {..} <- getBoundingClientRect cssSelector+  return (left + (width / 2.0), top + (height / 2.0))
+ tests/TestLib/Types.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module TestLib.Types (+  StaticServerContext(..)+  , staticServer+  , HasStaticServerContext++  , BrowserDependencies(..)+  , browserDependencies+  , HasBrowserDependencies++  , driverConfig+  , HasDriverConfig++  , webdriverContext+  , HasWebDriverContext++  , getCapabilities++  , session+  , HasSession++  , SeleniumVersion(..)++  , SessionSpec+  , SpecWithWebDriver+  ) where++import Control.Exception.Safe+import Control.Monad.IO.Unlift+import Data.ByteString+import qualified Data.ByteString.Lazy as BL+import Data.String.Interpolate+import Lens.Micro+import qualified Network.HTTP.Client as HC+import Network.HTTP.Types.Status as N+import Network.Socket (PortNumber)+import Test.Sandwich+import Test.Sandwich.Contexts.Nix+import Test.WebDriver+import Test.WebDriver.Capabilities+import Test.WebDriver.Types+import TestLib.Types.Cli+++-- * StaticServer++data StaticServerContext = StaticServerContext {+  staticServerHostname :: String+  , staticServerPort :: PortNumber+  }++staticServer :: Label "staticServer" StaticServerContext+staticServer = Label++type HasStaticServerContext context = HasLabel context "staticServer" StaticServerContext++-- * BrowserDependencies++data BrowserDependencies = BrowserDependenciesChrome {+  browserDependenciesChromeChrome :: FilePath+  , browserDependenciesChromeChromedriver :: FilePath+  , browserDependenciesChromeNoSandbox :: Maybe Bool+  }+  | BrowserDependenciesFirefox {+      browserDependenciesFirefoxFirefox :: FilePath+      , browserDependenciesFirefoxGeckodriver :: FilePath+      }+  deriving (Show)++browserDependencies :: Label "browserDependencies" BrowserDependencies+browserDependencies = Label++type HasBrowserDependencies context = HasLabel context "browserDependencies" BrowserDependencies++-- * WebDriver++driverConfig :: Label "driverConfig" DriverConfig+driverConfig = Label++type HasDriverConfig context = HasLabel context "driverConfig" DriverConfig++-- * WebDriver++webdriverContext :: Label "webdriver" WebDriverContext+webdriverContext = Label++type HasWebDriverContext context = HasLabel context "webdriver" WebDriverContext++-- * Session++session :: Label "session" Session+session = Label++type HasSession context = HasLabel context "session" Session++-- * Instances++instance (HasSession context, MonadIO m) => SessionState (ExampleT context m) where+  getSession = getContext session++  -- putSession sess = do+  --   sessVar <- getContext wdSession+  --   writeIORef sessVar sess++instance (MonadUnliftIO m, MonadCatch m) => WebDriverBase (ExampleT context m) where+  doCommandBase driver method path args = do+    let req = mkDriverRequest driver method path args+    -- debug [i|--> Full request: #{req} (#{showRequestBody (HC.requestBody req)})|]+    debug [i|--> #{HC.method req} #{HC.path req}#{HC.queryString req} (#{showRequestBody (HC.requestBody req)})|]+    response <- tryAny (liftIO $ HC.httpLbs req (_driverManager driver)) >>= either throwIO return+    let (N.Status code _) = HC.responseStatus response+    debug [i|<-- #{code} #{response}|]+    return response++    where+      showRequestBody :: HC.RequestBody -> ByteString+      showRequestBody (HC.RequestBodyLBS bytes) = BL.toStrict bytes+      showRequestBody (HC.RequestBodyBS bytes) = bytes+      showRequestBody _ = "<request body>"++-- * Config++getCapabilities :: MonadIO m => Bool -> BrowserDependencies -> m Capabilities+getCapabilities headless (BrowserDependenciesChrome {..}) = pure $ defaultCaps {+  _capabilitiesBrowserName = Just "chrome"+  , _capabilitiesGoogChromeOptions = Just $+    defaultChromeOptions+      & over (chromeOptionsArgs . non []) (if headless then (\xs -> "--headless" : [i|--window-size=1920,1080|] : xs) else id)+      & over (chromeOptionsArgs . non []) (if browserDependenciesChromeNoSandbox == Just True then ("--no-sandbox" :) else id)+      & set chromeOptionsBinary (Just browserDependenciesChromeChrome)+  }+getCapabilities headless (BrowserDependenciesFirefox {..}) = pure $ defaultCaps {+  _capabilitiesBrowserName = Just "firefox"+  , _capabilitiesMozFirefoxOptions = Just $+    defaultFirefoxOptions+      & set firefoxOptionsBinary (Just browserDependenciesFirefoxFirefox)+      & over (firefoxOptionsArgs . non []) (if headless then ("-headless" :) else id)+  }++-- * Spec types++type SpecWithWebDriver = forall context. (+  HasBaseContext context+  , HasCommandLineOptions context UserOptions+  , HasBrowserDependencies context+  , HasDriverConfig context+  , HasWebDriverContext context+  , HasStaticServerContext context+  , HasNixContext context+  ) => SpecFree context IO ()++type SessionSpec = forall context. (+  HasBaseContext context+  , HasCommandLineOptions context UserOptions+  , HasBrowserDependencies context+  , HasDriverConfig context+  , HasWebDriverContext context+  , HasStaticServerContext context+  ) => SpecFree context IO ()
+ tests/TestLib/Types/Cli.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE RankNTypes #-}++module TestLib.Types.Cli where++import Options.Applicative+++data BrowserToUse = UseChrome | UseFirefox+  deriving (Show, Eq)++browserToUse :: (forall f a. Mod f a) -> Parser BrowserToUse+browserToUse maybeInternal =+  flag' UseFirefox (long "use-firefox" <> help "Use Firefox" <> maybeInternal)+  <|> flag UseChrome UseChrome (long "use-chrome" <> help "Use Chrome (default)" <> maybeInternal)++data UserOptions = UserOptions {+  optChromeBinary :: Maybe FilePath+  , optChromeDriver :: Maybe FilePath+  , optChromeNoSandbox :: Maybe Bool++  , optFirefoxBinary :: Maybe FilePath+  , optGeckoDriver :: Maybe FilePath++  , optBrowserToUse :: BrowserToUse++  , optHeadlessTests :: Maybe Bool+  } deriving (Show)++userOptions :: Parser UserOptions+userOptions = UserOptions+  <$> optional (strOption (long "webdriver-chrome" <> help "Path to Chrome binary"))+  <*> optional (strOption (long "webdriver-chromedriver" <> help "Path to chromedriver"))+  <*> optional (flag False True (long "webdriver-chrome-no-sandbox" <> help "Pass the --no-sandbox flag to Chrome (useful in GitHub Actions when installing Chrome via Nix)"))++  <*> optional (strOption (long "webdriver-firefox" <> help "Path to Firefox binary"))+  <*> optional (strOption (long "webdriver-geckodriver" <> help "Path to geckodriver"))++  <*> browserToUse mempty++  <*> optional (flag False True (long "headless-tests" <> help "Run the test browser in headless mode"))
+ tests/TestLib/Waits.hs view
@@ -0,0 +1,59 @@++module TestLib.Waits where++import Control.Exception.Safe+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Retry+import Data.String.Interpolate+import Network.Socket+import UnliftIO.Timeout++++-- * Socket waits++-- | Each individual connect attempt needs a timeout to prevent it from hanging+-- indefinitely. This policy allows us to make that timeout length adaptive,+-- based on the 'RetryStatus' of the outer retry policy.+--+-- Thus, the first attempt to connect will have a short timeout (currently 100ms),+-- and then successive attempts will get longer timeouts via "FullJitter" backoff.+-- The goals of this are twofold:+--+-- 1) If a connect call hangs during the first few attempts, it is timed out quickly+-- and re-attempted, so on a healthy network you aren't penalized too much by the hang.+-- The outer retry policy can control the time between attempts, so the user can set+-- it high enough to make this be the case.+--+-- 2) If the network is slow, we will eventually reach the maximum timeout of 3 seconds,+-- which should be long enough. Note that the popular wait-for script uses 1 second+-- timeouts, so this is extra conservative:+-- https://github.com/eficode/wait-for/blob/7586b3622f010808bb2027c19aaf367221b4ad54/wait-for#L72+connectRetryPolicy :: MonadIO m => RetryPolicyM m+connectRetryPolicy = capDelay (3000000) (fullJitterBackoff 100000)++waitForSocket :: (+  MonadUnliftIO m, MonadLogger m, MonadMask m+  )+  => RetryPolicyM m+  -> AddrInfo+  -> m ()+waitForSocket policy addr = recoverAll policy $ \retryStatus@(RetryStatus {..}) -> do+  flip withException (\(e :: SomeException) -> logErrorN [i|waitForSocket: failed to connect to #{addr}: #{e}|]) $ do+    when (rsIterNumber > 0) $+      logDebugN [i|waitForSocket: attempt \##{rsIterNumber} to connect to #{addr}|]++    bracket (liftIO initSocket) (liftIO . close) $ \sock -> do+      connectTimeoutUs <- (getRetryPolicyM connectRetryPolicy) retryStatus >>= \case+        Nothing -> throwIO $ userError "Timeout due to connect retry policy"+        Just us -> pure us++      timeout connectTimeoutUs (liftIO $ connect sock (addrAddress addr)) >>= \case+        Nothing -> throwIO $ userError "Timeout in connect attempt"+        Just () -> pure ()++  where+    initSocket = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
webdriver.cabal view
@@ -1,22 +1,20 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0.+-- This file has been generated from package.yaml by hpack version 0.38.0. -- -- see: https://github.com/sol/hpack  name:           webdriver-version:        0.12.0.1+version:        0.13.0.0 synopsis:       a Haskell client for the Selenium WebDriver protocol-description:    A Selenium WebDriver client for Haskell.-                You can use it to automate browser sessions-                for testing, system administration, etc.-                .-                For more information about Selenium itself, see-                <http://seleniumhq.org/>+description:    A WebDriver client for Haskell.+                You can use it to automate browser sessions for testing, system administration, etc.+                Here are some relevant links:                 .-                To find out what's been changed in this version and others,-                see the change log at-                <https://github.com/haskell-webdriver/haskell-webdriver/blob/main/CHANGELOG.md>+                * <https://www.w3.org/TR/webdriver2/>+                * <https://www.selenium.dev/>+                * <https://github.com/mozilla/geckodriver>+                * <https://developer.chrome.com/docs/chromedriver> category:       Web, Browser, Testing, WebDriver, Selenium homepage:       https://github.com/haskell-webdriver/haskell-webdriver#readme bug-reports:    https://github.com/haskell-webdriver/haskell-webdriver/issues@@ -26,12 +24,13 @@ license-file:   LICENSE build-type:     Simple tested-with:-    GHC == 8.6.5-  , GHC == 8.8.4-  , GHC == 8.10.7-  , GHC == 9.0.2-  , GHC == 9.2.7-  , GHC == 9.4.4+    GHC == 9.0.2+  , GHC == 9.2.8+  , GHC == 9.4.8+  , GHC == 9.6.7+  , GHC == 9.8.4+  , GHC == 9.10.2+  , GHC == 9.12.2 extra-source-files:     README.md     CHANGELOG.md@@ -44,63 +43,160 @@   exposed-modules:       Test.WebDriver       Test.WebDriver.Capabilities-      Test.WebDriver.Chrome.Extension-      Test.WebDriver.Class       Test.WebDriver.Commands-      Test.WebDriver.Commands.Internal-      Test.WebDriver.Commands.Wait-      Test.WebDriver.Common.Keys-      Test.WebDriver.Common.Profile-      Test.WebDriver.Config-      Test.WebDriver.Cookies-      Test.WebDriver.Exceptions-      Test.WebDriver.Exceptions.Internal-      Test.WebDriver.Firefox.Profile-      Test.WebDriver.Internal-      Test.WebDriver.JSON-      Test.WebDriver.Monad-      Test.WebDriver.Session-      Test.WebDriver.Session.History+      Test.WebDriver.Keys+      Test.WebDriver.Profile       Test.WebDriver.Types-      Test.WebDriver.Utils+      Test.WebDriver.Waits   other-modules:-      Test.WebDriver.IO+      Test.WebDriver.Capabilities.Aeson+      Test.WebDriver.Capabilities.ChromeOptions+      Test.WebDriver.Capabilities.FirefoxOptions+      Test.WebDriver.Capabilities.Platform+      Test.WebDriver.Capabilities.Proxy+      Test.WebDriver.Capabilities.Timeouts+      Test.WebDriver.Capabilities.UserPromptHandler+      Test.WebDriver.Commands.Actions+      Test.WebDriver.Commands.CommandContexts+      Test.WebDriver.Commands.Cookies+      Test.WebDriver.Commands.DocumentHandling+      Test.WebDriver.Commands.ElementInteraction+      Test.WebDriver.Commands.ElementRetrieval+      Test.WebDriver.Commands.ElementState+      Test.WebDriver.Commands.Logs+      Test.WebDriver.Commands.Logs.BiDi+      Test.WebDriver.Commands.Logs.Chrome+      Test.WebDriver.Commands.Logs.Common+      Test.WebDriver.Commands.Logs.Firefox+      Test.WebDriver.Commands.Logs.Selenium+      Test.WebDriver.Commands.Navigation+      Test.WebDriver.Commands.ScreenCapture+      Test.WebDriver.Commands.SeleniumSpecific.HTML5+      Test.WebDriver.Commands.SeleniumSpecific.Misc+      Test.WebDriver.Commands.SeleniumSpecific.Mobile+      Test.WebDriver.Commands.SeleniumSpecific.Uploads+      Test.WebDriver.Commands.Sessions+      Test.WebDriver.Commands.UserPrompts+      Test.WebDriver.Exceptions+      Test.WebDriver.JSON+      Test.WebDriver.LaunchDriver+      Test.WebDriver.Util.Aeson+      Test.WebDriver.Util.Commands+      Test.WebDriver.Util.Ports+      Test.WebDriver.Util.Sockets+      Paths_webdriver   hs-source-dirs:       src   default-extensions:-      ScopedTypeVariables-      OverloadedStrings       FlexibleContexts       FlexibleInstances-      RecordWildCards+      LambdaCase       NamedFieldPuns-  ghc-options: -Wall+      OverloadedStrings+      QuasiQuotes+      RecordWildCards+      ScopedTypeVariables+  ghc-options: -Wall -Wredundant-constraints -Wunused-packages   build-depends:-      aeson >=0.6.2.0+      aeson >=1.4.1.0 && <2.3     , attoparsec >=0.10-    , attoparsec-aeson >=2+    , attoparsec-aeson >=2.1.0.0 && <2.3     , base ==4.*     , base64-bytestring >=1.0     , bytestring >=0.9-    , call-stack-    , data-default+    , containers     , directory >1.0-    , directory-tree >=0.11     , exceptions >=0.4     , filepath >1.0     , http-client >=0.3     , http-types >=0.8-    , lifted-base >=0.1-    , monad-control >=0.3-    , network >=2.6+    , microlens-th >=0.4.0.0+    , monad-logger+    , network     , network-uri >=2.6+    , random+    , retry+    , safe-exceptions     , scientific >=0.2-    , temporary >=1.0+    , stm+    , string-interpolate     , text >=0.11.3     , time >1.0-    , transformers >=0.4-    , transformers-base >=0.1+    , unliftio+    , unliftio-core     , unordered-containers >=0.1.3-    , vector >=0.3+    , websockets >=0.13     , zip-archive >=0.1.1.8+  default-language: Haskell2010++test-suite tests+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Spec+      Spec.Actions+      Spec.CommandContexts+      Spec.Cookies+      Spec.DocumentHandling+      Spec.ElementInteraction+      Spec.ElementRetrieval+      Spec.ElementState+      Spec.Logs+      Spec.LogsBiDi+      Spec.Navigation+      Spec.ScreenCapture+      Spec.SeleniumSpecific.Mobile+      Spec.SeleniumSpecific.Uploads+      Spec.Sessions+      Spec.UserPrompts+      TestLib.Contexts.BrowserDependencies+      TestLib.Contexts.Selenium4+      TestLib.Contexts.Session+      TestLib.Contexts.StaticServer+      TestLib.Contexts.WebDriver+      TestLib.Mouse+      TestLib.Types+      TestLib.Types.Cli+      TestLib.Waits+      Paths_webdriver+  hs-source-dirs:+      tests+  default-extensions:+      FlexibleContexts+      FlexibleInstances+      LambdaCase+      NamedFieldPuns+      OverloadedStrings+      QuasiQuotes+      RecordWildCards+      ScopedTypeVariables+  ghc-options: -threaded -Wall -Wredundant-constraints -Wunused-packages+  build-tool-depends:+      sandwich:sandwich-discover+  build-depends:+      aeson+    , base+    , bytestring+    , containers+    , exceptions+    , filepath+    , http-client+    , http-types+    , microlens+    , monad-logger+    , mtl+    , network+    , network-uri+    , optparse-applicative+    , retry+    , safe-exceptions+    , sandwich+    , sandwich-contexts+    , string-interpolate+    , text+    , unliftio+    , unliftio-core+    , wai-app-static+    , warp+    , webdriver   default-language: Haskell2010