{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}

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

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

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

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

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

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


-- | This is the main 'introduce' method for creating a WebDriver.
introduceWebDriver :: (BaseMonadContext m context) => WdOptions -> SpecFree (LabelValue "webdriver" WebDriver :> context) m () -> SpecFree context m ()
introduceWebDriver :: WdOptions
-> SpecFree (LabelValue "webdriver" WebDriver :> context) m ()
-> SpecFree context m ()
introduceWebDriver WdOptions
wdOptions = String
-> Label "webdriver" WebDriver
-> ExampleT context m WebDriver
-> (WebDriver -> ExampleT context m ())
-> SpecFree (LabelValue "webdriver" WebDriver :> context) m ()
-> SpecFree context m ()
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 (WdOptions -> ExampleT context m WebDriver
forall context (m :: * -> *).
(HasBaseContext context, BaseMonad m) =>
WdOptions -> ExampleT context m WebDriver
allocateWebDriver WdOptions
wdOptions) WebDriver -> ExampleT context m ()
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 :: WdOptions
-> SpecFree (LabelValue "webdriver" WebDriver :> context) m ()
-> SpecFree context m ()
introduceWebDriverOptions WdOptions
wdOptions = String
-> Label "webdriver" WebDriver
-> ExampleT context m WebDriver
-> (WebDriver -> ExampleT context m ())
-> SpecFree (LabelValue "webdriver" WebDriver :> context) m ()
-> SpecFree context m ()
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 WebDriver -> ExampleT context m ()
forall context (m :: * -> *).
(HasBaseContext context, BaseMonad m) =>
WebDriver -> ExampleT context m ()
cleanupWebDriver
  where alloc :: ExampleT context m WebDriver
alloc = do
          CommandLineOptions a
clo <- ExampleT context m (CommandLineOptions a)
forall a context (m :: * -> *).
(HasCommandLineOptions context a, MonadReader context m,
 MonadIO m) =>
m (CommandLineOptions a)
getCommandLineOptions
          WdOptions -> ExampleT context m WebDriver
forall context (m :: * -> *).
(HasBaseContext context, BaseMonad m) =>
WdOptions -> ExampleT context m WebDriver
allocateWebDriver (CommandLineOptions a -> WdOptions -> WdOptions
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 :: WdOptions -> ExampleT context m WebDriver
allocateWebDriver WdOptions
wdOptions = do
  Text -> ExampleT context m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug Text
"Beginning allocateWebDriver"
  Maybe String
maybeRunRoot <- ExampleT context m (Maybe String)
forall (m :: * -> *) context.
(Monad m, HasBaseContext context, MonadReader context m) =>
m (Maybe String)
getRunRoot
  let runRoot :: String
runRoot = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"/tmp" Maybe String
maybeRunRoot
  WdOptions -> String -> ExampleT context m WebDriver
forall (m :: * -> *).
Constraints m =>
WdOptions -> String -> m WebDriver
startWebDriver WdOptions
wdOptions String
runRoot

-- | 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
  NoLoggingT IO WebDriver -> IO WebDriver
forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT (NoLoggingT IO WebDriver -> IO WebDriver)
-> NoLoggingT IO WebDriver -> IO WebDriver
forall a b. (a -> b) -> a -> b
$ WdOptions -> String -> NoLoggingT IO WebDriver
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 :: WebDriver -> ExampleT context m ()
cleanupWebDriver WebDriver
sess = do
  WebDriver -> ExampleT context m ()
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadLogger m, MonadBaseControl IO m,
 MonadCatch m) =>
WebDriver -> m ()
closeAllSessions WebDriver
sess
  WebDriver -> ExampleT context m ()
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
  NoLoggingT IO () -> IO ()
forall (m :: * -> *) a. NoLoggingT m a -> m a
runNoLoggingT (NoLoggingT IO () -> IO ()) -> NoLoggingT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    WebDriver -> NoLoggingT IO ()
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadLogger m, MonadBaseControl IO m,
 MonadCatch m) =>
