FallbackDemos.hs

module BiDi.Demos.FallbackDemos where

import BiDi.Actions (BiDiActions (..))
import BiDi.DemoUtils
import Const (seconds)
import Data.Aeson (Value (..), FromJSON)
import Data.Aeson.KeyMap qualified as KM
import IOUtils (DemoActions (..))
import TestData (contentPageUrl)
import WebDriverPreCore.BiDi.API qualified as API
import WebDriverPreCore.BiDi.Protocol
    ( JSUInt(MkJSUInt),
      BrowsingContext(MkBrowsingContext),
      OffSpecSubscriptionType(MkOffSpecSubscriptionType),
      URL(..),
      GetTree(..), Navigate(..),
      coerceCommand,
      extendLoosenCommand,
      loosenCommand,
      mkOffSpecCommand )
import Utils (txt)
import Prelude hiding (log, putStrLn)
import GHC.Generics (Generic)

-- >>> runDemo fallbackExtendCommandDemo
fallbackExtendCommandDemo :: BiDiDemo
fallbackExtendCommandDemo =
  demo "Fallback - Extend Navigate Command with Extra Property" action
  where
    action :: DemoActions -> BiDiActions -> IO ()
    action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do
      bc <- rootContext utils bidi
      url <- contentPageUrl

      logTxt "Demo 1: Navigate using typed command with extension"
      logTxt "Creating Navigate command with extra 'customProperty' field"
      
      let navigateCmd = API.browsingContextNavigate $ MkNavigate
            { context = bc,
              url,
              wait = Nothing
            }
      
          extraProps = KM.fromList [("customProperty", String "this will be ignored by the driver")]
          extendedCmd = extendLoosenCommand extraProps navigateCmd
      
      logShow "Extended command (with extra property)" extendedCmd
      pause

      logTxt "Sending extended navigate command..."
      result <- sendCommand' (MkJSUInt 100) extendedCmd
      logShow "Navigation result" result
      pause


-- >>> runDemo fallbackOffSpecCommandDemo
fallbackOffSpecCommandDemo :: BiDiDemo
fallbackOffSpecCommandDemo =
  demo "Fallback - Navigate Using mkAnyCommand with Raw Object" action
  where
    action :: DemoActions -> BiDiActions -> IO ()
    action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do
      bc <- rootContext utils bidi
      url <- contentPageUrl

      logTxt "Demo 2: Navigate using mkAnyCommand with raw Aeson Object"
      logTxt "Constructing navigation parameters manually as JSON object"
      
      let MkBrowsingContext contextId = bc
          navParams = KM.fromList
            [ ("context", String contextId),
              ("url", String url.url),
              ("customProperty", String "this will also be ignored by the driver")
            ]
      
          unknownNav = mkOffSpecCommand "browsingContext.navigate" navParams
      
      logShow "Any command (raw object)" unknownNav
      logShowM "Unknown navigate result" $ sendCommand unknownNav
      pause

      logTxt "Sending command via sendAnyCommand'..."
      resultObj <- sendOffSpecCommand' (MkJSUInt 101) "browsingContext.navigate" navParams 
      
      logShow "Navigation result object" resultObj
      pause

newtype GetTreeResultContextOnly = MkGetTreeResultContextOnly
  { contexts :: [ContextOnly]
  }
  deriving stock (Show, Eq, Generic)

instance FromJSON GetTreeResultContextOnly

data ContextOnly = MkContextOnly
  { 
    context :: BrowsingContext
  }
  deriving (Show, Eq, Generic)

instance FromJSON ContextOnly

