diff --git a/Test/Main.hs b/Test/Main.hs index 20ee875..f59c83a 100644 --- a/Test/Main.hs +++ b/Test/Main.hs @@ -8,6 +8,8 @@ import Web.Controller.Api.V2.InteractionEvents ( declaredEventTypeNames, manifestAllowsEvent, metadataFromJsonBody , metadataParamOrEmpty ) +import Web.Controller.Api.V2.Hubs (missingRequiredFields, validCreateHubKind) +import Web.Controller.Api.V2.Widgets (missingWidgetCreateFields, validWidgetStatus) main :: IO () main = hspec do @@ -44,4 +46,32 @@ main = hspec do metadataParamOrEmpty (Just metadata) `shouldBe` metadata metadataParamOrEmpty Nothing `shouldBe` object [] + describe "API v2 hub and widget create validation" do + it "accepts scriptable domain/shared hub kinds only" do + validCreateHubKind "domain" `shouldBe` True + validCreateHubKind "shared" `shouldBe` True + validCreateHubKind "framework" `shouldBe` False + + it "reports missing hub create fields including empty strings" do + missingRequiredFields + [ ("slug", Just "") + , ("name", Nothing) + , ("domain", Just "operations") + ] + `shouldBe` ["slug", "name"] + + it "accepts widget statuses supported by the UI create flow" do + validWidgetStatus "active" `shouldBe` True + validWidgetStatus "deprecated" `shouldBe` True + validWidgetStatus "draft" `shouldBe` True + validWidgetStatus "archived" `shouldBe` False + + it "reports missing widget create fields including empty strings" do + missingWidgetCreateFields + [ ("hubId", Just "") + , ("name", Just "Ops endpoint card") + , ("widgetType", Nothing) + ] + `shouldBe` ["hubId", "widgetType"] + LayerBoundary.spec diff --git a/Web/Controller/Api/V2/Annotations.hs b/Web/Controller/Api/V2/Annotations.hs index 720a8b0..e640447 100644 --- a/Web/Controller/Api/V2/Annotations.hs +++ b/Web/Controller/Api/V2/Annotations.hs @@ -10,25 +10,15 @@ import Web.Controller.Api.V2.Auth , respondWithStatus ) import Application.Helper.TypeRegistry (validateAnnotationCategory) import qualified Data.UUID as UUID +import Network.Wai (requestMethod) instance Controller ApiV2AnnotationsController where action ApiV2IndexAnnotationsAction = do - _consumer <- requireApiConsumer - (page, perPage) <- getPageParams - let mWidgetId = paramOrNothing @(Id Widget) "widgetId" - mCategory = paramOrNothing @Text "category" - let off = (page - 1) * perPage - let baseQ = query @Annotation |> orderByDesc #createdAt - let q1 = case mWidgetId of - Just wId -> baseQ |> filterWhere (#widgetId, wId) - Nothing -> baseQ - let q2 = case mCategory of - Just cat -> q1 |> filterWhere (#category, cat) - Nothing -> q1 - total <- q2 |> fetchCount - anns <- q2 |> limit perPage |> offset off |> fetch - renderJson $ paginatedResponse (map annotationToJson anns) page perPage total + case requestMethod ?request of + "GET" -> listAnnotations + "POST" -> createAnnotation + _ -> respondWithStatus 405 $ object ["error" .= ("Method not allowed" :: Text)] action ApiV2ShowAnnotationAction { annotationId } = do _consumer <- requireApiConsumer @@ -36,54 +26,75 @@ instance Controller ApiV2AnnotationsController where renderJson (annotationToJson ann) -- POST /api/v2/annotations - action ApiV2CreateAnnotationAction = do - _consumer <- requireApiConsumer - let widgetIdText = paramOrNothing @Text "widgetId" - category = paramOrNothing @Text "category" - body = paramOrNothing @Text "body" + action ApiV2CreateAnnotationAction = createAnnotation - let missing = catMaybes - [ if isNothing widgetIdText then Just ("widgetId" :: Text) else Nothing - , if isNothing category then Just "category" else Nothing - , if isNothing body then Just "body" else Nothing - ] - unless (null missing) do - respondWithStatus 422 $ object - [ "error" .= ("Missing required fields" :: Text) - , "missing" .= missing - ] +listAnnotations :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO () +listAnnotations = do + _consumer <- requireApiConsumer + (page, perPage) <- getPageParams + let mWidgetId = paramOrNothing @(Id Widget) "widgetId" + mCategory = paramOrNothing @Text "category" + let off = (page - 1) * perPage + let baseQ = query @Annotation |> orderByDesc #createdAt + let q1 = case mWidgetId of + Just wId -> baseQ |> filterWhere (#widgetId, wId) + Nothing -> baseQ + let q2 = case mCategory of + Just cat -> q1 |> filterWhere (#category, cat) + Nothing -> q1 + total <- q2 |> fetchCount + anns <- q2 |> limit perPage |> offset off |> fetch + renderJson $ paginatedResponse (map annotationToJson anns) page perPage total - let Just wIdText = widgetIdText - Just cat = category - Just bodyTxt = body +createAnnotation :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO () +createAnnotation = do + _consumer <- requireApiConsumer + let widgetIdText = paramOrNothing @Text "widgetId" + category = paramOrNothing @Text "category" + body = paramOrNothing @Text "body" - catResult <- liftIO $ validateAnnotationCategory cat - case catResult of - Left _ -> respondWithStatus 422 $ object - [ "error" .= ("Unregistered annotation category" :: Text) - , "code" .= ("unregistered_category" :: Text) - , "value" .= cat - , "registry" .= ("/api/v2/annotation-categories" :: Text) - ] - Right () -> pure () + let missing = catMaybes + [ if isNothing widgetIdText then Just ("widgetId" :: Text) else Nothing + , if isNothing category then Just "category" else Nothing + , if isNothing body then Just "body" else Nothing + ] + unless (null missing) do + respondWithStatus 422 $ object + [ "error" .= ("Missing required fields" :: Text) + , "missing" .= missing + ] - 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 - ann <- newRecord @Annotation - |> set #widgetId wId - |> set #category cat - |> set #body bodyTxt - |> set #actorType "api" - |> createRecord - renderJson (annotationToJson ann) + let Just wIdText = widgetIdText + Just cat = category + Just bodyTxt = body + + catResult <- liftIO $ validateAnnotationCategory cat + case catResult of + Left _ -> respondWithStatus 422 $ object + [ "error" .= ("Unregistered annotation category" :: Text) + , "code" .= ("unregistered_category" :: Text) + , "value" .= cat + , "registry" .= ("/api/v2/annotation-categories" :: Text) + ] + Right () -> pure () + + 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 + ann <- newRecord @Annotation + |> set #widgetId wId + |> set #category cat + |> set #body bodyTxt + |> set #actorType "api" + |> createRecord + respondWithStatus 201 (annotationToJson ann) annotationToJson :: Annotation -> Value annotationToJson a = object diff --git a/Web/Controller/Api/V2/Hubs.hs b/Web/Controller/Api/V2/Hubs.hs new file mode 100644 index 0000000..34a1f2d --- /dev/null +++ b/Web/Controller/Api/V2/Hubs.hs @@ -0,0 +1,112 @@ +module Web.Controller.Api.V2.Hubs where + +import Web.Types +import Generated.Types +import IHP.Prelude +import IHP.ControllerPrelude +import Data.Aeson (Value, object, (.=)) +import Network.Wai (requestMethod) +import Web.Controller.Api.V2.Auth + ( requireApiConsumer, paginatedResponse, getPageParams + , respondWithStatus ) + +instance Controller ApiV2HubsController where + + action ApiV2IndexHubsAction = do + case requestMethod ?request of + "GET" -> listHubs + "POST" -> createHub + _ -> respondWithStatus 405 $ object ["error" .= ("Method not allowed" :: Text)] + + action ApiV2ShowHubAction { hubId } = do + _consumer <- requireApiConsumer + hub <- fetch hubId + renderJson (hubToJson hub) + + action ApiV2CreateHubAction = createHub + +listHubs :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO () +listHubs = do + _consumer <- requireApiConsumer + (page, perPage) <- getPageParams + let pageOffset = (page - 1) * perPage + total <- query @Hub |> fetchCount + hubs <- query @Hub + |> orderByAsc #name + |> limit perPage + |> offset pageOffset + |> fetch + renderJson $ paginatedResponse (map hubToJson hubs) page perPage total + +createHub :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO () +createHub = do + _consumer <- requireApiConsumer + let slug = paramOrNothing @Text "slug" + name = paramOrNothing @Text "name" + domain = paramOrNothing @Text "domain" + kind = fromMaybe "domain" (nonEmptyText =<< paramOrNothing @Text "hubKind") + + let missing = missingRequiredFields + [ ("slug", slug) + , ("name", name) + , ("domain", domain) + ] + unless (null missing) do + respondWithStatus 422 $ object + [ "error" .= ("Missing required fields" :: Text) + , "missing" .= missing + ] + + unless (validCreateHubKind kind) do + respondWithStatus 422 $ object + [ "error" .= ("Unsupported hubKind" :: Text) + , "code" .= ("unsupported_hub_kind" :: Text) + , "value" .= kind + , "valid" .= validCreateHubKinds + ] + + let Just slugText = slug + Just nameText = name + Just domainText = domain + + existing <- query @Hub + |> filterWhere (#slug, slugText) + |> fetchOneOrNothing + when (isJust existing) do + respondWithStatus 422 $ object + [ "error" .= ("Hub slug already exists" :: Text) + , "code" .= ("duplicate_hub_slug" :: Text) + , "value" .= slugText + ] + + hub <- newRecord @Hub + |> set #slug slugText + |> set #name nameText + |> set #domain domainText + |> set #hubKind kind + |> createRecord + respondWithStatus 201 (hubToJson hub) + +hubToJson :: Hub -> Value +hubToJson hub = object + [ "id" .= hub.id + , "slug" .= hub.slug + , "name" .= hub.name + , "domain" .= hub.domain + , "hubKind" .= hub.hubKind + , "createdAt" .= hub.createdAt + ] + +validCreateHubKinds :: [Text] +validCreateHubKinds = ["domain", "shared"] + +validCreateHubKind :: Text -> Bool +validCreateHubKind kind = kind `elem` validCreateHubKinds + +missingRequiredFields :: [(Text, Maybe Text)] -> [Text] +missingRequiredFields fields = + [ name | (name, value) <- fields, maybe True (== "") value ] + +nonEmptyText :: Text -> Maybe Text +nonEmptyText "" = Nothing +nonEmptyText value = Just value diff --git a/Web/Controller/Api/V2/InteractionEvents.hs b/Web/Controller/Api/V2/InteractionEvents.hs index fe1aff7..230388e 100644 --- a/Web/Controller/Api/V2/InteractionEvents.hs +++ b/Web/Controller/Api/V2/InteractionEvents.hs @@ -5,7 +5,7 @@ import Generated.Types import IHP.Prelude import IHP.ControllerPrelude import Data.Aeson (Value(..), object, (.=)) -import IHP.ControllerSupport (ControllerContext, getHeader, requestBodyJSON) +import IHP.ControllerSupport (getHeader, requestBodyJSON) import Web.Controller.Api.V2.Auth ( requireApiConsumer, paginatedResponse, getPageParams , respondWithStatus ) @@ -20,26 +20,15 @@ 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 - _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 + case requestMethod ?request of + "GET" -> listInteractionEvents + "POST" -> createInteractionEvent + _ -> respondWithStatus 405 $ object ["error" .= ("Method not allowed" :: Text)] action ApiV2ShowInteractionEventAction { interactionEventId } = do _consumer <- requireApiConsumer @@ -47,75 +36,97 @@ instance Controller ApiV2InteractionEventsController where 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 + action ApiV2CreateInteractionEventAction = createInteractionEvent - 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 - ] +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 - let Just wIdText = widgetIdText - Just evType = eventType +createInteractionEvent :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO () +createInteractionEvent = do + consumer <- requireApiConsumer + let widgetIdText = paramOrNothing @Text "widgetId" + eventType = paramOrNothing @Text "eventType" + viewContext = paramOrNothing @Text "viewContext" + metadata = metadataFromRequest - -- 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 () + 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 + ] - -- 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 - ] + let Just wIdText = widgetIdText + Just evType = eventType - 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) + -- 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 diff --git a/Web/Controller/Api/V2/OpenApi.hs b/Web/Controller/Api/V2/OpenApi.hs index 874377f..81e3c46 100644 --- a/Web/Controller/Api/V2/OpenApi.hs +++ b/Web/Controller/Api/V2/OpenApi.hs @@ -84,6 +84,7 @@ buildOpenApiSpec = do , "total" .= object ["type" .= ("integer" :: Text)] ] ] + , "Hub" .= hubSchema , "Widget" .= widgetSchema , "InteractionEvent" .= interactionEventSchema , "Annotation" .= annotationSchema @@ -108,7 +109,15 @@ buildOpenApiSpec = do buildPaths :: Value buildPaths = object - [ "/widgets" .= getListPath "Widget" + [ "/hubs" .= object + [ "get" .= listOp "Hub" [] + , "post" .= writeOp "Hub" "CreateHubRequest" + ] + , "/hubs/{id}" .= getShowPath "Hub" + , "/widgets" .= object + [ "get" .= listOp "Widget" [] + , "post" .= writeOp "Widget" "CreateWidgetRequest" + ] , "/widgets/{id}" .= getShowPath "Widget" , "/interaction-events" .= object [ "get" .= listOp "InteractionEvent" @@ -266,6 +275,19 @@ pageParams = -- Schemas for all resource types +hubSchema :: Value +hubSchema = object + [ "type" .= ("object" :: Text) + , "properties" .= object + [ "id" .= uuidProp + , "slug" .= strProp + , "name" .= strProp + , "domain" .= strProp + , "hubKind" .= object ["type" .= ("string" :: Text), "enum" .= ["domain" :: Text, "shared"]] + , "createdAt" .= object ["type" .= ("string" :: Text), "format" .= ("date-time" :: Text)] + ] + ] + widgetSchema :: Value widgetSchema = object [ "type" .= ("object" :: Text) diff --git a/Web/Controller/Api/V2/Sdk.hs b/Web/Controller/Api/V2/Sdk.hs index da26a90..e7dcda9 100644 --- a/Web/Controller/Api/V2/Sdk.hs +++ b/Web/Controller/Api/V2/Sdk.hs @@ -94,11 +94,19 @@ tsSdkClientClass = T.unlines , " });" , " }" , "" + , " async createHub(body: { slug: string; name: string; domain: string; hubKind?: 'domain' | 'shared' }) {" + , " return this.fetch('/hubs', 'POST', body).then(r => r.json());" + , " }" + , "" , " async getWidgets(params?: { page?: number; perPage?: number }) {" , " const q = params ? `?page=${params.page ?? 1}&per_page=${params.perPage ?? 50}` : '';" , " return this.fetch('/widgets' + q).then(r => r.json());" , " }" , "" + , " async createWidget(body: { hubId: string; name: string; widgetType: WidgetType; capabilityRef?: string; viewContext?: string; policyScope?: string; status?: 'active' | 'deprecated' | 'draft' }) {" + , " return this.fetch('/widgets', 'POST', body).then(r => r.json());" + , " }" + , "" , " async getInteractionEvents(params?: { widgetId?: string; eventType?: EventType }) {" , " const qs = new URLSearchParams();" , " if (params?.widgetId) qs.set('widgetId', params.widgetId);" @@ -149,9 +157,20 @@ pyClientClass = T.unlines , " with urllib.request.urlopen(req) as resp:" , " return json.loads(resp.read())" , "" + , " def create_hub(self, slug: str, name: str, domain: str, hub_kind: str = 'domain') -> dict:" + , " return self._request('/hubs', 'POST', {'slug': slug, 'name': name, 'domain': domain, 'hubKind': hub_kind})" + , "" , " def get_widgets(self, page: int = 1, per_page: int = 50) -> dict:" , " return self._request(f'/widgets?page={page}&per_page={per_page}')" , "" + , " def create_widget(self, hub_id: str, name: str, widget_type: WidgetType, capability_ref: Optional[str] = None, view_context: Optional[str] = None, policy_scope: Optional[str] = None, status: Optional[str] = None) -> dict:" + , " body: dict = {'hubId': hub_id, 'name': name, 'widgetType': str(widget_type)}" + , " if capability_ref: body['capabilityRef'] = capability_ref" + , " if view_context: body['viewContext'] = view_context" + , " if policy_scope: body['policyScope'] = policy_scope" + , " if status: body['status'] = status" + , " return self._request('/widgets', 'POST', body)" + , "" , " def get_interaction_events(self, widget_id: Optional[str] = None, event_type: Optional[EventType] = None) -> dict:" , " qs = urllib.parse.urlencode({k: v for k, v in {'widgetId': widget_id, 'eventType': event_type and str(event_type)}.items() if v})" , " return self._request('/interaction-events' + ('?' + qs if qs else ''))" diff --git a/Web/Controller/Api/V2/Widgets.hs b/Web/Controller/Api/V2/Widgets.hs index 9d43967..66b431e 100644 --- a/Web/Controller/Api/V2/Widgets.hs +++ b/Web/Controller/Api/V2/Widgets.hs @@ -4,28 +4,158 @@ import Web.Types import Generated.Types import IHP.Prelude import IHP.ControllerPrelude -import Data.Aeson (object, (.=), ToJSON, toJSON) -import Web.Controller.Api.V2.Auth (requireApiConsumer, paginatedResponse, getPageParams) +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 - _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 + case requestMethod ?request of + "GET" -> listWidgets + "POST" -> createWidget + _ -> respondWithStatus 405 $ object ["error" .= ("Method not allowed" :: Text)] action ApiV2ShowWidgetAction { widgetId } = do _consumer <- requireApiConsumer widget <- fetch widgetId renderJson (widgetToJson widget) + action ApiV2CreateWidgetAction = createWidget + +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 + +createWidget :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO () +createWidget = 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 @@ -39,3 +169,17 @@ widgetToJson w = object , "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 diff --git a/Web/FrontController.hs b/Web/FrontController.hs index 6610db8..259ae67 100644 --- a/Web/FrontController.hs +++ b/Web/FrontController.hs @@ -48,6 +48,7 @@ import Web.Controller.Api.V2.Registries () import Web.Controller.Api.V2.OpenApi () import Web.Controller.Api.V2.Token () import Web.Controller.Api.V2.Sdk () +import Web.Controller.Api.V2.Hubs () -- Phase 10 — Hub Registry and Widget Marketplace (IHUB-WP-0011) import Web.Controller.HubRegistry () import Web.Controller.WidgetPatterns () @@ -116,6 +117,7 @@ instance FrontController WebApplication where , parseRoute @ApiV2OpenApiController , parseRoute @ApiV2TokenController , parseRoute @ApiV2SdkController + , parseRoute @ApiV2HubsController -- Phase 10 — Hub Registry and Widget Marketplace (IHUB-WP-0011) , parseRoute @HubRegistryController , parseRoute @WidgetPatternsController diff --git a/Web/Routes.hs b/Web/Routes.hs index 249c698..2a9bef8 100644 --- a/Web/Routes.hs +++ b/Web/Routes.hs @@ -89,6 +89,7 @@ instance CanRoute ApiV2WidgetsController where instance HasPath ApiV2WidgetsController where pathTo ApiV2IndexWidgetsAction = "/api/v2/widgets" pathTo ApiV2ShowWidgetAction { widgetId } = "/api/v2/widgets/" <> tshow widgetId + pathTo ApiV2CreateWidgetAction = "/api/v2/widgets" instance CanRoute ApiV2InteractionEventsController where parseRoute' = do @@ -242,6 +243,20 @@ instance HasPath ApiV2HubRegistryController where pathTo ApiV2IndexHubRegistryAction = "/api/v2/hub-registry" pathTo ApiV2ShowHubRegistryAction { hubId } = "/api/v2/hub-registry/" <> tshow hubId +instance CanRoute ApiV2HubsController where + parseRoute' = do + _ <- string "/api/v2/hubs" + choice + [ do endOfInput; pure ApiV2IndexHubsAction + , do _ <- string "/"; hId <- parseUUID; endOfInput + pure ApiV2ShowHubAction { hubId = Id hId } + ] + +instance HasPath ApiV2HubsController where + pathTo ApiV2IndexHubsAction = "/api/v2/hubs" + pathTo ApiV2ShowHubAction { hubId } = "/api/v2/hubs/" <> tshow hubId + pathTo ApiV2CreateHubAction = "/api/v2/hubs" + instance CanRoute ApiV2WidgetPatternsController where parseRoute' = do _ <- string "/api/v2/widget-patterns" diff --git a/Web/Types.hs b/Web/Types.hs index 334a693..2c123dd 100644 --- a/Web/Types.hs +++ b/Web/Types.hs @@ -285,6 +285,7 @@ data ApiDashboardController data ApiV2WidgetsController = ApiV2IndexWidgetsAction | ApiV2ShowWidgetAction { widgetId :: !(Id Widget) } + | ApiV2CreateWidgetAction deriving (Eq, Show, Data) data ApiV2InteractionEventsController @@ -400,6 +401,12 @@ data ApiV2HubRegistryController | ApiV2ShowHubRegistryAction { hubId :: !(Id Hub) } deriving (Eq, Show, Data) +data ApiV2HubsController + = ApiV2IndexHubsAction + | ApiV2ShowHubAction { hubId :: !(Id Hub) } + | ApiV2CreateHubAction + deriving (Eq, Show, Data) + data ApiV2WidgetPatternsController = ApiV2IndexWidgetPatternsAction | ApiV2ShowWidgetPatternAction { widgetPatternId :: !(Id WidgetPattern) } diff --git a/workplans/IHUB-WP-0019-vsm-hub-bootstrap-api.md b/workplans/IHUB-WP-0019-vsm-hub-bootstrap-api.md index d65f0ea..702ddf9 100644 --- a/workplans/IHUB-WP-0019-vsm-hub-bootstrap-api.md +++ b/workplans/IHUB-WP-0019-vsm-hub-bootstrap-api.md @@ -79,7 +79,7 @@ The same shape should later work for: ```task id: IHUB-WP-0019-T01 -status: todo +status: done priority: high state_hub_task_id: "72c5b7b2-632f-42ab-ac4d-eff123d8f143" ``` @@ -101,6 +101,15 @@ The endpoints should validate the same invariants as the UI controllers: Done when: a script can create a hub row and seed widgets without direct DB access. +Implementation note (2026-05-16): added authenticated v2 `POST /api/v2/hubs` +and `POST /api/v2/widgets`, with required-field validation, hub-kind/status +validation, widget type and policy-scope registry checks, hub existence checks, +initial widget-version snapshots, OpenAPI path entries, SDK helper methods, and +focused Hspec helper coverage. The collection controllers now dispatch +GET/POST by HTTP method so the create routes are reachable. Local +`git diff --check` passed; `scripts/compile-check` could not run because this +shell does not have `IHP_LIB`/the IHP dev environment loaded. + --- ### T02 — Add manifest and policy-scope API support