{-# LANGUAGE StrictData #-}
{-# LANGUAGE MultiWayIf #-}

module Test.WebDriver.Commands.BiDi.NetworkActivity (
  withRecordNetworkActivityViaBiDi
  , withRecordNetworkActivityViaBiDi'

  , readNetworkActivity
  , waitForNetworkIdle
  , waitForNetworkIdleForPeriod
  , withWaitForNetworkIdleForPeriod

  -- * Types
  , RequestInfo
  , requestInfoRequestId
  , requestInfoMethod
  , requestInfoUrl
  , requestInfoTimestamp
  , requestInfoRequestHeaders
  , requestInfoResponseHeaders
  , requestInfoResponseText
  , requestInfoErrorText
  , requestInfoCompleted
  , RequestId
  ) where

import Control.Applicative ((<|>))
import Control.Concurrent.STM (retry)
import Control.Monad (unless)
import Control.Monad.IO.Unlift
import Control.Monad.Logger (MonadLogger, logDebugN, logWarnN)
import Data.Aeson
import Data.Aeson.Types (parseEither, Parser)
import Data.Foldable (toList)
import Data.Map (Map)
import qualified Data.Map as M
import Data.String.Interpolate
import Data.Text (Text)
import Data.Time
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import qualified Network.URI as URI
import Test.WebDriver.Commands.BiDi.Session
import Test.WebDriver.Types
import UnliftIO.Concurrent
import UnliftIO.STM


networkEvents :: [Text]
networkEvents :: [Text]
networkEvents = [
  Text
"network.beforeRequestSent"
  , Text
"network.responseCompleted"
  , Text
"network.responseStarted"
  , Text
"network.fetchError"
  ]

type RequestId = Text

data RequestInfo = RequestInfo {
  RequestInfo -> Text
requestInfoRequestId :: RequestId
  , RequestInfo -> Text
requestInfoMethod :: Text
  , RequestInfo -> Text
requestInfoUrl :: Text
  , RequestInfo -> UTCTime
requestInfoTimestamp :: UTCTime
  , RequestInfo -> Maybe (Map Text Text)
requestInfoRequestHeaders :: Maybe (Map Text Text)
  , RequestInfo -> Maybe (Map Text Text)
requestInfoResponseHeaders :: Maybe (Map Text Text)
  , RequestInfo -> Maybe Int
requestInfoResponseStatus :: Maybe Int
  , RequestInfo -> Maybe Text
requestInfoResponseText :: Maybe Text
  , RequestInfo -> Maybe Text
requestInfoErrorText :: Maybe Text
  , RequestInfo -> Bool
requestInfoCompleted :: Bool
  } deriving (Int -> RequestInfo -> ShowS
[RequestInfo] -> ShowS
RequestInfo -> String
(Int -> RequestInfo -> ShowS)
-> (RequestInfo -> String)
-> ([RequestInfo] -> ShowS)
-> Show RequestInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RequestInfo -> ShowS
showsPrec :: Int -> RequestInfo -> ShowS
$cshow :: RequestInfo -> String
show :: RequestInfo -> String
$cshowList :: [RequestInfo] -> ShowS
showList :: [RequestInfo] -> ShowS
Show, RequestInfo -> RequestInfo -> Bool
(RequestInfo -> RequestInfo -> Bool)
-> (RequestInfo -> RequestInfo -> Bool) -> Eq RequestInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RequestInfo -> RequestInfo -> Bool
== :: RequestInfo -> RequestInfo -> Bool
$c/= :: RequestInfo -> RequestInfo -> Bool
/= :: RequestInfo -> RequestInfo -> Bool
Eq)

data NetworkActivity = NetworkActivity {
  NetworkActivity -> Map Text RequestInfo
networkActivityRequests :: Map RequestId RequestInfo
  , NetworkActivity -> UTCTime
networkActivityLastActivityTime :: UTCTime
  } deriving (NetworkActivity -> NetworkActivity -> Bool
(NetworkActivity -> NetworkActivity -> Bool)
-> (NetworkActivity -> NetworkActivity -> Bool)
-> Eq NetworkActivity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NetworkActivity -> NetworkActivity -> Bool
== :: NetworkActivity -> NetworkActivity -> Bool
$c/= :: NetworkActivity -> NetworkActivity -> Bool
/= :: NetworkActivity -> NetworkActivity -> Bool
Eq)

type NetworkActivityVar = TVar NetworkActivity

-- | Wrapper around 'withRecordNetworkActivityViaBiDi'' which uses the WebSocket URL from
-- the current 'Session'. You must make sure to pass '_capabilitiesWebSocketUrl'
-- = @Just True@ to enable this. This will not work with Selenium 3.
withRecordNetworkActivityViaBiDi :: (WebDriver m, MonadLogger m) => BiDiOptions -> (NetworkActivityVar -> m a) -> m a
withRecordNetworkActivityViaBiDi :: forall (m :: * -> *) a.
(WebDriver m, MonadLogger m) =>
BiDiOptions -> (NetworkActivityVar -> m a) -> m a
withRecordNetworkActivityViaBiDi BiDiOptions
biDiOptions NetworkActivityVar -> m a
action = do
  NetworkActivityVar
networkActivityVar <- m NetworkActivityVar
forall (m :: * -> *). MonadIO m => m NetworkActivityVar
newNetworkActivityVar
  BiDiOptions -> [Text] -> (BiDiEvent -> m ()) -> m a -> m a
forall (m :: * -> *) a.
(WebDriver m, MonadLogger m) =>
BiDiOptions -> [Text] -> (BiDiEvent -> m ()) -> m a -> m a
withBiDiSession BiDiOptions
biDiOptions [Text]
networkEvents (NetworkActivityVar -> BiDiEvent -> m ()
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
NetworkActivityVar -> BiDiEvent -> m ()
mkCallback NetworkActivityVar
networkActivityVar) (NetworkActivityVar -> m a
action NetworkActivityVar
networkActivityVar)

-- | Connect to WebSocket URL and subscribe to network events using the W3C BiDi protocol; see
-- <https://w3c.github.io/webdriver-bidi/>.
withRecordNetworkActivityViaBiDi' :: forall m a. (MonadUnliftIO m, MonadLogger m) => BiDiOptions -> Int -> URI.URI -> (NetworkActivityVar -> m a) -> m a
withRecordNetworkActivityViaBiDi' :: forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLogger m) =>
BiDiOptions -> Int -> URI -> (NetworkActivityVar -> m a) -> m a
withRecordNetworkActivityViaBiDi' BiDiOptions
biDiOptions Int
bidiSessionId URI
uri NetworkActivityVar -> m a
action = do
  NetworkActivityVar
networkActivityVar <- m NetworkActivityVar
forall (m :: * -> *). MonadIO m => m NetworkActivityVar
newNetworkActivityVar
  BiDiOptions
-> Int -> URI -> [Text] -> (BiDiEvent -> m ()) -> m a -> m a
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadLogger m) =>
BiDiOptions
-> Int -> URI -> [Text] -> (BiDiEvent -> m ()) -> m a -> m a
withBiDiSession' BiDiOptions
biDiOptions Int
bidiSessionId URI
uri [Text]
networkEvents (NetworkActivityVar -> BiDiEvent -> m ()
forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
NetworkActivityVar -> BiDiEvent -> m ()
mkCallback NetworkActivityVar
networkActivityVar) (NetworkActivityVar -> m a
action NetworkActivityVar
networkActivityVar)

mkCallback :: (MonadIO m, MonadLogger m) => NetworkActivityVar -> BiDiEvent -> m ()
mkCallback :: forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
NetworkActivityVar -> BiDiEvent -> m ()
mkCallback NetworkActivityVar
nav (BiDiEvent Text
"event" Text
"network.beforeRequestSent" Value
params) = do
  case Value -> Maybe (Text, Text, Text, UTCTime, Maybe (Map Text Text))
parseBeforeRequestSent Value
params of
    Just (Text
requestId, Text
method, Text
url, UTCTime
timestamp, Maybe (Map Text Text)
headers) -> do
      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
      STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ NetworkActivityVar
-> (NetworkActivity -> NetworkActivity) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar NetworkActivityVar
nav ((NetworkActivity -> NetworkActivity) -> STM ())
-> (NetworkActivity -> NetworkActivity) -> STM ()
forall a b. (a -> b) -> a -> b
$ \NetworkActivity
na -> NetworkActivity
na {
        networkActivityRequests = M.insert requestId (RequestInfo {
          requestInfoRequestId = requestId
          , requestInfoMethod = method
          , requestInfoUrl = url
          , requestInfoTimestamp = timestamp
          , requestInfoRequestHeaders = headers
          , requestInfoResponseHeaders = Nothing
          , requestInfoResponseStatus = Nothing
          , requestInfoResponseText = Nothing
          , requestInfoErrorText = Nothing
          , requestInfoCompleted = False
          }) (networkActivityRequests na)
        , networkActivityLastActivityTime = now
        }
      Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN [i|BiDi: Network request started: #{requestId} #{method} #{url}|]
    Maybe (Text, Text, Text, UTCTime, Maybe (Map Text Text))
Nothing -> Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logWarnN Text
"BiDi: Failed to parse network.beforeRequestSent event"

mkCallback NetworkActivityVar
nav (BiDiEvent Text
"event" Text
"network.responseStarted" Value
params) = do
  case Value -> Maybe (Text, Int, Maybe (Map Text Text))
parseResponseStarted Value
params of
    Just (Text
requestId, Int
status, Maybe (Map Text Text)
headers) -> do
      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 RequestInfo
maybeRequestInfo <- STM (Maybe RequestInfo) -> m (Maybe RequestInfo)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe RequestInfo) -> m (Maybe RequestInfo))
-> STM (Maybe RequestInfo) -> m (Maybe RequestInfo)
forall a b. (a -> b) -> a -> b
$ do
        NetworkActivity
