Skip to content
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
3 changes: 3 additions & 0 deletions orb.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -94,6 +94,7 @@ library
, json-fleece-aeson
, json-fleece-core
, mtl
, non-empty-text
, openapi3
, optparse-applicative
, safe-exceptions
Expand Down Expand Up @@ -125,6 +126,7 @@ test-suite orb-test
Fixtures.NullableRef
Fixtures.NullableRefCollectComponents
Fixtures.OpenApiSubset
Fixtures.SchemaDescriptions
Fixtures.SimpleGet
Fixtures.SimplePost
Fixtures.TaggedUnion
Expand Down Expand Up @@ -160,6 +162,7 @@ test-suite orb-test
, json-fleece-aeson
, json-fleece-core
, mtl
, non-empty-text
, openapi3
, optparse-applicative
, orb
Expand Down
1 change: 1 addition & 0 deletions package.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -66,6 +66,7 @@ dependencies:
- json-fleece-aeson
- json-fleece-core
- mtl
- non-empty-text
- openapi3
- optparse-applicative
- safe-exceptions
Expand Down
73 changes: 58 additions & 15 deletions src/Orb/OpenApi.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -562,7 +563,7 @@ mkRequestBody handler =
let
FleeceOpenApi mkErrOrSchemaInfo = FC.schemaInterpreter schema

schemaInfo <- mkErrOrSchemaInfo []
schemaInfo <- applySchemaDescription schema <$> mkErrOrSchemaInfo []
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It feels bad that we have to add applySchemaDescription in so many places. Can this be avoided somehow?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I don't see any way to avoid it, but I'm open to discussing it.


let
schemaRef =
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -853,9 +854,7 @@ schemaWithComponents =
(schemaComponents schemaInfo)
}
)
. ($ [])
. unFleeceOpenApi
. FC.schemaInterpreter
. interpretSchemaWithDescription

data PathEntry
= PathSchema FC.Name
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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 =
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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) =
Expand Down
1 change: 1 addition & 0 deletions test/Fixtures.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
71 changes: 71 additions & 0 deletions test/Fixtures/SchemaDescriptions.hs
Original file line number Diff line number Diff line change
@@ -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
]
8 changes: 8 additions & 0 deletions test/OpenApi.hs
Original file line number Diff line number Diff line change
Expand Up @@ -30,6 +30,7 @@ testGroup =
, test_nullableRefOpenApi
, test_unionOpenApi
, test_taggedUnionOpenApi
, test_schemaDescriptionsOpenApi
, test_nullableRefCollectComponentsOpenApi
]

Expand Down Expand Up @@ -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
Expand Down
66 changes: 66 additions & 0 deletions test/examples/schema-descriptions.json
Original file line number Diff line number Diff line change
@@ -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": ""
}
}
}
}
}
}