-- >>> runDemo fallbackCommandCoercionsDemo
fallbackCommandCoercionsDemo :: BiDiDemo
fallbackCommandCoercionsDemo =
  demo "Fallback - Command Coercions" action
  where
    action :: DemoActions -> BiDiActions -> IO ()
    action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do
      bc <- rootContext utils bidi
      url <- contentPageUrl

      logTxt "Navigate using typed command"
      browsingContextNavigate $ MkNavigate {context = bc, url, wait = Nothing}
      pause

      logTxt "Return a different type with compatible JSON (coerceCommand)"
      logShowM 
        "Get tree result - coerced to JSON compatible GetTreeResultContextOnly" 
          $ sendCommand . coerceCommand @_ @GetTreeResultContextOnly $ API.browsingContextGetTree (MkGetTree Nothing Nothing)
      pause

      logTxt "Return Value rather than GetTreeResult (loosenCommand)"
      treeVal <- sendCommand . loosenCommand $ API.browsingContextGetTree (MkGetTree Nothing Nothing)
      logShow "Get tree result - as Value" treeVal
      pause

-- >>> runDemo fallbackSubscribeUnknownEventDemo
fallbackSubscribeUnknownEventDemo :: BiDiDemo
fallbackSubscribeUnknownEventDemo =
  demo "Fallback - Subscribe to Navigation Event Using Unknown Subscription" action
  where
    action :: DemoActions -> BiDiActions -> IO ()
    action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do
      bc <- rootContext utils bidi
      url <- contentPageUrl

      logTxt "Demo 3: Subscribe to browsingContext.navigationStarted using subscribeUnknownMany"
      logTxt "This demonstrates subscribing to events as unknown types"
      
      let unknownEventType = MkOffSpecSubscriptionType "browsingContext.navigationStarted"
      
      (unknownEventFired, waitUnknownEventFired) <- timeLimitLog' "navigationStarted (unknown subscription)" (10 * seconds) unknownEventType
      
      subId <- subscribeUnknownMany
        [unknownEventType]
        unknownEventFired
      
      logShow "Subscription ID" subId
      pause

      logTxt "Navigating to trigger the event..."
      navResult <- browsingContextNavigate $ MkNavigate
        { context = bc,
          url = url,
          wait = Nothing
        }
      logShow "Navigation result" navResult
      pause

      logTxt "Waiting for event to be received..."
      waitUnknownEventFired

      logTxt "Unsubscribing from unknown event"
      unsubscribe subId
      pause

-- >>> runDemo fallbackSubscribeUnknownEventFilteredDemo
fallbackSubscribeUnknownEventFilteredDemo :: BiDiDemo
fallbackSubscribeUnknownEventFilteredDemo =
  demo "Fallback - Subscribe to Navigation Event with Context Filter" action
  where
    action :: DemoActions -> BiDiActions -> IO ()
    action utils@MkDemoActions {..} bidi@MkBiDiActions {..} = do
      bc <- rootContext utils bidi
      url <- contentPageUrl

      logTxt "Demo 4: Subscribe using subscribeUnknownMany' with context filtering"
      logTxt "Creating a second browsing context for comparison"
      
      bc2 <- newWindowContext utils bidi
      pause

      logTxt $ "Subscribing to navigationStarted events ONLY for first context: " <> txt bc
      let unknownEventType = MkOffSpecSubscriptionType "browsingContext.navigationStarted"
      
      (unknownEventFired, waitUnknownEventFired) <- timeLimitLog' "navigationStarted (filtered unknown subscription)" (10 * seconds) unknownEventType
      
      subId <- subscribeUnknownMany'
        [bc]  -- Only subscribe for first context
        []    -- No user context filter
        [unknownEventType]
        unknownEventFired
      
      logShow "Subscription ID" subId
      pause

      logTxt $ "Navigating in FIRST context (should trigger event): " <> txt bc
      navResult1 <- browsingContextNavigate $ MkNavigate
        { context = bc,
          url = url,
          wait = Nothing
        }
      logShow "Navigation result (first context)" navResult1
      
      logTxt "Waiting for event..."
      waitUnknownEventFired

      logTxt $ "Navigating in SECOND context (should NOT trigger event): " <> txt bc2
      navResult2 <- browsingContextNavigate $ MkNavigate
        { context = bc2,
          url = url,
          wait = Nothing
        }
      logShow "Navigation result (second context)" navResult2
      pause

      logTxt "Unsubscribing from filtered unknown event"
      unsubscribe subId