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

module Web.Controller.GovernanceTemplates where

import Web.Types
import Web.View.GovernanceTemplates.Index
import Web.View.GovernanceTemplates.Show
import Web.View.GovernanceTemplates.New
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Data.Aeson (Value(..), decode, encode, toJSON)
import qualified Data.ByteString.Lazy as LBS

instance Controller GovernanceTemplatesController where
    beforeAction = ensureIsUser

    -- List published templates with clone count
    action GovernanceTemplatesAction = autoRefresh do
        templates <- sqlQuery
            "SELECT gt.*, COUNT(gtc.id) AS clone_count \
            \ FROM governance_templates gt \
            \ LEFT JOIN governance_template_clones gtc ON gtc.governance_template_id = gt.id \
            \ WHERE gt.is_published = TRUE \
            \ GROUP BY gt.id \
            \ ORDER BY clone_count DESC, gt.name ASC"
            ()
        render IndexView { templates }

    -- Template detail with clone count
    action ShowGovernanceTemplateAction { governanceTemplateId } = do
        template   <- fetch governanceTemplateId
        hub        <- fetch template.hubId
        cloneCount <- sqlQueryScalar
            "SELECT COUNT(*) FROM governance_template_clones WHERE governance_template_id = ?"
            (Only governanceTemplateId)
        render ShowView { template, hub, cloneCount = fromMaybe 0 cloneCount }

    action NewGovernanceTemplateAction = do
        hubs <- query @Hub |> orderByAsc #name |> fetch
        categories <- sqlQuery
            "SELECT name, label FROM annotation_category_registry WHERE status = 'active' ORDER BY label"
            ()
        let template = newRecord @GovernanceTemplate
        render NewView { template, hubs, categories }

    action CreateGovernanceTemplateAction = do
        hubs <- query @Hub |> orderByAsc #name |> fetch
        categories <- sqlQuery
            "SELECT name, label FROM annotation_category_registry WHERE status = 'active' ORDER BY label"
            ()
        let template = newRecord @GovernanceTemplate
        let selectedCats = paramList @Text "categories"
        let templateBodyRaw = param @Text "templateBody"
        let mBody = decode (LBS.fromStrict (cs templateBodyRaw)) :: Maybe Value
        case mBody of
            Nothing -> do
                setErrorMessage "Template body must be valid JSON."
                render NewView { template, hubs, categories }
            Just bodyVal -> do
                -- Validate each selected category is in the registry
                mErrors <- validateCategories selectedCats
                case mErrors of
                    Left unknown -> do
                        setErrorMessage ("Unknown categories: " <> intercalate ", " unknown)
                        render NewView { template, hubs, categories }
                    Right () -> do
                        template
                            |> fill @'["hubId", "name", "description"]
                            |> set #categories (toJSON selectedCats)
                            |> set #templateBody bodyVal
                            |> set #isPublished False
                            |> validateField #name nonEmpty
                            |> validateField #hubId nonEmpty
                            |> ifValid \case
                                Left template -> render NewView { template, hubs, categories }
                                Right template -> do
                                    t <- createRecord template
                                    setSuccessMessage "Governance template created"
                                    redirectTo ShowGovernanceTemplateAction { governanceTemplateId = t.id }

    -- Clone template + manifest amendment if needed
    action CloneGovernanceTemplateAction { governanceTemplateId } = do
        template <- fetch governanceTemplateId
        hubId    <- getUserHubId
        existing <- query @GovernanceTemplateClone
            |> filterWhere (#governanceTemplateId, governanceTemplateId)
            |> filterWhere (#cloningHubId, hubId)
            |> fetchOneOrNothing
        case existing of
            Just _ -> do
                setSuccessMessage "Your hub has already cloned this template."
                redirectTo ShowGovernanceTemplateAction { governanceTemplateId }
            Nothing -> do
                newRecord @GovernanceTemplateClone
                    |> set #governanceTemplateId governanceTemplateId
                    |> set #cloningHubId hubId
                    |> createRecord
                -- Check if template categories are in hub's manifest
                mManifest <- query @HubCapabilityManifest
                    |> filterWhere (#hubId, hubId)
                    |> filterWhere (#status, "active")
                    |> fetchOneOrNothing
                let templateCats = jsonArrayTexts template.categories
                let existingCats = maybe [] (jsonArrayTexts . (.declaredAnnotationCategories)) mManifest
                let missingCats  = filter (`notElem` existingCats) templateCats
                if not (null missingCats)
                    then do
                        let newCats     = existingCats ++ missingCats
                        draft <- newRecord @HubCapabilityManifest
                            |> set #hubId hubId
                            |> set #status "draft"
                            |> set #declaredWidgetTypes
                                (maybe (toJSON ([] :: [Text])) (.declaredWidgetTypes) mManifest)
                            |> set #declaredEventTypes
                                (maybe (toJSON ([] :: [Text])) (.declaredEventTypes) mManifest)
                            |> set #declaredAnnotationCategories (toJSON newCats)
                            |> set #declaredPolicyScopes
                                (maybe (toJSON ([] :: [Text])) (.declaredPolicyScopes) mManifest)
                            |> createRecord
                        setSuccessMessage "Template cloned. A manifest amendment draft has been created for the new categories."
                        redirectTo ShowHubCapabilityManifestAction { hubCapabilityManifestId = draft.id }
                    else do
                        setSuccessMessage "Template cloned."
                        redirectTo ShowGovernanceTemplateAction { governanceTemplateId }

-- | Validate that all category names exist in the active annotation_category_registry.
validateCategories ::
    (?modelContext :: ModelContext) =>
    [Text] -> IO (Either [Text] ())
validateCategories cats = do
    registered <- sqlQuery
        "SELECT name FROM annotation_category_registry WHERE status = 'active'"
        ()
    let known   = map (\(Only n) -> n) (registered :: [Only Text])
    let unknown = filter (`notElem` known) cats
    pure $ if null unknown then Right () else Left unknown

-- | Resolve the hub for the current session (first hub fallback).
getUserHubId :: (?modelContext :: ModelContext, ?context :: ControllerContext) => IO (Id Hub)
getUserHubId = do
    hubs <- query @Hub |> limit 1 |> fetch
    case hubs of
        (h:_) -> pure h.id
        []    -> error "No hubs found"

-- | Extract text values from a JSONB array.
jsonArrayTexts :: Value -> [Text]
jsonArrayTexts val = case decode (encode val) of
    Just (arr :: [Text]) -> arr
    Nothing              -> []

intercalate :: Text -> [Text] -> Text
intercalate _ []     = ""
intercalate _ [x]    = x
intercalate sep (x:xs) = x <> sep <> intercalate sep xs