NetworkEventDemos.hs

module BiDi.Demos.NetworkEventDemos where

import BiDi.Actions (BiDiActions (..))
import BiDi.DemoUtils
import IOUtils (DemoActions (..))
import TestServerAPI (authTestUrl, malformedResponseUrl, testServerHomeUrl, withTestServer)
import WebDriverPreCore.BiDi.Protocol
  ( ContextTarget (..),
    Evaluate (..),
    KnownCommand (..), 
    KnownSubscriptionType (..),
    Navigate (..),
    Target (..),
    URL (..),
    mkCommand,
  )
import Prelude hiding (log, putStrLn)

-- >>> runDemo networkEventRequestResponseLifecycle
-- *** Exception: user error (Timeout - Expected event did not fire: NetworkResponseStarted after 10000 milliseconds)
networkEventRequestResponseLifecycle :: BiDiDemo
networkEventRequestResponseLifecycle =
  demo "Network Events - Complete Request/Response Lifecycle" action
  where
    action :: DemoActions -> BiDiActions -> IO ()
    action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do
      logTxt "Subscribe to all network lifecycle events"

      (beforeReqEventFired, waitBeforeReqEventFired) <- timeLimitLog NetworkBeforeRequestSent
      subscribeNetworkBeforeRequestSent beforeReqEventFired

      (respStartedEventFired, waitRespStartedEventFired) <- timeLimitLog NetworkResponseStarted
      subscribeNetworkResponseStarted respStartedEventFired

      (respCompletedEventFired, waitNetworkResponseCompletedEventFired) <- timeLimitLog NetworkResponseCompleted
      subscribeNetworkResponseCompleted respCompletedEventFired

      bc <- rootContext utils bidi

      withTestServer $ do
        logTxt "Trigger network request to demonstrate complete network lifecycle"
        scriptEvaluate $
          MkEvaluate
            { expression = "fetch('" <> testServerHomeUrl <> "')",
              target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing},
              awaitPromise = False,
              resultOwnership = Nothing,
              serializationOptions = Nothing
            }
        logTxt "Waiting for all network lifecycle events..."

        sequence_
          [ waitBeforeReqEventFired,
            waitRespStartedEventFired,
            waitNetworkResponseCompletedEventFired
          ]

-- >>> runDemo networkEventFetchError
networkEventFetchError :: BiDiDemo
networkEventFetchError =
  demo "Network Events - Fetch Error" action
  where
    action :: DemoActions -> BiDiActions -> IO ()
    action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do
      withTestServer $ do
        logTxt "Subscribe to FetchError event"
        (fetchErrorEventFired, waitFetchErrorEventFired) <- timeLimitLog NetworkFetchError
        subscribeNetworkFetchError fetchErrorEventFired

        (manyFetchErrorEventFired, waitManyFetchErrorEventFired) <- timeLimitLogMany NetworkFetchError
        subscribeMany [NetworkFetchError] manyFetchErrorEventFired

        bc <- rootContext utils bidi

        logTxt "Trigger fetch error using invalid URL"
        scriptEvaluate $
          MkEvaluate
            { expression = "fetch('" <> malformedResponseUrl <> "')",
              target = ContextTarget $ MkContextTarget {context = bc, sandbox = Nothing},
              awaitPromise = False,
              resultOwnership = Nothing,
              serializationOptions = Nothing
            }
        logTxt "Waiting for fetch error events..."

        sequence_
          [ waitFetchErrorEventFired,
            waitManyFetchErrorEventFired
          ]

-- >>> runDemo networkEventAuthRequired
-- *** Exception: user error (Timeout - Expected event did not fire: NetworkAuthRequired after 10000 milliseconds)
networkEventAuthRequired :: BiDiDemo
networkEventAuthRequired =
  demo "Network Events - Auth Required (requires auth-protected URL)" action
  where
    action :: DemoActions -> BiDiActions -> IO ()
    action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do
      logTxt "Subscribe to AuthRequired event"
      (authReqEventFired, waitAuthReqEventFired) <- timeLimitLog NetworkAuthRequired
      subscribeNetworkAuthRequired authReqEventFired

      (manyAuthReqEventFired, waitManyAuthReqEventFired) <- timeLimitLogMany NetworkAuthRequired
      subscribeMany [NetworkAuthRequired] manyAuthReqEventFired

      bc <- rootContext utils bidi

      logTxt "Navigate to auth-protected URL to trigger AuthRequired event"

      withTestServer $ do
        logTxt "Waiting for auth required events..."

        sendCommandNoWait . mkCommand BrowsingContextNavigate $ MkNavigate {context = bc, url = MkUrl authTestUrl, wait = Nothing}
        
        pause

        sequence_
          [ waitAuthReqEventFired,
            waitManyAuthReqEventFired
          ]