WebDriver -> m ()
closeAllSessions WebDriver
sess
    WebDriver -> NoLoggingT IO ()
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 :: 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
wdConfig :: WebDriver -> WDConfig
wdSessionMap :: WebDriver -> MVar (Map String WDSession)
wdOptions :: WebDriver -> WdOptions
wdWebDriver :: WebDriver
-> (Handle, Handle, ProcessHandle, String, String,
    Maybe XvfbSession)
wdName :: WebDriver -> String
wdConfig :: WDConfig
wdSessionMap :: MVar (Map String WDSession)
wdOptions :: WdOptions
wdWebDriver :: (Handle, Handle, ProcessHandle, String, String, Maybe XvfbSession)
wdName :: String
..} <- Label "webdriver" WebDriver -> ExampleT context m WebDriver
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 <- MVar (Map String WDSession)
-> (Map String WDSession
    -> ExampleT context m (Map String WDSession, WDSession))
-> ExampleT context m WDSession
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar (Map String WDSession)
wdSessionMap ((Map String WDSession
  -> ExampleT context m (Map String WDSession, WDSession))
 -> ExampleT context m WDSession)
-> (Map String WDSession
    -> ExampleT context m (Map String WDSession, WDSession))
-> ExampleT context m WDSession
forall a b. (a -> b) -> a -> b
$ \Map String WDSession
sessionMap -> case String -> Map String WDSession -> Maybe WDSession
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
session Map String WDSession
sessionMap of
    Just WDSession
sess -> (Map String WDSession, WDSession)
-> ExampleT context m (Map String WDSession, WDSession)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map String WDSession
sessionMap, WDSession
sess)
    Maybe WDSession
Nothing -> do
      Text -> ExampleT context m ()
forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
debug [i|Creating session '#{session}'|]
      WDSession
sess'' <- IO WDSession -> ExampleT context m WDSession
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO WDSession -> ExampleT context m WDSession)
-> IO WDSession -> ExampleT context m WDSession
forall a b. (a -> b) -> a -> b
$ WDConfig -> IO WDSession
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 <- IO WDSession -> ExampleT context m WDSession
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO WDSession -> ExampleT context m WDSession)
-> IO WDSession -> ExampleT context m WDSession
forall a b. (a -> b) -> a -> b
$ WDSession -> WD WDSession -> IO WDSession
forall a. WDSession -> WD a -> IO a
W.runWD WDSession
sess' (WD WDSession -> IO WDSession) -> WD WDSession -> IO WDSession
forall a b. (a -> b) -> a -> b
$ Capabilities -> WD WDSession
forall (wd :: * -> *).
(HasCallStack, WebDriver wd) =>
Capabilities -> wd WDSession
W.createSession (Capabilities -> WD WDSession) -> Capabilities -> WD WDSession
forall a b. (a -> b) -> a -> b
$ WDConfig -> Capabilities
W.wdCapabilities WDConfig
wdConfig
      (Map String WDSession, WDSession)
-> ExampleT context m (Map String WDSession, WDSession)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> WDSession -> Map String WDSession -> Map String WDSession
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 <- IO (IORef WDSession) -> ExampleT context m (IORef WDSession)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef WDSession) -> ExampleT context m (IORef WDSession))
-> IO (IORef WDSession) -> ExampleT context m (IORef WDSession)
forall a b. (a -> b) -> a -> b
$ WDSession -> IO (IORef WDSession)
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 = m a -> m a
forall a. a -> a
id

  ReaderT context (LoggingT m) a -> ExampleT context m a