na <- NetworkActivityVar -> STM NetworkActivity
forall a. TVar a -> STM a
readTVar NetworkActivityVar
nav

        let (Maybe RequestInfo
ret, Map Text RequestInfo
requests') = Text
-> Map Text RequestInfo
-> (RequestInfo -> RequestInfo)
-> (Maybe RequestInfo, Map Text RequestInfo)
forall k a. Ord k => k -> Map k a -> (a -> a) -> (Maybe a, Map k a)
adjustAndReturnNew Text
requestId (NetworkActivity -> Map Text RequestInfo
networkActivityRequests NetworkActivity
na) ((RequestInfo -> RequestInfo)
 -> (Maybe RequestInfo, Map Text RequestInfo))
-> (RequestInfo -> RequestInfo)
-> (Maybe RequestInfo, Map Text RequestInfo)
forall a b. (a -> b) -> a -> b
$ \RequestInfo
ri -> RequestInfo
ri {
              requestInfoResponseStatus = Just status
              , requestInfoResponseHeaders = headers
              }

        NetworkActivityVar
-> (NetworkActivity -> NetworkActivity) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar NetworkActivityVar
nav ((NetworkActivity -> NetworkActivity) -> STM ())
-> (NetworkActivity -> NetworkActivity) -> STM ()
forall a b. (a -> b) -> a -> b
$ \NetworkActivity
na' -> NetworkActivity
na' {
          networkActivityRequests = requests'
          , networkActivityLastActivityTime = now
          }

        Maybe RequestInfo -> STM (Maybe RequestInfo)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RequestInfo
