inter-hub/Web/Controller/Widgets.hs

module Web.Controller.Widgets where

import Web.Types
import Web.View.Widgets.Index
import Web.View.Widgets.Show
import Web.View.Widgets.New
import Web.View.Widgets.Edit
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Data.Aeson (toJSON, object, (.=))
import Application.Helper.Controller (isInRegression, widgetCycleCounts)

instance Controller WidgetsController where
    beforeAction = ensureIsUser

    action WidgetsAction = do
        widgets <- query @Widget |> orderByAsc #name |> fetch
        hubs    <- query @Hub    |> fetch
        render IndexView { widgets, hubs }

    action NewWidgetAction = do
        let widget = newRecord @Widget
        hubs <- query @Hub |> fetch
        render NewView { widget, hubs }

    action ShowWidgetAction { widgetId } = do
        widget   <- fetch widgetId
        hub      <- fetch widget.hubId
        versions <- query @WidgetVersion
            |> filterWhere (#widgetId, widgetId)
            |> orderByDesc #version
            |> fetch
        events   <- query @InteractionEvent
            |> filterWhere (#widgetId, widgetId)
            |> orderByDesc #occurredAt
            |> limit 20
            |> fetch
        annotations <- query @Annotation
            |> filterWhere (#widgetId, widgetId)
            |> orderByAsc #createdAt
            |> fetch
        recentSignals <- query @OutcomeSignal
            |> filterWhere (#widgetId, widgetId)
            |> orderByDesc #observedAt
            |> limit 10
            |> fetch
        allSignals <- query @OutcomeSignal
            |> filterWhere (#widgetId, widgetId)
            |> fetch
        let isRegressed = isInRegression allSignals annotations widgetId
        -- Recurrence cycle count for this widget
        allCandidates  <- query @RequirementCandidate |> filterWhere (#sourceWidgetId, widgetId) |> fetch
        allRequirements <- query @Requirement |> fetch
        allDecisions   <- query @DecisionRecord |> fetch
        allDeployments <- query @DeploymentRecord |> fetch
        let cycleCounts = widgetCycleCounts allCandidates allRequirements allDecisions allDeployments
            cycleCount  = fromMaybe 0 (lookup widgetId cycleCounts)
        render ShowView { widget, hub, versions, events, annotations, recentSignals, isRegressed, cycleCount }

    action CreateWidgetAction = do
        let widget = newRecord @Widget
        hubs <- query @Hub |> fetch
        widget
            |> fill @'["name", "widgetType", "hubId", "capabilityRef", "viewContext", "policyScope", "status"]
            |> validateField #name nonEmpty
            |> validateField #widgetType nonEmpty
            |> ifValid \case
                Left widget -> render NewView { widget, hubs }
                Right widget -> do
                    widget <- createRecord widget
                    let snapshot = object
                            [ "name"         .= widget.name
                            , "widget_type"  .= widget.widgetType
                            , "hub_id"       .= widget.hubId
                            , "capability_ref" .= widget.capabilityRef
                            , "view_context" .= widget.viewContext
                            , "policy_scope" .= widget.policyScope
                            , "status"       .= widget.status
                            , "version"      .= widget.version
                            ]
                    newRecord @WidgetVersion
                        |> set #widgetId widget.id
                        |> set #version  1
                        |> set #schemaSnapshot snapshot
                        |> createRecord
                    setSuccessMessage "Widget registered"
                    redirectTo ShowWidgetAction { widgetId = widget.id }

    action EditWidgetAction { widgetId } = do
        widget <- fetch widgetId
        hubs   <- query @Hub |> fetch
        render EditView { widget, hubs }

    action UpdateWidgetAction { widgetId } = do
        widget <- fetch widgetId
        hubs   <- query @Hub |> fetch
        widget
            |> fill @'["name", "widgetType", "hubId", "capabilityRef", "viewContext", "policyScope", "status"]
            |> validateField #name nonEmpty
            |> validateField #widgetType nonEmpty
            |> ifValid \case
                Left widget -> render EditView { widget, hubs }
                Right widget -> do
                    let newVersion = widget.version + 1
                    widget <- widget |> set #version newVersion |> updateRecord
                    let snapshot = object
                            [ "name"           .= widget.name
                            , "widget_type"    .= widget.widgetType
                            , "hub_id"         .= widget.hubId
                            , "capability_ref" .= widget.capabilityRef
                            , "view_context"   .= widget.viewContext
                            , "policy_scope"   .= widget.policyScope
                            , "status"         .= widget.status
                            , "version"        .= newVersion
                            ]
                    newRecord @WidgetVersion
                        |> set #widgetId widget.id
                        |> set #version  newVersion
                        |> set #schemaSnapshot snapshot
                        |> createRecord
                    setSuccessMessage "Widget updated"
                    redirectTo ShowWidgetAction { widgetId = widget.id }