238 lines
12 KiB
Haskell
238 lines
12 KiB
Haskell
|
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
|