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