{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}

module Test.Sandwich.WebDriver (
  -- * Introducing a WebDriver server
  introduceWebDriver
  , introduceWebDriverOptions
  , addCommandLineOptionsToWdOptions

  -- * Running an example in a given session
  , withSession
  , withSession1
  , withSession2

  -- * Managing sessions
  , getSessions
  , closeCurrentSession
  , closeSession
  , closeAllSessions
  , closeAllSessionsExcept
  , Session

  -- * Lower-level allocation functions
  , allocateWebDriver
  , allocateWebDriver'
  , cleanupWebDriver
  , cleanupWebDriver'

  -- * Re-exports
  , module Test.Sandwich.WebDriver.Class
  , module Test.Sandwich.WebDriver.Config
  , module Test.Sandwich.WebDriver.Types
  ) where

import Control.Applicative
import Control.Concurrent.MVar.Lifted
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
import Data.IORef
import qualified Data.Map as M
import Data.Maybe
import Data.String.Interpolate
import Test.Sandwich
import Test.Sandwich.Internal
import Test.Sandwich.WebDriver.Class
import Test.Sandwich.WebDriver.Config
import Test.Sandwich.WebDriver.Internal.Action
import Test.Sandwich.WebDriver.Internal.StartWebDriver
import Test.Sandwich.WebDriver.Internal.Types
import Test.Sandwich.WebDriver.Types
import qualified Test.WebDriver as W
import qualified Test.WebDriver.Config as W
import qualified Test.WebDriver.Session as W


-- | This is the main 'introduce' method for creating a WebDriver.
introduceWebDriver :: (BaseMonadContext m context) => WdOptions -> SpecFree (LabelValue "webdriver" WebDriver :> context) m () -> SpecFree context m ()
introduceWebDriver :: forall (m :: * -> *) context.
BaseMonadContext m context =>
WdOptions
-> SpecFree (LabelValue "webdriver" WebDriver :> context) m ()
-> SpecFree context m ()
introduceWebDriver WdOptions
wdOptions = forall intro (l :: Symbol) context (m :: * -> *).
(HasCallStack, Typeable intro) =>
String
-> Label l intro
-> ExampleT context m intro
-> (intro -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduce String
"Introduce WebDriver session" Label "webdriver" WebDriver
webdriver (forall context (m :: * -> *).
(HasBaseContext context, BaseMonad m) =>
WdOptions -> ExampleT context m WebDriver
allocateWebDriver WdOptions
wdOptions) forall context (m :: * -> *).
(HasBaseContext context, BaseMonad m) =>
WebDriver -> ExampleT context m ()
cleanupWebDriver

-- | Same as introduceWebDriver, but merges command line options into the 'WdOptions'.
introduceWebDriverOptions :: forall a context m. (BaseMonadContext m context, HasCommandLineOptions context a)
  => WdOptions -> SpecFree (LabelValue "webdriver" WebDriver :> context) m () -> SpecFree context m ()
introduceWebDriverOptions :: forall a context (m :: * -> *).
(BaseMonadContext m context, HasCommandLineOptions context a) =>
WdOptions
-> SpecFree (LabelValue "webdriver" WebDriver :> context) m ()
-> SpecFree context m ()
introduceWebDriverOptions WdOptions
wdOptions = forall intro (l :: Symbol) context (m :: * -> *).
(HasCallStack, Typeable intro) =>
String
-> Label l intro
-> ExampleT context m intro
-> (intro -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduce String
"Introduce WebDriver session" Label "webdriver" WebDriver
webdriver ExampleT context m WebDriver
alloc forall context (m :: * -> *).
(HasBaseContext context, BaseMonad m) =>
WebDriver -> ExampleT context m ()
cleanupWebDriver
  where alloc :: ExampleT context m WebDriver
alloc = do
          CommandLineOptions a
clo <- forall a context (m :: * -> *).
(HasCommandLineOptions context a, MonadReader context m,
 MonadIO m) =>
m (CommandLineOptions a)
getCommandLineOptions
          forall context (m :: * -> *).
(HasBaseContext context, BaseMonad m) =>
WdOptions -> ExampleT context m WebDriver
allocateWebDriver (forall a. CommandLineOptions a -> WdOptions -> WdOptions
addCommandLineOptionsToWdOptions @a CommandLineOptions a
clo WdOptions
wdOptions)

-- | Allocate a WebDriver using the given options.
allocateWebDriver :: (HasBaseContext context, BaseMonad m) => WdOptions -> ExampleT context m WebDriver
allocateWebDriver :: forall context (m :: * -> *).
(HasBaseContext context, BaseMonad m) =>
WdOptions -> ExampleT context m WebDriver
allocateWebDriver WdOptions
wdOptions = do
  forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug Text
"Beginning allocateWebDriver"
  String
dir <- forall a. a -> Maybe a -> a
fromMaybe String
"/tmp" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall context (m :: * -> *).
(HasBaseContext context, MonadReader context m, MonadIO m) =>
m (Maybe String)
getCurrentFolder
  forall (m :: * -> *).
Constraints m =>
WdOptions -> String -> m WebDriver
startWebDriver WdOptions
wdOptions String
dir

-- | Allocate a WebDriver using the given options and putting logs under the given path.
allocateWebDriver' :: FilePath -> WdOptions -> IO WebDriver
allocateWebDriver' :: String -> WdOptions -> IO WebDriver
allocateWebDriver' String
runRoot WdOptions
wdOptions = do
  forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Constraints m =>
WdOptions -> String -> m WebDriver
startWebDriver WdOptions
wdOptions String
runRoot

-- | Clean up the given WebDriver.
cleanupWebDriver :: (HasBaseContext context, BaseMonad m) => WebDriver -> ExampleT context m ()
cleanupWebDriver :: forall context (m :: * -> *).
(HasBaseContext context, BaseMonad m) =>
WebDriver -> ExampleT context m ()
cleanupWebDriver WebDriver
sess = do
  forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadLogger m, MonadBaseControl IO m,
 MonadCatch m) =>
WebDriver -> m ()
closeAllSessions WebDriver
sess
  forall (m :: * -> *). Constraints m => WebDriver -> m ()
stopWebDriver WebDriver
sess

-- | Clean up the given WebDriver without logging.
cleanupWebDriver' :: WebDriver -> IO ()
cleanupWebDriver' :: WebDriver -> IO ()
cleanupWebDriver' WebDriver
sess = do
  forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadLogger m, MonadBaseControl IO m,
 MonadCatch m) =>
