inter-hub-haskell/Web/Controller/Api/V2/Widgets.hs

module Web.Controller.Api.V2.Widgets where

import Web.Types
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Data.Aeson (Value, object, (.=))
import Network.Wai (requestMethod)
import qualified Data.UUID as UUID
import Application.Helper.TypeRegistry (validateWidgetType, validatePolicyScope)
import Web.Controller.Api.V2.Auth
    ( requireApiConsumer, paginatedResponse, getPageParams
    , respondWithStatus )

instance Controller ApiV2WidgetsController where

    action ApiV2IndexWidgetsAction = do
        case requestMethod ?request of
            "GET"  -> listWidgets
            "POST" -> createApiWidget
            _      -> respondWithStatus 405 $ object ["error" .= ("Method not allowed" :: Text)]

    action ApiV2ShowWidgetAction { widgetId } = do
        _consumer <- requireApiConsumer
        widget <- fetch widgetId
        renderJson (widgetToJson widget)

    action ApiV2CreateWidgetAction = createApiWidget

listWidgets :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ()
listWidgets = do
    _consumer <- requireApiConsumer
    (page, perPage) <- getPageParams
    let pageOffset = (page - 1) * perPage
    total   <- query @Widget |> fetchCount
    widgets <- query @Widget
        |> orderByDesc #createdAt
        |> limit perPage
        |> offset pageOffset
        |> fetch
    renderJson $ paginatedResponse (map widgetToJson widgets) page perPage total

createApiWidget :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ()
createApiWidget = do
    _consumer <- requireApiConsumer
    let hubIdText     = paramOrNothing @Text "hubId"
        name          = paramOrNothing @Text "name"
        widgetType    = paramOrNothing @Text "widgetType"
        capabilityRef = paramOrNothing @Text "capabilityRef"
        viewContext   = paramOrNothing @Text "viewContext"
        policyScope   = fromMaybe "internal" (nonEmptyText =<< paramOrNothing @Text "policyScope")
        status        = fromMaybe "active" (nonEmptyText =<< paramOrNothing @Text "status")

    let missing = missingWidgetCreateFields
            [ ("hubId", hubIdText)
            , ("name", name)
            , ("widgetType", widgetType)
            ]
    unless (null missing) do
        respondWithStatus 422 $ object
            [ "error"   .= ("Missing required fields" :: Text)
            , "missing" .= missing
            ]

    unless (validWidgetStatus status) do
        respondWithStatus 422 $ object
            [ "error" .= ("Unsupported widget status" :: Text)
            , "code"  .= ("unsupported_widget_status" :: Text)
            , "value" .= status
            , "valid" .= validWidgetStatuses
            ]

    let Just hubIdRaw  = hubIdText
        Just nameText  = name
        Just typeText  = widgetType

    typeResult <- liftIO $ validateWidgetType typeText
    case typeResult of
        Left _ -> respondWithStatus 422 $ object
            [ "error"    .= ("Unregistered widget type" :: Text)
            , "code"     .= ("unregistered_widget_type" :: Text)
            , "value"    .= typeText
            , "registry" .= ("/api/v2/widget-types" :: Text)
            ]
        Right () -> pure ()

    scopeResult <- liftIO $ validatePolicyScope policyScope
    case scopeResult of
        Left _ -> respondWithStatus 422 $ object
            [ "error"    .= ("Unregistered policy scope" :: Text)
            , "code"     .= ("unregistered_policy_scope" :: Text)
            , "value"    .= policyScope
            , "registry" .= ("/api/v2/policy-scopes" :: Text)
            ]
        Right () -> pure ()

    adapterSpecId <- parseOptionalAdapterSpecId

    case UUID.fromText hubIdRaw of
        Nothing -> respondWithStatus 422 $ object
            ["error" .= ("hubId must be a valid UUID" :: Text)]
        Just rawId -> do
            let hubId = Id rawId :: Id Hub
            mHub <- fetchOneOrNothing hubId
            case mHub of
                Nothing -> respondWithStatus 422 $ object
                    ["error" .= ("Hub not found" :: Text)]
                Just _hub -> do
                    widget <- newRecord @Widget
                        |> set #hubId hubId
                        |> set #name nameText
                        |> set #widgetType typeText
                        |> set #capabilityRef capabilityRef
                        |> set #viewContext viewContext
                        |> set #policyScope policyScope
                        |> set #status status
                        |> set #adapterSpecId adapterSpecId
                        |> createRecord
                    _version <- createInitialWidgetVersion widget
                    respondWithStatus 201 (widgetToJson widget)

parseOptionalAdapterSpecId :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO (Maybe (Id WidgetAdapterSpec))
parseOptionalAdapterSpecId =
    case paramOrNothing @Text "adapterSpecId" of
        Nothing -> pure Nothing
        Just "" -> pure Nothing
        Just adapterSpecRaw ->
            case UUID.fromText adapterSpecRaw of
                Nothing -> respondWithStatus 422 $ object
                    ["error" .= ("adapterSpecId must be a valid UUID" :: Text)]
                Just rawId -> do
                    let adapterSpecId = Id rawId :: Id WidgetAdapterSpec
                    mAdapterSpec <- fetchOneOrNothing adapterSpecId
                    case mAdapterSpec of
                        Nothing -> respondWithStatus 422 $ object
                            ["error" .= ("Widget adapter spec not found" :: Text)]
                        Just _ -> pure (Just adapterSpecId)

createInitialWidgetVersion :: (?modelContext :: ModelContext) => Widget -> IO WidgetVersion
createInitialWidgetVersion widget =
    newRecord @WidgetVersion
        |> set #widgetId widget.id
        |> set #version  1
        |> set #schemaSnapshot (widgetVersionSnapshot widget)
        |> createRecord

widgetVersionSnapshot :: Widget -> Value
widgetVersionSnapshot widget = 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
    ]

widgetToJson :: Widget -> Value
widgetToJson w = object
    [ "id"           .= w.id
    , "hubId"        .= w.hubId
    , "name"         .= w.name
    , "widgetType"   .= w.widgetType
    , "capabilityRef" .= w.capabilityRef
    , "viewContext"  .= w.viewContext
    , "policyScope"  .= w.policyScope
    , "status"       .= w.status
    , "version"      .= w.version
    , "createdAt"    .= w.createdAt
    ]

validWidgetStatuses :: [Text]
validWidgetStatuses = ["active", "deprecated", "draft"]

validWidgetStatus :: Text -> Bool
validWidgetStatus status = status `elem` validWidgetStatuses

missingWidgetCreateFields :: [(Text, Maybe Text)] -> [Text]
missingWidgetCreateFields fields =
    [ name | (name, value) <- fields, maybe True (== "") value ]

nonEmptyText :: Text -> Maybe Text
nonEmptyText "" = Nothing
nonEmptyText value = Just value