From a4d7a7fe63b3f6a890d063223ecdaed08935d33e Mon Sep 17 00:00:00 2001 From: AugmenTab Date: Sun, 1 Mar 2026 16:48:30 -0600 Subject: [PATCH] Adds schema descriptions to SwaggerUI This uses the schema descriptions added in a recent `json-fleece` update to the SwaggerUI so it renders along with the schema. A golden test has been added to show that the descriptions for both an object and its fields are included in the generated OpenAPI document. This was also tested with an external project using `orb` to see that the SwaggerUI page includes the description. --- orb.cabal | 3 ++ package.yaml | 1 + src/Orb/OpenApi.hs | 73 ++++++++++++++++++++------ test/Fixtures.hs | 1 + test/Fixtures/SchemaDescriptions.hs | 71 +++++++++++++++++++++++++ test/OpenApi.hs | 8 +++ test/examples/schema-descriptions.json | 66 +++++++++++++++++++++++ 7 files changed, 208 insertions(+), 15 deletions(-) create mode 100644 test/Fixtures/SchemaDescriptions.hs create mode 100644 test/examples/schema-descriptions.json diff --git a/orb.cabal b/orb.cabal index 8d762ea..5251d4d 100644 --- a/orb.cabal +++ b/orb.cabal @@ -94,6 +94,7 @@ library , json-fleece-aeson , json-fleece-core , mtl + , non-empty-text , openapi3 , optparse-applicative , safe-exceptions @@ -125,6 +126,7 @@ test-suite orb-test Fixtures.NullableRef Fixtures.NullableRefCollectComponents Fixtures.OpenApiSubset + Fixtures.SchemaDescriptions Fixtures.SimpleGet Fixtures.SimplePost Fixtures.TaggedUnion @@ -160,6 +162,7 @@ test-suite orb-test , json-fleece-aeson , json-fleece-core , mtl + , non-empty-text , openapi3 , optparse-applicative , orb diff --git a/package.yaml b/package.yaml index 2b5356d..ad83334 100644 --- a/package.yaml +++ b/package.yaml @@ -66,6 +66,7 @@ dependencies: - json-fleece-aeson - json-fleece-core - mtl + - non-empty-text - openapi3 - optparse-applicative - safe-exceptions diff --git a/src/Orb/OpenApi.hs b/src/Orb/OpenApi.hs index 5d23ca3..3939194 100644 --- a/src/Orb/OpenApi.hs +++ b/src/Orb/OpenApi.hs @@ -35,6 +35,7 @@ import Data.Hashable (Hashable) import Data.List qualified as List import Data.Map.Strict qualified as Map import Data.Maybe qualified as Maybe +import Data.NonEmptyText qualified as NET import Data.OpenApi qualified as OpenApi import Data.Semialign.Indexed qualified as IAlign import Data.Set qualified as Set @@ -562,7 +563,7 @@ mkRequestBody handler = let FleeceOpenApi mkErrOrSchemaInfo = FC.schemaInterpreter schema - schemaInfo <- mkErrOrSchemaInfo [] + schemaInfo <- applySchemaDescription schema <$> mkErrOrSchemaInfo [] let schemaRef = @@ -690,11 +691,11 @@ mkResponses handler = case responseSchema of Response.NoSchemaResponseBody _mbContentType -> pure Nothing - Response.SchemaResponseBody schema -> + Response.SchemaResponseBody schema -> do let FleeceOpenApi mkInfo = FC.schemaInterpreter schema - in - fmap Just (mkInfo []) + + Just . applySchemaDescription schema <$> mkInfo [] Response.EmptyResponseBody -> pure Nothing let @@ -853,9 +854,7 @@ schemaWithComponents = (schemaComponents schemaInfo) } ) - . ($ []) - . unFleeceOpenApi - . FC.schemaInterpreter + . interpretSchemaWithDescription data PathEntry = PathSchema FC.Name @@ -870,6 +869,36 @@ renderPathEntry pathEntry = type Path = [PathEntry] +interpretSchemaWithDescriptionAt :: + Path -> + FC.Schema FleeceOpenApi a -> + Either OpenApiError SchemaInfo +interpretSchemaWithDescriptionAt path schema = do + let + FleeceOpenApi mk = FC.schemaInterpreter schema + + schemaInfo <- mk path + pure (applySchemaDescription schema schemaInfo) + +interpretSchemaWithDescription :: + FC.Schema FleeceOpenApi a -> + Either OpenApiError SchemaInfo +interpretSchemaWithDescription = + interpretSchemaWithDescriptionAt [] + +applySchemaDescription :: + FC.Schema FleeceOpenApi a -> + SchemaInfo -> + SchemaInfo +applySchemaDescription schema schemaInfo = + schemaInfo + { openApiSchema = + (openApiSchema schemaInfo) + { OpenApi._schemaDescription = + NET.toText <$> FC.schemaDescription schema + } + } + addSchemaToPath :: FC.Name -> Path -> Path addSchemaToPath = (:) . PathSchema @@ -1050,7 +1079,11 @@ instance FC.Fleece FleeceOpenApi where let FleeceOpenApi mkErrOrSchemaInfo = FC.schemaInterpreter schema in - fmap (setSchemaInfoFormat (T.pack formatString)) . mkErrOrSchemaInfo + fmap + ( setSchemaInfoFormat (T.pack formatString) + . applySchemaDescription schema + ) + . mkErrOrSchemaInfo interpretNumber name = FleeceOpenApi $ Right . mkPrimitiveSchema name OpenApi.OpenApiNumber @@ -1069,7 +1102,9 @@ instance FC.Fleece FleeceOpenApi where let FleeceOpenApi mkErrOrItemSchemaInfo = FC.schemaInterpreter schema - itemSchemaInfo <- mkErrOrItemSchemaInfo path + itemSchemaInfo <- + applySchemaDescription schema <$> mkErrOrItemSchemaInfo path + components <- collectComponents [itemSchemaInfo] let @@ -1096,7 +1131,7 @@ instance FC.Fleece FleeceOpenApi where let FleeceOpenApi mkErrOrSchemaInfo = FC.schemaInterpreter schema - schemaInfo <- mkErrOrSchemaInfo path + schemaInfo <- applySchemaDescription schema <$> mkErrOrSchemaInfo path let innerSchemaShouldBeNullable = @@ -1125,7 +1160,10 @@ instance FC.Fleece FleeceOpenApi where let FleeceOpenApi mkErrOrSchemaInfo = FC.schemaInterpreter schema - schemaInfo <- mkErrOrSchemaInfo (addFieldToPath name path) + schemaInfo <- + applySchemaDescription schema + <$> mkErrOrSchemaInfo (addFieldToPath name path) + pure $ FieldInfo { fieldName = T.pack name @@ -1138,7 +1176,10 @@ instance FC.Fleece FleeceOpenApi where let FleeceOpenApi mkErrOrSchemaInfo = FC.schemaInterpreter schema - schemaInfo <- mkErrOrSchemaInfo (addFieldToPath name path) + schemaInfo <- + applySchemaDescription schema + <$> mkErrOrSchemaInfo (addFieldToPath name path) + pure $ FieldInfo { fieldName = T.pack name @@ -1171,7 +1212,9 @@ instance FC.Fleece FleeceOpenApi where let FleeceOpenApi mkErrOrSchemaInfo = FC.schemaInterpreter schema - schemaInfo <- mkErrOrSchemaInfo (addSchemaToPath name path) + schemaInfo <- + applySchemaDescription schema + <$> mkErrOrSchemaInfo (addSchemaToPath name path) let key = Just $ fleeceNameToOpenApiKey name @@ -1203,7 +1246,7 @@ instance FC.Fleece FleeceOpenApi where let FleeceOpenApi errOrSchemaInfo = FC.schemaInterpreter schema in - FleeceOpenApi errOrSchemaInfo + FleeceOpenApi (fmap (applySchemaDescription schema) . errOrSchemaInfo) interpretBoundedEnumNamed name toText = let @@ -1259,7 +1302,7 @@ instance FC.Fleece FleeceOpenApi where let FleeceOpenApi mkErrOrSchemaInfo = FC.schemaInterpreter schema - schemaInfo <- mkErrOrSchemaInfo path + schemaInfo <- applySchemaDescription schema <$> mkErrOrSchemaInfo path pure [schemaInfo] unionCombine (UnionMembers left) (UnionMembers right) = diff --git a/test/Fixtures.hs b/test/Fixtures.hs index ad344be..85ea718 100644 --- a/test/Fixtures.hs +++ b/test/Fixtures.hs @@ -9,6 +9,7 @@ import Fixtures.NoPermissions as Export import Fixtures.NullableRef as Export import Fixtures.NullableRefCollectComponents as Export import Fixtures.OpenApiSubset as Export +import Fixtures.SchemaDescriptions as Export import Fixtures.SimpleGet as Export import Fixtures.SimplePost as Export import Fixtures.TaggedUnion as Export diff --git a/test/Fixtures/SchemaDescriptions.hs b/test/Fixtures/SchemaDescriptions.hs new file mode 100644 index 0000000..d0da4cf --- /dev/null +++ b/test/Fixtures/SchemaDescriptions.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} + +module Fixtures.SchemaDescriptions + ( schemaDescriptionsOpenApiRouter + ) where + +import Beeline.Routing ((/-), (/:)) +import Beeline.Routing qualified as R +import Data.Text qualified as T +import Fleece.Core ((#+)) +import Fleece.Core qualified as FC +import Shrubbery qualified + +import Fixtures.NoPermissions (NoPermissions (NoPermissions)) +import Orb qualified +import TestDispatchM qualified as TDM + +schemaDescriptionsOpenApiRouter :: + Orb.OpenApiProvider r => + r (Shrubbery.Union '[SchemaDescriptions]) +schemaDescriptionsOpenApiRouter = + Orb.provideOpenApi "schema-descriptions" $ + R.routeList $ + (Orb.get (R.make SchemaDescriptions /- T.pack "schema-descriptions")) + /: R.emptyRoutes + +newtype DescribedObject + = DescribedObject + { describedObjectContent :: T.Text + } + +describedObjectSchema :: FC.Fleece t => FC.Schema t DescribedObject +describedObjectSchema = + let + objectDescription = T.pack "This is the description for DescribedObject." + fieldDescription = T.pack "This is the description for the content field." + in + FC.describeSchema objectDescription $ + FC.object $ + FC.constructor DescribedObject + #+ FC.required "content" describedObjectContent (FC.describeSchema fieldDescription FC.text) + +data SchemaDescriptions = SchemaDescriptions + +instance Orb.HasHandler SchemaDescriptions where + type HandlerResponses SchemaDescriptions = SchemaDescriptionsResponses + type HandlerPermissionAction SchemaDescriptions = NoPermissions + type HandlerMonad SchemaDescriptions = TDM.TestDispatchM + routeHandler = + Orb.Handler + { Orb.handlerId = "SchemaDescriptionsHandler" + , Orb.requestBody = Orb.EmptyRequestBody + , Orb.requestQuery = Orb.EmptyRequestQuery + , Orb.requestHeaders = Orb.EmptyRequestHeaders + , Orb.handlerResponseBodies = + Orb.responseBodies + . Orb.addResponseSchema200 describedObjectSchema + . Orb.addResponseSchema500 Orb.internalServerErrorSchema + $ Orb.noResponseBodies + , Orb.mkPermissionAction = + \_request -> NoPermissions + , Orb.handleRequest = + \_request () -> + Orb.return200 . DescribedObject $ T.pack "Described content." + } + +type SchemaDescriptionsResponses = + [ Orb.Response200 DescribedObject + , Orb.Response500 Orb.InternalServerError + ] diff --git a/test/OpenApi.hs b/test/OpenApi.hs index 19ab706..ada4185 100644 --- a/test/OpenApi.hs +++ b/test/OpenApi.hs @@ -30,6 +30,7 @@ testGroup = , test_nullableRefOpenApi , test_unionOpenApi , test_taggedUnionOpenApi + , test_schemaDescriptionsOpenApi , test_nullableRefCollectComponentsOpenApi ] @@ -124,6 +125,13 @@ test_taggedUnionOpenApi = "test/examples/tagged-union.json" $ mkTestOpenApi Fixtures.taggedUnionOpenApiRouter "tagged-union" +test_schemaDescriptionsOpenApi :: Tasty.TestTree +test_schemaDescriptionsOpenApi = + mkGoldenTest + "Generates the correct schema descriptions." + "test/examples/schema-descriptions.json" + (mkTestOpenApi Fixtures.schemaDescriptionsOpenApiRouter "schema-descriptions") + test_nullableRefCollectComponentsOpenApi :: Tasty.TestTree test_nullableRefCollectComponentsOpenApi = mkGoldenTest diff --git a/test/examples/schema-descriptions.json b/test/examples/schema-descriptions.json new file mode 100644 index 0000000..0f59c35 --- /dev/null +++ b/test/examples/schema-descriptions.json @@ -0,0 +1,66 @@ +{ + "components": { + "schemas": { + "DescribedObject": { + "description": "This is the description for DescribedObject.", + "properties": { + "content": { + "description": "This is the description for the content field.", + "type": "string" + } + }, + "required": [ + "content" + ], + "title": "DescribedObject", + "type": "object" + }, + "InternalServerError": { + "properties": { + "internal_server_error": { + "type": "string" + } + }, + "required": [ + "internal_server_error" + ], + "title": "InternalServerError", + "type": "object" + } + } + }, + "info": { + "title": "", + "version": "" + }, + "openapi": "3.0.0", + "paths": { + "/schema-descriptions": { + "get": { + "operationId": "SchemaDescriptionsHandler", + "responses": { + "200": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/DescribedObject" + } + } + }, + "description": "" + }, + "500": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/InternalServerError" + } + } + }, + "description": "" + } + } + } + } + } +}