inter-hub-haskell/Application/Helper/RoutingEngine.hs

module Application.Helper.RoutingEngine where

import IHP.Prelude
import IHP.ModelSupport
import IHP.QueryBuilder
import IHP.Fetch
import Generated.Types
import Web.Routes ()

-- | Apply active routing rules to a RequirementCandidate.
-- Finds the highest-priority matching active rule for the candidate's hub
-- and sets routed_to_hub_id. Returns the updated candidate.
applyRoutingRules
    :: (?modelContext :: ModelContext)
    => RequirementCandidate
    -> [Widget]        -- to resolve widget_type for the source widget
    -> IO RequirementCandidate
applyRoutingRules candidate widgets = do
    rules <- query @HubRoutingRule
        |> filterWhere (#status, "active")
        |> orderByDesc #priority
        |> fetch
    -- Find the hub of the source widget
    let mWidget    = find (\w -> w.id == candidate.sourceWidgetId) widgets
        widgetType = maybe Nothing (\w -> Just w.widgetType) mWidget
    let matchingRule = find (ruleMatches candidate.category widgetType) rules
    case matchingRule of
        Nothing   -> pure candidate
        Just rule -> do
            candidate
                |> set #routedToHubId (Just rule.targetHubId)
                |> updateRecord

-- | A rule matches if:
--   - source hub matches candidate's source widget's hub
--   - match_category is null OR equals candidate category
--   - match_widget_type is null OR equals widget type
ruleMatches :: Text -> Maybe Text -> HubRoutingRule -> Bool
ruleMatches category mWidgetType rule =
    categoryMatch && widgetTypeMatch
  where
    categoryMatch   = isNothing rule.matchCategory
                   || rule.matchCategory == Just category
    widgetTypeMatch = isNothing rule.matchWidgetType
                   || (isJust mWidgetType && rule.matchWidgetType == mWidgetType)