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

module Web.Controller.TypeRegistries where

import Web.Types
import Web.View.TypeRegistries.WidgetTypes
import Web.View.TypeRegistries.EventTypes
import Web.View.TypeRegistries.AnnotationCategories
import Web.View.TypeRegistries.PolicyScopes
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude

instance Controller TypeRegistriesController where
    beforeAction = ensureIsUser

    -- ── Widget Types ─────────────────────────────────────────────────────────

    action WidgetTypeRegistryAction = do
        entries <- query @WidgetTypeRegistry
            |> orderByAsc #label_
            |> fetch
        hubs <- query @Hub |> fetch
        render WidgetTypesView { entries, hubs }

    action ShowWidgetTypeAction { widgetTypeRegistryId } = do
        entry <- fetch widgetTypeRegistryId
        mOwner <- case entry.ownerHubId of
            Nothing  -> pure Nothing
            Just hid -> fmap Just (fetch hid)
        render ShowWidgetTypeView { entry, mOwner }

    action NewWidgetTypeAction = do
        let entry = newRecord @WidgetTypeRegistry
        hubs <- query @Hub |> fetch
        render NewWidgetTypeView { entry, hubs }

    action CreateWidgetTypeAction = do
        let entry = newRecord @WidgetTypeRegistry
        hubs <- query @Hub |> fetch
        entry
            |> fill @'["name", "label_", "description", "ownerHubId"]
            |> validateField #name nonEmpty
            |> validateField #label_ nonEmpty
            |> ifValid \case
                Left entry -> render NewWidgetTypeView { entry, hubs }
                Right entry -> do
                    createRecord entry
                    setSuccessMessage ("Widget type '" <> entry.name <> "' registered")
                    redirectTo WidgetTypeRegistryAction

    action EditWidgetTypeAction { widgetTypeRegistryId } = do
        entry <- fetch widgetTypeRegistryId
        hubs <- query @Hub |> fetch
        render EditWidgetTypeView { entry, hubs }

    action UpdateWidgetTypeAction { widgetTypeRegistryId } = do
        entry <- fetch widgetTypeRegistryId
        hubs <- query @Hub |> fetch
        -- name is immutable after creation
        entry
            |> fill @'["label_", "description", "ownerHubId"]
            |> validateField #label_ nonEmpty
            |> ifValid \case
                Left entry -> render EditWidgetTypeView { entry, hubs }
                Right entry -> do
                    updateRecord entry
                    setSuccessMessage "Widget type updated"
                    redirectTo WidgetTypeRegistryAction

    action DeprecateWidgetTypeAction { widgetTypeRegistryId } = do
        entry <- fetch widgetTypeRegistryId
        let replacedBy = param @Text "deprecated_in_favour_of"
        when (null replacedBy) do
            setErrorMessage "You must specify the replacement type name"
            redirectTo WidgetTypeRegistryAction
        entry
            |> set #status "deprecated"
            |> set #deprecatedInFavourOf (Just replacedBy)
            |> updateRecord
        setSuccessMessage ("Widget type '" <> entry.name <> "' deprecated")
        redirectTo WidgetTypeRegistryAction

    -- ── Event Types ──────────────────────────────────────────────────────────

    action EventTypeRegistryAction = do
        entries <- query @EventTypeRegistry
            |> orderByAsc #label_
            |> fetch
        hubs <- query @Hub |> fetch
        render EventTypesView { entries, hubs }

    action ShowEventTypeAction { eventTypeRegistryId } = do
        entry <- fetch eventTypeRegistryId
        mOwner <- case entry.ownerHubId of
            Nothing  -> pure Nothing
            Just hid -> fmap Just (fetch hid)
        render ShowEventTypeView { entry, mOwner }

    action NewEventTypeAction = do
        let entry = newRecord @EventTypeRegistry
        hubs <- query @Hub |> fetch
        render NewEventTypeView { entry, hubs }

    action CreateEventTypeAction = do
        let entry = newRecord @EventTypeRegistry
        hubs <- query @Hub |> fetch
        entry
            |> fill @'["name", "label_", "description", "ownerHubId"]
            |> validateField #name nonEmpty
            |> validateField #label_ nonEmpty
            |> ifValid \case
                Left entry -> render NewEventTypeView { entry, hubs }
                Right entry -> do
                    createRecord entry
                    setSuccessMessage ("Event type '" <> entry.name <> "' registered")
                    redirectTo EventTypeRegistryAction

    action EditEventTypeAction { eventTypeRegistryId } = do
        entry <- fetch eventTypeRegistryId
        hubs <- query @Hub |> fetch
        render EditEventTypeView { entry, hubs }

    action UpdateEventTypeAction { eventTypeRegistryId } = do
        entry <- fetch eventTypeRegistryId
        hubs <- query @Hub |> fetch
        entry
            |> fill @'["label_", "description", "ownerHubId"]
            |> validateField #label_ nonEmpty
            |> ifValid \case
                Left entry -> render EditEventTypeView { entry, hubs }
                Right entry -> do
                    updateRecord entry
                    setSuccessMessage "Event type updated"
                    redirectTo EventTypeRegistryAction

    action DeprecateEventTypeAction { eventTypeRegistryId } = do
        entry <- fetch eventTypeRegistryId
        let replacedBy = param @Text "deprecated_in_favour_of"
        when (null replacedBy) do
            setErrorMessage "You must specify the replacement type name"
            redirectTo EventTypeRegistryAction
        entry
            |> set #status "deprecated"
            |> set #deprecatedInFavourOf (Just replacedBy)
            |> updateRecord
        setSuccessMessage ("Event type '" <> entry.name <> "' deprecated")
        redirectTo EventTypeRegistryAction

    -- ── Annotation Categories ────────────────────────────────────────────────

    action AnnotationCategoryRegistryAction = do
        entries <- query @AnnotationCategoryRegistry
            |> orderByAsc #label_
            |> fetch
        hubs <- query @Hub |> fetch
        render AnnotationCategoriesView { entries, hubs }

    action ShowAnnotationCategoryAction { annotationCategoryRegistryId } = do
        entry <- fetch annotationCategoryRegistryId
        mOwner <- case entry.ownerHubId of
            Nothing  -> pure Nothing
            Just hid -> fmap Just (fetch hid)
        render ShowAnnotationCategoryView { entry, mOwner }

    action NewAnnotationCategoryAction = do
        let entry = newRecord @AnnotationCategoryRegistry
        hubs <- query @Hub |> fetch
        render NewAnnotationCategoryView { entry, hubs }

    action CreateAnnotationCategoryAction = do
        let entry = newRecord @AnnotationCategoryRegistry
        hubs <- query @Hub |> fetch
        entry
            |> fill @'["name", "label_", "description", "ownerHubId"]
            |> validateField #name nonEmpty
            |> validateField #label_ nonEmpty
            |> ifValid \case
                Left entry -> render NewAnnotationCategoryView { entry, hubs }
                Right entry -> do
                    createRecord entry
                    setSuccessMessage ("Annotation category '" <> entry.name <> "' registered")
                    redirectTo AnnotationCategoryRegistryAction

    action EditAnnotationCategoryAction { annotationCategoryRegistryId } = do
        entry <- fetch annotationCategoryRegistryId
        hubs <- query @Hub |> fetch
        render EditAnnotationCategoryView { entry, hubs }

    action UpdateAnnotationCategoryAction { annotationCategoryRegistryId } = do
        entry <- fetch annotationCategoryRegistryId
        hubs <- query @Hub |> fetch
        entry
            |> fill @'["label_", "description", "ownerHubId"]
            |> validateField #label_ nonEmpty
            |> ifValid \case
                Left entry -> render EditAnnotationCategoryView { entry, hubs }
                Right entry -> do
                    updateRecord entry
                    setSuccessMessage "Annotation category updated"
                    redirectTo AnnotationCategoryRegistryAction

    action DeprecateAnnotationCategoryAction { annotationCategoryRegistryId } = do
        entry <- fetch annotationCategoryRegistryId
        let replacedBy = param @Text "deprecated_in_favour_of"
        when (null replacedBy) do
            setErrorMessage "You must specify the replacement category name"
            redirectTo AnnotationCategoryRegistryAction
        entry
            |> set #status "deprecated"
            |> set #deprecatedInFavourOf (Just replacedBy)
            |> updateRecord
        setSuccessMessage ("Annotation category '" <> entry.name <> "' deprecated")
        redirectTo AnnotationCategoryRegistryAction

    -- ── Policy Scopes ────────────────────────────────────────────────────────

    action PolicyScopeRegistryAction = do
        entries <- query @PolicyScopeRegistry
            |> orderByAsc #label_
            |> fetch
        hubs <- query @Hub |> fetch
        render PolicyScopesView { entries, hubs }

    action ShowPolicyScopeAction { policyScopeRegistryId } = do
        entry <- fetch policyScopeRegistryId
        mOwner <- case entry.ownerHubId of
            Nothing  -> pure Nothing
            Just hid -> fmap Just (fetch hid)
        render ShowPolicyScopeView { entry, mOwner }

    action NewPolicyScopeAction = do
        let entry = newRecord @PolicyScopeRegistry
        hubs <- query @Hub |> fetch
        render NewPolicyScopeView { entry, hubs }

    action CreatePolicyScopeAction = do
        let entry = newRecord @PolicyScopeRegistry
        hubs <- query @Hub |> fetch
        entry
            |> fill @'["name", "label_", "description", "ownerHubId"]
            |> validateField #name nonEmpty
            |> validateField #label_ nonEmpty
            |> ifValid \case
                Left entry -> render NewPolicyScopeView { entry, hubs }
                Right entry -> do
                    createRecord entry
                    setSuccessMessage ("Policy scope '" <> entry.name <> "' registered")
                    redirectTo PolicyScopeRegistryAction

    action EditPolicyScopeAction { policyScopeRegistryId } = do
        entry <- fetch policyScopeRegistryId
        hubs <- query @Hub |> fetch
        render EditPolicyScopeView { entry, hubs }

    action UpdatePolicyScopeAction { policyScopeRegistryId } = do
        entry <- fetch policyScopeRegistryId
        hubs <- query @Hub |> fetch
        entry
            |> fill @'["label_", "description", "ownerHubId"]
            |> validateField #label_ nonEmpty
            |> ifValid \case
                Left entry -> render EditPolicyScopeView { entry, hubs }
                Right entry -> do
                    updateRecord entry
                    setSuccessMessage "Policy scope updated"
                    redirectTo PolicyScopeRegistryAction

    action DeprecatePolicyScopeAction { policyScopeRegistryId } = do
        entry <- fetch policyScopeRegistryId
        let replacedBy = param @Text "deprecated_in_favour_of"
        when (null replacedBy) do
            setErrorMessage "You must specify the replacement scope name"
            redirectTo PolicyScopeRegistryAction
        entry
            |> set #status "deprecated"
            |> set #deprecatedInFavourOf (Just replacedBy)
            |> updateRecord
        setSuccessMessage ("Policy scope '" <> entry.name <> "' deprecated")
        redirectTo PolicyScopeRegistryAction