inter-hub/Web/Controller/HubCapabilityManifests.hs

module Web.Controller.HubCapabilityManifests where

import Web.Types
import Web.View.HubCapabilityManifests.Index
import Web.View.HubCapabilityManifests.Show
import Web.View.HubCapabilityManifests.New
import Web.View.HubCapabilityManifests.Edit
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Data.Aeson (Value, Array, decode, encode, toJSON)
import qualified Data.Vector as V
import Data.Maybe (mapMaybe)
import Control.Monad (void)

instance Controller HubCapabilityManifestsController where
    beforeAction = ensureIsUser

    action HubCapabilityManifestsAction = autoRefresh do
        manifests <- query @HubCapabilityManifest
            |> orderByDesc #createdAt
            |> fetch
        hubs <- query @Hub |> fetch
        render IndexView { manifests, hubs }

    action ShowHubCapabilityManifestAction { hubCapabilityManifestId } = do
        manifest <- fetch hubCapabilityManifestId
        hub      <- fetch manifest.hubId
        render ShowView { manifest, hub }

    action NewHubCapabilityManifestAction = do
        let mHubId = paramOrNothing @(Id Hub) "hubId"
        hubs   <- query @Hub |> orderByAsc #name |> fetch
        let manifest = newRecord @HubCapabilityManifest
        case mHubId of
            Just hubId -> do
                -- Check if a manifest already exists for this hub
                existing <- query @HubCapabilityManifest
                    |> filterWhere (#hubId, hubId)
                    |> fetchOneOrNothing
                case existing of
                    Just m -> redirectTo EditHubCapabilityManifestAction { hubCapabilityManifestId = m.id }
                    Nothing -> render NewView { manifest = manifest |> set #hubId hubId, hubs }
            Nothing -> render NewView { manifest, hubs }

    action CreateHubCapabilityManifestAction = do
        hubs <- query @Hub |> orderByAsc #name |> fetch
        let manifest = newRecord @HubCapabilityManifest
        manifest
            |> fill @'["hubId", "manifestVersion", "capabilityDescription", "contact"]
            |> set #status "draft"
            |> validateField #hubId nonEmpty
            |> ifValid \case
                Left manifest -> render NewView { manifest, hubs }
                Right manifest -> do
                    manifest <- createRecord manifest
                    setSuccessMessage "Capability manifest created (draft)"
                    redirectTo EditHubCapabilityManifestAction { hubCapabilityManifestId = manifest.id }

    action EditHubCapabilityManifestAction { hubCapabilityManifestId } = do
        manifest <- fetch hubCapabilityManifestId
        hub      <- fetch manifest.hubId
        widgetTypeEntries    <- sqlQuery "SELECT * FROM widget_type_registry WHERE status = 'active' ORDER BY label ASC" ()
        eventTypeEntries     <- sqlQuery "SELECT * FROM event_type_registry WHERE status = 'active' ORDER BY label ASC" ()
        categoryEntries      <- sqlQuery "SELECT * FROM annotation_category_registry WHERE status = 'active' ORDER BY label ASC" ()
        policyScopeEntries   <- sqlQuery "SELECT * FROM policy_scope_registry WHERE status = 'active' ORDER BY label ASC" ()
        render EditView { manifest, hub, widgetTypeEntries, eventTypeEntries, categoryEntries, policyScopeEntries }

    action UpdateHubCapabilityManifestAction { hubCapabilityManifestId } = do
        manifest <- fetch hubCapabilityManifestId
        hub      <- fetch manifest.hubId
        widgetTypeEntries    <- sqlQuery "SELECT * FROM widget_type_registry WHERE status = 'active' ORDER BY label ASC" ()
        eventTypeEntries     <- sqlQuery "SELECT * FROM event_type_registry WHERE status = 'active' ORDER BY label ASC" ()
        categoryEntries      <- sqlQuery "SELECT * FROM annotation_category_registry WHERE status = 'active' ORDER BY label ASC" ()
        policyScopeEntries   <- sqlQuery "SELECT * FROM policy_scope_registry WHERE status = 'active' ORDER BY label ASC" ()
        when (manifest.status == "active") do
            setErrorMessage "Active manifests are read-only. Retire the current manifest and create a new draft to amend."
            redirectTo ShowHubCapabilityManifestAction { hubCapabilityManifestId }
        manifest
            |> fill @'["manifestVersion", "capabilityDescription", "contact"]
            |> set #declaredWidgetTypes        (toJSON (paramList @Text "declaredWidgetTypes"))
            |> set #declaredEventTypes         (toJSON (paramList @Text "declaredEventTypes"))
            |> set #declaredAnnotationCategories (toJSON (paramList @Text "declaredAnnotationCategories"))
            |> set #declaredPolicyScopes       (toJSON (paramList @Text "declaredPolicyScopes"))
            |> ifValid \case
                Left manifest -> render EditView { manifest, hub, widgetTypeEntries, eventTypeEntries, categoryEntries, policyScopeEntries }
                Right manifest -> do
                    updateRecord manifest
                    setSuccessMessage "Manifest updated"
                    redirectTo EditHubCapabilityManifestAction { hubCapabilityManifestId }

    action ActivateManifestAction { hubCapabilityManifestId } = do
        manifest <- fetch hubCapabilityManifestId
        hub      <- fetch manifest.hubId

        -- Collect declared type names from JSONB arrays
        let wTypes  = jsonArrayTexts manifest.declaredWidgetTypes
            eTypes  = jsonArrayTexts manifest.declaredEventTypes
            cats    = jsonArrayTexts manifest.declaredAnnotationCategories
            scopes  = jsonArrayTexts manifest.declaredPolicyScopes

        -- Conflict detection: check that each declared name is either
        -- unregistered or already owned by this hub.
        conflicts <- fmap concat $ mapM (checkConflict "widget_type_registry" hub.id) wTypes
        eConflicts <- fmap concat $ mapM (checkConflict "event_type_registry" hub.id) eTypes
        cConflicts <- fmap concat $ mapM (checkConflict "annotation_category_registry" hub.id) cats
        pConflicts <- fmap concat $ mapM (checkConflict "policy_scope_registry" hub.id) scopes
        let allConflicts = conflicts <> eConflicts <> cConflicts <> pConflicts

        if not (null allConflicts)
            then do
                setErrorMessage ("Activation blocked — type name conflicts: " <> intercalate ", " allConflicts)
                redirectTo ShowHubCapabilityManifestAction { hubCapabilityManifestId }
            else do
                -- Register declared types (idempotent — skip if already present)
                mapM_ (upsertType "widget_type_registry" hub.id) wTypes
                mapM_ (upsertType "event_type_registry" hub.id) eTypes
                mapM_ (upsertType "annotation_category_registry" hub.id) cats
                mapM_ (upsertType "policy_scope_registry" hub.id) scopes
                now <- getCurrentTime
                manifest |> set #status "active" |> set #activatedAt (Just now) |> updateRecord
                setSuccessMessage "Manifest activated — all declared types are now registered"
                redirectTo ShowHubCapabilityManifestAction { hubCapabilityManifestId }

    action RetireManifestAction { hubCapabilityManifestId } = do
        manifest <- fetch hubCapabilityManifestId
        manifest |> set #status "retired" |> updateRecord
        setSuccessMessage "Manifest retired. Types remain in registry but this manifest is no longer current."
        redirectTo HubCapabilityManifestsAction

-- | Extract text values from a JSONB array (e.g. '["foo","bar"]').
jsonArrayTexts :: Value -> [Text]
jsonArrayTexts val = case val of
    _ -> case decode (encode val) of
        Just (arr :: Array) -> mapMaybe extractText (V.toList arr)
        Nothing -> []
  where
    extractText (String t) = Just t
    extractText _          = Nothing

-- | Check if 'name' in 'tableName' is owned by a different hub.
--   Returns [] if no conflict, or [error message] if conflict.
checkConflict ::
    (?modelContext :: ModelContext) =>
    Text -> Id Hub -> Text -> IO [Text]
checkConflict tableName hubId name = do
    rows <- sqlQuery
        (fromString $ cs ("SELECT owner_hub_id FROM " <> tableName <> " WHERE name = ?"))
        (Only name)
    case rows of
        [] -> pure []
        [Only Nothing] -> pure []  -- framework-level, no owner conflict
        [Only (Just ownerId)] ->
            if ownerId == hubId
                then pure []
                else pure ["Type '" <> name <> "' in " <> tableName <> " is already owned by another hub"]
        _ -> pure []

-- | Insert a type name into the registry table if it doesn't exist.
upsertType ::
    (?modelContext :: ModelContext) =>
    Text -> Id Hub -> Text -> IO ()
upsertType tableName hubId name =
    void $ sqlExec
        (fromString $ cs ("INSERT INTO " <> tableName <> " (name, label, owner_hub_id, status) "
         <> "VALUES (?, ?, ?, 'active') ON CONFLICT (name) DO NOTHING"))
        (name, name, hubId)