WebDriver -> m ()
closeAllSessions WebDriver
sess
    forall (m :: * -> *). Constraints m => WebDriver -> m ()
stopWebDriver WebDriver
sess

-- | Run a given example using a given Selenium session.
withSession :: forall m context a. WebDriverMonad m context => Session -> ExampleT (ContextWithSession context) m a -> ExampleT context m a
withSession :: forall (m :: * -> *) context a.
WebDriverMonad m context =>
String
-> ExampleT (ContextWithSession context) m a
-> ExampleT context m a
withSession String
session (ExampleT ReaderT (ContextWithSession context) (LoggingT m) a
readerMonad) = do
  WebDriver {String
(Handle, Handle, ProcessHandle, String, String, Maybe XvfbSession)
MVar (Map String WDSession)
WDConfig
WdOptions
wdDownloadDir :: WebDriver -> String
wdConfig :: WebDriver -> WDConfig
wdSessionMap :: WebDriver -> MVar (Map String WDSession)
wdOptions :: WebDriver -> WdOptions
wdWebDriver :: WebDriver
-> (Handle, Handle, ProcessHandle, String, String,
    Maybe XvfbSession)
wdName :: WebDriver -> String
wdDownloadDir :: String
wdConfig :: WDConfig
wdSessionMap :: MVar (Map String WDSession)
wdOptions :: WdOptions
wdWebDriver :: (Handle, Handle, ProcessHandle, String, String, Maybe XvfbSession)
wdName :: String
..} <- forall (m :: * -> *) context (l :: Symbol) a.
(Monad m, HasLabel context l a, HasCallStack,
 MonadReader context m) =>
Label l a -> m a
getContext Label "webdriver" WebDriver
webdriver
  -- Create new session if necessary (this can throw an exception)
  WDSession
sess <- forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar (Map String WDSession)
wdSessionMap forall a b. (a -> b) -> a -> b
$ \Map String WDSession
sessionMap -> case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
session Map String WDSession
sessionMap of
    Just WDSession
sess -> forall (m :: * -> *) a. Monad m => a -> m a
return (Map String WDSession
sessionMap, WDSession
sess)
    Maybe WDSession
Nothing -> do
      forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|Creating session '#{session}'|]
      WDSession
sess'' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *).
(WebDriverConfig c, MonadBase IO m) =>
c -> m WDSession
W.mkSession WDConfig
wdConfig
      let sess' :: WDSession
sess' = WDSession
sess'' { wdSessHistUpdate :: SessionHistoryConfig
W.wdSessHistUpdate = SessionHistoryConfig
W.unlimitedHistory }
      WDSession
