From a2d0dddddda234b78cba8b45033123a31621b09c Mon Sep 17 00:00:00 2001 From: tegwick Date: Sun, 14 Jun 2026 14:42:11 +0200 Subject: [PATCH] fix(api): unblock production build --- Web/Controller/Api/V2/Annotations.hs | 8 ++-- Web/Controller/Api/V2/ApiConsumers.hs | 8 ++-- .../Api/V2/HubCapabilityManifests.hs | 40 ++++++++++++------- Web/Controller/Api/V2/Hubs.hs | 8 ++-- Web/Controller/Api/V2/InteractionEvents.hs | 19 ++++----- Web/Controller/Api/V2/Widgets.hs | 8 ++-- 6 files changed, 51 insertions(+), 40 deletions(-) diff --git a/Web/Controller/Api/V2/Annotations.hs b/Web/Controller/Api/V2/Annotations.hs index e640447..b3ab0b1 100644 --- a/Web/Controller/Api/V2/Annotations.hs +++ b/Web/Controller/Api/V2/Annotations.hs @@ -17,7 +17,7 @@ instance Controller ApiV2AnnotationsController where action ApiV2IndexAnnotationsAction = do case requestMethod ?request of "GET" -> listAnnotations - "POST" -> createAnnotation + "POST" -> createApiAnnotation _ -> respondWithStatus 405 $ object ["error" .= ("Method not allowed" :: Text)] action ApiV2ShowAnnotationAction { annotationId } = do @@ -26,7 +26,7 @@ instance Controller ApiV2AnnotationsController where renderJson (annotationToJson ann) -- POST /api/v2/annotations - action ApiV2CreateAnnotationAction = createAnnotation + action ApiV2CreateAnnotationAction = createApiAnnotation listAnnotations :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO () listAnnotations = do @@ -46,8 +46,8 @@ listAnnotations = do anns <- q2 |> limit perPage |> offset off |> fetch renderJson $ paginatedResponse (map annotationToJson anns) page perPage total -createAnnotation :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO () -createAnnotation = do +createApiAnnotation :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO () +createApiAnnotation = do _consumer <- requireApiConsumer let widgetIdText = paramOrNothing @Text "widgetId" category = paramOrNothing @Text "category" diff --git a/Web/Controller/Api/V2/ApiConsumers.hs b/Web/Controller/Api/V2/ApiConsumers.hs index 331250b..eaeb739 100644 --- a/Web/Controller/Api/V2/ApiConsumers.hs +++ b/Web/Controller/Api/V2/ApiConsumers.hs @@ -20,7 +20,7 @@ instance Controller ApiV2ApiConsumersController where action ApiV2IndexApiConsumersAction = do case requestMethod ?request of "GET" -> listApiConsumers - "POST" -> createApiConsumer + "POST" -> createApiConsumerRecord _ -> respondWithStatus 405 $ object ["error" .= ("Method not allowed" :: Text)] action ApiV2ShowApiConsumerAction { apiConsumerId } = do @@ -28,7 +28,7 @@ instance Controller ApiV2ApiConsumersController where apiConsumer <- fetch apiConsumerId renderJson (apiConsumerToJson apiConsumer) - action ApiV2CreateApiConsumerAction = createApiConsumer + action ApiV2CreateApiConsumerAction = createApiConsumerRecord action ApiV2CreateApiConsumerKeyAction { apiConsumerId } = do when (requestMethod ?request /= "POST") do @@ -48,8 +48,8 @@ listApiConsumers = do |> fetch renderJson $ paginatedResponse (map apiConsumerToJson consumers) page perPage total -createApiConsumer :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO () -createApiConsumer = do +createApiConsumerRecord :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO () +createApiConsumerRecord = do _consumer <- requireApiConsumer let name = paramOrNothing @Text "name" description = paramOrNothing @Text "description" diff --git a/Web/Controller/Api/V2/HubCapabilityManifests.hs b/Web/Controller/Api/V2/HubCapabilityManifests.hs index 8453e2b..c614463 100644 --- a/Web/Controller/Api/V2/HubCapabilityManifests.hs +++ b/Web/Controller/Api/V2/HubCapabilityManifests.hs @@ -16,6 +16,7 @@ import Data.String (fromString) import qualified Data.Aeson.Key as K import qualified Data.Aeson.KeyMap as KM import qualified Data.ByteString as BS +import qualified Data.Text.Encoding as TE import qualified Data.UUID as UUID import qualified Data.Vector as V import Database.PostgreSQL.Simple (Only(..)) @@ -103,13 +104,17 @@ createManifest = do [ "error" .= ("Hub already has a capability manifest" :: Text) , "code" .= ("manifest_already_exists" :: Text) ] + declaredWidgetTypes <- textArrayFieldFromRequestOrEmpty "declaredWidgetTypes" + declaredEventTypes <- textArrayFieldFromRequestOrEmpty "declaredEventTypes" + declaredAnnotationCategories <- textArrayFieldFromRequestOrEmpty "declaredAnnotationCategories" + declaredPolicyScopes <- textArrayFieldFromRequestOrEmpty "declaredPolicyScopes" manifest <- newRecord @HubCapabilityManifest |> set #hubId hubId |> set #manifestVersion manifestVersion - |> set #declaredWidgetTypes (toJSON (textArrayFieldFromRequestOrEmpty "declaredWidgetTypes")) - |> set #declaredEventTypes (toJSON (textArrayFieldFromRequestOrEmpty "declaredEventTypes")) - |> set #declaredAnnotationCategories (toJSON (textArrayFieldFromRequestOrEmpty "declaredAnnotationCategories")) - |> set #declaredPolicyScopes (toJSON (textArrayFieldFromRequestOrEmpty "declaredPolicyScopes")) + |> set #declaredWidgetTypes (toJSON declaredWidgetTypes) + |> set #declaredEventTypes (toJSON declaredEventTypes) + |> set #declaredAnnotationCategories (toJSON declaredAnnotationCategories) + |> set #declaredPolicyScopes (toJSON declaredPolicyScopes) |> set #capabilityDescription capabilityDescription |> set #contact contact |> set #status "draft" @@ -126,13 +131,17 @@ updateManifest manifestId = do , "code" .= ("manifest_read_only" :: Text) ] + maybeDeclaredWidgetTypes <- textArrayFieldFromRequest "declaredWidgetTypes" + maybeDeclaredEventTypes <- textArrayFieldFromRequest "declaredEventTypes" + maybeDeclaredAnnotationCategories <- textArrayFieldFromRequest "declaredAnnotationCategories" + maybeDeclaredPolicyScopes <- textArrayFieldFromRequest "declaredPolicyScopes" let manifestVersion = fromMaybe manifest.manifestVersion (nonEmptyText =<< paramOrNothing @Text "manifestVersion") capabilityDescription = fromMaybe manifest.capabilityDescription (Just <$> paramOrNothing @Text "capabilityDescription") contact = fromMaybe manifest.contact (Just <$> paramOrNothing @Text "contact") - declaredWidgetTypes = maybe manifest.declaredWidgetTypes toJSON (textArrayFieldFromRequest "declaredWidgetTypes") - declaredEventTypes = maybe manifest.declaredEventTypes toJSON (textArrayFieldFromRequest "declaredEventTypes") - declaredAnnotationCategories = maybe manifest.declaredAnnotationCategories toJSON (textArrayFieldFromRequest "declaredAnnotationCategories") - declaredPolicyScopes = maybe manifest.declaredPolicyScopes toJSON (textArrayFieldFromRequest "declaredPolicyScopes") + declaredWidgetTypes = maybe manifest.declaredWidgetTypes toJSON maybeDeclaredWidgetTypes + declaredEventTypes = maybe manifest.declaredEventTypes toJSON maybeDeclaredEventTypes + declaredAnnotationCategories = maybe manifest.declaredAnnotationCategories toJSON maybeDeclaredAnnotationCategories + declaredPolicyScopes = maybe manifest.declaredPolicyScopes toJSON maybeDeclaredPolicyScopes manifest <- manifest |> set #manifestVersion manifestVersion @@ -204,18 +213,19 @@ manifestToJson manifest = object , "updatedAt" .= manifest.updatedAt ] -textArrayFieldFromRequestOrEmpty :: (?context :: ControllerContext, ?request :: Request) => Text -> [Text] +textArrayFieldFromRequestOrEmpty :: (?context :: ControllerContext, ?request :: Request) => Text -> IO [Text] textArrayFieldFromRequestOrEmpty fieldName = - fromMaybe [] (textArrayFieldFromRequest fieldName) + fromMaybe [] <$> textArrayFieldFromRequest fieldName -textArrayFieldFromRequest :: (?context :: ControllerContext, ?request :: Request) => Text -> Maybe [Text] +textArrayFieldFromRequest :: (?context :: ControllerContext, ?request :: Request) => Text -> IO (Maybe [Text]) textArrayFieldFromRequest fieldName = case getHeader "Content-Type" of - Just contentType | "application/json" `BS.isPrefixOf` contentType -> - textArrayFieldFromJsonBody fieldName requestBodyJSON + Just contentType | "application/json" `BS.isPrefixOf` contentType -> do + body <- requestBodyJSON + pure $ textArrayFieldFromJsonBody fieldName body _ -> - let values = paramList @Text fieldName - in if null values then Nothing else Just values + let values = paramList @Text (TE.encodeUtf8 fieldName) + in pure $ if null values then Nothing else Just values textArrayFieldFromJsonBody :: Text -> Value -> Maybe [Text] textArrayFieldFromJsonBody fieldName (Object body) = diff --git a/Web/Controller/Api/V2/Hubs.hs b/Web/Controller/Api/V2/Hubs.hs index 7e62898..f726941 100644 --- a/Web/Controller/Api/V2/Hubs.hs +++ b/Web/Controller/Api/V2/Hubs.hs @@ -15,7 +15,7 @@ instance Controller ApiV2HubsController where action ApiV2IndexHubsAction = do case requestMethod ?request of "GET" -> listHubs - "POST" -> createHub + "POST" -> createApiHub _ -> respondWithStatus 405 $ object ["error" .= ("Method not allowed" :: Text)] action ApiV2ShowHubAction { hubId } = do @@ -23,7 +23,7 @@ instance Controller ApiV2HubsController where hub <- fetch hubId renderJson (hubToJson hub) - action ApiV2CreateHubAction = createHub + action ApiV2CreateHubAction = createApiHub listHubs :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO () listHubs = do @@ -38,8 +38,8 @@ listHubs = do |> fetch renderJson $ paginatedResponse (map hubToJson hubs) page perPage total -createHub :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO () -createHub = do +createApiHub :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO () +createApiHub = do _consumer <- requireApiConsumer let slug = paramOrNothing @Text "slug" name = paramOrNothing @Text "name" diff --git a/Web/Controller/Api/V2/InteractionEvents.hs b/Web/Controller/Api/V2/InteractionEvents.hs index 230388e..130efe2 100644 --- a/Web/Controller/Api/V2/InteractionEvents.hs +++ b/Web/Controller/Api/V2/InteractionEvents.hs @@ -27,7 +27,7 @@ instance Controller ApiV2InteractionEventsController where action ApiV2IndexInteractionEventsAction = do case requestMethod ?request of "GET" -> listInteractionEvents - "POST" -> createInteractionEvent + "POST" -> createApiInteractionEvent _ -> respondWithStatus 405 $ object ["error" .= ("Method not allowed" :: Text)] action ApiV2ShowInteractionEventAction { interactionEventId } = do @@ -36,7 +36,7 @@ instance Controller ApiV2InteractionEventsController where renderJson (eventToJson event) -- POST /api/v2/interaction-events - action ApiV2CreateInteractionEventAction = createInteractionEvent + action ApiV2CreateInteractionEventAction = createApiInteractionEvent listInteractionEvents :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO () listInteractionEvents = do @@ -57,13 +57,13 @@ listInteractionEvents = do events <- q2 |> limit perPage |> offset off |> fetch renderJson $ paginatedResponse (map eventToJson events) page perPage total -createInteractionEvent :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO () -createInteractionEvent = do +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" - metadata = metadataFromRequest let missing = catMaybes [ if isNothing widgetIdText then Just ("widgetId" :: Text) else Nothing @@ -155,13 +155,14 @@ manifestAllowsEvent eventType declaredEventTypes = metadataParamOrEmpty :: Maybe A.Value -> A.Value metadataParamOrEmpty = fromMaybe (object []) -metadataFromRequest :: (?context :: ControllerContext) => A.Value +metadataFromRequest :: (?context :: ControllerContext, ?request :: Request) => IO A.Value metadataFromRequest = case getHeader "Content-Type" of - Just contentType | "application/json" `BS.isPrefixOf` contentType -> - metadataParamOrEmpty (metadataFromJsonBody requestBodyJSON) + Just contentType | "application/json" `BS.isPrefixOf` contentType -> do + body <- requestBodyJSON + pure $ metadataParamOrEmpty (metadataFromJsonBody body) _ -> - metadataParamOrEmpty (metadataFromText =<< paramOrNothing @Text "metadata") + pure $ metadataParamOrEmpty (metadataFromText =<< paramOrNothing @Text "metadata") metadataFromJsonBody :: A.Value -> Maybe A.Value metadataFromJsonBody (Object body) = KM.lookup "metadata" body diff --git a/Web/Controller/Api/V2/Widgets.hs b/Web/Controller/Api/V2/Widgets.hs index 66b431e..38f33f5 100644 --- a/Web/Controller/Api/V2/Widgets.hs +++ b/Web/Controller/Api/V2/Widgets.hs @@ -17,7 +17,7 @@ instance Controller ApiV2WidgetsController where action ApiV2IndexWidgetsAction = do case requestMethod ?request of "GET" -> listWidgets - "POST" -> createWidget + "POST" -> createApiWidget _ -> respondWithStatus 405 $ object ["error" .= ("Method not allowed" :: Text)] action ApiV2ShowWidgetAction { widgetId } = do @@ -25,7 +25,7 @@ instance Controller ApiV2WidgetsController where widget <- fetch widgetId renderJson (widgetToJson widget) - action ApiV2CreateWidgetAction = createWidget + action ApiV2CreateWidgetAction = createApiWidget listWidgets :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO () listWidgets = do @@ -40,8 +40,8 @@ listWidgets = do |> fetch renderJson $ paginatedResponse (map widgetToJson widgets) page perPage total -createWidget :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO () -createWidget = do +createApiWidget :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO () +createApiWidget = do _consumer <- requireApiConsumer let hubIdText = paramOrNothing @Text "hubId" name = paramOrNothing @Text "name"