ret
      Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN [i|BiDi: Network response started: #{requestId} status #{status} (#{maybe "<unknown>" requestInfoUrl maybeRequestInfo})|]
    Maybe (Text, Int, Maybe (Map Text Text))
Nothing -> Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logWarnN Text
"BiDi: Failed to parse network.responseStarted event"

mkCallback NetworkActivityVar
nav (BiDiEvent Text
"event" Text
"network.responseCompleted" Value
params) = do
  case Value -> Maybe (Text, Maybe Text)
parseResponseCompleted Value
params of
    Just (Text
requestId, Maybe Text
responseText) -> do
      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 RequestInfo
maybeRequestInfo <- STM (Maybe RequestInfo) -> m (Maybe RequestInfo)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe RequestInfo) -> m (Maybe RequestInfo))
-> STM (Maybe RequestInfo) -> m (Maybe RequestInfo)
forall a b. (a -> b) -> a -> b
$ do
        NetworkActivity
na <- NetworkActivityVar -> STM NetworkActivity
forall a. TVar a -> STM a
readTVar NetworkActivityVar
nav

        let (Maybe RequestInfo
ret, Map Text RequestInfo
requests') = Text
-> Map Text RequestInfo
-> (RequestInfo -> RequestInfo)
-> (Maybe RequestInfo, Map Text RequestInfo)
forall k a. Ord k => k -> Map k a -> (a -> a) -> (Maybe a, Map k a)
adjustAndReturnNew Text
requestId (NetworkActivity -> Map Text RequestInfo
networkActivityRequests NetworkActivity
na) ((RequestInfo -> RequestInfo)
 -> (Maybe RequestInfo, Map Text RequestInfo))
-> (RequestInfo -> RequestInfo)
-> (Maybe RequestInfo, Map Text RequestInfo)
forall a b. (a -> b) -> a -> b
$ \RequestInfo
ri -> RequestInfo
ri {
              requestInfoResponseText = responseText
              , requestInfoCompleted = True
              }

        NetworkActivityVar
-> (NetworkActivity -> NetworkActivity) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar NetworkActivityVar
nav ((NetworkActivity -> NetworkActivity) -> STM ())
-> (NetworkActivity -> NetworkActivity) -> STM ()
forall a b. (a -> b) -> a -> b
$ \NetworkActivity
na' -> NetworkActivity
na' {
          networkActivityRequests = requests'
          , networkActivityLastActivityTime = now
          }

        Maybe RequestInfo -> STM (Maybe RequestInfo)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RequestInfo
