inter-hub-haskell/Web/Controller/HubRoutingRules.hs

module Web.Controller.HubRoutingRules where

import Web.Types
import Web.View.HubRoutingRules.Index
import Web.View.HubRoutingRules.Show
import Web.View.HubRoutingRules.New
import Web.View.HubRoutingRules.Edit
import Web.View.HubRoutingRules.RoutedCandidates
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Application.Helper.RoutingEngine (applyRoutingRules)
import Application.Helper.TypeRegistry (validateWidgetType, validateAnnotationCategory)

instance Controller HubRoutingRulesController where
    beforeAction = ensureIsUser

    action HubRoutingRulesAction = autoRefresh do
        rules <- query @HubRoutingRule |> orderByDesc #priority |> fetch
        hubs  <- query @Hub |> fetch
        render IndexView { rules, hubs }

    action ShowHubRoutingRuleAction { hubRoutingRuleId } = do
        rule      <- fetch hubRoutingRuleId
        sourceHub <- fetch rule.sourceHubId
        targetHub <- fetch rule.targetHubId
        render ShowView { rule, sourceHub, targetHub }

    action NewHubRoutingRuleAction = do
        let rule = newRecord @HubRoutingRule
        hubs <- query @Hub |> orderByAsc #name |> fetch
        render NewView { rule, hubs }

    action CreateHubRoutingRuleAction = do
        let rule = newRecord @HubRoutingRule
        hubs <- query @Hub |> orderByAsc #name |> fetch
        let mMatchWidgetType = paramOrNothing @Text "matchWidgetType"
            mMatchCategory   = paramOrNothing @Text "matchCategory"
        wtResult  <- case mMatchWidgetType of { Nothing -> pure (Right ()); Just "" -> pure (Right ()); Just t -> liftIO (validateWidgetType t) }
        catResult <- case mMatchCategory   of { Nothing -> pure (Right ()); Just "" -> pure (Right ()); Just c -> liftIO (validateAnnotationCategory c) }
        rule
            |> fill @'["sourceHubId","targetHubId","matchCategory","matchWidgetType","priority","notes"]
            |> validateField #sourceHubId nonEmpty
            |> validateField #targetHubId nonEmpty
            |> (case wtResult  of { Left msg -> attachFailure #matchWidgetType msg; Right () -> \x -> x })
            |> (case catResult of { Left msg -> attachFailure #matchCategory msg;   Right () -> \x -> x })
            |> ifValid \case
                Left r  -> render NewView { rule = r, hubs }
                Right r -> do
                    r <- createRecord r
                    setSuccessMessage "Routing rule created"
                    redirectTo ShowHubRoutingRuleAction { hubRoutingRuleId = r.id }

    action EditHubRoutingRuleAction { hubRoutingRuleId } = do
        rule <- fetch hubRoutingRuleId
        hubs <- query @Hub |> orderByAsc #name |> fetch
        render EditView { rule, hubs }

    action UpdateHubRoutingRuleAction { hubRoutingRuleId } = do
        rule <- fetch hubRoutingRuleId
        hubs <- query @Hub |> orderByAsc #name |> fetch
        let mMatchWidgetType = paramOrNothing @Text "matchWidgetType"
            mMatchCategory   = paramOrNothing @Text "matchCategory"
        wtResult  <- case mMatchWidgetType of { Nothing -> pure (Right ()); Just "" -> pure (Right ()); Just t -> liftIO (validateWidgetType t) }
        catResult <- case mMatchCategory   of { Nothing -> pure (Right ()); Just "" -> pure (Right ()); Just c -> liftIO (validateAnnotationCategory c) }
        rule
            |> fill @'["matchCategory","matchWidgetType","priority","notes"]
            |> (case wtResult  of { Left msg -> attachFailure #matchWidgetType msg; Right () -> \x -> x })
            |> (case catResult of { Left msg -> attachFailure #matchCategory msg;   Right () -> \x -> x })
            |> ifValid \case
                Left r  -> render EditView { rule = r, hubs }
                Right r -> do
                    updateRecord r
                    setSuccessMessage "Routing rule updated"
                    redirectTo ShowHubRoutingRuleAction { hubRoutingRuleId = r.id }

    action ActivateRoutingRuleAction { hubRoutingRuleId } = do
        rule <- fetch hubRoutingRuleId
        rule |> set #status "active" |> updateRecord
        setSuccessMessage "Rule activated"
        redirectTo HubRoutingRulesAction

    action DeactivateRoutingRuleAction { hubRoutingRuleId } = do
        rule <- fetch hubRoutingRuleId
        rule |> set #status "inactive" |> updateRecord
        setSuccessMessage "Rule deactivated"
        redirectTo HubRoutingRulesAction

    action RoutedCandidatesAction { hubId } = autoRefresh do
        hub        <- fetch hubId
        candidates <- query @RequirementCandidate
            |> filterWhere (#routedToHubId, Just hubId)
            |> orderByDesc #createdAt
            |> fetch
        render RoutedCandidatesView { hub, candidates }

    action RouteNowAction { requirementCandidateId } = do
        candidate <- fetch requirementCandidateId
        widgets   <- query @Widget |> fetch
        _         <- applyRoutingRules candidate widgets
        setSuccessMessage "Routing re-evaluated"
        redirectTo ShowRequirementCandidateAction { requirementCandidateId }