diff --git a/src/Data/OpenApi/SchemaOptions.hs b/src/Data/OpenApi/SchemaOptions.hs index ed95881f..99f83894 100644 --- a/src/Data/OpenApi/SchemaOptions.hs +++ b/src/Data/OpenApi/SchemaOptions.hs @@ -1,13 +1,19 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} -- | -- Module: Data.OpenApi.SchemaOptions -- Maintainer: Nickolay Kudasov -- Stability: experimental -- -- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@. -module Data.OpenApi.SchemaOptions where +module Data.OpenApi.SchemaOptions ( + SchemaOptions (..) + , defaultSchemaOptions + , fromAesonOptions +) where import qualified Data.Aeson.Types as Aeson +import Data.Char -- | Options that specify how to encode your type to Swagger schema. data SchemaOptions = SchemaOptions @@ -40,14 +46,26 @@ data SchemaOptions = SchemaOptions -- @ defaultSchemaOptions :: SchemaOptions defaultSchemaOptions = SchemaOptions + -- \x -> traceShowId x { fieldLabelModifier = id , constructorTagModifier = id - , datatypeNameModifier = id + , datatypeNameModifier = conformDatatypeNameModifier , allNullaryToStringTag = True , unwrapUnaryRecords = False , sumEncoding = Aeson.defaultTaggedObject } + +-- | According to spec https://github.com/OAI/OpenAPI-Specification/blob/main/versions/3.0.3.md#components-object +-- name must conform to ^[a-zA-Z0-9\.\-_]+$ +conformDatatypeNameModifier :: String -> String +conformDatatypeNameModifier = + foldl (\acc x -> acc ++ convertChar x) "" + where + convertChar = \case + c | isAlphaNum c || elem c "-._" -> [c] + c -> "_" ++ (show $ ord c) ++ "_" + -- | Convert 'Aeson.Options' to 'SchemaOptions'. -- -- Specifically the following fields get copied: diff --git a/test/Data/OpenApi/CommonTestTypes.hs b/test/Data/OpenApi/CommonTestTypes.hs index 3a83703b..4cf735d6 100644 --- a/test/Data/OpenApi/CommonTestTypes.hs +++ b/test/Data/OpenApi/CommonTestTypes.hs @@ -258,6 +258,30 @@ playersSchemaJSON = [aesonQQ| } |] +-- ======================================================================== +-- Player (with type param) +-- ======================================================================== + +newtype PlayerPoly a = PlayerPoly + { position' :: PointG a + } deriving (Generic) +instance (ToSchema a) => ToSchema (PlayerPoly a) + +playerPolySchemaJSON :: Value +playerPolySchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "position": + { + "$ref": "#/components/schemas/Point" + } + }, + "required": ["position"] +} +|] + -- ======================================================================== -- Character (sum type with ref and record in alternative) -- ======================================================================== @@ -505,6 +529,18 @@ pointSchemaJSON = [aesonQQ| } |] +-- ======================================================================== +-- Point (record data type with custom fieldLabelModifier) +-- ======================================================================== + +data PointG a = PointG + { pointGX :: a + , pointGY :: a + } deriving (Generic) + +instance ToSchema a => ToSchema (PointG a) where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + -- ======================================================================== -- Point (record data type with multiple fields) -- ======================================================================== diff --git a/test/Data/OpenApi/SchemaSpec.hs b/test/Data/OpenApi/SchemaSpec.hs index 0a3f96e7..26080f3e 100644 --- a/test/Data/OpenApi/SchemaSpec.hs +++ b/test/Data/OpenApi/SchemaSpec.hs @@ -95,6 +95,7 @@ spec = do context "(Int, Float)" $ checkSchemaName Nothing (Proxy :: Proxy (Int, Float)) context "Person" $ checkSchemaName (Just "Person") (Proxy :: Proxy Person) context "Shade" $ checkSchemaName (Just "Shade") (Proxy :: Proxy Shade) + context "Player (polymorphic record)" $ checkSchemaName (Just "PlayerPoly__40_PointG_Int_41_") (Proxy :: Proxy (PlayerPoly (PointG Int))) describe "Generic Definitions" $ do context "Unit" $ checkDefs (Proxy :: Proxy Unit) [] context "Paint" $ checkDefs (Proxy :: Proxy Paint) ["Color"]