ret

      Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN [i|BiDi: Network response completed: #{requestId} (#{maybe "<unknown>" requestInfoUrl maybeRequestInfo})|]
    Maybe (Text, Maybe Text)
Nothing -> Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logWarnN Text
"BiDi: Failed to parse network.responseCompleted event"

mkCallback NetworkActivityVar
nav (BiDiEvent Text
"event" Text
"network.fetchError" Value
params) = do
  case Value -> Maybe (Text, Text)
parseFetchError Value
params of
    Just (Text
requestId, Text
errorText) -> do
      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 RequestInfo
maybeRequestInfo <- STM (Maybe RequestInfo) -> m (Maybe RequestInfo)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe RequestInfo) -> m (Maybe RequestInfo))
-> STM (Maybe RequestInfo) -> m (Maybe RequestInfo)
forall a b. (a -> b) -> a -> b
$ do
        NetworkActivity
na <- NetworkActivityVar -> STM NetworkActivity
forall a. TVar a -> STM a
readTVar NetworkActivityVar
nav

        let (Maybe RequestInfo
ret, Map Text RequestInfo
requests') = Text
-> Map Text RequestInfo
-> (RequestInfo -> RequestInfo)
-> (Maybe RequestInfo, Map Text RequestInfo)
forall k a. Ord k => k -> Map k a -> (a -> a) -> (Maybe a, Map k a)
adjustAndReturnNew Text
requestId (NetworkActivity -> Map Text RequestInfo
networkActivityRequests NetworkActivity
na) ((RequestInfo -> RequestInfo)
 -> (Maybe RequestInfo, Map Text RequestInfo))
-> (RequestInfo -> RequestInfo)
-> (Maybe RequestInfo, Map Text RequestInfo)
forall a b. (a -> b) -> a -> b
$ \RequestInfo
ri -> RequestInfo
ri {
              requestInfoErrorText = Just errorText
              , requestInfoCompleted = True
              }

        NetworkActivityVar
-> (NetworkActivity -> NetworkActivity) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar NetworkActivityVar
nav ((NetworkActivity -> NetworkActivity) -> STM ())
-> (NetworkActivity -> NetworkActivity) -> STM ()
forall a b. (a -> b) -> a -> b
$ \NetworkActivity
na' -> NetworkActivity
na' {
          networkActivityRequests = requests'
          , networkActivityLastActivityTime = now
          }

        Maybe RequestInfo -> STM (Maybe RequestInfo)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RequestInfo