sess <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. WDSession -> WD a -> IO a
W.runWD WDSession
sess' forall a b. (a -> b) -> a -> b
$ forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
Capabilities -> wd WDSession
W.createSession forall a b. (a -> b) -> a -> b
$ WDConfig -> Capabilities
W.wdCapabilities WDConfig
wdConfig
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
session WDSession
sess Map String WDSession
sessionMap, WDSession
sess)

  IORef WDSession
ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef WDSession
sess

  -- Not used for now, but previous libraries have use a finally to grab the final session on exception.
  -- We could do the same here, but it's not clear that it's needed.
  let m a -> m a
f :: m a -> m a = forall a. a -> a
id

  forall context (m :: * -> *) a.
ReaderT context (LoggingT m) a -> ExampleT context m a
ExampleT (forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (\context
ctx -> forall (l :: Symbol) a. a -> LabelValue l a
LabelValue (String
session, IORef WDSession
ref) forall a b. a -> b -> a :> b
:> context
ctx) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT (forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> LoggingT m a -> LoggingT n b
mapLoggingT m a -> m a
f) ReaderT (ContextWithSession context) (LoggingT m) a
readerMonad)

-- | Convenience function. 'withSession1' = 'withSession' "session1"
withSession1 :: WebDriverMonad m context => ExampleT (ContextWithSession context) m a -> ExampleT context m a
withSession1 :: forall (m :: * -> *) context a.
WebDriverMonad m context =>
ExampleT (ContextWithSession context) m a -> ExampleT context m a
withSession1 = forall (m :: * -> *) context a.
WebDriverMonad m context =>
String
-> ExampleT (ContextWithSession context) m a
-> ExampleT context m a
withSession String
"session1"

-- | Convenience function. 'withSession2' = 'withSession' "session2"
withSession2 :: WebDriverMonad m context => ExampleT (ContextWithSession context) m a -> ExampleT context m a
withSession2 :: forall (m :: * -> *) context a.
WebDriverMonad m context =>
ExampleT (ContextWithSession context) m a -> ExampleT context m a
withSession2 = forall (m :: * -> *) context a.
WebDriverMonad m context =>
String
-> ExampleT (ContextWithSession context) m a
-> ExampleT context m a
withSession String
"session2"

-- | Get all existing session names
getSessions :: (WebDriverMonad m context, MonadReader context m, HasLabel context "webdriver" WebDriver) => m [Session]
getSessions :: forall (m :: * -> *) context.
(WebDriverMonad m context, MonadReader context m,
 HasLabel context "webdriver" WebDriver) =>
m [String]
getSessions = do
  WebDriver {String
(Handle, Handle, ProcessHandle, String, String, Maybe XvfbSession)
MVar (Map String WDSession)
WDConfig
WdOptions
wdDownloadDir :: String
wdConfig :: WDConfig
wdSessionMap :: MVar (Map String WDSession)
wdOptions :: WdOptions
wdWebDriver :: (Handle, Handle, ProcessHandle, String, String, Maybe XvfbSession)
wdName :: String
wdDownloadDir :: WebDriver -> String
wdConfig :: WebDriver -> WDConfig
wdSessionMap :: WebDriver -> MVar (Map String WDSession)
wdOptions :: WebDriver -> WdOptions
wdWebDriver :: WebDriver
-> (Handle, Handle, ProcessHandle, String, String,
    Maybe XvfbSession)
wdName :: WebDriver -> String
..} <- forall (m :: * -> *) context (l :: Symbol) a.
(Monad m, HasLabel context l a, HasCallStack,
 MonadReader context m) =>
Label l a -> m a
getContext Label "webdriver" WebDriver
webdriver
  forall k a. Map k a -> [k]
M.keys forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
readMVar MVar (Map String WDSession)
wdSessionMap)

