107 lines
4.4 KiB
Haskell
107 lines
4.4 KiB
Haskell
|
module Web.Controller.Widgets where
|
||
|
|
|
||
|
|
import Web.Types
|
||
|
|
import Web.View.Widgets.Index
|
||
|
|
import Web.View.Widgets.Show
|
||
|
|
import Web.View.Widgets.New
|
||
|
|
import Web.View.Widgets.Edit
|
||
|
|
import Generated.Types
|
||
|
|
import IHP.Prelude
|
||
|
|
import IHP.ControllerPrelude
|
||
|
|
import Data.Aeson (toJSON, object, (.=))
|
||
|
|
|
||
|
|
instance Controller WidgetsController where
|
||
|
|
beforeAction = ensureIsUser
|
||
|
|
|
||
|
|
action WidgetsAction = do
|
||
|
|
widgets <- query @Widget |> orderByAsc #name |> fetch
|
||
|
|
hubs <- query @Hub |> fetch
|
||
|
|
render IndexView { widgets, hubs }
|
||
|
|
|
||
|
|
action NewWidgetAction = do
|
||
|
|
let widget = newRecord @Widget
|
||
|
|
hubs <- query @Hub |> fetch
|
||
|
|
render NewView { widget, hubs }
|
||
|
|
|
||
|
|
action ShowWidgetAction { widgetId } = do
|
||
|
|
widget <- fetch widgetId
|
||
|
|
hub <- fetch widget.hubId
|
||
|
|
versions <- query @WidgetVersion
|
||
|
|
|> filterWhere (#widgetId, widgetId)
|
||
|
|
|> orderByDesc #version
|
||
|
|
|> fetch
|
||
|
|
events <- query @InteractionEvent
|
||
|
|
|> filterWhere (#widgetId, widgetId)
|
||
|
|
|> orderByDesc #occurredAt
|
||
|
|
|> limit 20
|
||
|
|
|> fetch
|
||
|
|
annotations <- query @Annotation
|
||
|
|
|> filterWhere (#widgetId, widgetId)
|
||
|
|
|> orderByAsc #createdAt
|
||
|
|
|> fetch
|
||
|
|
render ShowView { widget, hub, versions, events, annotations }
|
||
|
|
|
||
|
|
action CreateWidgetAction = do
|
||
|
|
let widget = newRecord @Widget
|
||
|
|
hubs <- query @Hub |> fetch
|
||
|
|
widget
|
||
|
|
|> fill @'["name", "widgetType", "hubId", "capabilityRef", "viewContext", "policyScope", "status"]
|
||
|
|
|> validateField #name nonEmpty
|
||
|
|
|> validateField #widgetType nonEmpty
|
||
|
|
|> ifValid \case
|
||
|
|
Left widget -> render NewView { widget, hubs }
|
||
|
|
Right widget -> do
|
||
|
|
widget <- createRecord widget
|
||
|
|
let snapshot = object
|
||
|
|
[ "name" .= widget.name
|
||
|
|
, "widget_type" .= widget.widgetType
|
||
|
|
, "hub_id" .= widget.hubId
|
||
|
|
, "capability_ref" .= widget.capabilityRef
|
||
|
|
, "view_context" .= widget.viewContext
|
||
|
|
, "policy_scope" .= widget.policyScope
|
||
|
|
, "status" .= widget.status
|
||
|
|
, "version" .= widget.version
|
||
|
|
]
|
||
|
|
newRecord @WidgetVersion
|
||
|
|
|> set #widgetId widget.id
|
||
|
|
|> set #version 1
|
||
|
|
|> set #schemaSnapshot snapshot
|
||
|
|
|> createRecord
|
||
|
|
setSuccessMessage "Widget registered"
|
||
|
|
redirectTo ShowWidgetAction { widgetId = widget.id }
|
||
|
|
|
||
|
|
action EditWidgetAction { widgetId } = do
|
||
|
|
widget <- fetch widgetId
|
||
|
|
hubs <- query @Hub |> fetch
|
||
|
|
render EditView { widget, hubs }
|
||
|
|
|
||
|
|
action UpdateWidgetAction { widgetId } = do
|
||
|
|
widget <- fetch widgetId
|
||
|
|
hubs <- query @Hub |> fetch
|
||
|
|
widget
|
||
|
|
|> fill @'["name", "widgetType", "hubId", "capabilityRef", "viewContext", "policyScope", "status"]
|
||
|
|
|> validateField #name nonEmpty
|
||
|
|
|> validateField #widgetType nonEmpty
|
||
|
|
|> ifValid \case
|
||
|
|
Left widget -> render EditView { widget, hubs }
|
||
|
|
Right widget -> do
|
||
|
|
let newVersion = widget.version + 1
|
||
|
|
widget <- widget |> set #version newVersion |> updateRecord
|
||
|
|
let snapshot = object
|
||
|
|
[ "name" .= widget.name
|
||
|
|
, "widget_type" .= widget.widgetType
|
||
|
|
, "hub_id" .= widget.hubId
|
||
|
|
, "capability_ref" .= widget.capabilityRef
|
||
|
|
, "view_context" .= widget.viewContext
|
||
|
|
, "policy_scope" .= widget.policyScope
|
||
|
|
, "status" .= widget.status
|
||
|
|
, "version" .= newVersion
|
||
|
|
]
|
||
|
|
newRecord @WidgetVersion
|
||
|
|
|> set #widgetId widget.id
|
||
|
|
|> set #version newVersion
|
||
|
|
|> set #schemaSnapshot snapshot
|
||
|
|
|> createRecord
|
||
|
|
setSuccessMessage "Widget updated"
|
||
|
|
redirectTo ShowWidgetAction { widgetId = widget.id }
|