ret

      Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN [i|BiDi: Network fetch error: #{requestId} - #{errorText} (#{maybe "<unknown>" requestInfoUrl maybeRequestInfo})|]
    Maybe (Text, Text)
Nothing -> Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logWarnN Text
"BiDi: Failed to parse network.fetchError event"

mkCallback NetworkActivityVar
_nav BiDiEvent
x = Text -> m ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN [i|BiDi: Ignoring event: #{x}|]

parseBeforeRequestSent :: Value -> Maybe (RequestId, Text, Text, UTCTime, Maybe (Map Text Text))
parseBeforeRequestSent :: Value -> Maybe (Text, Text, Text, UTCTime, Maybe (Map Text Text))
parseBeforeRequestSent (Object Object
o) = case (Object
 -> Parser (Text, Text, Text, UTCTime, Maybe (Map Text Text)))
-> Object
-> Either String (Text, Text, Text, UTCTime, Maybe (Map Text Text))
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Object -> Parser (Text, Text, Text, UTCTime, Maybe (Map Text Text))
forall {a} {b} {c}.
(FromJSON a, FromJSON b, FromJSON c) =>
Object -> Parser (a, b, c, UTCTime, Maybe (Map Text Text))
parseRequest Object
o of
  Right (Text, Text, Text, UTCTime, Maybe (Map Text Text))
result -> (Text, Text, Text, UTCTime, Maybe (Map Text Text))
-> Maybe (Text, Text, Text, UTCTime, Maybe (Map Text Text))
forall a. a -> Maybe a
Just (Text, Text, Text, UTCTime, Maybe (Map Text Text))
result
  Left String
_ -> Maybe (Text, Text, Text, UTCTime, Maybe (Map Text Text))
forall a. Maybe a
Nothing
  where
    parseRequest :: Object -> Parser (a, b, c, UTCTime, Maybe (Map Text Text))
parseRequest Object
o' = do
      Object
request <- Object
o' Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"request"
      a
requestId <- Object
request Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"request"  -- The requestId is in request.request
      b
method <- Object
request Object -> Key -> Parser b
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"method"
      c
url <- Object
request Object -> Key -> Parser c
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"url"
      Integer
timestamp <- Object
o' Object -> Key -> Parser Integer
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"timestamp" :: Parser Integer
      Maybe (Map Text Text)
headers <- Parser Value -> Parser (Maybe Value)
forall a. Parser a -> Parser (Maybe a)
optional (Object
request Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"headers") Parser (Maybe Value)
-> (Maybe Value -> Parser (Maybe (Map Text Text)))
-> Parser (Maybe (Map Text Text))
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Value
headerList -> Map Text Text -> Maybe (Map Text Text)
forall a. a -> Maybe a
Just (Map Text Text -> Maybe (Map Text Text))
-> Parser (Map Text Text) -> Parser (Maybe (Map Text Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (Map Text Text)
parseHeaders Value
headerList
        Maybe Value
Nothing -> Maybe (Map Text Text) -> Parser (Maybe (Map Text Text))
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map Text Text)
forall a. Maybe a
Nothing
      let utcTime :: UTCTime
utcTime = POSIXTime -> UTCTime
posixSecondsToUTCTime (Integer -> POSIXTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac Integer
timestamp POSIXTime -> POSIXTime -> POSIXTime
forall a. Fractional a => a -> a -> a
/ POSIXTime
1000)
      (a, b, c, UTCTime, Maybe (Map Text Text))
-> Parser (a, b, c, UTCTime, Maybe (Map Text Text))
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
requestId, b
method, c
url, UTCTime
utcTime, Maybe (Map Text Text)
headers)
parseBeforeRequestSent Value
_ = Maybe (Text, Text, Text, UTCTime, Maybe (Map Text Text))
forall a. Maybe a
Nothing

parseResponseStarted :: Value -> Maybe (RequestId, Int, Maybe (Map Text Text))
parseResponseStarted :: Value -> Maybe (Text, Int, Maybe (Map Text Text))
parseResponseStarted (Object Object
o) = case (Object -> Parser (Text, Int, Maybe (Map Text Text)))
-> Object -> Either String (Text, Int, Maybe (Map Text Text))
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Object -> Parser (Text, Int, Maybe (Map Text Text))
forall {a} {b}.
(FromJSON a, FromJSON b) =>
Object -> Parser (a, b, Maybe (Map Text Text))
parseResponse Object
o of
  Right (Text, Int, Maybe (Map Text Text))
result -> (Text, Int, Maybe (Map Text Text))
-> Maybe (Text, Int, Maybe (Map Text Text))
forall a. a -> Maybe a
Just (Text, Int, Maybe (Map Text Text))
result
  Left String
_ -> Maybe (Text, Int, Maybe (Map Text Text))
forall a. Maybe a
Nothing
  where
    parseResponse :: Object -> Parser (a, b, Maybe (Map Text Text))
parseResponse Object
o' = do
      Object
request <- Object
o' Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"request"
      a
requestId <- Object
request Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"request"  -- The requestId is in request.request
      Object
response <- Object
o' Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"response"
      b
status <- Object
response Object -> Key -> Parser b
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"status"
      Maybe (Map Text Text)
headers <- Parser Value -> Parser (Maybe Value)
forall a. Parser a -> Parser (Maybe a)
optional (Object
response Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"headers") Parser (Maybe Value)
-> (Maybe Value -> Parser (Maybe (Map Text Text)))
-> Parser (Maybe (Map Text Text))
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Value
headerList -> Map Text Text -> Maybe (Map Text Text)
forall a. a -> Maybe a
Just (Map Text Text -> Maybe (Map Text Text))
-> Parser (Map Text Text) -> Parser (Maybe (Map Text Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (Map Text Text)
parseHeaders Value
headerList
        Maybe Value
Nothing -> Maybe (Map Text Text) -> Parser (Maybe (Map Text Text))
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Map Text Text)
forall a. Maybe a
Nothing
      (a, b, Maybe (Map Text Text))
-> Parser (a, b, Maybe (Map Text Text))
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
requestId, b
status, Maybe (Map Text Text)
headers)
parseResponseStarted Value
_ = Maybe (Text, Int, Maybe (Map Text Text))
forall a. Maybe a
Nothing

parseResponseCompleted :: Value -> Maybe (RequestId, Maybe Text)
parseResponseCompleted :: Value -> Maybe (Text, Maybe Text)
parseResponseCompleted (Object Object
o) = case (Object -> Parser (Text, Maybe Text))
-> Object -> Either String (Text, Maybe Text)
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Object -> Parser (Text, Maybe Text)
forall {a} {a}.
(FromJSON a, FromJSON a) =>
Object -> Parser (a, Maybe a)
parseResponse Object
o of
  Right (Text, Maybe Text)
result -> (Text, Maybe Text) -> Maybe (Text, Maybe Text)
forall a. a -> Maybe a
Just (Text, Maybe Text)
result
  Left String
_ -> Maybe (Text, Maybe Text)
forall a. Maybe a
Nothing
  where
    parseResponse :: Object -> Parser (a, Maybe a)
parseResponse Object
o' = do
      Object
request <- Object
o' Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"request"
      a
requestId <- Object
request Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"request"  -- The requestId is in request.request
      Maybe a
responseText <- Parser a -> Parser (Maybe a)
forall a. Parser a -> Parser (Maybe a)
optional (Object
o' Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"response" Parser Object -> (Object -> Parser Object) -> Parser Object
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"body") Parser Object -> (Object -> Parser a) -> Parser a
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value"))
      (a, Maybe a) -> Parser (a, Maybe a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
requestId, Maybe a
responseText)
parseResponseCompleted Value
_ = Maybe (Text, Maybe Text)
forall a. Maybe a
Nothing

parseFetchError :: Value -> Maybe (RequestId, Text)
parseFetchError :: Value -> Maybe (Text, Text)
parseFetchError (Object Object
o) = case (Object -> Parser (Text, Text))
-> Object -> Either String (Text, Text)
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Object -> Parser (Text, Text)
forall {a} {b}. (FromJSON a, FromJSON b) => Object -> Parser (a, b)
parseError Object
o of
  Right (Text, Text)
result -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text, Text)
result
  Left String
_ -> Maybe (Text, Text)
forall a. Maybe a
Nothing
  where
    parseError :: Object -> Parser (a, b)
parseError Object
o' = do
      Object
request <- Object
o' Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"request"
      a
requestId <- Object
request Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"request"  -- The requestId is in request.request
      b
errorText <- Object
o' Object -> Key -> Parser b
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"errorText"
      (a, b) -> Parser (a, b)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
requestId, b
errorText)
parseFetchError Value
_ = Maybe (Text, Text)
forall a. Maybe a
Nothing

