{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ViewPatterns #-}

module Test.WebDriver.LaunchDriver (
  launchDriver
  , teardownDriver
  , mkDriverRequest
  ) where

import Control.Monad
import Control.Monad.Catch (MonadMask)
import Control.Monad.IO.Unlift
import Control.Monad.Logger
import Control.Retry
import Data.Aeson
import qualified Data.ByteString.Char8 as BS
import Data.Function
import qualified Data.List as L
import Data.Maybe
import Data.String.Interpolate
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.IO as T
import Data.Time
import Network.HTTP.Client
import Network.HTTP.Types (hAccept, hContentType, statusCode)
import Network.Socket
import System.FilePath
import System.IO
import Test.WebDriver.Types
import Test.WebDriver.Util.Ports
import Test.WebDriver.Util.Sockets
import Text.Read (readMaybe)
import UnliftIO.Async
import UnliftIO.Exception
import UnliftIO.Process
import UnliftIO.Timeout


launchDriver :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => DriverConfig -> m Driver
launchDriver :: forall (m :: * -> *).
(MonadUnliftIO m, MonadMask m, MonadLogger m) =>
DriverConfig -> m Driver
launchDriver DriverConfig
driverConfig = do
  Manager
manager <- IO Manager -> m Manager
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> m Manager) -> IO Manager -> m Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings
  let requestHeaders :: RequestHeaders
requestHeaders = RequestHeaders
forall a. Monoid a => a
mempty

  PortNumber
port <- m PortNumber
forall (m :: * -> *). (MonadIO m, MonadCatch m) => m PortNumber
findFreePortOrException

  ([Char]
programName, [[Char]]
args) <- PortNumber -> DriverConfig -> m ([Char], [[Char]])
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
PortNumber -> DriverConfig -> m ([Char], [[Char]])
getArguments PortNumber
port DriverConfig
driverConfig
  Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN [i|#{programName} #{T.unwords $ fmap T.pack args}|]

  (Handle
hRead, Handle
hWrite) <- m (Handle, Handle)
forall (m :: * -> *). MonadIO m => m (Handle, Handle)
createPipe

  let cp :: CreateProcess
cp = ([Char] -> [[Char]] -> CreateProcess
proc [Char]
programName [[Char]]
args) {
        create_group = True
        , std_out = UseHandle hWrite
        , std_err = UseHandle hWrite
        }

  (Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
p) <- CreateProcess
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall (m :: * -> *).
MonadIO m =>
CreateProcess
-> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
cp

  let hostname :: [Char]
hostname = [Char]
"localhost"

  Maybe Handle
maybeLogFileHandle <- case DriverConfig -> Maybe [Char]
driverConfigLogDir DriverConfig
driverConfig of
    Maybe [Char]
Nothing -> Maybe Handle -> m (Maybe Handle)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Handle
forall a. Maybe a
Nothing
    Just [Char]
logDir -> do
      ([Char]
logFilePath, Handle
logFileHandle) <- IO ([Char], Handle) -> m ([Char], Handle)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([Char], Handle) -> m ([Char], Handle))
-> IO ([Char], Handle) -> m ([Char], Handle)
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ([Char], Handle)
openTempFile [Char]
logDir ((DriverConfig -> [Char]
driverBaseName DriverConfig
driverConfig) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
".log")
      Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN [i|Logging driver output to #{logFilePath}|]
      Maybe Handle -> m (Maybe Handle)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Handle -> m (Maybe Handle))
-> Maybe Handle -> m (Maybe Handle)
forall a b. (a -> b) -> a -> b
$ Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
logFileHandle

  let handler :: SomeException -> m ()
handler (SomeException
e :: SomeException) = do
        ProcessHandle -> m ()
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ()
terminateProcess ProcessHandle
p
        UTCTime
