diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,9 +1,19 @@ +2.2.1 +----- + +* Add `Semigroup` instances +* GHC-8.4 compatibility +* `Schema (NonEmpty a) instance (see [#141](https://github.com/GetShopTV/swagger2/pull/141)) +* Fix optional property for unary records (see [#142](https://github.com/GetShopTV/swagger2/issues/142)) +* Add `fromAesonOptions` helper (see [#146](https://github.com/GetShopTV/swagger2/issues/139)) +* Fix non-termination when using `datatypeNameModifier` with recursive data types (see [#132](https://github.com/GetShopTV/swagger2/issues/132)) + 2.2 --- -* Treat unknown properties as validation errors in `validateToJSON`; -* Add `validateJSON` and `validateJSONWithPatternChecker` to validate JSON `Value` against `Schema` without classes; -* Add more `Schema` helpers: +* Treat unknown properties as validation errors in `validateToJSON` (see [#126](https://github.com/GetShopTV/swagger2/pull/126)); +* Add `validateJSON` and `validateJSONWithPatternChecker` to validate JSON `Value` against `Schema` without classes (see [#126](https://github.com/GetShopTV/swagger2/pull/126)); +* Add more `Schema` helpers (see [#126](https://github.com/GetShopTV/swagger2/pull/126)): * `genericNameSchema` — to give a custom schema `Generic`-based name; * `genericDeclareNamedSchemaNewtype` — to derive `NamedSchema` for `newtype`s; * `declareSchemaBoundedEnumKeyMapping` — to derive more specific `Schema` for maps with `Bounded` `Enum` keys; diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -32,7 +32,8 @@ import qualified Data.HashMap.Strict as HashMap import Data.Map (Map) import qualified Data.Map as Map -import Data.Monoid +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Semigroup (..)) import Data.Scientific (Scientific) import Data.Set (Set) import Data.String (IsString(..)) @@ -303,7 +304,7 @@ } deriving (Eq, Show, Generic, Data, Typeable) newtype MimeList = MimeList { getMimeList :: [MediaType] } - deriving (Eq, Show, Monoid, Typeable) + deriving (Eq, Show, Semigroup, Monoid, Typeable) mimeListConstr :: Constr mimeListConstr = mkConstr mimeListDataType "MimeList" ["getMimeList"] Prefix @@ -754,7 +755,7 @@ -- (that is, there is a logical AND between the schemes). newtype SecurityRequirement = SecurityRequirement { getSecurityRequirement :: InsOrdHashMap Text [Text] - } deriving (Eq, Read, Show, Monoid, ToJSON, FromJSON, Data, Typeable) + } deriving (Eq, Read, Show, Semigroup, Monoid, ToJSON, FromJSON, Data, Typeable) -- | Tag name. type TagName = Text @@ -805,61 +806,89 @@ -- Monoid instances -- ======================================================================= +instance Semigroup Swagger where + (<>) = genericMappend instance Monoid Swagger where mempty = genericMempty - mappend = genericMappend + mappend = (<>) +instance Semigroup Info where + (<>) = genericMappend instance Monoid Info where mempty = genericMempty - mappend = genericMappend + mappend = (<>) +instance Semigroup Contact where + (<>) = genericMappend instance Monoid Contact where mempty = genericMempty - mappend = genericMappend + mappend = (<>) +instance Semigroup PathItem where + (<>) = genericMappend instance Monoid PathItem where mempty = genericMempty - mappend = genericMappend + mappend = (<>) +instance Semigroup Schema where + (<>) = genericMappend instance Monoid Schema where mempty = genericMempty - mappend = genericMappend + mappend = (<>) +instance Semigroup (ParamSchema t) where + (<>) = genericMappend instance Monoid (ParamSchema t) where mempty = genericMempty - mappend = genericMappend + mappend = (<>) +instance Semigroup Param where + (<>) = genericMappend instance Monoid Param where mempty = genericMempty - mappend = genericMappend + mappend = (<>) +instance Semigroup ParamOtherSchema where + (<>) = genericMappend instance Monoid ParamOtherSchema where mempty = genericMempty - mappend = genericMappend + mappend = (<>) +instance Semigroup Header where + (<>) = genericMappend instance Monoid Header where mempty = genericMempty - mappend = genericMappend + mappend = (<>) +instance Semigroup Responses where + (<>) = genericMappend instance Monoid Responses where mempty = genericMempty - mappend = genericMappend + mappend = (<>) +instance Semigroup Response where + (<>) = genericMappend instance Monoid Response where mempty = genericMempty - mappend = genericMappend + mappend = (<>) +instance Semigroup ExternalDocs where + (<>) = genericMappend instance Monoid ExternalDocs where mempty = genericMempty - mappend = genericMappend + mappend = (<>) +instance Semigroup Operation where + (<>) = genericMappend instance Monoid Operation where mempty = genericMempty - mappend = genericMappend + mappend = (<>) +instance Semigroup Example where + (<>) = genericMappend instance Monoid Example where mempty = genericMempty - mappend = genericMappend + mappend = (<>) -- ======================================================================= -- SwaggerMonoid helper instances @@ -893,7 +922,7 @@ instance Monoid a => SwaggerMonoid (Referenced a) where swaggerMempty = Inline mempty - swaggerMappend (Inline x) (Inline y) = Inline (x <> y) + swaggerMappend (Inline x) (Inline y) = Inline (mappend x y) swaggerMappend _ y = y instance SwaggerMonoid ParamAnySchema where diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs --- a/src/Data/Swagger/Internal/Schema.hs +++ b/src/Data/Swagger/Internal/Schema.hs @@ -44,6 +44,7 @@ import Data.Int import Data.IntSet (IntSet) import Data.IntMap (IntMap) +import Data.List.NonEmpty (NonEmpty) import Data.Map (Map) import Data.Proxy import Data.Scientific (Scientific) @@ -561,6 +562,13 @@ instance ToSchema a => ToSchema (HashSet a) where declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy (Set a)) +-- | @since 2.2.1 +instance ToSchema a => ToSchema (NonEmpty a) where + declareNamedSchema _ = do + schema <- declareSchema (Proxy :: Proxy [a]) + return $ unnamed $ schema + & minItems .~ Just 1 + instance ToSchema All where declareNamedSchema = plain . paramSchemaToSchema instance ToSchema Any where declareNamedSchema = plain . paramSchemaToSchema @@ -680,11 +688,12 @@ genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d)) gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text -gdatatypeSchemaName opts _ = case name of +gdatatypeSchemaName opts _ = case orig of (c:_) | isAlpha c && isUpper c -> Just (T.pack name) _ -> Nothing where - name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a)) + orig = datatypeName (Proxy3 :: Proxy3 d f a) + name = datatypeNameModifier opts orig -- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@. paramSchemaToNamedSchema :: forall a d f proxy. @@ -724,7 +733,7 @@ gdeclareNamedSchema = gdeclareNamedSumSchema -- | Single field constructor. -instance (Selector s, GToSchema f) => GToSchema (C1 c (S1 s f)) where +instance (Selector s, GToSchema f, GToSchema (S1 s f)) => GToSchema (C1 c (S1 s f)) where gdeclareNamedSchema opts _ s | unwrapUnaryRecords opts = fieldSchema | otherwise = diff --git a/src/Data/Swagger/Schema.hs b/src/Data/Swagger/Schema.hs --- a/src/Data/Swagger/Schema.hs +++ b/src/Data/Swagger/Schema.hs @@ -54,6 +54,7 @@ -- * Generic encoding configuration SchemaOptions(..), defaultSchemaOptions, + fromAesonOptions, ) where import Data.Swagger.Internal.Schema diff --git a/src/Data/Swagger/SchemaOptions.hs b/src/Data/Swagger/SchemaOptions.hs --- a/src/Data/Swagger/SchemaOptions.hs +++ b/src/Data/Swagger/SchemaOptions.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RecordWildCards #-} -- | -- Module: Data.Swagger.SchemaOptions -- Maintainer: Nickolay Kudasov @@ -6,6 +7,8 @@ -- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@. module Data.Swagger.SchemaOptions where +import qualified Data.Aeson.Types as Aeson + -- | Options that specify how to encode your type to Swagger schema. data SchemaOptions = SchemaOptions { -- | Function applied to field labels. Handy for removing common record prefixes for example. @@ -41,3 +44,29 @@ , unwrapUnaryRecords = False } +-- | Convert 'Aeson.Options' to 'SchemaOptions'. +-- +-- Specifically the following fields get copied: +-- +-- * 'fieldLabelModifier' +-- * 'constructorTagModifier' +-- * 'allNullaryToStringTag' +-- * 'unwrapUnaryRecords' +-- +-- Note that these fields have no effect on `SchemaOptions`: +-- +-- * 'Aeson.omitNothingFields' +-- * 'Aeson.sumEncoding' +-- * 'Aeson.tagSingleConstructors' +-- +-- The rest is defined as in 'defaultSchemaOptions'. +-- +-- @since 2.2.1 +-- +fromAesonOptions :: Aeson.Options -> SchemaOptions +fromAesonOptions opts = defaultSchemaOptions + { fieldLabelModifier = Aeson.fieldLabelModifier opts + , constructorTagModifier = Aeson.constructorTagModifier opts + , allNullaryToStringTag = Aeson.allNullaryToStringTag opts + , unwrapUnaryRecords = Aeson.unwrapUnaryRecords opts + } diff --git a/swagger2.cabal b/swagger2.cabal --- a/swagger2.cabal +++ b/swagger2.cabal @@ -1,5 +1,5 @@ name: swagger2 -version: 2.2 +version: 2.2.1 synopsis: Swagger 2.0 data model description: This library is inteded to be used for decoding and encoding Swagger 2.0 API @@ -21,7 +21,7 @@ , examples/*.hs , include/overlapping-compat.h cabal-version: >=1.10 -tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.1 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.1 custom-setup setup-depends: @@ -48,7 +48,7 @@ Data.Swagger.Internal.Utils Data.Swagger.Internal.AesonUtils Data.Swagger.Internal.TypeShape - build-depends: base >=4.7 && <4.11 + build-depends: base >=4.7 && <4.12 , base-compat >=0.9.1 && <0.10 , aeson >=0.11.2.1 , bytestring @@ -71,6 +71,8 @@ , uuid-types >=1.0.2 && <1.1 if !impl(ghc >= 7.10) build-depends: nats >=1.1.1 && <1.2 + if !impl(ghc >= 8.0) + build-depends: semigroups >= 0.18.3 && <0.19 default-language: Haskell2010 test-suite spec @@ -90,15 +92,20 @@ , HUnit , mtl , QuickCheck >=2.8.2 + , quickcheck-instances , swagger2 , text , time , unordered-containers , vector , lens + if !impl(ghc >= 8.0) + build-depends: semigroups + other-modules: SpecCommon Data.SwaggerSpec + Data.Swagger.CommonTestTypes Data.Swagger.ParamSchemaSpec Data.Swagger.SchemaSpec Data.Swagger.Schema.ValidationSpec diff --git a/test/Data/Swagger/CommonTestTypes.hs b/test/Data/Swagger/CommonTestTypes.hs new file mode 100644 --- /dev/null +++ b/test/Data/Swagger/CommonTestTypes.hs @@ -0,0 +1,652 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes #-} + +module Data.Swagger.CommonTestTypes where + +import Prelude () +import Prelude.Compat + +import Data.Aeson (Value, ToJSON(..), ToJSONKey(..)) +import Data.Aeson.Types (toJSONKeyText) +import Data.Aeson.QQ +import Data.Char +import Data.Proxy +import Data.Set (Set) +import Data.Map (Map) +import qualified Data.Text as Text +import GHC.Generics + +import Data.Swagger +import Data.Swagger.Declare +import Data.Swagger.Internal (SwaggerKind(..)) + +-- ======================================================================== +-- Unit type +-- ======================================================================== + +data Unit = Unit deriving (Generic) +instance ToParamSchema Unit +instance ToSchema Unit + +unitSchemaJSON :: Value +unitSchemaJSON = [aesonQQ| +{ + "type": "string", + "enum": ["Unit"] +} +|] + +-- ======================================================================== +-- Color (enum) +-- ======================================================================== +data Color + = Red + | Green + | Blue + deriving (Generic) +instance ToParamSchema Color +instance ToSchema Color + +colorSchemaJSON :: Value +colorSchemaJSON = [aesonQQ| +{ + "type": "string", + "enum": ["Red", "Green", "Blue"] +} +|] + +-- ======================================================================== +-- Shade (paramSchemaToNamedSchema) +-- ======================================================================== + +data Shade = Dim | Bright deriving (Generic) +instance ToParamSchema Shade + +instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions + +shadeSchemaJSON :: Value +shadeSchemaJSON = [aesonQQ| +{ + "type": "string", + "enum": ["Dim", "Bright"] +} +|] + +-- ======================================================================== +-- Paint (record with bounded enum property) +-- ======================================================================== + +newtype Paint = Paint { color :: Color } + deriving (Generic) +instance ToSchema Paint + +paintSchemaJSON :: Value +paintSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "color": + { + "$ref": "#/definitions/Color" + } + }, + "required": ["color"] +} +|] + +paintInlinedSchemaJSON :: Value +paintInlinedSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "color": + { + "type": "string", + "enum": ["Red", "Green", "Blue"] + } + }, + "required": ["color"] +} +|] + +-- ======================================================================== +-- Status (constructorTagModifier) +-- ======================================================================== + +data Status + = StatusOk + | StatusError + deriving (Generic) + +instance ToParamSchema Status where + toParamSchema = genericToParamSchema defaultSchemaOptions + { constructorTagModifier = map toLower . drop (length "Status") } +instance ToSchema Status where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { constructorTagModifier = map toLower . drop (length "Status") } + +statusSchemaJSON :: Value +statusSchemaJSON = [aesonQQ| +{ + "type": "string", + "enum": ["ok", "error"] +} +|] + +-- ======================================================================== +-- Email (newtype with unwrapUnaryRecords set to True) +-- ======================================================================== + +newtype Email = Email { getEmail :: String } + deriving (Generic) +instance ToParamSchema Email +instance ToSchema Email where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { unwrapUnaryRecords = True } + +emailSchemaJSON :: Value +emailSchemaJSON = [aesonQQ| +{ + "type": "string" +} +|] + +-- ======================================================================== +-- UserId (non-record newtype) +-- ======================================================================== + +newtype UserId = UserId Integer + deriving (Eq, Ord, Generic) +instance ToParamSchema UserId +instance ToSchema UserId + +userIdSchemaJSON :: Value +userIdSchemaJSON = [aesonQQ| +{ + "type": "integer" +} +|] + +-- ======================================================================== +-- UserGroup (set newtype) +-- ======================================================================== + +newtype UserGroup = UserGroup (Set UserId) + deriving (Generic) +instance ToSchema UserGroup + +userGroupSchemaJSON :: Value +userGroupSchemaJSON = [aesonQQ| +{ + "type": "array", + "items": { "$ref": "#/definitions/UserId" }, + "uniqueItems": true +} +|] + +-- ======================================================================== +-- Person (simple record with optional fields) +-- ======================================================================== +data Person = Person + { name :: String + , phone :: Integer + , email :: Maybe String + } deriving (Generic) + +instance ToSchema Person + +personSchemaJSON :: Value +personSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "name": { "type": "string" }, + "phone": { "type": "integer" }, + "email": { "type": "string" } + }, + "required": ["name", "phone"] +} +|] + +-- ======================================================================== +-- Player (record newtype) +-- ======================================================================== + +newtype Player = Player + { position :: Point + } deriving (Generic) +instance ToSchema Player + +playerSchemaJSON :: Value +playerSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "position": + { + "$ref": "#/definitions/Point" + } + }, + "required": ["position"] +} +|] + +newtype Players = Players [Inlined Player] + deriving (Generic) +instance ToSchema Players + +playersSchemaJSON :: Value +playersSchemaJSON = [aesonQQ| +{ + "type": "array", + "items": + { + "type": "object", + "properties": + { + "position": + { + "$ref": "#/definitions/Point" + } + }, + "required": ["position"] + } +} +|] + +-- ======================================================================== +-- Character (sum type with ref and record in alternative) +-- ======================================================================== + +data Character + = PC Player + | NPC { npcName :: String, npcPosition :: Point } + deriving (Generic) +instance ToSchema Character + +characterSchemaJSON :: Value +characterSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "PC": { "$ref": "#/definitions/Player" }, + "NPC": + { + "type": "object", + "properties": + { + "npcName": { "type": "string" }, + "npcPosition": { "$ref": "#/definitions/Point" } + }, + "required": ["npcName", "npcPosition"] + } + }, + "maxProperties": 1, + "minProperties": 1 +} +|] + +characterInlinedSchemaJSON :: Value +characterInlinedSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "PC": + { + "type": "object", + "properties": + { + "position": + { + "type": "object", + "properties": + { + "x": { "type": "number", "format": "double" }, + "y": { "type": "number", "format": "double" } + }, + "required": ["x", "y"] + } + }, + "required": ["position"] + }, + "NPC": + { + "type": "object", + "properties": + { + "npcName": { "type": "string" }, + "npcPosition": + { + "type": "object", + "properties": + { + "x": { "type": "number", "format": "double" }, + "y": { "type": "number", "format": "double" } + }, + "required": ["x", "y"] + } + }, + "required": ["npcName", "npcPosition"] + } + }, + "maxProperties": 1, + "minProperties": 1 +} +|] + +characterInlinedPlayerSchemaJSON :: Value +characterInlinedPlayerSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "PC": + { + "type": "object", + "properties": + { + "position": + { + "$ref": "#/definitions/Point" + } + }, + "required": ["position"] + }, + "NPC": + { + "type": "object", + "properties": + { + "npcName": { "type": "string" }, + "npcPosition": { "$ref": "#/definitions/Point" } + }, + "required": ["npcName", "npcPosition"] + } + }, + "maxProperties": 1, + "minProperties": 1 +} +|] + +-- ======================================================================== +-- ISPair (non-record product data type) +-- ======================================================================== +data ISPair = ISPair Integer String + deriving (Generic) + +instance ToSchema ISPair + +ispairSchemaJSON :: Value +ispairSchemaJSON = [aesonQQ| +{ + "type": "array", + "items": + [ + { "type": "integer" }, + { "type": "string" } + ], + "minItems": 2, + "maxItems": 2 +} +|] + +-- ======================================================================== +-- Point (record data type with custom fieldLabelModifier) +-- ======================================================================== + +data Point = Point + { pointX :: Double + , pointY :: Double + } deriving (Generic) + +instance ToSchema Point where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { fieldLabelModifier = map toLower . drop (length "point") } + +pointSchemaJSON :: Value +pointSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "x": { "type": "number", "format": "double" }, + "y": { "type": "number", "format": "double" } + }, + "required": ["x", "y"] +} +|] + +-- ======================================================================== +-- Point (record data type with multiple fields) +-- ======================================================================== + +data Point5 = Point5 + { point5X :: Double + , point5Y :: Double + , point5Z :: Double + , point5U :: Double + , point5V :: Double -- 5 dimensional! + } deriving (Generic) + +instance ToSchema Point5 where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { fieldLabelModifier = map toLower . drop (length "point5") } + +point5SchemaJSON :: Value +point5SchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "x": { "type": "number", "format": "double" }, + "y": { "type": "number", "format": "double" }, + "z": { "type": "number", "format": "double" }, + "u": { "type": "number", "format": "double" }, + "v": { "type": "number", "format": "double" } + }, + "required": ["x", "y", "z", "u", "v"] +} +|] + +point5Properties :: [String] +point5Properties = ["x", "y", "z", "u", "v"] + +-- ======================================================================== +-- MyRoseTree (custom datatypeNameModifier) +-- ======================================================================== + +data MyRoseTree = MyRoseTree + { root :: String + , trees :: [MyRoseTree] + } deriving (Generic) + +instance ToSchema MyRoseTree where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { datatypeNameModifier = drop (length "My") } + +myRoseTreeSchemaJSON :: Value +myRoseTreeSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "root": { "type": "string" }, + "trees": + { + "type": "array", + "items": + { + "$ref": "#/definitions/RoseTree" + } + } + }, + "required": ["root", "trees"] +} +|] + +data MyRoseTree' = MyRoseTree' + { root' :: String + , trees' :: [MyRoseTree'] + } deriving (Generic) + +instance ToSchema MyRoseTree' where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions + { datatypeNameModifier = map toLower } + +myRoseTreeSchemaJSON' :: Value +myRoseTreeSchemaJSON' = [aesonQQ| +{ + "type": "object", + "properties": + { + "root'": { "type": "string" }, + "trees'": + { + "type": "array", + "items": + { + "$ref": "#/definitions/myrosetree'" + } + } + }, + "required": ["root'", "trees'"] +} +|] + +-- ======================================================================== +-- Inlined (newtype for inlining schemas) +-- ======================================================================== + +newtype Inlined a = Inlined { getInlined :: a } + +instance ToSchema a => ToSchema (Inlined a) where + declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a) + where + unname (NamedSchema _ s) = NamedSchema Nothing s + +-- ======================================================================== +-- Light (sum type with unwrapUnaryRecords) +-- ======================================================================== + +data Light + = NoLight + | LightFreq Double + | LightColor Color + | LightWaveLength { waveLength :: Double } + deriving (Generic) + +instance ToSchema Light where + declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions + { unwrapUnaryRecords = True } + +lightSchemaJSON :: Value +lightSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "NoLight": { "type": "array", "items": [] }, + "LightFreq": { "type": "number", "format": "double" }, + "LightColor": { "$ref": "#/definitions/Color" }, + "LightWaveLength": { "type": "number", "format": "double" } + }, + "maxProperties": 1, + "minProperties": 1 +} +|] + +lightInlinedSchemaJSON :: Value +lightInlinedSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "NoLight": { "type": "array", "items": [] }, + "LightFreq": { "type": "number", "format": "double" }, + "LightColor": + { + "type": "string", + "enum": ["Red", "Green", "Blue"] + }, + "LightWaveLength": { "type": "number", "format": "double" } + }, + "maxProperties": 1, + "minProperties": 1 +} +|] + +-- ======================================================================== +-- ResourceId (series of newtypes) +-- ======================================================================== + +newtype Id = Id String deriving (Generic) +instance ToSchema Id + +newtype ResourceId = ResourceId Id deriving (Generic) +instance ToSchema ResourceId + +-- ======================================================================== +-- ButtonImages (bounded enum key mapping) +-- ======================================================================== + +data ButtonState = Neutral | Focus | Active | Hover | Disabled + deriving (Show, Bounded, Enum, Generic) + +instance ToJSON ButtonState +instance ToSchema ButtonState +instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show) + +type ImageUrl = Text.Text + +newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl } + deriving (Generic) + +instance ToJSON ButtonImages where + toJSON = toJSON . getButtonImages + +instance ToSchema ButtonImages where + declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions + declareSchemaBoundedEnumKeyMapping + +buttonImagesSchemaJSON :: Value +buttonImagesSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "Neutral": { "type": "string" }, + "Focus": { "type": "string" }, + "Active": { "type": "string" }, + "Hover": { "type": "string" }, + "Disabled": { "type": "string" } + } +} +|] + +-- ======================================================================== +-- SingleMaybeField (single field data with optional field) +-- ======================================================================== + +data SingleMaybeField = SingleMaybeField { singleMaybeField :: Maybe String } + deriving (Show, Generic) + +instance ToJSON SingleMaybeField +instance ToSchema SingleMaybeField + +singleMaybeFieldSchemaJSON :: Value +singleMaybeFieldSchemaJSON = [aesonQQ| +{ + "type": "object", + "properties": + { + "singleMaybeField": { "type": "string" } + } +} +|] diff --git a/test/Data/Swagger/ParamSchemaSpec.hs b/test/Data/Swagger/ParamSchemaSpec.hs --- a/test/Data/Swagger/ParamSchemaSpec.hs +++ b/test/Data/Swagger/ParamSchemaSpec.hs @@ -14,6 +14,7 @@ import Data.Swagger import Data.Swagger.Internal (SwaggerKind(..)) +import Data.Swagger.CommonTestTypes import SpecCommon import Test.Hspec @@ -32,85 +33,3 @@ main :: IO () main = hspec spec - --- ======================================================================== --- Unit type --- ======================================================================== - -data Unit = Unit deriving (Generic) -instance ToParamSchema Unit - -unitSchemaJSON :: Value -unitSchemaJSON = [aesonQQ| -{ - "type": "string", - "enum": ["Unit"] -} -|] - --- ======================================================================== --- Color (enum) --- ======================================================================== -data Color - = Red - | Green - | Blue - deriving (Generic) -instance ToParamSchema Color - -colorSchemaJSON :: Value -colorSchemaJSON = [aesonQQ| -{ - "type": "string", - "enum": ["Red", "Green", "Blue"] -} -|] - --- ======================================================================== --- Status (constructorTagModifier) --- ======================================================================== - -data Status = StatusOk | StatusError deriving (Generic) - -instance ToParamSchema Status where - toParamSchema = genericToParamSchema defaultSchemaOptions - { constructorTagModifier = map toLower . drop (length "Status") } - -statusSchemaJSON :: Value -statusSchemaJSON = [aesonQQ| -{ - "type": "string", - "enum": ["ok", "error"] -} -|] - --- ======================================================================== --- Email (newtype with unwrapUnaryRecords set to True) --- ======================================================================== - -newtype Email = Email { getEmail :: String } - deriving (Generic) -instance ToParamSchema Email - -emailSchemaJSON :: Value -emailSchemaJSON = [aesonQQ| -{ - "type": "string" -} -|] - --- ======================================================================== --- UserId (non-record newtype) --- ======================================================================== - -newtype UserId = UserId Integer - deriving (Generic) -instance ToParamSchema UserId - -userIdSchemaJSON :: Value -userIdSchemaJSON = [aesonQQ| -{ - "type": "integer" -} -|] - diff --git a/test/Data/Swagger/Schema/ValidationSpec.hs b/test/Data/Swagger/Schema/ValidationSpec.hs --- a/test/Data/Swagger/Schema/ValidationSpec.hs +++ b/test/Data/Swagger/Schema/ValidationSpec.hs @@ -16,6 +16,7 @@ import qualified "unordered-containers" Data.HashSet as HashSet import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import Data.Map (Map) import Data.Monoid (mempty) import Data.Proxy @@ -32,6 +33,7 @@ import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck +import Test.QuickCheck.Instances () shouldValidate :: (ToJSON a, ToSchema a) => Proxy a -> a -> Bool shouldValidate _ x = validateToJSON x == [] @@ -69,6 +71,7 @@ -- prop "(Maybe [Int])" $ shouldValidate (Proxy :: Proxy (Maybe [Int])) prop "(IntMap String)" $ shouldValidate (Proxy :: Proxy (IntMap String)) prop "(Set Bool)" $ shouldValidate (Proxy :: Proxy (Set Bool)) + prop "(NonEmpty Bool)" $ shouldValidate (Proxy :: Proxy (NonEmpty Bool)) prop "(HashSet Bool)" $ shouldValidate (Proxy :: Proxy (HashSet Bool)) prop "(Either Int String)" $ shouldValidate (Proxy :: Proxy (Either Int String)) prop "(Int, String)" $ shouldValidate (Proxy :: Proxy (Int, String)) @@ -228,35 +231,5 @@ instance Arbitrary ButtonImages where arbitrary = ButtonImages <$> arbitrary --- Arbitrary instances for common types - -instance (Eq k, Hashable k, Arbitrary k, Arbitrary v) => Arbitrary (HashMap k v) where - arbitrary = HashMap.fromList <$> arbitrary - -instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (HashSet a) where - arbitrary = HashSet.fromList <$> arbitrary - -instance Arbitrary T.Text where - arbitrary = T.pack <$> arbitrary - -instance Arbitrary TL.Text where - arbitrary = TL.pack <$> arbitrary - -instance Arbitrary Day where - arbitrary = liftA3 fromGregorian (fmap ((+ 1) . abs) arbitrary) arbitrary arbitrary - -instance Arbitrary LocalTime where - arbitrary = LocalTime - <$> arbitrary - <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60)) - instance Eq ZonedTime where ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y - -instance Arbitrary ZonedTime where - arbitrary = ZonedTime - <$> arbitrary - <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z'])) - -instance Arbitrary UTCTime where - arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400)) diff --git a/test/Data/Swagger/SchemaSpec.hs b/test/Data/Swagger/SchemaSpec.hs --- a/test/Data/Swagger/SchemaSpec.hs +++ b/test/Data/Swagger/SchemaSpec.hs @@ -22,6 +22,7 @@ import Data.Swagger import Data.Swagger.Declare +import Data.Swagger.CommonTestTypes import SpecCommon import Test.Hspec @@ -78,8 +79,10 @@ context "Email (unwrapUnaryRecords)" $ checkToSchema (Proxy :: Proxy Email) emailSchemaJSON context "UserId (non-record newtype)" $ checkToSchema (Proxy :: Proxy UserId) userIdSchemaJSON context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON + context "SingleMaybeField (unary record with Maybe)" $ checkToSchema (Proxy :: Proxy SingleMaybeField) singleMaybeFieldSchemaJSON context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON + context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON' context "Sum types" $ do context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON @@ -95,6 +98,7 @@ context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"] context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"] context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"] + context "MyRoseTree'" $ checkDefs (Proxy :: Proxy MyRoseTree') ["myrosetree'"] context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"] context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) [] describe "Inlining Schemas" $ do @@ -103,590 +107,9 @@ context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON + context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON' describe "Bounded Enum key mapping" $ do context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON main :: IO () main = hspec spec - --- ======================================================================== --- Person (simple record with optional fields) --- ======================================================================== -data Person = Person - { name :: String - , phone :: Integer - , email :: Maybe String - } deriving (Generic) - -instance ToSchema Person - -personSchemaJSON :: Value -personSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "name": { "type": "string" }, - "phone": { "type": "integer" }, - "email": { "type": "string" } - }, - "required": ["name", "phone"] -} -|] - --- ======================================================================== --- ISPair (non-record product data type) --- ======================================================================== -data ISPair = ISPair Integer String - deriving (Generic) - -instance ToSchema ISPair - -ispairSchemaJSON :: Value -ispairSchemaJSON = [aesonQQ| -{ - "type": "array", - "items": - [ - { "type": "integer" }, - { "type": "string" } - ], - "minItems": 2, - "maxItems": 2 -} -|] - --- ======================================================================== --- Point (record data type with custom fieldLabelModifier) --- ======================================================================== - -data Point = Point - { pointX :: Double - , pointY :: Double - } deriving (Generic) - -instance ToSchema Point where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions - { fieldLabelModifier = map toLower . drop (length "point") } - -pointSchemaJSON :: Value -pointSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "x": { "type": "number", "format": "double" }, - "y": { "type": "number", "format": "double" } - }, - "required": ["x", "y"] -} -|] - --- ======================================================================== --- Point (record data type with multiple fields) --- ======================================================================== - -data Point5 = Point5 - { point5X :: Double - , point5Y :: Double - , point5Z :: Double - , point5U :: Double - , point5V :: Double -- 5 dimensional! - } deriving (Generic) - -instance ToSchema Point5 where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions - { fieldLabelModifier = map toLower . drop (length "point5") } - -point5SchemaJSON :: Value -point5SchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "x": { "type": "number", "format": "double" }, - "y": { "type": "number", "format": "double" }, - "z": { "type": "number", "format": "double" }, - "u": { "type": "number", "format": "double" }, - "v": { "type": "number", "format": "double" } - }, - "required": ["x", "y", "z", "u", "v"] -} -|] - -point5Properties :: [String] -point5Properties = ["x", "y", "z", "u", "v"] - --- ======================================================================== --- Color (enum) --- ======================================================================== -data Color - = Red - | Green - | Blue - deriving (Generic) -instance ToSchema Color - -colorSchemaJSON :: Value -colorSchemaJSON = [aesonQQ| -{ - "type": "string", - "enum": ["Red", "Green", "Blue"] -} -|] - --- ======================================================================== --- Shade (paramSchemaToNamedSchema) --- ======================================================================== - -data Shade = Dim | Bright deriving (Generic) -instance ToParamSchema Shade - -instance ToSchema Shade where declareNamedSchema = pure . paramSchemaToNamedSchema defaultSchemaOptions - -shadeSchemaJSON :: Value -shadeSchemaJSON = [aesonQQ| -{ - "type": "string", - "enum": ["Dim", "Bright"] -} -|] - --- ======================================================================== --- Paint (record with bounded enum property) --- ======================================================================== - -newtype Paint = Paint { color :: Color } - deriving (Generic) -instance ToSchema Paint - -paintSchemaJSON :: Value -paintSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "color": - { - "$ref": "#/definitions/Color" - } - }, - "required": ["color"] -} -|] - -paintInlinedSchemaJSON :: Value -paintInlinedSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "color": - { - "type": "string", - "enum": ["Red", "Green", "Blue"] - } - }, - "required": ["color"] -} -|] - --- ======================================================================== --- Email (newtype with unwrapUnaryRecords set to True) --- ======================================================================== - -newtype Email = Email { getEmail :: String } - deriving (Generic) - -instance ToSchema Email where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions - { unwrapUnaryRecords = True } - -emailSchemaJSON :: Value -emailSchemaJSON = [aesonQQ| -{ - "type": "string" -} -|] - --- ======================================================================== --- UserId (non-record newtype) --- ======================================================================== - -newtype UserId = UserId Integer - deriving (Eq, Ord, Generic) -instance ToSchema UserId - -userIdSchemaJSON :: Value -userIdSchemaJSON = [aesonQQ| -{ - "type": "integer" -} -|] - --- ======================================================================== --- UserGroup (set newtype) --- ======================================================================== - -newtype UserGroup = UserGroup (Set UserId) - deriving (Generic) -instance ToSchema UserGroup - -userGroupSchemaJSON :: Value -userGroupSchemaJSON = [aesonQQ| -{ - "type": "array", - "items": { "$ref": "#/definitions/UserId" }, - "uniqueItems": true -} -|] - --- ======================================================================== --- Player (record newtype) --- ======================================================================== - -newtype Player = Player - { position :: Point - } deriving (Generic) -instance ToSchema Player - -playerSchemaJSON :: Value -playerSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "position": - { - "$ref": "#/definitions/Point" - } - }, - "required": ["position"] -} -|] - --- ======================================================================== --- MyRoseTree (custom datatypeNameModifier) --- ======================================================================== - -data MyRoseTree = MyRoseTree - { root :: String - , trees :: [MyRoseTree] - } deriving (Generic) - -instance ToSchema MyRoseTree where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions - { datatypeNameModifier = drop (length "My") } - -myRoseTreeSchemaJSON :: Value -myRoseTreeSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "root": { "type": "string" }, - "trees": - { - "type": "array", - "items": - { - "$ref": "#/definitions/RoseTree" - } - } - }, - "required": ["root", "trees"] -} -|] - --- ======================================================================== --- Inlined (newtype for inlining schemas) --- ======================================================================== - -newtype Inlined a = Inlined { getInlined :: a } - -instance ToSchema a => ToSchema (Inlined a) where - declareNamedSchema _ = unname <$> declareNamedSchema (Proxy :: Proxy a) - where - unname (NamedSchema _ s) = NamedSchema Nothing s - -newtype Players = Players [Inlined Player] - deriving (Generic) -instance ToSchema Players - -playersSchemaJSON :: Value -playersSchemaJSON = [aesonQQ| -{ - "type": "array", - "items": - { - "type": "object", - "properties": - { - "position": - { - "$ref": "#/definitions/Point" - } - }, - "required": ["position"] - } -} -|] - --- ======================================================================== --- Status (sum type with unary constructors) --- ======================================================================== - -data Status - = StatusOk String - | StatusError String - deriving (Generic) - -instance ToSchema Status where - declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions - { constructorTagModifier = map toLower . drop (length "Status") } - -statusSchemaJSON :: Value -statusSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "ok": { "type": "string" }, - "error": { "type": "string" } - }, - "maxProperties": 1, - "minProperties": 1 -} -|] - --- ======================================================================== --- Unit type --- ======================================================================== - -data Unit = Unit deriving (Generic) -instance ToSchema Unit - -unitSchemaJSON :: Value -unitSchemaJSON = [aesonQQ| -{ - "type": "string", - "enum": ["Unit"] -} -|] - - --- ======================================================================== --- Character (sum type with ref and record in alternative) --- ======================================================================== - -data Character - = PC Player - | NPC { npcName :: String, npcPosition :: Point } - deriving (Generic) -instance ToSchema Character - -characterSchemaJSON :: Value -characterSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "PC": { "$ref": "#/definitions/Player" }, - "NPC": - { - "type": "object", - "properties": - { - "npcName": { "type": "string" }, - "npcPosition": { "$ref": "#/definitions/Point" } - }, - "required": ["npcName", "npcPosition"] - } - }, - "maxProperties": 1, - "minProperties": 1 -} -|] - -characterInlinedSchemaJSON :: Value -characterInlinedSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "PC": - { - "type": "object", - "properties": - { - "position": - { - "type": "object", - "properties": - { - "x": { "type": "number", "format": "double" }, - "y": { "type": "number", "format": "double" } - }, - "required": ["x", "y"] - } - }, - "required": ["position"] - }, - "NPC": - { - "type": "object", - "properties": - { - "npcName": { "type": "string" }, - "npcPosition": - { - "type": "object", - "properties": - { - "x": { "type": "number", "format": "double" }, - "y": { "type": "number", "format": "double" } - }, - "required": ["x", "y"] - } - }, - "required": ["npcName", "npcPosition"] - } - }, - "maxProperties": 1, - "minProperties": 1 -} -|] - -characterInlinedPlayerSchemaJSON :: Value -characterInlinedPlayerSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "PC": - { - "type": "object", - "properties": - { - "position": - { - "$ref": "#/definitions/Point" - } - }, - "required": ["position"] - }, - "NPC": - { - "type": "object", - "properties": - { - "npcName": { "type": "string" }, - "npcPosition": { "$ref": "#/definitions/Point" } - }, - "required": ["npcName", "npcPosition"] - } - }, - "maxProperties": 1, - "minProperties": 1 -} -|] - --- ======================================================================== --- Light (sum type with unwrapUnaryRecords) --- ======================================================================== - -data Light - = NoLight - | LightFreq Double - | LightColor Color - | LightWaveLength { waveLength :: Double } - deriving (Generic) - -instance ToSchema Light where - declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions - { unwrapUnaryRecords = True } - -lightSchemaJSON :: Value -lightSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "NoLight": { "type": "array", "items": [] }, - "LightFreq": { "type": "number", "format": "double" }, - "LightColor": { "$ref": "#/definitions/Color" }, - "LightWaveLength": { "type": "number", "format": "double" } - }, - "maxProperties": 1, - "minProperties": 1 -} -|] - -lightInlinedSchemaJSON :: Value -lightInlinedSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "NoLight": { "type": "array", "items": [] }, - "LightFreq": { "type": "number", "format": "double" }, - "LightColor": - { - "type": "string", - "enum": ["Red", "Green", "Blue"] - }, - "LightWaveLength": { "type": "number", "format": "double" } - }, - "maxProperties": 1, - "minProperties": 1 -} -|] - --- ======================================================================== --- ResourceId (series of newtypes) --- ======================================================================== - -newtype Id = Id String deriving (Generic) -instance ToSchema Id - -newtype ResourceId = ResourceId Id deriving (Generic) -instance ToSchema ResourceId - --- ======================================================================== --- ButtonImages (bounded enum key mapping) --- ======================================================================== - -data ButtonState = Neutral | Focus | Active | Hover | Disabled - deriving (Show, Bounded, Enum, Generic) - -instance ToJSON ButtonState -instance ToSchema ButtonState -instance ToJSONKey ButtonState where toJSONKey = toJSONKeyText (Text.pack . show) - -type ImageUrl = Text.Text - -newtype ButtonImages = ButtonImages { getButtonImages :: Map ButtonState ImageUrl } - deriving (Generic) - -instance ToJSON ButtonImages where - toJSON = toJSON . getButtonImages - -instance ToSchema ButtonImages where - declareNamedSchema = genericDeclareNamedSchemaNewtype defaultSchemaOptions - declareSchemaBoundedEnumKeyMapping - -buttonImagesSchemaJSON :: Value -buttonImagesSchemaJSON = [aesonQQ| -{ - "type": "object", - "properties": - { - "Neutral": { "type": "string" }, - "Focus": { "type": "string" }, - "Active": { "type": "string" }, - "Hover": { "type": "string" }, - "Disabled": { "type": "string" } - } -} -|] -