parseHeaders :: Value -> Parser (Map Text Text)
parseHeaders :: Value -> Parser (Map Text Text)
parseHeaders (Array Array
headers) = do
  [(Text, Text)]
headerPairs <- (Value -> Parser (Text, Text)) -> [Value] -> Parser [(Text, Text)]
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 Value -> Parser (Text, Text)
forall {a}. FromJSON a => Value -> Parser (a, Text)
parseHeader (Array -> [Value]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
headers)
  Map Text Text -> Parser (Map Text Text)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Text Text -> Parser (Map Text Text))
-> Map Text Text -> Parser (Map Text Text)
forall a b. (a -> b) -> a -> b
$ [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text, Text)]
headerPairs
  where
    parseHeader :: Value -> Parser (a, Text)
parseHeader (Object Object
h) = do
      a
name <- Object
h Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
      Value
valueObj <- Object
h Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value"
      Text
value <- case Value
valueObj of
        Object Object
vo -> Object
vo Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"value"  -- Extract value from {type: "string", value: "..."}
        String Text
s -> Text -> Parser Text
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
s          -- Fallback for direct string values
        Value
_ -> String -> Parser Text
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid header value format"
      (a, Text) -> Parser (a, Text)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
name, Text
value)
    parseHeader Value
_ = String -> Parser (a, Text)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid header format"
parseHeaders Value
_ = String -> Parser (Map Text Text)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Headers should be an array"

