inter-hub/Web/Controller/Api/V2/InteractionEvents.hs

module Web.Controller.Api.V2.InteractionEvents where

import Web.Types
import Generated.Types
import IHP.Prelude
import IHP.ControllerPrelude
import Data.Aeson (Value(..), object, (.=))
import IHP.ControllerSupport (ControllerContext, getHeader, requestBodyJSON)
import Web.Controller.Api.V2.Auth
    ( requireApiConsumer, paginatedResponse, getPageParams
    , respondWithStatus )
import Application.Helper.TypeRegistry (validateEventType)
import Web.Job.WebhookDeliveryJob (dispatchWebhooks)
import Control.Concurrent (forkIO)
import Control.Monad (void)
import Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy.Char8 as LBSC
import qualified Data.UUID as UUID
import qualified Data.Aeson as A
import qualified Data.Vector as V

instance Controller ApiV2InteractionEventsController where

    action ApiV2IndexInteractionEventsAction = do
        _consumer <- requireApiConsumer
        (page, perPage) <- getPageParams
        let mWidgetId  = paramOrNothing @(Id Widget) "widgetId"
            mEventType = paramOrNothing @Text "eventType"
        let off = (page - 1) * perPage
        let baseQ = query @InteractionEvent
                |> orderByDesc #occurredAt
        let q1 = case mWidgetId  of
                    Just wId -> baseQ |> filterWhere (#widgetId, wId)
                    Nothing  -> baseQ
        let q2 = case mEventType of
                    Just et  -> q1 |> filterWhere (#eventType, et)
                    Nothing  -> q1
        total  <- q2 |> fetchCount
        events <- q2 |> limit perPage |> offset off |> fetch
        renderJson $ paginatedResponse (map eventToJson events) page perPage total

    action ApiV2ShowInteractionEventAction { interactionEventId } = do
        _consumer <- requireApiConsumer
        event <- fetch interactionEventId
        renderJson (eventToJson event)

    -- POST /api/v2/interaction-events
    action ApiV2CreateInteractionEventAction = do
        consumer <- requireApiConsumer
        let widgetIdText = paramOrNothing @Text "widgetId"
            eventType    = paramOrNothing @Text "eventType"
            viewContext  = paramOrNothing @Text "viewContext"
            metadata     = metadataFromRequest

        let missing = catMaybes
                [ if isNothing widgetIdText then Just ("widgetId" :: Text) else Nothing
                , if isNothing eventType    then Just "eventType"           else Nothing
                ]
        unless (null missing) do
            respondWithStatus 422 $ object
                [ "error"   .= ("Missing required fields" :: Text)
                , "missing" .= missing
                ]

        let Just wIdText = widgetIdText
            Just evType  = eventType

        -- Validate against event_type_registry
        evResult <- liftIO $ validateEventType evType
        case evResult of
            Left _ -> respondWithStatus 422 $ object
                [ "error"    .= ("Unregistered event type" :: Text)
                , "code"     .= ("unregistered_event_type" :: Text)
                , "value"    .= evType
                , "registry" .= ("/api/v2/event-types" :: Text)
                ]
            Right () -> pure ()

        -- If consumer has a manifest, also validate against declared_event_types
        forM_ consumer.hubCapabilityManifestId $ \manifestId -> do
            manifest <- fetch manifestId
            when (manifest.status == "active") do
                unless (manifestAllowsEvent evType manifest.declaredEventTypes) do
                    respondWithStatus 422 $ object
                        [ "error" .= ("Event type not declared in hub manifest" :: Text)
                        , "code"  .= ("event_type_not_in_manifest" :: Text)
                        , "value" .= evType
                        ]

        case UUID.fromText wIdText of
            Nothing -> respondWithStatus 422 $ object
                ["error" .= ("widgetId must be a valid UUID" :: Text)]
            Just rawId -> do
                let wId = Id rawId :: Id Widget
                mWidget <- fetchOneOrNothing wId
                case mWidget of
                    Nothing -> respondWithStatus 422 $ object
                        ["error" .= ("Widget not found" :: Text)]
                    Just _widget -> do
                        event <- newRecord @InteractionEvent
                            |> set #widgetId wId
                            |> set #eventType evType
                            |> set #actorType "api"
                            |> set #viewContextRef viewContext
                            |> set #metadata metadata
                            |> createRecord
                        -- Dispatch webhooks fire-and-forget
                        let webhookPayload = object
                                [ "event"      .= ("interaction_event.created" :: Text)
                                , "resourceId" .= event.id
                                , "widgetId"   .= event.widgetId
                                , "eventType"  .= event.eventType
                                , "occurredAt" .= event.occurredAt
                                ]
                        liftIO $ void $ forkIO $ dispatchWebhooks evType webhookPayload
                        renderJson (eventToJson event)

eventToJson :: InteractionEvent -> Value
eventToJson e = object
    [ "id"             .= e.id
    , "widgetId"       .= e.widgetId
    , "eventType"      .= e.eventType
    , "actorId"        .= e.actorId
    , "actorType"      .= e.actorType
    , "viewContextRef" .= e.viewContextRef
    , "metadata"       .= e.metadata
    , "occurredAt"     .= e.occurredAt
    ]

declaredEventTypeNames :: A.Value -> [Text]
declaredEventTypeNames (Array values) = mapMaybe extractText (V.toList values)
  where
    extractText (String value) = Just value
    extractText _              = Nothing
declaredEventTypeNames _ = []

manifestAllowsEvent :: Text -> A.Value -> Bool
manifestAllowsEvent eventType declaredEventTypes =
    let declared = declaredEventTypeNames declaredEventTypes
    in null declared || eventType `elem` declared

metadataParamOrEmpty :: Maybe A.Value -> A.Value
metadataParamOrEmpty = fromMaybe (object [])

metadataFromRequest :: (?context :: ControllerContext) => A.Value
metadataFromRequest =
    case getHeader "Content-Type" of
        Just contentType | "application/json" `BS.isPrefixOf` contentType ->
            metadataParamOrEmpty (metadataFromJsonBody requestBodyJSON)
        _ ->
            metadataParamOrEmpty (metadataFromText =<< paramOrNothing @Text "metadata")

metadataFromJsonBody :: A.Value -> Maybe A.Value
metadataFromJsonBody (Object body) = KM.lookup "metadata" body
metadataFromJsonBody _             = Nothing

metadataFromText :: Text -> Maybe A.Value
metadataFromText raw = A.decode (LBSC.pack (cs raw))