forall context (m :: * -> *) a.
ReaderT context (LoggingT m) a -> ExampleT context m a
ExampleT ((context -> ContextWithSession context)
-> ReaderT (ContextWithSession context) (LoggingT m) a
-> ReaderT context (LoggingT m) a
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (\context
ctx -> (String, IORef WDSession)
-> LabelValue "webdriverSession" (String, IORef WDSession)
forall (l :: Symbol) a. a -> LabelValue l a
LabelValue (String
session, IORef WDSession
ref) LabelValue "webdriverSession" (String, IORef WDSession)
-> context -> ContextWithSession context
forall a b. a -> b -> a :> b
:> context
ctx) (ReaderT (ContextWithSession context) (LoggingT m) a
 -> ReaderT context (LoggingT m) a)
-> ReaderT (ContextWithSession context) (LoggingT m) a
-> ReaderT context (LoggingT m) a
forall a b. (a -> b) -> a -> b
$ (LoggingT m a -> LoggingT m a)
-> ReaderT (ContextWithSession context) (LoggingT m) a
-> ReaderT (ContextWithSession context) (LoggingT m) a
forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT ((m a -> m a) -> LoggingT m a -> LoggingT m a
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 :: ExampleT (ContextWithSession context) m a -> ExampleT context m a
withSession1 = String
-> ExampleT (ContextWithSession context) m a
-> ExampleT context m a
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 :: ExampleT (ContextWithSession context) m a -> ExampleT context m a
withSession2 = String
-> ExampleT (ContextWithSession context) m a
-> ExampleT context m a
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 :: m [String]
getSessions = do
  WebDriver {String
(Handle, Handle, ProcessHandle, String, String, Maybe XvfbSession)
MVar (Map String WDSession)
WDConfig
WdOptions
wdConfig :: WDConfig
wdSessionMap :: MVar (Map String WDSession)
wdOptions :: WdOptions
wdWebDriver :: (Handle, Handle, ProcessHandle, String, String, Maybe XvfbSession)
wdName :: 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
..} <- Label "webdriver" WebDriver -> m WebDriver
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
  Map String WDSession -> [String]
forall k a. Map k a -> [k]
M.keys (Map String WDSession -> [String])
-> m (Map String WDSession) -> m [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map String WDSession) -> m (Map String WDSession)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVar (Map String WDSession) -> IO (Map String WDSession)
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 :: CommandLineOptions a -> WdOptions -> WdOptions
addCommandLineOptionsToWdOptions (CommandLineOptions {optWebdriverOptions :: forall a. CommandLineOptions a -> CommandLineWebdriverOptions
optWebdriverOptions=(CommandLineWebdriverOptions {Bool
Maybe DisplayType
Maybe BrowserToUse
optFirefox :: CommandLineWebdriverOptions -> Maybe BrowserToUse
optDisplay :: CommandLineWebdriverOptions -> Maybe DisplayType
optFluxbox :: CommandLineWebdriverOptions -> Bool
optIndividualVideos :: CommandLineWebdriverOptions -> Bool
optErrorVideos :: CommandLineWebdriverOptions -> Bool
optErrorVideos :: Bool
optIndividualVideos :: Bool
optFluxbox :: Bool
optDisplay :: Maybe DisplayType
optFirefox :: Maybe BrowserToUse
..})}) wdOptions :: WdOptions
wdOptions@(WdOptions {Int
String
Maybe Manager
Capabilities
GeckoDriverToUse
ChromeDriverToUse
SeleniumToUse
RunMode
WhenToSave
httpRetryCount :: WdOptions -> Int
httpManager :: WdOptions -> Maybe Manager
runMode :: WdOptions -> RunMode
geckoDriverToUse :: WdOptions -> GeckoDriverToUse
chromeDriverToUse :: WdOptions -> ChromeDriverToUse
seleniumToUse :: WdOptions -> SeleniumToUse
saveSeleniumMessageHistory :: WdOptions -> WhenToSave
capabilities :: WdOptions -> Capabilities
toolsRoot :: WdOptions -> String
httpRetryCount :: Int
httpManager :: Maybe Manager
runMode :: RunMode
geckoDriverToUse :: GeckoDriverToUse
chromeDriverToUse :: ChromeDriverToUse
seleniumToUse :: SeleniumToUse
saveSeleniumMessageHistory :: WhenToSave
capabilities :: Capabilities
toolsRoot :: String
..}) = WdOptions
wdOptions {
  capabilities :: Capabilities
capabilities = case Maybe BrowserToUse
optFirefox of
    Maybe BrowserToUse
Nothing -> Capabilities
capabilities
    Just BrowserToUse
UseFirefox -> Capabilities
firefoxCapabilities
    Just BrowserToUse
UseChrome -> Capabilities
chromeCapabilities
  , 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
  }