optional :: Parser a -> Parser (Maybe a)
optional :: forall a. Parser a -> Parser (Maybe a)
optional Parser a
p = (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Parser a -> Parser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
p) Parser (Maybe a) -> Parser (Maybe a) -> Parser (Maybe a)
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe a -> Parser (Maybe a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

newNetworkActivityVar :: MonadIO m => m NetworkActivityVar
newNetworkActivityVar :: forall (m :: * -> *). MonadIO m => m NetworkActivityVar
newNetworkActivityVar = do
  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
  NetworkActivity -> m NetworkActivityVar
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (NetworkActivity -> m NetworkActivityVar)
-> NetworkActivity -> m NetworkActivityVar
forall a b. (a -> b) -> a -> b
$ Map Text RequestInfo -> UTCTime -> NetworkActivity
NetworkActivity Map Text RequestInfo
forall k a. Map k a
M.empty UTCTime
now

-- | Read the current network activity map.
readNetworkActivity :: MonadIO m => NetworkActivityVar -> m (Map RequestId RequestInfo)
readNetworkActivity :: forall (m :: * -> *).
MonadIO m =>
NetworkActivityVar -> m (Map Text RequestInfo)
readNetworkActivity NetworkActivityVar
nav = NetworkActivity -> Map Text RequestInfo
networkActivityRequests (NetworkActivity -> Map Text RequestInfo)
-> m NetworkActivity -> m (Map Text RequestInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetworkActivityVar -> m NetworkActivity
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO NetworkActivityVar
nav

-- | Wait for network to be idle (no pending requests).
waitForNetworkIdle :: MonadIO m => NetworkActivityVar -> m ()
waitForNetworkIdle :: forall (m :: * -> *). MonadIO m => NetworkActivityVar -> m ()
waitForNetworkIdle NetworkActivityVar
nav = STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  NetworkActivity
na <- NetworkActivityVar -> STM NetworkActivity
forall a. TVar a -> STM a
readTVar NetworkActivityVar
nav
  let pending :: [RequestInfo]
pending = (RequestInfo -> Bool) -> [RequestInfo] -> [RequestInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (RequestInfo -> Bool) -> RequestInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestInfo -> Bool
requestInfoCompleted) (Map Text RequestInfo -> [RequestInfo]
forall k a. Map k a -> [a]
M.elems (NetworkActivity -> Map Text RequestInfo
networkActivityRequests NetworkActivity
na))
  Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([RequestInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RequestInfo]
pending) STM ()
forall a. STM a
retry

-- | Wait for network to be idle with a delay after the last activity
-- This waits until:
--
-- 1. There are no outstanding requests AND
-- 2. No request has started or finished in the last time period given by the 'NominalDiffTime'.
waitForNetworkIdleForPeriod :: MonadIO m => NetworkActivityVar -> NominalDiffTime -> m ()
waitForNetworkIdleForPeriod :: forall (m :: * -> *).
MonadIO m =>
NetworkActivityVar -> POSIXTime -> m ()
waitForNetworkIdleForPeriod NetworkActivityVar
nav POSIXTime
idleTime = do
  UTCTime
lastActivityTime <- STM UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM UTCTime -> m UTCTime) -> STM UTCTime -> m UTCTime
forall a b. (a -> b) -> a -> b
$ do
    NetworkActivity
na <- NetworkActivityVar -> STM NetworkActivity
forall a. TVar a -> STM a
readTVar NetworkActivityVar
nav
    let pending :: [RequestInfo]
pending = (RequestInfo -> Bool) -> [RequestInfo] -> [RequestInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (RequestInfo -> Bool) -> RequestInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RequestInfo -> Bool
requestInfoCompleted) (Map Text RequestInfo -> [RequestInfo]
forall k a. Map k a -> [a]
M.elems (NetworkActivity -> Map Text RequestInfo
networkActivityRequests NetworkActivity
na))
    Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([RequestInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RequestInfo]
pending) STM ()
forall a. STM a
retry

    UTCTime -> STM UTCTime
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (NetworkActivity -> UTCTime
networkActivityLastActivityTime NetworkActivity
na)

  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
  let timeSinceLastActivity :: POSIXTime
timeSinceLastActivity = UTCTime -> UTCTime -> POSIXTime
diffUTCTime UTCTime
now UTCTime
lastActivityTime
  if | POSIXTime
timeSinceLastActivity POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
>= POSIXTime
idleTime ->
         () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     | Bool
otherwise -> do
         Int -> m ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int -> m ()) -> Int -> m ()
