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 (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
import Network.Wai (requestMethod)

instance Controller ApiV2InteractionEventsController where

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

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

    -- POST /api/v2/interaction-events
    action ApiV2CreateInteractionEventAction = createApiInteractionEvent

listInteractionEvents :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ()
listInteractionEvents = 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

createApiInteractionEvent :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ()
createApiInteractionEvent = do
    consumer <- requireApiConsumer
    metadata <- metadataFromRequest
    let widgetIdText = paramOrNothing @Text "widgetId"
        eventType    = paramOrNothing @Text "eventType"
        viewContext  = paramOrNothing @Text "viewContext"

    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
                    respondWithStatus 201 (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, ?request :: Request) => IO A.Value
metadataFromRequest =
    case getHeader "Content-Type" of
        Just contentType | "application/json" `BS.isPrefixOf` contentType -> do
            body <- requestBodyJSON
            pure $ metadataParamOrEmpty (metadataFromJsonBody body)
        _ ->
            pure $ 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))