now <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        Maybe Handle -> (Handle -> m ()) -> m ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
maybeLogFileHandle ((Handle -> m ()) -> m ()) -> (Handle -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Handle
logFileHandle -> do
          IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> Text -> IO ()
T.hPutStrLn Handle
logFileHandle [i|(#{now}) haskell-webdriver: process ending with exception: #{e}|])
          IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> IO ()
hClose Handle
logFileHandle)

  (m Driver -> (SomeException -> m ()) -> m Driver)
-> (SomeException -> m ()) -> m Driver -> m Driver
forall a b c. (a -> b -> c) -> b -> a -> c
flip m Driver -> (SomeException -> m ()) -> m Driver
forall (m :: * -> *) e a b.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m b) -> m a
withException SomeException -> m ()
forall {m :: * -> *}. MonadIO m => SomeException -> m ()
handler (m Driver -> m Driver) -> m Driver -> m Driver
forall a b. (a -> b) -> a -> b
$ do
    -- Read from the (combined) output stream until we see the up and running message
    Maybe ()
maybeReady <- Int -> m () -> m (Maybe ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
Int -> m a -> m (Maybe a)
timeout Int
30_000_000 (m () -> m (Maybe ())) -> m () -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ (m () -> m ()) -> m ()
forall a. (a -> a) -> a
fix ((m () -> m ()) -> m ()) -> (m () -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \m ()
loop -> do
      Text
line <- ([Char] -> Text) -> m [Char] -> m Text
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Text
T.pack (m [Char] -> m Text) -> m [Char] -> m Text
forall a b. (a -> b) -> a -> b
$ IO [Char] -> m [Char]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> m [Char]) -> IO [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ Handle -> IO [Char]
hGetLine Handle
hRead
      Maybe Handle -> (Handle -> m ()) -> m ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
maybeLogFileHandle ((Handle -> m ()) -> m ()) -> (Handle -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Handle
logFileHandle ->
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
T.hPutStrLn Handle
logFileHandle Text
line
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
Prelude.any (Text -> Text -> Bool
`T.isInfixOf` Text
line) (DriverConfig -> [Text]
needles DriverConfig
driverConfig)) m ()
loop
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe () -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ()
maybeReady) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      DriverException -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DriverException
DriverNoReadyMessage

    Async ()
logAsync <- m () -> m (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (m () -> m (Async ())) -> m () -> m (Async ())
forall a b. (a -> b) -> a -> b
$ (m () -> m () -> m ()) -> m () -> m () -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip m () -> m () -> m ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
finally (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe Handle -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
maybeLogFileHandle Handle -> IO ()
hClose) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Text
line <- IO Text -> m Text
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> IO Text
T.hGetLine Handle
hRead)
      Maybe Handle -> (Handle -> m ()) -> m ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
maybeLogFileHandle ((Handle -> m ()) -> m ()) -> (Handle -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Handle
logFileHandle ->
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
T.hPutStrLn Handle
logFileHandle Text
line

    (m Driver -> m () -> m Driver) -> m () -> m Driver -> m Driver
forall a b c. (a -> b -> c) -> b -> a -> c
flip m Driver -> m () -> m Driver
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
onException (Async () -> m ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
cancel Async ()
logAsync) (m Driver -> m Driver) -> m Driver -> m Driver
forall a b. (a -> b) -> a -> b
$ do
      -- Wait for a successful connection to the server socket
      AddrInfo
addr <- IO [AddrInfo] -> m [AddrInfo]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe AddrInfo -> Maybe [Char] -> Maybe [Char] -> IO [AddrInfo]
forall (t :: * -> *).
GetAddrInfo t =>
Maybe AddrInfo -> Maybe [Char] -> Maybe [Char] -> IO (t AddrInfo)
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
defaultHints) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"127.0.0.1") ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (PortNumber -> [Char]
forall a. Show a => a -> [Char]
show PortNumber
port))) m [AddrInfo] -> ([AddrInfo] -> m AddrInfo) -> m AddrInfo
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        AddrInfo
addr:[AddrInfo]
_ -> AddrInfo -> m AddrInfo
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return AddrInfo
addr
        [AddrInfo]
_ -> DriverException -> m AddrInfo
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DriverException
DriverGetAddrInfoFailed
      let policy :: RetryPolicyM m
policy = Int -> RetryPolicyM m -> RetryPolicyM m
forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
limitRetriesByCumulativeDelay (Int
120 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1_000_000) (RetryPolicyM m -> RetryPolicyM m)
-> RetryPolicyM m -> RetryPolicyM m
forall a b. (a -> b) -> a -> b
$ Int -> RetryPolicyM m -> RetryPolicyM m
forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
capDelay Int
1_000_000 (RetryPolicyM m -> RetryPolicyM m)
-> RetryPolicyM m -> RetryPolicyM m
forall a b. (a -> b) -> a -> b
$ Int -> RetryPolicyM m
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
exponentialBackoff Int
1000

      RetryPolicyM m -> AddrInfo -> m ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadLogger m, MonadMask m) =>
RetryPolicyM m -> AddrInfo -> m ()
waitForSocket RetryPolicyM m
policy AddrInfo
addr

      Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN [i|Finished wait for driver socket|]

      let basePath :: [Char]