forall a b. (a -> b) -> a -> b
$ POSIXTime -> Int
nominalDiffTimeToMicroseconds (POSIXTime
idleTime POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
- POSIXTime
timeSinceLastActivity)
         NetworkActivityVar -> POSIXTime -> m ()
forall (m :: * -> *).
MonadIO m =>
NetworkActivityVar -> POSIXTime -> m ()
waitForNetworkIdleForPeriod NetworkActivityVar
nav POSIXTime
idleTime
  where
    nominalDiffTimeToMicroseconds :: NominalDiffTime -> Int
    nominalDiffTimeToMicroseconds :: POSIXTime -> Int
nominalDiffTimeToMicroseconds POSIXTime
t = POSIXTime -> Int
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime
t POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
1000000)

withWaitForNetworkIdleForPeriod :: (WebDriver m, MonadLogger m) => BiDiOptions -> NominalDiffTime -> m a -> m a
withWaitForNetworkIdleForPeriod :: forall (m :: * -> *) a.
(WebDriver m, MonadLogger m) =>
BiDiOptions -> POSIXTime -> m a -> m a
withWaitForNetworkIdleForPeriod BiDiOptions
biDiOptions POSIXTime
dt m a
action  = do
  BiDiOptions -> (NetworkActivityVar -> m a) -> m a
forall (m :: * -> *) a.
(WebDriver m, MonadLogger m) =>
BiDiOptions -> (NetworkActivityVar -> m a) -> m a
withRecordNetworkActivityViaBiDi BiDiOptions
biDiOptions ((NetworkActivityVar -> m a) -> m a)
-> (NetworkActivityVar -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \NetworkActivityVar
nav -> do
    a
ret <- m a
action
    NetworkActivityVar -> POSIXTime -> m ()
forall (m :: * -> *).
MonadIO m =>
NetworkActivityVar -> POSIXTime -> m ()
waitForNetworkIdleForPeriod NetworkActivityVar
nav POSIXTime
dt
    a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
ret

adjustAndReturnNew :: Ord k => k -> M.Map k a -> (a -> a) -> (Maybe a, M.Map k a)
adjustAndReturnNew :: forall k a. Ord k => k -> Map k a -> (a -> a) -> (Maybe a, Map k a)
adjustAndReturnNew k
k Map k a
m a -> a
f = (Maybe a -> (Maybe a, Maybe a))
-> k -> Map k a -> (Maybe a, Map k a)
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
M.alterF Maybe a -> (Maybe a, Maybe a)
alter k
k Map k a
m
  where
    alter :: Maybe a -> (Maybe a, Maybe a)
alter Maybe a
Nothing = (Maybe a
forall a. Maybe a
Nothing, Maybe a
forall a. Maybe a
Nothing)
    alter (Just a
v) = let v' :: a
v' = a -> a
f a
v in (a -> Maybe a
forall a. a -> Maybe a
Just a
v', a -> Maybe a
forall a. a -> Maybe a
Just a
v')