{-# LANGUAGE DeriveDataTypeable, RecordWildCards, Rank2Types, OverloadedStrings #-}
module Test.Tasty.WebDriver (
defaultWebDriverMain
, testCase
, testCaseM
, testCaseT
, testCaseTM
, testCaseWithSetup
, testCaseWithSetupM
, testCaseWithSetupT
, testCaseWithSetupTM
, ifDriverIs
, ifTierIs
, ifHeadless
, unlessDriverIs
, unlessTierIs
, unlessHeadless
, Driver(..)
, DriverName(..)
, DataPath(..)
, Deployment(..)
, DeploymentTier(..)
, BrowserPath(..)
, ApiResponseFormat(..)
, WebDriverApiVersion(..)
, LogHandle(..)
, TestDelay(..)
, NumRetries(..)
, LogNoiseLevel(..)
, ConsoleInHandle(..)
, ConsoleOutHandle(..)
, RemoteEndRef(..)
, Headless(..)
, LogColors(..)
, GeckodriverLog(..)
, PrivateMode(..)
, module Test.Tasty.WebDriver.Config
) where
import Control.Monad.Trans.Class
( MonadTrans(..) )
import Control.Monad.Trans.Identity
( IdentityT(..) )
import Data.Typeable
( Typeable, Proxy(Proxy) )
import System.IO
( Handle, stdout, stderr, stdin, openFile, IOMode(..), hClose )
import Control.Concurrent
( threadDelay )
import Control.Concurrent.MVar
( newMVar )
import Control.Concurrent.STM
import Control.Lens
((.~), (&))
import qualified Data.ByteString.Lazy.Char8 as BS
( pack )
import qualified Data.Digest.Pure.SHA as SHA
( showDigest, sha1 )
import Data.Maybe
( fromMaybe, catMaybes )
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Data.String
import Network.HTTP.Client
( defaultManagerSettings, managerResponseTimeout
, responseTimeoutNone )
import qualified Network.Wreq as Wreq
( defaults, manager )
import qualified System.Environment as SE
( getEnv, setEnv, getArgs, lookupEnv )
import System.Exit
( exitFailure )
import Text.Read
( readMaybe )
import qualified Data.Map.Strict as MS
import Data.Text (Text)
import qualified Test.Tasty as T
import qualified Test.Tasty.Providers as TT
import qualified Test.Tasty.Options as TO
import Web.Api.WebDriver
import Test.Tasty.WebDriver.Config
_OPT_LOG_HANDLE :: (IsString t) => t
_OPT_LOG_HANDLE :: t
_OPT_LOG_HANDLE = t
"wd-log"
_OPT_CONSOLE_OUT :: (IsString t) => t
_OPT_CONSOLE_OUT :: t
_OPT_CONSOLE_OUT = t
"wd-console-out"
_OPT_CONSOLE_IN :: (IsString t) => t
_OPT_CONSOLE_IN :: t
_OPT_CONSOLE_IN = t
"wd-console-in"
_OPT_COLOR :: (IsString t) => t
_OPT_COLOR :: t
_OPT_COLOR = t
"wd-color"
_OPT_HEADLESS :: (IsString t) => t
_OPT_HEADLESS :: t
_OPT_HEADLESS = t
"wd-headless"
_OPT_DRIVER :: (IsString t) => t
_OPT_DRIVER :: t
_OPT_DRIVER = t
"wd-driver"
_OPT_GECKODRIVER_LOG :: (IsString t) => t
_OPT_GECKODRIVER_LOG :: t
_OPT_GECKODRIVER_LOG = t
"wd-geckodriver-log"
_OPT_BROWSERPATH :: (IsString t) => t
_OPT_BROWSERPATH :: t
_OPT_BROWSERPATH = t
"wd-browserpath"
_OPT_DEPLOYMENT :: (IsString t) => t
_OPT_DEPLOYMENT :: t
_OPT_DEPLOYMENT = t
"wd-deploy"
_OPT_REMOTE_ENDS :: (IsString t) => t
_OPT_REMOTE_ENDS :: t
_OPT_REMOTE_ENDS = t
"wd-remote-ends"
_OPT_DATA_PATH :: (IsString t) => t
_OPT_DATA_PATH :: t
_OPT_DATA_PATH = t
"wd-data-path"
_OPT_RESPONSE_FORMAT :: (IsString t) => t
_OPT_RESPONSE_FORMAT :: t
_OPT_RESPONSE_FORMAT = t
"wd-response-format"
_OPT_API_VERSION :: (IsString t) => t
_OPT_API_VERSION :: t
_OPT_API_VERSION = t
"wd-api-version"
_OPT_VERBOSITY :: (IsString t) => t
_OPT_VERBOSITY :: t
_OPT_VERBOSITY = t
"wd-verbosity"
_OPT_NUM_RETRIES :: (IsString t) => t
_OPT_NUM_RETRIES :: t
_OPT_NUM_RETRIES = t
"wd-num-retries"
_OPT_DELAY :: (IsString t) => t
_OPT_DELAY :: t
_OPT_DELAY = t
"wd-delay"
_OPT_REMOTE_ENDS_CONFIG :: (IsString t) => t
_OPT_REMOTE_ENDS_CONFIG :: t
_OPT_REMOTE_ENDS_CONFIG = t
"wd-remote-ends-config"
_OPT_PRIVATE_MODE :: (IsString t) => t
_OPT_PRIVATE_MODE :: t
_OPT_PRIVATE_MODE = t
"wd-private-mode"
data WebDriverTest t eff = WebDriverTest
{ WebDriverTest t eff -> Text
wdTestName :: Text
, WebDriverTest t eff -> WebDriverTT t eff ()
wdTestSession :: WebDriverTT t eff ()
, WebDriverTest t eff -> forall a. P WDAct a -> eff a
wdEval :: forall a. P WDAct a -> eff a
, WebDriverTest t eff -> forall a. t eff a -> IO a
wdToIO :: forall a. t eff a -> IO a
}
instance
(Monad eff, Monad (t eff), MonadTrans t, Typeable eff, Typeable t)
=> TT.IsTest (WebDriverTest t eff) where
testOptions :: Tagged (WebDriverTest t eff) [OptionDescription]
testOptions = [OptionDescription]
-> Tagged (WebDriverTest t eff) [OptionDescription]
forall (m :: * -> *) a. Monad m => a -> m a
return
[ Proxy Driver -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
TO.Option (Proxy Driver
forall k (t :: k). Proxy t
Proxy :: Proxy Driver)
, Proxy Headless -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
TO.Option (Proxy Headless
forall k (t :: k). Proxy t
Proxy :: Proxy Headless)
, Proxy ApiResponseFormat -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
TO.Option (Proxy ApiResponseFormat
forall k (t :: k). Proxy t
Proxy :: Proxy ApiResponseFormat)
, Proxy WebDriverApiVersion -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
TO.Option (Proxy WebDriverApiVersion
forall k (t :: k). Proxy t
Proxy :: Proxy WebDriverApiVersion)
, Proxy LogHandle -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
TO.Option (Proxy LogHandle
forall k (t :: k). Proxy t
Proxy :: Proxy LogHandle)
, Proxy LogNoiseLevel -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
TO.Option (Proxy LogNoiseLevel
forall k (t :: k). Proxy t
Proxy :: Proxy LogNoiseLevel)
, Proxy ConsoleInHandle -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
TO.Option (Proxy ConsoleInHandle
forall k (t :: k). Proxy t
Proxy :: Proxy ConsoleInHandle)
, Proxy ConsoleOutHandle -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
TO.Option (Proxy ConsoleOutHandle
forall k (t :: k). Proxy t
Proxy :: Proxy ConsoleOutHandle)
, Proxy Deployment -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
TO.Option (Proxy Deployment
forall k (t :: k). Proxy t
Proxy :: Proxy Deployment)
, Proxy DataPath -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
TO.Option (Proxy DataPath
forall k (t :: k). Proxy t
Proxy :: Proxy DataPath)
, Proxy BrowserPath -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
TO.Option (Proxy BrowserPath
forall k (t :: k). Proxy t
Proxy :: Proxy BrowserPath)
, Proxy TestDelay -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
TO.Option (Proxy TestDelay
forall k (t :: k). Proxy t
Proxy :: Proxy TestDelay)
, Proxy RemoteEndRef -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
TO.Option (Proxy RemoteEndRef
forall k (t :: k). Proxy t
Proxy :: Proxy RemoteEndRef)
, Proxy RemoteEndOpt -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
TO.Option (Proxy RemoteEndOpt
forall k (t :: k). Proxy t
Proxy :: Proxy RemoteEndOpt)
, Proxy NumRetries -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
TO.Option (Proxy NumRetries
forall k (t :: k). Proxy t
Proxy :: Proxy NumRetries)
, Proxy LogColors -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
TO.Option (Proxy LogColors
forall k (t :: k). Proxy t
Proxy :: Proxy LogColors)
, Proxy GeckodriverLog -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
TO.Option (Proxy GeckodriverLog
forall k (t :: k). Proxy t
Proxy :: Proxy GeckodriverLog)
, Proxy PrivateMode -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
TO.Option (Proxy PrivateMode
forall k (t :: k). Proxy t
Proxy :: Proxy PrivateMode)
]
run :: OptionSet
-> WebDriverTest t eff -> (Progress -> IO ()) -> IO Result
run OptionSet
opts WebDriverTest{Text
WebDriverTT t eff ()
forall a. t eff a -> IO a
forall a. P WDAct a -> eff a
wdToIO :: forall a. t eff a -> IO a
wdEval :: forall a. P WDAct a -> eff a
wdTestSession :: WebDriverTT t eff ()
wdTestName :: Text
wdToIO :: forall (t :: (* -> *) -> * -> *) (eff :: * -> *).
WebDriverTest t eff -> forall a. t eff a -> IO a
wdEval :: forall (t :: (* -> *) -> * -> *) (eff :: * -> *).
WebDriverTest t eff -> forall a. P WDAct a -> eff a
wdTestSession :: forall (t :: (* -> *) -> * -> *) (eff :: * -> *).
WebDriverTest t eff -> WebDriverTT t eff ()
wdTestName :: forall (t :: (* -> *) -> * -> *) (eff :: * -> *).
WebDriverTest t eff -> Text
..} Progress -> IO ()
_ = do
let
Driver DriverName
driver = OptionSet -> Driver
forall v. IsOption v => OptionSet -> v
TO.lookupOption OptionSet
opts
Headless Bool
headless = OptionSet -> Headless
forall v. IsOption v => OptionSet -> v
TO.lookupOption OptionSet
opts
ApiResponseFormat ResponseFormat
format = OptionSet -> ApiResponseFormat
forall v. IsOption v => OptionSet -> v
TO.lookupOption OptionSet
opts
WebDriverApiVersion ApiVersion
version = OptionSet -> WebDriverApiVersion
forall v. IsOption v => OptionSet -> v
TO.lookupOption OptionSet
opts
LogHandle Handle
logHandle = OptionSet -> LogHandle
forall v. IsOption v => OptionSet -> v
TO.lookupOption OptionSet
opts
logNoiseLevel :: LogNoiseLevel
logNoiseLevel = OptionSet -> LogNoiseLevel
forall v. IsOption v => OptionSet -> v
TO.lookupOption OptionSet
opts
ConsoleInHandle Handle
cinHandle = OptionSet -> ConsoleInHandle
forall v. IsOption v => OptionSet -> v
TO.lookupOption OptionSet
opts
TestDelay Int
delay = OptionSet -> TestDelay
forall v. IsOption v => OptionSet -> v
TO.lookupOption OptionSet
opts
ConsoleOutHandle Handle
coutHandle = OptionSet -> ConsoleOutHandle
forall v. IsOption v => OptionSet -> v
TO.lookupOption OptionSet
opts
DataPath Maybe FilePath
datas = OptionSet -> DataPath
forall v. IsOption v => OptionSet -> v
TO.lookupOption OptionSet
opts
BrowserPath Maybe FilePath
browserPath = OptionSet -> BrowserPath
forall v. IsOption v => OptionSet -> v
TO.lookupOption OptionSet
opts
RemoteEndRef Maybe (TVar RemoteEndPool)
remotes = OptionSet -> RemoteEndRef
forall v. IsOption v => OptionSet -> v
TO.lookupOption OptionSet
opts
NumRetries Int
numRetries = OptionSet -> NumRetries
forall v. IsOption v => OptionSet -> v
TO.lookupOption OptionSet
opts
LogColors Bool
logColors = OptionSet -> LogColors
forall v. IsOption v => OptionSet -> v
TO.lookupOption OptionSet
opts
GeckodriverLog LogLevel
geckoLogLevel = OptionSet -> GeckodriverLog
forall v. IsOption v => OptionSet -> v
TO.lookupOption OptionSet
opts
PrivateMode Bool
privateMode = OptionSet -> PrivateMode
forall v. IsOption v => OptionSet -> v
TO.lookupOption OptionSet
opts
let
title :: WebDriverTT t eff ()
title = Text -> WebDriverTT t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
Text -> WebDriverTT t eff ()
comment Text
wdTestName
attemptLabel :: a -> WebDriverTT t eff ()
attemptLabel a
k = Text -> WebDriverTT t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
Text -> WebDriverTT t eff ()
comment (Text -> WebDriverTT t eff ()) -> Text -> WebDriverTT t eff ()
forall a b. (a -> b) -> a -> b
$ Text
"Attempt #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (a -> FilePath
forall a. Show a => a -> FilePath
show a
k)
logNoise :: Bool
logNoise = case LogNoiseLevel
logNoiseLevel of
LogNoiseLevel
NoisyLog -> Bool
False
LogNoiseLevel
SilentLog -> Bool
True
caps :: Capabilities
caps = case DriverName
driver of
DriverName
Geckodriver -> Capabilities
emptyCapabilities
{ _browserName :: Maybe BrowserName
_browserName = BrowserName -> Maybe BrowserName
forall a. a -> Maybe a
Just BrowserName
Firefox
, _firefoxOptions :: Maybe FirefoxOptions
_firefoxOptions = FirefoxOptions -> Maybe FirefoxOptions
forall a. a -> Maybe a
Just FirefoxOptions
defaultFirefoxOptions
{ _firefoxBinary :: Maybe FilePath
_firefoxBinary = Maybe FilePath
browserPath
, _firefoxArgs :: Maybe [Text]
_firefoxArgs = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ([Text] -> Maybe [Text]) -> [Text] -> Maybe [Text]
forall a b. (a -> b) -> a -> b
$ [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes
[ if Bool
headless then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"-headless" else Maybe Text
forall a. Maybe a
Nothing
, if Bool
privateMode then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"-private" else Maybe Text
forall a. Maybe a
Nothing
]
, _firefoxLog :: Maybe FirefoxLog
_firefoxLog = FirefoxLog -> Maybe FirefoxLog
forall a. a -> Maybe a
Just FirefoxLog :: Maybe LogLevel -> FirefoxLog
FirefoxLog
{ _firefoxLogLevel :: Maybe LogLevel
_firefoxLogLevel = LogLevel -> Maybe LogLevel
forall a. a -> Maybe a
Just LogLevel
geckoLogLevel
}
}
}
DriverName
Chromedriver -> Capabilities
emptyCapabilities
{ _browserName :: Maybe BrowserName
_browserName = BrowserName -> Maybe BrowserName
forall a. a -> Maybe a
Just BrowserName
Chrome
, _chromeOptions :: Maybe ChromeOptions
_chromeOptions = ChromeOptions -> Maybe ChromeOptions
forall a. a -> Maybe a
Just (ChromeOptions -> Maybe ChromeOptions)
-> ChromeOptions -> Maybe ChromeOptions
forall a b. (a -> b) -> a -> b
$ ChromeOptions
defaultChromeOptions
{ _chromeBinary :: Maybe FilePath
_chromeBinary = Maybe FilePath
browserPath
, _chromeArgs :: Maybe [Text]
_chromeArgs = [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ([Text] -> Maybe [Text]) -> [Text] -> Maybe [Text]
forall a b. (a -> b) -> a -> b
$ [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes
[ if Bool
headless then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"--headless" else Maybe Text
forall a. Maybe a
Nothing
, if Bool
privateMode then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"--incognito" else Maybe Text
forall a. Maybe a
Nothing
]
}
}
FilePath
dataPath <- case Maybe FilePath
datas of
Maybe FilePath
Nothing -> (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/.webdriver") (IO FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
SE.getEnv FilePath
"HOME"
Just FilePath
dpath -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
dpath
TVar RemoteEndPool
remotesRef <- case Maybe (TVar RemoteEndPool)
remotes of
Just TVar RemoteEndPool
ref -> TVar RemoteEndPool -> IO (TVar RemoteEndPool)
forall (m :: * -> *) a. Monad m => a -> m a
return TVar RemoteEndPool
ref
Maybe (TVar RemoteEndPool)
Nothing -> do
FilePath -> IO ()
putStrLn FilePath
"Error: no remote ends specified."
IO (TVar RemoteEndPool)
forall a. IO a
exitFailure
MVar ()
logLock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
let
attempt :: Int -> IO TT.Result
attempt :: Int -> IO Result
attempt Int
attemptNumber = do
RemoteEnd
remote <- TVar RemoteEndPool -> Int -> DriverName -> IO RemoteEnd
acquireRemoteEnd TVar RemoteEndPool
remotesRef Int
delay DriverName
driver
let
uid :: Text
uid = Text -> Text
forall a. Show a => a -> Text
digest Text
wdTestName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
attemptNumber) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack (RemoteEnd -> FilePath
forall a. Show a => a -> FilePath
show RemoteEnd
remote)
where
digest :: (Show a) => a -> Text
digest :: a -> Text
digest = FilePath -> Text
Text.pack (FilePath -> Text) -> (a -> FilePath) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take Int
8 (FilePath -> FilePath) -> (a -> FilePath) -> a -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest SHA1State -> FilePath
forall t. Digest t -> FilePath
SHA.showDigest (Digest SHA1State -> FilePath)
-> (a -> Digest SHA1State) -> a -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Digest SHA1State
SHA.sha1 (ByteString -> Digest SHA1State)
-> (a -> ByteString) -> a -> Digest SHA1State
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString
BS.pack (FilePath -> ByteString) -> (a -> FilePath) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FilePath
forall a. Show a => a -> FilePath
show
config :: WebDriverConfig eff
config = WDConfig :: forall (eff :: * -> *).
S WDState
-> R WDError WDLog WDEnv
-> (forall a. P WDAct a -> eff a)
-> WebDriverConfig eff
WDConfig
{ _evaluator :: forall a. P WDAct a -> eff a
_evaluator = forall a. P WDAct a -> eff a
wdEval
, _initialState :: S WDState
_initialState = S :: forall s. Options -> Maybe Session -> s -> S s
S
{ _httpOptions :: Options
_httpOptions = Options
Wreq.defaults
Options -> (Options -> Options) -> Options
forall a b. a -> (a -> b) -> b
& (Either ManagerSettings Manager
-> Identity (Either ManagerSettings Manager))
-> Options -> Identity Options
Lens' Options (Either ManagerSettings Manager)
Wreq.manager ((Either ManagerSettings Manager
-> Identity (Either ManagerSettings Manager))
-> Options -> Identity Options)
-> Either ManagerSettings Manager -> Options -> Options
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ManagerSettings -> Either ManagerSettings Manager
forall a b. a -> Either a b
Left (ManagerSettings
defaultManagerSettings
{ managerResponseTimeout :: ResponseTimeout
managerResponseTimeout = ResponseTimeout
responseTimeoutNone } )
, _httpSession :: Maybe Session
_httpSession = Maybe Session
forall a. Maybe a
Nothing
, _userState :: WDState
_userState = WDState :: Maybe Text -> BreakpointSetting -> WDState
WDState
{ _sessionId :: Maybe Text
_sessionId = Maybe Text
forall a. Maybe a
Nothing
, _breakpoints :: BreakpointSetting
_breakpoints = BreakpointSetting
BreakpointsOff
}
}
, _environment :: R WDError WDLog WDEnv
_environment = R WDError WDLog WDEnv
defaultWebDriverEnvironment
{ _logHandle :: Handle
_logHandle = Handle
logHandle
, _logLock :: Maybe (MVar ())
_logLock = MVar () -> Maybe (MVar ())
forall a. a -> Maybe a
Just MVar ()
logLock
, _uid :: Text
_uid = Text
uid
, _logOptions :: LogOptions WDError WDLog
_logOptions = LogOptions WDError WDLog
defaultWebDriverLogOptions
{ _logColor :: Bool
_logColor = Bool
logColors
, _logJson :: Bool
_logJson = Bool
True
, _logHeaders :: Bool
_logHeaders = Bool
False
, _logSilent :: Bool
_logSilent = Bool
logNoise
}
, _env :: WDEnv
_env = WDEnv :: Text
-> Int
-> Text
-> FilePath
-> ResponseFormat
-> ApiVersion
-> Handle
-> Handle
-> WDEnv
WDEnv
{ _remoteHostname :: Text
_remoteHostname = RemoteEnd -> Text
remoteEndHost RemoteEnd
remote
, _remotePort :: Int
_remotePort = RemoteEnd -> Int
remoteEndPort RemoteEnd
remote
, _remotePath :: Text
_remotePath = RemoteEnd -> Text
remoteEndPath RemoteEnd
remote
, _responseFormat :: ResponseFormat
_responseFormat = ResponseFormat
format
, _apiVersion :: ApiVersion
_apiVersion = ApiVersion
version
, _dataPath :: FilePath
_dataPath = FilePath
dataPath
, _stdout :: Handle
_stdout = Handle
coutHandle
, _stdin :: Handle
_stdin = Handle
cinHandle
}
}
}
(Either Text ()
result, AssertionSummary
summary) <- t eff (Either Text (), AssertionSummary)
-> IO (Either Text (), AssertionSummary)
forall a. t eff a -> IO a
wdToIO (t eff (Either Text (), AssertionSummary)
-> IO (Either Text (), AssertionSummary))
-> t eff (Either Text (), AssertionSummary)
-> IO (Either Text (), AssertionSummary)
forall a b. (a -> b) -> a -> b
$ WebDriverConfig eff
-> WebDriverTT t eff () -> t eff (Either Text (), AssertionSummary)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
WebDriverConfig eff
-> WebDriverTT t eff a -> t eff (Either Text a, AssertionSummary)
debugWebDriverTT WebDriverConfig eff
config (WebDriverTT t eff () -> t eff (Either Text (), AssertionSummary))
-> WebDriverTT t eff () -> t eff (Either Text (), AssertionSummary)
forall a b. (a -> b) -> a -> b
$
WebDriverTT t eff ()
title WebDriverTT t eff ()
-> WebDriverTT t eff () -> WebDriverTT t eff ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> WebDriverTT t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t, Show a) =>
a -> WebDriverTT t eff ()
attemptLabel Int
attemptNumber WebDriverTT t eff ()
-> WebDriverTT t eff () -> WebDriverTT t eff ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Capabilities -> WebDriverTT t eff () -> WebDriverTT t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
Capabilities -> WebDriverTT t eff a -> WebDriverTT t eff ()
runIsolated_ Capabilities
caps WebDriverTT t eff ()
wdTestSession
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar RemoteEndPool -> DriverName -> RemoteEnd -> STM ()
releaseRemoteEnd TVar RemoteEndPool
remotesRef DriverName
driver RemoteEnd
remote
case Either Text ()
result of
Right ()
_ ->
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ AssertionSummary -> Result
webDriverAssertionsToResult AssertionSummary
summary
Left Text
err -> if Int
attemptNumber Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
numRetries
then Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ FilePath -> Result
TT.testFailed (FilePath -> Result) -> FilePath -> Result
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
Text.unpack (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text
"Unhandled error!\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
else Int -> IO Result
attempt (Int
attemptNumber Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
Int -> IO Result
attempt Int
1
webDriverAssertionsToResult :: AssertionSummary -> TT.Result
webDriverAssertionsToResult :: AssertionSummary -> Result
webDriverAssertionsToResult AssertionSummary
x =
if AssertionSummary -> Integer
numFailures AssertionSummary
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0
then FilePath -> Result
TT.testFailed (FilePath -> Result) -> FilePath -> Result
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ (Assertion -> FilePath) -> [Assertion] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> FilePath
Text.unpack (Text -> FilePath) -> (Assertion -> Text) -> Assertion -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Assertion -> Text
printAssertion) ([Assertion] -> [FilePath]) -> [Assertion] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ AssertionSummary -> [Assertion]
failures AssertionSummary
x
else FilePath -> Result
TT.testPassed (FilePath -> Result) -> FilePath -> Result
forall a b. (a -> b) -> a -> b
$ Integer -> FilePath
forall a. Show a => a -> FilePath
show (AssertionSummary -> Integer
numSuccesses AssertionSummary
x) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" assertion(s)"
testCase
:: TT.TestName
-> WebDriverT IO ()
-> TT.TestTree
testCase :: FilePath -> WebDriverT IO () -> TestTree
testCase FilePath
name WebDriverT IO ()
test =
FilePath
-> WebDriverT IO ()
-> (() -> WebDriverT IO ())
-> (() -> WebDriverT IO ())
-> TestTree
forall u v.
FilePath
-> WebDriverT IO u
-> (v -> WebDriverT IO ())
-> (u -> WebDriverT IO v)
-> TestTree
testCaseWithSetup FilePath
name (() -> WebDriverT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) () -> WebDriverT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (WebDriverT IO () -> () -> WebDriverT IO ()
forall a b. a -> b -> a
const WebDriverT IO ()
test)
testCaseM
:: (Monad eff, Typeable eff)
=> TT.TestName
-> (forall a. P WDAct a -> eff a)
-> (forall a. eff a -> IO a)
-> WebDriverT eff ()
-> TT.TestTree
testCaseM :: FilePath
-> (forall a. P WDAct a -> eff a)
-> (forall a. eff a -> IO a)
-> WebDriverT eff ()
-> TestTree
testCaseM FilePath
name forall a. P WDAct a -> eff a
eval forall a. eff a -> IO a
toIO WebDriverT eff ()
test =
FilePath
-> (forall a. P WDAct a -> eff a)
-> (forall a. eff a -> IO a)
-> WebDriverT eff ()
-> (() -> WebDriverT eff ())
-> (() -> WebDriverT eff ())
-> TestTree
forall (eff :: * -> *) u v.
(Monad eff, Typeable eff) =>
FilePath
-> (forall a. P WDAct a -> eff a)
-> (forall a. eff a -> IO a)
-> WebDriverT eff u
-> (v -> WebDriverT eff ())
-> (u -> WebDriverT eff v)
-> TestTree
testCaseWithSetupM FilePath
name forall a. P WDAct a -> eff a
eval forall a. eff a -> IO a
toIO (() -> WebDriverT eff ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) () -> WebDriverT eff ()
forall (m :: * -> *) a. Monad m => a -> m a
return (WebDriverT eff () -> () -> WebDriverT eff ()
forall a b. a -> b -> a
const WebDriverT eff ()
test)
testCaseT
:: (Monad (t IO), MonadTrans t, Typeable t)
=> TT.TestName
-> (forall a. t IO a -> IO a)
-> WebDriverTT t IO ()
-> TT.TestTree
testCaseT :: FilePath
-> (forall a. t IO a -> IO a) -> WebDriverTT t IO () -> TestTree
testCaseT FilePath
name forall a. t IO a -> IO a
toIO WebDriverTT t IO ()
test =
FilePath
-> (forall a. t IO a -> IO a)
-> WebDriverTT t IO ()
-> (() -> WebDriverTT t IO ())
-> (() -> WebDriverTT t IO ())
-> TestTree
forall (t :: (* -> *) -> * -> *) u v.
(Monad (t IO), MonadTrans t, Typeable t) =>
FilePath
-> (forall a. t IO a -> IO a)
-> WebDriverTT t IO u
-> (v -> WebDriverTT t IO ())
-> (u -> WebDriverTT t IO v)
-> TestTree
testCaseWithSetupT FilePath
name forall a. t IO a -> IO a
toIO (() -> WebDriverTT t IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) () -> WebDriverTT t IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (WebDriverTT t IO () -> () -> WebDriverTT t IO ()
forall a b. a -> b -> a
const WebDriverTT t IO ()
test)
testCaseTM
:: (Monad eff, Monad (t eff), MonadTrans t, Typeable eff, Typeable t)
=> TT.TestName
-> (forall a. P WDAct a -> eff a)
-> (forall a. t eff a -> IO a)
-> WebDriverTT t eff ()
-> TT.TestTree
testCaseTM :: FilePath
-> (forall a. P WDAct a -> eff a)
-> (forall a. t eff a -> IO a)
-> WebDriverTT t eff ()
-> TestTree
testCaseTM FilePath
name forall a. P WDAct a -> eff a
eval forall a. t eff a -> IO a
toIO WebDriverTT t eff ()
test =
FilePath
-> (forall a. P WDAct a -> eff a)
-> (forall a. t eff a -> IO a)
-> WebDriverTT t eff ()
-> (() -> WebDriverTT t eff ())
-> (() -> WebDriverTT t eff ())
-> TestTree
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) u v.
(Monad eff, Monad (t eff), MonadTrans t, Typeable eff,
Typeable t) =>
FilePath
-> (forall a. P WDAct a -> eff a)
-> (forall a. t eff a -> IO a)
-> WebDriverTT t eff u
-> (v -> WebDriverTT t eff ())
-> (u -> WebDriverTT t eff v)
-> TestTree
testCaseWithSetupTM FilePath
name forall a. P WDAct a -> eff a
eval forall a. t eff a -> IO a
toIO (() -> WebDriverTT t eff ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) () -> WebDriverTT t eff ()
forall (m :: * -> *) a. Monad m => a -> m a
return (WebDriverTT t eff () -> () -> WebDriverTT t eff ()
forall a b. a -> b -> a
const WebDriverTT t eff ()
test)
testCaseWithSetup
:: TT.TestName
-> WebDriverT IO u
-> (v -> WebDriverT IO ())
-> (u -> WebDriverT IO v)
-> TT.TestTree
testCaseWithSetup :: FilePath
-> WebDriverT IO u
-> (v -> WebDriverT IO ())
-> (u -> WebDriverT IO v)
-> TestTree
testCaseWithSetup FilePath
name =
FilePath
-> (forall a. P WDAct a -> IO a)
-> (forall a. IO a -> IO a)
-> WebDriverT IO u
-> (v -> WebDriverT IO ())
-> (u -> WebDriverT IO v)
-> TestTree
forall (eff :: * -> *) u v.
(Monad eff, Typeable eff) =>
FilePath
-> (forall a. P WDAct a -> eff a)
-> (forall a. eff a -> IO a)
-> WebDriverT eff u
-> (v -> WebDriverT eff ())
-> (u -> WebDriverT eff v)
-> TestTree
testCaseWithSetupM FilePath
name ((WDAct a -> IO a) -> P WDAct a -> IO a
forall (p :: * -> *) a. (p a -> IO a) -> P p a -> IO a
evalIO WDAct a -> IO a
forall a. WDAct a -> IO a
evalWDAct) forall a. a -> a
forall a. IO a -> IO a
id
testCaseWithSetupM
:: (Monad eff, Typeable eff)
=> TT.TestName
-> (forall a. P WDAct a -> eff a)
-> (forall a. eff a -> IO a)
-> WebDriverT eff u
-> (v -> WebDriverT eff ())
-> (u -> WebDriverT eff v)
-> TT.TestTree
testCaseWithSetupM :: FilePath
-> (forall a. P WDAct a -> eff a)
-> (forall a. eff a -> IO a)
-> WebDriverT eff u
-> (v -> WebDriverT eff ())
-> (u -> WebDriverT eff v)
-> TestTree
testCaseWithSetupM FilePath
name forall a. P WDAct a -> eff a
eval forall a. eff a -> IO a
toIO =
FilePath
-> (forall a. P WDAct a -> eff a)
-> (forall a. IdentityT eff a -> IO a)
-> WebDriverT eff u
-> (v -> WebDriverT eff ())
-> (u -> WebDriverT eff v)
-> TestTree
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) u v.
(Monad eff, Monad (t eff), MonadTrans t, Typeable eff,
Typeable t) =>
FilePath
-> (forall a. P WDAct a -> eff a)
-> (forall a. t eff a -> IO a)
-> WebDriverTT t eff u
-> (v -> WebDriverTT t eff ())
-> (u -> WebDriverTT t eff v)
-> TestTree
testCaseWithSetupTM FilePath
name forall a. P WDAct a -> eff a
eval (eff a -> IO a
forall a. eff a -> IO a
toIO (eff a -> IO a)
-> (IdentityT eff a -> eff a) -> IdentityT eff a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdentityT eff a -> eff a
forall k (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT)
testCaseWithSetupT
:: (Monad (t IO), MonadTrans t, Typeable t)
=> TT.TestName
-> (forall a. t IO a -> IO a)
-> WebDriverTT t IO u
-> (v -> WebDriverTT t IO ())
-> (u -> WebDriverTT t IO v)
-> TT.TestTree
testCaseWithSetupT :: FilePath
-> (forall a. t IO a -> IO a)
-> WebDriverTT t IO u
-> (v -> WebDriverTT t IO ())
-> (u -> WebDriverTT t IO v)
-> TestTree
testCaseWithSetupT FilePath
name =
FilePath
-> (forall a. P WDAct a -> IO a)
-> (forall a. t IO a -> IO a)
-> WebDriverTT t IO u
-> (v -> WebDriverTT t IO ())
-> (u -> WebDriverTT t IO v)
-> TestTree
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) u v.
(Monad eff, Monad (t eff), MonadTrans t, Typeable eff,
Typeable t) =>
FilePath
-> (forall a. P WDAct a -> eff a)
-> (forall a. t eff a -> IO a)
-> WebDriverTT t eff u
-> (v -> WebDriverTT t eff ())
-> (u -> WebDriverTT t eff v)
-> TestTree
testCaseWithSetupTM FilePath
name ((WDAct a -> IO a) -> P WDAct a -> IO a
forall (p :: * -> *) a. (p a -> IO a) -> P p a -> IO a
evalIO WDAct a -> IO a
forall a. WDAct a -> IO a
evalWDAct)
testCaseWithSetupTM
:: (Monad eff, Monad (t eff), MonadTrans t, Typeable eff, Typeable t)
=> TT.TestName
-> (forall a. P WDAct a -> eff a)
-> (forall a. t eff a -> IO a)
-> WebDriverTT t eff u
-> (v -> WebDriverTT t eff ())
-> (u -> WebDriverTT t eff v)
-> TT.TestTree
testCaseWithSetupTM :: FilePath
-> (forall a. P WDAct a -> eff a)
-> (forall a. t eff a -> IO a)
-> WebDriverTT t eff u
-> (v -> WebDriverTT t eff ())
-> (u -> WebDriverTT t eff v)
-> TestTree
testCaseWithSetupTM FilePath
name forall a. P WDAct a -> eff a
eval forall a. t eff a -> IO a
toIO WebDriverTT t eff u
setup v -> WebDriverTT t eff ()
teardown u -> WebDriverTT t eff v
test =
FilePath -> WebDriverTest t eff -> TestTree
forall t. IsTest t => FilePath -> t -> TestTree
TT.singleTest FilePath
name WebDriverTest :: forall (t :: (* -> *) -> * -> *) (eff :: * -> *).
Text
-> WebDriverTT t eff ()
-> (forall a. P WDAct a -> eff a)
-> (forall a. t eff a -> IO a)
-> WebDriverTest t eff
WebDriverTest
{ wdTestName :: Text
wdTestName = FilePath -> Text
Text.pack FilePath
name
, wdTestSession :: WebDriverTT t eff ()
wdTestSession = WebDriverTT t eff u
setup WebDriverTT t eff u
-> (u -> WebDriverTT t eff v) -> WebDriverTT t eff v
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= u -> WebDriverTT t eff v
test WebDriverTT t eff v
-> (v -> WebDriverTT t eff ()) -> WebDriverTT t eff ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= v -> WebDriverTT t eff ()
teardown
, wdEval :: forall a. P WDAct a -> eff a
wdEval = forall a. P WDAct a -> eff a
eval
, wdToIO :: forall a. t eff a -> IO a
wdToIO = forall a. t eff a -> IO a
toIO
}
newtype Driver
= Driver { Driver -> DriverName
theDriver :: DriverName }
deriving Typeable
instance TO.IsOption Driver where
defaultValue :: Driver
defaultValue = DriverName -> Driver
Driver DriverName
Geckodriver
parseValue :: FilePath -> Maybe Driver
parseValue FilePath
str = case FilePath
str of
FilePath
"geckodriver" -> Driver -> Maybe Driver
forall a. a -> Maybe a
Just (Driver -> Maybe Driver) -> Driver -> Maybe Driver
forall a b. (a -> b) -> a -> b
$ DriverName -> Driver
Driver DriverName
Geckodriver
FilePath
"chromedriver" -> Driver -> Maybe Driver
forall a. a -> Maybe a
Just (Driver -> Maybe Driver) -> Driver -> Maybe Driver
forall a b. (a -> b) -> a -> b
$ DriverName -> Driver
Driver DriverName
Chromedriver
FilePath
_ -> Maybe Driver
forall a. Maybe a
Nothing
optionName :: Tagged Driver FilePath
optionName = FilePath -> Tagged Driver FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
forall t. IsString t => t
_OPT_DRIVER
optionHelp :: Tagged Driver FilePath
optionHelp = FilePath -> Tagged Driver FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"remote end name: (geckodriver), chromedriver"
newtype LogColors
= LogColors { LogColors -> Bool
theLogColors :: Bool }
deriving Typeable
instance TO.IsOption LogColors where
defaultValue :: LogColors
defaultValue = Bool -> LogColors
LogColors Bool
True
parseValue :: FilePath -> Maybe LogColors
parseValue = (Bool -> LogColors) -> Maybe Bool -> Maybe LogColors
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> LogColors
LogColors (Maybe Bool -> Maybe LogColors)
-> (FilePath -> Maybe Bool) -> FilePath -> Maybe LogColors
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe Bool
TO.safeReadBool
optionName :: Tagged LogColors FilePath
optionName = FilePath -> Tagged LogColors FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
forall t. IsString t => t
_OPT_COLOR
optionHelp :: Tagged LogColors FilePath
optionHelp = FilePath -> Tagged LogColors FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"colored logs: (true), false"
newtype Headless
= Headless { Headless -> Bool
theHeadless :: Bool }
deriving Typeable
instance TO.IsOption Headless where
defaultValue :: Headless
defaultValue = Bool -> Headless
Headless Bool
False
parseValue :: FilePath -> Maybe Headless
parseValue = (Bool -> Headless) -> Maybe Bool -> Maybe Headless
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Headless
Headless (Maybe Bool -> Maybe Headless)
-> (FilePath -> Maybe Bool) -> FilePath -> Maybe Headless
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe Bool
TO.safeReadBool
optionName :: Tagged Headless FilePath
optionName = FilePath -> Tagged Headless FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
forall t. IsString t => t
_OPT_HEADLESS
optionHelp :: Tagged Headless FilePath
optionHelp = FilePath -> Tagged Headless FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"run in headless mode: (false), true"
newtype PrivateMode
= PrivateMode { PrivateMode -> Bool
thePrivateMode :: Bool }
deriving Typeable
instance TO.IsOption PrivateMode where
defaultValue :: PrivateMode
defaultValue = Bool -> PrivateMode
PrivateMode Bool
False
parseValue :: FilePath -> Maybe PrivateMode
parseValue = (Bool -> PrivateMode) -> Maybe Bool -> Maybe PrivateMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> PrivateMode
PrivateMode (Maybe Bool -> Maybe PrivateMode)
-> (FilePath -> Maybe Bool) -> FilePath -> Maybe PrivateMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe Bool
TO.safeReadBool
optionName :: Tagged PrivateMode FilePath
optionName = FilePath -> Tagged PrivateMode FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
forall t. IsString t => t
_OPT_PRIVATE_MODE
optionHelp :: Tagged PrivateMode FilePath
optionHelp = FilePath -> Tagged PrivateMode FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"run in private mode: (false), true"
newtype DataPath
= DataPath { DataPath -> Maybe FilePath
theDataPath :: Maybe FilePath }
deriving Typeable
instance TO.IsOption DataPath where
defaultValue :: DataPath
defaultValue = Maybe FilePath -> DataPath
DataPath Maybe FilePath
forall a. Maybe a
Nothing
parseValue :: FilePath -> Maybe DataPath
parseValue FilePath
path = DataPath -> Maybe DataPath
forall a. a -> Maybe a
Just (DataPath -> Maybe DataPath) -> DataPath -> Maybe DataPath
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> DataPath
DataPath (Maybe FilePath -> DataPath) -> Maybe FilePath -> DataPath
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
path
optionName :: Tagged DataPath FilePath
optionName = FilePath -> Tagged DataPath FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
forall t. IsString t => t
_OPT_DATA_PATH
optionHelp :: Tagged DataPath FilePath
optionHelp = FilePath -> Tagged DataPath FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"data path: (~/.webdriver), PATH"
newtype GeckodriverLog
= GeckodriverLog { GeckodriverLog -> LogLevel
theGeckodriverLog :: LogLevel }
deriving Typeable
instance TO.IsOption GeckodriverLog where
defaultValue :: GeckodriverLog
defaultValue = LogLevel -> GeckodriverLog
GeckodriverLog LogLevel
LogInfo
parseValue :: FilePath -> Maybe GeckodriverLog
parseValue FilePath
level = case FilePath
level of
FilePath
"trace" -> GeckodriverLog -> Maybe GeckodriverLog
forall a. a -> Maybe a
Just (GeckodriverLog -> Maybe GeckodriverLog)
-> GeckodriverLog -> Maybe GeckodriverLog
forall a b. (a -> b) -> a -> b
$ LogLevel -> GeckodriverLog
GeckodriverLog LogLevel
LogTrace
FilePath
"debug" -> GeckodriverLog -> Maybe GeckodriverLog
forall a. a -> Maybe a
Just (GeckodriverLog -> Maybe GeckodriverLog)
-> GeckodriverLog -> Maybe GeckodriverLog
forall a b. (a -> b) -> a -> b
$ LogLevel -> GeckodriverLog
GeckodriverLog LogLevel
LogDebug
FilePath
"config" -> GeckodriverLog -> Maybe GeckodriverLog
forall a. a -> Maybe a
Just (GeckodriverLog -> Maybe GeckodriverLog)
-> GeckodriverLog -> Maybe GeckodriverLog
forall a b. (a -> b) -> a -> b
$ LogLevel -> GeckodriverLog
GeckodriverLog LogLevel
LogConfig
FilePath
"info" -> GeckodriverLog -> Maybe GeckodriverLog
forall a. a -> Maybe a
Just (GeckodriverLog -> Maybe GeckodriverLog)
-> GeckodriverLog -> Maybe GeckodriverLog
forall a b. (a -> b) -> a -> b
$ LogLevel -> GeckodriverLog
GeckodriverLog LogLevel
LogInfo
FilePath
"warn" -> GeckodriverLog -> Maybe GeckodriverLog
forall a. a -> Maybe a
Just (GeckodriverLog -> Maybe GeckodriverLog)
-> GeckodriverLog -> Maybe GeckodriverLog
forall a b. (a -> b) -> a -> b
$ LogLevel -> GeckodriverLog
GeckodriverLog LogLevel
LogWarn
FilePath
"error" -> GeckodriverLog -> Maybe GeckodriverLog
forall a. a -> Maybe a
Just (GeckodriverLog -> Maybe GeckodriverLog)
-> GeckodriverLog -> Maybe GeckodriverLog
forall a b. (a -> b) -> a -> b
$ LogLevel -> GeckodriverLog
GeckodriverLog LogLevel
LogError
FilePath
"fatal" -> GeckodriverLog -> Maybe GeckodriverLog
forall a. a -> Maybe a
Just (GeckodriverLog -> Maybe GeckodriverLog)
-> GeckodriverLog -> Maybe GeckodriverLog
forall a b. (a -> b) -> a -> b
$ LogLevel -> GeckodriverLog
GeckodriverLog LogLevel
LogFatal
FilePath
_ -> Maybe GeckodriverLog
forall a. Maybe a
Nothing
optionName :: Tagged GeckodriverLog FilePath
optionName = FilePath -> Tagged GeckodriverLog FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
forall t. IsString t => t
_OPT_GECKODRIVER_LOG
optionHelp :: Tagged GeckodriverLog FilePath
optionHelp = FilePath -> Tagged GeckodriverLog FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"log level passed to geckodriver: trace, debug, config, info, warn, error, fatal"
newtype BrowserPath
= BrowserPath { BrowserPath -> Maybe FilePath
theBrowserPath :: Maybe FilePath }
deriving Typeable
instance TO.IsOption BrowserPath where
defaultValue :: BrowserPath
defaultValue = Maybe FilePath -> BrowserPath
BrowserPath Maybe FilePath
forall a. Maybe a
Nothing
parseValue :: FilePath -> Maybe BrowserPath
parseValue FilePath
path = BrowserPath -> Maybe BrowserPath
forall a. a -> Maybe a
Just (BrowserPath -> Maybe BrowserPath)
-> BrowserPath -> Maybe BrowserPath
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> BrowserPath
BrowserPath (Maybe FilePath -> BrowserPath) -> Maybe FilePath -> BrowserPath
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
path
optionName :: Tagged BrowserPath FilePath
optionName = FilePath -> Tagged BrowserPath FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
forall t. IsString t => t
_OPT_BROWSERPATH
optionHelp :: Tagged BrowserPath FilePath
optionHelp = FilePath -> Tagged BrowserPath FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"path to browser binary: (), PATH"
newtype ApiResponseFormat
= ApiResponseFormat { ApiResponseFormat -> ResponseFormat
theApiResponseFormat :: ResponseFormat }
deriving Typeable
instance TO.IsOption ApiResponseFormat where
defaultValue :: ApiResponseFormat
defaultValue = ResponseFormat -> ApiResponseFormat
ApiResponseFormat ResponseFormat
SpecFormat
parseValue :: FilePath -> Maybe ApiResponseFormat
parseValue FilePath
str = case FilePath
str of
FilePath
"spec" -> ApiResponseFormat -> Maybe ApiResponseFormat
forall a. a -> Maybe a
Just (ApiResponseFormat -> Maybe ApiResponseFormat)
-> ApiResponseFormat -> Maybe ApiResponseFormat
forall a b. (a -> b) -> a -> b
$ ResponseFormat -> ApiResponseFormat
ApiResponseFormat ResponseFormat
SpecFormat
FilePath
"chromedriver" -> ApiResponseFormat -> Maybe ApiResponseFormat
forall a. a -> Maybe a
Just (ApiResponseFormat -> Maybe ApiResponseFormat)
-> ApiResponseFormat -> Maybe ApiResponseFormat
forall a b. (a -> b) -> a -> b
$ ResponseFormat -> ApiResponseFormat
ApiResponseFormat ResponseFormat
ChromeFormat
FilePath
_ -> Maybe ApiResponseFormat
forall a. Maybe a
Nothing
optionName :: Tagged ApiResponseFormat FilePath
optionName = FilePath -> Tagged ApiResponseFormat FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
forall t. IsString t => t
_OPT_RESPONSE_FORMAT
optionHelp :: Tagged ApiResponseFormat FilePath
optionHelp = FilePath -> Tagged ApiResponseFormat FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"JSON response format: (spec), chromedriver"
newtype WebDriverApiVersion
= WebDriverApiVersion { WebDriverApiVersion -> ApiVersion
theWebDriverApiVersion :: ApiVersion }
deriving Typeable
instance TO.IsOption WebDriverApiVersion where
defaultValue :: WebDriverApiVersion
defaultValue = ApiVersion -> WebDriverApiVersion
WebDriverApiVersion ApiVersion
CR_2018_03_04
parseValue :: FilePath -> Maybe WebDriverApiVersion
parseValue FilePath
str = case FilePath
str of
FilePath
"cr-2018-03-04" -> WebDriverApiVersion -> Maybe WebDriverApiVersion
forall a. a -> Maybe a
Just (WebDriverApiVersion -> Maybe WebDriverApiVersion)
-> WebDriverApiVersion -> Maybe WebDriverApiVersion
forall a b. (a -> b) -> a -> b
$ ApiVersion -> WebDriverApiVersion
WebDriverApiVersion ApiVersion
CR_2018_03_04
FilePath
_ -> Maybe WebDriverApiVersion
forall a. Maybe a
Nothing
optionName :: Tagged WebDriverApiVersion FilePath
optionName = FilePath -> Tagged WebDriverApiVersion FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
forall t. IsString t => t
_OPT_API_VERSION
optionHelp :: Tagged WebDriverApiVersion FilePath
optionHelp = FilePath -> Tagged WebDriverApiVersion FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"WebDriverT API version: (cr-2018-03-04)"
newtype LogHandle
= LogHandle { LogHandle -> Handle
theLogHandle :: Handle }
deriving Typeable
instance TO.IsOption LogHandle where
defaultValue :: LogHandle
defaultValue = Handle -> LogHandle
LogHandle Handle
stderr
parseValue :: FilePath -> Maybe LogHandle
parseValue FilePath
_ = LogHandle -> Maybe LogHandle
forall a. a -> Maybe a
Just (LogHandle -> Maybe LogHandle) -> LogHandle -> Maybe LogHandle
forall a b. (a -> b) -> a -> b
$ Handle -> LogHandle
LogHandle Handle
stderr
optionName :: Tagged LogHandle FilePath
optionName = FilePath -> Tagged LogHandle FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
forall t. IsString t => t
_OPT_LOG_HANDLE
optionHelp :: Tagged LogHandle FilePath
optionHelp = FilePath -> Tagged LogHandle FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"log destination: (stderr), stdout, PATH"
data LogNoiseLevel
= NoisyLog
| SilentLog
deriving Typeable
instance TO.IsOption LogNoiseLevel where
defaultValue :: LogNoiseLevel
defaultValue = LogNoiseLevel
NoisyLog
parseValue :: FilePath -> Maybe LogNoiseLevel
parseValue FilePath
str = case FilePath
str of
FilePath
"noisy" -> LogNoiseLevel -> Maybe LogNoiseLevel
forall a. a -> Maybe a
Just LogNoiseLevel
NoisyLog
FilePath
"silent" -> LogNoiseLevel -> Maybe LogNoiseLevel
forall a. a -> Maybe a
Just LogNoiseLevel
SilentLog
FilePath
_ -> Maybe LogNoiseLevel
forall a. Maybe a
Nothing
optionName :: Tagged LogNoiseLevel FilePath
optionName = FilePath -> Tagged LogNoiseLevel FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
forall t. IsString t => t
_OPT_VERBOSITY
optionHelp :: Tagged LogNoiseLevel FilePath
optionHelp = FilePath -> Tagged LogNoiseLevel FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"log verbosity: (noisy), silent"
newtype NumRetries
= NumRetries { NumRetries -> Int
theNumRetries :: Int }
deriving Typeable
instance TO.IsOption NumRetries where
defaultValue :: NumRetries
defaultValue = Int -> NumRetries
NumRetries Int
1
parseValue :: FilePath -> Maybe NumRetries
parseValue = (Int -> NumRetries) -> Maybe Int -> Maybe NumRetries
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> NumRetries
NumRetries (Maybe Int -> Maybe NumRetries)
-> (FilePath -> Maybe Int) -> FilePath -> Maybe NumRetries
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe Int
forall a. Read a => FilePath -> Maybe a
readMaybe
optionName :: Tagged NumRetries FilePath
optionName = FilePath -> Tagged NumRetries FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
forall t. IsString t => t
_OPT_NUM_RETRIES
optionHelp :: Tagged NumRetries FilePath
optionHelp = FilePath -> Tagged NumRetries FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"number of times to retry a failed test"
newtype ConsoleInHandle
= ConsoleInHandle { ConsoleInHandle -> Handle
theConsoleInHandle :: Handle }
deriving Typeable
instance TO.IsOption ConsoleInHandle where
defaultValue :: ConsoleInHandle
defaultValue = Handle -> ConsoleInHandle
ConsoleInHandle Handle
stdin
parseValue :: FilePath -> Maybe ConsoleInHandle
parseValue FilePath
_ = ConsoleInHandle -> Maybe ConsoleInHandle
forall a. a -> Maybe a
Just (ConsoleInHandle -> Maybe ConsoleInHandle)
-> ConsoleInHandle -> Maybe ConsoleInHandle
forall a b. (a -> b) -> a -> b
$ Handle -> ConsoleInHandle
ConsoleInHandle Handle
stdin
optionName :: Tagged ConsoleInHandle FilePath
optionName = FilePath -> Tagged ConsoleInHandle FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
forall t. IsString t => t
_OPT_CONSOLE_IN
optionHelp :: Tagged ConsoleInHandle FilePath
optionHelp = FilePath -> Tagged ConsoleInHandle FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"console input: (stdin), PATH"
newtype ConsoleOutHandle
= ConsoleOutHandle { ConsoleOutHandle -> Handle
theConsoleOutHandle :: Handle }
deriving Typeable
instance TO.IsOption ConsoleOutHandle where
defaultValue :: ConsoleOutHandle
defaultValue = Handle -> ConsoleOutHandle
ConsoleOutHandle Handle
stdout
parseValue :: FilePath -> Maybe ConsoleOutHandle
parseValue FilePath
_ = ConsoleOutHandle -> Maybe ConsoleOutHandle
forall a. a -> Maybe a
Just (ConsoleOutHandle -> Maybe ConsoleOutHandle)
-> ConsoleOutHandle -> Maybe ConsoleOutHandle
forall a b. (a -> b) -> a -> b
$ Handle -> ConsoleOutHandle
ConsoleOutHandle Handle
stdout
optionName :: Tagged ConsoleOutHandle FilePath
optionName = FilePath -> Tagged ConsoleOutHandle FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
forall t. IsString t => t
_OPT_CONSOLE_OUT
optionHelp :: Tagged ConsoleOutHandle FilePath
optionHelp = FilePath -> Tagged ConsoleOutHandle FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"console output: (stdout), stderr, PATH"
newtype TestDelay = TestDelay
{ TestDelay -> Int
theTestDelay :: Int
} deriving (TestDelay -> TestDelay -> Bool
(TestDelay -> TestDelay -> Bool)
-> (TestDelay -> TestDelay -> Bool) -> Eq TestDelay
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TestDelay -> TestDelay -> Bool
$c/= :: TestDelay -> TestDelay -> Bool
== :: TestDelay -> TestDelay -> Bool
$c== :: TestDelay -> TestDelay -> Bool
Eq, Int -> TestDelay -> FilePath -> FilePath
[TestDelay] -> FilePath -> FilePath
TestDelay -> FilePath
(Int -> TestDelay -> FilePath -> FilePath)
-> (TestDelay -> FilePath)
-> ([TestDelay] -> FilePath -> FilePath)
-> Show TestDelay
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [TestDelay] -> FilePath -> FilePath
$cshowList :: [TestDelay] -> FilePath -> FilePath
show :: TestDelay -> FilePath
$cshow :: TestDelay -> FilePath
showsPrec :: Int -> TestDelay -> FilePath -> FilePath
$cshowsPrec :: Int -> TestDelay -> FilePath -> FilePath
Show, Typeable)
instance TO.IsOption TestDelay where
defaultValue :: TestDelay
defaultValue = Int -> TestDelay
TestDelay Int
800000
parseValue :: FilePath -> Maybe TestDelay
parseValue = (Int -> TestDelay) -> Maybe Int -> Maybe TestDelay
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> TestDelay
TestDelay (Maybe Int -> Maybe TestDelay)
-> (FilePath -> Maybe Int) -> FilePath -> Maybe TestDelay
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe Int
forall a. Read a => FilePath -> Maybe a
readMaybe
optionName :: Tagged TestDelay FilePath
optionName = FilePath -> Tagged TestDelay FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
forall t. IsString t => t
_OPT_DELAY
optionHelp :: Tagged TestDelay FilePath
optionHelp = FilePath -> Tagged TestDelay FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"delay between test attempts in ms: (500000), INT"
newtype Deployment
= Deployment { Deployment -> DeploymentTier
theDeployment :: DeploymentTier }
deriving (Deployment -> Deployment -> Bool
(Deployment -> Deployment -> Bool)
-> (Deployment -> Deployment -> Bool) -> Eq Deployment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Deployment -> Deployment -> Bool
$c/= :: Deployment -> Deployment -> Bool
== :: Deployment -> Deployment -> Bool
$c== :: Deployment -> Deployment -> Bool
Eq, Typeable)
data DeploymentTier
= DEV
| TEST
| PROD
deriving (DeploymentTier -> DeploymentTier -> Bool
(DeploymentTier -> DeploymentTier -> Bool)
-> (DeploymentTier -> DeploymentTier -> Bool) -> Eq DeploymentTier
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DeploymentTier -> DeploymentTier -> Bool
$c/= :: DeploymentTier -> DeploymentTier -> Bool
== :: DeploymentTier -> DeploymentTier -> Bool
$c== :: DeploymentTier -> DeploymentTier -> Bool
Eq, Int -> DeploymentTier -> FilePath -> FilePath
[DeploymentTier] -> FilePath -> FilePath
DeploymentTier -> FilePath
(Int -> DeploymentTier -> FilePath -> FilePath)
-> (DeploymentTier -> FilePath)
-> ([DeploymentTier] -> FilePath -> FilePath)
-> Show DeploymentTier
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [DeploymentTier] -> FilePath -> FilePath
$cshowList :: [DeploymentTier] -> FilePath -> FilePath
show :: DeploymentTier -> FilePath
$cshow :: DeploymentTier -> FilePath
showsPrec :: Int -> DeploymentTier -> FilePath -> FilePath
$cshowsPrec :: Int -> DeploymentTier -> FilePath -> FilePath
Show, Typeable)
instance TO.IsOption Deployment where
defaultValue :: Deployment
defaultValue = DeploymentTier -> Deployment
Deployment DeploymentTier
DEV
parseValue :: FilePath -> Maybe Deployment
parseValue FilePath
str = case FilePath
str of
FilePath
"dev" -> Deployment -> Maybe Deployment
forall a. a -> Maybe a
Just (Deployment -> Maybe Deployment) -> Deployment -> Maybe Deployment
forall a b. (a -> b) -> a -> b
$ DeploymentTier -> Deployment
Deployment DeploymentTier
DEV
FilePath
"test" -> Deployment -> Maybe Deployment
forall a. a -> Maybe a
Just (Deployment -> Maybe Deployment) -> Deployment -> Maybe Deployment
forall a b. (a -> b) -> a -> b
$ DeploymentTier -> Deployment
Deployment DeploymentTier
TEST
FilePath
"prod" -> Deployment -> Maybe Deployment
forall a. a -> Maybe a
Just (Deployment -> Maybe Deployment) -> Deployment -> Maybe Deployment
forall a b. (a -> b) -> a -> b
$ DeploymentTier -> Deployment
Deployment DeploymentTier
PROD
FilePath
_ -> Maybe Deployment
forall a. Maybe a
Nothing
optionName :: Tagged Deployment FilePath
optionName = FilePath -> Tagged Deployment FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
forall t. IsString t => t
_OPT_DEPLOYMENT
optionHelp :: Tagged Deployment FilePath
optionHelp = FilePath -> Tagged Deployment FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"deployment environment: (dev), test, prod"
newtype RemoteEndRef = RemoteEndRef
{ RemoteEndRef -> Maybe (TVar RemoteEndPool)
theRemoteEndRef :: Maybe (TVar RemoteEndPool)
} deriving (Typeable)
instance TO.IsOption RemoteEndRef where
defaultValue :: RemoteEndRef
defaultValue = Maybe (TVar RemoteEndPool) -> RemoteEndRef
RemoteEndRef Maybe (TVar RemoteEndPool)
forall a. Maybe a
Nothing
parseValue :: FilePath -> Maybe RemoteEndRef
parseValue FilePath
_ = RemoteEndRef -> Maybe RemoteEndRef
forall a. a -> Maybe a
Just (RemoteEndRef -> Maybe RemoteEndRef)
-> RemoteEndRef -> Maybe RemoteEndRef
forall a b. (a -> b) -> a -> b
$ Maybe (TVar RemoteEndPool) -> RemoteEndRef
RemoteEndRef Maybe (TVar RemoteEndPool)
forall a. Maybe a
Nothing
optionName :: Tagged RemoteEndRef FilePath
optionName = FilePath -> Tagged RemoteEndRef FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
forall t. IsString t => t
_OPT_REMOTE_ENDS_CONFIG
optionHelp :: Tagged RemoteEndRef FilePath
optionHelp = FilePath -> Tagged RemoteEndRef FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"path to remote end config"
data RemoteEndOpt = RemoteEndOpt
deriving Typeable
instance TO.IsOption RemoteEndOpt where
defaultValue :: RemoteEndOpt
defaultValue = RemoteEndOpt
RemoteEndOpt
parseValue :: FilePath -> Maybe RemoteEndOpt
parseValue FilePath
_ = RemoteEndOpt -> Maybe RemoteEndOpt
forall a. a -> Maybe a
Just RemoteEndOpt
RemoteEndOpt
optionName :: Tagged RemoteEndOpt FilePath
optionName = FilePath -> Tagged RemoteEndOpt FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
forall t. IsString t => t
_OPT_REMOTE_ENDS
optionHelp :: Tagged RemoteEndOpt FilePath
optionHelp = FilePath -> Tagged RemoteEndOpt FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"remote end uris"
ifDriverIs :: DriverName -> (TT.TestTree -> TT.TestTree) -> TT.TestTree -> TT.TestTree
ifDriverIs :: DriverName -> (TestTree -> TestTree) -> TestTree -> TestTree
ifDriverIs DriverName
driver TestTree -> TestTree
f TestTree
tree = (Driver -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
T.askOption Driver -> TestTree
checkDriver
where
checkDriver :: Driver -> TT.TestTree
checkDriver :: Driver -> TestTree
checkDriver (Driver DriverName
d) = if DriverName
d DriverName -> DriverName -> Bool
forall a. Eq a => a -> a -> Bool
== DriverName
driver
then TestTree -> TestTree
f TestTree
tree
else TestTree
tree
unlessDriverIs :: DriverName -> (TT.TestTree -> TT.TestTree) -> TT.TestTree -> TT.TestTree
unlessDriverIs :: DriverName -> (TestTree -> TestTree) -> TestTree -> TestTree
unlessDriverIs DriverName
driver TestTree -> TestTree
f TestTree
tree = (Driver -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
T.askOption Driver -> TestTree
checkDriver
where
checkDriver :: Driver -> TT.TestTree
checkDriver :: Driver -> TestTree
checkDriver (Driver DriverName
d) = if DriverName
d DriverName -> DriverName -> Bool
forall a. Eq a => a -> a -> Bool
/= DriverName
driver
then TestTree -> TestTree
f TestTree
tree
else TestTree
tree
ifTierIs :: DeploymentTier -> (TT.TestTree -> TT.TestTree) -> TT.TestTree -> TT.TestTree
ifTierIs :: DeploymentTier -> (TestTree -> TestTree) -> TestTree -> TestTree
ifTierIs DeploymentTier
tier TestTree -> TestTree
f TestTree
tree = (Deployment -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
T.askOption Deployment -> TestTree
checkDeployment
where
checkDeployment :: Deployment -> TT.TestTree
checkDeployment :: Deployment -> TestTree
checkDeployment (Deployment DeploymentTier
t) = if DeploymentTier
t DeploymentTier -> DeploymentTier -> Bool
forall a. Eq a => a -> a -> Bool
== DeploymentTier
tier
then TestTree -> TestTree
f TestTree
tree
else TestTree
tree
unlessTierIs :: DeploymentTier -> (TT.TestTree -> TT.TestTree) -> TT.TestTree -> TT.TestTree
unlessTierIs :: DeploymentTier -> (TestTree -> TestTree) -> TestTree -> TestTree
unlessTierIs DeploymentTier
tier TestTree -> TestTree
f TestTree
tree = (Deployment -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
T.askOption Deployment -> TestTree
checkDeployment
where
checkDeployment :: Deployment -> TT.TestTree
checkDeployment :: Deployment -> TestTree
checkDeployment (Deployment DeploymentTier
t) = if DeploymentTier
t DeploymentTier -> DeploymentTier -> Bool
forall a. Eq a => a -> a -> Bool
/= DeploymentTier
tier
then TestTree -> TestTree
f TestTree
tree
else TestTree
tree
ifHeadless :: (TT.TestTree -> TT.TestTree) -> TT.TestTree -> TT.TestTree
ifHeadless :: (TestTree -> TestTree) -> TestTree -> TestTree
ifHeadless TestTree -> TestTree
f TestTree
tree = (Headless -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
T.askOption Headless -> TestTree
checkHeadless
where
checkHeadless :: Headless -> TT.TestTree
checkHeadless :: Headless -> TestTree
checkHeadless (Headless Bool
p) = (if Bool
p then TestTree -> TestTree
f else TestTree -> TestTree
forall a. a -> a
id) TestTree
tree
unlessHeadless :: (TT.TestTree -> TT.TestTree) -> TT.TestTree -> TT.TestTree
unlessHeadless :: (TestTree -> TestTree) -> TestTree -> TestTree
unlessHeadless TestTree -> TestTree
f TestTree
tree = (Headless -> TestTree) -> TestTree
forall v. IsOption v => (v -> TestTree) -> TestTree
T.askOption Headless -> TestTree
checkHeadless
where
checkHeadless :: Headless -> TT.TestTree
checkHeadless :: Headless -> TestTree
checkHeadless (Headless Bool
p) = (if Bool
p then TestTree -> TestTree
forall a. a -> a
id else TestTree -> TestTree
f) TestTree
tree
defaultWebDriverMain :: TT.TestTree -> IO ()
defaultWebDriverMain :: TestTree -> IO ()
defaultWebDriverMain TestTree
tree = do
TVar RemoteEndPool
pool <- IO (TVar RemoteEndPool)
getRemoteEndRef
DeploymentTier
deploy <- Text
-> (Text -> Maybe DeploymentTier)
-> Text
-> (Text -> Maybe DeploymentTier)
-> DeploymentTier
-> IO DeploymentTier
forall a.
Text -> (Text -> Maybe a) -> Text -> (Text -> Maybe a) -> a -> IO a
getEnvVarDefaultOption
Text
forall t. IsString t => t
_OPT_DEPLOYMENT (Text -> [(Text, DeploymentTier)] -> Maybe DeploymentTier
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(Text
"dev", DeploymentTier
DEV), (Text
"test", DeploymentTier
TEST), (Text
"prod", DeploymentTier
PROD)])
Text
"CI" (\Text
str -> DeploymentTier -> Maybe DeploymentTier
forall a. a -> Maybe a
Just (DeploymentTier -> Maybe DeploymentTier)
-> DeploymentTier -> Maybe DeploymentTier
forall a b. (a -> b) -> a -> b
$ if Text
str Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"true" then DeploymentTier
TEST else DeploymentTier
DEV)
DeploymentTier
DEV
FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
">>> Deployment environment is " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ DeploymentTier -> FilePath
forall a. Show a => a -> FilePath
show DeploymentTier
deploy
Bool
colors <- Text
-> (Text -> Maybe Bool)
-> Text
-> (Text -> Maybe Bool)
-> Bool
-> IO Bool
forall a.
Text -> (Text -> Maybe a) -> Text -> (Text -> Maybe a) -> a -> IO a
getEnvVarDefaultOption
Text
forall t. IsString t => t
_OPT_COLOR (Text -> [(Text, Bool)] -> Maybe Bool
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(Text
"true", Bool
True), (Text
"false", Bool
False)])
Text
"NO_COLOR" (\Text
_ -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
Bool
True
FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
">>> Logging " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (if Bool
colors then FilePath
"with" else FilePath
"without") FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" colors"
if Bool
colors
then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else FilePath -> FilePath -> IO ()
SE.setEnv FilePath
"TASTY_COLOR" FilePath
"never"
Handle
logHandle <- Text -> Handle -> IO Handle
getWriteModeHandleOption Text
forall t. IsString t => t
_OPT_LOG_HANDLE Handle
stderr
Handle
coutHandle <- Text -> Handle -> IO Handle
getWriteModeHandleOption Text
forall t. IsString t => t
_OPT_CONSOLE_OUT Handle
stdout
Handle
cinHandle <- Text -> Handle -> IO Handle
getReadModeHandleOption Text
forall t. IsString t => t
_OPT_CONSOLE_IN Handle
stdin
TestTree -> IO ()
T.defaultMain
(TestTree -> IO ()) -> (TestTree -> TestTree) -> TestTree -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Deployment -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
T.localOption (DeploymentTier -> Deployment
Deployment DeploymentTier
deploy)
(TestTree -> TestTree)
-> (TestTree -> TestTree) -> TestTree -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RemoteEndRef -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
T.localOption (Maybe (TVar RemoteEndPool) -> RemoteEndRef
RemoteEndRef (Maybe (TVar RemoteEndPool) -> RemoteEndRef)
-> Maybe (TVar RemoteEndPool) -> RemoteEndRef
forall a b. (a -> b) -> a -> b
$ TVar RemoteEndPool -> Maybe (TVar RemoteEndPool)
forall a. a -> Maybe a
Just TVar RemoteEndPool
pool)
(TestTree -> TestTree)
-> (TestTree -> TestTree) -> TestTree -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogHandle -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
T.localOption (Handle -> LogHandle
LogHandle Handle
logHandle)
(TestTree -> TestTree)
-> (TestTree -> TestTree) -> TestTree -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogColors -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
T.localOption (Bool -> LogColors
LogColors Bool
colors)
(TestTree -> TestTree)
-> (TestTree -> TestTree) -> TestTree -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConsoleOutHandle -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
T.localOption (Handle -> ConsoleOutHandle
ConsoleOutHandle Handle
coutHandle)
(TestTree -> TestTree)
-> (TestTree -> TestTree) -> TestTree -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConsoleInHandle -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
T.localOption (Handle -> ConsoleInHandle
ConsoleInHandle Handle
cinHandle)
(TestTree -> IO ()) -> TestTree -> IO ()
forall a b. (a -> b) -> a -> b
$ TestTree
tree
(Handle -> IO ()) -> [Handle] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Handle -> IO ()
hClose
[ Handle
logHandle, Handle
coutHandle, Handle
cinHandle ]
getWriteModeHandleOption :: Text -> Handle -> IO Handle
getWriteModeHandleOption :: Text -> Handle -> IO Handle
getWriteModeHandleOption Text
opt Handle
theDefault = do
[Text]
args <- ([FilePath] -> [Text]) -> IO [FilePath] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath -> Text) -> [FilePath] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
Text.pack) IO [FilePath]
SE.getArgs
case Text -> [Text] -> Maybe (Maybe Text)
parseOptionWithArgument (Text
"--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
opt) [Text]
args of
Maybe (Maybe Text)
Nothing -> do
Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Error: option '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
opt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' is missing a required path argument"
IO Handle
forall a. IO a
exitFailure
Just Maybe Text
Nothing -> Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
theDefault
Just (Just Text
path) -> case Text
path of
Text
"stdout" -> Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout
Text
"stderr" -> Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stderr
Text
_ -> FilePath -> IOMode -> IO Handle
openFile (Text -> FilePath
Text.unpack Text
path) IOMode
WriteMode
getReadModeHandleOption :: Text -> Handle -> IO Handle
getReadModeHandleOption :: Text -> Handle -> IO Handle
getReadModeHandleOption Text
opt Handle
theDefault = do
[Text]
args <- ([FilePath] -> [Text]) -> IO [FilePath] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath -> Text) -> [FilePath] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
Text.pack) IO [FilePath]
SE.getArgs
case Text -> [Text] -> Maybe (Maybe Text)
parseOptionWithArgument (Text
"--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
opt) [Text]
args of
Maybe (Maybe Text)
Nothing -> do
Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Error: option '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
opt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' is missing a required path argument"
IO Handle
forall a. IO a
exitFailure
Just Maybe Text
Nothing -> Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
theDefault
Just (Just Text
path) -> case Text
path of
Text
"stdin" -> Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdin
Text
_ -> FilePath -> IOMode -> IO Handle
openFile (Text -> FilePath
Text.unpack Text
path) IOMode
ReadMode
getEnvVarDefaultOption
:: Text
-> (Text -> Maybe a)
-> Text
-> (Text -> Maybe a)
-> a
-> IO a
getEnvVarDefaultOption :: Text -> (Text -> Maybe a) -> Text -> (Text -> Maybe a) -> a -> IO a
getEnvVarDefaultOption Text
flag Text -> Maybe a
flagMap Text
var Text -> Maybe a
varMap a
def = do
[FilePath]
args <- IO [FilePath]
SE.getArgs
case Text -> [Text] -> Maybe (Maybe Text)
parseOptionWithArgument (Text
"--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
flag) ((FilePath -> Text) -> [FilePath] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
Text.pack [FilePath]
args) of
Maybe (Maybe Text)
Nothing -> do
Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Error: option '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
flag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' is missing a required argument"
IO a
forall a. IO a
exitFailure
Just (Just Text
value) ->
case Text -> Maybe a
flagMap Text
value of
Just a
a -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
Maybe a
Nothing -> do
Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Error: unrecognized value '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
value Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' for option '--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
flag Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'."
IO a
forall a. IO a
exitFailure
Just Maybe Text
Nothing -> do
Maybe FilePath
value <- FilePath -> IO (Maybe FilePath)
SE.lookupEnv (FilePath -> IO (Maybe FilePath))
-> FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
Text.unpack Text
var
case (FilePath -> Text) -> Maybe FilePath -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
Text.pack Maybe FilePath
value of
Just Text
str ->
case Text -> Maybe a
varMap Text
str of
Just a
a -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
Maybe a
Nothing -> do
Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Error: unrecognized value '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
str Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Text
"' for environment variable '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
var Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'."
IO a
forall a. IO a
exitFailure
Maybe Text
Nothing -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
def
getRemoteEndRef :: IO (TVar RemoteEndPool)
getRemoteEndRef :: IO (TVar RemoteEndPool)
getRemoteEndRef = do
RemoteEndPool
configPool <- RemoteEndPool -> Maybe RemoteEndPool -> RemoteEndPool
forall a. a -> Maybe a -> a
fromMaybe RemoteEndPool
forall a. Monoid a => a
mempty (Maybe RemoteEndPool -> RemoteEndPool)
-> IO (Maybe RemoteEndPool) -> IO RemoteEndPool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe RemoteEndPool)
getRemoteEndConfigPath
RemoteEndPool
optionPool <- RemoteEndPool -> Maybe RemoteEndPool -> RemoteEndPool
forall a. a -> Maybe a -> a
fromMaybe RemoteEndPool
forall a. Monoid a => a
mempty (Maybe RemoteEndPool -> RemoteEndPool)
-> IO (Maybe RemoteEndPool) -> IO RemoteEndPool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe RemoteEndPool)
getRemoteEndOptionString
let pool :: RemoteEndPool
pool = RemoteEndPool -> RemoteEndPool -> RemoteEndPool
forall a. Monoid a => a -> a -> a
mappend RemoteEndPool
configPool RemoteEndPool
optionPool
if RemoteEndPool
pool RemoteEndPool -> RemoteEndPool -> Bool
forall a. Eq a => a -> a -> Bool
== RemoteEndPool
forall a. Monoid a => a
mempty
then RemoteEndPool -> IO (TVar RemoteEndPool)
forall a. a -> IO (TVar a)
newTVarIO (RemoteEndPool -> IO (TVar RemoteEndPool))
-> RemoteEndPool -> IO (TVar RemoteEndPool)
forall a b. (a -> b) -> a -> b
$ Map DriverName [RemoteEnd] -> RemoteEndPool
RemoteEndPool (Map DriverName [RemoteEnd] -> RemoteEndPool)
-> Map DriverName [RemoteEnd] -> RemoteEndPool
forall a b. (a -> b) -> a -> b
$ [(DriverName, [RemoteEnd])] -> Map DriverName [RemoteEnd]
forall k a. Ord k => [(k, a)] -> Map k a
MS.fromList
[ (DriverName
Geckodriver, [Text -> Int -> Text -> RemoteEnd
RemoteEnd Text
"localhost" Int
4444 Text
""])
, (DriverName
Chromedriver, [Text -> Int -> Text -> RemoteEnd
RemoteEnd Text
"localhost" Int
9515 Text
""])
]
else RemoteEndPool -> IO (TVar RemoteEndPool)
forall a. a -> IO (TVar a)
newTVarIO (RemoteEndPool -> IO (TVar RemoteEndPool))
-> RemoteEndPool -> IO (TVar RemoteEndPool)
forall a b. (a -> b) -> a -> b
$ RemoteEndPool -> RemoteEndPool -> RemoteEndPool
forall a. Monoid a => a -> a -> a
mappend RemoteEndPool
configPool RemoteEndPool
optionPool
getRemoteEndConfigPath :: IO (Maybe RemoteEndPool)
getRemoteEndConfigPath :: IO (Maybe RemoteEndPool)
getRemoteEndConfigPath = do
[Text]
args <- ([FilePath] -> [Text]) -> IO [FilePath] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath -> Text) -> [FilePath] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
Text.pack) IO [FilePath]
SE.getArgs
case Text -> [Text] -> Maybe (Maybe Text)
parseOptionWithArgument Text
"--wd-remote-ends-config" [Text]
args of
Maybe (Maybe Text)
Nothing -> do
FilePath -> IO ()
putStrLn FilePath
"option --wd-remote-ends-config missing required path argument"
IO (Maybe RemoteEndPool)
forall a. IO a
exitFailure
Just Maybe Text
Nothing -> Maybe RemoteEndPool -> IO (Maybe RemoteEndPool)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RemoteEndPool
forall a. Maybe a
Nothing
Just (Just Text
path) -> do
Text
str <- FilePath -> IO Text
Text.readFile (FilePath -> IO Text) -> FilePath -> IO Text
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
Text.unpack Text
path
case Text -> Either Text RemoteEndPool
parseRemoteEndConfig Text
str of
Left Text
err -> do
Text -> IO ()
Text.putStrLn Text
err
IO (Maybe RemoteEndPool)
forall a. IO a
exitFailure
Right RemoteEndPool
x -> Maybe RemoteEndPool -> IO (Maybe RemoteEndPool)
forall (m :: * -> *) a. Monad m => a -> m a
return (RemoteEndPool -> Maybe RemoteEndPool
forall a. a -> Maybe a
Just RemoteEndPool
x)
getRemoteEndOptionString :: IO (Maybe RemoteEndPool)
getRemoteEndOptionString :: IO (Maybe RemoteEndPool)
getRemoteEndOptionString = do
[Text]
args <- ([FilePath] -> [Text]) -> IO [FilePath] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath -> Text) -> [FilePath] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
Text.pack) IO [FilePath]
SE.getArgs
case Text -> [Text] -> Maybe (Maybe Text)
parseOptionWithArgument Text
"--wd-remote-ends" [Text]
args of
Maybe (Maybe Text)
Nothing -> do
FilePath -> IO ()
putStrLn FilePath
"option --wd-remote-ends missing required argument"
IO (Maybe RemoteEndPool)
forall a. IO a
exitFailure
Just Maybe Text
Nothing -> Maybe RemoteEndPool -> IO (Maybe RemoteEndPool)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RemoteEndPool
forall a. Maybe a
Nothing
Just (Just Text
str) ->
case Text -> Either Text RemoteEndPool
parseRemoteEndOption Text
str of
Left Text
err -> do
Text -> IO ()
Text.putStrLn Text
err
IO (Maybe RemoteEndPool)
forall a. IO a
exitFailure
Right RemoteEndPool
x -> Maybe RemoteEndPool -> IO (Maybe RemoteEndPool)
forall (m :: * -> *) a. Monad m => a -> m a
return (RemoteEndPool -> Maybe RemoteEndPool
forall a. a -> Maybe a
Just RemoteEndPool
x)
acquireRemoteEnd :: TVar RemoteEndPool -> Int -> DriverName -> IO RemoteEnd
acquireRemoteEnd :: TVar RemoteEndPool -> Int -> DriverName -> IO RemoteEnd
acquireRemoteEnd TVar RemoteEndPool
var Int
delay DriverName
driver = do
Maybe (Maybe RemoteEnd)
result <- STM (Maybe (Maybe RemoteEnd)) -> IO (Maybe (Maybe RemoteEnd))
forall a. STM a -> IO a
atomically (STM (Maybe (Maybe RemoteEnd)) -> IO (Maybe (Maybe RemoteEnd)))
-> STM (Maybe (Maybe RemoteEnd)) -> IO (Maybe (Maybe RemoteEnd))
forall a b. (a -> b) -> a -> b
$ TVar RemoteEndPool -> DriverName -> STM (Maybe (Maybe RemoteEnd))
acquireRemoteEndSTM TVar RemoteEndPool
var DriverName
driver
case Maybe (Maybe RemoteEnd)
result of
Maybe (Maybe RemoteEnd)
Nothing -> do
FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Error: no remotes defined for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ DriverName -> FilePath
forall a. Show a => a -> FilePath
show DriverName
driver
IO RemoteEnd
forall a. IO a
exitFailure
Just Maybe RemoteEnd
Nothing -> do
Int -> IO ()
threadDelay Int
delay
TVar RemoteEndPool -> Int -> DriverName -> IO RemoteEnd
acquireRemoteEnd TVar RemoteEndPool
var Int
delay DriverName
driver
Just (Just RemoteEnd
x) -> RemoteEnd -> IO RemoteEnd
forall (m :: * -> *) a. Monad m => a -> m a
return RemoteEnd
x
acquireRemoteEndSTM
:: TVar RemoteEndPool -> DriverName -> STM (Maybe (Maybe RemoteEnd))
acquireRemoteEndSTM :: TVar RemoteEndPool -> DriverName -> STM (Maybe (Maybe RemoteEnd))
acquireRemoteEndSTM TVar RemoteEndPool
var DriverName
driver = do
RemoteEndPool
pool <- TVar RemoteEndPool -> STM RemoteEndPool
forall a. TVar a -> STM a
readTVar TVar RemoteEndPool
var
let (RemoteEndPool
newPool, Maybe (Maybe RemoteEnd)
result) = DriverName
-> RemoteEndPool -> (RemoteEndPool, Maybe (Maybe RemoteEnd))
getRemoteEndForDriver DriverName
driver RemoteEndPool
pool
TVar RemoteEndPool -> RemoteEndPool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar RemoteEndPool
var RemoteEndPool
newPool
Maybe (Maybe RemoteEnd) -> STM (Maybe (Maybe RemoteEnd))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Maybe RemoteEnd)
result
releaseRemoteEnd :: TVar RemoteEndPool -> DriverName -> RemoteEnd -> STM ()
releaseRemoteEnd :: TVar RemoteEndPool -> DriverName -> RemoteEnd -> STM ()
releaseRemoteEnd TVar RemoteEndPool
var DriverName
driver RemoteEnd
remote =
TVar RemoteEndPool -> (RemoteEndPool -> RemoteEndPool) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar RemoteEndPool
var ((RemoteEndPool -> RemoteEndPool) -> STM ())
-> (RemoteEndPool -> RemoteEndPool) -> STM ()
forall a b. (a -> b) -> a -> b
$ DriverName -> RemoteEnd -> RemoteEndPool -> RemoteEndPool
addRemoteEndForDriver DriverName
driver RemoteEnd
remote