basePath = case DriverConfig
driverConfig of
            DriverConfigSeleniumJar {} -> [Char]
"/wd/hub"
            DriverConfig
_ -> [Char]
""

      let driver :: Driver
driver = Driver {
            _driverHostname :: [Char]
_driverHostname = [Char]
hostname
            , _driverPort :: Int
_driverPort = PortNumber -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port
            , _driverBasePath :: [Char]
_driverBasePath = [Char]
basePath
            , _driverRequestHeaders :: RequestHeaders
_driverRequestHeaders = RequestHeaders
requestHeaders
            , _driverManager :: Manager
_driverManager = Manager
manager
            , _driverProcess :: Maybe ProcessHandle
_driverProcess = ProcessHandle -> Maybe ProcessHandle
forall a. a -> Maybe a
Just ProcessHandle
p
            , _driverLogAsync :: Maybe (Async ())
_driverLogAsync = Async () -> Maybe (Async ())
forall a. a -> Maybe a
Just Async ()
logAsync
            , _driverConfig :: DriverConfig
_driverConfig = DriverConfig
driverConfig
            }

      -- Wait for a successful call to /status
      RetryPolicyM m -> (RetryStatus -> m ()) -> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m -> (RetryStatus -> m a) -> m a
recoverAll RetryPolicyM m
policy ((RetryStatus -> m ()) -> m ()) -> (RetryStatus -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \RetryStatus
retryStatus -> do
        let req :: Request
req = Driver -> Method -> Text -> Value -> Request
forall a. ToJSON a => Driver -> Method -> Text -> a -> Request
mkDriverRequest Driver
driver Method
methodGet Text
"/status" Value
Null
        Response ByteString
resp <- IO (Response ByteString) -> m (Response ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> m (Response ByteString))
-> IO (Response ByteString) -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
manager
        let code :: Int
code = Status -> Int
statusCode (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
resp)
        if | Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
200 Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
300 -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           | Bool
otherwise -> do
               Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logWarnN [i|(#{retryStatus}) Invalid response from /status: #{resp}|]
               DriverException -> m ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO DriverException
DriverStatusEndpointNotReady

      Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfoN [i|Finished wait for driver /status endpoint. Driver is running on #{hostname}:#{port}|]

      Driver -> m Driver
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Driver
driver

getArguments :: (MonadIO m, MonadLogger m) => PortNumber -> DriverConfig -> m (FilePath, [String])
getArguments :: forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
PortNumber -> DriverConfig -> m ([Char], [[Char]])
getArguments PortNumber
port (DriverConfigSeleniumJar {[Char]
[[Char]]
[DriverConfig]
Maybe [Char]
Maybe SeleniumVersion
driverConfigLogDir :: DriverConfig -> Maybe [Char]
driverConfigJava :: [Char]
driverConfigJavaFlags :: [[Char]]
driverConfigSeleniumJar :: [Char]
driverConfigSeleniumVersion :: Maybe SeleniumVersion
driverConfigSubDrivers :: [DriverConfig]
driverConfigLogDir :: Maybe [Char]
driverConfigSubDrivers :: DriverConfig -> [DriverConfig]
driverConfigSeleniumVersion :: DriverConfig -> Maybe SeleniumVersion
driverConfigSeleniumJar :: DriverConfig -> [Char]
driverConfigJavaFlags :: DriverConfig -> [[Char]]
driverConfigJava :: DriverConfig -> [Char]
..}) = do
  [[Char]]
javaArgs :: [String] <- [[[Char]]] -> [[Char]]
forall a. Monoid a => [a] -> a
mconcat ([[[Char]]] -> [[Char]]) -> m [[[Char]]] -> m [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DriverConfig -> m [[Char]]) -> [DriverConfig] -> m [[[Char]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM DriverConfig -> m [[Char]]
forall (m :: * -> *). Monad m => DriverConfig -> m [[Char]]
getSubDriverArgs [DriverConfig]
driverConfigSubDrivers

  let maybeSeleniumVersion :: Maybe SeleniumVersion
maybeSeleniumVersion = case Maybe SeleniumVersion
driverConfigSeleniumVersion of
        Just SeleniumVersion
x -> SeleniumVersion -> Maybe SeleniumVersion
forall a. a -> Maybe a
Just SeleniumVersion
x
        Maybe SeleniumVersion
Nothing -> [Char] -> Maybe SeleniumVersion
autodetectSeleniumVersionByFileName [Char]
driverConfigSeleniumJar
  Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfoN [i|Detected Selenium version: #{maybeSeleniumVersion}|]
  let extraArgs :: [[Char]]
extraArgs = case Maybe SeleniumVersion
maybeSeleniumVersion of
        Just SeleniumVersion
Selenium3 -> [[Char]
"-port", PortNumber -> [Char]
forall a. Show a => a -> [Char]
show PortNumber
port]
        Just SeleniumVersion
Selenium4 -> [[Char]
"standalone", [Char]
"--port", PortNumber -> [Char]
forall a. Show a => a -> [Char]
show PortNumber
port, [Char]
"--host", [Char]
"localhost"]
        Maybe SeleniumVersion
Nothing -> [[Char]
"-port", PortNumber -> [Char]
forall a. Show a => a -> [Char]
show PortNumber
port]

  let fullArgs :: [[Char]]
fullArgs = [[Char]]
javaArgs
               [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]
"-jar", [Char]
driverConfigSeleniumJar]
               [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
extraArgs
  ([Char], [[Char]]) -> m ([Char], [[Char]])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
driverConfigJava, [[Char]]
fullArgs [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
driverConfigJavaFlags)
getArguments PortNumber
port (DriverConfigChromedriver {[Char]
[[Char]]
Maybe [Char]
driverConfigLogDir :: DriverConfig -> Maybe [Char]
driverConfigChromedriver :: [Char]
driverConfigChromedriverFlags :: [[Char]]
driverConfigChrome :: [Char]
driverConfigLogDir :: Maybe [Char]
driverConfigChrome :: DriverConfig -> [Char]
driverConfigChromedriverFlags :: DriverConfig -> [[Char]]
driverConfigChromedriver :: DriverConfig -> [Char]
..}) = do
  ([Char], [[Char]]) -> m ([Char], [[Char]])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
driverConfigChromedriver, [[Char]
"--port=" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> PortNumber -> [Char]
forall a. Show a => a -> [Char]
show PortNumber
port] [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
driverConfigChromedriverFlags)
getArguments PortNumber
port (DriverConfigGeckodriver {[Char]
[[Char]]
Maybe [Char]
driverConfigLogDir :: DriverConfig -> Maybe [Char]
driverConfigGeckodriver :: [Char]
driverConfigGeckodriverFlags :: [[Char]]
driverConfigFirefox :: [Char]
driverConfigLogDir :: Maybe [Char]
driverConfigFirefox :: DriverConfig -> [Char]
driverConfigGeckodriverFlags :: DriverConfig -> [[Char]]
driverConfigGeckodriver :: DriverConfig -> [Char]
..}) = do
  ([Char], [[Char]]) -> m ([Char], [[Char]])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
driverConfigGeckodriver, [[Char]
"--port", PortNumber -> [Char]
forall a. Show a => a -> [Char]
show PortNumber
port] [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
driverConfigGeckodriverFlags)

autodetectSeleniumVersionByFileName :: FilePath -> Maybe SeleniumVersion
autodetectSeleniumVersionByFileName :: [Char] -> Maybe SeleniumVersion
autodetectSeleniumVersionByFileName ([Char] -> [Char]
takeFileName -> [Char]
seleniumJar) = case Maybe Int
autodetectSeleniumMajorVersionByFileName of
  Just Int
3 -> SeleniumVersion -> Maybe SeleniumVersion
forall a. a -> Maybe a
Just SeleniumVersion
Selenium3
  Just Int
4 -> SeleniumVersion -> Maybe SeleniumVersion
forall a. a -> Maybe a
Just SeleniumVersion
Selenium4
  Maybe Int
_ -> Maybe SeleniumVersion
forall a. Maybe a
Nothing
  where
    autodetectSeleniumMajorVersionByFileName :: Maybe Int
    autodetectSeleniumMajorVersionByFileName :: Maybe Int
autodetectSeleniumMajorVersionByFileName
      | Bool -> Bool
not ([Char]
"selenium-server-" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` [Char]
seleniumJar) = Maybe Int
forall a. Maybe a
Nothing
      | Bool -> Bool
not ([Char]
".jar" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf` [Char]
seleniumJar) = Maybe Int
forall a. Maybe a
Nothing
      | Bool
otherwise = do
          let parts :: [Maybe Int]
parts = [Char]
seleniumJar
                    [Char] -> ([Char] -> [Char]) -> [Char]
forall a b. a -> (a -> b) -> b
& Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char]
"selenium-server-" :: String))
                    [Char] -> ([Char] -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Int -> Text -> Text
T.dropEnd ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Char]
".jar" :: String)) (Text -> Text) -> ([Char] -> Text) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack
                    Text -> (Text -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"."
                    [Text] -> ([Text] -> [[Char]]) -> [[Char]]
forall a b. a -> (a -> b) -> b
& (Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> [Char]
T.unpack
                    [[Char]] -> ([[Char]] -> [Maybe Int]) -> [Maybe Int]
forall a b. a -> (a -> b) -> b
& ([Char] -> Maybe Int) -> [[Char]] -> [Maybe Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
readMaybe

          case (Maybe Int -> Bool) -> [Maybe Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe Int]
parts of
            Bool
True -> Maybe Int
forall a. Maybe a
Nothing
            Bool
False -> case [Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Int]
parts of
              [Int
x, Int
_, Int
_, Int
_] -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x
              [Int
x, Int
_, Int
_] -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x
              [Int
x, Int
_] -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x
              [Int
x] -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x
              [Int]
_ -> Maybe Int
forall a. Maybe a
Nothing

getSubDriverArgs :: Monad m => DriverConfig -> m [FilePath]
getSubDriverArgs :: forall (m :: * -> *). Monad m => DriverConfig -> m [[Char]]
getSubDriverArgs (DriverConfigChromedriver {[Char]
[[Char]]
Maybe [Char]
driverConfigLogDir :: DriverConfig -> Maybe [Char]
driverConfigChrome :: DriverConfig -> [Char]
driverConfigChromedriverFlags :: DriverConfig -> [[Char]]
driverConfigChromedriver :: DriverConfig -> [Char]
driverConfigChromedriver :: [Char]
driverConfigChromedriverFlags :: [[Char]]
driverConfigChrome :: [Char]
driverConfigLogDir :: Maybe [Char]
..}) = do
  let logArgs :: [[Char]]
logArgs = case Maybe [Char]
driverConfigLogDir of
        Just [Char]
d -> [[Char]
"-Dwebdriver.chrome.logfile=" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ([Char]
d [Char] -> [Char] -> [Char]
</> [Char]
"chromedriver.log")
                  , [Char]
"-Dwebdriver.chrome.verboseLogging=true"
                  ]
        Maybe [Char]
Nothing -> []
  [[Char]] -> m [[Char]]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Char]
"-Dwebdriver.chrome.driver=" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
driverConfigChromedriver] [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]]
logArgs)
getSubDriverArgs (DriverConfigGeckodriver {[Char]
[[Char]]
Maybe [Char]
driverConfigLogDir :: DriverConfig -> Maybe [Char]
driverConfigFirefox :: DriverConfig -> [Char]
driverConfigGeckodriverFlags :: DriverConfig -> [[Char]]
driverConfigGeckodriver :: DriverConfig -> [Char]
driverConfigGeckodriver :: [Char]
driverConfigGeckodriverFlags :: [[Char]]
driverConfigFirefox :: [Char]
driverConfigLogDir :: Maybe [Char]
..}) = do
  [[Char]] -> m [[Char]]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [
    [Char]
"-Dwebdriver.gecko.driver=" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
driverConfigGeckodriver
    ]
getSubDriverArgs DriverConfig
_ = [[Char]] -> m [[Char]]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []

needles :: DriverConfig -> [T.Text]
needles :: DriverConfig -> [Text]
needles (DriverConfigSeleniumJar {}) = [Text
"Selenium Server is up and running", Text
"Started Selenium Standalone"]
needles (DriverConfigChromedriver {}) = [Text
"ChromeDriver was started successfully"]
needles (DriverConfigGeckodriver {}) = [Text
"Listening on"]

driverBaseName :: DriverConfig -> String
driverBaseName :: DriverConfig -> [Char]
driverBaseName (DriverConfigSeleniumJar {}) = [Char]
"selenium"
driverBaseName (DriverConfigChromedriver {}) = [Char]
"chromedriver"
driverBaseName (DriverConfigGeckodriver {}) = [Char]
"geckodriver"

data DriverException =
  DriverGetAddrInfoFailed
  | DriverNoReadyMessage
  | DriverStatusEndpointNotReady
  deriving (Int -> DriverException -> [Char] -> [Char]
[DriverException] -> [Char] -> [Char]
DriverException -> [Char]
(Int -> DriverException -> [Char] -> [Char])
-> (DriverException -> [Char])
-> ([DriverException] -> [Char] -> [Char])
-> Show DriverException
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> DriverException -> [Char] -> [Char]
showsPrec :: Int -> DriverException -> [Char] -> [Char]
$cshow :: DriverException -> [Char]
show :: DriverException -> [Char]
$cshowList :: [DriverException] -> [Char] -> [Char]
showList :: [DriverException] -> [Char] -> [Char]
Show, DriverException -> DriverException -> Bool
(DriverException -> DriverException -> Bool)
-> (DriverException -> DriverException -> Bool)
-> Eq DriverException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DriverException -> DriverException -> Bool
== :: DriverException -> DriverException -> Bool
$c/= :: DriverException -> DriverException -> Bool
/= :: DriverException -> DriverException -> Bool
Eq)

instance Exception DriverException

mkDriverRequest :: (ToJSON a) => Driver -> Method -> T.Text -> a -> Request
mkDriverRequest :: forall a. ToJSON a => Driver -> Method -> Text -> a -> Request
mkDriverRequest (Driver {Int
[Char]
RequestHeaders
Maybe (Async ())
Maybe ProcessHandle
Manager
DriverConfig
_driverHostname :: Driver -> [Char]
_driverPort :: Driver -> Int
_driverBasePath :: Driver -> [Char]
_driverRequestHeaders :: Driver -> RequestHeaders
_driverManager :: Driver -> Manager
_driverProcess :: Driver -> Maybe ProcessHandle
_driverLogAsync :: Driver -> Maybe (Async ())
_driverConfig :: Driver -> DriverConfig
_driverHostname :: [Char]
_driverPort :: Int
_driverBasePath :: [Char]
_driverRequestHeaders :: RequestHeaders
_driverManager :: Manager
_driverProcess :: Maybe ProcessHandle
_driverLogAsync :: Maybe (Async ())
_driverConfig :: DriverConfig
..}) Method
meth Text
wdPath a
args =
  Request
defaultRequest {
    host = BS.pack _driverHostname
    , port = _driverPort
    , path = BS.pack _driverBasePath `BS.append`  TE.encodeUtf8 wdPath
    , requestBody = RequestBodyLBS body
    , requestHeaders = _driverRequestHeaders ++ extraHeaders
    , method = meth
#if !MIN_VERSION_http_client(0,5,0)
    , checkStatus = \_ _ _ -> Nothing
#endif
    }
  where
    body :: ByteString
body = case a -> Value
forall a. ToJSON a => a -> Value
toJSON a
args of
      Value
Null -> ByteString
"" -- Passing Null as the argument indicates no request body
      Value
other -> Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
other

    extraHeaders :: RequestHeaders
extraHeaders = [
      (HeaderName
hAccept, Method
"application/json;charset=UTF-8")
      , (HeaderName
hContentType, Method
"application/json;charset=UTF-8")
      ]


teardownDriver :: (MonadUnliftIO m, MonadLogger m) => Driver -> m ()
teardownDriver :: forall (m :: * -> *).
(MonadUnliftIO m, MonadLogger m) =>
Driver -> m ()
teardownDriver (Driver {Int
[Char]
RequestHeaders
Maybe (Async ())
Maybe ProcessHandle
Manager
DriverConfig
_driverHostname :: Driver -> [Char]
_driverPort :: Driver -> Int
_driverBasePath :: Driver -> [Char]
_driverRequestHeaders :: Driver -> RequestHeaders
_driverManager :: Driver -> Manager
_driverProcess :: Driver -> Maybe ProcessHandle
_driverLogAsync :: Driver -> Maybe (Async ())
_driverConfig :: Driver -> DriverConfig
_driverHostname :: [Char]
_driverPort :: Int
_driverBasePath :: [Char]
_driverRequestHeaders :: RequestHeaders
_driverManager :: Manager
_driverProcess :: Maybe ProcessHandle
_driverLogAsync :: Maybe (Async ())
_driverConfig :: DriverConfig
..}) = do
  case Maybe ProcessHandle
_driverProcess of
    Just ProcessHandle
p -> ProcessHandle -> m ()
forall (m :: * -> *). MonadIO m => ProcessHandle -> m ()
terminateProcess ProcessHandle
p
    Maybe ProcessHandle
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  case Maybe (Async ())
_driverLogAsync of
    Just Async ()
x -> Async () -> m ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
cancel Async ()
x
    Maybe (Async ())
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
whenJust :: forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe a
mg a -> m ()
f = m () -> (a -> m ()) -> Maybe a -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) a -> m ()
f Maybe a
mg