-- | Merge the options from the 'CommandLineOptions' into some 'WdOptions'.
addCommandLineOptionsToWdOptions :: CommandLineOptions a -> WdOptions -> WdOptions
addCommandLineOptionsToWdOptions :: forall a. CommandLineOptions a -> WdOptions -> WdOptions
addCommandLineOptionsToWdOptions (CommandLineOptions {optWebdriverOptions :: forall a. CommandLineOptions a -> CommandLineWebdriverOptions
optWebdriverOptions=(CommandLineWebdriverOptions {Bool
Maybe String
Maybe DisplayType
Maybe BrowserToUse
optFirefox :: CommandLineWebdriverOptions -> Maybe BrowserToUse
optDisplay :: CommandLineWebdriverOptions -> Maybe DisplayType
optFluxbox :: CommandLineWebdriverOptions -> Bool
optIndividualVideos :: CommandLineWebdriverOptions -> Bool
optErrorVideos :: CommandLineWebdriverOptions -> Bool
optSeleniumJar :: CommandLineWebdriverOptions -> Maybe String
optChromeBinary :: CommandLineWebdriverOptions -> Maybe String
optChromeDriver :: CommandLineWebdriverOptions -> Maybe String
optFirefoxBinary :: CommandLineWebdriverOptions -> Maybe String
optGeckoDriver :: CommandLineWebdriverOptions -> Maybe String
optGeckoDriver :: Maybe String
optFirefoxBinary :: Maybe String
optChromeDriver :: Maybe String
optChromeBinary :: Maybe String
optSeleniumJar :: Maybe String
optErrorVideos :: Bool
optIndividualVideos :: Bool
optFluxbox :: Bool
optDisplay :: Maybe DisplayType
optFirefox :: Maybe BrowserToUse
..})}) wdOptions :: WdOptions
wdOptions@(WdOptions {Int
String
Maybe String
Maybe Manager
Capabilities
GeckoDriverToUse
ChromeDriverToUse
SeleniumToUse
RunMode
WhenToSave
httpRetryCount :: WdOptions -> Int
httpManager :: WdOptions -> Maybe Manager
runMode :: WdOptions -> RunMode
geckoDriverToUse :: WdOptions -> GeckoDriverToUse
firefoxBinaryPath :: WdOptions -> Maybe String
chromeDriverToUse :: WdOptions -> ChromeDriverToUse
chromeBinaryPath :: WdOptions -> Maybe String
seleniumToUse :: WdOptions -> SeleniumToUse
saveSeleniumMessageHistory :: WdOptions -> WhenToSave
capabilities :: WdOptions -> Capabilities
toolsRoot :: WdOptions -> String
httpRetryCount :: Int
httpManager :: Maybe Manager
runMode :: RunMode
geckoDriverToUse :: GeckoDriverToUse
firefoxBinaryPath :: Maybe String
chromeDriverToUse :: ChromeDriverToUse
chromeBinaryPath :: Maybe String
seleniumToUse :: SeleniumToUse
saveSeleniumMessageHistory :: WhenToSave
capabilities :: Capabilities
toolsRoot :: String
..}) = WdOptions
wdOptions {
  capabilities :: Capabilities
capabilities = case Maybe BrowserToUse
optFirefox of
    Just BrowserToUse
UseFirefox -> Maybe String -> Capabilities
firefoxCapabilities Maybe String
fbp
    Just BrowserToUse
UseChrome -> Maybe String -> Capabilities
chromeCapabilities Maybe String
cbp
    Maybe BrowserToUse
Nothing -> case Maybe String
cbp of
      Just String
p -> Maybe String -> Capabilities
chromeCapabilities (forall a. a -> Maybe a
Just String
p)
      Maybe String
Nothing -> case Maybe String
fbp of
        Just String
p -> Maybe String -> Capabilities
firefoxCapabilities (forall a. a -> Maybe a
Just String
p)
        Maybe String
Nothing -> Capabilities
capabilities

  , runMode :: RunMode
runMode = case Maybe DisplayType
optDisplay of
      Maybe DisplayType
Nothing -> RunMode
runMode
      Just DisplayType
Headless -> HeadlessConfig -> RunMode
RunHeadless HeadlessConfig
defaultHeadlessConfig
      Just DisplayType
Xvfb -> XvfbConfig -> RunMode
RunInXvfb (XvfbConfig
defaultXvfbConfig { xvfbStartFluxbox :: Bool
xvfbStartFluxbox = Bool
optFluxbox })
      Just DisplayType
Current -> RunMode
Normal

  , seleniumToUse :: SeleniumToUse
seleniumToUse = forall b a. b -> (a -> b) -> Maybe a -> b
maybe SeleniumToUse
seleniumToUse String -> SeleniumToUse
UseSeleniumAt Maybe String
optSeleniumJar

  , chromeBinaryPath :: Maybe String
chromeBinaryPath = Maybe String
cbp
  , chromeDriverToUse :: ChromeDriverToUse
chromeDriverToUse = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ChromeDriverToUse
chromeDriverToUse String -> ChromeDriverToUse
UseChromeDriverAt Maybe String
optChromeDriver

  , firefoxBinaryPath :: Maybe String
firefoxBinaryPath = Maybe String
fbp
  , geckoDriverToUse :: GeckoDriverToUse
geckoDriverToUse = forall b a. b -> (a -> b) -> Maybe a -> b
maybe GeckoDriverToUse
geckoDriverToUse String -> GeckoDriverToUse
UseGeckoDriverAt Maybe String
optGeckoDriver
  }

  where
    cbp :: Maybe String
cbp = Maybe String
optChromeBinary forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
chromeBinaryPath
    fbp :: Maybe String
fbp = Maybe String
optFirefoxBinary forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
firefoxBinaryPath