inter-hub/Web/Controller/WidgetPatterns.hs

module Web.Controller.WidgetPatterns where

import Web.Types
import Web.View.WidgetPatterns.Index
import Web.View.WidgetPatterns.Show
import Web.View.WidgetPatterns.New
import Web.View.WidgetPatterns.Edit
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Data.Aeson (decode, encode, object, (.=))
import qualified Data.ByteString.Lazy as LBS

instance Controller WidgetPatternsController where
    beforeAction = ensureIsUser

    -- List all published patterns with adopter count
    action WidgetPatternsAction = autoRefresh do
        patterns <- sqlQuery
            "SELECT wp.*, \
            \       COUNT(pa.id) AS adopter_count, \
            \       MAX(wpv.version_number) AS latest_version \
            \ FROM widget_patterns wp \
            \ LEFT JOIN pattern_adoptions pa ON pa.widget_pattern_id = wp.id \
            \ LEFT JOIN widget_pattern_versions wpv ON wpv.widget_pattern_id = wp.id \
            \ WHERE wp.is_published = TRUE \
            \ GROUP BY wp.id \
            \ ORDER BY adopter_count DESC, wp.name ASC"
            ()
        render IndexView { patterns }

    -- Detail with version history and aggregate adoption stats (T07)
    action ShowWidgetPatternAction { widgetPatternId } = do
        pattern <- fetch widgetPatternId
        hub     <- fetch pattern.hubId
        versions <- query @WidgetPatternVersion
            |> filterWhere (#widgetPatternId, widgetPatternId)
            |> orderByDesc #versionNumber
            |> fetch
        adopterCount <- sqlQueryScalar
            "SELECT COUNT(*) FROM pattern_adoptions WHERE widget_pattern_id = ?"
            (Only widgetPatternId)
        anonCount <- sqlQueryScalar
            "SELECT COUNT(*) FROM pattern_adoptions WHERE widget_pattern_id = ? AND is_anonymous = TRUE"
            (Only widgetPatternId)
        -- Aggregate friction/outcome from non-anonymous adopter hubs
        aggStats <- sqlQuery
            "SELECT \
            \    AVG(fs.score) AS mean_friction_score, \
            \    COUNT(DISTINCT os.id) AS outcome_signal_count \
            \ FROM pattern_adoptions pa \
            \ JOIN widgets w \
            \     ON w.hub_id = pa.adopting_hub_id \
            \     AND w.widget_type = ? \
            \ LEFT JOIN friction_scores fs ON fs.widget_id = w.id \
            \ LEFT JOIN outcome_signals os ON os.widget_id = w.id \
            \ WHERE pa.widget_pattern_id = ? \
            \   AND pa.is_anonymous = FALSE"
            (pattern.widgetType, widgetPatternId)
        let (mFriction, outcomeCount) = case (aggStats :: [(Maybe Double, Int)]) of
                [(f, o)] -> (f, o)
                _        -> (Nothing, 0)
        render ShowView
            { pattern, hub, versions
            , adopterCount    = fromMaybe 0 adopterCount
            , anonCount       = fromMaybe 0 anonCount
            , meanFriction    = mFriction
            , outcomeCount
            }

    action NewWidgetPatternAction = do
        hubs <- query @Hub |> orderByAsc #name |> fetch
        widgetTypes <- sqlQuery "SELECT name, label FROM widget_type_registry WHERE status = 'active' ORDER BY label" ()
        let pattern = newRecord @WidgetPattern
        render NewView { pattern, hubs, widgetTypes }

    action CreateWidgetPatternAction = do
        hubs <- query @Hub |> orderByAsc #name |> fetch
        widgetTypes <- sqlQuery "SELECT name, label FROM widget_type_registry WHERE status = 'active' ORDER BY label" ()
        let pattern = newRecord @WidgetPattern
        pattern
            |> fill @'["hubId", "name", "description", "widgetType"]
            |> set #isPublished False
            |> set #isCrossHub False
            |> validateField #name nonEmpty
            |> validateField #hubId nonEmpty
            |> validateField #widgetType nonEmpty
            |> ifValid \case
                Left pattern -> render NewView { pattern, hubs, widgetTypes }
                Right pattern -> do
                    -- Determine cross-hub: is widget_type owned by a different hub?
                    typeOwner <- sqlQuery
                        "SELECT owner_hub_id FROM widget_type_registry WHERE name = ?"
                        (Only pattern.widgetType)
                    let isCross = case (typeOwner :: [(Maybe (Id Hub))]) of
                            [Just ownerId] -> ownerId /= pattern.hubId
                            _              -> False
                    pattern <- pattern |> set #isCrossHub isCross |> createRecord
                    setSuccessMessage "Pattern created"
                    redirectTo EditWidgetPatternAction { widgetPatternId = pattern.id }

    action EditWidgetPatternAction { widgetPatternId } = do
        pattern <- fetch widgetPatternId
        hubs <- query @Hub |> orderByAsc #name |> fetch
        widgetTypes <- sqlQuery "SELECT name, label FROM widget_type_registry WHERE status = 'active' ORDER BY label" ()
        render EditView { pattern, hubs, widgetTypes }

    action UpdateWidgetPatternAction { widgetPatternId } = do
        pattern <- fetch widgetPatternId
        hubs <- query @Hub |> orderByAsc #name |> fetch
        widgetTypes <- sqlQuery "SELECT name, label FROM widget_type_registry WHERE status = 'active' ORDER BY label" ()
        when pattern.isPublished do
            setErrorMessage "Published patterns are read-only. Version it instead."
            redirectTo ShowWidgetPatternAction { widgetPatternId }
        pattern
            |> fill @'["name", "description"]
            |> validateField #name nonEmpty
            |> ifValid \case
                Left pattern -> render EditView { pattern, hubs, widgetTypes }
                Right pattern -> do
                    updateRecord pattern
                    setSuccessMessage "Pattern updated"
                    redirectTo ShowWidgetPatternAction { widgetPatternId }

    -- Publish: set is_published = True, create version 1
    action PublishWidgetPatternAction { widgetPatternId } = do
        pattern <- fetch widgetPatternId
        when pattern.isPublished do
            setErrorMessage "Pattern is already published."
            redirectTo ShowWidgetPatternAction { widgetPatternId }
        now <- getCurrentTime
        pattern |> set #isPublished True |> updateRecord
        let definition = object [ "name" .= pattern.name
                                 , "widgetType" .= pattern.widgetType
                                 , "description" .= pattern.description
                                 ]
        newRecord @WidgetPatternVersion
            |> set #widgetPatternId widgetPatternId
            |> set #versionNumber 1
            |> set #definition definition
            |> set #changelog (Just "Initial publication")
            |> createRecord
        setSuccessMessage "Pattern published (v1)"
        redirectTo ShowWidgetPatternAction { widgetPatternId }

    -- Publish a new version (T04)
    action PublishNewVersionAction { widgetPatternId } = do
        pattern <- fetch widgetPatternId
        unless pattern.isPublished do
            setErrorMessage "Publish the pattern first before versioning."
            redirectTo ShowWidgetPatternAction { widgetPatternId }
        latestVersion <- query @WidgetPatternVersion
            |> filterWhere (#widgetPatternId, widgetPatternId)
            |> orderByDesc #versionNumber
            |> limit 1
            |> fetchOneOrNothing
        let nextNum = maybe 1 (\v -> v.versionNumber + 1) latestVersion
        let definitionJson = case param @Text "definition" of
                raw -> fromMaybe (object []) (decode (LBS.fromStrict (cs raw)))
        let changelog = paramOrNothing @Text "changelog"
        newRecord @WidgetPatternVersion
            |> set #widgetPatternId widgetPatternId
            |> set #versionNumber nextNum
            |> set #definition definitionJson
            |> set #changelog changelog
            |> createRecord
        setSuccessMessage ("Published version " <> tshow nextNum)
        redirectTo ShowWidgetPatternAction { widgetPatternId }

    -- Adopt pattern — creates PatternAdoption (see T05 for amendment logic)
    action AdoptPatternAction { widgetPatternId } = do
        pattern <- fetch widgetPatternId
        hubId   <- getUserHubId
        existing <- query @PatternAdoption
            |> filterWhere (#widgetPatternId, widgetPatternId)
            |> filterWhere (#adoptingHubId, hubId)
            |> fetchOneOrNothing
        case existing of
            Just _ -> do
                setSuccessMessage "Your hub has already adopted this pattern."
                redirectTo ShowWidgetPatternAction { widgetPatternId }
            Nothing -> do
                let isAnon = paramOrDefault @Bool False "isAnonymous"
                adoption <- newRecord @PatternAdoption
                    |> set #widgetPatternId widgetPatternId
                    |> set #adoptingHubId hubId
                    |> set #isAnonymous isAnon
                    |> createRecord
                -- Check if pattern's widget_type is in the hub's active manifest
                mManifest <- query @HubCapabilityManifest
                    |> filterWhere (#hubId, hubId)
                    |> filterWhere (#status, "active")
                    |> fetchOneOrNothing
                let needsAmendment = case mManifest of
                        Nothing -> True
                        Just m  -> not (pattern.widgetType `elem` jsonArrayTexts m.declaredWidgetTypes)
                if needsAmendment
                    then do
                        -- Create a draft manifest amendment
                        let existingTypes = maybe [] (jsonArrayTexts . (.declaredWidgetTypes)) mManifest
                        let newTypes = existingTypes ++ [pattern.widgetType]
                        let newTypesJson = toJSON newTypes
                        draft <- newRecord @HubCapabilityManifest
                            |> set #hubId hubId
                            |> set #status "draft"
                            |> set #declaredWidgetTypes newTypesJson
                            |> set #declaredEventTypes
                                (maybe (toJSON ([] :: [Text])) (.declaredEventTypes) mManifest)
                            |> set #declaredAnnotationCategories
                                (maybe (toJSON ([] :: [Text])) (.declaredAnnotationCategories) mManifest)
                            |> set #declaredPolicyScopes
                                (maybe (toJSON ([] :: [Text])) (.declaredPolicyScopes) mManifest)
                            |> createRecord
                        setSuccessMessage "Pattern adopted. A manifest amendment draft has been created — please review and activate it."
                        redirectTo ShowHubCapabilityManifestAction { hubCapabilityManifestId = draft.id }
                    else do
                        setSuccessMessage "Pattern adopted."
                        redirectTo ShowWidgetPatternAction { widgetPatternId }

-- | Get the hub ID associated with the logged-in user.
--   Falls back to the first hub if no per-user association exists.
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 — cannot determine adopting hub"

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

-- | Convert a list to a JSON Value.
toJSON :: [Text] -> Value
toJSON ts = Data.Aeson.toJSON ts